crt.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986
  1. {
  2. $Id$
  3. Borland Pascal 7 Compatible CRT Unit for win32
  4. See the file COPYING.FPC, included in this distribution,
  5. for details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. **********************************************************************}
  10. unit crt;
  11. {$mode objfpc}
  12. interface
  13. const
  14. { CRT modes }
  15. BW40 = 0; { 40x25 B/W on Color Adapter }
  16. CO40 = 1; { 40x25 Color on Color Adapter }
  17. BW80 = 2; { 80x25 B/W on Color Adapter }
  18. CO80 = 3; { 80x25 Color on Color Adapter }
  19. Mono = 7; { 80x25 on Monochrome Adapter }
  20. Font8x8 = 256; { Add-in for ROM font }
  21. { Mode constants for 3.0 compatibility }
  22. C40 = CO40;
  23. C80 = CO80;
  24. { Foreground and background color constants }
  25. Black = 0;
  26. Blue = 1;
  27. Green = 2;
  28. Cyan = 3;
  29. Red = 4;
  30. Magenta = 5;
  31. Brown = 6;
  32. LightGray = 7;
  33. { Foreground color constants }
  34. DarkGray = 8;
  35. LightBlue = 9;
  36. LightGreen = 10;
  37. LightCyan = 11;
  38. LightRed = 12;
  39. LightMagenta = 13;
  40. Yellow = 14;
  41. White = 15;
  42. { Add-in for blinking }
  43. Blink = 128;
  44. var
  45. { Interface variables }
  46. CheckBreak: Boolean; { Enable Ctrl-Break }
  47. CheckEOF: Boolean; { Enable Ctrl-Z }
  48. DirectVideo: Boolean; { Enable direct video addressing }
  49. CheckSnow: Boolean; { Enable snow filtering }
  50. LastMode: Word; { Current text mode }
  51. TextAttr: Byte; { Current text attribute }
  52. WindMin: Word; { Window upper left coordinates }
  53. WindMax: Word; { Window lower right coordinates }
  54. { Interface procedures }
  55. procedure AssignCrt(var F: Text);
  56. function KeyPressed: Boolean;
  57. function ReadKey: Char;
  58. procedure TextMode(Mode: Integer);
  59. procedure Window(X1,Y1,X2,Y2: Byte);
  60. procedure GotoXY(X,Y: Byte);
  61. function WhereX: Byte;
  62. function WhereY: Byte;
  63. procedure ClrScr;
  64. procedure ClrEol;
  65. procedure InsLine;
  66. procedure DelLine;
  67. procedure TextColor(Color: Byte);
  68. procedure TextBackground(Color: Byte);
  69. procedure LowVideo;
  70. procedure HighVideo;
  71. procedure NormVideo;
  72. procedure Delay(MS: Word);
  73. procedure Sound(Hz: Word);
  74. procedure NoSound;
  75. {Extra Functions}
  76. procedure cursoron;
  77. procedure cursoroff;
  78. procedure cursorbig;
  79. implementation
  80. uses
  81. dos,
  82. windows;
  83. var
  84. OutHandle : THandle;
  85. InputHandle : THandle;
  86. CursorSaveX : Longint;
  87. CursorSaveY : Longint;
  88. ScreenWidth : Longint;
  89. ScreenHeight : Longint;
  90. IsWindowsNT : Boolean;
  91. SaveCursorSize: Longint;
  92. {
  93. definition of textrec is in textrec.inc
  94. }
  95. {$i textrec.inc}
  96. {****************************************************************************
  97. Low level Routines
  98. ****************************************************************************}
  99. function GetPlatformID: Longint;
  100. var OsVersion: TOSVersionInfo;
  101. begin
  102. OsVersion.dwOsVersionInfoSize := SizeOf(OsVersion);
  103. GetVersionEx(OsVersion);
  104. Result := OsVersion.dwPlatformID;
  105. end; { func. GetPlatformID }
  106. procedure TurnMouseOff;
  107. var Mode: DWORD;
  108. begin
  109. if GetConsoleMode(InputHandle, @Mode) then { Turn the mouse-cursor off }
  110. begin
  111. Mode := Mode AND NOT enable_processed_input
  112. AND NOT enable_mouse_input;
  113. SetConsoleMode(InputHandle, Mode);
  114. end; { if }
  115. end; { proc. TurnMouseOff }
  116. function GetScreenHeight : longint;
  117. var ConsoleInfo: TConsoleScreenBufferinfo;
  118. begin
  119. GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
  120. Result := ConsoleInfo.dwSize.Y;
  121. end; { func. GetScreenHeight }
  122. function GetScreenWidth : longint;
  123. var ConsoleInfo: TConsoleScreenBufferInfo;
  124. begin
  125. GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
  126. Result := ConsoleInfo.dwSize.X;
  127. end; { func. GetScreenWidth }
  128. procedure SetScreenCursor(x,y : longint);
  129. var CurInfo: TCoord;
  130. begin
  131. FillChar(Curinfo, SizeOf(Curinfo), 0);
  132. CurInfo.X := X - 1;
  133. CurInfo.Y := Y - 1;
  134. SetConsoleCursorPosition(OutHandle, CurInfo);
  135. CursorSaveX := X - 1;
  136. CursorSaveY := Y - 1;
  137. end;
  138. procedure GetScreenCursor(var x,y : longint);
  139. begin
  140. X := CursorSaveX + 1;
  141. Y := CursorSaveY + 1;
  142. end;
  143. {****************************************************************************
  144. Helper Routines
  145. ****************************************************************************}
  146. Function WinMinX: Byte;
  147. {
  148. Current Minimum X coordinate
  149. }
  150. Begin
  151. WinMinX:=(WindMin and $ff)+1;
  152. End;
  153. Function WinMinY: Byte;
  154. {
  155. Current Minimum Y Coordinate
  156. }
  157. Begin
  158. WinMinY:=(WindMin shr 8)+1;
  159. End;
  160. Function WinMaxX: Byte;
  161. {
  162. Current Maximum X coordinate
  163. }
  164. Begin
  165. WinMaxX:=(WindMax and $ff)+1;
  166. End;
  167. Function WinMaxY: Byte;
  168. {
  169. Current Maximum Y coordinate;
  170. }
  171. Begin
  172. WinMaxY:=(WindMax shr 8) + 1;
  173. End;
  174. Function FullWin:boolean;
  175. {
  176. Full Screen 80x25? Window(1,1,80,25) is used, allows faster routines
  177. }
  178. begin
  179. FullWin:=(WinMinX=1) and (WinMinY=1) and
  180. (WinMaxX=ScreenWidth) and (WinMaxY=ScreenHeight);
  181. end;
  182. {****************************************************************************
  183. Public Crt Functions
  184. ****************************************************************************}
  185. procedure textmode(mode : integer);
  186. begin
  187. {!!! Not done yet !!! }
  188. end;
  189. Procedure TextColor(Color: Byte);
  190. {
  191. Switch foregroundcolor
  192. }
  193. Begin
  194. TextAttr:=(Color and $8f) or (TextAttr and $70);
  195. End;
  196. Procedure TextBackground(Color: Byte);
  197. {
  198. Switch backgroundcolor
  199. }
  200. Begin
  201. TextAttr:=((Color shl 4) and ($f0 and not Blink)) or (TextAttr and ($0f OR Blink) );
  202. End;
  203. Procedure HighVideo;
  204. {
  205. Set highlighted output.
  206. }
  207. Begin
  208. TextColor(TextAttr Or $08);
  209. End;
  210. Procedure LowVideo;
  211. {
  212. Set normal output
  213. }
  214. Begin
  215. TextColor(TextAttr And $77);
  216. End;
  217. Procedure NormVideo;
  218. {
  219. Set normal back and foregroundcolors.
  220. }
  221. Begin
  222. TextColor(7);
  223. TextBackGround(0);
  224. End;
  225. Procedure GotoXy(X: Byte; Y: Byte);
  226. {
  227. Go to coordinates X,Y in the current window.
  228. }
  229. Begin
  230. If (X>0) and (X<=WinMaxX- WinMinX+1) and
  231. (Y>0) and (Y<=WinMaxY-WinMinY+1) Then
  232. Begin
  233. Inc(X,WinMinX-1);
  234. Inc(Y,WinMinY-1);
  235. SetScreenCursor(x,y);
  236. End;
  237. End;
  238. Procedure Window(X1, Y1, X2, Y2: Byte);
  239. {
  240. Set screen window to the specified coordinates.
  241. }
  242. Begin
  243. if (X1>X2) or (X2>ScreenWidth) or
  244. (Y1>Y2) or (Y2>ScreenHeight) then
  245. exit;
  246. WindMin:=((Y1-1) Shl 8)+(X1-1);
  247. WindMax:=((Y2-1) Shl 8)+(X2-1);
  248. GoToXY(1,1);
  249. End;
  250. procedure ClrScr;
  251. var
  252. ClipRect: TSmallRect;
  253. SrcRect: TSmallRect;
  254. DestCoor: TCoord;
  255. CharInfo: TCharInfo;
  256. begin
  257. CharInfo.UnicodeChar := 32;
  258. CharInfo.Attributes := TextAttr;
  259. SrcRect.Left := WinMinX - 1;
  260. SrcRect.Top := WinMinY - 1;
  261. SrcRect.Right := WinMaxX - 1;
  262. SrcRect.Bottom := WinMaxY - 1;
  263. ClipRect := SrcRect;
  264. if IsWindowsNT then
  265. begin
  266. DestCoor.X := -WinMaxX;
  267. DestCoor.Y := -WinMaxY;
  268. ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
  269. DestCoor, CharInfo);
  270. end
  271. else begin { Win95 seems to have a bug in scrolling, unfortunately }
  272. { This routine 3 times copies the bottom 12 lines to the }
  273. { top part of the screen. This eventually will clear the }
  274. { screen. }
  275. DestCoor.X := WinMinX - 1;
  276. DestCoor.Y := WinMinY - (Succ((WinMaxY - WinMinY) div 2));
  277. {-------- Scroll 1st part }
  278. ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
  279. DestCoor, CharInfo);
  280. {-------- Scroll 2nd part }
  281. ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
  282. DestCoor, CharInfo);
  283. {-------- Scroll 3rd part (last line) }
  284. ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect,
  285. DestCoor, CharInfo);
  286. end; { if in Windows95 }
  287. GotoXY(1,1);
  288. end; { proc. ClrScr }
  289. procedure ClrEol;
  290. {
  291. Clear from current position to end of line.
  292. }
  293. var Temp: Dword;
  294. CharInfo: Char;
  295. Coord: TCoord;
  296. X,Y: Longint;
  297. begin
  298. GetScreenCursor(x,y);
  299. CharInfo := #32;
  300. Coord.X := X - 1;
  301. Coord.Y := Y - 1;
  302. FillConsoleOutputCharacter(OutHandle, CharInfo, WinMaxX - (X + 01), Coord, @Temp);
  303. end;
  304. Function WhereX: Byte;
  305. {
  306. Return current X-position of cursor.
  307. }
  308. var
  309. x,y : longint;
  310. Begin
  311. GetScreenCursor(x,y);
  312. WhereX:=x-WinMinX+1;
  313. End;
  314. Function WhereY: Byte;
  315. {
  316. Return current Y-position of cursor.
  317. }
  318. var
  319. x,y : longint;
  320. Begin
  321. GetScreenCursor(x,y);
  322. WhereY:=y-WinMinY+1;
  323. End;
  324. {*************************************************************************
  325. KeyBoard
  326. *************************************************************************}
  327. var
  328. ScanCode : char;
  329. SpecialKey : boolean;
  330. DoingNumChars: Boolean;
  331. DoingNumCode: Byte;
  332. Function RemapScanCode (ScanCode: byte; CtrlKeyState: byte; keycode:longint): byte;
  333. { Several remappings of scancodes are necessary to comply with what
  334. we get with MSDOS. Special Windows keys, as Alt-Tab, Ctrl-Esc etc.
  335. are excluded }
  336. var
  337. AltKey, CtrlKey, ShiftKey: boolean;
  338. const
  339. {
  340. Keypad key scancodes:
  341. Ctrl Norm
  342. $77 $47 - Home
  343. $8D $48 - Up arrow
  344. $84 $49 - PgUp
  345. $8E $4A - -
  346. $73 $4B - Left Arrow
  347. $8F $4C - 5
  348. $74 $4D - Right arrow
  349. $4E $4E - +
  350. $75 $4F - End
  351. $91 $50 - Down arrow
  352. $76 $51 - PgDn
  353. $92 $52 - Ins
  354. $93 $53 - Del
  355. }
  356. CtrlKeypadKeys: array[$47..$53] of byte =
  357. ($77, $8D, $84, $8E, $73, $8F, $74, $4E, $75, $91, $76, $92, $93);
  358. begin
  359. AltKey := ((CtrlKeyState AND
  360. (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
  361. CtrlKey := ((CtrlKeyState AND
  362. (RIGHT_CTRL_PRESSED OR LEFT_CTRL_PRESSED)) > 0);
  363. ShiftKey := ((CtrlKeyState AND SHIFT_PRESSED) > 0);
  364. if AltKey then begin
  365. Case KeyCode of
  366. VK_NUMPAD0 ..
  367. VK_NUMPAD9 : begin
  368. DoingNumChars := true;
  369. DoingNumCode := Byte((DoingNumCode * 10) + (KeyCode - VK_NUMPAD0));
  370. end;
  371. end; { case }
  372. case ScanCode of
  373. // Digits, -, =
  374. $02..$0D: inc(ScanCode, $76);
  375. // Function keys
  376. $3B..$44: inc(Scancode, $2D);
  377. $57..$58: inc(Scancode, $34);
  378. // Extended cursor block keys
  379. $47..$49, $4B, $4D, $4F..$53:
  380. inc(Scancode, $50);
  381. // Other keys
  382. $1C: Scancode := $A6; // Enter
  383. $35: Scancode := $A4; // / (keypad and normal!)
  384. end
  385. end
  386. else if CtrlKey then
  387. case Scancode of
  388. // Tab key
  389. $0F: Scancode := $94;
  390. // Function keys
  391. $3B..$44: inc(Scancode, $23);
  392. $57..$58: inc(Scancode, $32);
  393. // Keypad keys
  394. $35: Scancode := $95; // \
  395. $37: Scancode := $96; // *
  396. $47..$53: Scancode := CtrlKeypadKeys[Scancode];
  397. end
  398. else if ShiftKey then
  399. case Scancode of
  400. // Function keys
  401. $3B..$44: inc(Scancode, $19);
  402. $57..$58: inc(Scancode, $30);
  403. end
  404. else
  405. case Scancode of
  406. // Function keys
  407. $57..$58: inc(Scancode, $2E); // F11 and F12
  408. end;
  409. Result := ScanCode;
  410. end;
  411. function KeyPressed : boolean;
  412. var
  413. nevents, nread, i: longint;
  414. buf : TINPUTRECORD;
  415. AltKey: Boolean;
  416. begin
  417. KeyPressed := FALSE;
  418. if ScanCode <> #0 then
  419. KeyPressed := TRUE
  420. else
  421. begin
  422. nevents:=0;
  423. GetNumberOfConsoleInputEvents(TextRec(input).Handle,nevents);
  424. For i := 1 to nevents do
  425. begin
  426. ReadConsoleInputA(TextRec(input).Handle,buf,1,nread);
  427. if buf.EventType = KEY_EVENT then
  428. if buf.KeyEvent.bKeyDown then
  429. begin
  430. { Alt key is VK_MENU }
  431. { Capslock key is VK_CAPITAL }
  432. AltKey := ((Buf.KeyEvent.dwControlKeyState AND
  433. (RIGHT_ALT_PRESSED OR LEFT_ALT_PRESSED)) > 0);
  434. if (Buf.KeyEvent.wVirtualKeyCode in [VK_SHIFT, VK_MENU, VK_CONTROL,
  435. VK_CAPITAL, VK_NUMLOCK,
  436. VK_SCROLL]) then
  437. begin
  438. { Discard this key }
  439. end
  440. else begin
  441. KeyPressed := TRUE;
  442. if ord(buf.KeyEvent.AsciiChar) = 0 then
  443. begin
  444. SpecialKey := TRUE;
  445. ScanCode := Chr(RemapScanCode(Buf.KeyEvent.wVirtualScanCode, Buf.KeyEvent.dwControlKeyState,
  446. Buf.KeyEvent.wVirtualKeyCode));
  447. end
  448. else
  449. begin
  450. SpecialKey := FALSE;
  451. ScanCode := Chr(Ord(buf.KeyEvent.AsciiChar));
  452. end;
  453. if Buf.KeyEvent.wVirtualKeyCode in [VK_NUMPAD0..VK_NUMPAD9] then
  454. if AltKey then
  455. begin
  456. Keypressed := false;
  457. Specialkey := false;
  458. ScanCode := #0;
  459. end
  460. else BREAK;
  461. end;
  462. end { if }
  463. else if (Buf.KeyEvent.wVirtualKeyCode in [VK_MENU]) then
  464. if DoingNumChars then
  465. if DoingNumCode > 0 then
  466. begin
  467. ScanCode := Chr(DoingNumCode);
  468. Keypressed := true;
  469. DoingNumChars := false;
  470. DoingNumCode := 0;
  471. BREAK;
  472. end; { if }
  473. end;
  474. end;
  475. end;
  476. function ReadKey: char;
  477. begin
  478. repeat
  479. Sleep(1);
  480. until KeyPressed;
  481. if SpecialKey then begin
  482. ReadKey := #0;
  483. SpecialKey := FALSE;
  484. end
  485. else begin
  486. ReadKey := ScanCode;
  487. ScanCode := #0;
  488. end;
  489. end;
  490. {*************************************************************************
  491. Delay
  492. *************************************************************************}
  493. procedure Delay(MS: Word);
  494. begin
  495. Sleep(ms);
  496. end; { proc. Delay }
  497. procedure sound(hz : word);
  498. begin
  499. MessageBeep(0); { lame ;-) }
  500. end;
  501. procedure nosound;
  502. begin
  503. end;
  504. {****************************************************************************
  505. HighLevel Crt Functions
  506. ****************************************************************************}
  507. procedure removeline(y : longint);
  508. var
  509. ClipRect: TSmallRect;
  510. SrcRect: TSmallRect;
  511. DestCoor: TCoord;
  512. CharInfo: TCharInfo;
  513. begin
  514. CharInfo.UnicodeChar := 32;
  515. CharInfo.Attributes := TextAttr;
  516. Y := WinMinY + Y-1;
  517. SrcRect.Top := Y - 01;
  518. SrcRect.Left := WinMinX - 1;
  519. SrcRect.Right := WinMaxX - 1;
  520. SrcRect.Bottom := WinMaxY - 1;
  521. DestCoor.X := WinMinX - 1;
  522. DestCoor.Y := Y - 2;
  523. ClipRect := SrcRect;
  524. ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect, DestCoor, CharInfo);
  525. end; { proc. RemoveLine }
  526. procedure delline;
  527. begin
  528. removeline(wherey);
  529. end; { proc. DelLine }
  530. procedure insline;
  531. var
  532. ClipRect: TSmallRect;
  533. SrcRect: TSmallRect;
  534. DestCoor: TCoord;
  535. CharInfo: TCharInfo;
  536. X,Y: Longint;
  537. begin
  538. GetScreenCursor(X, Y);
  539. CharInfo.UnicodeChar := 32;
  540. CharInfo.Attributes := TextAttr;
  541. SrcRect.Top := Y - 1;
  542. SrcRect.Left := WinMinX - 1;
  543. SrcRect.Right := WinMaxX - 1;
  544. SrcRect.Bottom := WinMaxY - 1;
  545. DestCoor.X := WinMinX - 1;
  546. DestCoor.Y := Y;
  547. ClipRect := SrcRect;
  548. ScrollConsoleScreenBuffer(OutHandle, SrcRect, ClipRect, DestCoor, CharInfo);
  549. end; { proc. InsLine }
  550. {****************************************************************************
  551. Extra Crt Functions
  552. ****************************************************************************}
  553. procedure cursoron;
  554. var CursorInfo: TConsoleCursorInfo;
  555. begin
  556. GetConsoleCursorInfo(OutHandle, CursorInfo);
  557. CursorInfo.dwSize := SaveCursorSize;
  558. CursorInfo.bVisible := true;
  559. SetConsoleCursorInfo(OutHandle, CursorInfo);
  560. end;
  561. procedure cursoroff;
  562. var CursorInfo: TConsoleCursorInfo;
  563. begin
  564. GetConsoleCursorInfo(OutHandle, CursorInfo);
  565. CursorInfo.bVisible := false;
  566. SetConsoleCursorInfo(OutHandle, CursorInfo);
  567. end;
  568. procedure cursorbig;
  569. var CursorInfo: TConsoleCursorInfo;
  570. begin
  571. GetConsoleCursorInfo(OutHandle, CursorInfo);
  572. CursorInfo.dwSize := 100;
  573. CursorInfo.bVisible := true;
  574. SetConsoleCursorInfo(OutHandle, CursorInfo);
  575. end;
  576. {*****************************************************************************
  577. Read and Write routines
  578. *****************************************************************************}
  579. var
  580. CurrX, CurrY : longint;
  581. procedure WriteChar(c:char);
  582. var
  583. Cell : TCharInfo;
  584. BufSize : Coord; { Column-row size of source buffer }
  585. WritePos: TCoord; { Upper-left cell to write from }
  586. DestRect: TSmallRect;
  587. begin
  588. Case C of
  589. #10 : begin
  590. Inc(CurrY);
  591. end;
  592. #13 : begin
  593. CurrX := WinMinX;
  594. end; { if }
  595. #08 : begin
  596. if CurrX > WinMinX then Dec(CurrX);
  597. end; { ^H }
  598. #07 : begin
  599. // MessagBeep(0);
  600. end; { ^G }
  601. else begin
  602. BufSize.X := 01;
  603. BufSize.Y := 01;
  604. WritePos.X := 0;
  605. WritePos.Y := 0;
  606. Cell.UniCodeChar := Ord(c);
  607. Cell.Attributes := TextAttr;
  608. DestRect.Left := (CurrX - 01);
  609. DestRect.Top := (CurrY - 01);
  610. DestRect.Right := (CurrX - 01);
  611. DestRect.Bottom := (CurrY - 01);
  612. WriteConsoleOutput(OutHandle, Cell, BufSize, WritePos, @DestRect);
  613. Inc(CurrX);
  614. end; { else }
  615. end; { case }
  616. if CurrX > WinMaxX then
  617. begin
  618. CurrX := WinMinX;
  619. Inc(CurrY);
  620. end; { if }
  621. While CurrY > WinMaxY do
  622. begin
  623. RemoveLine(1);
  624. Dec(CurrY);
  625. end; { while }
  626. end;
  627. Function CrtWrite(var f : textrec):integer;
  628. var
  629. i : longint;
  630. begin
  631. GetScreenCursor(CurrX,CurrY);
  632. for i:=0 to f.bufpos-1 do
  633. WriteChar(f.buffer[i]);
  634. SetScreenCursor(CurrX,CurrY);
  635. f.bufpos:=0;
  636. CrtWrite:=0;
  637. end;
  638. Function CrtRead(Var F: TextRec): Integer;
  639. procedure BackSpace;
  640. begin
  641. if (f.bufpos>0) and (f.bufpos=f.bufend) then
  642. begin
  643. WriteChar(#8);
  644. WriteChar(' ');
  645. WriteChar(#8);
  646. dec(f.bufpos);
  647. dec(f.bufend);
  648. end;
  649. end;
  650. var
  651. ch : Char;
  652. Begin
  653. GetScreenCursor(CurrX,CurrY);
  654. f.bufpos:=0;
  655. f.bufend:=0;
  656. repeat
  657. if f.bufpos>f.bufend then
  658. f.bufend:=f.bufpos;
  659. SetScreenCursor(CurrX,CurrY);
  660. ch:=readkey;
  661. case ch of
  662. #0 : case readkey of
  663. #71 : while f.bufpos>0 do
  664. begin
  665. dec(f.bufpos);
  666. WriteChar(#8);
  667. end;
  668. #75 : if f.bufpos>0 then
  669. begin
  670. dec(f.bufpos);
  671. WriteChar(#8);
  672. end;
  673. #77 : if f.bufpos<f.bufend then
  674. begin
  675. WriteChar(f.bufptr^[f.bufpos]);
  676. inc(f.bufpos);
  677. end;
  678. #79 : while f.bufpos<f.bufend do
  679. begin
  680. WriteChar(f.bufptr^[f.bufpos]);
  681. inc(f.bufpos);
  682. end;
  683. end;
  684. ^S,
  685. #8 : BackSpace;
  686. ^Y,
  687. #27 : begin
  688. f.bufpos:=f.bufend;
  689. while f.bufend>0 do
  690. BackSpace;
  691. end;
  692. #13 : begin
  693. WriteChar(#13);
  694. WriteChar(#10);
  695. f.bufptr^[f.bufend]:=#13;
  696. f.bufptr^[f.bufend+1]:=#10;
  697. inc(f.bufend,2);
  698. break;
  699. end;
  700. #26 : if CheckEOF then
  701. begin
  702. f.bufptr^[f.bufend]:=#26;
  703. inc(f.bufend);
  704. break;
  705. end;
  706. else
  707. begin
  708. if f.bufpos<f.bufsize-2 then
  709. begin
  710. f.buffer[f.bufpos]:=ch;
  711. inc(f.bufpos);
  712. WriteChar(ch);
  713. end;
  714. end;
  715. end;
  716. until false;
  717. f.bufpos:=0;
  718. SetScreenCursor(CurrX,CurrY);
  719. CrtRead:=0;
  720. End;
  721. Function CrtReturn(Var F:TextRec):Integer;
  722. Begin
  723. CrtReturn:=0;
  724. end;
  725. Function CrtClose(Var F: TextRec): Integer;
  726. Begin
  727. F.Mode:=fmClosed;
  728. CrtClose:=0;
  729. End;
  730. Function CrtOpen(Var F: TextRec): Integer;
  731. Begin
  732. If F.Mode=fmOutput Then
  733. begin
  734. TextRec(F).InOutFunc:=@CrtWrite;
  735. TextRec(F).FlushFunc:=@CrtWrite;
  736. end
  737. Else
  738. begin
  739. F.Mode:=fmInput;
  740. TextRec(F).InOutFunc:=@CrtRead;
  741. TextRec(F).FlushFunc:=@CrtReturn;
  742. end;
  743. TextRec(F).CloseFunc:=@CrtClose;
  744. CrtOpen:=0;
  745. End;
  746. procedure AssignCrt(var F: Text);
  747. begin
  748. Assign(F,'');
  749. TextRec(F).OpenFunc:=@CrtOpen;
  750. end;
  751. var
  752. CursorInfo : TConsoleCursorInfo;
  753. ConsoleInfo : TConsoleScreenBufferinfo;
  754. begin
  755. { Initialize the output handles }
  756. OutHandle := GetStdHandle(STD_OUTPUT_HANDLE);
  757. InputHandle := GetStdHandle(STD_INPUT_HANDLE);
  758. LastMode := 3;
  759. {--------------------- Get the cursor size and such -----------------------}
  760. FillChar(CursorInfo, SizeOf(CursorInfo), 00);
  761. GetConsoleCursorInfo(OutHandle, CursorInfo);
  762. SaveCursorSize := CursorInfo.dwSize;
  763. {------------------ Get the current cursor position and attr --------------}
  764. FillChar(ConsoleInfo, SizeOf(ConsoleInfo), 0);
  765. GetConsoleScreenBufferInfo(OutHandle, ConsoleInfo);
  766. CursorSaveX := ConsoleInfo.dwCursorPosition.X;
  767. CursorSaveY := ConsoleInfo.dwCursorPosition.Y;
  768. TextAttr := ConsoleInfo.wAttributes;
  769. { Load startup values }
  770. ScreenWidth := GetScreenWidth;
  771. ScreenHeight := GetScreenHeight;
  772. IsWindowsNT := (GetPlatformID = VER_PLATFORM_WIN32_NT);
  773. TurnMouseOff;
  774. WindMax := (ScreenWidth - 1) OR ((ScreenHeight - 1) SHL 8);
  775. DoingNumChars := false;
  776. DoingNumCode := 0;
  777. { Redirect the standard output }
  778. AssignCrt(Output);
  779. Rewrite(Output);
  780. TextRec(Output).Handle:= OutHandle;
  781. AssignCrt(Input);
  782. Reset(Input);
  783. TextRec(Input).Handle:= InputHandle;
  784. end. { unit Crt }
  785. {
  786. $Log$
  787. Revision 1.14 2000-02-26 14:57:17 florian
  788. * writing at coloumn <screenwidth> wasn't possible in some cases,
  789. fixed
  790. Revision 1.13 2000/02/09 16:59:34 peter
  791. * truncated log
  792. Revision 1.12 1999/10/22 14:36:20 peter
  793. * crtreturn also needs f:textrec as parameter
  794. Revision 1.11 1999/08/28 09:30:39 peter
  795. * fixes from Maarten Bekers
  796. Revision 1.10 1999/08/24 13:15:44 peter
  797. * Removeline fixed
  798. }