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