Power-Programmierung/CD1.mdf/pascal/bp7os2/oscrt4/crt.pas

Pascal/Delphi Source File | 1994-02-21 | 35.2 KB | 1,674 lines

{$R-,I-,S-,G+}

{$C FIXED PRELOAD PERMANENT}

{$define UseAsm}
{$define NoAutoShowBuf}

{**********************************************************}
{                                                          }
{ BP4OS2: Crt Interface Unit                               }
{                                                          }
{         Portions of this file                            }
{         Copyright (C) 1988,92 Borland International      }
{         Used with permission                             }
{                                                          }
{----------------------------------------------------------}
{  Borland - Interface                                     }
{  Matthias Withopf / c't - limited Port to OS/2           }
{  Brad Harrison  - completed Borland compatability        }
{  Rohit Gupta  -  added KBD binary mode & break handler   }
{  Dan Hughes - Converted to ASM and updated TextMode      }
{**********************************************************}



{****************************************}
{                                        }
{      ***    ****   *****     *         }
{      *  *   *        *      * *        }
{      ***    ***      *      ***        }
{      *  *   *        *     *   *       }
{      ***    ****     *     *   *       }
{                                        }
{ Please report problems (and successes) }
{ on BPASCAL section 17. Prefix all      }
{ messages with BP4OS2.                  }
{                                        }
{ Internet: [e-mail]     }
{                                        }
{****************************************}

unit Crt;

{$ifndef OS2}
  !! ERROR: This unit must be compiled for OS/2 !!
{$endif}

interface

uses
  BseSub;

const

{ Crt modes }

  BW40          = 0;            { 40x25 B/W on Color Adapter }
  CO40          = 1;            { 40x25 Color on Color Adapter }
  BW80          = 2;            { 80x25 B/W on Color Adapter }
  CO80          = 3;            { 80x25 Color on Color Adapter }
  Mono          = 7;            { 80x25 on Monochrome Adapter }
  Font8x8       = 256;          { Add-in for ROM font }

{ Mode constants for 3.0 compatibility }

  C40           = CO40;
  C80           = CO80;

{ BP4OS2 specific Crt screen modes }

  smOs2         = 512;          { Text mode for OS/2 only }
  smUnSupported = 1024;         { Unsupported mode }
  smStartup     = -1;           { Initial startup mode }

{ Foreground and background color constants }

  Black         = 0;
  Blue          = 1;
  Green         = 2;
  Cyan          = 3;
  Red           = 4;
  Magenta       = 5;
  Brown         = 6;
  LightGray     = 7;

{ Foreground color constants }

  DarkGray      = 8;
  LightBlue     = 9;
  LightGreen    = 10;
  LightCyan     = 11;
  LightRed      = 12;
  LightMagenta  = 13;
  Yellow        = 14;
  White         = 15;

{ Add-in for blinking }

  Blink         = 128;

var

{ Interface variables }

  CheckBreak : Boolean;         { Enable Ctrl-Break }
  CheckEOF   : Boolean;         { Enable Ctrl-Z }
  DirectVideo: Boolean;         { Enable direct video addressing }
  CheckSnow  : Boolean;         { Enable snow filtering }
  LastMode   : Word;            { Current text mode }
  TextAttr   : Byte;            { Current text attribute }
  WindMin    : Word;            { Window upper left coordinates }
  WindMax    : Word;            { Window lower right coordinates }

{ Additional support for BP4OS2 }

  SaveInt1B  : Pointer;         { to pfnSighandler }
  CrtVioMode : tVioModeInfo;    { Current OS/2 text mode information }
  LocVioBuf  : Pointer;         { Local video buffer address }
  LVBSize    : Word;            { Local video buffer size }
  ShowBufDly : Word;            { ShowBuf delay factor }

{ Interface procedures }

procedure AssignCrt(var F: Text);
function  KeyPressed: Boolean;
function  ReadKey: Char;
procedure TextMode(Mode: Integer);
procedure Window(X1, Y1, X2, Y2: Byte);
procedure GotoXY(X, Y: Byte);
function  WhereX: Byte;
function  WhereY: Byte;
procedure ClrScr;
procedure ClrEol;
procedure InsLine;
procedure DelLine;
procedure TextColor(Color: Byte);
procedure TextBackground(Color: Byte);
procedure LowVideo;
procedure HighVideo;
procedure NormVideo;
procedure Delay(Ms: Word);
procedure Sound(Hz: Word);
procedure NoSound;

procedure ShowBuf;
procedure AutoShowBuf(On: Boolean);

implementation

uses
  OS2Def, BseDos, Dos;

type
  tCell = record
    c: Char;
    a: Byte;
  end;

const
  soundStackSize   = 8192;
  showBufStackSize = 8192;

var
  SaveExitProc: Pointer;
  StartVioMode: tVioModeInfo;
  NormAttr    : Byte;             { Startup text attribute }
  CurCrtSize  : Word;
  ExtKeyChar  : Char;
  SpaceCell   : tCell;            { cell used when SPACE+ATTRIB is needed }

{ Sound() support }

  SoundHz      : Word;
  SoundThreadID: PID;
  SoundActive  : Boolean;
  SoundStackPtr: Pointer;

  ShowBufThreadID: PID;
  ShowBufActive  : Boolean;
  ShowBufStackPtr: Pointer;


{ -----------------------------------------------------------}
{ Break handler }

procedure TriggerBreakHandler; forward;

procedure BreakHandler(A, B: Word); far;
  begin
    if CheckBreak then
      Halt(255)
    else
      TriggerBreakHandler;
  end;

procedure TriggerBreakHandler;
  var
    PrevAction: Word;
  begin
    DosSetSigHandler(BreakHandler, pfnSigHandler(SaveInt1B), PrevAction,
                     siga_Accept, sig_CtrlBreak);
  end;


{ -----------------------------------------------------------}
{ Get Crt Mode }

function GetCrtMode: Integer; near;
  var
    Mode: Integer;
  begin
    VioGetMode(CrtVioMode, 0);
    if (CrtVioMode.fbType and 2) = 0 then
      begin
        if CrtVioMode.fbType = 0 then
          Mode := Mono
        else
          begin
            if CrtVioMode.col = 40 then
              Mode := CO40
            else if CrtVioMode.col = 80 then
              Mode := CO80
            else
              Mode := smOs2 + CO80;
            if CrtVioMode.fbType = 5 then
              Dec(Mode);
            if CrtVioMode.row > 25 then
              Mode := Mode + Font8x8
          end;
      end
    else
      Mode := smUnSupported;
    GetCrtMode := Mode;
  end;


{ -----------------------------------------------------------}
{ Get Crt Mode }

procedure SetCrtMode(Mode: Integer); near;
  begin
    if Mode = smStartup then
      VioSetMode(StartVioMode, 0)
    else if (Mode and smOs2) <> 0 then
      VioSetMode(CrtVioMode, 0)
    else if (Mode < smUnSupported) then
      begin
        VioGetMode(CrtVioMode, 0);
        case Lo(Mode) of
          0:
            begin
              CrtVioMode.fbType := 5;
              CrtVioMode.color  := 4;
              CrtVioMode.col    := 40;
              CrtVioMode.row    := 25;
              CrtVioMode.hres   := 360;
              CrtVioMode.vres   := 400;
            end;
          1:
            begin
              CrtVioMode.fbType := 1;
              CrtVioMode.color  := 4;
              CrtVioMode.col    := 40;
              CrtVioMode.row    := 25;
              CrtVioMode.hres   := 360;
              CrtVioMode.vres   := 400;
            end;
          2:
            begin
              CrtVioMode.fbType := 5;
              CrtVioMode.color  := 4;
              CrtVioMode.col    := 80;
              CrtVioMode.row    := 25;
              CrtVioMode.hres   := 720;
              CrtVioMode.vres   := 400;
            end;
          3:
            begin
              CrtVioMode.fbType := 1;
              CrtVioMode.color  := 4;
              CrtVioMode.col    := 80;
              CrtVioMode.row    := 25;
              CrtVioMode.hres   := 720;
              CrtVioMode.vres   := 400;
            end;
          7:
            begin
              CrtVioMode.fbType := 0;
              CrtVioMode.color  := 0;
              CrtVioMode.col    := 80;
              CrtVioMode.row    := 25;
              CrtVioMode.hres   := 720;
              CrtVioMode.vres   := 400;
            end;
        end;
        if (Mode and Font8x8) <> 0 then
          begin
            CrtVioMode.row  := 50;
            CrtVioMode.vres := 400;
          end
        else
          begin
            CrtVioMode.row  := 25;
            CrtVioMode.vres := 400;
          end;
        VioSetMode(CrtVioMode, 0)
      end;
  end;


{ -----------------------------------------------------------}
{ Fix CRT mode }

function FixCrtMode(Mode: Integer): Integer; near;
  var
    FixMode: Integer;
  begin
    FixMode := Mode;
    if (CrtVioMode.fbType and 2) <> 0  then
      FixMode := CO80
    else if (Mode and smOs2) = 0 then
      begin
        if Not(Lo(Mode) in [BW40,CO40,BW80,CO80,Mono]) then
          FixMode := CO80;
      end;
    FixCrtMode := FixMode;
  end;


{ -----------------------------------------------------------}
{ Setup CRT variables according to selected mode }

procedure CrtSetup; near;
  begin
    LastMode    := GetCrtMode;
    CheckSnow   := True;
    DirectVideo := True;
    WindMin     := 0;
    CurCrtSize  := ((CrtVioMode.row - 1) shl 8) + (CrtVioMode.col - 1);
    WindMax     := CurCrtSize;
    VioGetBuf(LocVioBuf, LVBSize, 0);
  end;


{ -----------------------------------------------------------}
{ Return true if key is available }

{$ifndef UseAsm}

function KeyPressed: Boolean;
  var
    KeyInfo : tKbdKeyInfo;
  begin
    if ExtKeyChar <> #0 then
      KeyPressed := True
    else
      begin
        KbdPeek(KeyInfo, 0);
        if (KeyInfo.fbStatus and $40) <> 0 then
          KeyPressed := True
        else
          begin
            KeyPressed := False;
          end
      end;
  end;

{$else}

function KeyPressed: Boolean; assembler;
  var
    KeyInfo: tKbdKeyInfo;
  asm
    CMP   ExtKeyChar,0
    JNE   @@1
    PUSH  DI
    LEA   DI,KeyInfo
    PUSH  DS
    PUSH  DI
    PUSH  0000H
    CALL  KbdPeek
    MOV   AL,tKbdKeyInfo(DS:[DI]).fbStatus
    AND   AL,40H
    POP   DI
    JZ    @@2
@@1:
    MOV   AL,1
@@2:
  end;

{$endif}


{ -----------------------------------------------------------}
{ Read character from keyboard }

{$ifndef UseAsm}

function ReadKey: Char;
  var
    KeyInfo: tKbdKeyInfo;
  begin
    if ExtKeyChar <> #0 then
      begin
        ReadKey    := ExtKeyChar;
        ExtKeyChar := #0
      end
    else
      begin
        KbdCharIn(KeyInfo, 0, 0);
        if ((KeyInfo.chChar=$00) or (KeyInfo.chChar=$E0)) and
            ((KeyInfo.fbStatus and $02) <> 0) then
          begin
            ExtKeyChar := Char(KeyInfo.chScan);
            ReadKey    := #0;
          end
        else
          ReadKey := Char(KeyInfo.chChar);
      end;
  end;

{$else}

function ReadKey: Char; assembler;
  var
    KeyInfo: tKbdKeyInfo;
  asm
    PUSH  DI
    MOV   AL,ExtKeyChar
    MOV   ExtKeyChar,0
    OR    AL,AL
    JNZ   @@2
    LEA   DI,KeyInfo
    PUSH  DS
    PUSH  DI
    PUSH  0000H
    PUSH  0000H
    CALL  KbdCharIn
    MOV   AL,tKbdKeyInfo(DS:[DI]).fbStatus
    AND   AL,02H
    MOV   AL,tKbdKeyInfo(DS:[DI]).chChar
    JZ    @@2
    CMP   AL,0E0H
    JE    @@1
    OR    AL,AL
    JNZ   @@2
@@1:
    MOV   AH,tKbdKeyInfo(DS:[DI]).chScan
    MOV   ExtKeyChar,AH
    XOR   AL,AL
@@2:
    POP   DI
  end;

{$endif}


{$ifdef UseAsm}

{ --------------------- Support Routine ---------------------}
{ Get cursor position }
{ Uses AX, BX, SI     }

procedure GetCursor; near; assembler;
  var
    Row, Col: Word;
  asm
    LEA   BX,Row
    PUSH  DS
    PUSH  BX
    LEA   SI,Col
    PUSH  DS
    PUSH  SI
    PUSH  0000H
    CALL  VioGetCurPos
    MOV   DH,[BX].Byte[0]
    MOV   DL,[SI].Byte[0]
  end;


{ --------------------- Support Routine ---------------------}
{ Set cursor position      }
{ In  DX = Cursor position }
{ Uses  AX                 }

procedure SetCursor; near; assembler;
  asm
    XOR   AH,AH
    MOV   AL,DH
    PUSH  AX
    MOV   AL,DL
    PUSH  AX
    PUSH  0000H
    CALL  VioSetCurPos
  end;


{ --------------------- Support Routine ---------------------}
{ Do pending write string          }
{ In  BX    = Cursor position      }
{     ES:SI = String start address }
{     ES:DI = String end address   }
{ Uses  AX, BX, SI                 }

procedure DirectWrite; near; assembler;
  asm
    CMP   SI,DI
    JE    @@2
    PUSH  CX
    PUSH  ES
    PUSH  SI
    MOV   CX,DI
    SUB   CX,SI
    PUSH  CX
    XOR   AX,AX
    MOV   AL,BH
    PUSH  AX
    MOV   AL,BL
    PUSH  AX
    LEA   AX,TextAttr
    PUSH  DS
    PUSH  AX
    PUSH  0000H
    CALL  VioWrtCharStrAtt
    POP   CX
@@2:
  end;


{ --------------------- Support Routine ---------------------}
{ Do line-feed operation   }
{ In  DX = Cursor position }
{ Uses  AX, BX             }

procedure LineFeed; near; assembler;
  asm
    INC   DH
    CMP   DH,WindMax.Byte[1]
    JBE   @@1
    DEC   DH
    XOR   AX,AX
    MOV   AL,WindMin.Byte[1]
    PUSH  AX
    MOV   AL,WindMin.Byte[0]
    PUSH  AX
    MOV   AL,WindMax.Byte[1]
    PUSH  AX
    MOV   AL,WindMax.Byte[0]
    PUSH  AX
    PUSH  0001H
    MOV   AL,TextAttr
    MOV   SpaceCell.a,AL
    LEA   BX,SpaceCell.c
    PUSH  DS
    PUSH  BX
    PUSH  0000h
    CALL  VioScrollUp
@@1:
  end;

{$endif}


{ -----------------------------------------------------------}
{ Write character string directly to Crt }

{$ifndef UseAsm}

procedure WritePChar(S: PChar; Len: Word); near;
  var
    Row, Col, SCol: Word;
    Cnt, SCnt     : Integer;

  procedure DirectWrite;
    begin
      if Cnt <> SCnt then
        VioWrtCharStrAtt(@S[SCnt], Cnt - SCnt, Row, SCol, TextAttr, 0);
    end;

  procedure LineFeed;
    begin
      if Row < Hi(WindMax) then
        Inc(Row)
      else
        begin
          SpaceCell.a := TextAttr;
          VioScrollUp(Hi(WindMin), Lo(WindMin), Hi(WindMax), Lo(WindMax), 1,
                      @SpaceCell, 0);
        end;
    end;

  begin
    VioGetCurPos(Row, Col, 0);
    SCol := Col;
    Cnt := 0;
    SCnt := Cnt;
    while Cnt < Len do
      begin
        if S[Cnt] in [#$07,#$08,#$0A,#$0D] then
          begin
            DirectWrite;
            case S[Cnt] of
              #$07 : {bell}
                VioWrtTTY(@S[Cnt], 1, 0);
              #$08 : {backspace}
                if Col <> Lo(WindMin) then
                  Dec(Col);
              #$0A : {line feed}
                LineFeed;
              #$0D : {carriage return}
                Col := Lo(WindMin);
            end;  { case }
            Inc(Cnt);
          end
        else
          begin
            Inc(Cnt);
            Inc(Col);
            if Col <= Lo(WindMax) then
              continue;
            DirectWrite;
            LineFeed;
            Col := Lo(WindMin);
          end;
        SCnt := Cnt;
        SCol := Col;
      end;  { while }
    DirectWrite;
    VioSetCurPos(Row, Col, 0);
  end;

{$else}

{ In  CX    = Character count            }
{     DX    = Position                   }
{     ES:DI = String pointer             }
{ Uses  AX, BX, CX, DX, SI, DI, ES       }

procedure WritePChar; near; assembler;
  asm
    CALL  GetCursor
    MOV   BX,DX
    MOV   SI,DI
@@1:
    MOV   AL,ES:[DI]
    CMP   AL,07H
    JE    @@2
    CMP   AL,08H
    JE    @@3
    CMP   AL,0AH
    JE    @@4
    CMP   AL,0DH
    JE    @@5
    INC   DI
    INC   DL
    CMP   DL,WindMax.Byte[0]
    JBE   @@8
    CALL  DirectWrite
    CALL  LineFeed
    MOV   DL,WindMin.Byte[0]
    JMP   @@7
@@2:
    CALL  DirectWrite
    PUSH  ES
    PUSH  DI
    XOR   AX,AX
    INC   AX
    PUSH  AX
    DEC   AX
    PUSH  AX
    CALL  VioWrtTTY

    JMP   @@6
@@3:
    CALL  DirectWrite
    CMP   DL,WindMin.Byte[0]
    JE    @@6
    DEC   DL
    JMP   @@6
@@4:
    CALL  DirectWrite
    CALL  LineFeed
    JMP   @@6
@@5:
    CALL  DirectWrite
    MOV   DL,WindMin.Byte[0]
@@6:
    INC   DI
@@7:
    MOV   SI,DI
    MOV   BX,DX
@@8:
    LOOP  @@1
    CALL  DirectWrite
    CALL  SetCursor
  end;

{$endif}


{$ifdef UseAsm}

{ --------------------- Support Routine ---------------------}
{ Writes character on Crt }

{ In    AL = Character    }
{ Uses  None              }

procedure WriteChar; near; assembler;
  var
    WrkChar: Char;
  asm
    PUSHA
    PUSH  ES
    MOV   CX,1
    MOV   WrkChar,AL
    LEA   DI,WrkChar
    PUSH  DS
    POP   ES
    CALL  WritePChar
    POP   ES
    POPA
  end;

{$endif}


{ -----------------------------------------------------------}
{ CRT file read procedure }

{$ifndef UseAsm}

function CrtRead(var F: Text): Word; far;
  var
    Max    : Integer;
    CurPos : Integer;
    C      : Char;
    C1     : Array[0..2] of Char;
    Flag   : Boolean;
  begin
    with TextRec(F) do
      begin
        Max    := BufSize - 2;
        CurPos := 0;
        repeat
          ExtKeyChar := #00;
          C := ReadKey;
          case C of
            #8, ^S, #27, ^A :  { BS, ^S, ESC, ^A }
              begin
                if (C = #8) or (C = ^S) then
                  Flag := True
                else
                  Flag := False;
                repeat
                  if CurPos = 0 then
                    Break;
                  C1 := #8' '#8; WritePChar(@C1, 3);
                  Dec(CurPos);
                until Flag;
              end;
            ^D, ^F :
              begin
                if C = ^D then
                  Flag := True
                else
                  Flag := False;
                repeat
                  if CurPos = BufPos then
                    Break;
                  C := BufPtr^[CurPos];
                  WritePChar(@C, 1);
                  Inc(CurPos);
                until Flag
              end;
            #13 :   { CR }
              begin
                C1 := #$0D#$0A#00; WritePChar(@C1, 2);
                BufPtr^[CurPos] := #$0D; Inc(CurPos);
                BufPtr^[CurPos] := #$0A; Inc(CurPos);
                BufPos := 0;
                BufEnd := CurPos;
                Break;
              end;
            ^Z  :
              begin
                if CheckEOF = True then
                  begin
                    BufPtr^[CurPos] := C;
                    Inc(CurPos);
                    BufPos := 0;
                    BufEnd := CurPos;
                    Break;
                  end;
              end;
            #32..#255 :
              if CurPos < Max then
                begin
                  WritePChar(@C, 1);
                  BufPtr^[CurPos] := C;
                  Inc(CurPos);
                  if CurPos > BufPos then
                    begin
                      BufPos := CurPos;
                    end;
                end;
          end;
        until False;
      end;
    CrtRead := 0;
  end;

{$else}

function CrtRead(var F: Text): Word; far; assembler;
  asm
    LES   DI, F
    MOV   DX, TextRec(ES:[DI]).BufSize
    DEC   DX
    DEC   DX
    MOV   SI, TextRec(ES:[DI]).BufPos
    LES   DI, TextRec(ES:[DI]).BufPtr
    XOR   BX, BX
@@1:
    MOV   ExtKeyChar,0
    CALL  ReadKey
    MOV   CX,1
    CMP   AL,08H
    JE    @@2
    CMP   AL,'S'-64
    JE    @@2
    CMP   AL,'D'-64
    JE    @@3
    DEC   CX
    CMP   AL,1BH
    JE    @@2
    CMP   AL,'A'-64
    JE    @@2
    CMP   AL,'F'-64
    JE    @@3
    CMP   AL,1AH
    JE    @@4
    CMP   AL,0DH
    JE    @@5
    CMP   AL,' '
    JB    @@1
    CMP   BX,DX
    JE    @@1
    MOV   ES:[DI+BX],AL
    INC   BX
    CALL  WriteChar
    CMP   BX,SI
    JBE   @@1
    MOV   SI,BX
    JMP   @@1
@@2:
    OR    BX,BX
    JE    @@1
    MOV   AL,08H
    CALL  WriteChar
    MOV   AL,' '
    CALL  WriteChar
    MOV   AL,08H
    CALL  WriteChar
    DEC   BX
    LOOP  @@2
    JMP   @@1
@@3:
    CMP   BX,SI
    JE    @@1
    MOV   AL,ES:[DI+BX]
    CMP   AL,' '
    JB    @@1
    CALL  WriteChar
    INC   BX
    LOOP  @@3
    JMP   @@1
@@4:
    CMP   CheckEOF,0
    JE    @@1
    MOV   ES:[DI+BX],AL
    INC   BX
    JMP   @@6
@@5:
    MOV   AL,0DH
    CALL  WriteChar
    MOV   AL,0AH
    CALL  WriteChar
    MOV   WORD PTR ES:[DI+BX],0A0DH
    INC   BX
    INC   BX
@@6:
    LES   DI,F
    XOR   AX,AX
    MOV   TextRec(ES:[DI]).BufPos,AX
    MOV   TextRec(ES:[DI]).Bufend,BX
  end;

{$endif}


{ -----------------------------------------------------------}
{ CRT file write procedure }

{$ifndef UseAsm}

function CrtWrite(var F: Text): Word; far;
  begin
    with TextRec(F) do
      begin
        WritePChar(PChar(BufPtr), BufPos);
        BufPos := 0;
      end;
    CrtWrite := 0;
  end;

{$else}

function CrtWrite(var F: Text): Word; far; assembler;
  asm
    LES   DI,F
    MOV   CX,TextRec(ES:[DI]).BufPos
    SUB   TextRec(ES:[DI]).BufPos,CX
    JCXZ  @@1
    LES   DI,TextRec(ES:[DI]).BufPtr
    CALL  WritePChar
@@1:
    XOR   AX,AX
  end;

{$endif}


{ -----------------------------------------------------------}
{ CRT file no-op procedure }

{$ifndef UseAsm}

function CrtReturn(var F: Text): Word; far;
  begin
    CrtReturn := 0;
  end;

{$else}

function CrtReturn(var F: Text): Word; far; assembler;
  asm
    XOR AX,AX
  end;

{$endif}


{ -----------------------------------------------------------}
{ CRT file open procedure }

{$ifndef UseAsm}

function CrtOpen(Var F: Text): Word; far;
  var
    InOut,
    Flush: Pointer;
  begin
    with TextRec(F) do
      begin
        if Mode = fmInput then
          begin
            InOut := @CrtRead;
            Flush := @CrtReturn;
          end
        else
          begin
            Mode := fmOutput;
            InOut := @CrtWrite;
            Flush := @CrtWrite;
          end;
        InOutFunc := InOut;
        FlushFunc := Flush;
        CloseFunc := @CrtReturn;
      end;
    CrtOpen := 0;
  end;

{$else}

function CrtOpen(var F: Text): Word; far; assembler;
  asm
    LES   DI,F
    MOV   AX,OFFSET CrtRead
    MOV   BX,OFFSET CrtReturn
    MOV   CX,BX
    CMP   TextRec(ES:[DI]).Mode,fmInput
    JE    @@1
    MOV   TextRec(ES:[DI]).Mode,fmOutput
    MOV   AX,OFFSET CrtWrite
    MOV   BX,AX
@@1:
    MOV   TextRec(ES:[DI]).InOutFunc.Word[0],AX
    MOV   TextRec(ES:[DI]).InOutFunc.Word[2],CS
    MOV   TextRec(ES:[DI]).FlushFunc.Word[0],BX
    MOV   TextRec(ES:[DI]).FlushFunc.Word[2],CS
    MOV   TextRec(ES:[DI]).CloseFunc.Word[0],CX
    MOV   TextRec(ES:[DI]).CloseFunc.Word[2],CS
    XOR   AX,AX
  end;

{$endif}


{ -----------------------------------------------------------}
{ Assign Crt to textfile }

{$ifndef UseAsm}

procedure AssignCrt(var F: Text);
  begin
    with TextRec(F) do
      begin
        Mode     := fmClosed;
        BufSize  := 128;
        BufPtr   := @Buffer;
        OpenFunc := @CrtOpen;
      end;
    end;

{$else}

procedure AssignCrt(var F: Text); assembler;
  asm
    LES   DI,F
    MOV   TextRec(ES:[DI]).Mode,fmClosed
    MOV   TextRec(ES:[DI]).BufSize,128
    LEA   AX,TextRec(ES:[DI]).Buffer
    MOV   TextRec(ES:[DI]).BufPtr.Word[0],AX
    MOV   TextRec(ES:[DI]).BufPtr.Word[2],ES
    MOV   TextRec(ES:[DI]).OpenFunc.Word[0],OFFSET CrtOpen
    MOV   TextRec(ES:[DI]).OpenFunc.Word[2],CS
    MOV   TextRec(ES:[DI]).Name.Byte[0],0
  end;

{$endif}


{ -----------------------------------------------------------}
{ Set Crt text mode }

procedure TextMode(Mode: Integer);
  begin
    SetCrtMode(FixCrtMode(Mode));
    CrtSetup;
    TextAttr := NormAttr;
    ClrScr;
  end;


{ -----------------------------------------------------------}
{ Define output window }

{$ifndef UseAsm}

procedure Window(X1, Y1, X2, Y2: Byte);
  begin
    if X1 > X2 then Exit;
    if Y1 > Y2 then Exit;
    Dec(X1);
    if X1 < 0 then Exit;
    Dec(Y1);
    if Y1 < 0 then Exit;
    Dec(X2);
    if X2 > Lo(CurCrtSize) then Exit;
    Dec(Y2);
    if y2 > Hi(CurCrtSize) then Exit;
    WindMin := (Y1 shl 8) + X1;
    WindMax := (Y2 shl 8) + X2;
    GotoXY(1, 1);
  End;

{$else}

procedure Window(X1, Y1, X2, Y2: Byte); assembler;
  asm
    MOV   DL,X1
    MOV   DH,Y1
    MOV   CL,X2
    MOV   CH,Y2
    CMP   DL,CL
    JA    @@1
    CMP   DH,CH
    JA    @@1
    DEC   DL
    JS    @@1
    DEC   DH
    JS    @@1
    DEC   CL
    CMP   CL,CurCrtSize.Byte[0]
    JA    @@1
    DEC   CH
    CMP   CH,CurCrtSize.Byte[1]
    JA    @@1
    MOV   WindMin,DX
    MOV   WindMax,CX
    CALL  SetCursor
@@1:
  end;

{$endif}


{ -----------------------------------------------------------}
{ Position cursor }

{$ifndef UseAsm}

procedure GotoXY(X,Y: Byte);
  begin
    Dec(X);
    X := X + Lo(WindMin);
    if X > Lo(WindMax) then
      Exit;
    Dec(Y);
    Y := Y + Hi(WindMin);
    if Y > Hi(WindMax) then
      Exit;
    VioSetCurPos(Y, X, 0);
  End;

{$else}

procedure GotoXY(X, Y: Byte); assembler;
  asm
    MOV   DL,X
    MOV   DH,Y
    DEC   DL
    ADD   DL,WindMin.Byte[0]
    JC    @@1
    CMP   DL,WindMax.Byte[0]
    JA    @@1
    DEC   DH
    ADD   DH,WindMin.Byte[1]
    JC    @@1
    CMP   DH,WindMax.Byte[1]
    JA    @@1
    CALL  SetCursor
@@1:
  end;

{$endif}


{ -----------------------------------------------------------}
{ Return cursor X coordinate }

{$ifndef UseAsm}

function WhereX;
  var
    Row, Col: Word;
  begin
    VioGetCurPos(Row, Col, 0);
    WhereX := Col - Lo(WindMin) + 1;
  end;

{$else}

function WhereX: Byte; assembler;
  asm
    CALL  GetCursor
    MOV   AL,DL
    SUB   AL,WindMin.Byte[0]
    INC   AL
  end;

{$endif}


{ -----------------------------------------------------------}
{ Return cursor Y coordinate }

{$ifndef UseAsm}

function WhereY: Byte;
  var
    Row, Col: Word;
  begin
    VioGetCurPos(Row, Col, 0);
    WhereY := Row - Hi(WindMin) + 1;
  end;

{$else}

function WhereY: Byte; assembler;
  asm
    CALL  GetCursor
    MOV   AL,DH
    SUB   AL,WindMin.Byte[1]
    INC   AL
  end;

{$endif}


{ -----------------------------------------------------------}
{ Clear screen }

{$ifndef UseAsm}

procedure ClrScr;
  begin
    SpaceCell.a := TextAttr;
    VioScrollUp(Hi(WindMin), Lo(WindMin), Hi(WindMax), Lo(WindMax),
                Hi(WindMax) - Hi(WindMin) + 1, @SpaceCell, 0);
    GotoXY(1, 1);
  end;

{$else}

procedure ClrScr; assembler;
  asm
    XOR   AX,AX
    MOV   AL,WindMin.Byte[1]
    MOV   BX,AX
    PUSH  AX
    MOV   AL,WindMin.Byte[0]
    PUSH  AX
    MOV   AL,WindMax.Byte[1]
    PUSH  AX
    SUB   AL,BL
    MOV   BL,AL
    INC   BL
    MOV   AL,WindMax.Byte[0]
    PUSH  AX
    PUSH  BX
    MOV   AL,TextAttr
    MOV   SpaceCell.a,AL
    LEA   BX,SpaceCell.c
    PUSH  DS
    PUSH  BX
    PUSH  0000H
    CALL  VioScrollUp
    XOR   AX,AX
    INC   AX
    PUSH  AX
    PUSH  AX
    CALL  GotoXY
  end;

{$endif}


{ -----------------------------------------------------------}
{ Clear to end-of-line }

{$ifndef UseAsm}

procedure ClrEol;
  var
    Row, Col: Word;
  begin
    VioGetCurPos(Row, Col, 0);
    SpaceCell.a := TextAttr;
    VioScrollUp(Row, Col, Row, Lo(WindMax), 1, @SpaceCell, 0);
  end;

{$else}

procedure ClrEol; assembler;
  asm
    CALL  GetCursor
    XOR   AX,AX
    MOV   AL,DH
    MOV   BX,AX
    PUSH  AX
    MOV   AL,DL
    PUSH  AX
    PUSH  AX
    MOV   AL,WindMax.Byte[0]
    PUSH  AX
    PUSH  0001H
    MOV   AL,TextAttr
    MOV   SpaceCell.a,AL
    LEA   BX,SpaceCell.c
    PUSH  DS
    PUSH  BX
    PUSH  0000H
    CALL  VioScrollUp
  end;

{$endif}


{ -----------------------------------------------------------}
{ Insert line }

{$ifndef UseAsm}

procedure InsLine;
  var
    Row, Col: Word;
  begin
    VioGetCurPos(Row, Col, 0);
    SpaceCell.a := TextAttr;
    VioScrollDn(Row, Lo(WindMin), Hi(WindMax), Lo(WindMax), 1, @SpaceCell, 0);
  end;

{$else}

procedure InsLine; assembler;
  asm
    CALL  GetCursor
    XOR   AX,AX
    MOV   AL,DH
    PUSH  AX
    MOV   AL,WindMin.Byte[0]
    PUSH  AX
    MOV   AL,WindMax.Byte[1]
    PUSH  AX
    MOV   AL,WindMax.Byte[0]
    PUSH  AX
    PUSH  0001H
    MOV   AL,TextAttr
    MOV   SpaceCell.a,AL
    LEA   BX,SpaceCell.c
    PUSH  DS
    PUSH  BX
    PUSH  0000H
    CALL  VioScrollDn
  end;

{$endif}


{ -----------------------------------------------------------}
{ Delete line }

{$ifndef UseAsm}

procedure DelLine;
  var
    Row, Col: Word;
  begin
    VioGetCurPos(Row, Col, 0);
    SpaceCell.a := TextAttr;
    VioScrollUp(Row, Lo(WindMin), Hi(WindMax), Lo(WindMax), 1, @SpaceCell, 0);
  end;

{$else}

procedure DelLine; assembler;
  asm
    CALL  GetCursor
    XOR   AX,AX
    MOV   AL,DH
    PUSH  AX
    MOV   AL,WindMin.Byte[0]
    PUSH  AX
    MOV   AL,WindMax.Byte[1]
    PUSH  AX
    MOV   AL,WindMax.Byte[0]
    PUSH  AX
    PUSH  0001H
    MOV   AL,TextAttr
    MOV   SpaceCell.a,AL
    LEA   BX,SpaceCell.c
    PUSH  DS
    PUSH  BX
    PUSH  0000H
    CALL  VioScrollUp
  end;

{$endif}


{ -----------------------------------------------------------}
{ Set text color (color modes) }

{$ifndef UseAsm}

procedure TextColor(Color: Byte);
  begin
    TextAttr := (TextAttr and $70) or
                (Color and $0F) + Ord(Color > $0F) * $80;
  end;

{$else}

procedure TextColor(Color: Byte); assembler;
  asm
    MOV   AL,Color
    TEST  AL,0F0H
    JE    @@1
    AND   AL,0FH
    OR    AL,80H
@@1:
    AND   TextAttr,70H
    OR    TextAttr,AL
  end;

{$endif}


{ -----------------------------------------------------------}
{ Set text background (color modes) }

{$ifndef UseAsm}

procedure TextBackground;
  begin
    TextAttr := (TextAttr and $8F) or ((Color and $07) shl 4);
  end;

{$else}

procedure TextBackground; assembler;
  asm
    MOV   AL,Color
    AND   AL,7
    MOV   CL,4
    SHL   AL,CL
    AND   TextAttr,8FH
    OR    TextAttr,AL
  end;

{$endif}


{ -----------------------------------------------------------}
{ Select low intensity }

{$ifndef UseAsm}

procedure LowVideo;
  begin
    TextAttr := TextAttr and $F7;
  end;


{$else}

procedure LowVideo; assembler;
  asm
    AND   TextAttr,0F7H
  end;

{$endif}


{ -----------------------------------------------------------}
{ Select high intensity }

{$ifndef UseAsm}

procedure HighVideo;
  begin
    TextAttr := TextAttr or $08;
  end;

{$else}

procedure HighVideo; assembler;
  asm
    OR    TextAttr,8
  end;

{$endif}


{ -----------------------------------------------------------}
{ Select normal intensity }

{$ifndef UseAsm}

procedure NormVideo;
  begin
    TextAttr := NormAttr;
  end;

{$else}

procedure NormVideo; assembler;
  asm
    MOV   AL,NormAttr
    MOV   TextAttr,AL
  end;

{$endif}


{ -----------------------------------------------------------}
{ Delay specified number of milliseconds }

{$ifndef UseAsm}

procedure Delay(MS: Word);
  begin
    if MS <> 0 then
      DosSleep(Ms);
  end;

{$else}

procedure Delay(Ms: Word); assembler;
  asm
    MOV   AX,Ms
    OR    AX,AX
    JZ    @@1
    PUSH  0000H
    PUSH  AX
    CALL  DosSleep
@@1:
  end;
{$endif}


{ -----------------------------------------------------------}
{ Sound thead }

procedure SoundThread; far;
  begin
    repeat
      DosBeep(SoundHz, 50);
    until False;
  end;


{ -----------------------------------------------------------}
{ Start sound generator }

procedure Sound(Hz: Word);
  begin
    SoundHz := Hz;
    if SoundActive then
      DosResumeThread(SoundThreadID)
    else
      begin
        GetMem(SoundStackPtr, soundStackSize);
        SoundActive := True;
        DosCreateThread(SoundThread, SoundThreadID,
                        @PChar(SoundStackPtr)[soundStackSize]);
      end;
  end;


{ -----------------------------------------------------------}
{ Turn off sound generator }

procedure NoSound;
  begin
    if SoundActive then
      DosSuspendThread(SoundThreadID);
    { If it was possible to cancel a task, then:  }
    { FreeMem(SoundStackPtr, SoundStackSize);     }
    { SoundActive := False;                       }
  end;


{ -----------------------------------------------------------}
{ Show local video buffer }

procedure ShowBuf;
  begin
    VioShowBuf(0, LVBSize, 0);
  end;


{ -----------------------------------------------------------}
{ ShowBuf thead }

procedure ShowBufThread; far;
  begin
    repeat
      DosSleep(ShowBufDly);
      VioShowBuf(0, LVBSize, 0);
    until False;
  end;


{ -----------------------------------------------------------}
{ Start ShowBuf thread }

procedure AutoShowBuf(On: Boolean);
  begin
    case On of
      False:
        begin
          if ShowBufActive then
            DosSuspendThread(ShowBufThreadID);
        end;
      True:
        begin
          if ShowBufActive then
            DosResumeThread(ShowBufThreadID)
          else
            begin
              GetMem(ShowBufStackPtr, showBufStackSize);
              ShowBufActive := True;
              DosCreateThread(ShowBufThread, ShowBufThreadID,
                              @PChar(ShowBufStackPtr)[showBufStackSize]);
            end;
        end;
    end;
  end;


{ -----------------------------------------------------------}
{ Crt exit procedure }

procedure CrtExitProc; far;
  begin
    { restore previous exit handler }
    ExitProc := SaveExitProc;

    { Show the last writes to the LVB }
    ShowBuf;
  end;


{ -----------------------------------------------------------}
{ One-time initialization }

procedure Initialize; near;
  const
    P2: Word = 2;
    ModeChg: Boolean = False;

  var
    Row, Col: Word;
    RCell   : tCell;
    Status  : tKbdInfo;
    Mode    : Integer;

  begin
    SoundActive   := False;
    ExtKeyChar    := #0;
    SpaceCell.c   := ' ';                             { space }
    CrtVioMode.cb := SizeOf(tVioModeInfo);
    LastMode      := GetCrtMode;
    StartVioMode  := CrtVioMode;
    Mode          := FixCrtMode(LastMode);
    if Mode <> LastMode then
      begin
        SetCrtMode(Mode);
        ModeChg := True;
      end;
    CrtSetup;
    ShowBufDly    := 10;
    ShowBufActive := False;
{$ifndef NoAutoShowBuf}
    AutoShowBuf(True)
{$endif}
    VioGetCurPos(Row, Col, 0);
    VioReadCellStr(RCell, P2, Row, Col, 0);
    NormAttr  := RCell.a and $7F;
    TextAttr  := NormAttr;
    CheckEOF  := False;
    if ModeChg then
      ClrScr;
    Status.cb := 10;                                  { Set KBD to binary }
    KbdGetStatus(Status, 0);                          { mode, else ctrl-c }
    Status.fsMask := (Status.fsMask and $80) or $6;   { is linked to      }
    KbdSetStatus(Status, 0);                          { ctrl-break        }

    CheckBreak   := True;
    TriggerBreakHandler;                              { Break Handler }
    SaveExitProc := ExitProc;                         { save old exit handler }
    ExitProc     := @CrtExitProc;                     { install exit handler }
  end;


begin
  Initialize;
  AssignCrt(Input);  Reset(Input);
  AssignCrt(Output); Rewrite(Output);
end.