unit AppConsole;

interface

uses Winapi.Windows, System.SysUtils, System.Classes, System.StrUtils, System.Math, System.SyncObjs, System.Generics.Collections;

type
  TCoordHelper = record helper for TCoord
    constructor Create(aX, aY :smallint);
  end;

  TCharArray  = set of char;

  TSelectOption = record
                    Text    :string;
                    Options :TCharArray;
                    Color   :word;
                  end;

  Console = class abstract
  private type
    TStatus     = TDictionary<integer, TCoord>;
    TStepFunc   = reference to function :boolean;

  private
    class var Input   :THandle;
    class var Output  :THandle;
    class var Status  :TStatus;
    class var Lock    :TCriticalSection;
    class var Counter :cardinal;

    class var FLineLength    :integer;
    class var FStatusError   :string;
    class var FStatusSuccess :string;

    class procedure Call(aProc :TProc);

  public const
    Default       = FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_BLUE;
    White         = FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_BLUE or FOREGROUND_INTENSITY;
    Red           = FOREGROUND_RED or FOREGROUND_INTENSITY;
    DarkRed       = FOREGROUND_RED;
    Green         = FOREGROUND_GREEN or FOREGROUND_INTENSITY;
    DarkGreen     = FOREGROUND_GREEN;
    Blue          = FOREGROUND_BLUE or FOREGROUND_INTENSITY;
    DarkBlue      = FOREGROUND_BLUE;
    Yellow        = FOREGROUND_RED or FOREGROUND_GREEN or FOREGROUND_INTENSITY;
    DarkYellow    = FOREGROUND_RED or FOREGROUND_GREEN;
    Purple        = FOREGROUND_RED or FOREGROUND_BLUE or FOREGROUND_INTENSITY;
    DarkPurple    = FOREGROUND_RED or FOREGROUND_BLUE;
    SkyBlue       = FOREGROUND_GREEN or FOREGROUND_BLUE or FOREGROUND_INTENSITY;
    DarkSkyBlue   = FOREGROUND_GREEN or FOREGROUND_BLUE;

    BkWhite       = BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_BLUE or BACKGROUND_INTENSITY;
    BkSilver      = BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_BLUE;
    BkRed         = BACKGROUND_RED or BACKGROUND_INTENSITY;
    BkDarkRed     = BACKGROUND_RED;
    BkGreen       = BACKGROUND_GREEN or BACKGROUND_INTENSITY;
    BkDarkGreen   = BACKGROUND_GREEN;
    BkBlue        = BACKGROUND_BLUE or BACKGROUND_INTENSITY;
    BkDarkBlue    = BACKGROUND_BLUE;
    BkYellow      = BACKGROUND_RED or BACKGROUND_GREEN or BACKGROUND_INTENSITY;
    BkDarkYellow  = BACKGROUND_RED or BACKGROUND_GREEN;
    BkPurple      = BACKGROUND_RED or BACKGROUND_BLUE or BACKGROUND_INTENSITY;
    BkDarkPurple  = BACKGROUND_RED or BACKGROUND_BLUE;
    BkSkyBlue     = BACKGROUND_GREEN or BACKGROUND_BLUE or BACKGROUND_INTENSITY;
    BkDarkSkyBlue = BACKGROUND_GREEN or BACKGROUND_BLUE;

  public
    class property    LineLength :integer read FLineLength write FLineLength;
    class property    StatusError :string read FStatusError write FStatusError;
    class property    StatusSuccess :string read FStatusSuccess write FStatusSuccess;

    class function    GetBufferInfo :TConsoleScreenBufferInfo;
    class function    GetPos :TCoord;
    class function    SetPos(aPos :TCoord) :TCoord;

    class procedure   Clear;

    class function    WaitInput(aOptions :TCharArray; const aText :string = ''; aColor :word = Default) :AnsiChar; overload;
    class function    WaitInput(aOptions :TSelectOption) :AnsiChar; overload;

    class procedure   Write(const aText :string = ''; aColor :word = Default);
    class procedure   WriteLn(const aText :string = ''; aColor :word = Default);
    class procedure   WriteHeader(const aText :string; aColor :word = White; aChar :char = '-');
    class procedure   WriteRule(aColor :word = Default; aChar :char = '-');
    class function    WriteTask(const aText :string; aFunc :TStepFunc; aColor :word = Default) :boolean;

    class Constructor Create;
    class destructor  Destroy;
  end;

implementation

{ TCoordHelper }

constructor TCoordHelper.Create(aX, aY: smallint);
begin
  X := aX;
  Y := aY;
end;

{ Console }

