home *** CD-ROM | disk | FTP | other *** search
/ AMIGA PD 1 / AMIGA-PD-1.iso / Programme_zum_Heft / Programmieren / Kurztests / PascalPCQ / Examples / MapMaker.p < prev    next >
Text File  |  1991-03-27  |  7KB  |  291 lines
  1. Program MapMaker;
  2.  
  3. {$I "Include:Exec/Libraries.i"}
  4. {$I "Include:Exec/Interrupts.i"}
  5. {$I "Include:Graphics/Graphics.i"}
  6. {$I "Include:Graphics/Pens.i"}
  7. {$I "Include:Intuition/Intuition.i"}
  8. {$I "Include:Libraries/DOS.i"}
  9. {$I "Include:Graphics/View.i"}
  10. {$I "Include:Utils/Random.i"}
  11.  
  12. {
  13.     This program just draws a blocky map from straight overhead,
  14. then repeatedly splits each block into four parts and adjusts the
  15. elevation of each of the parts until it gets down to one pixel per
  16. block.  It ends up looking something like a terrain map.  It's kind
  17. of a fractal thing, but not too much.  Some program a long time ago
  18. inspired this, but I apologize for forgetting which one.  As I
  19. recall, that program was derived from Chris Gray's sc.
  20.     Once upon a time I was thinking about writing an overblown
  21. strategic conquest game, and this was the first stab at a map
  22. maker.  The maps it produces look nifty, but have no sense of
  23. geology so they're really not too useful for a game.
  24.     When the map is finished, press the left button inside the
  25. window somewhere and the program will go away.
  26. }
  27.  
  28. const
  29.     MinX = 0;
  30.     MaxX = 320;
  31.     MinY = 0;
  32.     MaxY = 200;
  33.  
  34. type
  35.     MapArray = array [MinX .. MaxX - 1, MinY .. MaxY - 1] of Byte;
  36.  
  37. VAR
  38.     average,x,y,
  39.     nextx,nexty,count,
  40.     skip,level      : Short;
  41.     rp            : RastPortPtr;
  42.     vp            : Address;
  43.     s             : Address;
  44.     w             : WindowPtr;
  45.     Seed      : Integer;
  46.     m             : MessagePtr;
  47.     Map           : MapArray;
  48.     Quit      : Boolean;
  49.  
  50.  
  51. Function FixX(x : short): short;
  52. begin
  53.     if x < 0 then
  54.     FixX := x + MaxX
  55.     else
  56.     FixX := x mod MaxX;
  57. end;
  58.  
  59. Function FixY(y : short) : short;
  60. begin
  61.     if x < 0 then
  62.     FixY := y + MaxY
  63.     else
  64.     FixY := y mod MaxY;
  65. end;
  66.  
  67. Procedure DrawMap;
  68. begin
  69.     if skip = 1 then begin
  70.     for x := MinX to MaxX - 1 do begin
  71.         for y := MinY to MaxY - 1 DO begin
  72.         if Map[x,y] < 100 then begin
  73.             SetAPen(rp, 0);
  74.             WritePixel(rp, x, y)
  75.         end else begin
  76.             average := (Map[x,y] - 100) DIV 6 + 1;
  77.             if average > 15 then
  78.             average := 15;
  79.             SetAPen(rp, average);
  80.             WritePixel(rp, x, y)
  81.         end
  82.         end
  83.     end
  84.    end else begin
  85.     x := MinX;
  86.     while x < MaxX do begin
  87.         y := MinY;
  88.         while y < MaxY do begin
  89.         if Map[x,y] < 100 then begin
  90.             SetAPen(rp, 0);
  91.             RectFill(rp,x,y,x + skip - 1,y + skip - 1)
  92.         end else begin
  93.             average := (Map[x,y] - 100) DIV 6 + 1;
  94.             if average > 15 then
  95.             average := 15;
  96.             SetAPen(rp,average);
  97.             RectFill(rp,x,y,x + skip - 1,y + skip - 1);
  98.         end;
  99.         y := y + skip;
  100.         end;
  101.         x := x + skip;
  102.     end;
  103.     end;
  104. end;
  105.  
  106. Function OpenTheScreen() : Boolean;
  107. var
  108.     ns : NewScreenPtr;
  109. begin
  110.     new(ns);
  111.     with ns^ do begin
  112.     LeftEdge := 0;
  113.     TopEdge  := 0;
  114.     Width    := 320;
  115.     Height   := 200;
  116.     Depth    := 4;
  117.     DetailPen := 3;
  118.     BlockPen  := 2;
  119.     ViewModes := 0;
  120.     SType     := CUSTOMSCREEN_f;
  121.     Font      := nil;
  122.     DefaultTitle := nil;
  123.     Gadgets   := nil;
  124.     CustomBitMap := nil;
  125.     end;
  126.  
  127.     s := OpenScreen(ns);
  128.     dispose(ns);
  129.     OpenTheScreen := s <> nil;
  130. end;
  131.  
  132. Function OpenTheWindow() : Boolean;
  133. var
  134.     nw : NewWindowPtr;
  135. begin
  136.     new(nw);
  137.     with nw^ do begin
  138.     LeftEdge := MinX;
  139.     TopEdge := MinY;
  140.     Width := MaxX;
  141.     Height := MaxY;
  142.  
  143.     DetailPen := -1;
  144.     BlockPen  := -1;
  145.     IDCMPFlags := MOUSEBUTTONS_f;
  146.     Flags := BORDERLESS + BACKDROP + SMART_REFRESH + ACTIVATE;
  147.     FirstGadget := nil;
  148.     CheckMark := nil;
  149.     Title := nil;
  150.     Screen := s;
  151.     BitMap := nil;
  152.     MinWidth := 50;
  153.     MaxWidth := -1;
  154.     MinHeight := 20;
  155.     MaxHeight := -1;
  156.     WType := CUSTOMSCREEN_f;
  157.     end;
  158.  
  159.     w := OpenWindow(nw);
  160.     dispose(nw);
  161.     OpenTheWindow := w <> nil;
  162. end;
  163.  
  164. Procedure MakeMap;
  165. begin
  166.  
  167.     rp:= w^.RPort;
  168.     vp:= ViewPortAddress(w);
  169.  
  170.     SetRGB4(vp, 0, 0, 0, 9); { Ocean Blue }
  171.     SetRGB4(vp, 1, 1, 1, 0);
  172.     SetRGB4(vp, 2, 0, 3, 0);
  173.     SetRGB4(vp, 3, 0, 4, 0); { Dark Green }
  174.     SetRGB4(vp, 4, 0, 5, 0);
  175.     SetRGB4(vp, 5, 1, 6, 0);
  176.     SetRGB4(vp, 6, 2, 8, 0); { Medium Green }
  177.     SetRGB4(vp, 7, 4, 10, 0);
  178.     SetRGB4(vp, 8, 6, 10, 0);
  179.     SetRGB4(vp, 9, 9, 9, 0); { Brown }
  180.     SetRGB4(vp, 10, 8, 8, 0);
  181.     SetRGB4(vp, 11, 7, 7, 0); { Dark Brown }
  182.     SetRGB4(vp, 12, 10, 10, 0); { Dark Grey }
  183.     SetRGB4(vp, 13, 10, 10, 10);
  184.     SetRGB4(vp, 14, 12, 12, 12);
  185.     SetRGB4(vp, 15, 14, 14, 15); { White }
  186.  
  187.     SelfSeed; { Seed the Random Number Generator }
  188.  
  189.     level := 7;
  190.     skip  := 16;
  191.  
  192.     y := MinY;
  193.     while y < MaxY do begin
  194.     x := MinX;
  195.     while x < MaxX do begin
  196.         Map[x,y] := RangeRandom(220);
  197.         x := x + skip;
  198.     end;
  199.     y := y + skip;
  200.     end;
  201.  
  202.     DrawMap;
  203.  
  204.     for level := 2 to 5 do begin
  205.     skip := skip DIV 2;
  206.     y := MinY;
  207.     while y < MaxY do begin
  208.         if (y MOD (2*skip)) = 0 then
  209.         nexty := skip * 2
  210.         else
  211.         nexty:=skip;
  212.         x := MinX;
  213.         while x < MaxX do begin
  214.         if (x MOD (2*skip)) = 0 then
  215.             nextx := skip * 2
  216.         else
  217.             nextx := skip;
  218.         if (nextx = skip * 2) AND (nexty = skip * 2) then begin
  219.             average := Map[x,y] * 5;
  220.             count := 9;
  221.         end else begin
  222.             average := 0;
  223.             count := 4;
  224.         end;
  225.         if (nextx = skip * 2) then begin
  226.             average := average + Map[x,FixY(y - skip)];
  227.             average := average + Map[x,FixY(y + nexty)];
  228.             count := count + 2;
  229.         end;
  230.         if (nexty = skip * 2) then begin
  231.             average := average + Map[FixX(x - skip),y];
  232.             average := average + Map[FixX(x + nextx),y];
  233.             count := count + 2;
  234.         end;
  235.         average := average + Map[FixX(x-skip),FixY(y-skip)]
  236.                    + Map[FixX(x-nextx),FixY(y+nexty)]
  237.                    + Map[FixX(x+skip),FixY(y-skip)]
  238.                    + Map[FixX(x+nextx),FixY(y+nexty)];
  239.         average := (average DIV count) +
  240.                 (RangeRandom(4) - 2) * (9 - level);
  241.         case Average of
  242.           150..255 : Average := Average + 2;
  243.           100..149 : Inc(Average);
  244.         else
  245.             Average := Average - 3;
  246.         end;
  247.         if average < 0 then
  248.             average := 0;
  249.         if average > 220 then
  250.             average := 220;
  251.         Map[x,y] := average;
  252.  
  253.         x := x + skip;
  254.         end;
  255.         m := GetMsg(w^.UserPort);
  256.         if m <> Nil then begin
  257.         Quit := True;
  258.         return;
  259.         end;
  260.         y := y + skip;
  261.     end;
  262.     DrawMap;
  263.     end;
  264. end;
  265.  
  266. begin
  267.     GfxBase := OpenLibrary("graphics.library", 0);
  268.     if GfxBase <> nil then begin
  269.     if OpenTheScreen() then begin
  270.         if OpenTheWindow() then begin
  271.         Quit := False;
  272.         ShowTitle(s, false);
  273.         MakeMap;
  274.         if not Quit then
  275.             m := WaitPort(w^.UserPort);
  276.         Forbid;
  277.         repeat
  278.             m := GetMsg(w^.UserPort);
  279.         until m = nil;
  280.         CloseWindow(w);
  281.         Permit;
  282.         end else
  283.         writeln('Could not open the window.');
  284.         CloseScreen(s);
  285.     end else
  286.         writeln('Could not open the screen.');
  287.     CloseLibrary(GfxBase);
  288.     end else
  289.     writeln('Could not open graphics.library');
  290. end.
  291.