See Also edit
Description edit
Richard Suchenwirth 2002-06-15: Cameron Laird pointed me to Functional Image Synthesis
foo 1 o bar 2 o grill(where "o" is the composition operator) would in Tcl look like
o {foo 1} {bar 2} grillAs the example shows, additional arguments can be specified; only the last argument is passed through the generated "function nest":
proc f x {foo 1 [bar 2 [grill $x]]}But the name of the generated function is much nicer than "f": namely, the complete call to "o" is used, so the example proc has the name
{o {foo 1} {bar 2} grill}which is pretty self-documenting ;-) I implemented "o" like this (PYK 2014-04-14: Basic idea of RS is still here, but object system has been added, and changes to the interface made):
Code edit
#! /bin/env tclsh proc method {name params args} { switch [llength $args] { 1 { lassign $args body set attributes {} } 2 { lassign $args attributes body } default { error {wrong number args: should be \ "method name params ?attributes? body"} } } proc $name $params [string map [ list {{{attributes}}} [list $attributes] {{{body}}} $body] { set id $::errorInfo foreach varname {{attributes}} { upvar 0 ${id}::$varname $varname } {{body}} }] } method o args { # combine the functions in args, return the created name set body [concat [join $args { [}] \$x] append body [string repeat \] [expr {[llength $args]-1}]] set name [string map {: _} $args] regsub -all {[[:space:]]+} $name { } name set name o\ $name proc ${id}::$name x $body return $name } # Now for the rendering framework: method fim {f onfinish {zoom 100} {width 200} {height -}} busy { set busy 1 # produce a photo image by applying function f to pixels if {$height eq "-"} {set height $width} set im [image create photo -height $height -width $width] set data {} set xs {} for {set j 0} {$j < $width} {incr j} { lappend xs [expr {($j-$width/2.)/$zoom}] } $id fim_doing $f $onfinish $zoom $height $xs 0 $im $data[set data {}] } method fim_doing {f onfinish zoom height xs i im data} { if {$i >= $height} { after idle [list {*}$onfinish $im $data] return } set row {} set y [expr {($i-$height/2.)/$zoom}] foreach x $xs { lappend row [{*}$f [list $x $y]] } lappend data $row incr i after idle [list $id fim_doing $f $onfinish $zoom $height $xs $i $im $data[ set data {}]] } proc vstrip p { # a simple vertical bar b2c [expr {abs([lindex $p 0]) < 0.5}] } proc udisk p { # unit circle with radius 1 foreach {x y} $p break b2c [expr {hypot($x,$y) < 1}] } proc xor {f1 f2 p} { lappend f1 $p; lappend f2 $p b2c [expr {[eval $f1] != [eval $f2]}] } proc and {f1 f2 p} { lappend f1 $p; lappend f2 $p b2c [expr {[eval $f1] eq "#000" && [eval $f2] eq "#000"}] } proc checker p { # black and white checkerboard foreach {x y} $p break b2c [expr {int(floor($x)+floor($y)) % 2 == 0}] } proc gChecker p { # greylevels correspond to fractional part of x,y foreach {x y} $p break g2c [expr {(fmod(abs($x),1.)*fmod(abs($y),1.))}] } proc bRings p { # binary concentric rings foreach {x y} $p break b2c [expr {round(hypot($x,$y)) % 2 == 0}] } proc gRings p { # grayscale concentric rings foreach {x y} $p break g2c [expr {(1 + cos(3.14159265359 * hypot($x,$y))) / 2.}] } proc radReg {n p} { # n wedge slices starting at (0,0) foreach {r a} [toPolars $p] break b2c [expr {int(floor($a*$n/3.14159265359))%2 == 0}] } proc xPos p {b2c [expr {[lindex $p 0]>0}]} proc cGrad p { # color gradients - best watched at zoom=100 foreach {x y} $p break if {abs($x)>1.} {set x 1.} if {abs($y)>1.} {set y 1.} set r [expr {int((1.-abs($x))*255.)}] set g [expr {int((sqrt(2.)-hypot($x,$y))*180.)}] set b [expr {int((1.-abs($y))*255.)}] c2c $r $g $b } proc fplot {expr p} { foreach {x y} $p break b2c [expr abs($expr)<=0.04] ;# double eval required here! } proc bin2 {f1 f2 p} { set a [eval $f1 [list $p]] set b [eval $f2 [list $p]] expr { $a eq "#000" ? $b eq "#000" ? "green" : "yellow" : $b eq "#000" ? "blue" : "black" } } #--------------------------------------- Pixel converters: proc g2c {greylevel} { # convert 0..1 to #000000..#FFFFFF set hex [format %02X [expr {round($greylevel*255)}]] return #$hex$hex$hex } proc b2c {binpixel} { # 0 -> white, 1 -> black expr {$binpixel ? "#000" : "#FFF"} } proc c2c {r g b} { # make Tk color name: {0 128 255} -> #0080FF format #%02X%02X%02X $r $g $b } proc bPaint {color0 color1 pixel} { # convert a binary pixel to one of two specified colors expr {$pixel eq "#000" ? $color0 : $color1} } proc gPaint {color pixel} { set abspixel [lindex [rgb $pixel] 0] set rgb [rgb $color] set rgbw [rgb white] foreach var {r g b} in $rgb ref $rgbw { set $var [expr {round(double($abspixel)*$in/$ref/$ref*255.)}] } c2c $r $g $b } proc rgb {color} { upvar "#0" rgb($color) rgb if {![info exists rgb]} {set rgb [winfo rgb . $color]} set rgb } #------------------------------ point -> point transformers proc fromPolars p { foreach {r a} $p break list [expr {$r*cos($a)}] [expr {$r*sin($a)}] } proc toPolars p { foreach {x y} $p break # for Sun, we have to make sure atan2 gets no two 0's list [expr {hypot($x,$y)}] [expr {$x||$y ? atan2($y,$x): 0}] } proc radInvert p { foreach {r a} [toPolars $p] break fromPolars [list [expr {$r ? 1/$r: 9999999}] $a] } proc rippleRad {n s p} { foreach {r a} [toPolars $p] break fromPolars [list [expr {$r*(1.+$s*sin($n*$a))}] $a] } proc slice {n p} { foreach {r a} $p break list $r [expr {$a*$n/3.14159265359}] } proc rotate {angle p} { foreach {x y} $p break set x1 [expr {$x*cos(-$angle) - $y*sin(-$angle)}] set y1 [expr {$y*cos(-$angle) + $x*sin(-$angle)}] list $x1 $y1 } proc swirl {radius p} { foreach {x y} $p break set angle [expr {hypot($x,$y)*6.283185306/$radius}] rotate $angle $p } #------------------------------ Contour #contributed by Arjen Markus proc contour {expr p} { foreach {x y} $p break colourClass {-10 -5 0 5 10} [expr $expr] ;# double eval required here! } proc colourClass {classbreaks value} { set nobreaks [llength $classbreaks] set colour [lindex {darkblue blue green yellow orange red magenta} end ] for {set i 0} {$i < $nobreaks} {incr i} { set break [lindex $classbreaks $i] if { $value <= $break } { set colour \ [lindex {darkblue blue green yellow orange red magenta} $i ] break } } return $colour } #------------------------------ Some fancier gradient operators #contribued by DKF method g2 {f1 f2 p} { foreach {r1 g1 b1} [rgb [$id $f1 $p]] {break} foreach {r2 g2 b2} [rgb [$id $f2 $p]] {break} set r3 [expr {($r1+$r2)/2/256}] set g3 [expr {($g1+$g2)/2/256}] set b3 [expr {($b1+$b2)/2/256}] c2c $r3 $g3 $b3 } method g+ {f1 f2 p} { foreach {r1 g1 b1} [rgb [$id $f1 $p]] {break} foreach {r2 g2 b2} [rgb [$id $f2 $p]] {break} set r3 [expr {($r1>$r2?$r1:$r2)/256}] set g3 [expr {($g1>$g2?$g1:$g2)/256}] set b3 [expr {($b1>$b2?$b1:$b2)/256}] c2c $r3 $g3 $b3 } method g- {f1 f2 p} { foreach {r1 g1 b1} [rgb [$id $f1 $p] {break} foreach {r2 g2 b2} [rgb [$id $f1 $p] {break} set r3 [expr {($r1<$r2?$r1:$r2)/256}] set g3 [expr {($g1<$g2?$g1:$g2)/256}] set b3 [expr {($b1<$b2?$b1:$b2)/256}] c2c $r3 $g3 $b3 } proc invert {c} { foreach {r1 g1 b1} [rgb $c] {break} set r3 [expr {0xff-$r1/256}] set g3 [expr {0xff-$g1/256}] set b3 [expr {0xff-$b1/256}] c2c $r3 $g3 $b3 } #------------------------------ User Interface method fim'show f {busy oldzoom onfinish t0 w zoom} { set t0 [clock clicks] set oldzoom $zoom $id fim [list $id $f] [list $id fim'finished $f] $zoom [ winfo width $w.f2.c] [winfo height $w.f2.c] } method fim'finished {f im data} {busy cimg w t0} { if {$cimg ne {}} { $w.f2.c delete $cimg } set cimg [$w.f2.c create image 0 0 -image $im -anchor nw] $im put $data pack $w.f2.c set busy {} wm title . "[expr [clock clicks]-$t0] clicks for $f" } method fim'try {} {w try} { set ${id}::command [list $id fim'show [$id o {*}$try]] after idle [namespace eval $id [list namespace code { if {[catch $command]} { $w.f2.c delete all $w.f2.c create text 10 10 -anchor nw -text $::errorInfo } }]] } package require Tk #----------------------------------------------- testing method behave {behaviour args} {busy} { if {$busy ne {}} { return } set busy [after idle [list $id $behaviour {*}$args]] } method randtoggle {} {w randomplay} { if {$randomplay} { set randomplay 0 $w.f2.rplay configure -fg black } { set randomplay 1 $w.f2.rplay configure -fg green $id randomplay } } method randomplay {} {try randomplay} { if {!$randomplay} return set funcs [lmap x [info procs ${id}::o\ *] { string trimleft [string trimleft [namespace tail $x] o] }] set idx [expr {entier(rand()*[llength $funcs])}] set try [lindex $funcs $idx] $id behave fim'try after 5000 [list after idle [list $id randomplay]] } method rezoom args {afterzoom scale_delay} { after cancel $afterzoom set afterzoom [after $scale_delay [list after idle [ namespace eval $id [list namespace code { if {$zoom != $oldzoom} { if {$try ne {}} { $id behave fim'try } } }]]]] } method gui {} { namespace eval $id { frame $w.f2 canvas $w.f2.c variable cimg {} variable try entry $w.f2.e -bg white -textvar ${id}::try bind $w.f2.e <Return> [namespace code { $id behave fim'try}] button $w.f2.rplay -text randplay -command [namespace code { $id randtoggle }] scale $w.f2.s -from 1 -to 100 -variable \ ${id}::zoom -ori hori -width 6 bind $w.f2.s <Button1-ButtonRelease> [list $id rezoom] #--------------------------------- button bar: frame $w.f listbox $w.f.listbox -yscrollcommand [ list $w.f.scrbary set] -xscrollcommand [ list $w.f.scrbarx set] foreach imf [lsort [info procs ${id}::o\ *]] { $w.f.listbox insert end [string trimleft [ string trimleft [namespace tail $imf] o]] } bind $w.f.listbox <<ListboxSelect>> [namespace code { set try [$w.f.listbox get [$w.f.listbox curselection]] }] bind $w.f.listbox <Return> [namespace code { $id behave fim'try}] bind $w.f.listbox <Double-Button-1> [namespace code { $id behave fim'try}] scrollbar $w.f.scrbarx -orient horizontal -command [ list $w.f.listbox xview] scrollbar $w.f.scrbary -orient vertical -command [ list $w.f.listbox yview] #pack {*}[winfo children $w.f] -side top -fill x -ipady 0 pack $w.f.scrbary -side right -fill y pack $w.f.scrbarx -side bottom -fill x pack $w.f.listbox -fill both -expand 1 pack $w.f2.c -side top -fill both -expand 1 pack $w.f2.e -side bottom -fill x pack $w.f2.s -side left -fill x -expand 1 pack $w.f2.rplay -side right -fill x pack $w.f $w.f2 -side left -anchor n -fill both -expand 1 } } proc new {id w} { set id [namespace eval $id { namespace export {[a-z]*} namespace ensemble create -prefixes no namespace path [namespace parent] #dirtiest object system in The West! namespace ensemble configure [namespace current] -unknown [ list apply [list {ns args} { set args [lassign $args[set args {}] ns cmd] set ::errorInfo $ns list [namespace current] $cmd } [namespace parent]] [namespace current]] variable id [namespace current] proc my {} {namespace current} variable busy {} variable scale_delay 0 variable zoom 25 variable oldzoom $zoom variable afterzoom {} variable randomplay 0 namespace import [namespace parent]::o\ * set id }] $id o bRings $id o cGrad $id o checker $id o gRings $id o vstrip $id o xPos $id o {bPaint brown beige} checker $id o checker {slice 10} toPolars $id o checker {rotate 0.1} $id o vstrip {swirl 1.5} $id o checker {swirl 16} $id o {fplot {$y + exp($x)}} $id o checker radInvert $id o gRings {rippleRad 8 0.3} $id o xPos {swirl .75} $id o gChecker $id o {gPaint red} gRings $id o {bin2 {radReg 7} udisk} #contour plot (isoline-like) of the map ''f(x,y) = xy''. $id o {contour {$x*$y}} #Other cute variations by RS $id o {contour {($x+$y)*$y}} $id o {contour {sin($x)/cos($y)}} $id o {contour {exp($y)-exp($x)}} $id o {contour {exp($y)-cos($x)}} $id o {contour {exp($x)*tan($x*$y)}} $id o cGrad radInvert $id o cGrad {swirl 8} $id o {contour {sin($y)-tan($x)}} $id o {contour {exp($x)-tan($x*$y)}} toPolars ;# at zoom 20, a weird tropical fish... #contributed by DKF $id o gRings {rippleRad 8 0.3} {swirl 16} $id o gChecker {rippleRad 8 0.3} {swirl 16} $id o gChecker {rippleRad 6 0.2} {swirl 26} $id o {gPaint yellow} gChecker {rippleRad 6 0.2} {swirl 26} toPolars ;# Yellow Rose $id o cGrad {swirl 8} {slice 110} radInvert $id o cGrad {rippleRad 8 0.3} {swirl 8} radInvert {swirl 8} ;# Toothpaste! #and here are some stranger ones contributed by DKF $id o {gPaint yellow} gChecker fromPolars {rippleRad 6 0.2} {swirl 26} toPolars $id o {gPaint yellow} gChecker toPolars {rippleRad 6 0.2} {swirl 26} fromPolars #a few more $id o {bin2 checker bRings} {swirl 5} radInvert $id o cGrad {rippleRad 8 .3} {swirl 8} $id o vstrip {swirl 1.5} {rippleRad 8 .3} $id o {fplot {($x*$x-$y*$y)/10}} {swirl 15} {rippleRad 8 .3} $id o gChecker {rotate .1} {slice 10} radInvert ;# two kissing fish $id o cGrad fromPolars {swirl 16} ;# neon galaxy #And some pretty demos from DKF, word-smithed by PYK $id o invert {gPaint red} gRings $id o [list g2 [$id o gRings] [$id o gRings {rippleRad 8 0.3}]] $id o [list g+ [$id o {gPaint red} gRings] [$id o gRings {rippleRad 8 0.3}]] $id o [list g+ [ $id o {gPaint red} gChecker {swirl 16}] [ $id o gRings {rippleRad 8 0.3}]] $id o [list g+ [ $id o {gPaint red} gRings {rippleRad 8 0.3} {swirl 19}] [ $id o {gPaint green} gRings {rippleRad 8 0.3} {swirl 20}]] $id o [list g+ [ $id o {gPaint yellow} gRings {rippleRad 8 0.9} {swirl 28}] [ $id o {gPaint blue} gRings {rippleRad 6 1.5} {swirl 14}]] set ${id}::w $w $id gui set id } namespace export {[a-z]*} namespace ensemble create bind . <Escape> {exec wish $argv0 &; exit} ;# dev helper bind . ? {console show} ;# dev helper, Win/Mac only for {set i 0} {$i < 2} {incr i} { frame .myframe$i pack .myframe$i -expand 1 -fill both for {set j 0} {$j < 2} {incr j} { pack [frame .myframe$i.$j] -expand 1 -fill both -side left new [info cmdcount] .myframe$i.$j } }
JCW - If you have Critcl (and gcc), then you can use the following code to halve the execution time of cGrad (others could be "critified" too, of course):
if {[catch { package require critcl }]} { proc cGrad p { # color gradients - best watched at zoom=100 foreach {x y} $p break if {abs($x)>1.} {set x 1.} if {abs($y)>1.} {set y 1.} set r [expr {int((1.-abs($x))*255.)}] set g [expr {int((sqrt(2.)-hypot($x,$y))*180.)}] set b [expr {int((1.-abs($y))*255.)}] c2c $r $g $b } } else { proc cGrad p { return [eval [linsert $p 0 _cGrad]] } critcl::ccode { #include <math.h> } critcl::cproc _cGrad {double x double y} char* { int r, g, b; static char buf [10]; if (fabs(x) > 1) x = 1; if (fabs(y) > 1) y = 1; r = (1 - fabs(x)) * 255; g = (sqrt(2) - hypot(x, y)) * 180; b = (1 - fabs(y)) * 255; sprintf(buf, "#%02X%02x%02x", r, g, b); return buf; } }
Discussion edit
Arjen Markus: Added contour and colourClass to the repertoire:RS: Beautiful - and fast: 1..2 sec on 833MHz W2K box. Best viewed at zoom ~10. There are many more left for to discover...DKF: This is really cool indeed. Pretty. I've added some of my favourites. Note that many images with radInvert don't look very good.
DKF: Here's some fancier operators for working with gradients...

Changes edit
PYK 2012-12-09: removed update, scale change now triggers redrawPYK 2014-04-12: revision 80