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

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

{
 Land demo for OpenPTC 1.0 C++ API

 Based on Heightmap example from Hornet (RIP)
 PTC version Copyright (c) 1998 Marcus Fletcher ([email protected])

 Updated to OpenPTC 1.0 by Glenn Fiedler ([email protected])

 Cursor keys to move, <Pause> to brake and <Esc> to quit
}

program Land;

{$MODE objfpc}

uses
  ptc;

const
  SCREENWIDTH = 320;
  SCREENHEIGHT = 200;

  FOV: Integer = 256; { half of the xy field of view (This is based on the 0-2048 convention) }

var
  HMap: array [0..256*256 - 1] of Uint8; { Height field }
  CMap: array [0..256*256 - 1] of Uint8; { Color map }

  lasty, { Last pixel drawn on a given column }
  lastc: array [0..SCREENWIDTH - 1] of Integer; { Color of last pixel on a column }
  CosT, SinT: array [0..2047] of Integer; { Cosine and Sine tables }

{ Reduces a value to 0..255 (used in height field computation) }
function Clamp(x: Integer): Integer;
begin
  if x < 0 then
    Result := 0
  else
    if x > 255 then
      Result := 255
    else
      Result := x;
end;

{ Heightfield and colormap computation }
procedure ComputeMap;
var
  p, i, j, k, k2, p2, a, b, c, d: Integer;
begin
  { Start from a plasma clouds fractal }
  HMap[0] := 128;
  p := 256;
  while p > 1 do
  begin
    p2 := p shr 1;
    k := p * 8 + 20;
    k2 := k shr 1;
    i := 0;
    while i < 256 do
    begin
      j := 0;
      while j < 256 do
      begin
        a := HMap[(i shl 8) + j];
        b := HMap[(((i + p) and 255) shl 8) + j];
        c := HMap[(i shl 8) + ((j + p) and 255)];
        d := HMap[(((i + p) and 255) shl 8) + ((j + p) and 255)];

        HMap[(i shl 8) + ((j + p2) and 255)] :=
          Clamp(((a + c) shr 1) + (Random(k) - k2));
        HMap[(((i + p2) and 255) shl 8) + ((j + p2) and 255)] :=
          Clamp(((a + b + c + d) shr 2) + (Random(k) - k2));
        HMap[(((i + p2) and 255) shl 8) + j] :=
          Clamp(((a + b) shr 1) + (Random(k) - k2));
        Inc(j, p);
      end;
      Inc(i, p);
    end;
    p := p2;
  end;

  { Smoothing }
  for k := 0 to 2 do
  begin
    i := 0;
    while i < 256*256 do
    begin
      for j := 0 to 255 do
        HMap[i + j] := (HMap[((i + 256) and $FF00) + j] +
                        HMap[i + ((j + 1) and $FF)] +
                        HMap[((i - 256) and $FF00) + j] +
                        HMap[i + ((j - 1) and $FF)]) shr 2;
      Inc(i, 256);
    end;
  end;

  { Color computation (derivative of the height field) }
  i := 0;
  while i < 256*256 do
  begin
    for j := 0 to 255 do
    begin
      k := 128 + (HMap[((i + 256) and $FF00) + ((j + 1) and 255)] - HMap[i + j])*4;
      if k < 0 then
        k := 0;
      if k > 255 then
        k := 255;
      CMap[i + j] := k;
    end;
    Inc(i, 256);
  end;
end;

{ Calculate the lookup tables }
procedure InitTables;
var
  a: Integer;
  result: Single;
begin
  for a := 0 to 2047 do
  begin
    { Precalculate cosine }
    result := cos(a * PI / 1024) * 256;
    CosT[a] := Trunc(result);

    { and sine }
    result := sin(a * PI / 1024) * 256;
    SinT[a] := Trunc(result);
  end;
end;

