source pkgsNeeded.tcl

ui_init "t_warp.tcl"
SetFileTypes

PH "Image warping with Tcl functions"

proc warpfunct { x y } {
    global xdistort ydistort
    set nx [expr $x - $xdistort*$y*$y]
    set ny [expr $y - $ydistort*$x*$x]
    return [list $nx $ny]
}

proc warpderiv { x y } {
    set ux 1
    set uy 1
    set vx 1
    set vy 1
    return [list $ux $uy $vx $vy]
}

set srcimg [poImage NewImageFromFile "testIn/keksi$fInfo(suf)"]
$srcimg GetImageInfo w h a g
set dstimg [poImage NewImage $w $h $a $g]
set msg "Original image"
ui_addimg $srcimg $msg

set fname "testOut/warpFill$fInfo(suf)"
set istep 10
set xdistort 0.2
set ydistort 0.0
set msg   "$fname: Call Tcl every $istep pixel (IMGFILL)"
P $msg
poImgUtil SetDrawColorRGB 0.5 0.5 0.0
$dstimg WarpFunct $srcimg warpfunct warpderiv $istep $IMGFILL
$dstimg WriteSimple $fname $fInfo(fmt) $fInfo(vsn)
ui_addimg $dstimg $msg

set fname "testOut/warpWrap$fInfo(suf)"
set istep 5
set xdistort 0.4
set ydistort 0.0
set msg   "$fname: Call Tcl every $istep pixel (IMGWRAP)"
P $msg
$dstimg WarpFunct $srcimg warpfunct warpderiv $istep $IMGWRAP
$dstimg WriteSimple $fname $fInfo(fmt) $fInfo(vsn)
ui_addimg $dstimg $msg

set fname "testOut/warpClip$fInfo(suf)"
set istep 2
set xdistort 0.6
set ydistort 0.0
set msg   "$fname: Call Tcl every $istep pixel (IMGCLIP)"
P $msg
$dstimg WarpFunct $srcimg warpfunct warpderiv $istep $IMGCLIP
$dstimg WriteSimple $fname $fInfo(fmt) $fInfo(vsn)
ui_addimg $dstimg $msg

for { set i 1 } { $i <= 20 } { incr i } {
    set j [expr $i + 3]
    set fname "testOut/warp.[format "%03d" $i]$fInfo(suf)"
    set istep 10
    set xdistort [expr ($i -1) / 20.0]
    set ydistort [expr ($i -1) / 60.0]
    set msg   "$fname: Warpanimation (Image $i)"
    P $msg
    $dstimg WarpFunct $srcimg warpfunct warpderiv $istep $IMGCLIP
    $dstimg WriteSimple $fname $fInfo(fmt) $fInfo(vsn)
    ui_addimg $dstimg $msg
}

PS
P "End of test"

ui_show

if { [lindex $argv 0] eq "auto" } {
    ui_exit
    exit 0
}
