if 0 {[Richard Suchenwirth] 2002-06-06 -- Here's a little Pachisi game (in Germany known as '''Mensch aergere dich nicht'''), featuring the classical board, a lightly animated die, and moving pieces. All dimensions are computed from the -size switch, so maybe change that to suit your likings. As usual, playing is left to the humans. See also [Tcl/Tk games], and enjoy! [WikiDbImage pachisi.jpg] ''MNO'' - This game is also known (in England at least) as [Ludo] } 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 [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 } ##################################### pack [pachisi .p -bg beige] ---- [Category Games]