Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/MADTRB11.ZIP/SHEETLIB.INC

Text File | 1985-11-28 | 7.8 KB | 434 lines

procedure incr(var i : integer);

begin
  i := i + 1;
end;




procedure get_screen(var buffer : imagetype);

begin
    if crtmode = 7 then buffer := monobuffer else
            buffer := colorbuffer;
end;



procedure put_screen(var buffer : imagetype);

begin
    if crtmode = 7 then monobuffer := buffer else
            colorbuffer := buffer;
end;



procedure decr(var i : integer);

begin
  i := i - 1;
end;





procedure init_var;


var
  i : integer;


begin
  wp_index := 0;
  escape := #27;
  retrn  := #13;
  up     := #9;
  down   := #10;
  left   := #11;
  right  := #12;
  home   := #14;
  endd   := #15;
  pgup   := #16;
  pgdn   := #17;
  f1     := #1;
  f2     := #2;
  f3     := #3;
  f4     := #4;
  f5     := #5;
  f6     := #6;
  f7     := #7;
  f8     := #8;
  sheet_corn[0] := 13;
  sheet_corn[1] :=  2;
  sheet_corn[2] := 77;
  sheet_corn[3] := 11;
  graph_corn[0] :=  2;
  graph_corn[1] := 13;
  graph_corn[2] := 75;
  graph_corn[3] := 24;
  rp_mode       := false;
  for i := 0 to 1 do
    begin
      range.top[i] := 0;
      range.bottom[i] := 0;
    end;
  point_mode    := o;
  scale := 0;
  ar_sz := 0;
end;   { procedure init_var }








procedure putcharv(x,y : integer; ch : char);
begin
    if crtmode = 7 then
      begin
         monobuffer[y,x,char_byte] := ch;
         monobuffer[y,x,attr_byte] := chr(112);
      end
    else
      begin
         colorbuffer[y,x,char_byte] := ch;
         colorbuffer[y,x,attr_byte] := chr(112);
      end;
end;


procedure putchar(x,y : integer; ch : char);
begin
    if crtmode = 7 then
      begin
         monobuffer[y,x,char_byte] := ch;
         monobuffer[y,x,attr_byte] := chr(7);
      end
    else
      begin
         colorbuffer[y,x,char_byte] := ch;
         colorbuffer[y,x,attr_byte] := chr(7);
      end;
end;





PROCEDURE PUTSTRING(xcoord, ycoord : integer;s :lst);

var
  i :integer;

begin
  for i := 1 to length(s) do putchar((xcoord + i - 1), ycoord,s[i]);
end;   { PUTSTRING }

PROCEDURE PUTSTRINGv(xcoord, ycoord : integer;s :lst);

var
  i :integer;

begin
  for i := 1 to length(s) do putcharv((xcoord + i - 1), ycoord,s[i]);
end;   { PUTSTRING }




PROCEDURE INVERSE;
 { sets current screen attribute (used by PUTSTRING) to inverse status }

BEGIN


   textcolor(black);
   textbackground(white);

END;   { inverse }





PROCEDURE NORMAL;
 { sets the current screen attribute (used by PUTSTRING) to normal status }

BEGIN


   textcolor(white);
   textbackground(black);

END;   { normal }



PROCEDURE DRAWBOX(col, line, horiz, vert : integer);

VAR
   I                    : INTEGER;
   S                    : LST;
   ul,ur,ll,lr,h,v      : char;

BEGIN  { DRAWBOX }

   UL := CHR(218); {┌}
   UR := CHR(191); {┐}
   LL := CHR(192); {└}
   LR := CHR(217); {┘ }
   H  := CHR(196); {─ }
   V  := CHR(179); {│ }



   s := '';
   for i := 1 to horiz do s:= concat(s,h);

   s := concat(ul,s,ur);
   putstring(col,line,s);


    { DRAW RIGHT VERTICAL LINE }
   FOR I := 1 TO (VERT + 1) DO
        begin
          putchar(col,(line + i),v);
          putchar((col + horiz + 1),(line + i),v);
        end;


    { DRAW BOTTOM LINE }

   s := '';
   for i := 1 to horiz do s:= concat(s,h);

   s := concat(ll,s,lr);
   putstring(col,(line + vert + 1),s);


END;   { DRAWBOX }





procedure put_box(text1, text2:lst);

const
   maxlength  = 75;

begin
  drawbox(0,20,77,2);
  if (length(text1) > maxlength) then text1 := copy(text1,1,75);
  if (length(text2) > maxlength) then text2 :=  copy(text2,1,75);
  putstring(2,21,text1);
  putstring(2,22,text2);
