##+##########################################################################
#
# razzledazzle.tcl -- Simulation of the Razzle Dazzle carnival game
# by Keith Vetter 2019-04-22
#

package require Tk

set SCORE(score) 0
set SCORE(prizes) 1
set SCORE(cost) 1
set SCORE(cost,money) "\$1"
set SCORE(spent) 0
set SCORE(spent,money) "\$0"

set S(shuffle,rounds) 10
set S(shuffle,delay) 50

foreach font {titleFont scoreUFont scoreLFont boardFont} { catch { font delete $font }}
font create titleFont {*}[font actual TkDefaultFont] -size 48 -weight bold
font create scoreUFont {*}[font actual TkDefaultFont] -size 36 -weight bold
font create scoreLFont {*}[font actual TkDefaultFont] -size 12 -weight bold
font create boardFont {*}[font actual TkDefaultFont] -size 24 -weight bold

set CLRS(score,num) red
set CLRS(score,prize) green

# https://i.imgur.com/MTeyAL5.jpg
set SCORECARD {
    {{29 "PAY DOUBLE"} . . . . . . {29 "PAY DOUBLE"}}
    {{18 PRIZE} {42 "20 PTS"} {38 PRIZE} {15 "15 PTS"} {19 PRIZE} {41 "15 PTS"} {37 PRIZE} {14 "20 PTS"}}
    {{9 "100 PTS"} {28 } {48 "100 PTS"} {26 } {8 "100 PTS"} {30 } {47 "100 PTS"} {27 }}
    {{32 } {44 "50 PTS"} {25 } {13 "50 PTS"} {31 } {43 "50 PTS"} {24 } {12 "50 PTS"}}
    {{46 "50 PTS"} {34 } {11 "30 PTS"} {23 } {45 "30 PTS"} {33 } {10 "50 PTS"} {22 }}
    {{36 PRIZE} {16 "10 PTS"} {21 PRIZE} {40 "5 PTS"} {35 PRIZE} {17 "5 PTS"} {20 PRIZE} {39 "5 PTS"}}
}

# https://proxy.duckduckgo.com/iu/?u=https://tse4.mm.bing.net/th?id=OIP.UKwwWr7PWLV4ES_7cJXaigHaGD&pid=Api&f=1

# board:
# http://www.goodmagic.com/websales/midway/photos/razzle2.jpg
# https://youtu.be/527F51qTcTg?t=242

set BOARD {
    {4 3 2 4 1 3 2 3 6 4 5 3 4}
    {3 4 5 3 6 4 5 4 1 3 2 4 5}
    {4 3 2 4 1 3 2 3 6 4 5 3 4}
    {3 4 5 3 6 4 5 4 1 3 2 4 2}
    {4 3 2 4 1 3 2 3 6 4 5 3 4}
    {3 4 5 3 6 4 5 4 1 3 2 4 2}
    {4 3 2 4 1 3 2 3 6 4 5 3 4}
    {3 4 5 3 6 4 5 4 1 3 2 4 5}
    {4 3 2 4 1 3 2 3 6 4 5 3 4}
    {3 4 5 3 6 4 5 4 1 3 2 4 5}
    {4 3 2 4 1 3 2 3 6 4 5 3 4}
}

