Last updated: 18. 1.1998, 12:48
<* +M2EXTENSIONS *>
MODULE Bounce;
(*---------------------------------------
BOUNCE.C --- Bouncing Ball Program
(c) Charles Petzold, 1996
Bounce.mod --- Translation to XDS Modula-2
(c) Peter Stadler, 1997
---------------------------------------*)
IMPORT Windows;
IMPORT SYSTEM;
CONST
szAppName = "Bounce";
VAR
hwnd : Windows.HWND;
msg : Windows.MSG;
wc : Windows.WNDCLASSEX;
hBitmap : Windows.HBITMAP;
cxClient, cyClient, xCenter, yCenter, cxTotal, cyTotal,
cxRadius, cyRadius, cxMove, cyMove, xPixel, yPixel : INTEGER;
hBrush : Windows.HBRUSH;
hdc : Windows.HDC;
hdcMem : Windows.HDC;
iScale : INTEGER;
(*++++*****************************************************************)
PROCEDURE MaxInt (a,b : INTEGER) : INTEGER;
(**********************************************************************)
BEGIN
IF(a>b) THEN
RETURN a;
ELSE
RETURN b;
END;
END MaxInt;
(*++++*****************************************************************)
PROCEDURE MinInt (a,b : INTEGER) : INTEGER;
(**********************************************************************)
BEGIN
IF(a>b) THEN
RETURN b;
ELSE
RETURN a;
END;
END MinInt;
(*++++*****************************************************************)
PROCEDURE [Windows.CALLBACK] WndProc (hwnd : Windows.HWND;
(**********************************************************************)
iMsg : Windows.UINT;
wParam : Windows.WPARAM;
lParam : Windows.LPARAM) : Windows.LRESULT;
BEGIN
CASE (iMsg) OF
| Windows.WM_CREATE :
hdc := Windows.GetDC (hwnd);
xPixel := Windows.GetDeviceCaps (hdc, Windows.ASPECTX);
yPixel := Windows.GetDeviceCaps (hdc, Windows.ASPECTY);
Windows.ReleaseDC (hwnd, hdc);
RETURN 0;
| Windows.WM_SIZE :
cxClient := Windows.LOWORD (lParam);
xCenter := cxClient / 2;
cyClient := Windows.HIWORD (lParam);
yCenter := cyClient / 2;
iScale := MinInt (cxClient * xPixel, cyClient * yPixel) / 16;
cxRadius := iScale / xPixel;
cyRadius := iScale / yPixel;
cxMove := MaxInt (1, cxRadius / 2);
cyMove := MaxInt (1, cyRadius / 2);
cxTotal := 2 * (cxRadius + cxMove);
cyTotal := 2 * (cyRadius + cyMove);
IF (hBitmap#NIL) THEN
Windows.DeleteObject (SYSTEM.CAST(Windows.HGDIOBJ,hBitmap));
END;
hdc := Windows.GetDC (hwnd);
hdcMem := Windows.CreateCompatibleDC (hdc);
hBitmap := Windows.CreateCompatibleBitmap (hdc, cxTotal, cyTotal);
Windows.ReleaseDC (hwnd, hdc);
Windows.SelectObject (hdcMem, SYSTEM.CAST(Windows.HGDIOBJ,hBitmap));
Windows.Rectangle (hdcMem, -1, -1, cxTotal + 1, cyTotal + 1);
hBrush := Windows.CreateHatchBrush (Windows.HS_DIAGCROSS, 0000h);
Windows.SelectObject (hdcMem, SYSTEM.CAST(Windows.HGDIOBJ,hBrush));
Windows.SetBkColor (hdcMem, Windows.RGB (255, 0, 255));
Windows.Ellipse (hdcMem, cxMove, cyMove, cxTotal - cxMove,
cyTotal - cyMove);
Windows.DeleteDC (hdcMem);
Windows.DeleteObject (SYSTEM.CAST(Windows.HGDIOBJ,hBrush));
RETURN 0;
| Windows.WM_TIMER :
IF (hBitmap#NIL) THEN
hdc := Windows.GetDC (hwnd);
hdcMem := Windows.CreateCompatibleDC (hdc);
Windows.SelectObject (hdcMem, SYSTEM.CAST(Windows.HGDIOBJ,hBitmap));
Windows.BitBlt (hdc, xCenter - cxTotal / 2,
yCenter - cyTotal / 2, cxTotal, cyTotal,
hdcMem, 0, 0, Windows.SRCCOPY);
Windows.ReleaseDC (hwnd, hdc);
Windows.DeleteDC (hdcMem);
xCenter := xCenter+cxMove;
yCenter := yCenter+cyMove;
IF ((xCenter + cxRadius >= cxClient) OR
(xCenter - cxRadius <= 0)) THEN
cxMove := -cxMove;
END;
IF ((yCenter + cyRadius >= cyClient) OR
(yCenter - cyRadius <= 0)) THEN
cyMove := -cyMove;
END;
RETURN 0;
ELSE
RETURN Windows.DefWindowProc (hwnd, iMsg, wParam, lParam);
END;
| Windows.WM_DESTROY :
IF (hBitmap#NIL) THEN
Windows.DeleteObject (SYSTEM.CAST(Windows.HGDIOBJ,hBitmap));
END;
Windows.KillTimer (hwnd, 1);
Windows.PostQuitMessage (0);
RETURN 0;
ELSE
RETURN Windows.DefWindowProc (hwnd, iMsg, wParam, lParam);
END;
END WndProc;
(*++++*****************************************************************)
PROCEDURE InitApplication () : BOOLEAN;
(**********************************************************************)
BEGIN
wc.cbSize := SIZE(wc);
wc.style := Windows.CS_HREDRAW + Windows.CS_VREDRAW;
wc.lpfnWndProc := WndProc;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hInstance := Windows.MyInstance();
wc.hIcon := Windows.LoadIcon (NIL, Windows.IDI_APPLICATION);
wc.hCursor := Windows.LoadCursor (NIL, Windows.IDC_ARROW);
wc.hbrBackground := SYSTEM.CAST(Windows.HBRUSH, Windows.GetStockObject (Windows.WHITE_BRUSH));
wc.lpszMenuName := NIL;
wc.lpszClassName := SYSTEM.ADR(szAppName);
wc.hIconSm := Windows.LoadIcon (NIL,Windows.IDI_APPLICATION);
RETURN Windows.RegisterClassEx(wc)#0;
END InitApplication;
(*++++*****************************************************************)
PROCEDURE InitMainWindow () : BOOLEAN;
(**********************************************************************)
BEGIN
hwnd := Windows.CreateWindow (szAppName,
"Bouncing Ball: Translation to XDS Modula-2",
Windows.WS_OVERLAPPEDWINDOW,
Windows.CW_USEDEFAULT,
Windows.CW_USEDEFAULT,
Windows.CW_USEDEFAULT,
Windows.CW_USEDEFAULT,
NIL,
NIL,
Windows.MyInstance(),
NIL);
IF(Windows.SetTimer (hwnd, 1, 50, NIL)=0) THEN
Windows.MessageBox (hwnd,
"Too many clocks or timers!",
szAppName,
Windows.MB_ICONEXCLAMATION + Windows.MB_OK);
RETURN FALSE;
END;
Windows.ShowWindow (hwnd, Windows.SW_SHOWDEFAULT);
Windows.UpdateWindow (hwnd);
RETURN TRUE;
END InitMainWindow;
BEGIN
IF InitApplication() AND InitMainWindow() THEN
WHILE (Windows.GetMessage(msg,NIL,0,0)) DO
Windows.TranslateMessage(msg);
Windows.DispatchMessage(msg);
END;
END;
END Bounce.