Unit1.pas (3) of dtm_maker

unit Unit1;

{$R *.lfm}

{$MODE Delphi}

interface

uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Menus,
  StdCtrls, LResources, fgl;

{  Digital Terrain Model Maker - Island Maker

   Language: Lazarus
   Author:   Peter E. Williams
   Date:     12 March 2011
   Version:  0.01 beta 2

   Description: The original idea for this program was to write a random
     island DTM generator which goes on a random walk defining the
     _outline_ of the island. Therefore, it was my original intention
     that areas of "sea" which are land-locked should in some later process
     be marked as land (since the program is really only defining a
     coast-line).

     Island map is generated starting with a "*" and ending with a "@".
     All points in between go in the sequence A..Z..1..9 and repeat. This
     is simply to show the sequence in which the points were generated.

     Next steps would required an expanded "map_detail" record.

     The classical next steps would be to:
        (a) mark land-locked water as land,
        (b) randomly pick a point of land then go on a "short" random
            walk to define the top of a mountain range,
        (c) do same as (b) but for a valley,
        (d) run an algorithm to graduate the elevation levels of land
            between mountain range and valley.
        (e) generate a few number of random spots and define them
            as towns.
        (f) do a series of "short" random walks (similar to (b)) to
            define vegetation types, roads, railroads, rivers, etc.
            Obviously river flows would be determined by elevation
            levels. Logically roads and railroads would connect towns
            [placed in (e)] so would be logical to _start_
            roads/railroads random walks at these points.

     I have had a good book which discusses these types of algorithms
     which I bought many years ago... it's called "Games Programming".
     If anyone's interested I'll be happy to post the details of it
     when I get home - or I'll bring it along to the next SIG I go to.

          UP
          9
      NW  N  NE
        8 1 2
      W 7   3 E
        6 5 4
      SW  S  SE
          10
         DOWN

}

const
  array_max_x = 1000;
  array_max_y = 1000;
  default_max_x = 90; // horizontal
  default_max_y = 35; // vertical
  max_directions = 10;

type
  directions = 1..max_directions;
  directions_text_type = array[directions] of string;

const
  directions_text : directions_text_type =
    ('North', 'North-East', 'East', 'South-East', 'South', 'South-West', 'West', 'North-West', 'Up', 'Down' );

type
  Terrain_type = (Land, Sea);

  exit_type = array[ directions ] of integer;

  description_type = array[1..2] of string;

  Tmap_detail = Object
                 FTerrain : Terrain_type;
                 FTerrain_char : char;
                 Fdescription : description_type;
                 Fx, Fy, Flocation_number : integer;
                 Fexits : exit_type;
               end;

  // The Island class definition
  Generic TIsland<T> = class
      Items : array of Tmap_detail;
    public
    constructor Create(AList: TList);
    procedure Add( Value : Tmap_detail );
  end;

  island_2D_type = array[ 1..array_max_x, 1..array_max_y ] of
                     Tmap_detail;

{
  island_single_type = array[ 1..(array_max_x * array_max_y) ] of
                         map_detail;
}

  // The form class definition

  { TForm1 }

  TForm1 = class(TForm)
    File1: TMenuItem;
    MainMenu1: TMainMenu;
    CreateANewIsland: TMenuItem;
    Memo1: TMemo;
    Options: TMenuItem;
    SaveIslandToFile: TMenuItem;
    SaveDialog1: TSaveDialog;
    procedure CreateANewIslandClick(Sender: TObject);
    procedure OptionsClick(Sender: TObject);
    procedure SaveIslandToFileClick(Sender: TObject);
    procedure show_island( start_x, start_y, finish_x, finish_y, max_locations : integer);
    procedure make_an_island;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
    // The TList object we use in this code

    // Method to show the contents of our list object
    procedure ShowListContents;

    { Public declarations }
  public

  end;

var
  Form1: TForm1;
  Island : TIsland;
  Island_2D : island_2D_type;
  max_x, max_y,
  location_counter,
  max_locations,
  start_x, start_y,
  finish_x, finish_y : integer;

implementation

uses set_max;

{$R *.lfm}

procedure TIsland.Add(Value: T);
begin
  SetLength(Items, Length(Items) + 1);
  Items[Length(Items) - 1] := Value;
end;
{--------------------------------------------------------------------}

