[编程交流] 在Ca中输入数据需要Lisp

(rtos SomeNumericVariable 2 3)

  ;; Internal error handler defined locally
 ;;
 (defun al_err (s)                   ; If an error (such as CTRL-C) occurs
                                     ; while this command is active...
   (if (/= s "Function cancelled")
     (princ (strcat "\nError: " s))
   )
   (if al_oe                         ; If an old error routine exists
     (setq *error* al_oe)            ; then, reset it 
   )
   (setq aliasi (close aliasi))
   (setvar "cmdecho" al_oce)         ; Reset command echoing on error
   (princ)
 )
 ;;
 ;; Body of alias function
 ;;
 (if *error*                         ; Set our new error handler
   (setq al_oe *error* *error* al_err) 
   (setq *error* al_err) 
 )
(DEFUN C:TOPO ()
(COMMAND "LAYER" "N" "SIGN" "C" "1" "SIGN" "")
(COMMAND "LAYER" "N" "LEVEL" "C" "7" "LEVEL" "")
(COMMAND "LAYER" "N" "PNT_CEN" "C" "7" "PNT_CEN" "")
(COMMAND "LAYER" "N" "PNT_NUM" "C" "2" "PNT_NUM" "")
(initget (+ 1 2 4))
(setq raz (getreal "Imenitelj razmere .........: "))
(initget (+ 1 2 4))
(setq fnt (getreal "Visina ispisa [mm] .........: "))
(setq oang (getreal "Zakosenje ispisa [dec. step.] ...: "))
(setq fnt (* fnt (/ raz 1000)))
;(setq dia (* fnt 1.25))
(setq dia (* fnt 0.)
;(setq dia fnt) ############## TP
;(setq dis (/ fnt 5))
(setq dis (/ fnt 4))
(setq dpn (/ fnt 4))
(setq imefnt "1")
(setq ffile "ROMANS")
(setq wfac 0.75)
(setq non "N")
(COMMAND "PDMODE" "32")
(COMMAND "PDSIZE" "0.125")
(COMMAND "STYLE")
(COMMAND imefnt)
(COMMAND ffile)
(COMMAND fnt)
(COMMAND wfac)
(COMMAND oang)
(COMMAND non)
(COMMAND non)
(COMMAND non)
 (setvar "CMDECHO" 0)
 (setq f (getfiled "Fajla tacaka" "" "*" 4))
 (setq fr (open f "r"))
 (setq k 0 Cr " " Row " ")
 (while (/= Row nil)
   (setq Row (read-line fr))
   (if (/= Row nil)
     (progn
       (SPC)
       (if (> k 1)
         (TRIMS)
       )
       (VALU)
       (setq Pn (substr Row 1 (- k 1)))
       (TRIMS)
       (SPC)
       (TRIMS)
       (VALU)
       (setq y (atof (substr Row 1 (- k 1))))
       (TRIMS)
       (SPC)
       (TRIMS)
       (VALU)
       (setq x (atof (substr Row 1 (- k 1))))
       (TRIMS)
       (if (= Cr " ")
         (progn
           (SPC)
           (TRIMS)
         )
       )
       (setq h nil s nil)
       (VALU)
       (if (> k 1)
         (progn
           (if (< (ascii (substr Row 1 1)) 58)
             (setq h (atof (substr Row 1 (- k 1))))
             (setq h nil s (substr Row 1 (- k 1)))
           )
         )
       )
       (TRIMS)
       (if (= Cr " ")
         (progn
           (SPC)
           (TRIMS)
         )
       )
       (if (and (= s nil) (/= (substr Row 1 1) ""))
         (progn
           (VALU)
           (setq s (substr Row 1 (- k 1)))
         )
       )
       (setq tc (list y x))
       (WRT)
       (if (/= h nil)
           (WRTH)
       )
       (if (/= s nil)
            (WRTS)
       )
     )
     (progn
       (COMMAND "LAYER" "S" "0" "")
       (COMMAND "ZOOM" "E" "")
       (prin1)
     )
   )
 )
 (close fr)
;  (close m)
)
(DEFUN SPC ()
 (setq k 0 Cr " ")
 (while (= Cr " ")
   (setq k (+ k 1))
   (setq Cr (substr Row k 1))
 )
)
(DEFUN VALU ()
 (setq k 0 Cr "&")
 (while (and (/= Cr " ") (/= Cr ""))
   (setq k (+ k 1))
   (setq Cr (substr Row k 1))
 )
)
(DEFUN TRIMS ()
 (setq tmp (substr Row k))
 (setq Row tmp)
)
(DEFUN WRT ()
 (if (/= s nil)
   (progn
     (if (or (= (strcase s) "P") (= (strcase s) "T"))
       (setq tn (list y (+ x fnt)))
       (setq tn (list y (+ x dpn)))
     )
   )
   (setq tn (list y (+ x dpn)))
 )
 (COMMAND "LAYER" "S" "PNT_CEN" "")
 (COMMAND "POINT" tc)
 (COMMAND "LAYER" "S" "PNT_NUM" "")
 (COMMAND "TEXT" "S" "1" "BC" tn "0" Pn)
)
(DEFUN WRTH ()
 (if (/= s nil)
   (progn
     (if (or (= (strcase s) "P") (= (strcase s) "T"))
       (setq tl (list (+ y fnt) x))
       (setq tl (list (+ y dis) x))
     )
   )
   (setq tl (list (+ y dis) x))
 )
 (setq hs (rtos h 2 2))
 (setq l (strlen hs))
 (setq hs (substr hs 1 l))
 (DEC)
 (setq p (- l k))
;  (cond ((= k l) (setq hs (strcat hs ".00")))
;        ((= (- l 1)) (setq hs (strcat hs "0")))
;  (progn
   (cond ((= p 0) (setq hs (strcat hs ".00")))
         ((= p 1) (setq hs (strcat hs "0")))
   )
;  )
 (COMMAND "LAYER" "S" "LEVEL" "")
 (COMMAND "TEXT" "S" "1" "TL" tl "0" hs)
)
(DEFUN WRTS ()
 (setq ts (list (- y (/ fnt 1.625)) x))
;  (setq ts (list (- y dis) x))
 (COMMAND "LAYER" "S" "SIGN" "")
 (if (= (strcase s) "T" )
   (TRG)
 )
 (if (= (strcase s) "P" )
   (TRP)
 )
 (if (and (/= (strcase s) "P") (/= (strcase s) "T"))
   (COMMAND "TEXT" "S" "1" "MR" ts "0" s)
 )
)
(DEFUN DEC ()
 (setq k 0 Cr "&" l (strlen hs))
 (while (and (< k l) (/= Cr "."))
   (setq k (+ k 1))
   (setq Cr (substr hs k 1))
 )
)
(DEFUN TRG ()
;  (setq a (/ (sqrt (/ (expt dia 2) 3)) 2))
 (setq a (sqrt (/ (expt dia 2) 3)))
 (setq b (* a (/ (sin 0.5236) (cos 0.5236))))
;  (setq b (* a (/ (sin 30) (cos 30))))
;  (setq b (* a (/ 1 (atan 0.5236))))
 (setq c (- dia b))
 (setq t1 (list (+ y a) (- x b)))
 (setq t2 (list (- y a) (- x b)))
 (setq t3 (list y (+ x c)))
 (COMMAND "LINE" t1 t2 t3 t1 "")
)
(DEFUN TRP ()
 (COMMAND "LAYER" "S" "SIGN" "")
 (COMMAND "CIRCLE" tc (/ dia 2))
)
(princ "..!")
(prompt "\rProgram se startuje sa TOPO\007")
(prin1)