class procedure Console.Clear;
begin
  const Size    = GetBufferInfo.dwSize;
  const TopLeft = TCoord.Create(0, 0);
  var   Written :cardinal;

  FillConsoleOutputCharacterA(Output, ' ', Size.X *Size.Y, TopLeft, Written);
  FillConsoleOutputAttribute(Output, Default,Size.X *Size.Y, TopLeft, Written);
  SetConsoleCursorPosition(Output, TopLeft);
end;

class constructor Console.Create;
begin
  Input  := GetStdHandle(STD_INPUT_HANDLE);
  Output := GetStdHandle(STD_OUTPUT_HANDLE);

  Status := TStatus.Create;
  Lock   := TCriticalSection.Create;

  FLineLength    := 80;
  FStatusSuccess := 'SUCCES';
  FStatusError   := 'ERREUR';
end;

class destructor Console.Destroy;
begin
  Status.Free;
  Lock.Free;
end;

class procedure Console.Call(aProc: TProc);
begin
  Lock.Acquire;
  try
    aProc;
  finally
    Lock.Release;
  end;
end;

class function Console.GetBufferInfo: TConsoleScreenBufferInfo;
begin
  GetConsoleScreenBufferInfo(Output, Result);
end;

class function Console.GetPos: TCoord;
begin
  var Coord :TCoord;

  Call(procedure
       begin
         Coord := GetBufferInfo.dwCursorPosition;
       end);

  Result := Coord;
end;

class function Console.SetPos(aPos: TCoord): TCoord;
begin
  var Coord :TCoord;

  Call(procedure
       begin
         Coord := GetPos;
         SetConsoleCursorPosition(Output, aPos);
       end);

  Result := Coord;
end;

class function Console.WaitInput(aOptions: TCharArray; const aText :string; aColor :word): AnsiChar;
begin
  var Rec  :TInputRecord;
  var Read :cardinal;
  var c    :AnsiChar;
  var Opts :TCharArray := [];

  for var Opt in aOptions do
    Include(Opts, UpCase(Opt));

  if not aText.IsEmpty then
    WriteLn(aText, aColor);

  repeat
    ReadConsoleInput(Input, Rec, 1, Read);
    c := UpCase(Rec.Event.KeyEvent.AsciiChar);
  until (Rec.EventType = KEY_EVENT) and not Rec.Event.KeyEvent.bKeyDown and (c in Opts);

  Result := c;
end;

class function Console.WaitInput(aOptions: TSelectOption): AnsiChar;
begin
  Result := WaitInput(aOptions.Options, aOptions.Text, aOptions.Color);
end;

class procedure Console.Write(const aText: string; aColor: word);
begin
  Call(procedure
       begin
         SetConsoleTextAttribute(Output, aColor);
         System.Write(aText);
       end);
end;

class procedure Console.WriteLn(const aText: string; aColor: word);
begin
  Call(procedure
       begin
         var dY := 0;
         SetConsoleTextAttribute(Output, aColor);

         for var Text in aText.Split([#13#10, #13]) do
         begin
           const Pos = GetPos;
           System.WriteLn(Text);

           if Pos.Y = GetPos.Y then
             Inc(dY);
         end;

         if dY > 0 then
           for var S in Status do
           begin
             var Coord := S.Value;
             Dec(Coord.Y, dY);
             Status.AddOrSetValue(S.Key, Coord);
           end;
       end);
end;

class procedure Console.WriteRule(aColor: word; aChar: char);
begin
  if GetPos.X > 0 then
    System.WriteLn;

  WriteLn(StringOfChar(aChar, FLineLength), aColor);
end;

class procedure Console.WriteHeader(const aText: string; aColor :word; aChar :char);
begin
  WriteLn(#13 +aText +#13 +StringOfChar(aChar, aText.Length) +#13, aColor);
end;

class function Console.WriteTask(const aText: string; aFunc: TStepFunc; aColor :word) :boolean;
begin
  var ID  := TInterlocked.Increment(Counter);
  var Res := FALSE;

  try
    Call(procedure
         begin
           var Coord := GetPos;
           const StatusLen = Max(FStatusSuccess.Length, FStatusError.Length);
           const Sep = StringOfChar('.', LineLength -Coord.X -StatusLen -aText.Length -2);

           Coord.X := LineLength -StatusLen -1;

           Status.Add(ID, Coord);

           WriteLn(Format('%s%s[%*.s]', [aText, Sep, StatusLen, ' ']), aColor);
         end);

    Res := aFunc;

  except
    on E:Exception do
      WriteLn(E.Message, Red);
  end;

  Call(procedure
       begin
         const Coord = Status.ExtractPair(ID).Value;

         if Coord.Y > -1 then
         begin
           const Pos = SetPos(Coord);
           Write(IfThen(Res, FStatusSuccess, FStatusError), IfThen(Res, DarkGreen, DarkRed));
           SetPos(Pos);
         end;
       end);

  Result := Res;
end;

end.