; 3DJOIN.LSP   [Article Figure 1]   (c)1990, Phil Kreiker

;   +--------------------------------------------------------------+
;   | 3DJoin.LSP -- COPYRIGHT 1990 BY LOOKING GLASS MICROPRODUCTS  |
;   +--------------------------------------------------------------+
;
(Setq
   version "1.0"
   ucs     1
   fuzz    1e-8
)
;-----------------------------------------------------
; Load-time chewing gum
;-----------------------------------------------------
(Princ "\n")
(Setq bcount 0)
(Defun bump ()
   (Setq bcount (1+ bcount))
   (Princ
      (Strcat
         "\r3DJoin version "
         version
         " -- Copyright 1990 by Looking Glass Microproducts : "
         (ItoA bcount)
      )
   )
)
;-----------------------------------------------------
; Item from association list
;-----------------------------------------------------
(bump)
(Defun item (n e)
   (CDR (Assoc n e))
)
;-----------------------------------------------------
; BIT SET
;-----------------------------------------------------
(bump)
(Defun bitset (a b)
   (= (Boole 1 a b) b)
)
;-----------------------------------------------------
; Error Handler
;-----------------------------------------------------
(bump)
(Defun 3DJoin-error (s)
   (If (/= S "Function cancelled")
      (Princ s)
   )
   (Command)
   (Command)
   (Command ".UNDO" "e")
   (If undoit
      (Progn
         (Princ "\nUndoing...")
         (Command ".undo" 1)
      )
   )
   (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))
   )
)
;-----------------------------------------------------
; Get vertices of pline -- Return Spline frame if 
; it has been spline or curve fit. 
;-----------------------------------------------------
(bump)
(Defun getverts (pname / ent ename ss1 verts pflag vflag splinefit
)
   (Setq
      ent       (EntGet pname)
      pflags    (item 70 ent)
      Ename     pname
      splinefit (bitset pflags 4)
      verts     Nil
   )
   (While (=
             "VERTEX"
             (item
                0
                (Setq
                   Ename (EntNext Ename)
                   ent   (EntGet Ename)
                )
             )
          )
      (Setq vflag (item 70 ent))
      (If (Or
             (And
                (Not splinefit)
                (Not (bitset vflag 1))
             )
             (bitset vflag 16)
          )
         (Setq
            verts (Cons
                     (Trans
                        (item 10 ent)
                        pname
                        ucs
                     )
                     verts
                  )
         )
      )
   )
   (Reverse verts)
)
;-----------------------------------------------------
; DRAW 3D POLY
;-----------------------------------------------------
(bump)
(Defun 3Dpoly (closed vlist / bm)
   (Setq bm (GetVar "blipmode"))
   (Setvar "blipmode" 0)
   (Command ".3Dpoly")
   (MapCar 'command vlist)
   (Command (If closed "c" ""))
   (Setvar "blipmode" bm)
   (EntLast)
)
;-----------------------------------------------------
; MATCH the layer, linetype, and color of
; ename1 to ename2
;-----------------------------------------------------
(bump)
(Defun match (ename1 ename2 / ent2 layer color ltype hl)
   (Setq
      ent2  (EntGet ename2)
      layer (item 8 ent2)
      ltype (item 6 ent2)
      color (item 62 ent2)
   )
   (If (Null ltype)
      (Setq ltype "BYLAYER")
   )
   (If (Null color)
      (Setq color "BYLAYER")
      (If (Zerop color)
         (Setq color "BYBLOCK")
      )
   )
   (Setq hl (GetVar "highlight"))
   (Setvar "highlight" 0)
   (Command
      ".chprop" ename1 "" "la" layer "lt" ltype "color" color ""
   )
   (Setvar "highlight" hl)
   ename1
)
;-----------------------------------------------------
; CONVERT LINE to 3D POLYLINE
;-----------------------------------------------------
(bump)
(Defun convert-line (ename / 3name ent p0 p1)
   (Setq
      undoit T
      ent    (EntGet ename)
      p0     (Trans
                (item 10 ent)
                ename
                ucs
             )
      p1     (Trans
                (item 11 ent)
                ename
                ucs
             )
   )
   (match
      (Setq
         3name (3Dpoly Nil (List p0 p1))
      )
      ename
   )
   (EntDel ename)
   (Setq undoit Nil)
   3name
)
;-----------------------------------------------------
; CONVERT 2D POLYLINE to 3D POLYLINE
;-----------------------------------------------------
(bump)
(Defun convert-pline (ename / 3name vlist)
   (Setq
      undoit T
      vlist  (getverts ename)
   )
   (match
      (Setq
         3name (3Dpoly
                  (bitset
                     (item 70 (EntGet ename))
                     1
                  )
                  vlist
               )
      )
      ename
   )
   (EntDel ename)
   (Setq undoit Nil)
   3name
)
;-----------------------------------------------------
; MAKE IT ONE?
;-----------------------------------------------------
(bump)
(Defun make-it-one ()
   (InitGet "Yes No")
   (/=
      "No"
      (GetKword
         "\nDo you want to turn it into one? <Y> "
      )
   )
)
;-----------------------------------------------------
; GET A 3D POLYLINE or MAKE IT ONE
;-----------------------------------------------------
(bump)
(Defun get3Dpoly (/ again ename ent)
   (Setq again T)
   (While again
      (If (Setq
             ename (CAR
                      (EntSel
                         "\nSelect 3D polyline: "
                      )
                   )
          )
         (Progn
            (Setq ent (EntGet ename))
            (If (And
                   (=
                      (Setq etype (item 0 ent))
                      "POLYLINE"
                   )
                   (bitset
                      (Setq pflags (item 70 ent))
                      8
                   )
                )
               (Progn (Setq again Nil) ename)
               (Progn
                  (Princ
                     "\nEntity selected is not a 3D polyline."
                  )
                  (Cond
                     ((= "LINE" etype)
                        (If (make-it-one)
                           (Progn
                              (Setq again Nil)
                              (convert-line ename)
                           )
                        )
                     )
                     ((And
                         (= "POLYLINE" etype)
                         (Not (bitset pflags 16))
                      )
                        (If (make-it-one)
                           (Progn
                              (Setq again Nil)
                              (convert-pline ename)
                           )
                        )
                     )
                  )
               )
            )
         )
         (Setq again Nil)
      )
   )
)
;-----------------------------------------------------
; GET ACTION
;-----------------------------------------------------
(bump)
(Defun get-action (ename / ent pflags closed splined kwords prmpt
)
   (Setq
      ent     (EntGet ename)
      pflags  (item 70 ent)
      closed  (bitset pflags 1)
      splined (bitset pflags 4)
      kwords  ""
      prmpt   ""
   )
   (If closed
      (Setq
         kwords "Open"
         prmpt  "\nOpen"
      )
      (Setq
         kwords "Close Join"
         prmpt  "\nClose/Join"
      )
   )
   (If splined
      (Setq
         kwords (Strcat kwords " Decurve")
         prmpt  (Strcat prmpt "/Decurve")
      )
      (Setq
         kwords (Strcat kwords " Spline")
         prmpt  (Strcat prmpt "/Spline curve")
      )
   )
   (Setq
      kwords (Strcat kwords " X")
      prmpt  (Strcat prmpt "/eXit <X>: ")
   )
   (InitGet kwords)
   (Cond
      ((GetKword prmpt))
      ("X")
   )
)
;-----------------------------------------------------
; expand one
;-----------------------------------------------------
(bump)
(Defun expand-one (ename / ent etype closed mesh pflags)
   (Setq
      ent   (EntGet ename)
      etype (item 0 ent)
   )
   (Cond
      ((= "LINE" etype)
         (List
            ename
            (Trans
               (item 10 ent)
               ename
               ucs
            )
            (Trans
               (item 11 ent)
               ename
               ucs
            )
         )
      )
      ((= "POLYLINE" etype)
         (Setq
            pflags (item 70 ent)
            closed (bitset pflags 1)
            mesh   (bitset pflags 16)
         )
         (If (And (Not closed) (Not mesh))
            (Cons ename (getverts ename))
         )
      )
   )
)

;-----------------------------------------------------
; Expand an entity list into a list of joinable vert lists
;-----------------------------------------------------
(bump)
(Defun Expand (slist / outlist node)
   (Setq outlist Nil)
   (ForEach ent slist
      (If (Setq node (expand-one ent))
         (Setq
            outlist (Cons node outlist)
         )
      )
   )
   (Reverse outlist)
)
;-----------------------------------------------------
; Join lines and 3D and 2d polylines to pname
;-----------------------------------------------------
(bump)
(Defun join (pname / ss1 again plist elist added qlist p0 pn qname
             q0 qn closed 3name)
   (If (Setq ss1 (SsGet))
      (Progn
         (SsDel pname ss1)
         (Setq
            plist (getverts pname)
            elist (Expand (sslist ss1))
            again T
            added Nil
         )
         (While again
            (Setq again Nil)
            (ForEach qlist elist
               (If (CAR qlist)
                  (Progn
                     (Setq
                        p0    (CAR plist)
                        pn    (Last plist)
                        qname (CAR qlist)
                        q0    (CADR qlist)
                        qn    (Last qlist)
                     )
                     (If (Cond
                            ((Equal pn q0 fuzz)
                               (Setq
                                  plist (Append plist (CDDR qlist))
                               )
                            )
                            ((Equal pn qn fuzz)
                               (Setq
                                  plist (Append
                                           plist
                                           (CDR (Reverse (CDR qlist)))
                                        )
                               )
                            )
                            ((Equal p0 q0 fuzz)
                               (Setq
                                  plist (Append
                                           (Reverse plist)
                                           (CDDR qlist)
                                        )
                               )
                            )
                            ((Equal p0 qn fuzz)
                               (Setq
                                  plist (Append
                                           (CDR qlist)
                                           (CDR plist)
                                        )
                               )
                            )
                         )
                        (Progn
                           (Setq
                              elist (Subst
                                       (List Nil)
                                       (Assoc qname elist)
                                       elist
                                    )
                              again T
                              added (Cons qname added)
                           )
                           (EntDel qname)
                        )
                     )
                  )
               )
            )
         )
         (If added
            (Progn
               (If (Setq
                      closed (Equal
                                (CAR plist)
                                (Last plist)
                                fuzz
                             )
                   )
                  (Setq
                     plist (Reverse
                              (CDR (Reverse plist))
                           )
                  )
               )
               (match
                  (Setq
                     3name (3Dpoly closed plist)
                  )
                  pname
               )
               (EntDel pname)
               (Setq pname 3name)
            )
         )
         (Princ
            (Strcat
               "\n"
               (ItoA (Length added))
               " segment"
               (If (/= (Length added) 1)
                  "s"
                  ""
               )
               " added to 3D polyline"
            )
         )
      )
   )
   (Setq ss1 Nil)
   pname
)
;-----------------------------------------------------
; SSLIST - Return a list of entities in selection set
;-----------------------------------------------------
(bump)
(Defun sslist (ss1 / i l blist)
   (Setq
      l     (If ss1 (SsLength ss1) 0)
      i     0
      blist Nil
   )
   (While (< i l)
      (Setq
         blist (Cons (SsName ss1 i) blist)
         i     (1+ i)
      )
   )
   (Reverse blist)
)

;-----------------------------------------------------
; 3DJoin MAIN ROUTINE
;-----------------------------------------------------
(bump)
(Defun 3DJoin (/ ss1 ss2 3Dpname again action)
   (Setq
      3Dpname (get3Dpoly)
      again   3Dpname
   )
   (While again
      (Redraw 3Dpname)
      (Setq
         undoit Nil
         action (get-action 3Dpname)
         undoit T
      )
      (Cond
         ((= action "X")
            (Setq again Nil)
         )
         ((Member
             action
             '("Close"
                "Open"
                "Spline"
                "Decurve"
             )
          )
            (Command
               ".pedit" 3Dpname action "X"
            )
         )
         ((= action "Join")
            (Setq 3Dpname (join 3Dpname))
         )
      )
   )
)
;-----------------------------------------------------
; 3DJoin COMMAND
;-----------------------------------------------------
(bump)
(Defun c:3DJoin (/ olderror undoit)
   (modes
      '("cmdecho"
         "osmode"
         "flatland"
         "elevation"
         "blipmode"
         "highlight"
      )
   )
   (Setq
      olderror *Error*
      *Error*  3DJoin-error
   )
   (setvars
      '(("cmdecho" 0)
         ("osmode" 0)
         ("flatland" 0)
         ("elevation" 0.0)
      )
   )
   (Command ".undo" "group")
   (3DJoin)
   (Command ".undo" "e")
   (moder)
)
(c:3DJoin)