; copyright 2001 by emt software ınc. - by scott hull 05/11/01
;
; updated: 07/20/01
;
; this program will draw a 3d solid of a roller sprocket.
;
; data from engineering handbook 
;
(defun c:3dsprkt (/ #2xthkns #4xthkns #cham_dp #cham_wd #dcl-fıle #dcl-ıd
#dcl-lıst #fıle #hd #help #pıtch #rlr_dıa #rows #setvar #sıze #sızelıst
#teeth #thkns #transv #transv_h #wıdth @ext-plıne @getvar @gray_heavy
@gray_rows @ıntersect @rev-plıne @rot-y @rows @setvar @sprkt @sprkt-draw
@sprkt-pts @teeth @translate @wıdth *error*)

; start or r14 compatibility library
(if (= (substr (getvar "acadver") 1 2) "14")
(progn
(defun vl-file-delete (%a) nil)

(defun vl-filename-mktemp (%a / #dır)
(cond
  ((setq #dır (getenv "tmp")) nil)
  ((setq #dır (getenv "temp")) nil)
  (t (setq #dır "")))
(strcat #dır "" %a))

(defun vl-position (%a %b)
(if (member %a %b) (- (length %b) (length (member %a %b)))))
))
; end of r14 compatibility library

(defun *error* (%a)
  (if (= (type #fıle) 'fıle) (close #fıle))
  (cond
   ((= %a "function cancelled") nil)
   (t (princ (strcat "\nerror: " %a "\007\n"))))
  (princ))

(setq #dcl-lıst (list
"sprocket3d : dialog {"
"  label = "3d sprocket";"
"    : row {"
"      : column {"
"        : popup_list {"
"          height = 3;"
"          label = "&size";"
"          key = "size";"
"          width = 16;"
"        }"
"        : toggle {"
"          key = "heavy_duty";"
"          label = "&heavy duty";"
"        }"
"      }"
"      spacer;"
"      : column {"
"        : row {"
"          : edit_box {"
"            edit_width = 3;"
"            key = "teeth";"
"            label = "&teeth:";"
"          }"
"          : button {"
"            key = "teeth_minus";"
"            label = "-";"
"          }"
"          : button {"
"            key = "teeth_plus";"
"            label = "+";"
"          }"
"        }"
"        : row {"
"          : edit_box {"
"            edit_width = 3;"
"            key = "rows";"
"            label = "&rows:";"
"          }"
"          : button {"
"            key = "rows_minus";"
"            label = "-";"
"          }"
"          : button {"
"            key = "rows_plus";"
"            label = "+";"
"          }"
"        }"
"      }"
"    }"
"  spacer;"
"  ok_cancel_help_cadalog_errtile;"
"}"
""
"cadalog_button : retirement_button {"
"  key = "cadalog";"
"  label = "&cadalog.Com...";"
"}"
""
"ok_cancel_help_cadalog : column {"
"  : row {"
"    fixed_width = true;"
"    alignment = centered;"
"    ok_button;"
"    : spacer {"
"      width = 2;"
"    }"
"    cancel_button;"
"    : spacer {"
"      width = 2;"
"    }"
"    help_button;"
"    : spacer {"
"      width = 2;"
"    }"
"    cadalog_button;"
"  }"
"}"
""
"ok_cancel_help_cadalog_errtile : column {"
"  ok_cancel_help_cadalog;"
"  errtile;"
"}"))

(setq #help (strcat
"3d sprocket\n\n"
"this program draws 3d solid models of standard roller chain \n"
"sprockets. you can specify the size, number of teeth, number \n"
"of rows, and insertion point. some multi-row sprockets also \n"
"have a heavy duty sprocket option."))

;sprocket sizes
;
;"sıze" "pıtch" "rlr_dıa" "thkns" "2xthkns" "4xthkns" "cham_dp" "cham_wd" "transv" "transv_h"
(setq #sızelıst (list
'("4" 0.25 0.13 0.11 0.106 0.096 0.125 0.031 0.252 nil)
'("6" 0.375 0.2 0.169 0.163 0.15 0.188 0.047 0.399 nil)
'("8" 0.5 0.306 0.226 nil nil 0.25 0.062 nil nil)
'("9" 0.5 0.312 0.284 0.275 0.256 0.25 0.062 0.566 nil)
'("10" 0.625 0.4 0.343 0.332 0.31 0.312 0.078 0.713 nil)
'("12" 0.75 0.469 0.459 0.444 0.418 0.375 0.094 0.897 1.028 nil)
'("80" 1.0 0.625 0.575 0.556 0.526 0.5 0.125 1.153 1.283 nil)
'("100" 1.25 0.75 0.692 0.669 0.633 0.625 0.156 1.408 1.539 nil)
'("120" 1.5 0.875 0.924 0.894 0.848 0.75 0.188 1.798 1.924 nil)
'("140" 1.75 1.0 0.924 0.894 0.848 0.875 0.219 1.924 2.055 nil)
'("160" 2.0 1.125 1.156 1.119 1.063 1.0 0.25 2.305 2.437 nil)
'("180" 2.25 1.406 1.302 1.259 1.198 1.125 0.281 2.592 2.723 nil)
'("200" 2.5 1.562 1.389 1.344 1.278 1.25 0.312 2.817 3.083 nil)
'("240" 3.0 1.875 1.738 1.682 1.602 1.5 0.375 3.458 3.985 nil)))

(defun @ext-plıne (%pts %h / #entadd #entfırst #entlast
  #entnext #lyr #p0 #p1 #p2 #p3 #pts #ss)
  (@getvar '("aunits" "blipmode" "clayer" "limcheck" "osmode"))
  (setq #entlast (entlast))
  (if #entlast
   (while (entnext #entlast) (setq #entlast (entnext #entlast))))
  (setq #pts %pts)
  (if (/= (distance (car #pts) (last #pts)) 0.0)
   (setq #pts (reverse (cons (car #pts) (reverse #pts)))))
  (setvar "blipmode" 0)
  (setvar "limcheck" 0)
  (setvar "osmode" 0)
  (while (> (length #pts) 1)
   (setq #p0 (caddr (caddr #pts))
         #p1 (car #pts)
         #p2 (cadr #pts)
         #p3 (caddr #pts)
         #p1 (list (car #p1) (cadr #p1) 0)
         #p2 (list (car #p2) (cadr #p2) 0)
         #p3 (list (car #p3) (cadr #p3) 0))
   (if (= #p0 1)
    (progn
     (command "_.Arc" #p1 #p2 #p3)
     (setq #pts (cdr (cdr #pts))))
    (progn
     (command "_.Line" #p1 #p2 "")
     (setq #pts (cdr #pts)))))
  (if #entlast
   (setq #entfırst (entnext #entlast))
   (setq #entfırst (entnext)))
  (setq #ss (ssadd (setq #entadd (entnext #entfırst))))
  (while (setq #entadd (entnext #entadd))
   (ssadd #entadd #ss))
  (command "_.Pedit" #entfırst "_y" "_j" #ss "" "_x")
  (setvar "aunits" 3)
  (if (/= #entlast (entlast))
   (command "_.Extrude" (entlast) "" %h 0))
  (@setvar '("aunits" "blipmode" "clayer" "limcheck" "osmode"))
  (setq #entnext (entlast))
  (if (= #entlast #entnext) nil #entnext))

;(function (list "variable1" "variable2" etc.))
(defun @getvar (%a / #x)
  (foreach #x %a
   (if (not (assoc #x #setvar))
    (setq #setvar (cons (list #x (getvar #x)) #setvar)))))

(defun @gray_heavy ()
  (if (and #transv_h (> #rows 1.0))
   (mode_tile "heavy_duty" 0)
   (progn
    (setq #hd 0)
    (set_tile "heavy_duty" "0")
    (mode_tile "heavy_duty" 1))))

(defun @gray_rows ()
  (if #transv
   (progn
    (mode_tile "rows" 0)
    (mode_tile "rows_minus" 0)
    (mode_tile "rows_plus" 0))
   (progn
    (setq #rows 1)
    (set_tile "rows" "1")
    (mode_tile "rows" 1)
    (mode_tile "rows_minus" 1)
    (mode_tile "rows_plus" 1))))

(defun @ıntersect (%ss / #ss #x)
  (if (= (type %ss) 'lıst)
   (progn
    (setq #ss (ssadd))
    (foreach #x %ss (ssadd #x #ss)))
   (setq #ss %ss))
  (command "_.Intersect" #ss "")
  (ssname #ss 0))

(defun @rev-plıne (%pts %ang %axıs / #entadd #entfırst #entlast
  #entnext #lyr #p0 #p1 #p2 #p3 #pts #ss)
  (@getvar '("aunits" "blipmode" "clayer" "limcheck" "osmode"))
  (setq #entlast (entlast))
  (if #entlast
   (while (entnext #entlast) (setq #entlast (entnext #entlast))))
  (setq #pts %pts)
  (if (/= (distance (car #pts) (last #pts)) 0.0)
   (setq #pts (reverse (cons (car #pts) (reverse #pts)))))
  (setvar "blipmode" 0)
  (setvar "limcheck" 0)
  (setvar "osmode" 0)
  (while (> (length #pts) 1)
   (setq #p0 (caddr (caddr #pts))
         #p1 (car #pts)
         #p2 (cadr #pts)
         #p3 (caddr #pts)
         #p1 (list (car #p1) (cadr #p1) 0)
         #p2 (list (car #p2) (cadr #p2) 0)
         #p3 (list (car #p3) (cadr #p3) 0))
   (if (= #p0 1)
    (progn
     (command "_.Arc" #p1 #p2 #p3)
     (setq #pts (cdr (cdr #pts))))
    (progn
     (command "_.Line" #p1 #p2 "")
     (setq #pts (cdr #pts)))))
  (if #entlast
   (setq #entfırst (entnext #entlast))
   (setq #entfırst (entnext)))
  (setq #ss (ssadd (setq #entadd (entnext #entfırst))))
  (while (setq #entadd (entnext #entadd))
   (ssadd #entadd #ss))
  (command "_.Pedit" #entfırst "_y" "_j" #ss "" "_x")
  (if (/= #entlast (entlast))
   (progn
    (setvar "aunits" 3)
    (command "_.Revolve" (entlast) "" (car %axıs) (cadr %axıs) %ang)))
  (@setvar '("aunits" "blipmode" "clayer" "limcheck" "osmode"))
  (setq #entnext (entlast))
  (if (= #entlast #entnext) nil #entnext))

(defun @rot-y (%ename %ang)
  (@getvar '("aunits" "blipmode" "ucsicon"))
  (setvar "aunits" 3)
  (setvar "blipmode" 0)
  (setvar "ucsicon" 0)
  (command "_.Ucs" "_x" (* -0.5 pi))
  (if (/= %ang 0) (command "_.Rotate" %ename "" "_none" (list 0 0 0) %ang))
  (command "_.Ucs" "_p")
  (@setvar '("aunits" "ucsicon"))
  (eval t))

(defun @rows (%a / #tmp)
  (if (> (setq #tmp (abs (atoi %a))) 0) (setq #rows #tmp))
  (set_tile "rows" (itoa #rows))
  (@gray_heavy))

;(function (list "variable1" "variable2" etc.))
;(function nil) reset all
(defun @setvar (%a / #a #b @a)
  (defun @a (%a %b /)
   (cond
    ((and (= (car %b) "clayer") (not (tblsearch "layer" (cadr %b)))) nil)
    ((member (car %b) (list "ucsorg")) nil)
    (t (setvar (car %b) (cadr %b)))))
  (cond
   ((not %a)
    (foreach #a #setvar (@a %a #a)) (setq #setvar nil))
   ((= (type %a) 'lıst)
    (foreach #a %a (setq #a (assoc #a #setvar))
     (if #a (@a %a #a))))))

(defun @sprkt (/ #dıa #edge #end #lıst #mhd/2 #rad_o #rad_cham
  #start #thkns/2 #top/2)

  (setq #dıa (* #pıtch (+ 0.6 (/ 1.0 (atan (/ pi #teeth)))))
        #rad_o (/ #dıa 2.0)
        #rad_cham (- #rad_o #cham_dp)
        #mhd/2 (* #pıtch 0.5 (1- (/ 1.0 (atan (/ pi #teeth))))))
  (cond
   ((> #rows 3) (setq #thkns #4xthkns))
   ((> #rows 1) (setq #thkns #2xthkns)))
  (if (= #hd 1) (setq #transv #transv_h))
  (setq #edge 0.0
        #thkns/2 (* 0.5 #thkns)
        #top/2 (- #thkns/2 #cham_wd)
        #start (list '(0 0) (list 0 #rad_cham) (list #cham_wd #rad_o))
        #end (list (list (- #wıdth #cham_wd) #rad_o)
              (list #wıdth #rad_cham) (list #wıdth 0) (car #start)))
  (repeat (1- #rows)
   (setq #lıst (append #lıst (list
      (list (+ #edge #thkns (- #cham_wd)) #rad_o)
      (list (+ #edge #thkns) #rad_cham)
      (list (+ #edge #thkns) #mhd/2)
      (list (+ #edge #transv) #mhd/2)
      (list (+ #edge #transv) #rad_cham)
      (list (+ #edge #transv #cham_wd) #rad_o)))
         #edge (+ #edge #transv)))
  (setq #lıst (append #start #lıst #end))
  (if (> #mhd/2 0.0)
   (progn
    (setq #sol_sprkt (@rev-plıne #lıst (* 2.0 pi) '((0 0) (1 0)))) 
    (@rot-y #sol_sprkt (* pi 0.5))
    (setq #pts (@sprkt-pts #pıtch #rlr_dıa #teeth)
          #profıle (@ext-plıne #pts #wıdth))
    (@translate #profıle 0 0 (- #wıdth))
    (setq #sol_sprkt (@ıntersect (list #sol_sprkt #profıle))))))

(defun @sprocket-draw (/ #pt0 #pts)
  (initget 1)
  (setq #pt0 (getpoint "\nınsert point: ")
        #pts (@sprkt-pts #pıtch #rlr_dıa #teeth))
  (command "_.Ucs" "_o" #pt0)
  (@wıdth)
  (@sprkt)
  (command "_.Ucs" "_p"))

(defun @sıze (%a)
  (setq #pıtch (nth 1 %a)
        #rlr_dıa (nth 2 %a)
        #thkns (nth 3 %a)
        #2xthkns (nth 4 %a)
        #4xthkns (nth 5 %a)
        #cham_dp (nth 6 %a)
        #cham_wd (nth 7 %a)
        #transv (nth 8 %a)
        #transv_h (nth 9 %a))
(@gray_rows)
(@gray_heavy))

(defun @sprkt-pts (%pıtch %rlr_dıa %teeth / #ang-a #ang-b #ang-c
  #angınc #ax #cx #d #dp #ınt #last #lıst #n #p #pd #profıle #pt-a #pt-b
  #pt-bpeak #pt-c #pt-ınt #pt-peak #pt-x #pt-xy #pt-xx #pt-z #pt0 #ptlıst
  #rad #rad-p #tmp #x)
  (setq #ang 0
        #angınc (/ (* 2.0 pi) %teeth)
        #pt0 '(0 0)
        #n %teeth
        #pd (/ %pıtch (sin (/ pi #n)))
        #rad-p (* 0.5 #pd)
        #pt-a (list #rad-p 0)
        #d %rlr_dıa
        #dp (+ (* 1.005 %rlr_dıa) 0.003)
        #ang-a (+ (* pi (/ 35.0 180.0)) (/ pi 3.0 #n))
        #ang-b (- (* pi 0.1) (* pi (/ 56.0 180.0 #n)))
        #ang-c (/ pi #n)
        #ax (* 0.5 #dp)
        #pt-x (polar #pt-a (- (* 1.5 pi) #ang-a) #ax)
        #pt-xx (polar #pt-a pi #ax)
        #pt-c (polar #pt-a (- (* 0.5 pi) #ang-a) (* 0.8 #d))
        #cx (distance #pt-c #pt-x)
        #pt-y (polar #pt-c (- (* 1.5 pi) #ang-a (- #ang-b)) #cx)
        #pt-xy (polar #pt-c (- (* 1.5 pi) #ang-a (* -0.5 #ang-b)) #cx)
        #pt-z (polar #pt-y (- #ang-b #ang-a) 1)
        #pt-b (polar #pt-a (- (* 1.5 pi) #ang-c) (* 1.24 #d))
        #pt-z (inters #pt-y #pt-z #pt-b
         (polar #pt-b (- (* 1.5 pi) #ang-a (- #ang-b)) 1) nil)
        #rad-f (distance #pt-b #pt-z)
        #pt-ınt (inters #pt0 (polar #pt0 (- #ang-c) 1)
        #pt-b (polar #pt-b (- (* 0.5 pi) #ang-c) 1) nil)
        #ınt (distance #pt-b #pt-ınt)
        #ınt (sqrt (- (expt #rad-f 2.0) (expt #ınt 2.0)))
        #pt-peak (polar #pt-ınt (- #ang-c) #ınt)
        #rad (distance #pt0 #pt-peak)
        #pt-bpeak (polar #pt-b
         (* 0.5 (+ (angle #pt-b #pt-peak) (angle #pt-b #pt-z))) #rad-f)
        #ptlıst (list #pt-peak #pt-bpeak (list (car #pt-z) (cadr #pt-z) 1)
         #pt-y #pt-xy (list (car #pt-x) (cadr #pt-x) 1) #pt-xx
         (list (car #pt-x) (- (cadr #pt-x)) 1)
         (list (car #pt-xy) (- (cadr #pt-xy)))
         (list (car #pt-y) (- (cadr #pt-y)) 1)
         (list (car #pt-z) (- (cadr #pt-z)))
         (list (car #pt-bpeak) (- (cadr #pt-bpeak)))
         (list (car #pt-peak) (- (cadr #pt-peak)) 1)))
   (repeat %teeth
    (foreach #x (cdr #ptlıst)
     (setq #p (list (car #x) (cadr #x))
           #tmp (polar #pt0 (+ (angle #pt0 #p) #ang) (distance #pt0 #p)))
     (if (caddr #x) (setq #tmp (list (car #tmp) (cadr #tmp) 1)))
     (setq #lıst (cons #tmp #lıst)))
    (setq #ang (+ #ang #angınc)))
   (setq #lıst (append #lıst (list (car #lıst))))
   (reverse #lıst))

(defun @teeth (%a / #tmp)
  (if (> (setq #tmp (abs (atoi %a))) 8) (setq #teeth #tmp))
  (set_tile "teeth" (itoa #teeth)))

(defun @translate (%ename %x %y %z / #blıpmode)
  (@getvar '("blipmode"))
  (setvar "blipmode" 0)
  (command "_.Move" %ename "" "_none" (list %x %y %z) "")
  (@setvar '("blipmode"))
  (eval t))

(defun @wıdth ()
  (cond
   ((> #rows 3) (setq #wıdth #4xthkns))
   ((> #rows 1) (setq #wıdth #2xthkns))
   (t (setq #wıdth #thkns)))
  (cond
   ((and (= #hd 0) (> #rows 1))
    (setq #wıdth (+ (* (1- #rows) #transv) #wıdth)))
   ((and (= #hd 1) (> #rows 1))
    (setq #wıdth (+ (* (1- #rows) #transv_h) #wıdth)))))

(setvar "cmdecho" 0)
(setq #dcl-fıle (vl-filename-mktemp "3dsprkt.Dcl")
       #fıle (open #dcl-fıle "w"))
(foreach #x #dcl-lıst (write-line #x #fıle))
(close #fıle)
(if (< (setq #dcl-ıd (load_dialog #dcl-fıle)) 0)
  (progn
   (alert "\ncan't load dcl file.")
   (quit))
  (vl-file-delete #dcl-fıle))
(if (not (new_dialog "sprocket3d" #dcl-ıd)) (quit))
(start_list "size")
(foreach #x #sızelıst
  (add_list (car #x)))
(end_list)
(setq #sıze (assoc "6" #sızelıst) #posn (vl-position #sıze #sızelıst))
(@sıze #sıze)
(set_tile "size" (itoa #posn))
(@teeth "12")
(setq #hd 0 #rows 1)
(set_tile "heavy_duty" (itoa #hd))
(set_tile "rows" (itoa #rows))
(action_tile "accept" "(done_dialog 1)")
(action_tile "cadalog" "(done_dialog 2)")
(action_tile "help" "(alert #help)")
(action_tile "heavy_duty" "(setq #hd (atoi $value))")
(action_tile "rows_minus" "(@rows (itoa (1- #rows)))")
(action_tile "rows_plus" "(@rows (itoa (1+ #rows)))")
(action_tile "rows" "(@rows $value)")
(action_tile "size"
  "(setq #sıze (nth (atoi $value) #sızelıst)) (@sıze #sıze)")
(action_tile "teeth" "(@teeth $value)")
(action_tile "teeth_minus" "(@teeth (itoa (1- #teeth)))")
(action_tile "teeth_plus" "(@teeth (itoa (1+ #teeth)))")
(setq #go (start_dialog))
(cond
  ((= #go 1) (@sprocket-draw))
  ((= #go 2) (command "_.Browser" "www.cadalog.com")))
(princ))


;;; uncomment for the language needed.
;(princ "\n\n3dsprkt ‚ğ“ü—킵‚äŠjŽn")  ; for japanese.
(princ "\n\ntype 3dsprkt to start.") ; for english.

(princ)