Richard Suchenwirth 2001-07-10 -- This is a birthday present I made to myself, but I'll gladly share it with all Tclworld. Given a binary BMP image scanned from a font sample book, the task is to segment it into lines, and each line into characters, and return the list of characters as strimjes (see strimj - string image routines). It's not perfect, segmentation requires full white lines between segments, and it takes some time, but the results are already quite amazing: one page of Tcl code produces mostly usable images as further input for strimj fonts - or playing OCR...
% strimj::text Hallo -font Schwabacher
@@@@@ @@ @@
@@@@@@ @@@ @@@
@@@@@ @@@@ @@@@
@@@@@@ @@@@@ @@@@@
@@@@@@ @@@ @@@
@@@@@@ @@@ @@@
@@@@@@ @@@ @@@
@@@@@ @@@ @@@ @@@ @@@@
@@@@@@ @@@@@@ @@@ @@@ @@@@@@
@@@@@ @ @@@@@@@@@ @@@ @@@ @@@@@@@@
@@@@@ @@@@ @@ @@@@@@ @@@ @@@ @@ @@@@@
@@@@ @@@@@@@ @@ @@@ @@@ @@@ @@ @@@@
@@@@@ @@@@@@@@@@ @@@ @@@ @@@ @@@ @@@ @@@@
@@@@ @@@ @@@@@@ @@ @@@ @@@ @@@ @@@ @@@@
@@@@@@@@ @@@@@ @@@ @@@ @@@ @@@ @@@ @@@
@@@@@@ @@@@ @@@ @@@ @@@@ @@@@ @@@ @@@
@@@@ @@@@@ @@@@ @@@@ @@@@ @@@@ @@@ @@@
@@ @@@@ @@@@ @@@@ @@@@ @@@@ @@@@ @@
@@@ @@@@ @@@@@@ @@@@ @@@@ @@@@ @@
@@@ @@@@@@@@@@@@@ @@@@@@@@ @@@@@@@@ @@@@@@ @
@@@@ @@@@@@ @@@@ @@@@@ @@@@@ @@@@@@@
@@@ @@@@ @@@ @@ @@ @@@@
@@ @@@@ @ @ @@
@@@@ @@@
@@@@@@ @@@
@@@@@@@@@@@@
@@@@@@@@@ namespace eval strimj {
proc fromBMP2 bmp {
#-- make a strimj from a binary BMP image file
set fp [open $bmp]
fconfigure $fp -translation binary
set data [read $fp [file size $bmp]]
close $fp
set offset 62
binary scan $data @18ii width height
set nbytes [expr {(($width+31)/32)*4}] ;# 4-byte aligned
set nbits [expr {(($width+7)/8)*8}] ;# byte-aligned
set res ""
for {set y [expr {$height-1}]} {$y>=0} {incr y -1} {
binary scan $data @[expr {$y*$nbytes+$offset}]B$nbits line
append res [string range $line 0 [expr {$width-1}]]\n
}
string map {1 . 0 @} $res
}
proc segment si {
#-- segment a binary text image into a list of character images
set res {}
foreach linesi [lseg $si] {
foreach charsi [lseg [rotate $linesi 270]] {
lappend res [vcrop [rot90 $charsi]]
}
}
set res
}
proc vcrop si {
#-- vertical crop, remove empty lines at top & bottom
set lines [lines $si]
set core [regexp -indices -inline @.+@ [pp2 $lines]]
foreach {from to} [lindex $core 0] break
join [lrange $lines $from $to] \n
}
proc lseg si {
#-- segment a binary text image into a list of line images
set lines [lines $si]
set ranges [regexp -all -indices -inline @+ [pp2 $lines]]
set res {}
foreach pair $ranges {
foreach {from to} $pair break
set height [expr {$to-$from+1}]
if {$height>2 && $height<100} {
lappend res [join [lrange $lines $from $to] \n]
}
}
set res
}
proc pp2 lines {
#-- vertical binary projection profile
set res ""
foreach line $lines {
append res [expr {[string first @ $line]>=0? "@":"."}]
}
set res
}
}
proc testseg {{bmpfile schwabacher2.bmp}} {
join [strimj::segment [strimj::fromBMP2 $bmpfile]] \n\n
}See Arts and crafts of Tcl-Tk programming