;; 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 (typein)
  "If ARG is non-nil, \"type in\" text rather than using insert-string.
When copying \"selections\" into the Emacs tnt window, \"type in\" text
goes through the keymap, while insertion is similar to yanking text."
  (interactive
   (list
    (y-or-n-p "Selections should \"type in\" rather than \"insert\"? ")))
  (tnt-set-option 5 typein))

;; 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"		"left"		"right"
;	8		9		10		11
	"start"		"adjust"	"stop"		"context"
;	12		13		14		15
	"identify"	"request"	"reception"	"deselect"
;	16		17		18		19
	"delete"	"contents"	"undo"		"find"
;	20		21		22		23
	"again"		"help"		"frob"		"spaz" 
;	24		25		26		27
	"north"		"northeast"	"east"		"southeast"
;	28		29		30		31
	"south"		"southwest"	"west"		"northwest" 
;	32		33		34		35
	"home"		"end"		"pgup"		"pgdn"
;	36		37		38		39
	"here"		"foo"		"bar"		"baz"
;	40		41		42		43
	"f1"		"f2"		"f3"		"f4"
;	44		45		46		47
	"f5"		"f6"		"f7"		"f8"
;	48		49		50		51
	"f9"		"f10"		"f11"		"f12"
])

(setq tnt-selection-ranks
  [PrimarySelection SecondarySelection])

(setq tnt-selection-pins
  [LowEnd HighEnd NearEnd FarEnd AtPoint NoPin])

(setq tnt-selection-requests
  [UnknownRequest ContentsAscii SelectionObjsize DeleteContents DragText])

(setq tnt-reception-names
  [MoveToLocation CopyToLocation MoveToCaret CopyToCaret])

(setq TrackEvent nil)
(setq TrackSaveWindow nil)
(setq TrackSavePoint nil)
(setq TrackInModeLine nil)
(setq TrackInSelection nil)
(setq TrackReception nil)

(setq SelRank 'PrimarySelection)
(set-marker (put 'PrimarySelection 'Point (make-marker)) 0 (current-buffer))
(set-marker (put 'PrimarySelection 'Mark (make-marker)) 0 (current-buffer))
(set-marker (put 'SecondarySelection 'Point (make-marker)) 0 (current-buffer))
(set-marker (put 'SecondarySelection 'Mark (make-marker)) 0 (current-buffer))

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

(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)
  (message "Point Down %d %d" x y))

(defun track:point-move (x y)
  (message "Point Move %d %d" x y))

(defun track:point-timer (x y)
  (message "Point Timer %d %d" x y))

(defun track:point-up (x y)
  (message "Point Up %d %d" x y))

(defun track:point-cancel (x y)
  (message "Point Cancel %d %d" x y))

(defun track:adjust-down (x y)
  (message "Adjust Down %d %d" x y))

(defun track:adjust-move (x y)
  (message "Adjust Move %d %d" x y))

(defun track:adjust-timer (x y)
  (message "Adjust Timer %d %d" x y))

(defun track:adjust-up (x y)
  (message "Adjust Up %d %d" x y))

(defun track:adjust-cancel (x y)
  (message "Adjust Cancel %d %d" x y))

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

(defun track:selection-identify (x y)
  (setq TrackInModeLine (tnt-coordinates-in-modeline-p x y))
  (setq TrackInSelection (and (not TrackInModeLine)
			      (tnt-coordinates-in-selection-p x y)))
  (if TrackInModeLine
    (tnt-send-ps "1 SSC /Graphic Meet")
    (tnt-send-ps (if TrackInSelection
		   "0 SSC /Text Meet"
		   "1 SSC /Text Meet"))))

(defun track:selection-context (x y)
  ; doesn't get called -- handled in server
)

; Before the selection-start event, we're sent a command in the form:
;   (SelStart rank level pin)

