Roulette

 #: Roulette.tcl - HaJo Gurt - 2005-07-07
 #: French roulette table (only 1 zero)

 #########1#########2#########3#########4#########5#########6#########7#####

  package require Tk

  proc int x {expr int($x)}

  proc Carree {w  x y  w1 h1  txt c} {
  #: Draw large symbols for red and black
    set xr [expr {$w1*0.20}]
    set yr [expr {$h1*0.25}]
    $w create poly [expr {$x-$xr}] $y \
                   $x              [expr {$y+$yr}] \
                   [expr {$x+$xr}] $y              \
                   $x              [expr {$y-$yr}] \
                   -tag $txt  -fill $c
  }

  proc Color {nr} {
  #: Colors of the roulette-numbers
    set c [lindex {G  R - R   - R -   R - R   - - R \
                      - R -   R - R   R - R   - R - \
                      R - R   - - R   - R -   R - R } $nr]
    if {$c=="R"} { return red   }
    if {$c=="-"} { return black }
    if {$c=="G"} { return green } else { return white }
  }

  proc Field {x1 y1  w1 h1  txt} {
  #: Draw one field of the table
    .c create rect $x1 $y1  [expr {$x1 + $w1}] [expr {$y1 + $h1}] -fill SpringGreen4

    set x  [expr {$x1 + $w1*.5}]
    set y  [expr {$y1 + $h1*.5}]

    switch -regexp -- $txt {
    "Rouge"   { Carree .c  $x $y  $w1 $h1  $txt red   }
    "Noir"    { Carree .c  $x $y  $w1 $h1  $txt black }
    "C"       { .c create text $x $y  -text "  "  -tag $txt  -fill white }
    "[aPMD-]" { .c create text $x $y  -text $txt  -tag $txt  -fill white }
    default   { .c create text $x $y  -text $txt  -tag $txt  -fill [Color $txt] }
    }
  }

 #########1#########2#########3#########4#########5#########6#########7#####

 # Height, Width:  22..50 : 9*40=360 14*40=560
  set W1  30
  set H1  30

  set x0  [expr {$W1 *  3 }]
  set y0  0
  set WW  [expr {$W1 *  9 }]
  set HH  [expr {$H1 * 14 }]

  set xx  [expr {$W1* 9+10}]
  set yy  [expr {$H1*14+10}]
  grid [canvas .c -width $xx -height $yy]
  .c config -scrollregion [list -5 -5 [expr {$xx-5}] [expr {$yy-5}]]

  set  x $x0
  set  y $y0
  set  i 0
  Field $x0 $y [expr {$W1*3}] $H1 0

  incr y $H1
  Field 0              [expr {$H1*1}] $x0            [expr {$H1*4}] "Passe"
  Field [expr {$W1*6}] [expr {$H1*1}] [expr {$W1*3}] [expr {$H1*4}] "Manque"

  Field 0              [expr {$H1*5}] $x0            [expr {$H1*4}] "Pair"
  Field [expr {$W1*6}] [expr {$H1*5}] [expr {$W1*3}] [expr {$H1*4}] "Impair"

  Field 0              [expr {$H1*9}] $x0            [expr {$H1*4}] "Noir"
  Field [expr {$W1*6}] [expr {$H1*9}] [expr {$W1*3}] [expr {$H1*4}] "Rouge"

  # Numbers:
  for { set i 1 } { $i <= 36 } { incr i } {
    Field $x $y $W1 $H1 $i
    if {$i%3 == 0} {
      incr y $H1
      set  x $x0
    } else {
      incr x $W1
    }
  }

  # Columns:
  set  x $x0
  for { set i 1 } { $i <= 3 } { incr i } {
    Field $x $y $W1 $H1 " Column$i"  ;# Field remains empty
    incr x $W1
  }

  # Dozens:  (Premier/Medium/Dernier)
  set xR $x
  set xL [expr {$x0 - $W1 }]
  for { set i 1 } { $i <= 3 } { incr i } {
    Field $xL $y $W1 $H1 [lindex [list _ 12D 12M 12P] $i]
    Field $xR $y $W1 $H1 [lindex [list _ 12D 12M 12P] $i]
    incr xL -$W1
    incr xR  $W1
  }

 #########1#########2#########3#########4#########5#########6#########7#####

  bind .c <Motion> {
    set tags [.c itemcget current -tag]
    set p    [string first "current" $tags]
    set tags [string replace $tags $p end]
    wm title . "[int [%W canvasx %x]],[int [%W canvasy %y]] : $tags"
  }
HJG A simple french roulette table, but no gameplay yet.
To also show the wheel correctly, it would be nessessary to rotate text an arbitary angle, but I haven't looked yet into Rotate text on a canvas. Otherwise, it would look somewhat like the Alphabet Wheel...
Category Toys