proc DoDisplay {} {
    wm title . "Razzle Dazzle"

    frame .play
    pack .play -side left -expand 1 -fill both
    DrawPlay .play

    frame .s
    pack .s -side top -fill both -expand 1
    DrawScoreCard .s

    frame .b
    pack .b -side top -fill both
    DrawBoard .b

}
proc DrawPlay {f} {

    canvas $f.c -width 200 -height 200 -bd 0 -highlightthickness 0
    MakeBall $f.c
    grid $f.c -row 0 -column 0 -columnspan 2 -pady 1i
    $f.c bind all <1> StartRoll
    $f.c bind all <ButtonRelease-1> EndRoll

    set data {
        1 score "Score so far:" ::SCORE(score)
        2 prizes "Prizes you can win:" ::SCORE(prizes)
        3 cost "Cost per roll:" ::SCORE(cost,money)
        4 spent "Money spent so far:" ::SCORE(spent,money)
        5 roll "Roll value:" ::SCORE(sum)
    }
    foreach {row w text var} $data {
        label $f.$w -text $text -font boardFont
        label $f.$w,2 -textvariable $var -font boardFont -width 4
        grid $f.$w $f.$w,2 -row $row -sticky e
    }
    label $f.msg -textvariable ::SCORE(msg) -font boardFont -fg red
    grid $f.msg -row 6 -columnspan 2 -sticky ew


    ::ttk::button .about -text About -command About
    grid rowconfigure $f 7 -weight 1
    grid .about -in $f -row 8 -columnspan 2 -sticky s -pady .2i
    FlashingLights
}
proc DrawBoard {f} {
    global BOARD
    $f config -bd 5 -relief solid
    for {set row 0} {$row < [llength $BOARD]} {incr row} {
        set ROW [lindex $BOARD $row]
        for {set col 0} {$col < [llength $ROW]} {incr col} {
            set value [lindex $ROW $col]
            set w "$f.b$row,$col"
            label $w -text $value -bd 1 -font boardFont -relief solid
            grid $w -row $row -column $col -sticky news
        }
    }
    grid columnconfigure $f all -uniform a -weight 1
}
proc DrawScoreCard {f} {
    destroy {*}[winfo child $f]
    $f config -bd 5 -relief solid
    for {set row 0} {$row < [llength $::SCORECARD]} {incr row} {
        set ROW [lindex $::SCORECARD $row]
        for {set col 0} {$col < [llength $ROW]} {incr col} {
            lassign [lindex $ROW $col] num text
            if {$num eq "."} continue
            set w $f.s$num
            if {[winfo exists $w]} { set w $f.ss$num }
            _ScoreCardCell $w $num $text
            grid $w -row $row -column $col -sticky news
        }
    }
    label $f.s -text "RAZZLE DAZZLE" -font titleFont -bd 1 -relief solid
    grid $f.s -row 0 -column 1 -columnspan 6 -sticky news
    grid columnconfigure $f all -uniform a
}
proc LightColor {} {
    # Pick random RGB color, convert to HSV and check V > .7
    set light [expr {255 * .7}]                 ;# Value threshold
    while {1} {
        set r [expr {int (255 * rand())}]
        set g [expr {int (255 * rand())}]
        set b [expr {int (255 * rand())}]
        set v [expr {max($r, $g, $b)}]
        if {$v > $light} break
    }
    return [format "\#%02x%02x%02x" $r $g $b]
}

proc _ScoreCardCell {w num text} {
    set clr black
    if {[string match {[0-9]*} $text]} { set clr $::CLRS(score,num) }
    if {$text eq "PRIZE"} { set clr $::CLRS(score,prize) }
    frame $w -bd 1 -relief solid
    label $w,u -text $num -font scoreUFont -fg $clr
    label $w,l -text $text -font scoreLFont -fg $clr
    pack $w,u $w,l -side top -fill both -expand 1 -in $w
    return $w
}

proc HighlightNumber {num} {
    foreach w [winfo child .s] {
        $w config -bg white
    }
    set w .s.s$num
    if {! [winfo exists $w]} { return "" }
    $w,u config -bg lightgreen
    $w,l config -bg lightgreen
    if {$num == 29} {
        set w .s.ss$num
        $w,u config -bg lightgreen
        $w,l config -bg lightgreen
    }
    return [$w,l cget -text]
}

