1 (*

     2  * Hedgewars, a worms-like game

     3  * Copyright (c) 2005 Andrey Korotaev <unC0Rr@gmail.com>

     4  *

     5  * Distributed under the terms of the BSD-modified licence:

     6  *

     7  * Permission is hereby granted, free of charge, to any person obtaining a copy

     8  * of this software and associated documentation files (the "Software"), to deal

     9  * with the Software without restriction, including without limitation the

    10  * rights to use, copy, modify, merge, publish, distribute, sublicense, and/or

    11  * sell copies of the Software, and to permit persons to whom the Software is

    12  * furnished to do so, subject to the following conditions:

    13  *

    14  * 1. Redistributions of source code must retain the above copyright notice,

    15  *    this list of conditions and the following disclaimer.

    16  * 2. Redistributions in binary form must reproduce the above copyright notice,

    17  *    this list of conditions and the following disclaimer in the documentation

    18  *    and/or other materials provided with the distribution.

    19  * 3. The name of the author may not be used to endorse or promote products

    20  *    derived from this software without specific prior written permission.

    21  *

    22  * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED

    23  * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF

    24  * MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO

    25  * EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

    26  * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,

    27  * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;

    28  * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,

    29  * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR

    30  * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF

    31  * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

    32  *)

    33 

    34 unit uLand;

    35 interface

    36 uses SDLh;

    37 {$include options.inc}

    38 type TLandArray = packed array[0..1023, 0..2047] of LongWord;

    39 

    40 var  Land: TLandArray;

    41      LandSurface: PSDL_Surface;

    42 

    43 procedure GenLandSurface;

    44 procedure MakeFortsMap;

    45 procedure AddHHPoint(_x, _y: integer);

    46 procedure GetHHPoint(out _x, _y: integer);

    47 procedure RandomizeHHPoints;

    48 

    49 implementation

    50 uses uConsole, uStore, uMisc, uConsts, uRandom, uTeams;

    51 

    52 type TPixAr = record

    53               Count: Longword;

    54               ar: array[word] of TPoint;

    55               end;

    56 

    57 var HHPoints: record

    58               First, Last: word;

    59               ar: array[1..Pred(cMaxHHs)] of TPoint

    60               end = (First: 1);

    61 

    62 procedure BlitImageAndGenerateCollisionInfo(cpX, cpY: Longword; Image, Surface: PSDL_Surface);

    63 var i, p: LongWord;

    64     x, y: Longword;

    65     bpp: integer;

    66     r: TSDL_Rect;

    67 begin

    68 r.x:= cpX;

    69 r.y:= cpY;

    70 SDL_UpperBlit(Image, nil, Surface, @r);

    71 WriteToConsole('Generating collision info... ');

    72 

    73 if SDL_MustLock(Image) then

    74    SDLTry(SDL_LockSurface(Image) >= 0, true);

    75 

    76 bpp:= Image.format.BytesPerPixel;

    77 WriteToConsole('('+inttostr(bpp)+') ');

    78 p:= LongWord(Image.pixels);

    79 case bpp of

    80      1: OutError('We don''t work with 8 bit surfaces', true);

    81      2: for y:= 0 to Pred(Image.h) do

    82             begin

    83             i:= Longword(@Land[cpY + y, cpX]);

    84             for x:= 0 to Pred(Image.w) do

    85                 if PWord(p + x * 2)^ = 0 then PLongWord(i + x * 4)^:= 0

    86                                          else PLongWord(i + x * 4)^:= 1;

    87             inc(p, Image.pitch);

    88             end;

    89      3: for y:= 0 to Pred(Image.h) do

    90             begin

    91             i:= Longword(@Land[cpY + y, cpX]);

    92             for x:= 0 to Pred(Image.w) do

    93                 if  (PByte(p + x * 3 + 0)^ = 0)

    94                 and (PByte(p + x * 3 + 1)^ = 0)

    95                 and (PByte(p + x * 3 + 2)^ = 0) then PLongWord(i + x * 4)^:= 0

    96                                                 else PLongWord(i + x * 4)^:= 1;

    97             inc(p, Image.pitch);

    98             end;

    99      4: for y:= 0 to Pred(Image.h) do

   100             begin

   101             i:= Longword(@Land[cpY + y, cpX]);

   102             for x:= 0 to Pred(Image.w) do

   103                 if PLongword(p + x * 4)^ = 0 then PLongWord(i + x * 4)^:= 0

   104                                              else PLongWord(i + x * 4)^:= 1;

   105             inc(p, Image.pitch);

   106             end;

   107      end;

   108 if SDL_MustLock(Image) then

   109    SDL_UnlockSurface(Image);

   110 WriteLnToConsole(msgOK)

   111 end;

   112 

   113 procedure GenEdge(out pa: TPixAr);

   114 var angle, r: real;

   115     len1: Longword;

   116 begin

   117 len1:= 0;

   118 angle:= 5*pi/6;

   119 r:= 410;

   120 repeat

   121   angle:= angle + 0.1 + getrandom * 0.1;

   122   pa.ar[len1].X:= 544  + trunc(r*cos(angle));

   123   pa.ar[len1].Y:= 1080 + trunc(1.5*r*sin(angle));

   124   if r<380 then r:= r+getrandom*110

   125            else r:= r - getrandom*80;

   126   inc(len1);

   127 until angle > 7/4*pi;

   128 

   129 angle:= -pi/6;

   130 r:= 510;

   131 pa.ar[len1].X:= 644 + trunc(r*cos(angle));

   132 pa.ar[len1].Y:= 1080 + trunc(r*sin(angle));

   133 angle:= -pi;

   134 

   135 repeat

   136   angle:= angle + 0.1 + getrandom*0.1;

   137   pa.ar[len1].X:= 1504 + trunc(r*cos(angle));

   138   pa.ar[len1].Y:= 880 + trunc(1.5*r*sin(angle));

   139   if r<410 then r:= r + getrandom*80

   140            else r:= r - getrandom*110;

   141   inc(len1);

   142 until angle > 1/4*pi;

   143 pa.ar[len1]:= pa.ar[0];

   144 pa.Count:= Succ(len1)

   145 end;

   146 

   147 procedure DrawBezierBorder(var pa: TPixAr);

   148 var x, y, i: integer;

   149     tx, ty, vx, vy, vlen, t: real;

   150     r1, r2, r3, r4: real;

   151     x1, y1, x2, y2, cx1, cy1, cx2, cy2, tsq, tcb: real;

   152 begin

   153 vx:= 0;

   154 vy:= 0;

   155 with pa do

   156 for i:= 0 to Count-2 do

   157     begin

   158     vlen:= sqrt(sqr(ar[i + 1].x - ar[i    ].X) + sqr(ar[i + 1].y - ar[i    ].y));

   159     t:=    sqrt(sqr(ar[i + 1].x - ar[i + 2].X) + sqr(ar[i + 1].y - ar[i + 2].y));

   160     if t<vlen then vlen:= t;

   161     vlen:= vlen/3;

   162     tx:= ar[i+2].X - ar[i].X;

   163     ty:= ar[i+2].y - ar[i].y;

   164     t:= sqrt(sqr(tx)+sqr(ty));

   165     if t = 0 then

   166        begin

   167        tx:= -tx * 100000;

   168        ty:= -ty * 100000;

   169        end else

   170        begin

   171        tx:= -tx/t;

   172        ty:= -ty/t;

   173        end;

   174     t:= 1.0*vlen;

   175     tx:= tx*t;

   176     ty:= ty*t;

   177     x1:= ar[i].x;

   178     y1:= ar[i].y;

   179     x2:= ar[i + 1].x;

   180     y2:= ar[i + 1].y;

   181     cx1:= ar[i].X   + trunc(vx);

   182     cy1:= ar[i].y   + trunc(vy);

   183     cx2:= ar[i+1].X + trunc(tx);

   184     cy2:= ar[i+1].y + trunc(ty);

   185     vx:= -tx;

   186     vy:= -ty;

   187     t:= 0;

   188     while t <= 1.0 do

   189           begin

   190           tsq:= sqr(t);

   191           tcb:= tsq * t;

   192           r1:= (1 - 3*t + 3*tsq -   tcb) * x1;

   193           r2:= (    3*t - 6*tsq + 3*tcb) * cx1;

   194           r3:= (          3*tsq - 3*tcb) * cx2;

   195           r4:= (                    tcb) * x2;

   196           X:= round(r1 + r2 + r3 + r4);

   197           r1:= (1 - 3*t + 3*tsq -   tcb) * y1;

   198           r2:= (    3*t - 6*tsq + 3*tcb) * cy1;

   199           r3:= (          3*tsq - 3*tcb) * cy2;

   200           r4:= (                    tcb) * y2;

   201           Y:= round(r1 + r2 + r3 + r4);

   202           t:= t + 0.001;

   203           if ((x and $FFFFF800) = 0) and ((y and $FFFFFC00) = 0) then

   204                 Land[y, x]:= $FFFFFF;

   205           end;

   206     end;

   207 end;

   208 

   209 procedure FillLand(x, y: integer);

   210 var Stack: record

   211            Count: Longword;

   212            points: array[0..8192] of record

   213                                      xl, xr, y, dir: integer;

   214                                      end

   215            end;

   216 

   217     procedure Push(_xl, _xr, _y, _dir: integer);

   218     begin

   219     _y:= _y + _dir;

   220     if (_y < 0) or (_y > 1023) then exit;

   221     with Stack.points[Stack.Count] do

   222          begin

   223          xl:= _xl;

   224          xr:= _xr;

   225          y:= _y;

   226          dir:= _dir

   227          end;

   228     inc(Stack.Count);

   229     TryDo(Stack.Count < 8192, 'stack overflow', true)

   230     end;

   231 

   232     procedure Pop(out _xl, _xr, _y, _dir: integer);

   233     begin

   234     dec(Stack.Count);

   235     with Stack.points[Stack.Count] do

   236          begin

   237          _xl:= xl;

   238          _xr:= xr;

   239          _y:= y;

   240          _dir:= dir

   241          end

   242     end;

   243 

   244 var xl, xr, dir: integer;

   245 begin

   246 Stack.Count:= 0;

   247 xl:= x - 1;

   248 xr:= x;

   249 Push(xl, xr, 1024, -1);

   250 while Stack.Count > 0 do

   251       begin

   252       Pop(xl, xr, y, dir);

   253       while (xl > 0) and (Land[y, xl] = 0) do dec(xl);

   254       while (xr < 2047) and (Land[y, xr] = 0) do inc(xr);

   255       while (xl < xr) do

   256             begin

   257             while (xl <= xr) and (Land[y, xl] <> 0) do inc(xl);

   258             x:= xl;

   259             while (xl <= xr) and (Land[y, xl] = 0) do

   260                   begin

   261                   Land[y, xl]:= $FFFFFF;

   262                   inc(xl)

   263                   end;

   264             if x < xl then Push(x, Pred(xl), y, dir)

   265             end;

   266       end;

   267 end;

   268 

   269 procedure ColorizeLand(Surface: PSDL_Surface);

   270 var tmpsurf: PSDL_Surface;

   271     r: TSDL_Rect;

   272 begin

   273 tmpsurf:= LoadImage(Pathz[ptThemeCurrent] + 'LandTex.png');

   274 r.y:= 0;

   275 while r.y < 1024 do

   276       begin

   277       r.x:= 0;

   278       while r.x < 2048 do

   279             begin

   280             SDL_UpperBlit(tmpsurf, nil, Surface, @r);

   281             inc(r.x, tmpsurf.w)

   282             end;

   283       inc(r.y, tmpsurf.h)

   284       end;

   285 SDL_FreeSurface(tmpsurf);

   286 

   287 tmpsurf:= SDL_CreateRGBSurfaceFrom(@Land, 2048, 1024, 32, 2048*4, $FF0000, $FF00, $FF, 0);

   288 SDLTry(tmpsurf <> nil, true);

   289 SDL_SetColorKey(tmpsurf, SDL_SRCCOLORKEY, SDL_MapRGB(tmpsurf.format, $FF, $FF, $FF));

   290 SDL_UpperBlit(tmpsurf, nil, Surface, nil)

   291 end;

   292 

   293 procedure AddBorder(Surface: PSDL_Surface);

   294 var tmpsurf: PSDL_Surface;

   295     r, rr: TSDL_Rect;

   296     x, yd, yu: integer;

   297 begin

   298 tmpsurf:= LoadImage(Pathz[ptThemeCurrent] + 'Border.png');

   299 for x:= 0 to 2047 do

   300     begin

   301     yd:= 1023;

   302     repeat

   303       while (yd > 0   ) and (Land[yd, x] =  0) do dec(yd);

   304       if (yd < 0) then yd:= 0;

   305       while (yd < 1024) and (Land[yd, x] <> 0) do inc(yd);

   306       dec(yd);

   307       yu:= yd;

   308       while (yu > 0  ) and (Land[yu, x] <> 0) do dec(yu);

   309       while (yu < yd ) and (Land[yu, x] =  0) do inc(yu);

   310       if (yd < 1023) and ((yd - yu) >= 16) then

   311          begin

   312          rr.x:= x;

   313          rr.y:= yd - 15;

   314          r.x:= x mod tmpsurf.w;

   315          r.y:= 16;

   316          r.w:= 1;

   317          r.h:= 16;

   318          SDL_UpperBlit(tmpsurf, @r, Surface, @rr);

   319          end;

   320       if (yu > 0) then

   321          begin

   322          rr.x:= x;

   323          rr.y:= yu;

   324          r.x:= x mod tmpsurf.w;

   325          r.y:= 0;

   326          r.w:= 1;

   327          r.h:= min(16, yd - yu + 1);

   328          SDL_UpperBlit(tmpsurf, @r, Surface, @rr);

   329          end;

   330       yd:= yu - 1;

   331     until yd < 0;

   332     end;

   333 end;

   334 

   335 procedure AddGirders(Surface: PSDL_Surface);

   336 var tmpsurf: PSDL_Surface;

   337     x1, x2, y, k, i: integer;

   338     r, rr: TSDL_Rect;

   339 

   340     function CountZeroz(x, y: integer): Longword;

   341     var i: integer;

   342     begin

   343     Result:= 0;

   344     for i:= y to y + 15 do

   345         if Land[i, x] <> 0 then inc(Result)

   346     end;

   347 

   348 begin

   349 y:= 256;

   350 repeat

   351   inc(y, 24);

   352   x1:= 1024;

   353   x2:= 1024;

   354   while (x1 > 100) and (CountZeroz(x1, y) = 0) do dec(x1, 2);

   355   i:= x1 - 12;

   356   repeat

   357     k:= CountZeroz(x1, y);

   358     dec(x1, 2)

   359   until (x1 < 100) or (k = 0) or (k = 16) or (x1 < i);

   360   inc(x1, 2);

   361   if k = 16 then

   362      begin

   363      while (x2 < 1900) and (CountZeroz(x2, y) = 0) do inc(x2, 2);

   364      i:= x2 + 12;

   365      repeat

   366        k:= CountZeroz(x2, y);

   367        inc(x2, 2)

   368      until (x2 > 1900) or (k = 0) or (k = 16) or (x2 > i);

   369      if (x2 < 1900) and (k = 16) and (x2 - x1 > 250) then break;

   370      end;

   371 x1:= 0;

   372 until y > 900;

   373 if x1 > 0 then

   374    begin

   375    tmpsurf:= LoadImage(Pathz[ptGraphics] + 'Girder.png');

   376    rr.x:= x1;

   377    rr.y:= y;

   378    while rr.x + 100 < x2 do

   379          begin

   380          SDL_UpperBlit(tmpsurf, nil, Surface, @rr);

   381          inc(rr.x, 100);

   382          end;

   383    r.x:= 0;

   384    r.y:= 0;

   385    r.w:= x2 - rr.x;

   386    r.h:= 16;

   387    SDL_UpperBlit(tmpsurf, @r, Surface, @rr);

   388    SDL_FreeSurface(tmpsurf);

   389    for k:= y to y + 15 do

   390        for i:= x1 to x2 do Land[k, i]:= $FFFFFF

   391    end

   392 end;

   393 

   394 procedure AddHHPoints;

   395 var i, x, y: integer;

   396 begin

   397 for i:= 0 to 9 do

   398     begin

   399     y:= 0;

   400     x:= i * 160 + 300;

   401     repeat

   402     inc(y, 2);

   403     until (y > 1023) or (Land[y, x - 6] <> 0) or (Land[y, x - 3] <> 0) or (Land[y, x] <> 0)

   404                      or (Land[y, x + 3] <> 0) or (Land[y, x + 6] <> 0);

   405     AddHHPoint(x, y - 12)

   406     end;

   407 end;

   408 

   409 procedure GenLandSurface;

   410 var pa: TPixAr;

   411     tmpsurf: PSDL_Surface;

   412 begin

   413 GenEdge(pa);

   414 DrawBezierBorder(pa);

   415 FillLand(1023, 1023);

   416 AddProgress;

   417 with PixelFormat^ do

   418      tmpsurf:= SDL_CreateRGBSurface(SDL_HWSURFACE, 2048, 1024, BitsPerPixel, RMask, GMask, BMask, 0);

   419 ColorizeLand(tmpsurf);

   420 AddProgress;

   421 AddBorder(tmpsurf);

   422 with PixelFormat^ do

   423      LandSurface:= SDL_CreateRGBSurface(SDL_HWSURFACE, 2048, 1024, BitsPerPixel, RMask, GMask, BMask, 0);

   424 SDL_FillRect(LandSurface, nil, 0);

   425 AddGirders(LandSurface);

   426 SDL_SetColorKey(tmpsurf, SDL_SRCCOLORKEY, 0);

   427 SDL_UpperBlit(tmpsurf, nil, LandSurface, nil);

   428 SDL_FreeSurface(tmpsurf);

   429 AddProgress;

   430 AddHHPoints;

   431 RandomizeHHPoints;

   432 end;

   433 

   434 procedure MakeFortsMap;

   435 var p: PTeam;

   436     tmpsurf: PSDL_Surface;

   437 begin

   438 p:= TeamsList;

   439 TryDo(p <> nil, 'No teams on map!', true);

   440 with PixelFormat^ do

   441      LandSurface:= SDL_CreateRGBSurface(SDL_HWSURFACE, 2048, 1024, BitsPerPixel, RMask, GMask, BMask, 0);

   442 tmpsurf:= LoadImage(Pathz[ptForts] + p.FortName + 'L.png');

   443 BlitImageAndGenerateCollisionInfo(0, 0, tmpsurf, LandSurface);

   444 SDL_FreeSurface(tmpsurf);

   445 p:= p.Next;

   446 TryDo(p <> nil, 'Only one team on map!', true);

   447 tmpsurf:= LoadImage(Pathz[ptForts] + p.FortName + 'R.png');

   448 BlitImageAndGenerateCollisionInfo(1024, 0, tmpsurf, LandSurface);

   449 SDL_FreeSurface(tmpsurf);

   450 p:= p.Next;

   451 TryDo(p = nil, 'More than 2 teams on map in forts mode!', true);

   452 AddHHPoints

   453 end;

   454 

   455 procedure AddHHPoint(_x, _y: integer);

   456 begin

   457 with HHPoints do

   458      begin

   459      inc(Last);

   460      TryDo(Last < cMaxHHs, 'HHs coords queue overflow', true);

   461      with ar[Last] do

   462           begin

   463           x:= _x;

   464           y:= _y

   465           end

   466      end

   467 end;

   468 

   469 procedure GetHHPoint(out _x, _y: integer);

   470 begin

   471 with HHPoints do

   472      begin

   473      TryDo(First <= Last, 'HHs coords queue underflow ' + inttostr(First), true);

   474      with ar[First] do

   475           begin

   476           _x:= x;

   477           _y:= y

   478           end;

   479      inc(First)

   480      end

   481 end;

   482 

   483 procedure RandomizeHHPoints;

   484 var i, t: integer;

   485     p: TPoint;

   486 begin

   487 with HHPoints do

   488      begin

   489      for i:= First to Last do

   490          begin

   491          t:= GetRandom(Last - First + 1) + First;

   492          if i <> t then

   493             begin

   494             p:= ar[i];

   495             ar[i]:= ar[t];

   496             ar[t]:= p

   497             end

   498          end

   499      end

   500 end;

   501 

   502 end.