unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, ExtCtrls, Ocr, ExtDlgs, XPMan;

type
  TFormMain = class(TForm)
    Ocr: TOcr;
    OpenPictureDialog: TOpenPictureDialog;
    XPManifest: TXPManifest;
    PanelLeft: TPanel;
    Panel: TPanel;
    Image: TImage;
    ButtonSelectPicture: TButton;
    PanelRight: TPanel;
    Splitter: TSplitter;
    ButtonCancel: TButton;
    ProgressBar: TProgressBar;
    PageControl: TPageControl;
    TabSheetText: TTabSheet;
    MemoText: TMemo;
    TabSheetHtml: TTabSheet;
    MemoHtml: TMemo;
    TabSheetUnlv: TTabSheet;
    MemoUnlv: TMemo;
    TabSheetWords: TTabSheet;
    ScrollBoxWords: TScrollBox;
    ImageWords: TImage;
    TabSheetRegions: TTabSheet;
    ScrollBoxRegions: TScrollBox;
    ImageRegions: TImage;
    TabSheetTextLines: TTabSheet;
    ScrollBoxTextLines: TScrollBox;
    ImageTextLines: TImage;
    TabSheetConnectedComponents: TTabSheet;
    ScrollBoxComponents: TScrollBox;
    ImageComponents: TImage;
    ButtonRecognize: TButton;
    TabSheetParagraphs: TTabSheet;
    ScrollBoxParagraphs: TScrollBox;
    ImageParagraphs: TImage;
    Shape: TShape;
    procedure ButtonSelectPictureClick(Sender: TObject);
    procedure ButtonRecognizeClick(Sender: TObject);
    procedure ButtonCancelClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure OcrProgress(Sender: TObject; var Cancel: Boolean; Progress,
      WordCount: Integer);
    procedure ImageMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure ImageMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure ImageMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure PanelResize(Sender: TObject);
  private
    { Private declarations }
    CancelRequest: Boolean;
    Selecting: Boolean;
  public
    { Public declarations }
  end;

var
  FormMain: TFormMain;

implementation

{$R *.dfm}

uses Jpeg
{$ifdef CONDITIONALEXPRESSIONS}
  {$if CompilerVersion >= 30} // Delphi 10
    , GIFImg, PngImage
  {$ifend}
{$endif}
;

procedure TFormMain.ButtonSelectPictureClick(Sender: TObject);
begin
  with OpenPictureDialog do
    if Execute then
    begin
      Shape.Width := 0;
      Shape.Height := 0;
      ProgressBar.Position := 0;
      MemoText.Clear;
      MemoHtml.Clear;
      MemoUnlv.Clear;
      ImageWords.Picture := nil;
      ImageRegions.Picture := nil;
      ImageTextLines.Picture := nil;
      ImageComponents.Picture := nil;
      ImageParagraphs.Picture := nil;
      
      try
        Image.Picture.LoadFromFile(FileName);
        Ocr.Picture.Assign(Image.Picture);
      except
        Image.Picture := nil;
        ShowMessage('Preview of this image cannot be displayed. Click Recognize button to start OCR.');
        Ocr.PictureFileName := FileName;
      end;

      if not Ocr.Active then
      begin
        Ocr.DataPath := ExtractFilePath(Application.ExeName);
        Ocr.Active := True;
      end;
      ButtonRecognize.Enabled := True;
      Image.Cursor := crCross;
    end
end;

function RectToImageRect(Image: TImage; Rect: TRect): TRect;
var
  w, h, cw, ch: Integer;
  xyaspect: Double;
  DrawRect: TRect;
  Temp: Integer;
