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.


'''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 dx 50
   set dy 50
   set size 30
   set colorground bisque
   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.
   # Sliding middle mouse across piece
   # might delete same piece or other pieces.
   # 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 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 xpop { topper } {
 global liner
 global ind 

 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 
     variable bg; variable fg; variable size
      set jack [lpick {red yellow blue purple \
      pink green brown black  gray}]
   set jill rose
     #remaining doctered_suchenwirth_subroutine;
     set tags [list mv d-$val1$val2];
     #remaining doctered_suchenwirth_subroutine;
     set x1 [expr {$x+$size-0.5}]
     set y1 [expr {$y+$size}]
     $w create rect $x $y [expr {$x+2*$size}] $y1 \
         -fill $jack -tags [linsert $tags 0 bd-$val1$val2]
     #$w create text [expr {$x+1*$size}]   [expr {$y+0.5*$size }] \
        -text   [eval poetry $jill] -fill $fg -tags $tags
    set looky "rook"
    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] [? $noun_subject]. The [? $adjective_poetic] [? $noun_subject] [? $verb_transitive] [? $silly_propostion] [? $adjective_poetic] [? $noun_subject] . The [? $adjective_poetic] [? $noun_subject] [? $verb_transitive] [? $silly_propostion] [? $adjective_poetic] [? $noun_subject]. The [? $adjective_poetic] [? $noun_subject] [? $verb_transitive] [? $silly_propostion] [? $adjective_poetic] [? $noun_subject]. The [? $adjective_poetic] [? $noun_subject] [? $verb_transitive] [? $silly_propostion] [? $adjective_poetic] [? $noun_subject]."
  #set liner [list a b c d e f g ]
  set liner [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
 lappend liner $poetsey
 set looky "stringx"
   $w create text [expr {$x+1*$size}]   [expr {$y+0.5*$size }] \
        -text   [xpop $looky ] -fill $fg -tags $tags

  }

  if 0 {Clicking on a piece records \
  the click position, and its "catch-all"  tag, \
  in global variables:}
  proc mv'1 {w x y} {
     set ::_x $x; set ::_y $y;#suchenwirth subroutine;
     foreach tag [$w gettags current] {
         if [regexp ^(d-.+) $tag -> ::_tag] break
     }
  }
   if 0 {Moving the mouse with button 1 down \
  moves the items with the  "catch-all" tag \
  with the mouse pointer:}
 proc 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 yyyy
     global text_texas
     incr yyyy 10
     $w create text 800 50 -text $text_texas  -tags "text"
   }

   proc itembox {w} {
     global xx1 yy1 xx2 yy2
     $w create rect  50  10  100  60  -tags "box"
     $w create rect $xx1 $yy1  $xx2 $yy2  -tags "box"
     incr xx1 15
     incr xx2 15
     incr yy1 10
     incr yy2 10
   }
 
   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

   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 { itembox    .c }
   button  .b4 -text "exit"   -command { exit }
   button  .b5 -text "destroy"   -command { destroy . }
   
  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 "exit"   -command {  [exit]  }
 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 {set state1 1;
     set val1 1; 
  set val2 1;
    for {set i 0; set y 0} {$i<8} {incr i; incr y $dy} {
     for {set j 0; set x 0} {$j<8} {incr j; incr x $dx}   {
   set val1 $i; 
  set val2 $j;
     set tags [list mv d-$val1$val2];       
 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 looky "stringx";
  set looky "stringx"
 #  .c create text [expr {$x+1*$size}]   [expr {$y+0.5*$size }] \
        -text   [xpop $looky ] -fill blue -tags $tags; 
  .c configure -bg $jack
    .c create text [expr  $j*65+40]   [expr $i*35+100+12 ] \
        -text  [eval poetry $jill]  -fill blue -tags $tags;
 
 }
  }
 ;random_poetry .w; }

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

  if 0 {Moving the mouse with button 1 \
  down moves the items with the   "catch-all" tag \
  with the mouse pointer:}
   proc move&die {w x y} {
    # remove selected pieces & other pieces
   # by moving middle mouse
   #  on top of them, not working too well
   $w raise $::_tag
     $w move $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}]
    $w delete $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}]
     set ::_x $x; set ::_y $y

  }
  if 0 {Clicking on a piece records the click position, \
  and its  "catch-all" tag, in global variables:}
  proc select&die {w x y} {
       # remove selected pieces by moving right mouse
      # on top of them,  working better
   set ::_x $x; set ::_y $y
     foreach tag [$w gettags current] {
         if [regexp ^(d-.+) $tag -> ::_tag] break
     }
   $w delete $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}]
   }
   set size 30
   .c bind mv <1>         {mv'1 %W %x %y}
   .c bind mv <B1-Motion> {mv'motion %W %x %y}
  .c bind mv <B3-Motion> {select&die %W %x %y}
  .c bind mv <B2-Motion> {move&die %W %x %y}
   #-- 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])}]
 }



 proc poem_of_sorts {poetsey} {
  global liner 
  #set liner [list q w e r]
  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], [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic] [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $noun_subject],The [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $noun_subject],"

 set liner $poetsey
 return $poetsey
 
 }


  if { 1 == 1 } {
  package require Tk
  #set anagrams [list]
  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 [poem_of_sorts {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 .]]
    join  $liner $liner
    join  $liner [poem_of_sorts {poetsey}]
    join  $liner [poem_of_sorts {poetsey}]
    join  $liner [poem_of_sorts {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
      }
   }

  #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.


[Category Toys]