(not inlined due to size).The detection is sloooooow. And it will only work with rather clean images, sorry.
#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: 9789069744063SeS (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.
