stk/Lib/palette.stk

;;;;
;;;; Palette -- procedures that change the color palette used by Tk
;;;;
;;;; Copyright <20> 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:  4-Aug-1995 11:24
;;;; Last file update:  3-Sep-1999 19:53 (eg)
;;;;

(require "hash")

(select-module Tk)


;=============================================================================
;
; Utilities
;
;=============================================================================

;;
;; make-rgb-color
;;
(define (make-rgb-color r g b)
  (let ((hexa (lambda (n) 
		(string-append (number->string (quotient n 16) 16) 
			       (number->string (modulo n 16) 16)))))
    (string-append "#" (hexa (min (inexact->exact r) 255))
		       (hexa (min (inexact->exact g) 255))
		       (hexa (min (inexact->exact b) 255)))))

;;
;; make-lighter-color
;;
(define (make-lighter-color color)
  ;; Make a lighter color: to do this, round each color component
  ;; up by 15% or 1/3 of the way to full white, whichever is greater.
  (let ((rgb   (winfo 'rgb *root* color))
	(light (make-vector 3)))
    (dotimes (i 3)
      (let* ((c    (/ (list-ref rgb i) 256))
	     (inc1 (* c 0.15))
	     (inc2 (/ (- 255 c) 3)))
	(set! c (+ c (max inc1 inc2)))
	(vector-set! light i (min c 255))))
    (make-rgb-color (vector-ref light 0) 
		    (vector-ref light 1) 
		    (vector-ref light 2))))

;;
;; make-darker-color
;;
(define (make-darker-color color)
  (let ((rgb    (winfo 'rgb *root* color)))
    (make-rgb-color (/ (* 9 (list-ref rgb 0)) 2560)
		    (/ (* 9 (list-ref rgb 1)) 2560)
		    (/ (* 9 (list-ref rgb 2)) 2560))))


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


;; Tk:set-palette! --
;; Changes the default color scheme for a Tk application by setting
;; default colors in the option database and by modifying all of the
;; color options for existing widgets that have the default value.
;;
;; The arguments consist of either a single color name, which
;; will be used as the new background color (all other colors will
;; be computed from this) or an even number of values consisting of
;; option names and values.  The name for an option is the one used
;; for the option database, such as activeForeground, not -activeforeground.

(define Tk:set-palette!
  (let ((tk::palette #f))
	   
    (define (Tk:recolor-tree w colors)
      (hash-table-for-each colors 
			   (lambda (db-opt db-value)
			     (let ((opt (make-keyword (string-lower db-opt)))
				   (val #f))
			       (unless (catch (set! val (tk-get w opt)))
				   (if (equal? val
					       (hash-table-get tk::palette db-opt))
				       (tk-set! w opt db-value))))))

      ;; Do the same job for all the children
      (for-each (lambda (child) (Tk:recolor-tree child colors))
		(winfo 'children w)))

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;;
  ;;;; Start of procedure Tk:set-palette!
  ;;;;
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (lambda args
    (let ((new (make-hash-table string=?)))
      ;; Create a hash table that has the complete new palette. If some colors
      ;; aren't specified, compute them from other colors that are specified.
      (if (= (length args) 1)
	  (hash-table-put! new "background" (car args))
	  ;; place all given colors in the "new" hashatable
	  (for-each (lambda (x) (hash-table-put! new (car x) (cadr x))) args))

      (unless (hash-table-get new "background" #f)
	 (error "you must specify a background color"))

      (unless (hash-table-get new "foreground" #f)
	 (hash-table-put! new "foreground" "black"))

      (let* ((back       (hash-table-get new "background"))
	     (fore       (hash-table-get new "foreground"))
	     (bg         (winfo 'rgb *root* back))
	     (fg         (winfo 'rgb *root* fore))
	     (lighter-bg (make-lighter-color back))
	     (darker-bg  (make-darker-color back)))
	(for-each (lambda (x)
		    (unless (hash-table-get new x #f)
		       (hash-table-put! new x fore)))
		  (list "activeForeground" "insertBackground" 
			"selectForeground" "highlightColor"))

	(unless (hash-table-get new "disabledForeground" #f)
	   (hash-table-put! new 
			    "disabledForeground" 
			    (make-rgb-color 
			           (+ (* 3 (car   bg)) (/ (car   fg) 1024))
				   (+ (* 3 (cadr  bg)) (/ (cadr  fg) 1024))
				   (+ (* 3 (caddr bg)) (/ (caddr fg) 1024)))))

	(unless (hash-table-get new "highlightBackground" #f)
	   (hash-table-put! new "highlightBackground" back))

	(unless (hash-table-get new "activeBackground" #f)
	  (hash-table-put! new "activeBackground" lighter-bg))

	(unless (hash-table-get new "selectBackground" #f)
	   (hash-table-put! new "selectBackground" darker-bg))

	(unless (hash-table-get new "troughColor" #f)
	   (hash-table-put! new "troughColor" darker-bg))

	(unless (hash-table-get new "selectColor" #f)
	   (hash-table-put! new "selectColor" "#b03060"))

	;; Walk the widget hierarchy, recoloring all existing windows.
	;; Before doing this, make sure that the tk::palette variable holds
	;; the default values of all options, so that Tk:recolor-tree can
	;; be sure to only change options that have their default values.
	;; If the variable exists, then it is already correct (it was created
	;; the last time this procedure was invoked).  If the variable
	;; doesn't exist, fill it in using the defaults from a few widgets.

      (unless (hash-table? tk::palette)
	 (let ((c (checkbutton (gensym ".tmp")))
	       (e (entry       (gensym ".tmp")))
	       (s (scrollbar   (gensym ".tmp"))))

	   (set! tk::palette (make-hash-table string=?))

	   (hash-table-put! tk::palette "activeBackground"
			    (cadddr (c 'configure :activebackground)))
	   (hash-table-put! tk::palette "activeForeground"
			    (cadddr (c 'configure :activeforeground)))
	   (hash-table-put! tk::palette "background"
			    (cadddr (c 'configure :background)))
	   (hash-table-put! tk::palette "disabledForeground"
			    (cadddr (c 'configure :disabledforeground)))
	   (hash-table-put! tk::palette "foreground"
			    (cadddr (c 'configure :foreground)))
	   (hash-table-put! tk::palette "highlightBackground"
			    (cadddr (c 'configure :highlightbackground)))
	   (hash-table-put! tk::palette "highlightColor"
			    (cadddr (c 'configure :highlightcolor)))
	   (hash-table-put! tk::palette "insertBackground"
			    (cadddr (e 'configure :insertbackground)))
	   (hash-table-put! tk::palette "selectColor"
			    (cadddr (c 'configure :selectcolor)))
	   (hash-table-put! tk::palette "selectBackground"
			    (cadddr (e 'configure :selectbackground)))
	   (hash-table-put! tk::palette "selectForeground"
			    (cadddr (e 'configure :selectforeground)))
	   (hash-table-put! tk::palette "troughColor"
			    (cadddr (s 'configure :troughcolor)))

	   ;; Destroy temporary widgets
	   (destroy c e s)))

      (Tk:recolor-tree *root* new)

      ;; Change the option database so that future windows will get the
      ;; same colors. Save the options in the global variable tk::palette, 
      ;; for use the next time we change the options.
      (hash-table-for-each new (lambda (x y)
				 (option 'add 
					 (format #f "*~A" x)
					 (hash-table-get new x))
				 (hash-table-put! tk::palette x y))))))))

;;
;; Tk:bisque --
;; Reset the Tk color palette to the old "bisque" colors.
;;


(define (Tk:bisque)
  (tk:set-palette! '("activeBackground" 	"#e6ceb1")
		   '("activeForeground" 	"black")
		   '("background" 		"#ffe4c4")
		   '("disabledForeground" 	"#b0b0b0")
		   '("foreground" 		"black")
		   '("highlightBackground" 	"#ffe4c4")
		   '("highlightColor" 		"black")
		   '("insertBackground" 	"black")
		   '("selectColor" 		"#b03060")
		   '("selectBackground" 	"#e6ceb1")
		   '("selectForeground" 	"black")
		   '("troughColor" 		"#cdb79e")))
(provide "palette")