***Refrigerator_Pinyin_Poetry***

<<TOC>>
**Introduction**
This page uses Tcl8/Expect 5.2 for windows to develop Refrigerator Pinyin Poetry. Poetry is random poetic words from Japanese Haiku style and translated to phonetic Japanese and Chinese. Metal weave and color weave features seem usefull from [Experimenting with graphics algorithms].

The  weave button implements a colorized version of the etched metal background from Marco Maggi[Experimenting with graphics algorithms]. The metal button implements metal background from same. The reset button filters and loads from text residing or pasted in holding tank, which can be from other text sources on the internet. 

Japanese Haiku has poetic license of occasional nonsense words, which are translated into the phonetic Chinese as stars (*) in this program. English articles replaced with stars. Also, English speakers have some difficulty with the intention or selection of plurals in Japanese and Chinese written poetry. Some words and allusions are from 8th century poems, hard to find in current dictionaries. Since Haiku is usually 5/7/5 words in the line sequence, monosyllabic words in English were given preference in the vocabulary selection.

[gold] 2Mar2017. filtered blank lines out of code and used pretty print of Ased editor. Code has better cosmetics.

   
***Screenshots Section***

****figure 1.****
[Refrigerator_Pinyin_Poetry first screenshot]

****figure 2.****
[Refrigerator_Pinyin_Poetry plus colors marker.png]

****figure 3.****
[Refrigerator_Pinyin_Poetry plus colors marker more version.png]

***References:***
   * http://www.elf.org/tclplugin/poetry.html
   * http://wiki.tcl.tk/12970
   * http://www.as.ua.edu/nihongo/haiku.htm
   * http://library.thinkquest.org/C0126526/technique.html
   * http://library.thinkquest.org/3721/poems/forms/haiku.html
   * http://www.modernhaiku.org/index.html
   * http://slashdot.org/developers/00/06/13/2326222.shtml
   * http://www.wordgumbo.com/st/man/index.htm
   * Wordgumbo: Ancient Egyptian
   * http://www.wordgumbo.com/st/man/erengman.htm
----
**Appendix Code**

***appendix TCL programs and scripts ***


======
    #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 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 ]
        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 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 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]
                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
======
----
   
======
    if{0) { test code 

 black grief loses through pale gray road The long bloom cheer bygone red broad tear The high 

 hei nanguo meiyou through cangbai 

 cangbai li * chang hua guoxing yu 

 hong kuan lei zo gao 

 kuroi kanashimi nakusu through usui 

 guree michi kana nagai hana kansei sugita 

 aka haba namida yo takai 

 door sits in blue lush soil The flat plum hears to brown brown elm The green elm 

 men zuo zai lan duo 

 du * ping lizi ting ge zongse 

 zongse shu ya luse shu 

 doa suwaru no aoi_ao subishii 

 tsuchi kana taira puramu kiku ni chairo 

 chairo ki kana midori-iro ki 

 grows at hard high night The brown silk walk in blue glad pool The thin bird burns 

 sheng zai ying gao ye 

 * zongse si zou zai lan gaoxing 

 chitang kana shou naio huo 

 sodatsu de katai takai yoru 

 zo chairo si aruku no aoi_ao ureshii 

 koke keri hosoi tori moeru 

 to far lone stem The red wasp walk to dry flat ghost The hard nest fade in 

 ge yuan dandu stem * 

 hong huangfeng zou ge gan ping ti 

 ya ying chang fade zai 

 ni tooi subishii kuki keri 

 aka suzume_bachi aruku ni kawaite_iru taira yuuree 

 kana katai su kieru no 

 blue dry night The black cat sits through broad blue moon The lone smile roost bygone brown 

 lan gan ye * hei 

 mao zuo through kuan lan yue * 

 dandu xiao chang yu zongse 

 aoi_ao kawaite_iru yoru keri kuroi 

 neko suwaru through haba aoi_ao tsuki yo 

 subishii hohoemi yasumu sugita chairo 

 thin cedar The long ant fly to poor broad mist The long bone shine to blue blue 

 shou song * chang kunchong 

 fei ge qiong kuan wu * chang 

 gu guang ge lan lan 

 hosoi ki keri nagai ari 

 tobu ni bimboo haba kiri keri nagai 

 hone hikaru ni aoi_ao aoi_ao }
======
    
**Changes Registry**
[gold] 2Mar2017. filtered blank lines out of code and used pretty print of Ased editor. Code has better cosmetics.
[gold] 3Mar2017. Minus tags in zone, poly, and circle corrupted, trying to change. Removed older utilities and kyget procs. deleted phonesort proc.
----

[gold] This page is copyrighted under the TCL/TK license terms, [http://tcl.tk/software/tcltk/license.html%|%this license]. 
                         
**Comments Section**
#  Refrigerator_Pinyin_Poetry

''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, .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.

[RS]: See also [Memory 2]
----
''Q. from goldshell7'':28jul2006,would like
selected tiles to have a red, blue, or colored    outline. However commented 
 .c itemconfigure tile_number -outline red
colored outine but reverts text font to vertical arranged text.

Maybe somebody can figure how to keep text horizontal.
----
problem with "insert statement" in subroutine  procedures
resolved through upvar statements. -goldshell7
----
[MG] 
With your second - you don't use ''$widget insert'' for a label  widget.   It's something like:
======
  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"
======
----

<<discussion>>
Please place any comments here, Thanks.

<<categories>> Numerical Analysis | Toys | Calculator | Mathematics| Example| Toys and Games | Games | Application | GUI
----
<<categories>> Development | Concept| Algorithm | Human Language