[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]. [WikiDbImage tksoroban.jpg] ---- [Jeff Smith] Below is an online demo using [CloudTk] <> <> ---- 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 } main ====== ---- [Things Japanese] | [Arts and crafts of Tcl-Tk programming] <> Application | Toys