[编程交流] 自动lisp不工作

(defun find_file ()
(setq fname (getfiled "Select Your Data File..." "/My Documents/" "dat" )
)
(defun datum_dialog ()
(if (not (new_dialog "DATUMDIALOG" dcl_id)) (exit))
(Setq datum (rtos datum))
(set_tile "datum" datum)
(mode_tile "datum" 2)
(action_tile "datum" "(setq datum $value)")
(action_tile "accept" "(done_dialog)")
(start_dialog)
(unload_dialog dcl_id)
(setq datum (atof datum))
)
(defun call_dialog ()
(setq dcl_id (load_dialog "css.dcl"))
(if (not (new_dialog "CSSDIALOG" dcl_id)) (exit))
(if (/= us nil)
     (setq us us)
     (setq us 1.5)
)
(if (/= ds nil)
     (setq ds ds)
     (setq ds 2)
)
(if (/= bwidth nil)
     (setq bwidth bwidth)
     (setq bwidth 2.5)
)
(if (/= blevel nil)
     (setq blevel blevel)
     (setq blevel 25.5)
)
(setq us (rtos us))
(set_tile "us" us)
(setq ds (rtos ds))
(set_tile "ds" ds)
(setq bwidth (rtos bwidth))
(set_tile "bwidth" bwidth)
(setq blevel (rtos blevel))
(set_tile "blevel" blevel)
(if (= section "canal") 
        (mode_tile "c" 2)
        (if (= section "lbbund")
                (mode_tile "lb" 2)
                (mode_tile "rb" 2)
        )
)
(action_tile "datum" "(setq datum $value)")
(action_tile "us" "(setq us $value)")
(action_tile "ds" "(setq ds $value)")
(action_tile "bwidth" "(setq bwidth $value)")
(action_tile "blevel" "(setq blevel $value)")
(action_tile "c" "(setq section "canal")(mode_tile "ds" 1)")
(action_tile "lb" "(setq section "lbbund")(mode_tile "ds" 0)")
(action_tile "rb" "(setq section "rbbund")(mode_tile "ds" 0)")
(action_tile "data_file" "(find_file)")
(action_tile "cancel" "(done_dialog)
                        (setq ds nil)
                        (setq us nil)
                        (setq bwidth nil)
                        (setq blevel nil)
                        (exit)"
)
(action_tile "accept" "(done_dialog)")
(start_dialog)
(setq us (atof us))
(setq ds (atof ds))
(setq bwidth (atof bwidth))
(setq blevel (atof blevel))
)
(defun read_data () 
(setq no 0)
(setq f (open fname "r"))
 (while (setq a (read-line f))
(setq mydist a)
(setq mydist (strcat "(" mydist))
         (setq mydist (strcat mydist ")"))
;(if (/= mylist nil) 
(setq mydist (read mydist))
(setq mylocation (car mydist))
(setq mylocationlist (cons mylocation mylocationlist))
;(setq mylocationlist (reverse mylocationlist))
(setq mydistlist (cons mydist mydistlist))
;(setq mydistlist (reverse mydistlist))
(setq a (read-line f))
(setq mylevel a)
(setq mylevel (strcat "(" mylevel))
         (setq mylevel (strcat mylevel ")"))
(setq mylevel (read mylevel))
(setq mylevellist (cons mylevel mylevellist))
(setq min_level (cdr mylevel))
(setq minlevel1 (apply 'min min_level))
(setq minlevellist (cons minlevel1 minlevellist))
(setq no (1+ no))
) 
(close f)
(setq minlevel (apply 'min minlevellist))
(setq datum (- minlevel 4))
(setq datum (fix datum))
(datum_dialog)
(setq mo (- no 1))
  (while (<= 0 mo)
(setq location (nth mo mylocationlist))
(setq distances (assoc location mydistlist))
(setq distances (cdr distances))
(setq levels (assoc location mylevellist))
(setq levels (cdr levels))
(setq mo (- mo 1))
(draw_cs)
  )
(princ)  
)
(defun draw_cs ()
(if (= section nil) (setq section "rbbund"))
(setq textht11 200)
(setq textht12 300)
(setq textht13 400)
(command "ucs" "o" pause)
(setq datum (* datum 1000))
(setq blevel (* blevel 1000))
(setq bwidth (* bwidth 1000))
(setq len (length distances))
(setq lenlevels (length levels))
;(if (/= len lenlevels) (and (Alert "Check Your Data in next CS")(exit)))
;writing of existing levels to CS (as texts)
;-------------------------------------------
(setq q 0)
  (while (< q len)
  (setq textlevel (rtos (nth q levels)))
  (setq point (list (* (nth q distances) 1000) 750))
  (command "text" "J" "ML" point  textht11 "90" textlevel)
  (command "point" (list (nth 0 point) 600) )
  (setq q (1+ q))
  )
;writing of distances to CS (as texts)
;-------------------------------------
(setq r 0)
  (while (< r len)
  (setq textdist (rtos (nth r distances)))
  (setq point1 (list (* (nth r distances) 1000) 100))
  (command "text" "J" "BC" point1  textht11 "0" textdist)
  (command "point" (list (nth 0 point1) 0) )
  (setq r (1+ r))
  )
(foreach n distances
(setq distances (* n 1000))
(setq distances1 (cons distances distances1))
(setq distances (reverse distances1))
)
(foreach name levels
(setq levels (* name 1000))
(setq levels (- levels datum))
       (setq levels (+ levels 2600))
             (setq levels1 (cons levels levels1))
(setq levels (reverse levels1))
)
 
(setq maxht (apply 'max levels))
;drawing existing profile and vertical lines from each point
;-----------------------------------------------------------
     (setq m1 0)
       (while (< m1 (- len 1))
 (setq pt1 (list (nth m1 distances) (nth m1 levels)))
 (setq m1 (1+ m1))
 (setq pt2 (list (nth m1 distances) (nth m1 levels)))
 (command "line" pt1 pt2 "")
        (setq pt3 (list (nth 0 pt1) 2600))
 (command "line" pt1 pt3 "")
       )
(setq minvalue (apply 'min distances))
(setq maxvalue (apply 'max distances))
;;drawing of boundary lines
;;-------------------------
(setq ptp (list (- minvalue 3500) 0))
(setq ptq (list maxvalue 0))
(setq ptr (list (nth 0 ptp) 600))
(setq pts (list (nth 0 ptq) 600))
(setq ptt (list (nth 0 ptp) 1600))
(setq ptu (list (nth 0 ptq) 1600))
(setq ptv (list (nth 0 ptp) 2600))
(setq ptw (list (nth 0 ptq) 2600))
(setq pta (list minvalue 2600))
(setq ptb (list minvalue maxht))
(setq pto (list 0 2600))
(setq ptd (list 0 (nth 1 ptb)))
(setq pte (list (nth 0 ptq) (nth 1 ptb)))
(setq ptf (list (nth 0 ptq) 2600))
(command "line" ptp ptq "")
(command "line" ptr pts "")
(command "line" ptt ptu "")
(command "line" ptv ptw "")
(command "line" pta ptb "")
(command "line" pto ptd "")
(command "line" ptf pte "")
;drawing of Design profile
;-------------------------
(setq blevel (- blevel datum))
(setq blevel (+ blevel 2600))
(setq bwidth (/ bwidth 2))
(setq t1 (- 0 bwidth))
(setq dpt2 (list t1 blevel))
(setq dpt3 (list bwidth blevel))
(setq x1 (abs (- (nth 0 pta) (nth 0 dpt2))))
(setq x2 (- (nth 0 ptq) (nth 0 dpt3)))
(command "layer" "n" "DesignProfile" "c" "green" "DesignProfile" "")
(command "layer" "s" "DesignProfile" "")
(command "line" dpt2 dpt3 "")     
(if (= section "lbbund")        ;drawing design profile of LB bund
    (progn
    (setq y1lb (/ x1 ds))
    (setq dpt1lb (list (nth 0 pta) (- blevel y1lb)))
    (setq y2lb (/ x2 us))
    (setq dpt4lb (list (nth 0 ptq) (- blevel y2lb)))
    (command "line" dpt1lb dpt2 "")
    (command "line" dpt3 dpt4lb "")
     (command "layer" "s" "0" "")
)
 )
   (if (= section "rbbund")        ;drawing design profile of RB bund
       (progn    
       (setq y1 (/ x1 us))
       (setq dpt1 (list (nth 0 pta) (- blevel y1)))
       (setq y2 (/ x2 ds))
       (setq dpt4 (list (nth 0 ptq) (- blevel y2)))
       (command "line" dpt1 dpt2 "")
       (command "line" dpt3 dpt4 "")
       (command "layer" "s" "0" "")
)
   )
    (if (= section "canal")   ;drawing design profile of canal
       (progn    
       (setq y1c (/ x1 us))
       (setq dpt1c (list (nth 0 pta) (+ blevel y1c)))
       (setq y2c (/ x2 us))
       (setq dpt4c (list (nth 0 ptq) (+ blevel y2c)))
       (command "line" dpt1c dpt2 "")
       (command "line" dpt3 dpt4c "")
       (command "layer" "s" "0" "")
)
    )
;writing of texts to CS
;----------------------
(setq dlevelf (- blevel 2600))
(setq dlevelg (+ datum dlevelf))
(setq dlevelg (/ dlevelg 1000))
(setq blevel (rtos dlevelg))
(setq pointln (list 0 1800))
(command "text" "J" "ML" pointln  textht11 "90" blevel)
(setq datum (/ datum 1000))
(setq datum (rtos datum))
(setq text1 (strcat "Datum " datum " MSL"))
(setq ptt1 (list (nth 0 ptv) (+ 400 (nth 1 ptv))))
(command "text" "J" "ML" ptt1  textht12 "0" text1)
(setq text2 "Design Levels")
(setq ptt2 (list (nth 0 ptt) (+ 400 (nth 1 ptt))))
(command "text" "J" "ML" ptt2  textht12 "0" text2)
(setq text3 "Existing Levels")
(setq ptt3 (list (nth 0 ptr) (+ 400 (nth 1 ptr))))
(command "text" "J" "ML" ptt3  textht12 "0" text3)
(setq text4 "Distance in m")
(setq ptt4 (list (nth 0 ptp) (+ 300 (nth 1 ptp))))
(command "text" "J" "ML" ptt4  textht12 "0" text4)
(setq location (rtos location))
(setq location1 (strcat "CS at " location " m"))
(setq pointn (- 0 800))
(setq pointnn (list 0 pointn))
(command "text" "J" "BC" pointnn  textht13 "0" location1)
(command "zoom" "a")
(setq bwidth (* bwidth 2))
(setq datum (atof datum))
(setq bwidth (/ bwidth 1000))
(setq blevel (atof blevel))
(setq location (atof location))
(setq distances1 nil distances nil levels1 nil levels nil levels2 nil levels3 nil)
)
;;Define error handler
(defun gp_err (msg)
(setq *error* olderr)
(if (not gperr)
(princ (strcat "\nC.S. error: " msg))
(princ gperr)
)
(if sblip (setvar "blipmode" sblip))
(if scmde (setvar "cmdecho" scmde))
(princ)
)
(defun c:css ( / dist1 dista distan minvalue maxht dcl_id canal lbbund rbbund mylocationlist mydistlist mylevellist minlevellist)
(command "-osnap" "none")
(command "snap" "off")
(command "ucsicon" "off")
(setq sang (getvar "snapang"))
(setq olderr *error* *error* gp_err sblip nil scmde nil gperr nil)
(setq sblip (getvar "blipmode"))
(setq scmde (getvar "cmdecho"))
(call_dialog)
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(command "style" "csfont" "times.ttf" "0" "1" "0" "n" "n")
(command "units" "2" "2" "1" "0" "0" "n")
(read_data)
(setvar "blipmode" sblip)
(setvar "cmdecho" scmde)
(setvar "snapang" sang) 
(setq *error* olderr)
(command "zoom" "a")
(princ)
)
(princ "\nCSS.LSP Loaded. Type CSS to use.")
(princ)
(defun find_file ()
(setq fname (getfiled "Select Your Data File..." "/My Documents/" "dat" )
)
(defun datum_dialog ()
(if (not (new_dialog "DATUMDIALOG" dcl_id)) (exit))
(Setq datum (rtos datum))
(set_tile "datum" datum)
(mode_tile "datum" 2)
(action_tile "datum" "(setq datum $value)")
(action_tile "accept" "(done_dialog)")
(start_dialog)
(unload_dialog dcl_id)
(setq datum (atof datum))
)
(defun call_dialog ()
(setq dcl_id (load_dialog "css.dcl"))
(if (not (new_dialog "CSSDIALOG" dcl_id)) (exit))
(if (/= us nil)
     (setq us us)
     (setq us 1.5)
)
(if (/= ds nil)
     (setq ds ds)
     (setq ds 2)
)
(if (/= bwidth nil)
     (setq bwidth bwidth)
     (setq bwidth 2.5)
)
(if (/= blevel nil)
     (setq blevel blevel)
     (setq blevel 25.5)
)
(setq us (rtos us))
(set_tile "us" us)
(setq ds (rtos ds))
(set_tile "ds" ds)
(setq bwidth (rtos bwidth))
(set_tile "bwidth" bwidth)
(setq blevel (rtos blevel))
(set_tile "blevel" blevel)
(if (= section "canal") 
        (mode_tile "c" 2)
        (if (= section "lbbund")
                (mode_tile "lb" 2)
                (mode_tile "rb" 2)
        )
)
(action_tile "datum" "(setq datum $value)")
(action_tile "us" "(setq us $value)")
(action_tile "ds" "(setq ds $value)")
(action_tile "bwidth" "(setq bwidth $value)")
(action_tile "blevel" "(setq blevel $value)")
(action_tile "c" "(setq section "canal")(mode_tile "ds" 1)")
(action_tile "lb" "(setq section "lbbund")(mode_tile "ds" 0)")
(action_tile "rb" "(setq section "rbbund")(mode_tile "ds" 0)")
(action_tile "data_file" "(find_file)")
(action_tile "cancel" "(done_dialog)
                        (setq ds nil)
                        (setq us nil)
                        (setq bwidth nil)
                        (setq blevel nil)
                        (exit)"
)
(action_tile "accept" "(done_dialog)")
(start_dialog)
(setq us (atof us))
(setq ds (atof ds))
(setq bwidth (atof bwidth))
(setq blevel (atof blevel))
)
(defun read_data () 
(setq no 0)
(setq f (open fname "r"))
 (while (setq a (read-line f))
(setq mydist a)
(setq mydist (strcat "(" mydist))
         (setq mydist (strcat mydist ")"))
;(if (/= mylist nil) 
(setq mydist (read mydist))
(setq mylocation (car mydist))
(setq mylocationlist (cons mylocation mylocationlist))
;(setq mylocationlist (reverse mylocationlist))
(setq mydistlist (cons mydist mydistlist))
;(setq mydistlist (reverse mydistlist))
(setq a (read-line f))
(setq mylevel a)
(setq mylevel (strcat "(" mylevel))
         (setq mylevel (strcat mylevel ")"))
(setq mylevel (read mylevel))
(setq mylevellist (cons mylevel mylevellist))
(setq min_level (cdr mylevel))
(setq minlevel1 (apply 'min min_level))
(setq minlevellist (cons minlevel1 minlevellist))
(setq no (1+ no))
) 
(close f)
(setq minlevel (apply 'min minlevellist))
(setq datum (- minlevel 4))
(setq datum (fix datum))
(datum_dialog)
(setq mo (- no 1))
  (while (<= 0 mo)
(setq location (nth mo mylocationlist))
(setq distances (assoc location mydistlist))
(setq distances (cdr distances))
(setq levels (assoc location mylevellist))
(setq levels (cdr levels))
(setq mo (- mo 1))
(draw_cs)
  )
(princ)  
)
(defun draw_cs ()
(if (= section nil) (setq section "rbbund"))
(setq textht11 200)
(setq textht12 300)
(setq textht13 400)
(command "ucs" "o" pause)
(setq datum (* datum 1000))
(setq blevel (* blevel 1000))
(setq bwidth (* bwidth 1000))
(setq len (length distances))
(setq lenlevels (length levels))
;(if (/= len lenlevels) (and (Alert "Check Your Data in next CS")(exit)))
;writing of existing levels to CS (as texts)
;-------------------------------------------
(setq q 0)
  (while (< q len)
  (setq textlevel (rtos (nth q levels)))
  (setq point (list (* (nth q distances) 1000) 750))
  (command "text" "J" "ML" point  textht11 "90" textlevel)
  (command "point" (list (nth 0 point) 600) )
  (setq q (1+ q))
  )
;writing of distances to CS (as texts)
;-------------------------------------
(setq r 0)
  (while (< r len)
  (setq textdist (rtos (nth r distances)))
  (setq point1 (list (* (nth r distances) 1000) 100))
  (command "text" "J" "BC" point1  textht11 "0" textdist)
  (command "point" (list (nth 0 point1) 0) )
  (setq r (1+ r))
  )
(foreach n distances
(setq distances (* n 1000))
(setq distances1 (cons distances distances1))
(setq distances (reverse distances1))
)
(foreach name levels
(setq levels (* name 1000))
(setq levels (- levels datum))
       (setq levels (+ levels 2600))
             (setq levels1 (cons levels levels1))
(setq levels (reverse levels1))
)
 
(setq maxht (apply 'max levels))
;drawing existing profile and vertical lines from each point
;-----------------------------------------------------------
     (setq m1 0)
       (while (< m1 (- len 1))
 (setq pt1 (list (nth m1 distances) (nth m1 levels)))
 (setq m1 (1+ m1))
 (setq pt2 (list (nth m1 distances) (nth m1 levels)))
 (command "line" pt1 pt2 "")
        (setq pt3 (list (nth 0 pt1) 2600))
 (command "line" pt1 pt3 "")
       )
(setq minvalue (apply 'min distances))
(setq maxvalue (apply 'max distances))
;;drawing of boundary lines
;;-------------------------
(setq ptp (list (- minvalue 3500) 0))
(setq ptq (list maxvalue 0))
(setq ptr (list (nth 0 ptp) 600))
(setq pts (list (nth 0 ptq) 600))
(setq ptt (list (nth 0 ptp) 1600))
(setq ptu (list (nth 0 ptq) 1600))
(setq ptv (list (nth 0 ptp) 2600))
(setq ptw (list (nth 0 ptq) 2600))
(setq pta (list minvalue 2600))
(setq ptb (list minvalue maxht))
(setq pto (list 0 2600))
(setq ptd (list 0 (nth 1 ptb)))
(setq pte (list (nth 0 ptq) (nth 1 ptb)))
(setq ptf (list (nth 0 ptq) 2600))
(command "line" ptp ptq "")
(command "line" ptr pts "")
(command "line" ptt ptu "")
(command "line" ptv ptw "")
(command "line" pta ptb "")
(command "line" pto ptd "")
(command "line" ptf pte "")
;drawing of Design profile
;-------------------------
(setq blevel (- blevel datum))
(setq blevel (+ blevel 2600))
(setq bwidth (/ bwidth 2))
(setq t1 (- 0 bwidth))
(setq dpt2 (list t1 blevel))
(setq dpt3 (list bwidth blevel))
(setq x1 (abs (- (nth 0 pta) (nth 0 dpt2))))
(setq x2 (- (nth 0 ptq) (nth 0 dpt3)))
(command "layer" "n" "DesignProfile" "c" "green" "DesignProfile" "")
(command "layer" "s" "DesignProfile" "")
(command "line" dpt2 dpt3 "")     
(if (= section "lbbund")        ;drawing design profile of LB bund
    (progn
    (setq y1lb (/ x1 ds))
    (setq dpt1lb (list (nth 0 pta) (- blevel y1lb)))
    (setq y2lb (/ x2 us))
    (setq dpt4lb (list (nth 0 ptq) (- blevel y2lb)))
    (command "line" dpt1lb dpt2 "")
    (command "line" dpt3 dpt4lb "")
     (command "layer" "s" "0" "")
)
 )
   (if (= section "rbbund")        ;drawing design profile of RB bund
       (progn    
       (setq y1 (/ x1 us))
       (setq dpt1 (list (nth 0 pta) (- blevel y1)))
       (setq y2 (/ x2 ds))
       (setq dpt4 (list (nth 0 ptq) (- blevel y2)))
       (command "line" dpt1 dpt2 "")
       (command "line" dpt3 dpt4 "")
       (command "layer" "s" "0" "")
)
   )
    (if (= section "canal")   ;drawing design profile of canal
       (progn    
       (setq y1c (/ x1 us))
       (setq dpt1c (list (nth 0 pta) (+ blevel y1c)))
       (setq y2c (/ x2 us))
       (setq dpt4c (list (nth 0 ptq) (+ blevel y2c)))
       (command "line" dpt1c dpt2 "")
       (command "line" dpt3 dpt4c "")
       (command "layer" "s" "0" "")
)
    )
;writing of texts to CS
;----------------------
(setq dlevelf (- blevel 2600))
(setq dlevelg (+ datum dlevelf))
(setq dlevelg (/ dlevelg 1000))
(setq blevel (rtos dlevelg))
(setq pointln (list 0 1800))
(command "text" "J" "ML" pointln  textht11 "90" blevel)
(setq datum (/ datum 1000))
(setq datum (rtos datum))
(setq text1 (strcat "Datum " datum " MSL"))
(setq ptt1 (list (nth 0 ptv) (+ 400 (nth 1 ptv))))
(command "text" "J" "ML" ptt1  textht12 "0" text1)
(setq text2 "Design Levels")
(setq ptt2 (list (nth 0 ptt) (+ 400 (nth 1 ptt))))
(command "text" "J" "ML" ptt2  textht12 "0" text2)
(setq text3 "Existing Levels")
(setq ptt3 (list (nth 0 ptr) (+ 400 (nth 1 ptr))))
(command "text" "J" "ML" ptt3  textht12 "0" text3)
(setq text4 "Distance in m")
(setq ptt4 (list (nth 0 ptp) (+ 300 (nth 1 ptp))))
(command "text" "J" "ML" ptt4  textht12 "0" text4)
(setq location (rtos location))
(setq location1 (strcat "CS at " location " m"))
(setq pointn (- 0 800))
(setq pointnn (list 0 pointn))
(command "text" "J" "BC" pointnn  textht13 "0" location1)
(command "zoom" "a")
(setq bwidth (* bwidth 2))
(setq datum (atof datum))
(setq bwidth (/ bwidth 1000))
(setq blevel (atof blevel))
(setq location (atof location))
(setq distances1 nil distances nil levels1 nil levels nil levels2 nil levels3 nil)
)
;;Define error handler
(defun gp_err (msg)
(setq *error* olderr)
(if (not gperr)
(princ (strcat "\nC.S. error: " msg))
(princ gperr)
)
(if sblip (setvar "blipmode" sblip))
(if scmde (setvar "cmdecho" scmde))
(princ)
)
(defun c:css ( / dist1 dista distan minvalue maxht dcl_id canal lbbund rbbund mylocationlist mydistlist mylevellist minlevellist)
(command "-osnap" "none")
(command "snap" "off")
(command "ucsicon" "off")
(setq sang (getvar "snapang"))
(setq olderr *error* *error* gp_err sblip nil scmde nil gperr nil)
(setq sblip (getvar "blipmode"))
(setq scmde (getvar "cmdecho"))
(call_dialog)
(setvar "cmdecho" 0)
(setvar "blipmode" 0)
(command "style" "csfont" "times.ttf" "0" "1" "0" "n" "n")
(command "units" "2" "2" "1" "0" "0" "n")
(read_data)
(setvar "blipmode" sblip)
(setvar "cmdecho" scmde)
(setvar "snapang" sang) 
(setq *error* olderr)
(command "zoom" "a")
(princ)
)
(princ "\nCSS.LSP Loaded. Type CSS to use.")
(princ)

Your Code Here[/NOPARSE]