;; tnt interface for GNU Emacs.
;;
;; Author:	Chris Maio
;; Modified:	Don Hopkins
;; Last edit:	Apr 10 1991

;; An alist containing the valid tnt options.
(setq command-switch-alist
      (append '(("-origin" . tnt-option-window-location)
		("-xy" . tnt-option-window-location)
		("-dimensions" . tnt-option-window-size)
		("-size" . tnt-option-window-size)
		("-label" . tnt-option-label)
		("-fl" . tnt-option-label))
	      command-switch-alist))

(defun tnt-option-arg (type)
  (let ((result (car command-line-args-left)))
    (setq command-line-args-left (cdr command-line-args-left))
    (cond ((eq type 'string) result)
	  ((eq type 'int) (string-to-int result)))))

(defun tnt-option-window-location (ignored)
  (tnt-set-window-location (tnt-option-arg 'int) (tnt-option-arg 'int)))

(defun tnt-option-window-size (rest)
  (tnt-set-window-size (tnt-option-arg 'int) (tnt-option-arg 'int)))

(defun tnt-option-label (rest)
  (tnt-set-label (tnt-option-arg 'string)))

(defun tnt-set-i&d-line-ok (bool)
  "Specify whether it's ok to use hardware insert- and delete-line functions.
Disable this if you don't like what happens in partially-obscured windows.
See \"tnt-set-scroll-region-ok.\""
  (interactive (list (y-or-n-p "Use insert- and delete-line functions? ")))
  (tnt-set-option 1 bool))

(defun tnt-set-i&d-char-ok (bool)
  "Specify whether it's ok to use rasterops to move characters on the display.
This function doesn't really work."
  (interactive (list (y-or-n-p "Use insert- and delete-char functions? ")))
  (tnt-set-option 2 bool))

(defun tnt-set-scroll-region-ok (bool)
  "Specify whether it's ok to use the display hardware's scrolling function.
Hardware scrolling looks better but currently causes odd behavior in
partially-obscured windows.  See \"tnt-set-i&d-line-ok.\""
  (interactive (list (y-or-n-p "Use scroll regions? ")))
  (tnt-set-option 3 bool))

(defun tnt-set-window-retained (retain)
  "Specify whether or not the tnt window should be retained.
Retained windows behave better in some circumstances, but worse in others;
among other things, scrolling and line-insert/delete functions may be
noticably slower in obscured, retained windows."
  (interactive (list (y-or-n-p "Retain this window? ")))
  (tnt-set-option 4 retain))

(defun tnt-set-input-policy (stuff)
  "If ARG is non-nil, \"stuff\" text rather than using insert-string.
When copying \"selections\" into the Emacs tnt window, \"stuffing\" text
simulates typein, while insertion is similar to yanking text."
  (interactive
   (list
    (y-or-n-p "tnt Selections should \"Stuff\" rather than \"Insert\"? ")))
  (tnt-set-option 5 stuff))

;; tnt input handler indicates event info available with C-x NUL
(define-key global-map "\C-x\C-@" 'tnt-handle-event)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Event Handling

;; tnt-next-event returns one of the following:
;;
;;	(0 string)			; insert string
;;	(1 string)			; execute command
;;	(2 name action x y)		; track

(setq tnt-event-types [insert command track])

(setq tnt-event-names [
;	0		1		2		3
	"point"		"adjust"	"menu"		"selection"
;	4		5		6		7
	"drag"		"function"	"help"		"scroll"
])

(setq tnt-event-actions [
;	0		1		2		3
	"down"		"move"		"up"		"cancel"
;	4		5		6		7
	"timer"		"rest"		"foo"		"bar"
;	8		9		10		11
	"start"		"adjust"	"stop"		"context"
;	12		13		14		15
	"identify"	"request"	"reception"	"deselect"
;	16		17		18		19
	"delete"	"contents"	"fold"		"spindle"
;	20		21		22		23
	"tweak"		"twiddle"	"frob"		"spaz" 
;	24		25		26		27
	"north"		"northeast"	"east"		"southeast"
;	28		29		30		31
	"south"		"southwest"	"west"		"northwest" 
])

(setq track:event nil)
(setq track:window nil)
(setq track:edges nil)
(setq track:x 0)
(setq track:y 0)

(setq SelRegistered nil)
(setq SelRank 'PrimarySelection)
(setq SelLevel 0)
(setq SelPin nil)
(setq SelPoint nil)
(setq SelPinMarker (make-marker))
(setq SelPointMarker (make-marker))
(setq SelPointOld (make-marker))
(setq SelPointLast (make-marker))
(setq SelWinOld nil)
(setq SelLineWidths nil)
(setq SelModeLine nil)

(defun tnt-handle-event ()
  "Handle a tnt input event.  Don't call this function."
  (interactive)
  (let (elist type)
   (while (setq track:event (tnt-next-event))
     (setq type (aref tnt-event-types (car track:event)))
     (cond
      ((eq type 'track)
       (let*
	((name (aref tnt-event-names (nth 1 track:event)))
	 (action (aref tnt-event-actions (nth 2 track:event)))
	 (x (nth 3 track:event))
	 (y (nth 4 track:event)))
	(funcall (intern (concat "track:" name "-" action))
		 x y)))
      ((eq type 'command)		; command execution request
       (eval (car (read-from-string (nth 1 track:event)))))
      ((eq type 'insert)		; string insertion request
       (push-mark)
       (if buffer-read-only
	 (error "Read only!")
	 (insert-string (nth 1 track:event))))))))

(defun tnt-event-window (x y)
  (and (>= x 0) (>= y 0)
       (< x (screen-width))
       (< y (screen-height))
       (car (window-at x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Track Event Handlers

(defun track:point-down (x y)
)

(defun track:point-move (x y)
)

(defun track:point-timer (x y)
)

(defun track:point-up (x y)
)

(defun track:point-cancel (x y)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Selection Event Handlers

; save original insertion point in SelectionStart. 
; only set insertion point when asked to in SelectionStop.
; try to make secondary cut not move insertion point, and paste into it

(defun track:selection-identify (x y)
  (setq SelModeLine (tnt-coordinates-in-modeline-p x y))
  (let ((selected-p (or SelModeLine
			(tnt-in-selection-p x y)))
	 filename)
    (save-excursion
      (tnt-move-to x y)
      (if SelModeLine
	(progn
	  (setq filename (or (buffer-file-name (current-buffer))
			     default-directory))
	  (set-buffer "*tnt-selection*")
	  (erase-buffer)
	  (insert-string filename))
        (progn
	  (setq track:window (selected-window))
	  (setq track:edges (window-edges track:window))
	  (tnt-send-track-region (point)))))
    (tnt-send-ps
      (concat
        ;; {/SelectedObject /UnselectedObject /Background}
        (if selected-p "0 " "1 ") 
        (if buffer-read-only "true" "false") " SSC "
        (if SelModeLine "/Graphic Meet" "/Text Meet")))))

(defun track:selection-context (x y)
)

; Before the selection-start event, we're sent a command in the form:
;   (setq SelRank 'PrimarySelection|SecondarySelection
;         SelLevel 0|1|2|3|4
;	  SelPin 'LowEnd|HighEnd|NearEnd|FarEnd|AtPoint)

(defun track:selection-start (x y)
  (setq SelWinOld (selected-window))
  (setq SelPointOld (point))
  (let ()
    (select-window (car (window-at x y)))
    (setq SelPointLast (point))
    (tnt-move-to x y)
    (if (not (eq (marker-buffer SelPinMarker) (current-buffer)))
      (set-marker SelPinMarker (point) (current-buffer)))
    (setq SelPoint (point))
    (setq track:window (tnt-event-window x y))
    (setq track:edges (window-edges track:window)) ; (left top right bottom)
    (setq SelRegistered t)

    (if (eq SelPin 'FarEnd)
      (if (< (abs (- SelPoint SelPinMarker))
	     (abs (- SelPoint SelPointLast)))
	  (set-marker SelPinMarker SelPointOld (current-buffer)))
      (set-marker SelPinMarker SelPoint (current-buffer)))
    (set-marker SelPointMarker SelPoint (current-buffer))
;    (tnt-adjust-selection-level SelLevel)
  (tnt-send-track-region SelPinMarker)
))

(defun track:selection-adjust (x y)
  (if (inside-window-edges x y track:edges)
    (progn
      (tnt-move-to x y)
      (set-marker SelPointMarker (point) (current-buffer))
;      (tnt-adjust-selection-level SelLevel)
; XXX: send new insertionpoint
)))

(defun track:selection-timer (x y)
  (tnt-auto-scroll x y)
  (tnt-send-track-region SelPinMarker)
  (tnt-send-ps "/SendTimer? unpromote"))

(defun track:selection-stop (x y)
  (if (eq (tnt-event-window x y) track:window)
    (tnt-move-to x y))
  (push-mark)
  (goto-char SelPinMarker)
  (exchange-dot-and-mark)
  (set-marker SelPointMarker (point) (current-buffer))
;  (tnt-adjust-selection-level SelLevel)
; XXX: send new insertionpoint
  (tnt-erase-selection)
  (append-to-buffer
    "*tnt-selection*" SelPointMarker SelPinMarker)
  (if (not (eq SelRank 'PrimarySelection))
    (prognnates-in-modeline-p x y)
    (select-window (tnt-event-window x y))
    (progn
      (tnt-move-to x y)
      (if (not buffer-read-only)
	(if (tnt-in-selection-p x y)
	  (tnt-kill-selection))))))

(defun track:selection-deselect (x y)
  (setq SelRegistered nil)
)

(defun track:selection-delete (x y)
;  (tnt-send-ps
;    (if (tnt-kill-selection) "true Meet" "false Meet"))
  (if (not SelModeLine)
    (tnt-kill-selection)))

(defun track:selection-contents (x y)
  (save-excursion
    (set-buffer "*tnt-selection*")
    (tnt-send-string (buffer-string))
    (tnt-send-ps "Meet")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Other Handlers

(defun track:help-down (x y)
  (tnt-move-to x y)
  (describe-mode)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Tracking Utilities

(defun abs (n)
  (if (< n 0) (- n) n))

(defun tnt-move-to (x y)
  "Move the cursor to X Y in the appropriate window."
  (let ((winxy (window-at x y)))
    (and winxy
	 (select-window (car winxy))
	 (move-to-window-line (nth 2 winxy))
	 (move-to-column (+ (current-column) (nth 1 winxy))))))

(defun tnt-coordinates-in-modeline-p (x y)
  "Return the window whose modeline occupies screen COLUMN and ROW, or NIL."
  (let* ((winxy (window-at x y))
	 (window (car winxy))
	 (wy (nth 2 winxy)))
    (and window
; test for right edge ??
	 (eq (- (window-height window) 1) wy)
	 window)))

(defun inside-window-edges (x y edges)
  (and
    (>= x (nth 0 edges))
    (< x (nth 2 edges))
    (>= y (nth 1 edges))
    (< y (- (nth 3 edges) 1))))

(defun tnt-send-track-region (pinmark)
  (let* ((width (window-width track:window))
	 (height (window-height track:window))
	 (line 0)
	 (done nil)
	 (pin '(0 0))
	 line-start line-end line-width
	 col
	 )
	(setq SelLineWidths nil)
	(save-excursion
	 (setq pin (if (< pinmark (window-start))
		       '(0 0)
		       nil))
	 (while (< line (- height 1))
	   (setq SelLineWidths
	     (append SelLineWidths
	       (if done '(0)
		 (progn
		   (move-to-window-line line)
		   (setq line-start (point))
		   (setq col (current-column))
		   (move-to-column (* (- width 1)
				      (+ 1 (/ (current-column)
					      (- width 1)))))
		   (setq line-end (point))
		   (setq line-width (- (current-column) col))
		   (or pin
		       (> pinmark line-end)
		       (save-excursion
			 (goto-char pinmark)
			 (setq pin
			       (if (and (not truncate-lines)
					(= (current-column) (- width 1))
					(not (looking-at "\n")))
				 (list (+ line 1) 0)
				 (list line (- (current-column) col))))))
		   (if (looking-at "\n")
		       (setq line-width (format "%s.5" line-width)))
		   (if (eobp) (setq done t))
		   (list line-width)))))
	   (setq line (+ line 1)))
	 (if (null pin)
	     (setq pin (list (- line 1)
			     (nth (- line 1) SelLineWidths))))
	 (set-buffer (get-buffer-create "*tnt-track-region*"))
	 (erase-buffer)
	 (mapcar '(lambda (n) (insert-string n " "))
		 (append
		    '("[")
		    SelLineWidths
		    '("]SLW")
		    track:edges pin
		    '("STR")))
	 (tnt-send-ps (buffer-string)))))

(defun tnt-auto-scroll (x y)
  (let ((scroll-step
; XXX: scroll proportionaly to distance above top or bottom of window
	   (max 1 (+ 1 (/ (- x (nth 0 track:edges)) 4)))))
    (select-window track:window)

    (if (<= y (nth 1 track:edges))
      (progn
	(condition-case ()
	    (scroll-down scroll-step)
	  (error (message "Beginning of buffer!"))))
      (if (>= y (- (nth 3 track:edges) 2))
	(progn
	  (condition-case ()
	      (scroll-up scroll-step)
	    (error (message "End of buffer!"))))
	(progn
	  (message "You've gone over the edge!"))))))

(defun tnt-adjust-selection-level (level)
; XXX: fix this
  (let ((point-at-beginning (> SelPinMarker (point))))
    (if point-at-beginning (exchange-point-and-mark))
    (cond
      ((eq level 0))
      ((eq level 1))
      ((eq level 2)
       (if (not (looking-at "\\b"))
	 (forward-word 1))
       (exchange-point-and-mark)
       (if (not (looking-at "\\b"))
	 (backward-word 1)))
      ((eq level 3)
       (if (not (looking-at "$\\|\\'"))
	 (progn
	   (end-of-line)
	   (or (eobp) (forward-char 1))))
       (exchange-point-and-mark)
       (if (not (looking-at "^"))
	 (beginning-of-line)))
      ((eq level 4)
       (mark-whole-buffer)))
    (if (and point-at-beginning
	     (> (mark) (point)))
      (exchange-point-and-mark))))

(defun tnt-kill-selection ()
  (save-excursion
    (set-buffer (marker-buffer SelPinMarker))
    (if (not buffer-read-only)
      (progn
	(kill-region SelPinMarker SelPointMarker)
	t))))

(defun tnt-in-selection-p (x y)
  (let ((window (tnt-event-window x y)))
    (and SelRegistered
	 (eq window track:window)
;        (/= (- SelPinMarker SelPointMarker) 0)
	 (save-excursion
	   (save-window-excursion
	     (tnt-move-to x y)
	     (and (<= (min SelPinMarker SelPointMarker)
		      (point))
		  (< (point)
		     (max SelPinMarker SelPointMarker))))))))

(defun tnt-erase-selection ()
  (save-excursion
    (set-buffer (get-buffer-create "*tnt-selection*"))
    (erase-buffer)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Setup

(if (eq window-system 'tnt)
    (progn
      (setq suspend-hook
	    '(lambda nil
	       (error "You can't suspend Emacs in a tnt window.")))
      (if (boundp 'window-system-version)
	  (setq window-setup-hook 'tnt-map-window)
	(setq term-setup-hook 'tnt-map-window))
      (run-hooks 'tnt-setup-hook)))