Valentines

Some valentine postings from comp.lang.tcl.

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 .}
 bump

And 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
         }
 }

gold added pix