package require Tk
package require nx::trait

::nx::Slot method type=expr {name value} {return [expr $value]}

nx::Class create Figure {
    :property canvas:required
    :property x:double
    :property y:double
    :property size:double
    :property position:integer
    :property color
    :property no:integer
    :property board:object,required
    :variable tag ""

    :require trait nx::trait::callback

    :method init {} {
        #
        # Draw figure and define interactions
        #
        set d [expr {${:size}/6.}]
        set s [expr {${:size}/1.5}]
        set y [expr {${:y}-$d*2.5}]
        set :tag ${:color}${:no}
        set id [${:canvas} create arc [expr {${:x}-$s}] [expr {${:y}-$s}] \
                    [expr {${:x}+$s}] [expr {${:y}+$s}] -outline grey \
                    -start 250 -extent 40 -fill ${:color} \
                    -tags [list mv ${:tag}]]
        ${:canvas} create oval \
            [expr {${:x}-$d}] [expr {${:y}-$d}] \
            [expr {${:x}+$d}] [expr {${:y}+$d}] \
            -fill ${:color} -outline grey -tags [list mv ${:tag}]
        #${:board} figure set $id [self]
        ${:canvas} bind ${:tag} <B1-ButtonRelease> [:callback go]
    }

    :public method go {} {
        #
        # Start moving the figure if the draw is permitted.
        # The board knows the die and the rules.
        #
        if {![${:board} moveFigure [self]]} {
            # stay at old position
            :gotoNr ${:position}
        }
    }

    :public method gotoNr {nr {-path ""} {-afterCmd ""}} {
        #
        # Move figure to the numbered position. If a path is given it
        # moves stepwise from position to position.
        #
        set oldPos ${:position}
        set :position $nr
        if {$path eq ""} {set path $nr}
        return [:move {*}[${:board} getPointCenter $oldPos] $path \
                    -afterCmd $afterCmd]
    }

    :protected method move {x0 y0 path:integer,1..n {-afterCmd ""}} {
        #
        # Move figure from old position (x0 y0) stepwise along the
        # path using animation. At the end of the move, 'afterCmd' is
        # issued.
        #
        set t 0
        foreach pos $path {
            lassign [${:board} getPointCenter $pos] x y
            set stepx [expr {($x-$x0)/50.0}]
            set stepy [expr {($y-$y0)/50.0}]
            for {set i 0} {$i < 50} {incr i} {
                after [incr t 8] ${:canvas} move ${:tag} $stepx $stepy
            }
            lassign [list $x $y] x0 y0
            incr t 100
        }
        after $t ${:canvas} raise ${:tag}
        after $t $afterCmd
        set :x $x; set :y $y
    }

    :public object method lookup {position} {
        #
        # Return the figure at the provided position.  This function
        # could be made faster, but is efficient enough as it is.
        #
        foreach f [Figure info instances] {
            if {[$f cget -position] == $position} {
                return $f
            }
        }
        return ""
    }
}

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
}

nx::Class create Die {
    :property canvas:required
    :property x:double
    :property y:double
    :property {size:double 25}
    :property {fg gold}
    :property {bg red}
    :property {eyes 0}

    :require trait nx::trait::callback

    :method set {n} {
        #
        # Set the eyes of the die.
        #
        ${:canvas} 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] {
            ${:canvas} itemconfig ${:id}$i -fill ${:fg} -outline ${:fg}
        }
        set :eyes $n
    }

    :public method invalidate {} {
        #
        # Invalidate the eyes to avoid double uses of the eyes.
        #
        set :eyes 0
    }

    :public method roll {} {
        #
        # Roll the dice and animate rolling
        #
        # wiggle: amount, pick one of eight wiggle directions
        set dwig [expr {${:size}/5}]
        for {set i 10} {$i<100} {incr i 10} {
            :set [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 ,]]
            ${:canvas} move group${:id} {*}$wig
            update
            set wig [lexpr \$i*-1 $wig] ;# wiggle back
            ${:canvas} move group${:id} {*}$wig
            after $i
        }
    }

    :method init {} {
        #
        # initialize the widgets with tags interactions
        #
        set x [expr {${:x} - ${:size}/2.0}]
        set y [expr {${:y} - ${:size}/2.0}]
        set :id [${:canvas} create rect $x $y \
                     [expr {$x+${:size}}] [expr {$y+${:size}}] \
                     -fill ${:bg} -tags mvg]
        set :grouptag group${:id}
        ${:canvas} addtag ${:grouptag} withtag ${:id}
        set ex [expr {$x+${:size}/10.}]
        set ey [expr {$y+${:size}/10.}]
        set d  [expr {${:size}/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}]] {
                ${:canvas} create oval $x $y [expr {$x+$d}] [expr {$y+$d}] \
                    -fill ${:bg} -outline ${:bg} \
                    -tags [list mvg ${:grouptag} ${:id}d$dotno]
                incr dotno
            }
        }
        :set [expr {int(rand()*6)+1}]
        :invalidate
        #
        # To dice, let people click on the die, or press <d> on the
        # board
        #
        ${:canvas} bind mvg <1> [:callback roll]
        bind . <d> [:callback roll]
    }
}

