Version 63 of Refrigerator_Magnetic_Poetry
Updated 2006-08-25 15:38:24This page uses TCL8/Expect 5.2 for windows to develop Refrigerator magnetic Poetry. For example, we are laying out tiles in random colors imprinted with text and symbols applied randomly. Would also like to develop a crude Mahjong program using some of these subroutines.
Strengths
test picture??? [http://mini.net/files/balance.gif]
- Subroutine use whereever possible.
- This one
[Refrigerator_Magnetic_Poetry]
#Refrigerator_Magnetic_Poetry
# Start of Deck
#Refrigerator_Magnetic_Poetry
# Start of Deck
package require Tk
proc down(reset) {w x y} {
reset $w
}
proc move(reset) {w x y} {}
proc radio {w var values {col 0}} {
frame $w
set type [expr {$col? "-background" : "-text"}]
foreach value $values {
radiobutton $w.v$value $type $value -variable $var -value $value \
-indicatoron 0
if $col {$w.v$value config -selectcolor $value -borderwidth 3}
}
eval pack [winfo children $w] -side left
set ::$var [lindex $values 0]
set w
}
proc down(Draw) {w x y} {
set ::ID [$w create line $x $y $x $y -fill $::Fill]
}
proc move(Draw) {w x y} {
$w coords $::ID [concat [$w coords $::ID] $x $y]
}
#-- Movement of an item
proc down(Move) {w x y} {
set ::ID [$w find withtag current]
set ::X $x; set ::Y $y
}
proc move(Move) {w x y} {
$w move $::ID [expr {$x-$::X}] [expr {$y-$::Y}]
set ::X $x; set ::Y $y
}
proc luniq {L} {
# removes duplicates without sorting the input list
set t {}
foreach i $L {if {[lsearch -exact $t $i]==-1} {lappend t $i}}
return $t
} ;# RS
#-- Clone an existing item
proc serializeCanvasItem {c item} {
set data [concat [$c type $item] [$c coords $item]]
foreach opt [$c itemconfigure $item] {
# Include any configuration that deviates from the default
if {[lindex $opt end] != [lindex $opt end-1]} {
lappend data [lindex $opt 0] [lindex $opt end]
}
}
return $data
}
proc down(Clone) {w x y} {
set current [$w find withtag current]
if {[string length $current] > 0} {
set itemData [serializeCanvasItem $w [$w find withtag current]]
set ::ID [eval $w create $itemData]
set ::X $x; set ::Y $y
}
}
interp alias {} move(Clone) {} move(Move)
#-- Drawing a rectangle
proc down(Rect) {w x y} {
set tile [expr {int(rand()*1000000000.)}]
set poof "rectangle" ;
set tagx [list $poof mv "obj_$tile" "colorit_$::Fill" d-$x$y];
set ::ID [$w create rect $x $y $x $y -tags $tagx -fill $::Fill]
}
proc move(Rect) {w x y} {
$w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
}
#-- Drawing an oval (or circle, if you're careful)
proc down(Oval) {w x y} {
set tile [expr {int(rand()*1000000000.)}]
set poof "oval" ;
set tagx [list $poof mv "obj_$tile" "colorit_$::Fill" d-$x$y];
set ::ID [$w create oval $x $y $x $y -tags $tagx -fill $::Fill]
}
proc move(Oval) {w x y} {
$w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
}
proc down(circle) {w x y} {
set tile [expr {int(rand()*1000000000.)}]
set poof "oval" ;
set tagx [list $poof mv "obj_$tile" "colorit_$::Fill" d-$x$y];
set dx 50
set dy 50
set ::ID [$w create oval [expr {$x+2}] [expr {$y+2}] [expr {$x+$dx-3}] [expr {$y+$dy-3}] -tags $tagx -fill $::Fill]
}
proc move(circle) {w x y} {
#$w coords $::ID [lreplace [$w coords $::ID] 2 3 $x $y]
}
proc down(Poly) {w x y} {
if [info exists ::Poly] {
set tile [expr {int(rand()*1000000000.)}]
set poof "poly" ;
set tagx [list $poof mv "obj_$tile" "colorit_$::Fill" d-$x$y];
set coords [$w coords $::Poly]
foreach {x0 y0} $coords break
if {hypot($y-$y0,$x-$x0)<10} {
$w delete $::Poly
$w create poly [lrange $coords 2 end] -fill $::Fill
unset ::Poly
} else {
$w coords $::Poly [concat $coords $x $y]
}
} else {
set ::Poly [$w create line $x $y $x $y -tags "obj_[expr {int(rand()*1000000000.)}]" -fill $::Fill ]
}
}
proc ? L {
lindex $L [expr {int(rand()*[llength $L])}]
#suchenwirth_subroutine;
}
proc move(Poly) {w x y} {#nothing}
#-- With little more coding, the Fill mode allows changing an item's fill color:
proc down(Fill) {w x y} {$w itemconfig current -fill $::Fill}
proc move(Fill) {w x y} {}
proc lcount list {
foreach x $list {lappend arr($x) {}}
set res {}
foreach name [array names arr] {
lappend res [list $name [llength $arr($name)]]
}
return $res
}
#lcount {yes no no present yes yes no no yes present yes no no yes yes}
#{no 6} {yes 7} {present 2}
proc translationx {string dictName} {
#suchenwirth_subroutine;
upvar 1 $dictName dict
set res {}
foreach word $string {
if [info exists dict($word)] {set word $dict($word)}
lappend res $word
}
set res
}
proc plural word {
switch -- $word {
man {return men}
foot {return feet}
goose {return geese}
louse {return lice}
mouse {return mice}
ox {return oxen}
tooth {return teeth}
calf - elf - half - hoof - leaf - loaf - scarf
- self - sheaf - thief - wolf
{return [string range $word 0 end-1]ves}
knife - life - wife
{return [string range $word 0 end-2]ves}
auto - kangaroo - kilo - memo
- photo - piano - pimento - pro - solo - soprano - studio
- tattoo - video - zoo
{return ${word}s}
cod - deer - fish - offspring - perch - sheep - trout
- species
{return $word}
genus {return genera}
phylum {return phyla}
radius {return radii}
cherub {return cherubim}
mythos {return mythoi}
phenomenon {return phenomena}
formula {return formulae}
}
switch -regexp -- $word {
{[ei]x$} {return [string range $word 0 end-2]ices}
{[sc]h$} - {[soxz]$} {return ${word}es}
{[bcdfghjklmnprstvwxz]y$} {return [string range $word 0 end-1]ies}
{child$} {return ${word}ren}
{eau$} {return ${word}x}
{is$} {return [string range $word 0 end-2]es}
{woman$} {return [string range $word 0 end-2]en}
}
return ${word}s
}
proc keyget {list key} {
foreach {lkey value} $list {
if [string equal $lkey $key] {return $value}
}
} ;# RS
# % keyget {fnm John lnm Brown phone (123)456-7890 email [email protected]} phone
# (123)456-7890
# % keyget {fnm John lnm Brown phone (123)456-7890 email [email protected]} fax
proc lswap list {
set res {}
foreach {a b} $list {lappend res $b $a}
set res
} ;# RS
# % lswap {a b c d e f g h}
# b a d c f e h g
#Prepend elements to a list (add in front):
proc lprepend {var args} {
upvar 1 $var v
set v [eval [list linsert $v 0] $args]
} ;# DKF
proc kvsearch {kvlist item} {
set pos [lsearch $kvlist $item]
if {$pos != -1} {
lindex $kvlist [expr {$pos+1-2*($pos%2)}]
}
} ;# RS
## kvsearch {1 one 2 two 3 three} four ;# returns empty string/list
# kvsearch {1 one 2 two 3 three} 1
#one
#% kvsearch {1 one 2 two 3 three} one
#1
#-- Building the UI
set modes {Draw Move Clone Fill Rect Oval Poly circle canvas Poetry hairs zone help clear reset 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 \
}
set colork [list seashell honeydew gainsboro floralwhite \
oldlace linen antiquewhite papayawhip blanchedalmond \
bisque peachpuff navajowhite moccasin cornsilk ivory \
lemonchiffon seashell honeydew mintcream azure]
global helpx
global liner
global ind
set ind 0
global movesit
set helpx 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 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
grid [radio .1 Mode $modes] -sticky nw
grid [radio .2 Fill $colors 1] -sticky nw
grid [radio .3 Fill $colorx 2] -sticky nw
grid [radio .4 Fill $colorz 3] -sticky nw
grid [canvas .c -relief raised -borderwidth 1 -bg $colorground] - -sticky news
grid rowconfig . 0 -weight 0
grid rowconfig . 1 -weight 1
grid rowconfig . 2 -weight 2
grid rowconfig . 3 -weight 3
button .b2 -text dismiss -command "destroy ."
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 .b2 .b3 .b5 .b6 .b7
grid rowconfig . 0 -weight 0
grid rowconfig . 1 -weight 1
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];
.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 " ]
set txt [text .wxx -width 20 -height 3 -bg beige]
grid $txt -sticky news
focus .wxx ;# allow keyboard input
set wow [.c find withtag current];
.wxx insert 1.0 "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
set baseline [list ]
set baseline2 [list ]
set baseline3 [list ]
set dy 40
set dx 40
set dk 10
set poof "tester";
set looky "stringx";
set tile "tile"
set tagx [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
set tagx [list ]
#set tags [list mv d-$val1$val2];
#set tile [expr {int(rand()*1000000000.)}]
#set looky "stringx";
#set poof [xpop $looky ] ;
#set tags [list $poof mv obj_$tile d-$val1$val2];
#set tags [list $poof mv "obj_$tile+1" d-$val1$val2];
#set tagx [list $poof mv "obj_$tile+1" d-$x$y];
for {set i 0; set y [expr {4+$y}];set x [expr {10+$dx}]; } {$i<5} {incr i; incr x $dx} {
set state1 1;
set tile [expr {int(rand()*1000000000.)}]
set looky "stringx";
set poof [xpop $looky ] ;
lappend baseline $poof;
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;
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;
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];
set k [expr {20+$y}];
set ::ID [$w create text $x $k -text $baseline -tags $tagx -fill $::Fill ]
set baseline [translationx $baseline2 en_chinese];
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 k [expr {40+$y}];
set ::ID [$w create text $x $k -text $baseline -tags $tagx -fill $::Fill ]
}
proc history {xhistory } {
set xhistory [list object history @];
global xhistory firstnode curnode
global ind movesit
set number 2
set numberx 2
set firstnode [.c find withtag current]
lappend $xhistory $firstnode ;
set ::ID [.c create text 100 200 -text $xhistory -tags " history " -fill $::Fill -fill black ]
}
proc dualcheck { tile firstnode curnode} {
global match_id selected_tile tiles_left jack
global newy oldy match oldx xhistory
global selected_tile previous_tile
global xhistory
global tilex
#global firstnode curnode
set selected_tile "selected tile";
set colorxxx "test"
set colorzzz "test"
#set previous_tile "previous tile";
set numberx [.c gettags current];
regexp {obj_(\d+)} $numberx -> tilex
regexp {colorit_(\d+)} $numberx -> colorxxx
regexp {colorit_(\d+)} $numberx -> colorzzz
set indexer [string first "mv" $numberx ];
set indexer [ expr { $indexer - 1 } ]
set new [string range $numberx 0 $indexer ];
set tags [.c gettags current]
#.c itemconfigure obj_$tilex -width 2 -outline red;
#.c itemconfigure $previous_tile -width 2 -outline green;
# .c itemconfigure obj_$tilex -width 3 ;
# .c itemconfigure $previous_tile -width 3 ;
set old "test"
set kkk [.c gettags $previous_tile ]
set indexer [string first "mv" $kkk ]; ;
set indexer [ expr { $indexer - 1 } ]
set old [string range $kkk 0 $indexer ];
if {$old == ""} {set old "poof $previous_tile"}
set tx [string range $tilex 0 end ];
set rx [string range $previous_tile 4 end ];
if { $tx != $rx } {
.wxx delete 1.0 end;
.wxx insert end " pair error identified, text not equal !!!" ;
}
if { $old == $new } {
set tx [string range $tilex 0 end ];
set rx [string range $previous_tile 4 end ];
if { $tx == $rx } {
.wxx delete 1.0 end;
.wxx insert end " pair error identified, double touch of same tile !!!" ;
}
if { $tx != $rx } {
#.c itemconfigure obj_$tilex -width 2 -outline blue;
#.c itemconfigure $previous_tile -width 2 -outline blue;
.wxx delete 1.0 end;
.wxx insert end " xxx $tilex xxx $tx xxx $rx xxx $previous_tile xxxx ";
.wxx insert end $previous_tile;
.wxx insert end " old $old ";
.wxx insert end $old;
.wxx insert end " identical pair identified !!!" ;
.wxx insert end " xxx old $old xxx new xxx $new ";
.wxx insert end $new;
.wxx insert end "obj_tilex obj_$tilex "
regexp {colorit_(\d+)} $numberx -> colorxxx
regexp {colorit_(\d+)} $previous_tile -> colorzzz
if { $colorxxx == $colorzzz } {
.c delete "$previous_tile+1";
.c delete "obj_$tilex+1" ;
.c delete obj_$tilex ;
.c delete $previous_tile;
}
}
}
#.wxx delete 1.0 end;
set $selected_tile $tags;
.wxx insert end $tags ;
.wxx insert end " selected_tile equals $new ";
if { $previous_tile != $selected_tile } {
set previous_tile [.c gettags current]
set indexer [string first "mv" $previous_tile ];
set indexer [ expr { $indexer - 1 } ]
set old [string range $previous_tile 0 $indexer ];
.wxx insert end " previous_tile equals $old ";
}
#.c itemconfigure $curnode -width 2 ;
set previous_tile obj_$tilex
set firstnode obj_$tilex;
if { $firstnode != $curnode } {
set curnode obj_$tilex;}
.wxx insert end " current equals $curnode ";
.wxx insert end " first equals $firstnode ";
return }
proc initialize {w x y} {
global tile
global xhistory firstnode curnode
global ind movesit
set tile [.c find withtag current]
set number 2
set numberx 2
set ::_x $x; set ::_y $y;
set firstnode [.c find withtag current]
set number [$w gettags current]
set indexer [string first "mv" $number ];
set numberx [string range $number 0 $indexer];
# this card deletes previous history in tank
# reduces tank verbage but loses history
# .wxx delete 1.0 end;
# general reporting line
.wxx insert 1.0 " 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;
# 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 baseline
set poetsey aaaaa
set liner [poemsorts $poetsey];
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.
# This was the first TCL canvas code I
# saw that one could create easy gamepieces.
# Writing grouped designs
# on top of canvas shape, so basic canvas
# shape and "grouped" design would move
# by mouse. "grouped" design is used
# extensively in Microsoft powerpoint
# and Harvard Graphics, etc.
# This first effort is refrigerator
# magnet poetry in English.
# Believe a similar select & die could
# be used for a computer Mahjong game
# or coin&card games.
# Could use TCL8.4 chinese charactors
# on top of tiles for Chinese magnetic
# poetry or colored Mahjong tiles.
# Various Esc and F-keys activate
# to exit program or change background color.
# Sliding right mouse across piece
# should delete same.
# Pick and Sliding left mouse across piece
# should move same.
# Selecting piece with middle mouse
# should delete same piece.
# Selecting pair of [same text] pieces
# [in sequence] with right mouse
# should delete same piece.
# Right mouse uses initialization from
# left mouse, so one has to pick
# one tile with left mouse for
# game start.
# 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
array set en_chinese {
bird naio
water shui
cloud yun
smoke yan
come lai
rain yu
he ta
she ta
it ta
cat mao
horse ma
girl nuer
two lian
one yi
above shang
add jia
admiral haijunshang
aches tong
hear ting
air kongqi
wind feng
airplane feiji
airport feijichang
alley hutong
apple pingguo
apart lu
arm gebo
apricot xing
armchair fushiuyi
atlas dituji
asparagus lusun
ask wen
arrow jian
arrive daoda
author zuiozhe
attic gelou
autumn qiu
axe futou
axle lunzhou
ball qiu
ballet baleiwu
baby yinger
bag bao
barge bochuan
barley damai
barracks yingfang
bank yinhang
bathtub lahncheo
bay haiwan
battery dianchi
bed chuang
beautiful meili
beard huzi
bean dou
bear xlong
beak hui
bead jhuzi
beach haitan
beehive fengxiang
bell leeng
beer pijiu
biscuit binggan
big da
bike zixingche
blanket tanzi
boat zhou
blossom hua
bloom hua
blood xue
blonde jinse
bone gu
bottle pingzi
book shu
branch shuzhi
bow gong
hill shan
deer lu
sea hai
night ye
sky tian
tomarrow mingtian
heart xin
rock shi
song ge
year nian
pine song
rice mi
door men
gate men
open kai
moon yue
dry gan
dark hei
black hei
red hong
field yuan
yellow huang
not bu
carriage che
bright ming
guang shine
frost shuang
head tou
white bai
eve wan
cup bei
stove lu
small xiao
fire huo
tear lei
sit zuo
first xian
cut duan
dream meng
sand sha
grass cao
star xing
shore an
river jiang
flat ping
sun ri
goose yan
sound sheng
duck ya
lamp deng
root gen
by yu
in zai
pear li
pearl zhenzhu
path xiaodao
wants yao
wasp huangfeng
watch kan
see kan
green luse
The *
the *
hard ying
blue lan
dance tiaowu
snow xue
broad kuan
brown zongse
high gao
long chang
look kan
wild yesheng
wide kuan
town zhen
fall liu
to ge
rose meigui
cave shandong
cedar song
lone dandu
leaps tiao
jumps tiao
walk zou
bygone yu
tree shu
dawn liming
cool liang
moth kunchong
insect kunchong
mouse laoshu
mosquito wenzi
moss lu
gray cangbai
pale cangbai
moss lu
before zai
fore zai
salt yan
sail fan
deep shen
deer lu
weed zhiwu
plant zhiwu
kelp haizhiwu
thick hou
shine zhaoyao
shoe xie
lush duo
hears ting
hear ting
pond chitang
pool chitang
for wei
far yuan
at zai
pea xiaodou
morn zaochen
morning zaochen
lost milu
peace heping
plum lizi
sad nanguo
grief nanguo
storm fengbao
sits zuo
sleep shuimian
sleeps shuimian
mist wu
wave bolang
jade yu
reed cao
know zhu
float piao
takes you
has you
smile xiao
cricket kunchong
quince yingtao
cherry yingtao
burns huo
roost chang
mount shan
slope shan
ice xue
fly fiji
snail wongnui
poor qiong
silk si
tea chai
rough buping
move zhou
flys fiji
move zhou
road li
strean he
river he
cry ti
through zai
drift zhou
drifts zhou
perch yu
carp yu
glad gaoxing
falls liu
thin shou
soak shui
loves ai
ghost ti
ant kunchong
dusk heitian
peach tao
towards zai
ink moshui
fence liba
lake he
dove naio
lies zhi
is zhi
soil du
elm shu
oak shu
crane niao
nest chang
cheer guoxing
worm wongnu
rabbit tuzhu
month yue
flips zhou
waits zhou
grows sheng
bark shu
flower hua
crest xia
breeze xiaofeng
leaves shu
leaf shu
hare tuzhu
waits zho
snake she
serpent she
shade si
stone shi
flow liu
zero ling
0 ling
1 yi
one yi
2 er
3 san
three san
4 si
four si
5 wu
five wu
6 liu
six liu
7 ci
seven ci
8 ba
eight ba
9 jiu
nine jiu
10 shi
ten shi
11 shi_yi
eleven shi_yi
twelve shi_er
20 er_shi
twenty er_shi
21 er_shi_yi
twenty_two er_shi_yi
100 bai_bye_yi_bai
hundred bai_bye_yi_bai
300 san_bai
three_hundred san_bai
1000 cian
thousand cian
10000 yi_wan
ten_thousand yi_wan
100000 shi_wan
hundred_thousand shi_wan
1000000 yi_bai_wan
thousand_thousand yi_bai_wan
}
proc phonesort2 { list } {
#KBK (14 February 2001)
foreach name $list {
regsub {Ma?c ?([A-Z])} $name {M_\1} key
lappend list2 [list $key $name]
}
foreach pair [lsort -index 0 -ascii $list2] {
lappend list3 [lindex $pair 1]
}
return $list3
}
global baseline
global en_chinese
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"]" ;
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(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 helpx
$w delete "all"
set helpx 0;
}
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} {}
#end of deck
#end of deck
#end of deck
#end of deck
#end of deck
#end of deck
#end of deck- Code Reuse
- Tcl's package system makes it easy to write code that can be reused.
Many other people have made their code available for reuse.
''Q. from goldshell7'':I am trying to load a feature or subroutine "select&pair_then_die" , where one selects two equal pieces in color,text, or tags. If the two pieces are equal , both pairs disappear from the screen ( or to a hockey safety zone on the screen). Kind of like the old Microsoft Mahjong game, which was an elimination process of equal pairs.
''A. received''
You should make up unique tags
and assign them to both the rect
and the text inside it, and for convenience,
another one for the text only.
incr n
$w create rect ... -tags [list mv obj$n]
$w create text ... -tags [list mv obj$n text$n]
For moving, specify the obj.. tag so both move together.
To get the tags of the current selection, try something like:
set tags [$w gettags current]
In the returned list, locate the tag with the obj number,
e.g. like this
regexp {obj(\d+)} $tags -> number
You can retrieve the text by giving the tag
set text [$w itemcget text$number -text]
end of record.''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.
test vol
above shang
aches tong
add jia
admiral haijunshang
air kongqi
airplane feiji
airport feijichang
alley hutong
alley hutong
american_person meiguoren
ant kunchong
apart lu
apple pingguo
apricot xing
arm gebo
armchair fushiuyi
arrive daoda
arrow jian
ask wen
asparagus lusun
at zai
atlas dituji
attic gelou
author zuiozhe
autumn qiu
axe futou
axle lunzhou
baby yinger
bag bao
ball qiu
ballet baleiwu
bank yinhang
barge bochuan
bark shu
barley damai
barracks yingfang
bathtub lahncheo
battery dianchi
bay haiwan
beach haitan
bead jhuzi
beak hui
bean dou
bear xlong
beard huzi
beautiful meili
bed chuang
beehive fengxiang
beer pijiu
before zai
bell leeng
big da
bike zixingche
bird naio
biscuit binggan
black hei
blanket tanzi
blonde jinse
blonde huangtou
blood xue
bloom hua
blossom hua
blue lan
boat zhou
bone gu
book shu
bottle pingzi
bow gong
branch shuzhi
breeze xiaofeng
bright ming
broad kuan
brown zongse
burns huo
by yu
bygone yu
carp yu
carriage che
cat mao
cave shandong
cedar song
cheer guoxing
cheers ganbei
cherry yingtao
china zhongguo
cloud yun
college xueyuan
come lai
cool liang
costly guo
crane niao
crest xia
cricket kunchong
cry ti
cup bei
cut duan
dance tiaowu
dark hei
dawn liming
deep shen
deer lu
deer lu
door men
dove naio
dream meng
drift zhou
drifts zhou
drink he
drink he
driver siji
dry gan
duck ya
dusk heitian
east dong
eat chi
elm shu
eve wan
expensive guo
fall liu
falls liu
far yuan
fast kuaidianr
fence liba
field yuan
fire huo
first xian
flat ping
flips zhou
float piao
flow liu
flower hua
fly fei
flys fei
for wei
fore zai
friend pengyou
frost shuang
gate men
ghost ti
girl nuer
glad gaoxing
goose yan
goodby zaijian
grass cao
gray cangbai
green luse
grief nanguo
grows sheng
guang shine
half ban
hansome haokan
hard ying
hare tuzhu
has you
have_eaten chi_le
he ta
head tou
hear ting
hear ting
hears ting
heart xin
hello ni_hao
high gao
hill shan
horse ma
ice xue
in zai
ink moshui
insect kunchong
is zhi
it ta
jade yu
jumps tiao
kelp haizhiwu
know zhu
lake he
lamp deng
lao old
leaf shu
leaps tiao
leaves shu
lies zhi
liquor baijiu
lone dandu
long chang
look kan
lost milu
loves ai
lush duo
many duo
mist wu
miss xiaojie
monkey houzi
month yue
moon yue
moonshine baijiu
morn zaochen
morning zaochen
mosquito wenzi
moss lu
moss lu
moth kunchong
mount shan
mouse laoshu
move zhou
move zhou
much duo
nest chang
night ye
no_problem meiwenti
not bu
oak shu
old_boss laoban
old_foreigner laowen
old_man laoren
old_teacher laoshi
once tael
one yi
open kai
pale cangbai
path xiaodao
pea xiaodou
peace heping
peach tao
pear li
pearl zhenzhu
perch yu
pine song
plant zhiwu
pluck cai
plum lizi
pond chitang
pool chitang
poor qiong
quickly kuaidianr
quince yingtao
rabbit tuzhu
rain yu
rat laoshu
red hong
reed cao
really zhende
rice mi
river jiang
river he
road li
rock shi
roost chang
root gen
rose meigui
rough buping
rugby ganlanqiu
rugby ganlanqiu
sad nanguo
sail fan
salt yan
sand sha
sea hai
seat zuowei
see kan
serpent she
shade si
she ta
shine zhaoyao
shoe xie
shore an
silk si
sit zuo
sits zuo
sky tian
sleep shuimian
sleeps shuimian
slope shan
small xiao
smile xiao
smoke yan
snail wongnui
snake she
snow xue
so_so mamahuhu
soak shui
soft rou
soil du
song ge
sound sheng
south nan
spear qiang
speak shuo
star xing
stone shi
storm fengbao
stove lu
stream he
subway ditie
sun ri
takes you
tea chai
tear lei
thank_you xiexie
The *
the *
thick hou
thin shou
through zai
ticket chepiao
to ge
toilet cesuo
tomarrow mingtian
towards zai
town zhen
train huoche
tree shu
two lian
usa meiguo
vehicle che
very tai
waits zhou
wait zho
walk zou
wants yao
wants yao
wasp huangfeng
watch kan
water shui
water_crane shuihe
water_tower shuita
wave bolang
we nimen
weed zhiwu
west xi
wheel lun
white bai
wide kuan
wild yesheng
wind feng
woman nu_ren
worm wongnu
year nian
yellow huang
zero ling
0 ling
1 yi
one yi
2 er
3 san
three san
4 si
four si
5 wu
five wu
6 liu
six liu
7 ci
seven ci
8 ba
eight ba
9 jiu
nine jiu
10 shi
ten shi
11 shi_yi
eleven shi_yi
twelve shi_er
20 er_shi
twenty er_shi
21 er_shi_yi
twenty_two er_shi_yi
100 bai_bye_yi_bai
hundred bai_bye_yi_bai
300 san_bai
three_hundred san_bai
1000 cian
thousand cian
10000 yi_wan
ten_thousand yi_wan
100000 shi_wan
hundred_thousand shi_wan
1000000 yi_bai_wan
thousand_thousand yi_bai_wan