;------------------------------------------------------------------------------------;
;                                                                                    ;
;   SPLICE.LSP by Michael Bulatovich November 30th, 2002  www.michaelbulatovich.ca   ;
;                                                                                    ;
;   "Joins" two colinear lines into one line having the properties of the            ;
;   first one picked on screen                                                       ;
;                                                                                    ;
;   Originally written in ~1998, it had a stupid flaw which I finally fixed in       ;
;   November 2002. At the same time an adjustable fuzz factor was included.          ;
;                                                                                    ;
;------------------------------------------------------------------------------------;

(defun C:splice	(/	 first	 second	 list1	 list2	 resetfuzz
		 switch	 pt1	 pt2	 pt3	 pt4	 setfuzz
		 minx	  maxx	  left   firsttest 1z	2z
		 right p1x	 p2x	 p3x	 p4x	 p1y
		 p2y	 p3y	 p4y	 shift1	 shift2	 YbyX
		 dYbyX
		)
  (setvar "cmdecho" 0)
  (command "undo" "be")

;-----------------------------------------------------------------
;THE FIRST RUN SECTION                                            
;-----------------------------------------------------------------
  (if (equal firstsplice nil)
    (progn
      (setq splicefuzz
	     0.0000001
	    firstsplice	t
      )
      (prompt
	(strcat
	  "Splice will splice two colinear line segments."
	  "\nDefault accuracy factor is "
	  (rtos splicefuzz 2 8)
	  "."
	)
      )
      (initget "Yes No")
      (setq setfuzz
	     (getkword
	       "\nDo you want to set the accuracy factor? Yes/<No>:"
	     )
      )
      (if (equal setfuzz nil)
	(setq setfuzz "No"
	      switch 2
	)
	(setq switch 3)
      )
    )
  )
;------------------------------------------------------------------
;THE STANDARD FIRST PICK SECTION                                   
;------------------------------------------------------------------
  (if (equal switch nil)
    (progn
      (initget "Yes No")
      (setq firsttest
	     (car
	       (entsel
		 (strcat
		   "Current accuracy factor is "
		   (rtos splicefuzz 2 8)
		   ". "
		   "<Adjust accuracy>/Pick the line with desired properties:"
		 )
	       ) ;_ end of entsel
	     ) ;_ end of car
      )
      (if (equal firsttest nil)
	(setq setfuzz "Yes")
	(setq first firsttest)
      )
    )
  )
;-----------------------------------------------------------------
;THE RESET SECTION                                                
;-----------------------------------------------------------------
  (if (or (equal setfuzz "Yes") (equal switch 3))
    (progn
      (setq resetfuzz
	     (getreal
	       (strcat
		 "\nSpecify minimum significant angular difference as a real number <"
		 (rtos splicefuzz 2 8)
		 ">:"
	       )
	     )
	    switch 2
      )
      (if (not (equal resetfuzz nil))
	(setq splicefuzz resetfuzz)
      )
    )
  )
;-----------------------------------------------------------------
;THE SIMPLE PICK SECTION                                          
;-----------------------------------------------------------------
  (if (equal switch 2)
    (while (equal first nil)
      (setq first
	     (car
	       (entsel
		 "\nPick first line:"
	       )
	     )
      )
    )
  )
  (while (or (equal second first) (equal second nil))
    (setq second (car (entsel "     Pick second line:")))
  )
;-----------------------------------------------------------------
;THE COORDINATE EXTRACTION SECTION                                
;-----------------------------------------------------------------
  (setq	list1  (entget first)
	pt1    (cdr (assoc 10 list1))
	pt2    (cdr (assoc 11 list1))
	p1x    (cadr (assoc 10 list1))
	p1y    (caddr (assoc 10 list1))
	1z     (max (cadddr (assoc 10 list1))(cadddr(assoc 11 list1)))
	p2x    (cadr (assoc 11 list1))	
	p2y    (caddr (assoc 11 list1))
	YbyX   (/ (- p2y p1y) (- p2x p1x)) 
	shift1 (- p1y (* p1x YbyX))
	list2  (entget second)
	pt3    (cdr (assoc 10 list2))
	pt4    (cdr (assoc 11 list2))
	p3x    (cadr (assoc 10 list2))	
	p3y    (caddr (assoc 10 list2))
	2z     (max (cadddr (assoc 10 list2))(cadddr(assoc 11 list2)))
	p4x    (cadr (assoc 11 list2))
	p4y    (caddr (assoc 11 list2))
	dYbyX  (/ (- p4y p3y) (- p4x p3x)) 
	shift2 (- p3y (* p3x dYbyX))
  )
;-----------------------------------------------------------------
;THE COLINEARITY TEST AND MODIFICATION SECTION                   
;-----------------------------------------------------------------
  (cond
    ((not(equal 0 1z))(progn(alert " The first line is not 2D.")(exit)))
    ((not(equal 0 2z))(progn(alert "The second line is not 2D.")(exit)))
    )
  (if (and (equal YbyX dYbyX splicefuzz)
	   (equal shift1 shift2 splicefuzz)
      )
    (progn
      (setq minx (min (car pt1) (car pt2) (car pt3) (car pt4)))
      (setq maxx (max (car pt1) (car pt2) (car pt3) (car pt4)))
      (cond ((equal minx (car pt1)) (setq left pt1))
	    ((equal minx (car pt2)) (setq left pt2))
	    ((equal minx (car pt3)) (setq left pt3))
	    ((equal minx (car pt4)) (setq left pt4))
      )
      (cond
	((equal maxx (car pt1)) (setq right pt1))
	((equal maxx (car pt2)) (setq right pt2))
	((equal maxx (car pt3)) (setq right pt3))
	((equal maxx (car pt4)) (setq right pt4))
      )
      (setq list1 (subst (cons 10 left) (assoc 10 list1) list1)
	    list1 (subst (cons 11 right) (assoc 11 list1) list1)
      )
      (entmod list1)
      (entdel second)
      (princ)
    )
    (alert
      "               Sorry,\n  Lines are  NOT co-linear\n to that level of accuracy."
    )
  )
  (princ)
)