The original, by mailto:[email protected]
canvas .c -width 200 -height 200 -bg pink pack .c .c create polygon 100 55 75 33 35 45 20 100 100 170 100 170 180 100 165 45 125 33 100 55 100 55 -smooth true -fill red
Slightly modified by me (Andreas Kupries) to work with older versions of Tk.
canvas .c -width 200 -height 200 -bg pink pack .c set i [.c create polygon 100 55 75 33 35 45 20 100 100 170 100 170 180 100 165 45 125 33 100 55 100 55] .c itemconfigure $i -smooth true -fill red
A throbbing heart, by John Ellson - mailto:[email protected]
set shape {0 -47 -25 -69 -65 -57 -80 -2 0 68 0 68 80 -2 65 -57 25 -69 0 -47 0 -47}
set throb {1.0 1.05 1.10 1.05}
pack [canvas .c -width 200 -height 200 -bg pink]
set i [eval .c create polygon $shape]
.c itemconfigure $i -smooth true -fill red -tag heart
set i 0
while {1} {
if {!([incr i] % [llength $throb])} {set i 0}
eval .c coords heart $shape
set factor [lindex $throb $i]
.c scale heart 0 0 $factor $factor
.c move heart 100 100
update
after 100
}And now it's bumping ([Uwe Koloska] - mailto:[email protected]
)
canvas .c -width 200 -height 200 -bg pink
pack .c
.c create polygon 100 55 75 33 35 45 20 100 100 170 100 170 180 100 165 45 125 33 100 55 100 55 -smooth true -fill red
foreach {x1 y1 x2 y2} [.c bbox 1] {}
set origx [expr $x1 + ($x2 - $x1) / 2]
set origy [expr $y1 + ($y2 -$y1) / 2]
proc bump {} {
global factor origx origy pause
.c scale 1 $origx $origy $factor $factor
update idletasks
after $pause {bump}
set factor [expr 1.0 / $factor]
if {$pause == 80} {
set pause 300
} {
set pause 80
}
}
set factor 1.1
set pause 80
bind . <1> {destroy .}
bumpAnd [Ian Findleton] pierced it with an arrow:
# Display a heart
set points { 100 55 75 33 35 45 20 100 100 170 100 170 180 100 165 45 125 33 100 55 100 55 }
# Get the centroid of the drawing
proc FindCenter { points } {
set xc 0
set yc 0
set count 0
foreach { x y } $points {
incr xc $x
incr yc $y
incr count
}
return "[expr $xc / $count] [expr $yc / $count]"
}
# Get the offsets from the center of gravity
proc GetOffsets { points origin } {
set xc [lindex $origin 0]
set yc [lindex $origin 1]
set result {}
foreach { x y } $points {
lappend result [expr $x - $xc]
lappend result [expr $y - $yc]
}
return $result
}
# Scale the points by a factor
proc ScalePoints { factor points } {
set result {}
foreach val $points {
lappend result [expr $val * $factor]
}
return $result
}
# Build the list of locations
proc BuildLocationList { points origin } {
set xc [lindex $origin 0]
set yc [lindex $origin 1]
set result {}
foreach { x y } $points {
lappend result [expr $x + $xc]
lappend result [expr $y + $yc]
}
return $result
}
catch { destroy .c }
canvas .c -width 200 -height 200 -bg pink
pack .c
set origin [FindCenter $points]
set list [GetOffsets $points $origin]
set factors { 1.0 0.95 1.0 1.05 }
set layers { red4 1.0 red3 0.92 red2 0.88 red1 0.82 }
# Draw the heart
proc DrawHeart { list origin } {
global layers
foreach { color factor } $layers {
set i [eval .c create polygon [BuildLocationList [ScalePoints $factor $list] $origin]]
.c itemconfigure $i -smooth true -fill $color -tags heart
}
}
# Draw the arrow
proc DrawArrow { origin what } {
set xc [lindex $origin 0]
set yc [expr [lindex $origin 1] + 20]
set color gold3
if { $what } {
set xn [expr $xc + 85]
set yn [expr $yc - 85]
set xo [expr $xc + 15]
set yo [expr $yc - 15]
.c create line $xo $yo $xn $yn -width 7 -arrow last -fill $color -arrowshape { 20 24 5 }
} else {
set xo [expr $xc - 75]
set yo [expr $yc + 75]
set xn [expr $xo + 20]
set yn [expr $yo - 20]
.c create line $xo $yo $xn $yn -width 7 -arrow last -fill $color -arrowshape { 20 28 7 }
.c create line $xo $yo $xc $yc -width 7 -fill $color
}
}
# Display a beating heart!
while { 1 } {
foreach factor $factors {
DrawArrow $origin 0
DrawHeart [ScalePoints $factor $list] $origin
DrawArrow $origin 1
update
after 250
.c delete heart
}
}