[原创]：A SIMPLE LISP PROGRAM

KERRYWM

(DEFUN C:QXCL()
  (VL-LOAD-COM)
  (COMMAND "UNDO" "BE")
  (COMMAND "UCS" "W")
  (SETQ PRE-ECHO(GETVAR "CMDECHO"))
  (SETQ PRE-OSMODE(GETVAR "OSMODE"))
  (SETQ PRE-OTHROMODE(GETVAR "ORTHOMODE"))
  (SETVAR "OSMODE" 0)
  (SETVAR "ORTHOMODE" 0)
  (SETVAR "CMDECHO" 0)
  (SETQ CURVE(CAR (ENTSEL "PLEASE SELECT A CURVE:")))
  (SETQ FACTOR(GETREAL "THE TRANSLATION FACTOR<1>:"))
  (IF (= FACTOR NIL)
    (SETQ PRECISION 0.5)
    (SETQ PRECISION (/ 0.5 FACTOR))
    )
  (COMMAND "AREA" "E" CURVE)
  (SETQ CURVE-LENGTH(GETVAR "PERIMETER"))
  (SETQ REMAIN(REM CURVE-LENGTH PRECISION))
  (SETQ I(/ (- CURVE-LENGTH REMAIN) PRECISION))
  (SETQ J 0)
  (SETQ ARC(SSADD))
  (SETQ VLA-CURVE(VLAX-ENAME->VLA-OBJECT CURVE))
  (SETQ ST-POINT(VLAX-CURVE-GETSTARTPOINT VLA-CURVE))
  (WHILE (< J I)
    (SETQ MID-POINT(VLAX-CURVE-GETPOINTATDIST VLA-CURVE (+ (/ PRECISION 2) (* PRECISION J))))
    (SETQ END-POINT(VLAX-CURVE-GETPOINTATDIST VLA-CURVE (+ PRECISION (* PRECISION J))))
    (SLOPE)
    (COND
      ((= FLAG 1)
       (COMMAND "LINE" ST-POINT END-POINT "")
      )
      ((= FLAG 2)
       (COMMAND "ARC" ST-POINT MID-POINT  END-POINT)
       )
      ((= FLAG 0)
       (PROGN
         (SETQ MID-POINT(VLAX-CURVE-GETPOINTATDIST VLA-CURVE (+ (/ PRECISION 8) (* PRECISION J))))
         (SETQ END-POINT(VLAX-CURVE-GETPOINTATDIST VLA-CURVE (+ (/ PRECISION 4) (* PRECISION J))))
         (COMMAND "ARC" ST-POINT MID-POINT  END-POINT)
         )
       )
      )
    (SETQ ARC(SSADD (ENTLAST) ARC))
    (SETQ ST-POINT END-POINT)
    (SETQ J(1+ J))
    )
  (IF (> REMAIN 0)
    (PROGN
      (SETQ MID-POINT(VLAX-CURVE-GETPOINTATDIST VLA-CURVE (+ (/ REMAIN 2.0) (* PRECISION J))))
      (SETQ END-POINT(VLAX-CURVE-GETENDPOINT VLA-CURVE))
      (SLOPE)
      (COND
        ((= FLAG 1)
         (COMMAND "LINE" ST-POINT END-POINT "")
         )
        ((= FLAG 0)
         (COMMAND "ARC" ST-POINT MID-POINT  END-POINT)
         )
        ((= FLAG 2)
         (COMMAND "ARC" ST-POINT MID-POINT  END-POINT)
         )
        )
      (SETQ LAST-OBJ(ENTLAST))
      (SETQ ARC(SSADD LAST-OBJ ARC))
      (PRINC)
      )
    )
  (COMMAND "PEDIT" LAST-OBJ "Y" "J" ARC "" "")
  (SETVAR "OSMODE" PRE-OSMODE)
  (SETVAR "ORTHOMODE" PRE-OTHROMODE)
  (SETVAR "CMDECHO" PRE-ECHO)
  )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DEFUN SLOPE()
  (SETQ XST(CAR ST-POINT))
  (SETQ YST(CADR ST-POINT))
  (SETQ XMID(CAR MID-POINT))
  (SETQ YMID(CADR MID-POINT))
  (SETQ XEND(CAR END-POINT))
  (SETQ YEND(CADR END-POINT))
  (SETQ SLOPE-MID-END(/ (- YEND YMID) (- XEND XMID)))
  (SETQ SLOPE-ST-MID(/ (- YMID YST) (- XMID XST)))
  (SETQ SUBSLOPE(ABS (- SLOPE-MID-END SLOPE-ST-MID)))
  (COND
     ((AND (= XMID XST) (/= XEND XMID) (> SLOPE-MID-END 1000000))
      (SETQ FLAG 1)
      )
     ((AND (/= XMID XST) (= XEND XMID) (> SLOPE-ST-MID 1000000))
      (SETQ FLAG 1)
      )
     ((AND (= XMID XST) (/= XEND XMID) (<= SLOPE-MID-END 1000000))
      (SETQ FLAG 2)
      )
     ((AND (/= XMID XST) (= XEND XMID) (<= SLOPE-ST-MID 1000000))
      (SETQ FLAG 2)
      )
     ((AND (/= XMID XST) (/= XEND XMID))
       (PROGN
         (COND
           ((< SUBSLOPE 1E-4)
            (SETQ FLAG 1)
            )
           ((> SUBSLOPE 0.25)
            (SETQ FLAG 0)
            )
           (SETQ FLAG 2)
           )
         )
      )
     ((AND (/= XMID XST) (/= XEND XMID))
       (SETQ FLAG 1)
       )
     )
  )
;;;THIS IS SIMPLE PROGRAM WITH NO EXPLANATION.YOU CAN ANALYZE IT AND THEN GIVE SOME ADVICE.THANKS FOR YOU KINDNESS.

ysx810210

最好说明程序的用途

舟自横

I THINK YOUR VLISP IS VERY GOOD!
BUT I MUST STILL GIVE YOU TWO ADVICES.
THE FIRST IS IF YOU CAN SPEAK CHINESE,PLEASE SPEAK IN IT,
BECAUSE IN THIS FORUM MOSTLY ARE CHINESE.
SECOND IS WHEN YOU HAVE  PUBLISHED A  PROGRAM YOU SHOULD EXPLAN
HOW TO USE IT.

啵浪鼓

我能明白你的VLISP是非常好的
但是我有2个问题
第一,如果你能说中文,请用中文交流,
         因为在这里交流的大多数是中国人
第二,需要将你的程序加上注释,让使用者明白你的意图

太棒了

舟自横

呵呵。。。李兄你什么時候變成我的私人翻譯拉。。

winabcd

舟自横，你明知道这儿中国人多，还在三楼用洋文，这不是硬逼大家去学那洋玩意。

舟自横

呵呵。。。我是怕那個仁兄看不懂中文。。。

qjcpj

没想到舟自横除程序之外，对E文也蛮有研究的嘛，佩服！

xyp1964

曲线转换工具，速度太慢。
不如“★线转多段线”（2pl）好使。呵呵……

舟自横

呵呵。。過獎過獎。。也就是一般般拉。。

啵浪鼓

哎,现在下岗在家,闲着没事在此灌水,呵呵~!

狂刀

各位英文都很好啊．能否翻译一下这个程序是干什么用的？

KERRYWM

因為電腦為繁體系統，發到網站上可能為亂碼，故用了英文，請大家不要見怪。
所發的LISP程序是用來將曲線轉為直線和圓弧邊成的復線，以保証能夠做線割加工。