[Back to SCREEN SWAG index] [Back to Main SWAG index] [Original]

    unit screenio;

    interface

    uses crt,dos;

    const
      SHFTR   = 1;
      SHFTL   = 2;
      CTRL    = 4;
      ALT     = 8;
      SCRL    = 16;
      NUML    = 32;
      CAPL    = 64;
      INS     = 128;
      _BKSPC  = 8;
      _ESC    = 27;
      _UP     = 328;
      _DN     = 336;
      _RIGHT  = 333;
      _LEFT   = 331;
      _PGUP   = 329;
      _PGDN   = 337;
      _HOME   = 327;
      _END    = 335;
      _DEL    = 339;
      _INS    = 338;
      _F1     = 315;
      _F2     = 316;
      _F3     = 317;
      _F4     = 318;
      _F5     = 319;
      _F6     = 320;
      _F7     = 321;
      _F8     = 322;
      _F9     = 323;
      _F10    = 324;
      single  = 'ÚÄ¿³ÀÙ';
      double  = 'ÉÍ»ºÈ¼';
      bellsnd = 50;

    type
      ScreenType = array[1..25,1..80] of word;
      str2  = string[2];
      str10 = string[10];
      str20 = string[20];
      str80 = string[80];

    procedure InitScrn;
    function  CenterNum(Num : longint;Len : byte) : string;
    function  FileOpen(var Fn      : text;
                          FileName: String): Boolean;
    function  FileVOpen(var Fn      : file;
                          FileName: String): Boolean;
    function  Get_Key : Integer;
    function  GetKeyScan(SCANBYTE : BYTE) : Boolean;
    PROCEDURE GetText(Left,Top,Right,Bottom:INTEGER;VAR dest);
    PROCEDURE PutText(Left,Top,Right,Bottom:INTEGER;VAR Source);
    procedure GetChar(X,Y           : integer;           { Display Coord }
                      var Character : char;              { the character }
                      var COLOR     : integer);          { its Attribute }
    procedure Scroll(  Direction : Char;   { Direction U=Up D=Down }
                       Number,             { Number of lines to be scrolled }
                       COLOR,              { Attribute for the blank lines created }
                       XLeft,              { Column in the upper left corner }
                       YLeft,              { line in the upper left corner }
                       XRight,             { Column in the lower right corner }
                       YRight     : integer);  { Line in lower right corner }
    procedure WriteXY(X,Y : Byte;Str : String);
    procedure DrawBox(Title,BoxDef : string;TopX,TopY,BotX,BotY,Shadow,Border,WindC : byte);
    function  Parse(ParseChr : char;VAR Str : string) : string;
    function  SelMenu(Xpos,Ypos,NormColor,HighColor,BordColor,Box : Byte;
                     MenuName,MenuS : string) : Char;
    function  Trim_Str(InputStr : string) : string;
    procedure soundbell;
    procedure InValidInput(Prompt : string);
    procedure ClearInvalid;

    var
      ErrPrompt : Boolean;

    implementation

    var
      Screen : ^ScreenType;
      vinput : array[1..240] of word;

    procedure soundbell;
      begin
        sound(500);
        delay(bellsnd);
        nosound;
      end;

    procedure InValidInput(Prompt : string);
      var
        xpos,oldx,oldy,attr : byte;
      begin
        GetText(1,1,80,3,vinput);
        attr := textattr;
        oldx := wherex;
        oldy := wherey;
        textattr := $5f;
        xpos := 80-3-length(prompt);
        DrawBox('',Single,xpos,1,80,3,$00,$5f,$5f);
        gotoxy(xpos+2,2);
        write(prompt);
        textattr := attr;
        gotoxy(oldx,oldy);
        ErrPrompt := True;
      end;

    procedure ClearInvalid;
      begin
        ErrPrompt := False;
        PutText(1,1,80,3,vinput);
      end;

    procedure InitScrn;
      begin
        IF LastMode = Mono THEN Screen := Ptr($b000,0)
          ELSE Screen:=Ptr($b800,0);
      end;

    function Trim_Str(InputStr : string) : string;
      var
        count  : byte;
      begin
        count := 1;
        while InputStr[count] = ' ' do
          begin
            Delete(InputStr,1,1);
            inc(count);
          end;
        count := Length(InputStr);
        while InputStr[count] = ' ' do
          begin
            Delete(InputStr,Length(InputStr),1);
            dec(count);
          end;
        Trim_Str := InputStr;
      end;

    function CenterNum(Num : longint;Len : byte) : string;
      var
        Tstr : string;
        SLen,TVal : byte;
      begin
        Str(Num,Tstr);
        SLen := Length(Tstr);
        if SLen < Len then
          repeat
            Insert(' ',Tstr,Slen+1);
            inc(Slen);
            if SLen < Len then Insert(' ',Tstr,1);
            inc(Slen);
          until Slen >= Len else if Slen > Len then Delete(Tstr,Len+1,Slen-Len);
        Centernum := Tstr;
      end;

    function FileVOpen(var Fn      : file;
                          FileName: String): Boolean;
    { Boolean function that returns True if the file exists;otherwise,
     it returns False. Closes the file if it exists. }
    begin
     {$I-}
     Assign(Fn, FileName);

     FileMode := 2;  { Set file access to read/write }
     Reset(Fn);
     {$I+}
     FileVOpen := (IOResult = 0) and (FileName <> '');
    end;  { FileExists }

    function FileOpen(var Fn      : text;
                          FileName: String): Boolean;
    { Boolean function that returns True if the file exists;otherwise,
     it returns False. Closes the file if it exists. }
    begin
     {$I-}
     Assign(Fn, FileName);

     FileMode := 2;  { Set file access to read/write }
     Reset(Fn);
     {$I+}
     FileOpen := (IOResult = 0) and (FileName <> '');
    end;  { FileExists }

    function Get_Key : Integer;
      Var CH : Char;
          Int : Integer;
      begin
        CH := ReadKey;
        If CH = #0 then
          begin
            CH := ReadKey;
            int := Ord(CH);
            inc(int,256);
          end else Int := Ord(CH);
        Get_Key := Int;
      end;

    function GetKeyScan(SCANBYTE : BYTE) : Boolean;
      var
        Regs : Registers;
      begin
        Regs.ah := $2;
        intr($16,Regs);
        if (Regs.al and SCANBYTE <> 0) then GetKeyScan := true
          else GetKeyScan := False;
      end;

    PROCEDURE GetText(Left,Top,Right,Bottom:INTEGER;VAR dest);
      TYPE
        DestType = ARRAY[1..2000] OF WORD;
      VAR
        d      : 1..2000;
        x      : 1..80;
        y      : 1..25;
      BEGIN
        d := 1;
        FOR y:=Top TO Bottom DO
          FOR x:= Left TO Right DO
            BEGIN
              DestType(Dest)[d] := Screen^[y,x];
              inc(d);
            END
      END;

    PROCEDURE PutText(Left,Top,Right,Bottom:INTEGER;VAR Source);
      TYPE
        SourceType = ARRAY[1..2000] OF WORD;
      VAR
        x      : 1..80;
        y      : 1..25;
        s      : 1..2000;
      BEGIN
        s := 1;
        FOR y := Top TO Bottom DO
          FOR x := Left TO Right DO
            BEGIN
              Screen^[y,x] := SourceType(Source)[s];
              inc(s);
            END
      END;

    procedure GetChar(X,Y           : integer;           { Display Coord }
                      var Character : char;              { the character }
                      var COLOR     : integer);          { its Attribute }
      var
        Regs : Registers;           { Register-Variable for the Interrupt }

    begin
      gotoxy(X,Y);                  { cursor on the position indicated }
      Regs.ah := 8;                 { Get Function number for char. and Attribute }
      Regs.bh := 0;                 { display page }
      Intr($10,Regs);               { Invoke DOS registers }
      Character := chr(Regs.al);    { ASCII-Code of character }
      COLOR := Regs.ah;             { Attribute of the character }
    end;

    procedure Scroll(  Direction : Char;   { Direction U=Up D=Down }
                       Number,             { Number of lines to be scrolled }
                       COLOR,              { Attribute for the blank lines created }
                       XLeft,              { Column in the upper left corner }
                       YLeft,              { line in the upper left corner }
                       XRight,             { Column in the lower right corner }
                       YRight     : integer);  { Line in lower right corner }

    var Regs : Registers;       { Register variable for calling Interrupt }

    begin
      if Direction = 'U' then
        Regs.ah := 6                        { Scroll Up }
      else Regs.ah := 7;                    { Scroll Down }
      Regs.al := Number;
      Regs.bh := COLOR;                     { Color of empty line(s) }
      Regs.ch := YLeft-1;                   { Upper left }
      Regs.cl := XLeft-1;                   { coordinates }
      Regs.dh := YRight-1;                  { Lower right }
      Regs.dl := XRight-1;                  { coordinates }
      Intr($10,Regs);                       { Call BIOS-Video-Interrupt }
    end;

    procedure WriteXY(X,Y : Byte;Str : String);
      begin
        GotoXY(X,Y);
        Write(Str);
      end;

    procedure DrawBox(Title,BoxDef : string;TopX,TopY,BotX,BotY,Shadow,Border,WindC : byte);
      var
        count,space,
        TX,TY,BX,BY,OldC : byte;
      begin
        OldC := Textattr;
        TX := Lo(WindMin);
        TY := Hi(WindMin);
        BX := Lo(WindMax);
        BY := Hi(WindMax);
        if Shadow > 0 then
          begin
            TextAttr := Shadow;
            Window(TopX+2,TopY+1,BotX+2,BotY+1);
            clrscr;
          end;
        TextAttr := WindC;
        Window(TopX,TopY,BotX,BotY);
        if windC <> $00 then clrscr;
        Window(TX+1,TY+1,BX+1,BY+1);
        TextAttr := Border;

        WriteXY(TopX,TopY,BoxDef[1]);
        for count := 1 to BotX-TopX-1 do
          write(BoxDef[2]);
        write(BoxDef[3]);

        For count := TopY+1 to BotY-1 do
          begin
            WriteXY(TopX,Count,BoxDef[4]);
            WriteXY(BotX,Count,BoxDef[4]);
          end;

        WriteXY(TopX,BotY,BoxDef[5]);
        for count := 1 to BotX-TopX-1 do
          write(BoxDef[2]);
        write(BoxDef[6]);

        If Length(Title)+2 < (BotX-TopX-2) then
          begin
            GotoXY(TopX+ (Round((BotX-TopX)/2) - Round((Length(Title)/2)+1)) ,TopY);
            if Title <> '' then write(' ',Title,' ');
          end;

        TextAttr := OldC;
      end;

    function Parse(ParseChr : char;VAR Str : string) : string;
      var
        count : byte;
      begin
        count := Pos(ParseChr,Str);
        if count > 0 then
          begin
            Parse := Copy(Str,1,count-1);
            Str   := Copy(Str,count+1,Length(Str)-count);
          end else Parse := '';
      end;

    function SelMenu(Xpos,Ypos,NormColor,HighColor,BordColor,Box : Byte;
                     MenuName,MenuS : string) : Char;
      type
        MenuRec = record
          mstr  : string[12];
          xpos : byte;
        end;
      var
        Selection : integer;
        x,lastm,lastx,
        y,Xlen    : byte;
        MenuArr   : array[1..20] of MenuRec;
        CH        : Char;
      begin
        lastm := 0;
        lastX := xpos;
        Repeat
          inc(LastM);
          MenuArr[LastM].mstr := ' '+Parse('|',MenuS)+' ';
          MenuArr[LastM].xpos := LastX;
          LastX := Length(MenuArr[LastM].mstr)+LastX;
        until MenuS = '';
        x := Length(MenuArr[LastM].mstr)+MenuArr[LastM].xpos;
        if Box = 1 then DrawBox(MenuName,single,Xpos-1,Ypos-1,x,Ypos+1,0,BordColor,NormColor);
        Gotoxy(Xpos,Ypos);
        for x := 1 to lastM do
          Write(MenuArr[x].mstr);
        x := 1;
        repeat
          case selection of
            333 : inc(x);
            331 : dec(x);
          end;
          if x = lastm+1 then x := 1;
          if x = 0 then x := lastm;
          textattr := HighColor;
          WriteXY(MenuArr[x].xpos,Ypos,MenuArr[x].mstr);
          gotoxy(menuArr[x].xpos+1,Ypos);
          selection := Get_Key;
          gotoxy(menuArr[x].xpos+1,Ypos);
          textattr := NormColor;
          WriteXY(MenuArr[x].xpos,Ypos,MenuArr[x].mstr);
        until (selection > 333) or (selection < 331);
        if selection = 13 then
          begin
            y := 2;
            while y < Length(MenuArr[x].mstr)-1 do
              begin
                Ch := MenuArr[x].mstr[y];
                If (CH >= 'A') and (CH <= 'Z') then SelMenu := CH;
                inc(y);
              end;
          end else SelMenu := Chr(Selection);
      end;

    var
      keyval : integer;

    begin
      ErrPrompt := False;
      InitScrn;
    end.

[Back to SCREEN SWAG index] [Back to Main SWAG index] [Original]