;;;;
;;;; Initializing file for Stk
;;;;
;;;; This script is executed for each Stk-based application. It arranges class 
;;;; bindings for widgets.
;;;;
;;;; Copyright (C) 1993,1994,1995 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;; 
;;;; Permission to use, copy, and/or distribute this software and its
;;;; documentation for any purpose and without fee is hereby granted, provided
;;;; that both the above copyright notice and this permission notice appear in
;;;; all copies and derived works.  Fees for distribution or use of this
;;;; software or derived works may only be charged with express written
;;;; permission of the copyright holder.  
;;;; 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: 11-Jul-1995 15:26
;;;;

(unless (equal? tk_version "3.6")
    (error "wrong version of Tk loaded: need 3.6 (actual version is ~A)" 
	   tk_version))

;; This is my personnal flavour. You'll probably wold like it
;(option 'add "STk*foreground"  		"Grey20")
;(option 'add "STk*background"  		"DarkSeaGreen3")
;(option 'add "STk*Scrollbar*foreground" "DarkSeaGreen2")

;(option 'add "STk*background"  		"#00feff")
;(option 'add "STk*Scrollbar*foreground" "#00cdff")



;; Define some variables and utilities 

(define-macro (tk-get w option)
  `(list-ref (,w 'configure ,option) 4))

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

(define (do-bindings class bindings)
  (for-each (lambda(l) (bind class (car l) (cdr l))) bindings))

(define (& . l)
  (let loop ((l l) (res ""))
    (if (null? l)
        res
        (let ((e (car l)))
          (loop (cdr l) 
		(string-append res (cond ((string? e) e)
					 ((symbol? e) (symbol->string e))
					 ((widget? e) (widget->string e))
					 ((number? e) (number->string e)))))))))

(define (get-focus)
  (let ((f (focus)))
    (if (equal? f 'none) "none" (eval f))))


;; Turn off strict Motif look and feel as a default.
(define tk-strictMotif 		#f)  


;; Following vars are used everywhere. So define them here 
(define tk::window	 '())
(define tk::relief	 '())
(define tk::buttons	 0)
(define tk::dragging	 '())
(define tk::focus	 '())
(define tk::grab	 "")
(define tk::inMenuButton '())
(define tk::posted	 #f)
(define tk::selectMode	 '())
(define tk::window	 '())
(define tk::activeBg	 '())
(define tk::activeFg	 '())
(define tk::x		 0)
(define tk::y		 0)
(define tk::buttonWindow '())
(define tk::cursor	 "")
(define tk::kill-buffer "") ;; One kill buffer shared between all texts. 

(let ((load (lambda (f) 
	      (load (string-append tk_library "/STk/" f)))))
  (load "error.stk")
  
  (load "button.stk")
  (load "entry.stk")
  (load "listbox.stk")
  (load "menu.stk")
  (load "scale.stk")
  (load "scrollbar.stk")
  (load "text.stk"))

;;
;; Now retain widget names in global vars to allow their overloading
;;
(define Tk:button	button)
(define Tk:checkbutton	checkbutton)
(define Tk:canvas	canvas)
(define Tk:entry	entry)
(define Tk:frame	frame)
(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: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)

;;;
;;; A procedure which permits to add a binding (before or after) the current
;;; widget (widget or class) binding
;;;
(define (add-binding widget event binding where)
  (let ((old (bind widget event)))
    (when (null? old) 
       ;; Try to look if a class binding already exists for this event
       (set! old (bind (winfo 'class widget) event)))
    (bind widget 
	  event 
	  (if (null? old) 
	      binding 
	      (if (eqv? where :before)
		  `(begin ,binding ,old)
		  `(begin ,old ,binding))))))

(autoload "dialog" 			stk::make-dialog stk:center-window)
(autoload "help"   			stk:make-help)
(autoload "inspect-main"		inspect view detail)
(autoload "editor"			stk:make-editor ed)

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

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