home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / tpwinst / owldemos.pak / BONK.PAS < prev    next >
Pascal/Delphi Source File  |  1991-05-21  |  14KB  |  519 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Demo program                                 }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. program Bonk;
  10.  
  11. {$R BONK}
  12.  
  13. uses
  14.   WinTypes, WinProcs, WObjects, Strings;
  15.  
  16. const
  17.   idm_Reset    = 100;
  18.   idm_Option   = 101;
  19.   idm_About    = 102;
  20.   idm_Pause    = 103;
  21.   idm_Stop     = 104;
  22.  
  23.   InputEditBox = 109;
  24.   LiveTimeSB   = 101;
  25.   PopSB        = 102;
  26.  
  27.   MissedPoints = -2;
  28.   HitPoints    =  5;
  29.   MissedCritter = -1;
  30.   CritterSize  = 72;
  31.  
  32.   MaxPop       = 35;
  33.   MaxLiveTime  = 30;
  34.  
  35.   Holes: array[1..5] of TPoint = ((X: 10; Y: 10), (X: 200; Y: 10),
  36.     (X: 100; Y: 100), (X: 10; Y: 200), (X: 200; Y: 200));
  37.  
  38. type
  39.   TApp = object(TApplication)
  40.     procedure InitMainWindow; virtual;
  41.   end;
  42.  
  43.   THole = record
  44.     Time: Word;
  45.     Dead: Boolean;
  46.   end;
  47.  
  48.   PGameWindow = ^TGameWindow;
  49.   TGameWindow = object(TWindow)
  50.     Live, Dead, GameOver, ScoreBoard: HBitMap;
  51.     CursorDown, CursorUp: HCursor;
  52.     Counter, Score, LiveTime, Frequence, GameTime: Integer;
  53.     Hits, Miss, Escaped: Integer;
  54.     IsGameOver, IsPause: Boolean;
  55.     HoleInfo: array[1..5] of THole;
  56.     constructor Init(AParent: PWindowsObject; Title: PChar);
  57.     procedure About(var Message: TMessage); virtual cm_First + idm_About;
  58.     procedure DrawBMP(DC: HDC; X, Y, BitMap: HBitmap);
  59.     procedure DrawGameOver(DC: HDC);
  60.     procedure DrawCritter(DC: HDC; CritterNumber: Byte);
  61.     procedure DrawScoreBoard(DC: HDC);
  62.     procedure GetWindowClass(var WndClass: TWndClass); virtual;
  63.     procedure Options(var Message: TMessage); virtual cm_First + idm_Option;
  64.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  65.     procedure Pause(var Message: TMessage); virtual cm_First + idm_Pause;
  66.     procedure ResetGame(var Message: TMessage); virtual cm_First + idm_Reset;
  67.     procedure SetUpWindow; virtual;
  68.     procedure Stop(var Message: TMessage); virtual cm_First + idm_Stop;
  69.     procedure StopGame;
  70.     procedure WMDestroy(var Message: TMessage); virtual wm_Destroy;
  71.     procedure WMLButtonDown(var Message: TMessage); virtual wm_LButtonDown;
  72.     procedure WMLButtonUp(var Message: TMessage); virtual wm_LButtonUp;
  73.     procedure WMTimer(var Message: TMessage); virtual wm_Timer + wm_First;
  74.     procedure WMSize(var Message: TMessage); virtual wm_Size;
  75.     procedure WriteScore(DC: HDC);
  76.   end;
  77.  
  78. TOptionDialog = object(TDialog)
  79.   procedure OK(var Message: TMessage); virtual id_First + id_Ok;
  80.   procedure SetUpWindow; virtual;
  81.   procedure WMHScroll(var Message: TMessage); virtual wm_HScroll;
  82. end;
  83.  
  84. {--------------- TOptionDialog ---------------}
  85.  
  86. procedure TOptionDialog.SetUpWindow;
  87. var
  88.   S: String;
  89.   CS: array[0..20] of Char;
  90. begin
  91.   TDialog.SetUpWindow;
  92.   SetScrollRange(GetDlgItem(HWindow, LiveTimeSB), sb_Ctl, 1,
  93.     MaxLiveTime, False);
  94.   SetScrollRange(GetDlgItem(HWindow, PopSB), sb_Ctl, 1, MaxPop, False);
  95.   SetScrollPos(GetDlgItem(HWindow, LiveTimeSB), sb_Ctl,
  96.     MaxLiveTime + 1 - PGameWindow(Parent)^.LiveTime, True);
  97.   SetScrollPos(GetDlgItem(HWindow, PopSB), sb_Ctl,
  98.     MaxPop + 6 - PGameWindow(Parent)^.Frequence, True);
  99.   Str(PGameWindow(Parent)^.GameTime div 10, S);
  100.   StrPCopy(CS, S);
  101.   SetDlgItemText(HWindow, InputEditBox, CS);
  102. end;
  103.  
  104. procedure TOptionDialog.WMHScroll(var Message: TMessage);
  105. const
  106.   PageStep = 10;
  107. var
  108.   Pos: Integer;
  109.   Scroll: HWnd;
  110. begin
  111.   Scroll := HiWord(Message.lParam);
  112.   Pos := GetScrollPos(Scroll, SB_Ctl);
  113.   case Message.wParam of
  114.     sb_LineUp: Dec(Pos);
  115.     sb_LineDown: Inc(Pos);
  116.     sb_PageUp: Dec(Pos, PageStep);
  117.     sb_PageDown: Inc(Pos, PageStep);
  118.     sb_ThumbPosition: Pos := LoWord(Message.lParam);
  119.     sb_ThumbTrack: Pos := LoWord(Message.lParam);
  120.   end;
  121.   SetScrollPos(Scroll, sb_Ctl, Pos, True);
  122. end;
  123.  
  124. procedure TOptionDialog.OK(var Message: TMessage);
  125. var
  126.   NoError: Bool;
  127.   Time: Integer;
  128. begin
  129.   PGameWindow(Parent)^.LiveTime := MaxLiveTime + 1 - GetScrollPos(
  130.     GetDlgItem(HWindow, LiveTimeSB), sb_Ctl);
  131.   PGameWindow(Parent)^.Frequence := MaxPop + 1 - GetScrollPos(
  132.     GetDlgItem(HWindow, PopSB), sb_Ctl) + 5;
  133.   Time := GetDlgItemInt(HWindow, InputEditBox, @NoError, False) * 10;
  134.   if (NoError) and (Time > 0) then
  135.   begin
  136.     PGameWindow(Parent)^.GameTime := Time;
  137.     EndDlg(id_Ok);
  138.   end
  139.   else
  140.     MessageBox(HWindow, 'Game Time must be a number greater than 0!',
  141.       'Error', mb_Ok)
  142. end;
  143.  
  144. {--------------- TGameWindow -----------------}
  145.  
  146. constructor TGameWindow.Init(AParent: PWindowsObject; Title: PChar);
  147. begin
  148.   TWindow.Init(AParent, Title);
  149.   Attr.W := 282;
  150.   Attr.H := 400;
  151.   Attr.Style := WS_Caption or WS_SysMenu or WS_MinimizeBox;
  152.   Randomize;
  153. end;
  154.  
  155. procedure TGameWindow.About(var Message: TMessage);
  156. var
  157.   Dialog: TDialog;
  158. begin
  159.   Dialog.Init(@Self, 'About');
  160.   Dialog.Execute;
  161.   Dialog.Done;
  162. end;
  163.  
  164. procedure TGameWindow.DrawBMP(DC: HDC; X, Y, BitMap: HBitMap);
  165. var
  166.   MemDC: HDC;
  167.   bm: TBitMap;
  168.   MadeDC: Boolean;
  169. begin
  170.   if DC = 0 then
  171.   begin
  172.     DC := GetDC(HWindow);
  173.     MadeDC := True;
  174.   end
  175.   else
  176.     MadeDC := False;
  177.   MemDC := CreateCompatibleDC(DC);
  178.   SelectObject(MemDC, BitMap);
  179.   GetObject(GameOver, SizeOf(bm), @bm);
  180.   BitBlt(DC, X, Y, bm.bmWidth, bm.bmHeight, MemDC, 0, 0, SRCCopy);
  181.   DeleteDC(MemDC);
  182.   if MadeDC then ReleaseDC(HWindow, DC);
  183. end;
  184.  
  185. procedure TGameWindow.DrawGameOver(DC: HDC);
  186. begin
  187.   DrawBMP(DC, 10, 70, GameOver);
  188. end;
  189.  
  190. procedure TGameWindow.DrawCritter(DC: HDC; CritterNumber: Byte);
  191. var
  192.   MadeDC: Boolean;
  193.   MemDC: HDC;
  194. begin
  195.   if DC = 0 then
  196.   begin
  197.     DC := GetDC(HWindow);
  198.     MadeDC := True;
  199.   end
  200.   else MadeDC := False;
  201.  
  202.   if HoleInfo[CritterNumber].Time <> 0 then
  203.   begin
  204.     MemDC := CreateCompatibleDC(DC);
  205.     if HoleInfo[CritterNumber].Dead then SelectObject(MemDC, Dead)
  206.     else SelectObject(MemDC, Live);
  207.     BitBlt(DC, Holes[CritterNumber].X, Holes[CritterNumber].Y,
  208.       CritterSize, CritterSize, MemDC, 0, 0, SRCCopy);
  209.     DeleteDC(MemDC);
  210.   end
  211.   else
  212.   begin
  213.     SelectObject(DC, GetStockObject(White_Brush));
  214.     SelectObject(DC, GetStockObject(Null_Pen));
  215.     Rectangle(DC, Holes[CritterNumber].X, Holes[CritterNumber].Y,
  216.       Holes[CritterNumber].X + CritterSize + 1,
  217.       Holes[CritterNumber].Y + CritterSize + 1);
  218.   end;
  219.   if MadeDC then ReleaseDC(HWindow, DC);
  220. end;
  221.  
  222. procedure TGameWindow.DrawScoreBoard(DC: HDC);
  223. begin
  224.   DrawBMP(DC, 11, 214, ScoreBoard);
  225. end;
  226.  
  227. procedure TGameWindow.GetWindowClass(var WndClass: TWndClass);
  228. begin
  229.   TWindow.GetWindowClass(WndClass);
  230.   CursorUp := LoadCursor(hInstance, 'Malet');
  231.   WndClass.Style := 0;
  232.   WndClass.hCursor := CursorUp;
  233.   WndClass.hbrBackGround := GetStockObject(White_Brush);
  234.   WndClass.lpszMenuName := 'Menu';
  235.   WndClass.hIcon := LoadIcon(hInstance, 'Critter');
  236. end;
  237.  
  238. procedure TGameWindow.Options(var Message: TMessage);
  239. var
  240.   D: TOptionDialog;
  241. begin
  242.   D.Init(@Self, 'OptionDlg');
  243.   D.Execute;
  244.   D.Done;
  245. end;
  246.  
  247. procedure TGameWindow.Paint(PaintDC: HDC;var PaintInfo: TPaintStruct);
  248. var
  249.   I: integer;
  250. begin
  251.   DrawScoreBoard(PaintDC);
  252.   WriteScore(PaintDC);
  253.   if IsGameOver then
  254.     DrawGameOver(PaintDC)
  255.   else
  256.     for I := 1 to 5 do
  257.       DrawCritter(PaintDC, I);
  258. end;
  259.  
  260. procedure TGameWindow.Pause(var Message: TMessage);
  261. begin
  262.   if IsGameOver then Exit;
  263.   if IsPause then
  264.   begin
  265.     IsPause := False;
  266.     ModifyMenu(GetMenu(HWindow), idm_Pause, mf_ByCommand,
  267.       idm_Pause, '&Pause');
  268.     DrawMenuBar(hWindow);
  269.     if SetTimer(HWindow, 1, 100, nil) = 0 then
  270.     begin
  271.       MessageBox(HWindow, 'No Timers Left', 'Error', mb_Ok);
  272.       Halt(1);
  273.     end;
  274.   end
  275.   else
  276.   begin
  277.     IsPause := True;
  278.     KillTimer(HWindow, 1);
  279.     ModifyMenu(GetMenu(HWindow), idm_Pause, mf_ByCommand,
  280.       idm_Pause, '&Continue');
  281.     DrawMenuBar(hWindow);
  282.   end;
  283. end;
  284.  
  285. procedure TGameWindow.ResetGame(var Message: TMessage);
  286. begin
  287.   ModifyMenu(GetMenu(HWindow), idm_Option, mf_ByCommand or mf_Grayed,
  288.     idm_Option, '&Options');
  289.   ModifyMenu(GetMenu(HWindow), idm_Pause, mf_ByCommand,
  290.     idm_Pause, '&Pause');
  291.   ModifyMenu(GetMenu(HWindow), idm_Stop, mf_ByCommand,
  292.     idm_Stop, '&Stop');
  293.   DrawMenuBar(HWindow);
  294.   InValidateRect(HWindow, nil, True);
  295.   if SetTimer(HWindow, 1, 100, nil) = 0 then
  296.   begin
  297.     MessageBox(HWindow, 'No Timers Left', 'Error', mb_Ok);
  298.     Halt(1);
  299.   end;
  300.   FillChar(HoleInfo, SizeOf(HoleInfo), 0);
  301.   Counter := 0;
  302.   Score := 0;
  303.   Hits := 0;
  304.   Miss := 0;
  305.   Escaped := 0;
  306.   IsGameOver := False;
  307.   if IsPause then
  308.   begin
  309.     IsPause := False;
  310.     ModifyMenu(GetMenu(HWindow), idm_Pause, mf_ByCommand,
  311.       idm_Pause, '&Pause');
  312.     DrawMenuBar(hWindow);
  313.   end;
  314. end;
  315.  
  316. procedure TGameWindow.SetUpWindow;
  317. begin
  318.   CursorDown := LoadCursor(hInstance, 'MaletDown');
  319.   Live := LoadBitMap(hInstance, 'Live');
  320.   Dead := LoadBitMap(hInstance, 'Dead');
  321.   GameOver := LoadBitMap(hInstance, 'GameOver');
  322.   ScoreBoard := LoadBitMap(hInstance, 'Board');
  323.   IsGameOver := True;
  324.   IsPause := False;
  325.   LiveTime := 10;
  326.   Frequence := 20;
  327.   Counter := 0;
  328.   Score := 0;
  329.   Hits := 0;
  330.   Miss := 0;
  331.   Escaped := 0;
  332.   GameTime := 150 {fifteen seconds}
  333. end;
  334.  
  335. procedure TGameWindow.Stop(var Message: TMessage);
  336. begin
  337.   StopGame;
  338. end;
  339.  
  340. procedure TGameWindow.StopGame;
  341. begin
  342.   KillTimer(HWindow, 1);
  343.   ModifyMenu(GetMenu(HWindow), idm_Option, mf_ByCommand,
  344.     idm_Option, '&Options');
  345.   ModifyMenu(GetMenu(HWindow), idm_Pause, mf_ByCommand or mf_Grayed,
  346.     idm_Pause, '&Pause');
  347.   ModifyMenu(GetMenu(HWindow), idm_Stop, mf_ByCommand or mf_Grayed,
  348.     idm_Stop, '&Stop');
  349.   IsPause := False;
  350.   DrawMenuBar(HWindow);
  351.   IsGameOver := True;
  352.   InValidateRect(HWindow, nil, True);
  353.   Counter := GameTime;
  354. end;
  355.  
  356. procedure TGameWindow.WMDestroy(var Message: TMessage);
  357. begin
  358.   DeleteObject(Live);
  359.   DeleteObject(Dead);
  360.   DeleteObject(GameOver);
  361.   DeleteObject(ScoreBoard);
  362.   KillTimer(HWindow, 1);
  363.   TWindow.WMDestroy(Message);
  364. end;
  365.  
  366. procedure TGameWindow.WMLButtonDown(var Message: TMessage);
  367. var
  368.   Point: TPoint;
  369.   R: TRect;
  370.   I: Integer;
  371.   Hit: Boolean;
  372. begin
  373.   SetClassWord(HWindow, GCW_hCursor, CursorDown);
  374.   GetCursorPos(Point);
  375.   SetCursorPos(Point.X, Point.Y);
  376.   if IsGameOver or IsPause then Exit;
  377.   Hit := False;
  378.   for I := 1 to 5 do
  379.     if not ((HoleInfo[I].Dead) or (HoleInfo[I].Time = 0)) then
  380.     begin
  381.       R.Top := Holes[I].X;
  382.       R.Left := Holes[I].Y;
  383.       R.Bottom := R.Top + CritterSize;
  384.       R.Right := R.Left + CritterSize;
  385.       Point.X := HiWord(Message.lParam);
  386.       Point.Y := LoWord(Message.lParam);
  387.       if PtInRect(R, Point) then
  388.       begin
  389.     Inc(Score, HitPoints);
  390.     HoleInfo[I].Dead := True;
  391.     HoleInfo[I].Time := Counter + 2 * LiveTime;
  392.     Inc(Hits);
  393.     Hit := True;
  394.     DrawCritter(0, I);
  395.       end;
  396.     end;
  397.   if not Hit then
  398.   begin
  399.     Inc(Score, MissedPoints);
  400.     Inc(Miss);
  401.   end;
  402.   WriteScore(0);
  403. end;
  404.  
  405. procedure TGameWindow.WMLButtonUp(var Message: TMessage);
  406. var
  407.   Point: TPoint;
  408. begin
  409.   SetClassWord(HWindow, gcw_hCursor, CursorUp);
  410.   GetCursorPos(Point);
  411.   SetCursorPos(Point.X, Point.Y);
  412. end;
  413.  
  414. procedure TGameWindow.WMTimer(var Message: TMessage);
  415. var
  416.   R: TRect;
  417.   I: Integer;
  418. begin
  419.   Inc(Counter);
  420.   I := Random(Frequence) + 1;
  421.   if I < 6 then
  422.     if HoleInfo[I].Time = 0 then
  423.     begin
  424.       HoleInfo[I].Time := Counter + LiveTime;
  425.       HoleInfo[I].Dead := False;
  426.       DrawCritter(0, I);
  427.     end;
  428.   for I := 1 to 5 do
  429.     if (Counter > HoleInfo[I].Time) and (HoleInfo[I].Time <> 0) then
  430.     begin
  431.       HoleInfo[I].Time := 0;
  432.       if not HoleInfo[I].Dead then
  433.       begin
  434.     Inc(Score, MissedCritter);
  435.     Inc(Escaped);
  436.       end;
  437.       DrawCritter(0, I);
  438.     end;
  439.   WriteScore(0);
  440.   if Counter >= GameTime then StopGame;
  441. end;
  442.  
  443. procedure TGameWindow.WMSize(var Message: TMessage);
  444. begin
  445.   if IsGameOver then Exit;
  446.   if IsIconic(HWindow) then KillTimer(HWindow, 1)
  447.   else
  448.     if not IsPause then
  449.       if SetTimer(HWindow, 1, 100, nil) = 0 then
  450.       begin
  451.     MessageBox(HWindow, 'No Timers Left', 'Error', mb_Ok);
  452.     Halt(1);
  453.       end;
  454. end;
  455.  
  456. procedure TGameWindow.WriteScore(DC: HDC);
  457. var
  458.   S: array[0..20] of Char;
  459.   MadeDC: Boolean;
  460. begin
  461.  if DC = 0 then
  462.  begin
  463.    MadeDC := True;
  464.    DC := GetDC(HWindow);
  465.  end
  466.  else MadeDC := False;
  467.  SelectObject(DC, CreateSolidBrush($8080));
  468.  SelectObject(DC, GetStockObject(Null_Pen));
  469.  SetBKMode(DC, TransParent);
  470.  
  471.  {Timer}
  472.  Rectangle(DC, 130, 252, 163, 275);
  473.  Str((GameTime-Counter):3, S);
  474.  S[3] :=S[2];
  475.  S[2]:='.';
  476.  TextOut(DC, 130, 252, S, 4);
  477.  
  478.  {Hits}
  479.  Rectangle(DC, 40, 310, 71, 329);
  480.  Str(Hits:3, S);
  481.  TextOut(DC, 40, 310, S, StrLen(S));
  482.  
  483.  {Misses}
  484.  Rectangle(DC, 77, 310, 117, 329);
  485.  Str(Miss:3, S);
  486.  TextOut(DC, 77, 310, S, StrLen(S));
  487.  
  488.  {Escaped}
  489.  Rectangle(DC, 133, 310, 174, 329);
  490.  Str(Escaped:3, S);
  491.  TextOut(DC, 133, 310, S, StrLen(S));
  492.  
  493.  {Total}
  494.  Rectangle(DC, 203, 310, 239, 328);
  495.  Str(Score:3, S);
  496.  TextOut(DC, 203, 310, S, StrLen(S));
  497.  
  498.  DeleteObject(SelectObject(DC, GetStockObject(White_Brush)));
  499.  SelectObject(DC, GetStockObject(Null_Pen));
  500.  if MadeDC then ReleaseDC(HWindow, DC);
  501. end;
  502.  
  503. {--------------- TApp ------------------------}
  504.  
  505. procedure TApp.InitMainWindow;
  506. begin
  507.   MainWindow := New(PGameWindow, Init(nil, 'Bonk!'));
  508. end;
  509.  
  510. {-------------Main Program--------------------}
  511.  
  512. var
  513.   App: TApp;
  514. begin
  515.   App.Init('BonkGame');
  516.   App.Run;
  517.   App.Done;
  518. end.
  519.