Last updated: 18. 1.1998, 11: 4
<* +M2EXTENSIONS *>
(*--------------------------------------
TYPER.C --- Typing Program
(c) Charles Petzold, 1996
Typer.mod --- Translation to XDS Modula-2
(c) Peter Stadler, 1997
--------------------------------------*)
MODULE Typer;
IMPORT SYSTEM;
IMPORT Windows;
IMPORT Storage;
CONST
szAppName = "Typer";
VAR
hwnd : Windows.HWND;
msg : Windows.MSG;
wc : Windows.WNDCLASSEX;
(*
#define BUFFER(x,y) *(pBuffer + y * cxBuffer + x)
*)
TYPE
BUFFER = ARRAY[0..10000] OF CHAR;
VAR
Buffer : BUFFER;
pBuffer : POINTER TO BUFFER;
cxChar : INTEGER;
cyChar : INTEGER;
cxClient: INTEGER;
cyClient: INTEGER;
cxBuffer: INTEGER;
cyBuffer: INTEGER;
xCaret : INTEGER;
yCaret : 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 BUFFEROut (x,y : INTEGER) : CHAR;
(**********************************************************************)
(*
#define BUFFER(x,y) *(pBuffer + y * cxBuffer + x)
*)
VAR
ch : CHAR;
BEGIN
ch := Buffer[y*cxBuffer+x];
RETURN ch;
END BUFFEROut;
(*++++*****************************************************************)
PROCEDURE BUFFERIn (x,y : INTEGER; ch : CHAR);
(**********************************************************************)
BEGIN
Buffer[y*cxBuffer+x] := ch;
END BUFFERIn;
(*++++*****************************************************************)
PROCEDURE [Windows.CALLBACK] WndProc (hwnd : Windows.HWND;
iMsg : Windows.UINT;
wParam : Windows.WPARAM;
lParam : Windows.LPARAM) : Windows.LRESULT;
(**********************************************************************)
VAR
hdc : Windows.HDC;
x : INTEGER;
y : INTEGER;
i : INTEGER;
ps : Windows.PAINTSTRUCT;
tm : Windows.TEXTMETRIC;
ch2 : ARRAY[0..1] OF CHAR;
BEGIN
CASE (iMsg) OF
| Windows.WM_CREATE :
hdc := Windows.GetDC (hwnd);
Windows.SelectObject (hdc, Windows.GetStockObject (Windows.SYSTEM_FIXED_FONT));
Windows.GetTextMetrics (hdc, tm);
cxChar := tm.tmAveCharWidth;
cyChar := tm.tmHeight;
Windows.ReleaseDC (hwnd, hdc);
RETURN 0;
| Windows.WM_SIZE :
(* obtain window size in pixels *)
cxClient := Windows.LOWORD (lParam);
cyClient := Windows.HIWORD (lParam);
(* calculate window size in characters *)
cxBuffer := MaxInt (1, cxClient DIV cxChar);
cyBuffer := MaxInt (1, cyClient DIV cyChar);
(* allocate memory for buffer and clear it *)
IF (pBuffer # NIL) THEN
Storage.DEALLOCATE(pBuffer,10000);
END;
Storage.ALLOCATE(pBuffer,10000);
(*
IF ((pBuffer := (char * ) malloc (cxBuffer * cyBuffer)) = NIL) THEN
MessageBox (hwnd, "Window too large. Cannot "
"allocate enough memory.", "Typer",
MB_ICONEXCLAMATION + MB_OK);
ELSE
*) FOR y := 0 TO cyBuffer-1 DO
FOR x := 0 TO cxBuffer-1 DO
BUFFERIn (x,y,' ');
END;
END;
(*
END;
*)
(* set caret to upper left corner *)
xCaret := 0;
yCaret := 0;
IF (hwnd = Windows.GetFocus ()) THEN
Windows.SetCaretPos (xCaret * cxChar, yCaret * cyChar);
END;
RETURN 0;
| Windows.WM_SETFOCUS :
(* create and show the caret *)
Windows.CreateCaret (hwnd, NIL, cxChar, cyChar);
Windows.SetCaretPos (xCaret * cxChar, yCaret * cyChar);
Windows.ShowCaret (hwnd);
RETURN 0;
| Windows.WM_KILLFOCUS :
(* hide and destroy the caret *)
Windows.HideCaret (hwnd);
Windows.DestroyCaret ();
RETURN 0;
| Windows.WM_KEYDOWN :
CASE (wParam) OF
| Windows.VK_HOME :
xCaret := 0;
| Windows.VK_END :
xCaret := cxBuffer - 1;
| Windows.VK_PRIOR :
yCaret := 0;
| Windows.VK_NEXT :
yCaret := cyBuffer - 1;
| Windows.VK_LEFT :
xCaret := MaxInt (xCaret - 1, 0);
| Windows.VK_RIGHT :
xCaret := MinInt (xCaret + 1, cxBuffer - 1);
| Windows.VK_UP :
yCaret := MaxInt (yCaret - 1, 0);
| Windows.VK_DOWN :
yCaret := MinInt (yCaret + 1, cyBuffer - 1);
| Windows.VK_DELETE :
FOR x := xCaret TO cxBuffer - 2 DO
BUFFERIn (x, yCaret,BUFFEROut (x + 1, yCaret));
END;
BUFFERIn (cxBuffer - 1, yCaret, ' ');
Windows.HideCaret (hwnd);
hdc := Windows.GetDC (hwnd);
Windows.SelectObject (hdc,
Windows.GetStockObject (Windows.SYSTEM_FIXED_FONT));
ch2[0] := BUFFEROut (xCaret, yCaret);
Windows.TextOut (hdc, xCaret * cxChar, yCaret * cyChar,
ch2,
cxBuffer - xCaret);
Windows.ShowCaret (hwnd);
Windows.ReleaseDC (hwnd, hdc);
ELSE
END;
Windows.SetCaretPos (xCaret * cxChar, yCaret * cyChar);
RETURN 0;
| Windows.WM_CHAR :
FOR i := 0 TO VAL(INTEGER,Windows.LOWORD (lParam))-1 DO
CASE (wParam) OF
| 8 : (* backspace *)
IF (xCaret > 0) THEN
DEC(xCaret);
Windows.SendMessage (hwnd, Windows.WM_KEYDOWN,
Windows.VK_DELETE, 1h);
END;
| 9 : (* tab *)
REPEAT
Windows.SendMessage (hwnd, Windows.WM_CHAR, 0, 1h);
UNTIL (xCaret MOD 8 = 0);
| 10 : (* line feed *)
INC(yCaret);
IF (yCaret = cyBuffer) THEN
yCaret := 0;
END;
| 13 : (* carriage RETURN *)
xCaret := 0;
INC(yCaret);
IF (yCaret = cyBuffer) THEN
yCaret := 0;
END;
| 27 : (* escape *)
FOR y := 0 TO cyBuffer-1 DO
FOR x := 0 TO cxBuffer-1 DO
BUFFERIn (x, y,' ');
END;
END;
xCaret := 0;
yCaret := 0;
Windows.InvalidateRect (hwnd, NIL, FALSE);
ELSE (* character codes *)
BUFFERIn (xCaret, yCaret, SYSTEM.CAST(CHAR,wParam));
Windows.HideCaret (hwnd);
hdc := Windows.GetDC (hwnd);
Windows.SelectObject (hdc,
Windows.GetStockObject (Windows.SYSTEM_FIXED_FONT));
ch2[0] := BUFFEROut (xCaret, yCaret);
Windows.TextOut (hdc, xCaret * cxChar, yCaret * cyChar,
ch2, 1);
Windows.ShowCaret (hwnd);
Windows.ReleaseDC (hwnd, hdc);
INC(xCaret);
IF (xCaret = cxBuffer) THEN
xCaret := 0;
INC(yCaret);
IF (yCaret = cyBuffer) THEN
yCaret := 0;
END;
END;
END;
END;
Windows.SetCaretPos (xCaret * cxChar, yCaret * cyChar);
RETURN 0;
| Windows.WM_PAINT :
hdc := Windows.BeginPaint (hwnd, ps);
Windows.SelectObject (hdc, Windows.GetStockObject (Windows.SYSTEM_FIXED_FONT));
FOR y := 0 TO cyBuffer-1 DO
FOR x := 0 TO cxBuffer-1 DO
ch2[0] := BUFFEROut (xCaret, yCaret);
Windows.TextOut (hdc, x, y * cyChar, ch2, 1);
END;
END;
Windows.EndPaint (hwnd, ps);
RETURN 0;
| Windows.WM_DESTROY :
Windows.PostQuitMessage (0);
RETURN 0;
ELSE
RETURN Windows.DefWindowProc (hwnd, iMsg, wParam, lParam);
END;
END WndProc;
(*++++*****************************************************************)
PROCEDURE InitApplication () : BOOLEAN;
(**********************************************************************)
VAR
rc : CARDINAL;
BEGIN
wc.cbSize := SIZE(Windows.WNDCLASSEX);
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);
rc := Windows.RegisterClassEx (wc);
RETURN rc#0;
END InitApplication;
(*++++*****************************************************************)
PROCEDURE InitMainWindow () : BOOLEAN;
(**********************************************************************)
BEGIN
hwnd := Windows.CreateWindow
(szAppName, (* window class name *)
"Typing Program: Translation to XDS Modula-2",
(* window caption *)
Windows.WS_OVERLAPPEDWINDOW, (* window style *)
Windows.CW_USEDEFAULT, (* initial x position *)
Windows.CW_USEDEFAULT, (* initial y position *)
Windows.CW_USEDEFAULT, (* initial x size *)
Windows.CW_USEDEFAULT, (* initial y size *)
NIL, (* parent window handle *)
NIL, (* window menu handle *)
Windows.MyInstance(), (* program instance handle *)
NIL); (* creation parameters *)
IF hwnd = NIL THEN
RETURN FALSE;
END;
Windows.ShowWindow (hwnd, Windows.SW_SHOWDEFAULT);
Windows.UpdateWindow (hwnd);
RETURN TRUE;
END InitMainWindow;
(*++++*****************************************************************)
BEGIN
pBuffer := NIL;
IF InitApplication() AND InitMainWindow() THEN
WHILE (Windows.GetMessage(msg,NIL,0,0)) DO
Windows.TranslateMessage(msg);
Windows.DispatchMessage(msg);
END;
END;
END Typer.