;HAT is distrubuted as Shareware, please register your copy.  See Hat.doc.
;
;HAT 1.4 copyright 1990 Michael E. Ross
;                       610 E. Canon Perdido #6
;                       Santa Barbara, CA 93103
;
;HAT IS A HATCH ENHANCEMENT UTILITY.  HAT ALLOWS THE USER TO REFERENCE AN
;EXISTING HATCH PATTERN TO DETERMINE THE PATTERN NAME, SCALE AND ROTATION
;ANGLE.  THE REFERENCE INFORMATION FOR EACH HATCH IS SAVED WITH THE DRAWING.
;THIS IS VERY USEFUL WHEN EDITING A DRAWING WICH USES HATCHED AREAS.  OFTEN
;THE INFORMATION ABOUT AN EXISTING HATCH PATTERN MUST BE DETERMINED BY GUESSING
;OR BY TRIAL AND ERROR.
;
;DURING A HATCH COMMAND, HAT ALSO ALLOWS THE USER TO RESCALE, ROTATE OR MOVE THE
;HATCH UNTIL HE IS SATISFIED THAT IT IS CORRECT.
;
;IN ORDER TO OBTAIN THE HATCH REFERENCE INFORMATION, C:HAT MUST BE USED TO
;CREATE THE HATCH.  C:HAT STORES THE PATTERN INFORMATION IN AN INVISIBLE
;BLOCK, NO SPECIAL LAYERS OR OTHER VISIBLE TEXT ENTITIES ARE CREATED.
;THE BLOCK CONTAINS INVISIBLE ATTRIBUTES WHICH STORE THE INFO.  EACH REFERENCE
;BLOCK ADDS APPROX. 400 BYTES (NOT MUCH) TO THE DRAWING.
;
;IF THE USER JUST WANTS TO USE THE DYNAMIC RESCALE, ROTATE AND MOVE OPTIONS OF
;C:HAT AND NOT CREATE A REFERENCE BLOCK, HAT ALLOWS THIS TOO.
;
;C:HATREF RETRIEVES THE PATTERN NAME, ROTATION ANGLE AND SCALE
;INFORMATION FOR A SPECIFIED HATCH.
;
;
(prompt "\n ")
(princ "\nLoading...")

;Degrees to radians conversion
(defun DTR (Y)
  (* pi (/ Y 180.0))
)

;Radians to degrees conversion
(defun RTD (Y)
  (* 180.0 (/ Y pi))
)

(defun acqrel (PRM DEF TEST2 / REL)
  (setq PRM (strcat PRM " <" (rtos DEF 2 4) ">: "))
  (if TEST2 (initget TEST2))
  (setq REL (getreal PRM))
  (if (null REL) (setq REL DEF))
  REL
)

(defun acqst (PRM DEF / ST)
  (setq PRM (strcat PRM " <" DEF ">: ")
        ST (strcase (getstring PRM))) ;returns caps
  (if (eq (strlen ST) 0) (setq ST DEF))
  ST
)

;returns angle in radians
(defun acqang (PRM DEF / ANG)
  (setq PRM (strcat PRM " <" (rtos DEF 2 4) ">: ")
        ANG (getangle PRM))
  (if (null ANG) (setq ANG (DTR DEF)))
  ANG
)

(defun acqss ( / SS1 PT1)
  (while (null (setq PT1 (entsel))))
  (redraw (car PT1) 3)
  (setq SS1 (ssget))
  (redraw (car PT1) 4)
  (if SS1
    (setq SS1 (ssadd (car PT1) SS1))
    (setq SS1 (ssadd (car PT1)))
  )
  (list SS1 (cadr PT1))
)

