[编程交流] 阿尔托Lisp程序

(defun dtr (a)
 (* pi (/ a 180.0))
)
(defun addz (pos inc / z)
(setq z (caddr pos)
          z (+ inc z)
          pos (list (car pos) (cadr pos) z)
          )
)
(defun rnge (bot top)
(setq r (rand (- top bot))
        r (+ bot r))
)
;
(defun rand (range / x z r)
(if (not seed) (setq seed 350))
(setq x (1 + (* seed 2197.0))
           z (fix (/ x 4096.0))
           seed (fix (- x (* z 4096.0)))
           r (fix (1 + (abs (* (/ seed 4096.0) (- range 1.0)))))
)
)                
(defun dvolp (pcn)
(setq radb (distance ps pe)
        angb (angle ps pcn)
        psb (polar ps ang radb)
        peb (polar pe (* ang anginc) radb)
        )
)
;
(defun drawvolp (pcn)
(setq radb (distance ps pe)
        angb (angle ps pcn)
        psb (polar ps ang radb)
        peb (polar pe (+ ang anginc) radb)
        radc (distance psb speb)
        angc (angle psb speb)
        angd (angle peb pe)
        ange (angle ps pe)
        angf (angle pe ps)
        angg (angle peb pe)
                psc (polar psb angc (/ radc 2))
                psoa (polar psb angc (/ radc 2))
                psob (polar ps angc radc)
                psn (polar psob ange radc)
                peoa (polar pe angg (/ radc 2))
                peob (polar pe angg radc)
                pen (polar peob angf radc)
                        htrad1 (distance psc peb)
                        htrad2 (distance psoa peoa)
                        htrad3 (distance psob peob)
                                psnht (addz psn htrad3)
                                psoaht (addz psoa htrad2)
                                pscht (addz psoa htrad1)
                                penht (addz pen htrad3)
                                peoaht (addz peoa htrad2)
                                pebht (addz peb htrad1)
                                        )
                        (command "layer" "m" "line" "c" 5 "" "")
                        (command "3dface" psoa psoaht pscht psc "")
                        (command "3dface" psc pscht pebht peb"")
                        (command "3dface" peb pebht peoaht peoa "")
                        (command "3dface" peoa peoaht penht pen "")
                        (command "3dface" pen penht psnht psn "")
                        (command "3dface" psn psnht psoaht psoa "")
                        (command "3dface" pebht peoaht penht pebht "")
                        (command "3dface" pscht psoaht psnht pscht "")
                        (command "3dface" pebht penht psnht pscht "")
)
(defun dvolreg (pcn)
(setq radt (fix (* (distance pte pts) (sqrt 2)))
        anga (angle pts pcn)
        angb (angle pte pcn)
        ptsb (polar pts anga radt)
        pteb (polar pte angb radt)
        htrad (distance pte pts)
                ptsht (addz pts htrad)
                ptsbht (addz ptsb htrad)
                pteht (addz pte htrad)
                ptebht (addz pteb htrad)
                p1val (rnge 1 (fix (/ radt 2.7)))
                 outang (angle pte pts)
                 innang (angle pteb ptsb)
                 ptemid (polar pte outang (/ htrad 2))
                 ptebmid (polar pteb innang (/ (distance pteb ptsb) 2))
                 midang (angle ptebmid ptemid)
                 p4val (rnge 1 p1val)
                 npte1 (polar pte angb p4val))
                (if (>= cnter 1) (setq npte1 npts1))
                (if (= cnter 0) (setq p2val (rnge 1 (fix (/ htrad 6)))))
                (if (= cnter 0) (setq p3val (rnge 1 p1val)))
        (setq npte2 (polar npte1 (+ angb (dtr 90)) p2val)
                npte3 (polar npte2 midang p3val)
                npts1 (polar pts anga p4val)
                npts2 (polar npts1 (- anga (dtr 90)) p2val)
                npts3 (polar npts2 midang p3val)
                npte1ht (addz npte1 htrad)
                npte2ht (addz npte2 htrad)
                npte3ht (addz npte3 htrad)
                npts1ht (addz npts1 htrad)
                npts2ht (addz npts2 htrad)
                npts3ht (addz npts3 htrad))
        (command "layer" "m" "line" "c" 5 "" "")
        (command "3dface" pteb ptebht npte1ht npte1 "")
        (command "3dface" npte1 npte1ht npte2ht npte2 "")
        (command "3dface" npte2 npte2ht npte3ht npte3 "")
        (command "3dface" npte3 npte3ht npts3ht npts3 "")
        (command "3dface" npts3 npts3ht npts2ht npts2 "")
        (command "3dface" npts2 npts2ht npts1ht npts1 "")
        (command "3dface" npts1 npts1ht ptsbht ptsb "")
        (command "3dface" ptsb ptsbht ptebht pteb "")
        (command "3dface" ptebht npte1ht npte2ht npte3ht "")
        (command "3dface" npts3ht npts2ht npts1ht ptsbht "")
        (command "3dface" ptebht npte3ht npts3ht ptsbht "")
(setq pteb ptsb
        pte pts)
)
(defun prog ()
(command "erase" (ssget "x") "")
(command "redraw")
(setq small (list 300 300)
      large (list 1000 1000))
(command "zoom" "w" small large)
(command "layer" "m" "arcs" "c" 3 "" "")
(setvar "cmdecho" 0)
(setvar "pdmode" 35)
(setvar "pdsize" 1)
(setq pc (getpoint "\nPick a Point: ")
        rd (getpoint pc "\nPick Radius and Start Angle: ")
        anginc (getangle "\nEnter Angle in Degrees: ")
      rad (distance pc rd)
        ang (angle pc rd)
        ps (polar pc ang rad)
        pe (polar pc (+ ang anginc) rad)
                        )
(command "arc" "c" pc ps pe)
(setq cntr (fix (/ 360 (atof (angtos anginc))))
        cntb (- (/ cntr 2) 1)
                n "t")
(while n
(setq speb peb
        ang (angle pe pc)
        angrev (angle pc pe)
        rad (* rad (sqrt 2))
        pcb pc
        pc (polar pe ang rad)
        ps pe
        pe (polar pc (+ angrev anginc) rad))
        (command "layer" "m" "arcs" "c" 3 "" "")
        (command "arc" "c" pc ps pe)
        (if (> cntr cntb) (dvolp pcb))
        (if (<= cntr cntb) (drawvolp pcb))
        (command "layer" "m" "pnts" "c" 1 "" "")
        (command "point" pe)
                (setq cntr (- cntr 1))
                (if (= cntr 0) (setq n nil))
        (command "layer" "m" "arcs" "c" 3 "" "")
        (command "arc" "c" pc ps pe)
                )
                (command "zoom" "e")
)
(defun reg ()
(command "erase" (ssget "x") "")
(setq small (list 300 300)
      large (list 1000 1000))
(command "zoom" "w" small large)
(command "redraw")
(command "layer" "m" "arcs" "c" 3 "" "")
(setvar "cmdecho" 0)
(setvar "pdmode" 35)
(setvar "pdsize" 1)
(setq pc (getpoint "\nPick a Point: ")
        rd (getpoint pc "\nPick Radius and Start Angle: ")
        anginc (getangle "\nEnter Angle in Degrees: ")
      seed (getreal "\nEnter Seed: ")
        pc1 pc
        rad (distance pc rd)
        ang (angle pc rd)
        ps (polar pc ang rad)
        pe (polar pc (+ ang anginc) rad))
                (command "pline")
                (setq cntr (fix (/ 360 (atof (angtos anginc))))
                        cntb (/ cntr 2)
                n "t")
        (while n
                (setq ang (angle pe pc)
                        angrev (angle pc pe)
                        rad (* rad (sqrt 2))
                        pcb pc
                        pc (polar pe ang rad)
                        ps pe
                        pe (polar pc (+ angrev anginc) rad))
        (if (<= cntr cntb) (command ps "arc" "ce" pc pe))
        (if (= cntr cntb) (setq ps1 ps))
                (setq cntr (- cntr 1))
        (if (< cntr 0) (setq n nil))
        )
                (command "")
                (command "line" ps1 pe "")
                (command "layer" "m" "pnts" "c" 1 "" "")
                (command "zoom" "e" "")
                (command "divide" ps (rnge 5 15))
                        (setq pte pe
                                ss1 (ssget "x" (list (cons 0 "point")))
                                num (sslength ss1)
                                cnter 0)
                        (repeat num
                (setq pts (cdr (assoc 10 (entget (ssname ss1 cnter)))))
                                (dvolreg pcb)
                                (setq cnter (1+ cnter))
                                )
                                (command "zoom" "e")
)
 
