Version 1 of Kaleidoscope
Updated 2004-09-12 12:27:27if 0 {Richard Suchenwirth 2004-09-12 - In this fun project I tried to emulate the classic kaleidoscope - a tube to look through, where colorful pieces of glass are multiply mirrored, resulting in snowflake-like symmetric patterns. Click on the canvas for a new random pattern.
}
package require Tk
set tcl_precision 17
proc kaleidoscope w {
$w delete all
foreach color {red green blue yellow magenta cyan} {
random'triangle $w $color
}
foreach item [$w find withtag ori] {
$w raise $item
set item2 [poly'copy $w $item 1 -1]
foreach angle {60 120 180 240 300} {
poly'rotate $w [poly'copy $w $item] $angle
poly'rotate $w [poly'copy $w $item2] $angle
}
}
}
proc random'triangle {w color} {
set x0 [expr {rand()*150-75}]
set y0 [expr {rand()*150-75}]
set x1 [expr {$x0+rand()*150-75}]
set y1 [expr {$y0+rand()*150-75}]
set x2 [expr {$x1+rand()*150-75}]
set y2 [expr {$y1+rand()*150-75}]
$w create poly $x0 $y0 $x1 $y1 $x2 $y2 -fill $color \
-tag ori
}
proc poly'rotate {w item angle} {
set delta [expr {$angle/180.*acos(-1)}]
foreach {x y} [$w coords $item] {
set r [expr {hypot($y,$x)}]
set a [expr {atan2($y,$x)+$delta}]
lappend coords [expr {cos($a)*$r}] [expr {sin($a)*$r}]
}
$w coords $item $coords
#$w raise $item
}
proc poly'copy {w item {fx 1} {fy 1}} {
foreach {x y} [$w coords $item] {
lappend coords [expr {$x*$fx}] [expr {$y*$fy}]
}
$w create poly $coords -fill [$w itemcget $item -fill] \
-stipple [$w itemcget $item -stipple]
}#-- The main part:
pack [canvas .c -width 200 -height 200 -background white]
.c config -scrollregion {-100 -100 100 100}
kaleidoscope .c
bind .c <1> {kaleidoscope %W}#-- Development helpers, including how to make screenshots:
bind . <Escape> {exec wish $argv0 &; exit}
bind . <F1> {console show}
set n 0
bind . <F2> {
package req Img; [image create photo -data .c] write kal[incr n].gif
}