;;;Draws an ARC (semicircle) on either side of any line or polyline intersection and trims the line inside the arc. ;;; ;;;Entity definitions are currently stored in variables in anticipation of future code making use of ;;;ENTMAKE, ENTMOD, and/or ENTUPD rather than the TRIM command. Once written, the code will eliminate arc ;;;creation (except at lines) and the use of the TRIM command and its occasional trim errors (wrong entity trimmed). ;;; ;;;The number of crossing Lines, Polylines, or LWPolylines has been arbitrarily limited to 6. More than 4 increases ;;;the possibility of trimming the wrong line. ;;; ;;; Author: Henry C. Francis ;;; 425 N. Ashe St. ;;; Southern Pines, NC 28387 ;;; http://www.paracadd.com ;;; All rights reserved. ;;; ;;; COPYRIGHT: 5/3/2010 ;;; EDITED: 5/3/2010 ;;; ;;; Required subroutines: dimscl.lsp, ureal.lsp, upoint.lsp, ukword.lsp ;;; ;;;**************************************************************************** (DEFUN pick_inters_error (msg /) (IF (EQ msg "Function cancelled") (PRINC "\nLinejump cancelled ") (PROGN (PRINC "\nCommand LINEJUMP abborted on error: ") (PRINC msg)) ) ;_ end of IF (SETQ *error* old_pick_inters_error) (SETVAR "CELTYPE" pick_inters_celtype) (SETVAR "CECOLOR" pick_inters_cecolor) (SETVAR "osmode" pick_inters_osmode) (SETVAR "pickbox" pick_inters_pickbox) (SETVAR "aperture" pick_inters_aperture) (PRINC) ) ;_ end of DEFUN ;;;**************************************************************************** (DEFUN c:linejump () (SETQ pick_inters nil inters_ss nil ) ;_ end of SETQ (SETQ old_pick_inters_error *error* *error* pick_inters_error ) ;_ end of SETQ (SETQ pick_inters_celtype (GETVAR "celtype")) (SETQ pick_inters_cecolor (GETVAR "cecolor")) (SETQ pick_inters_osmode (GETVAR "osmode")) (SETQ pick_inters_pickbox (GETVAR "pickbox")) (SETQ pick_inters_aperture (GETVAR "aperture")) (SETVAR "CELTYPE" "BYLAYER") (SETVAR "CECOLOR" "BYLAYER") (SETVAR "osmode" 2080) (IF dimscl nil (LOAD "dimscl" "\nFile DIMSCL.LSP not loaded! ") ) ;_ end of IF (dimscl) (IF ureal nil (LOAD "ureal" "\nFile UREAL.LSP not loaded! ") ) ;_ end of IF (IF ukword nil (LOAD "ukword" "\nFile UKWORD.LSP not loaded! ") ) ;_ end of IF (SETQ plotted_rad (ureal 1 "" (STRCAT "Arc radius (" (RTOS dimsc 2 1) " scale R" (RTOS (IF plotted_rad plotted_rad 0.0625 ) ;_ end of IF 2 4 ) ;_ end of RTOS "(" (RTOS (IF plotted_rad plotted_rad 0.0625 ) ;_ end of IF 5 4 ) ;_ end of RTOS "\")=" (RTOS (IF plotted_rad (* plotted_rad dimsc) (* 0.0625 dimsc) ) ;_ end of IF 2 3 ) ;_ end of RTOS " drawing units)" ) ;_ end of STRCAT (IF plotted_rad plotted_rad 0.0625 ) ;_ end of IF ) ;_ end of ureal ) ;_ end of SETQ (SETQ jump_rad (* dimsc plotted_rad)) (IF upoint nil (LOAD "upoint" "\nFile UPOINT.LSP not loaded! ") ) ;_ end of IF ;;; (WHILE (AND (SETQ pick_inters (upoint 0 "Quit" "Pick intersection of lines or [Quit]" nil nil)) (/= pick_inters "Quit") ;;; ) ;_ end of AND (IF (AND pick_inters (/= pick_inters "Quit")) (PROGN (COMMAND ".undo" "begin") (SETQ pt1 (POLAR pick_inters 0 jump_rad) ;(* 0.01 dimsc) pt2 (POLAR pick_inters (* PI 0.5) jump_rad) ;(* 0.01 dimsc) pt3 (POLAR pick_inters PI jump_rad) ;(* 0.01 dimsc) pt4 (POLAR pick_inters (* PI 1.5) jump_rad) ;(* 0.01 dimsc) ) ;_ end of SETQ (SETQ inters_ss (SSGET "CP" (LIST pt1 pt2 pt3 pt4) '((-4 . "")) ) ;_ end of SSGET ) ;_ end of SETQ (IF (AND inters_ss (< (SSLENGTH inters_ss) 5));arbitrary limit on the selection set size is 4 (PROGN (SETQ inters_cnt 0 inters_ang_lst nil ) ;_ end of SETQ (WHILE (< inters_cnt (SSLENGTH inters_ss)) (SETQ inters_ent (ENTGET (SSNAME inters_ss inters_cnt))) (COND ((EQ (CDR (ASSOC 0 inters_ent)) "POLYLINE") (SETQ prev_ent nil) (WHILE (AND (SETQ inters_ent (ENTGET (ENTNEXT (CDR (ASSOC -1 inters_ent))))) (/= (CDR (ASSOC 0 inters_ent)) "SEQEND") ) ;_ end of AND (IF (AND prev_ent ;Find the selected VERTEX ;The distance and angle to next vertex will match: ;sum of distances from intersection point to each; and, ;angle from intersection point to next vertex (EQUAL (DISTANCE (CDR (ASSOC 10 inters_ent)) (CDR (ASSOC 10 prev_ent))) (+ (DISTANCE pick_inters (CDR (ASSOC 10 inters_ent))) (DISTANCE pick_inters (CDR (ASSOC 10 prev_ent))) ) ;_ end of + 0.01 ) ;_ end of EQUAL (EQUAL (ANGLE pick_inters (CDR (ASSOC 10 prev_ent))) (ANGLE (CDR (ASSOC 10 inters_ent)) (CDR (ASSOC 10 prev_ent))) 0.001 ) ;_ end of EQUAL ) ;_ end of AND (SETQ inters_ang_lst (APPEND inters_ang_lst (LIST (LIST (ANGLE (CDR (ASSOC 10 prev_ent)) (CDR (ASSOC 10 inters_ent)) ) ;_ end of ANGLE prev_ent ;The beginning VERTEX entity is stored for use with ENTMAKE and ENTDEL code ;which is yet to be written. Once written, arc creation and the command line use of TRIM ;will be unnecessary and the occasional trim errors (wrong entity trimmed) will be eliminated. ;The new VERTEX bulge of 1.0 or -1.0 must be determined by the direction of the Polyline and ;the side on which the arc segment will be. ;Code should account for an existing VERTEX that has a bulge already. ) ;_ end of LIST ) ;_ end of LIST ) ;_ end of APPEND ) ;_ end of SETQ ) ;_ end of IF (SETQ prev_ent inters_ent) ) ;_ end of WHILE ) ((EQ (CDR (ASSOC 0 inters_ent)) "LWPOLYLINE") (SETQ prev_ent (MEMBER (ASSOC 10 inters_ent) inters_ent)) (WHILE (AND (SETQ pnt_1 (LIST (NTH 0 prev_ent)(NTH 1 prev_ent)(NTH 2 prev_ent)(NTH 3 prev_ent))) (ASSOC 10 (CDR prev_ent)) (SETQ prev_ent (MEMBER (ASSOC 10 (CDR prev_ent)) prev_ent)) (SETQ pnt_2 (LIST (NTH 0 prev_ent)(NTH 1 prev_ent)(NTH 2 prev_ent)(NTH 3 prev_ent))) ) ;_ end of AND (IF (AND ;Find the selected LWPOLYLINE segment ;The distance and angle from pnt_1 to pnt_2 will match: ;the sum of distances from intersection point to pnt_1 and pnt_2; and, ;the angle from intersection point to pnt_2 (EQUAL (DISTANCE (CDAR pnt_1) (CDAR pnt_2)) (+ (DISTANCE pick_inters (CDAR pnt_1)) (DISTANCE pick_inters (CDAR pnt_2)) ) ;_ end of + 0.01 ) ;_ end of EQUAL (EQUAL (ANGLE pick_inters (CDAR pnt_2)) (ANGLE (CDAR pnt_1) (CDAR pnt_2)) 0.001 ) ;_ end of EQUAL ) ;_ end of AND (SETQ inters_ang_lst (APPEND inters_ang_lst (LIST (LIST (ANGLE (CDAR pnt_1) (CDAR pnt_2) ) ;_ end of ANGLE inters_ent ;The original LWPOLYLINE entity is stored for use with ENTMOD and ENTUPD code ;which is yet to be written. Once written, arc creation and the command line use of TRIM ;will be unnecessary and the occasional trim errors (wrong entity trimmed) will be eliminated. ;The new vertex bulge of 1.0 or -1.0 must be determined by the direction of the LWPolyline and ;the side on which the arc segment will be. ;Code should account for an existing vertex that has a bulge already. ) ;_ end of LIST ) ;_ end of LIST ) ;_ end of APPEND ) ;_ end of SETQ ) ;_ end of IF ) ;_ end of WHILE ) ((EQ (CDR (ASSOC 0 inters_ent)) "LINE") (IF (EQUAL (ANGLE pick_inters (CDR (ASSOC 11 inters_ent))) (ANGLE (CDR (ASSOC 10 inters_ent)) (CDR (ASSOC 11 inters_ent))) 0.001 ) ;_ end of EQUAL (SETQ inters_ang_lst (APPEND inters_ang_lst (LIST (LIST (ANGLE (CDR (ASSOC 10 inters_ent)) (CDR (ASSOC 11 inters_ent)) ) ;_ end of ANGLE inters_ent ;The original LINE entity is stored for use with ENTMAKE, ENTMOD and ENTUPD code ;which is yet to be written. Once written, the command line use of TRIM will be ;unnecessary and the occasional trim errors (wrong entity trimmed) will be eliminated ) ;_ end of LIST ) ;_ end of LIST ) ;_ end of APPEND ) ;_ end of SETQ ) ;_ end of IF ) ) ;_ end of COND (SETQ inters_cnt (1+ inters_cnt)) ) ;_ end of WHILE (SETQ use_arc "No") (FOREACH n inters_ang_lst (IF (EQ use_arc "Yes") nil (PROGN (SETQ this_arc (ENTMAKE (APPEND (LIST (CONS 0 "ARC") (CONS 10 pick_inters) (CONS 40 jump_rad) (CONS 50 (CAR n)) (CONS 51 (IF (>= (CAR n) PI) (- (CAR n) PI) (+ PI (CAR n)) ) ;_ end of IF ) ;_ end of CONS ) ;_ end of LIST (COND ((AND (ASSOC 6 (CADR n)) (ASSOC 62 (CADR n))) (LIST (ASSOC 8 (CADR n)) (ASSOC 6 (CADR n)) (ASSOC 62 (CADR n))) ) ((ASSOC 6 (CADR n)) (LIST (ASSOC 8 (CADR n)) (ASSOC 6 (CADR n))) ) ((ASSOC 62 (CADR n)) (LIST (ASSOC 8 (CADR n)) (ASSOC 62 (CADR n))) ) (T (LIST (ASSOC 8 (CADR n)))) ) ;_ end of COND ) ;_ end of APPEND ) ;_ end of ENTMAKE ) ;_ end of SETQ (SETQ use_arc (ukword 1 "Yes No" "Use this arc? " "No")) (IF (EQ use_arc "Yes") (PROGN (SETQ used_arc this_arc) ;;; (SETVAR "pickbox" 1) ;;; (SETVAR "aperture" 1) (COMMAND ".trim" (ENTLAST) "" pause ;;; (POLAR pick_inters (CAR n) (/ jump_rad 8.0)) ;;; (POLAR pick_inters (+ (CAR n) PI) (/ jump_rad 8.0)) ;;; (POLAR pick_inters (CAR n) (/ jump_rad 1.1)) ;;; (POLAR pick_inters (+ (CAR n) PI) (/ jump_rad 1.1)) "" ) ;_ end of COMMAND ;;; (SETVAR "pickbox" pick_inters_pickbox) ;;; (SETVAR "aperture" pick_inters_aperture) ) ;_ end of PROGN (ENTDEL (ENTLAST)) ) ;_ end of IF (IF (EQ use_arc "Yes") nil (PROGN (SETQ this_arc (ENTMAKE (APPEND (LIST (CONS 0 "ARC") (CONS 10 pick_inters) (CONS 40 jump_rad) (CONS 50 (IF (>= (CAR n) PI) (- (CAR n) PI) (+ PI (CAR n)) ) ;_ end of IF ) ;_ end of CONS (CONS 51 (CAR n)) ) ;_ end of LIST (COND ((AND (ASSOC 6 (CADR n)) (ASSOC 62 (CADR n))) (LIST (ASSOC 8 (CADR n)) (ASSOC 6 (CADR n)) (ASSOC 62 (CADR n)) ) ;_ end of LIST ) ((ASSOC 6 (CADR n)) (LIST (ASSOC 8 (CADR n)) (ASSOC 6 (CADR n))) ) ((ASSOC 62 (CADR n)) (LIST (ASSOC 8 (CADR n)) (ASSOC 62 (CADR n))) ) (T (LIST (ASSOC 8 (CADR n)))) ) ;_ end of COND ) ;_ end of APPEND ) ;_ end of ENTMAKE ) ;_ end of SETQ (SETQ this_arc (ENTMAKE (LIST (CONS 0 "ARC") (ASSOC 8 (CADR n)) (CONS 10 pick_inters) (CONS 40 jump_rad) ) ;_ end of LIST ) ;_ end of ENTMAKE ) ;_ end of SETQ (SETQ use_arc (ukword 1 "Yes No" "Use this arc? " "No")) (IF (EQ use_arc "Yes") (PROGN (SETQ used_arc this_arc) ;;; (SETVAR "pickbox" 1) ;;; (SETVAR "aperture" 1) (COMMAND ".trim" (ENTLAST) "" pause ;;; (POLAR pick_inters (CAR n) (/ jump_rad 8.0)) ;;; (POLAR pick_inters (+ (CAR n) PI) (/ jump_rad 8.0)) ;;; (POLAR pick_inters (CAR n) (/ jump_rad 1.1)) ;;; (POLAR pick_inters (+ (CAR n) PI) (/ jump_rad 1.1)) "" ) ;_ end of COMMAND ;;; (SETVAR "pickbox" pick_inters_pickbox) ;;; (SETVAR "aperture" pick_inters_aperture) ) ;_ end of PROGN (ENTDEL (ENTLAST)) ) ;_ end of IF ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of PROGN ) ;_ end of IF ) ;_ end of FOREACH (FOREACH n inters_ang_lst) ) ;_ end of PROGN ) ;_ end of IF (COMMAND ".undo" "end") ) ;_ end of PROGN ) ;_ end of IF ;;; ) ;_ end of WHILE (SETQ *error* old_pick_inters_error) (SETVAR "CELTYPE" pick_inters_celtype) (SETVAR "CECOLOR" pick_inters_cecolor) (SETVAR "osmode" pick_inters_osmode) (SETVAR "pickbox" pick_inters_pickbox) (SETVAR "aperture" pick_inters_aperture) (PRINC) ) ;_ end of DEFUN ;;;**************************************************************************** (DEFUN c:lj () (c:linejump)) ;;;**************************************************************************** ;|«Visual LISP© Format Options» (100 2 30 2 T "end of " 100 9 2 1 1 nil nil nil T) ;*** DO NOT add text below the comment! ***|;