(defun restor ()
  (foreach TEMP SVARS (apply 'setvar TEMP))
  (if (eq (getvar "MENUNAME") "HAT") (command ".menu" CM))
  (if CTS (command ".style" CTS "" "" "" "" "" "" ^C))
  (setq *error* OLDERR)
  (command ".undo" "end")
  (princ)
)

(defun haterr (s)
  (restor)
  (princ)
)

(defun C:HAT ( / SVARS CM OLDERR SS1 TEST1 NAM)

  (command ".undo" "group")

  (setq SVARS
    (mapcar
      '(lambda (A B)
         (setq VARLST (getvar A))
         (setvar A B)
         (list A VARLST)
       )
       '("CMDECHO" "REGENMODE" "ATTDIA" "ATTREQ" "AFLAGS")
       '(0 0 0 1 1)
    )
        CM (getvar "MENUNAME")
        CTS (getvar "TEXTSTYLE")
        SVARS (append (list (list "SNAPBASE" (getvar "SNAPBASE")))
                      (list (list "HIGHLIGHT" (getvar "HIGHLIGHT")))
                      SVARS
              )
        OLDERR *error* *error* HATERR
  )
  (if (not (eq (type MSG) 'STR))
    (setq MSG "ANSI31")
  )
  (setq MSG (acqst "\nPattern name / [S]elect / [U]ser / ? /" MSG))
  (cond
    (
      (eq MSG "?")
      (if (findfile "HAT.MNU")
        (progn
          (command ".menu" "HAT")
          (prompt "\nSelect pattern: ")
          (menucmd "i=hat1")
          (menucmd "i=*")
          (setq MSG (getstring))
          (command ".menu" CM)
        )
      )
      (hat)
    )
    (
      (eq MSG "S") ;must just be S cause some pats could begin with S
      (hatrf)
      (if (eq MSG "U") (hatu) (hat))
    )
    (
      (eq MSG "U") ;must just be U cause some pats could begin with U
      (hatu)
    )
    (t
      (hat)
    )
  )
  (restor)
  (princ)
)

(defun hat ( / PT1 PT2)
  (cond
    (
      (rdpat MSG)
      (if (or (<= SCL 0) (null SCL) (null (numberp ANG1))) (setq SCL 1.00))
      (setq SCL (acqrel "\nScale for pattern" SCL 6))
      (if (null (numberp ANG1)) (setq ANG1 0.00))
      (setq ANG1 (rtd (acqang "\nAngle for pattern" ANG1))
            SS1 (acqss)
            PT3 (cadr SS1)
            SS1 (car SS1))
      (setvar "HIGHLIGHT" 0)
      (command ".hatch" MSG SCL ANG1 SS1 "")
      (setq TEST1 T)
      (while TEST1
        (initget "Yes No REscale ROtate Move")
        (setq TEST1
          (getkword "\nDo you want to REscale / ROtate / Move? <No>: "))
        (cond
          (
            (eq TEST1 "No")
            (setq TEST1 nil)
          )
          (
            (eq TEST1 "REscale")
            (setq SCL (acqrel "\nNew scale" SCL 6))
            (command ".erase" "l" "" ".hatch" MSG SCL ANG1 SS1 "")
          )
          (
            (eq TEST1 "ROtate")
            (setq ANG1 (rtd
              (acqang "\nNew angle" ANG1)))
            (command ".erase" "l" "" ".hatch" MSG SCL ANG1 SS1 "")
          )
          (
            (eq TEST1 "Move")
            (initget 1)
            (setq PT1 (getpoint "\nBase point or displacement: ")
                  PT2 (getpoint  PT1 "\nSecond point of displacement: ")
            )
            (if (null PT2)
              (setq PT2 PT1 PT1 (list 0 0))
            )
            (command "setvar" "snapbase"
              (polar PT1 (angle PT1 PT2) (distance PT1 PT2)))
            (command ".erase" "l" "" ".hatch" MSG SCL ANG1 SS1 "")
          )
        )
      ) ; end of while
      (initget "No Yes")
      (setq TEST1
        (getkword "\nDo you want to make a Hatch Reference Block? <Yes>: "))
      (if (null TEST1) (setq TEST1 "Yes"))
      (if (eq "Yes" TEST1)
        (progn
          (setq DBL "No") ;user double flag
          (mkhref)
        )
      )
    )
    (
      (eq MSG "?")
      (prompt (strcat "\nCan't find HAT.MNU. This file must be located in"
                      " the ACAD search path."
                      "\nSee R.10 Reference Manual, page 54 and"
                      " HAT.DOC for instrucions on using HAT.MNU."))
    )
    (t
      (prompt "\nUnknown pattern name.")
      (prompt "\n*Invalid*")
      (setq MSG "ANSI31")
      (restor)
      (C:HAT)
    )
  )
)

(defun hatu ( / PT1 PT2)
  (if (null (numberp ANG1)) (setq ANG1 0.00))
  (setq ANG1 (rtd (acqang "\nAngle for crosshatch lines" ANG1)))
  (if (or (<= SCL 0) (null SCL) (null (numberp ANG1))) (setq SCL 1.00))
  (setq SCL (acqrel "\nSpacing between lines" SCL 6))
  (if DBL (setq TEST1 DBL) (setq TEST1 "No"))
  (initget "Yes No")
  (setq DBL (getkword (strcat "\nDouble hatch area? <" TEST1 "> ")))
  (if (null DBL) (setq DBL TEST1))
  (setq SS1 (acqss)
        PT3 (cadr SS1)
        SS1 (car SS1))
  (setvar "HIGHLIGHT" 0)
  (command ".hatch" MSG ANG1 SCL DBL SS1 "")
  (setq TEST1 T)
  (while TEST1
    (initget "Yes No REspace ROtate Move")
    (setq TEST1
      (getkword "\nDo you want to REspace / ROtate / Move? <No>: "))
    (cond
      (
        (eq TEST1 "No")
        (setq TEST1 nil)
      )
      (
        (eq TEST1 "REspace")
        (setq SCL (acqrel "\nNew spacing between lines" SCL 6))
        (command ".erase" "l" "" ".hatch" MSG ANG1 SCL DBL SS1 "")
      )
      (
        (eq TEST1 "ROtate")
        (setq ANG1 (rtd
          (acqang "\nNew angle for crosshatch lines" ANG1)))
        (command ".erase" "l" "" ".hatch" MSG ANG1 SCL DBL SS1 "")
      )
      (
        (eq TEST1 "Move")
        (initget 1)
        (setq PT1 (getpoint "\nBase point or displacement: ")
              PT2 (getpoint  PT1 "\nSecond point of displacement: ")
        )
        (if (null PT2)
          (setq PT2 PT1 PT1 (list 0 0))
        )
        (command "setvar" "snapbase"
          (polar PT1 (angle PT1 PT2) (distance PT1 PT2)))
        (command ".erase" "l" "" ".hatch" MSG ANG1 SCL DBL SS1 "")
      )
    )
  ) ; end of while
  (initget "No Yes")
  (setq TEST1
    (getkword "\nDo you want to make a Hatch Reference Block? <Yes>: "))
  (if (null TEST1) (setq TEST1 "Yes"))
  (if (eq "Yes" TEST1)
    (mkhref)
  )
)

(defun mkhref ( / SS1)
  (command ".chprop" "l" "" "color" "byblock" "la" "0" ""
           ".style" "hat" "txt" 0 1 0 "n" "n" "n")
  (setq SS1 (ssadd)
        SS1 (ssadd (entlast) SS1)
        NAM (strcat "$X" (substr (rtos (getvar "CDATE") 2 9) 13))
  )
  (command ".attdef" "" "pattern" "pattern" "none" PT3 "0.001" "0")
  (setq SS1 (ssadd (entlast) SS1))
  (command ".attdef" "" "scale" "scale" "1" "")
  (setq SS1 (ssadd (entlast) SS1))
  (command ".attdef" "" "angle" "angle" "0" "")
  (setq SS1 (ssadd (entlast) SS1))
  (command ".attdef" "" "udbl" "udbl" "N" "")
  (setq SS1 (ssadd (entlast) SS1))
  (command ".block" NAM (getvar "SNAPBASE") SS1 ""
           ".insert" NAM (getvar "SNAPBASE") "1" "" "0" MSG SCL ANG1 DBL
           ".change" "L" "" "la" (getvar "CLAYER")
  )
)

(defun C:HATREF ()
  (setvar "CMDECHO" 0)
  (setq SVARS '(("CMDECHO" 0)))
  (setq OLDERR *error* *error* MYERR CTS nil)
  (hatrf)
  (RESTOR)
  (princ)
)

(defun hatrf ( / SS1 NAM E1 E2 E3 E4)
  (if (setq SS1 (entsel "\nSelect hatch entity: "))
    (progn
      (setq SS1 (entget (car SS1)))
      (if (eq (cdr (assoc 0 SS1)) "INSERT")
        (if (eq (substr (cdr (assoc 2 SS1)) 1 1) "*")
          (prompt "\nNo reference defined for that hatch")
          (if
            (and
              (eq (cdr (assoc 0 SS1)) "INSERT")
              (eq (substr (cdr (assoc 2 SS1)) 1 1) "$")
              (setq E1 (entnext (cdr (assoc -1 SS1)))
                    E2 (entnext E1)
                    E3 (entnext E2)
                    E4 (entnext E3))
            )
            (progn
              (setq DBL (cdr (assoc 1 (entget E4)))
                    ANG1 (+ (rtd (cdr (assoc 50 (entget E3))));if attrib rotated
                            (atof (cdr (assoc 1 (entget E3)))))
                    SCL (* (/ (cdr (assoc 40 (entget E2))) 0.001);if scaled
                           (atof (cdr (assoc 1 (entget E2)))))
                    MSG (cdr (assoc 1 (entget E1)))
              )
                  (prompt (strcat "\nThe hatch pattern is: "
                                  (if (eq DBL "Yes")
                                    (strcat MSG ", Double")
                                    MSG
                                  )
                                  ",   scale: "
                                     (rtos SCL 2 4)
                                  ",   angle: "
                                     (rtos ANG1 2 4)))
            )
            (prompt "\nInvalid block selected.")
          )
        )
        (prompt "\nNot a Hatch.")
      )
    )
  )
)

;function to read the acad.pat file
(defun rdpat (MSG /  F1 TEST1 TEST2)
  (setq F1 (open (findfile "acad.pat") "r")
        MSG (capconv MSG)
        TEST1 nil)
  (while (not TEST1)
    (if (setq TEST2 (read-line F1))
      (if (eq "*" (substr TEST2 1 1))
        (progn
          (setq TEST2 (capconv (substr TEST2 2)))
          (if
            (or
              (eq TEST2 MSG)
              (eq (strcat MSG ",") (substr TEST2 1 (1+ (strlen MSG))))
            )
            (setq TEST1 T)
          )
        )
      )
      (setq TEST1 T MSG nil)
    )
  )
  (close F1)
  MSG
)

;convert a to all lower case
(defun capconv (a)
  (strcase a t)
)


(princ "\nLoaded HAT V.1.4 lisp routines. (c)1990 Michael E. Ross.")
(princ)