(defun SelStart (rank level pin)
  (setq SelRank (aref tnt-selection-ranks rank))
  (put SelRank 'Level level)
  (put SelRank 'PinName (aref tnt-selection-pins pin)))

(defun track:selection-start (x y)
  (let ((p (get SelRank 'Point))
	(m (get SelRank 'Mark)))

    (setq TrackSaveWindow (selected-window))
    (setq TrackSavePoint (point))

    (select-window (put SelRank 'Window (car (window-at x y))))
    (tnt-move-to x y)

    (if (or TrackInModeLine
	    (not (eq (marker-buffer m)
		     (current-buffer))))
      (progn
	(set-marker m (point) (current-buffer))
	(set-marker p (point) (current-buffer))))

    (if (not TrackInModeLine)
      (progn
	(put SelRank 'Edges (window-edges (get SelRank 'Window)))

	(if (eq (get SelRank 'PinName) 'FarEnd)
	  (if (>= (abs (- (point) p))
		  (abs (- (point) m)))
	    (progn
	      (set-marker m p)
	      (message "Exchanged point and mark.")))
	  (set-marker m (point)))
	(set-marker p (point))

	(put SelRank 'Registered t)
	(tnt-send-track-lines)
	(tnt-send-track-region)))))

(defun track:selection-adjust (x y)
  (if (not TrackInModeLine)
    (progn
      (if (tnt-inside-window-edges x y (get SelRank 'Edges))
	(tnt-move-to x y)
	(tnt-move-to-window-edge x y (get SelRank 'Edges)))
      (set-marker (get SelRank 'Point) (point))
      (tnt-send-track-region))))

(defun track:selection-timer (x y)
  (if (not TrackInModeLine)
    (progn
      (tnt-auto-scroll x y)
      (tnt-send-track-lines)
      (tnt-send-track-region)
      (tnt-send-ps "/SendTimer? unpromote"))))

(defun track:selection-stop (x y)
  (if (not TrackInModeLine)
    (progn
      (if (tnt-inside-window-edges x y (get SelRank 'Edges))
	(tnt-move-to x y)
	(tnt-move-to-window-edge x y (get SelRank 'Edges)))
      (set-marker (get SelRank 'Point) (point))
      (put SelRank 'Text
	   (buffer-substring (get SelRank 'Point)
			     (get SelRank 'Mark)))
      (if (not (eq SelRank 'PrimarySelection)) ; 'PinName ???
	  (progn
	    (select-window TrackSaveWindow)
	    (goto-char TrackSavePoint))))))

(defun track:selection-cancel (x y)
  (message "Selection Cancel!")
)

(defun track:selection-deselect (ranknum y)
  (put (aref tnt-selection-ranks ranknum) 'Registered nil)
  (message "Deselected %s" (aref tnt-selection-ranks ranknum)))

(defun track:selection-request (ranknum requestnum)
  (let ((rank (aref tnt-selection-ranks ranknum))
	(request (aref tnt-selection-requests requestnum)))
    (message "Selection request %s %s" rank request)
    (cond
     ((eq request 'UnknownRequest)
      (tnt-send-ps "/UnknownRequest"))
     ((eq request 'ContentsAscii)
      (tnt-send-string (or (get rank 'Text) "")))
     ((eq request 'SelectionObjsize)
      (tnt-send-number (length (get rank 'Text))))
     ((eq request 'DeleteContents)
      (let ((p (get rank 'Point))
	    (m (get rank 'Mark)))
	(save-excursion
	  (switch-to-buffer (marker-buffer p))
	  (if buffer-read-only
	    (progn
	      (tnt-send-boolean t)
	      (message "Read-only selection not deleted."))
	    (progn
	      (kill-region p m)
	      (put rank 'Text nil)
	      (tnt-send-boolean t))))))
     ((eq request 'DragText)
      (let ((text (or (get rank 'Text) "")))
	(tnt-send-string
	 (if (<= (length text) 16)
	   text
	   (concat (substring text 0 8) "..." (substring text -5))))))
     (t
      (tnt-send-ps "/UnknownRequest")
     ))
    (tnt-send-ps "Meet")))

(defun SelRec (where)
  (setq TrackReception (aref tnt-reception-names where))
;  (message "SELREC %s" TrackReception)
;  (sit-for 3)
)

(defun track:selection-reception (x y)
    (let* (;(window (car (window-at x y)))
	   buffer
;	   (buffer (save-excursion
;		     (and window (select-window window))
;		     (current-buffer)))
	   read-only
;	   (read-only (save-excursion
;		 (set-buffer buffer)
;		 buffer-read-only))
	   (modeline-p (tnt-coordinates-in-modeline-p x y)))
      (save-window-excursion
	(tnt-move-to x y)
	(setq buffer (current-buffer))
	(setq loc (point))
	(setq read-only buffer-read-only)
      )
;   (message "track:selection-reception x %d y %d window %s buffer %s ro %s ml %s"
;	    x y window buffer read-only modeline-p)
;   (sit-for 1)
    (if (and modeline-p (not read-only))
      (progn
;	(and window (select-window window))
	(message "Modeline reception: %s" TrackReception buffer)
	(tnt-send-ps "/ModeLine Meet"))
      (if read-only
	(progn
	  (message "Reception target %s is read-only!" buffer)
	  (tnt-send-ps "/ReadOnly Meet"))
	(progn
	  (if (memq TrackReception '(CopyToLocation MoveToLocation))
	    (progn (tnt-move-to x y)
;		   (message "XXXXXXX")
;		   (sit-for 3)
	  ))
;	  (message "Text reception: %s %s" TrackReception buffer)
;	  (sit-for 3)
	  (tnt-send-ps "/Text Meet"))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; function key handlers

(defun track:function-help (x y)
  (tnt-move-to x y)
  (call-interactively 'describe-key))

(defun track:function-undo (x y)
  (undo))

(defun track:function-find (x y)
  (isearch-forward))

(defun track:function-again (x y)
  (universal-argument))

(defun track:function-stop (x y)
  (message "Stop!")
  (beep))

(defun track:function-up (x y)
  (previous-line 1))

(defun track:function-down (x y)
  (next-line 1))

(defun track:function-right (x y)
  (forward-char))

(defun track:function-left (x y)
  (backward-char))

(defun track:function-home (x y)
  (beginning-of-buffer))

(defun track:function-end (x y)
  (end-of-buffer))

(defun track:function-pgup (x y)
  (scroll-down))

(defun track:function-pgdn (x y)
  (scroll-up))

(defun track:function-here (x y)
  (recenter))

(defun track:function-f1 (x y))
(defun track:function-f2 (x y))
(defun track:function-f3 (x y))
(defun track:function-f4 (x y))
(defun track:function-f5 (x y))
(defun track:function-f6 (x y))
(defun track:function-f7 (x y))
(defun track:function-f8 (x y))
(defun track:function-f9 (x y))
(defun track:function-f10 (x y))
(defun track:function-f11 (x y))
(defun track:function-f12 (x y))

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

(defun tnt-move-to-window-edge (x y edges)
  (if (< y (top-window-edge edges))
    (tnt-move-to (left-window-edge edges)
		 (top-window-edge edges))
    (tnt-move-to (- (right-window-edge edges) 1)
		 (- (bottom-window-edge edges) 2))))

(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
	 (eq (- (window-height window) 1) wy)
	 window)))

(defun tnt-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-lines ()
  (let* ((edges (get SelRank 'Edges))
	 (right (- (right-window-edge edges) 1))
	 (top (top-window-edge edges))
	 (bottom (- (bottom-window-edge edges) 2))
	 (window-width (- right (left-window-edge edges)))
	 widths column line-width)
    (save-excursion
      (while (>= bottom top)
	(move-to-window-line bottom)
	(if (eobp)
	  (setq widths
		(cons 0 widths))
	  (progn
	    (setq line-start (point))
	    (setq column (current-column))
	    (move-to-column (* window-width
			       (+ 1 (/ (current-column)
				       window-width))))
	    (setq line-end (point))
	    (setq widths
		  (cons (+ (- (current-column) column)
			   (if (looking-at "\n") 1 0))
			widths))))
	(setq bottom (- bottom 1))))
    (mapcar 'tnt-send-number edges)
    (tnt-send-string (concat widths))
    (tnt-send-ps "SLW")))

(defun tnt-send-track-region ()
  (let* ((point  (get SelRank 'Point))
	 (mark (get SelRank 'Mark))
	 (edges (get SelRank 'Edges))
	 (window (get SelRank 'Window))
	 point-row point-col mark-row mark-col )
    (save-excursion
      (cond
        ((< mark (window-start window))
	 (setq mark-row 0 mark-col 0))
	((pos-visible-in-window-p mark window)
	 (progn
	   (goto-char mark)
	   (sit-for 0)
	   (setq mark-row (window-point-row window)
		 mark-col (window-point-column window))))
	(t (setq mark-row (- (bottom-window-edge edges) 2)
		 mark-col (- (right-window-edge edges) 1))))
      (cond
        ((equal mark point)
	 (setq point-row mark-row point-col mark-col))
	((< point (window-start))
	 (setq point-row 0 point-col 0))
	((pos-visible-in-window-p point window)
	 (progn
	   (goto-char point)
	   (sit-for 0)
	   (setq point-row (window-point-row window)
		 point-col (window-point-column window))))
	(t (setq point-row (- (bottom-window-edge edges) 2)
		 point-col (- (right-window-edge edges) 1)))))
    (list point-row point-col mark-row mark-col)
    (mapcar 'tnt-send-number
	    (list point-row point-col mark-row mark-col))
    (tnt-send-ps "STR")
))

(defun old-send-track-region (pinmark)
  (let* ((edges (get SelRank 'Edges))
	 (window (get SelRank 'Window))
	 (width (window-width window))
	 (height (window-height 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")
		    edges pin
		    '("STR")))
	 (tnt-send-ps (buffer-string)))))

(defun tnt-auto-scroll (x y)
  (let* ((edges (get SelRank 'Edges))
	 (scroll-step ; XXX: scroll proportionaly to distance above top or bottom
	  (max 1 (+ 1 (/ (- x (nth 0 edges)) 4)))))

    (select-window (get SelRank 'Window))

    (if (<= y (nth 1 edges))
      (progn
	(condition-case ()
	    (scroll-down scroll-step)
	  (error (message "Beginning of buffer!"))))
      (if (>= y (- (nth 3 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-coordinates-in-selection-p (x y)
  (let ((window (tnt-event-window x y))
	(point  (get SelRank 'Point))
	(mark (get SelRank 'Mark)))
    (and (eq SelRank 'PrimarySelection)
	 (get SelRank 'Registered)
	 (eq window (get SelRank 'Window))
	 (save-excursion
	   (tnt-move-to x y)
	   (and (<= (min point mark)
		    (point))
		(< (point)
		   (max point mark)))))))

(defun left-window-edge (edges) (car edges))
(defun top-window-edge (edges) (nth 1 edges))
(defun right-window-edge (edges) (nth 2 edges))
(defun bottom-window-edge (edges) (nth 3 edges))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; 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)))