[refrigerator magnetic poetry ] 
----

 # horoscope pie plotter
 # horoscope pie plotter 
 # loaded on tcl wiki
 # used version tcl8
 # 22may2006, goldshell7
 # start of deck
 # canvas_horoscope_pie_chart.tcl --
 # goldshell7, tcl wiki script on 20060601
 # modified to demonstration script in Expect 5.2
 # TCL8 distribution, for Win95 use
 # canvas_horoscope_pie_chart.tcl --
 #
 # modified to demonstration script in TCL8 distribution
 # canvas item types.
 #
 # SCCS: @(#) items.tcl 1.16 97/03/02 16:25:05

 set w .items
 catch {destroy $w}
 toplevel $w
 wm title $w "Canvas Horoscope Pie Plot"
 wm iconname $w "Items"
 #positionWindow $w
 set c $w.frame.c


 frame $w.buttons
 pack $w.buttons -side bottom -fill x -pady 2m
 button $w.buttons.dismiss -text Dismiss -command "destroy $w"
 button $w.buttons.code -text "See Code" -command "showCode $w"
 pack $w.buttons.dismiss $w.buttons.code -side left -expand 1

 frame $w.frame
 pack $w.frame -side top -fill both -expand yes

 canvas $c -scrollregion {0c 0c 30c 24c} -width 15c -height 10c \
	-relief sunken -borderwidth 2 \
	-xscrollcommand "$w.frame.hscroll set" \
	-yscrollcommand "$w.frame.vscroll set"
 scrollbar $w.frame.vscroll -command "$c yview"
 scrollbar $w.frame.hscroll -orient horiz -command "$c xview"

 grid $c -in $w.frame \
    -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
 grid $w.frame.vscroll \
    -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
 grid $w.frame.hscroll \
    -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
 grid rowconfig    $w.frame 0 -weight 1 -minsize 0
 grid columnconfig $w.frame 0 -weight 1 -minsize 0
 proc lpick L {lindex $L [expr int(rand()*[llength $L])]}

    set c3 [lpick {black brown white  \
     brown3 brown4 red }]
    set c1 [lpick {red yellow blue purple \
     pink green brown black white gray}]
    set c2 [lpick {red yellow blue purple \
      pink green brown black white gray}] 

 set color black
 set dx 50
  set dy 50
 set radiusradius 220
 set sectors  [list ARIES TAURUS CANCER GEMINI LEO VIRGO LIBRA
 SCORPIO  SAGITTARIUS  CAPRICORN "AQUARIUS"  
 PISCES ]  
 set percentages [list 8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.3 8.9 ]      
 array set colors  [list white white yellow white white yellow white white yellow white white yellow]
 proc lpick L {lindex $L [expr int(rand()*[llength $L])]}


 set next 0
    set x0   [expr $radiusradius * 1.1]
    set y0   [expr $radiusradius * 1.1]

    set dim [list [expr $x0 - $radiusradius] [expr $y0 - $radiusradius]           \
                  [expr $x0 + $radiusradius] [expr $y0 + $radiusradius]]

    foreach segment $sectors percentage $percentages colour $color {
        set degrees [expr $percentage * 3.6]
        eval $c create arc $dim -start $next -extent $degrees -fill yellow;       
                

        set sectors_mid [expr ($next + $degrees / 2) * acos (0) / 90]
        $c create text                                              \
                [expr $x0 + $radiusradius * cos ($sectors_mid)*6 / 8]         \
                [expr $y0 - $radiusradius * sin ($sectors_mid)*6 / 8]         \
                -text $segment

        set next [expr $next + $degrees]
    }




 


 set font1 {Helvetica 12}
 set font2 {Helvetica 24 bold}
 if {[winfo depth $c] > 1} {
    set blue DeepSkyBlue3
    set red red
    set bisque bisque3
    set green SeaGreen3
 } else {
    set blue black
    set red black
    set bisque black
    set green black
 }

 # Set up 

 $c create text 2c .2c -text HOROSCOPE -anchor n
 $c create line 21c 21c 23c 21c 21c 24c 23c 24c -width 2m -fill $blue \
	-cap butt -join miter -tags item
 $c create line 24.67c 21c 24.67c 24c -arrow last -tags item
 $c create line 26.33c 21c 26.33c 24c -arrow both -tags item
 $c create line 31c 24c 31.5c 21c 33.5c 21c 34c 24c -smooth on \
	-fill $blue -tags item

  $c create line 21c 5c 21.5c 7c 21.5c 5c 22c 4c -arrow last -smooth on \
	-fill brown -width 3 -tags item

 $c create line 15.5c 11c 19.5c 11.5c 15.5c 14.5c 19.5c 14c -smooth on \
	-arrow both -width 3 -tags item
 catch {$c create line 32c 26c 33.5c 24.5c 36.5c 27.5c 38c 26c \
	36.5c 24.5c 33.5c 27.5c 32c 26c -smooth on -width 3m -cap round \
	-stipple @[file join $tk_library demos images gray25.bmp] \
	-fill $red -tags item }



 $c create line 21c 27c 21.75c 25.8c 22.5c 27c 23.25c 25.8c 24c 27c -width .5c \
	-cap round -join round -tags item

 $c create text 25c .2c -text Symbol_Stack -anchor n
 $c create polygon 21c 1.0c 22.5c 1.75c 24c 1.0c 23.25c 2.5c \
	24c 4.0c 22.5c 3.25c 21c 4.0c 21.75c 2.5c -fill $green \
	-outline black -width 4 -tags item

 
     $c create oval 21c 9.0c 22c 10.0c  -fill $c2 -outline black -width 1m -tags item ;
    $c create oval 21c 19.5c 24c 22.5c  -fill $c2 -outline $red -width 3m -tags item ;
 $c create oval 21c 19.5c 24c 22.5c  -fill $c2 -outline $red -width 3m -tags item ; 
 $c create oval 21c 19.5c 24c 22.5c  -fill $c2 -outline $red -width 3m -tags item ;
 $c create oval 21c 19.5c 24c 22.5c  -fill $c2 -outline $red -width 3m -tags item ;






 button $c.button -text "exit" -command "exit"
 $c create window 15c 1c -window $c.button -anchor n -tags item
 entry $c.entry -width 20 -relief sunken
 $c.entry insert end "Date TBA"
 $c create window 15c 3c -window $c.entry -anchor n -tags item

 $c create text 15c 1c -text Button: -anchor s
 $c create text 15c 3c -text Entry: -anchor s


  # Set up event bindings for canvas:

 $c bind item <Any-Enter> "itemEnter $c"
 $c bind item <Any-Leave> "itemLeave $c"
 bind $c <2> "$c scan mark %x %y"
 bind $c <B2-Motion> "$c scan dragto %x %y"
 bind $c <3> "itemMark $c %x %y"
 bind $c <B3-Motion> "itemStroke $c %x %y"
 bind $c <Control-f> "itemsUnderArea $c"
 bind $c <1> "itemStartDrag $c %x %y"
 bind $c <B1-Motion> "itemDrag $c %x %y"

 # Utility procedures for highlighting the item under the pointer:

 proc itemEnter {c} {
    global restoreCmd

    if {[winfo depth $c] == 1} {
	set restoreCmd {}
	return
    }
    set type [$c type current]
    if {$type == "window"} {
	set restoreCmd {}
	return
    }
    if {$type == "bitmap"} {
	set bg [lindex [$c itemconf current -background] 4]
	set restoreCmd [list $c itemconfig current -background $bg]
	$c itemconfig current -background SteelBlue2
	return
    }
    set fill [lindex [$c itemconfig current -fill] 4]
    if {(($type == "rectangle") || ($type == "oval") || ($type == "arc"))
	    && ($fill == "")} {
	set outline [lindex [$c itemconfig current -outline] 4]
	set restoreCmd "$c itemconfig current -outline $outline"
	$c itemconfig current -outline SteelBlue2
    } else {
	set restoreCmd "$c itemconfig current -fill $fill"
	$c itemconfig current -fill SteelBlue2
    }
 }

 proc itemLeave {c} {
    global restoreCmd

    eval $restoreCmd
 }

 # Utility procedures for stroking out a rectangle and printing what's
 # underneath the rectangle's area.

 proc itemMark {c x y} {
    global areaX1 areaY1
    set areaX1 [$c canvasx $x]
    set areaY1 [$c canvasy $y]
    $c delete area
 }

 proc itemStroke {c x y} {
    global areaX1 areaY1 areaX2 areaY2
    set x [$c canvasx $x]
    set y [$c canvasy $y]
    if {($areaX1 != $x) && ($areaY1 != $y)} {
	$c delete area
	$c addtag area withtag [$c create rect $areaX1 $areaY1 $x $y \
		-outline black]
	set areaX2 $x
	set areaY2 $y
    }
 }

 proc itemsUnderArea {c} {
    global areaX1 areaY1 areaX2 areaY2
    set area [$c find withtag area]
    set items ""
    foreach i [$c find enclosed $areaX1 $areaY1 $areaX2 $areaY2] {
	if {[lsearch [$c gettags $i] item] != -1} {
	    lappend items $i
	}
    }
    puts stdout "Items enclosed by area: $items"
    set items ""
    foreach i [$c find overlapping $areaX1 $areaY1 $areaX2 $areaY2] {
	if {[lsearch [$c gettags $i] item] != -1} {
	    lappend items $i
	}
    }
    puts stdout "Items overlapping area: $items"
 }

 set areaX1 0
 set areaY1 0
 set areaX2 0
 set areaY2 0

 # Utility procedures to support dragging of items.

 proc itemStartDrag {c x y} {
    global lastX lastY
    set lastX [$c canvasx $x]
    set lastY [$c canvasy $y]
 }

 proc itemDrag {c x y} {
    global lastX lastY
    set x [$c canvasx $x]
    set y [$c canvasy $y]
    $c move current [expr $x-$lastX] [expr $y-$lastY]
    set lastX $x
    set lastY $y
 }

 # Procedure that's invoked when the button embedded in the canvas
 # is invoked.

 proc butPress {w color} {
    set i [$w create text 25c 18.1c -text "Ouch!!" -fill $color -anchor n]
    after 500 "$w delete $i"
 }
  #end of deck
----
 #horoscope pie chart!   
----
[Category Toys]----
[ 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]