Photo reflection

BAS 2008-01-03: For a project I am working on, it involved multimedia, and specifically photos. Apple has this photo reflection thing that I thought might be fun to emulate in Tcl/Tk. So, here it is. It's not going to win any speed races, but it was fun to do. I'd really like to get this done in C to make it fast. Here is the code, with a GUI wrapped around it to make it a demo:

Oh, I use lassign here, so you will need Tcl8.5, or change the lassign.

I got a lot of tips from the wiki, most notably from here: Merging images with transparency

http://www.bschwarz.com/reflect_kids.png


    package require Img

    ##
    ##  Does a gradient blend of the background color
    ##  and the image data. alpha1 and alpha2 are
    ##  the alpha range values used for the gradient blend
    ##
    proc alphablend {data alpha1 alpha2} {
    
        set row 0
        set data2 [list]
        set h [llength $data]
        set step [expr {($alpha2 - $alpha1)/$h}]
    
        lassign  [winfo rgb .c [.c cget -background]] bgred bggreen bgblue
    
        set alpha $alpha1
        foreach ROW $data {
    
            set col 0
            set rowdata [list]
            foreach COL $ROW {
                scan $COL "#%02x%02x%02x" src(red) src(green) src(blue)
                foreach color {red green blue} {
                    set $color [expr {round(($alpha * $src($color)) + (((1-$alpha) * [set bg$color])/256))}]
    
                    if {[set $color] > 255} {set $color 255}
                    if {[set $color] < 0} {set $color 0}
                }
                lappend rowdata [format #%02x%02x%02x $red $green $blue]
            }
    
            lappend data2 $rowdata
            set alpha [expr {$alpha + $step}]
        }
    
        return $data2
    }
    
    ##
    ##  Takes a source image, and reflects it
    ##
    proc reflect {srcimg} {
    
        set w [image width $srcimg]
        set h [image height $srcimg]
    
        set ref_img [image create photo]
        set ref_h [image height $ref_img]
    
        set y1 [expr {(2*$h)/3}]
    
        ##
        ##  We flip the image upside down
        ##  and also just grab the bottom 1/3 of it
        ##
        $ref_img copy $srcimg \
            -subsample 1 -1 \
            -from 0 $y1 $w $h
    
        return $ref_img
    }
    
    
    proc openColor {} {
    
        set color [tk_chooseColor -initialcolor black]
    
        if {$color eq ""} return
    
        .c configure -background $color
    
        loadimage
    
        return
    }
    
    proc openFile {} {
    
        variable file
    
        set file [tk_getOpenFile]
    
        if {$file eq ""} return
    
        loadimage
    
        return
    }
    
    proc loadimage {} {
    
        variable img
        variable pos
        variable file
    
        catch {image delete $img(main) $img(reflect)}
        set img(main) [image create photo -file $file]
    
        .c create image $pos(X) $pos(Y) \
            -image $img(main) \
            -anchor nw
    
        set h [image height $img(main)]
        set w [image width $img(main)]
    
        .c configure -height [expr {2*$pos(Y) + (4*$h)/3}] -width [expr {2*$pos(X) + $w}]
    
        set img(reflect) [reflect $img(main)]
        set ndata [alphablend [$img(reflect) data] .5 0]
        $img(reflect) blank
        $img(reflect) put $ndata
    
        .c create image $pos(X) [expr {$pos(Y) + [image height $img(main)]}] \
            -image $img(reflect) \
            -anchor nw
    
        return
    }
    
    proc gui {} {
    
        variable bgcolor
    
        menu .menu -tearoff off
    
        . configure -menu .menu
    
        .menu add cascade \
            -label "File" \
            -menu .menu.file
    
        menu .menu.file -tearoff off
    
        .menu.file add command \
            -label "Open" \
            -command openFile
    
        .menu.file add command \
            -label "Exit" \
            -command exit
    
        .menu add cascade \
            -label "Config" \
            -menu .menu.cfg
    
        menu .menu.cfg -tearoff off
    
        .menu.cfg add command \
            -label "Color" \
            -command openColor
    
        canvas .c \
            -background $bgcolor \
            -width 450 \
            -height 450
    
        pack .c \
            -fill both \
            -expand 1
    }
    
    ##
    ##  Some defaults
    ##
    set bgcolor black
    set pos(X) 50
    set pos(Y) 50
    
    set file ""
    
    gui