procedure TIsland.Create(AList : TList);
begin
  inherited Create;
  self.FMap_detail := AList;
end
{--------------------------------------------------------------------}

// TList sort routine : compare Islands by name
// --------------------------------------------------------------------------
// The returned integer has the following value :
//
//   > 0 : (positive)   Item1 is less than Item2
//     0 : Item1 is equal to Item2
//   < 0 : (negative)   Item1 is greater than Item2
function compareByLocationNumber(Item1 : Pointer; Item2 : Pointer) : Integer;
var
  Island1, Island2 : TIsland;
begin
  // We start by viewing the object pointers as TIsland objects
  Island1 := TIsland(Item1);
  Island2 := TIsland(Item2);

  // Now compare by string
  if Island1.Flocation_number > Island2.Flocation_number then
    Result := 1
  else
    if Island1.Flocation_number = Island2.Flocation_number then
      Result := 0
    else
      Result := -1;
end;
{--------------------------------------------------------------------}

procedure blank_island;
var
  j,k,d : integer;
begin
  for j := 1 to max_x do
    for k := 1 to max_y do
    begin
      Island_2D[ j,k ].FTerrain := Sea;
      Island_2D[ j,k ].FTerrain_char := '.';
      Island_2D[ j,k ].Fdescription[1] := '';
      Island_2D[ j,k ].Fdescription[2] := '';
      Island_2D[ j,k ].Fx := 0;
      Island_2D[ j,k ].Fy := 0;
      Island_2D[ j,k ].Flocation_number := 0;
      for d := 1 to max_directions do
        Island_2D[ j,k ].Fexits[ d ] := 0;
    end;
  max_locations := trunc( max_x * max_y / 1.575 ); // gives 2000 for 35 x 90
end; { blank_island }
{--------------------------------------------------------------------}

{
          UP
          9
      NW  N  NE
        8 1 2
      W 7   3 E
        6 5 4
      SW  S  SE
          10
         DOWN
}

procedure define_island_outline( var start_x, start_y,
  finish_x, finish_y: integer;
  var location_counter, max_locations : integer );
var
  got_good_dir : boolean;
  old_x, old_y,
  j,
  current_x, current_y : integer;
  new_direction_int,
  old_direction_int,
  opposite_direction : directions;
  char1 : char;
  temp_direction : directions;
