package require Tk
 proc main {} {
    variable dx 20 dy 14 cols 10
    set w [expr $dx*($cols+2)]
    set h [expr $dy*9]
    pack [frame .f] -fill x
    label .f.res -textvar result -width 11 -bg white
    button .f.r -text Reset -command {reset .c}
    button .f.a -text About -command {tk_messageBox -message $about}
    button .f.x -text X -command exit
    eval pack [winfo chil .f] -side left
    pack [canvas .c -width $w -height $h]
    set x0 [expr $dy/4]
    set x1 [expr $w-$x0]
    .c create rect $x0 0 $x1 $h -fill {} -width $dy
    set yl [expr $dy*3]
    .c create line 0 $yl $w $yl -width $dy
    set x [expr $dx+2]
    for {set i 0} {$i<$cols} {incr i} {
        .c create line $x 0 $x $h -fill white -tag axis
        set y [expr $dy*5]
        foreach j {1 2 3 4} {
          .c create poly [hexagon $x $y $dx $dy] -fill yellow -outline black -tags "$i,$j bead"
          incr y $dy
        }
        .c create poly [hexagon $x $dy $dx $dy] -fill yellow -outline black -tags "$i,5 bead"
        .c create text $x $yl -fill white -text 0 -tag value$i
        set x [expr $x+$dx+2]
    }
    .c bind bead <1> {select %W}
    .c lower axis
 }
 proc reset w {
    variable dy
    foreach bead [$w find withtag bead] {
       if [isSet $w $bead] {
          $w itemconfig $bead -fill yellow
          if [regexp ,5 [$w gettags $bead]] {
            $w move $bead 0 -$dy
          } else {
            $w move $bead 0 $dy
          }
       }
    }
    redisplay $w
 }
 proc select w {
    set mv $::dy
    set id [$w find withtag current]
    set set [isSet $w $id]
    regexp {(.+),(.+)} [lindex [$w gettags $id] 0] -> col val
    if {$val==5} {
       set todo 5
       set mv -$mv
    } else {
       set littles {1 2 3 4}
       set pos [lsearch $littles $val]
       if !$set {
         set todo [lrange $littles 0 $pos]
       } else {
         set todo [lrange $littles $pos end]
       }
   }
   foreach i $todo {
      if $set {
         if [isSet $w $col,$i] {
            $w move $col,$i 0 $mv
            $w itemconf $col,$i -fill yellow
         }
      } else {
         if ![isSet $w $col,$i] {
            $w move $col,$i 0 [expr -$mv]
            $w itemconf $col,$i -fill green
         }
      }
   }
   redisplay $w
 }
 proc isSet {w id} {
    expr {[$w itemcget $id -fill] != "yellow"}
 }
 proc redisplay w {
    variable cols
    variable result 0
    for {set i 0} {$i<$cols} {incr i} {
       set n 0
       foreach j {1 2 3 4} {
          if [isSet $w $i,$j] {set n $j}
       }
       if [isSet $w $i,5] {incr n 5}
       $w itemconfig value$i -text $n
       set result [expr {$result*10+$n}]
    }
 }
 proc hexagon {x y dx dy} {
    set x0 [expr $x-$dx/2]
    set x1 [expr $x-$dx/7]
    set x2 [expr $x+$dx/7]
    set x3 [expr $x+$dx/2]
    set y0 [expr $y-$dy/2]
    set y1 [expr $y+$dy/2]
    list $x0 $y $x1 $y0 $x2 $y0 $x3 $y $x2 $y1 $x1 $y1
 }
 main