Patch title: Release 96 bulk changes
Abstract:
File: /pliant/protocol/vnc/ocr.pli
Key:
    Removed line
    Added line
module "/pliant/language/unsafe.pli"
module "/pliant/math/transform.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/color/color.pli"
module "/pliant/graphic/filter/io.pli"
module "/pliant/graphic/image/pixmap.pli"
module "/pliant/graphic/image/antialiasing.pli"
module "/pliant/graphic/vector/font.pli"

constant trace false
constant trace2 false


public
  type OCRResult
    field Int x0 y0 x1 y1
    field Str text
    field Float uncertainty


function ocr_word density rx0 ry0 rx1 ry1 f options text uncertainty ax0 ay0 ax1 ay1
  oarg_rw ImagePixmap density ; arg Int rx0 ry0 rx1 ry1 ; arg Font f ; arg Str options ; arg_w Str text ; arg_w Float uncertainty ; arg_w Int ax0 ay0 ax1 ay1
  var Int dt := options option "density_threshold" Int 64
  var Float mu := options option "maximum_uncertainty" Float 0.5
  var Str answer := options option "answer" Str
  text := "" ; uncertainty := 0 ; var Int strange := 0
  ax0 := undefined ; ay0 := undefined ; ax1 := undefined ; ay1 := undefined
  var Int start_x := rx0
  part global_scan "ocr word "+string:rx0+" "+string:ry0+" "+string:rx1+" "+string:ry1
    while true
      var Int stop_x := rx1 ; var Int shift_x := 0
      var Int start_y := ry0 ; var Int stop_y := ry1
      var CBool cut := false
      part character_scan

        part scan_x0
          var Int ix0 := undefined
          var Float fx0 := density x1
          for (var Int x) start_x stop_x-1
            var CBool some := false
            for (var Int y) start_y stop_y-1
              var Int d := (density pixel x y) map uInt8
              if d>=dt
                ix0 := x
                var Float fx := x+1-d/255
                fx := density:x0+(density:x1-density:x0)/density:size_x*fx
                fx0 := min fx0 fx
                some := true
            if some
              leave scan_x0
        if ix0=undefined
          leave global_scan
        part scan_x1
          var Int ix1 := undefined
          var Float fx1 := density x0
          var Int iy0 := ry1
          var Float fy0 := density y1
          var Int iy1 := ry0
          var Float fy1 := density y0
          for (var Int x) ix0 stop_x-1
            var CBool some := false
            for (var Int y) start_y stop_y-1
              var Int d := (density pixel x y) map uInt8
              if d>=dt
                ix1 := x+1
                var Float fx := x+d/255
                fx := density:x0+(density:x1-density:x0)/density:size_x*fx
                fx1 := max fx1 fx
                iy0 := min iy0 y
                var Float fy := y+1-d/255
                fy := density:y0+(density:y1-density:y0)/density:size_y*fy
                fy0 := min fy0 fy
                iy1 := max iy1 y+1
                var Float fy := y+d/255
                fy := density:y0+(density:y1-density:y0)/density:size_y*fy
                fy1 := max fy1 fy
                some := true
            if not some
              leave scan_x1
      
        var Link:ImagePixmap selected :> new ImagePixmap
        selected setup (image_prototype density:x0+(density:x1-density:x0)/density:size_x*ix0 density:y0+(density:y1-density:y0)/density:size_y*iy0 density:x0+(density:x1-density:x0)/density:size_x*ix1 density:y0+(density:y1-density:y0)/density:size_y*iy1 ix1-ix0 iy1-iy0 density:gamut) ""
        for (var Int y) 0 selected:size_y-1
          memory_copy (density pixel ix0 iy0+y) (selected pixel 0 y) selected:line_size
        var Int ref_delta := 0
        for (var Int y) 0 selected:size_y-1
          for (var Int x) 0 selected:size_x-1
            ref_delta += (selected pixel x y) map uInt8
      
        var Int aa := 4
        var Link:ImagePixmap over :> new ImagePixmap
        over setup (image_prototype selected:x0 selected:y0 selected:x1 selected:y1 selected:size_x*aa selected:size_y*aa selected:gamut) ""
      
        var Link:ImageAntiAliasing final :> new ImageAntiAliasing
        final bind over aa aa
      
        var Int best_delta := 2^30 ; var Int best_ch := 32
        var Float best_sx best_sy
        var Address buffer := memory_allocate final:line_size addressof:final
        var Int ach := shunt answer:len>text:len (answer text:len):number undefined
        for (var Int ch) (shunt ach<>undefined ach 32) (shunt ach<>undefined ach 127)
          for (var Int y) 0 over:size_y-1
            var Int d := 0
            over fill 0 y over:size_x addressof:d
        
          f bbox ch (var Float bx0) (var Float by0) (var Float bx1) (var Float by1)
          var Float sx := (fx1-fx0)/(bx1-bx0)
          var Float sy := (fy1-fy0)/(by1-by0)
          sx := min sx 2*sy
          sy := min sy 2*sx
          var Float tx := fx0-bx0*sx
          var Float ty := fy0-by0*sy
          var Int d := 255
          over character f ch (transform tx ty sx sy 0 0) addressof:d
          
          var Int delta := 0
          for (var Int y) 0 final:size_y-1
            final read 0 y final:size_x buffer
            var Address ref := selected pixel 0 y
            for (var Int x) 0 final:size_x-1
              delta += abs (cast (buffer map uInt8 x)-(ref map uInt8 x) Int)
      
          if delta<best_delta
            best_ch := ch ; best_delta := delta
            best_sx := sx ; best_sy := sy
        memory_free buffer
        
        var Float err := best_delta/ref_delta
        if err>=mu and iy1-(max iy0 start_y)>=3
          var Int mini := 256 ; var Int mini_y
          for (var Int y) (max iy0 start_y)+1 iy1-2
            var Int maxi := 0
            for (var Int x) ix0 ix1-1
              maxi := max maxi ((density pixel x y) map uInt8)
            if maxi<mini
              mini := maxi
              mini_y := y
          if mini<dt
            if trace2
              console "vertical cut" eol
            start_y := mini_y
            cut := true
            restart character_scan
        if err>=mu and (min ix1 stop_x)-ix0>=3
          var Int mini := 256 ; var Int mini_x
          for (var Int x) ix0+1 (min ix1 stop_x)-2
            var Int maxi := 0
            for (var Int y) ry0 ry1-1
              maxi := max maxi ((density pixel x y) map uInt8)
            if maxi<mini
              mini := maxi
              mini_x := x
          if trace2
            console "horizontal cut" eol
          stop_x := mini_x+1
          shift_x := -1
          cut := true
          restart character_scan
            
        if cut and (f vector best_ch):x<f:vector:x/2
          if strange>=3 and strange>text:len\2
            if trace2
              console "discard strange '" text "'" eol
            text := ""
            uncertainty := mu
            return
          strange += 1
        text += character best_ch
        uncertainty := max uncertainty err
        if uncertainty>=mu
          if trace2
            console "discard '" text "'" eol
          text := ""
          return
        start_x := max ix1+shift_x start_x+1
        ax0 := shunt ax0=undefined ix0 (min ix0 ax0)
        ay0 := shunt ay0=undefined iy0 (min iy0 ay0)
        ax1 := shunt ax1=undefined ix1 (max ix1 ax1)
        ay1 := shunt ay1=undefined iy1 (max iy1 ay1)
        if text=answer
          return
        if trace
          console character:best_ch " " (string 100*err "fixed 0") "% (scale " best_sx " x " best_sy ")" eol


