Changeset 59
- Timestamp:
- Dec 25, 2022, 2:30:52 PM (2 years ago)
- Location:
- trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/Forms/UFormMain.lfm
r55 r59 46 46 ParentFont = False 47 47 SimplePanel = False 48 Visible = False 48 49 end 49 50 object Image1: TImage -
trunk/Forms/UFormMain.pas
r57 r59 219 219 Shift: TShiftState); 220 220 begin 221 Engine.Key Board.KeyState[Key] := True;221 Engine.KeyDown(Key); 222 222 StatusBar1.Panels[0].Text := IntToStr(Key); 223 223 end; … … 225 225 procedure TFormMain.FormKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState 226 226 ); 227 const 228 KeyF11 = 112; 229 var 230 I: Integer; 231 begin 232 Engine.KeyBoard.KeyState[Key] := False; 233 {$IFDEF DEBUG} 234 if Key = KeyF11 then begin 235 // Destroy first alive player 236 for I := 0 to Engine.Players.Count - 1 do 237 with Engine.Players[I] do begin 238 if not Exploded then begin 239 Energy := -100; 240 Break; 241 end; 242 end; 243 end; 244 {$ENDIF} 227 begin 228 Engine.KeyUp(Key); 245 229 end; 246 230 … … 250 234 PersistentForm.Load(Self, False, True); 251 235 FullScreenEnabled := PersistentForm.FormFullScreen; 236 {$IFDEF DEBUG} 237 StatusBar1.Visible := True; 238 {$ENDIF} 252 239 end; 253 240 -
trunk/UEngine.pas
r58 r59 29 29 PlayerHouseDoorSize = 8; 30 30 ExplosionDelay = 2; 31 NewRoundDelay = 2; 32 clTuna = $5555ff; 33 clPurple = $aa00aa; 34 clDarkOrange = $0000aa; 35 clDarkGreen = $00aa00; 31 36 32 37 type … … 159 164 procedure LoadConfig(Config: TXMLConfig; Path: string); 160 165 procedure SaveConfig(Config: TXMLConfig; Path: string); 166 function GetAliveCount: Integer; 161 167 end; 162 168 … … 212 218 213 219 TDrawThread = class(TListedThread) 220 private 221 procedure DrawSync; 222 public 214 223 Engine: TEngine; 215 224 procedure Execute; override; 216 225 end; 217 226 218 TGameState = (gsMenu, gsRunning, gsNewRound, gsMap, gsMenuStats, gsInformation, 227 TCanvasMethod = procedure (Canvas: TCanvas) of object; 228 229 TGameState = (gsMenu, gsGame, gsNewRound, gsMap, gsInformation, 219 230 gsInstructions); 220 231 … … 230 241 FBitmapLower: TBitmapTColor; 231 242 FDrawThread: TDrawThread; 243 FState: TGameState; 232 244 FSystemThread: TSystemThread; 233 245 ClearBackground: Boolean; 246 FStateTime: TDateTime; 234 247 procedure InitDigMasks; 235 248 procedure SetActive(const AValue: Boolean); … … 237 250 procedure Redraw; 238 251 function IsInsideHouses(Pos: TPoint): Boolean; 239 procedure DoDrawToBitmap;240 252 procedure InitPlayerPool; 241 253 procedure InitPlayers; 242 254 procedure CheckGameEnd; 255 procedure DrawMenu; 256 procedure DrawGamePrepare(Thread: TVirtualThread); 257 procedure DrawGame; 258 procedure DrawInformation; 259 procedure DrawInstructions; 260 procedure DrawNewRound; 261 procedure DrawMap; 262 procedure SetState(AValue: TGameState); 243 263 public 244 264 Keyboard: TKeyboard; … … 253 273 AudioExplode: TMediaPlayer; 254 274 DrawDuration: TDatetime; 255 State: TGameState;256 275 constructor Create(AOwner: TComponent); override; 257 276 destructor Destroy; override; 258 277 procedure ResizePlayerFrames; 259 278 procedure Tick; 260 procedure Draw(Thread: TVirtualThread); 279 procedure Draw; 280 procedure DrawThread(Thread: TVirtualThread); 261 281 procedure NewGame; 262 282 procedure NewRound; 263 283 procedure LoadConfig(Config: TXMLConfig; Path: string); 264 284 procedure SaveConfig(Config: TXMLConfig; Path: string); 285 procedure KeyUp(Key: Word); 286 procedure KeyDown(Key: Word); 265 287 property Bitmap: TBitmap read FBitmap write SetBitmap; 266 288 property Active: Boolean read FActive write SetActive; 289 property State: TGameState read FState write SetState; 267 290 property OnGameEnd: TNotifyEvent read FOnGameEnd write FOnGameEnd; 268 291 end; … … 343 366 for I := 0 to Count - 1 do 344 367 Items[I].SaveConfig(Config, Path + '/Player' + IntToStr(I)); 368 end; 369 370 function TPlayers.GetAliveCount: Integer; 371 var 372 I: Integer; 373 begin 374 Result := 0; 375 for I := 0 to Count - 1 do 376 with Items[I] do 377 if not Exploded then Inc(Result); 345 378 end; 346 379 … … 372 405 { TDrawThread } 373 406 407 procedure TDrawThread.DrawSync; 408 begin 409 with Engine do 410 if Assigned(Bitmap) then begin 411 Lock.Acquire; 412 Bitmap.BeginUpdate(True); 413 try 414 Draw; 415 finally 416 Bitmap.EndUpdate; 417 Lock.Release; 418 end; 419 end; 420 end; 421 374 422 procedure TDrawThread.Execute; 375 423 begin 376 424 repeat 377 Engine.Draw(Self); 425 Engine.DrawThread(Self); 426 if not Terminated then Synchronize(DrawSync); 378 427 Sleep(50); 379 428 until Terminated; … … 1186 1235 end; 1187 1236 1188 procedure TEngine.D oDrawToBitmap;1237 procedure TEngine.DrawGame; 1189 1238 var 1190 1239 X, Y: Integer; … … 1208 1257 BgColor: Cardinal; 1209 1258 begin 1210 if Assigned(FBitmap) then begin1211 Lock.Acquire;1259 // TODO: To be able to draw into Bitmap not just through Canvas 1260 Bitmap.EndUpdate; 1212 1261 Bitmap.BeginUpdate; 1213 try 1214 {$IFDEF WINDOWS} 1215 Bitmap.PixelFormat := pf32bit; 1216 {$ENDIF} 1217 RawImage := Bitmap.RawImage; 1218 BytePerPixel := RawImage.Description.BitsPerPixel div 8; 1219 BytePerRow := RawImage.Description.BytesPerLine; 1220 if ClearBackground then begin 1221 BgColor := World.Matters[Integer(miBorder)].Color; 1222 BgColor := SwapBRComponent(BgColor); 1223 FillDWord(RawImage.Data^, Bitmap.Height * BytePerRow div 4, BgColor); 1224 ClearBackground := False; 1225 end; 1226 1227 if (FBitmap.Width / FBitmapLower.Width) < (FBitmap.Height / FBitmapLower.Height) then 1228 Ratio := FBitmap.Width / FBitmapLower.Width 1229 else Ratio := FBitmap.Height / FBitmapLower.Height; 1230 1231 // Preserve aspect ratio 1232 TargetWidth := Trunc(FBitmapLower.Width * Ratio); 1233 TargetHeight := Trunc(FBitmapLower.Height * Ratio); 1234 1235 Shift.X := Trunc((Bitmap.Width - TargetWidth) / 2); 1236 Shift.Y := Trunc((Bitmap.Height - TargetHeight) / 2); 1237 1238 XDiv := TargetWidth div FBitmapLower.Width; 1239 XMod := TargetWidth mod FBitmapLower.Width; 1240 YDiv := TargetHeight div FBitmapLower.Height; 1241 YMod := TargetHeight mod FBitmapLower.Height; 1242 1243 PixelRowPtr := PInteger(RawImage.Data + BytePerRow * Shift.Y); 1244 YAcc := FBitmapLower.Height div 2; 1245 for Y := 0 to FBitmapLower.Height - 1 do begin 1246 SubPixelSizeY := YDiv; 1247 Inc(YAcc, YMod); 1248 if YAcc >= FBitmapLower.Height then begin 1249 Dec(YAcc, FBitmapLower.Height); 1250 Inc(SubPixelSizeY); 1262 1263 {$IFDEF WINDOWS} 1264 Bitmap.PixelFormat := pf32bit; 1265 {$ENDIF} 1266 RawImage := Bitmap.RawImage; 1267 BytePerPixel := RawImage.Description.BitsPerPixel div 8; 1268 BytePerRow := RawImage.Description.BytesPerLine; 1269 if ClearBackground then begin 1270 BgColor := World.Matters[Integer(miBorder)].Color; 1271 BgColor := SwapBRComponent(BgColor); 1272 FillDWord(RawImage.Data^, Bitmap.Height * BytePerRow div 4, BgColor); 1273 ClearBackground := False; 1274 end; 1275 1276 if (FBitmap.Width / FBitmapLower.Width) < (FBitmap.Height / FBitmapLower.Height) then 1277 Ratio := FBitmap.Width / FBitmapLower.Width 1278 else Ratio := FBitmap.Height / FBitmapLower.Height; 1279 1280 // Preserve aspect ratio 1281 TargetWidth := Trunc(FBitmapLower.Width * Ratio); 1282 TargetHeight := Trunc(FBitmapLower.Height * Ratio); 1283 1284 Shift.X := Trunc((Bitmap.Width - TargetWidth) / 2); 1285 Shift.Y := Trunc((Bitmap.Height - TargetHeight) / 2); 1286 1287 XDiv := TargetWidth div FBitmapLower.Width; 1288 XMod := TargetWidth mod FBitmapLower.Width; 1289 YDiv := TargetHeight div FBitmapLower.Height; 1290 YMod := TargetHeight mod FBitmapLower.Height; 1291 1292 PixelRowPtr := PInteger(RawImage.Data + BytePerRow * Shift.Y); 1293 YAcc := FBitmapLower.Height div 2; 1294 for Y := 0 to FBitmapLower.Height - 1 do begin 1295 SubPixelSizeY := YDiv; 1296 Inc(YAcc, YMod); 1297 if YAcc >= FBitmapLower.Height then begin 1298 Dec(YAcc, FBitmapLower.Height); 1299 Inc(SubPixelSizeY); 1300 end; 1301 1302 PixelPtr := PixelRowPtr + Shift.X; 1303 XAcc := FBitmapLower.Width div 2; 1304 for X := 0 to FBitmapLower.Width - 1 do begin 1305 SubPixelSizeX := XDiv; 1306 Inc(XAcc, XMod); 1307 if XAcc >= FBitmapLower.Width then begin 1308 Dec(XAcc, FBitmapLower.Width); 1309 Inc(SubPixelSizeX); 1251 1310 end; 1252 1253 PixelPtr := PixelRowPtr + Shift.X; 1254 XAcc := FBitmapLower.Width div 2; 1255 for X := 0 to FBitmapLower.Width - 1 do begin 1256 SubPixelSizeX := XDiv; 1257 Inc(XAcc, XMod); 1258 if XAcc >= FBitmapLower.Width then begin 1259 Dec(XAcc, FBitmapLower.Width); 1260 Inc(SubPixelSizeX); 1311 Color := FBitmapLower.Pixels[X, Y] and $ffffff; 1312 1313 Color := SwapBRComponent(Color); 1314 1315 // Draw large pixel 1316 SubPixelRowPtr := PixelPtr; 1317 for PixelY := 0 to SubPixelSizeY - 1 do begin 1318 SubPixelPtr := SubPixelRowPtr; 1319 for PixelX := 0 to SubPixelSizeX - 1 do begin 1320 SubPixelPtr^ := Color; 1321 Inc(PByte(SubPixelPtr), BytePerPixel); 1261 1322 end; 1262 Color := FBitmapLower.Pixels[X, Y] and $ffffff; 1263 1264 Color := SwapBRComponent(Color); 1265 1266 // Draw large pixel 1267 SubPixelRowPtr := PixelPtr; 1268 for PixelY := 0 to SubPixelSizeY - 1 do begin 1269 SubPixelPtr := SubPixelRowPtr; 1270 for PixelX := 0 to SubPixelSizeX - 1 do begin 1271 SubPixelPtr^ := Color; 1272 Inc(PByte(SubPixelPtr), BytePerPixel); 1273 end; 1274 Inc(PByte(SubPixelRowPtr), BytePerRow); 1275 end; 1276 Inc(PByte(PixelPtr), BytePerPixel * SubPixelSizeX); 1323 Inc(PByte(SubPixelRowPtr), BytePerRow); 1277 1324 end; 1278 Inc(PByte(PixelRowPtr), BytePerRow * SubPixelSizeY); 1279 end; 1280 finally 1281 Bitmap.EndUpdate; 1282 Lock.Release; 1283 end; 1284 end; 1325 Inc(PByte(PixelPtr), BytePerPixel * SubPixelSizeX); 1326 end; 1327 Inc(PByte(PixelRowPtr), BytePerRow * SubPixelSizeY); 1328 end; 1329 end; 1330 1331 procedure TEngine.DrawInformation; 1332 begin 1333 with Bitmap.Canvas do begin 1334 1335 end; 1336 end; 1337 1338 procedure TEngine.DrawInstructions; 1339 begin 1340 1341 end; 1342 1343 procedure TEngine.DrawNewRound; 1344 var 1345 Text: string; 1346 I: Integer; 1347 Y: Integer; 1348 begin 1349 with Bitmap.Canvas do begin 1350 Brush.Style := bsSolid; 1351 Brush.Color := clBlack; 1352 Clear; 1353 1354 Brush.Style := bsClear; 1355 Pen.Style := psSolid; 1356 Pen.Color := clWhite; 1357 Font.Color := clTuna; 1358 Font.Size := 30; 1359 Text := 'Round ' + IntToStr(CurrentRound); 1360 TextOut((Bitmap.Width - TextWidth(Text)) div 2, Bitmap.Height div 5, Text); 1361 1362 Y := 0; 1363 for I := 0 to Players.Count - 1 do 1364 with TPlayer(Players[I]) do begin 1365 if Enabled then begin 1366 Font.Color := Color1; 1367 Text := SPlayer + ' ' + Name + ': ' + IntToStr(Score); 1368 TextOut((Bitmap.Width - TextWidth(Text)) div 2, Bitmap.Height div 5 * 2 + Y, Text); 1369 Inc(Y, 50); 1370 end; 1371 end; 1372 end; 1373 end; 1374 1375 procedure TEngine.DrawMap; 1376 begin 1377 Bitmap.EndUpdate; 1378 Bitmap.BeginUpdate; 1379 1380 World.DrawToBitmap(Bitmap); 1381 end; 1382 1383 procedure TEngine.SetState(AValue: TGameState); 1384 begin 1385 if FState = AValue then Exit; 1386 FState := AValue; 1387 FRedrawPending := True; 1388 FStateTime := Now; 1285 1389 end; 1286 1390 … … 1485 1589 procedure TEngine.CheckGameEnd; 1486 1590 var 1487 AliveCount: Integer; 1488 I: Integer; 1489 begin 1490 AliveCount := 0; 1491 for I := 0 to Players.Count - 1 do 1492 with Players[I] do 1493 if not Exploded then Inc(AliveCount); 1494 if AliveCount <= 1 then begin 1591 I: Integer; 1592 begin 1593 if Players.GetAliveCount <= 1 then begin 1495 1594 for I := 0 to Players.Count - 1 do 1496 1595 with Players[I] do 1497 1596 if not Exploded then Inc(Score); 1498 if CurrentRound < MaxRound then 1499 NewRound else 1597 if CurrentRound < MaxRound then begin 1598 Inc(CurrentRound); 1599 NewRound; 1600 State := gsNewRound; 1601 end else 1602 State := gsMap; 1500 1603 if Assigned(FOnGameEnd) then 1501 1604 FOnGameEnd(Self); 1605 end; 1606 end; 1607 1608 procedure TEngine.DrawMenu; 1609 var 1610 Text: string; 1611 begin 1612 with Bitmap.Canvas do begin 1613 Brush.Style := bsSolid; 1614 Brush.Color := clBlack; 1615 Clear; 1616 1617 Brush.Style := bsClear; 1618 Pen.Style := psSolid; 1619 Pen.Color := clWhite; 1620 Font.Color := clTuna; 1621 Font.Size := 30; 1622 Text := 'TUNNELER'; 1623 TextOut((Bitmap.Width - TextWidth(Text)) div 2, Bitmap.Height div 10, Text); 1624 1625 Font.Color := clDarkOrange; 1626 Font.Size := 20; 1627 Text := 'by Chronosoft'; 1628 TextOut((Bitmap.Width - TextWidth(Text)) div 2, Bitmap.Height div 10 + 50, Text); 1629 1630 Pen.Color := clPurple; 1631 Pen.Width := 6; 1632 Frame((Bitmap.Width - 400) div 2, Bitmap.Height div 10 * 4 - 40, 1633 (Bitmap.Width + 400) div 2, Bitmap.Height div 10 * 4 + 200); 1634 1635 Font.Color := clPurple; 1636 Font.Size := 20; 1637 Text := '<F1> start game'; 1638 TextOut((Bitmap.Width - TextWidth(Text)) div 2, Bitmap.Height div 10 * 4, Text); 1639 Text := '<F2> instructions'; 1640 TextOut((Bitmap.Width - TextWidth(Text)) div 2, Bitmap.Height div 10 * 4 + 40, Text); 1641 Text := '<F3> information'; 1642 TextOut((Bitmap.Width - TextWidth(Text)) div 2, Bitmap.Height div 10 * 4 + 80, Text); 1643 Text := '<F10> exit'; 1644 TextOut((Bitmap.Width - TextWidth(Text)) div 2, Bitmap.Height div 10 * 4 + 120, Text); 1645 1646 Font.Color := clDarkGreen; 1647 Font.Size := 20; 1648 Text := '(world ready)'; 1649 TextOut((Bitmap.Width - TextWidth(Text)) div 2, Bitmap.Height div 10 * 9, Text); 1650 end; 1651 end; 1652 1653 procedure TEngine.DrawGamePrepare(Thread: TVirtualThread); 1654 var 1655 I: Integer; 1656 OldCount: TBitmapTColorIndex; 1657 begin 1658 Lock.Acquire; 1659 try 1660 // TODO: Without this (re)initialization we get range error 1661 OldCount := FBitmapLower.Count; 1662 FBitmapLower.Count := FBitmapLower.CreateIndex(0, 0); 1663 FBitmapLower.Count := OldCount; 1664 1665 if ClearBackground then FBitmapLower.FillAll(clNavy); 1666 for I := 0 to Players.Count - 1 do 1667 if Players[I].Enabled then begin 1668 Players[I].Paint; 1669 end; 1670 finally 1671 Lock.Release; 1502 1672 end; 1503 1673 end; … … 1579 1749 I: Integer; 1580 1750 begin 1581 Lock.Acquire; 1582 try 1583 for I := 0 to Players.Count - 1 do begin 1584 Players[I].Control; 1585 Players[I].Tick; 1586 end; 1587 finally 1588 Lock.Release; 1589 end; 1590 end; 1591 1592 procedure TEngine.Draw(Thread: TVirtualThread); 1593 var 1594 I: Integer; 1751 if State = gsGame then begin 1752 Lock.Acquire; 1753 try 1754 for I := 0 to Players.Count - 1 do begin 1755 Players[I].Control; 1756 Players[I].Tick; 1757 end; 1758 finally 1759 Lock.Release; 1760 end; 1761 end else 1762 if State = gsNewRound then begin 1763 if SecondOf(Now - FStateTime) > NewRoundDelay then begin 1764 State := gsGame; 1765 end; 1766 end; 1767 end; 1768 1769 procedure TEngine.Draw; 1770 var 1595 1771 DrawStart: TDateTime; 1596 OldCount: TBitmapTColorIndex;1597 1772 begin 1598 1773 if FRedrawPending then begin 1599 1774 DrawStart := NowPrecise; 1600 1775 FRedrawPending := False; 1601 Lock.Acquire; 1602 try 1603 // TODO: Without this (re)initialization we get range error 1604 OldCount := FBitmapLower.Count; 1605 FBitmapLower.Count := FBitmapLower.CreateIndex(0, 0); 1606 FBitmapLower.Count := OldCount; 1607 1608 if ClearBackground then FBitmapLower.FillAll(clNavy); 1609 for I := 0 to Players.Count - 1 do 1610 if Players[I].Enabled then begin 1611 Players[I].Paint; 1612 end; 1613 finally 1614 Lock.Release; 1615 end; 1616 if not Thread.Terminated then Thread.Synchronize(DoDrawToBitmap); 1776 case State of 1777 gsGame: DrawGame; 1778 gsMenu: DrawMenu; 1779 gsInformation: DrawInformation; 1780 gsInstructions: DrawInstructions; 1781 gsMap: DrawMap; 1782 gsNewRound: DrawNewRound; 1783 end; 1784 1617 1785 DrawDuration := NowPrecise - DrawStart; 1618 1786 end; 1787 end; 1788 1789 procedure TEngine.DrawThread(Thread: TVirtualThread); 1790 begin 1791 if State = gsGame then DrawGamePrepare(Thread); 1619 1792 end; 1620 1793 … … 1624 1797 InitPlayers; 1625 1798 ResizePlayerFrames; 1626 CurrentRound := 0;1799 CurrentRound := 1; 1627 1800 NewRound; 1628 1801 … … 1652 1825 end; 1653 1826 1827 procedure TEngine.KeyUp(Key: Word); 1828 const 1829 KeyF1 = 112; 1830 KeyF2 = 113; 1831 KeyF3 = 114; 1832 KeyF4 = 115; 1833 KeyEsc = 27; 1834 var 1835 I: Integer; 1836 begin 1837 KeyBoard.KeyState[Key] := False; 1838 1839 if State = gsMenu then begin 1840 if Key = KeyF1 then begin 1841 State := gsNewRound; 1842 NewGame; 1843 end else 1844 if Key = KeyF2 then begin 1845 State := gsInstructions; 1846 NewGame; 1847 end else 1848 if Key = KeyF3 then begin 1849 State := gsInformation; 1850 NewGame; 1851 end; 1852 end else 1853 if State = gsMap then begin 1854 if Key = KeyEsc then begin 1855 State := gsMenu; 1856 end; 1857 end; 1858 1859 {$IFDEF DEBUG} 1860 if Key = KeyF4 then begin 1861 // Destroy first alive player 1862 for I := 0 to Players.Count - 1 do 1863 with Players[I] do begin 1864 if not Exploded then begin 1865 Energy := -100; 1866 Break; 1867 end; 1868 end; 1869 end; 1870 {$ENDIF} 1871 end; 1872 1873 procedure TEngine.KeyDown(Key: Word); 1874 begin 1875 KeyBoard.KeyState[Key] := True; 1876 end; 1877 1654 1878 end. 1655 1879
Note:
See TracChangeset
for help on using the changeset viewer.