# 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