function ocr_image truecolor fonts options result
  oarg_rw ImagePrototype truecolor ; arg (List Link:Font) fonts ; arg Str options ; arg_w List:OCRResult result
  var Int cx0 := options option "x0" Int 0
  var Int cy0 := options option "y0" Int 0
  var Int cx1 := options option "x1" Int truecolor:size_x
  var Int cy1 := options option "y1" Int truecolor:size_y
  var Int fg := options option "foreground" Int 0
  var Int bg := options option "background" Int 255
  var Int dt := options option "density_threshold" Int 64
  var Int test_x := options option "test_x" Int 8
  var Int test_y := options option "test_y" Int 8
  var Int space_x := options option "space_x" Int 4
  var Int space_y := options option "space_y" Int 2
  var Int mini_x := options option "mini_x" Int 5
  var Int mini_y := options option "mini_y" Int 5
  var Int maxi_x := options option "maxi_x" Int 500
  var Int maxi_y := options option "maxi_y" Int 50
  var Float mu := options option "maximum_uncertainty" Float 0.5
  var Str answer := options option "answer" Str
  var Int partial := undefined
  part global_scan
    result := var List:OCRResult empty_list
    var Link:ImagePixmap density :> new ImagePixmap
    density setup (image_prototype truecolor:x0 truecolor:y0 truecolor:x1 truecolor:y1 truecolor:size_x truecolor:size_y color_gamut:"grey") ""
    var Address buffer := memory_allocate truecolor:line_size addressof:truecolor
    for (var Int y) 0 density:size_y-1
      truecolor read 0 y truecolor:size_x buffer
      var Address src := buffer ; var Address dest := density pixel 0 y
      for (var Int x) 0 density:size_x-1
        var Int green := src map uInt8 1
        var Int d := min 255*(abs green-bg)\(abs fg-bg) 255
        dest map uInt8 := d
        src := src translate Byte truecolor:pixel_size
        dest := dest translate Byte 1
    memory_free buffer
    # density save "file:/tmp/density.png" ""
    for (var Int cy) cy0 cy1-2
      var Int cx := cx0
      part try_position
        while cx<=cx1-2
          for (var Int x) cx (min cx+test_x density:size_x)-1
            if ((density pixel x cy) map uInt8)>=dt
              cx := x+1
              restart try_position
          part need_some
            for (var Int x) cx (min cx+2*test_x density:size_x)-1
              if ((density pixel x cy+1) map uInt8)>=dt
                leave need_some
            cx += test_x
            restart try_position
          for (var Int y) cy (min cy+test_y density:size_y)-1
            if ((density pixel cx y) map uInt8)>=dt
              cx += 1
              restart try_position
          part need_some2
            for (var Int y) cy (min cy+test_y density:size_y)-1
              if ((density pixel cx+1 y) map uInt8)>=dt
                leave need_some2
            cx += 1
            restart try_position
          var Int rx0 := x ; var Int ry0 := cy+1
          var Int rx1 := x ; var Int ry1 := cy+1
          part extend
            if rx1-rx0>maxi_x or ry1-ry0>maxi_y
              leave extend
            for (var Int d) 1 (max space_x space_y)
              if rx1+d<density:size_x and d<=space_x
                for (var Int y) (max ry0-d 0) (min ry1+d density:size_y)-1
                  if ((density pixel rx1+d y) map uInt8)>=dt
                    rx1 += d
                    restart extend
              if ry1+d<density:size_y and d<=space_y
                for (var Int x) (max rx0-d 0) (min rx1+d density:size_x)-1
                  if ((density pixel x ry1+d) map uInt8)>=dt
                    ry1 += d
                    restart extend
              if rx0-d>=0 and d<=space_x
                for (var Int y) (max ry0-d 0) (min ry1+d density:size_y)-1
                  if ((density pixel rx0-d y) map uInt8)>=dt
                    rx0 -= d
                    restart extend
              if ry0-d>=0 and d<=space_y
                for (var Int x) (max rx0-d 0) (min rx1+d density:size_x)-1
                  if ((density pixel x ry0-d) map uInt8)>=dt
                    ry0 -= d
                    restart extend
            rx1 += 1 ; ry1 += 1
            if rx1-rx0>=mini_x and ry1-ry0>=mini_y
              var DateTime start2 := datetime
              var OCRResult r ;r text := "" ; r uncertainty := 1e9
              each f fonts
                ocr_word density rx0 ry0 rx1 ry1 f "maximum_uncertainty "+string:mu+" "+options (var Str t) (var Float u) (var Int ax0) (var Int ay0) (var Int ax1) (var Int ay1)
                if u<r:uncertainty and ax1-ax0>=mini_x and ay1-ay0>=mini_y
                  r text := t ; r uncertainty := u
                  r x0 := ax0 ; r y0 := ay0 ; r x1 := ax1 ; r y1 := ay1
              if trace
                console "rectangle " rx0 " " ry0 " " rx1 " " ry1 " -> " ax0 " " ay0 " " ax1 " " ay1 " "
                console "-> '" t "' uncertainty " (string 100*u "fixed 0") "% in " (string datetime:seconds-start2:seconds "fixed 1") " seconds" eol
              if r:uncertainty<mu
                if answer="" or (shunt partial=undefined r:text=answer (r:text 0 partial)=(answer 0 partial))
                  var Pointer:OCRResult pr :> result first
                  while exists:pr and pr:uncertainty<r:uncertainty
                    pr :> result next pr
                  result insert_before pr r
            for (var Int y) ry0 ry1-1
              for (var Int x) rx0 rx1-1
                (density pixel x y) map uInt8 := 0
          cx += 1
    if answer<>"" and not (exists result:first) and not (options option "maximum_uncertainty")
      if mu<0.60
        mu += 0.01
        restart global_scan
      eif partial=undefined
        partial := answer len
        mu := options option "maximum_uncertainty" Float 0.5
        restart global_scan
      eif partial>2
        partial -= 1
        mu := options option "maximum_uncertainty" Float 0.5
        restart global_scan


function ocr_file filename options
  arg Str filename options
  var (List Link:Font) fonts
  var Link:Font f
  f :> font "Bitstream Vera Sans" ; fonts += f
  f :> font "Bitstream Vera Sans Bold" ; fonts += f
  var Link:ImagePixmap truecolor :> new ImagePixmap
  if (truecolor load filename "")=success
    var DateTime start := datetime
    ocr_image truecolor fonts options (var List:OCRResult result)
    each r result
      console r:x0 " " r:y0 " " r:x1 " " r:y1 " (" r:x1-r:x0 "x" r:y1-r:y0 ") " (string r:text) " " (string r:uncertainty*100 "fixed 0") "%" eol 
    console "done in " (string datetime:seconds-start:seconds "fixed 1") " seconds" eol
  else
    console "failed to load image '"+filename+"'" eol


export ocr_image ocr_file