Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/INTR_DMO.ZIP/PLS-UTIL.INC

Text File | 1985-10-01 | 5.6 KB | 199 lines

{ PLS-UTIL.INC  Miscelaneous global subprograms }

{ Forward declaration of error handling routines which use some of the
  routines in the STD-UTIL.INC file and are also used by some of these
  routines. The formal definition of these forward declared procedures
  is in the STD-DISP.INC Include file, which must be included at some
  point following STD-UTIL.INC. }

    procedure Disp_IO_Error(device_name: File_ID); forward;

    procedure Disp_Error_Msg(err_msg: Str_80); forward;

type  NoteRecord = record
                     C,CF,D,DF,E,F,FF,G,GF,A,AF,B: integer;
                   end;

const  NOTES : NoteRecord =
               (C:1;CF:2;D:3;DF:4;E:5;F:6;FF:7;G:8;GF:9;A:10;AF:11;B:12);

    procedure Play(note,duration: integer);

      var  frequency : real;
           i         : integer;
      begin
        frequency := 522;              { Middle C                        }
        for i := 1 to Note - 1 do      { Increase frequency Note-1 times }
        frequency := frequency * 1.059463094;
        Sound(Round(frequency));
        Delay(duration);
        NoSound;
      end; { Play }

    procedure Beep;

      var  i: integer;
      begin
        for i := 1 to 2 do
          with Notes do
          begin
            Play(G,50);
            Play(D,50);
          end;
      end; { Beep }

    function Fgnd(attr: Byte): Integer;
      begin
        Fgnd := (attr and $0F) + ((attr and $80) div 8);
      end { Fgnd };

    function Bgnd(attr: Byte): Integer;
      begin
        Bgnd := (attr and $70) div $10;
      end { Bgnd };

    function Null_Date(cmp_date: Byte_Date): Boolean;
      begin
        with cmp_date do
        Null_Date := ((month = ZERO) and (day = ZERO)) and (year = ZERO);
      end; { Null_Date }

    function Ok: Boolean;
      begin
        Ok := (io_status = ZERO);
      end; { Ok }

    procedure Usr_Out_Driver(out_chr: Char);
      var vid_char : PC_Char;

      begin
        vid_char.attribute := vid_attr; vid_char.character := out_chr;
        vid_chr[cur_pos] := vid_char;
        cur_pos := Succ(cur_pos);
      end; { Usr_Out_Driver }

    procedure GoTo_XY(col, row: Integer);         { Used to position }
      begin                                       { cur_pos for output }
        GoToXY(col,row);
        col := Pred(col) mod MAX_COL;
        row := Pred(row) mod MAX_ROW;
        cur_pos := (row * MAX_COL + col + 1);     { Calculate cur_pos as }
      end; { GoTo_XY }                            { offset into video RAM }

    procedure Repeat_Char(character : Char;     { Character to be output.    }
                          count     : Integer); { Number of times to output. }
      var i     : Integer;

      begin
        for i := 1 to count do
           Write(character);
      end; { Repeat_Char }

    procedure Repeat_Usr_Char(character : Char;
                              count     : Integer);
      var i     : Integer;

      begin
        for i := 1 to count do
           Write(Usr,character);
      end; { Repeat_Char }

    procedure Write_Usr_Str(out_str: Str_255);
      var i : Integer;
      begin
        for i := 1 to Length(out_str) do  { Outputs out_str via the }
           Write(Usr,out_str[i]);         { Usr output device       }
      end; { Write_Usr_Str }

    procedure Strip_Trailing(len : Byte);

      begin
        inp_str[0] := Chr(0);       { Set inp_str length to ZERO }
        while (inp_str[len] in [#0..SPACE,FILL_CHAR]) and (len > ZERO) do
          len := Pred(len);
        inp_str[0] := Chr(len);     { Set inp_str length to len }
      end; { Strip_Trailing }

    procedure Strip_Leading(len : Byte);

      var  i         : Byte;

      begin
        i := 1;
        While (inp_str[i] in [#0..SPACE,FILL_CHAR]) and (i <= len) do
          i := Succ(i);
        inp_str := Copy(inp_str,i,len);
      end; { Strip_Leading }

    procedure Strip_Inp_Str(len : Byte);

      begin
        Strip_Trailing(len);
        Strip_Leading(len);
      end; { Strip_Inp_Str }

  function Upper_Case(str: Str_80): Str_80;
      var  i  : Byte;
      begin
        for i := 1 to length(str) do
            str[i] := UpCase(str[i]);
        Upper_Case := str;
      end { Upper_Case };

  function Exist(file_name: File_ID): Boolean;
    var chk_file  : File;

    begin
      Assign(chk_file,file_name);
{$I-} Reset(chk_file); {$I+}
      Exist := (IOresult = ZERO);
      Close(chk_file);
    end; { Exist }

  procedure Clr_Kbd_Buf;
    var kbd_head  : Byte absolute $0000:$041A;
    var kbd_tail  : Byte absolute $0000:$041C;

    begin
      kbd_head := kbd_tail;
    end; { Clr_Kbd_Buf }

  procedure Get_System_Date;
    var ms_reg  : record
                    ax,bx,cx,dx,bp,si,di,ds,es,flags : Integer;
                  end;
        num_str : Str_5;

    begin
      with ms_reg do
      begin
        ax := $2A00;
        Intr($21,ms_reg);
        Str(Hi(dx):2,num_str);
        sys_date := num_str + '/';
        Str(Lo(dx):2,num_str);
        sys_date := sys_date + num_str + '/';
        Str(cx:4,num_str);
        sys_date := sys_date + num_str;
        for i := 1 to 4 do
          if (sys_date[i] = SPACE) then
            sys_date[i] := '0';
      end; {with}
    end; { Get_System_Date }

  procedure Chain_To(file_name: File_ID);
    var chain_file : File;

    begin
      if Exist(file_name) then
        begin
          Assign(chain_file,file_name);
          chain(chain_file);
        end
      else
        begin
          io_status := $22;
          Disp_IO_Error(file_name);
        end;
    end; { Chain_To }