 ; Parabola generator with light path constructor.  Uses the formula Y = Xý/k.
 ; Copyright 1993, 2004 by Rocket Software Ltd.
 ; This is the kind of cool but useless routine I've been bitching about.
 (DEFUN C:PARABOLA (/ coll blip snp orth limch pa pasav high paa pab pincr
                        pconst xval xx aa focus flen lin1 lin2 refl1 refl2)
   (setvar "cmdecho" 0)
   (command "undo" "be")
   (setq coll (getvar "cecolor"))
   (command "color" "red")
   (setq blip (getvar "blipmode"))
   (setvar "blipmode" 0)
   (setq snp (getvar "snapmode"))
   (setvar "snapmode" 0)
   (setq orth (getvar "orthomode"))
   (setvar "orthomode" 0)
   (setq limch (getvar "limcheck"))
   (setvar "limcheck" 0)
 ; -------------------- Get parabola description --------------------
   (If (= (type pa1) 'LIST)
       (setq pa (getpoint pa1 "Start point (<Return> for previous): "))
       (setq pa (getpoint "Start point:")))
   (if (null pa) (setq pa pa1) (setq pa1 pa))
   (setq pa2 (polar pa1 (/ pi 2) 100))
   (setq paa (car pa))
   (setq pab (cadr pa))
   (if (not (or (= (type incr) 'REAL) (= (type incr) 'INT))) (setq incr 1))
   (setq pincr (getdist pa (strcat "\nX increment (" (rtos incr 2 2) "): ")))
   (if pincr (setq incr pincr))
   (if (not (= (type const) 'REAL))
       (setq const 10.0))
   (setq pconst (getdist pa (strcat "\nY scaling factor ("
                                    (rtos const 2 2) "): ")))
   (if pconst (setq const pconst))
   (setq xval incr)
   (setq xx (getint "Number of segments <25>: "))
   (if (not xx) (setq xx 25))
   (setq aa 0)
   (setq ss (ssadd))
 ; -------------------- Construct the parabola --------------------
   (repeat xx
          (setq yval (* (* xval xval) const))            ; y = xý/k
          (setq pb (list (+ paa xval) (+ pab yval)))     ; line end = x,y
          (command "line" pa pb "")
          (setq xval (+ xval incr))                      ; increment x
          (setq aa (1+ aa))
          (grtext -2 (itoa aa))
          (ssadd (entlast) ss)
          (command "mirror" (entlast) "" pa1 pa2 "n")
          (ssadd (entlast) ss)
          (setq pa pb))
   (setq pasav pa)
 ; -------------------- Write the equation --------------------
   (setq pb (list (+ paa xval) (+ pab yval)))
   (setq hh (/ (distance pa pb) 2))
   (setq constx (rtos const 2 5))
   (setq len (strlen constx))
   (while (= (substr constx len 1) "0")
          (setq len (1- len)))
   (if (= (substr constx len 1) ".")
       (setq constx (substr constx 1 (1- len)))
       (setq constx (substr constx 1 len)))
   (setq zz (strcat "Y = X squared/" constx))
   (setq tt (getvar "textstyle"))
   (setq fh (cdr (assoc 40 (tblsearch "style" tt))))
   (if (= fh 0.0)
       (progn
            (setq pa (polar pa1 (* pi 1.5) (* hh 2)))
            (command "text" pa hh "" zz))
       (progn
            (setq pa (polar pa1 (* pi 1.5) (* fh 2)))
            (command "text" pa "" zz)))
   (setq txt (entlast))
 ; -------------------- Reflection calculator --------------------
   (command "color" "cyan")
   (setq pa (getpoint "Pick light source: "))
   (setq pay (cadr pa))                       ; y coord
   (setq high (cadr pasav))                   ; highest line end
   (if (> high pay)
       (progn
            (initget 0 "Yes No")
            (setq pasav
                 (getkword "\nLight source is inside parabola. Move? <Yes>: "))
            (if (/= pasav "No") (setq pay high))))
   (setq num (sslength ss))
   (while (setq so (ssname ss 0))
          (setq sss (entget so))
          (setq num (1- num))
          (setq mid (list (/ (+ (cadr (assoc 10 sss)) (cadr (assoc 11 sss))) 2)
                      (/ (+ (caddr (assoc 10 sss)) (caddr (assoc 11 sss))) 2)))
          (setq strt (list (/ (+ (cadr (assoc 10 sss))
                           (cadr (assoc 11 sss))) 2) pay))
          (command "line" strt mid "")
          (if (and lin1 (null lin2)) (setq lin2 (entlast)))
          (if (null lin1) (setq lin1 (entlast)))
          (setq light (entget (entlast)))
          (setq linang (- (angle (cdr (assoc 10 sss))
                                      (cdr (assoc 11 sss))) pi))
          (setq litang (- (angle (cdr (assoc 10 light))
                                 (cdr (assoc 11 light))) pi))
          (setq difang (- litang linang))
          (setq nuangl (- (+ linang pi) difang))
          (if focus 
                  (setq flen (distance focus mid))
                  (setq flen 25))
          (setq pa (polar mid nuangl flen))
          (command "Color" "yellow")
          (command "line" mid pa "")
          (command "Color" "cyan")
          (if (and refl1 (null refl2))
              (progn
                   (setq refl2 (entget (entlast)))
                   (setq focus (inters (cdr (assoc 10 refl1))
                                       (cdr (assoc 11 refl1))
                                       (cdr (assoc 10 refl2))
                                       (cdr (assoc 11 refl2)) ()))
                   (entmod (subst (cons 11 focus) (assoc 11 refl1) refl1))
                   (entmod (subst (cons 11 focus) (assoc 11 refl2) refl2))
                   (redraw lin1) (redraw lin2)))
          (if (null refl1) (setq refl1 (entget (entlast))))
          (ssdel so ss))
   (setq ss ())
 ;----------------reset entity creation colour----------------
   (cond ((= coll "BYLAYER") (command "color" "BYLAYER"))
         ((= coll "BYBLOCK") (command "color" "BYBLOCK"))
         (t (command "color" (read coll))))
   (setvar "blipmode" blip)
   (setvar "snapmode" snp)
   (setvar "orthomode" orth)
   (setvar "limcheck" limch)
   (command "undo" "end")
 (princ))