{
 Draw a "section" of the landscape; x0,y0 and x1,y1 and the xy coordinates
 on the height field, hy is the viewpoint height, s is the scaling factor
 for the distance. x0,y0,x1,y1 are 16.16 fixed point numbers and the
 scaling factor is a 16.8 fixed point value.
}
procedure Line(x0, y0, x1, y1, hy, s: Integer; surface_buffer: PUint32; fadeout: Integer);
var
  sx, sy, i, a, b, u0, u1, v0, v1, h0, h1, h2, h3, h, c, y: Integer;
  coord_x, coord_y, sc, cc, currentColor: Integer;
  pixel: PUint32;
begin
  { Compute xy speed }
  sx := (x1 - x0) div SCREENWIDTH;
  sy := (y1 - y0) div SCREENWIDTH;

  for i := 0 to SCREENWIDTH - 1 do
  begin
    { Compute the xy coordinates; a and b will be the position inside the }
    { single map cell (0..255). }
    a := (x0 shr 8) and $FF;
    b := (y0 shr 8) and $FF;

    u0 := (x0 shr 16) and $FF;
    u1 := (u0 + 1) and $FF;
    v0 := (y0 shr 8) and $FF00;
    v1 := (v0 + 256) and $FF00;

    { Fetch the height at the four corners of the square the point is in }
    h0 := HMap[u0 + v0];
    h1 := HMap[u1 + v0];
    h2 := HMap[u0 + v1];
    h3 := HMap[u1 + v1];

    { Compute the height using bilinear interpolation }
    h0 := (h0 shl 8) + a * (h1 - h0);
    h2 := (h2 shl 8) + a * (h3 - h2);
    h := ((h0 shl 8) + b * (h2 - h0)) shr 16;

    { Fetch the color at the centre of the square the point is in }
    h0 := CMap[u0 + v0];
    h1 := CMap[u1 + v0];
    h2 := CMap[u0 + v1];
    h3 := CMap[u1 + v1];

    { Compute the color using bilinear interpolation (in 16.16) }
    h0 := (h0 shl 8) + a * (h1 - h0);
    h2 := (h2 shl 8) + a * (h3 - h2);
    c := ((h0 shl 8) + b * (h2 - h0));

    { Compute screen height using the scaling factor }
    y := (((h - hy) * s) shr 11) + (SCREENHEIGHT shr 1);

    { Draw the column }
    a := lasty[i];
    if y < a then
    begin
      coord_x := i;
      coord_y := a;
      if lastc[i] = -1 then
        lastc[i] := c;

      sc := (c - lastc[i]) div (a - y);
      cc := lastc[i];

      if a > (SCREENHEIGHT - 1) then
      begin
        Dec(coord_y, a - (SCREENHEIGHT - 1));
        a := SCREENHEIGHT - 1;
      end;
      if y < 0 then
        y := 0;

      while y < a do
      begin
        currentColor := cc shr 18;
        pixel := surface_buffer + (coord_y * SCREENWIDTH) + coord_x;
        pixel^ := ((currentColor shl 2) * (150 - fadeout) div 150) shl 8;
        Inc(cc, sc);
        Dec(coord_y);
        Dec(a);
      end;
      lasty[i] := y;
    end;
    lastc[i] := c;

    { Advance to next xy position }
    Inc(x0, sx); Inc(y0, sy);
  end;
end;

{ Draw the view from the point x0,y0 (16.16) looking at angle a }
procedure View(x0, y0, angle, height: Integer; surface_buffer: PUint32);
var
  d, u0, a, v0, u1, v1, h0, h1, h2, h3: Integer;
