src/game/g_basic.pas

   1 (* Copyright (C)  Doom 2D: Forever Developers
   2  *
   3  * This program is free software: you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation, version 3 of the License ONLY.
   6  *
   7  * This program is distributed in the hope that it will be useful,
   8  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   9  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  10  * GNU General Public License for more details.
  11  *
  12  * You should have received a copy of the GNU General Public License
  13  * along with this program.  If not, see <http://www.gnu.org/licenses/>.
  14  *)
  15 {$INCLUDE ../shared/a_modes.inc}
  16 unit g_basic;
  17
  18 interface
  19
  20 uses
  21   utils, g_phys;
  22
  23 const
  24   GAME_VERSION  = '0.667';
  25   GAME_BUILDDATE = {$I %DATE%};
  26   GAME_BUILDTIME = {$I %TIME%};
  27   UID_GAME    = 1;
  28   UID_PLAYER  = 2;
  29   UID_MONSTER = 3;
  30   UID_ITEM    = 10;
  31   UID_MAX_GAME    = $10;
  32   UID_MAX_PLAYER  = $7FFF;
  33   UID_MAX_MONSTER = $FFFF;
  34
  35 type
  36   TDirection = (D_LEFT, D_RIGHT);
  37   WArray = array of Word;
  38   DWArray = array of DWORD;
  39   String20 = String[20];
  40
  41 function g_CreateUID(UIDType: Byte): Word;
  42 function g_GetUIDType(UID: Word): Byte;
  43 function g_Collide(X1, Y1: Integer; Width1, Height1: Word;
  44                    X2, Y2: Integer; Width2, Height2: Word): Boolean; inline;
  45 function g_CollideLine(x1, y1, x2, y2, rX, rY: Integer; rWidth, rHeight: Word): Boolean;
  46 function g_CollidePoint(X, Y, X2, Y2: Integer; Width, Height: Word): Boolean; inline;
  47 function g_CollideLevel(X, Y: Integer; Width, Height: Word): Boolean; inline;
  48 function g_CollideAround(X1, Y1: Integer; Width1, Height1: Word;
  49                          X2, Y2: Integer; Width2, Height2: Word): Boolean; inline;
  50 function g_CollidePlayer(X, Y: Integer; Width, Height: Word): Boolean; inline;
  51 function g_PatchLength(X1, Y1, X2, Y2: Integer): Word;
  52 function g_TraceVector(X1, Y1, X2, Y2: Integer): Boolean; // `true`: no wall hit
  53 function g_GetAcidHit(X, Y: Integer; Width, Height: Word): Byte;
  54 function g_Look(a, b: PObj; d: TDirection): Boolean;
  55 procedure IncMax(var A: Integer; B, Max: Integer); overload;
  56 procedure IncMax(var A: Single; B, Max: Single); overload;
  57 procedure IncMax(var A: Integer; Max: Integer); overload;
  58 procedure IncMax(var A: Single; Max: Single); overload;
  59 procedure IncMax(var A: Word; B, Max: Word); overload;
  60 procedure IncMax(var A: Word; Max: Word); overload;
  61 procedure IncMax(var A: SmallInt; B, Max: SmallInt); overload;
  62 procedure IncMax(var A: SmallInt; Max: SmallInt); overload;
  63 procedure DecMin(var A: Integer; B, Min: Integer); overload;
  64 procedure DecMin(var A: Single; B, Min: Single); overload;
  65 procedure DecMin(var A: Integer; Min: Integer); overload;
  66 procedure DecMin(var A: Single; Min: Single); overload;
  67 procedure DecMin(var A: Word; B, Min: Word); overload;
  68 procedure DecMin(var A: Word; Min: Word); overload;
  69 procedure DecMin(var A: Byte; B, Min: Byte); overload;
  70 procedure DecMin(var A: Byte; Min: Byte); overload;
  71 function Sign(A: Integer): ShortInt; overload;
  72 function Sign(A: Single): ShortInt; overload;
  73 function PointToRect(X, Y, X1, Y1: Integer; Width, Height: Word): Integer;
  74 function GetAngle(baseX, baseY, pointX, PointY: Integer): SmallInt;
  75 function GetAngle2(vx, vy: Integer): SmallInt;
  76 function GetLines(Text: string; FontID: DWORD; MaxWidth: Word): SSArray;
  77 procedure Sort(var a: SSArray);
  78 function Sscanf(const s: string; const fmt: string;
  79                 const Pointers: array of Pointer): Integer;
  80 function InDWArray(a: DWORD; arr: DWArray): Boolean;
  81 function InWArray(a: Word; arr: WArray): Boolean;
  82 function InSArray(a: string; arr: SSArray): Boolean;
  83 function GetPos(UID: Word; o: PObj): Boolean;
  84 function parse(s: string): SSArray;
  85 function parse2(s: string; delim: Char): SSArray;
  86 function g_GetFileTime(fileName: String): Integer;
  87 function g_SetFileTime(fileName: String; time: Integer): Boolean;
  88 procedure SortSArray(var S: SSArray);
  89 function b_Text_Format(S: string): string;
  90 function b_Text_Unformat(S: string): string;
  91 function b_Text_Wrap(S: string; LineLen: Integer): string;
  92 function b_Text_LineCount(S: string): Integer;
  93
  94 var
  95   gmon_dbg_los_enabled: Boolean = true;
  96
  97 implementation
  98
  99 uses
 100   Math, geom, e_log, g_map, g_gfx, g_player, SysUtils, MAPDEF,
 101   StrUtils, e_graphics, g_monsters, g_items, g_game;
 102
 103 function g_PatchLength(X1, Y1, X2, Y2: Integer): Word;
 104 begin
 105   Result := Min(Round(Hypot(Abs(X2-X1), Abs(Y2-Y1))), 65535);
 106 end;
 107
 108 function g_CollideLevel(X, Y: Integer; Width, Height: Word): Boolean; inline;
 109 begin
 110   result := g_Map_CollidePanel(X, Y, Width, Height, (PANEL_WALL or PANEL_CLOSEDOOR or PANEL_OPENDOOR), false);
 111 end;
 112 (*
 113 var
 114   a: Integer;
 115 begin
 116   Result := False;
 117
 118   if gWalls = nil then
 119     Exit;
 120
 121   for a := 0 to High(gWalls) do
 122     if gWalls[a].Enabled and
 123        not ( ((Y + Height <= gWalls[a].Y) or
 124               (Y          >= gWalls[a].Y + gWalls[a].Height)) or
 125              ((X + Width  <= gWalls[a].X) or
 126               (X          >= gWalls[a].X + gWalls[a].Width)) ) then
 127     begin
 128       Result := True;
 129       Exit;
 130     end;
 131 end;
 132 *)
 133
 134 function g_CollidePlayer(X, Y: Integer; Width, Height: Word): Boolean; inline;
 135 var
 136   a: Integer;
 137 begin
 138   Result := False;
 139
 140   if gPlayers = nil then Exit;
 141
 142   for a := 0 to High(gPlayers) do
 143     if (gPlayers[a] <> nil) and gPlayers[a].alive then
 144       if gPlayers[a].Collide(X, Y, Width, Height) then
 145       begin
 146         Result := True;
 147         Exit;
 148       end;
 149 end;
 150
 151
 152 function g_TraceVector(X1, Y1, X2, Y2: Integer): Boolean;
 153 var
 154   wallHitX: Integer = 0;
 155   wallHitY: Integer = 0;
 156 (*
 157   i: Integer;
 158   dx, dy: Integer;
 159   Xerr, Yerr, d: LongWord;
 160   incX, incY: Integer;
 161   x, y: Integer;
 162 *)
 163 begin
 164   (*
 165   result := False;
 166
 167   Assert(gCollideMap <> nil, 'g_TraceVector: gCollideMap = nil');
 168
 169   Xerr := 0;
 170   Yerr := 0;
 171   dx := X2-X1;
 172   dy := Y2-Y1;
 173
 174   if dx > 0 then incX := 1 else if dx < 0 then incX := -1 else incX := 0;
 175   if dy > 0 then incY := 1 else if dy < 0 then incY := -1 else incY := 0;
 176
 177   dx := abs(dx);
 178   dy := abs(dy);
 179
 180   if dx > dy then d := dx else d := dy;
 181
 182   x := X1;
 183   y := Y1;
 184
 185   for i := 1 to d do
 186   begin
 187     Inc(Xerr, dx);
 188     Inc(Yerr, dy);
 189     if Xerr>d then
 190     begin
 191       Dec(Xerr, d);
 192       Inc(x, incX);
 193     end;
 194     if Yerr > d then
 195     begin
 196       Dec(Yerr, d);
 197       Inc(y, incY);
 198     end;
 199
 200     if (y > gMapInfo.Height-1) or
 201     (y < 0) or (x > gMapInfo.Width-1) or (x < 0) then
 202       Exit;
 203     if ByteBool(gCollideMap[y, x] and MARK_BLOCKED) then
 204       Exit;
 205   end;
 206
 207   Result := True;
 208   *)
 209
 210   // `true` if no obstacles
 211   if (g_profile_los) then g_Mons_LOS_Start();
 212   result := (g_Map_traceToNearestWall(x1, y1, x2, y2, @wallHitX, @wallHitY) = nil);
 213   if (g_profile_los) then g_Mons_LOS_End();
 214 end;
 215
 216
 217 function g_CreateUID(UIDType: Byte): Word;
 218 var
 219   ok: Boolean;
 220   i: Integer;
 221 begin
 222   Result := $0;
 223
 224   case UIDType of
 225     UID_PLAYER:
 226     begin
 227       repeat
 228         Result := UID_MAX_GAME+$1+Random(UID_MAX_PLAYER-UID_MAX_GAME+$1);
 229
 230         ok := True;
 231         if gPlayers <> nil then
 232           for i := 0 to High(gPlayers) do
 233             if gPlayers[i] <> nil then
 234               if Result = gPlayers[i].UID then
 235               begin
 236                 ok := False;
 237                 Break;
 238               end;
 239       until ok;
 240     end;
 241
 242     UID_MONSTER:
 243     begin
 244       //FIXME!!!
 245       while true do
 246       begin
 247         result := UID_MAX_PLAYER+$1+Random(UID_MAX_MONSTER-UID_MAX_GAME-UID_MAX_PLAYER+$1);
 248         if (g_Monsters_ByUID(result) = nil) then break;
 249       end;
 250     end;
 251   end;
 252 end;
 253
 254 function g_GetUIDType(UID: Word): Byte;
 255 begin
 256   if UID <= UID_MAX_GAME then
 257     Result := UID_GAME
 258   else
 259     if UID <= UID_MAX_PLAYER then
 260       Result := UID_PLAYER
 261     else
 262       Result := UID_MONSTER;
 263 end;
 264
 265 function g_Collide(X1, Y1: Integer; Width1, Height1: Word;
 266                    X2, Y2: Integer; Width2, Height2: Word): Boolean; inline;
 267 begin
 268   Result := not ( ((Y1 + Height1 <= Y2) or
 269                    (Y2 + Height2 <= Y1)) or
 270                   ((X1 + Width1  <= X2) or
 271                    (X2 + Width2  <= X1)) );
 272 end;
 273
 274 function g_CollideAround(X1, Y1: Integer; Width1, Height1: Word;
 275                          X2, Y2: Integer; Width2, Height2: Word): Boolean; inline;
 276 begin
 277   Result := g_Collide(X1, Y1, Width1, Height1, X2, Y2, Width2, Height2) or
 278             g_Collide(X1+1, Y1, Width1, Height1, X2, Y2, Width2, Height2) or
 279             g_Collide(X1-1, Y1, Width1, Height1, X2, Y2, Width2, Height2) or
 280             g_Collide(X1, Y1+1, Width1, Height1, X2, Y2, Width2, Height2) or
 281             g_Collide(X1, Y1-1, Width1, Height1, X2, Y2, Width2, Height2);
 282 end;
 283
 284 function c(X1, Y1, Width1, Height1, X2, Y2, Width2, Height2: Integer): Boolean; inline;
 285 begin
 286   Result := not (((Y1 + Height1 <= Y2) or
 287                   (Y1           >= Y2 + Height2)) or
 288                   ((X1 + Width1 <= X2) or
 289                    (X1          >= X2 + Width2)));
 290 end;
 291
 292 function g_Collide2(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer): Boolean; inline;
 293 begin
 294   //Result :=  not (((Y2 <= Y3) or (Y1  >= Y4)) or ((X2 <= X3) or (X1  >= X4)));
 295   Result := c(X1, Y1, X2-X1, Y2-Y1, X3, Y3, X4-X3, Y4-Y3);
 296 end;
 297
 298 function g_CollidePoint(X, Y, X2, Y2: Integer; Width, Height: Word): Boolean; inline;
 299 begin
 300   X := X-X2;
 301   Y := Y-Y2;
 302   Result := (x >= 0) and (x <= Width) and
 303             (y >= 0) and (y <= Height);
 304 end;
 305
 306 procedure IncMax(var A: Integer; B, Max: Integer);
 307 begin
 308   if A+B > Max then A := Max else A := A+B;
 309 end;
 310
 311 procedure IncMax(var A: Single; B, Max: Single);
 312 begin
 313   if A+B > Max then A := Max else A := A+B;
 314 end;
 315
 316 procedure DecMin(var A: Integer; B, Min: Integer);
 317 begin
 318   if A-B < Min then A := Min else A := A-B;
 319 end;
 320
 321 procedure DecMin(var A: Word; B, Min: Word);
 322 begin
 323   if A-B < Min then A := Min else A := A-B;
 324 end;
 325
 326 procedure DecMin(var A: Single; B, Min: Single);
 327 begin
 328   if A-B < Min then A := Min else A := A-B;
 329 end;
 330
 331 procedure IncMax(var A: Integer; Max: Integer);
 332 begin
 333   if A+1 > Max then A := Max else A := A+1;
 334 end;
 335
 336 procedure IncMax(var A: Single; Max: Single);
 337 begin
 338   if A+1 > Max then A := Max else A := A+1;
 339 end;
 340
 341 procedure IncMax(var A: Word; B, Max: Word);
 342 begin
 343   if A+B > Max then A := Max else A := A+B;
 344 end;
 345
 346 procedure IncMax(var A: Word; Max: Word);
 347 begin
 348   if A+1 > Max then A := Max else A := A+1;
 349 end;
 350
 351 procedure IncMax(var A: SmallInt; B, Max: SmallInt);
 352 begin
 353   if A+B > Max then A := Max else A := A+B;
 354 end;
 355
 356 procedure IncMax(var A: SmallInt; Max: SmallInt);
 357 begin
 358   if A+1 > Max then A := Max else A := A+1;
 359 end;
 360
 361 procedure DecMin(var A: Integer; Min: Integer);
 362 begin
 363   if A-1 < Min then A := Min else A := A-1;
 364 end;
 365
 366 procedure DecMin(var A: Single; Min: Single);
 367 begin
 368   if A-1 < Min then A := Min else A := A-1;
 369 end;
 370
 371 procedure DecMin(var A: Word; Min: Word);
 372 begin
 373   if A-1 < Min then A := Min else A := A-1;
 374 end;
 375
 376 procedure DecMin(var A: Byte; B, Min: Byte);
 377 begin
 378   if A-B < Min then A := Min else A := A-B;
 379 end;
 380
 381 procedure DecMin(var A: Byte; Min: Byte); overload;
 382 begin
 383   if A-1 < Min then A := Min else A := A-1;
 384 end;
 385
 386 function Sign(A: Integer): ShortInt;
 387 begin
 388   if A < 0 then Result := -1
 389     else if A > 0 then Result := 1
 390       else Result := 0;
 391 end;
 392
 393 function Sign(A: Single): ShortInt;
 394 const
 395   Eps = 1.0E-5;
 396 begin
 397   if Abs(A) < Eps then Result := 0
 398     else if A < 0 then Result := -1
 399       else Result := 1;
 400 end;
 401
 402 function PointToRect(X, Y, X1, Y1: Integer; Width, Height: Word): Integer;
 403 begin
 404   X := X-X1;            // A(0;0) --- B(W;0)
 405   Y := Y-Y1;            // |          |
 406                         // D(0;H) --- C(W;H)
 407   if X < 0 then
 408     begin // Ñëåâà
 409       if Y < 0 then // Ñëåâà ñâåðõó: ðàññòîÿíèå äî A
 410         Result := Round(Hypot(X, Y))
 411       else
 412         if Y > Height then // Ñëåâà ñíèçó: ðàññòîÿíèå äî D
 413           Result := Round(Hypot(X, Y-Height))
 414         else // Ñëåâà ïîñåðåäèíå: ðàññòîÿíèå äî AD
 415           Result := -X;
 416     end
 417   else
 418     if X > Width then
 419       begin // Ñïðàâà
 420         X := X-Width;
 421         if y < 0 then // Ñïðàâà ñâåðõó: ðàññòîÿíèå äî B
 422           Result := Round(Hypot(X, Y))
 423         else
 424           if Y > Height then // Ñïðàâà ñíèçó: ðàññòîÿíèå äî C
 425             Result := Round(Hypot(X, Y-Height))
 426           else // Ñïðàâà ïîñåðåäèíå: ðàññòîÿíèå äî BC
 427             Result := X;
 428       end
 429     else // Ïîñåðåäèíå
 430       begin
 431         if Y < 0 then // Ïîñåðåäèíå ñâåðõó: ðàññòîÿíèå äî AB
 432           Result := -Y
 433         else
 434           if Y > Height then // Ïîñåðåäèíå ñíèçó: ðàññòîÿíèå äî DC
 435             Result := Y-Height
 436           else // Âíóòðè ïðÿìîóãîëüíèêà: ðàññòîÿíèå 0
 437             Result := 0;
 438       end;
 439 end;
 440
 441 function g_GetAcidHit(X, Y: Integer; Width, Height: Word): Byte;
 442 const
 443   tab: array[0..3] of Byte = (0, 5, 10, 20);
 444 var
 445   a: Byte;
 446 begin
 447   a := 0;
 448
 449   if g_Map_CollidePanel(X, Y, Width, Height, PANEL_ACID1, False) then a := a or 1;
 450   if g_Map_CollidePanel(X, Y, Width, Height, PANEL_ACID2, False) then a := a or 2;
 451
 452   Result := tab[a];
 453 end;
 454
 455 function g_Look(a, b: PObj; d: TDirection): Boolean;
 456 begin
 457   if not gmon_dbg_los_enabled then begin result := false; exit; end; // always "wall hit"
 458
 459   if ((b^.X > a^.X) and (d = TDirection.D_LEFT)) or
 460      ((b^.X < a^.X) and (d = TDirection.D_RIGHT)) then
 461   begin
 462     Result := False;
 463     Exit;
 464   end;
 465
 466   Result := g_TraceVector(a^.X+a^.Rect.X+(a^.Rect.Width div 2),
 467                           a^.Y+a^.Rect.Y+(a^.Rect.Height div 2),
 468                           b^.X+b^.Rect.X+(b^.Rect.Width div 2),
 469                           b^.Y+b^.Rect.Y+(b^.Rect.Height div 2));
 470 end;
 471
 472 function GetAngle(baseX, baseY, pointX, PointY: Integer): SmallInt;
 473 var
 474   c: Single;
 475   a, b: Integer;
 476 begin
 477   a := abs(pointX-baseX);
 478   b := abs(pointY-baseY);
 479
 480   if a = 0 then c := 90
 481     else c := RadToDeg(ArcTan(b/a));
 482
 483   if pointY < baseY then c := -c;
 484   if pointX > baseX then c := 180-c;
 485
 486   Result := Round(c);
 487 end;
 488
 489 function GetAngle2(vx, vy: Integer): SmallInt;
 490 var
 491   c: Single;
 492   a, b: Integer;
 493 begin
 494   a := abs(vx);
 495   b := abs(vy);
 496
 497   if a = 0 then
 498     c := 90
 499   else
 500     c := RadToDeg(ArcTan(b/a));
 501
 502   if vy < 0 then
 503     c := -c;
 504   if vx > 0 then
 505     c := 180 - c;
 506
 507   c := c + 180;
 508
 509   Result := Round(c);
 510 end;
 511
 512 {function g_CollideLine(x1, y1, x2, y2, rX, rY: Integer; rWidth, rHeight: Word): Boolean;
 513 const
 514   table: array[0..8, 0..8] of Byte =
 515          ((0, 0, 3, 3, 1, 2, 2, 0, 1),
 516           (0, 0, 0, 0, 4, 7, 2, 0, 1),
 517           (3, 0, 0, 0, 4, 4, 1, 3, 1),
 518           (3, 0, 0, 0, 0, 0, 5, 6, 1),
 519           (1, 4, 4, 0, 0, 0, 5, 5, 1),
 520           (2, 7, 4, 0, 0, 0, 0, 0, 1),
 521           (2, 2, 1, 5, 5, 0, 0, 0, 1),
 522           (0, 0, 3, 6, 5, 0, 0, 0, 1),
 523           (1, 1, 1, 1, 1, 1, 1, 1, 1));
 524
 525 function GetClass(x, y: Integer): Byte;
 526 begin
 527  if y < rY then
 528  begin
 529   if x < rX then Result := 7
 530    else if x < rX+rWidth then Result := 0
 531     else Result := 1;
 532  end
 533   else if y < rY+rHeight then
 534  begin
 535   if x < rX then Result := 6
 536    else if x < rX+rWidth then Result := 8
 537     else Result := 2;
 538  end
 539   else
 540  begin
 541   if x < rX then Result := 5
 542    else if x < rX+rWidth then Result := 4
 543     else Result := 3;
 544  end;
 545 end;
 546
 547 begin
 548  case table[GetClass(x1, y1), GetClass(x2, y2)] of
 549   0: Result := False;
 550   1: Result := True;
 551   2: Result := Abs((rY-y1))/Abs((rX-x1)) <= Abs((y2-y1))/Abs((x2-x1));
 552   3: Result := Abs((rY-y1))/Abs((rX+rWidth-x1)) <= Abs((y2-y1))/Abs((x2-x1));
 553   4: Result := Abs((rY+rHeight-y1))/Abs((rX+rWidth-x1)) >= Abs((y2-y1))/Abs((x2-x1));
 554   5: Result := Abs((rY+rHeight-y1))/Abs((rX-x1)) >= Abs((y2-y1))/Abs((x2-x1));
 555   6: Result := (Abs((rY-y1))/Abs((rX+rWidth-x1)) <= Abs((y2-y1))/Abs((x2-x1))) and
 556                (Abs((rY+rHeight-y1))/Abs((rX-x1)) >= Abs((y2-y1))/Abs((x2-x1)));
 557   7: Result := (Abs((rY+rHeight-y1))/Abs((rX+rWidth-x1)) >= Abs((y2-y1))/Abs((x2-x1))) and
 558                (Abs((rY-y1))/Abs((rX-x1)) <= Abs((y2-y1))/Abs((x2-x1)));
 559   else Result := False;
 560  end;
 561 end;}
 562
 563 function g_CollideLine(x1, y1, x2, y2, rX, rY: Integer; rWidth, rHeight: Word): Boolean;
 564 {
 565 var
 566   i: Integer;
 567   dx, dy: Integer;
 568   Xerr, Yerr: Integer;
 569   incX, incY: Integer;
 570   x, y, d: Integer;
 571 }
 572 begin
 573   result := lineAABBIntersects(x1, y1, x2, y2, rX, rY, rWidth, rHeight);
 574 {
 575   Result := True;
 576
 577   Xerr := 0;
 578   Yerr := 0;
 579   dx := X2-X1;
 580   dy := Y2-Y1;
 581
 582   if dx > 0 then incX := 1 else if dx < 0 then incX := -1 else incX := 0;
 583   if dy > 0 then incY := 1 else if dy < 0 then incY := -1 else incY := 0;
 584
 585   dx := abs(dx);
 586   dy := abs(dy);
 587
 588   if dx > dy then d := dx else d := dy;
 589
 590   x := X1;
 591   y := Y1;
 592
 593   for i := 1 to d+1 do
 594   begin
 595     Inc(Xerr, dx);
 596     Inc(Yerr, dy);
 597     if Xerr > d then
 598     begin
 599       Dec(Xerr, d);
 600       Inc(x, incX);
 601     end;
 602     if Yerr > d then
 603     begin
 604       Dec(Yerr, d);
 605       Inc(y, incY);
 606     end;
 607
 608     if (x >= rX) and (x <= (rX + rWidth - 1)) and
 609        (y >= rY) and (y <= (rY + rHeight - 1)) then Exit;
 610   end;
 611
 612   Result := False;
 613 }
 614 end;
 615
 616 function GetStr(var Str: string): string;
 617 var
 618   a: Integer;
 619 begin
 620   Result := '';
 621   for a := 1 to Length(Str) do
 622     if (a = Length(Str)) or (Str[a+1] = ' ') then
 623     begin
 624       Result := Copy(Str, 1, a);
 625       Delete(Str, 1, a+1);
 626       Str := Trim(Str);
 627       Exit;
 628     end;
 629 end;
 630
 631 {function GetLines(Text: string; MaxChars: Word): SSArray;
 632 var
 633   a: Integer;
 634   b: array of string;
 635   str: string;
 636 begin
 637  Text := Trim(Text);
 638
 639  while Pos('  ', Text) <> 0 do Text := AnsiReplaceStr(Text, '  ', ' ');
 640
 641  while Text <> '' do
 642  begin
 643   SetLength(b, Length(b)+1);
 644   b[High(b)] := GetStr(Text);
 645  end;
 646
 647  a := 0;
 648  while True do
 649  begin
 650   if a > High(b) then Break;
 651
 652   str := b[a];
 653   a := a+1;
 654
 655   if Length(str) >= MaxChars then
 656   begin
 657    while str <> '' do
 658    begin
 659     SetLength(Result, Length(Result)+1);
 660     Result[High(Result)] := Copy(str, 1, MaxChars);
 661     Delete(str, 1, MaxChars);
 662    end;
 663
 664    Continue;
 665   end;
 666
 667   while (a <= High(b)) and (Length(str+' '+b[a]) <= MaxChars) do
 668   begin
 669    str := str+' '+b[a];
 670    a := a+1;
 671   end;
 672
 673   SetLength(Result, Length(Result)+1);
 674   Result[High(Result)] := str;
 675  end;
 676 end;}
 677
 678 function GetLines(Text: string; FontID: DWORD; MaxWidth: Word): SSArray;
 679
 680 function TextLen(Text: string): Word;
 681 var
 682   h: Word;
 683 begin
 684   e_CharFont_GetSize(FontID, Text, Result, h);
 685 end;
 686
 687 var
 688   a, c: Integer;
 689   b: array of string;
 690   str: string;
 691 begin
 692 {
 693   SetLength(Result, 0);
 694   SetLength(b, 0);
 695
 696   Text := Trim(Text);
 697
 698 // Óäàëÿåì ìíîæåñòâåííûå ïðîáåëû:
 699   while Pos('  ', Text) <> 0 do
 700     Text := AnsiReplaceStr(Text, '  ', ' ');
 701
 702   while Text <> '' do
 703   begin
 704     SetLength(b, Length(b)+1);
 705     b[High(b)] := GetStr(Text);
 706   end;
 707
 708   a := 0;
 709   while True do
 710   begin
 711     if a > High(b) then
 712       Break;
 713
 714     str := b[a];
 715     a := a+1;
 716
 717     if TextLen(str) > MaxWidth then
 718     begin // Òåêóùàÿ ñòðîêà ñëèøêîì äëèííàÿ => ðàçáèâàåì
 719       while (str[0] <> #0) and (str <> '') do
 720       begin
 721         SetLength(Result, Length(Result)+1);
 722
 723         c := 0;
 724         while (c < Length(str)) and
 725               (TextLen(Copy(str, 1, c+1)) < MaxWidth) do
 726           c := c+1;
 727
 728         Result[High(Result)] := Copy(str, 1, c);
 729         Delete(str, 1, c);
 730       end;
 731     end
 732     else // Ñòðîêà íîðìàëüíîé äëèíû => ñîåäèíÿåì ñî ñëåäóþùèìè
 733     begin
 734       while (a <= High(b)) and
 735             (TextLen(str+' '+b[a]) < MaxWidth) do
 736       begin
 737         str := str+' '+b[a];
 738         a := a + 1;
 739       end;
 740
 741       SetLength(Result, Length(Result)+1);
 742       Result[High(Result)] := str;
 743     end;
 744   end;
 745 }
 746   Result := nil
 747 end;
 748
 749 procedure Sort(var a: SSArray);
 750 var
 751   i, j: Integer;
 752   s: string;
 753 begin
 754   if a = nil then Exit;
 755
 756   for i := High(a) downto Low(a) do
 757     for j := Low(a) to High(a)-1 do
 758       if LowerCase(a[j]) > LowerCase(a[j+1]) then
 759       begin
 760         s := a[j];
 761         a[j] := a[j+1];
 762         a[j+1] := s;
 763       end;
 764 end;
 765
 766 function Sscanf(const s: String; const fmt: String;
 767                 const Pointers: array of Pointer): Integer;
 768 var
 769   i, j, n, m: Integer;
 770   s1: ShortString;
 771   L: LongInt;
 772   X: Extended;
 773
 774   function GetInt(): Integer;
 775   begin
 776     s1 := '';
 777     while (n <= Length(s)) and (s[n] = ' ') do
 778       Inc(n);
 779
 780     while (n <= Length(s)) and (s[n] in ['0'..'9', '+', '-']) do
 781     begin
 782       s1 := s1 + s[n];
 783       Inc(n);
 784     end;
 785
 786     Result := Length(s1);
 787   end;
 788
 789   function GetFloat(): Integer;
 790   begin
 791     s1 := '';
 792     while (n <= Length(s)) and (s[n] = ' ') do
 793       Inc(n);
 794
 795     while (n <= Length(s)) and //jd >= rather than >
 796           (s[n] in ['0'..'9', '+', '-', '.', 'e', 'E']) do
 797     begin
 798       s1 := s1 + s[n];
 799       Inc(n);
 800     end;
 801
 802     Result := Length(s1);
 803   end;
 804
 805   function GetString(): Integer;
 806   begin
 807     s1 := '';
 808     while (n <= Length(s)) and (s[n] = ' ') do
 809       Inc(n);
 810
 811     while (n <= Length(s)) and (s[n] <> ' ') do
 812     begin
 813       s1 := s1 + s[n];
 814       Inc(n);
 815     end;
 816
 817     Result := Length(s1);
 818   end;
 819
 820   function ScanStr(c: Char): Boolean;
 821   begin
 822     while (n <= Length(s)) and (s[n] <> c) do
 823       Inc(n);
 824     Inc(n);
 825
 826     Result := (n <= Length(s));
 827   end;
 828
 829   function GetFmt(): Integer;
 830   begin
 831     Result := -1;
 832
 833     while (True) do
 834     begin
 835       while (fmt[m] = ' ') and (m < Length(fmt)) do
 836         Inc(m);
 837       if (m >= Length(fmt)) then
 838         Break;
 839
 840       if (fmt[m] = '%') then
 841       begin
 842         Inc(m);
 843         case fmt[m] of
 844           'd': Result := vtInteger;
 845           'f': Result := vtExtended;
 846           's': Result := vtString;
 847         end;
 848         Inc(m);
 849         Break;
 850       end;
 851
 852       if (not ScanStr(fmt[m])) then
 853         Break;
 854       Inc(m);
 855     end;
 856   end;
 857
 858 begin
 859   n := 1;
 860   m := 1;
 861   Result := 0;
 862   s1 := '';
 863
 864   for i := 0 to High(Pointers) do
 865   begin
 866     j := GetFmt();
 867
 868     case j of
 869       vtInteger :
 870       begin
 871         if GetInt() > 0 then
 872           begin
 873             L := StrToIntDef(s1, 0);
 874             Move(L, Pointers[i]^, SizeOf(LongInt));
 875             Inc(Result);
 876           end
 877         else
 878           Break;
 879       end;
 880
 881       vtExtended :
 882       begin
 883         if GetFloat() > 0 then
 884           begin
 885             X := StrToFloatDef(s1, 0.0);
 886             Move(X, Pointers[i]^, SizeOf(Extended));
 887             Inc(Result);
 888           end
 889         else
 890           Break;
 891       end;
 892
 893       vtString :
 894       begin
 895         if GetString() > 0 then
 896           begin
 897             Move(s1, Pointers[i]^, Length(s1)+1);
 898             Inc(Result);
 899           end
 900         else
 901           Break;
 902       end;
 903
 904       else {case}
 905         Break;
 906     end; {case}
 907   end;
 908 end;
 909
 910 function InDWArray(a: DWORD; arr: DWArray): Boolean;
 911 var
 912   b: Integer;
 913 begin
 914   Result := False;
 915
 916   if arr = nil then Exit;
 917
 918   for b := 0 to High(arr) do
 919     if arr[b] = a then
 920     begin
 921       Result := True;
 922       Exit;
 923     end;
 924 end;
 925
 926 function InWArray(a: Word; arr: WArray): Boolean;
 927 var
 928   b: Integer;
 929 begin
 930   Result := False;
 931
 932   if arr = nil then Exit;
 933
 934   for b := 0 to High(arr) do
 935     if arr[b] = a then
 936     begin
 937       Result := True;
 938       Exit;
 939     end;
 940 end;
 941
 942 function InSArray(a: string; arr: SSArray): Boolean;
 943 var
 944   b: Integer;
 945 begin
 946   Result := False;
 947
 948   if arr = nil then Exit;
 949
 950   a := AnsiLowerCase(a);
 951
 952   for b := 0 to High(arr) do
 953     if AnsiLowerCase(arr[b]) = a then
 954     begin
 955       Result := True;
 956       Exit;
 957     end;
 958 end;
 959
 960 function GetPos(UID: Word; o: PObj): Boolean;
 961 var
 962   p: TPlayer;
 963   m: TMonster;
 964 begin
 965   Result := False;
 966
 967   case g_GetUIDType(UID) of
 968     UID_PLAYER:
 969     begin
 970       p := g_Player_Get(UID);
 971       if p = nil then Exit;
 972       if not p.alive then Exit;
 973
 974       o^ := p.Obj;
 975     end;
 976
 977     UID_MONSTER:
 978     begin
 979       m := g_Monsters_ByUID(UID);
 980       if m = nil then Exit;
 981       if not m.alive then Exit;
 982
 983       o^ := m.Obj;
 984     end;
 985     else Exit;
 986   end;
 987
 988   Result := True;
 989 end;
 990
 991 function parse(s: String): SSArray;
 992 var
 993   a: Integer;
 994 begin
 995   Result := nil;
 996   if s = '' then
 997     Exit;
 998
 999   while s <> '' do
1000   begin
1001     for a := 1 to Length(s) do
1002       if (s[a] = ',') or (a = Length(s)) then
1003       begin
1004         SetLength(Result, Length(Result)+1);
1005
1006         if s[a] = ',' then
1007           Result[High(Result)] := Copy(s, 1, a-1)
1008         else // Êîíåö ñòðîêè
1009           Result[High(Result)] := s;
1010
1011         Delete(s, 1, a);
1012         Break;
1013       end;
1014   end;
1015 end;
1016
1017 function parse2(s: string; delim: Char): SSArray;
1018 var
1019   a: Integer;
1020 begin
1021   Result := nil;
1022   if s = '' then Exit;
1023
1024   while s <> '' do
1025   begin
1026     for a := 1 to Length(s) do
1027       if (s[a] = delim) or (a = Length(s)) then
1028       begin
1029         SetLength(Result, Length(Result)+1);
1030
1031         if s[a] = delim then Result[High(Result)] := Copy(s, 1, a-1)
1032         else Result[High(Result)] := s;
1033
1034         Delete(s, 1, a);
1035         Break;
1036       end;
1037   end;
1038 end;
1039
1040 function g_GetFileTime(fileName: String): Integer;
1041 var
1042   F: File;
1043 begin
1044   if not FileExists(fileName) then
1045   begin
1046     Result := -1;
1047     Exit;
1048   end;
1049
1050   AssignFile(F, fileName);
1051   Reset(F);
1052   Result := FileGetDate(TFileRec(F).Handle);
1053   CloseFile(F);
1054 end;
1055
1056 function g_SetFileTime(fileName: String; time: Integer): Boolean;
1057 var
1058   F: File;
1059 begin
1060   if (not FileExists(fileName)) or (time < 0) then
1061   begin
1062     Result := False;
1063     Exit;
1064   end;
1065
1066   AssignFile(F, fileName);
1067   Reset(F);
1068   Result := (FileSetDate(TFileRec(F).Handle, time) = 0);
1069   CloseFile(F);
1070 end;
1071
1072 procedure SortSArray(var S: SSArray);
1073 var
1074   b: Boolean;
1075   i: Integer;
1076   sw: ShortString;
1077 begin
1078   repeat
1079     b := False;
1080     for i := Low(S) to High(S) - 1 do
1081       if S[i] > S[i + 1] then begin
1082         sw := S[i];
1083         S[i] := S[i + 1];
1084         S[i + 1] := sw;
1085         b := True;
1086       end;
1087   until not b;
1088 end;
1089
1090 function b_Text_Format(S: string): string;
1091 var
1092   Spec, Rst: Boolean;
1093   I: Integer;
1094 begin
1095   Result := '';
1096   Spec := False;
1097   Rst := False;
1098   for I := 1 to Length(S) do
1099   begin
1100     if (not Spec) and (S[I] = '\') and (I + 1 <= Length(S)) then
1101     begin
1102       Spec := True;
1103       Rst := True;
1104       continue;
1105     end;
1106     if Spec then
1107     begin
1108       case S[I] of
1109         'n': // line feed
1110           Result := Result + #10;
1111         '0': // black
1112           Result := Result + #1;
1113         '1': // white
1114           Result := Result + #2;
1115         'd': // darker
1116           Result := Result + #3;
1117         'l': // lighter
1118           Result := Result + #4;
1119         'r': // red
1120           Result := Result + #18;
1121         'g': // green
1122           Result := Result + #19;
1123         'b': // blue
1124           Result := Result + #20;
1125         'y': // yellow
1126           Result := Result + #21;
1127         '\': // escape
1128           Result := Result + '\';
1129         else
1130           Result := Result + '\' + S[I];
1131       end;
1132       Spec := False;
1133     end else
1134       Result := Result + S[I];
1135   end;
1136   // reset to white at end
1137   if Rst then Result := Result + #2;
1138 end;
1139
1140 function b_Text_Unformat(S: string): string;
1141 var
1142   Spec: Boolean;
1143   I: Integer;
1144 begin
1145   Result := '';
1146   Spec := False;
1147   for I := 1 to Length(S) do
1148   begin
1149     if S[I] in [#1, #2, #3, #4, #10, #18, #19, #20, #21] then
1150     begin
1151       Spec := False;
1152       continue;
1153     end;
1154     if (not Spec) and (S[I] = '\') and (I + 1 <= Length(S)) then
1155     begin
1156       Spec := True;
1157       continue;
1158     end;
1159     if Spec then
1160     begin
1161       case S[I] of
1162         'n': ;
1163         '0': ;
1164         '1': ;
1165         'd': ;
1166         'l': ;
1167         'r': ;
1168         'g': ;
1169         'b': ;
1170         'y': ;
1171         '\': Result := Result + '\';
1172         else
1173           Result := Result + '\' + S[I];
1174       end;
1175       Spec := False;
1176     end else
1177       Result := Result + S[I];
1178   end;
1179 end;
1180
1181 function b_Text_Wrap(S: string; LineLen: Integer): string;
1182 begin
1183   Result := WrapText(S, ''#10, [#10, ' ', '-'], LineLen);
1184 end;
1185
1186 function b_Text_LineCount(S: string): Integer;
1187 var
1188   I: Integer;
1189 begin
1190   Result := IfThen(S = '', 0, 1);
1191   for I := 1 to High(S) do
1192     if S[I] = #10 then
1193       Inc(Result);
1194 end;
1195
1196 end.