;;; ;;; 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! ***|;