home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.0-b / stk-3 / blt-for-STk-3.0 / Demos / palette.stk < prev    next >
Encoding:
Text File  |  1995-12-26  |  10.8 KB  |  314 lines
  1. ;;;; ----------------------------------------------------------------------
  2. ;;;;  PURPOSE:  color palette (demo for drag&drop facilities)
  3. ;;;;
  4. ;;;;   AUTHOR:  Michael J. McLennan       Phone: (215)770-2842
  5. ;;;;            AT&T Bell Laboratories   E-mail: aluxpo!mmc@att.com
  6. ;;;;
  7. ;;;; Rewritten for STk by Erick Gallesio
  8. ;;;;    Creation date:  6-Jul-1994 09:53
  9. ;;;; Last file update: 27-Dec-1995 00:06
  10. ;;;; ----------------------------------------------------------------------
  11. ;;;;            Copyright (c) 1993  AT&T  All Rights Reserved
  12. ;;;; ======================================================================
  13.  
  14. (set! *load-path* (cons ".." *load-path*))
  15. (require "blt")
  16. (require "dd-protocol")
  17.  
  18. (define DragDrop (make-hash-table))
  19. (define Red         0)
  20. (define Green       0)
  21. (define Blue        0)
  22.  
  23. ;;;; ----------------------------------------------------------------------
  24. ;;;; Routines for packaging token windows...
  25. ;;;; ----------------------------------------------------------------------
  26. (define (package-color color win)
  27.   (when (null? (winfo 'children win))
  28.     (pack (label (& win ".label") :text "Color")) :side "top")
  29.  
  30.   (let* ((rgb (winfo 'rgb *root* color))
  31.      (r   (quotient (car rgb)   256))
  32.      (g   (quotient (cadr rgb)  256))
  33.      (b   (quotient (caddr rgb) 256)))
  34.     
  35.     (tk-set! (string->widget (& win ".label")) :background color)
  36.     (tk-set! (string->widget (& win ".label")) :foreground (if (> (+ r g b) 384) "black" "white")))
  37.   color)
  38.  
  39. (define (package-number num win)
  40.   (when (null? (winfo 'children win))
  41.     (pack (label (& win ".label") :text "")) :side "top")
  42.  
  43.   (tk-set! (string->widget (& win ".label"))
  44.        :text (format #f "Number: ~A" (* num 1)))
  45.   num)
  46.  
  47. (define (package-text text win)
  48.   (when (null? (winfo 'children win))
  49.     (pack (label (& win ".label") :text "" :width 30)) :side "top")
  50.  
  51.   (tk-set! (string->widget (& win ".label")) :text (format #f "Text: ~A" text))
  52.   text)
  53.  
  54.  
  55. ;;;; ----------------------------------------------------------------------
  56. ;;;; Actions to handle color data...
  57. ;;;; ----------------------------------------------------------------------
  58. (define (hexa n)
  59.   (string-append (number->string (quotient n 16) 16) 
  60.          (number->string (modulo n 16) 16)))
  61.  
  62. (define (set-color . args)
  63.   (let ((rgb (winfo 'rgb *root* (hash-table-get DragDrop 'color ""))))
  64.     (if (or (null? args) (eq? (car args) 'red))
  65.     (set-red  (quotient (car rgb)   256)))
  66.     (if (or (null? args) (eq? args 'green))
  67.     (set-green  (quotient (cadr rgb)   256)))
  68.     (if (or (null? args) (eq? args 'blue))
  69.     (set-blue  (quotient (caddr rgb)   256)))))
  70.  
  71. (define (bg-color win)
  72.   (when (widget? win)
  73.     (let* ((rgb  (winfo 'rgb *root* (hash-table-get DragDrop 'color "")))
  74.        (newR (quotient (car rgb)   256))
  75.        (newG (quotient (cadr rgb)  256))
  76.        (newB (quotient (caddr rgb) 256))
  77.        (actR (- newR 20))
  78.        (actG (- newG 20))
  79.        (actB (- newB 20))
  80.        (ncolor   (string-append "#" (hexa newR) (hexa newG) (hexa newB)))
  81.        (acolor   (string-append "#" (hexa actR) (hexa actG) (hexa actB)))
  82.        (children (winfo 'children win))
  83.        (win-name (widget->string win)))
  84.  
  85.       (if (and (not (string-find? "sample" win-name)) 
  86.            (not (string=? win-name "*root*")))
  87.       (catch (begin
  88.            (tk-set! win :background ncolor)
  89.            (tk-set! win :activebackground acolor))))
  90.  
  91.       (for-each (lambda (x) (if (winfo 'exists x) (bg-color  x)))
  92.         (if (list? children) children (list children))))))
  93.  
  94.  
  95. (define (fg-color win)
  96.   (when (widget? win)
  97.     (let* ((rgb  (winfo 'rgb *root* (hash-table-get DragDrop 'color "")))
  98.        (newR (quotient (car rgb)   256))
  99.        (newG (quotient (cadr rgb)  256))
  100.        (newB (quotient (caddr rgb) 256))
  101.        (actR (- newR 20))
  102.        (actG (- newG 20))
  103.        (actB (- newB 20))
  104.        (ncolor   (string-append "#" (hexa newR) (hexa newG) (hexa newB)))
  105.        (acolor   (string-append "#" (hexa actR) (hexa actG) (hexa actB)))
  106.        (children (winfo 'children win))
  107.        (win-name  (widget->string win)))
  108.  
  109.       (if (and (not (string-find? "sample" win-name)) 
  110.            (not (string=? win-name "*root*")))
  111.       (catch (begin
  112.            (tk-set! win :foreground ncolor)
  113.            (tk-set! win :activeforeground acolor))))
  114.  
  115.       (for-each (lambda (x) (if (winfo 'exists x) (fg-color x)))
  116.         (if (list? children) children (list children))))))
  117.  
  118.  
  119. ;;;; ----------------------------------------------------------------------
  120. ;;;; Setting color samples...
  121. ;;;; ----------------------------------------------------------------------
  122.  
  123. (define (update-main-sample)
  124.   (let ((color (string-append "#" (hexa Red) (hexa Green) (hexa Blue))))
  125.     (tk-set! .sample :background color)
  126.     (tk-set! .sample :foreground (if (> (+ Red Green Blue) 384) "black" "white"))))
  127.  
  128.  
  129. (define (set-red val)
  130.   (set! Red val)
  131.   (.red.cntl 'set val)
  132.   (tk-set! .red.sample :background (string-append "#" (hexa val) "0000"))
  133.   (update-main-sample))
  134.  
  135. (define (set-green val)
  136.   (set! Green val)
  137.   (.green.cntl 'set val)
  138.   (tk-set! .green.sample :background (string-append "#00" (hexa val) "00"))
  139.   (update-main-sample))
  140.  
  141. (define (set-blue val)
  142.   (set! Blue val)
  143.   (.blue.cntl 'set val)
  144.   (tk-set! .blue.sample :background (string-append "#0000" (hexa val)))
  145.   (update-main-sample))
  146.  
  147. ;;;; ----------------------------------------------------------------------
  148. ;;;; Main application window...
  149. ;;;; ----------------------------------------------------------------------
  150. (label '.sample :text "Color" :borderwidth 3 :relief 'raised)
  151.  
  152. (blt_drag&drop 'source .sample 'config
  153.            :packagecmd (lambda (w)
  154.                  (package-color (format #f "#~A~A~A" 
  155.                             (hexa Red) 
  156.                             (hexa Green) 
  157.                             (hexa Blue))
  158.                         w)))
  159.  
  160. (blt_drag&drop 'source .sample 'handler 'color 'dd-send-color)
  161. (blt_drag&drop 'target .sample 'handler 'color 'set-color)
  162.  
  163. (message '.explanation :font "-Adobe-times-medium-r-normal--*-120*"
  164.                 :aspect 200 
  165.                :text 
  166. "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.  
  167. Release the mouse button to drop the token and transfer information.  If the transfer fails, a \"no\" symbol is drawn on the token window.
  168. Try the following:
  169. - Drop a number from one slider onto another
  170. - Drop a color sample onto the Foreground/Background targets
  171. - Drop one of the slider color samples onto the main sample
  172. - Drop tokens from one palette application onto another")
  173.  
  174.  
  175. ;;;;
  176. ;;;; Color value entry...
  177. ;;;;
  178. (frame '.value :borderwidth 3)
  179. (label '.value.l :text "Color Value:")
  180. (entry '.value.e :borderwidth 2 :relief "sunken" :bg "white")
  181. (pack .value.l :side "left")
  182. (pack .value.e :side "left" :expand #t :fill 'x)
  183.  
  184. (blt_drag&drop 'source .value.e 'config
  185.            :packagecmd (lambda (w) (package-color (.value.e 'get) w)))
  186. (blt_drag&drop 'source .value.e 'handler 'color 'dd-send-color)
  187.  
  188. (blt_drag&drop 'target .value.e 'handler
  189.            'number '(begin
  190.               (.value.e 'delete 0 'end)
  191.               (.value.e 'insert 0 (hash-table-get DragDrop 'number)))
  192.            'color  '(begin
  193.               (.value.e 'delete 0 'end)
  194.               (.value.e 'insert 0 (hash-table-get DragDrop 'color))))
  195.  
  196. (bind .value.e "<Key-Return>" '(hash-table-put! DragDrop 
  197.                         'color 
  198.                         (.value.e 'get)))
  199.  
  200.  
  201. ;;;;
  202. ;;;; Red slider...
  203. ;;;;
  204. (frame '.red :borderwidth 3 :relief "raised")
  205. (scale '.red.cntl :label "Red" :orient "horiz" :from 0 :to 255 :command 'set-red)
  206. (frame '.red.sample :width 20 :height 20 :borderwidth 3 :relief "raised")
  207. (pack .red.cntl :side "left" :expand #t :fill 'x)
  208. (pack .red.sample :side "right" :fill 'y)
  209.  
  210.  
  211. (blt_drag&drop 'source '.red.sample 'config
  212.            :packagecmd (lambda (w)
  213.                  (package-color (format #f "#~A0000" (hexa Red)) w)))
  214. (blt_drag&drop 'source '.red.sample 'handler 'color 'dd-send-color)
  215.  
  216. (blt_drag&drop 'target '.red.sample 'handler 
  217.            'number '(set-red (hash-table-get DragDrop 'number))
  218.            'color  '(set-color 'red))
  219.  
  220. (blt_drag&drop 'source '.red.cntl 'config 
  221.            :packagecmd (lambda (w)
  222.                  (package-number [.red.cntl 'get] w)))
  223. (blt_drag&drop 'source '.red.cntl 'handler 'number 'dd-send-number)
  224.  
  225. (blt_drag&drop 'target .red.cntl 'handler
  226.            'number '(set-red (hash-table-get DragDrop 'number))
  227.            'color  '(set-color 'red))
  228.  
  229. ;;;;
  230. ;;;; Green slider...
  231. ;;;;
  232. (frame '.green :borderwidth 3 :relief "raised")
  233. (scale '.green.cntl :label "Green" :orient "horiz" :from 0 :to 255 :command 'set-green)
  234. (frame '.green.sample :width 20 :height 20 :borderwidth 3 :relief "raised")
  235. (pack .green.cntl :side "left" :expand #t :fill 'x)
  236. (pack .green.sample :side "right" :fill 'y)
  237.  
  238.  
  239. (blt_drag&drop 'source '.green.sample 'config
  240.            :packagecmd (lambda (w)
  241.                  (package-color (format #f "#00~A00" (hexa Green)) w)))
  242. (blt_drag&drop 'source '.green.sample 'handler 'color 'dd-send-color)
  243.  
  244. (blt_drag&drop 'target '.green.sample 'handler 
  245.            'number '(set-green (hash-table-get DragDrop 'number))
  246.            'color  '(set-color 'green))
  247.  
  248. (blt_drag&drop 'source '.green.cntl 'config 
  249.            :packagecmd (lambda (w)
  250.                  (package-number [.green.cntl 'get] w)))
  251. (blt_drag&drop 'source '.green.cntl 'handler 'number 'dd-send-number)
  252.  
  253. (blt_drag&drop 'target .green.cntl 'handler
  254.            'number '(set-green (hash-table-get DragDrop 'number))
  255.            'color  '(set-color 'green))
  256.  
  257.  
  258. ;;;;
  259. ;;;; Blue slider...
  260. ;;;;
  261. (frame '.blue :borderwidth 3 :relief "raised")
  262. (scale '.blue.cntl :label "Blue" :orient "horiz" :from 0 :to 255 :command 'set-blue)
  263. (frame '.blue.sample :width 20 :height 20 :borderwidth 3 :relief "raised")
  264. (pack .blue.cntl :side "left" :expand #t :fill 'x)
  265. (pack .blue.sample :side "right" :fill 'y)
  266.  
  267.  
  268. (blt_drag&drop 'source '.blue.sample 'config
  269.            :packagecmd (lambda (w)
  270.                  (package-color (format #f "#0000~A" (hexa Blue)) w)))
  271. (blt_drag&drop 'source '.blue.sample 'handler 'color 'dd-send-color)
  272.  
  273. (blt_drag&drop 'target '.blue.sample 'handler 
  274.            'number '(set-blue (hash-table-get DragDrop 'number))
  275.            'color  '(set-color 'blue))
  276.  
  277. (blt_drag&drop 'source '.blue.cntl 'config 
  278.            :packagecmd (lambda (w) 
  279.                  (package-number [.blue.cntl 'get] w)))
  280. (blt_drag&drop 'source '.blue.cntl 'handler 'number 'dd-send-number)
  281.  
  282. (blt_drag&drop 'target .blue.cntl 'handler
  283.            'number '(set-blue (hash-table-get DragDrop 'number))
  284.            'color  '(set-color 'blue))
  285. ;;;;
  286. ;;;; Foreground/Background color inputs...
  287. ;;;;
  288. (frame '.inputs)
  289. (label '.inputs.bg :text "Background" :borderwidth 3 :relief 'groove)
  290. (label '.inputs.fg :text "Foreground" :borderwidth 3 :relief 'groove)
  291. (button '.inputs.quit :text "Quit" :borderwidth 3 :command "exit")
  292.  
  293. (blt_drag&drop 'target .inputs.bg 'handler 'color '(bg-color *root*))
  294. (blt_drag&drop 'target .inputs.fg 'handler 'color '(fg-color *root*))
  295.  
  296. (pack .inputs.fg .inputs.bg :side "left" :padx 5 :pady 5)
  297. (pack .inputs.quit :side "right" :padx 5 :pady 5)
  298.  
  299. (pack 'append  *root*
  300.       .sample "top expand fillx filly" 
  301.       .explanation "top expand fillx filly" 
  302.       .value "top fillx" 
  303.       .red "top fill" 
  304.       .green "top fill" 
  305.       .blue "top fill" 
  306.       .inputs "top fillx")
  307.  
  308. (wm 'minsize *root* 200 200)
  309. (wm 'maxsize *root* 1000 1000)
  310.  
  311. (set-red 0)
  312. (set-green 0)
  313. (set-blue 0)
  314.