package require Tk
 
 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
 }
 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
 }

# kaleidoscope.tcl --
#     Kaleidoscope with a twist: the mirrors are set with an angle of
#     72 degrees and the triangles are copied with an imperfection
#
set angle [expr {2.0*acos(-1.0)/5.0}]

proc generateTriangle {} {
    global angle

    set coords {}
    foreach p {1 2 3} {

        while {1} {
            set x [expr {200.0*rand()}]
            set y [expr {200.0*rand()}]

            if { atan2($y,$x) <= $angle } {
                lappend coords $x $y
                break
            }
        }
    }
    return $coords
}

proc pickColour {} {
    return [lindex {red orange yellow cyan magenta blue lightblue green lightgreen} \
               [expr {int(rand()*9.0)}]]
}

proc mirrorTriangle {angle coords} {

    set cosa [expr {cos(2.0*$angle)}]
    set sina [expr {sin(2.0*$angle)}]

    set coordsn {}
    foreach {x y} $coords {
        set xn [expr { $cosa * $x + $sina * $y}]
        set yn [expr { $sina * $x - $cosa * $y}]
        lappend coordsn $xn $yn
    }
    return $coordsn
}

proc fillCanvas {} {
    global angle

    .c delete all

    set number [expr {int(20*rand())}]

    for {set i 0} {$i <$number} {incr i} {
        set colour [pickColour]
        set coords [generateTriangle]

        .c create polygon $coords -fill $colour -outline black

        foreach c {1 2 3 4} stipple {gray75 gray50 gray25 gray12} {
            set coords [mirrorTriangle [expr {$c*$angle}] $coords]

            .c create polygon $coords -fill $colour -outline black \
                -stipple $stipple
        }
    }

    .c scale all 0 0 1 -1
    .c move all 200 200

    after 250 fillCanvas
}


pack [canvas .c -width 400 -height 400] -fill both

fillCanvas