Version 14 of Functional imaging

Richard Suchenwirth 2002-06-15 - Cameron Laird pointed me to Conal Elliott's Pan project ("Functional Image Synthesis", [L1 ]), where images (of arbitrary size and resolution) are produced and manipulated in an elegant functional way. 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

 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

 "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 "[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
 }
 if 0 {Basic imaging functions ("drawers") have the common
 functionality ''point -> color'', where point is a pair {x y} (or,
 after applying a polar transform, {r a}...) and ''color'' is a Tk color
 name, like "green" or #010203:}
 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
 }

if 0 {Beyond the examples in Conal Elliott's paper, I found out that function imaging can also be abused for a (slow and imprecise) function plotter, which displays the graph for y = f(x) if you call it with $y + f($x) as first argument:}

 proc fplot {expr p} {
    foreach {x y} $p break
    b2c [expr abs($expr)<=0.04] ;# double eval required here!
 }

if 0 {Here is a combinator for two binary images that shows in different colors for which point both or either are "true" - nice but slow:}

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

if 0 {This painter colors a grayscale image in hues of the given color. It normalizes the given color through dividing by the corresponding values for "white", but appears pretty slow too:}

 proc gPaint {color pixel} {
    set abspixel [lindex [winfo rgb . $pixel] 0]
    set rgb [winfo rgb . $color]
    set rgbw [winfo 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
 }
 #------------------------------ 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
    list [expr {hypot($x,$y)}] [expr {atan2($y,$x)}]
 }
 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
 }

if 0 {Now comes the demo program. It shows the predefined basic image operators, and some combinations, on a button bar. Click on one, have some patience, and the corresponding image will be displayed on the canvas to the right. You can also experiment with image operators in the entry widget at bottom - hit <Return> to try. The text of sample buttons is also copied to the entry widget, so you can play with the parameters, or rewrite it as you wish. Note that a well-formed funimj composition consists of:

the composition operator "o"
zero or more "painters" (color -> color)
one "drawer" (point -> color)
zero or more "transformers" (point -> point)

}

 proc fim'show {c f} {
    $c delete all
    set ::try $f ;# prepare for editing
    set t0 [clock seconds]
    . config -cursor watch
    update ;# to make the cursor visible
    $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
    if [catch {fim'show $c [eval $var]}] {
        $c create text 10 10 -anchor nw -text $::errorInfo
    }
 }
 # Composed functions need only be mentioned once,
 # which creates them, and they can later be picked up
 # by [info procs]. The o looks nicely bullet-ish here..
 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%0