development/compilers/freepascal/rtl/aros/crt.pp

   1 {
   2     $Id$
   3     This file is part of the Free Pascal run time library.
   4     Copyright (c) 1999-2000 by Nils Sjoholm and Carl Eric Codere
   5
   6     See the file COPYING.FPC, included in this distribution,
   7     for details about the copyright.
   8
   9     This program is distributed in the hope that it will be useful,
  10     but WITHOUT ANY WARRANTY; without even the implied warranty of
  11     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12
  13  **********************************************************************}
  14
  15
  16 unit Crt;
  17
  18 {--------------------------------------------------------------------}
  19 { LEFT TO DO:                                                        }
  20 {--------------------------------------------------------------------}
  21 { o Write special characters are not recognized                      }
  22 { o Write does not take care of window coordinates yet.              }
  23 { o Read does not recognize the special editing characters           }
  24 { o Read does not take care of window coordinates yet.               }
  25 { o Readkey extended scancode is not correct yet                     }
  26 { o Color mapping only works for 4 colours                           }
  27 { o ClrScr, DeleteLine, InsLine do not work with window coordinates  }
  28 {--------------------------------------------------------------------}
  29
  30
  31
  32 Interface
  33
  34 Const
  35 { Controlling consts }
  36   Flushing=false;                       {if true then don't buffer output}
  37   ScreenWidth  = 80;
  38   ScreenHeight = 25;
  39
  40 { CRT modes }
  41   BW40          = 0;            { 40x25 B/W on Color Adapter }
  42   CO40          = 1;            { 40x25 Color on Color Adapter }
  43   BW80          = 2;            { 80x25 B/W on Color Adapter }
  44   CO80          = 3;            { 80x25 Color on Color Adapter }
  45   Mono          = 7;            { 80x25 on Monochrome Adapter }
  46   Font8x8       = 256;          { Add-in for ROM font }
  47
  48 { Mode constants for 3.0 compatibility }
  49   C40           = CO40;
  50   C80           = CO80;
  51
  52 {
  53   When using this color constants on the Amiga
  54   you can bet that they don't work as expected.
  55   You never know what color the user has on
  56   his Amiga. Perhaps we should do a check of
  57   the number of bitplanes (for number of colors)
  58
  59   The normal 4 first pens for an Amiga are
  60
  61   0 LightGrey
  62   1 Black
  63   2 White
  64   3 Blue
  65
  66 }
  67
  68 { Foreground and background color constants  }
  69   Black         = 1;  { normal pen for amiga }
  70   Blue          = 3;  { windowborder color   }
  71   Green         = 15;
  72   Cyan          = 7;
  73   Red           = 4;
  74   Magenta       = 5;
  75   Brown         = 6;
  76   LightGray     = 0;  { canvas color         }
  77
  78 { Foreground color constants }
  79   DarkGray      = 8;
  80   LightBlue     = 9;
  81   LightGreen    = 10;
  82   LightCyan     = 11;
  83   LightRed      = 12;
  84   LightMagenta  = 13;
  85   Yellow        = 14;
  86   White         = 2;  { third color on amiga }
  87
  88 { Add-in for blinking }
  89   Blink         = 128;
  90
  91 {Other Defaults}
  92   LastMode   : Word = 3;
  93   WindMin    : Word = $0;
  94   WindMax    : Word = $184f;
  95 { These don't change anything if they are modified }
  96   CheckSnow  : Boolean = FALSE;
  97   DirectVideo: Boolean = FALSE;
  98 var
  99   TextAttr : BYTE;
 100   { CheckBreak have to make this one to a function for Amiga }
 101   CheckEOF : Boolean;
 102
 103 Procedure AssignCrt(Var F: Text);
 104 Function  KeyPressed: Boolean;
 105 Function  ReadKey: Char;
 106 Procedure TextMode(Mode: Integer);
 107 Procedure Window(X1, Y1, X2, Y2: BYTE);
 108 Procedure GoToXy(X: byte; Y: byte);
 109 Function  WhereX: Byte;
 110 Function  WhereY: Byte;
 111 Procedure ClrScr;
 112 Procedure ClrEol;
 113 Procedure InsLine;
 114 Procedure DelLine;
 115 Procedure TextColor(Color: Byte);
 116 Procedure TextBackground(Color: Byte);
 117 Procedure LowVideo;
 118 Procedure HighVideo;
 119 Procedure NormVideo;
 120 Procedure Delay(DTime: Word);
 121 Procedure Sound(Hz: Word);
 122 Procedure NoSound;
 123
 124 { Extra functions }
 125
 126 Procedure CursorOn;
 127 Procedure CursorOff;
 128 Function CheckBreak: Boolean;
 129
 130 Implementation
 131
 132 {
 133   The definitions of TextRec and FileRec are in separate files.
 134 }
 135 {$i textrec.inc}
 136 {$i filerec.inc}
 137
 138 var
 139   maxcols,maxrows : longint;
 140
 141 CONST
 142   { This is used to make sure that readkey returns immediately }
 143   { if keypressed was used beforehand.                         }
 144   KeyPress : char = #0;
 145   _LVODisplayBeep = -96;
 146
 147
 148 Type
 149
 150     pInfoData = ^tInfoData;
 151     tInfoData = packed record
 152         id_NumSoftErrors        : Longint;      { number of soft errors on disk }
 153         id_UnitNumber           : Longint;      { Which unit disk is (was) mounted on }
 154         id_DiskState            : Longint;      { See defines below }
 155         id_NumBlocks            : Longint;      { Number of blocks on disk }
 156         id_NumBlocksUsed        : Longint;      { Number of block in use }
 157         id_BytesPerBlock        : Longint;
 158         id_DiskType             : Longint;      { Disk Type code }
 159         id_VolumeNode           : Longint;         { BCPL pointer to volume node }
 160         id_InUse                : Longint;      { Flag, zero if not in use }
 161     end;
 162
 163 { *  List Node Structure.  Each member in a list starts with a Node * }
 164
 165   pNode = ^tNode;
 166   tNode = packed Record
 167     ln_Succ,                { * Pointer to next (successor) * }
 168     ln_Pred  : pNode;       { * Pointer to previous (predecessor) * }
 169     ln_Type  : Byte;
 170     ln_Pri   : Shortint;    { * Priority, for sorting * }
 171     ln_Name  : PChar;       { * ID string, null terminated * }
 172   End;  { * Note: Integer aligned * }
 173
 174 { normal, full featured list }
 175
 176     pList = ^tList;
 177     tList = packed record
 178     lh_Head     : pNode;
 179     lh_Tail     : pNode;
 180     lh_TailPred : pNode;
 181     lh_Type     : Byte;
 182     l_pad       : Byte;
 183     end;
 184
 185     pMsgPort = ^tMsgPort;
 186     tMsgPort = packed record
 187     mp_Node     : tNode;
 188     mp_Flags    : Byte;
 189     mp_SigBit   : Byte;      { signal bit number    }
 190     mp_SigTask  : Pointer;   { task to be signalled (TaskPtr) }
 191     mp_MsgList  : tList;     { message linked list  }
 192     end;
 193
 194     pMessage = ^tMessage;
 195     tMessage = packed record
 196     mn_Node       : tNode;
 197     mn_ReplyPort  : pMsgPort;   { message reply port }
 198     mn_Length     : Word;       { message len in bytes }
 199     end;
 200
 201     pIOStdReq = ^tIOStdReq;
 202     tIOStdReq = packed record
 203     io_Message  : tMessage;
 204     io_Device   : Pointer;      { device node pointer  }
 205     io_Unit     : Pointer;      { unit (driver private)}
 206     io_Command  : Word;         { device command }
 207     io_Flags    : Byte;
 208     io_Error    : Shortint;     { error or warning num }
 209     io_Actual   : Longint;      { actual number of bytes transferred }
 210     io_Length   : Longint;      { requested number bytes transferred}
 211     io_Data     : Pointer;      { points to data area }
 212     io_Offset   : Longint;      { offset for block structured devices }
 213     end;
 214
 215     pIntuiMessage = ^tIntuiMessage;
 216     tIntuiMessage = packed record
 217         ExecMessage     : tMessage;
 218         IClass          : Longint;
 219         Code            : Word;
 220         Qualifier       : Word;
 221         IAddress        : Pointer;
 222         MouseX,
 223         MouseY          : Word;
 224         Seconds,
 225         Micros          : Longint;
 226         IDCMPWindow     : Pointer;
 227         SpecialLink     : pIntuiMessage;
 228     end;
 229
 230     pWindow = ^tWindow;
 231     tWindow = packed record
 232         NextWindow      : pWindow;      { for the linked list in a screen }
 233         LeftEdge,
 234         TopEdge         : Integer;      { screen dimensions of window }
 235         Width,
 236         Height          : Integer;      { screen dimensions of window }
 237         MouseY,
 238         MouseX          : Integer;      { relative to upper-left of window }
 239         MinWidth,
 240         MinHeight       : Integer;      { minimum sizes }
 241         MaxWidth,
 242         MaxHeight       : Word;         { maximum sizes }
 243         Flags           : Longint;      { see below for defines }
 244         MenuStrip       : Pointer;      { the strip of Menu headers }
 245         Title           : PChar;        { the title text for this window }
 246         FirstRequest    : Pointer;      { all active Requesters }
 247         DMRequest       : Pointer;      { double-click Requester }
 248         ReqCount        : Integer;      { count of reqs blocking Window }
 249         WScreen         : Pointer;      { this Window's Screen }
 250         RPort           : Pointer;      { this Window's very own RastPort }
 251         BorderLeft,
 252         BorderTop,
 253         BorderRight,
 254         BorderBottom    : Shortint;
 255         BorderRPort     : Pointer;
 256         FirstGadget     : Pointer;
 257         Parent,
 258         Descendant      : pWindow;
 259         Pointer_        : Pointer;      { sprite data }
 260         PtrHeight       : Shortint;     { sprite height (not including sprite padding) }
 261         PtrWidth        : Shortint;     { sprite width (must be less than or equal to 16) }
 262         XOffset,
 263         YOffset         : Shortint;     { sprite offsets }
 264         IDCMPFlags      : Longint;      { User-selected flags }
 265         UserPort,
 266         WindowPort      : pMsgPort;
 267         MessageKey      : pIntuiMessage;
 268         DetailPen,
 269         BlockPen        : Byte;         { for bar/border/gadget rendering }
 270         CheckMark       : Pointer;
 271         ScreenTitle     : PChar;        { if non-null, Screen title when Window is active }
 272         GZZMouseX       : Integer;
 273         GZZMouseY       : Integer;
 274         GZZWidth        : Integer;
 275         GZZHeight       : Word;
 276         ExtData         : Pointer;
 277         UserData        : Pointer;      { general-purpose pointer to User data extension }
 278         WLayer          : Pointer;
 279         IFont           : Pointer;
 280         MoreFlags       : Longint;
 281     end;
 282
 283     const
 284
 285     M_LNM               = 20;           { linefeed newline mode }
 286     PMB_ASM     = M_LNM + 1;    { internal storage bit for AS flag }
 287     PMB_AWM     = PMB_ASM + 1;  { internal storage bit for AW flag }
 288     MAXTABS     = 80;
 289     IECLASS_MAX = $15;
 290
 291 type
 292
 293     pKeyMap = ^tKeyMap;
 294     tKeyMap = packed record
 295         km_LoKeyMapTypes        : Pointer;
 296         km_LoKeyMap             : Pointer;
 297         km_LoCapsable           : Pointer;
 298         km_LoRepeatable         : Pointer;
 299         km_HiKeyMapTypes        : Pointer;
 300         km_HiKeyMap             : Pointer;
 301         km_HiCapsable           : Pointer;
 302         km_HiRepeatable         : Pointer;
 303     end;
 304
 305
 306
 307     pConUnit = ^tConUnit;
 308     tConUnit = packed record
 309         cu_MP   : tMsgPort;
 310         { ---- read only variables }
 311         cu_Window       : Pointer;      { (WindowPtr) intuition window bound to this unit }
 312         cu_XCP          : Integer;        { character position }
 313         cu_YCP          : Integer;
 314         cu_XMax         : Integer;        { max character position }
 315         cu_YMax         : Integer;
 316         cu_XRSize       : Integer;        { character raster size }
 317         cu_YRSize       : Integer;
 318         cu_XROrigin     : Integer;        { raster origin }
 319         cu_YROrigin     : Integer;
 320         cu_XRExtant     : Integer;        { raster maxima }
 321         cu_YRExtant     : Integer;
 322         cu_XMinShrink   : Integer;        { smallest area intact from resize process }
 323         cu_YMinShrink   : Integer;
 324         cu_XCCP         : Integer;        { cursor position }
 325         cu_YCCP         : Integer;
 326
 327    { ---- read/write variables (writes must must be protected) }
 328    { ---- storage for AskKeyMap and SetKeyMap }
 329
 330         cu_KeyMapStruct : tKeyMap;
 331
 332    { ---- tab stops }
 333
 334         cu_TabStops     : Array [0..MAXTABS-1] of Word;
 335                                 { 0 at start, -1 at end of list }
 336
 337    { ---- console rastport attributes }
 338
 339         cu_Mask         : Shortint;
 340         cu_FgPen        : Shortint;
 341         cu_BgPen        : Shortint;
 342         cu_AOLPen       : Shortint;
 343         cu_DrawMode     : Shortint;
 344         cu_AreaPtSz     : Shortint;
 345         cu_AreaPtrn     : Pointer;      { cursor area pattern }
 346         cu_Minterms     : Array [0..7] of Byte; { console minterms }
 347         cu_Font         : Pointer;      { (TextFontPtr) }
 348         cu_AlgoStyle    : Byte;
 349         cu_TxFlags      : Byte;
 350         cu_TxHeight     : Word;
 351         cu_TxWidth      : Word;
 352         cu_TxBaseline   : Word;
 353         cu_TxSpacing    : Word;
 354
 355    { ---- console MODES and RAW EVENTS switches }
 356
 357         cu_Modes        : Array [0..(PMB_AWM+7) div 8 - 1] of Byte;
 358                                 { one bit per mode }
 359         cu_RawEvents    : Array [0..(IECLASS_MAX+7) div 8 - 1] of Byte;
 360     end;
 361
 362 const
 363
 364
 365    CD_CURRX =  1;
 366    CD_CURRY =  2;
 367    CD_MAXX  =  3;
 368    CD_MAXY  =  4;
 369
 370    CSI      = chr($9b);
 371
 372    SIGBREAKF_CTRL_C = 4096;
 373
 374 function AllocVec( size, reqm : Longint ): Pointer;
 375 begin
 376    asm
 377        MOVE.L  A6,-(A7)
 378        MOVE.L  size,d0
 379        MOVE.L  reqm,d1
 380        MOVE.L  _ExecBase, A6
 381        JSR -684(A6)
 382        MOVE.L  (A7)+,A6
 383        MOVE.L  d0,@RESULT
 384    end;
 385 end;
 386
 387
 388 function DoPkt(ID : pMsgPort;
 389                Action, Param1, Param2,
 390                Param3, Param4, Param5 : Longint) : Longint;
 391 begin
 392    asm
 393        MOVEM.L d2/d3/d4/d5/d6/d7/a6,-(A7)
 394        MOVE.L  ID,d1
 395        MOVE.L  Action,d2
 396        MOVE.L  Param1,d3
 397        MOVE.L  Param2,d4
 398        MOVE.L  Param3,d5
 399        MOVE.L  Param4,d6
 400        MOVE.L  Param5,d7
 401        MOVE.L  _DOSBase,A6
 402        JSR -240(A6)
 403        MOVEM.L (A7)+,d2/d3/d4/d5/d6/d7/a6
 404        MOVE.L  d0,@RESULT
 405    end;
 406 end;
 407
 408 procedure FreeVec( memory : Pointer );
 409 begin
 410    asm
 411        MOVE.L  A6,-(A7)
 412        MOVE.L  memory,a1
 413        MOVE.L  _ExecBase,A6
 414        JSR -690(A6)
 415        MOVE.L  (A7)+,A6
 416    end;
 417 end;
 418
 419
 420 function GetConsoleTask : pMsgPort;
 421 begin
 422    asm
 423        MOVE.L  A6,-(A7)
 424        MOVE.L  _DOSBase,A6
 425        JSR -510(A6)
 426        MOVE.L  (A7)+,A6
 427        MOVE.L  d0,@RESULT
 428    end;
 429 end;
 430
 431
 432 function GetMsg(port : pMsgPort): pMessage;
 433 begin
 434    asm
 435        MOVE.L  A6,-(A7)
 436        MOVE.L  port,a0
 437        MOVE.L  _ExecBase,A6
 438        JSR -372(A6)
 439        MOVE.L  (A7)+,A6
 440        MOVE.L  d0,@RESULT
 441    end;
 442 end;
 443
 444 function ModifyIDCMP(window : pWindow;
 445                      IDCMPFlags : Longint) : Boolean;
 446 begin
 447    asm
 448        MOVE.L  A6,-(A7)
 449        MOVE.L  window,a0
 450        MOVE.L  IDCMPFlags,d0
 451        MOVE.L  _IntuitionBase,A6
 452        JSR -150(A6)
 453        MOVE.L  (A7)+,A6
 454        TST.L   d0
 455        bne     @success
 456        bra     @end
 457    @success:
 458        move.b  #1,d0
 459    @end:
 460        move.b  d0,@RESULT
 461    end;
 462 end;
 463
 464 procedure ReplyMsg(mess : pMessage);
 465 begin
 466    asm
 467        MOVE.L  A6,-(A7)
 468        MOVE.L  mess,a1
 469        MOVE.L  _ExecBase,A6
 470        JSR -378(A6)
 471        MOVE.L  (A7)+,A6
 472    end;
 473 end;
 474
 475
 476 function WaitPort(port : pMsgPort): pMessage;
 477 begin
 478    asm
 479        MOVE.L  A6,-(A7)
 480        MOVE.L  port,a0
 481        MOVE.L  _ExecBase,A6
 482        JSR -384(A6)
 483        MOVE.L  (A7)+,A6
 484        MOVE.L  d0,@RESULT
 485    end;
 486 end;
 487
 488 procedure Delay_(ticks : Longint);
 489 begin
 490    asm
 491        MOVE.L  A6,-(A7)
 492        MOVE.L  ticks,d1
 493        MOVE.L  _DOSBase,A6
 494        JSR -198(A6)
 495        MOVE.L  (A7)+,A6
 496    end;
 497 end;
 498
 499 function SetSignal(newSignals, signalMask : Longint) : Longint;
 500 begin
 501    asm
 502        MOVE.L  A6,-(A7)
 503        MOVE.L  newSignals,d0
 504        MOVE.L  signalMask,d1
 505        MOVE.L  _ExecBase,A6
 506        JSR -306(A6)
 507        MOVE.L  (A7)+,A6
 508        MOVE.L  d0,@RESULT
 509    end;
 510 end;
 511
 512 function OpenInfo : pInfoData;
 513 var
 514    port     :  pMsgPort;
 515    info     :  pInfoData;
 516    bptr, d4, d5, d6, d7 :  Longint;
 517 begin
 518    info  := pInfoData(AllocVec(SizeOf(tInfoData), 1));
 519
 520    if info <> nil then begin
 521       port  := GetConsoleTask;
 522       bptr  := Longint(info) shr 2;
 523
 524       if port <> nil then begin
 525          if DoPkt(port, $19, bptr, d4, d5, d6, d7) <> 0 then info := pInfoData(bptr shl 2)
 526          else port := nil;
 527       end;
 528
 529       if port = nil then begin
 530          FreeVec(info);
 531          info := nil;
 532       end;
 533    end;
 534
 535    OpenInfo := info;
 536 end;
 537
 538 procedure CloseInfo(var info : pInfoData);
 539 begin
 540    if info <> nil then begin
 541       FreeVec(info);
 542       info := nil;
 543    end;
 544 end;
 545
 546 function ConData(modus : byte) : integer;
 547 var
 548    info  :  pInfoData;
 549    theunit  :  pConUnit;
 550    pos   :  Longint;
 551 begin
 552    pos   := 1;
 553    info  := OpenInfo;
 554
 555    if info <> nil then begin
 556       theunit  := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit);
 557
 558       case modus of
 559          CD_CURRX :  pos   := theunit^.cu_XCP;
 560          CD_CURRY :  pos   := theunit^.cu_YCP;
 561          CD_MAXX  :  pos   := theunit^.cu_XMax;
 562          CD_MAXY  :  pos   := theunit^.cu_YMax;
 563       end;
 564
 565       CloseInfo(info);
 566    end;
 567
 568    ConData := pos + 1;
 569 end;
 570
 571 function WhereX : Byte;
 572 begin
 573    WhereX := Byte(ConData(CD_CURRX))-lo(windmin);
 574 end;
 575
 576 function realx: byte;
 577 begin
 578    RealX := Byte(ConData(CD_CURRX));
 579 end;
 580
 581 function realy: byte;
 582 begin
 583  RealY := Byte(ConData(CD_CURRY));
 584 end;
 585
 586 function WhereY : Byte;
 587 begin
 588    WhereY := Byte(ConData(CD_CURRY))-hi(windmin);
 589 end;
 590
 591 function screencols : integer;
 592 begin
 593    screencols := ConData(CD_MAXX);
 594 end;
 595
 596 function screenrows : integer;
 597 begin
 598    screenrows := ConData(CD_MAXY);
 599 end;
 600
 601
 602  procedure Realgotoxy(x,y : integer);
 603  begin
 604        Write(CSI, y, ';', x, 'H');
 605  end;
 606
 607
 608  procedure gotoxy(x,y : byte);
 609  begin
 610         if (x<1) then
 611           x:=1;
 612         if (y<1) then
 613           y:=1;
 614         if y+hi(windmin)-2>=hi(windmax) then
 615           y:=hi(windmax)-hi(windmin)+1;
 616         if x+lo(windmin)-2>=lo(windmax) then
 617           x:=lo(windmax)-lo(windmin)+1;
 618         Write(CSI, y+hi(windmin), ';', x+lo(windmin), 'H');
 619  end;
 620
 621
 622 procedure CursorOff;
 623 begin
 624    Write(CSI,'0 p');
 625 end;
 626
 627 procedure CursorOn;
 628 begin
 629    Write(CSI,'1 p');
 630 end;
 631
 632 procedure ClrScr;
 633 begin
 634    Write(Chr($0c));
 635 end;
 636
 637 function ReadKey : char;
 638 const
 639    IDCMP_VANILLAKEY = $00200000;
 640    IDCMP_RAWKEY     = $00000400;
 641 var
 642    info  :  pInfoData;
 643    win   :  pWindow;
 644    imsg  :  pIntuiMessage;
 645    msg   :  pMessage;
 646    key   :  char;
 647    idcmp, vanil   :  Longint;
 648 begin
 649    key   := #0;
 650    if KeyPress <> #0 then
 651     Begin
 652       ReadKey:=KeyPress;
 653       KeyPress:=#0;
 654       exit;
 655     end;
 656    info  := OpenInfo;
 657
 658    if info <> nil then begin
 659       win   := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window);
 660       idcmp := win^.IDCMPFlags;
 661       vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY;
 662
 663       ModifyIDCMP(win, (idcmp or vanil));
 664
 665       repeat
 666          msg   := WaitPort(win^.UserPort);
 667          imsg  := pIntuiMessage(GetMsg(win^.UserPort));
 668
 669          if (imsg^.IClass = IDCMP_VANILLAKEY) then
 670               key := char(imsg^.Code)
 671          else
 672          if (imsg^.IClass = IDCMP_RAWKEY) then
 673               key := char(imsg^.Code);
 674
 675          ReplyMsg(pMessage(imsg));
 676       until key <> #0;
 677
 678       repeat
 679          msg   := GetMsg(win^.UserPort);
 680
 681          if msg <> nil then ReplyMsg(msg);
 682       until msg = nil;
 683
 684       ModifyIDCMP(win, idcmp);
 685
 686       CloseInfo(info);
 687    end;
 688
 689    ReadKey := key;
 690 end;
 691
 692 function KeyPressed : Boolean;
 693 const
 694    IDCMP_VANILLAKEY = $00200000;
 695    IDCMP_RAWKEY     = $00000400;
 696 var
 697    info  :  pInfoData;
 698    win   :  pWindow;
 699    imsg  :  pIntuiMessage;
 700    msg   :  pMessage;
 701    idcmp, vanil   :  Longint;
 702    ispressed : Boolean;
 703 begin
 704    KeyPress := #0;
 705    ispressed := False;
 706    info  := OpenInfo;
 707
 708    if info <> nil then begin
 709       win   := pWindow(pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_Window);
 710       idcmp := win^.IDCMPFlags;
 711       vanil := IDCMP_VANILLAKEY or IDCMP_RAWKEY;
 712
 713       ModifyIDCMP(win, (idcmp or vanil));
 714
 715       msg   := WaitPort(win^.UserPort);
 716       imsg  := pIntuiMessage(GetMsg(win^.UserPort));
 717
 718       if (imsg^.IClass = IDCMP_VANILLAKEY) or (imsg^.IClass = IDCMP_RAWKEY) then
 719       Begin
 720         ispressed := true;
 721         KeyPress := char(imsg^.Code)
 722       end;
 723
 724       ReplyMsg(pMessage(imsg));
 725
 726       repeat
 727          msg   := GetMsg(win^.UserPort);
 728
 729          if msg <> nil then ReplyMsg(msg);
 730       until msg = nil;
 731
 732       ModifyIDCMP(win, idcmp);
 733
 734       CloseInfo(info);
 735    end;
 736
 737    KeyPressed := ispressed;
 738 end;
 739
 740 procedure TextColor(color : byte);
 741 begin
 742    TextAttr := (TextAttr and $70) or color;
 743    Write(CSI, '3', color, 'm');
 744 end;
 745
 746 procedure TextBackground(color : byte);
 747 begin
 748    Textattr:=(textattr and $8f) or ((color and $7) shl 4);
 749    Write(CSI, '4', color, 'm');
 750 end;
 751
 752 procedure Window(X1,Y1,X2,Y2: Byte);
 753  begin
 754    if (x1<1) or (x2>screencols) or (y2>screenrows) or
 755      (x1>x2) or (y1>y2) then
 756        exit;
 757    windmin:=(x1-1) or ((y1-1) shl 8);
 758    windmax:=(x2-1) or ((y2-1) shl 8);
 759    gotoxy(1,1);
 760  end;
 761
 762
 763
 764
 765
 766 procedure DelLine;
 767 begin
 768    Write(CSI,'X');
 769 end;
 770
 771 procedure ClrEol;
 772 begin
 773    Write(CSI,'K');
 774 end;
 775
 776 procedure InsLine;
 777 begin
 778    Write(CSI,'1 L');
 779 end;
 780
 781 procedure cursorbig;
 782 begin
 783 end;
 784
 785 procedure lowvideo;
 786 begin
 787 end;
 788
 789 procedure highvideo;
 790 begin
 791 end;
 792
 793 procedure nosound;
 794 begin
 795 end;
 796
 797 procedure sound(hz : word);
 798 begin
 799 end;
 800
 801 procedure delay(DTime : Word);
 802 var
 803     dummy : Longint;
 804 begin
 805     dummy := trunc((real(DTime) / 1000.0) * 50.0);
 806     Delay_(dummy);
 807 end;
 808
 809 function CheckBreak : boolean;
 810 begin
 811    if (SetSignal(0, 0) and SIGBREAKF_CTRL_C) = SIGBREAKF_CTRL_C then
 812       CheckBreak := true
 813    else
 814       CheckBreak := false;
 815 end;
 816
 817 procedure textmode(mode : integer);
 818 begin
 819        lastmode:=mode;
 820        mode:=mode and $ff;
 821        windmin:=0;
 822        windmax:=(screencols-1) or ((screenrows-1) shl 8);
 823        maxcols:=screencols;
 824        maxrows:=screenrows;
 825 end;
 826
 827 procedure normvideo;
 828 begin
 829 end;
 830
 831 function GetTextBackground : byte;
 832 var
 833    info  :  pInfoData;
 834    pen   :  byte;
 835 begin
 836    pen   := 1;
 837    info  := OpenInfo;
 838
 839    if info <> nil then begin
 840       pen   := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_BgPen;
 841
 842       CloseInfo(info);
 843    end;
 844
 845    GetTextBackground := pen;
 846 end;
 847
 848 function GetTextColor : byte;
 849 var
 850    info  :  pInfoData;
 851    pen   :  byte;
 852 begin
 853    pen   := 1;
 854    info  := OpenInfo;
 855
 856    if info <> nil then begin
 857       pen   := pConUnit((pIoStdReq(info^.id_InUse))^.io_Unit)^.cu_FgPen;
 858
 859       CloseInfo(info);
 860    end;
 861
 862    GetTextColor   := pen;
 863 end;
 864
 865
 866 {*****************************************************************************
 867                           Read and Write routines
 868 *****************************************************************************}
 869 { Problem here: Currently all these routines are not implemented because of how }
 870 { the console device works. Because w low level write is required to change the }
 871 { position of the cursor, and since the CrtWrite is assigned as the standard    }
 872 { write routine, a recursive call will occur                                    }
 873
 874 { How to fix this:                                                              }
 875 {  At startup make a copy of the Output handle, and then use this copy to make  }
 876 {  low level positioning calls. This does not seem to work yet.                 }
 877
 878
 879
 880    Function CrtWrite(var f : textrec):integer;
 881
 882       var
 883          i,col,row : longint;
 884          c : char;
 885          buf: array[0..1] of char;
 886
 887       begin
 888          col:=realx;
 889          row:=realy;
 890          inc(row);
 891          inc(col);
 892          for i:=0 to f.bufpos-1 do
 893            begin
 894               c:=f.buffer[i];
 895               case ord(c) of
 896                  10 : begin
 897                          inc(row);
 898                       end;
 899                  13 : begin
 900                          col:=lo(windmin)+1;
 901                      end;
 902                  8 : if col>lo(windmin)+1 then
 903                        begin
 904                           dec(col);
 905                        end;
 906                  7 : begin
 907                          { beep }
 908                          asm
 909                            move.l a6,d6               { save base pointer    }
 910                            move.l _IntuitionBase,a6   { set library base     }
 911                            sub.l  a0,a0
 912                            jsr    _LVODisplayBeep(a6)
 913                            move.l d6,a6               { restore base pointer }
 914                          end;
 915                       end;
 916               else
 917                  begin
 918                    buf[0]:=c;
 919                    realgotoxy(row,col);
 920                    do_write(f.handle,longint(@buf[0]),1);
 921                    inc(col);
 922                  end;
 923               end;
 924               if col>lo(windmax)+1 then
 925                 begin
 926                    col:=lo(windmin)+1;
 927                    inc(row);
 928                 end;
 929               while row>hi(windmax)+1 do
 930                 begin
 931                    delline;
 932                    dec(row);
 933                 end;
 934            end;
 935          f.bufpos:=0;
 936          realgotoxy(row-1,col-1);
 937          CrtWrite:=0;
 938       end;
 939
 940    Function CrtClose(Var F: TextRec): Integer;
 941      Begin
 942        F.Mode:=fmClosed;
 943        CrtClose:=0;
 944      End;
 945
 946    Function CrtOpen(Var F: TextRec): Integer;
 947      Begin
 948        If F.Mode = fmOutput Then
 949         CrtOpen:=0
 950        Else
 951         CrtOpen:=5;
 952      End;
 953
 954    Function CrtRead(Var F: TextRec): Integer;
 955      Begin
 956        f.bufend:=do_read(f.handle,longint(f.bufptr),f.bufsize);
 957        f.bufpos:=0;
 958        CrtRead:=0;
 959      End;
 960
 961    Function CrtInOut(Var F: TextRec): Integer;
 962      Begin
 963        Case F.Mode of
 964         fmInput: CrtInOut:=CrtRead(F);
 965         fmOutput: CrtInOut:=CrtWrite(F);
 966        End;
 967      End;
 968
 969    procedure assigncrt(var f : text);
 970      begin
 971    {     TextRec(F).Mode:=fmClosed;
 972         TextRec(F).BufSize:=SizeOf(TextBuf);
 973         TextRec(F).BufPtr:=@TextRec(F).Buffer;
 974         TextRec(F).BufPos:=0;
 975         TextRec(F).OpenFunc:=@CrtOpen;
 976         TextRec(F).InOutFunc:=@CrtInOut;
 977         TextRec(F).FlushFunc:=@CrtInOut;
 978         TextRec(F).CloseFunc:=@CrtClose;
 979         TextRec(F).Name[0]:='.';
 980         TextRec(F).Name[1]:=#0;}
 981      end;
 982
 983
 984 var
 985   old_exit : pointer;
 986
 987 procedure crt_exit;
 988 begin
 989   { Restore default colors }
 990   write(CSI,'0m');
 991   exitproc:=old_exit;
 992 end;
 993
 994
 995 Begin
 996    old_exit:=exitproc;
 997    exitproc:=@crt_exit;
 998    { load system variables to temporary variables to save time }
 999    maxcols:=screencols;
1000    maxrows:=screenrows;
1001    { Set the initial text attributes }
1002    { Text background }
1003    Textattr:=(textattr and $8f) or ((GetTextBackGround and $7) shl 4);
1004    { Text foreground }
1005    TextAttr := (TextAttr and $70) or GetTextColor;
1006    { set output window }
1007    windmax:=(maxcols-1) or (( maxrows-1) shl 8);
1008
1009
1010    { Get a copy of the standard      }
1011    { output handle, and when using   }
1012    { direct console calls, use this  }
1013    { handle instead.                 }
1014 {   assigncrt(Output);
1015    TextRec(Output).mode:=fmOutput;}
1016 end.
1017
1018
1019
1020
1021