;----------------------------------------------------------
;
; TEXT.LSP -- Copyright 1989 by Looking Glass Microproducts
;              Author -- Philip M. Kreiker
;
; A New Text Command
;
(Setq
   version   "1.0"
   fuzz      1.0e-8
   <45       (* 0.25 Pi)
   <135      (* 0.75 Pi)
   <225      (* 1.25 Pi)
   <325      (* 1.75 Pi)
   textangl  0.0
   textmargn 0.05
)
;----------------------------------------------------------
; System variable save
(Princ ".")
(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
(Princ ".")
(Defun moder ()
   (Repeat
      (Length MLST)
      (Setvar
         (CAAR MLST) (CADAR MLST)
      )
      (Setq MLST (CDR MLST))
   )
   (Princ)
)
;----------------------------------------------------------
; Associated Item
(Princ ".")
(Defun item (n alist)
   (CDR (Assoc n alist))
)
;----------------------------------------------------------
; Convert a point to current UCS
(Princ ".")
(Defun ucspnt (n ent)
   (Trans
      (item n ent)
      (item -1 ent)
      1
   )
)
;----------------------------------------------------------
; System variable set
(Princ ".")
(Defun smode (MLST)
   (Repeat
      (Length MLST)
      (Setvar
         (CAAR MLST) (CADAR MLST)
      )
      (Setq MLST (CDR MLST))
   )
)
;--------------------------------------------------------------------
; XGETDIST -- Extended Get Distance
(Princ ".")
(Defun xgetdist (p0 prmpt default / temp)
   (If p0
      (Cond
         ((GetDist
             p0
             (Strcat
                prmpt
                " <"
                (RtoS default)
                ">: "
             )
          )
         )
         (default)
      )
      (Cond
         ((GetDist
             (Strcat
                prmpt
                " <"
                (RtoS default)
                ">: "
             )
          )
         )
         (default)
      )
   )
)
;--------------------------------------------------------------------
; XGETANGLE -- Extended Get Angle
(Princ ".")
(Defun xgetangle (p0 prmpt default)
   (If p0
      (Cond
         ((GetAngle
             p0
             (Strcat
                prmpt
                " <"
                (AngToS default)
                ">: "
             )
          )
         )
         (default)
      )
      (Cond
         ((GetAngle
             (Strcat
                prmpt
                " <"
                (AngToS default)
                ">: "
             )
          )
         )
         (default)
      )
   )
)
;----------------------------------------------------------
; Degrees Function
(Princ ".")
(Defun degrees (x)
   (/ (* x 180.0) Pi)
)
;----------------------------------------------------------
; Replace Function
(Princ ".")
(Defun replace (node alist)
   (Subst
      node
      (Assoc (CAR node) alist)
      alist
   )
)
;----------------------------------------------------------
; Midpoint Function
(Princ ".")
(Defun midp (p1 p2)
   (MapCar
      '(Lambda
         (x1 x2)
         (* 0.5 (+ x1 x2))
      )
      p1
      p2
   )
)
;----------------------------------------------------------
; Get Style
(Princ ".")
(Defun getstyle (/ again)
   (Setq again T)
   (While again
      (Setq
         sname (Strcase
                  (GetString
                     (Strcat
                        "\nStyle name (or ?) <"
                        (GetVar "textstyle")
                        ">: "
                     )
                  )
               )
      )
      (Cond
         ((= "?" sname)
            (Command ".style" "?")
            (Setq sname "" again Nil)
         )
         ((= "" sname)
            (Setq again Nil)
         )
         ((TblSearch "style" sname)
            (Command
               ".dim1" "style" sname
            )
            (Setq again Nil)
         )
         ((Princ
             "\nUnknown text style name.\n"
          )
         )
      )
   )
   sname
)
;----------------------------------------------------------
; Get Justification
(Princ ".")
(Defun getjust (/ just)
   (While (Progn
             (InitGet
                "Align Box Center Fit Left Middle Right Style"
             )
             (Setq
                just (Cond
                        ((GetKword
                            "\nAlign/Box/Center/Fit/Middle/Right/Style/<Left>: "
                         )
                        )
                        ("Left")
                     )
             )
             (= just "Style")
          )
      (If (= just "Style")
         (getstyle)
      )
   )
   (Substr just 1 1)
)
;-----------------------------------------------------------
; Get Points
(Defun getpnts (just / pnts)
   (Setq pnts Nil)
   (While (Setq
             p1 (GetPoint
                   (Cond
                      ((Member just '("A" "F"))
                         "\nFirst text line point: "
                      )
                      ((= just "B")
                         "\nFirst corner: "
                      )
                      ((= just "C")
                         "\nCenter point: "
                      )
                      ((= just "L")
                         "\nStart point: "
                      )
                      ((= just "M")
                         "\nMiddle point: "
                      )
                      ((= just "R") "\nEnd point: ")
                   )
                )
          )
      (Setq
         p2   (Cond
                 ((Member just '("A" "F"))
                    (InitGet 1)
                    (GetPoint
                       p1
                       " Second text line point: "
                    )
                 )
                 ((= just "B")
                    (InitGet 1)
                    (GetCorner
                       p1
                       " Other corner: "
                    )
                 )
              )
         pnts (Cons
                 (List
                    p1
                    p2
                    (GetVar "viewctr")
                    (GetVar "viewsize")
                 )
                 pnts
              )
      )
   )
   (Reverse pnts)
)
;----------------------------------------------------------
; Zoom To
(Princ ".")
(Defun zoomto (pnt)
   (If (Or
          (Not
             (Equal
                (GetVar "viewctr")
                (CADDR pnt)
                fuzz
             )
          )
          (Not
             (Equal
                (GetVar "viewsize")
                (CADDDR pnt)
                fuzz
             )
          )
       )
      (Command
         ".zoom" "c"
         (CADDR pnt)
         (CADDDR pnt)
      )
   )
)
;----------------------------------------------------------
; Show Point
(Princ ".")
(Defun showpoint (pnt / size)
   (Setq
      size (* 0.025 (GetVar "viewsize"))
   )
   (GrDraw
      (Polar pnt <225 size)
      (Polar pnt <45 size)
      -1
   )
   (GrDraw
      (Polar pnt <135 size)
      (Polar pnt <325 size)
      -1
   )
)
;----------------------------------------------------------
; Show Line
(Princ ".")
(Defun showline (p1 p2)
   (GrDraw p1 p2 -1 1)
)
;----------------------------------------------------------
; Show Box
(Princ ".")
(Defun showbox (p1 p2 / p3 p4)
   (Setq
      p3 (List (CAR p1) (CADR p2))
      p4 (List (CAR p2) (CADR p1))
   )
   (GrDraw p1 p3 -1 1)
   (GrDraw p3 p2 -1 1)
   (GrDraw p2 p4 -1 1)
   (GrDraw p4 p1 -1 1)
)
;----------------------------------------------------------
; Get Left Centered, Right, and Middled Text
(Princ ".")
(Defun get_lcrm ()
   (showpoint (CAR pnt))
   (If (Not fixed)
      (Setq
         texthite (xgetdist
                     (CAR pnt)
                     "\nHeight"
                     texthite
                  )
      )
   )
   (Setq
      textangl (xgetangle
                  (CAR pnt)
                  "\nRotation angle"
                  textangl
               )
   )
   (Setq
      text (GetString T "\nText: ")
   )
   (showpoint (CAR pnt))
   (Command ".text")
   (If (/= "L" just)
      (Command just)
   )
   (Command (CAR pnt))
   (If (Not fixed)
      (Command texthite)
   )
   (Command
      (degrees textangl) text
   )
)
;----------------------------------------------------------
; Get Aligned and Fit Text
(Princ ".")
(Defun get_af ()
   (showline
      (CAR pnt)
      (CADR pnt)
   )
   (If (And (Not fixed) (= just "F"))
      (Setq
         texthite (xgetdist
                     (CAR pnt)
                     "\nHeight"
                     texthite
                  )
      )
   )
   (Setq
      text (GetString T "\nText: ")
   )
   (showline
      (CAR pnt)
      (CADR pnt)
   )
   (Command
      ".text" just
      (CAR pnt)
      (CADR pnt)
   )
   (If (And (Not fixed) (= just "F"))
      (Command texthite)
   )
   (Command text)
)
;----------------------------------------------------------
; Get Box Text
(Princ ".")
(Defun get_b ()
   (Setq
      textpnt (midp (CAR pnt) (CADR pnt))
   )
   (showbox (CAR pnt) (CADR pnt))
   (showpoint textpnt)
   (If (Not fixed)
      (Setq
         texthite (xgetdist
                     textpnt
                     "\nHeight"
                     texthite
                  )
      )
   )
   (Setq
      text (GetString T "\nText: ")
   )
   (showbox (CAR pnt) (CADR pnt))
   (showpoint textpnt)
   (Command ".text" "M" textpnt)
   (If (Not fixed)
      (Command texthite)
   )
   (Command 0 text)
   (If (/= text "")
      (Progn
         (Setq again T)
         (While again
            (Setq
               minx    (+
                          (Min (CAAR pnt) (CAADR pnt))
                          (*
                             textmargn
                             (Abs
                                (- (CAAR pnt) (CAADR pnt))
                             )
                          )
                       )
               textent (EntGet (EntLast))
               textmin (CAR (ucspnt 10 textent))
               oldhite (item 40 textent)
               oldwid  (item 41 textent)
               fits    (<= minx textmin)
            )
            (If (Not fits)
               (Progn
                  (InitGet
                     "Height Width Neither"
                  )
                  (showbox (CAR pnt) (CADR pnt))
                  (showpoint textpnt)
                  (Setq
                     Fix    (GetKword
                               "\nText does not fit.  Change Height/Width/<Neither>:"
                            )
                     t1     (- (CAR textpnt) textmin)
                     t2     (- (CAR textpnt) minx)
                     factor (If (And (> t1 0) (> t2 0))
                               (* (/ t2 t1) 0.999)
                               1.0
                            )
                  )
                  (Cond
                     ((= Fix "Height")
                        (InitGet 6)
                        (Setq
                           newhite (xgetdist
                                      textpnt
                                      "\nNew height:"
                                      (* factor oldhite)
                                   )
                           textent (replace
                                      (Cons 40 newhite)
                                      textent
                                   )
                        )
                        (showbox (CAR pnt) (CADR pnt))
                        (showpoint textpnt)
                        (EntMod textent)
                     )
                     ((= Fix "Width")
                        (InitGet 6)
                        (Setq
                           newwid  (xgetdist
                                      textpnt
                                      "\nNew width factor:"
                                      (* factor oldwid)
                                   )
                           textent (replace
                                      (Cons 41 newwid)
                                      textent
                                   )
                        )
                        (showbox (CAR pnt) (CADR pnt))
                        (showpoint textpnt)
                        (EntMod textent)
                     )
                     (T
                        (showbox (CAR pnt) (CADR pnt))
                        (showpoint textpnt)
                        (Setq again Nil)
                     )
                  )
               )
               (Setq again Nil)
            )
         )
      )
   )
)
;----------------------------------------------------------
; Get Text
(Princ ".")
(Defun gettext (pnt)
   (Cond
      ((Member
          just
          '("L" "C" "R" "M")
       )
         (get_lcrm)
      )
      ((Member just '("A" "F"))
         (get_af)
      )
      ((= just "B") (get_b))
   )
)
;-----------------------------------------------------------
; Text2 Command
(Defun text2 ()
   (Setq
      texthite (GetVar "textsize")
      just     (getjust)
      fixed    (/=
                  0.0
                  (item
                     40
                     (TblSearch
                        "style"
                        (GetVar "textstyle")
                     )
                  )
               )
      pnts     (getpnts just)
      i        0
      l        (Length pnts)
   )
   (smode
      '(("BLIPMODE" 0) ("OSMODE" 0))
   )
   (ForEach pnt pnts
      (zoomto pnt)
      (gettext pnt)
   )
)
;-----------------------------------------------------------
; Main program.  Text2 Command
;
(Princ ".")
(Defun c:text2 (/ myerror)
   ;----------------------------------------------------------
   ; Internal error handler
   ;
   (Defun myerror (s)
      (If (/= S "Function cancelled")
         (Princ s)
      )
      (Command)
      (Command ".undo" "end")
      (Command ".u")
      (Setq *Error* olderr)
      (moder)
   )
   ;---------------------------------------------------------
   (Setq
      olderr  *Error*
      *Error* myerror
   )
   (modes
      '("CMDECHO"
         "BLIPMODE"
         "OSMODE"
         "UCSFOLLOW"
         "HIGHLIGHT"
      )
   )
   (smode
      '(("CMDECHO" 0)
         ("UCSFOLLOW" 0)
         ("HIGHLIGHT" 0)
      )
   )
   (Command ".undo" "group")
   (Command "view" "save" "text2")
   (text2)
   (Command "view" "restore" "text2")
   (Command ".undo" "end")
   (Setq *Error* olderr)
   (moder)                       ; Restore saved modes
)
(Princ
   (Strcat
      "\nTEXT2.LSP version "
      version
      " -- Copyright 1989 by Looking Glass Microproducts"
   )
)
(c:text2)