1 unit uLandObjects;

     2 interface

     3 uses SDLh;

     4 {$include options.inc}

     5 

     6 procedure AddObjects(Surface: PSDL_Surface);

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

     8 

     9 implementation

    10 uses uLand, uStore, uConsts, uMisc, uConsole, uRandom;

    11 const MaxRects = 1024;

    12       MAXOBJECTRECTS = 32;

    13 type  PRectArray = ^TRectsArray;

    14       TRectsArray = array[0..MaxRects] of TSDL_rect;

    15 

    16 type TThemeObject = record

    17                     Surf: PSDL_Surface;

    18                     inland: TSDL_Rect;

    19                     outland: array[1..MAXOBJECTRECTS] of TSDL_Rect;

    20                     rectcnt: Longword;

    21                     Width, Height: Longword;

    22                     end;

    23 

    24 var Rects: PRectArray;

    25     RectCount: Longword;

    26 

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

    28 var i, p: LongWord;

    29     x, y: Longword;

    30     bpp: integer;

    31     r: TSDL_Rect;

    32 begin

    33 r.x:= cpX;

    34 r.y:= cpY;

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

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

    37 

    38 if SDL_MustLock(Image) then

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

    40 

    41 bpp:= Image.format.BytesPerPixel;

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

    43 p:= LongWord(Image.pixels);

    44 case bpp of

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

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

    47             begin

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

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

    50                 if PWord(p + x * 2)^ <> 0 then PLongWord(i + x * 4)^:= $FFFFFF;

    51             inc(p, Image.pitch);

    52             end;

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

    54             begin

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

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

    57                 if  (PByte(p + x * 3 + 0)^ <> 0)

    58                  or (PByte(p + x * 3 + 1)^ <> 0)

    59                  or (PByte(p + x * 3 + 2)^ <> 0) then PLongWord(i + x * 4)^:= $FFFFFF;

    60             inc(p, Image.pitch);

    61             end;

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

    63             begin

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

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

    66                 if PLongword(p + x * 4)^ <> 0 then PLongWord(i + x * 4)^:= $FFFFFF;

    67             inc(p, Image.pitch);

    68             end;

    69      end;

    70 if SDL_MustLock(Image) then

    71    SDL_UnlockSurface(Image);

    72 WriteLnToConsole(msgOK)

    73 end;

    74 

    75 procedure AddRect(x1, y1, w1, h1: integer);

    76 begin

    77 with Rects[RectCount] do

    78      begin

    79      x:= x1;

    80      y:= y1;

    81      w:= w1;

    82      h:= h1

    83      end;

    84 inc(RectCount);

    85 TryDo(RectCount < MaxRects, 'AddRect: overflow', true)

    86 end;

    87 

    88 procedure InitRects;

    89 begin

    90 RectCount:= 0;

    91 New(Rects)

    92 end;

    93 

    94 procedure FreeRects;

    95 begin

    96 Dispose(rects)

    97 end;

    98 

    99 function CheckIntersect(x1, y1, w1, h1: integer): boolean;

   100 var i: Longword;

   101 begin

   102 Result:= false;

   103 i:= 0;

   104 if RectCount > 0 then

   105    repeat

   106    with Rects[i] do

   107         Result:= (x < x1 + w1) and (x1 < x + w) and

   108                  (y < y1 + h1) and (y1 < y + h);

   109    inc(i)

   110    until (i = RectCount) or (Result)

   111 end;

   112 

   113 procedure AddGirders(Surface: PSDL_Surface);

   114 var tmpsurf: PSDL_Surface;

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

   116     r, rr: TSDL_Rect;

   117 

   118     function CountNonZeroz(x, y: integer): Longword;

   119     var i: integer;

   120     begin

   121     Result:= 0;

   122     for i:= y to y + 15 do

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

   124     end;

   125 

   126 begin

   127 y:= 256;

   128 repeat

   129   inc(y, 24);

   130   x1:= 1024;

   131   x2:= 1024;

   132   while (x1 > 100) and (CountNonZeroz(x1, y) = 0) do dec(x1, 2);

   133   i:= x1 - 12;

   134   repeat

   135     k:= CountNonZeroz(x1, y);

   136     dec(x1, 2)

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

   138   inc(x1, 2);

   139   if k = 16 then

   140      begin

   141      while (x2 < 1900) and (CountNonZeroz(x2, y) = 0) do inc(x2, 2);

   142      i:= x2 + 12;

   143      repeat

   144        k:= CountNonZeroz(x2, y);

   145        inc(x2, 2)

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

   147      if (x2 < 1900) and (k = 16) and (x2 - x1 > 250)

   148         and not CheckIntersect(x1, y, x2 - x1, 16) then break;

   149      end;

   150 x1:= 0;

   151 until y > 900;

   152 if x1 > 0 then

   153    begin

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

   155    rr.x:= x1;

   156    rr.y:= y;

   157    while rr.x + 100 < x2 do

   158          begin

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

   160          inc(rr.x, 100);

   161          end;

   162    r.x:= 0;

   163    r.y:= 0;

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

   165    r.h:= 16;

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

   167    SDL_FreeSurface(tmpsurf);

   168    AddRect(x1 - 8, y - 8, x2 - x1 + 8, 32);

   169    for k:= y to y + 15 do

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

   171    end

   172 end;

   173 

   174 function CheckLand(rect: TSDL_Rect; dX, dY, Color: Longword): boolean;

   175 var i: Longword;

   176 begin

   177 Result:= true;

   178 inc(rect.x, dX);

   179 inc(rect.y, dY);

   180 i:= 0;

   181 {$WARNINGS OFF}

   182 while (i <= rect.w) and Result do

   183       begin

   184       Result:= (Land[rect.y, rect.x + i] = Color) and (Land[rect.y + rect.h, rect.x + i] = Color);

   185       inc(i)

   186       end;

   187 i:= 0;

   188 while (i <= rect.h) and Result do

   189       begin

   190       Result:= (Land[rect.y + i, rect.x] = Color) or (Land[rect.y + i, rect.x + rect.w] = Color);

   191       inc(i)

   192       end;

   193 {$WARNINGS ON}

   194 end;

   195 

   196 function CheckCanPlace(x, y: Longword; var Obj: TThemeObject): boolean;

   197 var i: Longword;

   198 begin

   199 with Obj do

   200      if CheckLand(inland, x, y, $FFFFFF) then

   201         begin

   202         Result:= true;

   203         i:= 1;

   204         while Result and (i <= rectcnt) do

   205               begin

   206               Result:= CheckLand(outland[i], x, y, 0);

   207               inc(i)

   208               end;

   209         if Result then

   210            Result:= not CheckIntersect(x, y, Width, Height)

   211         end else

   212         Result:= false

   213 end;

   214 

   215 function TryPut(var Obj: TThemeObject; Surface: PSDL_Surface): boolean;

   216 const MaxPointsIndex = 2047;

   217 var x, y: Longword;

   218     ar: array[0..MaxPointsIndex] of TPoint;

   219     cnt, i: Longword;

   220 begin

   221 cnt:= 0;

   222 with Obj do

   223      begin

   224      x:= 0;

   225      repeat

   226          y:= 0;

   227          repeat

   228              if CheckCanPlace(x, y, Obj) then

   229                 begin

   230                 ar[cnt].x:= x;

   231                 ar[cnt].y:= y;

   232                 inc(cnt);

   233                 if cnt > MaxPointsIndex then // buffer is full, do not check the rest land

   234                    begin

   235                    y:= 5000;

   236                    x:= 5000;

   237                    end

   238                 end;

   239              inc(y, 2);

   240          until y > 1023 - Height;

   241          inc(x, getrandom(8) + 2)

   242      until x > 2047 - Width;

   243      Result:= cnt <> 0;

   244      if Result then

   245         begin

   246         i:= getrandom(cnt);

   247         BlitImageAndGenerateCollisionInfo(ar[i].x, ar[i].y, Obj.Surf, Surface);

   248         AddRect(ar[i].x, ar[i].y, Width, Height);

   249         end

   250      end

   251 end;

   252 

   253 procedure AddThemeObjects(Surface: PSDL_Surface; MaxCount: Longword);

   254 const MAXTHEMEOBJECTS = 16;

   255 var f: textfile;

   256     s: string;

   257     ThemeObjects: array[1..MAXTHEMEOBJECTS] of TThemeObject;

   258     i, ii, t, n: Longword;

   259     b: boolean;

   260 begin

   261 s:= Pathz[ptThemeCurrent] + cThemeCFGFilename;

   262 WriteLnToConsole('Adding objects...');

   263 AssignFile(f, s);

   264 {$I-}

   265 Reset(f);

   266 Readln(f, s); // skip color

   267 Readln(f, n);

   268 for i:= 1 to n do

   269     begin

   270     Readln(f, s); // filename

   271     with ThemeObjects[i] do

   272          begin

   273          Surf:= LoadImage(Pathz[ptThemeCurrent] + s + '.png');

   274          Read(f, Width, Height);

   275          with inland do Read(f, x, y, w, h);

   276          Read(f, rectcnt);

   277          for ii:= 1 to rectcnt do

   278              with outland[ii] do Read(f, x, y, w, h);

   279          ReadLn(f)

   280          end;

   281     end;

   282 Closefile(f);

   283 {$I+}

   284 TryDo(IOResult = 0, 'Bad data or cannot access file', true);

   285 

   286 // loaded objects, try to put on land

   287 if n = 0 then exit;

   288 i:= 1;

   289 repeat

   290     t:= getrandom(n) + 1;

   291     ii:= t;

   292     repeat

   293       inc(ii);

   294       if ii > n then ii:= 1;

   295       b:= TryPut(ThemeObjects[ii], Surface)

   296     until b or (ii = t);

   297 inc(i)

   298 until (i > MaxCount) or not b

   299 end;

   300 

   301 procedure AddObjects(Surface: PSDL_Surface);

   302 begin

   303 InitRects;

   304 AddGirders(Surface);

   305 AddThemeObjects(Surface, 5);

   306 FreeRects

   307 end;

   308 

   309 end.