[Richard Suchenwirth] 2007-10-03 - Playing with the [Critcl] emulation of [Odyce], I wanted another useful example and came up with this: a command to compare whether two [photo] [image]s are equal or not:

 critcl::tk 1
 critcl::ccode {#include <string.h>}
 critcl::cproc img_eq {Tcl_Interp* interp char* im1 char* im2} int {
    Tk_PhotoHandle h1, h2;
    struct Tk_PhotoImageBlock b1, b2;
    int row, off1, off2;
    int rowsize;
    h1 = Tk_FindPhoto(interp,im1);
    if (h1 == NULL) return -1;
    h2 = Tk_FindPhoto(interp,im2);
    if (h2 == NULL) return -1;
    Tk_PhotoGetImage(h1,&b1);
    Tk_PhotoGetImage(h2,&b2);
    if (b1.height != b2.height) return 0;
    if (b1.width != b2.width) return 0;
    rowsize = b1.width * b1.pixelSize;
    for(row = 0; row < b1.height; row++) {
        off1 = b1.pitch * row;
        off2 = b2.pitch * row;
        if (0 != memcmp(b1.pixelPtr+off1, b2.pixelPtr+off2, rowsize))
            return 0;
    }
    return 1;
 }
# This shall be compared with the pure-Tcl solution from [Binary image compression challenge]:
 proc photo'eq {im1 im2} {
    #-- returns 1 if both images are exactly equal, else 0
    set h [image height $im1]
    if {[image height $im2] != $h} {return 0}
    set w [image width $im1]
    if {[image width $im2] != $w} {return 0}
    for {set y 0} {$y<$h} {incr y} {
        for {set x 0} {$x<$w} {incr x} {
            if {[$im1 get $x $y] ne [$im2 get $x $y]} {return 0}
        }
    }
    return 1
 }
#-- while another competitor in pure-Tcl is very simple:

 proc img'eq2 {im1 im2} {expr {[$im1 data] eq [$im2 data]}}

#-- Testing with the famous [teapot] image which comes with the [Tk] demos :^)
 set im1 [image create photo -file [info script]/../teapot.ppm]
 set im2 [image create photo]
 $im2 copy $im1
 puts "identical: expect 1"
 puts tcc:[img_eq $im1 $im2],[time {img_eq $im1 $im2}]
 puts Tcl:[photo'eq $im1 $im2],[time {photo'eq $im1 $im2}]
 puts Tcl2:[img'eq2 $im1 $im2],[time {img'eq2 $im1 $im2}]
 $im2 put purple -to 111 111
 puts "different: expect 0"
 puts tcc:[img_eq $im1 $im2],[time {img_eq $im1 $im2}]
 puts Tcl:[photo'eq $im1 $im2],[time {photo'eq $im1 $im2}]
 puts Tcl2:[img'eq2 $im1 $im2],[time {img'eq2 $im1 $im2}]

----
This is what came out on my 200MHz W95 box - factors between 1276 and 1383:
 identical: expect 1
 tcc:1,5730 microseconds per iteration
 Tcl:1,7888562 microseconds per iteration
 Tcl2:1,2298478 microseconds per iteration
 different: expect 0
 tcc:0,2190 microseconds per iteration
 Tcl:0,3893308 microseconds per iteration
 Tcl2:0,2283866 microseconds per iteration

So obviously, this is a good use case for [tcc]... Lessons learned:
   * Small Tcl code can do the job much faster than big Tcl code
   * but real C code still beats small Tcl code by some orders of magnitude
   * it's so great that we can code in C in a Tcl script (and without bothering about compiler installation...) :^)
----
[Category Example]