Refrigerator_Magnetic_Poetry
#Refrigerator_Magnetic_Poetry
# Start of Deck
package require Tk
namespace eval xpoetry {
variable bg black fg white size 30
}
set dx 50
set dy 50
set size 30
set colorground bisque
# Refrigerator_Magnetic_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.
# from goldshell7 on 10jun2006.
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 xpoetry::create {w x y val1 val2} {
global jack
global jill
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
}
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 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
}
pack [canvas .c -bg $colorground -width 500 -height 350] -fill both -expand 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} {
xpoetry::create .c [expr $i*65+10] [expr $j*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}
#-- Little development helpers (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 }
#end of deck
Category Toys