Club Amiga de Montreal - CAM/CAM_CD_1.iso/files/254a.lha/PCQ/Examples/MapMaker.p

Text File | 1989-05-10 | 6.6 KB | 282 lines

Program MapMaker;

{$I "Include/Exec.i"}
{$I "Include/Ports.i"}
{$I "Include/Graphics.i"}
{$I "Include/Intuition.i"}
{$I "Include/DOS.i" solely for the DateStamp thing }

{
    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.
}

const
    MinX = 0;
    MaxX = 320;
    MinY = 0;
    MaxY = 200;

type
    VerticalArray = array [MinY .. MaxY - 1] of Byte;
    MapArray = array [MinX .. MaxX - 1] of VerticalArray;

VAR
    average,x,y,
    nextx,nexty,count,
    skip,level      : Short;
    rp            : RastPortPtr;
    vp            : Address;
    s             : ScreenPtr;
    w             : WindowPtr;
    Seed      : Integer;
    m             : MessagePtr;
    Map           : ^MapArray;


Function RangeRandom (MaxValue : Integer): Integer;
begin
    Seed := succ(Seed);
    Seed := (Seed * 171) MOD 30269;
    RangeRandom := Seed mod (MaxValue + 1);
end;

Procedure SetSeed;
var
    time : DateStampRec;
begin
    DateStamp(time);
    Seed := time.dsDays + time.dsMinute + time.dsTick;
end;

Function FixX(x : short): short;
begin
    if x < 0 then
    FixX := x + MaxX
    else
    FixX := x mod MaxX;
end;

Function FixY(y : short) : short;
begin
    if x < 0 then
    FixY := y + MaxY
    else
    FixY := y mod MaxY;
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] < 0 then begin
            SetAPen(rp, 0);
            WritePixel(rp, x, y)
        end else begin
            average := Map^[x][y] DIV 6 + 1;
            if average > 15 then
            average := 15;
            SetAPen(rp, average);
            WritePixel(rp, x, y)
        end
        end
    end
   end else begin
    for x := MinX to MaxX - 1 by skip do begin
        for y := MinY to MaxY - 1 by skip do begin
        if Map^[x][y] < 0 then begin
            SetAPen(rp, 0);
            RectFill(rp,x,y,x + skip - 1,y + skip - 1)
        end else begin
            average := Map^[x][y] DIV 6 + 1;
            if average > 15 then
            average := 15;
            SetAPen(rp,average);
            RectFill(rp,x,y,x + skip - 1,y + skip - 1);
        end;
        end;
    end;
    end;
end;

Function OpenTheScreen() : Boolean;
var
    ns : NewScreenPtr;
begin
    new(ns);

    ns^.LeftEdge := 0;
    ns^.TopEdge  := 0;
    ns^.Width    := 320;
    ns^.Height   := 200;
    ns^.Depth    := 4;
    ns^.DetailPen := 3;
    ns^.BlockPen  := 2;
    ns^.ViewModes := 0;
    ns^.SType     := CUSTOMSCREEN_f;
    ns^.Font      := nil;
    ns^.DefaultTitle := nil;
    ns^.Gadgets   := nil;
    ns^.CustomBitMap := nil;

    s := OpenScreen(ns);
    dispose(ns);
    OpenTheScreen := s <> nil;
end;

Function OpenTheWindow() : Boolean;
var
    nw : NewWindowPtr;
begin
    new(nw);

    nw^.LeftEdge := MinX;
    nw^.TopEdge := MinY;
    nw^.Width := MaxX;
    nw^.Height := MaxY;

    nw^.DetailPen := -1;
    nw^.BlockPen  := -1;
    nw^.IDCMPFlags := MOUSEBUTTONS_f;
    nw^.Flags := BORDERLESS_f + BACKDROP_f + SMART_REFRESH_f + ACTIVATE_f;
    nw^.FirstGadget := nil;
    nw^.CheckMark := nil;
    nw^.Title := nil;
    nw^.Screen := s;
    nw^.BitMap := nil;
    nw^.MinWidth := 50;
    nw^.MaxWidth := -1;
    nw^.MinHeight := 20;
    nw^.MaxHeight := -1;
    nw^.WType := CUSTOMSCREEN_f;

    w := OpenWindow(nw);
    dispose(nw);
    OpenTheWindow := w <> nil;
end;

Procedure MakeMap;
begin

    rp:= w^.RPort;
    vp:= ViewPortAddress(w);

    SetRGB4(vp, 0, 0, 0, 9); { Ocean Blue }
    SetRGB4(vp, 1, 0, 0, 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 }

    SetSeed;

    level := 7;
    skip  := 16;
    for y := MinY to MaxY - 1 by skip do
    for x := MinX to MaxX - 1 by skip do
        Map^[x][y] := RangeRandom(220) - 100;

    DrawMap;

    for level := 2 to 5 do begin
    skip := skip DIV 2;
    for y := MinY to MaxY - 1 by skip do begin
        if (y MOD (2*skip)) = 0 then
        nexty := skip * 2
        else
        nexty:=skip;
        for x := MinX to MaxX - 1 by skip 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;
            count := 9;
        end else begin
            average := 0;
            count := 4;
        end;
        if (nextx = skip * 2) then begin
            average := average + Map^[x][FixY(y - skip)];
            average := average + Map^[x][FixY(y + nexty)];
            count := count + 2;
        end;
        if (nexty = skip * 2) then begin
            average := average + Map^[FixX(x - skip)][y];
            average := average + Map^[FixX(x + nextx)][y];
            count := count + 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 count) +
                (RangeRandom(4) - 2) * (9 - level);
        if average > 0 then
            average := average + 1
        else
            average := average - 3;
        if average < -120 then
            average := -120;
        if average > 120 THEN
            average := 120;
        Map^[x][y] := average;
        end;
    end;
    DrawMap;
    end;
end;

begin
    GfxBase := OpenLibrary("graphics.library", 0);
    new(Map);
    if GfxBase <> nil then begin
    if OpenTheScreen() then begin
        if OpenTheWindow() then begin
        ShowTitle(s, false);
        MakeMap;
        dispose(Map);
        repeat
            m := GetMsg(w^.UserPort);
        until m = nil;
        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('Could not open graphics.library');
end.