begin
  current_x := random( max_x ) + 1;
  current_y := random( max_y ) + 1;
  start_x := current_x;
  start_y := current_y;
  location_counter := 1;
  old_x := 0;
  old_y := 0;
  old_direction_int := 1; //north
  temp_direction := 1; //north
  char1 := '9'; // this will mean that the sequence starts with an "A"
  Island_2D[ current_x, current_y ].FTerrain := Land;
  Island_2D[ current_x, current_y ].FTerrain_char := '*';
  max_locations := trunc( max_x * max_y / 1.575 ); // gives 2000 for 35 x 90

  j := 1;
  while (j <= max_locations) do
  begin
    repeat
{
          UP
          9
      NW  N  NE
        8 1 2
      W 7   3 E
        6 5 4
      SW  S  SE
          10
         DOWN
}
      new_direction_int := random( max_directions ) + 1;
      got_good_dir := true;

      // we don't want to go straight back where we came from
      if abs(new_direction_int - old_direction_int) = 4 then
        got_good_dir := false;

      if ((old_direction_int = 9) and (new_direction_int = 10)) or
         ((old_direction_int = 10) and (new_direction_int = 9)) then
        got_good_dir := false;

      // next 4 tests are to keep from going outside the bounds of the map.
      if (new_direction_int in [ 2..4 ]) and (current_x >= max_x) then
        got_good_dir := false;
      if (new_direction_int in [ 8,1,2 ]) and (current_y <= 1) then
        got_good_dir := false;
      if (new_direction_int in [ 6..8 ]) and (current_x <= 1) then
        got_good_dir := false;
      if (new_direction_int in [ 4..6 ]) and (current_y >= max_y) then
        got_good_dir := false;

    until got_good_dir;


    if new_direction_int in [6,7,8] then
      current_x := current_x - 1;

    if new_direction_int in [2,3,4] then
      current_x := current_x + 1;

    if new_direction_int in [8,1,2] then
      current_y := current_y - 1;

    if new_direction_int in [6,5,4] then
      current_y := current_y + 1;

    if not ((current_x in [ 1..max_x ]) and (current_y in [ 1..max_y ])) then
    begin
      showmessage( 'Error [index(es) out of range]:' + #13 +
                   'current_x = ' + inttostr( current_x ) + #13 +
                   'current_y = ' + inttostr( current_y ) + #13 +
                   'new_direction = ' + inttostr( new_direction_int) + #13 +
                   'old_direction = ' + inttostr( old_direction_int) );
      if current_x < 1 then
        current_x := 1;
      if current_x > max_x then
        current_x := max_x;
      if current_y < 1 then
        current_y := 1;
      if current_y > max_y then
        current_y := max_y;
    end
    else
    begin
      // first land_char is '*', last is '@'
      if j = max_locations then
      begin
        Island_2D[ current_x, current_y ].FTerrain_char := '@';
        finish_x := current_x;
        finish_y := current_y;
        inc(location_counter);
      end
      else
      begin
        if Island_2D[ current_x, current_y ].FTerrain = Sea then
        begin
          inc(location_counter);
          Island_2D[ current_x, current_y ].FTerrain := Land;
          // land_char will be A..Z..1..9 then repeat
          if char1 = '9' then
            char1 := 'A'
          else
            char1 := chr( ord( char1 ) + 1 );
            if char1 > 'Z' then
              char1 := '1';
          Island_2D[ current_x, current_y ].Fx := current_x;
          Island_2D[ current_x, current_y ].Fy := current_y;
          Island_2D[ current_x, current_y ].FTerrain_char := char1;
          Island_2D[ current_x, current_y ].Flocation_number := j;
          if j = 1 then
            Island_2D[ current_x, current_y ].Fdescription[1] := 'The entrance to the dungeons.'
          else
            Island_2D[ current_x, current_y ].Fdescription[1] := 'Game location #' + inttostr(j);

          Island_2D[ current_x, current_y ].Fdescription[2] := 'Exit to the ' + directions_text[ new_direction_int ];

          if (old_x > 0) and (old_y > 0) then
          begin
            Island_2D[ old_x, old_y ].Fexits[ old_direction_int ] := j;
            Island_2D[ current_x, current_y ].Fdescription[2] := 'Exits to the ' + directions_text[ old_direction_int ] +
              ' and ' + directions_text[ new_direction_int ];
          end;

          if old_direction_int <= 4 then
            opposite_direction := old_direction_int + 4
          else
            opposite_direction := old_direction_int - 4;

          if old_direction_int = 9 then
            opposite_direction := 10;

          if old_direction_int = 10 then
            opposite_direction := 9;

          Island_2D[ current_x, current_y ].Fexits[ opposite_direction ] := j-1;

          old_direction_int := new_direction_int;
          old_x := current_x;
          old_y := current_y;
        end; // then
      end; // else
    end; // else
    inc(j);
  end; // while j
end; { define_island_outline }
{--------------------------------------------------------------------}

procedure tform1.show_island( start_x, start_y, finish_x, finish_y, max_locations : integer);
var
  temp_str1 : string;
  j, k : integer;
begin
  memo1.lines.clear;
  for j := 1 to max_y do
  begin
    temp_str1 := '';
    for k := 1 to max_x do
      temp_str1 := temp_str1 + Island_2D[ k,j ].FTerrain_char;
    memo1.lines.add( temp_str1 );
  end;
  memo1.lines.add( 'start_x = ' + inttostr(start_x) );
  memo1.lines.add( 'start_y = ' + inttostr(start_y) );
  memo1.lines.add( 'finish_x = ' + inttostr(finish_x) );
  memo1.lines.add( 'finish_y = ' + inttostr(finish_y) );
  memo1.lines.add( 'max_locations = ' + inttostr(max_locations) );
end; { show_island }
{--------------------------------------------------------------------}

procedure TForm1.CreateANewIslandClick(Sender: TObject);
begin
  make_an_island;
end; { CreateaNewIslandClick }
{--------------------------------------------------------------------}

