package require Tk
proc pachisi {w args} {
array set opts {
-size 25 -bg LightBlue1 -fg white -colors {red green yellow blue}
}
array set opts $args
set hw [expr 14*$opts(-size)]
canvas $w -bg $opts(-bg) -height $hw -width $hw
set m [expr $hw/2]
set d $opts(-size)
set x [expr $d * 1.25]
set x0 $x
set y [expr $d * 1.25]
$w create line $x0 [expr $m-$y] [expr $m-$x0] [expr $m-$y] -width 2
$w create line $x0 [expr $m+$y] [expr $m-$x0] [expr $m+$y] -width 2
$w create line [expr $m+$x0] [expr $m-$y] [expr 2*$m-$x0] [expr $m-$y]\
-width 2
$w create line [expr $m+$x0] [expr $m+$y] [expr 2*$m-$x0] [expr $m+$y]\
-width 2
$w create line [expr $m-$y] $x0 [expr $m-$y] [expr $m-$x0] -width 2
$w create line [expr $m+$y] $x0 [expr $m+$y] [expr $m-$x0] -width 2
$w create line [expr $m-$y] [expr $m+$x0] [expr $m-$y] [expr 2*$m-$x0]\
-width 2
$w create line [expr $m+$y] [expr $m+$x0] [expr $m+$y] [expr 2*$m-$x0]\
-width 2
$w create line [expr $y-$d/2] [expr $m-$d] [expr $y-$d/2] [expr $m+$d]\
-width 2
$w create line [expr $m*2-$y+$d/2] [expr $m-$d] [expr $m*2-$y+$d/2]\
[expr $m+$d] -width 2
$w create line [expr $m-$d] [expr $y-$d/2] [expr $m+$d] [expr $y-$d/2]\
-width 2
$w create line [expr $m-$d] [expr $m*2-$y+$d/2] [expr $m+$d]\
[expr $m*2-$y+$d/2] -width 2
$w create line [expr $m+5*$d] [expr $m+2*$d] [expr $m+6*$d]\
[expr $m+2*$d] -arrow first
$w create line [expr $m-2*$d] [expr $m+5*$d] [expr $m-2*$d]\
[expr $m+6*$d] -arrow first
$w create line [expr $m-5*$d] [expr $m-2*$d] [expr $m-6*$d]\
[expr $m-2*$d] -arrow first
$w create line [expr $m+2*$d] [expr $m-5*$d] [expr $m+2*$d]\
[expr $m-6*$d] -arrow first
foreach i {1 2 3 4 5} {
point8 $w $m $x $y $d $opts(-fg)
set x [expr $x+$d*1.25]
}
set x [expr $x-$d*1.25]
set y 0
point8 $w $m $x $y $d $opts(-fg)
set xm [expr $x+$m]
set co $opts(-colors)
set d2 [expr $d*0.75]
set d15 $d2*2
pnest $w $m+$x-$d $d15 $d2 [lindex $co 0]
pnest $w $m+$x-$d $m+$x-$d $d2 [lindex $co 1]
pnest $w $d15 $m+$x-$d $d2 [lindex $co 2]
pnest $w $d15 $m-$x+$d $d2 [lindex $co 3]
for {set i 0;set y [expr $d*2]} {$i<4} {incr i;set y [expr $y+$d]} {
point $w $m $y $d2 [lindex $co 0]
point $w $m*2-$y $m $d2 [lindex $co 1]
point $w $m $m*2-$y $d2 [lindex $co 2]
point $w $y $m $d2 [lindex $co 3]
}
$w itemconfig [$w find closest [expr $m+$d] $d] -fill [lindex $co 0]
$w itemconfig [$w find closest $xm [expr $m+$d]] -fill [lindex $co 1]
$w itemconfig [$w find closest [expr $m-$d] $xm] -fill [lindex $co 2]
$w itemconfig [$w find closest $d [expr $m-$d]] -fill [lindex $co 3]
set mvbody {set g(x) [@w canvasx %x]; set g(y) [@w canvasy %y]}
regsub -all @w $mvbody $w mvbody
$w bind mv <1> $mvbody
canvas:die $w [expr $m-12.5] [expr $m-12.5]
set w
}
proc pnest {w x y d color} {
set fsize [expr $d/0.75]
fpoint $w [expr $x-$d] [expr $y-$d] $d $fsize $color 1
fpoint $w [expr $x-$d] [expr $y+$d] $d $fsize $color 2
fpoint $w [expr $x+$d] [expr $y-$d] $d $fsize $color 3
fpoint $w [expr $x+$d] [expr $y+$d] $d $fsize $color 4
}
proc fpoint {w x y psize fsize fg no} {
point $w $x $y $psize $fg
figure $w $x $y $fsize $fg $no
}
proc point {w x y d fg} {
$w create oval [expr $x-$d/2.] [expr $y-$d/2.] \
[expr $x+$d/2.] [expr $y+$d/2.] -fill $fg
}
proc point8 {w m x y d fg} {
point $w $m+$x $m+$y $d $fg
point $w $m+$x $m-$y $d $fg
point $w $m-$x $m+$y $d $fg
point $w $m-$x $m-$y $d $fg
point $w $m+$y $m+$x $d $fg
point $w $m+$y $m-$x $d $fg
point $w $m-$y $m+$x $d $fg
point $w $m-$y $m-$x $d $fg
}
proc figure {w x y size color no} {
set d [expr $size/6.]
set s $size/1.5
set y [expr $y-$d*2.5]
$w create arc [expr $x-$s] [expr $y-$s] [expr $x+$s] [expr $y+$s]\
-start 250 -extent 40 -fill $color -tags [list mv $color$no]
$w create oval [expr $x-$d] [expr $y-$d] [expr $x+$d] [expr $y+$d]\
-fill $color -tags [list mv $color$no]
$w bind $color$no <B1-Motion> [list figure:move $w $color$no %x %y]
}
proc figure:move {w tag x y} {
global g
set x0 [$w canvasx $x]; set y0 [$w canvasy $y]
$w move $tag [expr $x0-$g(x)] [expr $y0-$g(y)]
$w raise $tag
set g(x) $x0; set g(y) $y0
}
proc canvas:die {w x y args} {
upvar #0 g opt
array set opt {-size 25 -fg gold -bg red -mayroll 1}
array set opt $args
set s $opt(-size)
set id [$w create rect $x $y [expr $x+$s] [expr $y+$s] \
-fill $opt(-bg) -tags mvg]
set ::g($id,fg) $opt(-fg)
set ::g($id,bg) $opt(-bg)
set grouptag group$id
$w addtag $grouptag withtag $id
set ex [expr $x+$s/10.]
set ey [expr $y+$s/10.]
set d [expr $s/5.];# dot diameter
set dotno 1 ;# dot counter
foreach y [list $ey [expr $ey+$d*1.5] [expr $ey+$d*3]] {
foreach x [list $ex [expr $ex+$d*1.5] [expr $ex+$d*3]] {
$w create oval $x $y [expr $x+$d] [expr $y+$d] \
-fill $opt(-bg) -outline $opt(-bg) \
-tags [list mvg $grouptag ${id}d$dotno]
incr dotno
}
}
$w bind mvg <1> {cdie:roll %W [%W find withtag current]}
cdie:set $w $id [expr int(rand()*6)+1]
set id
}
proc cdie:set {w id n} {
set bg $::g($id,bg)
foreach i [$w gettags $id] {
if [regexp group $i] {set grouptag $i;break}
}
$w itemconfig $grouptag -fill $bg -outline $bg
foreach i [lindex [list \
{} {d5} [random:select {{d3 d7} {d1 d9}}] \
[random:select {{d1 d5 d9} {d3 d5 d7}}] \
{d1 d3 d7 d9} {d1 d3 d5 d7 d9} \
[random:select {{d1 d3 d4 d6 d7 d9} {d1 d2 d3 d7 d8 d9}}] \
] $n] {
$w itemconfig $id$i -fill $::g($id,fg) -outline $::g($id,fg)
}
set ::g($id) $n
}
proc cdie:roll {w id} {
# wiggle: amount, pick one of eight wiggle directions
set dwig [expr $::g(-size)/5]
regexp {group([0-9]+)} [$w gettags $id] -> id
for {set i 10} {$i<100} {incr i 10} {
cdie:set $w $id [expr int(rand()*6)+1]
set wig [random:select {0,1 0,-1 1,0 -1,0 1,1 -1,1 1,-1 -1,-1}]
set wig [lexpr \$i*$dwig [split $wig ,]]
eval $w move group$id $wig
update
set wig [lexpr \$i*-1 $wig] ;# wiggle back
eval $w move group$id $wig
after $i
}
}
proc random:select L {lindex $L [expr int(rand()*[llength $L].)]}
proc lexpr {term L} {
# map an expr term to each element \$i of a list
set res [list]
foreach i $L {lappend res [eval expr $term]}
set res
}
proc NextPlayer {} {
#: Move Turn-Marker-Button to position of next player
incr ::pos 1
switch -- $::pos {
1 { .p coords $::bw 35 95; .b1 config -fg blue }
2 { .p coords $::bw 253 36; .b1 config -fg red }
3 { .p coords $::bw 305 255; .b1 config -fg green4 }
4 { .p coords $::bw 92 305; .b1 config -fg yellow1 ; set ::pos 0 }
default { set ::pos 0 }
}
}
pack [pachisi .p -bg beige]
button .b1 -text "Done" -command {NextPlayer}
set bw [.p create window 22 14 -window .b1]
set pos 0
NextPlayerHJG 2007-07-13 Added a turnmarker, to show which player has his turn to do.
