Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- unit Unit1;
- {$R *.lfm}
- {$MODE Delphi}
- interface
- uses
- Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, Menus,
- StdCtrls, LResources;
- { 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;
- map_detail = record
- Terrain : Terrain_type;
- Terrain_char : char;
- description : array[1..2] of string;
- x, y, location_number : integer;
- exits : exit_type;
- end;
- description_type = array[1..2] of string;
- // The Island class definition
- TIsland = class
- private
- // The data fields of this new class
- ATerrain : Terrain_type;
- ATerrain_char : char;
- Adescription : description_type;
- Ax, Ay, Alocation_number : integer;
- Aexits : exit_type;
- public
- // Properties to read these data values
- property Terrain : Terrain_type
- read ATerrain;
- property Terrain_char : char
- read ATerrain_char;
- property description : description_type
- read Adescription;
- property x : integer read Ax;
- property y : integer read Ay;
- property location_number : integer read Alocation_number;
- property Exits : exit_type
- read Aexits;
- // Constructor
- constructor Create(const ATerrain : Terrain_type;
- const ATerrain_char : char;
- const Adescription : description_type;
- const Ax, Ay, Alocation_number : integer;
- const Aexits : exit_type );
- end;
- island_2D_type = array[ 1..array_max_x, 1..array_max_y ] of
- map_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
- island_List : TList;
- // Method to show the contents of our list object
- procedure ShowListContents;
- { Public declarations }
- public
- end;
- var
- Form1: TForm1;
- max_x, max_y,
- location_counter,
- max_locations,
- start_x, start_y,
- finish_x, finish_y : integer;
- island : island_2D_type;
- implementation
- uses set_max;
- {$R *.lfm}
- constructor TIsland.Create(const ATerrain : Terrain_type;
- const ATerrain_char : char;
- const Adescription : description_type;
- const Ax, Ay, Alocation_number : integer;
- const Aexits : exit_type );
- begin
- // Save the passed parameters
- self.Terrain := ATerrain;
- self.Terrain_char := ATerrain_char;
- self.description := Adescription;
- self.x := Ax;
- self.y := Ay;
- self.location_number := Alocation_number;
- self.exits := Aexits;
- 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.location_number > Island2.location_number then
- Result := 1
- else
- if Island1.location_number = Island2.location_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[ j,k ].Terrain := Sea;
- island[ j,k ].Terrain_char := '.';
- island[ j,k ].description[1] := '';
- island[ j,k ].description[2] := '';
- island[ j,k ].x := 0;
- island[ j,k ].y := 0;
- island[ j,k ].location_number := 0;
- for d := 1 to max_directions do
- island[ j,k ].exits[ 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[ current_x, current_y ].Terrain := Land;
- island[ current_x, current_y ].Terrain_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[ current_x, current_y ].Terrain_char := '@';
- finish_x := current_x;
- finish_y := current_y;
- inc(location_counter);
- end
- else
- begin
- if island[ current_x, current_y ].Terrain = Sea then
- begin
- inc(location_counter);
- island[ current_x, current_y ].Terrain := 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[ current_x, current_y ].x := current_x;
- island[ current_x, current_y ].y := current_y;
- island[ current_x, current_y ].Terrain_char := char1;
- island[ current_x, current_y ].location_number := j;
- if j = 1 then
- island[ current_x, current_y ].description[1] := 'The entrance to the dungeons.'
- else
- island[ current_x, current_y ].description[1] := 'Game location #' + inttostr(j);
- island[ current_x, current_y ].description[2] := 'Exit to the ' + directions_text[ new_direction_int ];
- if (old_x > 0) and (old_y > 0) then
- begin
- island[ old_x, old_y ].exits[ old_direction_int ] := j;
- island[ current_x, current_y ].description[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[ current_x, current_y ].exits[ 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[ k,j ].Terrain_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[ j,k ].location_number > 0 then
- begin
- Island := TIsland.Create(
- island[ j,k ].Terrain,
- island[ j,k ].Terrain_char,
- island[ j,k ].description,
- island[ j,k ].x,
- island[ j,k ].y,
- island[ j,k ].location_number,
- island[ j,k ].exits );
- myList.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.location_number ));
- Writeln( outfile, island.description[1] );
- Writeln( outfile, island.description[2] );
- Writeln( outfile, '[END OF TEXT]');
- str1 := '';
- for k := 1 to max_directions do
- str1 := str1 + inttostr( island.exits[ 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.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement