
(DEF-DE-COMMAND (DE-CLEAR-EOL #{{#/}}/K) (STREAM &OPTIONAL IGNORE)
  (DE-DELETE-STRING STREAM (TYPEIN-POINTER) (DE-SEARCH-FORWARD-NEWLINE (TYPEIN-POINTER))))


;; Word Commands

(DEFUN DE-ALPHABETIC? (CHAR)
  (SETQ CHAR (CHAR-UPCASE CHAR))
  (AND ({{#/}} CHAR #/A) ({{#/}} CHAR #/Z)))

;; Returns the position of the first (non) alphabetic character
;; in the buffer.  If no alphabetic characters between current
;; typein position and end of line, return nil.

(DEFUN DE-SEARCH-FORWARD-ALPHABETIC (POS)
  (DO ((FILL-POINTER (FILL-POINTER))
       (I POS (1+ I)))
      ((= I FILL-POINTER) NIL)
    (IF (DE-ALPHABETIC? (AREF ES-BUFFER I)) (RETURN I))))

(DEFUN DE-SEARCH-FORWARD-NON-ALPHABETIC (POS)
  (DO ((FILL-POINTER (FILL-POINTER))
       (I POS (1+ I)))
      ((= I FILL-POINTER) NIL)
    (IF (NOT (DE-ALPHABETIC? (AREF ES-BUFFER I))) (RETURN I))))

(DEFUN DE-SEARCH-BACKWARD-ALPHABETIC (POS)
  (DO ((I POS (1- I)))
      ((= I -1) NIL)
    (IF (DE-ALPHABETIC? (AREF ES-BUFFER I)) (RETURN I))))

(DEFUN DE-SEARCH-BACKWARD-NON-ALPHABETIC (POS)
  (DO ((I POS (1- I)))
      ((= I -1) NIL)
    (IF (NOT (DE-ALPHABETIC? (AREF ES-BUFFER I))) (RETURN I))))

;; Search for a point N words away and return that point.
;; If on an alphabetic character, skip to the first non alphabetic one.
;; If on a non-alphabetic, skip over non-alphabetics and then over alphabetics,
;; If no alphabetics follow the non-alphabetics, then don't move at all.

(DEFUN DE-SEARCH-FORWARD-WORD (N &AUX (POS (TYPEIN-POINTER)) SEARCH-POS)
  (DO ((I 0 (1+ I)))
      ((= I N) POS)
    (COND ((DE-ALPHABETIC? (AREF ES-BUFFER POS))
	   (SETQ POS (DE-SEARCH-FORWARD-NON-ALPHABETIC POS)))
	  (T (SETQ SEARCH-POS (DE-SEARCH-FORWARD-ALPHABETIC POS))
	     (IF (NOT SEARCH-POS) (RETURN POS))
	     (SETQ POS (DE-SEARCH-FORWARD-NON-ALPHABETIC SEARCH-POS))))
    ;;If within a word and can't find whitespace, leave at right end.
    (IF (NOT POS) (RETURN (FILL-POINTER)))))

;; Search for a point N words back and return that point.
;; If on an alphabetic character, skip to the character just following the
;; first non-alphabetic one.  If on a non-alphabetic, skip over non-alphabetics
;; and then over alphabetics.  If no alphabetics after non-alphabetics, then
;; don't move at all.  Treat cursor on first character of a word as a special case.

(DEFUN DE-SEARCH-BACKWARD-WORD (N &AUX (POS (TYPEIN-POINTER)) SEARCH-POS)
  (DO ((I 0 (1+ I)))
      ((= I N) POS)
    (COND
      ;;At beginning of line -- punt
      ((= POS 0) (RETURN 0))
      ;;Inside a word but not at the beginning of a word.
      ((AND (DE-ALPHABETIC? (AREF ES-BUFFER POS))
	    (DE-ALPHABETIC? (AREF ES-BUFFER (1- POS))))
       (SETQ POS (DE-SEARCH-BACKWARD-NON-ALPHABETIC POS)))
      ;;Within whitespace or at beginning of a word.
      (T (SETQ SEARCH-POS (IF (DE-ALPHABETIC? (AREF ES-BUFFER POS))
		       (1- POS) POS))
	 (SETQ SEARCH-POS (DE-SEARCH-BACKWARD-ALPHABETIC SEARCH-POS))
	 (IF (NOT SEARCH-POS) (RETURN POS))
	 (SETQ POS (DE-SEARCH-BACKWARD-NON-ALPHABETIC SEARCH-POS))))
    ;;If within a word and can't find whitespace, leave at left end.
    (IF (NOT POS) (RETURN 0))
    ;;Leave cursor on first character of the word
    (INCREMENT POS)
    ))

(DEF-DE-COMMAND (DE-FORWARD-WORD #{{#/}}/F) (STREAM &OPTIONAL (N 1))
  (DE-SET-POSITION STREAM (DE-SEARCH-FORWARD-WORD N)))

(DEF-DE-COMMAND (DE-BACKWARD-WORD #{{#/}}/B) (STREAM &OPTIONAL (N 1))
  (DE-SET-POSITION STREAM (DE-SEARCH-BACKWARD-WORD N)))

(DEF-DE-COMMAND (DE-DELETE-WORD #{{#/}}/D) (STREAM &OPTIONAL (N 1))
  (DE-DELETE-STRING STREAM (TYPEIN-POINTER) (DE-SEARCH-FORWARD-WORD N)))

(DEF-DE-COMMAND (DE-RUBOUT-WORD #{{#/}}\RUBOUT) (STREAM &OPTIONAL (N 1))
  (DE-DELETE-STRING STREAM (DE-SEARCH-BACKWARD-WORD N) (TYPEIN-POINTER)))

(DEF-DE-COMMAND (DE-TWIDDLE-CHARS #{{#/}}/T) (STREAM &OPTIONAL IGNORE &AUX DELETE-POINTER STRING)
  (SETQ DELETE-POINTER (TYPEIN-POINTER))
  ;; At end of line, go back two chars; in middle of line, one; at beginning, none.
  (DECREMENT DELETE-POINTER (COND ((= DELETE-POINTER 0) 0)
				  ((= DELETE-POINTER (FILL-POINTER)) 2)
				  (T 1)))
  (SETQ STRING (SUBSTRING ES-BUFFER DELETE-POINTER (+ DELETE-POINTER 2)))
  (DE-DELETE-STRING STREAM DELETE-POINTER (+ DELETE-POINTER 2))
