home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p024 / 9.img / ASCOMMON.LSP next >
Encoding:
Text File  |  1993-02-09  |  42.8 KB  |  1,254 lines
  1. ;*****************************************************************************
  2. ;*
  3. ;*  ascommon.lsp
  4. ;*  ¬⌐┼v (C) 1989-1992  Autodesk ñ╜Ñq
  5. ;*
  6. ;*  Ñ╗│n┼ΘºK╢O¿╤▒z╢iªµÑ⌠ª≤Ñ╬│~╗▌¿D¬║½■¿⌐íB¡╫º∩ñ╬╡oªµ, ª²¼O░╚╜╨┐φ┤`ñU¡z
  7. ;*  ¡∞½h :
  8. ;*
  9. ;*  1)  ñWªC¬║¬⌐┼v│qºi░╚╗▌ÑX▓{ªb¿Cñ@Ñ≈½■¿⌐∙╪íC
  10. ;*  2)  ¼█├÷¬║╗í⌐·ñσÑ≤ñ]Ñ▓╢╖⌐·╕ⁿ¬⌐┼v│qºiñ╬Ñ╗╢╡│\Ñi│qºiíC
  11. ;*
  12. ;*  Ñ╗│n┼Θ╢╚┤ú¿╤º@¼░└│Ñ╬ñW¬║░╤ª╥, ª╙Ñ╝┴n⌐·⌐╬┴⌠ºtÑ⌠ª≤½O├╥; ╣∩⌐≤Ñ⌠ª≤»S«φ
  13. ;*  Ñ╬│~ñº╛A║┘⌐╩, ÑHñ╬░╙╖~╛P░Γ⌐╥┴⌠ºtÑX¿π¬║½O├╥, ªbª╣ñ@╖ºñ⌐ÑHº_╗{íC
  14. ;*
  15. ;*
  16. ;*****************************************************************************
  17. ;*****************************************************************************
  18. ;*
  19. ;*    ASCOMMON.LSP
  20. ;*
  21. ;*    Common functions for ASHADE.LSP and RMAN.LSP.
  22. ;*
  23. ;*    Designed and Implemented by Larry Knott;  4/89
  24. ;*    12/20/90    DOS.2.0
  25. ;*    06/19/91    DOS.2.1  (1586ltk1)
  26. ;*    05/26/92    R12 Render (averendr[.exp]) compatibility
  27. ;*
  28. ;*    NOTE: This module is required for ASHADE.LSP and RMAN.LSP.
  29. ;*
  30. ;*****************************************************************************
  31. ;*
  32. ;*    Global variables:
  33. ;*
  34. ;*    G:SVER   -  INT, AutoShade version. (v1.1 = 11, v2.0 = 20)
  35. ;*    G:SHEV   -  STR, SHADE path if valid, else nil.
  36. ;*    G:R11    -  BOOL, T if AutoCAD r11, nil otherwise.
  37. ;*    G:MODE   -  LIST, saved system variables and values.
  38. ;*    G:RMAN   -  BOOL, prompt for RenderMan attributes.
  39. ;*    G:SCAL   -  REAL, scale factor for block insertion.
  40. ;*    G:SETU   -  LIST, setup block names.
  41. ;*
  42. ;*    Temporary files used:
  43. ;*
  44. ;*    tempfile.$$$   -  Utility temp file
  45. ;*    tempfile.$$a   -  Surface Property/Finish names
  46. ;*    tempfile.$$[n] -  Shader parameters
  47. ;*
  48. ;*****************************************************************************
  49.  
  50. (vmon)
  51. (prompt "\n╕ⁿñJíuascommon.lspív...")
  52.  
  53. ;-----------------------------------------------------------------------------
  54. ;  2 UNIX
  55. ;
  56. ;  (#2UNIX str)   -> str
  57. ;
  58. ;  Replace all instances of "\\" to "/" in a string.
  59. ;-----------------------------------------------------------------------------
  60.  
  61. (defun #2UNIX  (
  62.  
  63.    str1        ;  Text string to convert
  64.    /
  65.    int1        ;  Number of characters
  66.    int2        ;  Current character
  67.    )
  68.  
  69. (setq int1 (1- (strlen str1))
  70.       int2 1)
  71. (if (= (substr str1 1 1) "\\")
  72.    (setq str1 (strcat "/" (substr str1 2))))
  73. (repeat int1
  74.    (setq int2 (1+ int2))
  75.    (if (= (substr str1 int2 1) "\\")
  76.       (setq str1 (strcat
  77.                (substr str1 1 (1- int2)) "/" (substr str1 (1+ int2))))))
  78. str1)
  79.  
  80. ;-----------------------------------------------------------------------------
  81. ;  Change to Layer ASHade
  82. ;
  83. ;  (#CLASH) -> nil
  84. ;
  85. ;  Changes the last entity in the database to layer "ASHADE".
  86. ;-----------------------------------------------------------------------------
  87.  
  88. (defun #CLASH  (
  89.  
  90.    /
  91.    list1       ;  Entity list of last inserted entity (INSERT)
  92.    )
  93.  
  94. (setq list1 (entget (entlast)))
  95. (if (/= (#GTVAL 8 list1) "ASHADE")
  96.    (entmod (subst (cons 8 "ASHADE") (assoc 8 list1) list1))))
  97.  
  98. ;-----------------------------------------------------------------------------
  99. ;  GeT VALue
  100. ;
  101. ;  (#GTVAL int elist) -> int/str/real
  102. ;
  103. ;  Returns the associated group code value.
  104. ;-----------------------------------------------------------------------------
  105.  
  106. (defun #GTVAL  (
  107.  
  108.    int1        ;  Group code
  109.    list1       ;  List
  110.    )
  111.  
  112. (cdr (assoc int1 list1)))
  113.  
  114. ;-----------------------------------------------------------------------------
  115. ;  Get a Point that is 3D
  116. ;
  117. ;  (#GTP3D int list str) -> list
  118. ;
  119. ;  Makes the selected point the last point, so subsequent points can be entered
  120. ;  with the "@" modifier.  int is 0/1 for null input, list is point to rubber
  121. ;  band from.
  122. ;-----------------------------------------------------------------------------
  123.  
  124. (defun #GTP3D  (
  125.  
  126.    int1        ;  Null responses
  127.    pt1         ;  Optional point to rubber-band from
  128.    str1        ;  Prompt
  129.    /
  130.    pt2         ;  Selected point
  131.    str2        ;  Setvar name
  132.    )
  133.  
  134. (initget (+ int1 24))                  ;  3D points, no limits
  135. (setq str2  (if G:R11 "lastpoint" "lastpt3d")
  136.       pt2   (if pt1
  137.                (getpoint pt1 str1)
  138.                (getpoint str1)))
  139. (if pt2
  140.    (setvar str2 pt2)))
  141.  
  142. ;-----------------------------------------------------------------------------
  143. ;  PoinT to STRing
  144. ;
  145. ;  (#PTSTR list str) -> str
  146. ;
  147. ;  Return string given delimeter and list of reals (1 or more reals.) with 6
  148. ;  decimal places of accuracy.
  149. ;-----------------------------------------------------------------------------
  150.  
  151. (defun #PTSTR  (
  152.  
  153.    pt1         ;  Point list
  154.    str1        ;  Delimiter
  155.    /
  156.    str2        ;  Point string
  157.    item1       ;  Temp
  158.    )
  159.  
  160. (setq str2 (rtos (car pt1) 2 6))
  161. (foreach item1 (cdr pt1)
  162.    (setq str2 (strcat str2 str1 (rtos item1 2 6)))))
  163.  
  164. ;-----------------------------------------------------------------------------
  165. ;  ONE PaGe listed at a time
  166. ;
  167. ;  (#1PAGE) -> T/nil
  168. ;
  169. ;  Tests for one pagefull or 15 lines, if T, prompt to continue.  If not a
  170. ;  pagefull, or if user wants to continue, return T, else nil.  COUNT from
  171. ;  calling function.
  172. ;-----------------------------------------------------------------------------
  173.  
  174. (defun #1PAGE  (
  175.  
  176.    int1        ;
  177.    /
  178.    str1        ;
  179.    )
  180.  
  181. (if (zerop (rem int1 15))
  182.    (progn
  183.       (princ "\n-- º╣ª¿½ß╜╨½÷íuÑ⌠╖Nªrñ╕ív; └└─~─≥╜╨½÷ <Return> ┴Σ --\n\n")
  184.       (setq str1 (grread))
  185.       (if (and (= (car str1) 2)
  186.                (member (cadr str1) '(32 13 10)))
  187.          T))
  188.    T))
  189.  
  190. ;-----------------------------------------------------------------------------
  191. ;  LiSt CoLoRs
  192. ;
  193. ;  (#LSCLR) -> nil
  194. ;
  195. ;  Color names in colors.txt must be lower case.  Color values in colors.txt
  196. ;  must be in range 0 to 1.
  197. ;-----------------------------------------------------------------------------
  198.  
  199. (defun #LSCLR  (
  200.  
  201.    /
  202.    file1       ;  Colors.txt
  203.    int1        ;
  204.    list1       ;
  205.    )
  206.  
  207. (cond
  208.    ((setq file1 (findfile "colors.txt"))
  209.       (textscr)
  210.       (setq file1 (open file1 "r")
  211.             int1 1)
  212.       (princ "\nRGB ªΓ▒mªCÑ▄⌐≤íuªΓ▒m└╔ív:")
  213.       (princ "\n--------------------------------\n")
  214.       (while (and (#1PAGE (setq int1 (1+ int1)))
  215.                   (setq list1 (read-line file1)))
  216.          (setq list1 (read list1))
  217.          (princ (substr (strcat (car list1) "                ") 1 16))
  218.          (princ "  ")
  219.          (princ (#PTSTR (cadr list1) " "))
  220.          (terpri))
  221.       (setq file1 (close file1)))
  222.    (T    (princ "\n*** íuªΓ▒m└╔ívñúªsªbíC"))))
  223.  
  224. ;-----------------------------------------------------------------------------
  225. ;  GeT BLocK
  226. ;
  227. ;  (#GTBLK str str list bool) -> list/nil
  228. ;
  229. ;  If retry bit is on, loop until one of the requested blocks are selected.
  230. ;  If found, print name attribute and return insert entity list, else return
  231. ;  nil.
  232. ;-----------------------------------------------------------------------------
  233.  
  234. (defun #GTBLK  (
  235.  
  236.    str1        ;  Prompt
  237.    item1       ;  Object name
  238.    str2        ;  List of valid block names
  239.    bit1        ;  Retry bit
  240.    /
  241.    bit2        ;  Requested block not selected.
  242.    list1       ;  (entsel) list
  243.    list2       ;  Valid, selected block entity list
  244.    )
  245.  
  246. (setq bit2 T)
  247. (while bit2
  248.    (setq list2 nil)
  249.    (if (setq list1 (entsel str1))
  250.       (if (and (= (#GTVAL 0 (setq list2 (entget (car list1)))) "INSERT")
  251.                (member (#GTVAL 2 list2) str2))
  252.          (setq bit2 nil)
  253.          (princ (strcat "┐∩⌐w¬║¬½┼Θñú¼░íu" item1 "ívíC")))
  254.       (if bit1
  255.          (princ "Ñ╝╡o▓{¬½┼ΘíC")
  256.          (setq bit2 nil))))
  257. (cond
  258.    (list2
  259.       (princ (#GTVAL 1 (entget (entnext (car list1)))))
  260.       list2)))
  261.  
  262. ;-----------------------------------------------------------------------------
  263. ;  GeT CoLoR from colors.txt
  264. ;
  265. ;  (#GTCLR file) -> list/nil
  266. ;
  267. ;  If a valid color name (one with an entry in colors.txt) was supplied, its
  268. ;  color is returned, else nil.
  269. ;-----------------------------------------------------------------------------
  270.  
  271. (defun #GTCLR  (
  272.  
  273.    str1        ;  FINDFILE'd name of color file.
  274.    /
  275.    file1       ;  colors.txt file handle.
  276.    str2        ;
  277.    list1       ;
  278.    bit1        ;  Requested color found
  279.    )
  280.  
  281. (if str1
  282.    (while (not bit1)
  283.       (setq str2 (strcase (getstring "\n?/├CªΓªW║┘: ") T))
  284.       (cond
  285.          ((= str2 "")   (setq bit1 T))
  286.          ((= str2 "?")  (#LSCLR))
  287.          (T (setq file1 (open str1 "r"))
  288.             (princ "\n╖j┤MíuªΓ▒m└╔ív...")
  289.             (while (and str2 (setq list1 (read-line file1)))
  290.                (setq list1 (read list1))
  291.                (if (= str2 (car list1))
  292.                   (setq str2 nil)))
  293.             (princ "done.")
  294.             (if str2
  295.                   (princ (strcat "\n*** ├CªΓ íu" (strcase str2)
  296.                                  "ívÑ╝⌐w╕q⌐≤íuªΓ▒m└╔ívññíC"))
  297.                   (setq bit1 T))
  298.             (setq file1 (close file1)))))
  299.    (prompt "\n*** íuªΓ▒m└╔ívñúªsªbíC"))
  300. (if (not str2)
  301.    (cadr list1)))
  302.  
  303. ;-----------------------------------------------------------------------------
  304. ;  GeT point in range 0-1.
  305. ;
  306. ;  (#GT0-1 str point bool) -> point/nil
  307. ;
  308. ;  Validate RGB Color triplet or Opacity triplet or any RtPoint. Given a default
  309. ;  list of three reals, return new list if all lie between 0 and 1.
  310. ;
  311. ;  bool has the following meanings:
  312. ;
  313. ;     nil   :  Values must be in range 0-1 (Light color, SPB Opacity)
  314. ;     0     :  Keywords "Use" and "-1" return '(-1 -1 -1) (SPB Color)
  315. ;     1     :  Keyword "-1" returns '(-1 -1 -1) (Shader color parameter)
  316. ;
  317. ;-----------------------------------------------------------------------------
  318.  
  319. (defun #GT0-1  (
  320.  
  321.    str1        ;  Prompt string
  322.    pt1         ;  Default value
  323.    bit1        ;  Set allowable input (see above)
  324.    /
  325.    pt2         ;  Selected color
  326.    )
  327.  
  328. (setq str1  (strcat "\nName/"          ;  Colors.txt is an option
  329.                (if (and bit1 (zerop bit1))
  330.                   "Use ACI"           ;  SPB Color
  331.                   "")                  ;  Light or shader parameter color
  332.                str1                    ;  Prompt string
  333.                (cond                   ;  There IS a default value...
  334.                   (pt1 (strcat " <" (#PTSTR pt1 ",") ">: "))
  335.                   (": "))))            ;  No default value
  336. (while (not pt2)
  337.    (initget                            ;  Set valid keywords
  338.       (cond
  339.          ((not bit1)    "Name")        ;  Light color, SPB Opacity
  340.          ((zerop bit1)  "Name Use -1") ;  SPB Color
  341.          (T             "Name -1")))   ;  Shader color parameter
  342.    (#SVRST '(("BLIPMODE" . 0)))        ;  Don't flip to graphics screen
  343.    (setq pt2 (getpoint str1))
  344.    (#SVRST 1)
  345.    (cond
  346.       ((and bit1 (or (equal pt2 '(-1 -1 -1)) (= pt2 "-1") (= pt2 "Use")))
  347.          (setq pt2 '(-1 -1 -1)))       ;  Take care of keywords
  348.       ((= pt2 "Name")
  349.          (setq pt2 (#GTCLR (findfile "colors.txt"))))
  350.       (pt2
  351.          (if (or (< (apply 'min pt2) 0.0) (> (apply 'max pt2) 1.0))
  352.             (setq pt2 (prompt "\n╝╞¡╚╜d│≥Ñ▓╢╖ñ╢⌐≤ 0 í╨ 1 ñº╢ííC"))
  353.             pt2))                      ;  Return validated triplet
  354.       (T (setq pt2   T                 ;  Use default
  355.                str1  nil)))))          ;  Exit condition for default
  356.  
  357. ;-----------------------------------------------------------------------------
  358. ;  GeT STRing
  359. ;
  360. ;  (#GTSTR str) -> str
  361. ;
  362. ;  Acquire an 8 character MAX, uppercase string.  Ignores null input and returns
  363. ;  new value.  Characters cannot be any of the following: "*+,./:;<=>?[\]|
  364. ;-----------------------------------------------------------------------------
  365.  
  366. (defun #GTSTR  (
  367.  
  368.    str1        ;  Prompt
  369.    /
  370.    str2        ;  New string
  371.    bit1        ;  Input OK
  372.    int1        ;  Counter
  373.    list1       ;  String converted to list of ASCII #
  374.    )
  375.  
  376. (while (not bit1)
  377.    (setq str2 (getstring (strcat "\n" str1 ": ")))
  378.    (cond
  379.       ((zerop (ascii str2)) nil)       ;  Ignore null input
  380.       (T (setq str2  (strcase          ;  Trim UPPER-CASE input string
  381.                      (substr str2 1 8))
  382.                int1  1
  383.                bit1  T                 ;  String is OK now...
  384.                list1 '())
  385.          (repeat (strlen str2)         ;  Create list of ASCII #
  386.             (setq list1 (cons (ascii (substr str2 int1 1)) list1)
  387.                   int1  (1+ int1)))
  388.          (foreach int1  list1          ;  Compare each character
  389.             (if (member int1
  390.                   ;  "  *  +  ,  .  /  :  ;  <  =  >  ?  [  \  ]  |
  391.                   '(34 42 43 44 46 47 58 59 60 61 62 63 91 92 93 124))
  392.                (setq bit1  nil)))      ;  Bad character found in input string
  393.          (if (not bit1)
  394.             (princ "*** íuªW║┘ív╡L«─íC")))))
  395. str2)
  396.  
  397. ;-----------------------------------------------------------------------------
  398. ;  NeXt ATTribute
  399. ;
  400. ;  (#NXATT 'entlist) -> 'entlist/nil
  401. ;
  402. ;  Get NeXt ATTribute subroutine.  Given quoted sym name of "INSERT" or "ATTRIB"
  403. ;  entity list, reassigns sym to next attribute list or returns nil if next
  404. ;  entity is not an attribute.
  405. ;-----------------------------------------------------------------------------
  406.  
  407. (defun #NXATT  (
  408.  
  409.    var1        ;  Symbol
  410.    /
  411.    item1       ;  Entity list pointed to by symbol
  412.    )
  413.  
  414. (setq item1 (eval var1)                ;  For memory's sake ...
  415.       item1 (#GTVAL -1 item1)
  416.       item1 (entget (entnext item1)))
  417. (if (= (#GTVAL 0 item1) "ATTRIB")
  418.    (set var1 item1)))
  419.  
  420. ;-----------------------------------------------------------------------------
  421. ;  ADd Surface Definition Block
  422. ;
  423. ;  (#ADSDB str int bool) -> T/nil
  424. ;
  425. ;  Add unique name to tempfile.$$a and unique ACI to #SURF0.  If bit1 is set,
  426. ;  and ACI is used, post error message and return nil.
  427. ;
  428. ;  AVE_RENDER != nil
  429. ;     If bit1 is set, we're being called from C:RMSCAN, so go ahead and
  430. ;     send this definition to averendr[.exp].  Otherwise, #INSDB already
  431. ;     has added the definition, so we don't need to here.
  432. ;-----------------------------------------------------------------------------
  433.  
  434. (defun #ADSDB  (
  435.  
  436.    str1        ;  Surface property name
  437.    int1        ;  ACI
  438.    bit1        ;  Check for duplicate ACI
  439.    /
  440.    file1       ;
  441.    )
  442.  
  443. (cond
  444.    (ave_render T) ;  #INSDB has already called PUT_SURF_INFO so we don't
  445.                   ;  need to do it here.
  446.    ((and bit1 (setq str2 (#GTSBI int1 T)))
  447.       (prompt (strcat
  448.             "\n*** ┐∙╗~: ACI-" (itoa int1) " │Qíu" str2
  449.             "ív╗Píu" str1 "ív¿Γ¬╠░╤ª╥íC")))
  450.    (T (setq #SURF0 (subst              ;  Add new ACI to list of defined
  451.                   (append (list 'LIST) (list int1) (#SURF0))
  452.                   (last #SURF0)        ;  Eval'ing #SURF0 pages it in so ...
  453.                   #SURF0)              ;  works
  454.             file1 (open (strcat
  455.                   (cond (G:SHEV) ("")) ; SHADE dir or current
  456.                   "tempfile.$$a") "a"))
  457.       (write-line str1 file1)          ;  Add new name
  458.       (setq file1 (close file1))
  459.       T)))                             ;  Return value
  460.  
  461. ;-----------------------------------------------------------------------------
  462. ;  ADd Renderman Setup Block
  463. ;
  464. ;  (#ADRSB str) -> nil
  465. ;
  466. ;  Add unique name to list of defined, or post error message and return nil.
  467. ;-----------------------------------------------------------------------------
  468.  
  469. (defun #ADRSB  (
  470.  
  471.    str1        ;  Setup name
  472.    )
  473.  
  474. (cond
  475.    ((not G:SETU)
  476.       (setq G:SETU (list str1)))
  477.    ((member str1 G:SETU)
  478.       (prompt (strcat
  479.             "\n*** ┐∙╗~: ½╪╕mªW║┘íu" str1 "ív¡½╜╞íC")))
  480.    (T (setq G:SETU (append G:SETU (list str1))))))
  481.  
  482. ;-----------------------------------------------------------------------------
  483. ;  GeT Entities CoLor
  484. ;
  485. ;  (#GTECL str) -> int
  486. ;
  487. ;  Returns the color of the selected entity.
  488. ;-----------------------------------------------------------------------------
  489.  
  490. (defun #GTECL  (
  491.  
  492.    str1        ;  Prompt
  493.    /
  494.    list1       ;  Entity list
  495.    )
  496.  
  497. (while (null (setq list1 (nentsel str1)))
  498.    (prompt "Ñ╝╡o▓{¬½┼ΘíC"))
  499. (setq list1 (entget (car list1)))
  500. (cond
  501.    ((#GTVAL 62 list1))
  502.    ((#GTVAL 62 (tblsearch "layer" (#GTVAL 8 list1))))))
  503.  
  504. ;-----------------------------------------------------------------------------
  505. ;  GeT surface Definition COlor
  506. ;
  507. ;  (#GTDCO) -> int
  508. ;
  509. ;  Get color index.  Used by C:FINISH, C:RMPROP and C:RMCOPY.
  510. ;-----------------------------------------------------------------------------
  511.  
  512. (defun #GTDCO  (
  513.  
  514.    /
  515.    int1        ;  Option keyword and ACI
  516.    str1        ;  Surface name
  517.    )
  518.  
  519. (while (not int1)
  520.    (initget 6 "Find Select")           ;  n > 0
  521.    (setq int1 (getint "\nAutoCAD ├CªΓ»┴ñ▐/S┐∩╛▄/<FºΣ┤M>: "))
  522.    (cond
  523.       ((numberp int1)
  524.          (if (> int1 255)
  525.             (setq int1 (prompt "\n  »┴ñ▐╢╖ñ╢⌐≤íu1 í╨ 255ívíC"))))
  526.       ((= int1 "Select")
  527.          (setq int1 (#GTECL
  528.                "\n  ┐∩╛▄ñw▒─Ñ╬íu├CªΓ»┴ñ▐ív¬║╣╧ñ╕: ")))
  529.       (T (while (< 255 (progn
  530.                        (initget 6)     ;  n > 0
  531.                        (setq int1
  532.                        (cond ((getint "\n  »┴ñ▐ñU¡¡ <1>: "))
  533.                              (1)))))
  534.             (prompt "\n  »┴ñ▐╢╖ñ╢⌐≤íu1í╨255ívíC"))
  535.          (while (and (#GTSBI int1 nil) (< int1 256))
  536.             (setq int1 (1+ int1)))
  537.          (if (> int1 255)
  538.             (progn
  539.                (prompt "\n  ª╣íu»┴ñ▐ív½ß╡L╛AÑ╬¬║ ACI íC")
  540.                (setq int1 -1)))))
  541.    (cond
  542.       ((or (not int1) (minusp int1))
  543.          T)
  544.       ((setq str1 (#GTSBI int1 T))
  545.          (setq int1 (prompt (strcat
  546.                "\n*** ├CªΓ»┴ñ▐ ACI-" (itoa int1) " ñwªbíu" str1
  547.                "ívññ¿╧Ñ╬; \n╕╒Ñ╬ñúªP¬║├CªΓ, ⌐╬░⌡ªµíuRMSCANív¡½╕míC"))))
  548.       (T (prompt (strcat "\n  ¿╧Ñ╬├CªΓ " (itoa int1) "íC"))
  549.          int1)))
  550. (if (minusp int1)
  551.    nil
  552.    int1))
  553.  
  554. ;-----------------------------------------------------------------------------
  555. ;  GeT Surface Block Information
  556. ;
  557. ;  (#GTSBI int/str bool) -> int/str/nil
  558. ;
  559. ;  Given int, search #SURF0 (defun'd list of defined ACI's) for matching ACI
  560. ;  and if found and bool set, return its associated name, else return T, if not
  561. ;  found return nil.
  562. ;
  563. ;  Given str, search tempfile.$$a for matching name, and if found and bool set,
  564. ;  return its associated ACI, else return T, if not found return nil.
  565. ;-----------------------------------------------------------------------------
  566.  
  567. (defun #GTSBI  (
  568.  
  569.    item1       ;  ACI or name to check
  570.    bit1        ;  Return associated item?
  571.    /
  572.    )
  573.  
  574. (if ave_render
  575.    (GET_SURF_INFO item1 bit1)          ;  Defun'ed by averendr[.exp]
  576.    (#GTSBI_ORG item1 bit1)))
  577.  
  578. ;-----------------------------------------------------------------------------
  579.  
  580. (defun #GTSBI_ORG  (
  581.  
  582.    item1       ;  ACI or name to check
  583.    bit1        ;  Return associated item?
  584.    /
  585.    bit2        ;  Name not found yet
  586.    file1       ;  tempfile.$$a (List of surface names)
  587.    list1       ;  ACI and remainder found
  588.    int1        ;  Location of name in tempfile.$$a
  589.    str1        ;  Name to return
  590.    )
  591.  
  592. (cond
  593.    ((numberp item1)                    ;  Check ACI
  594.       (setq list1 (member item1 (#SURF0)))
  595.       (if (and bit1 list1)
  596.          (setq file1 (open (strcat
  597.                      (cond (G:SHEV) ("")) ; SHADE dir or current
  598.                      "tempfile.$$a") "r")
  599.                str1  (repeat (length list1)  ;  Get to name entry..
  600.                         (read-line file1))   ;  and return name
  601.                file1 (close file1)))
  602.       (cond
  603.          ((and bit1 list1)    str1)    ;  Return and Found
  604.          (list1               T)))     ;  Found
  605.    (T (setq int1  0                    ;  Check Surface name
  606.             file1 (open (strcat
  607.                   (cond (G:SHEV) ("")) ; SHADE dir or current
  608.                   "tempfile.$$a") "r"))
  609.       (while (and (not bit2) (setq str1 (read-line file1)))
  610.          (if (= item1 str1)
  611.             (setq bit2 T)              ;  Found!
  612.             (setq int1 (1+ int1))))
  613.       (setq file1 (close file1))
  614.       (cond
  615.          ((and bit1 bit2)              ;  Found and Return.
  616.             (nth int1 (reverse (#SURF0))))
  617.          (bit2                T)))))   ;  Found
  618.  
  619. ;-----------------------------------------------------------------------------
  620. ;  GeT surface Definition NaMe
  621. ;
  622. ;  (#GTDNM str) -> str
  623. ;
  624. ;  Get unique Surface name.
  625. ;-----------------------------------------------------------------------------
  626.  
  627. (defun #GTDNM  (
  628.  
  629.    str1        ;  Prompt (including "\n")
  630.    /
  631.    str2        ;  Requested name
  632.    int1        ;  Duplicated ACI
  633.    )
  634.  
  635. (while (not str2)
  636.    (setq str2 (#GTSTR str1))
  637.    (if (setq int1 (#GTSBI str2 T))
  638.       (setq str2  (prompt (strcat
  639.                   "\n*** " (substr str1 2) "íu" str2
  640.                   "ív¿╧Ñ╬ññ (¿╧Ñ╬ ACI-" (itoa int1)
  641.                   ") íC\n╕╒Ñ╬ñúªP¬║ªW║┘, ⌐╬░⌡ªµíuRMSCANív¡½╕míC")))))
  642. str2)
  643.  
  644. ;-----------------------------------------------------------------------------
  645. ;  SHader PaRaMeters
  646. ;
  647. ;  (#SHPRM) -> nil
  648. ;
  649. ;  Supply Shader Parameters in tempfile.$$[n] to attributes.
  650. ;-----------------------------------------------------------------------------
  651.  
  652. (defun #SHPRM  (
  653.  
  654.    int1        ;  Enumerated shader type (1=light,2=disp,3=surf,4=atmo)
  655.    /
  656.    int2        ;  # Command's made (must be < 5) *OVERFLOW*
  657.    str1        ;  Composite string
  658.    str2        ;  Current parameter read.
  659.    file1       ;  Shader parameter files
  660.    )
  661.  
  662. (setq str1  ""
  663.       int2  1
  664.       file1 (open (strcat
  665.             (cond (G:SHEV) (""))    ;  SHADE dir or current
  666.             "tempfile.$$"
  667.             (itoa INT1)) "r"))
  668. (while (and (< int2 5)                       ;  Attrib slots are available &
  669.             (setq str2 (read-line file1)))   ;  we have more parameters ...
  670.    (if (< (+ (strlen str1) (strlen str2)) 256)  ;  Is there room?
  671.       (setq str1 (strcat str1 str2))   ;  Add strings
  672.       (progn                           ;  Otherwise supply value, and re-start
  673.          (command str1)                ;  Supply parameters
  674.          (setq int2  (1+ int2)         ;  Bump "command" counter
  675.                str1  str2))))          ;  Reset string.
  676. (setq file1 (close file1))             ;  Close parameter file
  677. (cond                                  ;  Finish up ...
  678.    ((and (= int2 5)                    ;  All attrib slots taken and
  679.          (> (strlen str1) 0))          ;  we have more parameters ...
  680.       (prompt "\n*** íu┤y╝v╡{ªí░╤╝╞ív╢W╖╕íC"))
  681.    ((> (strlen str1) 0)                ;  We have some parameters left
  682.       (command str1)                   ;  Supply them
  683.       (repeat (- 4 int2)
  684.          (command "")))
  685.    (T (repeat (- 5 int2)
  686.          (command "")))))
  687.  
  688. ;-----------------------------------------------------------------------------
  689. ;  Read NULlsurf Parameters
  690. ;
  691. ;  (#RNULP) -> LIST
  692. ;
  693. ;  For averendr[.exp].  Read the parameters for the FINISH, and return
  694. ;  them as a list.
  695. ;-----------------------------------------------------------------------------
  696.  
  697. (defun #RNULP  (
  698.  
  699.    /
  700.    list1       ;  Current parameter list
  701.    list2       ;  Temporary list
  702.    int1        ;  Count
  703.    str1        ;  Current parameter read
  704.    file1       ;  Shader parameter files
  705.    )
  706.  
  707. (setq int1  0
  708.       file1 (open (strcat
  709.             (cond (G:SHEV) (""))    ;  SHADE dir or current
  710.             "tempfile.$$3") "r")
  711.       list1 (list (float (read (caddr (read (read-line file1)))))))  ;  Grab Ka
  712. (while (setq str1 (read-line file1))   ;  We have more parameters ...
  713.    (setq list2 (read str1)             ;  Convert to list
  714.          list1 (append list1 (list (float (read (caddr list2)))))))
  715. (setq file1 (close file1))             ;  Close parameter file
  716. list1)                                 ;  Return parameters.
  717.  
  718. ;-----------------------------------------------------------------------------
  719. ;  INsert Surface Definition Block
  720. ;
  721. ;  (#INSDB) -> nil
  722. ;
  723. ;  Insert Surface Property/Finish block ("RM_SDB") routine.
  724. ;
  725. ;  AVE_RENDER != nil
  726. ;     Send this new SPB definition to averendr[.exp]
  727. ;-----------------------------------------------------------------------------
  728.  
  729. (defun #INSDB  (/ list1)
  730.  
  731. (command "_.insert"
  732.          "rm_sdb"
  733.          inspt
  734.          (eval G:SCAL)
  735.          ""
  736.          "<<0"                         ;  No Rotation
  737.          att1                          ;  Surface Property name
  738.          att2                          ;  ACAD Color Index (int)
  739.          (#PTSTR att3 ",")             ;  RGB Color
  740.          (#PTSTR att4 ",")             ;  Opacity
  741.                                        ;  Surface Shader
  742.          (strcat "(\"" (car att5) "\" \"" (cadr att5) "\")"))
  743. (#SHPRM 3)                             ;  Surface Parameters
  744. (command (rtos att7 2 6)               ;  Shading Rate
  745.                                        ;  Displacement Shader
  746.          (strcat "(\"" (car att8) "\" \"" (cadr att8) "\")"))
  747. (#SHPRM 2)                             ;  Displacement Parameters
  748. (command (rtos att10 2 6)              ;  Displacement Bounds
  749.          att11                         ;  Smooth meshes
  750.                                        ;  Atmosphere Shader
  751.          (strcat "(\"" (car att12) "\" \"" (cadr att12) "\")"))
  752. (#SHPRM 4)                             ;  Atmosphere Parameters
  753. (command (#PTSTR (append pt1 pt2 pt3 pt4) " ")) ;  Texture Coordinate
  754. (#CLASH)
  755.  
  756. (if ave_render                         ;  Send the definition to Render
  757.    (if (= (car att5) "nullsurf")
  758.       (apply 'PUT_SURF_INFO (append (list att1 att2) (#RNULP)))
  759.       (PUT_SURF_INFO att1 att2))))     ;  Non-Finish
  760.  
  761. ;-----------------------------------------------------------------------------
  762. ;  Surface Block DeFauLt
  763. ;
  764. ;  (#SBDFL) ->
  765. ;
  766. ;  Sets the default values for all attributes of the Surface block.
  767. ;-----------------------------------------------------------------------------
  768.  
  769. (defun #SBDFL  ( / file1)
  770.  
  771. ;  Initionalize parameter files...
  772. (close (open (strcat (cond (G:SHEV) ("")) "tempfile.$$2") "w"))   ;  Disp
  773. (close (open (strcat (cond (G:SHEV) ("")) "tempfile.$$4") "w"))   ;  Atmo
  774. (setq file1 (open (strcat              ;  Surf
  775.             (cond (G:SHEV) (""))       ;  SHADE dir or current.
  776.             "tempfile.$$3") "w"))
  777. (prin1 (list 11 "Ka" "0.30") file1)    ;  No leading blank line
  778. (print (list 11 "Kd" "0.70") file1)    ;  But add here...
  779. (print (list 11 "Ks" "0.00") file1)
  780. (print (list 11 "roughness" "0.10") file1)
  781. (setq file1    (close file1)
  782.       att3     '(-1.0 -1.0 -1.0)       ;  RGB Color
  783.       att4     '(1.0 1.0 1.0)          ;  Opacity
  784.       att5     '("nullsurf" "")        ;  Surface Shader
  785.       att7     -1.0                    ;  Shading Rate
  786.       att8     '("nulldisp" "")        ;  Displacement Shader
  787.       att10    0                       ;  Displacement Bounds
  788.       att11    0                       ;  Smooth Surface
  789.       att12    '("" "")                ;  Atmosphere Shader
  790.       pt1      '(0 0)                  ;  Texture Coordinates
  791.       pt2      '(1 0)                  ;  ""
  792.       pt3      '(0 1)                  ;  ""
  793.       pt4      '(1 1)                  ;  ""
  794. ))
  795.  
  796. ;-----------------------------------------------------------------------------
  797. ;  SCAN for surface Property blocks
  798. ;
  799. ;  (#SCANP) -> nil
  800. ;
  801. ;  Scan the drawing for Surface Property/Finish blocks and initialize
  802. ;  tempfile.$$a with the names, and #SURF0 with the ACI's.
  803. ;-----------------------------------------------------------------------------
  804.  
  805. (defun #SCANP  ()
  806.  
  807. (defun #SURF0  () (list))              ;  Let's re-defun #SURF0 ...
  808. (setq file1    (close (open (strcat    ;  Dump current contents
  809.                (cond (G:SHEV) (""))    ;  SHADE dir or current
  810.                "tempfile.$$a") "w"))
  811.       int1     0
  812.       int2     0
  813.       sset1    (if (tblsearch "BLOCK" "RM_SDB")
  814.                   (ssget "x" '((0 . "INSERT") (2 . "RM_SDB"))))
  815.       list1    (if sset1
  816.                   (entget (ssname sset1 0)))
  817.       real1    (cond
  818.                   (G:SCAL)             ;  Keep user scale
  819.                   (list1 (#GTVAL 41 list1))))
  820. (if list1
  821.    (repeat (sslength sset1)
  822.       (setq str1 (#GTVAL 1 (#NXATT 'list1))           ;  "" if null ...
  823.             int2 (atoi (#GTVAL 1 (#NXATT 'list1))))   ;  0 if null ...
  824.       (if (equal str1 "") (setq str1 nil))   ;  so set to nil
  825.       (if (zerop int2) (setq int2 nil))      ;  so set to nil
  826.       (if (or (not str1) (not int2))
  827.          (progn
  828.             (prompt "\n*** ┐∙╗~:íu¬φ¡▒╣╧╕sív║|»╩íuªW║┘ív⌐M/⌐╬ ACI íC")
  829.             (setq bit1 T)))
  830.       (if (and str1 int2)
  831.          (if (not (#ADSDB str1 int2 T))
  832.             (setq bit1 T)))
  833.       (setq list1 (ssname sset1 (setq int1 (1+ int1)))
  834.             list1 (if list1 (entget list1))))))
  835.  
  836. ;-----------------------------------------------------------------------------
  837. ;  SCAN for Setup blocks
  838. ;
  839. ;  (#SCANP) -> nil
  840. ;
  841. ;  Scan the drawing for RenderMan Setup blocks and initialize G:SURF with the
  842. ;  names.
  843. ;-----------------------------------------------------------------------------
  844.  
  845. (defun #SCANS  ()
  846.  
  847. (setq G:SETU   nil
  848.       int1     0
  849.       int2     0
  850.       sset1    (if (tblsearch "BLOCK" "RM_RCB")
  851.                   (ssget "x" '((0 . "INSERT") (2 . "RM_RCB"))))
  852.       list1    (if sset1
  853.                   (entget (ssname sset1 0)))
  854.       real1    (cond
  855.                   (real1)
  856.                   (list1 (#GTVAL 41 list1))))
  857. (if list1
  858.    (repeat (sslength sset1)
  859.       (setq str1 (#GTVAL 1 (#NXATT 'list1)))
  860.       (if (equal str1 "") (setq str1 nil))
  861.       (if (not str1)
  862.          (progn
  863.             (prompt "\n*** ┐∙╗~: íu½╪╕m╣╧╕sív╡uñ╓íuªW║┘ívíC")
  864.             (setq bit1 T))
  865.          (if (not (#ADRSB str1))
  866.             (setq bit1 T)))
  867.       (setq list1 (ssname sset1 (setq int1 (1+ int1)))
  868.             list1 (if list1 (entget list1))))))
  869.  
  870. ;-----------------------------------------------------------------------------
  871. ;  RenderMan SCAN
  872. ;
  873. ;  (C:RMSCAN) ->
  874. ;
  875. ;  Scan drawing and initialize Surface name (tempfile.$$a), ACI (#SURF0), and
  876. ;  RenderMan Setup name (G:SETU) lists for uniqueness verification.  Also sets
  877. ;  the default Block Scale Factor (G:SCAL), and RenderMan prompting mode
  878. ;  (G:RMAN).
  879. ;-----------------------------------------------------------------------------
  880.  
  881. (defun C:RMSCAN   ( /   #ERROR int1 int2 sset1 list1 str1 real1 bit1)
  882.  
  883. (#HEAD (#SVINS))
  884. (prompt "\n╖j┤MíuAutoShadeív╣╧╕s...")
  885. (if (not ave_render)                   ;  Don't need to w/ Render loaded.
  886.    (#SCANP))                           ;  Scan for Surface blocks
  887. (#SCANS)                               ;  Scan for Setup blocks
  888. (if (not real1)                        ;  No block scale yet
  889.    (foreach item1 '("CAMERA" "OVERHEAD" "DIRECT" "SH_SPOT")
  890.       (if (not real1)
  891.          (if (tblsearch "BLOCK" item1)
  892.             (if (setq sset1 (ssget "x" (list '(0 . "INSERT") (cons 2 item1))))
  893.                (setq real1 (#GTVAL 41 (entget (ssname sset1 0)))
  894.                      sset1 nil))))))   ;  Reclaim selection set
  895. (setq G:SCAL (if real1                 ;  Set the block scale
  896.             real1
  897.             '(setq G:SCAL (/ (getvar "viewsize") 10.0))))
  898. (if G:SETU     (setq G:RMAN T))        ;  If RCB's exist then G:RMAN yes!
  899. (if (not bit1) (prompt "º╣ª¿íC"))
  900. (setq sset1 nil)                       ;  Reclaim selection set
  901. (#TAIL))
  902.  
  903. ;-----------------------------------------------------------------------------
  904. ;  AutoShade SCAle factor for blocks
  905. ;
  906. ;  (#ASSCA) -> list
  907. ;
  908. ;  Sets the scale factor for block insertion and echos factor.
  909. ;-----------------------------------------------------------------------------
  910.  
  911. (defun #ASSCA  (
  912.  
  913.    /
  914.    bit1        ;  Valid block selected?
  915.    list1       ;  Entity list
  916.    str1        ;  Prompt
  917.    real1       ;  Scale
  918.    )
  919.  
  920. (initget 6 "Select")                   ;  n > 0
  921. (setq str1  (strcat
  922.             "\nS┐∩╛▄/AutoShade ╣╧╕síuñ±¿╥½Y╝╞ív"
  923.             (if (listp G:SCAL)
  924.                ": "
  925.                (strcat " <" (rtos G:SCAL 2 2) ">: ")))
  926.       real1 (getreal str1))
  927. (cond
  928.    ((= real1 "Select")                 ;  Set scale by selection
  929.       (while (not bit1)
  930.          (setq list1 (entsel "\nÑH╣w┤┴ñ±¿╥¿╙┐∩╛▄íuAutoShade ╣╧╕sív: "))
  931.          (cond
  932.             (list1                     ;  We picked something ...
  933.                (setq list1 (entget (car list1)))
  934.                (if (= (#GTVAL 0 list1) "INSERT")
  935.                   (cond                ;  What type of INSERT?
  936.                      ((member (#GTVAL 2 list1)
  937.          '("CAMERA" "OVERHEAD" "DIRECT" "SH_SPOT" "RM_SDB" "RM_RCB"))
  938.                         (setq bit1 T)) ;  and it's valid
  939.                      ((member (#GTVAL 2 list1) '("CLAPPER" "SHOT"))
  940.                         (prompt "ñúªX▓z¬║íuAutoShade ╣╧╕sívíC"))
  941.                      (T (prompt "ñú¼OíuAutoShade ╣╧╕sívíC")))
  942.                   (prompt "ñú¼OíuAutoShade ╣╧╕sívíC")))
  943.             (T (prompt "Ñ╝╡o▓{¬½┼ΘíC"))))
  944.       (setq G:SCAL (princ (#GTVAL 41 list1))))  ;  Get the scale from the block
  945.    (real1                              ;  Set scale
  946.       (setq G:SCAL real1))))
  947.  
  948. ;-----------------------------------------------------------------------------
  949. ;  AutoShade PROmpting
  950. ;
  951. ;  (#ASPRO) -> list/nil
  952. ;
  953. ;  Changes the mode in effect for RenderMan prompting. (rman)
  954. ;-----------------------------------------------------------------------------
  955.  
  956. (defun #ASPRO  (
  957.  
  958.    /
  959.    str1        ;
  960.    )
  961.  
  962. (initget "Yes No")
  963. (setq str1  (getkword (strcat
  964.             "\n¼░íuRenderMan ─▌⌐╩ívÑ[ñW┤úÑ▄?  "
  965.             (if G:RMAN "No/<Yes" "Yes/<No")
  966.             ">: ")))
  967. (if str1
  968.    (setq G:RMAN (cond
  969.                ((= str1 "Yes")   T)
  970.                ((= str1 "No")    nil)))))
  971.  
  972. ;-----------------------------------------------------------------------------
  973. ;  AutoShade RESiZe blocks
  974. ;
  975. ;  (#ASRES) -> nil
  976. ;
  977. ;  All AutoShade/RenderMan blocks except CLAPPER and SHOT are rescaled to the
  978. ;  current scale factor (G:SCAL).
  979. ;-----------------------------------------------------------------------------
  980.  
  981. (defun #ASRES  (
  982.  
  983.    /
  984.    sset1       ;  Combined selection set
  985.    sset2       ;  Interim selection set
  986.    real1       ;  Scale factor
  987.    item1       ;  Block name to resize
  988.    int1        ;  Selection set counter
  989.    int2        ;  # blocks to scale
  990.    str1        ;  Partial prompt string
  991.    list1       ;  Entity list
  992.    )
  993.  
  994. (setq sset1 (ssadd)
  995.       real1 (if (listp G:SCAL)   ;  Don't set the scale here!
  996.                (/ (getvar "viewsize") 10.0)
  997.                G:SCAL))
  998. (princ "\n╢░╡▓íuAutoShade ╣╧╕sív...")
  999. (foreach item1 '("CAMERA" "OVERHEAD" "DIRECT" "SH_SPOT" "RM_SDB" "RM_RCB")
  1000.    (if (setq   int1  -1
  1001.                sset2 nil
  1002.                sset2 (ssget "x" (list '(0 . "INSERT") (cons 2 item1))))
  1003.       (repeat (sslength sset2)
  1004.          (ssadd (ssname sset2 (setq int1 (1+ int1))) sset1))))
  1005. (princ "done.\n")
  1006. (setq int1    0
  1007.       int2   (sslength sset1)
  1008.       str1   (strcat " of " (itoa int2) ".\r")) ;  Stay on same line
  1009. (#SVRST '(("BLIPMODE" . 0) ("HIGHLIGHT" . 0)))
  1010. (repeat int2                           ;  Resize each block
  1011.    (setq list1 (entget (ssname sset1 int1)))
  1012.    (princ (strcat "¡½╜╒íu╣╧╕sívñ╪ño " (itoa (setq int1 (1+ int1))) str1))
  1013.    (command "_.scale"                  ;  ENTMOD no good here: attrib's
  1014.                (#GTVAL -1 list1)       ;  Entity name
  1015.                ""
  1016.                (trans (#GTVAL 10 list1) (#GTVAL -1 list1) 1)
  1017.                (/ real1 (#GTVAL 41 list1))))
  1018. (#SVRST 2))
  1019.  
  1020. ;-----------------------------------------------------------------------------
  1021. ;  Main operating mode defaults.
  1022. ;-----------------------------------------------------------------------------
  1023.  
  1024. (defun C:DEFAULTS ( /   #ERROR str1)
  1025.  
  1026. (#HEAD (#SVINS))
  1027. (initget "Resize Scale Prompts")
  1028. (setq str1 (getkword "\nR¡½╜╒íuAutoShade ╣╧╕sív/Sñ±¿╥/<P┤úÑ▄>: "))
  1029. (cond
  1030.    ((= str1 "Resize")   (#ASRES))
  1031.    ((= str1 "Scale")    (#ASSCA))
  1032.    (T                   (#ASPRO)))
  1033. (#TAIL))
  1034.  
  1035. ;-----------------------------------------------------------------------------
  1036. ;  AutoShade and RenderMan ERRor function
  1037. ;
  1038. ;  (#ASERR str) -> nil
  1039. ;
  1040. ;  Set by #HEAD.
  1041. ;-----------------------------------------------------------------------------
  1042.  
  1043. (defun #ASERR  (
  1044.  
  1045.    str1        ;
  1046.    )
  1047.  
  1048. (cond
  1049.    ((= str1 "console break")
  1050.       (princ "* ¿·«° *"))
  1051.    ((/= str1 "Function cancelled")  ;  CTRL-C is not an error, all others are.
  1052.       (prompt (strcat "\n┐∙╗~: " str1))))
  1053. (command)                           ;  DVIEW
  1054. (command "_.undo" "_end" "_.undo" "1") ;  Reset drawing environment.
  1055. (if (= (type file1) 'FILE)          ;  shaders.txt & colors.txt always
  1056.    (setq file1 (close file1)))      ;     referred to as 'FILE1'.
  1057. (if (= (type file2) 'FILE)          ;  Parameter and temp files either file1
  1058.    (setq file2 (close file2)))      ;     or file2.
  1059. (#SVRST G:MODE)                     ;  Restore System Variables.
  1060. (setq *error*  #ERROR)              ;  Restore old *error* handler.
  1061. (foreach item1 '(                   ;  Unbind ALL variables.
  1062.  
  1063.    G:MODE
  1064.    ang1 ang2 ang3
  1065.    att1 att2 att3 att4 att5 att6 att7 att8 att9 att10 att11 att12 att13 att14
  1066.    bit1 bit2 bit3
  1067.    int1 int2 int3 int4
  1068.    inspt
  1069.    item1 item2
  1070.    list1 list2 list3
  1071.    pt1 pt2 pt3 pt4
  1072.    real1 real2 real3 real4 real5 real6
  1073.    sset1 sset2
  1074.    str1 str2 str3 str4 str5 str6
  1075.    var1 var2
  1076.    x1 y1 x2 y2 x3 y3 x4 y4
  1077.    x1_2  x1_3  x1_4  x2_3  x2_4  x3_4  y1_2  y1_3  y1_4  y2_3  y2_4  y3_4
  1078.  
  1079.                )
  1080.    (set item1 nil))
  1081. (gc)                                ;  Force Garbage Collection.
  1082. (princ))                            ;  Exit quietly.
  1083.  
  1084. ;-----------------------------------------------------------------------------
  1085. ;  SaVe and ReSTore system variables.
  1086. ;
  1087. ;  (#SVRST list/int) -> int/str
  1088. ;
  1089. ;  The global G:MODE has the form:
  1090. ;
  1091. ;     ((<sysvar name> . <value>) (...) ...)
  1092. ;
  1093. ;  If the argument is an integer, POP that many system variable settings.
  1094. ;  If the argument is a list, save their settings into G:MODE, and set.
  1095. ;-----------------------------------------------------------------------------
  1096.  
  1097. (defun #SVRST  (
  1098.  
  1099.    item1       ;  SysVar list to set, or # to POP
  1100.    /
  1101.    list1       ;
  1102.    str1        ;
  1103.    )
  1104.  
  1105. (cond
  1106.    ((numberp item1)                    ;  POP this many settings
  1107.       (repeat item1
  1108.          (setvar (caar G:MODE) (cdar G:MODE))
  1109.          (setq G:MODE (cdr G:MODE))))  ;  Remove from list
  1110.    (T (foreach list1 item1             ;  PUSH these vars onto the stack
  1111.          (setq str1     (car list1)
  1112.                G:MODE   (append (list (cons str1 (getvar str1))) G:MODE))
  1113.          (setvar str1 (cdr list1))))))
  1114.  
  1115. ;-----------------------------------------------------------------------------
  1116. ;  Set operating modes used whilst accessing our blocks
  1117. ;
  1118. ;  (#SVINS) -> list
  1119. ;
  1120. ;  This are the system variables that need to be set when inserting blocks with
  1121. ;  attributes.
  1122. ;-----------------------------------------------------------------------------
  1123.  
  1124. (defun #SVINS  ()
  1125.  
  1126. '( ("ATTDIA"    . 0)
  1127.    ("ATTMODE"   . 1)
  1128.    ("ATTREQ"    . 1)
  1129.    ("CMDECHO"   . 0)
  1130.    ("EXPERT"    . 1)
  1131.    ("FLATLAND"  . 0)
  1132.    ("LIMCHECK"  . 0)))
  1133.  
  1134. ;-----------------------------------------------------------------------------
  1135. ;  HEAD and TAIL functions for each C:xxxx function.
  1136. ;
  1137. ;  (#HEAD) -> nil
  1138. ;  (#TAIL) ->
  1139. ;
  1140. ;  #HEAD sets the AutoShade *error* function, system variables and UNDO GROUP.
  1141. ;  #TAIL restores the *error* function, system variables and ENDs the UNDO.
  1142. ;-----------------------------------------------------------------------------
  1143.  
  1144. (defun #HEAD   (
  1145.  
  1146.    list1       ;  List of SysVars to set
  1147.    )
  1148. (setq #ERROR   *error*                 ;  Trap old *error* function.
  1149.       *error*  #ASERR                  ;  Install AutoShade *error* function.
  1150.       G:MODE    '())
  1151. (#SVRST list1)
  1152. (command "_.undo" "_group"))           ;  UNDO must be set to ALL.
  1153.  
  1154. ;-----------------------------------------------------------------------------
  1155.  
  1156. (defun #TAIL   ()
  1157. (command "_.undo" "_end")              ;  Make function's effects one command.
  1158. (#SVRST G:MODE)                        ;  Restore System Variables.
  1159. (setq *error*  #ERROR                  ;  Reset old *error* function.
  1160.       G:MODE   '())
  1161. (princ))
  1162.  
  1163. ;-----------------------------------------------------------------------------
  1164. ;  LiSt RenderMan Blocks (revised for averendr[.exp])
  1165. ;
  1166. ;  (#LSRMB bool) -> nil
  1167. ;
  1168. ;  List currently defined RenderMan blocks from (C:FINISH "P")
  1169. ;-----------------------------------------------------------------------------
  1170.  
  1171. (defun #LSRMB  (
  1172.  
  1173.    bit1        ;  List RenderMan Setup blocks?
  1174.    /
  1175.    int1        ;  Current line number
  1176.    int2        ;  Current item
  1177.    int3        ;  String length
  1178.    list1       ;  List of SPB definitions from (C:FINISH "P")
  1179.    item1       ;  Current block information.
  1180.    file1       ;  tempfile.$$a - List of SPB names
  1181.    )
  1182.  
  1183. (setq int1  3
  1184.       int2  0)
  1185. (if bit1
  1186.    (cond
  1187.       (G:SETU
  1188.          (textscr)
  1189.          (princ "\n⌐w╕qíu½╪╕m╣╧╕sív:\n  ªW║┘\n--------\n")
  1190.          (while (and (setq item1 (nth int2 G:SETU)) (#1PAGE int1))
  1191.             (princ item1)
  1192.             (terpri)
  1193.             (setq int1  (1+ int1)
  1194.                   int2  (1+ int2))))
  1195.       (T (princ "\nÑ╝⌐w╕qíu½╪╕m╣╧╕sívíC"))))
  1196. (setq int2  1)
  1197. (if ave_render
  1198.    (if (setq list1 (cdr (C:FINISH "P")))
  1199.       (progn
  1200.          (princ "\n⌐w╕qíu¬φ¡▒╣╧╕sív:\n  ªW║┘  \n--------\n")
  1201.          (foreach item1 list1
  1202.             (#1PAGE int1)
  1203.             (princ item1)
  1204.             (terpri)
  1205.             (setq int1  (1+ int1)
  1206.                   int2  (1+ int2))))
  1207.       (princ "\nÑ╝⌐w╕qíu¬φ¡▒╣╧╕sívíC"))
  1208.    (if (#SURF0)
  1209.       (progn
  1210.          (textscr)
  1211.          (princ "\n⌐w╕qíu¬φ¡▒╣╧╕sív:\n  ªW║┘    ACI\n-------- -----\n")
  1212.          (setq file1 (open (strcat
  1213.                      (cond (G:SHEV) (""))    ; SHADE dir or current
  1214.                      "tempfile.$$a") "r"))
  1215.          (foreach item1 (reverse (#SURF0))
  1216.             (#1PAGE int1)
  1217.             (princ (substr (strcat (read-line file1) "             ")
  1218.                   1 (- 13 (strlen (itoa item1)))))
  1219.             (princ item1)
  1220.             (terpri)
  1221.             (setq int1  (1+ int1)
  1222.                   int2  (1+ int2)))
  1223.          (setq file1 (close file1)))
  1224.    (princ "\nÑ╝⌐w╕qíu¬φ¡▒╣╧╕sívíC"))))
  1225.  
  1226. ;*****************************************************************************
  1227.  
  1228. (prompt "ñw╕ⁿñJíC")
  1229.  
  1230. ;-----------------------------------------------------------------------------
  1231. ;  Make layer "ASHADE" if it doesn't exist.
  1232. ;-----------------------------------------------------------------------------
  1233. (if (not (tblsearch "layer" "ashade"))
  1234.    (progn
  1235.       (#HEAD '(("CMDECHO" . 0)))
  1236.       (command "_.layer" "_n" "ashade" "")
  1237.       (#TAIL)))
  1238.  
  1239. ;-----------------------------------------------------------------------------
  1240. ;  Initialize global variables.
  1241. ;-----------------------------------------------------------------------------
  1242. (if (setq str1 (getenv "SHADE"))       ;  If environment variable is set to a
  1243.    (if (setq file1 (open (strcat str1 "/tempfile.$$$") "a"))   ;  valid path
  1244.       (setq file1    (close file1)     ;  then use it.
  1245.             G:SHEV   (#2UNIX (strcat str1 "/")))))
  1246. (setq str1  nil
  1247.       G:R11 (if (getvar "TILEMODE") T))
  1248. (if (null G:SCAL) (C:RMSCAN))
  1249. ;  C:RMATTACH and C:RMLIST now will report that none exist...
  1250. (if ave_render
  1251.    (defun #SURF0  () (list)))          ;  Let's re-defun #SURF0 ...
  1252.  
  1253. (prin1)
  1254.