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
  namespace eval xpoetry {
     variable bg black  fg white  size 30
     global jack
     global jill
     global liner
   
     set  movesit 1
      }
   set dx 50
   set dy 50
   set size 30 
  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 entries
   set counter 0
   # Refrigerator_Magnetic_Poetry
   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. Other procedures working
   # on windows98 and old PC.
   # from goldshell7 on 10jun2006.}
     proc getvalues {path default1 default2} {
  global getvalues

   if {![winfo exists $path]} {
   toplevel $path
   frame $path.buttons
   button $path.buttons.ok -text OK \
  -command [list set getvalues($path) "ok"]
  button $path.buttons.cancel -text Cancel \
  -command [list set getvalues($path) "cancel"]
 pack $path.buttons.ok $path.buttons.cancel -side right
 #label $path.l1 -text "Value 1:"
 #label $path.l2 -text "Value 2:"
 label $path.l1 -text "state1:"
 label $path.l2 -text "state2:"

 entry $path.e1
 entry $path.e2
 grid $path.l1 -row 0 -column 0 -sticky e
 grid $path.e1 -row 0 -column 1 -sticky ew
 grid $path.l2 -row 1 -column 0 -sticky e
 grid $path.e2 -row 1 -column 1 -sticky ew
 grid $path.buttons -row 2 -column 0 -columnspan 2 \
 -sticky ew -pady 4
 }

 $path.e1 delete 0 end
 $path.e1 insert 0 $default1
 $path.e2 delete 0 end
 $path.e2 insert 0 $default2

 wm deiconify $path
 tkwait variable getvalues($path)

 wm withdraw $path
 if {$getvalues($path) eq "ok"} {
 set value1 [$path.e1 get]
 set value2 [$path.e2 get]
 return [list $value1 $value2]
 } else {
 return {}
 }
 }
 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}
    { joyful} {  flawed }
  }
  set noun_subject {
  {cat} {  apple} { garlic}
    { quince} { mallow}
     { smoke} {  rain}
  }
  set verb_transitive {falls snow burns flips flys lies}
  set noun_objective {
     cloud {old home} flower { sky } rice {cricket}
  }
  set silly_propostion {
     for {by} towards { to } at {bygone}
  }
 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

 }
  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 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 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 firstnode curnode
  set selected_tile "selected tile";
 
     #set previous_tile "previous tile";
     set numberx [.c  gettags current]
     regexp {obj_(\d+)} $numberx -> tilex
    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 "
