# EAN 8 barcode generation
# Specification described at http://www.barcodeisland.com/ean8.phtml
# Based heavily on code by Pascal Scheffers from https://wiki.tcl-lang.org/10538

proc ean8_csum {number} {

  set sum 0

  foreach {odd even} [split "[string range ${number} 0 6]0" ""] {
    incr sum [expr {$odd*3}]
    incr sum [expr {$even*1}]
  }

  set check [expr {$sum % 10}]
  if { $check > 0 } {
       return [expr {10 - $check}]
     }

  return $check;

};# ean8_csum

proc ean8 {number} {

  if { [string length $number] != 7 && [string length $number] != 8 } {
       puts "Must be 7 or 8 digits long"
       return;
     }

  # EAN8 digits, the ones represent black bars, the zeroes white space.
  # Two pairs of digits: lefthand-odd(A) and righthand

  set digits {
    {0 0001101 1110010}
    {1 0011001 1100110}
    {2 0010011 1101100}
    {3 0111101 1000010}
    {4 0100011 1011100}
    {5 0110001 1001110}
    {6 0101111 1010000}
    {7 0111011 1000100}
    {8 0110111 1001000}
    {9 0001011 1110100}
  }

  # If we get a 7 digit number, append the checkdigit to that. Otherwise, verify checkdigit.
  set csum [ean8_csum [string range $number 0 6]]
  if { [string length $number] == 7 } {
       set number $number[ean8_csum $number]
     } elseif { [string index $number 7] != $csum } {
       puts "Invalid code"
       return;
     }

  # All EAN8 codes start with 'left guard bars':
  lappend bars 101

  # First four digits:
  foreach digit [split [string range $number 0 3] ""] {
    lappend bars [lindex [lindex $digits $digit] 1]
  }

  # center guard bars:
  lappend bars 01010

  # the right hand chars, all encoded the same:
  foreach digit [split [string range $number 4 8] ""] {
    lappend bars [lindex [lindex $digits $digit] 2]
  }

  # and the final guards:
  lappend bars 101

  return [list $bars $number];
};# ean8

# Tk demo code:

package require Tk

wm title . "EAN-8 Barcode"

label .lbar -text "Barcode"
entry .barcode -textvariable barcode -width 15
button .show -text show -command do_display
bind . <Return> [list .show invoke]
grid .lbar .barcode .show -sticky nw

canvas .c -width 200 -height 100

grid x .c - -sticky nw

proc do_display { } {
  global barcode
  if { [string length $barcode] < 7 } {
        bell -displayof .
        return;
     }

  .c delete all
  set b [ean8 $barcode]

  set x 25
  foreach barset [lindex $b 0] {
    set bars [split $barset ""]
    if { [llength $bars] == 7 } {
         set len 40
       } else {
         set len 46
       }
    foreach bar $bars {
      incr x 1
      if { $bar } {
           .c create line $x 15 $x [expr $len+15]
         }
    }
  }

  # And create the human readable text below it:
  .c create text 43 60 -text [string range [lindex $b 1] 0 3]
  .c create text 75 60 -text [string range [lindex $b 1] 4 8]
};# do_display

set barcode {55123457}

do_display

catch {console show}