#Copyright (C) 2003 Pascal Scheffers <[email protected]> # This code is placed in the public domain. package require Img package require Tk # ean13.tcl from http://wiki.tcl.tk/13192 source ean13.tcl proc getline { img line angle } { set pixels {} set w [image width $img] for {set i 1} {$i < $w} { incr i } { lappend pixels [lindex [$img get $i $line] 0] } return $pixels } proc blackwhite { pixel } { return [lindex $pixel 0] foreach {r g b} $pixel {} #return [expr {$r < 150 } ] return [expr { ($r+$g+$b)/3 }] } proc average { list } { set val [lindex $list 0] foreach item [lrange $list 1 end] { set val [expr {$val+$item/2}] } return $val } proc scanline { line {threshold 125} } { set isbar 0 set prev 0 set width 0 set c 0 set quietzone {} append threshold ".0" foreach pix $line { incr c #build the quietzone: #and the average 'signal' #edge? set e 999 if { $prev != $pix && (($prev < $threshold && $pix >= $threshold) || \ ($pix < $threshold && $prev >= $threshold)) } { if { $prev > $pix } { set e [expr { 1- ($threshold-$pix)/($prev-$pix) }] } else { set e [expr { ($threshold-$prev)/($pix-$prev) }] } } #.t insert end "$c $prev > $pix = [expr $prev>$pix] :: e=$e \n" #.t insert end "$c\t$prev\n" if { $e > 0 && $e <= 1 } { #edge! set width [expr {$width+abs($e)}] lappend lengths [list $c $isbar $width] #.t insert end "Edge -- Isbar: $isbar width: $width\n" set width [expr {1-abs($e)}] set isbar [expr {$prev > $pix} ] } else { set width [expr {$width+1}] } set prev $pix } lappend lengths [list $c $isbar $width] return $lengths } image create photo button .b -text "Do it" -command do_it button .bt -text "time it" -command timing grid .b .bt text .t -width 60 -height 40 grid .t - proc do_it {} { foreach file [glob *.jpg] { .t insert end "File $file...\n" update set img [image create photo -file $file] # 9789069 744063 #Threshold pattern: set height [image height $img] set line_interval [expr {$height / 220}] foreach j {125 122 128 118 132 112 137 105 145 95 155} { puts $j for {set i 0} {$i < $height/2} {incr i $line_interval} { set line [expr {$height/2 + $i}] set pixs [getline $img $i 0] set lens [scanline $pixs $j] set nbr [ean13::scanline $lens] if {[string match "partial*" $nbr]} { set nbr [finescan $img $i $line_interval $j] #finescan only ever returns a number or "" } if {$nbr ne ""} { break } if { $i != 0 } { set line [expr {$height/2 - $i}] set pixs [getline $img $i 0] set lens [scanline $pixs $j] set nbr [ean13::scanline $lens] if {[string match "partial*" $nbr]} { set nbr [finescan $img $i $line_interval $j] #finescan only ever returns a number or "" } if {$nbr ne ""} { break } update } } if {$nbr ne ""} { break } } .t insert end "\tScan $file $i, $j: $nbr\n" update set nbr "" } .t insert end "\tDone.\n" } proc finescan {img start width threshold} { #scans all lines near a partial read. set height [image height $img] set nbr "" for {set t -2} {$t <3} {incr t} { set thr [expr {$threshold +$t}] for {set i [expr {$start-$width}]} {$i < $start+$width} {incr i} { if { $i > 0 && $i < $height } { set pixs [getline $img $i 0] set lens [scanline $pixs $thr] set nbr [ean13::scanline $lens] if {[string match "partial*" $nbr]} { .t insert end "Fine line $i/$thr: $nbr\n" set nbr "" } if {$nbr ne ""} { return $nbr } } } } return $nbr } proc timing {} { set file [lindex [glob scan/*.jpg] 0] .t insert end "File $file...\n" update set img [image create photo -file $file] # 9789069 744063 foreach j {125 122 128 118 132 112 137 105 145 95 155} { puts $j for {set i -100} {$i < 100} {incr i 5} { set line [expr [image height $img]/2+$i ] .t insert end "Getline [time { set pixs [getline $img $line 0] }]\n" .t insert end "Scanline [time { set lens [scanline $pixs $j] }]\n" .t insert end "eanscanline [time { set nbr [ean13::scanline $lens] }]\n" if {$nbr ne ""} { break } } if {$nbr ne ""} { break } } .t insert end "Scan $file $i, $j: $nbr\n" update set nbr "" }
SeS (10th April, 2011): Hallo Pascal, I tried your script, but it failed, it returns:
SeS (11th April, 2011): I found some more time to examine the ean13.tcl script, to my suprise, the dot seems to be hardcoded into the list, see:
JM: yes, it is a typo. When removed, it works.
list element in braces followed by "." instead of space while executing "lsearch $digits $d" (procedure "ean13::scanline" line 73)I am not sure if this has to do with the tcl/tk version you used back in 2004 when you developed & shared the code with us, since I am using 8.4.19. Anyway I was able to fix the problem by adding the following right after the comment "#Now decode:" in proc scanline (of ean13.tcl):
set digits [replace_words_in_string "." $digits ""]replace_words_in_string is a procedure from tG², it simply uses 'string map' command to remove the dot inside the list which seems to cause the error. With this patch, your script returned (using your example jpg):
File barcode-sample1.jpg... Scan barcode-sample1.jpg 158, 125: 9789069744063
SeS (11th April, 2011): I found some more time to examine the ean13.tcl script, to my suprise, the dot seems to be hardcoded into the list, see:
set digits { {3 2 1 1}. {2 2 2 1} {2 1 2 2} {1 4 1 1} {1 1 3 2} {1 2 3 1} {1 1 1 4} {1 3 1 2} {1 2 1 3} {3 1 1 2} }I wonder what purpose the dot has in this list? Typo?AK: I would assume that this is a typo.
JM: yes, it is a typo. When removed, it works.