;;;;
;;;; Initialization file for Tk
;;;;
;;;; This script is executed for each STk-based application. It arranges class 
;;;; bindings for widgets.
;;;;
;;;; 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: 16-Sep-1999 16:48 (eg)
;;;;

(unless (equal? *tk-version* "8.0")
  (error "wrong version of Tk loaded: need 8.0 (this version is ~A)" 
	 *tk-version*))

(select-module Tk)	  ;; The rest of this file belongs to the Tk module
(import Scheme)		  ;; Prefer the Scheme bindings rather than the STk ones.
(export-all-symbols)	  ;; Export all the symbols

;; Special user variables 
(define-variable *tk-strict-Motif*   #f)   ;; Turn off strict Motif look and feel
(define-variable *image-path*        #f)   ;; Path for images
(define-variable *help-path*	     #f)   ;; Path for HTML help pages
(define-variable *start-withdrawn*   #t)   ;; Start with *root* unmapped

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Utilities
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-macro (tk-get w option)
  `(,w 'cget ,option))

(define-macro (tk-set! w option . value)
  `(,w 'configure ,option ,@value))

(define (Tk-screen-changed  screen)
  ;; This function is called when the screen is changed. Since I own only 
  ;; one screen, I don't know what I must do here.
  screen)

(define-macro (define-binding class event args . body)
  (if (null? body)
      `(bind ,class ,event "")
      `(bind ,class ,event (lambda ,args ,@body))))

;;
;; Read and write access to the data associated to widget
;;
(define (set-widget-property! widget name value)
  (let ((data (get-widget-data widget)))
    (if (or (not data) (null? data))
	(set-widget-data! widget (list name value))
	(let ((prop (memv name data)))
	  (if prop 
	      (set-cdr! prop (cons value (cddr prop)))
	      (set-widget-data! widget (append (list name value) data)))))))


(define (get-widget-property widget name . default)
  (let ((data (get-widget-data widget)))
    (if (or (not data) (null? data))
	(if (null? default)
	    (error "get-widget-property: No property ~S in ~S" name widget)
	    (car default))
	(apply get-keyword name data default))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Following vars are used everywhere. So define them here
(define tk::window	   #f)
(define tk::button-window  '())
(define tk::relief	   "sunken")
(define tk::select-mode	   "char")
(define tk::mouse-moved    #f)
(define tk::press-x 	   0)
(define tk::press-y 	   0)
(define tk::x		   0)
(define tk::y		   0)
(define tk::after-id	   "")
(define tk::active-bg	   "")
(define tk::active-fg	   "")
(define tk::dragging	   #f)


(define tk::buttons	 0)
(define tk::focus	 '())
(define tk::grab	 "")
(define tk::inMenuButton '())
(define tk::posted	 #f)
(define tk::cursor	 "")
(define tk::kill-buffer  "") ;; One kill buffer shared between all texts. 


;; add-binding --
;; This procedure adds a binding to a widget. It replaces the Tcl "+" mechanism
;; which is meaningless with closures. Furthermore, this mechanism permits
;; to add the binding BEFORE the old binding
;;
(define (add-binding widget event binding before?)
  (let ((old (bind widget event)))
    (if (null? old)
	(bind widget event binding)
	;;; We must find the parameters of the old and given bindings
	;;; The new binding is a new closure with the union of these 
	;;; parameters.
	;;; if:
	;;;   old binding is   (lambda (x y) ....)
	;;;   given binding is (lambda (x t a) ...)
	;;; We must construct the binding of the form
	;;;    (lambda (x y t a)
	;;;       ((lambda (x y) ....) x y)
	;;;       ((lambda (x t a) ....) x t a))
	(let ((body-old (procedure-body (car old)))
	      (body-new (procedure-body binding)))
	  (if (and body-old body-new)
	      (let ((p-old (cadr body-old))
		    (p-new (cadr body-new)))
		(bind widget
		      event 
		      (if before?
			  (eval `(lambda ,(set-union p-old p-new)
				   (,binding ,@(cadr body-new))
				   ,old))
			  (eval `(lambda ,(set-union p-old p-new)
				   ,old
				   (,binding ,@(cadr body-new)))))))
	      ;; 
	      (Error "add-binding: Incorrect binding ~S" binding))))))

;; Tk:cancel-repeat --
;; This procedure is invoked to cancel an auto-repeat action described
;; by tk::after-id.  It's used by several widgets to auto-scroll
;; the widget when the mouse is dragged out of the widget with a
;; button pressed.

(define (Tk:cancel-repeat)
  (after 'cancel tk::after-id)
  (set! tk::after-id ""))

;; Tk:tab-to-window --
;; This procedure moves the focus to the given widget.  If the widget
;; is an entry, it selects the entire contents of the widget.

(define (Tk:tab-to-window w)
  (when (string=? (winfo 'class w) "Entry")
    (w 'select 'range 0 'end)
    (w 'icur 'end))
  (focus w))


;;;;
;;;; A procedure to forbid remote executution via the send Tk command
;;;;
(define (inhibit-send)
  ;; Redefine send sommand
  (set! send (make-unbound))
  ;; Issue a GC so that command is effectively deleted from Tk tables NOW
  (gc))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; Withdraw the root window
;;;;
;;;; A lot of people dislike the fact that the root window is mapped
;;;; on screen when Tk is started, The code below, unmaps the *root*
;;;; window and make it appearing as soon as the first sub-window is
;;;; packed or some action is asked to the window manager for
;;;; *root*. With this code, the the behaviour is identical to the Tk
;;;; original one except that the empty squared window don't appears
;;;; on screen. The original behaviour can be recovered by setting
;;;; *start-withdrawn* to #f
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(when *start-withdrawn*
  ;; Start without mapping the root window.
  (wm 'withdraw ".")
  
  (let ((old-pack pack) (old-wm wm))
    (set! pack 
	  (lambda l
	    (let ((res (apply old-pack l)))
	      (for-each (lambda (x)
			  (when (and *start-withdrawn*
				     (eq? (winfo 'toplevel x) *root*)
				     (winfo 'manager x))
			    (wm 'deiconify *root*)))
			(winfo 'children *root*))
	      res)))
    
    (set! wm
	  (lambda l
	    (let ((res (apply old-wm l)))
	      (unless (equal? (old-wm 'state *root*) "withdrawn")
		;; Previous wm call makes the *root* window no more withdrawn
		;; Replace the pack and wm command by the original Tk ones
		(set! pack    		old-pack)
		(set! Tk:pack 		old-pack)
		(set! wm      		old-wm)
		(set! Tk:wm   		old-wm)
		(set! *start-withdrawn*	#f))
	      res)))))

;;;;
;;;; Define widget which require a lot of initialization as a kind of autoload
;;;; This allows a faster loading for small programs which use only a few widgets
;;;; and decreases memory usage
;;;; 

(define-macro (%redefine-Tk-command widget file)
  (let ((synonym (string->symbol (format #f "tk:~A" widget))))
    `(set! ,widget
	   (let ((tk-cmd ,widget))
	     (lambda l
	       ;; Load the library file
	       (load ,(string-append *STk-library* "/STk/" file ".stk"))

	       ;; Test here that old value is a true closure because when
	       ;; using STklos some Tk commands are already defined as generic.
	       ;; Reloading the file and setting widget and Tk:widget breaks
	       ;; the generic function. Weak but it seems to work
	       (if (closure? ,widget)  (set! ,widget  tk-cmd))
	       (if (closure? ,synonym) (set! ,synonym tk-cmd))
	       
	       ;; Do the job
	       (apply tk-cmd l))))))

(%redefine-Tk-command button		"button")
(%redefine-Tk-command checkbutton	"button")
(%redefine-Tk-command radiobutton	"button")
(%redefine-Tk-command entry		"entry")
(%redefine-Tk-command focus		"focus")
(%redefine-Tk-command listbox		"listbox")
(%redefine-Tk-command menu		"menu")
(%redefine-Tk-command menubutton	"menu")
(%redefine-Tk-command scale		"scale")
(%redefine-Tk-command scrollbar		"scrollbar")
(%redefine-Tk-command text		"text")

;;
;; Make synonyms for all Tk-commands to "protect" them against redefinition.
;; This is no more necessary now with modules but some user code could rely on it. 
;;
(define Tk:button	button)
(define Tk:checkbutton	checkbutton)
(define Tk:canvas	canvas)
(define Tk:entry	entry)
(define Tk:frame	frame)
(define Tk:image	image)
(define Tk:label 	label)
(define Tk:listbox	listbox)
(define Tk:menu		menu)
(define Tk:menubutton	menubutton)
(define Tk:message	message)
(define Tk:scale	scale)
(define Tk:scrollbar	scrollbar)
(define Tk:radiobutton	radiobutton)
(define Tk:text		text)
(define Tk:toplevel	toplevel)

(define Tk:after	after)
(define Tk:bind		bind)
(define Tk:bindtags	bindtags)
(define Tk:bell		bell)
(define Tk:clipboard	clipboard)
(define Tk:destroy	destroy)
(define Tk:focus	focus)
(define Tk:grab		grab)
(define Tk:lower	lower)
(define Tk:option	option)
(define Tk:pack		pack)
(define Tk:place	place)
(define Tk:raise	raise)
(define Tk:selection	selection)
(define Tk:tk		tk)
(define Tk:tkwait	tkwait)
(define Tk:update	update)
(define Tk:winfo	winfo)
(define Tk:wm		wm)

;;;;
;;;; Default bindings
;;;; 

;; Keyboard traversal
(bind "all" "<Tab>" 	   (lambda (|W|) (Tk:tab-to-window (Tk:focus-next |W|))))
(bind "all" "<Shift-Tab>"  (lambda (|W|) (Tk:tab-to-window (Tk:focus-prev |W|))))

;; Cut/Copy/Paste virtual events
(case (os-kind)
  ((Windows) (event 'add "<<Cut>>"   "<Control-Key-x>" "<Shift-Key-Delete>")
	     (event 'add "<<Copy>>"  "<Control-Key-c>" "<Control-Key-Insert>")
	     (event 'add "<<Paste>>" "<Control-Key-v>" "<Shift-Key-Insert>")
	     (event 'add "<<PasteSelection>>" "<ButtonRelease-2>" ))
  ((Unix)    (event 'add "<<Cut>>"   "<Control-Key-x>" "<Key-F20>") 
	     (event 'add "<<Copy>>"  "<Control-Key-c>" "<Key-F16>")
	     (event 'add "<<Paste>>" "<Control-Key-v>" "<Key-F18>")
	     (event 'add "<<PasteSelection>>" "<ButtonRelease-2>" )
	     ;; Add a trace to set and unset Motif bindings when the
	     ;; *tk-strict-Motif* variable is changed
	     (let ((trace (lambda ()
			    (let ((op (if *tk-strict-Motif* 'delete 'add)))
			      (event op "<<Cut>>"   "<Control-Key-w>")
			      (event op "<<Copy>>"  "<Meta-Key-w>")
			      (event op "<<Paste>>" "<Control-Key-y>")))))
	       (trace-var '*tk-strict-Motif* trace)
	       (trace))))
  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Initialisation of *image-path* and *help-path*
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(set! *image-path* (append (list "" ".") 
			   (build-path-from-shell-variable "STK_IMAGE_PATH")
			   (list (string-append *STk-library* "/Images"))))

(set! *help-path* (append (list "" ".")
			  (build-path-from-shell-variable "STK_HELP_PATH")
			  (list (string-append *STk-library* "/Help"))))

;;;;
;;;; Some autoloads
;;;; 
(autoload "dialog"    	 STk:make-dialog STk:center-window)
(autoload "edit"	 ed)
(autoload "focus" 	 Tk:focus-next Tk:focus-prev)
(autoload "listener"  	 listener)
(autoload "palette"   	 Tk:set-palette! Tk:bisque)
(autoload "menu"      	 Tk:option-menu)
(autoload "inspect-main" inspect view detail)
(autoload "fileevent" 	 Tk:fileevent fileevent) ; for backward compatibility
(autoload "sterm" 	 sterm)
(autoload "image"        find-image make-image change-image delete-image)
;(autoload "error" 	 STk:report-error bgerror)))
(when (eq? (os-kind) 'Unix)
  (autoload "tk-unix"	 Tk:choose-color Tk:message-box
	    		 Tk:get-open-file Tk:get-save-file Tk:get-file))


(define (tk-set-error-handler!)
  (autoload "error" STk:report-error bgerror))

;=============================================================================
;
; Module STklos+Tk definition
;
; This module serves to define all the STklos classes and methods for
; working with Tk. It is defined here, even if you don't use STklos
; (you really must use it :) so that it can be imported before Tk. So,
; if functions are redefined in STklos for Tk they will be seen before
; the Tk ones. If STklos is not used (it's a pity!), the module is
; just passed thru since it contains nothing.
;
;=============================================================================

(define-module STklos+Tk
  (import STklos Tk))

(with-module STk 
  ;; Make all Tk public symbols available to STk
  (import STklos+Tk Tk)
  ;; report-error as a kind of autoload (must be a closure, rather than an 
  ;; autoload since C error function tests explicitely it is a closure before
  ;; applying its arguments
  (define (report-error . args)
    (apply STk:report-error args))
  
  ;; Global help functions which are defined when Tk is loaded
  (autoload "help"          help STk:show-help-file)
  (autoload "www-browser"   WWW:browser WWW:mailto)
  (autoload "class-browser" class-browser))

;;;;
;;;; Retain now that Tk is now fully initialized
;;;;
(set! Tk:initialized? #t)
