home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p055 / 2.ddi / SUPPORT.LIF / 057.KA.LSP < prev    next >
Encoding:
Text File  |  1990-08-31  |  18.7 KB  |  772 lines
  1. ;
  2. ;    ka.lsp - kenetic animation program for BIG D
  3. ;
  4. ;    globals        pathlist - the list of animation paths
  5. ;                startframe - the starting frame number
  6. ;                endframe - the ending frame number
  7. ;                fps - the number of frames per second
  8. ;
  9.  
  10. ;
  11. ;    setpath - define an animation path for a block
  12. ;
  13.  
  14. (princ "\nsetpath")
  15. (defun c:setpath ( / oldpdmode oldcmdecho oldaunits blk vl pl poly oldpath)
  16.  
  17.     ; save current settings
  18.     (setq oldpdmode (getvar "PDMODE"))
  19.     (setq oldcmdecho (getvar "CMDECHO"))
  20.     (setq oldaunits (getvar "AUNITS"))
  21.  
  22.     ; set settings
  23.     (setvar "PDMODE" 3)
  24.     (setvar "CMDECHO" 0)
  25.     (setvar "AUNITS" 0)
  26.  
  27.     ; initialize path list
  28.     (command "HANDLES" "ON")
  29.     (readbda)
  30.  
  31.     ; get polyline path
  32.     (setq poly (getpoly "\nChoose polyline path: "))
  33.     (prompt (strcat "\nPolyline name: " poly "\n"))
  34.  
  35.     ; see if path already exists
  36.     (setq oldpath (findpath poly))
  37.  
  38.     ; get block to animate
  39.     (setq blk (getblk oldpath))
  40.  
  41.     ; get vertex list info
  42.     (if (null oldpath)
  43.         (setq vl (getvert poly nil))
  44.         (setq vl (getvert poly (cdr (assoc 'vertlist oldpath)))))
  45.  
  46.     ; build path info list
  47.     (setq path (list (cons 'polyhand poly) (cons 'blkname blk) 
  48.         (cons 'layer (cdr (assoc 8 (entget (handent poly))))) 
  49.         (cons 'vertlist vl)))
  50.  
  51.     ; add path to path list
  52.     (if (null oldpath)
  53.         (setq pathlist (append pathlist (list path)))
  54.         (setq pathlist (subst path oldpath pathlist)))
  55.  
  56.     ; ask to save new path list
  57.     (initget 0 "Y N")
  58.     (setq s (getkword "Save the current animation? <Y> "))
  59.     (if (or (= s "Y") (null s))
  60.         (progn
  61.             (writebda)
  62.             (writebat)
  63.         )
  64.     )
  65.  
  66.     ; restore settings
  67.     (setvar "PDMODE" oldpdmode)
  68.     (setvar "CMDECHO" oldcmdecho)
  69.     (setvar "AUNITS" oldaunits)
  70.  
  71.     (princ)
  72. )
  73.  
  74. ;
  75. ;    delpath - delete an animation path from the path list
  76. ;
  77.  
  78. (princ "\ndelpath")
  79. (defun c:delpath ( / oldpdmode poly path oldpathlist s)
  80.  
  81.     ; save current settings
  82.     (setq oldpdmode (getvar "PDMODE"))
  83.     (setq oldcmdecho (getvar "CMDECHO"))
  84.  
  85.     ; set settings
  86.     (setvar "PDMODE" 3)
  87.     (setvar "CMDECHO" 0)
  88.  
  89.     ; initialize path list
  90.     (readbda)
  91.  
  92.     ; get polyline path
  93.     (setq poly (getpoly "\nChoose polyline path to delete: "))
  94.     (prompt (strcat "\nPolyline name: " poly "\n"))
  95.  
  96.     ; see if path already exists
  97.     (setq oldpath (findpath poly))
  98.  
  99.     ; rebuild path list
  100.     (setq oldpathlist pathlist  
  101.         pathlist nil)
  102.     (foreach path oldpathlist
  103.         (if (/= poly (cdr (assoc 'polyhand path)))
  104.             (setq pathlist (append pathlist (list path)))
  105.         )
  106.     )
  107.  
  108.     ; ask to save new path list
  109.     (initget 0 "Y N")
  110.     (setq s (getkword "Save the current animation? <Y> "))
  111.     (if (or (= s "Y") (null s))
  112.         (progn
  113.             (writebda)
  114.             (writebat)
  115.         )
  116.     )
  117.  
  118.     ; restore settings
  119.     (setvar "PDMODE" oldpdmode)
  120.     (setvar "CMDECHO" oldcmdecho)
  121.  
  122.     (princ)
  123. )
  124.  
  125. ;
  126. ;    findpath - search for a polyline path in the path list
  127. ;
  128.  
  129. (princ "\nfindpath")
  130. (defun findpath (poly / oldpath path)
  131.     (setq oldpath nil)
  132.     (foreach path pathlist
  133.         (if (= poly (cdr (assoc 'polyhand path)))
  134.             (setq oldpath path))
  135.     )
  136.     oldpath
  137. )
  138.  
  139. ;
  140. ;    getvert - get vertex info from user
  141. ;
  142.  
  143. (princ "\ngetvert")
  144. (defun getvert (poly oldvl / ename vert vl time loc bulge elev rot value)
  145.     (setq ename (handent poly) vl nil n 0)
  146.     (while (and (setq ename (entnext ename)) 
  147.             (= (cdr (assoc 0 (entget ename))) "VERTEX"))
  148.  
  149.         ; initialize vertex data
  150.         (setq loc (cdr (assoc 10 (entget ename)))
  151.             bulge (cdr (assoc 42 (entget ename))))
  152.         (if (null oldvl)
  153.             (setq time 0.0
  154.                 elev 0.0
  155.                 rot (list 0.0 0.0 0.0))
  156.             (setq vert (nth n oldvl)
  157.                 time (/ (float (cdr (assoc 'frame vert))) 30.0)
  158.                 elev (caddr (cdr (assoc 'location vert)))
  159.                 rot (cdr (assoc 'rotation vert))
  160.                 n (1+ n))
  161.         )
  162.  
  163.         (command "POINT" loc)
  164.  
  165.         ; get time
  166.         (setq value (getreal (strcat "Time <" (rtos time) ">: ")))
  167.         (if (not (null value))
  168.             (setq time value))
  169.  
  170.         ; get elevation
  171.         (setq value (getreal (strcat "Elevation <" (rtos elev) ">: ")))
  172.         (if (not (null value))
  173.             (setq elev value))
  174.  
  175.         ; get z rotation angle
  176.         (setq value (getreal (strcat "Rotation <" (rtos (caddr rot)) ">: ")))
  177.         (if (not (null value))
  178.             (setq rot (list (car rot) (cadr rot) value)))
  179.  
  180.         ; get y rotation angle (pitch)
  181.         (setq value (getreal (strcat "Pitch <" (rtos (cadr rot)) ">: ")))
  182.         (if (not (null value))
  183.             (setq rot (list (car rot) value (caddr rot))))
  184.  
  185.         ; get x rotation angle (roll)
  186.         (setq value (getreal (strcat "Roll <" (rtos (car rot)) ">: ")))
  187.         (if (not (null value))
  188.             (setq rot (list value (cadr rot) (caddr rot))))
  189.  
  190.         (command "ERASE" "L" "")
  191.         (setq vert (list (cons 'frame (* (fix time) 30)) 
  192.             (cons 'location (list (car loc) (cadr loc) elev))
  193.             (cons 'rotation rot) (cons 'bulge bulge)))
  194.         (setq vl (append vl (list vert)))
  195.     )
  196.     vl
  197. )
  198.  
  199. ;
  200. ;    getblk - get a block name from the user
  201. ;
  202.  
  203. (princ "\ngetblk")
  204. (defun getblk (oldpath / blk oldblk)
  205.     (setq blk "")
  206.     (if (null oldpath)
  207.         (setq oldblk "")
  208.         (setq oldblk (cdr (assoc 'blkname oldpath))))
  209.     (while (= blk "")
  210.         (setq blk (getstring (strcat "Block name <" oldblk ">: ")))
  211.         (if (or (null blk) (= blk ""))
  212.             (setq blk oldblk)
  213.             (if (null (tblsearch "block" blk))
  214.                 (setq blk ""))
  215.         )
  216.     )
  217.     (strcase blk)
  218. )
  219.  
  220. ;
  221. ;    settime - set global time parameters
  222. ;
  223.  
  224. (princ "\nsettime")
  225. (defun c:settime ( / newfps newval s t)
  226.     (if (or (null fps) (null startframe) (null endframe))
  227.         (readbda))
  228.  
  229.     ; get start frame
  230.     (setq t (/ (float startframe) 30.0))
  231.     (setq t (getreal (strcat "\nStart time <" (rtos t 2 2) ">: ")))
  232.     (if (boundp 't)
  233.         (setq startframe (* (fix t) 30)))
  234.  
  235.     ; get end frame
  236.     (setq t (/ (float endframe) 30.0))
  237.     (setq t (getreal (strcat "\nEnd time <" (rtos t 2 2) ">: ")))
  238.     (if (boundp 't)
  239.         (setq endframe (* (fix t) 30)))
  240.  
  241.     ; get frames per second
  242.     (setq newfps (getint (strcat "\nFrames per second <" (itoa fps)
  243.         ">: ")))
  244.     (if (boundp 'newfps)
  245.         (setq fps newfps))
  246.  
  247.     ; ask to save new path list
  248.     (initget 0 "Y N")
  249.     (setq s (getkword "Save the current animation? <Y> "))
  250.     (if (or (= s "Y") (null s))
  251.         (progn
  252.             (writebda)
  253.             (writebat)
  254.         )
  255.     )
  256.     (princ)
  257. )
  258.  
  259. ;
  260. ;    getpoly - get a polyline from the user
  261. ;
  262. ;    returns - entity handle of selected polyline
  263. ;
  264.  
  265. (princ "\ngetpoly")
  266. (defun getpoly (prompt / flag e)
  267.     (setq flag t)
  268.     (while flag
  269.         (setq e (entsel prompt))
  270.         (if (and e (= (cdr (assoc 0 (entget (car e)))) "POLYLINE"))
  271.             (setq flag nil)
  272.             (princ "\nMust be a polyline!\n")
  273.         )
  274.     )
  275.     (cdr (assoc 5 (entget (car e))))
  276. )
  277.  
  278. ;
  279. ;    pv - preview the animation
  280. ;
  281.  
  282. (princ "\npv")
  283. (defun c:pv ( / oldaunits oldpdmode oldcmdecho frame path f sldname)
  284.  
  285.     ; save initial state
  286.     (setq oldpdmode (getvar "PDMODE"))
  287.     (setq oldcmdecho (getvar "CMDECHO"))
  288.     (setq oldaunits (getvar "AUNITS"))
  289.  
  290.     ; set states
  291.     (setvar "PDMODE" 3)
  292.     (setvar "CMDECHO" 0)
  293.     (setvar "AUNITS" 0)
  294.  
  295.     ; initialize path list
  296.     (readbda)
  297.  
  298.     ; initialize
  299.     (setq frame startframe
  300.         nframes (1+ (- endframe startframe)))
  301.  
  302.     ; open script file
  303.     (setq f (open (strcat (getvar "DWGNAME") ".SCR") "w"))
  304.  
  305.     ; for each frame
  306.     (while (<= frame endframe)
  307.         ; locate each block
  308.         (foreach path pathlist
  309.             (setq ins (findins path frame))        ; get insertion info
  310.             (command "UCS" "O" (car ins))
  311.             (command "UCS" "Z" (rtos (caddr (cadr ins))))
  312.             (command "UCS" "Y" (rtos (cadr (cadr ins))))
  313.             (command "UCS" "X" (rtos (car (cadr ins))))
  314.             (command "INSERT" (cdr (assoc 'blkname path)) "0,0" "" "" "")
  315.             (command "UCS" "W")
  316.         )
  317.  
  318.         ; write frame to slide file
  319.         (setq sldname (strcat (substr (getvar "DWGNAME") 1 4) 
  320.             (int2str frame)))
  321.         (command "MSLIDE" sldname)
  322.  
  323.         ; write command to script file
  324.         (write-line (strcat "VSLIDE " sldname) f)
  325.  
  326.         ; delete inserted blocks
  327.         (foreach path pathlist
  328.             (command "ERASE" "L" "")
  329.         )
  330.  
  331.         ; update time and frame counter
  332.         (setq frame (+ frame (/ 30 fps)))
  333.     )
  334.  
  335.     ; close script file
  336.     (close f)
  337.  
  338.     ; restore previous state
  339.     (setvar "AUNITS" oldaunits)
  340.     (setvar "PDMODE" oldpdmode)
  341.     (setvar "CMDECHO" oldcmdecho)
  342.  
  343.     ; run the animation
  344.     (command "SCRIPT")
  345.  
  346.     (princ)
  347. )
  348.                
  349. ;
  350. ;    findcen - find arc center of a bulge
  351. ;
  352.  
  353. (princ "\nfindcen")
  354. (defun findcen (pt0 pt1 bulge / alpha l r d m n h k)
  355.     (setq alpha (* 4.0 (atan (abs bulge)))
  356.         l (distance pt0 pt1)
  357.         r (/ l (* 2.0 (sin (/ alpha 2.0))))
  358.         d (sqrt (- (* r r) (* (/ l 2.0) (/ l 2.0))))
  359.         m (* 0.5 (+ (car pt0) (car pt1)))
  360.         n (* 0.5 (+ (cadr pt0) (cadr pt1))))
  361.  
  362.     (cond
  363.         ((>= bulge 1.0)
  364.             (setq h (+ m (/ (* (- (cadr pt1) (cadr pt0)) d) l))
  365.                   k (- n (/ (* (- (car pt1) (car pt0)) d) l))))
  366.         ((>= bulge 0.0)
  367.             (setq h (- m (/ (* (- (cadr pt1) (cadr pt0)) d) l))
  368.                   k (+ n (/ (* (- (car pt1) (car pt0)) d) l))))
  369.         ((>= bulge -1.0)
  370.             (setq h (+ m (/ (* (- (cadr pt1) (cadr pt0)) d) l))
  371.                   k (- n (/ (* (- (car pt1) (car pt0)) d) l))))
  372.         (t
  373.             (setq h (- m (/ (* (- (cadr pt1) (cadr pt0)) d) l))
  374.                   k (+ n (/ (* (- (car pt1) (car pt0)) d) l))))
  375.     )
  376.     (list h k (caddr pt0))
  377. )
  378.  
  379. ;
  380. ;    findins - find insertion information for a path at a time
  381. ;
  382.  
  383. (princ "\nfindins")
  384. (defun findins (path frame / vl n vert ins f0 loc0 rot0 v0 bulge0 
  385.     f1 loc1 rot1 v1 bulge1 a x y z rx ry rz d ang0 ang1 dang)
  386.  
  387.     ; set up first vertex info
  388.     (setq vl (cdr (assoc 'vertlist path))
  389.         vert (nth 0 vl)
  390.         f1 (cdr (assoc 'frame vert))
  391.         loc1 (cdr (assoc 'location vert))
  392.         rot1 (cdr (assoc 'rotation vert))
  393.         bulge1 (cdr (assoc 'bulge vert))
  394.         v1 0.0
  395.         n 1
  396.         ins nil
  397.         a 0.0)
  398.  
  399.     ; check to see if time is before path starts
  400.     (if (<= frame f1)
  401.         (setq ins (list loc1 rot1))
  402.     ; else
  403.         (progn
  404.             ; step through each vertex
  405.             (while (setq vert (nth n vl))
  406.                 (setq f0 f1
  407.                     loc0 loc1
  408.                     rot0 rot1
  409.                     v0 v1
  410.                     bulge0 bulge1
  411.                     f1 (cdr (assoc 'frame vert))
  412.                     loc1 (cdr (assoc 'location vert))
  413.                     rot1 (cdr (assoc 'rotation vert))
  414.                     bulge1 (cdr (assoc 'bulge vert)))
  415.  
  416.                 ; find length of segment
  417.                 (if (< (abs bulge0) 0.0001)
  418.                     (setq l (distance loc0 loc1))        ; is a line
  419.                 ;else
  420.                     (setq l (arclen loc0 loc1 bulge0)))    ; is an arc
  421.  
  422.                 ; find acceleration and ending velocity
  423. ;                (setq a (* 2.0 (/ (- l (* v0 t1)) (* t1 t1)))
  424. ;                    v1 (+ (* 2.0 a l) v0))
  425.                 (setq a 0.0
  426.                     v1 (/ l (- f1 f0))
  427.                     v0 v1)
  428.  
  429.                 ; see if frame is within the current segment
  430.                 (if (<= frame f1)
  431.                     (progn
  432.                         (setq d (/ (+ (* v0 (float (- frame f0))) 
  433.                                 (* 0.5 a (float (- frame f0)) 
  434.                                 (float (- frame f0)))) l)
  435.                             z (+ (caddr loc0) (* d (- (caddr loc1) 
  436.                                 (caddr loc0)))))
  437. ;(textscr)
  438. ;(prin "findins: d = " d)
  439.  
  440.                         (if (< (abs bulge0) 0.0001)            ; if line
  441.                             (setq x (+ (car loc0) (* d (- (car loc1) 
  442.                                     (car loc0))))
  443.                                 y (+ (cadr loc0) (* d (- (cadr loc1) 
  444.                                     (cadr loc0)))))
  445.                         ;else is an arc
  446.                             (progn
  447.                                 (setq center (findcen loc0 loc1 bulge0)
  448.                                     radius (distance loc0 center)
  449.                                     ang0 (angle center loc0)
  450.                                     ang1 (angle center loc1))
  451. ;(prin "  ang0 = " ang0)
  452. ;(prin "  ang1 = " ang1)
  453. ;(prin "  bulge0 = " bulge0)
  454.                                 (if (< bulge0 0.0)        ; if clockwise arc
  455.                                     (progn
  456.                                         (setq dang (- ang0 ang1))
  457.                                         (if (< dang 0.0)
  458.                                             (setq dang (+ dang (* 2.0 pi))))
  459.                                         (setq ang (- ang0 (* d dang)))
  460.                                     )
  461.                                 ;else this is a counterclockwise arc
  462.                                     (progn
  463.                                         (setq dang (- ang1 ang0))
  464.                                         (if (< dang 0.0)
  465.                                             (setq dang (+ dang (* 2.0 pi))))
  466.                                         (setq ang (+ ang0 (* d dang)))
  467.                                     )
  468.                                 )
  469.                                 (setq x (+ (car center) (* radius (cos ang)))
  470.                                     y (+ (cadr center) (* radius (sin ang))))
  471. ;(prin "  dang = " dang)
  472. ;(prin "  ang = " ang)
  473. ;(prin "  x = " x)
  474. ;(prin "  y = " y)
  475. ;(getstring "Press Enter to continue...")
  476.                             )
  477.                         )
  478.  
  479.                     (setq rx (+ (car rot0) (* d (- (car rot1) (car rot0))))
  480.                         ry (+ (cadr rot0) (* d (- (cadr rot1) (cadr rot0))))
  481.                         rz (+ (caddr rot0) (* d (- (caddr rot1) (caddr rot0))))
  482.                         ins (list (list x y z) (list rx ry rz))
  483.                         n 5000)
  484.                     )
  485.                 ; else
  486.                     (setq n (1+ n))
  487.                 )
  488.             )
  489.         )
  490.     )
  491.  
  492.     ; see if ins has been found yet
  493.     (if (null ins)
  494.         (setq ins (list loc1 rot1)))
  495.     ins
  496. )
  497.  
  498. ;
  499. ;    arclen - find length of an arc segment
  500. ;
  501.  
  502. (princ "\narclen")
  503. (defun arclen (end0 end1 bulge / center radius ang0 ang1 l)
  504.     (setq center (findcen end0 end1 bulge)
  505.         radius (distance end0 center)
  506.         ang0 (angle center end0)
  507.         ang1 (angle center end1))
  508.     (if (<= bulge 0.0)            ; if clockwise
  509.         (if (>= ang0 ang1)
  510.             (setq l (* radius (- ang0 ang1)))
  511.         ;else
  512.             (setq l (* radius (+ ang0 (- (* 2.0 pi) ang1))))
  513.         )
  514.     ;else if counterclockwise
  515.         (if (>= ang0 ang1)
  516.             (setq l (* radius (+ ang1 (- (* 2.0 pi) ang0))))
  517.         ;else
  518.             (setq l (* radius (- ang1 ang0)))
  519.         )
  520.     )
  521.     l
  522. )
  523.  
  524. ;
  525. ;    int2str - convert integer number into four digit string
  526. ;
  527.  
  528. (princ "\nint2str")
  529. (defun int2str(i / s)
  530.     (cond
  531.         ((< i 10)
  532.             (setq s (strcat "000" (itoa i))))
  533.         ((< i 100)
  534.             (setq s (strcat "00" (itoa i))))
  535.         ((< i 1000)
  536.             (setq s (strcat "0" (itoa i))))
  537.         (t
  538.             (setq s (itoa i)))
  539.     )
  540.     s
  541. )
  542.  
  543. ;
  544. ;    readbda - read bda file if it exists and initialize path list
  545. ;
  546.  
  547. (princ "\nreadbda")
  548. (defun readbda ( / f s blk poly layr vl path vert frame loc rot bulge)
  549.     (if (null fps)
  550.         (setq fps 10))
  551.     (if (null startframe)
  552.         (setq startframe 0))
  553.     (if (null endframe)
  554.         (setq endframe 0))
  555.     (if (and (null pathlist) 
  556.             (setq f (open (strcat (getvar "DWGNAME") ".BDA") "r")))
  557.         (progn
  558.             (setq fps 10)
  559.             (while (setq s (read-line f))
  560.                 (cond
  561.                     ((= s "FPS")
  562.                         (setq fps (atoi (read-line f))))
  563.                     ((= s "STARTFRAME")
  564.                         (setq startframe (atoi (read-line f))))
  565.                     ((= s "ENDFRAME")
  566.                         (setq endframe (atoi (read-line f))))
  567.                     ((= s "PATH")
  568.                         (setq blk "" poly "" vl nil))
  569.                     ((= s "ENDPATH")
  570.                         (if (handent poly)
  571.                             (progn
  572.                                 (setq path (list (cons 'polyhand poly) 
  573.                                     (cons 'blkname blk) (cons 'layer layr)
  574.                                     (cons 'vertlist vl)))
  575.                                 (setq pathlist (append pathlist (list path)))
  576.                             )
  577.                         ))
  578.                     ((= s "VERTEX")
  579.                         (setq vert nil 
  580.                             frame 0 
  581.                             loc (list 0.0 0.0 0.0) 
  582.                             rot (list 0.0 0.0 0.0) 
  583.                             bulge 0.0))
  584.                     ((= s "ENDVERT")
  585.                         (setq vert (list (cons 'frame frame) 
  586.                             (cons 'location loc)
  587.                             (cons 'rotation rot) 
  588.                             (cons 'bulge bulge)))
  589.                         (setq vl (append vl (list vert))))
  590.                     ((= s "BLKNAME")
  591.                         (setq blk (read-line f)))
  592.                     ((= s "POLYHAND")
  593.                         (setq poly (read-line f)))
  594.                     ((= s "LAYER")
  595.                         (setq layr (read-line f)))
  596.                     ((= s "FRAME")
  597.                         (setq frame (atoi (read-line f))))
  598.                     ((= s "LOCATION")
  599.                         (setq loc (list
  600.                             (atof (read-line f))
  601.                             (atof (read-line f))
  602.                             (atof (read-line f)))))
  603.                     ((= s "ROTATION")
  604.                         (setq rot (list
  605.                             (atof (read-line f))
  606.                             (atof (read-line f))
  607.                             (atof (read-line f)))))
  608.                     ((= s "BULGE")
  609.                         (setq bulge (atof (read-line f))))
  610.                 )
  611.             )
  612.             (close f)
  613.         )
  614.     )
  615. )
  616.  
  617. ;
  618. ;    writebda - write animation info to bda file
  619. ;
  620.  
  621. (princ "\nwritebda")
  622. (defun writebda ( / f path vert pt)
  623.     (if (setq f (open (strcat (getvar "DWGNAME") ".BDA") "w"))
  624.         (progn
  625.             ; write start frame
  626.             (if (null startframe)
  627.                 (setq startframe 0))
  628.             (write-line (strcat "STARTFRAME\n" (itoa startframe)) f)
  629.  
  630.             ; write end frame
  631.             (if (null endframe)
  632.                 (setq endframe startframe))
  633.             (write-line (strcat "ENDFRAME\n" (itoa endframe)) f)
  634.  
  635.             ; write frames per second
  636.             (if (null fps)
  637.                 (setq fps 10))
  638.             (write-line (strcat "FPS\n" (itoa fps)) f)
  639.  
  640.             ; write paths
  641.             (foreach path pathlist
  642.                 (write-line "PATH" f)
  643.                 (write-line (strcat "BLKNAME\n" (cdr (assoc 'blkname path))) f)
  644.                 (write-line (strcat "POLYHAND\n" (cdr (assoc 'polyhand path))) 
  645.                     f)
  646.                 (write-line (strcat "LAYER\n" (cdr (assoc 'layer path))) f)
  647.  
  648.                 (foreach vert (cdr (assoc 'vertlist path))
  649.                     (write-line "VERTEX" f)
  650.  
  651.                     ; write vertex frame
  652.                     (write-line (strcat "FRAME\n" 
  653.                         (itoa (cdr (assoc 'frame vert)))) f)
  654.  
  655.                     ; write vertex location
  656.                     (setq pt (cdr (assoc 'location vert)))
  657.                     (write-line (strcat "LOCATION\n" 
  658.                         (rtos (car pt) 2 6) "\n" 
  659.                         (rtos (cadr pt) 2 6) "\n"
  660.                         (rtos (caddr pt) 2 6)) f)
  661.  
  662.                     ; write rotation angles
  663.                     (setq pt (cdr (assoc 'rotation vert)))
  664.                     (write-line (strcat "ROTATION\n" 
  665.                         (rtos (car pt)) "\n" 
  666.                         (rtos (cadr pt)) "\n"
  667.                         (rtos (caddr pt))) f)
  668.  
  669.                     ; write bulge
  670.                     (write-line (strcat "BULGE\n" 
  671.                         (rtos (cdr (assoc 'bulge vert)))) f)
  672.  
  673.                     (write-line "ENDVERT" f)
  674.                 )
  675.                 (write-line "ENDPATH" f)
  676.             )
  677.             (write-line "EOF" f)
  678.             (close f)
  679.         )
  680.     )
  681.     (princ)
  682. )
  683.  
  684. ;
  685. ;    prin - print a variable
  686. ;
  687.  
  688. (princ "\nprin")
  689. (defun prin (s v / )
  690.     (textscr)
  691.     (princ "\n")
  692.     (princ s)
  693.     (princ v)
  694.     (princ)
  695. )
  696.  
  697. ;
  698. ;    pause - wait for user to press enter
  699. ;
  700.  
  701. (princ "\npause")
  702. (defun pause ( / )
  703.     (getstring "\nPress Enter to continue...")
  704. )
  705.  
  706. ;
  707. ;    writebat - write animation batch file
  708. ;
  709.  
  710. (princ "\nwritebat")
  711. (defun writebat ( / f basename)
  712.     (if (setq f (open (strcat (getvar "DWGNAME") ".BAT") "w"))
  713.         (progn
  714.             ; write batch initialization commands
  715.             (write-line "ECHO OFF\nCLS" f)
  716.  
  717.             ; make sure bdx and bdv file exist
  718.             (write-line (strcat "IF NOT EXIST " (getvar "DWGNAME") 
  719.                 ".BDX GOTO NOBDX") f)
  720.             (write-line (strcat "IF NOT EXIST " (getvar "DWGNAME") 
  721.                 ".BDV GOTO NOBDV") f)
  722.  
  723.             ; make temporary copies of the bdx and bdv files
  724.             (write-line (strcat "COPY " (getvar "DWGNAME") ".BDX TEMP.BDX") f)
  725.             (write-line (strcat "COPY " (getvar "DWGNAME") ".BDV TEMP.BDV") f)
  726.  
  727.             ; determine base output file name
  728.             (setq basename (substr (getvar "DWGNAME") 1 4))
  729.  
  730.             ; for each frame
  731.             (setq frame startframe)
  732.             (while (<= frame endframe)
  733.                 (write-line (strcat "BD3 " basename " " 
  734.                     (itoa frame)) f)
  735.                 (write-line "IF ERRORLEVEL 1 GOTO ABORT" f)
  736.                 (write-line (strcat "BD4 TEMP " basename " 01") f)
  737.                 (write-line "IF ERRORLEVEL 1 GOTO ABORT" f)
  738.                 (write-line (strcat "BD5 TEMP " basename " 01") f)
  739.                 (write-line "IF ERRORLEVEL 1 GOTO ABORT" f)
  740.                 (write-line (strcat "IF EXIST " basename (int2str frame) 
  741.                     ".TGA DEL " basename (int2str frame) ".TGA") f)
  742.                 (write-line (strcat "REN " basename "01.TGA " basename 
  743.                     (int2str frame) ".TGA") f)
  744.                 (setq frame (+ frame (/ 30 fps)))
  745.             )
  746.  
  747.             ; error handling
  748.             (write-line "GOTO FINISHED" f)
  749.             (write-line ":NOBDX" f)
  750.             (write-line (strcat "ECHO File " (getvar "DWGNAME") 
  751.                 ".BDX not found.") f)
  752.             (write-line "GOTO ABORT" f)
  753.             (write-line ":NOBDV" f)
  754.             (write-line (strcat "ECHO File " (getvar "DWGNAME") 
  755.                 ".BDV not found.") f)
  756.             (write-line "GOTO ABORT" f)
  757.             (write-line ":ABORT" f)
  758.             (write-line "ECHO Animation generation failed." f)
  759.             (write-line "GOTO END" f)
  760.             (write-line ":FINISHED" f)
  761.             (write-line "ECHO Animation generation completed." f)
  762.             (write-line "GOTO END" f)
  763.             (write-line ":END" f)
  764.  
  765.             (close f)
  766.         )
  767.     )
  768. )
  769.  
  770. (princ)
  771. 
  772.