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.
}
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
}
Program 2 edit
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
Comments edit
...