(defun c:try ()
        (initget "Prog Reg")
        (setq answer (getkword "\nWhat do you want <Prog/Reg>? "))
        (cond
                ((= answer "Prog") (prog))
                ((= answer "Reg") (reg))
        )
)

(command "erase" (ssget "x") "")

(if (setq ss (ssget "x")) (command "erase" ss ""))

(1 + ...)

(1+ ...)

(defun c:test ( / answer )
(initget "Prog Reg")
(or (setq answer (getkword "\nWhat do you want [Prog/Reg] <Prog> ? ")) (setq answer "Prog"))
(cond
        ((and (= answer "Prog") (= 'SUBR (type prog))) (princ "\nChoosed: Prog") (prog))
        ((and (= answer "Reg") (= 'SUBR (type reg))) (princ "\nChoosed: Reg") (reg))
)
(princ)
)

(defun addz (pos inc / z)
(and 
        pos (listp pos) (numberp inc)
        (setq pos (list (car pos) (cadr pos) (+ inc (caddr pos))))
)
pos
)
(defun rnge (bot top)
(and
        (apply 'and (mapcar 'numberp (list bot top)))
        (setq        r (+ bot (rand (- top bot))))
)
r
)
(defun rand (range / x z r)
(and
        (or (numberp seed) (setq seed 350))
        (numberp range)
        (setq x (1+ (* seed 2197.0)))
        (setq z (fix (/ x 4096.0)))
        (setq seed (fix (- x (* z 4096.0))))
        (setq r (fix (1+ (abs (* (/ seed 4096.0) (- range 1.0))))))
)
r
)
(defun dvolp (pcn)
(and
        pcn (listp pcn) (apply 'and (mapcar 'numberp pcn))
        (setq radb (distance ps pe))
        (setq angb (angle ps pcn))
        (setq psb (polar ps ang radb))
        (setq peb (polar pe (* ang anginc) radb))
)
peb
)

(command "layer" "m" "line" "c" 5 "" "")
(command "3dface" psoa psoaht pscht psc "")
(command "3dface" psc pscht pebht peb"")
(command "3dface" peb pebht peoaht peoa "")
(command "3dface" peoa peoaht penht pen "")
(command "3dface" pen penht psnht psn "")
(command "3dface" psn psnht psoaht psoa "")
(command "3dface" pebht peoaht penht pebht "")
(command "3dface" pscht psoaht psnht pscht "")
(command "3dface" pebht penht psnht pscht "")

(command
"_.LAYER" "m" "line" "c" 5 "" ""
"_.3DFACE" "_non" psoa "_non" psoaht "_non" pscht "_non" psc ""
"_.3DFACE" "_non" psc "_non" pscht "_non" pebht "_non" peb ""
"_.3DFACE" "_non" peb "_non" pebht "_non" peoaht "_non" peoa ""
"_.3DFACE" "_non" peoa "_non" peoaht "_non" penht "_non" pen ""
"_.3DFACE" "_non" pen "_non" penht "_non" psnht "_non" psn ""
"_.3DFACE" "_non" psn "_non" psnht "_non" psoaht "_non" psoa ""
"_.3DFACE" "_non" pebht "_non" peoaht "_non" penht "_non" pebht ""
"_.3DFACE" "_non" pscht "_non" psoaht "_non" psnht "_non" pscht ""
"_.3DFACE" "_non" pebht "_non" penht "_non" psnht "_non" pscht ""
)

(setq pc (getpoint "\nPick a Point: ")
rd (getpoint pc "\nPick Radius and Start Angle: ")
anginc (getangle "\nEnter Angle in Degrees: ")
seed (getreal "\nEnter Seed: ")
...
)

... pe (polar pc (+ ang anginc) rad)