crt.pas.win32

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