home *** CD-ROM | disk | FTP | other *** search
/ Share Gallery 1 / share_gal_1.zip / share_gal_1 / GR / GR506.ZIP / ETEXT.EXE / ETEXT.LSP < prev    next >
Lisp/Scheme  |  1987-02-04  |  5KB  |  185 lines
  1. ];  ETEXT - ver 2.0       Aug 26, 1987.
  2. ;  author: Terence Puls.
  3. ;
  4. (defun getspu ()
  5.        (setq cs (- lw 65))
  6.        (setq cz 0)
  7.    (while (<= cz cs)
  8.       (setq cg (read-line fl)) 
  9.       (setq cz (1+ cz))
  10. ))
  11. (defun getspl ()
  12.       (setq cs (- lw 97))
  13.       (setq cz 0)
  14.    (while (<= cz cs)
  15.       (setq cg (read-line fl))
  16.       (setq cz (1+ cz))
  17. ))
  18. (defun ucase ()
  19.       (if (= l2 "A")
  20.       (setq fl (open "etext.gu0" "r"))
  21.  ) 
  22.  (if (/= nil (member l2 '("B" "D" "E" "F" "H" "I" "K" "L" "M" "N" "P" "R")))
  23.      (setq fl (open "etext.gu1" "r"))
  24.  )        
  25.   (if (/= nil (member l2 '("C" "G" "O" "Q")))
  26.       (setq fl (open "etext.gu2" "r"))
  27.  )
  28.       (if (= l2 "J")
  29.       (setq fl (open "etext.gu3" "r"))
  30.  )
  31.       (if (= l2 "S")
  32.       (setq fl (open "etext.gu4" "r"))
  33.  )
  34.       (if (= l2 "T")
  35.       (setq fl (open "etext.gu5" "r"))
  36.  )
  37.       (if (= l2 "U")
  38.       (setq fl (open "etext.gu6" "r"))
  39.  )
  40.       (if (= l2 "V")
  41.       (setq fl (open "etext.gu7" "r"))
  42.  )
  43.       (if (= l2 "W")
  44.       (setq fl (open "etext.gu8" "r"))
  45.  )
  46.       (if (= l2 "X")
  47.       (setq fl (open "etext.gu9" "r"))
  48.  )
  49.       (if (= l2 "Y")
  50.       (setq fl (open "etext.gua" "r"))
  51.  )
  52.       (if (= l2 "Z")
  53.       (setq fl (open "etext.gub" "r"))                   
  54.  )
  55. (getspu)
  56. (close fl)
  57. ; insp
  58. )
  59. (defun ulcase ()
  60.          (if (/= nil (member l2 '("a" "c" "d" "e" "g" "o" "q")))
  61.          (setq fl (open "etext.g0" "r"))
  62.  )
  63.          (if (/= nil (member l2 '("b" "h" "i" "k" "l" "m" "n" "p" "r" "u")))
  64.          (setq fl (open "etext.g1" "r"))
  65.  )
  66.          (if (/= nil (member l2 '("f" "w")))
  67.          (setq fl (open "etext.g2" "r"))
  68.  )
  69.          (if (= l2 "j")
  70.          (setq fl (open "etext.g3" "r"))
  71.  )
  72.          (if (/= nil (member l2 '("s" "t")))
  73.          (setq fl (open "etext.g4" "r"))
  74.  )
  75.          (if (/= nil (member l2 '("v" "y")))
  76.          (setq fl (open "etext.g5" "r"))
  77.  )
  78.          (if (= l2 "x")
  79.          (setq fl (open "etext.g6" "r"))
  80.  )
  81.          (if (= l2 "z")
  82.          (setq fl (open "etext.g7" "r"))
  83.  )
  84. (getspu)
  85. (close fl)
  86. ;insp
  87. )
  88. (defun lcase ()                 
  89.          (if (/= nil (member l2 '("a" "c" "d" "e" "g" "o" "q")))
  90.          (setq fl (open "etext.gl0" "r"))
  91.  )
  92.          (if (/= nil (member l2 '("b" "h" "i" "k" "l" "m" "n" "p" "r" "u")))
  93.          (setq fl (open "etext.gl1" "r"))
  94.  )
  95.          (if (/= nil (member l2 '("f" "w")))
  96.          (setq fl (open "etext.gl2" "r"))
  97.  )
  98.          (if (= l2 "j")
  99.          (setq fl (open "etext.gl3" "r"))
  100.  )
  101.          (if (/= nil (member l2 '("s" "t")))
  102.          (setq fl (open "etext.gl4" "r"))
  103.  )
  104.          (if (/= nil (member l2 '("v" "y")))
  105.          (setq fl (open "etext.gl5" "r"))
  106.  )
  107.          (if (= l2 "x")
  108.          (setq fl (open "etext.gl6" "r"))
  109.  )
  110.          (if (= l2 "z")
  111.          (setq fl (open "etext.gl7" "r"))
  112.  )
  113. (getspl)
  114. (close fl)
  115. )
  116. (defun chgstl ()
  117.             (command "style" "hgoth" "hgoth" "0" "1" "0" "n" "n")
  118.             (entdel (cdr (assoc -1 kj)))
  119.             (command "text" pt sh 0 sj)
  120. )
  121. (defun c:etext  () 
  122.        (setq pt (getpoint "\n Etext insertion point :"))
  123.        (princ "\ntext height-inches <")
  124.        (setq ib (open "etext.dft" "r"))
  125.        (setq sh (atof (read-line ib)))
  126.        (close ib)
  127.        (prin1 sh)
  128.        (prin1 '>)
  129.        (setq sy (getstring " :"))
  130.          (if  (= sy "")
  131.             (setq sh sh)
  132.             (setq sh (atof sy))
  133.        ) 
  134.        (setq ib (open "etext.dft" "w"))
  135.        (setq ie (rtos sh 2 2))
  136.        (write-line ie ib)
  137.        (close ib)
  138.        (setq f (/ sh 24))
  139.        (setq sl (strlen (setq ss (getstring "\n text :"))))
  140.              (setq fl (open "etext.dt1" "r"))
  141.              (setq ct 0 lt nil)
  142.              (while (< ct 52)              ;read in character spaces
  143.                  (setq ld (read-line fl))
  144.                  (setq lt (cons ld lt))
  145.                  (setq ct (1+ ct))
  146.                )
  147.                  (setq lt (reverse lt))
  148.                  (setq ct 1 es (1- (strlen ss)))       
  149.                  (setq sj (substr ss 1 1))
  150.                  (close fl)
  151.      (while (< ct sl)   ;put in spaces routine
  152.               (setq l1 (substr ss ct 1) l2 (substr ss (1+ ct) 1))
  153.               (setq lw (ascii l1) lx (ascii l2))
  154.               (if (< lx 96)
  155.                 (ucase))
  156.               (if (and (< lw 96) (> lx 96))
  157.                 (ulcase))
  158.               (if (and (> lw 96) (> lx 96))
  159.                 (lcase))
  160.               (setq cg (substr cg 2))
  161.               (setq cx (atof cg))
  162.            (if (< lw 96) 
  163.                (setq dx (atof (substr (nth cs lt) 2)))
  164.             )
  165.            (if (> lw 96)
  166.                (setq dx (atof (substr (nth (+ 26 cs) lt) 2)))
  167.             )
  168.               (setq dr (- cx dx))
  169.               (setq dr (fix (/ dr 0.40 )))
  170.            (if (> dr 24)
  171.                (progn
  172.                (repeat (fix (/ dr 24))
  173.                     (setq sj (strcat sj (chr 173))))
  174.                   (setq dr (- dr (* 24 (fix (/ dr 24)))))
  175.            ))   
  176.               (setq sj (strcat sj (chr (+ 149 dr)) l2))
  177.               (setq ct (1+ ct))
  178.     )     
  179.               (command "text" pt sh 0 sj)
  180.          (if (/= "HGOTH"
  181.        (cdr (assoc 7 (setq kj (entget (entlast))))))
  182.           (chgstl)) 
  183. )     
  184.  
  185.