[GS] (2017-12-20) https://w2.eff.org/Privacy/printers/docucolor/%|%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.

[IMG_Docucolor]


======
 # 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

======

<<categories>>Enter Category Here