#Refrigerator_Magnetic_Poetry
    # Start of Deck
     package require Tk
     proc uniswap {L} {
     # removes duplicates without sorting the input list
     # swap asterisk with haiku poetic "cutting" words 
     global v t
     set t {}
     set v {}
     foreach i $L {if {[lsearch -exact $t $i]==-1} {lappend t $i}}
     foreach i $L {if { $i != "*" } {lappend v $i}
     if { $i == "*" } {lappend v   [lpick { 
 
      ya  kana zo yo keri}]     }

      }
     return $v
     } ;# RS

     proc plainsub {text item replacewith} {
    set text [string map [list $item $replacewith] $text] 
    }   



    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
   }

  proc luniq {L} {
     # removes duplicates without sorting the input list
     set t {}
     foreach i $L {if {[lsearch -exact $t $i]==-1} {lappend t $i}}
     return $t
  } ;# RS
   #-- 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} {}
    proc lcount list {
     foreach x $list {lappend arr($x) {}}
     set res {}
     foreach name [array names arr] {
        lappend res [list $name [llength $arr($name)]]
     }
     return $res
  }
  #lcount {yes no no present yes yes no no yes present yes no no yes yes}
  #{no 6} {yes 7} {present 2}
 proc translationx {string dictName} {
     #suchenwirth_subroutine;

   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 keyget {list key} {
    foreach {lkey value} $list {
        if [string equal $lkey $key] {return $value}
    }
 } ;# RS
 # % keyget {fnm John lnm Brown phone (123)456-7890 email [email protected]} phone
 # (123)456-7890
 # % keyget {fnm John lnm Brown phone (123)456-7890 email [email protected]} fax

 proc lswap list {
    set res {}
    foreach {a b} $list {lappend res $b $a}
    set res
 } ;# RS
 # % lswap {a b c d e f g h}
 # b a d c f e h g
 #Prepend elements to a list (add in front):

 proc lprepend {var args} {
    upvar 1 $var v
    set v [eval [list linsert $v 0] $args]
 } ;# DKF

 proc kvsearch {kvlist item} {
   set pos [lsearch $kvlist $item]
   if {$pos != -1} {
      lindex $kvlist [expr {$pos+1-2*($pos%2)}]
   }
 } ;# RS
 ## kvsearch {1 one 2 two 3 three} four ;# returns empty string/list
 # kvsearch {1 one 2 two 3 three} 1
 #one
 #% kvsearch {1 one 2 two 3 three} one
 #1

   #-- Building the UI

   set modes {Draw Move Clone Fill Rect Oval Poly circle canvas Poetry hairs zone }
   set modez { define metal weave plural help clear reset edit exit }

  set colors {
     blue3 white magenta brown red orange yellow green green3 green4
     cyan blue blue2 purple}
    set colorz {black brown2 LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 LightGoldenrod4
      LightYellow2 LightYellow3 LightYellow4 yellow2 yellow3 yellow4
      gold2 gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4
      DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3
      orange3 orange4 DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4
      coral1 coral2 coral3 coral4 tomato2 tomato3 tomato4 OrangeRed2
      OrangeRed3 OrangeRed4 red2 red3 red4 DeepPink2 DeepPink3 DeepPink4
      HotPink1 HotPink2 HotPink3 HotPink4 pink1 pink2
   }
      set colorx { blue4 AntiqueWhite3 \
      Bisque1 Bisque2 Bisque3  Bisque4 \
      SlateBlue3 RoyalBlue1 SteelBlue2 \
      DeepSkyBlue3  LightBlue1 DarkSlateGray1 \
      Aquamarine2 DarkSeaGreen2 SeaGreen1 Bisque \
             Yellow1 IndianRed1 IndianRed2 Tan1 \
      lemonchiffon  seashell honeydew mintcream azure \
       peachpuff navajowhite moccasin cornsilk \
       IndianRed3 IndianRed4 sienna1 sienna2 sienna3 sienna4 burlywood1 \
      burlywood2 burlywood3 burlywood4 wheat1 wheat2 wheat3 wheat4  \
      tan2 tan4 chocolate1 chocolate2 chocolate3 firebrick1 firebrick2 \
      firebrick3 firebrick4 \
      }
     global helpx
       global liner 
       global loaderx 
       global ind
       set ind 0
      global   movesit
      set helpx 0
      set loaderx 0
      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 count 0

       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
       set count 0

   grid [radio .1 Mode $modes]  -sticky nw
   grid [radio .2 Mode $modez ]  -sticky nw

   grid [radio .3 Fill $colors 1]  -sticky nw

   grid [radio .4 Fill $colorx 2] -sticky nw
   grid [radio .5 Fill $colorz 3] -sticky nw
   grid rowconfig . 1 -weight 0
   grid rowconfig . 2 -weight 1
   grid rowconfig . 3 -weight 2
   grid rowconfig . 4 -weight 3
   grid rowconfig . 5 -weight 3

 set widthx 100;
 set heightx 200;
      set height 300
      set width  200
      set borderwidth 2

      set hscroll .hscroll
      set vscroll .vscroll
      set canvas .c

      scrollbar $hscroll -orient horiz -ori hori -command "$canvas xview"
      scrollbar $vscroll -ori vert -command "$canvas yview"
 
      grid [canvas .c -relief raised -width $widthx -xscrollcommand "$hscroll set" -height $heightx -yscrollcommand "$vscroll set" -borderwidth 1 -bg $colorground] - -sticky news 

      grid $vscroll -row 5 -column 2 -sticky sw
      grid $hscroll -row 5 -column 2 -sticky sw 
      grid rowconfig . 5 -weight 1
      grid columnconfig . 5 -weight 1
    
      button .b2 -text dismiss -command "destroy ."
      button .b10 -text "copy " -underline 1 -command {tk_textCopy .wxx }
      button .b9 -text "paste " -underline 1 -command {tk_textPaste .wxx}
      button .b8 -text pan -command { bind .c <ButtonPress-3> {%W scan mark   %x %y};
          bind .c <B3-Motion>     {%W scan dragto %x %y 1 ;}
      }
      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 [ 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];
   set rooky 1;
   .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 " ]


    # Mix old pack with new grid
    #grid .menubar.edit -side left

 text .wxx -width 20 -height 3 -bg beige -xscrollcommand ".x set" -yscrollcommand ".y set"
            scrollbar .x -command ".wxx xview" -ori hori
            scrollbar .y -command ".wxx yview" -ori vert
            grid .wxx .y -sticky news
            grid .x    -sticky ew
            grid rowconf    . 0 -weight 1
           grid columnconf . 0 -weight 1
          focus .wxx

  set wow [.c find withtag current];
  set pap 1;
  .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} {
         global baseline
        global en_chinese
        global en_romanji
        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;
      lappend caseline $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;
     lappend caseline2 $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;
       lappend caseline3 $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 topa [stringxxx [concat $baseline $baseline2 $baseline3]] ;
    .wxx insert 1.0 $topa;
     .wxx insert 1.0 [lcount $topa];
      set topat [translationx $topa en_chinese];
     .wxx insert 1.0 [lcount $topat];
     .wxx insert 1.0 [concat $topa [lcount $topa] $topat [lcount $topat]  ];

   set k 20;
   set baseline [translationx $baseline en_chinese];
  puts stdout "   \n";
  puts stdout " $baseline \n"; 
  set k  [expr {20+$y}];
   set ::ID [$w create text $x  $k  -text $baseline -tags $tagx -fill $::Fill ]
   set baseline [translationx $baseline2 en_chinese];
   puts stdout " $baseline \n"; 
  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 baseline [uniswap $baseline];
   puts stdout " $baseline \n";  
   set k  [expr {40+$y}];
   set ::ID [$w create text $x  $k  -text $baseline -tags $tagx -fill $::Fill ]
   set k 30;
   set j 20;
   set baseline [translationx $caseline en_romanji];
    puts stdout "   \n";
   set baseline [uniswap $baseline]; 
   puts stdout " $baseline \n"; 
   set k  [expr {60+$y}];
   set j  [expr {20+$x}];
   set ::ID [$w create text $j  $k  -text $baseline -tags $tagx -fill $::Fill ]
   set baseline [translationx $caseline2 en_romanji];
   set baseline [uniswap $baseline];
   puts stdout " $baseline \n"; 
   set k  [expr {70+$y}];
   set j  [expr {20+$x}];
   set ::ID [$w create text $j  $k  -text $baseline -tags $tagx -fill $::Fill ]
    set baseline [translationx $caseline3 en_romanji];
    set baseline [uniswap $baseline]; 
   puts stdout "  $baseline \n";
   set k  [expr {80+$y}];
   set j  [expr {20+$x}];
   set ::ID [$w create text $j  $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];
       # this card deletes previous history in tank
       # reduces tank verbage but loses history
       #  .wxx delete 1.0 end;
       # general reporting line
      set boo 1;
      .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;
       set coo 1;
       # 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 goldmine  
     global baseline
     global loaderx

     set poetsey aaaaa
     #if {![info exists L]} {set L {}}
     set liner [poemsorts $poetsey];

      if {$loaderx > 0} { set liner $goldmine  }

     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.
       # 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
      lappend liner $poetsey
      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
  # reduced volcabulary
 array set en_chinese {
    The     *
    the     *
    bird   naio
    water   shui
    cloud     yun
    smoke    yan
    come      lai
    rain     yu
   red     hong
   sad     nanguo
   blue     lan
   glad     gaoxing
   deep     shen
   black     hei
   wild     yesheng
   green     luse
   pale     cangbai
   bright     ming
   rough     buping
   gray     cangbai
   brown     zongse
   long     chang
   high     gao
   thin     shou
   lush     duo
   dry     gan
   poor     qiong
   lone     dandu
   far     yuan
   flat     ping
   broad     kuan
   thick     hou
   hard     ying
   cool     liang
   cat     mao
   mouse     laoshu
   reed     cao
   pear     li
   quince     yingtao
   peach     tao
   hare     tuzhu
   bird     naio
   smoke     yan
   rain     yu
   ice     xue
   snow     xue
   cloud     yun
   home       home
   flower     hua
   sky     tian
   rice     mi
   pine     song
   mist     wu
   door     men
   wind     feng
   cricket     kunchong
   year     nian
   moon     yue
   crane     niao
   grass     cao
   rose     meigui
   ink     moshui
   thaw      thaw
   bloom     hua
   lake     he
   cedar     song
   dusk     heitian
   autumn     qiu
   stone     shi
   dawn     liming
   stream     he
   tree     shu
   heart     xin
   boat     zhou
   grief     nanguo
   rock     shi
   town     zhen
   tear     lei
   pool     chitang
   silk     si
   deer     lu
   cedar    song
   barge     bochuan
   moss     lu
   night     ye
   gate     men
   fence     liba
   dove     naio
   dream     meng
   frost     shuang
   peace     heping
   shade     si
   ghost     ti
   road     li
   path     xiaodao
   root     gen
   horse     ma
   eve     wan
   sound     sheng
   sleep     shuimian
   leaves     shu
   sea     hai
   sail     fan
   peak     peak
   stem       stem
   field     yuan
   wave     bolang
   slope     shan
   bark     shu
   crest     xia
   weed     zhiwu
   moth     kunchong
   wasp     huangfeng
   pond     chitang
   soil     du
   snail     wongnui
   worm     wongnu
   ant     kunchong
   kelp     haizhiwu
   cave     shandong
   month     yue
   head     tou
   jade     yu
   branch     shuzhi
   bone     gu
   smile     xiao
   pea     xiaodou
   elm     shu
   morn     zaochen
   carp     yu
   nest     chang
   oak     shu
   perch     yu
   breeze     xiaofeng
   mount     shan
   plum     lizi
   storm     fengbao
   hill     shan
   falls     liu
   burns     huo
   flips     zhou
   flys     fei
   lies     zhi
   walk     zou
   flow     liu
   fall     liu
   fly     fei
   know     zhu
   come     lai
   meet       meet
   drift     zhou
   shine     guang
   soak     shui
   cry     ti
   dance     tiaowu
   lost     milu
   cheer     guoxing
   float     piao
   roost     chang
   move     zhou
   fade     fade
   loves     ai
   sleeps     shuimian
   takes     you
   sits     zuo
   leaps     tiao
   sit     zuo
   grows     sheng
   waits     zhou
   loses      meiyou
   hears     ting
   wants     yao
   watch     kan
   old     lao
   for     wei
   by     yu
   towards     zai
   to     ge
   at     zai
   bygone     yu
   in     zai

 }
            array set en_romanji {
                    The     *
                    the     *
                    red                aka
                    sad                kanashii
                    blue               aoi_ao
                    glad               ureshii
                    deep       fukai
                    black              kuroi
                    wild               yasee
                    green              midori-iro
                    pale               usui
                    bright             akarui_taiyoo
                    rough              zara_zara_sur
                    gray               guree
                    brown              chairo
                    long           nagai
                    high               takai
                    thin         hosoi
                    lush               subishii
                    dry                kawaite_iru
                    poor               bimboo
                    lone               subishii
                    far              tooi
                    flat              taira
                    broad             haba
                    thick              futoi
                    hard             katai
                    cool      tsumetai_mizu
                    cat             neko
                    mouse         hatsuka
                    reed          ashi
                    pear               nashi
                    quince             marumero_no_mi
                    peach          momo
                    hare     no_usagi
                    bird         tori
                    smoke           hebi
                    rain        ame_ga_furu
                    ice             aisu
                    snow               yuki
                    cloud             kumo
                    home           ie
                    flower       hana
                    sky          sora
                    rice               gohan
                    pine        matsu
                    mist        kiri
                    door               doa
                    wind          kaze
                    cricket       koorogi
                    year            toshi
                    moon          tsuki
                    crane              tsuru
                    grass       kusa
                    rose       bara
                    ink           inku
                    thaw        koori_ga_tokeru 
                    bloom              hana
                    lake         mizuumi
                    cedar       ki
                    dusk          yugure
                    autumn             aki
                    stone              ishi
                    dawn       yoake
                    stream             ogawa
                    tree               ki
                    heart            shinzo
                    boat               fune
                    grief          kanashimi
                    rock               iwa
                    town               machi
                    tear               namida
                    pool       koke
                    silk               si
                    deer         shika
                    song    uta
                    barge       unkasen
                    moss          koke
                    night      yoru
                    gate     mon
                    fence      saku
                    dove       hato
                    dream       yume
                    frost              shimo
                    peace     heiwa
                    shade              kage
                    ghost              obake
                    ghost              yuuree
                    road               michi
                    path               michi
                    root               ne
                    horse              uma
                    eve        zenya
                    sound         oto
                    sleep              nemuru
                    leaves     happa 
                    sea                umi
                    sail      ho
                    peak         choojoo
                    stem               kuki
                    field    hatahe
                    wave               wave
                    slope         suropu
                    bark    ki_no_kawa
                    crest         itadaki
                    weed       zassoo
                    moth        ga
                    wasp      suzume_bachi
                    pond         ike
                    soil         tsuchi
                    snail        katatsumuri
                    worm          mimizu
                    ant                ari
                    kelp          kaiso
                    cave            hora_ana
                    month        tsuki
                    head       atama
                    jade        hisui
                    branch             eda
                    bone          hone
                    smile          hohoemi
                    pea      endomane
                    elm     ki
                    morn          asa
                    carp        sakana
                    nest            su
                    oak    ki
                    perch              suzuki
                    breeze        soyokaze
                    mount         yama
                    plum               puramu
                    storm        arashi
                    hill        oka
                    falls    ochiru  
                    burns       moeru
                    flips     hajiku
                    flys       tobu
                    lies         aru
                    walk     aruku
                    flow     nagareru
                    fall         kao
                    fly       tobu
                    know   shiite_iru  
                    come        kuru
                    meet       au
                    drift  hyoryu_suru
                    shine        hikaru
                    soak      tsukaru
                    cry         kiki
                    dance       dansu
                    lost        nakusu 
                    cheer     kansei
                    float      ukaba
                    roost    yasumu
                    move      ugoku
                    fade      kieru
                    loves       ai
                    sleeps     nemuru
                    takes    toru
                    sits       suwaru
                    leaps      choyaku
                    sit     suwaru
                    falls              ochiru       
                    grows       sodatsu
                    waits       matsu
                    loses      nakusu
                    hears     kiku
                    wants        iru
                    watch       miru
                    old        furui
                    for        no_tami_ni
                    by           ni_yotte
                    towards      no_ho_ni
                    to         ni
                    at        de
                    bygone       sugita
                    in        no
                    The     *
                    the     * }

      proc down(edit) {w x y} {

   console_editor;
   }
   proc move(edit) {w x y} {}
    proc down(weave) {w x y} {
     global count
     set xwidth 200;
     set xheight 200; 
   .wxxccc insert 1 " weave  processing time substantial ";
    if  { $count  == 0 } {
    .wxxccc insert 1 " weave 1 processing time substantial ";

    colorweave  w x y $xwidth $xheight 1 }

       if  { $count  == 1 } {
     .wxxccc insert 1 " weave style 10  processing time substantial ";

 colorweave  w x y $xwidth $xheight 5  }


    if {$count == 2 } {
   .wxxccc insert 1 " weave style 3 on left mouse & touch screen "

 colorweave  w x y $xwidth $xheight 2   }

 if { $count == 3 } {
  .wxxccc insert 1 " weave style 4   on left mouse & touch screen "
    colorweave  w x y $xwidth $xheight 1 }
  if { $count == 4 } {
 
     .wxxccc insert 1 " weave style 5   on left mouse & touch screen "
    colorweave  w x y $xwidth $xheight 3 }
 incr count 1;
    if { $count == 5 } {
 set count 0}

 }


    proc move(weave) {w x y} {}

    proc console_editor {} {
    console show;
   console eval {.console config -font Arial -bg bisque }
    console eval {winfo children .}
    console eval {
    #set ::tk::console::maxLines 10000  #JH}
    console eval {.menubar.edit add command \
        -label "Clear" -underline 4 \
        -command {.console delete 1.0 end ; tkConsolePrompt}} 
    console eval {.menubar add command \
        -label "Clear" \
        -command {.console delete 1.0 end ; }}
    console eval {.menubar add command \
        -label "exit editor" \
        -command { destroy . ; }}
    console eval {.menubar add command \
        -label "exit all" \
        -command { exit ; }}
     console eval {.menubar add command \
        -label "line no's" \
        -command { 
          set i 0;
          set linenumbers [.console get 0.0 end];

   set linenumbers [list [lreplace $linenumbers 0 -1]];
          foreach item  $linenumbers   {
          puts stdout "      #$i  $item  \n";
           incr i;  }
 }}

      proc keepConsoleClean {} {
      after 1000 keepConsoleClean
      #KBK (11 January 2002)
      console eval { .console delete 1.0 end-100l }
  }
      #console eval {.console insert 1.0 end stdout }
      console eval {.console insert 1.0   stdout }
      console eval {.console insert 1.0   " \n " }

     console eval {
     .menubar.file add cascade -label "Save session" -underline 2 \
             -menu .menubar.file.sess
     menu .menubar.file.sess -tearoff 0
     .menubar.file.sess add command -label "Input only" \
         -underline 0 -command {saveSession 0}
     .menubar.file.sess add command -label "Save Refrigerator_Pinyin_Poetry" \
             -underline 10 -command {saveSession 0}
     proc saveSession {{all 1}} {
         #HD
         set fTypes {{"Text files" {.txt}} {"All files" {*}}}
         set f [tk_getSaveFile -filetypes $fTypes -title "Save session"]
         if {$f == ""} {
             # User cancelled the dialog
             return
         }
         if [catch {open $f "w"} fh] {
             messageBox -icon error -message $fh -title \
                     "Error while saving session"
             return
         }
         if {$all == 1} {
             puts $fh [.console get 0.0 end]
         } else {
             foreach {start end} [.console tag ranges stdin] {
                 puts -nonewline $fh [.console get $start $end]
             }
         }
         catch {close $fh}
     }
 }
 }

   proc %+ {a  } {return [string toupper $a]; #%+ tree >TREE }
   proc %- {a  } {return [string tolower $a]; #%+ Tree >tree  }
   proc %++ {a b} {return $a$b;#%+* tree root  >treeroot }
   proc %-- {a b} {regsub $b $a "" a; return $a;#%-- 5 7>5 }
   proc %% {a b} {regsub -all $b $a "";#%% tree root  >tree }
   proc %1 {a b} {regsub $b $a "" a; return $a;#%1 tree root  >tree }
   proc %2 {a b} {regsub $b $a "" a;regsub $b $a "" a; return $a;#%2 tree root>tree }
   proc %3 {a b} {regsub $b $a "" a;regsub $b $a "" a;regsub $b $a "" a; return $a;#%3 tree root>tree}
    proc %2x  {a} {return $a$a;#%2x tree>treetree}
    proc %3x  {a} {return $a$a$a;#%3x tree>treetreetree} 
    proc %4x  {a} {return "$a,$a,$a";#%5x tree>tree,tree,tree }
    proc %5x  {a} {return "$a $a $a";#%5x tree>tree tree tree }
    proc repeat {n body} {while {$n} {incr n -1; uplevel $body}}
    proc random n {expr {round($n*rand())}}
    proc whitelist {a} {return [lreplace $term 0 -1];#take string,return list without blanks}
    set k [split {abcdefghijklmnopqrstuvwxyz} {}]
    proc average L {expr ([join $L +])/[llength $L].}
    proc srevert s {
    set l [string length $s]
    set res ""
    while {$l} {append res [string index $s [incr l -1]]}
    set res
 };# RS,

    proc lreverse L {
    set res {}
    set i [llength $L]
    #while {[incr i -1]>=0} {lappend res [lindex $L $i]}
    while {$i} {lappend res [lindex $L [incr i -1]]} ;# rmax
    set res
 } ;# RS, tuned 10% faster by [rmax]


 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
 
    if {1 == 0 } {
 set topa [stringxxx [poemsorts "aaaaa"]] ;
 .wxx insert 1.0 $topa;
 .wxx insert 1.0 [lcount $topa];

 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 1.0 " $baseline xxx";
 .wxx insert 1.0 "man xxx [plural "man"] xxx";
 set baseline [list water bird smoke come];
 .wxx insert 1.0 "xxx $baseline xxx";
 set stringj [list ];
 set stringj [translationx "water bird smoke come" en_chinese]
 .wxx insert 1.0 $stringj ;
 .wxx insert 1.0 "xxxx trans [translationx $baseline en_chinese]" ;
      set listxxx [list MacDonald McArthur McEwan Lyttle Mabbs Jones]
 .wxx insert 1.0 "xxxx sort xxxx $listxxx xxx [phonesort2 "$listxxx"]" ;

      set commontest "In Tcl everything is represented as a string. Lists don't escape this rule of humans. "
     set ropa  [split $commontest];
      set ropa [stringxxx $ropa];
 foreach name [stringxxx [lcount $ropa]] {
        .wxx insert end " rating $name [kvsearch { 
 1 the 2 be 3 to 4 of 5 and 6 a 7 in 8 that 9 have  } $name]"
    }
 }
    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(metal) {w x y} {
     set xwidth 200;
     set xheight 200;
 heavymetal  w x y $xwidth $xheight 
  make_gradient $w 50 50
    make_gradient $w 30 15
    make_gradient $w 15 15 }
   proc move(metal) {w x y} {}


  proc down(help) {w x y} {
      set tile  [expr {int(rand()*1000000000.)}]
      set poof  "help" ;
      global helpx
     if {$helpx > 0} {return}
      set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];
     set base "help";
     set helpx 0;
     set baseline [helptext $base];
     #if {![info exists L]} {set L {}}
     set ::ID [$w create text $x  $y  -text $baseline -tags $tagx -fill $::Fill ]
     set helpx 1;

   }
   proc move(help) {w x y} {}
   proc down(clear) {w x y} {
    global helpx
    $w delete "all";
    set helpx 0;
   }
      proc reset {w} {
      global goldmine;
       global loaderx 0;
      upvar 1 .wxx .wxx;
      upvar 1 .wxxccc .wxxccc;
     .wxxccc insert 1 " reset screen  on left mouse & touch screen";
     set gold [list];
     set loaderx 1;
      set helpa  [list reset processing may take considerable time ];

 set helpb  [list reset, processing of holding tank, ];
 lappend helpa $helpb;
 global helpx
 #$w delete .wxxccc;
  set innn 1;
 .wxxccc insert end  $helpa;
 set goldmine [.wxx get 1.0 end] ;

 set goldmine [ string tolower $goldmine ] ;
   set goldmine [ split $goldmine ] ;
    set goldmine [ luniq  $goldmine ] ;
   set res {}
    foreach {a } $goldmine {
 set rook [string length $a] ;
    if {$rook > 3} {lappend res $a}}
 set goldmine $res
    set res {}
    foreach {a } $goldmine {
 set rook [string length $a] ;
   if {$rook > 3} {lappend res [? $goldmine]}}

    set goldmine [ lappend $helpa $res];
    set goldmine [plainsub $goldmine # ""];
    set goldmine [plainsub $goldmine \) ""];
    set goldmine [plainsub $goldmine \( ""];
    set goldmine [plainsub $goldmine \} ""];
    set goldmine [plainsub $goldmine \{ ""];

    set goldmine [stringxxx $goldmine ];
     set goldmine [ luniq  $goldmine ] ;
     printstuff $goldmine ;

     #set goldmine [ smoothxxx $goldmine ] ;
 }
      proc printstuff { bigstring } {
      set i 0;
      foreach {a b} $bigstring {

       puts stdout "      $a $b                               #$i   \n ";
      incr i;
      }

       }


  proc down(hairs) {w x y} {
      global helpx
      if {$helpx > 0} {return}
      set tile  [expr {int(rand()*1000000000.)}]
      set poof  "cross hair" ;
     set maximumxxxx 400
     set maximumyyyy 400
     set middlexxxx [expr { (400 + $x)/ 2 }]
     set middleyyyy [expr { (400 + $y)/ 2 }]
     set xx1 20;
     set xx2 15;
     set yy1 20;
     set yy2 10;
      set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];
     set base "help";
     set helpx 0;
     set baseline  $base;
     #if {![info exists L]} {set L {}}
     #set ::ID [$w create text $x  $y  -text $baseline -tags $tagx -fill $::Fill ]
      set ::ID [ $w create line $x     $middleyyyy $maximumxxxx  $middleyyyy -tags $tagx]
      set ::ID [$w create line $middlexxxx $y       $middlexxxx $maximumyyyy -tags tagx ]
      bind ::ID  [ $w create line $x     $middleyyyy $maximumxxxx  $middleyyyy -tags $tagx][$w create line $middlexxxx $y       $middlexxxx $maximumyyyy -tags tagx ]
      set helpx 1;

   }
   proc move(hairs) {w x y} {

      set ::ID [$w find withtag hair ]
     $w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
       set ::X $x; set ::Y $y

  }

    proc down(zone) {w x y} {
     global helpx
     if {$helpx > 0} {return}
     set xx1 20;
     set xx2 15;
     set yy1 20;
     set yy2 10;
     set tile  [expr {int(rand()*1000000000.)}];
      set poof  "zone" ;
      set tagx [list $poof mv "obj_$tile" "colorit_$::Fill"  d-$x$y];
     set base "help";
     #$w create rect  50  10  100  60  -tags "box"
     #$w create rect $xx1 $yy1  $xx2 $yy2  -tags "box"
     set ::ID [$w create rect $x  $y [expr { $x + $xx1 }] [expr { $y + $yy1 }]   -tags $tagx -fill $::Fill ]
     set helpx 1
 }
   proc move(zone) {w x y} {}
   proc stringinsert {string pos char} {
    set original [string index $string $pos]
    string replace $string $pos $pos $char$original
 } ;# RS
    proc colortalk { w x y $width $height colorgroundx } {
    global colorvalue1 colorvalue2
    global rbg1 rbg2 colorvalue1 colorvalue2
    global colorground
     upvar 1 .wxx .wxx;
     upvar 1 .wxxccc .wxxccc;

         set n [catch {winfo rgb . $::Fill} rgb];
          if {$n} continue;
          # Convert to HSV and get the V value to determine fill color;
          set colorvalue1 [lindex [lsort -integer $rgb] end];
          set colorvalue1 [expr {$colorvalue1 / double(65535)}];
          set rgb2 [eval format #%04X%04X%04X [winfo rgb . $::Fill]];
          set n [catch {winfo rgb . $colorground} rgb];

          set colorvalue2 [lindex [lsort -integer $rgb] end];
          set colorvalue2 [expr {$colorvalue2 / double(65535)}];
          set rgb3 [eval format #%04X%04X%04X [winfo rgb . $colorground]];

        set rgb3 [eval format #%04X%04X%04X [winfo rgb . $colorground]];
        .wxxccc insert end " canvas_color 33 $colorground \( rgb $rgb3 \) $colorvalue2   pen_color  $::Fill  $colorvalue1 $::Fill \(rgb $rgb2  \) \n";

    .wxx insert end " canvas_color 22 $colorground \( rgb $rgb3 \) $colorvalue2   pen_color  $::Fill  $colorvalue1 $::Fill \(rgb $rgb2  \) \n";
     set colorvalue1 [expr { int ($colorvalue1 * 100000)} ] ;
     set rgb5 [winfo rgb . $colorground];
     set colorvalue5 [lindex [lsort -integer $rgb5] end];
    .wxx insert end " test metal_colors  44 $colorground    $rgb5 $colorvalue5 \n";
 #[ lpick [list "\#054505" "\#058505" "\#057505" ]]
 return "\#054505";

 }



    set testererer [ colortalk w x y $width $height $colorground  ];


   proc  colorweave { w x y width height rownumber} {  
 set width   400
      set height  200
  global colorground 
  .wxxccc insert 1 " metal > processing time substantial ";
     upvar 1 .wxx .wxx;
  .wxxccc insert 1 " create metal background on left mouse & screen touch  ";
     set testererer 45000;
   set testererer [ colortalk w x y $width $height $colorground  ];
    for {set row 0} {$row < $height} {incr row $rownumber} {
      # set line_color [expr {450000+int(1000000*rand())%3000}];   
      set line_color [expr { int(45000 ) +int(1000000*rand())%3000}];
     if { $rownumber > 3 } { set line_color [expr { int(500 ) +int(1000000*rand())%3000}];}
    set testererer [winfo rgb . $colorground];
    set rgb3 [eval format #%04X%04X%04X [winfo rgb . $colorground]];
            #"\#057505";#099999957505
     set n [catch {winfo rgb . $colorground} rgb];

    if {$n} continue;
          # Convert to HSV and get the V value to determine fill color;
          set colorvalue1 [lindex [lsort -integer $rgb] end];
          set colorvalue1 [expr {$colorvalue1 / double(65535)}];
          set rgb2 [eval format #%04X%04X%04X [winfo rgb . $::Fill]];
          set n [catch {winfo rgb . $colorground} rgb];
   #.wxx insert end "  special test metal background $testererer real n $n \n"  
   set testa  [split [winfo rgb . $::Fill ]]; 
  set testr [join [split [winfo rgb . $::Fill ]]];
  #.wxx insert end "  special test metal background $testa   \n"
 set test1 [ stringinsert $testr 2 "99" ];
 set test2 [ stringinsert $testr 2 "88" ];
 set test3 [ stringinsert $testr 2 "77" ];
 set testi [ concat $test1 $test2 $test3 ];
 set testi [ stringinsert $test1 2 "" ];
 set testi "\#654535";
 catch {set testi [eval format #%04X%04X%04X [winfo rgb . $::Fill]];}
 set test1 [ stringinsert $testi 12 "9" ];
 set test2 [ stringinsert $testi 8 "8" ];
 set test3 [ stringinsert $testi 4 "7" ];
 set test4 $testi; 
 set xlength [string length $testi];
 set xlength [expr { $xlength - 1 }];
 set test1 [ string range   $test1  0  $xlength  ];
 set test2 [ string range   $test2  0  $xlength  ];
 set test3 [ string range   $test3  0  $xlength  ];
  #.wxx insert end "  special test metal background $testererer  \n"  
       .c create line 0 $row $width $row -width 1 \
         -fill [ lpick [list $test1 $test2 $test3 $test4]]
   #  \#654545 
   

      }
      }


     proc heavymetal { w x y width height } {  
 set width   400
      set height  200
  .wxxccc insert 1 " metal processing substantial ";
 for {set row 0} {$row < $height} {incr row 1} {
          set line_color [expr {45000+int(1000000*rand())%3000}]
          .c create line 0 $row $width $row -width 1 \
                  -fill [format "#%04x%04x%04x" \
                  $line_color $line_color $line_color]
      }
      }

    proc make_gradient { canvas N M } {
    set width [$canvas cget -width]
    set height [$canvas cget -height]

    set dx [expr {double($width)/double($N)}]
    set dy [expr {double($height)/double($M)}]
    set a [expr {pow(double($N)/2.0,2)+pow(double($M)/2.0,2)}]

    for {set i 0} {$i <= $N} {incr i} {
        for {set j 0} {$j <= $M} {incr j} {
            set x1 [expr {$dx*double($i)}]
            set x2 [expr {$x1+$dx}]
            set y1 [expr {$dy*double($j)}]
            set y2 [expr {$y1+$dy}]

            set k [expr {int(30000+25000*(1.0 - \
                    0.8*(pow(double($i-$N/2.0),2) + \
                    pow(double($j-$M/2.0),2))/$a))}]

            $canvas create rectangle $x1 $y1 $x2 $y2 \
                    -fill [format "#%04x%04x%04x" $k $k $k] \
                    -width 0
        }
    }
 }
  #-- definition of an item
   proc down(define) {w x y} {
      global en_romanji en_chinese
       set old "test";
       set kkk [.c  gettags current ];
       set indexer [string first "mv" $kkk ]; ;
       set indexer [ expr { $indexer - 1 } ];
       set term  [string range $kkk 0 $indexer ];
     .wxx insert 1.0  "    \n "

    .wxx insert 1.0  "  definition called \n "
    .wxx insert 1.0  " $term    \n "
    set linenumbers [list [lreplace $term 0 -1]];
 
     .wxx insert 1.0  " $term [translationx "$term" en_chinese]  [translationx "$term" en_romanji] \n ";

  set ::X $x; set ::Y $y
   }
   proc move(define) {w x y} {
 
   }
     proc down(plural) {w x y} {
      global en_romanji en_chinese
       set old "test";
       set kkk [.c  gettags current ];
       set indexer [string first "mv" $kkk ]; ;
       set indexer [ expr { $indexer - 1 } ];
       set term  [string range $kkk 0 $indexer ];
     .wxx insert 1.0  "    \n "


     .wxx insert 1.0  " $term [plural $term] \n ";
     .wxx insert 1.0  "  plural called \n "

  set ::X $x; set ::Y $y
   }
   proc move(plural) {w x y} {
 
   }

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

  label .l
  .l configure -text "Text goes here"
 If you then want to prepend, you can use
  .l configure -text "Before -> [.l cget -text]"
 Assuming you actually meant an [entry] widget, not a [label]:
  entry .e
  .e insert end "Last words."
  .e insert 1 "First words. "
 seems to work fine for me. For a text widget, your code looks fine:
  text .t
  .t insert end "This is at the end"
  .t insert 1.0 "This is at the start\n"