Updated 2012-05-13 05:10:52 by RLE

Richard Suchenwirth 2003-07-16 - This educational Tcltoy, as usual runnable on PocketPC and elsewhere, simulates a soroban (Japanese "calculating board" or "abacus"), most easily used for addition. See Martin Gardner's "Mathematical Circus" for details. For another mathematical toy, see A little slide-rule.

``` set about "TkSoroban
R.Suchenwirth 2003

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.
``` 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.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
if [regexp ,5 [\$w gettags \$bead]] {
} else {
}
}
}
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```

Things Japanese | Arts and crafts of Tcl-Tk programming