if 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.

[http://mini.net/files/kal1.gif]
[http://mini.net/files/kal2.gif]
[http://mini.net/files/kal2.gif]
}
 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
 }

----
[Category Graphics] | [Arts and crafts of Tcl-Tk programming]