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
  NextPlayer