home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 3.img / ASHADE.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1990-07-30  |  17.6 KB  |  595 lines
  1.  
  2. ;       AutoShade commands for AutoCAD
  3.  
  4. ;       Designed and implemented by Kelvin R. Throop in May of 1987
  5. ;       6/28/88  CLH --  Modified for Release 10
  6. ;       7/27/88  JSY & KWL -- Added CAMVIEW
  7. ;       7/27/90  LTK -- Modified for Release 11
  8.  
  9. (vmon)
  10. (prompt "\nLoading ashade.lsp (v1.1)...")
  11.  
  12. ;       CAMERA  --  Insert a camera
  13.  
  14. (defun C:CAMERA ( / olderr omode sname gname lfxy laxy oang
  15.                     selev scale slayer ltyp orth rot)
  16.  
  17.         (setq olderr *error*
  18.               *error* as-err)
  19.         (setq omode (a:cmod))      ; Set common modes
  20.         (graphscr)
  21.  
  22.         (setq sname (a:acqs "Enter camera name"  nil))
  23.  
  24. ;       Get the camera's target.
  25.  
  26.         (setq laxy (a:gp3d "Enter target point"))
  27.  
  28. ;       Get the object's look from point
  29.  
  30.         (setq lfxy (a:gp3d "Enter camera location"))
  31.         (setq rot (* (/ 180 pi) (- (angle lfxy laxy) 1.570796)))
  32.         (setq scale (/ (getvar "VIEWSIZE") 9.52381))
  33.         (if (null r9) (setq laxy (trans laxy 1 0)))
  34.         (command
  35.            "insert"
  36.               "camera"
  37.               lfxy
  38.               scale
  39.               scale
  40.               (strcat "<<" (rtos rot 2 6))
  41.               sname                     ; SNAME
  42.               " "                       ; GNAME
  43.               (rtos (car laxy) 2 6)     ; LAX
  44.               (rtos (cadr laxy) 2 6)    ; LAY
  45.               (rtos (caddr laxy) 2 6)   ; LAZ
  46.         )
  47.  
  48. ;       Restore the previous operating mode
  49.  
  50.         (a:smod omode)
  51.         (setq *error* olderr)
  52.         (princ)
  53. )
  54.  
  55. ;       LIGHT  --  Insert a light source
  56.  
  57. (defun C:LIGHT ( / olderr omode sname gname lfxy laxy oang
  58.                     selev scale slayer blkn ltyp orth rot)
  59.  
  60.         (setq olderr *error*
  61.               *error* as-err)
  62.         (setq omode (a:cmod))      ; Set running modes
  63.         (graphscr)
  64.  
  65.         (setq sname (a:acqs "Enter light name" nil))
  66.  
  67. ;       See if the light is a point source or a parallel (directed) source.
  68. ;       If it's a directed source, get the direction of the beam.
  69.  
  70.         (setq selev T)
  71.         (while selev
  72.            (setq selev (strcase (substr
  73.               (a:acqs "Point source or Directed" "P") 1 1)))
  74.            (cond ((= selev "P")
  75.                     (setq blkn "overhead")
  76.                     (setq gname " ")
  77.                     (setq laxy '(0 0 0))
  78.                     (setq selev nil)
  79.                  )
  80.                  ((= selev "D")
  81.                     (setq blkn "direct")
  82.                     (setq gname "Parallel")
  83.                     (setq laxy (a:gp3d "Enter light aim point"))
  84.                     (setq selev nil)
  85.                  )
  86.            )
  87.         )
  88.  
  89. ;       Get the light's location
  90.  
  91.         (setq lfxy (a:gp3d "Enter light location"))
  92.         (setq scale (/ (getvar "VIEWSIZE") 9.52381))
  93.         (if (= blkn "overhead")
  94.            (setq rot 0)
  95.            (setq rot (* (/ 180 pi) (- (angle lfxy laxy) 1.570796)))
  96.         )
  97.         (if (null r9) (setq laxy (trans laxy 1 0)))
  98.         (command
  99.            "insert"
  100.               blkn
  101.               lfxy
  102.               scale
  103.               scale
  104.               (strcat "<<" (rtos rot 2 6))
  105.               sname                     ; SNAME
  106.               gname                     ; GNAME
  107.               (rtos (car laxy) 2 6)     ; LAX
  108.               (rtos (cadr laxy) 2 6)    ; LAY
  109.               (rtos (caddr laxy) 2 6)   ; LAZ
  110.         )
  111.  
  112. ;       Restore the previous operating modes
  113.  
  114.         (a:smod omode)
  115.         (setq *error* olderr)
  116.         (princ)
  117. )
  118.  
  119. ;       SCENE  --  Define a scene
  120.  
  121. ;       It prompts the user for a camera name and optional light sources
  122. ;       and insert a series of scene blocks, one for the camera and as many as
  123. ;       needed for the light sources.
  124.  
  125. (defun C:SCENE ( / olderr sname cname lname savss savobj wlist oname
  126.                    ename lfxy scale lrefs)
  127.  
  128.         (setq olderr *error*
  129.               *error* as-err)
  130.         (setq sname "")            ; The set name
  131.         (setq v:olst nil)          ; List of the scene's objects
  132.         (graphscr)
  133.  
  134. ;       Obtain scene name
  135.  
  136.         (setq sname (a:acqs "Enter scene name" nil))
  137.  
  138. ;       Save the SCENE name
  139.  
  140.         (setq v:olst (list sname))
  141.  
  142. ;       Get the camera's name.  Don't take null for an answer.
  143.  
  144.         (setq v:objc "CAMERA")
  145.  
  146.         (a:bget (a:slob "\nSelect the " ": " nil))
  147.         (setq cname (cdr (assoc '1 (a:eget "SNAME"))))
  148.         (prompt (strcat " " cname "\n"))
  149.  
  150. ;       Include the camera name in the list of objects
  151. ;       which belong to the scene.
  152.  
  153.         (setq
  154.            v:olst
  155.              (append v:olst (list (list "CAMERA" cname)))
  156.         )
  157.  
  158. ;       Get the light sources' names. Here, a null
  159. ;       line is interpreted as an end of the list of light sources.
  160.  
  161.         (setq v:objc "LIGHT")
  162.         (setq lrefs "Lights:")
  163.  
  164.         (setq lname 1)
  165.         (while (and cname lname)
  166.            (setq lname (a:slob "\nSelect a " ": " T))
  167.  
  168. ;          Include the light name in the list of
  169. ;          objects which belong to the scene. Don't
  170. ;          do it if the light is already part of the
  171. ;          scene.
  172.  
  173.            (if lname
  174.               (progn
  175.                  (a:bget lname)
  176.                  (setq lname (cdr (assoc '1 (a:eget "SNAME"))))
  177.                  (prompt (strcat " " lname "\n"))
  178.                  (if (a:ntin lname)
  179.                     (setq v:olst
  180.                        (append v:olst
  181.                           (list (list v:objc lname))
  182.                        )
  183.                        lrefs (strcat lrefs " " lname)
  184.                     )
  185.                     (prompt (strcat "\nLight " lname " already selected.\n"))
  186.                  )
  187.               )
  188.            )
  189.         )
  190.  
  191.         (if v:olst
  192.            (progn
  193.  
  194. ;             Create a list of all of the objects to be inserted
  195.  
  196.               (setq wlist (cdr v:olst))
  197.  
  198. ;             Get the camera name
  199.  
  200.               (setq oname (cadr (assoc '"CAMERA" wlist)))
  201.  
  202. ;             Obtain location to put scene reference block
  203.  
  204.               (setq lfxy (a:gp3d "Enter scene location"))
  205.               (setq scale (/ (getvar "VIEWSIZE") 85.0))
  206.  
  207. ;             Put the clapper in the drawing
  208.  
  209.               (a:clin sname lfxy scale (strcat "Camera: " oname) lrefs)
  210.  
  211. ;             Insert the Scene's camera block and update its attributes
  212.  
  213.               (a:sins sname "CAMERA" oname lfxy scale)
  214.  
  215. ;             Insert the Scene's light sources and update their attributes
  216.  
  217.               (foreach oname wlist
  218.                  (if (eq (car oname) "LIGHT")
  219.                     (progn
  220. ;                      Offset each SHOT block to form bars on the clapper
  221.                        (setq lfxy (cons
  222.                           (+ (car lfxy) (* 0.8 scale)) (cdr lfxy)))
  223.                        (a:sins sname "LIGHT" (cadr oname) lfxy scale)
  224.                     )
  225.                  )
  226.               )
  227.               (prompt (strcat "\nScene " sname " included.\n"))
  228.            )
  229.            (prompt "\nNo scenes included.\n")
  230.         )
  231.         (setq v:olst nil)
  232.         (setq *error* olderr)
  233.         (princ)
  234. )
  235.  
  236. ; A:SINS - Scene insert update attributes
  237.  
  238. ; It will insert a scene block and update its attributes accordingly.
  239.  
  240. ; Input:  sname   The scene name
  241. ;         otype   The object' type
  242. ;         oname   The object's name
  243.  
  244. (defun a:sins (sname otype oname lfxy scale / omode slayer)
  245.  
  246.         (setq omode (a:cmod))      ; use common modes
  247.  
  248.         (command "insert"
  249.               "shot"               ; Load up the number 4 buck, Billy Bob!
  250.               lfxy                 ; Shot reference location
  251.               scale                ; X scaling
  252.               scale                ; Y scaling
  253.               "<<0"                ; No rotation
  254.               otype                ; Object type (e.g., light, camera)
  255.               oname                ; Object name (its name)
  256.               sname                ; Scene name
  257.         )
  258.  
  259. ;       Restore the previous operating modes
  260.  
  261.         (a:smod omode)
  262. )
  263.  
  264. ;       Insert clapper.  The whole purpose of the clapper is to carry the
  265. ;       extra attributes which cannot be added to the SHOT block.
  266.  
  267. (defun a:clin (sname lfxy scale cref lref / omode slayer)
  268.  
  269.         (setq omode (a:cmod))      ; use common modes
  270.  
  271.         (command "insert"
  272.               "clapper"            ; No applause for morons
  273.               lfxy                 ; Shot reference location
  274.               scale                ; X scaling
  275.               scale                ; Y scaling
  276.               "<<0"                ; No rotation
  277.               sname                ; Scene name
  278.               cref                 ; Camera reference string
  279.               lref                 ; Light reference string
  280.         )
  281.  
  282. ;       Restore the previous operating modes
  283.  
  284.         (a:smod omode)
  285. )
  286.  
  287. ;       A:SMOD  -  Save and set operating modes
  288.  
  289. ; Saves the operating modes in MLIST and sets them to the values
  290. ; indicated. It returns a list with the current settings.
  291.  
  292. ; Input:  mlist   - A list containing paired lists with operating names
  293. ;                   and the values which to set them. The format is as
  294. ;                   follows:
  295.  
  296. ;                   ((STRING1 VALUE1) (STRING2 VALUE2) ... (STRINGN VALUEN))
  297.  
  298. ; Return: clist   - A list with the same format as MLIST containning the
  299. ;                   current settings.
  300.  
  301. (defun a:smod (mlist / clist pair string oval)
  302.         (setq clist nil)
  303.         (foreach  pair mlist
  304.            (setq string (car pair))
  305.            (setq oval (getvar string))
  306.            (setq clist (append clist (list (list string oval))))
  307.            (setvar string (cadr pair))
  308.         )
  309.         clist
  310. )
  311.  
  312. ;       A:CMOD  --  Set operating modes used whilst accessing our blocks
  313.  
  314. (defun a:cmod()
  315.                (a:smod '(("CMDECHO" 0)("LIMCHECK" 0)("EXPERT" 1)
  316.                         ("ORTHOMODE" 0) ("ATTDIA" 0)))
  317. )
  318.  
  319.  
  320. ;       A:ACQS  --  Acquire string.  Handles defaults and rejects null;
  321. ;                   input if there is no default.
  322. ;                   Since this is used only for object names, it limits
  323. ;                   the name length to 8 characters.
  324.  
  325. ; Input:  a     - The prompt string
  326. ;         b     - The default string
  327. ;
  328.  
  329. (defun a:acqs ( a b / c d)
  330.  
  331. ;       Initialise working environment
  332.  
  333.         (setq c nil d T)
  334.  
  335. ;       Display default value, if necessary
  336.  
  337.         (cond
  338.            ((null b)
  339.               (setq a (strcat "\n" a ": ")))
  340.            (T
  341.               (setq a (strcat "\n" a " <" b ">: ")))
  342.         )
  343.         (while d
  344.            (setq c (getstring a))
  345.            (if (or (not (or (null c) (= c ""))) b)
  346.               (setq d nil)
  347.            )
  348.         )
  349.  
  350. ;       A null answer causes default to be returned
  351.  
  352.         (substr (if (= c "") b c) 1 8)
  353. )
  354.  
  355. ; A:SLOB   Select Object
  356.  
  357. ; Selects one of the active object types.
  358. ; Won't take NULL for an answer.
  359.  
  360. ; Input:  prefix prompt
  361. ;         postfix prompt
  362. ;         Null pick ok flag
  363.  
  364. ;         Uses globals v:objc and v:objo
  365.  
  366. ; Return: entity
  367.  
  368. (defun a:slob (pre post nulok / prcd)
  369.  
  370.   (setq prcd 1)
  371.  
  372. ;   Select the object to update.
  373.  
  374.   (while (= 1 prcd)
  375.      (setq ename (car (entsel (strcat pre (strcase v:objc t) post))))
  376.      (if ename
  377.         (if (= (cdr (assoc '0 (setq elist (entget ename)))) "INSERT")
  378.            (progn
  379.               (setq bnam (cdr (assoc '2 elist)))
  380.               (cond
  381.                  ; Inserted block must have the desired object name.
  382.                  ((or
  383.                     (= v:objc bnam)
  384.                     (and (= bnam "DIRECT") (= v:objc "LIGHT"))
  385.                     (and (= bnam "OVERHEAD") (= v:objc "LIGHT"))
  386.                     (and (= bnam "SHOT") (= v:objc "SCENE")))
  387.                     (setq prcd nil)
  388.                  )
  389.                  (T
  390.                     (prompt (strcat "\nSelected object is not a "
  391.                        (strcase v:objc t) " \n")))
  392.               )
  393.            )
  394.         )
  395.         (if nulok
  396.            (setq prcd nil))
  397.      )
  398.   )
  399.   ename
  400. )
  401.  
  402. ; a:bget (ename)
  403.  
  404. ; Starting at ENAME entity name it searches the database for an SEQEND
  405. ; entity . The following list is returned:
  406.  
  407. ;   (elist0   elist1   elist2   ...   elistN), where
  408.  
  409. ;      elist0    Is the block's entity list
  410.  
  411. ;      elist<i>, i=1,N are the entities lists of the block's attributes
  412.  
  413. ; If the desired INSERT entity is not found nil is returned
  414.  
  415. ; Input:  ename     - Where to start the search.
  416.  
  417. ; Return: v:blst     - A global value
  418.  
  419. (defun a:bget ( ename / prcd elist)
  420.  
  421.   (setq prcd 1)
  422.  
  423. ; Before starting, see if the current v:blst contains
  424. ; the desired entity.
  425.  
  426.   (cond
  427.      ((and (listp 'v:blst) (= ename (cdr (assoc '-1 (car v:blst)))))
  428.         (ename))
  429.  
  430.      (T
  431.         (setq v:blst (list (entget ename)))
  432.         (while prcd
  433.            (setq elist (entget (setq ename (entnext ename))))
  434.            (if (= (cdr (assoc '0 elist)) "SEQEND")
  435.              (setq prcd nil)
  436.              (setq v:blst (append v:blst (list elist)))
  437.            )
  438.         )
  439.         (cdr (assoc '-1 (car v:blst)))
  440.      )
  441.   )
  442. )
  443.  
  444. ; a:eget ( tagn )
  445.  
  446. ; Searches the current v:blst for an ATTRIB elist whith an attribute
  447. ; tag equal to the argument's tag name. It returns either the
  448. ; attribute's elist or nil.
  449.  
  450. ; Input:  tagn      - The attribute tag name
  451. ;         v:blst    - A global list containing the elists to be
  452. ;                     searched.
  453. ;
  454. ; Return: elist     - The desired entity list or nil
  455.  
  456. (defun a:eget ( tagn / elist wlist)
  457.  
  458.   (setq elist nil)
  459.   (foreach wlist v:blst
  460.      (if (and (= (cdr (assoc '0 wlist)) "ATTRIB")
  461.               (= (cdr (assoc '2 wlist)) tagn)
  462.          )
  463.         (setq elist wlist)
  464.      )
  465.   )
  466.   elist
  467. )
  468.  
  469. ; A:NTIN
  470.  
  471. ; It searches the current v:olst looking for the named object. If
  472. ; the object is defined it returns T otherwise nil.
  473.  
  474. ; Input:  oname  - The name of the object being searched.
  475. ;         v:olst - A global list containing the list of objects
  476. ;                  which belong to the current defined scene.
  477.  
  478. ; Return: T      - if the object is already part of the scene.
  479. ;         nil    - otherwise
  480.  
  481. (defun a:ntin ( lname / opair odfnd)
  482.  
  483.   (setq odfnd nil)                 ; Say object not defined
  484.   (foreach opair (cdr v:olst)
  485.      (if (and (eq "LIGHT" (car opair)) (eq lname (cadr opair)))
  486.         (setq odfnd 1)
  487.      )
  488.   )
  489.   (null odfnd)
  490. )
  491.  
  492. ;       A:GP3D  --  Acquire 3D point
  493.  
  494. (defun a:gp3d (p)
  495.         (initget (+ 1 8 16))       ; no null, limcheck off, want 3D
  496.         (setvar "lastpoint" (getpoint (strcat "\n" p ": ")))
  497. )
  498.  
  499. ;       CAMVIEW  --  Display a camera's view
  500.  
  501. ;    The routine drives DVIEW with a null selection set and the default
  502. ;    distance from the target to the camera in order to set perspective
  503. ;    on and then exits DVIEW.
  504.  
  505.  
  506. (defun C:CAMVIEW ( / olderr ename cname)
  507.  
  508.         (cond
  509.           ((= 1 (getvar "flatland")) ; exit if FLATLAND is on
  510.             (prompt "This routine requires FLATLAND to be set to 0."))
  511.           ((and (= 0 (getvar "tilemode"))
  512.                 (= 1 (getvar "cvport"))) ; exit if in PAPER SPACE
  513.             (prompt "** Command not allowed in Paper space **"))
  514.           (T
  515.             (setq olderr *error*
  516.                   *error* as-err)
  517.             (setq omode (a:cmod))
  518.  
  519. ;       Get the camera's name.  Don't take null for an answer.
  520.  
  521.             (setq v:objc "CAMERA")
  522.  
  523.             (setq ename (a:bget (a:slob "\nSelect the " ": " nil)))
  524.             (setq cname (cdr (assoc '1 (a:eget "SNAME"))))
  525.             (prompt (strcat " " cname "\n"))
  526.             (act (entget ename))
  527.             (a:smod omode)
  528.             (setq *error* olderr)
  529.           )
  530.         )
  531.         (princ)
  532. )
  533.  
  534. ;       ACT  --  Get to the new camera position
  535.  
  536. ; Input:  sset - A camera entity
  537.  
  538. (defun act (sset / nxt lax lay laz tar cam dis)
  539.  
  540.         (setq nxt (entget (entnext (cdr (assoc -1 sset)))))
  541.         (while
  542.           (and (= (cdr(assoc 0 nxt)) "ATTRIB") (/= (cdr(assoc 0 nxt)) "SEQEND"))
  543.             (cond
  544.                ((= (cdr(assoc 2 nxt)) "LAX")
  545.                    (setq lax (cdr(assoc 1 nxt)))
  546.                )
  547.                ((= (cdr(assoc 2 nxt)) "LAY")
  548.                    (setq lay (cdr(assoc 1 nxt)))
  549.                )
  550.                ((= (cdr(assoc 2 nxt)) "LAZ")
  551.                    (setq laz (cdr(assoc 1 nxt)))
  552.                )
  553.                (T)                 ; no operation if true
  554.             )
  555.           (setq nxt (entget (entnext (cdr (assoc -1 nxt)))))
  556.         )
  557.  
  558.         ; Translate target and camera points to world coordinates
  559.  
  560.         (setq tar (trans (list (atof lax) (atof lay) (atof laz)) 0 1))
  561.         (setq cam (trans (list (cadr  (assoc 10 sset))
  562.                                (caddr (assoc 10 sset))
  563.                                (cadddr(assoc 10 sset)))
  564.                          (cdr (assoc -1 sset)) 1))
  565.  
  566.         (setq dis (distance cam tar))
  567.         (command "dview" "" "po" tar cam "d" dis "") ; use default dviewblock
  568. )
  569.  
  570. ;       AS-ERR -- AutoShade internal error handler
  571.  
  572. (defun as-err (s)                  ; If an error (such as CTRL-C) occurs
  573.                                    ; while this command is active...
  574.         (if (/= s "Function cancelled")
  575.            (princ (strcat "\nError: " s))
  576.         )
  577.         (a:smod omode)
  578.         (setq *error* olderr)      ; restore old *error* handler
  579.         (princ)
  580. )
  581.  
  582. (defun a:shade ()                  ; function for AEC
  583.         (princ "\n \n \nAutoShade Commands Loaded, errors: ")
  584.         (princ)
  585.         (setq v:olst nil)
  586. )
  587. ; Running under Release 10 or later?
  588. (cond ((getvar "viewmode") (setq r9 nil))
  589.       (T (setq r9 T c:camview nil act nil)))
  590.  
  591. (prompt "loaded.")
  592. (setq G:SVER 11)                       ;  (v1.1 = 11, v2.0 = 20)
  593.  
  594. (prin1)
  595.