;Title - Erin Stephens Lisp Page
;Lisp Page from Internet - Internet Worldwide Communications
;;; AutoLISP File for
;;; Maximizing AutoCAD -- CA DISK (c) 1987, '88, '89, '91, '92 New Riders Publ.
;;;                Version 12.00 for Release 12 PC-DOS/MS-DOS                 
;;;       Developed by Rustin Gesner, Joseph Smith, and Patrick Haessly       
;;;
;;;       Permission to use, copy, modify, and distribute this software       
;;;       for any purpose is hereby granted, provided that no fees are        
;;;       collected directly or indirectly and that the above copyright       
;;;       notice and this permission notice appear in all copies and in       
;;;       all supporting documentation. See CA DISK DISCLAIMER.TXT file.
;;;

;* C:PATTERN writes a hatch pattern from selection set of LINES and/or POINTS.

;* LINES must be at 0 or angular multiples of 45 degrees. Other angles are NOT
;* filtered out and will become irregular in alignment. The selection set 
;* should be created relative to a 1-unit square box for correct alignment.
;*

;* Define a common tool function

(defun dxf (code lst)
  (cdr (assoc code lst))
)



(defun C:PATTERN ( / hname hdes ss1 fp count en ed et pt1 pt2 ang dlen
                     deltax deltay skip olin fspec)
                                              ;begin input section of program
  (setq  hname ""   hdes "" )                 ;init for input
  (while (not (and                            ;force a hatch name < 9 char 
                   (/= "" (setq hname (getstring "\nName of pattern: "))
                   (< 9 (strlen hname))
  )      )    )    )
  (while (= "" (setq hdes  (getstring "\nDescription: " T)))) ;for ACAD.PAT file
  (prompt "\nSelect unit pattern entities...")
  (while (not (setq ss1 (ssget))))            ;get entities
  (setq fp (open (strcat hname ".pat") "w"))  ;open a pattern file
  (if (getvar "TILEMODE") (textpage) (textscr))
                                              ;this section writes the header
  (princ (strcat "*" hname) fp)               ;mark start of entry with *
  (write-line (strcat "," hdes) fp)           ;write ",description" to file
                                              ;calculate & write body of pattern
  (setq count 0   emax (sslength ss1))        ;EMAX=number of entities selected
  (while (< count emax)                       ;examine ea entity selected
    (setq en (ssname ss1 count)               ;entity name
          ed (entget en)                      ;entity data
          et (dxf 0 ed)                       ;entity type
          count (1+ count)
    )
    (cond 
      ((= et "POINT")                         ;cond-1 - If it's a POINT...
        (setq olin                            ;...calc & format the hatch "line"
          (strcat "0," (rtos (car  (dxf 10 ed)) 2 6) ","
                       (rtos (cadr (dxf 10 ed)) 2 6) ",0,1,0,-1"
        ) )
        (prompt (strcat "\n" olin))           ;display "line" for amusement
        (write-line olin fp)                  ;write it to file
      );cond-1
      ((= et "LINE")                          ;cond-2 - If it's a LINE...
        (setq pt1 (dxf 10 ed)                 ;endpt 1
              pt2 (dxf 11 ed)                 ;endpt 2
              ang (angle pt1 pt2)             ;angle
              dlen (distance pt1 pt2)         ;length
        );setq
        (if (= "1.00"                         ;test whether 90 deg multiple
              (rtos                                ;if so, abs of sin or cos...
                (+ (setq deltax (abs (cos ang)))   ;...will be 1 and other 0
                   (setq deltay (abs (sin ang)))
                ) 2 2
            ) );=
            (setq deltax 0.0                  ;then set offset along line &
                  deltay 1.0                  ;offset to parallel line &
                  skip (- dlen deltay)        ;dash length
            )
                      ;else assume to be 45 deg family & use offsets set in IF test above
            (setq skip (- dlen (* deltay 2.0)))     ;& set dash length
        );if
        (setq olin                                  ;format LINE hatch "line"
          (strcat (angtos ang 0 6)      "," (rtos (car pt1) 2 6)
              "," (rtos (cadr pt1) 2 6) "," (rtos deltax 2 6)
              "," (rtos deltay 2 6)     "," (rtos dlen 2 6)
              "," (rtos skip 2 6)
        ) );setq&strcat
        (prompt (strcat "\n" olin))
        (write-line olin fp)
      );cond-2
      (T  (prompt                                   ;cond-3 - not LINE or POINT
            (strcat "\nInvalid entity " et " skipped.")
      )   )
    );cond
  );while
                                ;this section closes file & appends for use
  (write-char 26 fp)                                ;write ^Z EOF char
  (close fp)                                        ;close temp ACADPAT.$ file
  (graphscr)
  (princ)
);defun PATTERN
(princ)
;*