Annotation of tclpuks/prgsrc/puks.tcl, revision 1.6
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.6 ! boris 12: # Channel to talk to the MCR device
! 13: set MCR 0
! 14: set MCR_DEVICE "/dev/ttyUSB0"
1.2 boris 15:
1.3 boris 16: # Mapping of MCR codes to keys: button(code)
1.2 boris 17: set buttoncode 256
18: for {set i 1} {$i <=8} {incr i} {
19: set button($buttoncode) $i
20: set buttoncode [expr $buttoncode*2]
21: }
22:
1.3 boris 23:
24: ##############################################################
1.6 ! boris 25: # Procedures for talking with MCR
1.3 boris 26: ##############################################################
27:
1.6 ! boris 28: # Open the given device for MCR. Return 0 if successful, 1 otherwise
! 29: proc open_mcr {device} {
! 30: global MCR
! 31: set result [catch {set MCR [open $device r+]} error]
1.3 boris 32: if {$result !=0} {
1.6 ! boris 33: .status.mcr configure -text $error
! 34: .status.mcr configure -fg red
1.3 boris 35: return $result
36: }
1.6 ! boris 37: fconfigure $MCR -blocking 0 -translation binary \
! 38: -encoding binary -buffering none
! 39: #-mode 57600,n,8,1
! 40: .status.mcr configure -text "Opened $device"
! 41: .status.mcr configure -fg black
1.3 boris 42:
1.6 ! boris 43: puts $MCR s
1.3 boris 44: after 200
1.6 ! boris 45: read $MCR
! 46: puts $MCR r
1.3 boris 47: after 200
1.6 ! boris 48: read $MCR
1.3 boris 49: return 0
50: }
51:
52:
53:
1.6 ! boris 54: # Return the list of key pressed or empty list
1.2 boris 55: proc readbuffer {} {
1.6 ! boris 56: global MCR button
! 57: set keys ""
! 58: set message [read $MCR 6]
! 59: while { [string length $message] > 0} {
! 60: binary scan $message b48 msg
! 61: .status.mcr -configure -text $msg
! 62: .status.mcr -configure -fg black
! 63: binary scan $message s key
! 64: set key [expr $key & 0xFFFF]
! 65: if {[catch {set key $button($key)}] == 0} {
! 66: lappend keys $key
! 67: }
! 68: set message [read $MCR 6]
1.2 boris 69: }
1.6 ! boris 70: return keys
! 71: }
! 72:
! 73: # Dialog for opening the device
! 74: proc open_mcr_dialog {} {
! 75: toplevel .mcr_dialog
! 76: label .mcr_dialog.label -text "Open MCR port:"
! 77: entry .mcr_dialog.entry -textvariable MCR_DEVICE
! 78: pack .mcr_dialog.label .mcr_dialog.entry
! 79: frame .mcr_dialog.buttons
! 80: pack .mcr_dialog.buttons
! 81: button .mcr_dialog.buttons.ok -command {
! 82: open_mcr $MCR_DEVICE
! 83: destroy .mcr_dialog
! 84: } -text OK
! 85: button .mcr_dialog.buttons.cancel -command {destroy .mcr_dialog}\
! 86: -text "Cancel"
! 87: pack .mcr_dialog.buttons.ok .mcr_dialog.buttons.cancel -side left
1.2 boris 88: }
89:
1.3 boris 90: ##############################################################
91: # Setup
92: ##############################################################
1.2 boris 93:
1.4 boris 94:
95:
96: # Main menu
97:
98: menu .mbar -type menubar -relief ridge -borderwidth 2
99: pack .mbar -fill x
100:
1.6 ! boris 101:
1.4 boris 102: menubutton .mbar.file -text File -menu .mbar.file.m -underline 0 \
103: -relief raised -borderwidth 2
104: pack .mbar.file -side left
105: set m [menu .mbar.file.m]
106: $m add command -label "Open" -state disabled
107: $m add command -label "Save as..." -state disabled
108: $m add command -label "Save" -state disabled
109: $m add separator
110: $m add command -label "Quit" -command exit
111:
112: menubutton .mbar.edit -text Edit -underline 0 -state disabled\
113: -relief raised -borderwidth 2
114: pack .mbar.edit -side left
1.6 ! boris 115:
! 116: menubutton .mbar.mcr -text "MCR" -menu .mbar.mcr.m -underline 0 \
! 117: -relief raised -borderwidth 2
! 118: pack .mbar.mcr -side left
! 119: set m [menu .mbar.mcr.m]
! 120: $m add command -label "Open MCR" -command open_mcr_dialog
1.4 boris 121:
122: menubutton .mbar.help -text Help -menu .mbar.help.m -underline 0\
123: -relief raised -borderwidth 2
124: pack .mbar.help -side right
125: set m [menu .mbar.help.m]
126: $m add command -label "About..." -command {
127: tk_dialog .about "About Puks" \
128: "Система управления кнопками.
129: (C) Teytelman, 2002 (MCR code)
130: (C) Boris Veytsman, 2005 (Tcl/Tk version)"\
131: info 0 "OK"}
132:
133:
134: #Teams
135: frame .teams
136: pack .teams -side top
137: for {set i 0} {$i < 8} {incr i} {
138: frame .teams.frame($i)
139: pack .teams.frame($i) -side top -fill x
140: label .teams.frame($i).button -text 0
141: pack .teams.frame($i).button -side left
142: entry .teams.frame($i).name -width 60 -textvariable name($i)
143: pack .teams.frame($i).name -side left
144: entry .teams.frame($i).score -width 6 -textvariable score($i)
145: pack .teams.frame($i).score -side left
146: }
147:
1.5 boris 148:
149: # Question weight
150: frame .weight
151: set weight 1
152: set doubled 0
153: pack .weight -side top -fill x
154: label .weight.label -text "Цена вопроса"
155: entry .weight.weight -textvariable weight -width 3
156: checkbutton .weight.doubled -variable doubled
157: label .weight.label2 -text "x2"
158: pack .weight.label .weight.weight .weight.doubled .weight.label2 -side left
159:
160: # Buttons and timer
161: frame .control
162: pack .control -side top -fill x
163: frame .control.buttons
164: pack .control.buttons -side left -fill y
165:
166: button .control.buttons.assign -text "Assign Buttons" -underline 0 -state disabled
167: pack .control.buttons.assign -fill both -side top
168: bind Button <a> {.control.buttons.assign invoke}
169:
170: button .control.buttons.start -text Start -underline 0 -command "puts A"
171: pack .control.buttons.start -fill both -side top
172: bind Button <s> {.control.buttons.start invoke}
173:
174: button .control.buttons.stop -text Stop -underline 1 -command "puts B" -state disabled
175: pack .control.buttons.stop -fill both -side top
176: bind Button <t> {.control.buttons.stop invoke}
177:
178: button .control.buttons.reset -text "Reset scores" -underline 0 -state disabled
179: pack .control.buttons.reset -fill both -side top
180: bind Button <r> {.control.buttons.reset invoke}
181:
182:
183:
184: option add *timer.font -*-palatino-*-r-normal--*-1200-*-*-*-*-*-* widgetDefault
185: label .control.timer -text 0 -border 5 -relief raised -borderwidth 2
186: pack .control.timer -side left -expand 1 -fill x
187:
188: # Status line
189: frame .status -relief sunk -borderwidth 2
190: pack .status -side top -fill x
191: label .status.mcr -relief ridge -text "Not connected" -fg red -width 48
192: pack .status.mcr -side left -fill x
193: label .status.state -relief ridge -text "Idle"
194: pack .status.state -side left -fill x
195:
196:
1.4 boris 197: # button .start -text "Start" -command start
198: # pack .start
199: # label .pressed
200: # pack .pressed
1.2 boris 201:
202:
203: proc start {} {
204: global SRLFILE state idle waiting
205: readbuffer
206: .start configure -state disabled -command {}
207: set state $waiting
208: }
209:
210: proc body {} {
211: global state idle waiting
212: update idletasks
213: if { $state == $waiting } {
214: set pressed [readbuffer]
215: if { $pressed != 0 } {
1.3 boris 216: # set state $idle
217: # .start configure -state active -command start
1.2 boris 218: .pressed configure -text "Pressed $pressed"
219: puts $pressed
220: readbuffer }
221: } else {
222: readbuffer
223: }
224: after 10 body
225: }
226:
1.4 boris 227: #body
1.2 boris 228:
229:
230:
231:
232:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to puks.tcl CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Local Repository] / tclpuks / prgsrc