##+##########################################################################
 #
 # mind.tcl -- A mind reading game based on http://www.flashpsychic.com/
 # by Keith Vetter, December 2005
 #
 
 package require Tk
 if {![catch {package require tile 0.5}]} {
    catch {namespace import -force ::ttk::button}
 }
 
 set chars [list \x25 \x26 \x27 \x28 \x36 \x3e \x49 \x4d \x4e \x4f \x50 \x51 \
                \x52 \x53 \x54 \x55 \x56 \x57 \x58 \x59 \x60 \x61 \x62 \x63 \
                \x64 \x65 \x66 \x67 \x68 \x69 \x6a \x6b \x6c \x6d \x79 \x7a \
                \x7b \x7c \xa3 \xa5 \xa9 \xaa \xab \xae \xb3 \xb4 \xb5 \xb6 \
                \xcb \xd0 \xd9 \xfd]
 
 proc DoDisplay {} {
    option add *Background white
    . config -bg white
    wm title . "Mind Reader"
    bind all <Key-F2> {console show}
 
    set msg "Choose any two digit number, add together both digits\n"
    append msg "and then subtract the total from your original number.\n"
    append msg "For example, if you choose 23: 23-(2+3) = 23-5 = 18.\n\n"
    append msg "When you have the final number look it up on the chart\n"
    append msg "and find the relevant symbol. Concentrate on the symbol\n"
    append msg "and when you have it clearly in your mind, click on the\n"
    append msg "crystal ball and it will show you the symbol you are\n"
    append msg "thinking of..."
 
    frame .left
    label .title -text "Mind Reader" -font {Times 32 italic}
    canvas .c -width 200 -height 200 -highlightthickness 0
    bind .c <1> Predict
 
    MakeBall
    label .l -text $msg -justify left -padx 5 -pady 20 -font {Helvetica 8 bold}
    pack .title .c .l -side top -in .left
 
    frame .right -bd 2 -relief ridge
    for {set row 0} {$row < 20} {incr row} {
         for {set col 0} {$col < 5} {incr col} {
             set val [expr {99 - $col*20 - $row}]
             label .l$row,$col  -text [format "%02d" $val] -font {Helvetica 10 bold}
             label .ll$row,$col -textvariable ::T($val) -fg \#640406 -font {Wingdings 10 bold}
             grid  .l$row,$col  -row $row -column [expr {2*$col}] -in .right
             grid  .ll$row,$col -row $row -column [expr {2*$col+1}] -padx {0 5} -in .right
         }
    }
 
    pack .left .right -side left -fill both
 }
 
 proc FillTable {} {
    for {set i 0} {$i < 100} {incr i} {
         set ::T($i) [lindex $::chars [expr {int(rand() * [llength $::chars])}]]
    }
    for {set i 18} {$i <= 81} {incr i 9} {
         set ::T($i) $::T(9)
    }
 }
 
 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 {} {
    set n 90
    set steps [GradientSteps $n white blue]
    set width  [winfo reqwidth .c]
    set height [winfo reqheight .c]
    set centre 100
    .c create oval 10 10 190 190 -tag o -outline \#0000aa -width 15
    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
    }
 }
 
 proc Predict {} {
    wm geom . [wm geom .]
    frame .try
    pack forget .right ; pack .try -side right -expand 1
    .l config -fg white
 
    .c create text 100 100 -tag c -text $::T(9) -anchor c -fill \#004477 \
         -font {Wingdings 12 bold}
    for {set fsize 24} {$fsize < 90} {incr fsize 6} {
         update
         after 10
         .c itemconfig c -font [list Wingdings $fsize bold]
    }
 
    label  .try.amazing -text "Can you\nbelieve it?" -font {Times 24 bold} -fg red
    button .try.again -text "Try Again?" -command Again
    catch {.try.again config -bg wheat} ;# looks better for non-tile buttons
    pack   .try.amazing .try.again -side top -expand 1 -pady .15i
 }
 proc Again {} {
    destroy .try
    pack .right -side right
    FillTable
    .c delete c
    .l config -fg [lindex [.l config -fg] 3]
 }
 FillTable
 DoDisplay
 
 return