home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / blt1.000 / blt1 / blt-1.7-for-STk / demos / palette.stklos < prev    next >
Encoding:
Text File  |  1995-02-11  |  7.7 KB  |  217 lines
  1. #!../test-blt -f
  2. ;;;;
  3. ;;;;  PURPOSE:  color palette (demo for drag&drop facilities)
  4. ;;;;
  5. ;;;; This file was originally written in Tcl for the BLT package by 
  6. ;;;;            Michael J. McLennan       Phone: (215)770-2842
  7. ;;;;            AT&T Bell Laboratories   E-mail: aluxpo!mmc@att.com
  8. ;;;;            Copyright (c) 1993  AT&T  All Rights Reserved
  9. ;;;; 
  10. ;;;;
  11. ;;;; Rewritten for STklos by Erick Gallesio
  12. ;;;;    Creation date:  6-Jul-1994 09:53
  13. ;;;; Last file update: 11-Feb-1995 10:15
  14.  
  15. (require "blt")
  16. (require "dd-protocol.stklos")
  17. (require "Scale")
  18. (require "Message")
  19. (require "Lentry")
  20.  
  21. (define (hexa n)
  22.   (string-append (number->string (quotient n 16) 16)
  23.          (number->string (modulo n 16) 16)))
  24.  
  25. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26. ;;;;
  27. ;;;; Routines for packaging token windows...
  28. ;;;;
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. (define (package-color color win)
  31.   (let* ((rgb (winfo 'rgb *root* color))
  32.      (r   (quotient (car rgb)   256))
  33.      (g   (quotient (cadr rgb)  256))
  34.      (b   (quotient (caddr rgb) 256)))
  35.     (make-drag&drop-label win :text "Color"
  36.                   :background color
  37.                   :foreground (if (> (+ r g b) 384) "black" "white"))
  38.     color))
  39.  
  40. (define (set-colors)
  41.   (let ((rgb (winfo 'rgb *root* (hash-table-get DragDrop 'color "black"))))
  42.     (set! (value Red)   (quotient (car rgb)   256))
  43.     (set! (value Green) (quotient (cadr rgb)  256))
  44.     (set! (value Blue)  (quotient (caddr rgb) 256))))
  45.  
  46. (define (package-number num win)
  47.   (make-drag&drop-label win :text (format #f "Number: ~A" num))
  48.   num)
  49.  
  50. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51. ;;;;
  52. ;;;; A Class for color Slides
  53. ;;;;
  54. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  55. (define-class <Color-Scale>(<Tk-composite-widget> <Scale>)
  56.   ((sample     :accessor sample)
  57.    (scale      :accessor scale-of)
  58.    (background    :accessor background :init-keyword :background 
  59.         :allocation :special :propagate (frame scale))
  60.    (foreground    :accessor foreground :init-keyword :foreground
  61.         :allocation :special :propagate (frame scale))
  62.    (format     :accessor format-of 
  63.            :init-keyword :format))) ;; "#~A0000", "#00~A00" or "#0000~A"
  64.  
  65. (define-method initialize-composite-widget ((self <Color-Scale>) args parent)
  66.   (let ((s (make <Scale> :parent parent :from 0 :to 255 
  67.               :command (format #f "set! (value ~S)" 
  68.                          (address-of self))
  69.               :orientation "horizontal"))
  70.     (f (make <Frame> :parent parent :geometry "20x20" :border-width 3 
  71.               :relief "raised")))
  72.  
  73.     ;; Manage components
  74.     (slot-set! parent 'border-width 3)
  75.     (slot-set! parent 'relief "groove")
  76.     (pack s :side "left"  :expand #t :fill 'x)
  77.     (pack f :side "right" :fill 'y)
  78.  
  79.     ;; Assign slots
  80.     (slot-set! self 'Id     (Id s))
  81.     (slot-set! self 'sample f)
  82.     (slot-set! self 'scale  s)
  83.  
  84.     ;; Drag & Drop
  85.     (let ((ad    (address-of self))
  86.       (color (read-from-string (text-of s))))
  87.       (drag&drop-configure f 
  88.            :package-command (format #f "package-color (background (sample ~S))"
  89.                     ad)
  90.            :source-handler  '(color dd-send-color))
  91.       (drag&drop-configure s 
  92.            :package-command (format #f "package-number (value ~S)" ad)
  93.            :source-handler  '(number dd-send-number)
  94.            :target-handler  `(number 
  95.                       (set! (value ,ad)
  96.                         (hash-table-get DragDrop 'number)))))))
  97.  
  98. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99. ;;;;
  100. ;;;; procedure to change (fg or bg) color of a window and its descendants
  101. ;;;;
  102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  103. (define (change-color widgets foreground)
  104.   (let* ((rgb  (winfo 'rgb *root* (hash-table-get DragDrop 'color "")))
  105.      (newR (quotient (car rgb)   256))
  106.      (newG (quotient (cadr rgb)  256))
  107.      (newB (quotient (caddr rgb) 256))
  108.      (actR (- newR 20))
  109.      (actG (- newG 20))
  110.      (actB (- newB 20))
  111.      (ncolor   (string-append "#" (hexa newR) (hexa newG) (hexa newB)))
  112.      (acolor   (string-append "#" (hexa actR) (hexa actG) (hexa actB))))
  113.       
  114.     (let ((change (lambda (win)
  115.             (if foreground 
  116.             (catch 
  117.              (set! (foreground win) ncolor)
  118.              (set! (active-foreground win) acolor))
  119.             (catch
  120.              (set! (background win) ncolor)
  121.              (set! (active-background win) acolor))))))
  122.  
  123.       (for-each (lambda (x) (change x)) widgets))))
  124.  
  125. ;;;; ----------------------------------------------------------------------
  126. ;;;; Main application window...
  127. ;;;; ----------------------------------------------------------------------
  128.  
  129. ;;;; main-sample
  130. (define main-sample (make <Label> :text "Color" :border-width 3 :relief "raised"))
  131.  
  132. (drag&drop-configure main-sample 
  133.              :package-command "package-color (format #f \"#~A~A~A\" 
  134.                                                           (hexa (value Red)) 
  135.                               (hexa (value Green)) 
  136.                               (hexa (value Blue)))"
  137.              :source-handler '(color dd-send-color)
  138.              :target-handler '(color (set-colors)))
  139.  
  140. ;;;; explanation
  141. (define explanation (make <Message> :font "-Adobe-times-medium-r-normal--*-120*"
  142.                       :aspect 200 
  143.                     :text 
  144. "Press the third mouse button over a slider or a color sample and drag the token window around.  When the token becomes raised, it is over a target window.  
  145. Release the mouse button to drop the token and transfer information.  If the transfer fails, a \"no\" symbol is drawn on the token window.
  146. Try the following:
  147. - Drop a number from one slider onto another
  148. - Drop a color sample onto the Foreground/Background targets
  149. - Drop one of the slider color samples onto the main sample
  150. - Drop tokens from one palette application onto another"))
  151.  
  152. ;;;; entry
  153. (define ent (make <Labeled-Entry> :title "Color Value:" 
  154.                   :border-width 2
  155.                     :relief "sunken"))
  156.  
  157. (drag&drop-configure ent 
  158.     :package-command "package-color (value ent) "
  159.     :source-handler  '(color   dd-send-color)
  160.     :target-handler  '(color   (set! (value ent) 
  161.                      (hash-table-get DragDrop 'color))))
  162.  
  163. (bind ent "<Key-Return>" '(hash-table-put! DragDrop 'color (value ent)))
  164.  
  165. ;;;; Red/Green/Blue
  166. (define Red   (make <Color-Scale> :text "Red"   :format "#~A0000"))
  167. (define Green (make <Color-Scale> :text "Green" :format "#00~A00"))
  168. (define Blue  (make <Color-Scale> :text "Blue"  :format "#0000~A"))
  169.  
  170. ;;;
  171. ;;; Overload the (setter value) of <Color-Scale> so that modification of aslider
  172. ;;; is reported to the main sample
  173. ;;;
  174. (define-method (setter value) ((s <Color-Scale>) v)
  175.   (let ((r (value Red))
  176.     (g (value Green))
  177.     (b (value Blue)))
  178.     (set! (background (sample s)) (format #f (format-of s) (hexa v)))
  179.     (set! (value      (scale-of  s)) v)
  180.     ;; Update main sample
  181.     (set! (background main-sample) (format #f "#~A~A~A" (hexa r) (hexa g) (hexa b)))
  182.     (set! (foreground main-sample) (if (> (+ r g b) 384) "black" "white"))))
  183.  
  184. ;;;;
  185. ;;;; Foreground/Background color inputs...
  186. ;;;;
  187. (define inputs (make <Frame>))
  188. (define bg     (make <Label>  :text "Background" 
  189.                        :parent inputs :border-width 3 :relief 'groove))
  190. (define fg     (make <Label>  :text "Foreground" 
  191.                   :parent inputs :border-width 3 :relief 'groove))
  192.  
  193. (drag&drop-configure bg :target-handler '(color (change-color *the-widgets* #f)))
  194. (drag&drop-configure fg :target-handler '(color (change-color *the-widgets* #t)))
  195.  
  196. ;;;; Quit
  197. (define quit   (make <Button> :text "Quit"
  198.                        :parent inputs :border-width 3 :command "exit"))
  199.  
  200. ;;;;
  201. ;;;; Pack all the widgets
  202. ;;;;
  203. (pack bg fg :side "left" :padx 5 :pady 5)
  204. (pack quit  :side "right" :padx 5 :pady 5)
  205.  
  206. (pack main-sample explanation  ent :expand #t :fill "both")
  207. (pack Red Green Blue :fill "both")
  208. (pack inputs :fill "x")
  209.  
  210. (wm 'minsize *root* 200 200)
  211. (wm 'maxsize *root* 1000 1000)
  212.  
  213. ;; List of widgets whose bg/fg is changed when a global change-color is done
  214. (define *the-widgets* (list explanation ent Red Green Blue inputs bg fg quit))
  215.  
  216. (set-colors)
  217.