Refrigerator_Pinyin_Poetry
Refrigerator_Pinyin_Poetry
This page is under development. Comments are welcome, but please load any comments in the comments section at the bottom of the page. Please include your wiki MONIKER and date in your comment with the same courtesy that I will give you. Aside from your courtesy, your wiki MONIKER and date as a signature and minimal good faith of any internet post are the rules of this TCL-WIKI. Its very hard to reply reasonably without some background of the correspondent on his WIKI bio page. Thanks, gold 12Dec2018
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 useful from Experimenting with graphics algorithms.
The weave button implements a colorized version of the etched metal background from Marco MaggiExperimenting 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.
figure 2.
figure 3.
References:
- http://www.elf.org/tclplugin/poetry.html
- https://wiki.tcl-lang.org/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]}
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. deleted dualcheck proc.
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 -> numberYou can retrieve the text by giving the tag
set text [$w itemcget text$number -text]
end of record.
Q. from goldshell7:28jul2006,would like selected tiles to have a red, blue, or colored outline. However commented
.c itemconfigure tile_number -outline red
colored outine but reverts text font to vertical arranged text.
Maybe somebody can figure how to keep text horizontal.
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"
Hidden Comments Section
| Category Numerical Analysis | Category Toys | Category Calculator | Category Mathematics | Category Example | Toys and Games | Category Games | Category Application | Category GUI |