procedure TForm1.OptionsClick(Sender: TObject);
begin
  form2 := tform2.create( nil );
  try
    form2.max_x.text := inttostr( max_x );
    form2.max_y.text := inttostr( max_y );
    if form2.showmodal = mrOK then
    begin
      try
        max_x := strtoint( form2.max_x.text );
      except
        showmessage( 'Error: Value for Max_x is not a valid number.');
      end;

      try
        max_y := strtoint( form2.max_y.text );
      except
        showmessage( 'Error: Value for Max_y is not a valid number.');
      end;

      if (max_x < 1) or (max_x > array_max_x) then
      begin
        max_x := default_max_x;
        showmessage( 'Error: Max_x out of range.' );
      end;

      if (max_y < 1) or (max_y > array_max_y) then
      begin
        max_y := default_max_y;
        showmessage( 'Error: Max_y out of range.' );
      end;
    end;
  finally
    form2.close;
  end;
end; { SetHorizontalMaxSize1Click }
{--------------------------------------------------------------------}

procedure Copy_2D_island_to_single_array;
var
  j,k : integer;
begin
//  location_counter := 0;
  for j := 1 to max_x do
    for k := 1 to max_y do
    begin
      if island_2D[ j,k ].Flocation_number > 0 then
      begin
        Island := TIsland.Create(
           island_2D[ j,k ].FTerrain,
           island_2D[ j,k ].FTerrain_char,
           island_2D[ j,k ].Fdescription,
           island_2D[ j,k ].Fx,
           island_2D[ j,k ].Fy,
           island_2D[ j,k ].Flocation_number,
           island_2D[ j,k ].Fexits );
        Island.Add(Island);
//        inc(location_counter);
      end;
    end;
end; { Copy_2D_island_to_single_array }
{--------------------------------------------------------------------}

procedure TForm1.SaveIslandToFileClick(Sender: TObject);
var
  outfile : textfile;
  i,j : Integer;
  //temp_x, temp_y, j : integer;
  k : directions;
  str1 : string;
begin
  if savedialog1.execute then
  begin
    Copy_2D_island_to_single_array;
    Island.Sort(compareByLocationNumber);

    AssignFile( outfile, savedialog1.filename );
    Rewrite( outfile );

    Writeln( outfile, '%' );
    Writeln( outfile, '% Map data' );

    for k := 0 to memo1.Lines.Count - 1 do
        Writeln( outfile, memo1.Lines.Strings[ k ] );

    Writeln( outfile, '[END OF TEXT]');
    Writeln( outfile, '%' );
    Writeln( outfile, '% location_number');
    Writeln( outfile, '% Description');
    Writeln( outfile, '% [END OF TEXT]');
    Writeln( outfile, '% 1..10 of ints');

    // And redisplay the list
    for i := 0 to Island.Count-1 do
    begin
      if island.location_number > 0 then
      begin
        Writeln( outfile, inttostr(island.Flocation_number ));
        Writeln( outfile, island.Fdescription[1] );
        Writeln( outfile, island.Fdescription[2] );
        Writeln( outfile, '[END OF TEXT]');
        str1 := '';
        for k := 1 to max_directions do
          str1 := str1 + inttostr( island.Fexits[ k ] ) + ' ';
        Writeln( outfile, str1 );
      end;
    end;

    Writeln( outfile, '* --- End of Map data' );
    closeFile( outfile );

    // Free up the list
    Island.free;
  end;
end; { SaveIslandtoFile1Click }
{--------------------------------------------------------------------}

procedure tform1.make_an_island;
begin
  blank_island;
  define_island_outline( start_x, start_y, finish_x, finish_y, location_counter, max_locations );
  show_island( start_x, start_y, finish_x, finish_y, location_counter );
end; { make_an_island }
{--------------------------------------------------------------------}

procedure TForm1.FormCreate(Sender: TObject);
var
  ATerrain : Terrain_type;
  ATerrain_char : char;
  Adescription : description_type;
  Ax, Ay, Alocation_number : integer;
  Aexits : exit_type;
begin
  randomize;
  memo1.font.Name := 'Courier New';
  memo1.font.Size := 8;
  max_x := default_max_x; // horizontal
  max_y := default_max_y; // vertical

  // Create the TList object to hold a set of Island objects

  Island := TIsland.Create( nil, nil, nil, nil, nil, nil, nil );

  {
  Island := TIsland.Create(
     ATerrain : Terrain_type;
     const ATerrain_char : char;
     const Adescription : description_type;
     const Ax, Ay, Alocation_number : integer;
     const Aexits : exit_type );
  }
  make_an_island;
end; { FormCreate }
{--------------------------------------------------------------------}

initialization
  {$i unit1.lrs}

end.