begin
  w := Image.Picture.Width;
  h := Image.Picture.Height;
  cw := Image.ClientWidth;
  ch := Image.ClientHeight;
  if Image.Stretch or (Image.Proportional and ((w > cw) or (h > ch))) then
  begin
    if Image.Proportional and (w > 0) and (h > 0) then
    begin
      xyaspect := w / h;
      if w > h then
      begin
        w := cw;
        h := Trunc(cw / xyaspect);
        if h > ch then
        begin
          h := ch;
          w := Trunc(ch * xyaspect);
        end;
      end
      else
      begin
        h := ch;
        w := Trunc(ch * xyaspect);
        if w > cw then
        begin
          w := cw;
          h := Trunc(cw / xyaspect);
        end;
      end;
    end
    else
    begin
      w := cw;
      h := ch;
    end;
  end;

  with DrawRect do
  begin
    Left := 0;
    Top := 0;
    Right := w;
    Bottom := h;
  end;

  if Image.Center then
    OffsetRect(DrawRect, (cw - w) div 2, (ch - h) div 2);

  if Rect.Left > Rect.Right then
  begin
    // swap
    Temp := Rect.Left;
    Rect.Left := Rect.Right;
    Rect.Right := Temp;
  end;

  if Rect.Top > Rect.Bottom then
  begin
    // swap
    Temp := Rect.Top;
    Rect.Top := Rect.Bottom;
    Rect.Bottom := Temp;
  end;

  Result.Left := Trunc((Rect.Left - DrawRect.Left) * (Image.Picture.Width / w));
  Result.Top := Trunc((Rect.Top - DrawRect.Top) * (Image.Picture.Height / h));
  Result.Right := Trunc(Result.Left + (Rect.Right - Rect.Left) * (Image.Picture.Width / w));
  Result.Bottom := Trunc(Result.Top + (Rect.Bottom - Rect.Top) * (Image.Picture.Height / h));

  if Result.Left < 0 then
    Result.Left := 0
  else if Result.Left >= Image.Picture.Width then
    Result.Left := Image.Picture.Width - 1;

  if Result.Top < 0 then
    Result.Top := 0
  else if Result.Top >= Image.Picture.Height then
    Result.Top := Image.Picture.Height - 1;

  if Result.Right < 0 then
    Result.Right := 0
  else if Result.Right >= Image.Picture.Width then
    Result.Left := Image.Picture.Width - 1;

  if Result.Bottom < 0 then
    Result.Bottom := 0
  else if Result.Bottom >= Image.Picture.Height then
    Result.Bottom := Image.Picture.Height - 1;
end;

function RectToShapeRect(UseShape: Boolean; Rect, ShapeRect: TRect): TRect;
begin
  Result := Rect;
  if UseShape then
  begin
    Inc(Result.Left, ShapeRect.Left);
    Inc(Result.Top, ShapeRect.Top);
    Inc(Result.Right, ShapeRect.Left);
    Inc(Result.Bottom, ShapeRect.Top);
  end;
end;

procedure TFormMain.ButtonRecognizeClick(Sender: TObject);
var
  i: Integer;
  UseShape: Boolean;
  ShapeRect: TRect;
