;;;;
;;;; Entries bindings and procs
;;;;
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;; This software is a derivative work of other copyrighted softwares; the
;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
;;;;
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 17-May-1993 12:35
;;;; Last file update:  3-Sep-1999 19:50 (eg)
;;;;

(select-module Tk)

;; ----------------------------------------------------------------------
;; Class bindings for entry widgets.
;; ----------------------------------------------------------------------
;;
;; Elements used in this file:
;;
;; after-id -		If non-null, it means that auto-scanning is underway
;;			and it gives the "after" id for the next auto-scan
;;			command to be executed.
;; mouse-moved -	Non-zero means the mouse has moved a significant
;;			amount since the button went down (so, for example,
;;			start dragging out a selection).
;; press-x -		X-coordinate at which the mouse button was pressed.
;; select-mode -	The style of selection currently underway:
;;			char, word, or line.
;; x, y -		Last known mouse coordinates for scanning
;;			and auto-scanning.
;;-------------------------------------------------------------------------


;;
;; Utilities
;;
(define (Tk:word-character c)
  (or (char-alphabetic? c)
      (char-numeric? c)
      (char=? c #\-)
      (char=? c #\*)))

(define (Tk:word-separator c)
  (not (Tk:word-character c)))

(define (Tk:end-of-word str index . separator)
  (let ((len (string-length str))
	(sep (if (null? separator) Tk:word-separator separator)))
    (let loop ((i index))
      (cond
         ((= len 0)			0)
         ((>= i len) 			len)
	 ((sep (string-ref str i))	(if (= index i) (+ i 1) i))
	 (ELSE				(loop (+ i 1)))))))

(define (Tk:beginning-of-word str index . separator)
  (let ((len (string-length str))
	(sep (if (null? separator) Tk:word-separator separator)))
    (let loop ((i index))
      (cond
         ((= len 0)			0)
         ((= i -1) 			0)
	 ((>= i len)			(loop (- len 1)))
	 ((sep (string-ref str i)) 	(if (= index i) i (+ i 1)))
	 (ELSE 				(loop (- i 1)))))))

;=============================================================================

;; Tk:entry-button-1 --
;; This procedure is invoked to handle button-1 presses in "Entry"
;; widgets.  It moves the insertion cursor, sets the selection anchor,
;; and claims the input focus.
;;
;; Arguments:
;; w -		The "Entry" window in which the button was pressed.
;; x -		The x-coordinate of the button press.

(define (Tk:entry-button-1 w x)
  (let ((pos (format #f "@~A" x)))
    (set! tk::select-mode "char")
    (set! tk::mouse-moved #f)
    (set! tk::press-x x)
    (w 'icursor (Tk:entry-closest-gap w x))
    (w 'selection 'from 'insert)
    (if (equal? (tk-get w :state) "normal")
	(focus w))))

;; Tk:entry-mouse-select --
;; This procedure is invoked when dragging out a selection with
;; the mouse.  Depending on the selection mode (character, word,
;; line) it selects in different-sized units.  This procedure
;; ignores mouse motions initially until the mouse has moved from
;; one character to another or until there have been multiple clicks.
;;
;; Arguments:
;; w -		The "Entry" window in which the button was pressed.
;; x -		The x-coordinate of the mouse.

(define (Tk:entry-mouse-select w x)
  (let* ((cur    (Tk:entry-closest-gap w x))
	 (anchor (w 'index 'anchor)))

    (if (or (equal? cur anchor)  
	    (>= (abs (- tk::press-x x)) 3))
	(set! tk::mouse-moved #t))

    (cond
      ((string=? tk::select-mode "char")
       		(if tk::mouse-moved
		    (cond
		      ((< cur anchor) (w 'selection 'range cur anchor))
		      ((> cur anchor) (w 'selection 'range anchor cur))
		      (ELSE	      (w 'selection 'clear)))))
      ((string=? tk::select-mode "word")
                (if (< cur (w 'index 'anchor))
		    (w 'selection 'range 
		       (Tk:beginning-of-word (w 'get) cur)
		       (Tk:end-of-word       (w 'get) (- anchor 1)))
		    (w 'selection 'range 
		       (Tk:beginning-of-word (w 'get) anchor)
		       (Tk:end-of-word       (w 'get) (- cur 1)))))
      ((string=? tk::select-mode "line")
	    	(w 'selection 'range 0 'end)))

    (update 'idletasks)))


;; Tk:entry-auto-scan --
;; This procedure is invoked when the mouse leaves an "Entry" window
;; with button 1 down.  It scrolls the window left or right,
;; depending on where the mouse is, and reschedules itself as an
;; "after" command so that the window continues to scroll until the
;; mouse moves back into the window or the mouse button is released.
;;
;; Arguments:
;; w -	The "Entry" window.

(define (Tk:entry-auto-scan w)
  (when (winfo 'exists w)
    (let ((x tk::x))
      (if (>= x  (winfo 'width w))
	  (begin
	    (w 'xview 'scroll 2 'units)
	    (Tk:entry-mouse-select w x))
	  (if (< x 0)
	      (w 'xview 'scroll -2 'units)
	      (Tk:entry-mouse-select w x)))
      
      (set! tk::after-id (after 50 (lambda ()
				     (Tk:entry-auto-scan w)))))))

;; Tk:entry-key-select --
;; This procedure is invoked when stroking out selections using the
;; keyboard.  It moves the cursor to a new position, then extends
;; the selection to that position.
;;
;; Arguments:
;; w -		The "Entry" window.
;; new -	A new position for the insertion cursor (the cursor hasn't
;;		actually been moved to this position yet).

(define (Tk:entry-key-select w new)
  (if (w 'selection 'present)
      (w 'selection 'adjust new)
      (begin
	(w 'selection 'from 'insert)
	(w 'selection 'to new)))
  (w 'icursor new))

;; Tk:entry-Insert --
;; Insert a string into an "Entry" at the point of the insertion cursor.
;; If there is a selection in the "Entry", and it covers the point of the
;; insertion cursor, then delete the selection before inserting.
;;
;; Arguments:
;; w -	The "Entry" window in which to insert the string
;; s -		The string to insert (usually just a single character)

(define (Tk:entry-insert w s)
  (unless (equal? s "")
     (let ((insert (w 'index 'insert)))
       (catch
	   (if (and (<= (w 'index 'sel.first) insert)
		    (>= (w 'index 'sel.last)  insert))
	       (w 'delete 'sel.first 'sel.last))))
     (w 'insert 'insert s)
     (Tk:entry-see-insert w)))

;; Tk:entry-backspace --
;; Backspace over the character just before the insertion cursor.
;; If backspacing would move the cursor off the left edge of the
;; window, reposition the cursor at about the middle of the window.
;;
;; Arguments:
;; w -		The "Entry" window in which to backspace.

(define (Tk:entry-backspace w)
  (if (w 'selection 'present)
      (w 'delete 'sel.first 'sel.last)
      (let ((x (- (w 'index 'insert) 1)))
	(if (>= x 0) (w 'delete x))
	(when (>= (w 'index "@0") 
		  (w 'index 'insert))
	  (let* ((range (w 'xview))
		 (left  (car range))
		 (right (cadr range)))
	    (w 'xview 'moveto (- left (/ (- right left) 2.0))))))))

;; Tk:entry-see-insert --
;; Make sure that the insertion cursor is visible in the "Entry" window.
;; If not, adjust the view so that it is.
;;
;; Arguments:
;; w -		The "Entry" window.

(define (Tk:entry-see-insert w)
  (let ((c    (w 'index 'insert))
	(left (w 'index "@0")))
    
    (if (> left c)
	(w 'xview c)
	(let ((x (winfo 'width w)))
	  (while (and (<= (w 'index (format #f "@~A" x)) c)
		      (< left c))
	     (set! left (+ left 1))
	     (w 'xview left))))))

;; Tk:entry-set-cursor -
;; Move the insertion cursor to a given position in an "Entry".  Also
;; clears the selection, if there is one in the "Entry", and makes sure
;; that the insertion cursor is visible.
;;
;; Arguments:
;; w -		The "Entry" window.
;; pos -	The desired new position for the cursor in the window.

(define (Tk:entry-set-cursor w pos)
  (w 'icursor pos)
  (w 'selection 'clear)
  (Tk:entry-see-insert w))

;; Tk:entry-Transpose -
;; This procedure implements the "transpose" function for "Entry" widgets.
;; It tranposes the characters on either side of the insertion cursor,
;; unless the cursor is at the end of the line.  In this case it
;; transposes the two characters to the left of the cursor.  In either
;; case, the cursor ends up to the right of the transposed characters.
;;
;; w -		The "Entry" window.

(define (Tk:entry-transpose w)
  (let ((i (w 'index 'insert)))
    (if (< i (w 'index 'end))
	(set! i (+ i 1)))
    (let ((first (- i 2)))
      (if (>= first 0)
	  (let* ((str (w 'get))
		 (new (string (string-ref str (- i 1)) (string-ref str first))))
	    (w 'delete first i)
	    (w 'insert 'insert new)
	    (Tk:entry-see-insert w))))))

;; Tk:entry-closest-gap --
;; Given x and y coordinates, this procedure finds the closest boundary
;; between characters to the given coordinates and returns the index
;; of the character just after the boundary.
;;
;; w -		The entry window.
;; x -		X-coordinate within the window.

(define (Tk:entry-closest-gap w x)
  (let* ((pos  (w 'index (format #f "@~A" x)))
	 (bbox (w 'bbox pos)))
    (if (< [- x (list-ref bbox 0)] (/ (list-ref bbox 2) 2))
	pos
	(+ pos 1))))


;; Tk:entry-paste --
;; This procedure sets the insertion cursor to the current mouse position,
;; pastes the selection there, and sets the focus to the window.
;;
;; w -		The entry window.
;; x -		X position of the mouse.

(define (Tk:entry-paste w x)
  (w 'icursor (Tk:entry-closest-gap w x))
  (catch (w 'insert 'insert (selection 'get :displayof w)))
  (if (string=? (tk-get w :state) "normal")
      (focus w)))


;;-------------------------------------------------------------------------
;; The code below creates the default class bindings for entries.
;;-------------------------------------------------------------------------

(define-binding "Entry" "<<Cut>>" (|W|)
  (clipboard 'clear :displayof |W|)
  (catch 
     (clipboard 'append :displayof |W| 
		(substring (|W| 'get)
			   (|W| 'index 'sel.first)
			   (|W| 'index 'sel.last)))
     (|W| 'delete 'sel.first 'sel.last)))

(define-binding "Entry" "<<Copy>>" (|W|)
  (clipboard 'clear :displayof |W|)
  (catch 
     (clipboard 'append :displayof |W| 
		(substring (|W| 'get)
			   (|W| 'index 'sel.first)
			   (|W| 'index 'sel.last)))))


(define-binding "Entry" "<<Paste>>" (|W|)
  (catch
     (when (eqv? (os-kind) 'Unix)
        (catch (|W| 'delete 'sel.first 'sel.last)))
     (|W| 'insert 'insert (selection 'get :displayof |W| 
				     	  :selection "CLIPBOARD"))
     (Tk:entry-see-insert |W|)))
  
(define-binding "Entry" "<<Clear>>" (|W|)
  (|W| 'delete 'sel.first 'sel.last))

(define-binding "Entry" "<<PasteSelection>>" (|W| x)
  (when (or *tk-strict-Motif* (not tk::mouse-moved))
    (Tk:entry-paste |W| x)))

(define-binding "Entry" "<1>" (|W| x)
  (Tk:entry-button-1 |W| x)
  (|W| 'selection 'clear))

(define-binding "Entry" "<B1-Motion>" (|W| x)
  (set! tk::x x)
  (Tk:entry-mouse-select |W| x))

(define-binding "Entry" "<Double-1>" (|W| x)
  (set! tk::select-mode "word")
  (Tk:entry-mouse-select |W| x)
  (catch 
     (|W| 'icursor 'sel.first)))

(define-binding "Entry" "<Triple-1>" (|W| x)
  (set! tk::select-mode "line")
  (Tk:entry-mouse-select |W| x)
  (|W| 'icursor 0))

(define-binding "Entry" "<Shift-1>" (|W| x)
  (set! tk::select-mode "char")
  (|W| 'selection 'adjust (format #f "@~A" x)))

(define-binding "Entry" "<Double-Shift-1>" (|W| x)
  (set! tk::select-mode "word")
  (Tk:entry-mouse-select |W| x))

(define-binding "Entry" "<Triple-Shift-1>" (|W| x)
  (set! tk::select-mode "line")
  (Tk:entry-mouse-select |W| x))

(define-binding "Entry" "<B1-Leave>" (|W| x)
  (set! tk::x x)
  (Tk:entry-auto-scan |W|))

(define-binding "Entry" "<B1-Enter>" ()
  (Tk:cancel-repeat))

(define-binding "Entry" "<ButtonRelease-1>" ()
  (Tk:cancel-repeat))

(define-binding "Entry" "<Control-1>" (|W| x)
  (|W| 'icursor (format #f "@~A" x)))


(define-binding "Entry" "<Left>" (|W|)
  (Tk:entry-set-cursor |W| (- (|W| 'index 'insert) 1)))

(define-binding "Entry" "<Right>" (|W|)
  (Tk:entry-set-cursor |W| (+ (|W| 'index 'insert) 1)))

(define-binding "Entry" "<Shift-Left>" (|W|)
  (Tk:entry-key-select |W| (- (|W| 'index 'insert) 1))
  (Tk:entry-see-insert |W|))

(define-binding "Entry" "<Shift-Right>" (|W|)
  (Tk:entry-key-select |W| (+ (|W| 'index 'insert) 1))
  (Tk:entry-see-insert |W|))

(define-binding "Entry" "<Control-Left>" (|W|)
  (Tk:entry-set-cursor |W|
		       (Tk:beginning-of-word (|W| 'get) 
					     (- (|W| 'index 'insert) 1))))

(define-binding "Entry" "<Control-Right>" (|W|)
  (Tk:entry-set-cursor |W| (Tk:end-of-word (|W| 'get) (|W| 'index 'insert))))

(define-binding "Entry" "<Shift-Control-Left>" (|W|)
  (Tk:entry-key-select |W|
			(Tk:beginning-of-word (|W| 'get) 
					     (- (|W| 'index 'insert) 1)))
  (Tk:entry-see-insert |W|))

(define-binding "Entry" "<Shift-Control-Right>" (|W|)
  (Tk:entry-key-select |W| (Tk:end-of-word (|W| 'get) (|W| 'index 'insert)))
  (Tk:entry-see-insert |W|))

(define-binding "Entry" "<Home>" (|W|)
  (Tk:entry-set-cursor |W| 0))

(define-binding "Entry" "<Shift-Home>" (|W|)
  (Tk:entry-key-select |W| 0)
  (Tk:entry-see-insert |W|))

(define-binding "Entry" "<End>" (|W|)
  (Tk:entry-set-cursor |W| 'end))

(define-binding "Entry" "<Shift-End>" (|W|)
  (Tk:entry-key-select |W| 'end)
  (Tk:entry-see-insert |W|))

(define-binding "Entry" "<Delete>" (|W|)
  (if (|W| 'selection 'present)
      (|W| 'delete 'sel.first 'sel.last)
      (|W| 'delete 'insert)))

(define-binding "Entry" "<BackSpace>" (|W|)
  (Tk:entry-backspace |W|))

(define-binding "Entry" "<Control-space>" (|W|)
  (|W| 'selection 'from 'insert))

(define-binding "Entry" "<Select>" (|W|)
  (|W| 'selection 'from 'insert))

(define-binding "Entry" "<Control-Shift-space>" (|W|)
  (|W| 'selection 'adjust 'insert))

(define-binding "Entry" "<Shift-Select>" (|W|)
  (|W| 'selection 'adjust 'insert))

(define-binding "Entry" "<Control-slash>" (|W|)
  (|W| 'selection 'range 0 'end))

(define-binding "Entry" "<Control-backslash>" (|W|)
  (|W| 'selection 'clear))

(define-binding "Entry" "<KeyPress>" (|W| |A|)
  (Tk:entry-Insert |W| |A|))


;; Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
;; Otherwise, if a widget binding for one of these is defined, the
;; <KeyPress> class binding will also fire and insert the character,
;; which is wrong.  Ditto for Escape, Return, and Tab.
(let ((nop (lambda () '())))
  (bind "Entry" "<Alt-KeyPress>" 	nop)
  (bind "Entry" "<Meta-KeyPress>" 	nop)
  (bind "Entry" "<Control-KeyPress>" 	nop)
  (bind "Entry" "<Escape>" 		nop)
  (bind "Entry" "<Return>" 		nop)
  (bind "Entry" "<KP_Enter>" 		nop)
  (bind "Entry" "<Tab>" 		nop))

;; On Windows, paste is done using Shift-Insert.  Shift-Insert already
;; generates the <<Paste>> event, so we don't need to do anything here.
(if (eqv? (os-kind) 'Unix)
    (define-binding "Entry" "<Insert>" (|W|)
      (catch 
       (Tk:entry-insert |W| (selection 'get :displayof |W|)))))

;; Additional emacs-like bindings:

(define-binding "Entry" "<Control-a>" (|W|)
  (Tk:entry-set-cursor |W| 0))

(define-binding "Entry" "<Control-b>" (|W|)
  (Tk:entry-set-cursor |W| (- (|W| 'index 'insert) 1)))

(define-binding "Entry" "<Control-d>" (|W|)
  (|W| 'delete 'insert))

(define-binding "Entry" "<Control-e>" (|W|)
  (Tk:entry-set-cursor |W| 'end))

(define-binding "Entry" "<Control-f>" (|W|)
  (Tk:entry-set-cursor |W| (+ (|W| 'index 'insert) 1)))

(define-binding "Entry" "<Control-h>" (|W|)
  (Tk:entry-backspace |W|))

(define-binding "Entry" "<Control-k>" (|W|)
  (|W| 'delete 'insert 'end))

(define-binding "Entry" "<Control-t>" (|W|)
  (Tk:entry-transpose |W|))

(define-binding "Entry" "<Meta-b>" (|W|)
 (Tk:entry-set-cursor |W|
		       (Tk:beginning-of-word (|W| 'get) 
					     (- (|W| 'index 'insert) 1))))

(define-binding "Entry" "<Meta-d>" (|W|)
  (|W| 'delete 'insert (Tk:end-of-word (|W| 'get) (|W| 'index 'insert))))

(define-binding "Entry" "<Meta-f>" (|W|)
  (Tk:entry-set-cursor |W| (Tk:end-of-word (|W| 'get) (|W| 'index 'insert))))

(define-binding "Entry" "<Meta-BackSpace>" (|W|)
  (|W| 'delete (Tk:beginning-of-word (|W| 'get) (- (|W| 'index 'insert) 1))
       'insert))

(define-binding "Entry" "<Meta-Delete>" (|W|)
  (|W| 'delete (Tk:beginning-of-word (|W| 'get) (- (|W| 'index 'insert) 1))
       'insert))

;; A few additional bindings of my own.

(define-binding "Entry" "<Shift-2>" (|W| x)
  (|W| 'scan 'mark x)
  (set! tk::x x)
  (set! tk::mouse-moved #f))

(define-binding "Entry" "<Shift-B2-Motion>" (|W| x)
  (if (> (abs (- x tk::x)) 2)
      (set! tk::mouse-moved #t))
  (|W| 'scan 'dragto x))