Annotation of tclpuks/prgsrc/puks.tcl, revision 1.4
1.2 boris 1: #!/usr/bin/wish
2:
1.3 boris 3: ##############################################################
4: # Global flags and variables
5: ##############################################################
6:
7: # Flags
8: set waiting_for_key 0
9: set question_asked 0
10: set timer_started 0
1.2 boris 11:
1.3 boris 12: # Channel to talk to the MRC device
13: set MRC 0
1.2 boris 14:
1.3 boris 15: # Mapping of MCR codes to keys: button(code)
1.2 boris 16: set buttoncode 256
17: for {set i 1} {$i <=8} {incr i} {
18: set button($buttoncode) $i
19: set buttoncode [expr $buttoncode*2]
20: }
21:
1.3 boris 22:
23: ##############################################################
24: # Procedures for talking with MRC
25: ##############################################################
26:
27: # Open the given device for MRC. Return 0 if successful, 1 otherwise
28: proc open_mrc {device} {
29: global MRC
30: set result [catch {set MRC [open $device r+]}]
31: if {$result !=0} {
32: return $result
33: }
34: fconfigure $MRC -blocking 0 -translation binary \
35: -encoding binary -buffering none -mode 57600,n,8,1
36:
37: puts $MRC s
38: after 200
39: read $MRC
40: puts $MRC r
41: after 200
42: read $MRC
43: return 0
44: }
45:
46:
47:
48: # Return the key pressed or 0
1.2 boris 49: proc readbuffer {} {
1.3 boris 50: global MRC button
1.2 boris 51: set key 0
1.3 boris 52: set message [read $MRC]
1.2 boris 53: binary scan $message s key
54: set key [expr $key & 0xFFFF]
55: if {[catch {set key $button($key)}] == 0} {
56: return $key
57: }
58: return 0
59: }
60:
1.3 boris 61: ##############################################################
62: # Setup
63: ##############################################################
1.2 boris 64:
1.4 ! boris 65:
! 66:
! 67: # Main menu
! 68:
! 69: menu .mbar -type menubar -relief ridge -borderwidth 2
! 70: pack .mbar -fill x
! 71:
! 72: menubutton .mbar.file -text File -menu .mbar.file.m -underline 0 \
! 73: -relief raised -borderwidth 2
! 74: pack .mbar.file -side left
! 75: set m [menu .mbar.file.m]
! 76: $m add command -label "Open" -state disabled
! 77: $m add command -label "Save as..." -state disabled
! 78: $m add command -label "Save" -state disabled
! 79: $m add separator
! 80: $m add command -label "Quit" -command exit
! 81:
! 82: menubutton .mbar.edit -text Edit -underline 0 -state disabled\
! 83: -relief raised -borderwidth 2
! 84: pack .mbar.edit -side left
! 85:
! 86: menubutton .mbar.help -text Help -menu .mbar.help.m -underline 0\
! 87: -relief raised -borderwidth 2
! 88: pack .mbar.help -side right
! 89: set m [menu .mbar.help.m]
! 90: $m add command -label "About..." -command {
! 91: tk_dialog .about "About Puks" \
! 92: "Система управления кнопками.
! 93: (C) Teytelman, 2002 (MCR code)
! 94: (C) Boris Veytsman, 2005 (Tcl/Tk version)"\
! 95: info 0 "OK"}
! 96:
! 97:
! 98: #Teams
! 99: frame .teams
! 100: pack .teams -side top
! 101: for {set i 0} {$i < 8} {incr i} {
! 102: frame .teams.frame($i)
! 103: pack .teams.frame($i) -side top -fill x
! 104: label .teams.frame($i).button -text 0
! 105: pack .teams.frame($i).button -side left
! 106: entry .teams.frame($i).name -width 60 -textvariable name($i)
! 107: pack .teams.frame($i).name -side left
! 108: entry .teams.frame($i).score -width 6 -textvariable score($i)
! 109: pack .teams.frame($i).score -side left
! 110: }
! 111:
! 112: # button .start -text "Start" -command start
! 113: # pack .start
! 114: # label .pressed
! 115: # pack .pressed
1.2 boris 116:
117:
118: proc start {} {
119: global SRLFILE state idle waiting
120: readbuffer
121: .start configure -state disabled -command {}
122: set state $waiting
123: }
124:
125: proc body {} {
126: global state idle waiting
127: update idletasks
128: if { $state == $waiting } {
129: set pressed [readbuffer]
130: if { $pressed != 0 } {
1.3 boris 131: # set state $idle
132: # .start configure -state active -command start
1.2 boris 133: .pressed configure -text "Pressed $pressed"
134: puts $pressed
135: readbuffer }
136: } else {
137: readbuffer
138: }
139: after 10 body
140: }
141:
1.4 ! boris 142: #body
1.2 boris 143:
144:
145:
146:
147:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>