### OpenACS and Tcl/Tk Conference 2025, July 10-11

- Andreas Kupries
- AKTIVE

- AK Tcl Image Vector Extension
- MIT/BSD Licensed
- Inspired by VIPS
- Mixes C and Tcl via Critcl

### AK Tcl Image Vector Extension

- Inspired by VIPS

- Library for the processing of large images

- Similarities

- Demand-driven: Lazy construction
- Horizontally Threaded Execution

- Differences

- double is the only pixel value type
- Wedded to Tcl, not GNOME (GObject)
- Code Generation, also docs, examples

### AK Tcl Image Vector Extension

- Historical notes

- Begun as experiment with code gen
- Operator specs first translated to

- implementations (C, Tcl)

- Then also documentation, examples

- C, Tcl, Critcl - Each used for their strengths

- C is fast
- Tcl is high-level
- Critcl mixes them easily

### AK Tcl Image Vector Extension

- I/O

- Read/write Channels, Files, Tcl Values
- Currently supported image formats:

- PPM, PGM
- AKTIVE (package's own format)

- PPM/PGM values are the connection to Tk

### AK Tcl Image Vector Extension

    operator op::math1::abs {
        section transform math unary

        note Applies the unary function `abs(I)`.

        input

        simplify for   src/type @self   returns src
        simplify for   constant abs

        state -setup {
        #define IN_GEOM aktive_image_get_geometry (srcs->v[0])
    	aktive_geometry_copy (domain, IN_GEOM);
        }

        pixels {
        #define FETCH aktive_region_fetch_area (srcs->v[0], request)
    	aktive_blit_unary0 (block, dst, fabs, FETCH);
        }
    }

    proc aktive::op::math1::abs {src} {
        ::aktive simplify do \
            src/type op::math1::abs \
            /src
        ::aktive simplify do \
            src/type image::from::value \
            /fold/constant/0 abs
        Iabs $src
    }

    critcl::cproc aktive::op::math1::Iabs {
      Tcl_Interp*  ip
      aktive_image src
    } aktive_image {
      /* src :: keep */
      /* no parameters */
      aktive_image _r = aktive_image_check (ip,
            aktive_op_math1_abs_new (ip, src));
      return _r;
    }

    extern aktive_image
    aktive_op_math1_abs_new (Tcl_Interp* ip, aktive_image src) {
      TRACE_FUNC("", 0);

      static aktive_image_type aktive_op_math1_abs_opspec = {
        .name         = "op::math1::abs"
      , .sz_param     = 0
      , .setup        = (aktive_image_setup)  aktive_op_math1_abs_setup
      , .region_fetch = (aktive_region_fetch) aktive_op_math1_abs_region_fetch
      };

      aktive_image_vector srcs = {
          .c = 1, .v = &src
      };

      aktive_image r = aktive_image_new (&aktive_op_math1_abs_opspec,
                                         NULL, &srcs);
      TRACE_RETURN ("(aktive_image) %p", r);
    }

    static int
    aktive_op_math1_abs_setup (
      aktive_image_info* info
    , Tcl_Obj**          meta
    ) {
      TRACE_FUNC("((aktive_image_info*) %p)", info);
      aktive_image_vector* srcs   = &info->srcs;
      aktive_geometry*     domain = &info->domain;
    #define                state  (info->state)
      // - - -- --- ----- -------- ------------- ----------------

      #define IN_GEOM aktive_image_get_geometry (srcs->v[0])
      aktive_geometry_copy (domain, IN_GEOM);

      // - - -- --- ----- -------- ------------- ----------------
      TRACE_GEOMETRY (domain);
    #undef state
      TRACE_RETURN ("(ok) %d", 1);
    }

    static void
    aktive_op_math1_abs_region_fetch (
      aktive_region_info* info    // Params, inputs, (image) state
    , aktive_rectangle*   request // Area to fetch
    , aktive_rectangle*   dst     // Destination in `block`
    , aktive_block*       block   // Pixel storage
    ) {
      [...]
      aktive_region_vector* srcs    = &info->srcs;
      aktive_geometry*      idomain = info->domain;
      [...]
      // - - -- --- ----- -------- ------------- ----------------

      #define FETCH aktive_region_fetch_area (srcs->v[0], request)
      aktive_blit_unary0 (block, dst, fabs, FETCH);

      // - - -- --- ----- -------- ------------- ----------------
      TRACE_RETURN_VOID;
    }

### AK Tcl Image Vector Extension

Section | Lines | Percent
--- | --- | ---
Runtime | 9617 | 9.42
DSL | 5100 | 5.00
Operators | 15414 | 15.10
Generated | 69504 | 68.08
Doc Source | 2455 | 2.40
Total | 102090 | 100.00

### AK Tcl Image Vector Extension

Demo

The images and graphs seen in the coming slides were all created by AKTIVE

Our task: Given an image containing a document or book page, extract the area of the document or page, and rectify it

A complication: For book pages the image may not only contain the page of interest, but also part of the opposite page

### AK Tcl Image Vector Extension

Book data; origin of the page image

    General
    Prop	title		Geometry 2
    Prop	author		Lambacher Schweizer
    Prop	pubdate		1970
    Prop	publisher	Ernst Klett Verlag Stuttgart

    Prop	language	de
    Prop	binding		hardcover
    Prop	mmwidth		162
    Prop	mmheight	232

    Prop	editshotorder	odd/even
    Prop	editsize	800
    Prop	exportmode	space
    Prop	exportsize	dpi best

### AK Tcl Image Vector Extension

#### Input 3456 x 4608

### AK Tcl Image Vector Extension

#### do-scale-down

    param pnm src

    lassign [aktive query domain $src] _ _ w h
    set w   [expr {$w / [factor]}]
    set h   [expr {$h / [factor]}]

    result wtxt geo [list $w $h]
    result ppm  dst [aktive op resize $src width $w height $h]

#### aktive op resize

    ::aktive parameter validate         interpolate 0 width 0 height 0
    ::aktive parameter collect required width height
    set interpolate bilinear
    ::aktive parameter collect optional interpolate

    lassign [aktive query domain $src] _ _ w h

    set xscale  [expr {double($width)  / $w}]
    set yscale  [expr {double($height) / $h}]
    set trafo   [aktive transform scale x $xscale y $yscale]
    set resized [aktive op transform by $trafo $src interpolate $interpolate]

    lassign [aktive query geometry $resized] x y rw rh
    if {($rw != $width) || ($h != $height)} {
        set resized [aktive op view $resized port [list $x $y $width $height]]
    }

    return $resized

### AK Tcl Image Vector Extension

#### Scaled 864 x 1152

### AK Tcl Image Vector Extension

#### do-convert-to-grey

    param  pnm src

    result pgm dst [aktive op color sRGB to gray $src]

### AK Tcl Image Vector Extension

#### Grey

### AK Tcl Image Vector Extension

#### do-binarize

    param  pnm src

    set bw [aktive image mask per phansalkar $src radius 7]

    result pgm dst [aktive op math1 invert $bw]

#### aktive image threshold phansalkar

    ::aktive parameter validate         k 0 R 0 p 0 q 0 radius 0
    ::aktive parameter collect required radius
    set k 0.25
    set R 0.5
    set p 3
    set q 10
    ::aktive parameter collect optional k R p q

    set e    [aktive op embed mirror $src left $radius right $radius top $radius bottom $radius]
    set mean [aktive op tile mean   $e radius $radius]
    set std  [aktive op tile stddev $e radius $radius]

    return [aktive op math mul  $mean  [aktive op math add  [aktive op math1 scale  [aktive op math1 exp  [aktive op math1 scale $mean  factor [expr {- $q}]]]  factor $p]  [aktive op math1 linear  [aktive op math1 linear $std  scale [expr {1.0/$R}] gain -1]  scale $k gain 1]]]

Phansalkar is an extension of Sauvola.

Which is a modification of Niblack.

See the Craft Of Coding Blog Post

### AK Tcl Image Vector Extension

#### Binarized

### AK Tcl Image Vector Extension

#### do-get-borders

    param  pnm src

    result pgm dst [aktive op morph gradient internal $src]

#### aktive op morph gradient internal

    ::aktive parameter validate         radius 0 embed 0
    set radius 1
    set embed black
    ::aktive parameter collect optional radius embed

    set e   [aktive op morph erode $src radius $radius embed $embed]
    set src [aktive op math sub $src $e]

- Issues?

- Edge loss in going to grey & binarization?
- Example: Coffee table books

- Color content up to the page border

- Color edge algorithms ?

### AK Tcl Image Vector Extension

#### Borders

### AK Tcl Image Vector Extension

#### do-select

    param pnm src

    set ccs     [aktive op connected-components get $src]
    set ccs     [region-bbox-max $ccs]
    set ranges  [lsort -dict [lmap part [dict get $ccs 1 parts] {
        linsert $part end 1
    }]]
    set domain  [aktive query domain $src]
    result pgm dst [aktive image from sparse ranges geometry $domain ranges {*}$ranges]

### AK Tcl Image Vector Extension

#### Primary

### AK Tcl Image Vector Extension

#### do-show-border

    param pnm src
    param pnm border

    result ppm dst [overlay $src += $border yellow]

#### overlay

    lassign [aktive query domain $bg] _ _ w h

    set mask [aktive op morph dilate $mask radius 2]

    return [aktive op if-then-else $mask [{*}$color $w $h] $bg]

#### yellow

    color $w $h yellow

#### color

    aktive image from color width $w height $h color $name

#### aktive image from color

    ::aktive parameter validate         x 0 y 0 width 0 height 0 color 0
    ::aktive parameter collect required width height color
    set x 0
    set y 0
    ::aktive parameter collect optional x y

    set values [aktive color css $color]
    band x $x y $y width $width height $height values {*}$values

### AK Tcl Image Vector Extension

#### Scaled + Primary

### AK Tcl Image Vector Extension

#### do-left-profile

    param pnm  src
    param rtxt geo

    set profile [aktive op row profile $src]
    set profile [aktive query values $profile]
    set poly    [v-path-of $profile]

    result        wtxt dstdata $poly
    placeholder        dstshow
    debugs {result pgm dstshow [draw-poly {*}$geo $poly]}

#### draw-poly

    fat [aktive image sdf polyline width $w height $h points {*}$poly]

See Inigo Quilez's page about 2D distance functions

### AK Tcl Image Vector Extension

#### Left Profile

### AK Tcl Image Vector Extension

#### do-find-threshold

    param rtxt profile
    param rtxt geo

    set threshold [expr {[lindex $geo 0]/2}]

    if 0 {
        set xs        [as-image [xs $profile]]
        set xs        [aktive op math1 fit min-max $xs]
        set stretch   [aktive meta get $xs stretch]
        set scale     [dict get $stretch scale]
        set gain      [dict get $stretch gain]
        set threshold [aktive image threshold global otsu $xs]
        set threshold [expr {($threshold - $gain)/double($scale)}]
    }

    result        wtxt dstdata $threshold
    placeholder        dstshow
    debugs {result pgm dstshow [draw-vertical {*}$geo $threshold]}

### AK Tcl Image Vector Extension

#### Fixed Threshold

### AK Tcl Image Vector Extension

#### do-apply-threshold

    param rtxt profile
    param rtxt geo
    param rtxt threshold

    set poly [{*}$selector $threshold $profile]

    result        wtxt dstdata $poly
    placeholder        dstshow
    debugs {result pgm dstshow [draw-poly {*}$geo $poly]}

### AK Tcl Image Vector Extension

#### Profile Inlier

### AK Tcl Image Vector Extension

#### do-fit-vertical-line

    param rtxt profile
    param rtxt geo

    lassign $geo w h
    lassign [linreg-v $profile] slope intercept

    set a   [lerp-pv $slope $intercept 0]
    set b   [lerp-pv $slope $intercept [expr {$h-1}]]
    set hug [hugs-image-border $edge $w $a $b]

    result        wtxt dstdata [list $slope $intercept $hug]
    placeholder        dstshow
    debugs {result pgm dstshow [draw-line $w $h $a $b]}

### AK Tcl Image Vector Extension

#### Left Border

### AK Tcl Image Vector Extension

#### Scaled + Primary + Left Border

### AK Tcl Image Vector Extension

#### do-top-profile

    param pnm  src
    param rtxt geo

    set profile [aktive op column profile $src]
    set profile [aktive query values $profile]
    set poly    [h-path-of $profile]

    result        wtxt dstdata $poly
    placeholder        dstshow
    debugs {result pgm dstshow [draw-poly {*}$geo $poly]}

### AK Tcl Image Vector Extension

#### Top Profile

### AK Tcl Image Vector Extension

#### do-cut-horiz

    param rtxt geo
    param rtxt top
    param rtxt left
    param rtxt right

    lassign $left  lslope lintercept lhug
    lassign $right rslope rintercept rhug
    lassign [$cliffs $lhug $rhug $lslope $rslope] lcliff rcliff

    set top  [limit-left  $lcliff $lslope $lintercept $top]
    set top  [limit-right $rcliff $rslope $rintercept $top]

    result        wtxt dstdata $top
    placeholder        dstshow
    debugs {result pgm dstshow [draw-poly {*}$geo $top]}

#### top-cliff

    set lcliff [expr {!$lhug && ($lslope < 0)}]
    set rcliff [expr {!$rhug && ($rslope > 0)}]
    list $lcliff $rcliff

### AK Tcl Image Vector Extension

#### Top Profile L/R Limited

### AK Tcl Image Vector Extension

#### Top Profile + Base Line

### AK Tcl Image Vector Extension

#### Top Profile + Base + Sheared

### AK Tcl Image Vector Extension

#### do-refine-horiz

    param rtxt geo
    param rtxt profile
    param rtxt left
    param rtxt right

    lassign $left  lslope lintercept lhug
    lassign $right rslope rintercept rhug

    if {[llength $profile] > 10} {
        set profile [dehug $lhug $rhug $isbetter $profile]
    }

    result        wtxt dstdata $profile
    placeholder        dstshow
    debugs {result pgm dstshow [draw-poly {*}$geo $profile]}

### AK Tcl Image Vector Extension

#### Top Profile Refined

### AK Tcl Image Vector Extension

#### Refined Left/Right Borders

### AK Tcl Image Vector Extension

#### Left/Right/Top/Bottom Borders

### AK Tcl Image Vector Extension

#### do-collect-tangents

    param rtxt geo
    param rtxt profile

    if {[llength $profile] > 100 } {
        set hullspec [join [list 2 [llength $profile] {*}$profile] \n]
        set result   [exec qconvex Fx << $hullspec]
        set indices  [lassign [split [string trim $result] \n] n]
        set profile  [lmap i [lreverse $indices] { lindex $profile $i }]
    }

    set pairs    [pairs $profile]
    set tangents [filter $pairs $where $profile]
    set tangents [unique-tangents $tangents]

    result    wtxt dstdata $tangents
    placeholder    dstshow
    debugs {
        lassign $geo w h
        result pgm dstshow [draw-lines $w $h [t-lines $w $tangents]]
    }

### AK Tcl Image Vector Extension

#### Top Profile Tangents

### AK Tcl Image Vector Extension

#### do-choose-tangent

    param rtxt geo
    param rtxt profile
    param rtxt tangents

    if {![llength $tangents]} return

    set tareas [map $tangents line-area-delta $profile]
    set best   [fold {{} {} {} {} Inf} $tareas min-area]
    lassign $geo w h
    lassign [h-expand $w $best] a b

    result        wtxt dstdata [list $a $b]
    placeholder        dstshow
    debugs {result pgm dstshow [draw-line $w $h $a $b]}

### AK Tcl Image Vector Extension

#### Border + Tangents + Best

### AK Tcl Image Vector Extension

#### Left/Right Top/Bottom Box

### AK Tcl Image Vector Extension

#### do-fit-quadrilateral

    param rtxt geo
    param rtxt left
    param rtxt right
    param rtxt top
    param rtxt bottom

    if {[catch {
        set i [intersect $a $d $e $f]
        set j [intersect $b $c $e $f]
        set k [intersect $b $c $g $h]
        set l [intersect $a $d $g $h]

    set poly      [list $i $j $k $l]
    set polyclose $poly ; lappend polyclose $i

    result        wtxt dstdata $poly
    placeholder        dstshow
    debugs {result pgm dstshow [draw-poly {*}$geo $polyclose]}

### AK Tcl Image Vector Extension

#### Enclosing Quadrilateral

### AK Tcl Image Vector Extension

#### Border + Box

### AK Tcl Image Vector Extension

#### do-rectify

    param pnm  src
    param rtxt quad
    param rtxt top	; set top    [sup $top]
    param rtxt bottom	; set bottom [sup $bottom]

    lassign [aktive query domain $src] _ _ w h
    lassign $quad i j k l

    set quad      [aktive transform quad unit2 a $i b $j c $k d $l]
    set iquad     [aktive transform invert $quad]
    set scale     [aktive transform scale x $w y $h]
    set transform [aktive transform compose $scale $iquad]
    set rect      [aktive op transform by  $transform $src]
    set top       [aktive transform points $transform series {*}$top]
    set bottom    [aktive transform points $transform series {*}$bottom]

    result         ppm  dst      [aktive op view $rect port [list 0 0 $w $h]]
    result         wtxt tresidue $top
    result         wtxt bresidue $bottom
    debugs {result pgm  tshow [draw-poly $w $h $top]}
    debugs {result pgm  bshow [draw-poly $w $h $bottom]}

AKTIVE documentation; quadrilateral warping

### AK Tcl Image Vector Extension

#### Rectified Page 3456 x 4608

### AK Tcl Image Vector Extension

#### Rectified + Residuals

### AK Tcl Image Vector Extension

- Future Work

- Future Work

- Generally

- Future Work

- Generally

- Benchmarking
- FFT
- Hough Transform
- Hit/Miss Transform
- More file formats
- Matrix ops
- Image Smoothing via L0 Gradient Minimization
- ...

- Future Work

- Generally
- Demo Task

- Future Work

- Generally
- Demo Task

- Color edges for better borders?
- Remove residual curvature
- Blank page detection
- Text/Image Segmentation
- OCR

- Future Work

- Generally
- Demo Task

- Color edges for better borders?
- Remove residual curvature

- Forward transform profiles
- Profile approximations (spline, cubic, ...)
- Unwarp along the approximation

- Blank page detection
- Text/Image Segmentation
- OCR

### AK Tcl Image Vector Extension

- Questions ? ...

### AK Tcl Image Vector Extension

Warp Core
op warp bicubic
op warp bilinear
op warp lanczos
op warp near-neighbour

Warp Origins
warp matrix
warp 2cartesian
warp 2polar
warp noise gauss
warp noise uniform
warp swirl
warp wobble

Warp Origins | Warpers
--- | ---
warp matrix | op transform by
warp 2cartesian | effect 2cartesian
warp 2polar | effect 2polar
warp noise gauss | effect jitter gauss
warp noise uniform | effect jitter uniform
warp swirl | effect swirl
warp wobble | effect wobble

transform ...
... projective | ... identity | ... reflect x
... affine | ... translate | ... reflect y
| ... scale | ... reflect line
... compose | ... rotate | ... quad 2quad
... invert | ... shear | ... quad unit2
... point | ... points | ... domain