Return to puks.tcl CVS log

Up to [Local Repository] / tclpuks / prgsrc

Added some mcr menus

    1: #!/usr/bin/wish
    2: 
    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
   11: 
   12: # Channel to talk to the MCR device
   13: set MCR 0
   14: set MCR_DEVICE "/dev/ttyUSB0"
   15: 
   16: #  Mapping of MCR codes to keys:  button(code)
   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: 
   23: 
   24: ##############################################################
   25: #  Procedures for talking with MCR
   26: ##############################################################
   27: 
   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] 
   32:     if {$result !=0} {
   33: 	.status.mcr configure -text $error
   34: 	.status.mcr configure -fg red
   35: 	return $result
   36:     }
   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
   42:     
   43:     puts $MCR s
   44:     after 200
   45:     read $MCR
   46:     puts $MCR r
   47:     after 200
   48:     read $MCR
   49:     return 0
   50: }
   51:     
   52: 
   53: 
   54: # Return the list of key pressed or empty list
   55: proc readbuffer {} {
   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]
   69:     }
   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
   88: }
   89: 
   90: ##############################################################
   91: #   Setup
   92: ##############################################################
   93: 
   94: 
   95: 
   96: # Main menu
   97: 
   98: menu .mbar -type menubar -relief ridge -borderwidth 2
   99: pack .mbar -fill x
  100: 
  101: 
  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
  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
  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: 
  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: 
  197: #  button .start -text "Start" -command start
  198: #  pack .start
  199: #  label .pressed 
  200: #  pack .pressed
  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 } {
  216: #	    set state $idle
  217: #	    .start configure -state active -command start
  218: 	    .pressed configure -text "Pressed $pressed"
  219: 	    puts $pressed
  220: 	    readbuffer	}
  221:     } else {
  222: 	readbuffer
  223:     }
  224:     after 10 body
  225: }
  226: 
  227: #body 
  228: 
  229: 
  230: 
  231: 
  232: