EAN-13 encode/decode functions

2004Dec17 PS
This code is used by Scan an EAN-13 barcode from an image, save it as ean13.tcl in the same directory.
 #EAN 13 generation and decode routines
 namespace eval ean13 {

    #Digit bar/space widths
    #Lefthand digits start with spaces, righthand with bars
    #Lefthand-even are pattern inverse of odd: zero: 3211 ==even==> 1123 
    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}
    }

    set rdigits {
        {1 1 2 3}
        {1 2 2 2}
        {2 2 1 2} 
        {1 1 4 1}
        {2 3 1 1}
        {1 3 2 1}
        {4 1 1 1}
        {2 1 3 1}
        {3 1 2 1}
        {2 1 1 3}
    }

    #parity encoding, the odd-even patterns of digits 2 through 7
    set parity_table {
        ooooo oeoee oeeoe oeeeo eooee 
        eeooe eeeoo eoeoe eoeeo eeoeo    
    }

    proc lreverse { list } {
        set l {}
        for {set i [expr {[llength $list]-1}]} {$i> -1} {incr i -1} {
            lappend l [lindex $list $i]
        } 
        return $l
    }

    proc scanline { line } {
        variable digits
        variable rdigits
        variable parity_table
        #Start scanning!
        #Line is: {{pixel0 width0 isbar0} {pixel1 . .} ... } 
        set barcnt [llength $line]

        #try to locate a valid barcode (1=single bar, 0=single space):
        # 101 (6*4 bars/spaces) 01010 (6*4 bars/spaces) 101
        # there are 30 bars and 29 spaces in a barcode
        # the width of the entire barcode has 95 element width units
        for {set i 0} {$i <$barcnt-59} {incr i} {
            #.t insert end "Offset $i\n"

            #Barcodes start with a bar...
            foreach {c isbar width} [lindex $line $i] {}
            if { !$isbar } { continue }

            #Calculate X, the single item width.
            foreach {c_end isbar width} [lindex $line [expr {$i+59}]] {}
            set X [expr {($c_end-$c)/95.0}]

            #Now translate to integer values:
            set widths {}
            for { set j $i } { $j < $i+59 } { incr j } {
                foreach {c isbar width} [lindex $line $j] {}
                lappend widths [expr { round( $width/$X ) } ]
            }

            
            #So, if this is valid EAN13, it should start with three ones:    
            if { [lrange $widths 0 2] ne "1 1 1" } {
                #.t insert end "Bad start guard\n"
                continue
            }
            #It should also end with three ones:
            if { [lrange $widths end-2 end] ne "1 1 1" } {
                #.t insert end "Bad end guard\n"
                continue
            }
            #And the center pattern is five ones:
            if { [lrange $widths 27 31] ne "1 1 1 1 1" } {
                #.t insert end "Bad center guard\n"
                continue
            }

            #Got it. Try to decode.
            #.t insert end "Found guards\n"

            #Maybe reverse?
            #Is the first digit left or righthand?            
            set d [lrange $widths 3 6]

            #.t insert end "First $d >> [lsearch $digits $d] [lsearch $rdigits $d]\n"
            
            if { [lsearch $rdigits $d] > -1 } {
                #yes. 
                #.t insert end "Reverse! \n$widths ..\n"
                
                set widths [lreverse $widths]
                #.t insert end "$widths ..\n"
            } 

            #Now decode:
            #First six digits:
            set number {}

            for {set j 0} {$j<6} {incr j} {
                set d [lrange $widths [expr {3+$j*4}] [expr {3+$j*4+3}] ]
                if { $j == 0 } {
                    set n [lsearch $digits $d]
                } else {
                    set n [lsearch $digits $d]
                    if { $n > -1 } {
                        append parity o
                    } else {
                        set n [lsearch $rdigits $d]
                        append parity e
                    }
                }
                #.t insert end "Left digits: $j == $d >> $n \n"
                if { $n == -1 } {
                    break
                }

                append number $n
            }
            if { [string length $number] < 4 } {                
                return ""
            }

            if { [string length $number] < 6 } {                
                #decode error.
                return "partial $number"
            }
            set number [lsearch $parity_table $parity]$number


            #Last six digits:
            for {set j 0} {$j<6} {incr j} {
                set d [lrange $widths [expr {32+$j*4}] [expr {32+$j*4+3}] ]

                set n [lsearch $digits $d]
                #.t insert end "Right digits: $j == $d >> $n \n"
                if { $n == -1 } {
                    break
                }                
                append number $n
            }
            #.t insert end "All digits $number\n"
            if { [string length $number] == 13 } {
                set c [ean13_csum [string range $number 0 11]]
                if { $c ne [string index $number 12] } {
                    return "partial/csum $number"
                }
                return $number
            }
            return "partial $number"

        }
    }

    proc ean13 { number } {
        set digits {
            {0 0001101 0100111 1110010}
            {1 0011001 0110011 1100110}
            {2 0010011 0011011 1101100}
            {3 0111101 0100001 1000010}
            {4 0100011 0011101 1011100} 
            {5 0110001 0111001 1001110}
            {6 0101111 0000101 1010000}
            {7 0111011 0010001 1000100}
            {8 0110111 0001001 1001000}
            {9 0001011 0010111 1110100}
        }


        array set parity_enc {
            0 {1 1 1 1 1}
            1 {1 2 1 2 2}
            2 {1 2 2 1 2}
            3 {1 2 2 2 1}
            4 {2 1 1 2 2}
            5 {2 2 1 1 2}
            6 {2 2 2 1 1}
            7 {2 1 2 1 2}
            8 {2 1 2 2 1}
            9 {2 2 1 2 1}
        }
        
        if { [string length $number] == 12 } {
            set number $number[ean13_csum $number]
        }
        
        #left guard bars:
        lappend bars 101
        #second system char:
        lappend bars [lindex [lindex $digits [string index $number 1]] 1]    

        #the five digits that encode the first digit in their parity:
        foreach digit [split [string range $number 2 6] ""] \
            enc $parity_enc([string index $number 0]) {
                lappend bars [lindex [lindex $digits $digit] $enc]
            }

        #center guard bars:
        lappend bars 01010

        #the right hand chars:
        for {set i 7} {$i<13} {incr i} {
            lappend bars [lindex [lindex $digits [string index $number $i]] 3]
        }
        #and the final guards:
        lappend bars 101

        return [list $bars $number]
    }

    proc ean13_csum { number } {
        set odd 1
        set sum 0
        foreach digit [split $number ""] {
            set odd [expr {!$odd}]
            #puts "$sum += ($odd*2+1)*$digit :: [expr {($odd*2+1)*$digit}]"
            incr sum [expr {($odd*2+1)*$digit}]
        }
        set check [expr {$sum % 10}]
        if { $check > 0 } {
            return [expr {10 - $check}]
        }
        return $check
    }

 }
Category Barcode