nx::Class create Board {
    :property canvas:required
    :property {size:integer 25}
    :property {bg LightBlue1}
    :property {fg white}
    :property {colors:1..n {red green yellow blue}}

    :require trait nx::trait::callback

    :method lookup {var idx} {
        #
        # Convenience lookup function for arbitrary instance
        # variables.
        #
        set key "${var}($idx)"
        if {[info exists $key]} {return [set $key]}
        return ""
    }

    :public method getPointCenter {nr} {:lookup :pointCenter $nr}
    :public method getPointId {nr}     {:lookup :pointId $nr}

    :method line {
        x0:expr,convert y0:expr,convert x1:expr,convert y1:expr,convert
        {-width 1} {-arrow none}
    } {
        #
        # Convenience function for line drawing, evaluates passed
        # expressions.
        #
        ${:canvas} create line $x0 $y0 $x1 $y1 -width $width -arrow $arrow
    }

    :method point {x:expr,convert y:expr,convert d {-number:switch false} -fill} {
        #
        # Draw a point (a position on the game board) and keep its
        # basic data in instance variables. We could as well turn the
        # positions into objects.
        #
        if {![info exists fill]} {set fill ${:fg}}
        incr :pointCounter
        set id [${:canvas} create oval \
                    [expr {$x-$d/2.}] [expr {$y-$d/2.}] \
                    [expr {$x+$d/2.}] [expr {$y+$d/2.}] \
                    -fill $fill -tags [list point] -outline brown -width 2]
        #${:canvas} create text $x $y -text ${:pointCounter} -fill grey
        set :pointNr($id) ${:pointCounter}
        set :pointCenter(${:pointCounter}) [list $x $y]
        set :pointId(${:pointCounter}) $id
        return ${:pointCounter}
    }

    :method fpoint {x:expr,convert y:expr,convert psize fsize color no} {
        #
        # Draw a point with a figure, note the position in the board
        # in the figure
        #
        set nr [:point $x $y $psize -fill $color]
        Figure new -board [self] -canvas ${:canvas} \
            -x $x -y [expr {$y-$fsize/2.0}] \
            -size $fsize -color $color -no $no -position $nr
        return $nr
    }

    :method pnest {x:expr,convert y:expr,convert d colorNr xf yf} {
        #
        # Draw the nest with the figures in it
        #
        set fsize [expr {$d/0.75}]
        set color [lindex ${:colors} $colorNr]
        lappend :nest($colorNr) [:fpoint $x-$d $y-$d $d $fsize $color 0]
        lappend :nest($colorNr) [:fpoint $x-$d $y+$d $d $fsize $color 1]
        lappend :nest($colorNr) [:fpoint $x+$d $y-$d $d $fsize $color 2]
        lappend :nest($colorNr) [:fpoint $x+$d $y+$d $d $fsize $color 3]
        set :buttonPos($colorNr) [list [expr $x+($xf*$d)] [expr $y+($yf*$d)]]
    }

    :method pline {
        x0:expr,convert y0:expr,convert
        x1:expr,convert y1:expr,convert d {-width 1} {-arrow none}
    } {
        #
        # Draw a path of the play-field with points (potential player
        # positions) on it.
        #
        set id [${:canvas} create line $x0 $y0 $x1 $y1 \
                    -width $width -arrow $arrow -fill brown]
        if {$x0 eq $x1} {
            # vertical
            set f [expr {$y1<$y0 ? -1.25 : 1.25}]
            for {set i 0} {$i < int(abs($y1-$y0)/($d*1.25))} {incr i} {
                :point $x0 $y0+$i*$d*$f $d
            }
        } else {
            # horizontal
            set f [expr {$x1<$x0 ? -1.25 : 1.25}]
            for {set i 0} {$i < int(abs($x1-$x0)/($d*1.25))} {incr i} {
                :point $x0+$i*$d*$f $y0 $d -number
            }
        }
        ${:canvas} lower $id
    }

    :method draw {m} {
        #
        # Draw board and create figures
        #
        set d ${:size}
        set u [expr {$d * 1.25}]
        #
        # Major positions: p0 .. p1 ..m.. p2 .. p3
        #
        set p0 [expr {$u-$d/2.0}]
        set p1 [expr {$m-$u}]
        set p2 [expr {$m+$u}]
        set p3 [expr {2*$m-$u+$d/2}]

        :pline $p0 $p1 $p1 $p1 $d -width 4
        :pline $p1 $p1 $p1 $p0 $d -width 4
        :pline $p1 $p0 $p2 $p0 $d -width 4 ;# horizonal short line
        :pline $p2 $p0 $p2 $p1 $d -width 4
        :pline $p2 $p1 $p3 $p1 $d -width 4
        :pline $p3 $p1 $p3 $p2 $d -width 4 ;# vertical short line
        :pline $p3 $p2 $p2 $p2 $d -width 4
        :pline $p2 $p2 $p2 $p3 $d -width 4
        :pline $p2 $p3 $p1 $p3 $d -width 4 ;# horizonal short line
        :pline $p1 $p3 $p1 $p2 $d -width 4
        :pline $p1 $p2 $p0 $p2 $d -width 4
        :pline $p0 $p2 $p0 $p1 $d -width 4 ;# vertical short line
        :line $m+5*$d  $m+2*$d  $m+6*$d  $m+2*$d -arrow first
        :line $m-2*$d  $m+5*$d  $m-2*$d  $m+6*$d -arrow first
        :line $m-5*$d  $m-2*$d  $m-6*$d  $m-2*$d -arrow first
        :line $m+2*$d  $m-5*$d  $m+2*$d  $m-6*$d -arrow first

        set d2 [expr {$d*0.75}]
        set d15 $d2*2
        set o [expr {$u*5}]
        :pnest $m+$o-$d $m-$o+$d $d2 0 -1  3
        :pnest $m+$o-$d $m+$o-$d $d2 1 -1 -2.5
        :pnest $d15     $m+$o-$d $d2 2  1 -2.5
        :pnest $d15     $m-$o+$d $d2 3  1  3
        for {set i 0; set y [expr $d*2]} {$i<4} {incr i;set y [expr {$y+$d}]} {
            lappend p(0) [:point $m      $y      $d2 -fill [lindex ${:colors} 0]]
            lappend p(1) [:point $m*2-$y $m      $d2 -fill [lindex ${:colors} 1]]
            lappend p(2) [:point $m      $m*2-$y $d2 -fill [lindex ${:colors} 2]]
            lappend p(3) [:point $y      $m      $d2 -fill [lindex ${:colors} 3]]
        }
        #
        # Setup the path per player and color the starting points
        #
        for {set i 1} {$i < 41} {incr i} {lappend path $i}
        foreach c {0 1 2 3} pos {11 21 31 1} o {11 21 31 1} {
            ${:canvas} itemconfig [:getPointId $pos] -fill [lindex ${:colors} $c]
            set :path($c) [concat [lrange $path $o-1 end] [lrange $path 0 $o-2] $p($c)]
        }
    }

    :public method msg {text} {
        #
        # Report a message to the user.
        #
        ${:canvas} itemconfig ${:msgId} -text $text
        return 0
    }

    :public method wannaGo {obj pos {-path ""}} {
        #
        # We know that we can move the figure in principle.  We have
        # to check, whether the target position is free. If the target
        # is occupied by our own player, we give up, otherwise we
        # through the opponent out.
        #
        if {$pos eq ""} {return [:msg "beyond path"]}
        set other [Figure lookup $pos]
        set afterCmd ""
        if {$other ne ""} {
            if {[$obj cget -color] eq [$other cget -color]} {
                # On player can't have two figure at the same place.
                return [:msg "My player is already at pos $pos"]
            } else {
                # Opponent is at the target position. Find a free
                # position in the opponents nest and though her out.
                set opponent [$other cget -color]
                foreach p [set :nest([lsearch ${:colors} $opponent])] {
                    if {[Figure lookup $p] eq ""} {
                        set afterCmd [list $other gotoNr $p]
                        break
                    }
                }
            }
        }
        :msg "[$obj cget -color]-[$obj cget -no] went to $pos"
        $obj gotoNr $pos -path $path -afterCmd $afterCmd
        ${:die} invalidate
    }

    :public method moveFigure {obj} {
        #
        # Move the provided figure by the diced eyes according to the
        # rules. First we check, if we are allowed to move this
        # figure, which might be in the nest or on the run.
        #
        set currentColor [lindex ${:colors} ${:player}]
        if {[$obj cget -color] ne $currentColor} {
            return [:msg "figure is not from the current player"]
        }
        set eyes [${:die} cget -eyes]
        if {$eyes == 0} {
            return [:msg "Must dice first"]
        }
        set position [$obj cget -position]
        if {$position in [set :nest(${:player})]} {
            # Figure is in the nest, just accept eyes == 6
            if {$eyes == 6} {
                :wannaGo $obj [lindex [set :path(${:player})] 0]
            } else {
                return [:msg "Need 6 to move this figure"]
            }
        } else {
            #
            # Check, if we have still figures in the nest
            #
            set inNest ""
            foreach p [set :nest(${:player})] {
                set inNest [Figure lookup $p]
                if {$inNest ne ""} break
            }
            #
            # Check, if the actual figure is at the start position.
            #
            set startPos [lindex [set :path(${:player})] 0]
            set atStart [Figure lookup $startPos]
            if {$eyes == 6} {
                if {$inNest ne ""} {
                    # Move a figure out from the nest, if we can
                    if {$atStart ne ""} {
                        if {[$atStart cget -color] eq $currentColor} {
                            set path [set :path(${:player})]
                            set current [lsearch $path $position]
                            set targetPos [expr {$current + [${:die} cget -eyes]}]
                            :wannaGo $obj [lindex $path $targetPos] \
                                -path [lrange $path $current+1 $targetPos]
                            return 1
                        }
                    }
                    return [:msg "You have to move the figures from your nest first"]
                }
            }
            if {$atStart ne "" && $inNest ne "" && $obj ne $atStart} {
                return [:msg "You have to move the figures from the start first"]
            }
            set path [set :path(${:player})]
            set current [lsearch $path $position]
            set targetPos [expr {$current + [${:die} cget -eyes]}]
            :wannaGo $obj [lindex $path $targetPos] \
                -path [lrange $path $current+1 $targetPos]
        }
        return 1
    }

    :public method nextPlayer {} {
        #
        # Switch to the next player.
        #
        set :player [expr {(${:player}+1) % 4}]
        ${:canvas} coords ${:buttonWindow} {*}[set :buttonPos(${:player})]
    }

    :method init {} {
        set hw [expr {14 * ${:size}}]
        set center [expr {$hw / 2}]
        canvas ${:canvas} -bg ${:bg} -height $hw -width $hw
        :draw $center
        set :die [Die new -canvas ${:canvas} -x $center -y $center -size ${:size}]
        set :msgId [${:canvas} create text [expr {${:size}*4}] 10 -text ""]
        #
        # Player management (signal which player is next, etc.)
        #
        set :player 2
        button .b1 -text "Done" -command [:callback nextPlayer]
        set :buttonWindow [.p create window 22 14 -window .b1]
        :nextPlayer
        bind . <n> [:callback nextPlayer]
    }
}

Board new -canvas .p -bg beige -size 40
pack .p