begin
  try
    ProgressBar.Position := 0;
    CancelRequest := False;
    ButtonSelectPicture.Enabled := False;
    ButtonCancel.Visible := True;
    MemoText.Clear;
    MemoHtml.Clear;
    MemoUnlv.Clear;
    ImageWords.Picture := nil;
    ImageRegions.Picture := nil;
    ImageTextLines.Picture := nil;
    ImageComponents.Picture := nil;
    ImageParagraphs.Picture := nil;

    UseShape := (Shape.Width <> 0) and (Shape.Height <> 0);
    if UseShape then
    begin
      ShapeRect := RectToImageRect(Image, Shape.BoundsRect);
      Ocr.PictureLeft := ShapeRect.Left;
      Ocr.PictureTop := ShapeRect.Top;
      Ocr.PictureWidth := ShapeRect.Right - ShapeRect.Left;
      Ocr.PictureHeight := ShapeRect.Bottom - ShapeRect.Top;
    end
    else
    begin
      Ocr.PictureLeft := 0;
      Ocr.PictureTop := 0;
      Ocr.PictureWidth := 0;
      Ocr.PictureHeight := 0;
    end;

    Repaint;
    if not CancelRequest then
      MemoText.Text := StringReplace(Ocr.Text, #$a, #$d#$a, [rfReplaceAll]);
    if not CancelRequest then
      MemoHtml.Text := StringReplace(Ocr.GetHtmlText, #$a, #$d#$a, [rfReplaceAll]);
    if not CancelRequest then
      MemoUnlv.Text := StringReplace(Ocr.Unlv, #$a, #$d#$a, [rfReplaceAll]);

    if not CancelRequest then
      ProgressBar.Position := 100
    else
      ProgressBar.Position := 0;

    if not CancelRequest then
      if Image.Picture <> nil then
      begin
        ImageWords.Picture.Bitmap.Assign(Image.Picture.Graphic);
        ImageWords.Picture.Bitmap.PixelFormat := pf32bit;
        ImageWords.Canvas.Brush.Color := TColor($007FFF);
        for i := 0 to Ocr.WordCount - 1 do
          ImageWords.Canvas.FrameRect(RectToShapeRect(UseShape, Ocr.Words[i], ShapeRect));

        ImageRegions.Picture.Bitmap.Assign(Image.Picture.Graphic);
        ImageRegions.Picture.Bitmap.PixelFormat := pf32bit;
        ImageRegions.Canvas.Brush.Color := TColor($7F00FF);
        for i := 0 to Ocr.RegionCount - 1 do
          ImageRegions.Canvas.FrameRect(RectToShapeRect(UseShape, Ocr.Regions[i], ShapeRect));

        ImageTextLines.Picture.Bitmap.Assign(Image.Picture.Graphic);
        ImageTextLines.Picture.Bitmap.PixelFormat := pf32bit;
        ImageTextLines.Canvas.Brush.Color := TColor($00FF7F);
        for i := 0 to Ocr.TextLineCount - 1 do
          ImageTextLines.Canvas.FrameRect(RectToShapeRect(UseShape, Ocr.TextLines[i], ShapeRect));

        ImageComponents.Picture.Bitmap.Assign(Image.Picture.Graphic);
        ImageComponents.Picture.Bitmap.PixelFormat := pf32bit;
        ImageComponents.Canvas.Brush.Color := TColor($FF7F00);
        for i := 0 to Ocr.ConnectedComponentCount - 1 do
          ImageComponents.Canvas.FrameRect(RectToShapeRect(UseShape, Ocr.ConnectedComponents[i], ShapeRect));

        ImageParagraphs.Picture.Bitmap.Assign(Image.Picture.Graphic);
        ImageParagraphs.Picture.Bitmap.PixelFormat := pf32bit;
        ImageParagraphs.Canvas.Brush.Color := TColor($7FFF00);
        for i := 0 to Ocr.ParagraphCount - 1 do
          ImageParagraphs.Canvas.FrameRect(Ocr.Paragraphs[i].Location);
      end;
  finally
    ButtonCancel.Visible := False;
    ButtonSelectPicture.Enabled := True;
  end;
end;

procedure TFormMain.ButtonCancelClick(Sender: TObject);
begin
  CancelRequest := True;
end;

procedure TFormMain.FormCreate(Sender: TObject);
begin
  ShowMessage('OCR recognition can be slow when application is started from Delphi IDE.');
end;

procedure TFormMain.OcrProgress(Sender: TObject; var Cancel: Boolean;
  Progress, WordCount: Integer);
begin
  ProgressBar.Position := Progress;
  Application.ProcessMessages; // so we are able to click Cancel button
  Cancel := CancelRequest;
end;

procedure TFormMain.ImageMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Ocr.Active then
    if Button = mbLeft then
    begin
      Selecting := True;
      Shape.Left := X;
      Shape.Top := Y;
      Shape.Width := 0;
      Shape.Height := 0;
    end;
end;

procedure TFormMain.ImageMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
  if Selecting then
  begin
    Shape.Width := X - Shape.Left;
    Shape.Height := Y - Shape.Top;
  end;
end;

procedure TFormMain.ImageMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
  if Selecting then
  begin
    Selecting := False;
    Shape.Width := X - Shape.Left;
    Shape.Height := Y - Shape.Top;
    Repaint;
  end;
end;

procedure TFormMain.PanelResize(Sender: TObject);
begin
  Shape.Width := 0;
  Shape.Height := 0;
end;

end.