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

    Unit sundry;

    Interface

    Uses
      Dos,
      sCrt,
      Strings;

    Type
      LongWds = Record
                  loWord,
                  hiWord : Word;
                end;
      ica_rec = Record
                  Case Integer of
                    0: (Bytes   : Array[0..15] of Byte);
                    1: (Words   : Array[0..7] of Word);
                    2: (Integers: Array[0..7] of Integer);
                    3: (strg    : String[15]);
                    4: (longs   : Array[0..3] of LongInt);
                    5: (dummy   : String[13]; chksum: Integer);
                    6: (mix     : Byte; wds : Word; lng : LongInt);
                end;
    {-This simply creates a Variant Record which is mapped to 0000:04F0
      which is the intra-applications communications area in the bios area
      of memory. A Program may make use of any of the 16 Bytes in this area
      and be assured that Dos and the bios will not interfere With it. This
      means that it can be effectively used to pass values/inFormation
      between different Programs. It can conceivably be used to store
      inFormation from an application, then terminate from that application,
      run several other Programs, and then have another Program use the
      stored inFormation. As the area can be used by any Program, it is wise
      to incorporate a checksum to ensure that the intermediate applications
      have not altered any values. It is of most use when executing child
      processes or passing values between related Programs that are run
      consecutively.}

      IOproc = Procedure(derror:Byte; msg : String);

    Const
      ValidChars : String[40] = ' ABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890-'+#39;
      HexChars : Array[0..15] of Char = '0123456789ABCDEF';

    Var
      ica : ica_rec Absolute $0000:$04f0;
      FilePosition : LongInt;
    (*  OldRecSize   : Word; *)
      TempStr      : String;

    Procedure CheckIO(Error_action : IOproc; msg : String);

    Function CompressStr(Var n): String;
      {-Will Compress 3 alpha-numeric Bytes into 2 Bytes}

    Function DeCompress(Var s): String;
      {-DeCompresses a String Compressed by CompressStr}

    Function NumbofElements(Var s; size : Word): Word;
      {-returns the number of active elements in a set}

    Function PrinterStatus : Byte;
      {-Gets the Printer status}

    Function PrinterReady(Var b : Byte): Boolean;

    Function TestBbit(n,b: Byte): Boolean;
    Function TestWbit(Var n; b: Byte): Boolean;
    Function TestLbit(n: LongInt; b: Byte): Boolean;

    Procedure SetBbit(Var n: Byte; b: Byte);
    Procedure SetWbit(Var n; b: Byte);
    Procedure SetLbit(Var n: LongInt; b: Byte);

    Procedure ResetBbit(Var n: Byte; b: Byte);
    Procedure ResetWbit(Var n; b: Byte);
    Procedure ResetLbit(Var n: LongInt; b: Byte);

    Function right(Var s; n : Byte): String;
    Function left(Var s; n : Byte): String;
    Function shleft(Var s; n : Byte): String;
    Function nExtStr(Var s1; s2 : String; n : Byte): String;
    Procedure WriteAtCr(st: String; col,row: Byte);
    Procedure WriteLnAtCr(st: String; col,row: Byte);
    Procedure WriteLNCenter(st: String; width: Byte);
    Procedure WriteCenter(st: String; width: Byte);
    Procedure GotoCR(col,row: Byte);

      {-These Functions and Procedures Unit provides the means to do random
        access reads on Text Files.  }

    Function Exist(fn : String) : Boolean;

    Function Asc2Str(Var s; max: Byte): String;

    Procedure DisableBlink(State:Boolean);

    Function Byte2Hex(numb : Byte) : String;

    Function Numb2Hex(Var numb) : String;

    Function Long2Hex(long : LongInt): String;

    Function Hex2Byte(HexStr : String) : Byte;

    Function Hex2Word(HexStr : String) : Word;

    Function Hex2Integer(HexStr : String) : Integer;

    Function Hex2Long(HexStr : String) : LongInt;

    {======================================================================}

    Implementation

    Procedure CheckIO(error_action : IOproc;msg : String);
      Var c : Word;
      begin
        c := Ioresult;
        if c <> 0 then error_action(c,msg);
      end;

    {$F+}
    Procedure ReportError(c : Byte; st : String);
      begin
        Writeln('I/O Error ',c);
        Writeln(st);
        halt(c);
      end;
    {$F-}

    Function StUpCase(Str : String) : String;
    Var
      Count : Integer;
    begin
      For Count := 1 to Length(Str) do
        Str[Count] := UpCase(Str[Count]);
      StUpCase := Str;
    end;

    Function CompressStr(Var n): String;
      Var
        S      : String Absolute n;
        InStr  : String;
        len    : Byte Absolute InStr;
        Compstr: Record
                  Case Byte of
                    0: (Outlen  : Byte;
                        OutArray: Array[0..84] of Word);
                    1: (Out     : String[170]);
                 end;
        temp,
        x,
        count : Word;
      begin
        FillChar(InStr,256,32);
        InStr := S;
        len   := (len + 2) div 3 * 3;
        FillChar(CompStr.Out,171,0);
        InStr := StUpCase(InStr);
        x := 1; count := 0;
        While x <= len do begin
          temp  := pos(InStr[x+2],ValidChars);
          inc(temp,pos(InStr[x+1],ValidChars) * 40);
          inc(temp,pos(InStr[x],ValidChars) * 1600);
          inc(x,3);
          CompStr.OutArray[count] := temp;
          inc(count);
        end;
        CompStr.Outlen := count shl 1;
        CompressStr := CompStr.Out;
      end;  {-CompressStr}

    Function DeCompress(Var s): String;
      Var
        CompStr : Record
                    clen : Byte;
                    arry : Array[0..84] of Word;
                  end Absolute s;
        x,
        count,
        temp    : Word;
      begin
        With CompStr do begin
          DeCompress[0] := Char((clen shr 1) * 3);
          x := 0; count := 1;
          While x <= clen shr 1 do begin
            temp := arry[x] div 1600;
            dec(arry[x],temp*1600);
            DeCompress[count] := ValidChars[temp];
            temp := arry[x] div 40;
            dec(arry[x],temp*40);
            DeCompress[count+1] := ValidChars[temp];
            temp := arry[x];
            DeCompress[count+2] := ValidChars[temp];
            inc(count,3);
            inc(x);
          end;
        end;
      end;

    Function NumbofElements(Var s; size : Word): Word;
     {-The Variable s can be any set Type and size is the Sizeof(s)}
      Var
        TheSet : Array[1..32] of Byte Absolute s;
        count,x,y : Word;
      begin
        count := 0;
        For x := 1 to size do
          For y := 0 to 7 do
            inc(count, 1 and (TheSet[x] shr y));
        NumbofElements := count;
      end;

    Function PrinterStatus : Byte;
       Var regs   : Registers; {-from the Dos Unit                         }
       begin
         With regs do begin
           dx := 0;            {-The Printer number   LPT2 = 1             }
           ax := $0200;        {-The Function code For service wanted      }
           intr($17,regs);     {-$17= ROM bios int to return Printer status}
           PrinterStatus := ah;{-Bit 0 set = timed out                     }
         end;                  {     1     = unused                        }
       end;                    {     2     = unused                        }
                               {     3     = I/O error                     }
                               {     4     = Printer selected              }
                               {     5     = out of paper                  }
                               {     6     = acknowledge                   }
                               {     7     = Printer not busy              }

    Function PrinterReady(Var b : Byte): Boolean;
      begin
        b := PrinterStatus;
        PrinterReady := (b = $90) {-This may Vary between Printers}
      end;

    Function TestBbit(n,b: Byte): Boolean;
      begin
        TestBbit := odd(n shr b);
      end;

    Function TestWbit(Var n; b: Byte): Boolean;
      Var t: Word Absolute n;
      begin
        if b < 16 then
          TestWbit := odd(t shr b);
      end;

    Function TestLbit(n: LongInt; b: Byte): Boolean;
      begin
        if b < 32 then
          TestLbit := odd(n shr b);
      end;

    Procedure SetBbit(Var n: Byte; b: Byte);
      begin
        if b < 8 then
          n := n or (1 shl b);
      end;

    Procedure SetWbit(Var n; b: Byte);
      Var t : Word Absolute n; {-this allows either a Word or Integer}
      begin
        if b < 16 then
          t := t or (1 shl b);
      end;

    Procedure SetLbit(Var n: LongInt; b: Byte);
      begin
        if b < 32 then
          n := n or (LongInt(1) shl b);
      end;

    Procedure ResetBbit(Var n: Byte; b: Byte);
      begin
        if b < 8 then
          n := n and not (1 shl b);
      end;

    Procedure ResetWbit(Var n; b: Byte);
      Var t: Word Absolute n;
      begin
        if b < 16 then
          t := t and not (1 shl b);
      end;

    Procedure ResetLbit(Var n: LongInt; b: Byte);
      begin
        if b < 32 then
          n := n and not (LongInt(1) shl b);
      end;

    Function right(Var s; n : Byte): String;
      Var
        st : String Absolute s;
        len: Byte Absolute s;
      begin
        if n >= len then right := st else
        right := copy(st,len+1-n,n);
      end;

    Function shleft(Var s; n : Byte): String;
      Var
        st   : String Absolute s;
        stlen: Byte Absolute s;
        temp : String;
        len  : Byte Absolute temp;
      begin
        if n < stlen then begin
          move(st[n+1],temp[1],255);
          len := stlen - n;
          shleft := temp;
        end;
      end;

    Function left(Var s; n : Byte): String;
      Var
        st  : String Absolute s;
        temp: String;
        len : Byte Absolute temp;
      begin
        temp := st;
        if n < len then len := n;
        left := temp;
      end;

    Function nExtStr(Var s1;s2 : String; n : Byte): String;
      Var
        main   : String Absolute s1;
        second : String Absolute s2;
        len    : Byte Absolute s2;
      begin
        nExtStr := copy(main,pos(second,main)+len,n);
      end;

    Procedure WriteAtCr(st: String; col,row: Byte);
      begin
        GotoXY(col,row);
        Write(st);
      end;

    Procedure WriteLnAtCr(st: String; col,row: Byte);
      begin
        GotoXY(col,row);
        Writeln(st);
      end;

    Function Charstr(ch : Char; by : Byte) : String;
    Var
      Str : String;
      Count : Integer;
    begin
      Str := '';
      For Count := 1 to by do
        Str := Str + ch;
      CharStr := Str;
    end;

    Procedure WriteLnCenter(st: String; width: Byte);
      begin
        TempStr := CharStr(' ',(width div 2) - succ((length(st) div 2)));
        st      := TempStr + st;
        Writeln(st);
      end;

    Procedure WriteCenter(st: String; width: Byte);
      begin
        TempStr := CharStr(' ',(width div 2)-succ((length(st) div 2)));
        st      := TempStr + st;
        Write(st);
      end;

    Procedure GotoCR(col,row: Byte);
      begin
        GotoXY(col,row);
      end;

    Function Exist(fn : String): Boolean;
      Var
        f         : File;
        OldMode   : Byte;
      begin
        OldMode := FileMode;
        FileMode:= 0;
        assign(f,fn);
        {$I-}  reset(f,1); {$I+}
        if Ioresult = 0 then begin
          close(f);
          Exist := True;
        end
        else
          Exist := False;
        FileMode:= OldMode;
      end; {-Exist}

    Function Asc2Str(Var s; max: Byte): String;
      Var stArray : Array[0..255] of Byte Absolute s;
          st      : String;
          len     : Byte Absolute st;
      begin
        move(stArray[0],st[1],255);
        len := max;
        len := (max + Word(1)) * ord(pos(#0,st) = 0) + pos(#0,st)-1;
        Asc2Str := st;
      end;

    Procedure DisableBlink(state : Boolean);
       { DisableBlink(True) allows use of upper eight colors as background }
       { colours. DisableBlink(False) restores the normal mode and should  }
       { be called beFore Program Exit                                     }
    Var
       regs : Registers;
    begin
      With regs do
      begin
        ax := $1003;
        bl := ord(not(state));
      end;
      intr($10,regs);
    end;  { DisableBlink }

    Function Byte2Hex(numb : Byte) : String;
      begin
        Byte2Hex[0] := #2;
        Byte2Hex[1] := HexChars[numb shr  4];
        Byte2Hex[2] := HexChars[numb and 15];
      end;

    Function Numb2Hex(Var numb) : String;
      { converts an Integer or a Word to a String. Using an unTyped
        argument makes this possible. }
      Var n : Word Absolute numb;
      begin
        Numb2Hex := Byte2Hex(hi(n))+Byte2Hex(lo(n));
      end;

    Function Long2Hex(long : LongInt): String;
      begin
        With LongWds(long) do { Type casting makes the split up easy}
          Long2Hex := Numb2Hex(hiWord) + Numb2Hex(loWord);
      end;

    Function Hex2Byte(HexStr : String) : Byte;
      begin
        Hex2Byte := pos(UpCase(HexStr[2]),HexChars)-1  +
                   ((pos(UpCase(HexStr[1]),HexChars))-1) shl  4 { *  16}
      end;

    Function Hex2Word(HexStr : String) : Word;
      { This requires that the String passed is a True hex String  of 4
        Chars and not in a Format like $FDE0 }
      begin
        Hex2Word := pos(UpCase(HexStr[4]),HexChars)-1  +
                   ((pos(UpCase(HexStr[3]),HexChars))-1) shl  4 + { *  16}
                   ((pos(UpCase(HexStr[2]),HexChars))-1) shl  8 + { * 256}
                   ((pos(UpCase(HexStr[1]),HexChars))-1) shl 12;  { *4096}
      end;

    Function Hex2Integer(HexStr : String) : Integer;
      begin
        Hex2Integer := Integer(Hex2Word(HexStr));
      end;

    Function Hex2Long(HexStr : String) : LongInt;
      Var Long : LongWds;
      begin
        Long.hiWord := Hex2Word(copy(HexStr,1,4));
        Long.loWord := Hex2Word(copy(HexStr,5,4));
        Hex2Long := LongInt(Long);
      end;

    begin
      FilePosition := 0;
    end.

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