[BACK]Return to puks.tcl CVS log [TXT] [DIR] Up to [Local Repository] / tclpuks / prgsrc

Diff for /tclpuks/prgsrc/puks.tcl between versions 1.2 and 1.6

version 1.2, 2005/08/27 05:31:18 version 1.6, 2005/08/31 17:04:31
Line 1 Line 1
 #!/usr/bin/wish  #!/usr/bin/wish
 set DEVICE "/dev/ttyUSB0"  
   
 set SRLFILE [open $DEVICE r+]  
 fconfigure $SRLFILE -blocking 0  -translation binary -encoding binary -buffering none -mode  57600,n,8,1  
   
 set idle 0  
 set waiting 1  
   
 set state $idle  
   
   ##############################################################
   #    Global flags and variables
   ##############################################################
   
   # Flags
   set waiting_for_key 0
   set question_asked 0
   set timer_started 0
   
   # Channel to talk to the MCR device
   set MCR 0
   set MCR_DEVICE "/dev/ttyUSB0"
   
   #  Mapping of MCR codes to keys:  button(code)
 set buttoncode 256  set buttoncode 256
 for {set i 1} {$i <=8} {incr i} {  for {set i 1} {$i <=8} {incr i} {
     set button($buttoncode) $i      set button($buttoncode) $i
     set buttoncode [expr $buttoncode*2]      set buttoncode [expr $buttoncode*2]
 }  }
   
 proc readbuffer {} {  
     global SRLFILE  button  ##############################################################
     set key 0  #  Procedures for talking with MCR
     set message [read $SRLFILE]  ##############################################################
     binary scan $message s key  
     set key [expr $key & 0xFFFF]  # Open the given device for MCR.  Return 0 if successful, 1 otherwise
     if {[catch {set key $button($key)}] == 0} {  proc open_mcr {device} {
         return $key      global MCR
       set result [catch {set MCR [open $device r+]}  error] 
       if {$result !=0} {
           .status.mcr configure -text $error
           .status.mcr configure -fg red
           return $result
     }      }
       fconfigure $MCR -blocking 0  -translation binary \
           -encoding binary -buffering none 
   #-mode  57600,n,8,1
       .status.mcr configure -text "Opened $device"
       .status.mcr configure -fg black
       
       puts $MCR s
       after 200
       read $MCR
       puts $MCR r
       after 200
       read $MCR
     return 0      return 0
 }  }
       
   
   
   # Return the list of key pressed or empty list
   proc readbuffer {} {
       global MCR  button
       set keys ""
       set message [read $MCR 6]
       while { [string length $message] > 0} {
           binary scan $message b48 msg
           .status.mcr -configure -text $msg
           .status.mcr -configure -fg black
           binary scan $message s key 
           set key [expr $key & 0xFFFF]
           if {[catch {set key $button($key)}] == 0} {
               lappend keys $key
           }
           set message [read $MCR 6]
       }
       return keys
   }
   
   # Dialog for opening the device
   proc open_mcr_dialog {} {
       toplevel .mcr_dialog
       label .mcr_dialog.label -text "Open MCR port:"
       entry .mcr_dialog.entry -textvariable MCR_DEVICE
       pack .mcr_dialog.label .mcr_dialog.entry
       frame .mcr_dialog.buttons
       pack .mcr_dialog.buttons
       button .mcr_dialog.buttons.ok -command {
           open_mcr $MCR_DEVICE
           destroy .mcr_dialog
       } -text OK
       button .mcr_dialog.buttons.cancel -command {destroy .mcr_dialog}\
           -text "Cancel"
       pack .mcr_dialog.buttons.ok .mcr_dialog.buttons.cancel -side left
   }
   
   ##############################################################
   #   Setup
   ##############################################################
   
   
   
   # Main menu
   
   menu .mbar -type menubar -relief ridge -borderwidth 2
   pack .mbar -fill x
   
   
   menubutton .mbar.file -text File -menu .mbar.file.m -underline 0 \
           -relief raised -borderwidth 2
   pack .mbar.file -side left 
   set m [menu .mbar.file.m]
   $m add command -label "Open" -state disabled
   $m add command -label "Save as..." -state disabled
   $m add command -label "Save" -state disabled
   $m add separator
   $m add command -label "Quit" -command exit
   
   menubutton .mbar.edit -text Edit -underline 0 -state disabled\
           -relief raised -borderwidth 2
   pack .mbar.edit -side left
   
   menubutton .mbar.mcr -text "MCR" -menu .mbar.mcr.m -underline 0 \
       -relief raised -borderwidth 2
   pack .mbar.mcr -side left
   set m [menu .mbar.mcr.m]
   $m add command -label "Open MCR" -command open_mcr_dialog
   
   menubutton .mbar.help -text Help -menu .mbar.help.m -underline 0\
           -relief raised -borderwidth 2
   pack .mbar.help -side right
   set m [menu .mbar.help.m]
   $m add command -label "About..." -command {
       tk_dialog .about "About Puks" \
               "Система управления кнопками.
   (C) Teytelman, 2002 (MCR code)
   (C) Boris Veytsman, 2005 (Tcl/Tk version)"\
           info  0 "OK"}
       
   
   #Teams
   frame .teams 
   pack .teams -side top
   for {set  i 0} {$i < 8} {incr i} {
       frame .teams.frame($i) 
       pack .teams.frame($i) -side top -fill x
       label .teams.frame($i).button -text 0
       pack .teams.frame($i).button -side left
       entry .teams.frame($i).name -width 60 -textvariable name($i)
       pack .teams.frame($i).name -side left
       entry .teams.frame($i).score -width 6 -textvariable score($i)
       pack .teams.frame($i).score -side left
   }
   
   
 puts $SRLFILE s  # Question weight
 after 200  frame .weight
 readbuffer  set weight 1
 puts $SRLFILE r  set doubled 0
 after 200  pack .weight -side top -fill x
 readbuffer  label .weight.label -text "Цена вопроса"
   entry .weight.weight -textvariable weight -width 3
   checkbutton .weight.doubled -variable doubled
   label .weight.label2 -text "x2"
   pack .weight.label .weight.weight .weight.doubled .weight.label2 -side left
   
   # Buttons and timer
   frame .control
   pack .control -side top -fill x
   frame .control.buttons 
   pack .control.buttons -side left -fill y 
   
   button .control.buttons.assign -text "Assign  Buttons" -underline 0 -state disabled
   pack .control.buttons.assign -fill both  -side top 
   bind Button <a> {.control.buttons.assign invoke}
   
   button .control.buttons.start -text Start -underline 0 -command "puts A"
   pack .control.buttons.start -fill both  -side top 
   bind Button <s> {.control.buttons.start invoke}
   
   button .control.buttons.stop -text Stop -underline 1 -command "puts B" -state disabled
   pack .control.buttons.stop -fill both -side top 
   bind Button <t> {.control.buttons.stop invoke}
   
   button .control.buttons.reset -text "Reset scores" -underline 0 -state disabled
   pack .control.buttons.reset -fill both -side top 
   bind Button <r> {.control.buttons.reset invoke}
   
   
   
 button .start -text "Start" -command start  option add *timer.font  -*-palatino-*-r-normal--*-1200-*-*-*-*-*-* widgetDefault
 pack .start  label .control.timer -text 0 -border 5 -relief raised -borderwidth 2
 label .pressed   pack .control.timer -side left -expand 1 -fill x
 pack .pressed  
   # Status line
   frame .status -relief sunk -borderwidth 2
   pack .status -side top -fill x
   label .status.mcr -relief ridge -text "Not connected" -fg red -width 48
   pack .status.mcr -side left -fill x
   label .status.state -relief ridge -text "Idle" 
   pack .status.state -side left -fill x
   
   
   #  button .start -text "Start" -command start
   #  pack .start
   #  label .pressed 
   #  pack .pressed
   
   
 proc start {} {  proc start {} {
Line 56  proc body  {} { Line 213  proc body  {} {
     if { $state == $waiting } {      if { $state == $waiting } {
         set pressed [readbuffer]          set pressed [readbuffer]
         if { $pressed != 0 } {          if { $pressed != 0 } {
             set state $idle  #           set state $idle
             .start configure -state active -command start  #           .start configure -state active -command start
             .pressed configure -text "Pressed $pressed"              .pressed configure -text "Pressed $pressed"
             puts $pressed              puts $pressed
             readbuffer  }              readbuffer  }
Line 67  proc body  {} { Line 224  proc body  {} {
     after 10 body      after 10 body
 }  }
   
 body   #body 
   
   
   
Removed from v.1.2  
changed lines
  Added in v.1.6

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>