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 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]