; WORDmove.LSP                       Written by JDZ, Sept 1993
; This lisp routine moves one word from first string to a second string.
; If first selected string is below the second, the routine moves the 
; first word up.  otherwise it moves the last word down.

(defun chgterr (S)         ; If an error occurs while this command is active
 (if (/= S "quit / exit abort")(princ (strcat "\nError: " S)) )
 (if ENT1(redraw (cdar ENT1) 4))
 (setq *error* olderr)              ; Restore old *error* handler
 (princ)
)
;----------------------------------------------------------------------------
(defun entry1 (TT / X XX)            ; Pick and test text
	(setq X (car (entsel TT)))
	(if X
		(progn
			(setq XX (entget X))
			(if (not (eq (cdr (assoc 0 XX)) "TEXT"))
				(entry1 "\nEntity selected is not standard text - try again.")
			)
		)
		(setq XX nil)
	)
	XX
)

(defun entry2 (TT / X XX FLG)            ; Pick and test text
	(setq X (car (entsel TT)))
	(if X 
		(progn
			(setq XX (entget X))
			(cond
				((equal ENT1 XX)(entry2 "\nEntity selected is first text - try again."))
				((not (eq (cdr (assoc 0 XX)) "TEXT"))(entry2 "\nEntity selected is not standard text - try again."))
			)
		)
		(progn
			(princ "\nSecond line not selected.")
			(setq FLG(entsel "\nPress [ENTER] to create new line or select an entity to exit."))
			(if FLG
				(exit)
				(progn
					(setq XX (list))
					(foreach cluster (reverse ENT1)
						(if(not(member (car cluster) '(-1 5)))
							(setq XX(cons cluster XX))
						)
					)
					(setq XX(subst '(1 . "")(assoc 1 XX)XX))
					(setq PNT10 (cdr(assoc 10 ENT1)))
					(setq Y10 (cadr PNT10))
					(setq PNT10 (subst (- Y10 (* (cdr(assoc 40 ENT1)) (/ 5.0 3))) Y10 PNT10))
					(setq XX (subst (cons 10 PNT10)(assoc 10 XX)XX))
					(if(not(equal (setq PNT11 (cdr(assoc 11 ENT1))) '(0.0 0.0 0.0)))
						(progn
							(setq Y11 (cadr PNT11))
							(setq PNT11 (subst (- Y11 (* (cdr(assoc 40 ENT1)) (/ 5.0 3))) Y11 PNT11))
							(setq XX (subst (cons 11 PNT11)(assoc 11 XX)XX))
						)
					)
					(entmake XX)
					(setq XX(entget (entlast))) 
				)
			)
		)
	)
	XX
)
;----------------------------------------------------------------------------
(defun topper ()                    ; Common routines to wordup and worddown
  (setq TXT1 (cdr (assoc 1 ENT1))   SL1 (strlen TXT1)
        TXT2 (cdr (assoc 1 ENT2))   SL2 (strlen TXT2)  )

  (setq TEMP 0)                     ;------Find first word in second line.
  (while TEMP
       (setq TEMP (+ TEMP 1))
       (if (/= " " (substr TXT2 TEMP 1)) (setq L2_1st TEMP  TEMP nil))
       (if (> TEMP SL2)                  (setq L2_1st 0     TEMP nil))
  )                     ;------End while

  (while (= " " (substr TXT1 SL1 1));------Delete spaces at end of first line.
       (setq TXT1 (substr TXT1 1 (- SL1 1))  SL1 (strlen TXT1)   )  )
)
;----------------------------------------------------------------------------
(defun WORDup ()                    ; Moves first word up
  (topper)              ; gosub common routines
  (setq TEMP L2_1st  L2_2nd nil)    ;------Find second word in bottom line.
  (while TEMP
       (setq TEMP (+ TEMP 1))
       (if (= " "  (substr TXT2 TEMP 1)) (setq L2_2nd TEMP       ))
       (if (= "  " (substr TXT2 TEMP 2)) (setq L2_2nd (+ 1 TEMP) ))
       (if (> TEMP SL2)                  (setq L2_2nd (+ SL2 1)  ))
       (if L2_2nd (setq TEMP nil))
  )

  (setq TXT1 (strcat TXT1   " "
                     (substr TXT2 L2_1st       (- L2_2nd L2_1st))  ))
  (setq TXT2 (strcat (substr TXT2 1            (- L2_1st 1     ))
                     (substr TXT2 (+ L2_2nd 1) SL2              )  ))
)
;----------------------------------------------------------------------------
(defun WORDdown ()                  ; Moves last word down
  (topper)              ; Gosub common routines
  (setq TEMP SL1)                   ;------Find last word in top line.
  (if(> SL1 1)
  	(while TEMP
   	(setq TEMP (- TEMP 1))
      (if (= " " (substr TXT1 TEMP 1)) (setq L1_last TEMP  TEMP nil))
      (if (= TEMP 1)                   (setq L1_last 0     TEMP nil))
  	)
  	(setq l1_last 0)
  )
  (setq TXT2 (strcat (substr TXT2 1 (- L2_1st 1)    )
                     (substr TXT1 (+ 1 L1_last) SL1 ) 
                     " "
                     (substr TXT2 L2_1st SL2        )  ))
  (if (= 0 L1_last) (setq TXT1 "")  (setq TXT1 (substr TXT1 1 (- L1_last 1) ))  )
)

;----------------------------------------------------------------------------
(defun WORDMOVE (/ olderr ENT1 ENT2 TEMP TXT1 TXT2 SL1 SL2 L2_1st L1_last L2_2nd)
  (setq olderr *error*   *error* chgterr)
  (setq ENT1 (entry1 "\nPick source text: "))     ; Pick text and test
  (while ENT1
	 (command "undo" "be")
    (redraw (cdar ENT1) 3)
    (setq ENT2 (entry2 "\nPick destination text: ")); Pick text and test
    (redraw (cdar ENT1) 4)
    (if (< (car (cddr (assoc 10 ENT1) )) (car (cddr (assoc 10 ENT2))))
       (progn                       ;------Bottom line was selected first
           (setq TEMP ENT1   ENT1 ENT2   ENT2 TEMP)
           (wordup) 
		 )
       (worddown)                   ;------Top line was selected first
     )                     ; Puts text in order and gosub wordup or worddown	
    (if (read TXT1)
      (entmod (subst (cons 1 TXT1) (assoc 1 ENT1) ENT1))
      (entdel (CDR(ASSOC -1 ENT1)))
    )
    (if (read TXT2)
      (entmod (subst (cons 1 TXT2) (assoc 1 ENT2) ENT2))
      (entdel (CDR(ASSOC -1 ENT2)))
    )     ;------Modify the TEXT entities
	 (command "undo" "be")
    (setq ENT1 (entry1 "\nPick source text or [ENTER] to exit: "))     ; Pick text and test
	)
  (setq *error* olderr)          ;------Restore old *error* handler
  (princ)
)
;;(defun c:WM () (C:WORDmove))