----
[ Refrigerator_Magnetic_Poetry]
 #Refrigerator_Magnetic_Poetry
 # Start of Deck
  package require Tk
 namespace eval xpoetry {
    variable bg black  fg white  size 30
     }
  set dx 50
  set dy 50
  set size 30 
  set colorground bisque
  # Refrigerator_Magnetic_Poetry
  # Refrigerator magnet poetry
  # program is mainly TCL8.0 and 
  # Windows Expect5.2 offshoot of 
  # Suchenwirth's Domino.tcl, circa 2004.
  # Tried to note which Suchenwirth subroutines 
  # were mostly unchanged.
  # This was the first TCL canvas code I
  # saw that one could create easy gamepieces.
  # Writing grouped designs 
  # on top of canvas shape, so basic canvas
  # shape and "grouped" design would move
  # by mouse. "grouped" design is used 
  # extensively in Microsoft powerpoint
  # and Harvard Graphics, etc. 
  # This first effort is refrigerator
  # magnet poetry in English. 
  # Believe a similar select & die could  
  # be used for a computer Mahjong game
  # or coin&card games.
  # Could use TCL8.4 chinese charactors
  # on top of tiles for Chinese magnetic
  # poetry or colored Mahjong tiles. 
  # from goldshell7 on 10jun2006. 
 proc lpick L {lindex $L [expr int(rand()*[llength $L])];#suchenwirth_subroutine;} 
 proc poetry jill {
 set jill [lpick { tree happy grass love swan home  \
     power loss dance rose joy hate juice kick}]
  return $jill;
 }

    proc xpoetry::create {w x y val1 val2} {
   global jack
   global jill
    variable bg; variable fg; variable size
     set jack [lpick {red yellow blue purple \
     pink green brown black  gray}]
  set jill rose
    #remaining doctered_suchenwirth_subroutine;
    set tags [list mv d-$val1$val2];
    #remaining doctered_suchenwirth_subroutine;
    set x1 [expr {$x+$size-0.5}]
    set y1 [expr {$y+$size}]
    $w create rect $x $y [expr {$x+2*$size}] $y1 \
        -fill $jack -tags [linsert $tags 0 bd-$val1$val2]
    $w create text [expr {$x+1*$size}]   [expr {$y+0.5*$size }] \
       -text   [eval poetry $jill] -fill $fg -tags $tags
 
 }


 if 0 {Clicking on a piece records the click position, and its "catch-all"  tag, in global variables:}
 proc mv'1 {w x y} {
    set ::_x $x; set ::_y $y;#suchenwirth subroutine;
    foreach tag [$w gettags current] {
        if [regexp ^(d-.+) $tag -> ::_tag] break
    }
 }
  if 0 {Moving the mouse with button 1 down moves the items with the  "catch-all" tag with the mouse pointer:}
  proc mv'motion {w x y} {
    $w raise $::_tag;#suchenwirth subroutine;
    $w move $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}] 
   
    set ::_x $x; set ::_y $y
       
 }

  pack [canvas .c -bg $colorground -width 500 -height 350] -fill both -expand 1
 for {set i 0; set y 0} {$i<8} {incr i; incr y $dy} {
    for {set j 0; set x 0} {$j<8} {incr j; incr x $dx}   {
        xpoetry::create .c [expr $i*65+10] [expr $j*35+100] $i $j
    }
 }
 
 if 0 {Moving the mouse with button 1 down moves the items with the   "catch-all" tag with the mouse pointer:}
  proc move&die {w x y} {
   # remove selected pieces & other pieces
  # by moving middle mouse 
  #  on top of them, not working too well
  $w raise $::_tag
    $w move $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}] 
   $w delete $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}] 
    set ::_x $x; set ::_y $y
       
 }  
 if 0 {Clicking on a piece records the click position, and its  "catch-all" tag, in global variables:}
 proc select&die {w x y} {
      # remove selected pieces by moving right mouse
     # on top of them,  working better
  set ::_x $x; set ::_y $y
    foreach tag [$w gettags current] {
        if [regexp ^(d-.+) $tag -> ::_tag] break
    }
  $w delete $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}] 
  }
  set size 30 
  .c bind mv <1>         {mv'1 %W %x %y}
  .c bind mv <B1-Motion> {mv'motion %W %x %y}
 .c bind mv <B3-Motion> {select&die %W %x %y}
 .c bind mv <B2-Motion> {move&die %W %x %y}
  #-- Little development helpers (optional):
 
  bind . <Escape> { exit}
  bind . <F1> {destroy .}
  bind . <F2> { set colorground LightBlue1;.c configure -bg $colorground}
  bind . <F3> {set colorground Bisque;.c configure -bg $colorground }
  bind . <F4> {set backcolor [lpick {AntiqueWhite3 Bisque1 Bisque2 Bisque3  Bisque4 SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3  LightBlue1 DarkSlateGray1 Aquamarine2 DarkSeaGreen2 SeaGreen1 Bisque  
	Yellow1 IndianRed1 IndianRed2 Tan1 Tan4 gray}];set colorground $backcolor;.c configure -bg $colorground }
 #end of deck
----
[Category Toys]