RSCR Text

type
  TCharset = record
    chars: array[32..126] of record
      pixels: TPointArray;
      size: Integer;
      width, height: Integer;
    end;
    max_width, max_height: Integer;
    loaded: TIntegerArray;
  end;

function LoadCharset(path: string): TCharset;
var
  h, i, v, l: Integer;
  b: TStringArray;
  n: string;
  d: Integer;
begin
  b := GetFiles(path, 'bmp');
  h := High(b);
  l := 0;
  Result.max_width := 0;
  Result.max_height := 0;
  SetLength(Result.loaded, ((126 - 32) + 2));
  for i := 0 to h do
  begin
    n := Copy(b[i], 1, (Length(b[i]) - 4));
    if (n = ExtractFromStr(b[i], Numbers)) then
    begin
      v := StrToInt(n);
      if InRange(v, 32, 126) then
      begin
        d := LoadBitmap(path + b[i]);
        GetBitmapSize(d, Result.chars[v].width, Result.chars[v].height);
        if (Result.chars[v].width > Result.max_width) then
          Result.max_width := Result.chars[v].width;
        if (Result.chars[v].height > Result.max_height) then
          Result.max_height := Result.chars[v].height;
        if (v <> 32) then
        begin
          FindColorsBitmap(d, Result.chars[v].pixels, 16777215);
          Result.chars[v].size := Length(Result.chars[v].pixels);
        end else
          Result.chars[v].size := 0;
        Result.loaded[l] := v;
        l := (l + 1);
        FreeBitmap(d);
      end;
    end;
  end;
  SetLength(Result.loaded, l);
  SetLength(b, 0);
end;

function GetRSCRTextEx(position: TPoint; colors: TIntegerArray; size: Integer; charset: TCharset): string;
var
  area, bounds: TBox;
  n, o, g, q, d, m, e, f, t, s, r, w, h, i, l, j, k, x, y, z: Integer;
  p, c, offset: TPoint;
  a, v: TPointArray;
  image: Integer;
  matrix: array of TBoolArray;
  u: TIntegerArray;
begin
  n := High(colors);
  if (n > -1) then
  begin
    SetLength(u, (n + 1));
    for i := 0 to n do
      u[i] := colors[i];
    ClearSameIntegers(u);
    n := High(u);
    GetClientDimensions(w, h);
    Result := '';
    if PointInBox(position, IntToBox(0, 0, (w - 1), (h - 1))) then
    begin
      area := IntToBox(position.X, position.Y, (w - 1), (position.Y + charset.max_height));
      if (area.Y2 > (h - 1)) then
        Exit;
      w := ((area.X2 - area.X1) + 1);
      h := ((area.Y2 - area.Y1) + 1);
      for i := 0 to n do
        if FindColors(v, u[i], area.X1, area.Y1, area.X2, area.Y2) then
        begin
          AppendTPA(a, v);
          SetLength(v, 0);
        end;
      if (Length(a) > 0) then
      begin
        ClearDoubleTPA(a);
        l := (Length(a) - 1);
        offset := Point(-position.X, -position.Y);
        OffsetTPA(a, offset);
        bounds := GetTPABounds(a);
        d := charset.chars[32].width;
        //w := (((bounds.X2 - bounds.X1) + 1) + charset.max_width);
        //h := (charset.max_height + 1);
        SetLength(matrix, w, h);
        for i := 0 to l do
          matrix[a[i].X][a[i].Y] := True;
        z := (w - 1);
        s := (Length(charset.loaded) - 1);
        q := 0;
        o := 0;
        for x := 0 to z do
        begin
          t := -1;
          m := 0;
          f := -1;
          for e := 0 to 1 do
            if ((f > -1) or (e = 0)) then
            for i := 0 to s do
            begin
              g := charset.loaded[i];
              if (charset.chars[g].size > 0) then
                if not ((q + (x + e) + charset.chars[g].width) > w) then
                begin
                  k := (Length(charset.chars[g].pixels) - 1);
                  r := 0;
                  for j := 0 to k do
                  begin
                    c.X := ((charset.chars[g].pixels[j].X + (x + e)) + q);
                    c.Y := charset.chars[g].pixels[j].Y;
                    if not matrix[c.X][c.Y] then
                      Break
                    else
                      r := (r + 1);
                  end;
                  if (r > k) then
                    if (r > m) then
                    begin
                      f := e;
                      t := g;
                      m := r;
                    end;
                end;
            end;
          if (t > -1) then
          begin
            Result := (Result + StringOfChar(' ', (((((x + f) + q) - o) + 1) div d)));
            q := ((q + charset.chars[t].width) - 1);
            o := ((x + f) + q);
            Result := (Result + Chr(t));
            if (Length(Result) >= size) then
            begin
              SetLength(Result, size);
              SetLength(matrix, 0);
              Exit;
            end;
          end;
        end;
        SetLength(matrix, 0);
      end;
    end;
  end;
end;

var
  chars: TCharset;
  new, old: string;

begin
  chars := LoadCharset(ScriptPath + 'RSCR_Main\');
  ActivateClient;
  Wait(1000);
  repeat
    new := GetRSCRTextEx(Point(6, 5), [65535, 16777215, 16776960, 4231423], 50, chars);
    if (new <> '') then
    begin
      if (new <> old) then
      begin
        ClearDebug;
        WriteLn(new);
        old := new;
      end;
      //Wait(10);
    end;
  until IsKeyDown(VK_F12);
end.