SRL Archive - Senior Scripts and Snippets

Hey,

For the last few days I've been working on an OCR for the RS ChatText. I think it worked out pretty good. I've attached the rar-file, it includes the plugin and the bitmap with the chars. Put the plugin in the SCAR plugin folder and the bitmap in the Fonts/SmallChars/ folder.

program New;
var
  a, b: TPointArray;
  i, t: Integer;
begin
  ClearDebug;
  LoadLowChars;
  t := GetSystemTime;
  for i := 0 to 7 do
  begin
    FindColorsTolerance(a, clBlack, 10, 347 + (14 * i), 450, 360 + (14 * i), 0);
    FindColorsTolerance(b, clBlue, 10, 347 + (14 * i), 450, 360 + (14 * i), 0);
    a := CombineTPA(a, b);
    WriteLn(OCR(a));
  end;
  WriteLn('OCR of the chatbox took '+IntToStr(GetSystemTime - t)+' ms.');
end.

Run this and tell me how it works :)

Nielsie95

Nice. FP.

Ahh, nice. A good bit of it is hard to understand because I didn't write it, but I'm sure it's good :p

Could you explain briefly how it works?

Heh, nice nielsie, note that I'll be writing a new, improved and fast universal OCR system for SCAR 3.20 though ;)

function OCR(TPA: TPointArray): string; stdcall;
var
  Chars, Temp: T2DPointArray;
  a, b, c, d, e, x, w, h: Integer;
  r: TRect;
  tl: TPoint;
label
  FindChar;
begin
  Chars := SplitTPA(TPA);  //Get all the characters from the tpa
  if (Length(Chars) = 0) then Exit;
  r := GetTPABounds(TPA);
  tl := r.TopLeft;
  x := r.Left;
  SortATPAFromFirstPoint(Chars, tl);  //Sort for the right order
  b := High(LowChars);
  Result := '';
  a := 0;
  if (b < 0) then    //Make sure the presets are loaded
  begin
    LoadLowChars;
    b := High(LowChars);
    if (b < 0) then Exit;
  end;
  while (a < Length(Chars)) do  //Go through the loop of characters
  begin
    FindChar:   //Mark the label
    c := Length(Chars[a]);       //Get the length of the array
    r := GetTPABounds(Chars[a]); //Get the boundaries of the character
    w := (r.Right - r.Left) + 1; //Calculate the width and height from the bounds
    h := (r.Bottom - r.Top) + 1;
    for d := 0 to b do           //Loop through the presets
      if (LowChars[d].l = c) and (LowChars[d].w = w) and (LowChars[d].h = h) then //Check if any of the preset characters match the description of our char
      begin
        for e := 0 to c -1 do //if so, loop through the tpa to see if they match
          try                 //LowChars[d].p is a boolean array with "white points" set to true
            if (not LowChars[d].p[Chars[a][e].x - r.Left][Chars[a][e].y - r.Top]) then Break;
          except Break; end;
        if (e = c) then Break; //All matched
      end;
    if (d <= b) then  //if we got out of the loop early - we found a matching char
    begin
      if ((r.Left - x) > 3) then  //if the distance with the last char is bigger than 3
        Result := Result + StringOfChar(' ',  Max(1, Round((r.Left - x) / 6))); //calculate the number of spaces between the previous and this char
      x := r.Right;
      Result := Result + LowChars[d].c; //add the character to the result
    end
    else
    begin   //no match found
      for d := 0 to c -1 do
        if (Chars[a][d].y = r.Bottom) then  //Finds the point that's on the bottom of the tpa (that maybe shouldn't be there)
        begin
          FFCleanTPA(Chars[a], d); //Delete the point that's on the bottom along with the surrounding points
          Break;
        end;
      if (d < c) then
      begin
        SetLength(Temp, 0);
        Temp := SplitTPA(Chars[a]);  //split again, maybe there are 2 characters now
        if (Length(Temp) > 1) then   //if so, add them to the main tpa
        begin
          Chars[a] := Copy(Temp[0]);
          c := Length(Chars);
          SetLength(Chars, c + Length(Temp) -1);
          for d := 1 to High(Temp) do
            Chars[c + d - 1] := Copy(Temp[d]);
          SortATPAFromFirstPoint(Chars, tl);   //sort again, so the order stays the same
        end;
        if (Length(Temp) > 0) then
          goto FindChar;  //Go back and try to match the character again
      end;
    end;
    Inc(a);
  end;
  Result := Trim(StringReplace(Result, '.?', '?', [rfReplaceAll]));
end;

I did my best to explain it as good as possible.

From: Freddy1990
Heh, nice nielsie, note that I'll be writing a new, improved and fast universal OCR system for SCAR 3.20 though ;)

I'm sure yours will be better, but I just wanted to give it a shot too :)

Thanks, all understood :)
Very nice.

From: nielsie95
I'm sure yours will be better, but I just wanted to give it a shot too :)

Heh, that's not what I meant, I mean it won't be specific to anything like this OCR, but it will be able to handle anything and it will do it fast :)