;Two types of routines generating Parabola curves

;1) Simple - "PARABOLA" command (by Arkance Systems):

(defun C:Parabola ( /  oldos ptApex pt1 pt2 pt axvec ang1 pt111 pt222 ptCApex)
  (setq oldos (getvar "osmode"))
  (setq ptApex (getpoint "\nPick the apex point of parabola: "))
  (setq pt1 (getpoint "\nPick one endpoint of the parabola: "))
  (setq pt (getpoint ptApex "\nPick the symmetry-axis point of the parabola: "))
  (if (/= (logand oldos 16384) 16384)
   (setvar 'osmode (+ oldos 16384))
  ) 
  (setq axvec (mapcar '- pt ptApex))
  (setq ang1 (angle axvec '(0.0 0.0 0.0)))
  (setq pt2 (trans (list (- (+ (car (trans ptApex 0 axvec)) (car (trans ptApex 0 axvec))) (car (trans pt1 0 axvec))) 0.0 (caddr (trans pt1 0 axvec))) axvec 0))
  (setq pt111 pt1  pt222 pt2)
  (setq ptCApex (polar ptApex ang1 (distance ptApex (mapcar '/ (mapcar '(lambda ( a b ) (+ a b)) pt111 pt222) (list 2.0 2.0 2.0)))))
  (entmakex (append '((0 . "SPLINE") (100 . "AcDbEntity") (100 . "AcDbSpline") (210 0.0 0.0 1.0) (70 . 12) (71 . 2) (72 . 6) (73 . 3) (74 . 0) (42 . 1.0e-010) (43 . 1.0e-010) (40 . 0.0) (40 . 0.0) (40 . 0.0) (40 . 1.0) (40 . 1.0) (40 . 1.0)) (list (cons 10 pt111) (cons 41 1.0) (cons 10 ptCApex) (cons 41 1.0) (cons 10 pt222) (cons 41 1.0)) ))
  (setvar 'osmode oldos)
(princ)
)

;--------------------------------------------------------------------------------

;2) Advanced - "PARABOLAdyn" command (by M.Ribar and L.Mac)

(defun C:ParabolaDyn ( / LM:acapp *error* GrSnap-subs parabmake doc alo spc cmd ape osm osf msg str gr1 gr2 ff tmp done ptt pt1 pt2 pt axvec aa ls ti )

  ;; Application Object  -  Lee Mac
  ;; Returns the VLA Application Object
  ;; Mod. by M.R.

  (defun LM:acapp nil
    (eval
      (list 'defun 'LM:acapp '( / cad ) 
        (if (vl-catch-all-error-p (setq cad (vl-catch-all-apply (function vlax-get-acad-object) nil)))
          (progn (vl-load-com) (vlax-get-acad-object))
          cad
        )
      )
    )
    (LM:acapp)
  )

  (defun *error* ( m )
    (if ls
      (progn
        (foreach x ls
          (setq x nil)
        )
        (setq ls nil)
      )
    )
    (if command-s
      (command-s "_.undo" "_e")
      (vl-cmdf "_.undo" "_e")
    )
    (if osm (setvar 'osmode osm))
    (if cmde (setvar 'cmdecho cmde))
    (if ape (setvar 'aperture ape))
    (if doc (vla-regen doc acactiveviewport))
    (if m (prompt m))
    (princ)
  )

  ;;; GrSnap - Lee Mac
  ;;; Mod. by M.R. 2022.

  (defun GrSnap-subs nil
    (eval
      (progn

        ;; Object Snap for grread: Snap Function  -  Lee Mac
        ;; Returns: [fun] A function requiring two arguments:
        ;; p - [lst] UCS Point to be snapped
        ;; o - [int] Object Snap bit code
        ;; The returned function returns either the snapped point (displaying an appropriate snap symbol)
        ;; or the supplied point if the snap failed for the given Object Snap bit code.

        (defun LM:grsnap:snapfunction ( )
          (eval
            (list 'lambda '( p o / q )
              (list 'if '(zerop (logand 16384 o))
                (list 'if
                 '(setq q
                    (cdar
                      (vl-sort
                        (vl-remove-if 'null
                          (mapcar
                            (function
                              (lambda ( a / b )
                                (if (and (= (car a) (logand (car a) o)) (setq b (osnap p (cdr a))))
                                  (list (distance p b) b (car a))
                                )
                              )
                            )
                           '(
                              (0001 . "_end")
                              (0002 . "_mid")
                              (0004 . "_cen")
                              (0008 . "_nod")
                              (0016 . "_qua")
                              (0032 . "_int")
                              (0064 . "_ins")
                              (0128 . "_per")
                              (0256 . "_tan")
                              (0512 . "_nea")
                              (2048 . "_app")
                              (8192 . "_par")
                            )
                          )
                        )
                        (function (lambda ( a b ) (< (car a) (car b))))
                      )
                    )
                  )
                  (list 'LM:grsnap:displaysnap '(car q)
                    (list 'cdr
                      (list 'assoc '(cadr q)
                        (list 'quote
                          (LM:grsnap:snapsymbols
                            (atoi (cond ((getenv "AutoSnapSize")) ("5")))
                          )
                        )
                      )
                    )
                    (LM:OLE->ACI
                      (if (= 1 (getvar 'cvport))
                        (atoi (cond ((getenv "Layout AutoSnap Color")) ("117761")))
                        (atoi (cond ((getenv  "Model AutoSnap Color")) ("104193")))
                      )
                    )
                  )
                )
              )
             '(cond ((car q)) (p))
            )
          )
        )

        ;; Object Snap for grread: Display Snap  -  Lee Mac
        ;; pnt - [lst] UCS point at which to display the symbol
        ;; lst - [lst] grvecs vector list
        ;; col - [int] ACI colour for displayed symbol
        ;; Returns nil

        (defun LM:grsnap:displaysnap ( pnt lst col / scl )
          (setq scl (/ (getvar 'viewsize) (cadr (getvar 'screensize))))
          (setq pnt (trans pnt 1 1))
          (grvecs (cons col (mapcar (function (lambda ( x ) (mapcar (function +) (mapcar (function *) x (list scl scl)) pnt))) lst))
            ;|
            (list
              (list 1.0 0.0 0.0 0.0)
              (list 0.0 1.0 0.0 0.0)
              (list 0.0 0.0 1.0 0.0)
              (list 0.0 0.0 0.0 1.0)
            ) ;;; This matrix is for presentation of vectors - start/end points should be supplied in DCS ; if you omit matrix - start/end points should be supplied in UCS
            |;
          )
        )

        ;; Object Snap for grread: Snap Symbols  -  Lee Mac
        ;; p - [int] Size of snap symbol in pixels
        ;; Returns: [lst] List of vector lists describing each Object Snap symbol

        (defun LM:grsnap:snapsymbols ( p / -p -q -r a c i l q r )
          (setq -p (- p) q (1+  p)
                -q (- q) r (+ 2 p)
                -r (- r) i (/ pi 6)
                 a 0.0
          )
          (repeat 12
            (setq l (cons (list (* r (cos a)) (* r (sin a))) l)
                  a (- a i)
            )
          )
          (setq c (apply 'append (mapcar 'list (cons (last l) l) l)))
          (list
            (list 0001
              (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
              (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
            )
            (list 0002
              (list -r -q) (list 0  r) (list 0  r) (list r -q)
              (list -p -p) (list p -p) (list p -p) (list 0  p) (list 0  p) (list -p -p)
              (list -q -q) (list q -q) (list q -q) (list 0  q) (list 0  q) (list -q -q)
            )
            (cons 0004 c)
            (vl-list* 0008 (list -r -r) (list r r) (list r -r) (list -r r) c)
            (list 0016
              (list p 0) (list 0 p) (list 0 p) (list -p 0) (list -p 0) (list 0 -p) (list 0 -p) (list p 0)
              (list q 0) (list 0 q) (list 0 q) (list -q 0) (list -q 0) (list 0 -q) (list 0 -q) (list q 0)
              (list r 0) (list 0 r) (list 0 r) (list -r 0) (list -r 0) (list 0 -r) (list 0 -r) (list r 0)
            )
            (list 0032
              (list  r r) (list -r -r) (list  r q) (list -q -r) (list  q r) (list -r -q)
              (list -r r) (list  r -r) (list -q r) (list  r -q) (list -r q) (list  q -r)
            )
            (list 0064
              '( 0  1) (list  0  p) (list  0  p) (list -p  p) (list -p  p) (list -p -1) (list -p -1) '( 0 -1)
              '( 0 -1) (list  0 -p) (list  0 -p) (list  p -p) (list  p -p) (list  p  1) (list  p  1) '( 0  1)
              '( 1  2) (list  1  q) (list  1  q) (list -q  q) (list -q  q) (list -q -2) (list -q -2) '(-1 -2)
              '(-1 -2) (list -1 -q) (list -1 -q) (list  q -q) (list  q -q) (list  q  2) (list  q  2) '( 1  2)
            )
            (list 0128
              (list (1+ -p) 0) '(0 0) '(0 0) (list 0 (1+ -p))
              (list (1+ -p) 1) '(1 1) '(1 1) (list 1 (1+ -p))
              (list -p q) (list -p -p) (list -p -p) (list q -p)
              (list -q q) (list -q -q) (list -q -q) (list q -q)
            )
            (vl-list* 256 (list -r r)  (list r r) (list -r (1+ r)) (list r (1+ r)) c)
            (list 0512
              (list -p -p) (list  p -p) (list -p  p) (list p p) (list -q -q) (list  q -q)
              (list  q -q) (list -q  q) (list -q  q) (list q q) (list  q  q) (list -q -q)
            )
            (list 2048
              (list   -p     -p) (list    p      p) (list   -p      p) (list    p     -p)
              (list (+ p 05) -p) (list (+ p 06) -p) (list (+ p 05) -q) (list (+ p 06) -q)
              (list (+ p 09) -p) (list (+ p 10) -p) (list (+ p 09) -q) (list (+ p 10) -q)
              (list (+ p 13) -p) (list (+ p 14) -p) (list (+ p 13) -q) (list (+ p 14) -q)
              (list -p -p) (list p -p) (list p -p) (list p p) (list p p) (list -p p) (list -p p) (list -p -p)
              (list -q -q) (list q -q) (list q -q) (list q q) (list q q) (list -q q) (list -q q) (list -q -q)
            )
            (list 8192 (list r 1) (list -r -q) (list r 0) (list -r -r) (list r q) (list -r -1) (list r r) (list -r 0))
          )
        )

        ;; Object Snap for grread: Parse Point  -  Lee Mac
        ;; bpt - [lst] Basepoint for relative point input, e.g. @5,5
        ;; str - [str] String representing point input
        ;; Returns: [lst] Point represented by the given string, else nil

        (defun LM:grsnap:parsepoint ( bpt str / str->lst lst )

          (defun str->lst ( str / pos )
            (if (setq pos (vl-string-position 44 str))
              (cons (substr str 1 pos) (str->lst (substr str (+ pos 2))))
              (list str)
            )
          )

          (if (wcmatch str "`@*")
              (setq str (substr str 2))
              (setq bpt (list 0.0 0.0 0.0))
          )
          (if
            (and
              (setq lst (mapcar (function distof) (str->lst str)))
              (vl-every (function numberp) lst)
              (< 1 (length lst) 4)
            )
            (mapcar (function +) bpt lst)
          )
        )

        ;; Object Snap for grread: Snap Mode  -  Lee Mac
        ;; str - [str] Object Snap modifier
        ;; Returns: [int] Object Snap bit code for the given modifier, else nil

        (defun LM:grsnap:snapmode ( str )
          (vl-some
            (function
              (lambda ( x )
                (if (wcmatch (car x) (strcat (strcase str t) "*"))
                  (progn (setq ff t) (princ (cadr x)) (caddr x))
                )
              )
            )
           '(
              ("endpoint"      " of " 0001)
              ("midpoint"      " of " 0002)
              ("center"        " of " 0004)
              ("node"          " of " 0008)
              ("quadrant"      " of " 0016)
              ("intersection"  " of " 0032)
              ("insert"        " of " 0064)
              ("perpendicular" " to " 0128)
              ("tangent"       " to " 0256)
              ("nearest"       " to " 0512)
              ("appint"        " of " 2048)
              ("parallel"      " to " 8192)
              ("none"          ""     16384)
            )
          )
        )

        ;; OLE -> ACI  -  Lee Mac
        ;; Args: c - [int] OLE Colour
        (defun LM:OLE->ACI ( c )
          (apply (function LM:RGB->ACI) (LM:OLE->RGB c))
        )

        ;; OLE -> RGB  -  Lee Mac
        ;; Args: c - [int] OLE Colour
        (defun LM:OLE->RGB ( c )
          (mapcar (function (lambda ( x ) (lsh (lsh (fix c) x) -24))) (list 24 16 8))
        )

        ;; RGB -> ACI  -  Lee Mac
        ;; Args: r,g,b - [int] Red, Green, Blue values
        (defun LM:RGB->ACI ( r g b / c o )
          (if (setq o (vla-getinterfaceobject (LM:acapp) (strcat "autocad.accmcolor." (substr (getvar 'acadver) 1 2))))
            (progn
              (setq c (vl-catch-all-apply (function (lambda ( ) (vla-setrgb o r g b) (vla-get-colorindex o)))))
              (vlax-release-object o)
              (if (vl-catch-all-error-p c)
                (prompt (strcat "\nError: " (vl-catch-all-error-message c)))
                c
              )
            )
          )
        )

      )
    )
  ) ;;; end GrSnap-subs

  (defun parabmake ( pt1 ptt pt2 aa / mid pt11 pt22 ptcv mp )

    (defun mid ( p1 p2 )
      (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
    )

    (mapcar (function set) (list (quote pt11) (quote pt22)) (list pt1 pt2))
    (setq mp (mid pt11 pt22))
    (if (minusp (- (caddr (trans ptt 1 axvec)) (caddr (trans mp 1 axvec))))
      (setq ptcv (polar ptt aa (* -1.0 (distance ptt mp))))
      (setq ptcv (polar ptt aa (* +1.0 (distance ptt mp))))
    )
    (entmakex
      (append
       '((0 . "SPLINE") (100 . "AcDbEntity") (100 . "AcDbSpline") (210 0.0 0.0 1.0) (70 . 12) (71 . 2) (72 . 6) (73 . 3) (74 . 0) (42 . 1.0e-010) (43 . 1.0e-010) (40 . 0.0) (40 . 0.0) (40 . 0.0) (40 . 1.0) (40 . 1.0) (40 . 1.0))
        (list
          (cons 10 (trans pt11 1 0))
          (cons 41 1.0)
          (cons 10 (trans ptcv 1 0))
          (cons 41 1.0)
          (cons 10 (trans pt22 1 0))
          (cons 41 1.0)
        )
      )
    )
  )

  (setq doc (vla-get-activedocument (LM:acapp)))
  (setq spc (vla-get-block (setq alo (vla-get-activelayout doc))))
  (GrSnap-subs)
  (setq ls (list 'LM:grsnap:snapfunction 'LM:grsnap:displaysnap 'LM:grsnap:snapsymbols 'LM:grsnap:parsepoint 'LM:grsnap:snapmode 'LM:OLE->ACI 'LM:OLE->RGB 'LM:RGB->ACI))
  (setq cmd (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (setq ape (getvar 'aperture))
  (setvar 'aperture 10)
  (setq osf (LM:grsnap:snapfunction))
  (setq osm (getvar 'osmode))
  (setq msg "\nPick or specify point, or shift+right click for OSNAP dialog, or just type desired OSNAP : ")
  (setq str "")
  (if (equal 0 (getvar 'undoctl)) 
    (vl-cmdf "_.undo" "_all")
  )
  (if
    (or
      (not (equal 1 (logand 1 (getvar 'undoctl))))
      (equal 2 (logand 2 (getvar 'undoctl)))
    )
    (vl-cmdf "_.undo" "_control" "_all")
  )
  (if (equal 4 (logand 4 (getvar 'undoctl)))
    (vl-cmdf "_.undo" "_auto" "_off")
  )
  (while (equal 8 (logand 8 (getvar 'undoctl)))
    (vl-cmdf "_.undo" "_end")
  )
  (vl-cmdf "_.undo" "_begin")

  (setq osm (getvar 'osmode))
  (setq cmde (getvar 'cmdecho))
  (setvar 'cmdecho 0)
  (setq ptt (getpoint "\nPick apex point of parabola : "))
  (setq pt (getpoint ptt "\nPick point that define axis between two branches of parabola : "))
  (setq axvec (mapcar (function -) (trans pt 1 0) (trans ptt 1 0)))
  (setq aa (angle (list 0.0 0.0) (mapcar (function -) pt ptt)))
  (prompt "\nPick point through witch passes parabola... [ ~ (new apex point input) ] : ")
  (while
    (and
      (null done)
      (progn
        (setq gr1 (grread t 15 0) gr2 (if (and (cadr gr1) (= (type (cadr gr1)) 'list) (= (length (cadr gr1)) 3) (and gr2 (not (equal gr2 (cadr gr1))))) (progn (redraw) (cadr gr1)) (cadr gr1)) gr1 (car gr1))
        (cond
          ( (or (= 5 gr1) (and (= gr1 11) (or (= gr2 1000) (= gr2 2000))))
            t
          )
          ( (= 3 gr1)
            (setq done t)
          )
          ( (= 2 gr1)
            (if ff
              (progn (setq ff nil) (princ msg))
            )
            (cond
              ( (= 6 gr2)
                (if (zerop (logand 16384 (setq osm (setvar 'osmode (boole 6 16384 (getvar 'osmode))))))
                  (princ "\n<Osnap on>")
                  (princ "\n<Osnap off>")
                )
              )
              ( (= 8 gr2)
                (if (< 0 (strlen str))
                  (progn (princ "\010\040\010") (setq str (substr str 1 (1- (strlen str)))))
                )
                t
              )
              ( (< 32 gr2 126)
                (setq str (strcat str (princ (chr gr2))))
              )
              ( (member gr2 '(13 32))
                (cond
                  ( (= "" str) nil )
                  ( (setq gr2 (LM:grsnap:parsepoint (osf (cadr (grread t)) osm) str))
                    (setq str "")
                    (setq done t gr1 3)
                  )
                  ( (setq tmp (LM:grsnap:snapmode str))
                    (setq str "")
                    (setvar 'osmode tmp)
                    (setq osm tmp)
                    (setq gr2 (osf (cadr (grread t)) osm))
                    (setq ff t)
                  )
                )
              )
              ( (= 126 gr2)
                (setq pt (getpoint ptt "\nPick point that define axis between two branches of parabola : "))
                (setq axvec (mapcar (function -) (trans pt 1 0) (trans ptt 1 0)))
                (setq aa (angle (list 0.0 0.0) (mapcar (function -) pt ptt)))
              )
            )
          )
        )
      )
    )
    (setq osm (getvar 'osmode))
    (if (and (= gr1 11) (or (= gr2 1000) (= gr2 2000)))
        (progn (initdia) (vl-cmdf "_.OSNAP") (princ msg) (setq gr1 (grread t 15 0) gr2 (if (and (cadr gr1) (= (type (cadr gr1)) 'list) (= (length (cadr gr1)) 3) (and gr2 (not (equal gr2 (cadr gr1))))) (progn (redraw) (cadr gr1)) (cadr gr1)) gr1 (car gr1)))
    )
    (if (and (= (type gr2) 'list) (= (length gr2) 3))
      (progn
        (setq pt1 (osf gr2 osm))
        (setq pt2 (trans (list (- (car (trans ptt 1 axvec)) (- (car (trans pt1 1 axvec)) (car (trans ptt 1 axvec)))) (- (cadr (trans ptt 1 axvec)) (- (cadr (trans pt1 1 axvec)) (cadr (trans ptt 1 axvec)))) (caddr (trans pt1 1 axvec))) axvec 1))
        (if (and *parabola* (not (vlax-erased-p *parabola*)))
          (entdel *parabola*)
        )
        (setq *parabola* (parabmake pt1 ptt pt2 aa))
        (redraw *parabola* 1)
        (setq ti nil)
        (while (and (or ti (setq ti (car (_vl-times)))) (< (- (car (_vl-times)) ti) 100))) ;; redisplay and wait 0.1 seconds...
      )
    )
    (if (= 3 gr1)
      (setq done t)
    )
  )
  (if (and *parabola* (vlax-erased-p *parabola*))
    (entdel *parabola*)
  )
  (prompt "\nParabola SPLINE is stored in global variable *parabola*...")
  (*error* "\ndone...")
)

(princ "\nPARABOLA and PARABOLADYN commands loaded (2022, Arkance Systems, cadforum.cz; Marko Ribar, Lee Mac, theswamp.org)")
(prin1)