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. [WikiDbImage kal1.gif] [WikiDbImage kal2.gif] [WikiDbImage kal3.gif] } 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 . {exec wish $argv0 &; exit} bind . {console show} set n 0 bind . { package req Img; [image create photo -data .c] write kal[incr n].gif } ---- [AM] (4 may 2008) Just another twist to a kaleidoscope: this is based on angles of 72 degrees ... It was just to amuse myself. ====== # 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 ====== ---- [Category Graphics] | [Arts and crafts of Tcl-Tk programming]