Return to puks.tcl CVS log

Up to [Local Repository] / tclpuks / prgsrc

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: