home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TM40.ZIP / BASIC.INC next >
Encoding:
Text File  |  1985-07-20  |  7.6 KB  |  312 lines
  1. (****************************************************************************)
  2. (*               BASIC Functions Programmed in Turbo PASCAL.                *)
  3. (****************************************************************************)
  4.  
  5.  
  6. (****************************************************************************)
  7. (*                              INKEY$                                      *)
  8. (****************************************************************************)
  9. type
  10.    kbdtype = string[2];
  11. function
  12.    inkey : kbdtype;
  13. var
  14.    a     : string[2];
  15.    ch    : char;
  16. begin
  17.    if keypressed then begin
  18.       read(kbd,ch);
  19.       a := ch;
  20.       if keypressed and (ch = #27) then begin
  21.          read(kbd,ch);
  22.          a := concat(a,ch);
  23.       end;
  24.    end
  25.    else
  26.       a := '';
  27.    inkey := a;
  28. end;
  29.  
  30. (****************************************************************************)
  31. (*                               STRING$                                    *)
  32. (****************************************************************************)
  33. function
  34.    bstring( n : integer; x : char ) : strtype;
  35. var
  36.    j    : integer;
  37.    y    : strtype;
  38. begin
  39.    y[0] := chr(n);
  40.    for j:=1 to n do y[j]:=x;
  41.    bstring := y;
  42. end;
  43.  
  44. (****************************************************************************)
  45. (*                                  VAL                                     *)
  46. (****************************************************************************)
  47. function
  48.    bval( x : strtype ) : integer;
  49. var
  50.    i,j,err,a : integer;
  51. begin
  52.    a := 0;
  53.    if length(x) > 0 then begin
  54.       i := 1;
  55.       while x[i] = ' ' do i := succ(i);
  56.       j := length(x) - pred(i);
  57.       val(copy(x,i,j),a,err);
  58.       if err > 1 then begin
  59.          j := pred(err);
  60.          val(copy(x,i,j),a,err);
  61.       end;
  62.    end;
  63.    bval := a;
  64. end;
  65.  
  66. (****************************************************************************)
  67. (*                                   HEX$                                   *)
  68. (****************************************************************************)
  69. function
  70.    hex( n : integer ) : strtype;
  71. type
  72.    hexdigits  = 0..15;
  73.    hexarray   = array[hexdigits] of char;
  74. const
  75.    hextab : hexarray = ('0','1','2','3','4','5','6','7',
  76.                         '8','9','A','B','C','D','E','F');
  77. var
  78.    a      : string[4];
  79.    i,x    : integer;
  80. begin
  81.    x := n;
  82.    for i:=1 to 4 do begin
  83.       a := concat(hextab[x and $000F],a);
  84.       x := x shr 4;
  85.    end;
  86.    hex := a;
  87. end;
  88.  
  89. (****************************************************************************)
  90. (*                               INPUT                                      *)
  91. (****************************************************************************)
  92. procedure
  93.    shape_cursor(st,en : integer);
  94. type
  95.    registerpack = record
  96.                      AX,BX,CX,DX,BP,DI,SE,DS,ES,Flags : integer;
  97.                   end;
  98. var
  99.    reg          : registerpack;
  100.    crtmode      : byte absolute $0040:$0049;
  101. begin
  102.    curr_bscan := st;
  103.    curr_sscan := en;
  104.    if crtmode = 7 then begin
  105.       st := st + 5;
  106.       en := en + 5;
  107.    end;
  108.    reg.AX := $0100;
  109.    reg.CX := (st shl 8) + en;
  110.    intr($10,reg);
  111. end;
  112.  
  113. procedure
  114.    str_input(var s : strtype);
  115. var
  116.    ix,iy,ip,hx : byte;
  117.    ins_mode    : boolean;
  118.    ich         : kbdtype;
  119.  
  120.    procedure
  121.       end_of_line(s : strtype);
  122.    begin
  123.       ix:=wherex + length(s) - pred(ip);
  124.       ip:=length(s)+1;
  125.       gotoxy(ix,iy);
  126.    end;
  127.  
  128.    procedure
  129.       top_of_line;
  130.    begin
  131.       ip:=1;
  132.       gotoxy(hx,iy);
  133.    end;
  134.  
  135.    procedure
  136.       left_arrow;
  137.    begin
  138.       if ip>1 then begin
  139.          ip:=pred(ip);
  140.          ix:=pred(wherex);
  141.          gotoxy(ix,iy);
  142.       end;
  143.    end;
  144.  
  145.    procedure
  146.       right_arrow(s : strtype);
  147.    begin
  148.       if ip<=length(s) then begin
  149.          ip:=succ(ip);
  150.          ix:=succ(wherex);
  151.          gotoxy(ix,iy);
  152.       end;
  153.    end;
  154.  
  155.    procedure
  156.       del_char(var s : strtype);
  157.    var
  158.       i      : byte;
  159.    begin
  160.       if length(s)>0 then begin
  161.          if ip<=length(s) then begin
  162.             delete(s,ip,1);
  163.             ix:=wherex;
  164.             for i:=ip to length(s) do write(s[i]);
  165.             write(' ');
  166.             gotoxy(ix,iy);
  167.          end
  168.          else begin
  169.             ix:=pred(wherex);
  170.             ip:=pred(ip);
  171.             gotoxy(ix,iy);
  172.          end;
  173.       end;
  174.    end;
  175.  
  176.    procedure
  177.       erase_to_end(var s : strtype);
  178.    begin
  179.       while ip <= length(s) do del_char( s );
  180.    end;
  181.  
  182.    procedure
  183.       del_pre_char(var s : strtype);
  184.    begin
  185.       if ip>1 then begin
  186.          ip:=pred(ip);
  187.          ix:=pred(wherex);
  188.          gotoxy(ix,iy);
  189.          del_char(s);
  190.       end;
  191.    end;
  192.  
  193.    procedure
  194.       process_change(var s : strtype);
  195.    var
  196.       i     : byte;
  197.    begin
  198.       case ich[1] of
  199.          #210 : begin
  200.                    ins_mode := true;
  201.                    shape_cursor(1,7);
  202.                 end;
  203.          ^M   : ;
  204.          #199 : top_of_line;
  205.          #245 : erase_to_end(s);
  206.          #207 : end_of_line(s);
  207.          #211 : del_char(s);
  208.          ^H   : del_pre_char(s);
  209.          #205 : right_arrow(s);
  210.          #203 : left_arrow;
  211.       else
  212.          if ip<=length(s) then
  213.             s[ip] := ich
  214.          else
  215.             s := s+ich;
  216.          ip:=succ(ip);
  217.          write(ich);
  218.       end;
  219.    end;
  220.  
  221.    procedure
  222.       process_insert(var s : strtype);
  223.    var
  224.       i            : byte;
  225.    begin
  226.       case ich[1] of
  227.          #210 : begin
  228.                    ins_mode := false;
  229.                    shape_cursor(6,7);
  230.                 end;
  231.          ^M   : ;
  232.          #199 : top_of_line;
  233.          #245 : erase_to_end(s);
  234.          #207 : end_of_line(s);
  235.          #211 : del_char(s);
  236.          ^H   : del_pre_char(s);
  237.          #205 : right_arrow(s);
  238.          #203 : left_arrow;
  239.       else
  240.          if ip>length(s) then begin
  241.             ip:=succ(ip);
  242.             s:=s+ich;
  243.             write(ich);
  244.          end
  245.          else begin
  246.             insert(ich,s,ip);
  247.             ix:=succ(wherex);
  248.             for i:=ip to length(s) do write(s[i]);
  249.             ip:=succ(ip);
  250.             gotoxy(ix,iy);
  251.          end;
  252.       end;
  253.    end;
  254.  
  255. begin
  256.    ip:=1;
  257.    iy:=wherey;
  258.    hx:=wherex;
  259.    ins_mode:=false;
  260.    repeat
  261.       ich:=inkey;
  262.    until ich <> '';
  263.    repeat
  264.       if length(ich)=2 then ich:=chr(ord(ich[2])+128);
  265.       if ins_mode then
  266.          process_insert(s)
  267.       else
  268.          process_change(s);
  269.       if ich <> ^M then begin
  270.          repeat
  271.             ich:=inkey;
  272.          until ich <> '';
  273.       end;
  274.    until ich = ^M;
  275.    shape_cursor(6,7);
  276. end;
  277.  
  278. procedure
  279.    num_input( var i : integer );
  280. var
  281.    numstr : string10;
  282. begin
  283.    str(i,numstr);
  284.    str_input(numstr);
  285.    i:=bval(numstr);
  286. end;
  287.  
  288. (****************************************************************************)
  289. (*                               UP CASE STRING                             *)
  290. (****************************************************************************)
  291. procedure
  292.    upstring( var s : strtype );
  293. var
  294.    i   : integer;
  295. begin
  296.    for i:=1 to length( s ) do
  297.       s[i] := upcase( s[i] );
  298. end;
  299.  
  300. (****************************************************************************)
  301. (*                      DETERMINE MEMORY AVAILABLE                          *)
  302. (****************************************************************************)
  303. function
  304.    memory   : integer;
  305. var
  306.    memspace : real;
  307. begin
  308.    memspace := maxavail;
  309.    if memspace < 0 then
  310.       memspace := 65536.0 + memspace;
  311.    memory := round( (memspace * 16.0) / 1024.0 );
  312. end;