OSDN -- 開發和下載開源軟體
繁體中文翻譯狀態 translation status for zh-tw
  • R/O
  • SSH
  • HTTPS

dzbdslauncher: 提交


Commit MetaInfo

修訂44 (tree)
時間2022-01-22 20:44:16
作者dummzeuch

Log Message

removed spaces at line end

Change Summary

差異

--- trunk/src/Velthuis.Console.pas (revision 43)
+++ trunk/src/Velthuis.Console.pas (revision 44)
@@ -1,941 +1,941 @@
11 { }
2-{ File: Velthuis.Console.pas }
3-{ Function: Console unit, similar to the Crt unit in Turbo Pascal. }
4-{ Language: Delphi 5 and above }
5-{ Author: Rudolph Velthuis }
6-{ Copyright: (c) 2006,2008 Rudy Velthuis }
7-{ Disclaimer: This code is freeware. All rights are reserved. }
8-{ This code is provided as is, expressly without a warranty }
9-{ of any kind. You use it at your own risk. }
10-{ }
11-{ If you use this code, please credit me. }
12-{ }
13-// taken from https://github.com/rvelthuis/Consoles
14-// -- 2020-02-29 twm
2+{ File: Velthuis.Console.pas }
3+{ Function: Console unit, similar to the Crt unit in Turbo Pascal. }
4+{ Language: Delphi 5 and above }
5+{ Author: Rudolph Velthuis }
6+{ Copyright: (c) 2006,2008 Rudy Velthuis }
7+{ Disclaimer: This code is freeware. All rights are reserved. }
8+{ This code is provided as is, expressly without a warranty }
9+{ of any kind. You use it at your own risk. }
10+{ }
11+{ If you use this code, please credit me. }
12+{ }
13+// taken from https://github.com/rvelthuis/Consoles
14+// -- 2020-02-29 twm
15+
16+unit Velthuis.Console;
17+
18+{$IFDEF CONDITIONALEXPRESSIONS}
19+ {$IF CompilerVersion >= 17.0}
20+ {$DEFINE INLINES}
21+ {$IFEND}
22+ {$IF RTLVersion >= 14.0}
23+ {$DEFINE HASERROUTPUT}
24+ {$IFEND}
25+{$ENDIF}
26+
27+interface
28+
29+uses Windows;
30+
31+const
32+ // Background and foreground colors
33+ Black = 0;
34+ Blue = 1;
35+ Green = 2;
36+ Cyan = 3;
37+ Red = 4;
38+ Magenta = 5;
39+ Brown = 6;
40+ LightGray = 7;
41+
42+ // Foreground colors
43+ DarkGray = 8;
44+ LightBlue = 9;
45+ LightGreen = 10;
46+ LightCyan = 11;
47+ LightRed = 12;
48+ LightMagenta = 13;
49+ Yellow = 14;
50+ White = 15;
51+
52+ // Blink attribute, to be or-ed with background colors.
53+ Blink = 128;
54+
55+ // Text modes:
56+ BW40 = 0; // 40x25 B/W on Color Adapter
57+ CO40 = 1; // 40x25 Color on Color Adapter
58+ BW80 = 2; // 80x25 B/W on Color Adapter
59+ CO80 = 3; // 80x25 Color on Color Adapter
60+ Mono = 7; // 80x25 on Monochrome Adapter
61+ Font8x8 = 256; // Add-in for ROM font
62+
63+ // Mode constants for 3.0 compatibility of original CRT unit }
64+ C40 = CO40;
65+ C80 = CO80;
66+
67+
68+// Turbo/Borland Pascal Crt routines:
69+
70+// Waits for keypress and returns the key pressed. If the key is not an ASCII
71+// key, #0 is returned, and a successive ReadKey will give the extended key
72+// code of the key.
73+function ReadKey: Char;
74+
75+// Checks whether a key was pressed.
76+function KeyPressed: Boolean;
77+
78+// Puts the cursor at the given coordinates on the screen.
79+procedure GotoXY(X, Y: Smallint);
80+
81+// Returns the current X position of the cursor.
82+function WhereX: Integer;
83+
84+// Returns the current Y position of the cursor.
85+function WhereY: Integer;
86+
87+// Sets text foreground color.
88+procedure TextColor(Color: Byte); overload;
89+
90+// Gets text forground color.
91+function TextColor: Byte; overload;
92+
93+// Sets text background color.
94+procedure TextBackground(Color: Byte); overload;
95+
96+// Gets text background color.
97+function TextBackground: Byte; overload;
98+
99+// Sets text mode.
100+procedure TextMode(Mode: Word);
101+
102+// Sets text colors to low intensity
103+procedure LowVideo;
104+
105+// Sets text colors to high intensity
106+procedure HighVideo;
107+
108+// Sets text attribute to value at startup.
109+procedure NormVideo;
110+
111+// Clears the entire screen, or, if a window is set, the entire window,
112+// in the current background color.
113+procedure ClrScr;
114+
115+// Clears until the end of the line, in the current background color.
116+procedure ClrEol;
117+
118+// Inserts a line at the current cursor position.
119+procedure InsLine;
120+
121+// Deletes the line at the current cursor position.
122+procedure DelLine;
123+
124+// Sets a window, into which all successive output will go. You can reset the
125+// window to full screen by calling Window with a zero or negative value
126+// for Left.
127+procedure Window(Left, Top, Right, Bottom: Integer);
128+
129+// Displays message and waits for the next key press. Displays key
130+// and returns.
131+function Pause(const Msg: string = ''): Char;
132+
133+type
134+ // Plays a sound at the given frequency (in Herz).
135+ TSoundProc = procedure(Frequency: Smallint);
136+
137+ // Stops the sound started with Sound.
138+ TNoSoundProc = procedure;
139+
140+ // Delays for the given amount of milliseconds, or as close as possible.
141+ TDelayProc = procedure(Millisecs: Integer);
142+
143+ // Plays a sound at the given frequency (in Hz) and duration (in ms).
144+ TBeepProc = procedure(Frequency, Duration: Smallint);
145+
146+var
147+ Sound: TSoundProc;
148+ NoSound: TNoSoundProc;
149+ Delay: TDelayProc;
150+ Beep: TBeepProc;
151+
152+// Additional routines:
153+
154+function ScreenWidth: Smallint;
155+function ScreenHeight: Smallint;
156+function BufferWidth: Smallint;
157+function BufferHeight: Smallint;
158+
159+var
160+ TextWindow: TSmallRect;
161+ TextAttr: Byte;
162+ DefaultAttr: Byte;
163+ ScreenMode: Byte;
164+ BufferSize: TCoord;
165+ ScreenSize: TCoord;
166+ StdIn, StdOut: THandle;
167+ StdErr: THandle;
168+ LastMode: Word;
169+ WindMin: Word;
170+ WindMax: Word;
171+ CheckBreak: Boolean;
172+
173+implementation
174+
175+uses SysUtils;
176+
177+type
178+ PKey = ^TKey;
179+ TKey = record
180+ KeyCode: Smallint;
181+ Normal: Smallint;
182+ Shift: Smallint;
183+ Ctrl: Smallint;
184+ Alt: Smallint;
185+ end;
186+
187+const
188+ CKeys: array[0..88] of TKey = (
189+ (KeyCode: VK_BACK; Normal: $8; Shift: $8; Ctrl: $7F; Alt: $10E; ),
190+ (KeyCode: VK_TAB; Normal: $9; Shift: $10F; Ctrl: $194; Alt: $1A5; ),
191+ (KeyCode: VK_RETURN; Normal: $D; Shift: $D; Ctrl: $A; Alt: $1A6),
192+ (KeyCode: VK_ESCAPE; Normal: $1B; Shift: $1B; Ctrl: $1B; Alt: $101),
193+ (KeyCode: VK_SPACE; Normal: $20; Shift: $20; Ctrl: $103; Alt: $20),
194+ (KeyCode: Ord('0'); Normal: Ord('0'); Shift: Ord(')'); Ctrl: - 1; Alt: $181),
195+ (KeyCode: Ord('1'); Normal: Ord('1'); Shift: Ord('!'); Ctrl: - 1; Alt: $178),
196+ (KeyCode: Ord('2'); Normal: Ord('2'); Shift: Ord('@'); Ctrl: $103; Alt: $179),
197+ (KeyCode: Ord('3'); Normal: Ord('3'); Shift: Ord('#'); Ctrl: - 1; Alt: $17A),
198+ (KeyCode: Ord('4'); Normal: Ord('4'); Shift: Ord('$'); Ctrl: - 1; Alt: $17B),
199+ (KeyCode: Ord('5'); Normal: Ord('5'); Shift: Ord('%'); Ctrl: - 1; Alt: $17C),
200+ (KeyCode: Ord('6'); Normal: Ord('6'); Shift: Ord('^'); Ctrl: $1E; Alt: $17D),
201+ (KeyCode: Ord('7'); Normal: Ord('7'); Shift: Ord('&'); Ctrl: - 1; Alt: $17E),
202+ (KeyCode: Ord('8'); Normal: Ord('8'); Shift: Ord('*'); Ctrl: - 1; Alt: $17F),
203+ (KeyCode: Ord('9'); Normal: Ord('9'); Shift: Ord('('); Ctrl: - 1; Alt: $180),
204+ (KeyCode: Ord('A'); Normal: Ord('a'); Shift: Ord('A'); Ctrl: $1; Alt: $11E),
205+ (KeyCode: Ord('B'); Normal: Ord('b'); Shift: Ord('B'); Ctrl: $2; Alt: $130),
206+ (KeyCode: Ord('C'); Normal: Ord('c'); Shift: Ord('C'); Ctrl: $3; Alt: $12E),
207+ (KeyCode: Ord('D'); Normal: Ord('d'); Shift: Ord('D'); Ctrl: $4; Alt: $120),
208+ (KeyCode: Ord('E'); Normal: Ord('e'); Shift: Ord('E'); Ctrl: $5; Alt: $112),
209+ (KeyCode: Ord('F'); Normal: Ord('f'); Shift: Ord('F'); Ctrl: $6; Alt: $121),
210+ (KeyCode: Ord('G'); Normal: Ord('g'); Shift: Ord('G'); Ctrl: $7; Alt: $122),
211+ (KeyCode: Ord('H'); Normal: Ord('h'); Shift: Ord('H'); Ctrl: $8; Alt: $123),
212+ (KeyCode: Ord('I'); Normal: Ord('i'); Shift: Ord('I'); Ctrl: $9; Alt: $117),
213+ (KeyCode: Ord('J'); Normal: Ord('j'); Shift: Ord('J'); Ctrl: $A; Alt: $124),
214+ (KeyCode: Ord('K'); Normal: Ord('k'); Shift: Ord('K'); Ctrl: $B; Alt: $125),
215+ (KeyCode: Ord('L'); Normal: Ord('l'); Shift: Ord('L'); Ctrl: $C; Alt: $126),
216+ (KeyCode: Ord('M'); Normal: Ord('m'); Shift: Ord('M'); Ctrl: $D; Alt: $132),
217+ (KeyCode: Ord('N'); Normal: Ord('n'); Shift: Ord('N'); Ctrl: $E; Alt: $131),
218+ (KeyCode: Ord('O'); Normal: Ord('o'); Shift: Ord('O'); Ctrl: $F; Alt: $118),
219+ (KeyCode: Ord('P'); Normal: Ord('p'); Shift: Ord('P'); Ctrl: $10; Alt: $119),
220+ (KeyCode: Ord('Q'); Normal: Ord('q'); Shift: Ord('Q'); Ctrl: $11; Alt: $110),
221+ (KeyCode: Ord('R'); Normal: Ord('r'); Shift: Ord('R'); Ctrl: $12; Alt: $113),
222+ (KeyCode: Ord('S'); Normal: Ord('s'); Shift: Ord('S'); Ctrl: $13; Alt: $11F),
223+ (KeyCode: Ord('T'); Normal: Ord('t'); Shift: Ord('T'); Ctrl: $14; Alt: $114),
224+ (KeyCode: Ord('U'); Normal: Ord('u'); Shift: Ord('U'); Ctrl: $15; Alt: $116),
225+ (KeyCode: Ord('V'); Normal: Ord('v'); Shift: Ord('V'); Ctrl: $16; Alt: $12F),
226+ (KeyCode: Ord('W'); Normal: Ord('w'); Shift: Ord('W'); Ctrl: $17; Alt: $111),
227+ (KeyCode: Ord('X'); Normal: Ord('x'); Shift: Ord('X'); Ctrl: $18; Alt: $12D),
228+ (KeyCode: Ord('Y'); Normal: Ord('y'); Shift: Ord('Y'); Ctrl: $19; Alt: $115),
229+ (KeyCode: Ord('Z'); Normal: Ord('z'); Shift: Ord('Z'); Ctrl: $1A; Alt: $12C),
230+ (KeyCode: VK_PRIOR; Normal: $149; Shift: $149; Ctrl: $184; Alt: $199),
231+ (KeyCode: VK_NEXT; Normal: $151; Shift: $151; Ctrl: $176; Alt: $1A1),
232+ (KeyCode: VK_END; Normal: $14F; Shift: $14F; Ctrl: $175; Alt: $19F),
233+ (KeyCode: VK_HOME; Normal: $147; Shift: $147; Ctrl: $177; Alt: $197),
234+ (KeyCode: VK_LEFT; Normal: $14B; Shift: $14B; Ctrl: $173; Alt: $19B),
235+ (KeyCode: VK_UP; Normal: $148; Shift: $148; Ctrl: $18D; Alt: $198),
236+ (KeyCode: VK_RIGHT; Normal: $14D; Shift: $14D; Ctrl: $174; Alt: $19D),
237+ (KeyCode: VK_DOWN; Normal: $150; Shift: $150; Ctrl: $191; Alt: $1A0),
238+ (KeyCode: VK_INSERT; Normal: $152; Shift: $152; Ctrl: $192; Alt: $1A2),
239+ (KeyCode: VK_DELETE; Normal: $153; Shift: $153; Ctrl: $193; Alt: $1A3),
240+ (KeyCode: VK_NUMPAD0; Normal: Ord('0'); Shift: $152; Ctrl: $192; Alt: - 1),
241+ (KeyCode: VK_NUMPAD1; Normal: Ord('1'); Shift: $14F; Ctrl: $175; Alt: - 1),
242+ (KeyCode: VK_NUMPAD2; Normal: Ord('2'); Shift: $150; Ctrl: $191; Alt: - 1),
243+ (KeyCode: VK_NUMPAD3; Normal: Ord('3'); Shift: $151; Ctrl: $176; Alt: - 1),
244+ (KeyCode: VK_NUMPAD4; Normal: Ord('4'); Shift: $14B; Ctrl: $173; Alt: - 1),
245+ (KeyCode: VK_NUMPAD5; Normal: Ord('5'); Shift: $14C; Ctrl: $18F; Alt: - 1),
246+ (KeyCode: VK_NUMPAD6; Normal: Ord('6'); Shift: $14D; Ctrl: $174; Alt: - 1),
247+ (KeyCode: VK_NUMPAD7; Normal: Ord('7'); Shift: $147; Ctrl: $177; Alt: - 1),
248+ (KeyCode: VK_NUMPAD8; Normal: Ord('8'); Shift: $148; Ctrl: $18D; Alt: - 1),
249+ (KeyCode: VK_NUMPAD9; Normal: Ord('9'); Shift: $149; Ctrl: $184; Alt: - 1),
250+ (KeyCode: VK_MULTIPLY; Normal: Ord('*'); Shift: Ord('*'); Ctrl: $196; Alt: $137),
251+ (KeyCode: VK_ADD; Normal: Ord('+'); Shift: Ord('+'); Ctrl: $190; Alt: $14E),
252+ (KeyCode: VK_SUBTRACT; Normal: Ord('-'); Shift: Ord('-'); Ctrl: $18E; Alt: $14A),
253+ (KeyCode: VK_DECIMAL; Normal: Ord('.'); Shift: Ord('.'); Ctrl: $153; Alt: $193),
254+ (KeyCode: VK_DIVIDE; Normal: Ord('/'); Shift: Ord('/'); Ctrl: $195; Alt: $1A4),
255+ (KeyCode: VK_F1; Normal: $13B; Shift: $154; Ctrl: $15E; Alt: $168),
256+ (KeyCode: VK_F2; Normal: $13C; Shift: $155; Ctrl: $15F; Alt: $169),
257+ (KeyCode: VK_F3; Normal: $13D; Shift: $156; Ctrl: $160; Alt: $16A),
258+ (KeyCode: VK_F4; Normal: $13E; Shift: $157; Ctrl: $161; Alt: $16B),
259+ (KeyCode: VK_F5; Normal: $13F; Shift: $158; Ctrl: $162; Alt: $16C),
260+ (KeyCode: VK_F6; Normal: $140; Shift: $159; Ctrl: $163; Alt: $16D),
261+ (KeyCode: VK_F7; Normal: $141; Shift: $15A; Ctrl: $164; Alt: $16E),
262+ (KeyCode: VK_F8; Normal: $142; Shift: $15B; Ctrl: $165; Alt: $16F),
263+ (KeyCode: VK_F9; Normal: $143; Shift: $15C; Ctrl: $166; Alt: $170),
264+ (KeyCode: VK_F10; Normal: $144; Shift: $15D; Ctrl: $167; Alt: $171),
265+ (KeyCode: VK_F11; Normal: $185; Shift: $187; Ctrl: $189; Alt: $18B),
266+ (KeyCode: VK_F12; Normal: $186; Shift: $188; Ctrl: $18A; Alt: $18C),
267+ (KeyCode: $DC; Normal: Ord('\'); Shift: Ord('|'); Ctrl: $1C; Alt: $12B),
268+ (KeyCode: $BF; Normal: Ord('/'); Shift: Ord('?'); Ctrl: - 1; Alt: $135),
269+ (KeyCode: $BD; Normal: Ord('-'); Shift: Ord('_'); Ctrl: $1F; Alt: $182),
270+ (KeyCode: $BB; Normal: Ord('='); Shift: Ord('+'); Ctrl: - 1; Alt: $183),
271+ (KeyCode: $DB; Normal: Ord('['); Shift: Ord('{'); Ctrl: $1B; Alt: $11A),
272+ (KeyCode: $DD; Normal: Ord(']'); Shift: Ord('}'); Ctrl: $1D; Alt: $11B),
273+ (KeyCode: $BA; Normal: Ord(';'); Shift: Ord(':'); Ctrl: - 1; Alt: $127),
274+ (KeyCode: $DE; Normal: Ord(''''); Shift: Ord('"'); Ctrl: - 1; Alt: $128),
275+ (KeyCode: $BC; Normal: Ord(','); Shift: Ord('<'); Ctrl: - 1; Alt: $133),
276+ (KeyCode: $BE; Normal: Ord('.'); Shift: Ord('>'); Ctrl: - 1; Alt: $134),
277+ (KeyCode: $C0; Normal: Ord('`'); Shift: Ord('~'); Ctrl: - 1; Alt: $129)
278+ );
279+
280+var
281+ ExtendedChar: Char = #0;
282+
283+function FindKeyCode(KeyCode: Smallint): PKey; {$IFDEF INLINES}inline;{$ENDIF}
284+var
285+ I: Integer;
286+begin
287+ for I := 0 to High(CKeys) do
288+ if CKeys[I].KeyCode = KeyCode then
289+ begin
290+ Result := @CKeys[I];
291+ Exit;
292+ end;
293+ Result := nil;
294+end;
295+
296+// This has a complexity of 11, because of the if else ladder.
297+// That bugs me a bit. Looking for something more elegant.
298+function TranslateKey(const Rec: TInputRecord; State: Integer; Key: PKey; KeyCode: Integer): Smallint;
299+begin
300+ if State and (RIGHT_ALT_PRESSED or LEFT_ALT_PRESSED) <> 0 then
301+ Result := Key^.Alt
302+ else if State and (RIGHT_CTRL_PRESSED or LEFT_CTRL_PRESSED) <> 0 then
303+ Result := Key^.Ctrl
304+ else if State and SHIFT_PRESSED <> 0 then
305+ Result := Key^.Shift
306+ else if KeyCode in [Ord('A')..Ord('Z')] then
307+ Result := Ord(Rec.Event.KeyEvent.AsciiChar)
308+ else
309+ Result := Key^.Normal;
310+end;
311+
312+function ConvertKey(const Rec: TInputRecord; Key: PKey): Smallint;
313+ {$IFDEF INLINES}inline;{$ENDIF}
314+begin
315+ if Assigned(Key) then
316+ Result := TranslateKey(Rec, Rec.Event.KeyEvent.dwControlKeyState,
317+ Key, Rec.Event.KeyEvent.wVirtualKeyCode)
318+ else
319+ Result := -1
320+end;
321+
322+function ReadKey: Char;
323+var
324+ InputRec: TInputRecord;
325+ NumRead: Cardinal;
326+ KeyMode: DWORD;
327+ KeyCode: Smallint;
328+begin
329+ if ExtendedChar <> #0 then
330+ begin
331+ Result := ExtendedChar;
332+ ExtendedChar := #0;
333+ Exit;
334+ end
335+ else
336+ begin
337+ Result := #$FF;
338+ GetConsoleMode(StdIn, KeyMode);
339+ SetConsoleMode(StdIn, 0);
340+ repeat
341+ ReadConsoleInput(StdIn, InputRec, 1, NumRead);
342+ if (InputRec.EventType and KEY_EVENT <> 0) and
343+ InputRec.Event.KeyEvent.bKeyDown then
344+ begin
345+ if InputRec.Event.KeyEvent.AsciiChar <> #0 then
346+ begin
347+ // From Delphi 2009 on, Result is WideChar
348+ Result := Chr(Ord(InputRec.Event.KeyEvent.AsciiChar));
349+ Break;
350+ end;
351+ KeyCode := ConvertKey(InputRec,
352+ FindKeyCode(InputRec.Event.KeyEvent.wVirtualKeyCode));
353+ if KeyCode > $FF then
354+ begin
355+ ExtendedChar := Chr(KeyCode and $FF);
356+ Result := #0;
357+ Break;
358+ end;
359+ end;
360+ until False;
361+ SetConsoleMode(StdIn, KeyMode);
362+ end;
363+end;
364+
365+function KeyPressed: Boolean;
366+var
367+ InputRecArray: array of TInputRecord;
368+ NumRead: DWORD;
369+ NumEvents: DWORD;
370+ I: Integer;
371+ KeyCode: Word;
372+begin
373+ Result := False;
374+ GetNumberOfConsoleInputEvents(StdIn, NumEvents);
375+ if NumEvents = 0 then
376+ Exit;
377+ SetLength(InputRecArray, NumEvents);
378+ PeekConsoleInput(StdIn, InputRecArray[0], NumEvents, NumRead);
379+ for I := 0 to High(InputRecArray) do
380+ begin
381+ if (InputRecArray[I].EventType and Key_Event <> 0) and
382+ InputRecArray[I].Event.KeyEvent.bKeyDown then
383+ begin
384+ KeyCode := InputRecArray[I].Event.KeyEvent.wVirtualKeyCode;
385+ if not (KeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL]) then
386+ begin
387+ if ConvertKey(InputRecArray[I], FindKeyCode(KeyCode)) <> -1 then
388+ begin
389+ Result := True;
390+ Exit;
391+ end;
392+ end;
393+ end;
394+ end;
395+end;
396+
397+procedure TextColor(Color: Byte);
398+begin
399+ LastMode := TextAttr;
400+ TextAttr := (TextAttr and $F0) or (Color and $0F);
401+ SetConsoleTextAttribute(StdOut, TextAttr);
402+end;
403+
404+procedure TextBackground(Color: Byte);
405+begin
406+ LastMode := TextAttr;
407+ TextAttr := (TextAttr and $0F) or ((Color shl 4) and $F0);
408+ SetConsoleTextAttribute(StdOut, TextAttr);
409+end;
410+
411+procedure LowVideo;
412+begin
413+ LastMode := TextAttr;
414+ TextAttr := TextAttr and $F7;
415+ SetConsoleTextAttribute(StdOut, TextAttr);
416+end;
417+
418+procedure HighVideo;
419+begin
420+ LastMode := TextAttr;
421+ TextAttr := TextAttr or $08;
422+ SetConsoleTextAttribute(StdOut, TextAttr);
423+end;
424+
425+procedure NormVideo;
426+begin
427+ TextAttr := DefaultAttr;
428+ SetConsoleTextAttribute(StdOut, TextAttr);
429+end;
430+
431+// The following functions are independent of TextWindow.
432+
433+function GetCursorX: Integer; {$IFDEF INLINES}inline;{$ENDIF}
434+var
435+ BufferInfo: TConsoleScreenBufferInfo;
436+begin
437+ GetConsoleSCreenBufferInfo(StdOut, BufferInfo);
438+ Result := BufferInfo.dwCursorPosition.X;
439+end;
440+
441+function GetCursorY: Integer; {$IFDEF INLINES}inline;{$ENDIF}
442+var
443+ BufferInfo: TConsoleScreenBufferInfo;
444+begin
445+ GetConsoleSCreenBufferInfo(StdOut, BufferInfo);
446+ Result := BufferInfo.dwCursorPosition.Y;
447+end;
448+
449+procedure SetCursorPos(X, Y: Smallint);
450+var
451+ NewPos: TCoord;
452+begin
453+ NewPos.X := X;
454+ NewPos.Y := Y;
455+ SetConsoleCursorPosition(StdOut, NewPos);
456+end;
457+
458+// The following functions are relative to TextWindow.
459+
460+procedure ClrScr;
461+var
462+ StartPos: TCoord;
463+ Len, NumWritten: DWORD;
464+ I: Integer;
465+begin
466+ if (TextWindow.Left = 0) and (TextWindow.Top = 0) and
467+ (TextWindow.Right = BufferSize.X - 1) and
468+ (TextWindow.Bottom = BufferSize.Y - 1) then
469+ begin
470+ StartPos.X := 0;
471+ StartPos.Y := 0;
472+ Len := BufferSize.X * BufferSize.Y;
473+ FillConsoleOutputCharacterA(StdOut, ' ', Len, StartPos, NumWritten);
474+ FillConsoleOutputAttribute(StdOut, TextAttr, Len, StartPos, NumWritten);
475+ if NumWritten < Len then
476+ begin
477+ ScreenSize.X := ScreenWidth;
478+ ScreenSize.Y := ScreenHeight;
479+ end;
480+ end
481+ else
482+ begin
483+ Len := TextWindow.Right - TextWindow.Left + 1;
484+ StartPos.X := TextWindow.Left;
485+ for I := TextWindow.Top to TextWindow.Bottom do
486+ begin
487+ StartPos.Y := I;
488+ FillConsoleOutputCharacterA(StdOut, ' ', Len, StartPos, NumWritten);
489+ FillConsoleOutputAttribute(StdOut, TextAttr, Len, StartPos, NumWritten);
490+ end;
491+ end;
492+ GotoXY(1, 1);
493+end;
494+
495+procedure GotoXY(X, Y: Smallint);
496+begin
497+ Inc(X, TextWindow.Left - 1);
498+ Inc(Y, TextWindow.Top - 1);
499+ if (X >= TextWindow.Left) and (X <= TextWindow.Right) and
500+ (Y >= TextWindow.Top) and (Y <= TextWindow.Bottom) then
501+ SetCursorPos(X, Y);
502+end;
503+
504+procedure ClrEol;
505+var
506+ Len: Integer;
507+ Pos: TCoord;
508+ NumWritten: DWORD;
509+begin
510+ Len := TextWindow.Right - GetCursorX + 1;
511+ Pos.X := GetCursorX;
512+ Pos.Y := GetCursorY;
513+ FillConsoleOutputCharacterA(StdOut, ' ', Len, Pos, NumWritten);
514+ FillConsoleOutputAttribute(StdOut, TextAttr, Len, Pos, NumWritten);
515+end;
516+
517+procedure Scroll(Left, Top, Right, Bottom: Integer; Distance: Integer = 0);
518+var
519+ Rect: TSmallRect;
520+ Fill: TCharInfo;
521+ NewPos: TCoord;
522+begin
523+ Fill.AsciiChar := ' ';
524+ Fill.Attributes := TextAttr;
525+ if Distance = 0 then
526+ Distance := Bottom - Top + 1;
527+ Rect.Left := Left;
528+ Rect.Right := Right;
529+ Rect.Top := Top;
530+ Rect.Bottom := Bottom;
531+ NewPos.X := Left;
532+ NewPos.Y := Top + Distance;
533+ ScrollConsoleScreenBufferA(StdOut, Rect, @Rect, NewPos, Fill);
534+end;
535+
536+procedure InsLine;
537+begin
538+ Scroll(TextWindow.Left, GetCursorY,
539+ TextWindow.Right, TextWindow.Bottom, 1);
540+end;
541+
542+procedure DelLine;
543+begin
544+ Scroll(TextWindow.Left, GetCursorY,
545+ TextWindow.Right, TextWindow.Bottom, -1);
546+end;
547+
548+function Validate(X1, Y1, X2, Y2: Integer): Boolean;
549+ {$IFDEF INLINES}inline;{$ENDIF}
550+begin
551+ Result := (X1 < X2) and (Y1 < Y2) and
552+ (X1 >= 0) and (X2 < BufferSize.X) and
553+ (Y1 >= 0) and (Y2 < BufferSize.Y);
554+end;
555+
556+procedure WriteText(Line: PAnsiChar; Len: Integer);
557+var
558+ NumWritten: DWORD;
559+begin
560+ SetConsoleTextAttribute(StdOut, TextAttr);
561+ WriteConsoleA(StdOut, Line, Len, NumWritten, nil);
562+end;
563+
564+// Replacement for TTextRec.InOutFunc and TTextRec.FlushFunc for the Output
565+// and ErrOutput pseudo-textfiles.
566+// This is generally only used if a text window is set, otherwise this is
567+// handled by the runtime library.
568+function NewTextOut(var T: TTextRec): Integer;
569+var
570+ ReadPtr, WritePtr: PAnsiChar;
571+ Line: AnsiString;
572+ DistanceToEdge: Integer;
573+
574+ // Moves cursor to start of line, updates DistanceToEdge.
575+ procedure CarriageReturn;
576+ begin
577+ SetCursorPos(TextWindow.Left, GetCursorY);
578+ DistanceToEdge := TextWindow.Right - TextWindow.Left + 1;
579+ end;
580+
581+ // Moves cursor down one line. If necessary, scrolls window.
582+ procedure LineFeed; {$IFDEF INLINES}inline;{$ENDIF}
583+ begin
584+ if GetCursorY < TextWindow.Bottom then
585+ SetCursorPos(GetCursorX, GetCursorY + 1)
586+ else
587+ Scroll(TextWindow.Left, TextWindow.Top, TextWindow.Right,
588+ TextWindow.Bottom, -1);
589+ end;
590+
591+ // Store one char in write buffer.
592+ procedure CharToWriteBuffer(C: AnsiChar);
593+ begin
594+ WritePtr^ := C;
595+ Inc(WritePtr);
596+ Dec(DistanceToEdge);
597+ end;
598+
599+ // True if at right edge of window.
600+ function WriteLine: Boolean;
601+ begin
602+ WritePtr^ := #0;
603+ WriteText(PAnsiChar(Line), WritePtr - PAnsiChar(Line));
604+ Result := DistanceToEdge = 0;
605+ WritePtr := PAnsiChar(Line);
606+ DistanceToEdge := TextWindow.Right - TextWindow.Left + 1;
607+ end;
608+
609+ // Converts tabs to spaces, since WriteConsole will do its own tabbing when
610+ // it encounters a #9, which is of course independent of this unit's
611+ // TextWindow settings.
612+ procedure ProcessTab;
613+ var
614+ Num, I: Integer;
615+ begin
616+ Num := 8 - (WritePtr - PAnsiChar(Line)) mod 8;
617+ if Num > DistanceToEdge then
618+ Num := DistanceToEdge;
619+ for I := 1 to Num do
620+ CharToWriteBuffer(' ');
621+ end;
622+
623+begin
624+ SetLength(Line, BufferSize.X); // Line only contains one line of windowed text.
625+ WritePtr := PAnsiChar(Line);
626+ ReadPtr := T.BufPtr;
627+ DistanceToEdge := TextWindow.Right - GetCursorX + 1;
628+ while T.BufPos > 0 do
629+ begin
630+ while (T.BufPos > 0) and (DistanceToEdge > 0) do
631+ begin
632+ case ReadPtr^ of
633+ #7: Windows.Beep(800, 200); // this is what my internal speaker uses.
634+ #8: begin
635+ Dec(WritePtr);
636+ Inc(DistanceToEdge);
637+ end;
638+ #9: ProcessTab;
639+ // LineFeed is not just a line feed, it takes the function of #13#10
640+ #10: begin
641+ WriteLine;
642+ CarriageReturn;
643+ LineFeed;
644+ end;
645+ #13: begin
646+ WriteLine;
647+ CarriageReturn;
648+ end;
649+ else
650+ CharToWriteBuffer(ReadPtr^);
651+ end;
652+ Inc(ReadPtr);
653+ Dec(T.BufPos);
654+ end;
655+ if WriteLine then
656+ begin
657+ CarriageReturn;
658+ // If TexWindow.Right is at the edge of the screen, WriteConsole will
659+ // already do a linefeed.
660+ if TextWindow.Right <> ScreenWidth - 1 then
661+ LineFeed;
662+ end;
663+ end;
664+ Result := 0;
665+end;
666+
667+var
668+ OldInOutFunc: Pointer;
669+ OldFlushFunc: Pointer;
670+
671+procedure Window(Left, Top, Right, Bottom: Integer);
672+begin
673+ Dec(Left);
674+ Dec(Top);
675+ Dec(Right);
676+ Dec(Bottom);
677+ if Validate(Left, Top, Right, Bottom) then
678+ begin
679+ TextWindow.Left := Left;
680+ TextWindow.Top := Top;
681+ TextWindow.Right := Right;
682+ TextWindow.Bottom := Bottom;
683+ if (Left > 0) or (Top > 0) or
684+ (Right < BufferSize.X - 1) or (Bottom < BufferSize.Y - 1) then
685+ // Text must be contained in window
686+ begin
687+ OldInOutFunc := TTextRec(Output).InOutFunc;
688+ OldFlushFunc := TTextRec(Output).FlushFunc;
689+ TTextRec(Output).InOutFunc := @NewTextOut;
690+ TTextRec(Output).FlushFunc := @NewTextOut;
691+ SetCursorPos(Left, Top);
692+ end;
693+ end
694+ else
695+ begin
696+ TextWindow.Left := 0;
697+ TextWindow.Right := BufferSize.X - 1;
698+ TextWindow.Top := 0;
699+ TextWindow.Bottom := BufferSize.Y - 1;
700+ SetCursorPos(0, 0);
701+ if Assigned(OldInOutFunc) then
702+ begin
703+ TTextRec(Output).InOutFunc := OldInOutFunc;
704+ OldInOutFunc := nil;
705+ end;
706+ if Assigned(OldFlushFunc) then
707+ begin
708+ TTextRec(Output).FlushFunc := OldFlushFunc;
709+ OldFlushFunc := nil;
710+ end;
711+ end;
712+ WindMin := (TextWindow.Left and $FF) or (TextWindow.Top and $FF) shl 8;
713+ WindMax := (TextWindow.Right and $FF) or (TextWindow.Bottom and $FF) shl 8;
714+end;
715+
716+procedure HardwareSound(Frequency: Smallint);
717+asm
718+ CMP AX,37
719+ JB @@1
720+ MOV CX,AX
721+ MOV AL,$B6
722+ OUT $43,AL
723+ MOV AX,$3540
724+ MOV DX,$0012
725+ DIV CX
726+ OUT $42,AL
727+ MOV AL,AH
728+ OUT $42,AL
729+ MOV AL,3
730+ OUT $61,AL
731+@@1:
732+end;
733+
734+procedure HardwareNoSound;
735+asm
736+ MOV AL,0
737+ OUT $61,AL
738+end;
739+
740+procedure HardwareDelay(Millisecs: Integer);
741+begin
742+ Sleep(Millisecs);
743+end;
744+
745+procedure HardwareBeep(Frequency, Duration: Smallint);
746+begin
747+ Sound(Frequency);
748+ Delay(Duration);
749+ NoSound;
750+end;
751+
752+type
753+ TSoundState = (ssPending, ssPlaying, ssFreed);
754+
755+var
756+ CurrentFrequency: Integer;
757+ SoundState: TSoundState;
758+
759+// On Windows NT and later, direct port access is prohibited, so there is
760+// no way to use HardwareSound and HardwareNoSound.
761+//
762+// Since probably every note played by Sound will be delimited by some kind
763+// of Delay, the playing of the note is deferred to Delay. Sound only stores
764+// the frequency and sets the SoundState to ssPending. Delay now knows both
765+// parameters, and can use Windows.Beep.
766+//
767+// Note that such code is not reentrant.
768+
769+procedure SoftwareSound(Frequency: Smallint);
770+begin
771+ // $123540 div Frequency must be <= $7FFF, so Frequency must be >= 37.
772+ if Frequency >= 37 then
773+ begin
774+ CurrentFrequency := Frequency;
775+ SoundState := ssPending;
776+ end;
777+end;
778+
779+procedure SoftwareDelay(Millisecs: Integer);
780+begin
781+ if SoundState = ssPending then
782+ begin
783+ SoundState := ssPlaying;
784+ Windows.Beep(CurrentFrequency, MilliSecs);
785+ SoundState := ssFreed;
786+ end
787+ else
788+ Sleep(MilliSecs);
789+end;
790+
791+procedure SoftwareBeep(Frequency, Duration: Smallint);
792+begin
793+ if Frequency >= 37 then
794+ begin
795+ SoundState := ssPlaying;
796+ Windows.Beep(Frequency, Duration);
797+ SoundState := ssFreed;
798+ end;
799+end;
800+
801+procedure SoftwareNoSound;
802+begin
803+ Windows.Beep(CurrentFrequency, 0);
804+ SoundState := ssFreed;
805+end;
806+
807+function WhereX: Integer;
808+begin
809+ Result := GetCursorX - TextWindow.Left + 1;
810+end;
811+
812+function WhereY: Integer;
813+begin
814+ Result := GetCursorY - TextWindow.Top + 1;
815+end;
816+
817+procedure GetScreenSizes(var Width, Height: Smallint);
818+var
819+ BufferInfo: TConsoleScreenBufferInfo;
820+begin
821+ GetConsoleScreenBufferInfo(StdOut, BufferInfo);
822+ Width := BufferInfo.srWindow.Right - BufferInfo.srWindow.Left + 1;
823+ Height := BufferInfo.srWindow.Bottom - BufferInfo.srWindow.Top + 1;
824+end;
825+
826+function ScreenWidth: Smallint;
827+var
828+ Height: Smallint;
829+begin
830+ GetScreenSizes(Result, Height);
831+end;
832+
833+function ScreenHeight: Smallint;
834+var
835+ Width: Smallint;
836+begin
837+ GetScreenSizes(Width, Result);
838+end;
839+
840+procedure GetBufferSizes(var Width, Height: Smallint);
841+var
842+ BufferInfo: TConsoleScreenBufferInfo;
843+begin
844+ GetConsoleScreenBufferInfo(StdOut, BufferInfo);
845+ Width := BufferInfo.dwSize.X;
846+ Height := BufferInfo.dwSize.Y;
847+end;
848+
849+function BufferWidth: Smallint;
850+var
851+ Height: Smallint;
852+begin
853+ GetBufferSizes(Result, Height);
854+end;
855+
856+function BufferHeight: Smallint;
857+var
858+ Width: Smallint;
859+begin
860+ GetBufferSizes(Width, Result);
861+end;
862+
863+function TextColor: Byte;
864+begin
865+ Result := TextAttr and $0F;
866+end;
867+
868+function TextBackground: Byte;
869+begin
870+ Result := (TextAttr and $F0) shr 4;
871+end;
872+
873+procedure TextMode(Mode: Word);
874+begin
875+ Window(0, 0, 0, 0);
876+ NormVideo;
877+end;
878+
879+function Pause(const Msg: string = ''): Char;
880+begin
881+ if Msg = '' then
882+ Write('Press any key... ')
883+ else
884+ Write(Msg);
885+ Result := ReadKey;
886+end;
887+
888+procedure InitScreenMode;
889+var
890+ BufferInfo: TConsoleScreenBufferInfo;
891+begin
892+ Reset(Input);
893+ Rewrite(Output);
894+ StdIn := TTextRec(Input).Handle;
895+ StdOut := TTextRec(Output).Handle;
896+{$IFDEF HASERROUTPUT}
897+ Rewrite(ErrOutput);
898+ StdErr := TTextRec(ErrOutput).Handle;
899+{$ELSE}
900+ StdErr := GetStdHandle(STD_ERROR_HANDLE);
901+{$ENDIF}
902+ if not GetConsoleScreenBufferInfo(StdOut, BufferInfo) then
903+ begin
904+ SetInOutRes(GetLastError);
905+ Exit;
906+ end;
907+ TextWindow.Left := 0;
908+ TextWindow.Top := 0;
909+ TextWindow.Right := BufferInfo.dwSize.X - 1;
910+ TextWindow.Bottom := BufferInfo.dwSize.Y - 1;
911+ TextAttr := BufferInfo.wAttributes and $FF;
912+ DefaultAttr := TextAttr;
913+ BufferSize := BufferInfo.dwSize;
914+ ScreenSize.X := BufferInfo.srWindow.Right - BufferInfo.srWindow.Left + 1;
915+ ScreenSize.Y := BufferInfo.srWindow.Bottom - BufferInfo.srWindow.Top + 1;
916+ WindMin := 0;
917+ WindMax := (ScreenSize.X and $FF) or (ScreenSize.Y and $FF) shl 8;
918+ LastMode := CO80;
919+ OldInOutFunc := nil;
920+ OldFlushFunc := nil;
921+ if Win32Platform = VER_PLATFORM_WIN32_NT then
922+ begin
923+ Sound := SoftwareSound;
924+ NoSound := SoftwareNoSound;
925+ Delay := SoftwareDelay;
926+ Beep := SoftwareBeep;
927+ end
928+ else
929+ begin
930+ Sound := HardwareSound;
931+ NoSound := HardwareNoSound;
932+ Delay := HardwareDelay;
933+ Beep := HardwareBeep;
934+ end;
935+end;
936+
937+initialization
938+ InitScreenMode;
939+
940+end.
15941
16-unit Velthuis.Console;
17-
18-{$IFDEF CONDITIONALEXPRESSIONS}
19- {$IF CompilerVersion >= 17.0}
20- {$DEFINE INLINES}
21- {$IFEND}
22- {$IF RTLVersion >= 14.0}
23- {$DEFINE HASERROUTPUT}
24- {$IFEND}
25-{$ENDIF}
26-
27-interface
28-
29-uses Windows;
30-
31-const
32- // Background and foreground colors
33- Black = 0;
34- Blue = 1;
35- Green = 2;
36- Cyan = 3;
37- Red = 4;
38- Magenta = 5;
39- Brown = 6;
40- LightGray = 7;
41-
42- // Foreground colors
43- DarkGray = 8;
44- LightBlue = 9;
45- LightGreen = 10;
46- LightCyan = 11;
47- LightRed = 12;
48- LightMagenta = 13;
49- Yellow = 14;
50- White = 15;
51-
52- // Blink attribute, to be or-ed with background colors.
53- Blink = 128;
54-
55- // Text modes:
56- BW40 = 0; // 40x25 B/W on Color Adapter
57- CO40 = 1; // 40x25 Color on Color Adapter
58- BW80 = 2; // 80x25 B/W on Color Adapter
59- CO80 = 3; // 80x25 Color on Color Adapter
60- Mono = 7; // 80x25 on Monochrome Adapter
61- Font8x8 = 256; // Add-in for ROM font
62-
63- // Mode constants for 3.0 compatibility of original CRT unit }
64- C40 = CO40;
65- C80 = CO80;
66-
67-
68-// Turbo/Borland Pascal Crt routines:
69-
70-// Waits for keypress and returns the key pressed. If the key is not an ASCII
71-// key, #0 is returned, and a successive ReadKey will give the extended key
72-// code of the key.
73-function ReadKey: Char;
74-
75-// Checks whether a key was pressed.
76-function KeyPressed: Boolean;
77-
78-// Puts the cursor at the given coordinates on the screen.
79-procedure GotoXY(X, Y: Smallint);
80-
81-// Returns the current X position of the cursor.
82-function WhereX: Integer;
83-
84-// Returns the current Y position of the cursor.
85-function WhereY: Integer;
86-
87-// Sets text foreground color.
88-procedure TextColor(Color: Byte); overload;
89-
90-// Gets text forground color.
91-function TextColor: Byte; overload;
92-
93-// Sets text background color.
94-procedure TextBackground(Color: Byte); overload;
95-
96-// Gets text background color.
97-function TextBackground: Byte; overload;
98-
99-// Sets text mode.
100-procedure TextMode(Mode: Word);
101-
102-// Sets text colors to low intensity
103-procedure LowVideo;
104-
105-// Sets text colors to high intensity
106-procedure HighVideo;
107-
108-// Sets text attribute to value at startup.
109-procedure NormVideo;
110-
111-// Clears the entire screen, or, if a window is set, the entire window,
112-// in the current background color.
113-procedure ClrScr;
114-
115-// Clears until the end of the line, in the current background color.
116-procedure ClrEol;
117-
118-// Inserts a line at the current cursor position.
119-procedure InsLine;
120-
121-// Deletes the line at the current cursor position.
122-procedure DelLine;
123-
124-// Sets a window, into which all successive output will go. You can reset the
125-// window to full screen by calling Window with a zero or negative value
126-// for Left.
127-procedure Window(Left, Top, Right, Bottom: Integer);
128-
129-// Displays message and waits for the next key press. Displays key
130-// and returns.
131-function Pause(const Msg: string = ''): Char;
132-
133-type
134- // Plays a sound at the given frequency (in Herz).
135- TSoundProc = procedure(Frequency: Smallint);
136-
137- // Stops the sound started with Sound.
138- TNoSoundProc = procedure;
139-
140- // Delays for the given amount of milliseconds, or as close as possible.
141- TDelayProc = procedure(Millisecs: Integer);
142-
143- // Plays a sound at the given frequency (in Hz) and duration (in ms).
144- TBeepProc = procedure(Frequency, Duration: Smallint);
145-
146-var
147- Sound: TSoundProc;
148- NoSound: TNoSoundProc;
149- Delay: TDelayProc;
150- Beep: TBeepProc;
151-
152-// Additional routines:
153-
154-function ScreenWidth: Smallint;
155-function ScreenHeight: Smallint;
156-function BufferWidth: Smallint;
157-function BufferHeight: Smallint;
158-
159-var
160- TextWindow: TSmallRect;
161- TextAttr: Byte;
162- DefaultAttr: Byte;
163- ScreenMode: Byte;
164- BufferSize: TCoord;
165- ScreenSize: TCoord;
166- StdIn, StdOut: THandle;
167- StdErr: THandle;
168- LastMode: Word;
169- WindMin: Word;
170- WindMax: Word;
171- CheckBreak: Boolean;
172-
173-implementation
174-
175-uses SysUtils;
176-
177-type
178- PKey = ^TKey;
179- TKey = record
180- KeyCode: Smallint;
181- Normal: Smallint;
182- Shift: Smallint;
183- Ctrl: Smallint;
184- Alt: Smallint;
185- end;
186-
187-const
188- CKeys: array[0..88] of TKey = (
189- (KeyCode: VK_BACK; Normal: $8; Shift: $8; Ctrl: $7F; Alt: $10E; ),
190- (KeyCode: VK_TAB; Normal: $9; Shift: $10F; Ctrl: $194; Alt: $1A5; ),
191- (KeyCode: VK_RETURN; Normal: $D; Shift: $D; Ctrl: $A; Alt: $1A6),
192- (KeyCode: VK_ESCAPE; Normal: $1B; Shift: $1B; Ctrl: $1B; Alt: $101),
193- (KeyCode: VK_SPACE; Normal: $20; Shift: $20; Ctrl: $103; Alt: $20),
194- (KeyCode: Ord('0'); Normal: Ord('0'); Shift: Ord(')'); Ctrl: - 1; Alt: $181),
195- (KeyCode: Ord('1'); Normal: Ord('1'); Shift: Ord('!'); Ctrl: - 1; Alt: $178),
196- (KeyCode: Ord('2'); Normal: Ord('2'); Shift: Ord('@'); Ctrl: $103; Alt: $179),
197- (KeyCode: Ord('3'); Normal: Ord('3'); Shift: Ord('#'); Ctrl: - 1; Alt: $17A),
198- (KeyCode: Ord('4'); Normal: Ord('4'); Shift: Ord('$'); Ctrl: - 1; Alt: $17B),
199- (KeyCode: Ord('5'); Normal: Ord('5'); Shift: Ord('%'); Ctrl: - 1; Alt: $17C),
200- (KeyCode: Ord('6'); Normal: Ord('6'); Shift: Ord('^'); Ctrl: $1E; Alt: $17D),
201- (KeyCode: Ord('7'); Normal: Ord('7'); Shift: Ord('&'); Ctrl: - 1; Alt: $17E),
202- (KeyCode: Ord('8'); Normal: Ord('8'); Shift: Ord('*'); Ctrl: - 1; Alt: $17F),
203- (KeyCode: Ord('9'); Normal: Ord('9'); Shift: Ord('('); Ctrl: - 1; Alt: $180),
204- (KeyCode: Ord('A'); Normal: Ord('a'); Shift: Ord('A'); Ctrl: $1; Alt: $11E),
205- (KeyCode: Ord('B'); Normal: Ord('b'); Shift: Ord('B'); Ctrl: $2; Alt: $130),
206- (KeyCode: Ord('C'); Normal: Ord('c'); Shift: Ord('C'); Ctrl: $3; Alt: $12E),
207- (KeyCode: Ord('D'); Normal: Ord('d'); Shift: Ord('D'); Ctrl: $4; Alt: $120),
208- (KeyCode: Ord('E'); Normal: Ord('e'); Shift: Ord('E'); Ctrl: $5; Alt: $112),
209- (KeyCode: Ord('F'); Normal: Ord('f'); Shift: Ord('F'); Ctrl: $6; Alt: $121),
210- (KeyCode: Ord('G'); Normal: Ord('g'); Shift: Ord('G'); Ctrl: $7; Alt: $122),
211- (KeyCode: Ord('H'); Normal: Ord('h'); Shift: Ord('H'); Ctrl: $8; Alt: $123),
212- (KeyCode: Ord('I'); Normal: Ord('i'); Shift: Ord('I'); Ctrl: $9; Alt: $117),
213- (KeyCode: Ord('J'); Normal: Ord('j'); Shift: Ord('J'); Ctrl: $A; Alt: $124),
214- (KeyCode: Ord('K'); Normal: Ord('k'); Shift: Ord('K'); Ctrl: $B; Alt: $125),
215- (KeyCode: Ord('L'); Normal: Ord('l'); Shift: Ord('L'); Ctrl: $C; Alt: $126),
216- (KeyCode: Ord('M'); Normal: Ord('m'); Shift: Ord('M'); Ctrl: $D; Alt: $132),
217- (KeyCode: Ord('N'); Normal: Ord('n'); Shift: Ord('N'); Ctrl: $E; Alt: $131),
218- (KeyCode: Ord('O'); Normal: Ord('o'); Shift: Ord('O'); Ctrl: $F; Alt: $118),
219- (KeyCode: Ord('P'); Normal: Ord('p'); Shift: Ord('P'); Ctrl: $10; Alt: $119),
220- (KeyCode: Ord('Q'); Normal: Ord('q'); Shift: Ord('Q'); Ctrl: $11; Alt: $110),
221- (KeyCode: Ord('R'); Normal: Ord('r'); Shift: Ord('R'); Ctrl: $12; Alt: $113),
222- (KeyCode: Ord('S'); Normal: Ord('s'); Shift: Ord('S'); Ctrl: $13; Alt: $11F),
223- (KeyCode: Ord('T'); Normal: Ord('t'); Shift: Ord('T'); Ctrl: $14; Alt: $114),
224- (KeyCode: Ord('U'); Normal: Ord('u'); Shift: Ord('U'); Ctrl: $15; Alt: $116),
225- (KeyCode: Ord('V'); Normal: Ord('v'); Shift: Ord('V'); Ctrl: $16; Alt: $12F),
226- (KeyCode: Ord('W'); Normal: Ord('w'); Shift: Ord('W'); Ctrl: $17; Alt: $111),
227- (KeyCode: Ord('X'); Normal: Ord('x'); Shift: Ord('X'); Ctrl: $18; Alt: $12D),
228- (KeyCode: Ord('Y'); Normal: Ord('y'); Shift: Ord('Y'); Ctrl: $19; Alt: $115),
229- (KeyCode: Ord('Z'); Normal: Ord('z'); Shift: Ord('Z'); Ctrl: $1A; Alt: $12C),
230- (KeyCode: VK_PRIOR; Normal: $149; Shift: $149; Ctrl: $184; Alt: $199),
231- (KeyCode: VK_NEXT; Normal: $151; Shift: $151; Ctrl: $176; Alt: $1A1),
232- (KeyCode: VK_END; Normal: $14F; Shift: $14F; Ctrl: $175; Alt: $19F),
233- (KeyCode: VK_HOME; Normal: $147; Shift: $147; Ctrl: $177; Alt: $197),
234- (KeyCode: VK_LEFT; Normal: $14B; Shift: $14B; Ctrl: $173; Alt: $19B),
235- (KeyCode: VK_UP; Normal: $148; Shift: $148; Ctrl: $18D; Alt: $198),
236- (KeyCode: VK_RIGHT; Normal: $14D; Shift: $14D; Ctrl: $174; Alt: $19D),
237- (KeyCode: VK_DOWN; Normal: $150; Shift: $150; Ctrl: $191; Alt: $1A0),
238- (KeyCode: VK_INSERT; Normal: $152; Shift: $152; Ctrl: $192; Alt: $1A2),
239- (KeyCode: VK_DELETE; Normal: $153; Shift: $153; Ctrl: $193; Alt: $1A3),
240- (KeyCode: VK_NUMPAD0; Normal: Ord('0'); Shift: $152; Ctrl: $192; Alt: - 1),
241- (KeyCode: VK_NUMPAD1; Normal: Ord('1'); Shift: $14F; Ctrl: $175; Alt: - 1),
242- (KeyCode: VK_NUMPAD2; Normal: Ord('2'); Shift: $150; Ctrl: $191; Alt: - 1),
243- (KeyCode: VK_NUMPAD3; Normal: Ord('3'); Shift: $151; Ctrl: $176; Alt: - 1),
244- (KeyCode: VK_NUMPAD4; Normal: Ord('4'); Shift: $14B; Ctrl: $173; Alt: - 1),
245- (KeyCode: VK_NUMPAD5; Normal: Ord('5'); Shift: $14C; Ctrl: $18F; Alt: - 1),
246- (KeyCode: VK_NUMPAD6; Normal: Ord('6'); Shift: $14D; Ctrl: $174; Alt: - 1),
247- (KeyCode: VK_NUMPAD7; Normal: Ord('7'); Shift: $147; Ctrl: $177; Alt: - 1),
248- (KeyCode: VK_NUMPAD8; Normal: Ord('8'); Shift: $148; Ctrl: $18D; Alt: - 1),
249- (KeyCode: VK_NUMPAD9; Normal: Ord('9'); Shift: $149; Ctrl: $184; Alt: - 1),
250- (KeyCode: VK_MULTIPLY; Normal: Ord('*'); Shift: Ord('*'); Ctrl: $196; Alt: $137),
251- (KeyCode: VK_ADD; Normal: Ord('+'); Shift: Ord('+'); Ctrl: $190; Alt: $14E),
252- (KeyCode: VK_SUBTRACT; Normal: Ord('-'); Shift: Ord('-'); Ctrl: $18E; Alt: $14A),
253- (KeyCode: VK_DECIMAL; Normal: Ord('.'); Shift: Ord('.'); Ctrl: $153; Alt: $193),
254- (KeyCode: VK_DIVIDE; Normal: Ord('/'); Shift: Ord('/'); Ctrl: $195; Alt: $1A4),
255- (KeyCode: VK_F1; Normal: $13B; Shift: $154; Ctrl: $15E; Alt: $168),
256- (KeyCode: VK_F2; Normal: $13C; Shift: $155; Ctrl: $15F; Alt: $169),
257- (KeyCode: VK_F3; Normal: $13D; Shift: $156; Ctrl: $160; Alt: $16A),
258- (KeyCode: VK_F4; Normal: $13E; Shift: $157; Ctrl: $161; Alt: $16B),
259- (KeyCode: VK_F5; Normal: $13F; Shift: $158; Ctrl: $162; Alt: $16C),
260- (KeyCode: VK_F6; Normal: $140; Shift: $159; Ctrl: $163; Alt: $16D),
261- (KeyCode: VK_F7; Normal: $141; Shift: $15A; Ctrl: $164; Alt: $16E),
262- (KeyCode: VK_F8; Normal: $142; Shift: $15B; Ctrl: $165; Alt: $16F),
263- (KeyCode: VK_F9; Normal: $143; Shift: $15C; Ctrl: $166; Alt: $170),
264- (KeyCode: VK_F10; Normal: $144; Shift: $15D; Ctrl: $167; Alt: $171),
265- (KeyCode: VK_F11; Normal: $185; Shift: $187; Ctrl: $189; Alt: $18B),
266- (KeyCode: VK_F12; Normal: $186; Shift: $188; Ctrl: $18A; Alt: $18C),
267- (KeyCode: $DC; Normal: Ord('\'); Shift: Ord('|'); Ctrl: $1C; Alt: $12B),
268- (KeyCode: $BF; Normal: Ord('/'); Shift: Ord('?'); Ctrl: - 1; Alt: $135),
269- (KeyCode: $BD; Normal: Ord('-'); Shift: Ord('_'); Ctrl: $1F; Alt: $182),
270- (KeyCode: $BB; Normal: Ord('='); Shift: Ord('+'); Ctrl: - 1; Alt: $183),
271- (KeyCode: $DB; Normal: Ord('['); Shift: Ord('{'); Ctrl: $1B; Alt: $11A),
272- (KeyCode: $DD; Normal: Ord(']'); Shift: Ord('}'); Ctrl: $1D; Alt: $11B),
273- (KeyCode: $BA; Normal: Ord(';'); Shift: Ord(':'); Ctrl: - 1; Alt: $127),
274- (KeyCode: $DE; Normal: Ord(''''); Shift: Ord('"'); Ctrl: - 1; Alt: $128),
275- (KeyCode: $BC; Normal: Ord(','); Shift: Ord('<'); Ctrl: - 1; Alt: $133),
276- (KeyCode: $BE; Normal: Ord('.'); Shift: Ord('>'); Ctrl: - 1; Alt: $134),
277- (KeyCode: $C0; Normal: Ord('`'); Shift: Ord('~'); Ctrl: - 1; Alt: $129)
278- );
279-
280-var
281- ExtendedChar: Char = #0;
282-
283-function FindKeyCode(KeyCode: Smallint): PKey; {$IFDEF INLINES}inline;{$ENDIF}
284-var
285- I: Integer;
286-begin
287- for I := 0 to High(CKeys) do
288- if CKeys[I].KeyCode = KeyCode then
289- begin
290- Result := @CKeys[I];
291- Exit;
292- end;
293- Result := nil;
294-end;
295-
296-// This has a complexity of 11, because of the if else ladder.
297-// That bugs me a bit. Looking for something more elegant.
298-function TranslateKey(const Rec: TInputRecord; State: Integer; Key: PKey; KeyCode: Integer): Smallint;
299-begin
300- if State and (RIGHT_ALT_PRESSED or LEFT_ALT_PRESSED) <> 0 then
301- Result := Key^.Alt
302- else if State and (RIGHT_CTRL_PRESSED or LEFT_CTRL_PRESSED) <> 0 then
303- Result := Key^.Ctrl
304- else if State and SHIFT_PRESSED <> 0 then
305- Result := Key^.Shift
306- else if KeyCode in [Ord('A')..Ord('Z')] then
307- Result := Ord(Rec.Event.KeyEvent.AsciiChar)
308- else
309- Result := Key^.Normal;
310-end;
311-
312-function ConvertKey(const Rec: TInputRecord; Key: PKey): Smallint;
313- {$IFDEF INLINES}inline;{$ENDIF}
314-begin
315- if Assigned(Key) then
316- Result := TranslateKey(Rec, Rec.Event.KeyEvent.dwControlKeyState,
317- Key, Rec.Event.KeyEvent.wVirtualKeyCode)
318- else
319- Result := -1
320-end;
321-
322-function ReadKey: Char;
323-var
324- InputRec: TInputRecord;
325- NumRead: Cardinal;
326- KeyMode: DWORD;
327- KeyCode: Smallint;
328-begin
329- if ExtendedChar <> #0 then
330- begin
331- Result := ExtendedChar;
332- ExtendedChar := #0;
333- Exit;
334- end
335- else
336- begin
337- Result := #$FF;
338- GetConsoleMode(StdIn, KeyMode);
339- SetConsoleMode(StdIn, 0);
340- repeat
341- ReadConsoleInput(StdIn, InputRec, 1, NumRead);
342- if (InputRec.EventType and KEY_EVENT <> 0) and
343- InputRec.Event.KeyEvent.bKeyDown then
344- begin
345- if InputRec.Event.KeyEvent.AsciiChar <> #0 then
346- begin
347- // From Delphi 2009 on, Result is WideChar
348- Result := Chr(Ord(InputRec.Event.KeyEvent.AsciiChar));
349- Break;
350- end;
351- KeyCode := ConvertKey(InputRec,
352- FindKeyCode(InputRec.Event.KeyEvent.wVirtualKeyCode));
353- if KeyCode > $FF then
354- begin
355- ExtendedChar := Chr(KeyCode and $FF);
356- Result := #0;
357- Break;
358- end;
359- end;
360- until False;
361- SetConsoleMode(StdIn, KeyMode);
362- end;
363-end;
364-
365-function KeyPressed: Boolean;
366-var
367- InputRecArray: array of TInputRecord;
368- NumRead: DWORD;
369- NumEvents: DWORD;
370- I: Integer;
371- KeyCode: Word;
372-begin
373- Result := False;
374- GetNumberOfConsoleInputEvents(StdIn, NumEvents);
375- if NumEvents = 0 then
376- Exit;
377- SetLength(InputRecArray, NumEvents);
378- PeekConsoleInput(StdIn, InputRecArray[0], NumEvents, NumRead);
379- for I := 0 to High(InputRecArray) do
380- begin
381- if (InputRecArray[I].EventType and Key_Event <> 0) and
382- InputRecArray[I].Event.KeyEvent.bKeyDown then
383- begin
384- KeyCode := InputRecArray[I].Event.KeyEvent.wVirtualKeyCode;
385- if not (KeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL]) then
386- begin
387- if ConvertKey(InputRecArray[I], FindKeyCode(KeyCode)) <> -1 then
388- begin
389- Result := True;
390- Exit;
391- end;
392- end;
393- end;
394- end;
395-end;
396-
397-procedure TextColor(Color: Byte);
398-begin
399- LastMode := TextAttr;
400- TextAttr := (TextAttr and $F0) or (Color and $0F);
401- SetConsoleTextAttribute(StdOut, TextAttr);
402-end;
403-
404-procedure TextBackground(Color: Byte);
405-begin
406- LastMode := TextAttr;
407- TextAttr := (TextAttr and $0F) or ((Color shl 4) and $F0);
408- SetConsoleTextAttribute(StdOut, TextAttr);
409-end;
410-
411-procedure LowVideo;
412-begin
413- LastMode := TextAttr;
414- TextAttr := TextAttr and $F7;
415- SetConsoleTextAttribute(StdOut, TextAttr);
416-end;
417-
418-procedure HighVideo;
419-begin
420- LastMode := TextAttr;
421- TextAttr := TextAttr or $08;
422- SetConsoleTextAttribute(StdOut, TextAttr);
423-end;
424-
425-procedure NormVideo;
426-begin
427- TextAttr := DefaultAttr;
428- SetConsoleTextAttribute(StdOut, TextAttr);
429-end;
430-
431-// The following functions are independent of TextWindow.
432-
433-function GetCursorX: Integer; {$IFDEF INLINES}inline;{$ENDIF}
434-var
435- BufferInfo: TConsoleScreenBufferInfo;
436-begin
437- GetConsoleSCreenBufferInfo(StdOut, BufferInfo);
438- Result := BufferInfo.dwCursorPosition.X;
439-end;
440-
441-function GetCursorY: Integer; {$IFDEF INLINES}inline;{$ENDIF}
442-var
443- BufferInfo: TConsoleScreenBufferInfo;
444-begin
445- GetConsoleSCreenBufferInfo(StdOut, BufferInfo);
446- Result := BufferInfo.dwCursorPosition.Y;
447-end;
448-
449-procedure SetCursorPos(X, Y: Smallint);
450-var
451- NewPos: TCoord;
452-begin
453- NewPos.X := X;
454- NewPos.Y := Y;
455- SetConsoleCursorPosition(StdOut, NewPos);
456-end;
457-
458-// The following functions are relative to TextWindow.
459-
460-procedure ClrScr;
461-var
462- StartPos: TCoord;
463- Len, NumWritten: DWORD;
464- I: Integer;
465-begin
466- if (TextWindow.Left = 0) and (TextWindow.Top = 0) and
467- (TextWindow.Right = BufferSize.X - 1) and
468- (TextWindow.Bottom = BufferSize.Y - 1) then
469- begin
470- StartPos.X := 0;
471- StartPos.Y := 0;
472- Len := BufferSize.X * BufferSize.Y;
473- FillConsoleOutputCharacterA(StdOut, ' ', Len, StartPos, NumWritten);
474- FillConsoleOutputAttribute(StdOut, TextAttr, Len, StartPos, NumWritten);
475- if NumWritten < Len then
476- begin
477- ScreenSize.X := ScreenWidth;
478- ScreenSize.Y := ScreenHeight;
479- end;
480- end
481- else
482- begin
483- Len := TextWindow.Right - TextWindow.Left + 1;
484- StartPos.X := TextWindow.Left;
485- for I := TextWindow.Top to TextWindow.Bottom do
486- begin
487- StartPos.Y := I;
488- FillConsoleOutputCharacterA(StdOut, ' ', Len, StartPos, NumWritten);
489- FillConsoleOutputAttribute(StdOut, TextAttr, Len, StartPos, NumWritten);
490- end;
491- end;
492- GotoXY(1, 1);
493-end;
494-
495-procedure GotoXY(X, Y: Smallint);
496-begin
497- Inc(X, TextWindow.Left - 1);
498- Inc(Y, TextWindow.Top - 1);
499- if (X >= TextWindow.Left) and (X <= TextWindow.Right) and
500- (Y >= TextWindow.Top) and (Y <= TextWindow.Bottom) then
501- SetCursorPos(X, Y);
502-end;
503-
504-procedure ClrEol;
505-var
506- Len: Integer;
507- Pos: TCoord;
508- NumWritten: DWORD;
509-begin
510- Len := TextWindow.Right - GetCursorX + 1;
511- Pos.X := GetCursorX;
512- Pos.Y := GetCursorY;
513- FillConsoleOutputCharacterA(StdOut, ' ', Len, Pos, NumWritten);
514- FillConsoleOutputAttribute(StdOut, TextAttr, Len, Pos, NumWritten);
515-end;
516-
517-procedure Scroll(Left, Top, Right, Bottom: Integer; Distance: Integer = 0);
518-var
519- Rect: TSmallRect;
520- Fill: TCharInfo;
521- NewPos: TCoord;
522-begin
523- Fill.AsciiChar := ' ';
524- Fill.Attributes := TextAttr;
525- if Distance = 0 then
526- Distance := Bottom - Top + 1;
527- Rect.Left := Left;
528- Rect.Right := Right;
529- Rect.Top := Top;
530- Rect.Bottom := Bottom;
531- NewPos.X := Left;
532- NewPos.Y := Top + Distance;
533- ScrollConsoleScreenBufferA(StdOut, Rect, @Rect, NewPos, Fill);
534-end;
535-
536-procedure InsLine;
537-begin
538- Scroll(TextWindow.Left, GetCursorY,
539- TextWindow.Right, TextWindow.Bottom, 1);
540-end;
541-
542-procedure DelLine;
543-begin
544- Scroll(TextWindow.Left, GetCursorY,
545- TextWindow.Right, TextWindow.Bottom, -1);
546-end;
547-
548-function Validate(X1, Y1, X2, Y2: Integer): Boolean;
549- {$IFDEF INLINES}inline;{$ENDIF}
550-begin
551- Result := (X1 < X2) and (Y1 < Y2) and
552- (X1 >= 0) and (X2 < BufferSize.X) and
553- (Y1 >= 0) and (Y2 < BufferSize.Y);
554-end;
555-
556-procedure WriteText(Line: PAnsiChar; Len: Integer);
557-var
558- NumWritten: DWORD;
559-begin
560- SetConsoleTextAttribute(StdOut, TextAttr);
561- WriteConsoleA(StdOut, Line, Len, NumWritten, nil);
562-end;
563-
564-// Replacement for TTextRec.InOutFunc and TTextRec.FlushFunc for the Output
565-// and ErrOutput pseudo-textfiles.
566-// This is generally only used if a text window is set, otherwise this is
567-// handled by the runtime library.
568-function NewTextOut(var T: TTextRec): Integer;
569-var
570- ReadPtr, WritePtr: PAnsiChar;
571- Line: AnsiString;
572- DistanceToEdge: Integer;
573-
574- // Moves cursor to start of line, updates DistanceToEdge.
575- procedure CarriageReturn;
576- begin
577- SetCursorPos(TextWindow.Left, GetCursorY);
578- DistanceToEdge := TextWindow.Right - TextWindow.Left + 1;
579- end;
580-
581- // Moves cursor down one line. If necessary, scrolls window.
582- procedure LineFeed; {$IFDEF INLINES}inline;{$ENDIF}
583- begin
584- if GetCursorY < TextWindow.Bottom then
585- SetCursorPos(GetCursorX, GetCursorY + 1)
586- else
587- Scroll(TextWindow.Left, TextWindow.Top, TextWindow.Right,
588- TextWindow.Bottom, -1);
589- end;
590-
591- // Store one char in write buffer.
592- procedure CharToWriteBuffer(C: AnsiChar);
593- begin
594- WritePtr^ := C;
595- Inc(WritePtr);
596- Dec(DistanceToEdge);
597- end;
598-
599- // True if at right edge of window.
600- function WriteLine: Boolean;
601- begin
602- WritePtr^ := #0;
603- WriteText(PAnsiChar(Line), WritePtr - PAnsiChar(Line));
604- Result := DistanceToEdge = 0;
605- WritePtr := PAnsiChar(Line);
606- DistanceToEdge := TextWindow.Right - TextWindow.Left + 1;
607- end;
608-
609- // Converts tabs to spaces, since WriteConsole will do its own tabbing when
610- // it encounters a #9, which is of course independent of this unit's
611- // TextWindow settings.
612- procedure ProcessTab;
613- var
614- Num, I: Integer;
615- begin
616- Num := 8 - (WritePtr - PAnsiChar(Line)) mod 8;
617- if Num > DistanceToEdge then
618- Num := DistanceToEdge;
619- for I := 1 to Num do
620- CharToWriteBuffer(' ');
621- end;
622-
623-begin
624- SetLength(Line, BufferSize.X); // Line only contains one line of windowed text.
625- WritePtr := PAnsiChar(Line);
626- ReadPtr := T.BufPtr;
627- DistanceToEdge := TextWindow.Right - GetCursorX + 1;
628- while T.BufPos > 0 do
629- begin
630- while (T.BufPos > 0) and (DistanceToEdge > 0) do
631- begin
632- case ReadPtr^ of
633- #7: Windows.Beep(800, 200); // this is what my internal speaker uses.
634- #8: begin
635- Dec(WritePtr);
636- Inc(DistanceToEdge);
637- end;
638- #9: ProcessTab;
639- // LineFeed is not just a line feed, it takes the function of #13#10
640- #10: begin
641- WriteLine;
642- CarriageReturn;
643- LineFeed;
644- end;
645- #13: begin
646- WriteLine;
647- CarriageReturn;
648- end;
649- else
650- CharToWriteBuffer(ReadPtr^);
651- end;
652- Inc(ReadPtr);
653- Dec(T.BufPos);
654- end;
655- if WriteLine then
656- begin
657- CarriageReturn;
658- // If TexWindow.Right is at the edge of the screen, WriteConsole will
659- // already do a linefeed.
660- if TextWindow.Right <> ScreenWidth - 1 then
661- LineFeed;
662- end;
663- end;
664- Result := 0;
665-end;
666-
667-var
668- OldInOutFunc: Pointer;
669- OldFlushFunc: Pointer;
670-
671-procedure Window(Left, Top, Right, Bottom: Integer);
672-begin
673- Dec(Left);
674- Dec(Top);
675- Dec(Right);
676- Dec(Bottom);
677- if Validate(Left, Top, Right, Bottom) then
678- begin
679- TextWindow.Left := Left;
680- TextWindow.Top := Top;
681- TextWindow.Right := Right;
682- TextWindow.Bottom := Bottom;
683- if (Left > 0) or (Top > 0) or
684- (Right < BufferSize.X - 1) or (Bottom < BufferSize.Y - 1) then
685- // Text must be contained in window
686- begin
687- OldInOutFunc := TTextRec(Output).InOutFunc;
688- OldFlushFunc := TTextRec(Output).FlushFunc;
689- TTextRec(Output).InOutFunc := @NewTextOut;
690- TTextRec(Output).FlushFunc := @NewTextOut;
691- SetCursorPos(Left, Top);
692- end;
693- end
694- else
695- begin
696- TextWindow.Left := 0;
697- TextWindow.Right := BufferSize.X - 1;
698- TextWindow.Top := 0;
699- TextWindow.Bottom := BufferSize.Y - 1;
700- SetCursorPos(0, 0);
701- if Assigned(OldInOutFunc) then
702- begin
703- TTextRec(Output).InOutFunc := OldInOutFunc;
704- OldInOutFunc := nil;
705- end;
706- if Assigned(OldFlushFunc) then
707- begin
708- TTextRec(Output).FlushFunc := OldFlushFunc;
709- OldFlushFunc := nil;
710- end;
711- end;
712- WindMin := (TextWindow.Left and $FF) or (TextWindow.Top and $FF) shl 8;
713- WindMax := (TextWindow.Right and $FF) or (TextWindow.Bottom and $FF) shl 8;
714-end;
715-
716-procedure HardwareSound(Frequency: Smallint);
717-asm
718- CMP AX,37
719- JB @@1
720- MOV CX,AX
721- MOV AL,$B6
722- OUT $43,AL
723- MOV AX,$3540
724- MOV DX,$0012
725- DIV CX
726- OUT $42,AL
727- MOV AL,AH
728- OUT $42,AL
729- MOV AL,3
730- OUT $61,AL
731-@@1:
732-end;
733-
734-procedure HardwareNoSound;
735-asm
736- MOV AL,0
737- OUT $61,AL
738-end;
739-
740-procedure HardwareDelay(Millisecs: Integer);
741-begin
742- Sleep(Millisecs);
743-end;
744-
745-procedure HardwareBeep(Frequency, Duration: Smallint);
746-begin
747- Sound(Frequency);
748- Delay(Duration);
749- NoSound;
750-end;
751-
752-type
753- TSoundState = (ssPending, ssPlaying, ssFreed);
754-
755-var
756- CurrentFrequency: Integer;
757- SoundState: TSoundState;
758-
759-// On Windows NT and later, direct port access is prohibited, so there is
760-// no way to use HardwareSound and HardwareNoSound.
761-//
762-// Since probably every note played by Sound will be delimited by some kind
763-// of Delay, the playing of the note is deferred to Delay. Sound only stores
764-// the frequency and sets the SoundState to ssPending. Delay now knows both
765-// parameters, and can use Windows.Beep.
766-//
767-// Note that such code is not reentrant.
768-
769-procedure SoftwareSound(Frequency: Smallint);
770-begin
771- // $123540 div Frequency must be <= $7FFF, so Frequency must be >= 37.
772- if Frequency >= 37 then
773- begin
774- CurrentFrequency := Frequency;
775- SoundState := ssPending;
776- end;
777-end;
778-
779-procedure SoftwareDelay(Millisecs: Integer);
780-begin
781- if SoundState = ssPending then
782- begin
783- SoundState := ssPlaying;
784- Windows.Beep(CurrentFrequency, MilliSecs);
785- SoundState := ssFreed;
786- end
787- else
788- Sleep(MilliSecs);
789-end;
790-
791-procedure SoftwareBeep(Frequency, Duration: Smallint);
792-begin
793- if Frequency >= 37 then
794- begin
795- SoundState := ssPlaying;
796- Windows.Beep(Frequency, Duration);
797- SoundState := ssFreed;
798- end;
799-end;
800-
801-procedure SoftwareNoSound;
802-begin
803- Windows.Beep(CurrentFrequency, 0);
804- SoundState := ssFreed;
805-end;
806-
807-function WhereX: Integer;
808-begin
809- Result := GetCursorX - TextWindow.Left + 1;
810-end;
811-
812-function WhereY: Integer;
813-begin
814- Result := GetCursorY - TextWindow.Top + 1;
815-end;
816-
817-procedure GetScreenSizes(var Width, Height: Smallint);
818-var
819- BufferInfo: TConsoleScreenBufferInfo;
820-begin
821- GetConsoleScreenBufferInfo(StdOut, BufferInfo);
822- Width := BufferInfo.srWindow.Right - BufferInfo.srWindow.Left + 1;
823- Height := BufferInfo.srWindow.Bottom - BufferInfo.srWindow.Top + 1;
824-end;
825-
826-function ScreenWidth: Smallint;
827-var
828- Height: Smallint;
829-begin
830- GetScreenSizes(Result, Height);
831-end;
832-
833-function ScreenHeight: Smallint;
834-var
835- Width: Smallint;
836-begin
837- GetScreenSizes(Width, Result);
838-end;
839-
840-procedure GetBufferSizes(var Width, Height: Smallint);
841-var
842- BufferInfo: TConsoleScreenBufferInfo;
843-begin
844- GetConsoleScreenBufferInfo(StdOut, BufferInfo);
845- Width := BufferInfo.dwSize.X;
846- Height := BufferInfo.dwSize.Y;
847-end;
848-
849-function BufferWidth: Smallint;
850-var
851- Height: Smallint;
852-begin
853- GetBufferSizes(Result, Height);
854-end;
855-
856-function BufferHeight: Smallint;
857-var
858- Width: Smallint;
859-begin
860- GetBufferSizes(Width, Result);
861-end;
862-
863-function TextColor: Byte;
864-begin
865- Result := TextAttr and $0F;
866-end;
867-
868-function TextBackground: Byte;
869-begin
870- Result := (TextAttr and $F0) shr 4;
871-end;
872-
873-procedure TextMode(Mode: Word);
874-begin
875- Window(0, 0, 0, 0);
876- NormVideo;
877-end;
878-
879-function Pause(const Msg: string = ''): Char;
880-begin
881- if Msg = '' then
882- Write('Press any key... ')
883- else
884- Write(Msg);
885- Result := ReadKey;
886-end;
887-
888-procedure InitScreenMode;
889-var
890- BufferInfo: TConsoleScreenBufferInfo;
891-begin
892- Reset(Input);
893- Rewrite(Output);
894- StdIn := TTextRec(Input).Handle;
895- StdOut := TTextRec(Output).Handle;
896-{$IFDEF HASERROUTPUT}
897- Rewrite(ErrOutput);
898- StdErr := TTextRec(ErrOutput).Handle;
899-{$ELSE}
900- StdErr := GetStdHandle(STD_ERROR_HANDLE);
901-{$ENDIF}
902- if not GetConsoleScreenBufferInfo(StdOut, BufferInfo) then
903- begin
904- SetInOutRes(GetLastError);
905- Exit;
906- end;
907- TextWindow.Left := 0;
908- TextWindow.Top := 0;
909- TextWindow.Right := BufferInfo.dwSize.X - 1;
910- TextWindow.Bottom := BufferInfo.dwSize.Y - 1;
911- TextAttr := BufferInfo.wAttributes and $FF;
912- DefaultAttr := TextAttr;
913- BufferSize := BufferInfo.dwSize;
914- ScreenSize.X := BufferInfo.srWindow.Right - BufferInfo.srWindow.Left + 1;
915- ScreenSize.Y := BufferInfo.srWindow.Bottom - BufferInfo.srWindow.Top + 1;
916- WindMin := 0;
917- WindMax := (ScreenSize.X and $FF) or (ScreenSize.Y and $FF) shl 8;
918- LastMode := CO80;
919- OldInOutFunc := nil;
920- OldFlushFunc := nil;
921- if Win32Platform = VER_PLATFORM_WIN32_NT then
922- begin
923- Sound := SoftwareSound;
924- NoSound := SoftwareNoSound;
925- Delay := SoftwareDelay;
926- Beep := SoftwareBeep;
927- end
928- else
929- begin
930- Sound := HardwareSound;
931- NoSound := HardwareNoSound;
932- Delay := HardwareDelay;
933- Beep := HardwareBeep;
934- end;
935-end;
936-
937-initialization
938- InitScreenMode;
939-
940-end.
941-
Show on old repository browser