freepascal.compiler/packages/ptc/examples/modes.pp

{
Ported to FPC by Nikolay Nikolov ([email protected])
}

{
 Modes example for OpenPTC 1.0 C++ implementation
 Copyright (c) Glenn Fiedler ([email protected])
 This source code is in the public domain
}

program ModesExample;

{$MODE objfpc}

uses
  ptc;

procedure print(const format: TPTCFormat);
begin
  { check format type }
  if format.direct then
    { check alpha }
    if format.a = 0 then
      { direct color format without alpha }
      Write('Format(', format.bits:2, ',$', HexStr(format.r, 8), ',$', HexStr(format.g, 8), ',$', HexStr(format.b, 8), ')')
    else
      { direct color format with alpha }
      Write('Format(', format.bits:2, ',$', HexStr(format.r, 8), ',$', HexStr(format.g, 8), ',$', HexStr(format.b, 8), ',$', HexStr(format.a, 8), ')')
  else
    { indexed color format }
    Write('Format(', format.bits:2, ')');
end;

procedure print(const mode: TPTCMode);
begin
  { print mode width and height }
  Write(' ', mode.width:4, ' x ', mode.height);
  if mode.height < 1000 then
    Write(' ');
  if mode.height < 100 then
    Write(' ');
  if mode.height < 10 then
    Write(' ');
  Write(' x ');

  { print mode format }
  print(mode.format);

  { newline }
  Writeln;
end;

var
  console: TPTCConsole = nil;
  modes: PPTCMode;
  index: Integer;
begin
  try
    try
      { create console }
      console := TPTCConsole.Create;

      { get list of console modes }
      modes := console.modes;

      { check for empty list }
      if not modes[0].valid then
        { the console mode list was empty }
        Writeln('[console mode list is not available]')
      else
      begin
        { print mode list header }
        Writeln('[console modes]');

        { mode index }
        index := 0;

        { iterate through all modes }
        while modes[index].valid do
        begin
          { print mode }
          print(modes[index]);

          { next mode }
          Inc(index);
        end;
      end;
    finally
      console.Free;
    end;
  except
    on error: TPTCError do
      { report error }
      error.report;
  end;
end.