set about "TkSoroban
R.Suchenwirth 2003
Powered by Tcl/Tk!
Not a game, but a Japanese abacus (calculator).
Tap on a bead to move it. Beads count if they touch (directly or indirectly) the middle bar.
Top beads count 5." 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
}
mainThings Japanese | Arts and crafts of Tcl-Tk programming