proc Shuffle {l} {
    set len [llength $l]
    while {$len} {
        set n [expr {int($len*rand())}]
        set tmp [lindex $l $n]
        lset l $n [lindex $l [incr len -1]]
        lset l $len $tmp
    }
    return $l
}
proc RollingMarbles {action} {
    global S

    if {$action eq "stop"} {set S(shuffle,stop) 1}
    if {$S(shuffle,stop)} return

    if {$action eq "start"} {
        set S(shuffle,cells) [Shuffle [winfo child .b]]
        foreach cell $S(shuffle,cells) { $cell config -bg white }
        set S(shuffle,active) [lrange $S(shuffle,cells) 0 6]
        foreach cell $S(shuffle,active) { $cell config -bg red }
        set S(shuffle,idx) 6
    }
    incr S(shuffle,idx)
    if {$S(shuffle,idx) >= [llength $S(shuffle,cells)] - 8} return

    set cell [lindex $S(shuffle,cells) $S(shuffle,idx)]
    $cell config -bg red
    lappend S(shuffle,active) $cell

    if {[llength $S(shuffle,active)] > 8} {
        set cell [lindex $S(shuffle,active) 0]
        set S(shuffle,active) [lrange $S(shuffle,active) 1 end]
        $cell config -bg white
    }
    set values [lmap cell $S(shuffle,active) { $cell cget -text }]
    set ::SCORE(sum) [tcl::mathop::+ {*}$values]
    FlashingLights
    update
    after $S(shuffle,delay) RollingMarbles continue
}
proc FlashingLights {} {
    set color [LightColor]
    foreach w [concat .play [winfo child .play]] {
        $w config -background $color
    }
}
proc StartRoll {} {
    global SCORE S

    .play.c itemconfig txt -text "Let Go!"
    incr SCORE(spent) $SCORE(cost)
    set SCORE(spent,money) "\$$SCORE(spent)"
    set SCORE(msg) ""

    set S(shuffle,stop) 0
    RollingMarbles start
}
proc EndRoll {} {
    global S SCORE
    .play.c itemconfig txt -text "Press\nMe!"
    set S(shuffle,stop) 1
    set values [lmap cell $S(shuffle,active) { $cell cget -text }]
    set SCORE(sum) [tcl::mathop::+ {*}$values]

    set reward [HighlightNumber $SCORE(sum)]

    set SCORE(msg) "Nothing!  Roll again"
    if {$reward eq ""} return
    if {$reward eq "PRIZE"} {
        incr SCORE(prizes)
        set SCORE(msg) "Bonus Prize!"
    } elseif {$reward eq "PAY DOUBLE"} {
        incr SCORE(prizes)
        incr SCORE(cost) $SCORE(cost)
        set SCORE(cost,money) "\$$SCORE(cost)"
        set SCORE(msg) "Bonus Prize!\nDouble cost"
    } elseif {[regexp {(\d+) PTS} $reward . pts]} {
        incr SCORE(score) $pts
        set SCORE(msg) $reward
        if {$SCORE(score) >= 100} {
            tk_messageBox -icon info -message "You Win!"
            set SCORE(msg) "You Win!"
            set SCORE(score) 0
            set SCORE(prizes) 1
            set SCORE(cost) 1
            set SCORE(cost,money) "\$1"
            set SCORE(spent) 0
            set SCORE(spent,money) "\$0"
        }
    }
}
proc GradientSteps {n c1 c2} {
    # Get RGB in 0 to 255 range
    foreach var {r1 g1 b1 r2 g2 b2} v [concat [winfo rgb . $c1] [winfo rgb . $c2]] {
        set $var [expr {$v * 255 / 65535}]
    }

    set grad {}
    for {set i 0} {$i <= $n} {incr i} {
        set r [expr {int($r1 + (($r2 - $r1) * $i / double($n)))}]
        set g [expr {int($g1 + (($g2 - $g1) * $i / double($n)))}]
        set b [expr {int($b1 + (($b2 - $b1) * $i / double($n)))}]
        lappend grad [format "#%.2X%.2X%.2X" $r $g $b]
    }
    return $grad
}
proc MakeBall {c} {
    set n 90

    set steps [GradientSteps $n \#ddd blue]
    set centre 100
    $c create oval 10 10 190 190 -tag o -outline black -width 10
    for {set i $n} {$i > 0} {incr i -1} {
        #set centre [expr $centre - 0.55]
        set centre [expr $centre - 0.45]
        set x1     [expr $centre - $i]
        set x2     [expr $centre + $i]
        set color [lindex $steps $i]
        $c create oval  $x1 $x1  $x2 $x2 -fill $color -outline $color
    }
    $c create text 100 100 -tag txt -anchor c -justify c -fill black -font titleFont
    $c itemconfig txt -text "Press\nMe!"
}

proc About {} {
    set title "Razzle Dazzle"
    set msg ""
    append msg "Keith Vetter   April, 2019"
    append msg "\n\n"
    append msg "Razzle Dazzle is a carnival game with extremely poor odds for the player."
    append msg "\n\n"
    append msg "The game consists of a playing board with numbered holes upon which "
    append msg "eight marbles are tossed from a cup. The numbers of the holes the marbles "
    append msg "land in are summed, and that sum is looked up on a score card to determine "
    append msg "the outcomeof that roll. Some scores add points to the player's total, while "
    append msg "others add an additional prize or double the betting amount."
    append msg "\n\n"
    append msg "The player bets \$1 per roll and keeps going until he achieves 100 points--"
    append msg "the player doesn't \"lose\" until he walks away."
    append msg "\n\n"
    append msg "Mathematically, the game is a scam: rolling eight marbles is equivalent to rolling "
    append msg "eight dice resulting in a bell curve distribution. All the most likely outcomes "
    append msg "are worthless, and only the most rare outcomes achieve points. "
    append msg "\n\n"
    append msg "Furthermore, most razzle games also rely on a fast count by the game operator "
    append msg "to trick the player into believing he has a better number total than he actually "
    append msg "rolled. This is used to keep the player hooked into the game, increasing his "
    append msg "point total periodically, causing him to invest more and more into the game. "
    append msg "Increasingly the player believes that walking away would be a disaster: he only "
    append msg "needs one or two more points. Unfortunately for the player, he never actually "
    append msg "gets that last point."
    tk_messageBox -icon info -message $title -detail $msg
}

################################################################

DoDisplay
return