paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-22 01:09:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

* remove

Browse Source
This commit is contained in:
nils 2002-11-28 19:43:09 +00:00
parent eac09110d7
commit 0208620f08
1 changed files with 0 additions and 381 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

381
packages/extra/amunits/demos/mapmaker.pas
View File

@ -1,381 +0,0 @@
Program MapMaker;
uses Exec, graphics, Intuition, Utility;
{$I tagutils.inc}
{
Patrick Quaid.
This program just draws a blocky map from straight overhead,
then repeatedly splits each block into four parts and adjusts the
elevation of each of the parts until it gets down to one pixel per
block. It ends up looking something like a terrain map. It's kind
of a fractal thing, but not too much. Some program a long time ago
inspired this, but I apologize for forgetting which one. As I
recall, that program was derived from Chris Gray's sc.
Once upon a time I was thinking about writing an overblown
strategic conquest game, and this was the first stab at a map
maker. The maps it produces look nifty, but have no sense of
geology so they're really not too useful for a game.
When the map is finished, press the left button inside the
window somewhere and the program will go away.
}
{
Changed the source to 2.0+.
12 May 1998.
Translated to FPC. This was one of the first
program I tried with fpc, just to check that
the amiga units worked.
08 Aug 1998.
nils.sjoholm@mailbox.swipnet.se
}
const
MinX = 0;
MaxX = 320;
MinY = 0;
MaxY = 200;
type
MapArray = array [MinX .. MaxX - 1, MinY .. MaxY - 1] of Longint;
VAR
average,x,y,
nextx,nexty,count1,
skip,level : Longint;
rp : pRastPort;
vp : Pointer;
s : pScreen;
w : pWindow;
m : pMessage;
Map : MapArray;
Quit : Boolean;
i : Longint;
thetags : Array[0..12] of tTagItem;
Function FixX(x : Longint): Longint;
begin
if x < 0 then
FixX := x + MaxX
else if x >= MaxX then
FixX := x mod MaxX
else
FixX := x;
end;
Function FixY(y : Longint) : Longint;
begin
if x < 0 then
FixY := y + MaxY
else if x >= MaxY then
FixY := y mod MaxY
else
FixY := y;
end;
Procedure DrawMap;
begin
if skip = 1 then begin
for x := MinX to MaxX - 1 do begin
for y := MinY to MaxY - 1 DO begin
if Map[x,y] < 100 then begin
SetAPen(rp, 0);
i := WritePixel(rp, x, y)
end else begin
average := (Map[x,y] - 100) DIV 6 + 1;
if average > 15 then
average := 15;
SetAPen(rp, average);
i := WritePixel(rp, x, y)
end
end
end
end else begin
x := MinX;
while x < MaxX do begin
y := MinY;
while y < MaxY do begin
if Map[x,y] < 100 then begin
SetAPen(rp, 0);
RectFill(rp,x,y,x + skip - 1,y + skip - 1)
end else begin
average := (Map[x,y] - 100) DIV 6 + 1;
if average > 15 then
average := 15;
SetAPen(rp,average);
RectFill(rp,x,y,x + skip - 1,y + skip - 1);
end;
y := y + skip;
end;
x := x + skip;
end;
end;
end;
Function Min(x,y : Longint) : Longint;
begin
if x < y then
Min := x
else
Min := y;
end;
Function Max(x,y : Longint) : Longint;
begin
if x > y then
Max := x
else
Max := y;
end;
Function Height(x,y : Longint) : Longint;
begin
Height := Map[x,y] div 32;
end;
Procedure ChangeDelta(var d : Longint);
begin
case Random(100) of
51..75 : if d < 1 then
Inc(d);
76..100 : if d > -1 then
Dec(d);
end;
end;
Procedure MakeRivers;
var
i : Longint;
x,y,
dx,dy : Longint;
OK : Boolean;
LastHeight : Longint;
count1 : Longint;
cx,cy : Longint;
Search : Longint;
CheckHeight : Longint;
begin
SetAPen(rp, 16);
for cx := 0 to 319 do begin
for cy := 0 to 199 do begin
if (Map[cx,cy] > 153) and (Map[cx,cy] < 162) and
(Random(100) < 3) then begin
x := cx;
y := cy;
dx := 0;
dy := 0;
while (dx = 0) and (dy = 0) do begin
dx := Random(2) - 1;
dy := Random(2) - 1;
end;
OK := True;
count1 := 0;
while OK do begin
LastHeight := Map[x,y]; { Height(x,y); }
Map[x,y] := 0;
i := WritePixel(rp, x, y);
CheckHeight := -6;
Search := 0;
repeat
repeat
ChangeDelta(dx);
ChangeDelta(dy);
until (dx <> 0) or (dy <> 0);
Inc(Search);
if (Map[FixX(x + dx), FixY(y + dy)] > 0) and
{ (Height(FixX(x + dx), FixY(y + dy)) < CheckHeight) then begin }
(Map[FixX(x + dx), FixY(y + dy)] < (LastHeight + CheckHeight)) then begin
x := FixX(x + dx);
y := FixY(y + dy);
Search := 0;
end else if Search > 200 then begin
if CheckHeight < 6 then begin
Inc(CheckHeight,2);
Search := 1;
end else begin
Search := 0;
OK := False;
end;
end;
until Search = 0;
Inc(count1);
if count1 > 150 then
OK := False;
if Map[x,y] < 100 then
OK := False;
end;
end;
end;
end;
end;
Procedure MakeMap;
begin
rp:= w^.RPort;
vp:= ViewPortAddress(w);
SetRGB4(vp, 0, 0, 0, 12); { Ocean Blue }
SetRGB4(vp, 1, 1, 1, 0);
SetRGB4(vp, 2, 0, 3, 0);
SetRGB4(vp, 3, 0, 4, 0); { Dark Green }
SetRGB4(vp, 4, 0, 5, 0);
SetRGB4(vp, 5, 1, 6, 0);
SetRGB4(vp, 6, 2, 8, 0); { Medium Green }
SetRGB4(vp, 7, 4, 10, 0);
SetRGB4(vp, 8, 6, 10, 0);
SetRGB4(vp, 9, 9, 9, 0); { Brown }
SetRGB4(vp, 10, 8, 8, 0);
SetRGB4(vp, 11, 7, 7, 0); { Dark Brown }
SetRGB4(vp, 12, 10, 10, 0); { Dark Grey }
SetRGB4(vp, 13, 10, 10, 10);
SetRGB4(vp, 14, 12, 12, 12);
SetRGB4(vp, 15, 14, 14, 15); { White }
SetRGB4(vp, 16, 0, 0, 10); { River blue }
Randomize; { Seed the Random Number Generator }
level := 7;
skip := 16;
y := MinY;
while y < MaxY do begin
x := MinX;
while x < MaxX do begin
Map[x,y] := Random(220);
x := x + skip;
end;
y := y + skip;
end;
DrawMap;
for level := 2 to 5 do begin
skip := skip DIV 2;
y := MinY;
while y < MaxY do begin
if (y MOD (2*skip)) = 0 then
nexty := skip * 2
else
nexty:=skip;
x := MinX;
while x < MaxX do begin
if (x MOD (2*skip)) = 0 then
nextx := skip * 2
else
nextx := skip;
if (nextx = skip * 2) AND (nexty = skip * 2) then begin
average := Map[x,y] * 5;
count1 := 9;
end else begin
average := 0;
count1 := 4;
end;
if (nextx = skip * 2) then begin
average := average + Map[x,FixY(y - skip)];
average := average + Map[x,FixY(y + nexty)];
count1 := count1 + 2;
end;
if (nexty = skip * 2) then begin
average := average + Map[FixX(x - skip),y];
average := average + Map[FixX(x + nextx),y];
count1 := count1 + 2;
end;
average := average + Map[FixX(x-skip),FixY(y-skip)]
+ Map[FixX(x-nextx),FixY(y+nexty)]
+ Map[FixX(x+skip),FixY(y-skip)]
+ Map[FixX(x+nextx),FixY(y+nexty)];
average := (average DIV count1) +
(Random(4) - 2) * (9 - level);
case Average of
150..255 : Average := Average + 2;
100..149 : Inc(Average);
else
Average := Average - 3;
end;
if average < 0 then
average := 0;
if average > 220 then
average := 220;
Map[x,y] := average;
x := x + skip;
end;
m := GetMsg(w^.UserPort);
if m <> Nil then begin
Quit := True;
Exit;
end;
y := y + skip;
end;
DrawMap;
end;
MakeRivers;
end;
begin
GfxBase := OpenLibrary(GRAPHICSNAME,0);
if GfxBase <> nil then begin
thetags[0] := TagItem(SA_Left, 0);
thetags[1] := TagItem(SA_Top, 0);
thetags[2] := TagItem(SA_Width, 320);
thetags[3] := TagItem(SA_Height, 200);
thetags[4] := TagItem(SA_Depth, 5);
thetags[5] := TagItem(SA_DetailPen, 3);
thetags[6] := TagItem(SA_BlockPen, 2);
thetags[7] := TagItem(SA_Type, CUSTOMSCREEN_f);
thetags[8].ti_Tag := TAG_END;
s := OpenScreenTagList(NIL,@thetags);
if s <> NIL then begin
thetags[0] := TagItem(WA_IDCMP, IDCMP_MOUSEBUTTONS);
thetags[1] := TagItem(WA_Left, MinX);
thetags[2] := TagItem(WA_Top, MinY);
thetags[3] := TagItem(WA_Width, MaxX);
thetags[4] := TagItem(WA_Height, MaxY);
thetags[5] := TagItem(WA_MinWidth, 50);
thetags[6] := TagItem(WA_MinHeight, 20);
thetags[7] := TagItem(WA_Borderless, 1);
thetags[8] := TagItem(WA_BackDrop, 1);
thetags[9] := TagItem(WA_SmartRefresh, 1);
thetags[10] := TagItem(WA_Activate, 1);
thetags[11] := TagItem(WA_CustomScreen, longint(s));
thetags[12].ti_Tag := TAG_END;
w := OpenWindowTagList(NIL,@thetags);
IF w <> NIL THEN begin
Quit := False;
ShowTitle(s, 0);
MakeMap;
if not Quit then
m := WaitPort(w^.UserPort);
Forbid;
repeat
m := GetMsg(w^.UserPort);
until m = nil;
CloseWindow(w);
Permit;
end else
writeln('Could not open the window.');
CloseScreen(s);
end else
writeln('Could not open the screen.');
CloseLibrary(GfxBase);
end else writeln('no graphics.library');
end.