Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TMODEM.ZIP/BASIC.INC

Text File | 1987-06-15 | 6.6 KB | 268 lines

(****************************************************************************)
(*               BASIC Functions Programmed in Turbo PASCAL.                *)
(****************************************************************************)


(****************************************************************************)
(*                              INKEY$                                      *)
(****************************************************************************)
type
   kbdtype = string[2];
function
   inkey : kbdtype;
var
   a     : string[2];
   ch    : char;
begin
   if keypressed then begin
      read(kbd,ch);
      a := ch;
      if ch = #27 then begin
         read(kbd,ch);
         a := concat(a,ch);
      end;
   end
   else
      a := '';
   inkey := a;
end;

(****************************************************************************)
(*                               STRING$                                    *)
(****************************************************************************)
function
   bstring( n : integer; x : char ) : strtype;
var
   j    : integer;
   y    : strtype;
begin
   y[0] := chr(n);
   for j:=1 to n do y[j]:=x;
   bstring := y;
end;

(****************************************************************************)
(*                                  VAL                                     *)
(****************************************************************************)
function
   bval( x : strtype ) : integer;
var
   i,j,err,a : integer;
begin
   a := 0;
   if length(x) > 0 then begin
      i := 1;
      while x[i] = ' ' do i := i+1;
      j := length(x)-i+1;
      val(copy(x,i,j),a,err);
      if err > 1 then begin
         j := err-1;
         val(copy(x,i,j),a,err);
      end;
   end;
   bval := a;
end;

(****************************************************************************)
(*                                   HEX$                                   *)
(****************************************************************************)
function
   hex( n : integer ) : strtype;
type
   hexdigits  = 0..15;
   hexarray   = array[hexdigits] of char;
const
   hextab : hexarray = ('0','1','2','3','4','5','6','7',
                        '8','9','A','B','C','D','E','F');
var
   a      : string[4];
   i,x    : integer;
begin
   x := n;
   for i:=1 to 4 do begin
      a := concat(hextab[x and $000F],a);
      x := x shr 4;
   end;
   hex := a;
end;

(****************************************************************************)
(*                               INPUT                                      *)
(****************************************************************************)
procedure
   input(var s : strtype);
var
   ix,iy,ip    : byte;
   ins_mode    : boolean;
   ich         : kbdtype;

   procedure
      shape_cursor(st,en : integer);
   type
      registerpack = record
                        AX,BX,CX,DX,BP,DI,SE,DS,ES,Flags : integer;
                     end;
   var
      reg          : registerpack;
      crtmode      : byte absolute $0040:$0049;
   begin
      if crtmode = 7 then begin
         st := st + 5;
         en := en + 5;
      end;
      reg.AX := $0100;
      reg.CX := (st shl 8) + en;
      intr($10,reg);
   end;

   procedure
      end_of_line(s : strtype);
   begin
      ix:=wherex+length(s)-ip+1;
      ip:=length(s)+1;
      gotoxy(ix,iy);
   end;

   procedure
      left_arrow;
   begin
      if ip>1 then begin
         ip:=ip-1;
         ix:=wherex-1;
         gotoxy(ix,iy);
      end;
   end;

   procedure
      right_arrow(s : strtype);
   begin
      if ip<=length(s) then begin
         ip:=ip+1;
         ix:=wherex+1;
         gotoxy(ix,iy);
      end;
   end;

   procedure
      del_char(var s : strtype);
   var
      i      : byte;
   begin
      if length(s)>0 then begin
         if ip<=length(s) then begin
            delete(s,ip,1);
            ix:=wherex;
            for i:=ip to length(s) do write(s[i]);
            write(' ');
            gotoxy(ix,iy);
         end
         else begin
            ix:=wherex-1;
            ip:=ip-1;
            gotoxy(ix,iy);
         end;
      end;
   end;

   procedure
      del_pre_char(var s : strtype);
   begin
      if ip>1 then begin
         ip:=ip-1;
         ix:=wherex-1;
         gotoxy(ix,iy);
         del_char(s);
      end;
   end;

   procedure
      process_change(var s : strtype);
   var
      i     : byte;
   begin
      case ich[1] of
         #210 : begin
                   ins_mode := true;
                   shape_cursor(1,7);
                end;
         ^M   : ;
         #207 : end_of_line(s);
         #211 : del_char(s);
         ^H   : del_pre_char(s);
         #205 : right_arrow(s);
         #203 : left_arrow;
      else
         if ip<=length(s) then
            s[ip] := ich
         else
            s := s+ich;
         ip:=ip+1;
         write(ich);
      end;
   end;

   procedure
      process_insert(var s : strtype);
   var
      i            : byte;
   begin
      case ich[1] of
         #210 : begin
                   ins_mode := false;
                   shape_cursor(6,7);
                end;
         ^M   : ;
         #207 : end_of_line(s);
         #211 : del_char(s);
         ^H   : del_pre_char(s);
         #205 : right_arrow(s);
         #203 : left_arrow;
      else
         if ip>length(s) then begin
            ip:=ip+1;
            s:=s+ich;
            write(ich);
         end
         else begin
            insert(ich,s,ip);
            ix:=wherex+1;
            for i:=ip to length(s) do write(s[i]);
            ip:=ip+1;
            gotoxy(ix,iy);
         end;
      end;
   end;

begin
   ip:=1;
   iy:=wherey;
   ins_mode:=false;
   repeat
      ich:=inkey;
   until ich <> '';
   repeat
      if length(ich)=2 then ich:=chr(ord(ich[2])+128);
      if ins_mode then
         process_insert(s)
      else
         process_change(s);
      if ich <> ^M then begin
         repeat
            ich:=inkey;
         until ich <> '';
      end;
   until ich = ^M;
   shape_cursor(6,7);
end;

(****************************************************************************)
(*                               UP CASE STRING                             *)
(****************************************************************************)
   procedure
      upstring( var s : strtype );
   var
      i   : integer;
   begin
      for i:=1 to length( s ) do
         s[i] := upcase( s[i] );
   end;