home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0000 - 0009 / ibm0000-0009 / ibm0003.tar / ibm0003 / ACAD10-2.ZIP / ASHADE.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1987-08-09  |  13.8 KB  |  482 lines
  1.  
  2. ;       AutoShade commands for AutoCAD
  3.  
  4. ;       Designed and implemented by Kelvin R. Throop in May of 1987
  5.  
  6. ;       CAMERA  --  Insert a camera
  7.  
  8. (defun C:CAMERA ( / omode sname gname lfxy laxy oang selev
  9.                     scale slayer ltyp orth rot)
  10.  
  11.         (setq omode (cmode))       ; Set common modes
  12.         (graphscr)
  13.  
  14.         (setq sname (acqs "Enter camera name"  nil))
  15.  
  16. ;       Get the camera's target. 
  17.  
  18.         (setq laxy (gp3d "Enter target point"))
  19.  
  20. ;       Get the object's look from point
  21.         
  22.         (setq lfxy (gp3d "Enter camera location"))
  23.         (setq rot (* (/ 180 pi) (- (angle lfxy laxy) 1.570796)))
  24.         (setq scale (/ (getvar "VIEWSIZE") 9.52381))
  25.         (command
  26.            "insert"
  27.               "camera"
  28.               lfxy
  29.               scale
  30.               scale
  31.               (strcat "<<" (rtos rot 2 6))
  32.               sname                     ; SNAME
  33.               " "                       ; GNAME
  34.               (rtos (car laxy) 2 6)     ; LAX
  35.               (rtos (cadr laxy) 2 6)    ; LAY
  36.               (rtos (caddr laxy) 2 6)   ; LAZ
  37.         )
  38.  
  39. ;       Restore the previous operating mode
  40.  
  41.         (smode omode)
  42.         (terpri)
  43. )
  44.  
  45. ;       LIGHT  --  Insert a light source
  46.  
  47. (defun C:LIGHT ( / omode sname gname lfxy laxy oang selev
  48.                     scale slayer blkn ltyp orth rot)
  49.  
  50.         (setq omode (cmode))       ; Set running modes
  51.         (graphscr)
  52.  
  53.         (setq sname (acqs "Enter light name" nil))
  54.  
  55. ;       See if the light is a point source or a parallel (directed) source.
  56. ;       If it's a directed source, get the direction of the beam.
  57.  
  58.         (setq selev T)
  59.         (while selev
  60.            (setq selev (strcase (substr
  61.               (acqs "Point source or Directed" "P") 1 1)))
  62.            (cond ((= selev "P")
  63.                     (setq blkn "overhead")
  64.                     (setq gname " ")
  65.                     (setq laxy '(0 0 0))
  66.                     (setq selev nil)
  67.                  )
  68.                  ((= selev "D")
  69.                     (setq blkn "direct")
  70.                     (setq gname "Parallel")
  71.                     (setq laxy (gp3d "Enter light aim point"))
  72.                     (setq selev nil)
  73.                  )
  74.            )
  75.         )
  76.  
  77. ;       Get the light's location
  78.         
  79.         (setq lfxy (gp3d "Enter light location"))
  80.         (setq scale (/ (getvar "VIEWSIZE") 9.52381))
  81.         (if (= blkn "overhead") 
  82.            (setq rot 0)
  83.            (setq rot (* (/ 180 pi) (- (angle lfxy laxy) 1.570796)))
  84.         )
  85.         (command
  86.            "insert"
  87.               blkn
  88.               lfxy
  89.               scale
  90.               scale
  91.               (strcat "<<" (rtos rot 2 6))
  92.               sname                     ; SNAME
  93.               gname                     ; GNAME
  94.               (rtos (car laxy) 2 6)     ; LAX
  95.               (rtos (cadr laxy) 2 6)    ; LAY
  96.               (rtos (caddr laxy) 2 6)   ; LAZ
  97.         )
  98.  
  99. ;       Restore the previous operating modes
  100.  
  101.         (smode omode)
  102.         (terpri)
  103. )
  104.  
  105. ;       SCENE  --  Define a scene
  106.  
  107. ;       It prompts the user for a camera name and optional light sources
  108. ;       and insert a series of scene blocks, one for the camera and as many as
  109. ;       needed for the light sources.
  110.  
  111. (defun C:SCENE ( / sname cname lname savss savobj wlist oname ename
  112.                    lfxy scale lrefs)
  113.  
  114.         (setq sname "")            ; The set name
  115.         (setq olist nil)           ; List of the scene's objects
  116.         (graphscr)
  117.  
  118. ;       Obtain scene name
  119.  
  120.         (setq sname (acqs "Enter scene name" nil))
  121.  
  122. ;       Save the SCENE name
  123.  
  124.         (setq olist (list sname))
  125.  
  126. ;       Get the camera's name.  Don't take null for an answer.
  127.  
  128.         (setq objct "CAMERA")
  129.  
  130.         (bget (slob "\nSelect the " ": " nil))
  131.         (setq cname (cdr (assoc '1 (eget "SNAME"))))
  132.         (prompt (strcat " " cname "\n"))
  133.  
  134. ;       Include the camera name in the list of objects
  135. ;       which belong to the scene.
  136.         
  137.         (setq
  138.            olist
  139.              (append olist (list (list "CAMERA" cname)))
  140.         )
  141.  
  142. ;       Get the light sources' names. Here, a null
  143. ;       line is interpreted as an end of the list of light sources.
  144.  
  145.         (setq objct "LIGHT")
  146.         (setq lrefs "Lights:")
  147.  
  148.         (setq lname 1)
  149.         (while (and cname lname)
  150.            (setq lname (slob "\nSelect a " ": " T))
  151.  
  152. ;          Include the light name in the list of
  153. ;          objects which belong to the scene. Don't
  154. ;          do it if the light is already part of the
  155. ;          scene.
  156.  
  157.            (if lname
  158.               (progn
  159.                  (bget lname)
  160.                  (setq lname (cdr (assoc '1 (eget "SNAME"))))
  161.                  (prompt (strcat " " lname "\n"))
  162.                  (if (notin lname)
  163.                     (setq olist 
  164.                        (append olist
  165.                           (list (list objct lname))
  166.                        )
  167.                        lrefs (strcat lrefs " " lname)
  168.                     )
  169.                     (prompt (strcat "\nLight " lname " already selected.\n"))
  170.                  )
  171.               )
  172.            )
  173.         )
  174.         
  175.         (if olist
  176.            (progn
  177.  
  178. '             Create a list of all of the objects to be inserted
  179.  
  180.               (setq wlist (cdr olist))
  181.  
  182. ;             Get the camera name
  183.  
  184.               (setq oname (cadr (assoc '"CAMERA" wlist)))
  185.  
  186. ;             Obtain location to put scene reference block
  187.  
  188.               (setq lfxy (gp3d "Enter scene location"))
  189.               (setq scale (/ (getvar "VIEWSIZE") 85.0))
  190.  
  191. ;             Put the clapper in the drawing
  192.  
  193.               (clinsu sname lfxy scale (strcat "Camera: " oname) lrefs)
  194.  
  195. ;             Insert the Scene's camera block and update its attributes
  196.  
  197.               (sinsu sname "CAMERA" oname lfxy scale)
  198.  
  199. ;             Insert the Scene's light sources and update their attributes
  200.  
  201.               (foreach oname wlist
  202.                  (if (eq (car oname) "LIGHT")
  203.                     (progn
  204. ;                      Offset each SHOT block to form bars on the clapper
  205.                        (setq lfxy (cons
  206.                           (+ (car lfxy) (* 0.8 scale)) (cdr lfxy)))
  207.                        (sinsu sname "LIGHT" (cadr oname) lfxy scale)
  208.                     )
  209.                  )
  210.               )
  211.               (prompt (strcat "\nScene " sname " included\n"))
  212.            )
  213.            (prompt "\nNo scenes included\n")
  214.         )
  215.         (setq olist nil)
  216. )
  217.  
  218. ; SINSU - Scene insert update attributes
  219.  
  220. ; It will insert a scene block and update its attributes accordingly.
  221.  
  222. ; Input:  sname   The scene name
  223. ;         otype   The object' type
  224. ;         oname   The object's name
  225.  
  226. (defun SINSU (sname otype oname lfxy scale / omode slayer)
  227.  
  228.         (setq omode (cmode))   ; use common modes
  229.  
  230.         (command "insert"
  231.               "shot"               ; Load up the number 4 buck, Billy Bob!
  232.               lfxy                 ; Shot reference location
  233.               scale                ; X scaling
  234.               scale                ; Y scaling
  235.               "<<0"                ; No rotation
  236.               otype                ; Object type (e.g., light, camera)
  237.               oname                ; Object name (its name)
  238.               sname                ; Scene name
  239.         )
  240.  
  241. ;       Restore the previous operating modes
  242.  
  243.         (smode omode)
  244. )
  245.  
  246. ;       Insert clapper.  The whole purpose of the clapper is to carry the
  247. ;       extra attributes which cannot be added to the SHOT block.
  248.  
  249. (defun clinsu (sname lfxy scale cref lref / omode slayer)
  250.  
  251.         (setq omode (cmode))   ; use common modes
  252.  
  253.         (command "insert"
  254.               "clapper"            ; No applause for morons
  255.               lfxy                 ; Shot reference location
  256.               scale                ; X scaling
  257.               scale                ; Y scaling
  258.               "<<0"                ; No rotation
  259.               sname                ; Scene name
  260.               cref                 ; Camera reference string
  261.               lref                 ; Light reference string
  262.         )
  263.  
  264. ;       Restore the previous operating modes
  265.  
  266.         (smode omode)
  267. )
  268.  
  269. ;       SMODE  -  Save and set operating modes
  270.  
  271. ; Saves the operating modes in MLIST and sets them to the values
  272. ; indicated. It returns a list with the current settings.
  273.  
  274. ; Input:  mlist   - A list containing paired lists with operating names
  275. ;                   and the values which to set them. The format is as
  276. ;                   follows:
  277.  
  278. ;                   ((STRING1 VALUE1) (STRING2 VALUE2) ... (STRINGN VALUEN))
  279.  
  280. ; Return: clist   - A list with the same format as MLIST containning the
  281. ;                   current settings.
  282.  
  283. (defun smode (mlist / clist pair string oval)
  284.         (setq clist nil)
  285.         (foreach  pair mlist
  286.            (setq string (car pair))
  287.            (setq oval (getvar string))
  288.            (setq clist (append clist (list (list string oval))))
  289.            (setvar string (cadr pair))
  290.         )
  291.         clist
  292. )
  293.  
  294. ;       CMODE  --  Set operating modes used whilst accessing our blocks
  295.  
  296. (defun cmode()
  297.         (smode '(("CMDECHO" 0)("LIMCHECK" 0)("EXPERT" 1)
  298.            ("ORTHOMODE" 0)))
  299. )
  300.  
  301. ;       ACQS  --  Acquire string.  Handles defaults and rejects null;
  302. ;                 input if there is no default.
  303. ;                 Since this is used only for object names, it limits
  304. ;                 the name length to 8 characters.
  305.  
  306. ; Input:  a     - The prompt string
  307. ;         b     - The default string
  308. ;
  309.  
  310. (defun acqs ( a b / c d)
  311.  
  312. ;       Initialise working environment
  313.  
  314.         (setq c nil d T)
  315.  
  316. ;       Display default value, if necessary
  317.  
  318.         (cond
  319.            ((null b)
  320.               (setq a (strcat "\n" a ": ")))
  321.            (T
  322.               (setq a (strcat "\n" a " <" b ">: ")))
  323.         )
  324.         (while d
  325.            (setq c (getstring a))
  326.            (if (or (not (or (null c) (= c ""))) b)
  327.               (setq d nil) 
  328.            )
  329.         )
  330.  
  331. ;       A null answer causes default to be returned
  332.  
  333.         (substr (if (= c "") b c) 1 8)
  334. )
  335.  
  336. ; SLOB   Select Object
  337.  
  338. ; Selects one of the active object types.
  339. ; Won't take NULL for an answer. 
  340.  
  341. ; Input:  prefix prompt
  342. ;         postfix prompt
  343. ;         Null pick ok flag
  344.  
  345. ;         Uses globals objct and objo
  346.  
  347. ; Return: entity
  348.  
  349. (defun slob (pre post nulok / prcd)
  350.  
  351.   (setq prcd 1)
  352.  
  353. ;   Select the object to update.
  354.  
  355.   (while (= 1 prcd)
  356.      (setq ename (car (entsel (strcat pre (strcase objct t) post))))
  357.      (if ename
  358.         (if (= (cdr (assoc '0 (setq elist (entget ename)))) "INSERT")
  359.            (progn
  360.               (setq bnam (cdr (assoc '2 elist)))
  361.               (cond
  362.                  ; Inserted block must have the desired object name.
  363.                  ((or
  364.                     (= objct bnam)
  365.                     (and (= bnam "DIRECT") (= objct "LIGHT"))
  366.                     (and (= bnam "OVERHEAD") (= objct "LIGHT"))
  367.                     (and (= bnam "SHOT") (= objct "SCENE")))
  368.                     (setq prcd nil)
  369.                  )
  370.                  (T 
  371.                     (prompt (strcat "\nSelected object is not a "
  372.                        (strcase objct t) " \n")))
  373.               )
  374.            )
  375.         )
  376.         (if nulok
  377.            (setq prcd nil))
  378.      )
  379.   )
  380.   ename
  381. )
  382.  
  383. ; bget (ename)
  384.  
  385. ; Starting at ENAME entity name it searches the database for an SEQEND
  386. ; entity . The following list is returned:
  387.  
  388. ;   (elist0   elist1   elist2   ...   elistN), where
  389.  
  390. ;      elist0    Is the block's entity list
  391.  
  392. ;      elist<i>, i=1,N are the entities lists of the block's attributes
  393.  
  394. ; If the desired INSERT entity is not found nil is returned
  395.  
  396. ; Input:  ename     - Where to start the search.
  397.  
  398. ; Return: blist     - A global value
  399.  
  400. (defun bget ( ename / prcd elist)
  401.  
  402.   (setq prcd 1)
  403.  
  404. ; Before starting, see if the current blist contains
  405. ; the desired entity.
  406.  
  407.   (cond
  408.      ((and (listp 'blist) (= ename (cdr (assoc '-1 (car blist)))))
  409.         (ename))
  410.  
  411.      (T
  412.         (setq blist (list (entget ename)))
  413.         (while prcd
  414.            (setq elist (entget (setq ename (entnext ename))))
  415.            (if (= (cdr (assoc '0 elist)) "SEQEND")
  416.              (setq prcd nil)
  417.              (setq blist (append blist (list elist)))
  418.            )
  419.         )
  420.         (cdr (assoc '-1 (car blist)))
  421.      )
  422.   )
  423. )
  424.  
  425. ; eget ( tagn )
  426.  
  427. ; Searches the current blist for an ATTRIB elist whith an attribute
  428. ; tag equal to the argument's tag name. It returns either the
  429. ; attribute's elist or nil.
  430.  
  431. ; Input:  tagn      - The attribute tag name
  432. ;         blist     - A global list containning the elists to be
  433. ;                     searched.
  434. ;
  435. ; Return: elist     - The desired entity list or nil
  436.  
  437. (defun eget ( tagn / elist wlist)
  438.  
  439.   (setq elist nil)
  440.   (foreach wlist blist
  441.      (if (and (= (cdr (assoc '0 wlist)) "ATTRIB")
  442.               (= (cdr (assoc '2 wlist)) tagn)
  443.          )
  444.         (setq elist wlist)
  445.      )
  446.   )
  447.   elist
  448. )
  449.  
  450. ; NOTIN
  451.  
  452. ; It searches the current OLIST looking for the named object. If
  453. ; the object is defined it returns T otherwise nil.
  454.  
  455. ; Input:  oname - The name of the object being searched.
  456. ;         olist - A global list containing the list of objects
  457. ;                 which belong to the current defined scene.
  458.  
  459. ; Return: T     - if the object is already part of the scene.
  460. ;         nil   - otherwise
  461.  
  462. (defun notin ( lname / opair odfnd)
  463.  
  464.   (setq odfnd nil)                      ; Say object not defined
  465.   (foreach opair (cdr olist)
  466.      (if (and (eq "LIGHT" (car opair)) (eq lname (cadr opair)))
  467.         (setq odfnd 1)
  468.      )
  469.   )
  470.   (null odfnd)
  471. )
  472.  
  473. ;       GP3D  --  Acquire 3D point
  474.  
  475. (defun gp3d (p) 
  476.         (initget (+ 1 8 16))       ; no null, limcheck off, want 3D
  477.         (setvar "lastpt3d" (getpoint (strcat "\n" p ": ")))
  478. )
  479.  
  480. (princ "\nAutoShade Commands Loaded, errors: ")
  481. (setq olist nil)
  482.