examples/tcltk/fig16-14.scm

   1 #!/usr/bin/env gsi-script
   2
   3 ; File: "fig16-14.scm"
   4
   5 ; Copyright (c) 1997-2007 by Marc Feeley, All Rights Reserved.
   6
   7 ; Translation into Scheme of Figure 16.14 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 bold      "bold")
  15 (define italic    "italic")
  16 (define underline "underline")
  17 (define font      "font")
  18
  19 (define (bullet)  (display "bullet")  (newline))
  20 (define (margins) (display "margins") (newline))
  21
  22 (menu ".m")
  23
  24 (tcl ".m" 'add 'checkbutton label: "Bold" variable: bold)
  25 (tcl ".m" 'add 'checkbutton label: "Italic" variable: italic)
  26 (tcl ".m" 'add 'checkbutton label: "Underline" variable: underline)
  27 (tcl ".m" 'add 'separator)
  28 (tcl ".m" 'add 'radiobutton label: "Times" variable: font value: "times")
  29 (tcl ".m" 'add 'radiobutton label: "Helvetica" variable: font value: "helvetica")
  30 (tcl ".m" 'add 'radiobutton label: "Courier" variable: font value: "courier")
  31 (tcl ".m" 'add 'separator)
  32 (tcl ".m" 'add 'command label: "Insert Bullet" command: bullet)
  33 (tcl ".m" 'add 'command label: "Margins and Tabs..." command: margins)
  34
  35 (set-variable! font "courier")
  36
  37 (tcl ".m" 'post 0 0)
  38
  39
  40 ; ==> Equivalent program in pure Tcl/Tk:
  41 ;
  42 ; menu .m
  43 ; .m add checkbutton -label Bold -variable bold
  44 ; .m add checkbutton -label Italic -variable italic
  45 ; .m add checkbutton -label Underline -variable underline
  46 ; .m add separator
  47 ; .m add radiobutton -label Times -variable font -value times
  48 ; .m add radiobutton -label Helvetica -variable font -value helvetica
  49 ; .m add radiobutton -label Courier -variable font -value courier
  50 ; .m add separator
  51 ; .m add command -label "Insert Bullet" -command bullet
  52 ; .m add command -label "Margins and Tabs..." -command margins
  53 ;
  54 ; set font courier
  55 ;
  56 ; proc bullet {} {
  57 ;   puts "bullet"
  58 ; }
  59 ;
  60 ; proc margins {} {
  61 ;   puts "margins"
  62 ; }
  63 ;
  64 ; .m post 0 0