Bounce.mod: Translation to XDS Modula-2

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.