Functional imaging

Functional imaging is about Functional Image Synthesis

Description

Richard Suchenwirth 2002-06-15: Cameron Laird pointed me to Functional Image Synthesis (Pan), by Conal Elliott, 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: The current (2nd) edition of SICP has a chapter on functional imaging too, using painters and transformers. It doesn't have color transformers. Only the first edition is available on the web, and 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

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 (PYK 2014-04-14: Basic idea of RS is still here, but object system has been added, and changes to the interface made):

Code

#! /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
    lassign $p x y
    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
    lassign $p x y
    b2c [expr {int(floor($x)+floor($y)) % 2 == 0}]
}

proc gChecker p {
    # greylevels correspond to fractional part of x,y
    lassign $p x y
    g2c [expr {(fmod(abs($x),1.)*fmod(abs($y),1.))}]
}

proc bRings p {
    # binary concentric rings
    lassign $p x y
    b2c [expr {round(hypot($x,$y)) % 2 == 0}]
}

proc gRings p {
    # grayscale concentric rings
    lassign $p x y
    g2c [expr {(1 + cos(3.14159265359 * hypot($x,$y))) / 2.}]
}

proc radReg {n p} {
    # n wedge slices starting at (0,0)
    lassign [toPolars $p] r a
    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
    lassign $p x y
    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} {
    lassign $p x y
    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 {
    lassign $p r a
    list [expr {$r*cos($a)}] [expr {$r*sin($a)}]
}

proc toPolars p {
    lassign $p x y
    # 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 {
    lassign [toPolars $p] r a
    fromPolars [list [expr {$r ? 1/$r: 9999999}] $a]
}

proc rippleRad {n s p} {
    lassign [toPolars $p] r a
    fromPolars [list [expr {$r*(1.+$s*sin($n*$a))}] $a]
}

proc slice {n p} {
    lassign $p r a
    list $r [expr {$a*$n/3.14159265359}]
}

proc rotate {angle p} {
    lassign $p x y
    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} {
    lassign $p x y
    set angle [expr {hypot($x,$y)*6.283185306/$radius}]
    rotate $angle $p
}

#------------------------------  Contour 
#contributed by Arjen Markus

proc contour {expr p} {
    lassign $p x y
    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} {
    lassign [rgb [$id $f1 $p]] r1 g1 b1
    lassign [rgb [$id $f2 $p]] r2 g2 b2
    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} {
    lassign [rgb [$id $f1 $p]] r1 g1 b1
    lassign [rgb [$id $f2 $p]] r2 g2 b2
    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} {
    lassign [rgb [$id $f1 $p]] r1 g1 b1
    lassign [rgb [$id $f2 $p]] r2 g2 b2
    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} {
    lassign [rgb $c] r1 g1 b1
    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
        lassign $p x y
        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

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.

WikiDbImage funimj3.jpg

A few more:

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

(with a larger than usual image, I'll admit)

Changes

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

PYK 2014-04-12: revision 80 . Various changes to the user interface. Added object system to turn it into a widget that can be instantiated multiple times. Consolidated contributed code examples into one script.

Category Concept

Category Graphics

Arts and Crafts of Tcl-Tk Programming

Category Functional Programming