** Summary **

Functional Image Synthesis

** See Also **

   [Not functional imaging - scripting imaging]:   

** Description **

[Richard Suchenwirth] 2002-06-15 - [Cameron Laird] pointed me to Conal
Elliott's ''Pan'' project
([http://research.microsoft.com/~conal/papers/bridges2001/%|%Functional Image
Synthesis%|%]), where images (of arbitrary size and resolution) are produced
and manipulated in an elegant functional way.

[WikiDbImage funimj.gif] 
[WikiDbImage funimj.jpg] 
[WikiDbImage funimg2.jpg]


[AK] - Note that the current (2nd) edition of [SICP] has a chapter on
functional imaging too, using painters and transformers. It doesn't have color
transformers. The edition available on the web (1st) unfortunately does not
contain this chapter.

Functions written in Haskell (see [Playing Haskell]) are applied, mostly in
[functional composition], to pixels to return their color value. FAQ: "Can we
have that in Tcl too?"
 
As the ''funimj'' demo below shows, in principle yes; but it takes some
patience (or a very fast CPU) - for a 200x200 image the function is called
40000 times, which takes 9.48 seconds on my P200 box. Still, the output often
is worth waiting for... and the time used to write this code was negligible, as
the Haskell original could with few modifications be represented in Tcl.
[Functional composition] had to be rewritten to Tcl's Polish notation -
Haskell's

======none
foo 1 o bar 2 o grill
======
(where "o" is the composition operator) would in Tcl look like
======
o {foo 1} {bar 2} grill
======

As 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

======none
"o {foo 1} {bar 2} grill"
======

which is pretty self-documenting ;-) I implemented "o" like this:

======
proc o args {
    # combine the functions in args, return the created name
    set name [info level 0]
    set body [concat [join $args { [}] \$x]
    append body [string repeat \] [expr {[llength $args]-1}]]
    proc $name x $body
    set name
}

# Now for the rendering framework:
proc fim {f {zoom 100} {width 200} {height -}} {
    # produce a photo image by applying function f to pixels
    if {$height=="-"} {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}]
    }
    for {set i 0} {$i<$height} {incr i} {
        set row {}
        set y [expr {($i-$height/2.)/$zoom}]
        foreach x $xs {
            lappend row [$f [list $x $y]]
        }
        lappend data $row
    }
    $im put $data
    set im
}

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] == "#000" && [eval $f2] == "#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 == "#000" ?
            $b == "#000" ? "green"
            : "yellow"
        : $b == "#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=="#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
}

proc fim'show {c f} {
    variable busy {}
    set t0 [clock seconds]
    set ::oldzoom $::zoom
    $c create image 0 0 -anchor nw -image [fim $f $::zoom]
    wm title . "$f: [expr [clock seconds]-$t0] seconds"
    . config -cursor {}
}

proc fim'try {c varName} {
    upvar #0 $varName var
    $c delete all
    . config -cursor watch
    set ::command [list fim'show $c [eval $var]]
    after 0 [list after idle {
        if {[catch $::command]} {
            $c delete all
            $c create text 10 10 -anchor nw -text $::errorInfo
        }
    }]
}

o bRings
o cGrad
o checker
o gRings
o vstrip
o xPos
o {bPaint brown beige} checker
o checker {slice 10} toPolars
o checker {rotate 0.1}
o vstrip {swirl 1.5}
o checker {swirl 16}
o {fplot {$y + exp($x)}}
o checker radInvert
o gRings {rippleRad 8 0.3}
o xPos {swirl .75}
o gChecker
o {gPaint red} gRings
o {bin2 {radReg 7} udisk}

package require Tk
#----------------------------------------------- testing

proc behave {behaviour args} {
    variable busy
    if {$busy ne {}} {
        return
    }
    set busy [after idle [list [namespace current]::$behaviour {*}$args]]
}

proc rezoom args {
    after cancel $::afterzoom
    set ::afterzoom [after $::scale_delay {
        if {$zoom != $oldzoom} {
            if {$::try ne {}} {
                behave fim'try $c ::try
            }
        }
    }]
}

variable busy {}
variable scale_delay 0 
set ::zoom 25
set ::oldzoom $::zoom
set ::afterzoom {}