end;  { put_box }





PROCEDURE   SET_CURSOR_TYPE  (var start: byte; var  stop : byte);
{ use byte type as parameter so number is straight binary }

var
  recpack : regpack;

begin

 with recpack do
  begin
    ax := 1 shl 8;   { set cursor type call }
    cx := start shl 8 + stop;  { start goes into bits 4-0 of CH }
  end;

  intr($10,recpack);
end;   { set_cursor_type }






PROCEDURE   CURRENT_VIDEO_STATE
       (var page  : byte;     { parameter is modified }
        var mode  : byte;     { parameter is modified }
        var width : byte);    { parameter is modified }

var
  recpack : regpack;

begin
  with recpack do ax := 15 shl 8; {  video state request }
  intr($10,recpack);              {  int hex 10 is video services }
  with recpack do
    begin
      mode :=  ax; { actually in AL }
      width := swap(ax);  { AH }
      page  := swap(bx);  { BH }
    end;
end;   { current_video_state }









PROCEDURE RESET_CURSOR;                           { internal to SAFELIB.IMP }

 { turns cursor back to underline }

VAR
   PAGE,MODE,WIDTH,START,STOP : byte;

BEGIN  { reset_cursor }

CURRENT_VIDEO_STATE(PAGE,MODE,WIDTH); { find out what kind of monitor this is }

IF MODE = 7 THEN BEGIN                { monochrome }
   START := 12;
   STOP := 13;
END
ELSE BEGIN
   START := 7;
   STOP := 7;
END;  (* if *)
SET_CURSOR_TYPE(START,STOP);

END;   { reset_cursor }

PROCEDURE SET_CURSOR;                           { internal to SAFELIB.IMP }

 { turns cursor into large white block }

VAR
   PAGE,MODE,WIDTH,START,STOP : byte;

BEGIN  { set_cursor }

CURRENT_VIDEO_STATE(PAGE,MODE,WIDTH); { find out what kind of monitor this is }
START := 0;                           { cursor_start will be top line }
IF MODE = 7 THEN STOP := 13           { if monochrome, last line is 13 }
ELSE STOP := 7;                       { else color or graphice, last line = 7 }
SET_CURSOR_TYPE(START,STOP);          { set it }

END;   { set_cursor }




procedure zero_cursor;

var
  a,b : byte;

begin
  reset_cursor;
end;   { zereo_cursor }




function getchar(okset : setofchar; cursoron : boolean): char;


const
   prefix = #0;   { Turbo's version of chr(0) }
   BELL   = #7;


var
  ch : char;
  good   : boolean;


function getchar_detail:char;   {does the DOS call }

  type
   regpack = record
              ax,bx,cx,dx,bp,si,ds,es,flags: integer;
            end;

  var
   recpack : regpack;

  begin
     recpack.ax := $07 shl 8;
     { puts the Hex 07 call (KB input) into AH }
     MsDos(recpack);
     getchar_detail := chr(lo(recpack.ax));
     { keystroke is returned in AL -- this seems to read it ok }

  end;  { getchar_detail }


begin
  if (cursoron) then set_cursor;


  REPEAT
   ch := getchar_detail;
   IF CH = PREFIX THEN BEGIN     { prefixed key }
      ch := getchar_detail; { get next key that is sitting there }
      CASE ORD(CH) OF
         75 : ch := LEFT;
         77 : CH := RIGHT;
         72 : CH := UP;
         80 : CH := DOWN;
         59 : ch := f1;
         60 : ch := f2;
         61 : ch := f3;   {á}
         62 : ch := f4;   { í }
         63 : ch := f5;   { ó }
         64 : ch := f6;
         65 : ch := f7;
         66 : ch := f8;
{        68 : ch := f10;    }
         71 : ch := home;
         73 : ch := pgup;
         79 : ch := endd;
{        81 : ch := pgdn;
         84 : ch := f11;
         85 : ch := f12;
         86 : ch := f13;
         87 : ch := f14;
         88 : ch := f15;
}
         else CH := CHR(0);
      END;  { case }
   END;  { if }

  good := ch in okset;
  if not good then write(bell)
  else if (ord(ch) >= 32) and (cursoron) then write(ch);

UNTIL good;

getchar := ch;
  if (cursoron) then
reset_cursor;

end; { function getchar }


                                    { PC Specific }

{  function str2real(str:numstr):real

     begin end;
}