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

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

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

program ImageExample;

{$MODE objfpc}

uses
  SysUtils, ptc;

procedure load(surface: TPTCSurface; filename: String);
var
  F: File;
  width, height: Integer;
  pixels: PByte = nil;
  y: Integer;
  img_format: TPTCFormat = nil;
  img_palette: TPTCPalette = nil;
begin
  { open image file }
  AssignFile(F, filename);
  Reset(F, 1);

  try
    { skip header }
    Seek(F, 18);

    { get surface dimensions }
    width := surface.width;
    height := surface.height;

    { allocate image pixels }
    pixels := GetMem(width * height * 3);

    { read image pixels one line at a time }
    for y := height - 1 DownTo 0 do
      BlockRead(F, pixels[width * y * 3], width * 3);

    { load pixels to surface }
    {$IFDEF FPC_LITTLE_ENDIAN}
    img_format := TPTCFormat.Create(24, $00FF0000, $0000FF00, $000000FF);
    {$ELSE FPC_LITTLE_ENDIAN}
    img_format := TPTCFormat.Create(24, $000000FF, $0000FF00, $00FF0000);
    {$ENDIF FPC_LITTLE_ENDIAN}
    img_palette := TPTCPalette.Create;
    surface.load(pixels, width, height, width * 3, img_format, img_palette);

  finally
    CloseFile(F);

    { free image pixels }
    FreeMem(pixels);

    img_palette.Free;
    img_format.Free;
  end;
end;

var
  console: TPTCConsole = nil;
  format: TPTCFormat = nil;
  surface: TPTCSurface = nil;
begin
  try
    try
      { create console }
      console := TPTCConsole.Create;

      { create format }
      format := TPTCFormat.Create(32, $00FF0000, $0000FF00, $000000FF);

      try
        { try to open the console matching the image resolution }
        console.open('Image example', 320, 200, format);
      except
        on TPTCError do
          { fallback to the default resolution }
          console.open('Image example', format);
      end;

      { create surface }
      surface := TPTCSurface.Create(320, 200, format);

      { load image to surface }
      load(surface, 'image.tga');

      { copy surface to console }
      surface.copy(console);

      { update console }
      console.update;

      { read key }
      console.ReadKey;

    finally
      { close console }
      console.close;

      console.Free;
      surface.Free;
      format.Free;
    end;
  except
    on error: TPTCError do
      { report error }
      error.report;
  end;
end.