This 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]
[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 dx 50
set dy 50
set size 30
set colorground bisque
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.
# Sliding middle mouse across piece
# might delete same piece or other pieces.
# 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 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 xpop { topper } {
global liner
global ind
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
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}]
$w create rect $x $y [expr {$x+2*$size}] $y1 \
-fill $jack -tags [linsert $tags 0 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 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] [? $noun_subject]. The [? $adjective_poetic] [? $noun_subject] [? $verb_transitive] [? $silly_propostion] [? $adjective_poetic] [? $noun_subject] . The [? $adjective_poetic] [? $noun_subject] [? $verb_transitive] [? $silly_propostion] [? $adjective_poetic] [? $noun_subject]. The [? $adjective_poetic] [? $noun_subject] [? $verb_transitive] [? $silly_propostion] [? $adjective_poetic] [? $noun_subject]. The [? $adjective_poetic] [? $noun_subject] [? $verb_transitive] [? $silly_propostion] [? $adjective_poetic] [? $noun_subject]."
#set liner [list a b c d e f g ]
set liner [list aaaa bbbb cccc dddd eeee fffff gggg hhhh ]
lappend liner $poetsey
set looky "stringx"
$w create text [expr {$x+1*$size}] [expr {$y+0.5*$size }] \
-text [xpop $looky ] -fill $fg -tags $tags
}
if 0 {Clicking on a piece records \
the click position, and its "catch-all" tag, \
in global variables:}
proc mv'1 {w x y} {
set ::_x $x; set ::_y $y;#suchenwirth subroutine;
foreach tag [$w gettags current] {
if [regexp ^(d-.+) $tag -> ::_tag] break
}
}
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 yyyy
global text_texas
incr yyyy 10
$w create text 800 50 -text $text_texas -tags "text"
}
proc itembox {w} {
global xx1 yy1 xx2 yy2
$w create rect 50 10 100 60 -tags "box"
$w create rect $xx1 $yy1 $xx2 $yy2 -tags "box"
incr xx1 15
incr xx2 15
incr yy1 10
incr yy2 10
}
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
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 { itembox .c }
button .b4 -text "exit" -command { exit }
button .b5 -text "destroy" -command { destroy . }
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 "exit" -command { [exit] }
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 {set state1 1;
set val1 1;
set val2 1;
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 val1 $i;
set val2 $j;
set tags [list mv d-$val1$val2];
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 looky "stringx";
set looky "stringx"
# .c create text [expr {$x+1*$size}] [expr {$y+0.5*$size }] \
-text [xpop $looky ] -fill blue -tags $tags;
.c configure -bg $jack
.c create text [expr $j*65+40] [expr $i*35+100+12 ] \
-text [eval poetry $jill] -fill blue -tags $tags;
}
}
;random_poetry .w; }
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 }
}
}
if 0 {Moving the mouse with button 1 \
down moves the items with the "catch-all" tag \
with the mouse pointer:}
proc move&die {w x y} {
# remove selected pieces & other pieces
# by moving middle mouse
# on top of them, not working too well
$w raise $::_tag
$w move $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}]
$w delete $::_tag [expr {$x-$::_x}] [expr {$y-$::_y}]
set ::_x $x; set ::_y $y
}
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}]
}
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 <B2-Motion> {move&die %W %x %y}
#-- 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])}]
}
proc poem_of_sorts {poetsey} {
global liner
#set liner [list q w e r]
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], [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic] [? $noun_subject],The , [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $noun_subject],The [? $adjective_poetic],[? $noun_subject], [? $verb_transitive], [? $silly_propostion], [? $adjective_poetic], [? $noun_subject],"
set liner $poetsey
return $poetsey
}
if { 1 == 1 } {
package require Tk
#set anagrams [list]
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 [poem_of_sorts {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 .]]
join $liner $liner
join $liner [poem_of_sorts {poetsey}]
join $liner [poem_of_sorts {poetsey}]
join $liner [poem_of_sorts {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
}
}
#end of deck
#end of deckcode 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.