home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 13 / 13.iso / p / p065 / 4.img / PLV.LSP < prev    next >
Encoding:
Text File  |  1991-05-23  |  2.4 KB  |  66 lines
  1. (defun plverr(s)
  2.    (if (/= s "Function cancelled")
  3.        (princ (strcat "\nError:" s))
  4.    )
  5.    (command "layer" "s" "0" "")
  6.    (setvar "cmdecho" 1)
  7.    (setq *error* oer)
  8.    (princ)
  9. )
  10. (defun C:PLV(/ oer x insp insn ss wl hl ssl sn en sn1 en1 ins hgt n n1 xx ymin base insh)
  11.    (setvar "CMDECHO" 0)
  12.    (setq oer *error* *error* plverr)
  13.    (initget "Right Left")
  14.    (setq fg (getkword "\n╤í╘±▒Ω╘┌╫≤▒▀,╙╥▒▀ (Left or Right):"))
  15.    (if (= fg "Right") (setq fg "R") (setq fg "L"))
  16.    (princ "\n╡┌╥╗╕÷┤░╠¿╕▀╢╚ <")
  17.    (princ 900)
  18.    (setq wdh (if (setq x (getreal ">:")) x 900.0))
  19.    (setq insp (getpoint "\n▒Ω╕▀╖√║┼▓σ╚δ╡π:"))
  20.    (command "layer" "m" "sdim" "")
  21.    (setq ss (ssget) wl nil hl nil)
  22.    (if ss (progn
  23.      (setq ssl (sslength ss) n 0 n1 0)
  24.      (repeat ssl
  25.        (setq sn (ssname ss n) en (entget sn))
  26.        (if (and (= "INSERT" (cdr (assoc 0 en))) (= "SWINDOW" (cdr (assoc 8 en))))
  27.        (progn
  28.        (setq sn1 (entnext sn) en1 (entget sn1))
  29.        (setq rn (cdr (assoc 1 en1)) ww nil)
  30.        (setq loop t)
  31.        (while loop
  32.           (setq ll (instr 1 rn " "))
  33.           (if (= ll 0) (setq ww (cons rn ww) loop nil)
  34.              (progn ;else
  35.              (setq r1 (substr rn 1 (1- ll)))
  36.              (setq ww (cons r1 ww))
  37.              (setq rn (substr rn (1+ ll) (- (strlen rn) ll)))
  38.              (setq loop t)
  39.              )
  40.           )
  41.        )
  42.        (setq hgt (atoi (nth 1 ww)) wh (atoi (nth 0 ww)))
  43.        (setq ins (cdr (assoc 10 en)))
  44.        (setq wl (cons (list (- (cadr ins) (/ hgt 2)) n1) wl) hl (cons hgt hl))
  45.        (setq n1 (1+ n1))
  46.        )) ;if
  47.        (setq n (1+ n))
  48.      )
  49.      (setq n 0)
  50.      (repeat (length wl)
  51.         (setq ymin (apply 'min (mapcar 'car wl)))
  52.         (setq x (assoc ymin wl) xx (cadr x) hgt (nth xx hl))
  53.         (if (= n 0) (setq base (- ymin wdh)))
  54.         (setq wl (subst (list 1000000.0 0) x wl))
  55.         (setq ins (list (car insp) ymin) insh (list (car ins) (+ (cadr ins) hgt)))
  56.         (command "insert" (strcat "ELU" fg) ins (/ (getvar "USERR1") 100.0) "" "0" (rtos (/ (fix (+ 0.005 (- (cadr ins) base))) 1000.0) 2 3))
  57.         (command "insert" (strcat "ELD" fg) insh (/ (getvar "USERR1") 100.0) "" "0" (rtos (/ (fix (+ 0.005 (- (cadr insh) base))) 1000.0) 2 3))
  58.         (setq n (1+ n))
  59.       )
  60.     ))
  61.     (command "layer" "s" "0" "")
  62.     (setvar "CMDECHO" 1)
  63.     (setq *error* oer)
  64.     (princ)
  65. )
  66.