Domino
Richard Suchenwirth 2004-11-14 - Domino is a popular game. In this weekend fun project, I wanted to have it in Tcl/Tk too.
The real multiplayer game can't be implemented, as there's no way for one player to see a piece, while another doesn't - but at least one can use this for mathematical games with dominoes, as described in Martin Gardner's "Mathematical Circus". Drag a piece with left mouse button down, rotate it (counterclockwise 90 degrees) with right-click.
package require Tk
namespace eval domino {
variable bg black fg white size 30
#-- "Visual" definition of dot patterns - "sugared lists"
variable pattern
array set pattern {
0 {0 0 0
0
0 0 0}
1 {0 0 0
1
0 0 0}
2 {1 0 0
0
0 0 1}
3 {1 0 0
1
0 0 1}
4 {1 0 1
0
1 0 1}
5 {1 0 1
1
1 0 1}
6 {1 1 1
0
1 1 1}
}
variable points {1 1 1 2 1 3 2 2 3 1 3 2 3 3}
}This "constructor" creates a domino piece on the canvas w, landscape oriented, with top left corner at x/y and the specified two point values (0..6). For allowing motion, all canvas items belonging to a piece with values p|q are tagged with
- mv (so motion bindings have a common target)
- d-$p$q for unique identification (assuming no duplicate pieces)
The bd-$p$q tags aren't used yet - in future one might use them for reverting a piece, i.e. raising or lowering the rectangle.
proc domino::create {w x y val1 val2} {
variable bg; variable fg; variable size
set tags [list mv d-$val1$val2]
set x1 [expr {$x+$size-0.5}]
set y1 [expr {$y+$size}]
$w create rect $x $y [expr {$x+2*$size}] $y1 \
-fill $bg -tags [linsert $tags 0 bd-$val1$val2]
$w create line $x1 $y $x1 $y1 -fill $fg -tags $tags
dots $w $x $y $val1 $tags
dots $w [expr {$x+$size}] $y $val2 $tags
}Dots are drawn for a given value as ovals:
proc domino::dots {w x y val tags} {
variable fg; variable size; variable points; variable pattern
set d [expr {$size/4.}]
foreach bit $pattern($val) {y0 x0} $points {
if $bit {
$w create oval [expr {$x+($x0-0.5)*$d}] [expr {$y+($y0-0.5)*$d}] \
[expr {$x+($x0+0.5)*$d}] [expr {$y+($y0+0.5)*$d}] -fill $fg \
-tags $tags
}
}
}Pieces are rotated around the center of their bounding box with the usual "convert to polar coordinates, adjust angle, convert back to Cartesian coordinates" algorithm. Due to rounding problems, sometimes the line in the middle of a piece comes slightly crooked:
proc domino::rotate w {
foreach tag [$w gettags current] {
if [regexp ^(d-.+) $tag -> this] break
}
foreach {x0 y0 x1 y1} [$w bbox $this] break
set xm [expr {($x0+$x1)/2.}]
set ym [expr {($y0+$y1)/2.}]
set da [expr {acos(-1)/2.}]
foreach item [$w find withtag $this] {
set coords {}
foreach {x y} [$w coords $item] {
set r [expr {hypot($y-$ym, $x-$xm)}]
set a [expr {abs($x-$xm)<1e-17? 0:
atan2($y-$ym, $x-$xm)-$da}]
set x [expr {$xm+$r*cos($a)}]
set y [expr {$ym+$r*sin($a)}]
lappend coords $x $y
}
$w coords $item $coords
}
}Clicking on a piece records the click position, and its "catch-all" tag, in global variables:
proc mv'1 {w x y} {
set ::_x $x; set ::_y $y
foreach tag [$w gettags current] {
if [regexp ^(d-.+) $tag -> ::_tag] break
}
}Moving the mouse with button 1 down moves the items with the "catch-all" tag with the mouse pointer:
proc mv'motion {w x y} {
$w raise $::_tag
$w move $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}]
set ::_x $x; set ::_y $y
}
#-- The main routine makes a board and the classic 28 pieces:
pack [canvas .c -bg darkgreen -width 500 -height 350] -fill both -expand 1
for {set left 0} {$left<=6} {incr left} {
for {set right $left} {$right<=6} {incr right} {
domino::create .c [expr $left*65+10] [expr $right*35+100] $left $right
}
}
.c bind mv <1> {mv'1 %W %x %y}
.c bind mv <B1-Motion> {mv'motion %W %x %y}
.c bind mv <3> {domino::rotate %W}
#-- Little development helpers (optional):
bind . <Escape> {exec wish $argv0 &; exit}
bind . <F1> {console show}TV Well, could be fun, want to cooperate making a distributed version ? :) - RS: As most of my weekend projects happen on unconnected boxes at home, it would be hard for me. But a generic distributed-game concept might indeed be interesting - players having "views" (common, and private ones) on the game, and there is an independent "dealer" process to give Domino pieces (or cards) to players, into their private view. Having such a generic system, plugging in graphics fro different games might be easier than starting every game from scratch (although I love it how far one gets in Tcl, from scratch to a decent result, in a few hours... :^)
Pssst, Richard, you can do networked apps on a single machine - simply run it all on the same box! -jcw RS Indeed :) But my concern for this page was mostly how to draw the pieces, how to rotate them...
JSI If the orientation of the pieces is stored in variables (and it is, isn't it?) then maybe all we need here, is some tequila ;-)
LV Well, I don't know how many people are familar enough with tequila to know how to add its support into an application.
VK But is it possible to actually play domino, against computer? -
RS Should be - but that requires some more work :)
goldshell7,20060602 Fairly quick additions and changes will turn this TCL script into a refrigerator magnetic poetry with multicolored tiles. Below is changes with multicolor tiles as variable $jack and random poetry words as text variable $jill.
#start of deck
proc lpick L {lindex $L [expr int(rand()*[llength $L])]}
# lpick is reused Suchenworth subroutine
# add procedures poetry and lpick
proc poetry jill {
global jill
global jack
set jill [lpick { tree happy grass love swan home \
power loss dance rose joy hate juice kick}]
return $jill;
}
Following changes (only) to proc domino, rest of code same
global jill
global jack
set jack [lpick {red yellow blue purple \
pink green brown black gray}]
# set jill tester
$w create rect $x $y [expr {$x+2*$size}] $y1 \
-fill $jack -tags [linsert $tags 0 bd-$val1$val2]
$w create text [expr {$x+1*$size}] [expr {$y+0.5*$size }] \
-text [eval poetry $jill] -fill $fg -tags $tags
#domino & line creation ### commented out!!!!
#dots $w $x $y $val1 $tags
#dots $w [expr {$x+$size}] $y $val2 $tags
#options: might want to change refrigerator background
#to match home decor (white)
Eof mind blowing random color ($jack).
# pack [canvas .c -bg $jack -width 500 -height 350] -fill both -expand 1
global jill
global jack
pack [canvas .c -bg white -width 500 -height 350] -fill both -expand 1
# end of deck
# ps. Like to be able to select two tiles like in Mahjong
# and have the both selected tiles disappear,[ if equal color,
# equal number, or zero sum.]
# select button -command (destroy two selected tiles if equal?)