frame .f2
set c [canvas .f2.c]
set e [entry .f2.e -bg white -textvar try]
bind $e <Return> [list behave fim'try $c ::try]
scale .f2.s -from 1 -to 100 -variable zoom -ori hori -width 6
trace add variable ::zoom write rezoom
#--------------------------------- button bar:
frame .f
set n 0
foreach imf [lsort [info procs "o *"]] {
    button .f.b[incr n] -text $imf -anchor w -pady 0 \
        -command [list set ::try $imf]
}
trace add variable ::try write {
    behave fim'try $c ::try
    # this backslash eats "arguments" appended by [trace] \
}
eval pack [winfo children .f] -side top -fill x -ipady 0
eval pack [winfo children .f2] -side top -fill x
pack .f .f2 -side left -anchor n
bind . <Escape> {exec wish $argv0 &; exit} ;# dev helper
bind . ? {console show} ;# dev helper, Win/Mac only
======

----
[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;
    }
}
======

----
[Arjen Markus] A little extension to the repertoire:

======
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
}
======

And insert into the bullet list:

======
o {contour {$x*$y}}
======


This will show you the contour plot (isoline-like) of the map ''f(x,y) = xy''.

[RS] Beautiful - and fast: 1..2 sec on 833MHz W2K box. Best viewed at zoom ~10.
Other cute variations:

======
o {contour {($x+$y)*$y}}
o {contour {sin($x)/cos($y)}}
o {contour {exp($y)-exp($x)}}
o {contour {exp($y)-cos($x)}}
o {contour {exp($x)*tan($x*$y)}}
o cGrad radInvert
o cGrad {swirl 8}
o {contour {sin($y)-tan($x)}}
o {contour {exp($x)-tan($x*$y)}} toPolars ;# at zoom 20, a weird tropical fish...
======

...and many more left for you to experiment...
----
[DKF]: This is really cool indeed.  Pretty.  Here are some of my favourites:

======
o gRings {rippleRad 8 0.3} {swirl 16}
o gChecker {rippleRad 8 0.3} {swirl 16}
o gChecker {rippleRad 6 0.2} {swirl 26}
o {gPaint yellow} gChecker {rippleRad 6 0.2} {swirl 26} toPolars  ;# Yellow Rose
o cGrad {swirl 8} {slice 110} radInvert
o cGrad {rippleRad 8 0.3} {swirl 8} radInvert {swirl 8}           ;# Toothpaste!
======

And here are some stranger ones:

======
o {gPaint yellow} gChecker fromPolars {rippleRad 6 0.2} {swirl 26} toPolars
o {gPaint yellow} gChecker toPolars {rippleRad 6 0.2} {swirl 26} fromPolars
======

Note that many images with radInvert don't look very good.


[WikiDbImage funimj3.jpg]

A few more:

======
o {bin2 checker bRings} {swirl 5} radInvert
o cGrad {rippleRad 8 .3} {swirl 8}
o vstrip {swirl 1.5} {rippleRad 8 .3}
o {fplot {($x*$x-$y*$y)/10}} {swirl 15} {rippleRad 8 .3}

o gChecker {rotate .1} {slice 10} radInvert ;# two kissing fish
o cGrad fromPolars {swirl 16} ;# neon galaxy
======

----
[DKF]: Here's some fancier operators for working with gradients...

======
proc g2 {f1 f2 p} {
    foreach {r1 g1 b1} [rgb [eval $f1 [list $p]]] {break}
    foreach {r2 g2 b2} [rgb [eval $f2 [list $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
}
proc g+ {f1 f2 p} {
    foreach {r1 g1 b1} [rgb [eval $f1 [list $p]]] {break}
    foreach {r2 g2 b2} [rgb [eval $f2 [list $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 g- {f1 f2 p} {
    foreach {r1 g1 b1} [rgb [eval $f1 [list $p]]] {break}
    foreach {r2 g2 b2} [rgb [eval $f2 [list $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
}
======

And some pretty demos...

======
o invert {gPaint red} gRings
o {g2 {{o gRings}} {{o gRings {rippleRad 8 0.3}}}}
o {g+ {{o {gPaint red} gRings}} {{o gRings {rippleRad 8 0.3}}}}
o {g+ {[o {gPaint red} gChecker {swirl 16}]} {{o gRings {rippleRad 8 0.3}}}}
o {g+ {[o {gPaint red} gRings {rippleRad 8 0.3} {swirl 19}]} {[o {gPaint green} gRings {rippleRad 8 0.3} {swirl 20}]}}
o {g+ {[o {gPaint yellow} gRings {rippleRad 8 0.9} {swirl 28}]} {[o {gPaint blue} gRings {rippleRad 6 1.5} {swirl 14}]}}
======

[http://www.man.ac.uk/~zzcgudf/tcl/bitsandpieces/swirls.png]
''(with a larger than usual image, I'll admit)''

** Changes **

[PYK] 2012-12-09: removed [update], scale change now triggers redraw 

<<categories>> Concept | Graphics | Arts and crafts of Tcl-Tk programming | Functional Programming