begin
  { Initialize last-y and last-color arrays }
  for d := 0 to SCREENWIDTH - 1 do
  begin
    lasty[d] := SCREENHEIGHT;
    lastc[d] := -1;
  end;

  { Compute the xy coordinates; a and b will be the position inside the }
  { single map cell (0..255). }
  u0 := (x0 shr 16) and $FF;
  a := (x0 shr 8) and $FF;
  v0 := (y0 shr 8) and $FF00;
  u1 := (u0 + 1) and $FF;
  v1 := (v0 + 256) and $FF00;

  { Fetch the height at the four corners of the square the point is in }
  h0 := HMap[u0 + v0];
  h1 := HMap[u1 + v0];
  h2 := HMap[u0 + v1];
  h3 := HMap[u1 + v1];

  { Compute the height using bilinear interpolation }
  h0 := (h0 shl 8) + a * (h1 - h0);
  h2 := (h2 shl 8) + a * (h3 - h2);

  { Draw the landscape from near to far without overdraw }
  d := 0;
  while d < 150 do
  begin
    Line(x0 + (d shl 8)*CosT[(angle - FOV) and $7FF],
         y0 + (d shl 8)*SinT[(angle - FOV) and $7FF],
         x0 + (d shl 8)*CosT[(angle + FOV) and $7FF],
         y0 + (d shl 8)*SinT[(angle + FOV) and $7FF],
         height, (100 shl 8) div (d + 1),
         surface_buffer,
         d);
    Inc(d, 1 + (d shr 6));
  end;
end;

var
  format: IPTCFormat;
  console: IPTCConsole;
  surface: IPTCSurface;
  timer: IPTCTimer;
  key: IPTCKeyEvent;
  pixels: PUint32;
  Done: Boolean;

  x0, y0: Integer;
  height: Integer;
  angle, deltaAngle, deltaSpeed, CurrentSpeed, scale, delta: Double;
  index: Integer;
begin
  Done := False;
  try
    try
      format := TPTCFormatFactory.CreateNew(32, $00FF0000, $0000FF00, $000000FF);
      console := TPTCConsoleFactory.CreateNew;
      console.open('Land demo', SCREENWIDTH, SCREENHEIGHT, format);
      surface := TPTCSurfaceFactory.CreateNew(SCREENWIDTH, SCREENHEIGHT, format);

      { Compute the height map }
      ComputeMap;
      InitTables;

      x0 := 0;
      y0 := 0;

      height := -200;
      angle := 0;
      deltaAngle := 0;
      deltaSpeed := 4096;
      CurrentSpeed := deltaSpeed * 10;

      { time scaling constant }
      scale := 20;

      { create timer }
      timer := TPTCTimerFactory.CreateNew;

      { start timer }
      timer.start;

      { main loop }
      repeat
        { get time delta between frames }
        delta := timer.delta;

        { clear surface }
        surface.clear;

        { lock surface pixels }
        pixels := surface.lock;
        try
          { draw current landscape view }
          View(x0, y0, Trunc(angle), height, pixels);
        finally
          { unlock surface }
          surface.unlock;
        end;

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

        { update console }
        console.update;

        { check key press }
        while console.KeyPressed do
        begin
          { read key press }
          console.ReadKey(key);

          { handle key press }
          case key.code of
                        { increase speed }
            PTCKEY_UP: CurrentSpeed := CurrentSpeed + deltaSpeed * delta * scale;
                        { decrease speed }
            PTCKEY_DOWN: CurrentSpeed := CurrentSpeed - deltaSpeed * delta * scale;
                        { turn to the left }
            PTCKEY_LEFT: deltaAngle := deltaAngle - 1;
                        { turn to the right }
            PTCKEY_RIGHT: deltaAngle := deltaAngle + 1;
            PTCKEY_SPACE: begin
              { stop moving }
              CurrentSpeed := 0;
              deltaAngle := 0;
            end;
                           { exit }
            PTCKEY_ESCAPE: Done := True;
          end;
        end;

        { Update position/angle }
        angle := angle + deltaAngle * delta * scale;

        index := Trunc(angle) and $7FF;
        Inc(x0, Trunc(CurrentSpeed * CosT[index]) div 256);
        Inc(y0, Trunc(CurrentSpeed * SinT[index]) div 256);
      until Done;
    finally
      if Assigned(console) then
        console.close;
    end;
  except
    on error: TPTCError do
      { report error }
      error.report;
  end;
end.