;;;
;;; Author: Henry C. Francis
;;; 425 N. Ashe St.
;;; Southern Pines, NC 28387
;;;
;;; http://www.paracadd.com
;;; All rights reserved.
;;;
;;; Copyright: 02-21-2013
;;; Edited: 08-7-2014
;;;
(DEFUN C:LOCATEZ (/ this_sel this_ent next_ent vertex_pt1
vertex_pt2 vertex_z1 vertex_z2 this_slope new_run
zpt3d run_from_pt run_to_pt zpickpt zptxy
new_rise
)
(SETQ old_lz_osmode (GETVAR "OSMODE"))
(IF ureal
NIL
(LOAD "ureal" "\nFile UREAL.LSP not loaded! ")
) ;_ end of IF
(SETQ z2locate (ureal 1 "Pick Match" "Enter Z value or [Pick/Match-circle-Z]" (IF (AND z2locate(/=(TYPE z2locate) 'REAL)) z2locate "Pick")))
(IF (EQ z2locate "Match")
(PROGN
(PROMPT "\nSelect a Circle: ")
(SETQ circ_sel (SSGET '((0 . "Circle"))))
(SETQ this-circle (ENTGET (SSNAME circ_sel 0)))
(SETQ z2locate (LAST (CDR (ASSOC 10 this-circle))))
(PROMPT "\nSelect a Line or 3DPolyline: ")
)
(PROMPT "\nSelect a Line or 3DPolyline: ")
)
(SETQ this_sel (NENTSEL))
(IF this_sel
(PROGN
(SETQ this_ent (ENTGET (CAR this_sel)))
(COND
((EQ (CDR (ASSOC 0 this_ent)) "VERTEX")
(SETQ next_ent (ENTGET (ENTNEXT (CDR (ASSOC -1 this_ent)))))
(SETQ vertex_pt1 (LIST (CADR (ASSOC 10 this_ent))
(CADDR (ASSOC 10 this_ent))
) ;_ end of LIST
vertex_pt2 (LIST (CADR (ASSOC 10 next_ent))
(CADDR (ASSOC 10 next_ent))
) ;_ end of LIST
vertex_z1 (CADDDR (ASSOC 10 this_ent))
vertex_z2 (CADDDR (ASSOC 10 next_ent))
) ;_ end of SETQ
)
((EQ (CDR (ASSOC 0 this_ent)) "LINE")
(SETQ vertex_pt1 (LIST (CADR (ASSOC 10 this_ent))
(CADDR (ASSOC 10 this_ent))
) ;_ end of LIST
vertex_pt2 (LIST (CADR (ASSOC 11 this_ent))
(CADDR (ASSOC 11 this_ent))
) ;_ end of LIST
vertex_z1 (CADDDR (ASSOC 10 this_ent))
vertex_z2 (CADDDR (ASSOC 11 this_ent))
) ;_ end of SETQ
)
) ;_ end of COND
(SETQ this_slope (/ (- vertex_z1 vertex_z2) (DISTANCE vertex_pt1 vertex_pt2)))
(COND
((AND
(/= z2locate "Pick")
(>= z2locate (MIN vertex_z1 vertex_z2))
(<= z2locate (MAX vertex_z1 vertex_z2))
) ;_ end of AND
(PROGN
(SETQ new_run
(ABS (/ (- (MAX vertex_z1 vertex_z2) z2locate) this_slope))
) ;_ end of SETQ
(IF (EQ (MAX vertex_z1 vertex_z2) vertex_z1)
(SETQ run_from_pt vertex_pt1
run_to_pt vertex_pt2
) ;_ end of SETQ
(SETQ run_from_pt vertex_pt2
run_to_pt vertex_pt1
) ;_ end of SETQ
) ;_ end of IF
(SETQ zptxy (POLAR run_from_pt (ANGLE run_from_pt run_to_pt) new_run)
zpt3d (APPEND zptxy (LIST z2locate))
) ;_ end of SETQ
) ;_ end of PROGN
)
((EQ z2locate "Pick")
(IF upoint
NIL
(LOAD "upoint" "\nFile UPOINT.LSP not loaded! ")
) ;_ end of IF
(SETQ old_lz_osmode (GETVAR "OSMODE"))
(SETVAR "OSMODE" 0)
(SETQ zpickpt (upoint 1 "" "Pick point for Z-location" nil nil))
(SETQ zptxy
(INTERS vertex_pt1
vertex_pt2
(POLAR zpickpt
(+ (* PI 0.5) (ANGLE vertex_pt1 vertex_pt2))
20.0
) ;_ end of POLAR
(POLAR zpickpt
(+ (* PI 1.5) (ANGLE vertex_pt1 vertex_pt2))
20.0
) ;_ end of POLAR
nil
) ;_ end of INTERS
) ;_ end of SETQ
(SETQ new_run (DISTANCE vertex_pt1 zptxy)
new_rise (* this_slope new_run)
z2locate (- vertex_z1 new_rise)
zpt3d (APPEND zptxy (LIST z2locate))
) ;_ end of SETQ
;;; (PRINC "\nthis_slope=")
;;; (PRINC this_slope)
;;; (PRINC "\nnew_rise=")
;;; (PRINC new_rise)
;;; (PRINC "\nnew_run=")
;;; (PRINC new_run)
;;; (PRINC "\nvertex_z1=")
;;; (PRINC vertex_z1)
;;; (PRINC "\nvertex_z2=")
;;; (PRINC vertex_z2)
;;; (PRINC)
)
((AND
(/= z2locate "Pick")
(OR
(< z2locate (MIN vertex_z1 vertex_z2))
(> z2locate (MAX vertex_z1 vertex_z2))
)
)
(PROGN
(PRINC (STRCAT "\nRequested Z is out of range (max z=" (RTOS (MAX vertex_z1 vertex_z2) 2 3) ", min z=" (RTOS (MIN vertex_z1 vertex_z2) 2 3)))
(PRINC)
)
)
) ;_ end of COND
) ;_ end of PROGN
(PROMPT "\nNothing was selected! ")
) ;_ end of IF
(IF zpt3d
(PROGN
(PRINC "\nSlope=")
(PRINC this_slope)
(PRINC "\nZ=")
(PRINC z2locate)
(PRINC "\nPoint on polyline segment is: ")
(PRINC zpt3d)
(PRINC)
(IF ukword
nil
(LOAD "ukword" "\nFile UKWORD.LSP not loaded! ")
) ;_ end of IF
(SETQ mark_pt (ukword 1
"Yes No"
"Do you want to mark the point?"
(IF markpt
markpt
"Yes"
) ;_ end of IF
) ;_ end of ukword
) ;_ end of SETQ
(IF (EQ mark_pt "Yes")
(PROGN
(SETQ mark_on_pick (ukword 1 "Yes No" "Do you want to put the marker on the pick point? [Yes/No]" (IF mark_on_pick mark_on_pick "No")))
(IF (EQ mark_on_pick "Yes")
(ENTMAKE
(LIST (CONS 0 "CIRCLE") (CONS 10 (LIST (CAR zpickpt)(CADR zpickpt)(CADDR zpt3d))) (CONS 8 "LOCATEZ-CIRCLE-$TE$") (CONS 40 2.0)) ;_ end of LIST
) ;_ end of ENTMAKE
;;; (COMMAND ".circle" "non" (LIST (CAR zpickpt)(CADR zpickpt)(CADDR zpt3d)) 2.0)
(ENTMAKE
(LIST (CONS 0 "CIRCLE") (CONS 10 zpt3d) (CONS 8 "LOCATEZ-CIRCLE-$TE$") (CONS 40 2.0)) ;_ end of LIST
) ;_ end of ENTMAKE
;;; (COMMAND ".circle" "non" zpt3d 2.0)
)
)
) ;_ end of IF
) ;_ end of PROGN
) ;_ end of IF
(SETVAR "OSMODE" old_lz_osmode)
(PRINC)
) ;_ end of defun
(DEFUN C:LZ () (C:LOCATEZ))
;;;******************************************************************************
(DEFUN C:DELZCIRCLE ()
(SETQ z-circ-ss (SSGET "X" (LIST (CONS 8 "LOCATEZ-CIRCLE-$TE$")(CONS 0 "CIRCLE"))))
(SETQ delzcnt (SSLENGTH z-circ-ss))
(REPEAT (SSLENGTH z-circ-ss)
(ENTDEL (SSNAME z-circ-ss (SETQ delzcnt (1- delzcnt))))
)
)
;;;******************************************************************************
(DEFUN C:DAYLTCIRCLE ( / dayltpick pickpt slope-list)
(IF ustr
NIL
(LOAD "ustr" "\nFile USTR.LSP not loaded! ")
) ;_ end of IF
(WHILE
(OR
(NOT
(WCMATCH
(SETQ dayltslope
(ustr
1
"Enter slope to daylight (rise:run)"
(IF dayltslope
dayltslope
"3:1"
) ;_ end of IF
nil
) ;_ end of ureal
) ;_ end of SETQ
"*#*:*#*"
)
)
(MEMBER nil (MAPCAR '(LAMBDA (x) (OR (EQ (TYPE (READ x)) 'REAL)(EQ (TYPE (READ x)) 'INT)))(DOS_STRTOKENS dayltslope ":")))
)
(IF
(OR
(MEMBER nil (MAPCAR '(LAMBDA (x) (OR (EQ (TYPE (READ x)) 'REAL)(EQ (TYPE (READ x)) 'INT)))(DOS_STRTOKENS dayltslope ":")))
(NOT (WCMATCH dayltslope "*#*:*#*"))
)
(PRINC "\nEnter only integers or reals separated by a colon and no spaces! ")
)
)
(SETQ slope-list (MAPCAR '(LAMBDA (x) (READ x))(DOS_STRTOKENS dayltslope ":")))
(IF ureal
NIL
(LOAD "ureal" "\nFile UREAL.LSP not loaded! ")
) ;_ end of IF
(SETQ dayltel (ureal 1
"Pick"
"Enter Z value for daylight or [Pick]"
(IF dayltel dayltel "Pick")
) ;_ end of ureal
) ;_ end of SETQ
(IF (EQ dayltel "Pick")
(PROGN
(IF upoint
NIL
(LOAD "upoint" "\nFile UPOINT.LSP not loaded! ")
) ;_ end of IF
(SETQ dayltpick (upoint 1
"Quit"
"Pick elevation to daylight to or [Quit]"
nil
nil
) ;_ end of upoint
) ;_ end of SETQ
(SETQ dayltel (LAST dayltpick))
) ;_ end of PROGN
(SETQ dayltpick (LIST 0.0 0.0 dayltel))
) ;_ end of IF
(IF (EQ dayltpick "Quit")
(SETQ pickpt NIL)
)
(IF (AND
(/= dayltpick "Quit")
(EQ dayltel "Pick")
)
(SETQ use-daylt-el
(ukword 1
"Yes No"
(STRCAT "Use daylight elevation "
(RTOS (LAST dayltpick) 2 4)
"? [Yes/No]"
) ;_ end of STRCAT
"Yes"
) ;_ end of ukword
)
)
(IF
(AND
(NOT (EQ dayltpick "Quit"))
(NOT (EQ use-daylt-el "No"))
)
(PROGN
(IF upoint
NIL
(LOAD "upoint" "\nFile UPOINT.LSP not loaded! ")
) ;_ end of IF
(SETQ pickpt (upoint 1 "" "Location to daylight from" nil nil))
(IF pickpt
(PROGN
(IF ukword
nil
(LOAD "ukword" "\nFile UKWORD.LSP not loaded! ")
) ;_ end of IF
(SETQ use_pickpt
(ukword 1
"Yes No"
(STRCAT "Use selected point elevation "
(RTOS (LAST pickpt) 2 4)
"? [Yes/No]"
) ;_ end of STRCAT
(IF use_pickpt
use_pickpt
"Yes"
) ;_ end of IF
) ;_ end of ukword
) ;_ end of SETQ
(IF (EQ use_pickpt "Yes")
NIL
(PROGN
(SETQ pickptel
(ureal 1
"Quit"
"Enter new Z value for selected point or [Quit]"
(IF pickptel
pickptel
nil
) ;_ end of IF
) ;_ end of ureal
) ;_ end of SETQ
(IF (EQ pickptel "Quit")
(SETQ pickpt NIL)
(SETQ pickpt (REVERSE (CONS pickptel (CDR (REVERSE pickpt)))))
) ;_ end of IF
) ;_ end of PROGN
) ;_ end of IF
) ;_ end of PROGN
) ;_ end of IF
) ;_ end of PROGN
(SETQ pickpt NIL)
) ;_ end of IF
(IF (AND pickpt dayltel slope-list)
(PROGN
(SETQ daycirc-rad
(* (EVAL (CONS '/ slope-list))
(ABS (- dayltel (LAST pickpt)))
) ;_ end of *
) ;_ end of SETQ
(SETQ elist (LIST (CONS 0 "CIRCLE")
(CONS 8 "TEMPORARY-3D-CIRCLES")
(CONS 10 pickpt)
(CONS 40 daycirc-rad)
(CONS 62 256)
) ;_ end of list
) ;_ end of setq
(ENTMAKE elist)
) ;_ end of PROGN
)
(PRINC)
) ;_ end of DEFUN
;;;******************************************************************************
;|«Visual LISP© Format Options»
(84 2 40 2 T "end of " 60 9 2 0 0 nil T nil T)
;*** DO NOT add text below the comment! ***|;