crt.pas

   1 {$ifdef WIN32}
   2
   3 unit crt;
   4
   5 interface
   6
   7 type
   8         tcrtcoord = 1..255;
   9
  10 procedure AssignCrt(var F: Text);
  11 procedure ClrEol;
  12 procedure ClrScr;
  13 procedure cursorbig;
  14 procedure cursoroff;
  15 procedure cursoron;
  16 procedure Delay(MS: WORD);
  17 procedure DelLine;
  18 procedure GotoXY(X: tcrtcoord; Y: tcrtcoord);
  19 procedure HighVideo;
  20 procedure InsLine;
  21 function KeyPressed: Boolean;
  22 procedure LowVideo;
  23 procedure NormVideo;
  24 procedure NoSound;
  25 function ReadKey: Char;
  26 procedure Sound(Hz: Word);
  27 procedure TextBackground(Color: Byte);
  28 procedure TextColor(Color: Byte);
  29 procedure TextMode(Mode: WORD);
  30 function WhereX: tcrtcoord;
  31 function WhereY: tcrtcoord;
  32 procedure Window(X1: Byte; Y1: Byte; X2: Byte; Y2: Byte);
  33
  34 implementation
  35
  36 uses
  37         Sysutils,
  38         Strings,
  39         Windows;
  40
  41 const
  42         WIDTH = 80;
  43         HEIGHT = 26;
  44         SPACE = '                                                                                ';
  45
  46 var
  47         output: Handle;
  48         input: Handle;
  49         wx: Longint;
  50         wy: Longint;
  51         fore_color: WORD;
  52         back_color: WORD;
  53         last_key: Char;
  54
  55 procedure AssignCrt(var F: Text);
  56 begin
  57 end;
  58
  59 procedure ClrEol;
  60 var
  61         info: TConsoleScreenBufferinfo;
  62         n: DWORD;
  63 begin
  64         GetConsoleScreenBufferInfo(output, info);
  65         WriteConsoleOutputCharacter(output, SPACE, WIDTH - info.dwCursorPosition.X, info.dwCursorPosition, n);
  66         SetConsoleCursorPosition(output, info.dwCursorPosition);
  67 end;
  68
  69 procedure ClrScr;
  70 var
  71         info: TConsoleScreenBufferinfo;
  72         written: DWORD;
  73         xy: Coord;
  74 begin
  75         xy.x := 0;
  76         xy.y := 0;
  77
  78         GetConsoleScreenBufferInfo(output, info);
  79         FillConsoleOutputCharacter(output, Char(' '), info.dwSize.X * info.dwSize.Y, xy, written);
  80         FillConsoleOutputAttribute(output, info.wAttributes, info.dwSize.X * info.dwSize.Y, xy, written);
  81         GotoXY(1, 1);
  82 end;
  83
  84 procedure cursorbig;
  85 begin
  86 end;
  87
  88 procedure cursoroff;
  89 var
  90         info: CONSOLE_CURSOR_INFO;
  91 begin
  92         GetConsoleCursorInfo(output, info);
  93         info.bVisible := false;
  94         SetConsoleCursorInfo(output, info);
  95 end;
  96
  97 procedure cursoron;
  98 var
  99         info: CONSOLE_CURSOR_INFO;
 100 begin
 101         GetConsoleCursorInfo(output, info);
 102         info.bVisible := true;
 103         SetConsoleCursorInfo(output, info);
 104 end;
 105
 106 procedure Delay(MS: Word);
 107 begin
 108 {
 109         Sleep(MS);
 110 }
 111 end;
 112
 113 procedure DelLine;
 114 var
 115         info: TConsoleScreenBufferinfo;
 116         rect: SMALL_RECT;
 117         clip: SMALL_RECT;
 118         xy: Coord;
 119         c: CHAR_INFO;
 120 begin
 121         GetConsoleScreenBufferInfo(output, info);
 122         rect.Left := 0;
 123         rect.Top := info.dwCursorPosition.Y + 1;
 124         rect.Right := WIDTH - 1;
 125         rect.Bottom := HEIGHT - 1;
 126         clip.Left := 0;
 127         clip.Top := 0;
 128         clip.Right := WIDTH - 1;
 129         clip.Bottom := HEIGHT - 1;
 130         xy.x := 0;
 131         xy.y := info.dwCursorPosition.Y;
 132         c.Attributes := 0;
 133
 134         ScrollConsoleScreenBuffer(output, rect, clip, xy, c);
 135 end;
 136
 137 procedure GotoXY(X: tcrtcoord; Y: tcrtcoord);
 138 var
 139         xy: Coord;
 140 begin
 141         xy.x := X + wx - 1;
 142         xy.y := Y + wy - 1;
 143
 144         SetConsoleCursorPosition(output, xy);
 145 end;
 146
 147 procedure HighVideo;
 148 begin
 149 end;
 150
 151 procedure InsLine;
 152 var
 153         info: TConsoleScreenBufferinfo;
 154         rect: SMALL_RECT;
 155         clip: SMALL_RECT;
 156         xy: Coord;
 157         c: CHAR_INFO;
 158 begin
 159         GetConsoleScreenBufferInfo(output, info);
 160         rect.Left := 0;
 161         rect.Top := info.dwCursorPosition.Y;
 162         rect.Right := WIDTH - 1;
 163         rect.Bottom := HEIGHT - 1;
 164         clip.Left := 0;
 165         clip.Top := 0;
 166         clip.Right := WIDTH - 1;
 167         clip.Bottom := HEIGHT - 1;
 168         xy.x := 0;
 169         xy.y := info.dwCursorPosition.Y + 1;
 170         c.Attributes := 0;
 171
 172         ScrollConsoleScreenBuffer(output, rect, clip, xy, c);
 173 end;
 174
 175 function KeyPressed: Boolean;
 176 begin
 177         Sleep(1);
 178
 179         last_key := #0;
 180
 181         if((GetAsyncKeyState(VK_BACK) and $8000) <> 0) then last_key := #$08;
 182         if((GetAsyncKeyState(VK_TAB) and $8000) <> 0) then last_key := #$09;
 183         if((GetAsyncKeyState(VK_RETURN) and $8000) <> 0) then last_key := #$13;
 184         if((GetAsyncKeyState(VK_SPACE) and $8000) <> 0) then last_key := ' ';
 185         if((GetAsyncKeyState(VK_0) and $8000) <> 0) then last_key := '0';
 186         if((GetAsyncKeyState(VK_1) and $8000) <> 0) then last_key := '1';
 187         if((GetAsyncKeyState(VK_2) and $8000) <> 0) then last_key := '2';
 188         if((GetAsyncKeyState(VK_3) and $8000) <> 0) then last_key := '3';
 189         if((GetAsyncKeyState(VK_4) and $8000) <> 0) then last_key := '4';
 190         if((GetAsyncKeyState(VK_5) and $8000) <> 0) then last_key := '5';
 191         if((GetAsyncKeyState(VK_6) and $8000) <> 0) then last_key := '6';
 192         if((GetAsyncKeyState(VK_7) and $8000) <> 0) then last_key := '7';
 193         if((GetAsyncKeyState(VK_8) and $8000) <> 0) then last_key := '8';
 194         if((GetAsyncKeyState(VK_9) and $8000) <> 0) then last_key := '9';
 195         if((GetAsyncKeyState(VK_A) and $8000) <> 0) then last_key := 'A';
 196         if((GetAsyncKeyState(VK_B) and $8000) <> 0) then last_key := 'B';
 197         if((GetAsyncKeyState(VK_C) and $8000) <> 0) then last_key := 'C';
 198         if((GetAsyncKeyState(VK_D) and $8000) <> 0) then last_key := 'D';
 199         if((GetAsyncKeyState(VK_E) and $8000) <> 0) then last_key := 'E';
 200         if((GetAsyncKeyState(VK_F) and $8000) <> 0) then last_key := 'F';
 201         if((GetAsyncKeyState(VK_G) and $8000) <> 0) then last_key := 'G';
 202         if((GetAsyncKeyState(VK_H) and $8000) <> 0) then last_key := 'H';
 203         if((GetAsyncKeyState(VK_I) and $8000) <> 0) then last_key := 'I';
 204         if((GetAsyncKeyState(VK_J) and $8000) <> 0) then last_key := 'J';
 205         if((GetAsyncKeyState(VK_K) and $8000) <> 0) then last_key := 'K';
 206         if((GetAsyncKeyState(VK_L) and $8000) <> 0) then last_key := 'L';
 207         if((GetAsyncKeyState(VK_M) and $8000) <> 0) then last_key := 'M';
 208         if((GetAsyncKeyState(VK_N) and $8000) <> 0) then last_key := 'N';
 209         if((GetAsyncKeyState(VK_O) and $8000) <> 0) then last_key := 'O';
 210         if((GetAsyncKeyState(VK_P) and $8000) <> 0) then last_key := 'P';
 211         if((GetAsyncKeyState(VK_Q) and $8000) <> 0) then last_key := 'Q';
 212         if((GetAsyncKeyState(VK_R) and $8000) <> 0) then last_key := 'R';
 213         if((GetAsyncKeyState(VK_S) and $8000) <> 0) then last_key := 'S';
 214         if((GetAsyncKeyState(VK_T) and $8000) <> 0) then last_key := 'T';
 215         if((GetAsyncKeyState(VK_U) and $8000) <> 0) then last_key := 'U';
 216         if((GetAsyncKeyState(VK_V) and $8000) <> 0) then last_key := 'V';
 217         if((GetAsyncKeyState(VK_W) and $8000) <> 0) then last_key := 'W';
 218         if((GetAsyncKeyState(VK_X) and $8000) <> 0) then last_key := 'X';
 219         if((GetAsyncKeyState(VK_Y) and $8000) <> 0) then last_key := 'Y';
 220         if((GetAsyncKeyState(VK_Z) and $8000) <> 0) then last_key := 'Z';
 221         if((GetAsyncKeyState(VK_NUMPAD0) and $8000) <> 0) then last_key := '0';
 222         if((GetAsyncKeyState(VK_NUMPAD1) and $8000) <> 0) then last_key := '1';
 223         if((GetAsyncKeyState(VK_NUMPAD2) and $8000) <> 0) then last_key := '2';
 224         if((GetAsyncKeyState(VK_NUMPAD3) and $8000) <> 0) then last_key := '3';
 225         if((GetAsyncKeyState(VK_NUMPAD4) and $8000) <> 0) then last_key := '4';
 226         if((GetAsyncKeyState(VK_NUMPAD5) and $8000) <> 0) then last_key := '5';
 227         if((GetAsyncKeyState(VK_NUMPAD6) and $8000) <> 0) then last_key := '6';
 228         if((GetAsyncKeyState(VK_NUMPAD7) and $8000) <> 0) then last_key := '7';
 229         if((GetAsyncKeyState(VK_NUMPAD8) and $8000) <> 0) then last_key := '8';
 230         if((GetAsyncKeyState(VK_NUMPAD9) and $8000) <> 0) then last_key := '9';
 231         if((GetAsyncKeyState(VK_MULTIPLY) and $8000) <> 0) then last_key := '*';
 232         if((GetAsyncKeyState(VK_ADD) and $8000) <> 0) then last_key := '+';
 233         if((GetAsyncKeyState(VK_SUBTRACT) and $8000) <> 0) then last_key := '-';
 234         if((GetAsyncKeyState(VK_DECIMAL) and $8000) <> 0) then last_key := '/';
 235         if((GetAsyncKeyState(VK_DIVIDE) and $8000) <> 0) then last_key := '.';
 236
 237         keyPressed := (last_key <> #0);
 238 end;
 239
 240 procedure LowVideo;
 241 begin
 242 end;
 243
 244 procedure NormVideo;
 245 begin
 246 end;
 247
 248 procedure NoSound;
 249 begin
 250 end;
 251
 252 function ReadKey: Char;
 253 var
 254         buf: Pchar;
 255         n: DWORD;
 256 begin
 257         if (last_key <> #0) then
 258         begin
 259                 ReadKey := last_key;
 260                 last_key := #0;
 261                 FlushConsoleInputBuffer(input);
 262                 exit;
 263         end;
 264
 265         SetConsoleMode(input, ENABLE_PROCESSED_INPUT);
 266         buf := stralloc(8);
 267         ReadConsole(input, buf, 1, n, nil);
 268         ReadKey := String(buf)[1];
 269         strdispose(buf);
 270         SetConsoleMode(input, ENABLE_PROCESSED_INPUT or ENABLE_LINE_INPUT or ENABLE_ECHO_INPUT);
 271 end;
 272
 273 procedure Sound(Hz: Word);
 274 begin
 275 end;
 276
 277 procedure TextBackground(Color: Byte);
 278 begin
 279         case Color of
 280                 0: fore_color := 0;
 281                 1: fore_color := BACKGROUND_BLUE;
 282                 2: fore_color := BACKGROUND_GREEN;
 283                 3: fore_color := BACKGROUND_BLUE or BACKGROUND_GREEN;
 284                 4: fore_color := BACKGROUND_RED;
 285                 5: fore_color := BACKGROUND_RED or BACKGROUND_BLUE;
 286                 6: fore_color := BACKGROUND_RED or BACKGROUND_GREEN;
 287                 7: fore_color := BACKGROUND_RED or BACKGROUND_BLUE or BACKGROUND_GREEN;
 288                 8: fore_color := BACKGROUND_INTENSITY;
 289                 9: fore_color := BACKGROUND_INTENSITY or BACKGROUND_BLUE;
 290                 10: fore_color := BACKGROUND_INTENSITY or BACKGROUND_GREEN;
 291                 11: fore_color := BACKGROUND_INTENSITY or BACKGROUND_BLUE or BACKGROUND_GREEN;
 292                 12: fore_color := BACKGROUND_INTENSITY or BACKGROUND_RED;
 293                 13: fore_color := BACKGROUND_INTENSITY or BACKGROUND_RED or BACKGROUND_BLUE;
 294                 14: fore_color := BACKGROUND_INTENSITY or BACKGROUND_RED or BACKGROUND_GREEN;
 295                 15: fore_color := BACKGROUND_INTENSITY or BACKGROUND_RED or BACKGROUND_BLUE or BACKGROUND_GREEN;
 296                 else exit;
 297         end;
 298
 299         SetConsoleTextAttribute(output, fore_color or back_color);
 300 end;
 301
 302 procedure TextColor(Color: Byte);
 303 begin
 304         case Color of
 305                 0: back_color := 0;
 306                 1: back_color := FOREGROUND_BLUE;
 307                 2: back_color := FOREGROUND_GREEN;
 308                 3: back_color := FOREGROUND_BLUE or FOREGROUND_GREEN;
 309                 4: back_color := FOREGROUND_RED;
 310                 5: back_color := FOREGROUND_RED or FOREGROUND_BLUE;
 311                 6: back_color := FOREGROUND_RED or FOREGROUND_GREEN;
 312                 7: back_color := FOREGROUND_RED or FOREGROUND_BLUE or FOREGROUND_GREEN;
 313                 8: back_color := FOREGROUND_INTENSITY;
 314                 9: back_color := FOREGROUND_INTENSITY or FOREGROUND_BLUE;
 315                 10: back_color := FOREGROUND_INTENSITY or FOREGROUND_GREEN;
 316                 11: back_color := FOREGROUND_INTENSITY or FOREGROUND_BLUE or FOREGROUND_GREEN;
 317                 12: back_color := FOREGROUND_INTENSITY or FOREGROUND_RED;
 318                 13: back_color := FOREGROUND_INTENSITY or FOREGROUND_RED or FOREGROUND_BLUE;
 319                 14: back_color := FOREGROUND_INTENSITY or FOREGROUND_RED or FOREGROUND_GREEN;
 320                 15: back_color := FOREGROUND_INTENSITY or FOREGROUND_RED or FOREGROUND_BLUE or FOREGROUND_GREEN;
 321                 else exit;
 322         end;
 323
 324         SetConsoleTextAttribute(output, fore_color or back_color);
 325 end;
 326
 327 procedure TextMode(Mode: WORD);
 328 begin
 329 end;
 330
 331 function WhereX: tcrtcoord;
 332 var
 333         info: TConsoleScreenBufferinfo;
 334 begin
 335         GetConsoleScreenBufferInfo(output, info);
 336         WhereX := info.dwCursorPosition.X - wx + 1;
 337 end;
 338
 339 function WhereY: tcrtcoord;
 340 var
 341         info: TConsoleScreenBufferinfo;
 342 begin
 343         GetConsoleScreenBufferInfo(output, info);
 344         WhereY := info.dwCursorPosition.Y - wy + 1;
 345 end;
 346
 347 procedure Window(X1: Byte; Y1: Byte; X2: Byte; Y2: Byte);
 348 begin
 349         wx := X1 - 1;
 350         wy := Y1 - 1;
 351         GotoXY(1, 1);
 352 end;
 353
 354 procedure init;
 355 var
 356         xy: Coord;
 357         r: SMALL_RECT;
 358 begin
 359         output := GetStdHandle(STD_OUTPUT_HANDLE);
 360         input := GetStdHandle(STD_INPUT_HANDLE);
 361         SetConsoleMode(output, ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT);
 362         SetConsoleMode(input, ENABLE_PROCESSED_INPUT or ENABLE_LINE_INPUT or ENABLE_ECHO_INPUT);
 363
 364         xy.x := WIDTH;
 365         xy.y := HEIGHT;
 366         SetConsoleScreenBufferSize(output, xy);
 367
 368         r.Top := 0;
 369         r.Left := 0;
 370         r.Right := WIDTH - 1;
 371         r.Bottom := HEIGHT - 1;
 372         SetConsoleWindowInfo(output, true, r);
 373
 374         back_color := 0;
 375         fore_color := 0;
 376         TextBackground(0);
 377         TextColor(7);
 378
 379         last_key := #0;
 380 end;
 381
 382 initialization
 383         init;
 384
 385 finalization
 386         TextBackground(0);
 387         TextColor(7);
 388 end.
 389
 390 {$endif}
 391
 392 {
 393         Copyright 2019 maruhiro
 394         All rights reserved.
 395
 396         Redistribution and use in source and binary forms,
 397         with or without modification, are permitted provided that
 398         the following conditions are met:
 399
 400          1. Redistributions of source code must retain the above copyright notice,
 401             this list of conditions and the following disclaimer.
 402
 403          2. Redistributions in binary form must reproduce the above copyright notice,
 404             this list of conditions and the following disclaimer in the documentation
 405             and/or other materials provided with the distribution.
 406
 407         THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
 408         INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
 409         FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
 410         THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 411         SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 412         PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
 413         OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 414         WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 415         OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
 416         ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 417 }