examples/tcltk/fig16-12.scm

   1 #!/usr/bin/env gsi-script
   2
   3 ; File: "fig16-12.scm"
   4
   5 ; Copyright (c) 1997-2007 by Marc Feeley, All Rights Reserved.
   6
   7 ; Translation into Scheme of Figure 16.12 from Chapter 16 of John
   8 ; Ousterhout's "Tcl and the Tk Toolkit".
   9
  10 (include "tcltk#.scm") ; import Tcl/Tk procedures and variables
  11
  12 (load "tcltk")
  13
  14 (define (new-color value)
  15
  16   (define (get-number widget)
  17     (string->number (tcl widget 'get)))
  18
  19   (let ((color-code
  20          (number->string (+ (expt 2 24)
  21                             (* (expt 2 16) (get-number ".red"))
  22                             (* (expt 2 8) (get-number ".green"))
  23                             (get-number ".blue"))
  24                          16)))
  25     (string-set! color-code 0 #\#)
  26     (tcl ".sample" 'configure background: color-code)))
  27
  28 (scale ".red"
  29        label: "Red"
  30        from: 0
  31        to: 255
  32        length: "10c"
  33        orient: 'horizontal
  34        command: new-color)
  35
  36 (scale ".green"
  37        label: "Green"
  38        from: 0
  39        to: 255
  40        length: "10c"
  41        orient: 'horizontal
  42        command: new-color)
  43
  44 (scale ".blue"
  45        label: "Blue"
  46        from: 0
  47        to: 255
  48        length: "10c"
  49        orient: 'horizontal
  50        command: new-color)
  51
  52 (frame ".sample" height: "1.5c" width: "6c")
  53
  54 (pack ".red" ".green" ".blue" side: 'top)
  55
  56 (pack ".sample" side: 'bottom pady: "2m")
  57
  58
  59 ; ==> Equivalent program in pure Tcl/Tk:
  60 ;
  61 ; scale .red -label Red -from 0 -to 255 -length 10c \
  62 ;       -orient horizontal -command newColor
  63 ; scale .green -label Green -from 0 -to 255 -length 10c \
  64 ;       -orient horizontal -command newColor
  65 ; scale .blue -label Blue -from 0 -to 255 -length 10c \
  66 ;       -orient horizontal -command newColor
  67 ; frame .sample -height 1.5c -width 6c
  68 ; pack .red .green .blue -side top
  69 ; pack .sample -side bottom -pady 2m
  70 ;
  71 ; proc newColor value {
  72 ;   set color [format #%02x%02x%02x [.red get] [.green get] [.blue get]]
  73 ;   .sample configure -background $color
  74 ; }