.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 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 ? L {
 lindex $L [expr {int(rand()*[llength $L])}]
 #suchenwirth_subroutine;
 }
     proc xpoetry::create {w x y val1 val2} {
    global jack
    global jill
    global liner
    global tile ind
     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}]
   set tile  [expr {int(rand()*1000000000.)}] 
  set looky "stringx";
  set poof  [xpop $looky ] ;
   set tags [list $poof mv obj_$tile  d-$val1$val2];
     $w create rect $x $y [expr {$x+2*$size}] $y1 \
         -fill $jack -tags [linsert $tags end bd-$val1$val2]
     #$w create text [expr {$x+1*$size}]   [expr {$y+0.5*$size }] \
        -text   [eval poetry $jill] -fill $fg -tags $tags
    set looky "rook"

 set liner [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
 set looky "stringx"
   #$w create text [expr {$x+1*$size}]   [expr {$y+0.5*$size }] \
        -text   [xpop $looky ] -fill $fg -tags $tags
 set tags [list $poof mv "obj_$tile+1"   d-$val1$val2];
   $w create text [expr {$x+1*$size}]   [expr {$y+0.5*$size }] \
        -text  $poof -fill $fg -tags $tags
incr tile
  }

  if 0 {Clicking on a piece records \
  the click position, and its "catch-all"  tag, \
  in global variables:}
  proc mv'1 {w x y} {
    global tile
    global xhistory firstnode curnode
    global ind movesit
    set number 2
     set numberx 2
     set ::_x $x; set ::_y $y;#suchenwirth subroutine;
     set firstnode [.c find withtag current]
     foreach tag [$w gettags current] {
         if [regexp ^(d-.+) $tag -> ::_tag] break
  set number  [$w gettags current]
   set indexer [string first "mv" $number ];
   set numberx  [string range $number 0 $indexer];
     .wxx delete 1.0 end;
.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 ";
  incr movesit
     } 
  }
   if 0 {Moving the mouse with button 1 down \
  moves the items with the  "catch-all" tag \
  with the mouse pointer:}
 proc clearclear {w} {
     $w delete "all"
   }

   proc itemcrosshairs {w} {
     set middlexxxx [expr { $::maximumxxxx/ 2 }]
     set middleyyyy [expr { $::maximumyyyy/ 2 }]
     $w create line 0     $middleyyyy $::maximumxxxx  $middleyyyy -tags "axis"
     $w create line $middlexxxx 0        $middlexxxx $::maximumyyyy -tags "axis"
   }

   proc itemtext  {w Txt} {

     global text_texas

     $w create text 800 50 -text $text_texas  -tags "text"
   }

   proc itembox {w} {

     $w create rect  50  10  100  60  -tags "box"

   }

   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

  }
   frame .f1
   frame .f2
   pack  .f1 .f2
   proc reset {} {
   set ::maximumxxxx 500
   set ::maximumyyyy 500
    set yyyy 50
   set dx 50
   set dy 50
   set size 30
   set colorground bisque
   global counter
   global liner
   global ind
   set ind 0
   set maximumxxxx 320
   set maximumyyyy 300
   set yyyy      0
   set xx1 120
   set xx2 150
   set yy1 120
   set yy2 150

   set x1 120
   set x2 150
   set y1  50
   set y2  80

   pack [canvas .c -bg $colorground -width 500 \
   -height 250 ] -fill both -expand 1
     set height 400
     set width  600
     set borderwidth 2
     set canvas .c
     set hscroll .hscroll
     set vscroll .vscroll
     scrollbar $hscroll -orient horiz -command "$canvas xview"
     scrollbar $vscroll    -command "$canvas yview"
  $canvas configure -scrollregion [$canvas bbox all]

   pack  .c $vscroll   $hscroll -in .f2

   button  .b0 -text "clear" -command { clearclear .c }
   button  .b1 -text "text"  -command { itemtext  .c "Canvas" }
   button  .b2 -text "hairs"  -command {  itemcrosshairs .c }
   button  .b3 -text "zone"   -command {
   set maximumxxxx 320;
   set maximumyyyy 300;
   set yyyy      0;
   set xx1 120;
   set xx2 150;
   set yy1 120;
   set yy2 150;
   itembox    .c }
   button  .b4 -text "exit"   -command { exit }
   button  .b5 -text "Del_tank"   -command { .w delete 1.0 end}

  button  .b6 -text "lt_bg"   -command { set colorground LightBlue1; \
  .c configure -bg $colorground  }
  button  .b7 -text "bis_bg"   -command { set colorground Bisque; \
  .c configure -bg $colorground  }
 button  .b8 -text "ran_bg"   -command {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  }
   button  .b9 -text "del_hisry"   -command {  .wxx delete 1.0 end    }
 button  .b10 -text "deal"   -command {set state1 1; random_poetry .w;
    }
    button  .b11 -text "state"   -command {set state1 1; getvalues .dialog one  two;random_poetry .w; }
     button  .b12 -text "reset"   -command {foreach i {.b0 .b1 .b2 .b3 .b4 .b5 .b6 .b7 .b8 .b9 .b10 .b11 .b12 .b14 .b15 .b16 .c .hscroll .vscroll} {
	    destroy $i
	}; reset }

 button  .b14 -text "open"   -command { file:open .w }
 button  .b15 -text "save"   -command { htm_print .w }
 button  .b16 -text "print"   -command { file:save .w }
  pack .b0 .b1 .b2 .b3 .b4 .b5 .b6 .b7 .b8 .b9 .b10 .b11 .b12 .b14 .b15 .b16 -in .f1  -side left -padx 2
  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}   {

 set state1 1;
   if {$state1 == 0    }  {  xpoetry::create .c [expr $i*65+10] [expr $j*35+100] $i $j  }
     if {$state1 == 1    } {xpoetry::create .c [expr $j*65+10] [expr $i*35+100] $i $j }
     }
  }
  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 <2> {select&die %W %x %y}
  set curnode ""
  set firstnode ""
  bind .c <3> {
    #set firstnode [.c find withtag green]
    set curnode [.c find withtag current]
    #set curnode [.c find withtag red]
    if {( $firstnode != "") && ($curnode != "")} {
   dualcheck $tile $firstnode $curnode }}


 }
 reset
  if 0 {Moving the mouse with button 1 \
  down moves the items with the   "catch-all" tag \
  with the mouse pointer:}
 
  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}]
   }
 if 0 {Clicking on a piece records the click position, \
  and its  "catch-all" tag, in global variables:}
  
   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 <2> {select&die %W %x %y}
     set curnode ""
  set firstnode ""
  bind .c <3> {
    #set firstnode [.c find withtag green]
    set curnode [.c find withtag current]
    #set curnode [.c find withtag red]
    if {( $firstnode != "") && ($curnode != "")} {
   dualcheck $tile $firstnode $curnode }}
   #-- 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 }
 set entries 1
 proc ? L {
 lindex $L [expr {int(rand()*[llength $L])}]
 }

 if { 1 == 1 } {
  package require Tk
  #set anagrams [list]
  pack [ label .wcc -text "list of selection history " ]
 pack [text .wxx -width 80 -height 20 -bg bisque  \
 -setgrid true  -width 70  \
 -height 2 -wrap word -highlightthickness 0 -borderwidth 0]
 .wxx insert end $xhistory

 set labelx  [info tclversion];
 pack [ label .ww -text "holding tank, version $labelx " ]

  pack [text .w -width 80 -height 20 -bg bisque  \
 -setgrid true  -width 70 \
 -height 35 -wrap word -highlightthickness 0 -borderwidth 0]
  #bind .w <1> {random_poetry %W; break}
  proc random_poetry w {
    global liner
    #global anagrams
    set liner  [ list a b c d e ]

    $w delete 1.0 end
    #$anagrams insert end [ poem_of_sorts liner]
    #poem_of_sorts
    #set liner [split  $liner {\.\}\{\"}]
    $w insert end [poemsorts {poetsey}]
    $w insert end $liner
    #$anagrams insert end [poem_of_sorts ]
    #$w insert end [ split $liner \.\}\{\"]
    #lpush   $liner [split [ poem_of_sorts ] \.\}\{\"]
    #join $liner [list [ split poetsey .]]
    #set liner eval[ poem_of_sorts ]
 }

  random_poetry .w

 }
 proc htm_print {w} {
       #suchenwirth_subroutine from taiku;
       # this works only on Windows 95..ME...
       set filename [file join $::env(TEMP) taiku.html]
       set fp [open $filename w]
       puts $fp [s2html [$w get 1.0 end]]
       close $fp
       exec $::env(COMSPEC) /c start [file nativename $filename] &
   }
   proc s2html s {
      #suchenwirth_subroutine from taiku;
      set res ""
       foreach line [split $s \n] {
           append res <br>
           foreach c [split $line ""] {
              set uc [scan $c %c]
              append res [expr {$uc>127? "&#$uc;" : $c}]
          }
       }
       set res
   }

   proc file:open {w} {
      #suchenwirth_subroutine from taiku;
      set fn [tk_getOpenFile]
      if [string length $fn] {
          $w delete 1.0 end
          set f [open $fn]
          #fconfigure $f -encoding euc-cn
          fconfigure $f
          foreach line [split [read $f] \n] {$w insert end $line\n}
          close $f
      }
   }
   proc file:save {w} {
      #suchenwirth_subroutine;
      set fn [tk_getSaveFile]
      if [string length $fn] {
          set f [open $fn w]
          #fconfigure $f -encoding euc-cn
          fconfigure $f
          puts $f [$w get 1.0 end-2c]
          close $f
      }
   }
  #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]
   #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 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.


[Category Toys]