Version 40 of Refrigerator_Magnetic_Poetry
Updated 2006-07-28 15:55:32This 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
namespace eval xpoetry {
variable bg black fg white size 30
global jack
global jill
global liner
set movesit 1
}
set dx 50
set dy 50
set size 30
global movesit
set movesit 1
global xhistory firstnode curnode
set curnode ""
set firstnode ""
set xhistory [list aaa bbb ccc ddd eee fff ggg ]
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 entries
set counter 0
# Refrigerator_Magnetic_Poetry
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. Other procedures working
# on windows98 and old PC.
# from goldshell7 on 10jun2006.}
proc getvalues {path default1 default2} {
global getvalues
if {![winfo exists $path]} {
toplevel $path
frame $path.buttons
button $path.buttons.ok -text OK \
-command [list set getvalues($path) "ok"]
button $path.buttons.cancel -text Cancel \
-command [list set getvalues($path) "cancel"]
pack $path.buttons.ok $path.buttons.cancel -side right
#label $path.l1 -text "Value 1:"
#label $path.l2 -text "Value 2:"
label $path.l1 -text "state1:"
label $path.l2 -text "state2:"
entry $path.e1
entry $path.e2
grid $path.l1 -row 0 -column 0 -sticky e
grid $path.e1 -row 0 -column 1 -sticky ew
grid $path.l2 -row 1 -column 0 -sticky e
grid $path.e2 -row 1 -column 1 -sticky ew
grid $path.buttons -row 2 -column 0 -columnspan 2 \
-sticky ew -pady 4
}
$path.e1 delete 0 end
$path.e1 insert 0 $default1
$path.e2 delete 0 end
$path.e2 insert 0 $default2
wm deiconify $path
tkwait variable getvalues($path)
wm withdraw $path
if {$getvalues($path) eq "ok"} {
set value1 [$path.e1 get]
set value2 [$path.e2 get]
return [list $value1 $value2]
} else {
return {}
}
}
proc poemsorts {poetsey} {
global liner
#set liner [list q w e r]
set liner [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
set adjective_poetic {
{red} { sad} { blue}
{ joyful} { flawed }
}
set noun_subject {
{cat} { apple} { garlic}
{ quince} { mallow}
{ smoke} { rain}
}
set verb_transitive {falls snow burns flips flys lies}
set noun_objective {
cloud {old home} flower { sky } rice {cricket}
}
set silly_propostion {
for {by} towards { to } at {bygone}
}
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
set poetsey $liner
return $poetsey
}
proc lpick L {lindex $L [expr int(rand()*[llength $L])]; \
#suchenwirth_subroutine;}
proc poetry jill {
set jill [lpick { tree happy grass love swan home \
power loss dance rose joy hate juice kick}]
return $jill;
}
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 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 firstnode curnode
set selected_tile "selected tile";
#set previous_tile "previous tile";
set numberx [.c gettags current]
regexp {obj_(\d+)} $numberx -> tilex
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 "
.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 xpop { topper } {
global liner
global ind
set poetsey aaaaa
set liner [poemsorts $poetsey];
set goofy [stringxxx $liner] ;
set topper [ lindex $goofy $ind ];
set ind [ expr { $ind + 1}]
return $topper;
}
proc ? L {
lindex $L [expr {int(rand()*[llength $L])}]
#suchenwirth_subroutine;
}
proc xpoetry::create {w x y val1 val2} {
global jack
global jill
global liner
global tile ind
variable bg; variable fg; variable size
set jack [lpick {red yellow blue purple \
pink green brown black gray}]
set jill rose
#remaining doctered_suchenwirth_subroutine;
set tags [list mv d-$val1$val2];
#remaining doctered_suchenwirth_subroutine;
set x1 [expr {$x+$size-0.5}]
set y1 [expr {$y+$size}]
set tile [expr {int(rand()*1000000000.)}]
set looky "stringx";
set poof [xpop $looky ] ;
set tags [list $poof mv obj_$tile d-$val1$val2];
$w create rect $x $y [expr {$x+2*$size}] $y1 \
-fill $jack -tags [linsert $tags end bd-$val1$val2]
#$w create text [expr {$x+1*$size}] [expr {$y+0.5*$size }] \
-text [eval poetry $jill] -fill $fg -tags $tags
set looky "rook"
set liner [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
set looky "stringx"
#$w create text [expr {$x+1*$size}] [expr {$y+0.5*$size }] \
-text [xpop $looky ] -fill $fg -tags $tags
set tags [list $poof mv "obj_$tile+1" d-$val1$val2];
$w create text [expr {$x+1*$size}] [expr {$y+0.5*$size }] \
-text $poof -fill $fg -tags $tags
incr tile
}
if 0 {Clicking on a piece records \
the click position, and its "catch-all" tag, \
in global variables:}
proc mv'1 {w x y} {
global tile
global xhistory firstnode curnode
global ind movesit
set number 2
set numberx 2
set ::_x $x; set ::_y $y;#suchenwirth subroutine;
set firstnode [.c find withtag current]
foreach tag [$w gettags current] {
if [regexp ^(d-.+) $tag -> ::_tag] break
set number [$w gettags current]
set indexer [string first "mv" $number ];
set numberx [string range $number 0 $indexer];
.wxx delete 1.0 end;
# general reporting line
.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 ";
incr movesit
}
}
if 0 {Moving the mouse with button 1 down \
moves the items with the "catch-all" tag \
with the mouse pointer:}
proc clearclear {w} {
$w delete "all"
}
proc itemcrosshairs {w} {
set middlexxxx [expr { $::maximumxxxx/ 2 }]
set middleyyyy [expr { $::maximumyyyy/ 2 }]
$w create line 0 $middleyyyy $::maximumxxxx $middleyyyy -tags "axis"
$w create line $middlexxxx 0 $middlexxxx $::maximumyyyy -tags "axis"
}
proc itemtext {w Txt} {
global text_texas
$w create text 800 50 -text $text_texas -tags "text"
}
proc itembox {w} {
$w create rect 50 10 100 60 -tags "box"
}
proc mv'motion {w x y} {
$w raise $::_tag;#suchenwirth subroutine;
$w move $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}]
set ::_x $x; set ::_y $y
}
frame .f1
frame .f2
pack .f1 .f2
proc reset {} {
set ::maximumxxxx 500
set ::maximumyyyy 500
set yyyy 50
set dx 50
set dy 50
set size 30
set colorground bisque
global counter
global liner
global ind
set ind 0
set maximumxxxx 320
set maximumyyyy 300
set yyyy 0
set xx1 120
set xx2 150
set yy1 120
set yy2 150
set x1 120
set x2 150
set y1 50
set y2 80
pack [canvas .c -bg $colorground -width 500 \
-height 250 ] -fill both -expand 1
set height 400
set width 600
set borderwidth 2
set canvas .c
set hscroll .hscroll
set vscroll .vscroll
scrollbar $hscroll -orient horiz -command "$canvas xview"
scrollbar $vscroll -command "$canvas yview"
$canvas configure -scrollregion [$canvas bbox all]
pack .c $vscroll $hscroll -in .f2
button .b0 -text "clear" -command { clearclear .c }
button .b1 -text "text" -command { itemtext .c "Canvas" }
button .b2 -text "hairs" -command { itemcrosshairs .c }
button .b3 -text "zone" -command {
set maximumxxxx 320;
set maximumyyyy 300;
set yyyy 0;
set xx1 120;
set xx2 150;
set yy1 120;
set yy2 150;
itembox .c }
button .b4 -text "exit" -command { exit }
button .b5 -text "Del_tank" -command { .w delete 1.0 end}
button .b6 -text "lt_bg" -command { set colorground LightBlue1; \
.c configure -bg $colorground }
button .b7 -text "bis_bg" -command { set colorground Bisque; \
.c configure -bg $colorground }
button .b8 -text "ran_bg" -command {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 }
button .b9 -text "del_hisry" -command { .wxx delete 1.0 end }
button .b10 -text "deal" -command {set state1 1; random_poetry .w;
}
button .b11 -text "state" -command {set state1 1; getvalues .dialog one two;random_poetry .w; }
button .b12 -text "reset" -command {foreach i {.b0 .b1 .b2 .b3 .b4 .b5 .b6 .b7 .b8 .b9 .b10 .b11 .b12 .b14 .b15 .b16 .c .hscroll .vscroll} {
destroy $i
}; reset }
button .b14 -text "open" -command { file:open .w }
button .b15 -text "save" -command { htm_print .w }
button .b16 -text "print" -command { file:save .w }
pack .b0 .b1 .b2 .b3 .b4 .b5 .b6 .b7 .b8 .b9 .b10 .b11 .b12 .b14 .b15 .b16 -in .f1 -side left -padx 2
for {set i 0; set y 0} {$i<8} {incr i; incr y $dy} {
for {set j 0; set x 0} {$j<8} {incr j; incr x $dx} {
set state1 1;
if {$state1 == 0 } { xpoetry::create .c [expr $i*65+10] [expr $j*35+100] $i $j }
if {$state1 == 1 } {xpoetry::create .c [expr $j*65+10] [expr $i*35+100] $i $j }
}
}
set size 30
.c bind mv <1> {mv'1 %W %x %y}
.c bind mv <B1-Motion> {mv'motion %W %x %y}
#.c bind mv <B3-Motion> {select&die %W %x %y}
.c bind mv <2> {select&die %W %x %y}
set curnode ""
set firstnode ""
bind .c <3> {
#set firstnode [.c find withtag green]
set curnode [.c find withtag current]
#set curnode [.c find withtag red]
if {( $firstnode != "") && ($curnode != "")} {
dualcheck $tile $firstnode $curnode }}
}
reset
if 0 {Moving the mouse with button 1 \
down moves the items with the "catch-all" tag \
with the mouse pointer:}
if 0 {Clicking on a piece records the click position, \
and its "catch-all" tag, in global variables:}
proc select&die {w x y} {
# remove selected pieces by moving right mouse
# on top of them, working better
set ::_x $x; set ::_y $y
foreach tag [$w gettags current] {
if [regexp ^(d-.+) $tag -> ::_tag] break
}
$w delete $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}]
}
if 0 {Clicking on a piece records the click position, \
and its "catch-all" tag, in global variables:}
set size 30
.c bind mv <1> {mv'1 %W %x %y}
.c bind mv <B1-Motion> {mv'motion %W %x %y}
#.c bind mv <B3-Motion> {select&die %W %x %y}
.c bind mv <2> {select&die %W %x %y}
set curnode ""
set firstnode ""
bind .c <3> {
#set firstnode [.c find withtag green]
set curnode [.c find withtag current]
#set curnode [.c find withtag red]
if {( $firstnode != "") && ($curnode != "")} {
dualcheck $tile $firstnode $curnode }}
#-- 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 }
set entries 1
proc ? L {
lindex $L [expr {int(rand()*[llength $L])}]
}
if { 1 == 1 } {
package require Tk
#set anagrams [list]
pack [ label .wcc -text "list of selection history " ]
pack [text .wxx -width 80 -height 20 -bg bisque \
-setgrid true -width 70 \
-height 2 -wrap word -highlightthickness 0 -borderwidth 0]
.wxx insert end $xhistory
set labelx [info tclversion];
pack [ label .ww -text "holding tank, version $labelx " ]
pack [text .w -width 80 -height 20 -bg bisque \
-setgrid true -width 70 \
-height 35 -wrap word -highlightthickness 0 -borderwidth 0]
#bind .w <1> {random_poetry %W; break}
proc random_poetry w {
global liner
#global anagrams
set liner [ list a b c d e ]
$w delete 1.0 end
#$anagrams insert end [ poem_of_sorts liner]
#poem_of_sorts
#set liner [split $liner {\.\}\{\"}]
$w insert end [poemsorts {poetsey}]
$w insert end $liner
#$anagrams insert end [poem_of_sorts ]
#$w insert end [ split $liner \.\}\{\"]
#lpush $liner [split [ poem_of_sorts ] \.\}\{\"]
#join $liner [list [ split poetsey .]]
#set liner eval[ poem_of_sorts ]
}
random_poetry .w
}
proc htm_print {w} {
#suchenwirth_subroutine from taiku;
# this works only on Windows 95..ME...
set filename [file join $::env(TEMP) taiku.html]
set fp [open $filename w]
puts $fp [s2html [$w get 1.0 end]]
close $fp
exec $::env(COMSPEC) /c start [file nativename $filename] &
}
proc s2html s {
#suchenwirth_subroutine from taiku;
set res ""
foreach line [split $s \n] {
append res <br>
foreach c [split $line ""] {
set uc [scan $c %c]
append res [expr {$uc>127? "&#$uc;" : $c}]
}
}
set res
}
proc file:open {w} {
#suchenwirth_subroutine from taiku;
set fn [tk_getOpenFile]
if [string length $fn] {
$w delete 1.0 end
set f [open $fn]
#fconfigure $f -encoding euc-cn
fconfigure $f
foreach line [split [read $f] \n] {$w insert end $line\n}
close $f
}
}
proc file:save {w} {
#suchenwirth_subroutine;
set fn [tk_getSaveFile]
if [string length $fn] {
set f [open $fn w]
#fconfigure $f -encoding euc-cn
fconfigure $f
puts $f [$w get 1.0 end-2c]
close $f
}
}
#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]
#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 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'':28jun2006,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.