Décoder les marqueurs jaunes au format Docucolor des imprimantes laser couleur

 

GS (20171220) Docucolor Decoder est un programme qui peut décoder les marqueurs matérialisés sous la forme de points jaunes presqu'invisibles à l'oeil nu. Ceux-ci permettent d'identifier l'imprimante laser couleur et la date d'impression d'un document [1]

 # docucolor.tcl
 # Author:      Gerard Sookahet
 # Date:        20 Dec 2017
 # Version:     0.1
 # Description: Docucolor yellow tracking dots decoder for printers
 # Refs: https://w2.eff.org/Privacy/printers/docucolor/
 #       http://www.instructables.com/id/Yellow-Dots-of-Mystery-Is-Your-Printer-Spying-on-/

 bind all <Escape> {exit}

 option add *Button.relief flat
 option add *Button.foreground white
 option add *Button.background blue
 option add *Button.width 14
 option add *Label.foreground yellow
 option add *Label.background darkblue
 option add *Label.width 104

 proc About {} {
  set w .about
  catch {destroy $w}
  toplevel $w
  .about configure -bg black
  wm title $w "About Docucolor Decoder"
  set txt "Docucolor Decoder - (v0.1 - Dec 2017) - Gerard Sookahet\n
  Docucolor Decoder can decode small yellow tracking dots pattern inserted automatically
  to identify the color laser printer and the date when the document was produced."
  message $w.msg -justify left -aspect 250 -relief flat -bg black -fg lightblue -text $txt
  button $w.bquit -text " OK " -command {destroy .about}
  pack $w.msg $w.bquit
 }

 proc CreateDot {x y tag} {
  .f1.c create oval [list $x $y [expr {$x+20}] [expr {$y+20}]] -tag $tag -fill darkblue
  .f1.c bind $tag <1> "ChangeDotColor $tag"
 }

 proc ChangeDotColor {tag} {
  set color [.f1.c itemcget $tag -fill]
  if {$color eq "darkblue"} then {
    .f1.c itemconfigure $tag -fill yellow
  } elseif {$color eq "yellow"} then {
    .f1.c itemconfigure $tag -fill darkblue
  }
  Decode
 }

 proc Reset {col row} {
  set sep :
  foreach i $col {
     foreach j $row {
        .f1.c itemconfigure $i$sep$j -fill darkblue
     }
  }
  foreach j [lrange $row 1 end] {.f1.c itemconfigure 9$sep$j -fill yellow}
  foreach j [lrange $row 1 2]   {
     .f1.c itemconfigure 4$sep$j -fill midnightblue
     .f1.c itemconfigure 5$sep$j -fill midnightblue
  }
  foreach j [lrange $row 1 3] {.f1.c itemconfigure 6$sep$j -fill midnightblue}
  foreach j $row {
     .f1.c itemconfigure  2$sep$j -fill midnightblue
     .f1.c itemconfigure  3$sep$j -fill midnightblue
     .f1.c itemconfigure  8$sep$j -fill midnightblue
  }
  .f1.c itemconfigure 1:64 -fill midnightblue

  set ::code ""
 }

 proc GetCol {col row} {
  set l {}
  foreach i $col {
     set d 0
     foreach j $row {
       set tag [join [list $i $j] :]
       if {[.f1.c itemcget $tag -fill] eq "yellow"} then {incr d $j}
     }
     lappend l $d
  }
  return $l
 }

 proc CheckParity {col row} {
  set lrow {}
  set lcol {}

  foreach i $col {
     set d 0
     foreach j $row {
        set tag [join [list $i $j] :]
        if {[.f1.c itemcget $tag -fill] eq "yellow"} then {incr d}
     }
    lappend lcol [expr {$i*(($d % 2) ^ 1)}]
  }

  foreach j $row {
     set d 0
     foreach i $col {
        set tag [join [list $i $j] :]
        if {[.f1.c itemcget $tag -fill] eq "yellow"} then {incr d}
     }
     lappend lrow [expr {$j*(($d % 2) ^ 1)}]
  }
  foreach k {2 3 8 0} {
     set lcol [lsearch -inline -all -not -exact $lcol $k]
  }
  set lrow [lsearch -inline -all -not -exact $lrow 0]

  return [concat ROW $lrow COL $lcol]
 }

 proc Decode {} {

  set col [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14]
  set row [list 0 64 32 16 8 4 2 1]

  set lrow    [lrange $row 1 end]

  set serial [GetCol [lreverse [lrange $col 10 end]] $lrow]
  set ymd    [GetCol [lreverse [lrange $col 5 7]] $lrow]
  set hm     [GetCol [list 4 1] $lrow]

  set year  [lindex $ymd 0]
  set month [lindex $ymd 1]
  set day   [lindex $ymd 2]

  set hour [lindex $hm 0]
  set min  [lindex $hm 1]

  set serial [join $serial ""]
  if {$year < 70 || $year > 99} then {incr year 2000} else {incr year 1900}
  set date [join [concat $year [expr {$month < 13 ? $month : "MM"}] $day] "-"]
  set time [join [concat [expr {$hour < 25 ? $hour : "hh"}] [expr {$min < 61 ? $min : "mm"}]] ":"]

  set pc [CheckParity $col $row]
  if {$pc eq "ROW COL"} {set pc "OK"}

  set ::code "Date: $date at $time -- Printer Serial Number: $serial  -- Parity Check: $pc"
 }

 . configure -bg black
 wm title . "Docucolor Decoder"

 set f1 [frame .f1 -relief flat -bg black]
 set f3 [frame .f3 -relief flat -bg black]
 set f4 [frame .f4 -relief flat -bg black]
 pack $f1 $f3 $f4 -pady 2

 pack [canvas .f1.c -bg black -width 630 -height 390]

 set col [list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14]
 set row [list 0 64 32 16 8 4 2 1]

 set x 50
 set y 30
 .f1.c create text $x $y -text parity -angle 90 -fill white
 foreach {s c} {minute white unused grey unused grey hour white day white month white year white unused grey} {
   .f1.c create text [incr x 40]  $y -text $s -angle 90 -fill $c
 }
 .f1.c create text 530 $y -text serial -fill white
 .f1.c create line 445 [expr {$y+10}] 620 [expr {$y+10}] -fill blue

 set x 50
 foreach i $col {
   .f1.c create text $x 70 -text $i -fill white
   incr x 40
 }
 set y 90
 foreach j [concat parity [lrange $row 1 end]] {
   .f1.c create text 20 $y -text $j -fill white
   incr y 40
 }

 set x 40
 set sep :
 foreach i $col {
    set y 80
    foreach j $row {
       CreateDot $x $y $i$sep$j
       incr y 40
    }
    incr x 40
 }

 label $f3.l -textvariable code
 pack $f3.l -pady 4

 button $f4.b1 -text Reset -command {Reset $::col $::row}
 button $f4.b2 -text About -command {About}
 button $f4.b3 -text Exit  -command {exit}
 pack {*}[winfo children $f4] -side left -padx 2 -pady 2

 Reset $col $row