examples/tcltk/fig16-17.scm

   1 #!/usr/bin/env gsi-script
   2
   3 ; File: "fig16-17.scm"
   4
   5 ; Copyright (c) 1997-2007 by Marc Feeley, All Rights Reserved.
   6
   7 ; Translation into Scheme of Figure 16.17 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 (undo)   (display "undo")   (newline))
  15 (define (redo)   (display "redo")   (newline))
  16 (define (delete) (display "delete") (newline))
  17 (define (copy)   (display "copy")   (newline))
  18
  19 (frame ".mbar" relief: 'raised bd: 2)
  20 (frame ".dummy" width: "10c" height: "5c")
  21
  22 (pack ".mbar" ".dummy" side: 'top fill: 'x)
  23
  24 (menubutton ".mbar.file" text: "File" underline: 0)
  25 (menu ".mbar.file.menu")
  26 (tcl ".mbar.file" 'configure menu: ".mbar.file.menu")
  27
  28 (menubutton ".mbar.edit" text: "Edit" underline: 0)
  29 (menu ".mbar.edit.menu")
  30 (tcl ".mbar.edit" 'configure menu: ".mbar.edit.menu")
  31
  32 (tcl ".mbar.edit.menu" 'add 'command label: "Undo" underline: 0
  33                        accelerator: "Ctrl-z" command: undo)
  34 (tcl ".mbar.edit.menu" 'add 'command label: "Redo" underline: 0
  35                        accelerator: "Ctrl-r" command: redo)
  36 (tcl ".mbar.edit.menu" 'add 'separator)
  37 (tcl ".mbar.edit.menu" 'add 'command label: "Delete" underline: 0
  38                        accelerator: "Ctrl-x" command: delete)
  39 (tcl ".mbar.edit.menu" 'add 'command label: "Copy" underline: 0
  40                        accelerator: "Ctrl-c" command: copy)
  41
  42 (menubutton ".mbar.graphics" text: "Graphics" underline: 0)
  43 (menu ".mbar.graphics.menu")
  44 (tcl ".mbar.graphics" 'configure menu: ".mbar.graphics.menu")
  45
  46 (menubutton ".mbar.text" text: "Text" underline: 0)
  47 (menu ".mbar.text.menu")
  48 (tcl ".mbar.text" 'configure menu: ".mbar.text.menu")
  49
  50 (menubutton ".mbar.view" text: "View" underline: 0)
  51 (menu ".mbar.view.menu")
  52 (tcl ".mbar.view" 'configure menu: ".mbar.view.menu")
  53
  54 (menubutton ".mbar.help" text: "Help" underline: 0)
  55 (menu ".mbar.help.menu")
  56 (tcl ".mbar.help" 'configure menu: ".mbar.help.menu")
  57
  58 (pack ".mbar.file" ".mbar.edit" ".mbar.graphics" ".mbar.text" ".mbar.view" side: 'left)
  59 (pack ".mbar.help" side: 'right)
  60
  61 (focus ".mbar")
  62
  63
  64 ; ==> Equivalent program in pure Tcl/Tk:
  65 ;
  66 ; frame .mbar -relief raised -bd 2
  67 ; frame .dummy -width 10c -height 5c
  68 ; pack .mbar .dummy -side top -fill x
  69 ;
  70 ; menubutton .mbar.file -text File -underline 0 -menu .mbar.file.menu
  71 ; menubutton .mbar.edit -text Edit -underline 0 -menu .mbar.edit.menu
  72 ; menubutton .mbar.graphics -text Graphics -underline 0 \
  73 ;            -menu .mbar.graphics.menu
  74 ; menubutton .mbar.text -text Text -underline 0 -menu .mbar.text.menu
  75 ; menubutton .mbar.view -text View -underline 0 -menu .mbar.view.menu
  76 ; menubutton .mbar.help -text Help -underline 0 -menu .mbar.help.menu
  77 ;
  78 ; menu .mbar.file.menu
  79 ;
  80 ; menu .mbar.edit.menu
  81 ; .mbar.edit.menu add command -label "Undo" -underline 0 \
  82 ;                 -accelerator "Ctrl+z" -command undo
  83 ; .mbar.edit.menu add command -label "Redo" -underline 0 \
  84 ;                 -accelerator "Ctrl+r" -command redo
  85 ; .mbar.edit.menu add separator
  86 ; .mbar.edit.menu add command -label "Delete" -underline 0 \
  87 ;                 -accelerator "Ctrl+x" -command delete
  88 ; .mbar.edit.menu add command -label "Copy" -underline 0 \
  89 ;                 -accelerator "Ctrl+c" -command copy
  90 ;
  91 ; menu .mbar.graphics.menu
  92 ;
  93 ; menu .mbar.text.menu
  94 ;
  95 ; menu .mbar.view.menu
  96 ;
  97 ; menu .mbar.help.menu
  98 ;
  99 ; pack .mbar.file .mbar.edit .mbar.graphics .mbar.text .mbar.view -side left
 100 ; pack .mbar.help -side right
 101 ;
 102 ; focus .mbar
 103 ;
 104 ; proc undo {} {
 105 ;   puts "undo"
 106 ; }
 107 ;
 108 ; proc redo {} {
 109 ;   puts "redo"
 110 ; }
 111 ;
 112 ; proc delete {} {
 113 ;   puts "delete"
 114 ; }
 115 ;
 116 ; proc copy {} {
 117 ;   puts "copy"
 118 ; }