home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p030 / 2.ddi / AFWALK.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-09-20  |  15.9 KB  |  486 lines
  1. ;
  2. ;       Generate cameras and scenes to walk through drawing.
  3. ;
  4. ;       Last updated in release 1.0b
  5. ;
  6. ;       Designed and implemented by Kelvin R. Throop in May of 1987.
  7. ;
  8. ;       8/88  TLD/KWL -- Modified for Release 10.
  9. ;
  10. ;       This command takes a polyline, specifying the path and eye
  11. ;       height (from the polyline's elevation), and generates cameras
  12. ;       and scenes to walk through the model along the polyline.  It
  13. ;       simultaneously writes an AutoShade script file to generate
  14. ;       the images for each frame, and an AutoFlix command file
  15. ;       to create a movie from the frame images.  The camera's look-at
  16. ;       point can either be fixed or can be specified by a second
  17. ;       polyline, allowing either examination of a fixed point
  18. ;       from different viewpoints or a true Steadicam-type walkthrough.
  19. ;       In addition, the camera may be smoothly twisted throughout
  20. ;       the walkthrough, permitting inspection from various angles.
  21. ;
  22. ;       The generated script normally uses full shading to make the
  23. ;       images.  To change this to fast shading, or to subsequently
  24. ;       change back to full shade, use the command SHADETYPE.
  25. ;
  26.  
  27. (setq shadecmd "fullshade")
  28. (setq flixver "1.0b")
  29.  
  30. ;       SHADETYPE command.  Permits user to select fast or full shaded
  31. ;                           renderings for animation frames.
  32.  
  33. (defun C:shadetype ()
  34.         (setq prcd T)
  35.         (while prcd
  36.            (setq s (strcase (substr (getstring (strcat "\nFast shading for images? <"
  37.               (if (= shadecmd "fastshade") "Y" "N")
  38.               ">: ")) 1 1)))
  39.            (cond
  40.               ((= (strlen s) 0) (setq prcd nil))
  41.               ((= s "Y") (setq prcd nil shadecmd "fastshade"))
  42.               ((= s "N") (setq prcd nil shadecmd "fullshade"))
  43.            )
  44.         )
  45.         (princ)
  46. )
  47.  
  48. ;       Construct item name from type code B, base name, and index N
  49.  
  50. (defun cname (b n)
  51.         (strcat b bname (itoa n))
  52. )
  53.  
  54. ;       ICL  -- Insert camera or light.  Presently used only for cameras
  55.  
  56. (defun icl (blkn lfxy laxy sname / scale slayer rot)
  57.         (setq scale (/ (getvar "VIEWSIZE") 9.52381))
  58.         (setq rot (* (/ 180 pi) (- (angle lfxy laxy) 1.570796)))
  59.         (setq laxy (trans laxy 1 0))
  60.         (command
  61.            "insert"
  62.               blkn
  63.               lfxy
  64.               scale
  65.               scale
  66.               (strcat "<<" (rtos rot 2 6))
  67.               sname                     ; SNAME
  68.               " "                       ; GNAME
  69.               (rtos (car laxy) 2 6)     ; LAX
  70.               (rtos (cadr laxy) 2 6)    ; LAY
  71.               (rtos (caddr laxy) 2 6)   ; LAZ
  72.         )
  73. )
  74.  
  75. ;       ISH  -- Insert scene/set/shot/whatever the heck we're calling it today
  76.  
  77. (defun ish (sname otype oname / omode slayer)
  78.         (command
  79.            "insert"
  80.               "shot"
  81.               (list '2 '2)
  82.               1                               ; No x scaling
  83.               1                               ; No y scaling
  84.               "<<0"                           ; No rotation
  85.               otype                           ; Object type
  86.               oname                           ; Object name
  87.               sname                           ; Scene name
  88.         )
  89. )
  90.  
  91. ; SLOB   Select Object
  92.  
  93. ; Selects one of the active object types.
  94. ; Won't take NULL for an answer.
  95.  
  96. ; Input:  prefix prompt
  97. ;         postfix prompt
  98. ;         Null pick ok flag
  99.  
  100. ;         Uses global objct
  101.  
  102. ; Return: entity
  103.  
  104. (defun slob (pre post nulok / prcd)
  105.  
  106.   (setq prcd 1)
  107.  
  108. ;   Select the object to update.
  109.  
  110.   (while (= 1 prcd)
  111.      (setq ename (car (entsel (strcat pre (strcase objct t) post))))
  112.      (if ename
  113.         (if (= (cdr (assoc '0 (setq elist (entget ename)))) "INSERT")
  114.            (progn
  115.               (setq bnam (cdr (assoc '2 elist)))
  116.               (cond
  117.                  ; Inserted block must have the desired object name.
  118.                  ((or
  119.                     (= objct bnam)
  120.                     (and (= bnam "DIRECT") (= objct "LIGHT"))
  121.                     (and (= bnam "OVERHEAD") (= objct "LIGHT"))
  122.                     (and (= bnam "SHOT") (= objct "SCENE")))
  123.                     (setq prcd nil)
  124.                  )
  125.                  (T
  126.                     (prompt (strcat "\nSelected object is not a "
  127.                        (strcase objct t) " \n")))
  128.               )
  129.            )
  130.         )
  131.         (if nulok
  132.            (setq prcd nil))
  133.      )
  134.   )
  135.   ename
  136. )
  137.  
  138. ; bget (ename)
  139.  
  140. ; Starting at ENAME entity name it searches the database for an SEQEND
  141. ; entity . The following list is returned:
  142.  
  143. ;   (elist0   elist1   elist2   ...   elistN), where
  144.  
  145. ;      elist0    Is the block's entity list
  146.  
  147. ;      elist<i>, i=1,N are the entities lists of the block's attributes
  148.  
  149. ; If the desired INSERT entity is not found nil is returned
  150.  
  151. ; Input:  ename     - Where to start the search.
  152.  
  153. ; Return: blist     - A global value
  154.  
  155. (defun bget ( ename / prcd elist)
  156.  
  157.   (setq prcd 1)
  158.  
  159. ; Before starting, see if the current blist contains
  160. ; the desired entity.
  161.  
  162.   (cond
  163.      ((and (listp 'blist) (= ename (cdr (assoc '-1 (car blist)))))
  164.         (ename))
  165.  
  166.      (T
  167.         (setq blist (list (entget ename)))
  168.         (while prcd
  169.            (setq elist (entget (setq ename (entnext ename))))
  170.            (if (= (cdr (assoc '0 elist)) "SEQEND")
  171.              (setq prcd nil)
  172.              (setq blist (append blist (list elist)))
  173.            )
  174.         )
  175.         (cdr (assoc '-1 (car blist)))
  176.      )
  177.   )
  178. )
  179.  
  180. ; eget ( tagn )
  181.  
  182. ; Searches the current blist for an ATTRIB elist with an attribute
  183. ; tag equal to the argument's tag name. It returns either the
  184. ; attribute's elist or nil.
  185.  
  186. ; Input:  tagn      - The attribute tag name
  187. ;         blist     - A global list containing the elists to be
  188. ;                     searched.
  189. ;
  190. ; Return: elist     - The desired entity list or nil
  191.  
  192. (defun eget ( tagn / elist wlist)
  193.  
  194.   (setq elist nil)
  195.   (foreach wlist blist
  196.      (if (and (= (cdr (assoc '0 wlist)) "ATTRIB")
  197.               (= (cdr (assoc '2 wlist)) tagn)
  198.          )
  199.         (setq elist wlist)
  200.      )
  201.   )
  202.   elist
  203. )
  204.  
  205. ;       GETZ  --  Obtain elevation defaulting to current elevation
  206.  
  207. (defun getz (s / z)
  208.         (setq z (getreal (strcat s " elevation <"
  209.            (rtos (getvar "elevation")) ">: ")))
  210.         (if (null z)
  211.            (setq z (getvar "elevation"))
  212.         )
  213.         z
  214. )
  215.  
  216. ;       DIVPL  --  Divide polyline into n animation steps.  One
  217. ;                  step is placed at the start and one at the
  218. ;                  end of the polyline, and n - 2 in the middle.
  219. ;                  For historical reasons, DIVPL is called with
  220. ;                  1 one greater than the number of points desired.
  221.  
  222.       (defun divpl (p n / e op tda tdb)
  223.         (if (setq op (= 0 (logand 1 (cdr (assoc 70 (entget (car p)))))))
  224.            (progn
  225.               (setq tda
  226.                  (trans (cdr (assoc 10 (entget (entnext (car p))))) (car p) 1)
  227.               )
  228.               (command "point" (list (car tda) (cadr tda)))
  229.            )
  230.         )
  231.         (command "divide" p (- n (if op 2 1)))
  232.         (if op (progn
  233.            (setq e (car p))
  234.            (while (/= "SEQEND" (cdr (assoc 0 (entget (entnext e)))))
  235.               (setq e (entnext e))
  236.            )
  237.            (setq tdb (trans (cdr (assoc 10 (entget e))) e 1))
  238.            (command "point" (list (car tdb) (cadr tdb)))
  239.         ))
  240. )
  241.  
  242. ;       UCSP -- Check for UCS-parallel entities
  243. ;
  244. ;               Input is extrusion vector.
  245. ;               Returns T if UCS-parallel, nil if not.
  246.  
  247. (defun ucsp (edir / udir arbval dx dy dz)
  248.    (setq udir   (trans '(0 0 1) 1 0 t)
  249.          dx     (- (car edir) (car udir))
  250.          dy     (- (cadr edir) (cadr udir))
  251.          dz     (- (caddr edir) (caddr udir))
  252.          arbval (/ 1.0 64.0)
  253.    )
  254.    (if (< (+ (* dx dx) (* dy dy) (* dz dz)) 1E-20)
  255.       (equal (and (< (abs (car edir)) arbval) (< (abs (cadr edir))))
  256.              (and (< (abs (car udir)) arbval) (< (abs (cadr udir))))
  257.       )
  258.       nil
  259.    )
  260. )
  261.  
  262. ;       WALKTHROUGH  --   Main walk-through generation command
  263.  
  264. (defun C:walkthrough ( / ss ssep tdc tdd tde)
  265.         (setq prcd t)
  266.         (while prcd
  267.            (setq e (entsel "\nChoose walk-through polyline: "))
  268.            (if (and e
  269.                     (= (cdr (assoc 0 (entget (car e)))) "POLYLINE")
  270.                     (< (cdr (assoc 70 (entget (car e)))) 8)
  271.                )
  272.                (if (null (assoc 210 (entget (car e))))
  273.                    (if (ucsp (trans '(0 0 1) (car e) 0 T))
  274.                       (setq prcd nil)
  275.                       (princ "\n2D polyline must be UCS-parallel!\n")
  276.                    )
  277.                    (if (ucsp (cdr (assoc 210 (entget (car e)))))
  278.                        (setq prcd nil)
  279.                        (princ "\n2D polyline must be UCS-parallel!\n")
  280.                    )
  281.                )
  282.                (princ "\nMust be a 2D polyline!\n")
  283.            )
  284.         )
  285.         (setq ep nil)
  286.         (initget (+ 1 8 16) "Path Same")
  287.         (setq samef nil)
  288.         (setq laxy (getpoint "\nChoose look-at point (or Path or Same): "))
  289.         (if (= laxy "Path")
  290.            (progn
  291.               (setq prcd t)
  292.               (while prcd
  293.                  (setq ep (entsel "\nChoose look-at path polyline: "))
  294.                  (if (and ep
  295.                         (= (cdr (assoc 0 (entget (car ep)))) "POLYLINE")
  296.                         (< (cdr (assoc 70 (entget (car ep)))) 8)
  297.                      )
  298.                      (if (null (assoc 210 (entget (car ep))))
  299.                          (if (ucsp (trans '(0 0 1) (car ep) 0 T))
  300.                             (setq prcd nil)
  301.                             (princ "\n2D polyline must be UCS-parallel!\n")
  302.                          )
  303.                          (if (ucsp (cdr (assoc 210 (entget (car ep)))))
  304.                             (setq prcd nil)
  305.                             (princ "\n2D polyline must be UCS-parallel!\n")
  306.                          )
  307.                      )
  308.                      (princ "\nMust be a 2D polyline!\n")
  309.                  )
  310.               )
  311.               (setq piz (getz "\nInitial path"))
  312.               (setq pfz (getz "\nFinal path"))
  313.            )
  314.            (if (= laxy "Same")
  315.               (setq samef t)
  316.            )
  317.         )
  318.         (setq llist nil bname nil)
  319.         (while (null bname)
  320.            (setq bname (getstring "\nBase name for path (1-3 characters): "))
  321.            (if (or (< (strlen bname) 1) (> (strlen bname) 3))
  322.               (progn
  323.                  (princ
  324.                   "Base name null or too long.  Must be 1 to 3 characters.\n")
  325.                  (setq bname nil)
  326.               )
  327.            )
  328.         )
  329.         (initget (+ 1 2 4))
  330.         (setq np (getint "\nNumber of frames: "))
  331.         (if (< np 3)
  332.            (progn
  333.               (setq np 3)
  334.               (princ "Frames set to minimum: 3\n")
  335.            )
  336.         )
  337.         (setq iz (getz "\nInitial camera"))
  338.         (setq fz (getz "\nFinal camera"))
  339.         (setq twist (getreal "\nTwist revolutions <0>: "))
  340.  
  341. ;       Acquire the names of the lights to be used in this picture
  342. ;       by letting the user select them.
  343.  
  344.         (setq objct "LIGHT")
  345.         (while (or (null llist) lname)
  346.            (setq lname (slob "\nSelect a " ": " T))
  347.  
  348. ;          Include the light name in the list of
  349. ;          objects which belong to the scene. Don't
  350. ;          do it if the light is already part of the
  351. ;          scene.
  352.  
  353.            (if lname
  354.               (progn
  355.                  (bget lname)
  356.                  (setq lname (cdr (assoc '1 (eget "SNAME"))))
  357.                  (prompt (strcat " " lname "\n"))
  358.                  (if (not (member lname llist))
  359.                     (setq
  360.                        llist (cons lname llist)
  361.                     )
  362.                     (prompt (strcat "\nLight " lname " already selected.\n"))
  363.                  )
  364.               )
  365.            )
  366.         )
  367.  
  368. ;       All user input acquired.  Now go generate the cameras and scenes.
  369.  
  370.         (setq cmdo (getvar "CMDECHO"))
  371.         (setvar "CMDECHO" 0)
  372.         (setq blippo (getvar "BLIPMODE"))
  373.         (setvar "BLIPMODE" 0)
  374.  
  375. ;       Place the temporary divide information on layer "$$DOTS"
  376.  
  377.         (setq slayer (getvar "CLAYER"))
  378.         (command "LAYER" "MAKE" "$$DOTS" "")
  379.         (command "point" '(0 0))
  380.         (setq np (1+ np))
  381.         (setq ss (entlast))
  382. ;       (command "divide" e np)
  383.         (divpl e np)
  384.         (if ep
  385.            (progn
  386.               (setq ssep (entlast))
  387. ;             (command "divide" ep np)
  388.               (divpl ep np)
  389.            )
  390.         )
  391.         (command "LAYER" "MAKE" "ASHADE" "")
  392.  
  393. ;       Now walk through the polyline and generate a camera and
  394. ;       a set containing it and every light named, all pointing to
  395. ;       the desired look-at point.
  396.  
  397.         (setq asf (open (strcat bname ".scr") "w"))
  398.         (setq mvf (open (strcat bname ".mvi") "w"))
  399.         (write-line "spercent -1" asf)
  400.         (write-line "record on" asf)
  401.  
  402.         (setq pernt 1)
  403.         (setq e el)
  404.         (setq tangle 0.0)
  405.         (while (< pernt np)
  406.            (setq en (setq ss (entnext ss)))
  407.            (setq pelev (+ iz (* (- fz iz)
  408.               (/ (- pernt 1.0) (- np 2.0)))))
  409. ; (princ "Point ") (princ pernt) (princ " elevation ") (princ pelev) (terpri)
  410.            (if ep
  411.               (progn
  412.                  (setq tdc (cdr (assoc 10 (entget (setq ssep (entnext ssep)))))
  413.                        laxy (list
  414.                                (car tdc)
  415.                                (cadr tdc)
  416.                                (+ piz (* (- pfz piz) (/ (- pernt 1.0) (- np 2.0))))
  417.                             )
  418.                  )
  419.               )
  420.            )
  421.  
  422. ;          If look at path is same as camera path, constantly look at
  423. ;          next point (and at end, look from next to last to last
  424. ;          direction from the last point).
  425.  
  426.            (if samef
  427.               (progn
  428.                  (if (< pernt (1- np))
  429.                     (setq
  430.                        plaxy laxy
  431.                        tdd (cdr (assoc 10 (entget (entnext en))))
  432.                        laxy (list (car tdd)
  433.                                   (cadr tdd)
  434.                                   (+ iz (* (- fz iz) (/ pernt (- np 2.0))))
  435.                             )
  436.                     )
  437.                     (progn
  438.                        (setq
  439.                           tdd (cdr (assoc 10 (entget (entnext en))))
  440.                           cpxy (list (car tdd) (cadr tdd) pelev)
  441.                        )
  442.                        (setq laxy (mapcar '+ cpxy
  443.                           (mapcar '- cpxy plaxy))
  444.                        )
  445.                     )
  446.                  )
  447.               )
  448.            )
  449.            (if (= 0 (getvar "WORLDUCS"))
  450.               (setq tde (trans (cdr (assoc 10 (entget en))) 0 1))
  451.               (setq tde (cdr (assoc 10 (entget en))))
  452.            )
  453.            (icl "camera"
  454.                 (list (car tde) (cadr tde) pelev)
  455.                 laxy
  456.                 (setq tcn (cname "C" pernt))
  457.            )
  458.            (ish (setq tsn (cname "S" pernt)) "CAMERA" tcn)
  459.            (setq ll llist)
  460.            (while ll
  461.               (ish tsn "LIGHT" (car ll))
  462.               (setq ll (cdr ll))
  463.            )
  464.            (setq usn (cname "s" pernt))
  465.            (write-line (strcat "scene " usn) asf)
  466.            (if twist
  467.               (progn
  468.                  (write-line (strcat "twist " (rtos tangle 2 6)) asf)
  469.                  (setq tangle (rem (+ tangle (/ (* 360.0 twist) (- np 2.0)))
  470.                     360.0))
  471.               )
  472.            )
  473.            (write-line (strcat shadecmd " " usn) asf)
  474.            (write-line usn mvf)
  475.            (setq pernt (1+ pernt))
  476.         )
  477.         (close asf)
  478.         (close mvf)
  479.         (command "erase" (ssget "X" '((8 . "$$DOTS"))) "")
  480.         (command "LAYER" "SET" slayer "")
  481.         (setvar "CMDECHO" cmdo)
  482.         (setvar "BLIPMODE" blippo)
  483.         (princ)
  484. )
  485.  
  486.