;   +-------------------------------------------------------------+
;   | PLType.LSP -- COPYRIGHT 1990 BY LOOKING GLASS MICROPRODUCTS |
;   +-------------------------------------------------------------+
;
(Setq
   version    "1.0"            
   fuzz       1e-8            ; for comparing real numbers
   ucs        1               ; for 'trans function
   <180       Pi              ; 180 degrees in radians
   hold-layer "pltype-hold"   ; layer for converted polylines
)
;-----------------------------------------------------
; Load-time chewing gum
;-----------------------------------------------------
(Princ "\n")
(Setq bcount 0)
(Defun bump ()
   (Setq bcount (1+ bcount))
   (Princ
      (Strcat
         "\rPLType ver. "
         version
         " -- Copyright 1990 by Looking Glass Microproducts : "
         (ItoA bcount)
      )
   )
)
;-----------------------------------------------------
; Item from association list
;-----------------------------------------------------
(bump)
(Defun item (n e)
   (CDR (Assoc n e))
)
;-----------------------------------------------------
; Error Handler
;-----------------------------------------------------
(bump)
(Defun pltype-error (s)
   (If (/= S "Function cancelled")
      (Princ s)
   )
   (gridr gridlist)
   (Command)
   (Command)
   (Command ".UNDO" "e")
   (If undoit
      (Progn
         (Princ "\nUndoing...")
         (Command ".U")
      )
   )
   (moder)
)
;-----------------------------------------------------
; System variable save
;-----------------------------------------------------
(bump)
(Defun modes (a)
   (Setq MLST Nil)
   (Repeat
      (Length a)
      (Setq
         MLST (Append
                 MLST
                 (List
                    (List
                       (CAR a)
                       (GetVar (CAR a))
                    )
                 )
              )
      )
      (Setq a (CDR a))
   )
)
;-----------------------------------------------------
; System variable restore
;-----------------------------------------------------
(bump)
(Defun moder ()
   (Repeat
      (Length MLST)
      (Setvar
         (CAAR MLST) (CADAR MLST)
      )
      (Setq MLST (CDR MLST))
   )
   (Setq *Error* olderror)
   (Princ)
)
;-----------------------------------------------------
; System variable set
;-----------------------------------------------------
(bump)
(Defun setvars (mlst)
   (Repeat
      (Length MLST)
      (Setvar
         (CAAR MLST) (CADAR MLST)
      )
      (Setq MLST (CDR MLST))
   )
)
;--------------------------------------------------
; Truncate x to the lowest integer multiple of y
;--------------------------------------------------
(bump)
(Defun trunc (x y)
   (- x (Rem x y))
)
;-------------------------------------------------
; Round x to the nearest integer multiple of y
;-------------------------------------------------
(bump)
(Defun round (x y)
   (If (Minusp x)
      (trunc (- x (* 0.5 y)) y)
      (trunc (+ x (* 0.5 y)) y)
   )
)
;-----------------------------------------------------
; Tangent function
;-----------------------------------------------------
(bump)
(Defun tan (x)
   (/ (Sin x) (Cos x))
)
;-----------------------------------------------------
; Bulge to Angle
;-----------------------------------------------------
(bump)
(Defun btoa (b)
   (* 4.0 (Atan b))
)
;-----------------------------------------------------
; Angle to Bulge
;-----------------------------------------------------
(bump)
(Defun atob (a)
   (tan (* 0.25 a))
)
;-----------------------------------------------------
; Radians to Degrees
;-----------------------------------------------------
(bump)
(Defun rtod (x)
   (/ (* 180.0 x) <180)
)
;-----------------------------------------------------
; Unfuzz
;-----------------------------------------------------
(bump)
(Defun unfuzz (alist fuzz)
   (MapCar
      '(Lambda
         (x)
         (If (<= (Abs x) fuzz) 0.0 x)
      )
      alist
   )
)
;-----------------------------------------------------
; Arc Status
;-----------------------------------------------------
(bump)
(Defun arc-stat (p0 p1 bulge / d01 ang a01 a1c r c ac0 ac1)
   ; Return center, radius, start angle and end angle given endpoints
   ; and bulge of an arc-segment of a polyline.
   (If (Zerop bulge)
      Nil
      (Progn
         (Setq
            d01 (Distance p0 p1)
            ang (btoa bulge)
            a01 (Angle p0 p1)
            a1c (* 0.5 (- <180 ang))
            r   (/ (* 0.5 d01) (Cos a1c))
            c   (Polar p0 (+ a1c a01) r)
            ac0 (Angle c p0)
            ac1 (+ ac0 ang)
         )
         (List c (Abs r) ac0 ac1)
      )
   )
)
;-----------------------------------------------------
; Return, in current ucs, a vertex/bulge list 
; for a polyline 
;-----------------------------------------------------
(bump)
(Defun vlist (pname / ent ename closed tlist)
   (Setq
      ent    (EntGet pname)
      Ename  pname
      closed (= 1 (LogAnd 1 (item 70 ent)))
      tlist  Nil
   )
   (While (=
             "VERTEX"
             (item
                0
                (Setq
                   Ename (EntNext Ename)
                   ent   (EntGet Ename)
                )
             )
          )
      (Redraw Ename 3)
      (If (< (item 70 ent) 16) ; not a spline control point
         (Setq
            tlist (Cons
                     (List
                        (unfuzz
                           (Trans
                              (item 10 ent)
                              (item -1 ent)
                              ucs
                           )
                           fuzz
                        )
                        (item 42 ent)
                     )
                     tlist
                  )
         )
      )
   )
   (Redraw pname)
   (If closed
      (Setq
         tlist (Cons (Last tlist) tlist)
      )
   )
   (Reverse tlist)
)
;-----------------------------------------------------
; Turn ss3 into a block block, empty ss3
;-----------------------------------------------------
(bump)
(Defun make-block (inspnt player pcolor pthick / cdate bname)
   (If (> (SsLength ss3) 0)
      (Progn
         ; ready the entities in ss3
         (Command
            ".chprop" ss3 "" 
            "C"       "byblock" 
            "LA"      "0" 
            "LT"      "CONTINUOUS"
            "T"        pthick 
            ""
         )
         ; Form a unique block name from the current time and date
         (Setq
            cdate (RtoS (GetVar "cdate") 2 9)
            bname (Strcat
                     (Substr cdate 1 8)
                     (Substr cdate 10)
                  )
         )
         (Command
            ".block" bname inspnt ss3 "" 
            ".insert" bname inspnt 1 1 "<0" 
            ".chprop" (EntLast) "" "C" pcolor "LA" player ""
         )
         (Setq ss3 (SsAdd))
      )
   )
)
;-----------------------------------------------------
; Draw pline given vertex and bulge list..
;-----------------------------------------------------
(bump)
(Defun drawpoly (plist / arcmode bulge vertex first)
   (If plist
      (Progn
         (Command ".pline")
         (Setq
            arcmode Nil
            bulge   0.0
            first   T
         )
         (ForEach vertex plist
            (If (Zerop bulge)
               (Progn
                  (If arcmode
                     (Progn
                        (Setq arcmode Nil)
                        (Command "l")
                     )
                  )
                  (Command (CAR vertex))
                  (If first
                     (Progn
                        (Setq first Nil)
                        (Command "w" 0 0)
                     )
                  )
               )
               (Progn
                  (If (Not arcmode)
                     (Progn
                        (Setq arcmode T)
                        (Command "a")
                     )
                  )
                  (Command
                     "a"
                     (rtod (btoa bulge))
                     (CAR vertex)
                  )
               )
            )
            (Setq bulge (CADR vertex))
         )
         (Command "")
         ; record this entity
         (SsAdd (EntLast) ss3)
      )
   )
)
;-----------------------------------------------------
; MAPSET -- execute f for each entity name in ss
;-----------------------------------------------------
(Defun mapset (f ss / i l sslist)
   (Setq
      l (If ss (SsLength ss) 0)
      i (1- l)
   )
   (While (>= i 0)
      (Setq
         sslist (Cons (SsName ss i) sslist)
         i      (1- i)
      )
   )
   (MapCar 'f sslist)
)
;-----------------------------------------------------
; Returns the selection set of all entities   
; which are members of both ss1 and ss2. 
;-----------------------------------------------------
(bump)
(Defun meet (ss1 ss2 / pt1 ssa ssb)
   (If (And ss1 ss2)
      (Progn
         (Command
            ".point"
            (GetVar "viewctr")
         )
         (Setq pt1 (EntLast))
         (Command
            ".select" pt1 ss1 "r" ss2 ""
         )
         (Setq ssa (SsGet "P"))
         (SsDel pt1 ssa)
         (Command
            ".select" pt1 ss1 "r" ssa ""
         )
         (Setq ssb (SsGet "P"))
         (SsDel pt1 ssb)
         (EntDel pt1)
         (If (> (SsLength ssb) 0) ssb)
      )
   )
)
;-----------------------------------------------------
; Perimeter of a polyline
;-----------------------------------------------------
(Defun perimeter (plist)
   (Apply
      '+
      (MapCar
         'seg-len
         plist
         (CDR plist)
      )
   )
)
;-----------------------------------------------------
; Convert one polyline
;-----------------------------------------------------
(bump)
(Defun one-pltype (pname / pent pflags player pcolor pthick pflags
                   plength numsegs ascale plist)
   (Command ".ucs" "e" pname)
   (Setq
      pent   (EntGet pname)
      pflags (item 70 pent)
      player (item 8 pent)
      pcolor (Cond
                ((item 62 pent))
                ("BYLAYER")
             )
      pthick (Cond ((item 39 pent)) (0.0))
   )
   (If (= 0 pcolor)
      (Setq pcolor "BYBLOCK")
   )
   (If (< pflags 8)
      (Progn
         (Setq
            plist   (vlist pname)
            plength (perimeter plist)
            numsegs (Max
                       1
                       (Fix
                          (round
                             (/ plength (CAR ltype))
                             1.0
                          )
                       )
                    )
            ascale  (/
                       plength
                       numsegs
                       (CAR ltype)
                    )
            altype  (MapCar
                       '(Lambda (x) (* ascale x))
                       ltype
                    )
         )
         ; Put the converted polyline on the hold layer
         (Command
            ".chprop" pname "" "la" hold-layer ""
         )
         (draw-pltype
            plist
            altype
            numsegs
         )
         (make-block
            '(0 0 0)
            player
            pcolor
            pthick
         )
      )
   )
   (Command ".ucs" "p")
)
;-----------------------------------------------------
; Draw one polyline using linetype
;-----------------------------------------------------
(bump)
(Defun draw-pltype (plist altype numsegs / len)
   (Setq
      altype (CDR altype)
      len    (* 0.5 (CAR altype))
      plist  (split-poly plist (Abs len))
   )
   (drawpoly (CAR plist))
   (Repeat
      (* numsegs (Length altype))
      (Setq
         altype (rotate altype)
         len    (CAR altype)
         plist  (split-poly
                   (CADR plist)
                   (Abs len)
                )
      )
      (If (>= len 0)
         (drawpoly (CAR plist))
      )
   )
)
;-----------------------------------------------------
; Segment Length of a polyline segment
;-----------------------------------------------------
(bump)
(Defun seg-len (v0 v1 / p0 p1 b0 as)
   (Setq
      p0 (CAR v0)
      b0 (CADR v0)
      p1 (CAR v1)
   )
   (If (Zerop b0)
      (Distance p0 p1)
      (Progn
         (Setq as (arc-stat p0 p1 b0))
         (Abs
            (*
               (Nth 1 as)
               (- (Nth 3 as) (Nth 2 as))
            )
         )
      )
   )
)
;-----------------------------------------------------
; Return segment of dist from v0 to v2
;-----------------------------------------------------
(bump)
(Defun midway (v0 v2 dist / p0 b0 p2 p1 b1 as a0 a2)
   (Setq
      p0 (CAR v0)
      b0 (CADR v0)
      p2 (CAR v2)
   )
   (If (Zerop b0)
      (Setq
         p1 (Polar p0 (Angle p0 p2) dist)
         b1 0.0
      )
      (Setq
         as (arc-stat p0 p2 b0)
         a0 (Nth 2 as)
         a2 (Nth 3 as)
         a1 ((If (< a0 a2) + -)
               a0
               (/ dist (Nth 1 as))
            )
         p1 (Polar
               (Nth 0 as)
               a1
               (Nth 1 as)
            )
         b0 (atob (- a1 a0))
         b1 (atob (- a2 a1))
      )
   )
   (List
      (Cons p0 (Cons b0 (CDDR v0)))
      (Cons p1 (Cons b1 (CDDR v0)))
   )
)
;-----------------------------------------------------
; split a polyline into two polylines 
; a distance 'len' from the start
;-----------------------------------------------------
(bump)
(Defun split-poly (plist len / sofar v0 v1 head tlen)
   (If (Zerop len)
      (Setq len (+ fuzz fuzz))
   )
   (Setq
      sofar 0.0
      v0    (CAR plist)
      plist (CDR plist)
      v1    (CAR plist)
      head  Nil
   )
   (While (< sofar len)
      (If (<=
             (+
                (Setq tlen (seg-len v0 v1))
                sofar
             )
             len
          )
         ; add a whole segment
         (Progn
            (Setq
               head  (Cons v0 head)
               v0    v1
               plist (CDR plist)
               v1    (CAR plist)
               sofar (+ sofar tlen)
            )
            (If (Or
                   (Null plist)
                   (Equal sofar len fuzz)
                )
               (Setq
                  head  (Reverse (Cons v0 head))
                  plist (Cons v0 plist)
                  sofar (+ len 1.0)
               )
            )
         )
         ; add a part segment
         (Progn
            (If (Not (Equal sofar len fuzz))
               (Setq
                  seg1  (midway v0 v1 (- len sofar))
                  head  (Reverse
                           (Append (Reverse seg1) head)
                        )
                  plist (Cons (CADR seg1) plist)
               )
            )
            (Setq sofar (+ len 1.0))
         )
      )
   )
   (If (= (Length plist) 1)
      (Setq
         plist (Append plist plist)
      )
   )
   (List head plist)
)
;-----------------------------------------------------
; Get line type
;-----------------------------------------------------
(bump)
(Defun get-ltype (/ lname ltable ltscale)
   (Setq
      lname (Strcase
               (GetString "\nNew linetype: ")
            )
      ltscale (getvar "ltscale") 
  )
   (Cond
      ((= lname "") Nil)
      ((= lname "CONTINUOUS") Nil)
      ((Null
          (Setq
             ltable (TblSearch "ltype" lname)
          )
       )
         (Princ
            (Strcat
               "\nLinetype "
               lname
               " not found.  Use LINETYPE to load it."
            )
         )
         Nil
      )
      ((MapCar
          '(lambda (v)
              (* ltscale (cdr v))             
           )
          (Member
             (Assoc 40 ltable)
             ltable
          )
       )
      )
   )
)
;-----------------------------------------------------
; save grid status for all viewports, reset grids
;-----------------------------------------------------
(bump)
(Defun grids ()
   (MapCar
      '(Lambda
         (vp / tmp)
         (Setvar "cvport" vp)
         (If (Zerop
                (Setq tmp (GetVar "gridmode"))
             )
            (Cons vp 0)
            (Progn
               (Setvar "gridmode" 0)
               (Cons vp tmp)
            )
         )
      )
      (MapCar
         'car
         (rotate (Vports))
      )
   )
)
;-----------------------------------------------------
; rotate the head of a list to the tail
;-----------------------------------------------------
(bump)
(Defun rotate (alist)
   (If alist
      (Append
         (CDR alist)
         (List (CAR alist))
      )
   )
)
;-----------------------------------------------------
; restore grid status for all viewports
;-----------------------------------------------------
(bump)
(Defun gridr (glist)
   (MapCar
      '(Lambda
         (vp)
         (Setvar "cvport" (CAR vp))
         (Setvar "gridmode" (CDR vp))
      )
      glist
   )
)
;-----------------------------------------------------
; PLType MAIN ROUTINE
;-----------------------------------------------------
(bump)
(Defun pltype (/ ss1 ss2 ss3)
   (Setq ss1 (SsGet) ss3 (SsAdd))
   (Setvar "highlight" 0)
   (Setvar "blipmode" 0)
   (Setq
      ss1 (meet
             ss1
             (SsGet
                "x"
                '((0 . "POLYLINE"))
             )
          )
   )
   (If (And
          ss1
          (Setq ltype (get-ltype))
       )
      (Progn
         (Setq undoit T)
         (if (not (tblsearch "layer" hold-layer))
            (Command
               ".layer" "new" hold-layer "f" hold-layer ""
            )
         )
         (Princ
            (Strcat
               "\nProcessing "
               (RtoS (SsLength ss1) 2 0)
               " polyline"
               (If (/= (SsLength ss1) 1)
                  "s"
                  ""
               )
               "."
            )
         )
         (mapset one-pltype ss1)
      )
   )
   (Setq ss1 Nil ss2 Nil ss3 Nil)
)
;-----------------------------------------------------
; PLType COMMAND
;-----------------------------------------------------
(bump)
(Defun c:pltype (/ olderror gridlist undoit)
   (modes
      '("cmdecho"
         "highlight"
         "ucsfollow"
         "osmode"
         "flatland"
         "expert"
         "blipmode" 
         "elevation"
         "thickness"
     )
   )
   (Setq
      olderror *Error*
      *Error*  pltype-error
   )
   (setvars
      '(("cmdecho" 0)
         ("ucsfollow" 0)
         ("osmode" 0)
         ("flatland" 0)
         ("expert" 4)
         ("elevation" 0.0)
         ("thickness" 0.0)
      )
   )
   (Setq gridlist (grids))
   (Command ".undo" "group")
   (pltype)
   (gridr gridlist)
   (Command ".undo" "e")
   (moder)
)
(c:pltype)