[分享]：lisp程序

crtrccrt

[php]
(defun buyit (/)
  (startapp "\\sai_toolbox\\icalc\\support\\autoflsh.exe")
)
;;;
(defun regnow (/)
  (setq key (get_tile "keycode"))
  (if (= key "")
    (setq key nil)
  )
  (if (= key " ")
    (setq key nil)
  )
  (if (= key "  ")
    (setq key nil)
  )
  (if (= key "   ")
    (setq key nil)
  )
  (if (= key "    ")
    (setq key nil)
  )
  (if (= key nil)
    (help "\\sai_toolbox\\icalc\\ICaLCH" "Authorizing")
  )
  (while (/= key nil)
    (setq key (atof key))
    (setq can2 (atof can))
    (setq keycodechk (- key can2))
    (setq keycodechk (rtos keycodechk 2 4))
    (setq keycodechk2 "123456.7891")
    (if (/= keycodechk2 keycodechk)
      (alert "Invalid Key Code")
    )
    (if (= keycodechk2 keycodechk)
      (alert "Icalc is now Authorized...")
    )
    (princ)
    (if (= keycodechk2 keycodechk)
      (progn
        (setq usefl (open "\\C000R000.dll" "w"))
        (write-line "3" usefl)
        (write-line can usefl)
        (close usefl)
      )
    )
    (setq key nil)
  )
)
;;;Authorizing Module;;;;;;;;
(defun auth (/)
  (setq fnddllfl (findfile "\\C000R000.dll"))
  (if (= fnddllfl nil)
    (progn
      (setq dte (getvar "DATE"))
      (setq can (rtos dte 2 4))
      (setq dllfile (open "\\C000R000.dll" "w"))
      (write-line "0" dllfile)
      (write-line can dllfile)
      (close dllfile)
    )
  )
  (setq dllfile (open "\\C000R000.dll" "r"))
  (setq amode (read-line dllfile))
  (setq can (read-line dllfile))
  (close dllfile)
  (setq canline (strcat "Your Customer Authorization Number is:  IC" can "D"))
  (setq dte (getvar "DATE"))
  (setq dte (rtos dte 2 0))
  (setq dte (atoi dte))
  (setq can1 (atoi can))
  (setq endd (+ can1 15))
  (setq checkdemo (- endd dte))
  (setq demodays (rtos checkdemo 2 0))
  (setq countdown (strcat "You have " demodays " Days left of this Evaluation!"))
  (if (/= amode "3")
    (progn
      (setq checkdemo (minusp checkdemo))
      (if (/= checkdemo nil)
        (setq amode "2")
      )
    )
  )
  (if (/= amode "3")
    (progn                           ;
      ;;;crt;;;(setq dcl_id (load_dialog "\\sai_toolbox\\icalc\\auth.dcl"))
      (setq dcl_id (load_dialog "auth.dcl"))
      (if (not (new_dialog "auth" dcl_id))
        (exit)
      )                              ;
      (if (/= amode "2")
        (set_tile "dmode" countdown)
      )
      (set_tile "canum" canline)     ;
      (action_tile "regnow" "(regnow)")
      (action_tile "accept" "(done_dialog)")
      (action_tile "buynow" "(buyit)") ;
      ;;
      (start_dialog)
      (unload_dialog dcl_id)
    )
  )
  (if (= amode "2")
    (setq calcrun 3)
  )
)
;;;=============================================================
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;                  Authorizing program!
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;
;;;...........................................................
(defun ichelp (/)
  (help "\\sai_toolbox\\icalc\\icalch" "Contents")
)
;;;...........................................................
;;;=============================================================
(defun readcalc (/)
  (setq 000read000 (get_tile "calbox"))
)
;;;=============================================================
(defun chgprec (/)
  (setq newprec (get_tile "precbox"))
  (setq newprec (atoi newprec))
  (setvar "LUPREC" newprec)
)
;;;=============================================================
(defun cmem (/)
  (setq 000remem000 nil)
  (set_tile "memory" "Memory")
)
;;;=============================================================
(defun rmem (/)
  (if (/= 000remem000 nil)
    (set_tile "calbox" 000remem000)
  )
)
;;;=============================================================
(defun msto (/)
  (setq 000remem000 (get_tile "calbox"))
  (if (= 000remem000 nil)
    (setq 000remem000 nil)
  )
  (if (= 000remem000 "")
    (setq 000remem000 nil)
  )
  (if (= 000remem000 " ")
    (setq 000remem000 nil)
  )
  (if (= 000remem000 "  ")
    (setq 000remem000 nil)
  )
  (if (= 000remem000 "   ")
    (setq 000remem000 nil)
  )
  (if (= 000remem000 "    ")
    (setq 000remem000 nil)
  )
  (if (/= 000remem000 nil)
    (progn
      (setq memsho (strcat "Memory = " 000remem000))
      (set_tile "memory" memsho)
    )
  )
)
;;;=============================================================
(defun clrcalc (/)
  (set_tile "calbox" "")
  (setq hold1 nil)
  (set_tile "stus" "Ready")
)
;;;=============================================================
(defun rtvarea (/)
  (setq eop (getstring "\nAREA: Entity or Points [E / P] : "))
  (setq eop (strcase eop))
  (if (= eop "E")
    (setq e (entsel "\nSelect Entity: "))
  )
  (if (/= eop "E")
    (progn
      (setq pt1 1)
      (setq pntlist (list 1))
      (while (/= pt1 nil)
        (setq pt1 (getpoint "\nNext Point:"))
        (if (/= pt1 nil)
          (progn
            (setq pt1 (reverse pt1))
            (setq pt1 (cdr pt1))
            (setq pt1 (reverse pt1))
            (setq pt1 (list pt1))
            (setq pntlist (append pntlist pt1))
          )
        )
      )
      (setq pntlist (cdr pntlist))
    )
  )
  (setq echo (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (command "area")
  (if (= eop "E")
    (command "E")
  )
  (if (/= eop "E")
    (progn
      (foreach pnt pntlist (command pnt))
    )
  )
  (if (= eop "E")
    (command e)
  )
  (if (/= eop "E")
    (command "")
  )
  (setq sfarea (getvar "AREA"))
  (princ sfarea)
  (setq retreive (rtos sfarea 2 4))
  (setq retvmode nil)
  (setvar "CMDECHO" echo)
)
;;;=============================================================
(defun rtvelev (/)
  (setq pt1 nil)
  (setq pt1 (getpoint "\nELEVATION: Select Point:"))
  (if (/= pt1 nil)
    (progn
      (setq elev1 (caddr pt1))
      (setq retreive (rtos elev1 2 4))
    )
  )
  (if (= pt1 nil)
    (setq retreive nil)
  )
  (if (= pt1 nil)
    (alert "No Point Selected")
  )
  (setq retvmode nil)
)
;;;=============================================================
(defun rtvrad (/)
  (arxload "geomcal" '("cal" "cal"))
  (setq radrt (cal "rad"))
  (princ radrt)
  (setq retreive (rtos radrt 2 4))
  (setq retvmode nil)
)
;;;=============================================================
(defun rtvzdist (/)
  (setq pt1 nil)
  (setq pt2 nil)
  (setq pt1 (getpoint "\nZ DISTANCE: Select First Point:"))
  (if (/= pt1 nil)
    (setq pt2 (getpoint pt1 "\nSelect Second Point:"))
  )
  (if (/= pt2 nil)
    (progn
      (setq pt1 (caddr pt1))         ;
      (setq pt2 (caddr pt2))         ;
      (setq zdistrt (- pt1 pt2))
      (setq zdistrt (abs zdistrt))
      (setq retreive (rtos zdistrt 2 4))
    )
  )
  (if (= pt1 nil)
    (setq retreive nil)
  )
  (if (= pt2 nil)
    (setq retreive nil)
  )
  (if (= pt2 nil)
    (alert "No Distance Selected")
  )
  (setq retvmode nil)
)
;;;=============================================================
(defun rtvsdist (/)
  (setq pt1 nil)
  (setq pt2 nil)
  (setq pt1 (getpoint "\nSLOPE DISTANCE: Select First Point:"))
  (if (/= pt1 nil)
    (setq pt2 (getpoint pt1 "\nSelect Second Point:"))
  )
  (if (/= pt2 nil)
    (progn
      (setq sdistrt (distance pt1 pt2))
      (setq retreive (rtos sdistrt 2 4))
    )
  )
  (if (= pt1 nil)
    (setq retreive nil)
  )
  (if (= pt2 nil)
    (setq retreive nil)
  )
  (if (= pt2 nil)
    (alert "No Distance Selected")
  )
  (setq retvmode nil)
)
;;;=============================================================
(defun rtvhdist (/)
  (setq pt1 nil)
  (setq pt2 nil)
  (setq pt1 (getpoint "\nSelect First Point:"))
  (if (/= pt1 nil)
    (setq pt2 (getpoint pt1 "\nDISTANCE: Select Second Point:"))
  )
  (if (/= pt2 nil)
    (progn
      (setq pt1 (reverse pt1))
      (setq pt1 (cdr pt1))
      (setq pt1 (reverse pt1))       ;
      (setq pt2 (reverse pt2))
      (setq pt2 (cdr pt2))
      (setq pt2 (reverse pt2))       ;
      (setq hdistrt (distance pt1 pt2))
      (setq retreive (rtos hdistrt 2 4))
    )
  )
  (if (= pt1 nil)
    (setq retreive nil)
  )
  (if (= pt2 nil)
    (setq retreive nil)
  )
  (if (= pt2 nil)
    (alert "No Distance Selected")
  )
  (setq retvmode nil)
)
;;;=============================================================
(defun rtvang (/)
  (setq angpt nil)
  (setq angpt (getpoint "\nANGLE: Select First Angle Point"))
  (if (/= angpt nil)
    (progn
      (setq angrt (getangle angpt "\nSecond Angle Point"))
      (setq retreive (angtos angrt 0 4))
    )
  )
  (if (= angpt nil)
    (setq retreive nil)
  )
  (if (= angpt nil)
    (alert "No Angle Selected")
  )
  (setq retvmode nil)
)
;;;=============================================================
(defun trigfunc (/)
  (setq num (get_tile "calbox"))
  (setq num (atof num))              ;
  (if (= func 5)
    (progn
      (setq newnum (sqrt num))
    )
  )                                  ;
  (if (= func 6)
    (progn
      (setq newnum (* num num))
    )
  )                                  ;
  (if (= func 7)
    (progn
      (setq newnum (* num num))
      (setq newnum (* newnum num))
    )
  )                                  ;
  (if (= func 8)
    (progn
      (setq num (rtos num 2 8))
      (setq num (angtof num 0))
      (setq newnum (sin num))
    )
  )                                  ;
  (if (= func 9)
    (progn
      (setq num (rtos num 2 8))
      (setq num (angtof num 0))
      (setq newnum (cos num))
    )
  )                                  ;
  (if (= func 10)
    (progn
      (arxload "geomcal" '("cal" "cal"))
      (if (/= num 90)
        (setq newnum (cal "tang(num)"))
      )
      (if (= num 90)
        (alert "Invalid input for function")
      )
      (if (= num 90)
        (setq newnum 0)
      )
    )
  )                                  ;
  (if (= func 11)
    (progn
      (if (> num 0)
        (setq newnum (log num))
      )
      (if (<= num 0)
        (setq newnum 0)
      )
      (if (<= num 0)
        (alert "Invalid input for function")
      )
    )
  )                                  ;
  (if (= func 12)
    (progn
      (setq num (rtos num))
      (setq num (angtof num 0))
      (setq newnum (angtos num 1 5))
    )
  )                                  ;
  (if (= func 13)
    (progn
      (setq negchk (minusp num))
      (if (/= negchk nil)
        (setq newnum (abs num))
      )
      (if (= negchk nil)
        (progn
          (setq dbl (* num 2))
          (setq newnum (- num dbl))
        )
      )
    )
  )                                  ;
  (if (/= func 12)
    (setq newnum (rtos newnum))
  )
  (set_tile "calbox" newnum)
  (set_tile "stus" "Ready")
)
;;;=============================================================
(defun runfunc (/)
  (setq newnum nil)
  (setq num (get_tile "calbox"))
  (if (= num nil)
    (setq num "0")
  )
  (if (= num "")
    (setq num "0")
  )
  (if (= num " ")
    (setq num "0")
  )
  (if (= num "  ")
    (setq num "0")
  )
  (if (= num "   ")
    (setq num "0")
  )
  (if (= num "    ")
    (setq num "0")
  )
  (if (= hold1 nil)
    (setq hold1 "0")
  )
  (setq num (atof num))
  (setq hold1 (atof hold1))          ;
  (if (= func 1)
    (progn
      (setq newnum (+ num hold1))
    )
  )                                  ;
  (if (= func 2)
    (progn
      (setq newnum (- hold1 num))
    )
  )                                  ;
  (if (= func 3)
    (progn
      (setq newnum (* hold1 num))
    )
  )                                  ;
  (if (= func 4)
    (progn
      (setq newnum (/ hold1 num))
    )
  )                                  ;
  (if (/= newnum nil)
    (setq newnum (rtos newnum))
  )
  (if (/= newnum nil)
    (set_tile "calbox" newnum)
  )
  (set_tile "stus" "Ready")
  (setq hold1 nil)
  (setq func nil)
)
;;;=============================================================
(defun clrent (/)
  (set_tile "calbox" "")
)
;;;=============================================================
(defun hold (/)
  (setq hold1 (get_tile "calbox"))   ;
  (if (= func 1)
    (setq action "Adding... ")
  )
  (if (= func 2)
    (setq action "Subtract... ")
  )
  (if (= func 3)
    (setq action "Multiply... ")
  )
  (if (= func 4)
    (setq action "Divide... ")
  )                                  ;
  (setq status (strcat action hold1))
  (set_tile "stus" status)
  (clrent)
)
;;;=============================================================
(defun setnum1 (/)
  (setq num (get_tile "calbox"))
  (setq ritenum "00")
  (setq newnum (strcat num ritenum))
  (set_tile "calbox" newnum)
)
;;;=============================================================
(defun setnum2 (/)
  (setq num (get_tile "calbox"))
  (setq ritenum ".")
  (setq newnum (strcat num ritenum))
  (set_tile "calbox" newnum)
)
;;;=============================================================
(defun setnum (/)
  (setq num (get_tile "calbox"))
  (setq ritenum (rtos ritenum 2 0))
  (setq newnum (strcat num ritenum))
  (set_tile "calbox" newnum)
)
;;;=============================================================
(defun mainclc (/)
  (setq precboxlst (list "0" "0.0" "0.00" "0.000" "0.0000" "0.00000" "0.000000"
                       "0.0000000" "0.00000000"
                   ))                ;
  ;;;crt;;;(setq dcl_id (load_dialog "\\sai_toolbox\\icalc\\calc.dcl"))
  (setq dcl_id (load_dialog "calc.dcl"))
  (if (not (new_dialog "calc" dcl_id))
    (exit)
  )                                  ;
  ;;
  (if (/= hold1 nil)
    (set_tile "stus" status)
  )
  (if (/= 000remem000 nil)
    (set_tile "memory" memsho)
  )
  (if (/= retreive nil)
    (set_tile "calbox" retreive)
  )                                  ;
  (princ "\nCalculator Ready...")
  (princ)                            ;
  (action_tile "one" "(setq ritenum 1)(setnum)")
  (action_tile "two" "(setq ritenum 2)(setnum)")
  (action_tile "three" "(setq ritenum 3)(setnum)")
  (action_tile "four" "(setq ritenum 4)(setnum)")
  (action_tile "five" "(setq ritenum 5)(setnum)")
  (action_tile "six" "(setq ritenum 6)(setnum)")
  (action_tile "seven" "(setq ritenum 7)(setnum)")
  (action_tile "eight" "(setq ritenum 8)(setnum)")
  (action_tile "nine" "(setq ritenum 9)(setnum)")
  (action_tile "zero" "(setq ritenum 0)(setnum)")
  (action_tile "dzero" "(setnum1)")
  (action_tile "dcpt" "(setnum2)")   ;
  (action_tile "plus" "(setq func 1)(hold)")
  (action_tile "minus" "(setq func 2)(hold)")
  (action_tile "multiply" "(setq func 3)(hold)")
  (action_tile "divide" "(setq func 4)(hold)")
  (action_tile "sqrt" "(setq func 5)(trigfunc)")
  (action_tile "xsqr" "(setq func 6)(trigfunc)")
  (action_tile "xcube" "(setq func 7)(trigfunc)")
  (action_tile "xsin" "(setq func 8)(trigfunc)")
  (action_tile "xcos" "(setq func 9)(trigfunc)")
  (action_tile "xtan" "(setq func 10)(trigfunc)")
  (action_tile "xlog" "(setq func 11)(trigfunc)")
  (action_tile "xdms" "(setq func 12)(trigfunc)")
  (action_tile "chgsgn" "(setq func 13)(trigfunc)")
  (action_tile "equals" "(runfunc)") ;
  (action_tile "gtang" "(done_dialog)(setq retvmode 1)")
  (action_tile "gdist" "(done_dialog)(setq retvmode 2)")
  (action_tile "gslope" "(done_dialog)(setq retvmode 3)")
  (action_tile "gvdist" "(done_dialog)(setq retvmode 4)")
  (action_tile "grad" "(done_dialog)(setq retvmode 5)")
  (action_tile "gele" "(done_dialog)(setq retvmode 6)")
  (action_tile "garea" "(done_dialog)(setq retvmode 7)")
  (action_tile "precbox" "(chgprec)") ;
  (action_tile "clear" "(clrcalc)")  ;
  (action_tile "rm" "(rmem)")
  (action_tile "cm" "(cmem)")
  (action_tile "sm" "(msto)")        ;
  (action_tile "accept" "(readcalc)(setq calcrun 1)(done_dialog)")
  (action_tile "help" "(ichelp)")    ;
  (start_list "precbox")             ;Specify the name of the list box
  (mapcar 'add_list precboxlst)      ;Specify the AutoLISP list         
  (end_list)                         ;
  (set_tile "precbox" prec)          ;
  (start_dialog)
  (unload_dialog dcl_id)
  (done_dialog)                      ;
  ;;
  (if (= retvmode 1)
    (rtvang)
  )
  (if (= retvmode 2)
    (rtvhdist)
  )
  (if (= retvmode 3)
    (rtvsdist)
  )
  (if (= retvmode 4)
    (rtvzdist)
  )
  (if (= retvmode 5)
    (rtvrad)
  )
  (if (= retvmode 6)
    (rtvelev)
  )
  (if (= retvmode 7)
    (rtvarea)
  )                                  ;
)
;;;=============================================================
(defun c:icalc (/)
  (setq prec (getvar "LUPREC"))
  (setq prec (itoa prec))
  (setq calcrun 0)
  (setq retreive nil)
  ;;;crt;;;(auth)
  (while (= calcrun 0)
    (mainclc)
  )
  (if (= calcrun 1)
    (command 000read000)
  )
)
[/php]

xmchy

老大能不能解释一下，看不太懂，是不是计算的程序啊。

xjlmlxbq

有个说明就好了

shisj

请教一下楼主，这个程序能实现什麽功能啊？

ycao

程序是干什么用的？

zhang8755

像这样没头没脑的程序建议版主扣分

小雨思铃

autolisp

f5612140

最初由 小雨思铃 发布
[B]autolisp [/B]

然後呢?

aaddff

莫名其妙

陌生人

大概是从某个软件里面摘下来的吧，没有那个软件，这些lisp也没什么大用处，最多是参考一下罢了，但是谁有这个心思呢？
(defun buyit (/)
  (startapp "\sai_toolbox\icalc\support\autoflsh.exe")
)
sai_toolbox   ， sai，得赛？

斩泪

变态垃圾帖
斑竹口分啊

llccadd

楼主应该给说明一下的