# 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