Version 59 of Refrigerator_Magnetic_Poetry
Updated 2006-08-23 22:27:49This 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 {
black white magenta brown red orange yellow green green3 green4
cyan blue blue4 purple
}
set colorx { brown2 AntiqueWhite3 \
Bisque1 Bisque2 Bisque3 Bisque4 \
SlateBlue3 RoyalBlue1 SteelBlue2 \
DeepSkyBlue3 LightBlue1 DarkSlateGray1 \
Aquamarine2 DarkSeaGreen2 SeaGreen1 Bisque \
Yellow1 IndianRed1 IndianRed2 Tan1 \
lemonchiffon seashell honeydew mintcream azure \
oldlace linen antiquewhite papayawhip blanchedalmond
peachpuff navajowhite moccasin cornsilk \
Tan4 gray }
set colorz [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 [canvas .c -relief raised -borderwidth 1 -bg $colorground] - -sticky news
grid rowconfig . 0 -weight 0
grid rowconfig . 1 -weight 1
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
}
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.