This page uses TCL8/Expect 5.2 for windows to develop  
Refrigerator magnetic Poetry. 
For example, we are laying out tiles in random colors 
imprinted with text and symbols applied randomly.  
Would also like to develop a crude Mahjong program using some of these subroutines.

[http://mini.net/files/fridge.jpg]

'''Strengths'''
  test picture???
 [http://mini.net/files/balance.gif]
   

   ''Subroutine use whereever possible.'':   This one 
   [Refrigerator_Magnetic_Poetry]
----
#Refrigerator_Magnetic_Poetry
    # Start of Deck
    #Refrigerator_Magnetic_Poetry
    # Start of Deck
     package require Tk
    proc down(reset) {w x y} {
   reset $w
   }
   proc move(reset) {w x y} {}
    proc radio {w var values {col 0}} {
     frame $w
     set type [expr {$col? "-background" : "-text"}]
     foreach value $values {
         radiobutton $w.v$value $type $value -variable $var -value $value \
             -indicatoron 0
         if $col {$w.v$value config -selectcolor $value -borderwidth 3}
     }
     eval pack [winfo children $w] -side left
     set ::$var [lindex $values 0]
     set w
   }

   proc down(Draw) {w x y} {
     set ::ID [$w create line $x $y $x $y -fill $::Fill]
   }
   proc move(Draw) {w x y} {
     $w coords $::ID [concat [$w coords $::ID] $x $y]
   }

   #-- Movement of an item
   proc down(Move) {w x y} {
     set ::ID [$w find withtag current]
     set ::X $x; set ::Y $y
   }
   proc move(Move) {w x y} {
     $w move $::ID [expr {$x-$::X}] [expr {$y-$::Y}]
     set ::X $x; set ::Y $y
   }

   #-- Clone an existing item
   proc serializeCanvasItem {c item} {
     set data [concat [$c type $item] [$c coords $item]]
     foreach opt [$c itemconfigure $item] {
         # Include any configuration that deviates from the default
         if {[lindex $opt end] != [lindex $opt end-1]} {
             lappend data [lindex $opt 0] [lindex $opt end]
             }
         }
     return $data
     }
   proc down(Clone) {w x y} {
     set current [$w find withtag current]
     if {[string length $current] > 0} {
         set itemData [serializeCanvasItem $w [$w find withtag current]]
         set ::ID [eval $w create $itemData]
         set ::X $x; set ::Y $y
     }
   }
   interp alias {} move(Clone) {} move(Move)

   #-- Drawing a rectangle
   proc down(Rect) {w x y} {
      set tile  [expr {int(rand()*1000000000.)}]
      set poof  "rectangle" ;
      set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];
      set ::ID [$w create rect $x $y $x $y -tags $tagx -fill $::Fill]
   }
   proc move(Rect) {w x y} {
     $w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
   }

   #-- Drawing an oval (or circle, if you're careful)
   proc down(Oval) {w x y} {
      set tile  [expr {int(rand()*1000000000.)}]
      set poof  "oval" ;
      set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];
     set ::ID [$w create oval $x $y $x $y -tags $tagx -fill $::Fill]
   }
   proc move(Oval) {w x y} {
     $w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
   }
 proc down(circle) {w x y} {
      set tile  [expr {int(rand()*1000000000.)}]
      set poof  "oval" ;
      set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];
      set dx 50
      set dy 50

     set ::ID [$w create oval [expr {$x+2}] [expr {$y+2}] [expr {$x+$dx-3}] [expr {$y+$dy-3}]  -tags $tagx -fill $::Fill]
      }
   proc move(circle) {w x y} {
     #$w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
   }

   proc down(Poly) {w x y} {
     if [info exists ::Poly] {
      set tile  [expr {int(rand()*1000000000.)}]
      set poof  "poly" ;
      set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];

         set coords [$w coords $::Poly]
         foreach {x0 y0} $coords break
         if {hypot($y-$y0,$x-$x0)<10} {
             $w delete $::Poly
             $w create poly [lrange $coords 2 end] -fill $::Fill
             unset ::Poly
         } else {
             $w coords $::Poly [concat $coords $x $y]
         }
     } else {
         set ::Poly [$w create line $x $y $x $y -tags "obj_[expr {int(rand()*1000000000.)}]" -fill $::Fill ]
     }
   }

   proc ? L {
     lindex $L [expr {int(rand()*[llength $L])}]
     #suchenwirth_subroutine;
     }
   proc move(Poly) {w x y} {#nothing}

   #-- With little more coding, the Fill mode allows changing an item's fill color:
   proc down(Fill) {w x y} {$w itemconfig current -fill $::Fill}
   proc move(Fill) {w x y} {}

   #-- Building the UI
 
   set modes {Draw Move Clone Fill Rect Oval Poly circle canvas Poetry clear reset exit}
   set colors {
     black white magenta brown red orange yellow green green3 green4
     cyan blue blue4 purple
   }
      set colorx { brown2 AntiqueWhite3 \
      Bisque1 Bisque2 Bisque3  Bisque4 \
      SlateBlue3 RoyalBlue1 SteelBlue2 \
      DeepSkyBlue3  LightBlue1 DarkSlateGray1 \
      Aquamarine2 DarkSeaGreen2 SeaGreen1 Bisque \
             Yellow1 IndianRed1 IndianRed2 Tan1 \
      lemonchiffon  seashell honeydew mintcream azure \
        oldlace linen antiquewhite papayawhip blanchedalmond
       peachpuff navajowhite moccasin cornsilk \
       Tan4 gray }
       set colorz [list seashell honeydew gainsboro floralwhite \
       oldlace linen antiquewhite papayawhip blanchedalmond \
      bisque  peachpuff navajowhite moccasin cornsilk ivory \
      lemonchiffon  seashell honeydew mintcream azure]

     
       global liner
       global ind
       set ind 0
      global   movesit
      set  movesit 1
      set colorground bisque
      global xhistory firstnode curnode
      set curnode ""
      set firstnode ""
      set xhistory [list aaa bbb ccc ddd eee fff ggg ]
     set xhistory [list  ]
     set colorground bisque
      global selected_tile previous_tile
      set selected_tile "selected tile";
      set previous_tile "previous tile";
       global counter
       global liner
       global ind
       set ind 0
       set liner [list a b c d e f g ]
       global tilex tagx tagz
       set tilex "obj_66666test"
       set tagx "obj_77777test"
       set tagz "obj_55555test "
       global entries
       set counter 0
   grid [radio .1 Mode $modes] [radio .2 Fill $colors 1]  -sticky nw
  
   grid [radio .3 Fill $colorx 2] -sticky nw
   grid [canvas .c -relief raised -borderwidth 1 -bg $colorground] - -sticky news
   
   grid rowconfig . 0 -weight 0
   grid rowconfig . 1 -weight 1

     button .b2 -text dismiss -command "destroy ."
      button .b3 -text exit -command "exit"
   button  .b5 -text "Del_tank" -width 2  -command { .wxx delete 1.0 end}

      button  .b6 -text "lt_bg" -bg gray -width 2 \
    -command { set colorground LightBlue1;
      .c configure -bg $colorground  }
      button  .b7 -text "bis_bg" -width 3 \
    -command { set colorground Bisque; \
      .c configure -bg $colorground  }

      grid .b2 .b3 .b5 .b6 .b7
   grid rowconfig . 0 -weight 0
   grid rowconfig . 1 -weight 1
   grid [ label .wcc -text "list of selection history " ]
   grid [entry .wxxccc -textvar e -just left -bg beige -width 50]
   #.wxxccc insert end  "$liner"
   set wow [.c find withtag current];
   .wxxccc insert end  "xxx starter xxx $wow xxx"
   focus .wxxccc           ;# allow keyboard input
   set labelx  [info tclversion];
   grid [ label .ww -text "holding tank, version $labelx " ]
   set txt [text .wxx -width 20 -height 3 -bg beige]
     grid  $txt -sticky news
   focus .wxx           ;# allow keyboard input
   set wow [.c find withtag current];
   .wxx insert end  "xxx starter xxx $wow xxx ";

   #-- The current mode is retrieved at runtime from the global Mode variable:
   bind .c <1> {set firstnode [.c find withtag current];initialize %W %x %y ;down($Mode) %W %x %y}
   bind .c <B1-Motion> {move($Mode) %W %x %y}
   bind .c <2>         {%W delete current}
   bind .c <3> {
        #set firstnode [.c find withtag green]
        set firstnode [.c find withtag current]
        set curnode [.c find withtag current]
        set tile [.c find withtag current]
        #set curnode [.c find withtag red]
        if {( $firstnode != "") && ($curnode != "")} {
       dualcheck $tile $firstnode $curnode }}
   proc move(Poetry) {w x y} {
    if [info exists ::X] {
   $w move $::ID [expr {$x-$::X}] [expr {$y-$::Y}]
     set ::X $x; set ::Y $y}
   }
   proc down(exit) {w x y} {
     exit
   }
   proc downxxxx(Poetry) {w x y} {
       global baseline
       global en_chinese
        set baseline  [list ]
        set baseline2  [list ]
        set baseline3  [list ]
        set dy 40
        set dx 40
        set dk 10
        set poof "tester";
        set looky "stringx";
        set tile "tile"
        set tagx  [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
      set tagx  [list ]
    #set tags [list mv d-$val1$val2];

       #set tile  [expr {int(rand()*1000000000.)}]
      #set looky "stringx";
      #set poof  [xpop $looky ] ;
       #set tags [list $poof mv obj_$tile  d-$val1$val2];
   #set tags [list $poof mv "obj_$tile+1"   d-$val1$val2];
       #set tagx [list $poof mv "obj_$tile+1"   d-$x$y];
   for {set i 0; set y  [expr {4+$y}];set x  [expr {10+$dx}]; } {$i<5} {incr i; incr x $dx} {
     set state1 1;
   set tile  [expr {int(rand()*1000000000.)}]
      set looky "stringx";
      set poof  [xpop $looky ] ;   
      lappend baseline $poof;
      set tagx [list $poof mv "obj_$tile"   d-$x$y];
        set ::ID [$w create text $x $y  -text $poof -tags $tagx -fill $::Fill ]
      }
    set baseline [translationx $baseline en_chinese];
    set y  [expr {50+$y}];
    #set x [expr {15+$dx}];
   set ::ID [$w create text $x  $y  -text $baseline -tags $tagx -fill $::Fill ]
   set baseline  [list ]
     for {set i 0; set y [expr {8+$y}];set x [expr {10+$dx}] ;} {$i<7} {incr i; incr x $dx} {
     set state1 1;
   set tile  [expr {int(rand()*1000000000.)}]
      set looky "stringx";
      set poof  [xpop $looky ] ;
     lappend baseline2 $poof;
   set tagx [list $poof mv "obj_$tile"   d-$x$y];
        set ::ID [$w create text $x $y  -text $poof -tags $tagx -fill $::Fill ]
      }
        set baseline [translationx $baseline en_chinese];
     set y  [expr {60+$y}];
    #set x [expr {15+$dx}];
   set ::ID [$w create text $x  $y  -text $baseline -tags $tagx -fill $::Fill ]
  set baseline  [list ]
     for {set i 0; set y  [expr {12+$y}];set x [expr {15+$dx}];} {$i<5} {incr i; incr x $dx} {
     set state1 1;
   set tile  [expr {int(rand()*1000000000.)}]
      set looky "stringx";
      set poof  [xpop $looky ] ;
      lappend baseline3 $poof;
      set tagx [list $poof mv "obj_$tile"   d-$x$y];
        set ::ID [$w create text $x $y  -text $poof -tags $tagx -fill $::Fill ]
      }
    
    set baseline [translationx $baseline en_chinese];
  
   set ::ID [$w create text $x  $y  -text $baseline -tags $tagx -fill $::Fill ]
   set baseline [translationx $baseline2 en_chinese];
  
   set ::ID [$w create text $x  $y  -text $baseline -tags $tagx -fill $::Fill ]
    set baseline [translationx $baseline3 en_chinese];
  
   set ::ID [$w create text $x  $y  -text $baseline -tags $tagx -fill $::Fill ]

}
  proc down(Poetry) {w x y} {
         global baseline
        global en_chinese
        set baseline  [list ]
        set baseline2  [list ]
        set baseline3  [list ]
        set dy 40
        set dx 40
        set dk 10
        set poof "tester";
        set looky "stringx";
        set tile "tile"
        set tagx  [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
        set tagx  [list ]
    #set tags [list mv d-$val1$val2];

       #set tile  [expr {int(rand()*1000000000.)}]
      #set looky "stringx";
      #set poof  [xpop $looky ] ;
       #set tags [list $poof mv obj_$tile  d-$val1$val2];
   #set tags [list $poof mv "obj_$tile+1"   d-$val1$val2];
       #set tagx [list $poof mv "obj_$tile+1"   d-$x$y];
   for {set i 0; set y  [expr {4+$y}];set x  [expr {10+$dx}]; } {$i<5} {incr i; incr x $dx} {
     set state1 1;
   set tile  [expr {int(rand()*1000000000.)}]
      set looky "stringx";
      set poof  [xpop $looky ] ;
      lappend baseline $poof;
      set tagx [list $poof mv "obj_$tile"   d-$x$y];
        set ::ID [$w create text $x $y  -text $poof -tags $tagx -fill $::Fill ]
      }
       for {set i 0; set y [expr {8+$y}];set x [expr {10+$dx}] ;} {$i<7} {incr i; incr x $dx} {
     set state1 1;
   set tile  [expr {int(rand()*1000000000.)}]
      set looky "stringx";
      set poof  [xpop $looky ] ;
     lappend baseline2 $poof;
   set tagx [list $poof mv "obj_$tile"   d-$x$y];
        set ::ID [$w create text $x $y  -text $poof -tags $tagx -fill $::Fill ]
      }
     for {set i 0; set y  [expr {12+$y}];set x [expr {15+$dx}];} {$i<5} {incr i; incr x $dx} {
     set state1 1;
   set tile  [expr {int(rand()*1000000000.)}]
      set looky "stringx";
      set poof  [xpop $looky ] ;
       lappend baseline3 $poof;
      set tagx [list $poof mv "obj_$tile"   d-$x$y];
        set ::ID [$w create text $x $y  -text $poof -tags $tagx -fill $::Fill ]
      }
   set k 20;
   set baseline [translationx $baseline en_chinese];
  set k  [expr {20+$y}];
   set ::ID [$w create text $x  $k  -text $baseline -tags $tagx -fill $::Fill ]
   set baseline [translationx $baseline2 en_chinese];
  set k  [expr {30+$y}];
   set ::ID [$w create text $x  $k  -text $baseline -tags $tagx -fill $::Fill ]
    set baseline [translationx $baseline3 en_chinese];
  set k  [expr {40+$y}];
   set ::ID [$w create text $x  $k  -text $baseline -tags $tagx -fill $::Fill ]

   }
   proc history {xhistory } {
   set xhistory [list object history @];
   global xhistory firstnode curnode
        global ind movesit
        set number 2
         set numberx 2

         set firstnode [.c find withtag current]
   lappend  $xhistory  $firstnode ;
   set ::ID [.c create text 100 200  -text $xhistory -tags " history " -fill $::Fill -fill black ]
   }
      proc dualcheck { tile firstnode curnode} {
       global match_id selected_tile tiles_left jack
       global newy oldy match oldx xhistory
      global selected_tile previous_tile
      global xhistory
      global tilex
      #global firstnode curnode
      set selected_tile "selected tile";
      set colorxxx "test"
      set colorzzz "test"
         #set previous_tile "previous tile";
         set numberx [.c  gettags current];
         regexp {obj_(\d+)} $numberx -> tilex
         regexp {colorit_(\d+)} $numberx -> colorxxx
         regexp {colorit_(\d+)} $numberx -> colorzzz
        set indexer [string first "mv" $numberx ];
         set indexer [ expr { $indexer - 1 } ]
        set new  [string range $numberx 0 $indexer ];
       set tags [.c  gettags current]
       #.c itemconfigure obj_$tilex -width 2 -outline red;
       #.c itemconfigure $previous_tile -width 2 -outline green;
       # .c itemconfigure obj_$tilex -width 3  ;
      # .c itemconfigure $previous_tile -width 3  ;
       set old "test"
       set kkk [.c  gettags $previous_tile ]
       set indexer [string first "mv" $kkk ]; ;
        set indexer [ expr { $indexer - 1 } ]
        set old  [string range $kkk 0 $indexer ];
      if {$old == ""} {set old "poof $previous_tile"}
     set tx [string range $tilex  0 end ];
      set rx [string range $previous_tile 4 end ];
       if { $tx !=  $rx } {
       .wxx delete 1.0 end;
       .wxx insert end  "  pair error identified, text not equal !!!"  ;
       }

     if { $old ==  $new } {
      set tx [string range $tilex  0 end ];
      set rx [string range $previous_tile 4 end ];
       if { $tx ==  $rx } {
       .wxx delete 1.0 end;
       .wxx insert end  "  pair error identified, double touch of same tile !!!"  ;
       }
       if { $tx !=  $rx } {
     #.c itemconfigure obj_$tilex -width 2 -outline blue;
     #.c itemconfigure $previous_tile -width 2 -outline blue;
     .wxx delete 1.0 end;
     .wxx insert end " xxx $tilex xxx $tx xxx $rx xxx $previous_tile xxxx  ";
     .wxx insert end  $previous_tile;
     .wxx insert end  "  old $old ";
     .wxx insert end  $old;
     .wxx insert end  " identical pair identified !!!"  ;
     .wxx insert end " xxx old $old xxx new xxx $new  ";
     .wxx insert end  $new;
     .wxx insert end "obj_tilex obj_$tilex "
         regexp {colorit_(\d+)} $numberx -> colorxxx
         regexp {colorit_(\d+)} $previous_tile -> colorzzz
     if { $colorxxx ==  $colorzzz } {
     .c delete "$previous_tile+1";
     .c delete "obj_$tilex+1" ;

     .c delete obj_$tilex ;
     .c delete $previous_tile;
     }
     }

     }
       #.wxx delete 1.0 end;
       set $selected_tile $tags;
       .wxx insert end $tags ;
       .wxx insert end " selected_tile equals $new ";
       if {  $previous_tile != $selected_tile  } {
        set previous_tile [.c  gettags current]
        set indexer [string first "mv" $previous_tile ];
         set indexer [ expr { $indexer - 1 } ]
        set old  [string range $previous_tile 0 $indexer ];
       .wxx insert end " previous_tile equals $old ";
       }
       #.c itemconfigure  $curnode -width 2 ;
       set previous_tile obj_$tilex
       set firstnode obj_$tilex;
       if { $firstnode != $curnode } {
       set curnode obj_$tilex;}
      .wxx insert end " current equals $curnode ";
      .wxx insert end " first equals $firstnode ";
     return }
     proc initialize {w x y} {
        global tile
        global xhistory firstnode curnode
        global ind movesit
      set tile [.c find withtag current]
        set number 2
         set numberx 2
         set ::_x $x; set ::_y $y;
         set firstnode [.c find withtag current]
      set number  [$w gettags current]
       set indexer [string first "mv" $number ];
       set numberx  [string range $number 0 $indexer];
         .wxx delete 1.0 end;
       # general reporting line
      .wxx insert end " xxx $number xxx $numberx xxx \
     indexer  xxx  $indexer xxx number of tiles xxxx \
     $ind xxxx object xxx $tile xxx $ind xxx number of \
      straight moves xxx $movesit xxx ";
       #.wxxccc delete 1.0 end;
       # general reporting line
      .wxxccc insert end " xxx $number xxx $numberx xxx \
     indexer  xxx  $indexer xxx number of tiles xxxx \
     $ind xxxx object xxx $tile xxx $ind xxx number of \
      straight moves xxx $movesit xxx ";
       incr movesit

      }

      proc lpick L {lindex $L [expr int(rand()*[llength $L])]; \
      #suchenwirth_subroutine;}
    proc stringxxx s {
         #suchenwirth_subroutine;
         set res {}
        foreach line [split $s \n] {
           for {set i 0} {$i<[string length $line]} {incr i} {
              if {$i==[string wordstart $line $i]} {
                 set w [string range $line $i [expr {[string wordend $line $i]-1}]]
                 #if {$w!=" "} {lappend res $w}
                 #if {$w!=" " && $w!="\{" && $w!="\}"} {lappend res $w}
                 if {$w!=" " && $w!="\{" && $w!="\}" && $w!="\," && $w!="\\" && $w!="\/"} {lappend res $w}
                 #if {$w!="\}"} {lappend res $w}
                 #if {$w!="\{"} {lappend res $w}
                 incr i [expr {[string length $w]-1}];

                 # always loop incr
              }
           }
        }
        set res

     }
   proc xpop { topper } {
     global liner
     global ind
     global baseline
     set poetsey aaaaa

     set liner [poemsorts $poetsey];

     set goofy [stringxxx $liner] ;

     set topper [ lindex $goofy $ind ];

     set ind [ expr { $ind + 1}]
     lappend $baseline $topper;
     return $topper;
     }
    proc helptext {stringxxx} {
       set text_texas {
       # Refrigerator magnet 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.
       # Various Esc and F-keys activate
       # to exit program or change background color.
       # Sliding right mouse across piece
       # should delete same.
       # Pick and Sliding left mouse across piece
       # should move same.
       # Selecting piece with middle mouse
       # should delete same piece.
       # Selecting pair of [same text] pieces
       # [in sequence] with right mouse
       # should delete same piece.
       # Right mouse uses initialization from
       # left mouse, so one has to pick
       # one tile with left mouse for
       # game start.
       # 5/7/5 words per line is
       # setting for Japanese Haiku poetry.
       # Other procedures working
       # on windows98 and old PC.
       # from goldshell7 on 10jun2006.}
       return text_texas;}

     proc poemsorts {poetsey} {
      global liner
      #set liner [list q w e r]
      # alpha liner for test purposes
      set liner [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
      set liner [list  ]
      set adjective_poetic {
        {red} {sad} {blue} {blue}
        {glad} {glad} {deep} {black}
       {wild } { green } {pale } {bright}
       {rough } {gray } {brown } {long}
       {high } {thin} {brown } {lush}
       {dry } {poor} {lone } {far}
       {flat } {broad} {thick } {hard}
       {flat } {broad} {cool } {hard}
      }
      set noun_subject {
        cat  mouse  reed { pear }
        {quince } { peach } {hare } {bird}
       { smoke } { rain} { ice} { snow}
        {cloud} { home} { flower } {sky}
        {rice} { pine} { mist} {door}
        {wind} { cricket} { year } {moon}
        {crane } {grass } {rose} { ink}
        {thaw} { bloom } {lake} { cedar }
        {dusk} { autumn } {stone} { dawn}
        {stream} { tree } {heart} { boat}
        {grief} { tree } {boat} { boat}
        {rock} {town} {tear} {pool}
        {silk} {deer} {song} {barge}
        {moss} {night} {gate} {fence}
        {dove} {dream} {frost} {peace}
       {shade} {ghost} {road } {path}
       {root} {horse} {eve } {sound}
       {sleep} {leaves} {sea } {sail}
       {peak} {stem} {field} {wave}
       {slope} {bark} {crest} {weed}
       {moth} {wasp} {pond} {soil}
       {snail} {worm} {ant} {kelp}
       {cave} {month} {head} {jade}
         {branch} {bone} {head} {smile}
        {pea} {bone} {head} {smile}
       {elm} { morn} {carp} {nest}
       {oak} { bone} {perch} {breeze}
        mount  plum  storm  hill
      }
      set verb_transitive {falls
      {snow} { burns} { flips} { flys }
      {lies} { walk } {flow } {fall} {fly}
       {know } {come} { meet } { drift}
     {shine } {soak} { cry } {dance}
      { lost} {cheer}  {float } {dance}
     {roost} { move} { fade} { loves}
      {sleeps} {move} {takes } {sail}
     {sits} {leaps} {sits } {sit}
     {sits} {leaps} {grows } {waits}
      {loses} {hears} {wants } {watch}
      }
      set noun_objective {
         cloud {old home} flower { sky } rice {cricket}
      }
      set silly_propostion {
         for {by} towards { to } at {bygone}
         {to} {in} {in } {to }
         {to} {in} {fore } through
      }
     set poetsey "The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $adjective_poetic], [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $adjective_poetic], [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic] , [? $adjective_poetic] ,[? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $adjective_poetic], [? $noun_subject],The [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $adjective_poetic], [? $noun_subject],"

     lappend liner $poetsey
     set poetsey $liner
     return $poetsey

     }
    #-- Activate F-keys (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 }
      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 }
      bind .  <F5> {set backcolor [lpick {
      Bisque Aquamarine  }];
      set colorground $backcolor;
      .c configure -bg $colorground }
      bind . <F6> {set backcolor [lpick {AntiqueWhite3
      Bisque}];
      set colorground $backcolor;
      .c configure -bg $colorground }
     bind . <F7> {set backcolor [lpick {SeaGreen1
      Bisque}];
      set colorground $backcolor;
      .c configure -bg $colorground }
     bind . <F8> {set backcolor [lpick {AntiqueWhite3
      Bisque}];
      set colorground $backcolor;
      .c configure -bg $colorground }
  # some words/meanings from 8th century poems
  # english articles dumped for asterisk
  array set en_chinese {
    bird   naio
    water   shui
    cloud     yun
    smoke    yan
    come      lai
    rain     yu
    he       ta
   she       ta
    it       ta
    cat      mao
    horse    ma
    girl     nuer
    two      lian
    one      yi
    above    shang
   add       jia
   admiral    haijunshang
   aches    tong
   hear     ting
   air      kongqi
   wind     feng
   airplane  feiji
   airport   feijichang
   alley hutong
   apple    pingguo
   apart    lu
   arm      gebo
   apricot xing
   armchair  fushiuyi
   atlas    dituji
   asparagus   lusun
   ask      wen
   arrow    jian
    arrive   daoda
    author  zuiozhe
   attic    gelou
   autumn   qiu
   axe futou
   axle  lunzhou
   ball   qiu
   ballet  baleiwu
   baby   yinger
   bag    bao
   barge  bochuan
   barley  damai
   barracks yingfang
    bank  yinhang
    bathtub  lahncheo
    bay  haiwan
    battery  dianchi
   bed chuang
   beautiful  meili 
   beard  huzi
   bean  dou
   bear  xlong
   beak  hui
   bead jhuzi
   beach haitan
   beehive  fengxiang
   bell leeng
   beer pijiu
   biscuit binggan
   big da
   bike zixingche
   blanket tanzi
   boat zhou
   blossom hua
   bloom hua
   blood xue
   blonde jinse
   bone gu
   bottle pingzi
   book shu
   branch shuzhi
   bow gong
   hill shan
   deer lu
   sea hai
   night ye
   sky tian
   tomarrow mingtian
   heart xin
   rock  shi
   song  ge
   year nian
   pine song
   rice mi
   door men
   gate men
   open kai
   moon yue
   dry gan
   dark hei
   black hei
   red hong
   field yuan
   yellow huang
   not bu
   carriage che
   bright ming
   guang shine
   frost shuang
   head tou
   white bai
   eve wan
   cup bei
   stove lu
   small xiao
   fire huo
   tear lei
   sit zuo
   first xian
   cut duan
   dream meng
   sand sha
   grass cao
   star xing
   shore an
   river jiang
   flat ping
   sun ri
   goose yan
   sound sheng
   duck ya
   lamp deng
   root gen
   by yu
   in zai
   pear li
   pearl zhenzhu
   path xiaodao
   wants yao
   wasp huangfeng
   watch kan
   see kan
   green luse
   The *
   the *
   hard ying
   blue lan
   dance tiaowu
   snow xue
   broad kuan
   brown zongse
   high gao
   long chang
   look kan
   wild yesheng
   wide kuan
   town zhen
   fall liu
   to ge
  rose meigui
  cave shandong
  cedar song
  lone dandu
  leaps tiao
  jumps tiao
  walk zou
   bygone yu
  tree shu
  dawn liming
 cool liang
  moth kunchong
insect kunchong
mouse laoshu
mosquito wenzi
moss moss
gray cangbai
pale cangbai
 moss lu
before zai
fore zai
salt yan
sail fan
deep shen
deer lu
weed zhiwu
plant zhiwu
kelp haizhiwu
thick hou
shine zhaoyao
shoe xie
lush duo
hears ting
hear ting
pond chitang
pool chitang
for wei
far yuan
at zai 
pea xiaodou
morn zaochen
morning zaochen
lost milu
peace heping
plum lizi
sad nanguo
grief nanguo
storm fengbao
sits zuo
sleep shuimian
sleeps shuimian
mist wu
wave bolang
jade yu
reed cao
know zhu
float piao
takes you
has you
smile xiao
cricket kunchong
quince yingtao
cherry yingtao
burns huo
roost chang
mount shan
slope shan
ice xue
fly fiji
snail wongnui
poor qiong
silk si
tea chai
rough buping
move zhou
flys fiji
 move zhou
road li
strean he
river he
cry ti
through zai
drift zhou
drifts zhou
perch yu
carp yu
glad gaoxing
falls liu
thin shou
soak shui
loves ai
ghost ti
ant kunchong
dusk heitian
peach tao
towards zai
ink moshui
fence liba
lake he
dove naio
lies zhi
is zhi
soil du
elm shu
oak shu
crane niao
nest chang
cheer guoxing
worm wongnu
rabbit tuzhu
month yue
flips zhou
waits zhou
grows sheng
bark shu
flower hua
crest xia
breeze xiaofeng
leaves shu
leaf shu
hare tuzhu
waits zho
snake she
serpent she
shade si
stone shi
flow liu
return gui 
}

 proc translationx {string dictName} {
    upvar 1 $dictName dict
    set res {}
    foreach word $string {
        if [info exists dict($word)] {set word $dict($word)}
        lappend res $word
    }
    set res
 }
proc plural word {
    switch -- $word {
        man   {return men}
        foot  {return feet}
        goose {return geese}
        louse {return lice}
        mouse {return mice}
        ox    {return oxen}
        tooth {return teeth}
        calf - elf - half - hoof - leaf - loaf - scarf
        - self - sheaf - thief - wolf
              {return [string range $word 0 end-1]ves}
        knife - life - wife
              {return [string range $word 0 end-2]ves}
        auto - kangaroo - kilo - memo
        - photo - piano - pimento - pro - solo - soprano - studio
        - tattoo - video - zoo
              {return ${word}s}
        cod - deer - fish - offspring - perch - sheep - trout
        - species
              {return $word}
        genus {return genera}
        phylum {return phyla}
        radius {return radii}
        cherub {return cherubim}
        mythos {return mythoi}
        phenomenon {return phenomena}
        formula {return formulae}
    }
    switch -regexp -- $word {
      
      {[ei]x$}                  {return [string range $word 0 end-2]ices}
      {[sc]h$} - {[soxz]$}      {return ${word}es}
      {[bcdfghjklmnprstvwxz]y$} {return [string range $word 0 end-1]ies}
      {child$}                  {return ${word}ren}
      {eau$}                    {return ${word}x}
      {is$}                     {return [string range $word 0 end-2]es}
      {woman$}                  {return [string range $word 0 end-2]en}
      
    }
    return ${word}s
 }
proc phonesort2 { list } {
    #KBK (14 February 2001)
     foreach name $list {
	regsub {Ma?c ?([A-Z])} $name {M_\1} key
	lappend list2 [list $key $name]
    }
    foreach pair [lsort -index 0 -ascii $list2] {
	lappend list3 [lindex $pair 1]
    }
    return $list3
 }
global baseline
global en_chinese

set baseline [list man goose foot woman dives];
foreach oppie $baseline {
set letter "string";
set letter [string range $oppie  end end];
set letterx "s";
if { $letter != $letterx } {
lappend baseline [plural $oppie]; 
} else {
lappend baseline $oppie; }
}
.wxx insert end " $baseline xxx";
.wxx insert end "man xxx [plural "man"] xxx";
set baseline [list water bird smoke come];
.wxx insert end "xxx $baseline xxx";
set stringj [list ];
set stringj [translationx "water bird smoke come" en_chinese]
.wxx insert end $stringj ;
.wxx insert end "xxxx trans [translationx $baseline en_chinese]" ;
set listxxx [list MacDonald McArthur McEwan Lyttle Mabbs Jones]
.wxx insert end "xxxx sort xxxx $listxxx xxx [phonesort2 "$listxxx"]" ;
     proc down(canvas) {w x y} {global colorground; set colorground $::Fill; \
      .c configure -bg $colorground}
  proc move(canvas) {w x y} {}
  proc down(exit) {w x y} {
     exit
   }
   proc move(exit) {w x y} {}
 
   proc down(clear) {w x y} {
    $w delete "all" 
   }
 

 proc reset {w} {
  $w delete "all" 
}
#end of deck

   #end of deck
   #end of deck
   #end of deck



 #Refrigerator_Magnetic_Poetry
  # Start of Deck
  #Refrigerator_Magnetic_Poetry
  # Start of Deck
   package require Tk
  proc radio {w var values {col 0}} {
   frame $w
   set type [expr {$col? "-background" : "-text"}]
   foreach value $values {
       radiobutton $w.v$value $type $value -variable $var -value $value \
           -indicatoron 0
       if $col {$w.v$value config -selectcolor $value -borderwidth 3}
   }
   eval pack [winfo children $w] -side left
   set ::$var [lindex $values 0]
   set w
 }

 proc down(Draw) {w x y} {
   set ::ID [$w create line $x $y $x $y -fill $::Fill]
 }
 proc move(Draw) {w x y} {
   $w coords $::ID [concat [$w coords $::ID] $x $y]
 }

 #-- Movement of an item
 proc down(Move) {w x y} {
   set ::ID [$w find withtag current]
   set ::X $x; set ::Y $y
 }
 proc move(Move) {w x y} {
   $w move $::ID [expr {$x-$::X}] [expr {$y-$::Y}]
   set ::X $x; set ::Y $y
 }

 #-- Clone an existing item
 proc serializeCanvasItem {c item} {
   set data [concat [$c type $item] [$c coords $item]]
   foreach opt [$c itemconfigure $item] {
       # Include any configuration that deviates from the default
       if {[lindex $opt end] != [lindex $opt end-1]} {
           lappend data [lindex $opt 0] [lindex $opt end]
           }
       }
   return $data
   }
 proc down(Clone) {w x y} {
   set current [$w find withtag current]
   if {[string length $current] > 0} {
       set itemData [serializeCanvasItem $w [$w find withtag current]]
       set ::ID [eval $w create $itemData]
       set ::X $x; set ::Y $y
   }
 }
 interp alias {} move(Clone) {} move(Move)

 #-- Drawing a rectangle
 proc down(Rect) {w x y} {
    set tile  [expr {int(rand()*1000000000.)}]
    set poof  "rectangle" ;
    set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];
    set ::ID [$w create rect $x $y $x $y -tags $tagx -fill $::Fill]
 }
 proc move(Rect) {w x y} {
   $w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
 }

 #-- Drawing an oval (or circle, if you're careful)
 proc down(Oval) {w x y} {
    set tile  [expr {int(rand()*1000000000.)}]
    set poof  "oval" ;
    set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];
   set ::ID [$w create oval $x $y $x $y -tags $tagx -fill $::Fill]
 }
 proc move(Oval) {w x y} {
   $w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
 }

 proc down(Poly) {w x y} {
   if [info exists ::Poly] {
    set tile  [expr {int(rand()*1000000000.)}]
    set poof  "poly" ;
    set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];



       set coords [$w coords $::Poly]
       foreach {x0 y0} $coords break
       if {hypot($y-$y0,$x-$x0)<10} {
           $w delete $::Poly
           $w create poly [lrange $coords 2 end] -fill $::Fill 
           unset ::Poly
       } else {
           $w coords $::Poly [concat $coords $x $y]
       }
   } else {
       set ::Poly [$w create line $x $y $x $y -tags "obj_[expr {int(rand()*1000000000.)}]" -fill $::Fill ]
   }
 }

 proc ? L {
   lindex $L [expr {int(rand()*[llength $L])}]
   #suchenwirth_subroutine;
   }
 proc move(Poly) {w x y} {#nothing}


 #-- With little more coding, the Fill mode allows changing an item's fill color:
 proc down(Fill) {w x y} {$w itemconfig current -fill $::Fill}
 proc move(Fill) {w x y} {}

 #-- Building the UI
 set modes {Draw Move Clone Fill Rect Oval Poly Poetry exit}
 set colors {
   black white magenta brown red orange yellow green green3 green4
   cyan blue blue4 purple 
 }
     global liner
     global ind
     set ind 0
    global   movesit
    set  movesit 1
    global xhistory firstnode curnode
    set curnode ""
    set firstnode ""
    set xhistory [list aaa bbb ccc ddd eee fff ggg ]
    set colorground bisque
    global selected_tile previous_tile
    set selected_tile "selected tile";
    set previous_tile "previous tile";
     global counter
     global liner
     global ind
     set ind 0
     set liner [list a b c d e f g ]
     global tilex tagx tagz
     set tilex "obj_66666test"
     set tagx "obj_77777test"
     set tagz "obj_55555test "
     global entries
     set counter 0
 grid [radio .1 Mode $modes] [radio .2 Fill $colors 1]  -sticky nw 
 grid [canvas .c -relief raised -borderwidth 1] - -sticky news


 grid rowconfig . 0 -weight 0
 grid rowconfig . 1 -weight 1
   button .b2 -text dismiss -command "destroy ." 
    button .b3 -text exit -command "exit" 
 button  .b5 -text "Del_tank" -width 2  -command { .wxx delete 1.0 end}

    button  .b6 -text "lt_bg" -bg gray -width 2 \
  -command { set colorground LightBlue1; 
    .c configure -bg $colorground  }
    button  .b7 -text "bis_bg" -width 3 \
  -command { set colorground Bisque; \
    .c configure -bg $colorground  }
   
    grid .b2 .b3 .b5 .b6 .b7 
 grid rowconfig . 0 -weight 0
 grid rowconfig . 1 -weight 1
 grid [ label .wcc -text "list of selection history " ]
 grid [entry .wxxccc -textvar e -just left -bg beige -width 50] 
 #.wxxccc insert end  "$liner"
 set wow [.c find withtag current];
 .wxxccc insert end  "xxx starter xxx $wow xxx"
 focus .wxxccc           ;# allow keyboard input
 set labelx  [info tclversion];
 grid [ label .ww -text "holding tank, version $labelx " ]
 set txt [text .wxx -width 20 -height 3 -bg beige]
   grid  $txt -sticky news
 focus .wxx           ;# allow keyboard input
 set wow [.c find withtag current];
 .wxx insert end  "xxx starter xxx $wow xxx ";


 #-- The current mode is retrieved at runtime from the global Mode variable:
 bind .c <1> {set firstnode [.c find withtag current];initialize %W %x %y ;down($Mode) %W %x %y}
 bind .c <B1-Motion> {move($Mode) %W %x %y}
 bind .c <2>         {%W delete current}
 bind .c <3> {
      #set firstnode [.c find withtag green]
      set firstnode [.c find withtag current]
      set curnode [.c find withtag current]
      set tile [.c find withtag current]
      #set curnode [.c find withtag red]
      if {( $firstnode != "") && ($curnode != "")} {
     dualcheck $tile $firstnode $curnode }}
 proc move(Poetry) {w x y} {
  if [info exists ::X] {
 $w move $::ID [expr {$x-$::X}] [expr {$y-$::Y}]
   set ::X $x; set ::Y $y}
 }
 proc down(exit) {w x y} {
   exit
 }
 proc down(Poetry) {w x y} {
      set dy 40
      set dx 40
      set dk 10 
      set poof "tester";
      set looky "stringx";
      set tile "tile"
      set tagx  [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
  #set tags [list mv d-$val1$val2];
 
     #set tile  [expr {int(rand()*1000000000.)}]
    #set looky "stringx";
    #set poof  [xpop $looky ] ;
     #set tags [list $poof mv obj_$tile  d-$val1$val2];
 #set tags [list $poof mv "obj_$tile+1"   d-$val1$val2];
     #set tagx [list $poof mv "obj_$tile+1"   d-$x$y];
 for {set i 0; set y  [expr {4+$y}];set x  [expr {10+$dx}]; } {$i<5} {incr i; incr x $dx} {
   set state1 1;
 set tile  [expr {int(rand()*1000000000.)}]
    set looky "stringx";
    set poof  [xpop $looky ] ;
    set tagx [list $poof mv "obj_$tile"   d-$x$y];
      set ::ID [$w create text $x $y  -text $poof -tags $tagx -fill $::Fill ]
    }
     for {set i 0; set y [expr {8+$y}];set x [expr {10+$dx}] ;} {$i<7} {incr i; incr x $dx} {
   set state1 1;
 set tile  [expr {int(rand()*1000000000.)}]
    set looky "stringx";
    set poof  [xpop $looky ] ;
 set tagx [list $poof mv "obj_$tile"   d-$x$y];
      set ::ID [$w create text $x $y  -text $poof -tags $tagx -fill $::Fill ]
    }  
   for {set i 0; set y  [expr {12+$y}];set x [expr {15+$dx}];} {$i<5} {incr i; incr x $dx} {
   set state1 1;
 set tile  [expr {int(rand()*1000000000.)}]
    set looky "stringx";
    set poof  [xpop $looky ] ;
    set tagx [list $poof mv "obj_$tile"   d-$x$y];
      set ::ID [$w create text $x $y  -text $poof -tags $tagx -fill $::Fill ]
    }

 }
 proc history {xhistory } {
 set xhistory [list object history @];
 global xhistory firstnode curnode
      global ind movesit
      set number 2
       set numberx 2
       
       set firstnode [.c find withtag current]
 lappend  $xhistory  $firstnode ;
 set ::ID [.c create text 100 200  -text $xhistory -tags " history " -fill $::Fill -fill black ] 
 }
    proc dualcheck { tile firstnode curnode} {
     global match_id selected_tile tiles_left jack
     global newy oldy match oldx xhistory
    global selected_tile previous_tile
    global xhistory
    global tilex
    #global firstnode curnode
    set selected_tile "selected tile";
    set colorxxx "test"
    set colorzzz "test"
       #set previous_tile "previous tile";
       set numberx [.c  gettags current];
       regexp {obj_(\d+)} $numberx -> tilex
       regexp {colorit_(\d+)} $numberx -> colorxxx
       regexp {colorit_(\d+)} $numberx -> colorzzz
      set indexer [string first "mv" $numberx ];
       set indexer [ expr { $indexer - 1 } ]
      set new  [string range $numberx 0 $indexer ];
     set tags [.c  gettags current]
     #.c itemconfigure obj_$tilex -width 2 -outline red;
     #.c itemconfigure $previous_tile -width 2 -outline green;
     # .c itemconfigure obj_$tilex -width 3  ;
    # .c itemconfigure $previous_tile -width 3  ;
     set old "test"
     set kkk [.c  gettags $previous_tile ]
     set indexer [string first "mv" $kkk ]; ;
      set indexer [ expr { $indexer - 1 } ]
      set old  [string range $kkk 0 $indexer ];
    if {$old == ""} {set old "poof $previous_tile"}
   set tx [string range $tilex  0 end ];
    set rx [string range $previous_tile 4 end ];
     if { $tx !=  $rx } {
     .wxx delete 1.0 end;
     .wxx insert end  "  pair error identified, text not equal !!!"  ;
     }

   if { $old ==  $new } {
    set tx [string range $tilex  0 end ];
    set rx [string range $previous_tile 4 end ];
     if { $tx ==  $rx } {
     .wxx delete 1.0 end;
     .wxx insert end  "  pair error identified, double touch of same tile !!!"  ;
     }
     if { $tx !=  $rx } {
   #.c itemconfigure obj_$tilex -width 2 -outline blue;
   #.c itemconfigure $previous_tile -width 2 -outline blue;
   .wxx delete 1.0 end;
   .wxx insert end " xxx $tilex xxx $tx xxx $rx xxx $previous_tile xxxx  ";
   .wxx insert end  $previous_tile;
   .wxx insert end  "  old $old ";
   .wxx insert end  $old;
   .wxx insert end  " identical pair identified !!!"  ;
   .wxx insert end " xxx old $old xxx new xxx $new  ";
   .wxx insert end  $new;
   .wxx insert end "obj_tilex obj_$tilex "
       regexp {colorit_(\d+)} $numberx -> colorxxx
       regexp {colorit_(\d+)} $previous_tile -> colorzzz
   if { $colorxxx ==  $colorzzz } {
   .c delete "$previous_tile+1";
   .c delete "obj_$tilex+1" ;

   .c delete obj_$tilex ;
   .c delete $previous_tile;
   }
   }

   }
     #.wxx delete 1.0 end;
     set $selected_tile $tags;
     .wxx insert end $tags ;
     .wxx insert end " selected_tile equals $new ";
     if {  $previous_tile != $selected_tile  } {
      set previous_tile [.c  gettags current]
      set indexer [string first "mv" $previous_tile ];
       set indexer [ expr { $indexer - 1 } ]
      set old  [string range $previous_tile 0 $indexer ];
     .wxx insert end " previous_tile equals $old ";
     }
     #.c itemconfigure  $curnode -width 2 ;
     set previous_tile obj_$tilex
     set firstnode obj_$tilex;
     if { $firstnode != $curnode } {
     set curnode obj_$tilex;}
    .wxx insert end " current equals $curnode ";
    .wxx insert end " first equals $firstnode ";
   return }
   proc initialize {w x y} {
      global tile
      global xhistory firstnode curnode
      global ind movesit
    set tile [.c find withtag current]
      set number 2
       set numberx 2
       set ::_x $x; set ::_y $y;
       set firstnode [.c find withtag current]
    set number  [$w gettags current]
     set indexer [string first "mv" $number ];
     set numberx  [string range $number 0 $indexer];
       .wxx delete 1.0 end;
     # general reporting line
    .wxx insert end " xxx $number xxx $numberx xxx \
   indexer  xxx  $indexer xxx number of tiles xxxx \
   $ind xxxx object xxx $tile xxx $ind xxx number of \
    straight moves xxx $movesit xxx ";
     #.wxxccc delete 1.0 end;
     # general reporting line
    .wxxccc insert end " xxx $number xxx $numberx xxx \
   indexer  xxx  $indexer xxx number of tiles xxxx \
   $ind xxxx object xxx $tile xxx $ind xxx number of \
    straight moves xxx $movesit xxx ";
     incr movesit
        
    }

    proc lpick L {lindex $L [expr int(rand()*[llength $L])]; \
    #suchenwirth_subroutine;}
  proc stringxxx s {
       #suchenwirth_subroutine;
       set res {}
      foreach line [split $s \n] {
         for {set i 0} {$i<[string length $line]} {incr i} {
            if {$i==[string wordstart $line $i]} {
               set w [string range $line $i [expr {[string wordend $line $i]-1}]]
               #if {$w!=" "} {lappend res $w}
               #if {$w!=" " && $w!="\{" && $w!="\}"} {lappend res $w}
               if {$w!=" " && $w!="\{" && $w!="\}" && $w!="\," && $w!="\\" && $w!="\/"} {lappend res $w}
               #if {$w!="\}"} {lappend res $w}
               #if {$w!="\{"} {lappend res $w}
               incr i [expr {[string length $w]-1}];

               # always loop incr
            }
         }
      }
      set res

   }
 proc xpop { topper } {
   global liner
   global ind
   set poetsey aaaaa

   set liner [poemsorts $poetsey];

   set goofy [stringxxx $liner] ;

   set topper [ lindex $goofy $ind ];

   set ind [ expr { $ind + 1}]
   return $topper;
   }
  proc helptext {stringxxx} {
     set text_texas {
     # Refrigerator magnet 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.
     # Various Esc and F-keys activate
     # to exit program or change background color.
     # Sliding right mouse across piece
     # should delete same.
     # Pick and Sliding left mouse across piece
     # should move same.
     # Selecting piece with middle mouse
     # should delete same piece.
     # Selecting pair of [same text] pieces
     # [in sequence] with right mouse
     # should delete same piece.
     # Right mouse uses initialization from
     # left mouse, so one has to pick
     # one tile with left mouse for
     # game start.
     # 5/7/5 words per line is
     # setting for Japanese Haiku poetry.
     # Other procedures working
     # on windows98 and old PC.
     # from goldshell7 on 10jun2006.}
     return text_texas;}
     
   proc poemsorts {poetsey} {
    global liner
    #set liner [list q w e r]
    set liner [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
    set adjective_poetic {
      {red} {sad} {blue} {blue}
      {glad} {flawed} {deep} {black}
     {wild } { green } {pale } {bright} 
     {rough } {gray } {brown } {long}
     {high } {thin} {brown } {lush} 
     {dry } {poor} {lone } {far}
     {flat } {broad} {thick } {hard}
     {flat } {broad} {cool } {hard}    
    }
    set noun_subject {
      cat  mouse  reed { pear }
      {quince } { peach } {hare } {bird} 
     { smoke } { rain} { ice} { snow} 
      {cloud} { home} { flower } {sky} 
      {rice} { pine} { mist} {door} 
      {wind} { cricket} { year } {moon} 
      {crane } {grass } {rose} { ink} 
      {thaw} { bloom } {lake} { cedar } 
      {dusk} { autumn } {stone} { dawn} 
      {stream} { tree } {heart} { boat}
      {grief} { tree } {shack} { boat}
      {rock} {town} {tear} {pool} 
      {silk} {deer} {song} {barge}
      {moss} {night} {gate} {fence}
      {dove} {dream} {frost} {peace}
     {shade} {ghost} {road } {path} 
     {root} {horse} {eve } {sound}
     {sleep} {leaves} {sea } {sail}
     {peak} {stem} {field} {wave}
     {slope} {bark} {crest} {weed}
     {moth} {wasp} {pond} {soil} 
     {snail} {worm} {ant} {kelp}
     {cave} {month} {head} {jade} 
       {branch} {bone} {head} {smile}
      {pea} {bone} {head} {smile}
     {elm} { morn} {carp} {nest}
     {oak} { bone} {perch} {breeze}       
      mount  plum  storm  hill 
    }
    set verb_transitive {falls  
    {snow} { burns} { flips} { flys }
    {lies} { walk } {flow } {fall} { pluck}
     {know } {come} { meet } { drift}
   {shine } {soak} { cry } {dance} 
    { lost} {cheer}  {float } {dance}
   {roost} { move} { fade} { loves}
    {sleeps} {sighs} {takes } {sail}
   {sits} {leaps} {spars } {shakes} 
   {sits} {leaps} {grows } {waits}
    {loses} {hears} {wants } {watch}
    }
    set noun_objective {
       cloud {old home} flower { sky } rice {cricket}
    }
    set silly_propostion {
       for {by} towards { to } at {bygone}
       {to} {in} {in } {to }
       {to} {in} {fore } through 
    }
   set poetsey "The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $adjective_poetic], [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $adjective_poetic], [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic] , [? $adjective_poetic] ,[? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $adjective_poetic], [? $noun_subject],The [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $adjective_poetic], [? $noun_subject],"

   lappend liner $poetsey
   set poetsey $liner
   return $poetsey

   }  
  #-- Activate F-keys (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 }
    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 }
    bind .  <F5> {set backcolor [lpick {
    Bisque Aquamarine  }];
    set colorground $backcolor;
    .c configure -bg $colorground }
    bind . <F6> {set backcolor [lpick {AntiqueWhite3
    Bisque}];
    set colorground $backcolor;
    .c configure -bg $colorground }
   bind . <F7> {set backcolor [lpick {SeaGreen1
    Bisque}];
    set colorground $backcolor;
    .c configure -bg $colorground }
   bind . <F8> {set backcolor [lpick {AntiqueWhite3
    Bisque}];
    set colorground $backcolor;
    .c configure -bg $colorground }
 #end of deck
 #end of deck
 #end of deck
 #end of deck


   #end of deck
----


      ''Code Reuse'':   Tcl's package system makes it easy to write code that can be reused.
   Many  other people have made their 
 code available for reuse.
----
 ''Q. from goldshell7'':I am trying to load a feature or  
 subroutine "select&pair_then_die" ,
 where one selects two equal pieces in color,text, or 
 tags. If the two pieces are equal , both pairs disappear from
 the screen ( or to a hockey safety zone on the screen). 
 Kind of like the old Microsoft Mahjong game, which
 was an elimination process of equal pairs.
----
  ''A. received''
 You should make up unique tags 
 and assign them to both the rect   
 and the text inside it, and for convenience,
 another one for   the  text only.
 incr n 
 $w create rect ... -tags [list mv obj$n]
 $w create text ... -tags [list mv obj$n text$n]
 For moving, specify the obj.. tag so both move together.
 
 To get the tags of the current selection, try something like:
 set tags [$w gettags current]
 
 In the returned list, locate the tag with the obj number, 
  e.g.    like this
 regexp {obj(\d+)} $tags -> number
 
 You can retrieve the text by giving the tag
 set text [$w itemcget text$number -text]
 end of record.

----
 ''Q. from goldshell7'':28jul2006,would like
   selected tiles to have a red, blue, or   
   colored    outline. However

  commented ".c itemconfigure tile_number -outline
 red"  colored outine but reverts text font to 
  vertical arranged text.

  Maybe somebody can figure how to keep text 
  horizontal.
----

[Category Toys]