Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PRMASTR3.ZIP/IO.PAS

Pascal/Delphi Source File | 1990-01-22 | 23.0 KB | 950 lines

{$F+}
{
   "Created using Turbo Pascal, copyright (c) Borland International
   1987, 1988."      Turbo Pascal 5.5
}
UNIT IO;

INTERFACE

USES DOS,CRT;

CONST
  ScreenX = 80;
  ScreenY = 25;
  VideoBufferSize = ScreenX*ScreenY;  { E.g., 25 X 80 = 2000 words }

TYPE
  wrdptr        = ^word;
  window_action = Procedure;
  menuitemptr   = ^menuitem;
  Menuitem      = record
                    itemlabel      : string;
                    proc           : window_action;
                    prev,
                    next           : menuitemptr;
                  end;

  windaptr = ^winda;
  winda    = object
               x1,y1,x2,y2    : integer;
               oldwindowmin,
               oldwindowmax   : word;
               oldx,oldy      : byte;
               screenvar      : pointer;
               title          : string;
               ta,fg,bg       : word;
               constructor init(a,b,c,d:integer;t:string;a1,a2,a3:word);
               destructor done;virtual;
               Procedure storescreen;
               Procedure restorescreen;
             end;

  popptr   = ^pop;
  pop      = object(winda)
               msg:string;
               constructor init(a,b,c,d:integer;t,s:string;a1,a2,a3:word);
               Procedure showit;virtual;
               destructor done;virtual;
             end;

  popfetchptr = ^popfetch;
  popfetch    = object(winda)
                 msg:string;
                 constructor init(a,b,c,d:integer;t,s:string;a1,a2,a3:word);
                 Function fetchit:string;virtual;
                 destructor done;virtual;
                end;

  menuptr2    = ^menu;
  menu        = object(winda)
                  current,item   : menuitemptr;
                  maxwidth,
                  itemcount      : integer;
                  constructor init(a,b,c,d:integer;t:string;a1,a2,a3:word);
                  destructor done;virtual;
                  Procedure add2menu(labelname:string;procname:window_action);
                  Procedure nukethelist;
                  Procedure pickmenu;virtual;
                end;
Var
  alert,
  stimulus,
  quit,
  up1level           : boolean;
  global_choice      : integer;
  XSave,
  YSave              : Integer;
  SavePtr,
  VideoPtr           : wrdptr;
  VideoSeg           : Word;
  left_mkey_pressed,
  center_mkey_pressed, {works for 3 button logitech.....}
  right_mkey_pressed,
  islogitech,
  mouse_exists,
  mkeypressed        : boolean;
  numkeys,
  whichmkey,
  mousex,
  mousey             :integer;

Procedure whooop(low,high,increment,del:integer);
Function  MONOCHROME : Boolean;
Procedure CURSORON;
Procedure CURSOROFF;
Procedure WAITFORKEY;

Procedure Writeat(a,c,r:integer;s:string);
Procedure waitforaction;
Procedure mouseinit;
Procedure showmouse;
Procedure unshowmouse;
Procedure mouseinfo;
Procedure putatxy(x,y:integer);
Procedure mouse_window(x1,y1,x2,y2:integer);
Procedure id;
Procedure setsensitivity(horizon,vertic,doub:integer);
Procedure getsensitivity(Var horiz,vert,double:integer);
Function HeapFunc(size:word):integer;

IMPLEMENTATION

var
  startscanline,
  endscanline     : byte;

Function HeapFunc(size:word):integer;   {out of memory...}
begin
  window(1,1,80,25);
  clrscr;
  writeln('You are out of memory.');
  writeln('Program will halt.');
  halt;
  heapfunc:=1;
end;

Procedure whooop(low,high,increment,del:integer);
Var q:integer;
begin
  q:=low;
  while q < high+1 do
    begin
      sound(q);
      delay(del);
      q:=q+increment;
    end;
  nosound;
end;

{*********************************************************************}
{ This function will be true if the video adapter is a monochrom video}
{ adapter and false if any other adapter is in place.  This is used   }
{ by other functions to determine where video ram is.                 }

function monochrome : Boolean;
var
  Regs : Registers;
begin
  intr($11,Regs);                   {get equipment status word}
  if (Regs.AX AND $0030) = $30 then {are bit 4-5 = 11?}
    monochrome := True
  else
    monochrome := False;
end;

{*********************************************************************}
{ This procedure will turn the cursor on (after a call to CURSOROFF)  }

procedure cursoron;
var regs   : registers;
begin
  regs.ax:=$0100;
  regs.ch:=startscanline;
  regs.cl:=endscanline;
  intr($10,regs);                  {set cursor scan lines}
end;


{*********************************************************************}
{ This procedure will turn the cursor off.                            }

procedure cursoroff;
VAR Regs : Registers;
    active_page:byte;
begin
 regs.ah:=$0F;          {we need current video page}
 intr($10,regs);
 active_page:=regs.bh;

 regs.ah:=$03;          {determine cursor scan lines and save for later}
 regs.bh:=active_page;
 intr($10,regs);
 startscanline:=regs.ch;
 endscanline:=regs.cl;

 regs.ah:=$01;          {Turn cursor off}
 regs.ch:=$20;
 intr($10,regs);
end;


{*********************************************************************}
{ This Procedure will wait until a key is pressed, with no cursor on  }
{ the screen.                                                         }

  Procedure WAITFORKEY;
  Var Dummy   : Char;
  BEGIN
    gotoxy(1,1);
    REPEAT
      {nothing}
    UNTIL KeyPressed;
    Dummy := ReadKey;
    IF Dummy = Chr(0) THEN
       Dummy := ReadKey;
  END;

{*********************************************************************}
{ This is a replacement write Procedure and is window relative        }
{ a           = attribute to use for string                           }
{ c           = column to begin writing                               }
{ r           = row of begin writing                                  }
{ s           = string to write                                       }
{ This procedure may have snow, but it does NOT have the stupid scroll}
{ when you write to the last character of the last line of the window.}

Procedure Writeat(a,c,r:integer;s:string);
type artype = array[1..videobuffersize] of word;
Var d:word;
    x,z:integer;
    l:integer;
begin
   l:=length(s);
   if monochrome then
      d:= $B000
   else
      d:=$B800;
   z:=1;
   r:=r+hi(windmin);
   if r > screeny then
      exit;
   c:=c+lo(windmin);
   if (c+1-1) > 80 then
      exit;
   for x:=c to c+l-1 do {horizontal column}
     begin
       memw[d:word((r-1)*160+(2*(x-1)))]:=word(256*a+byte(s[z]));
       z:=z+1;
     end;
end;

Procedure mouseinfo;
Var regs:registers;
begin
  regs.ax:=3;
  intr($33,regs);
  if regs.bx = 0 then
     mkeypressed:=false
  else
     begin
        mkeypressed:=true;
        whichmkey:=integer(regs.bx);
        left_mkey_pressed:=false;
        center_mkey_pressed:=false;
        right_mkey_pressed:=false;
        case whichmkey of
          1 : left_mkey_pressed := true;
          2 : right_mkey_pressed := true;
          3 : begin
                left_mkey_pressed:=true;
                right_mkey_pressed:=true;
              end;
          4 : center_mkey_pressed := true;
        end;

        regs.ax:=3;
        repeat
          intr($33,regs)
        until regs.bx = 0;

     end;
  mousex:=regs.cx;
  mousey:=regs.dx;
end;

  Procedure MOUSE_WAITFORKEY;
  Var Dummy   : Char;
  BEGIN
    REPEAT
      mouseinfo
    UNTIL (KeyPressed or mkeypressed);
    if keypressed then
      begin
       Dummy := ReadKey;
       IF Dummy = Chr(0) THEN
          Dummy := ReadKey;
      end;
  END;


  Procedure waitforaction;
  begin
    if mouse_exists then
       mouse_waitforkey
    else
       waitforkey;
  end;

Procedure mouseinit;
Var regs:registers;

   Function logi_mouse:boolean;
   type
     signature = array[0..13] of char;
     sigptr = ^signature;
   const logitechsig : signature = 'LOGITECH MOUSE';
   Var
     testvector : sigptr;
     l          : longint;
   begin
     getintvec($33,pointer(testvector));
     longint(testvector) := longint(testvector) + 16;
     if testvector^ = logitechsig then
        logi_mouse := true
     else
        logi_mouse := false;
   end;

begin
  regs.ax:=0;
  intr($33,regs);
  if regs.ax > 0 then
    begin
     numkeys:=regs.bx;
     mouse_exists:=true;
     islogitech:=logi_mouse;
    end
  else
    begin
     numkeys:=0;
     mouse_exists:=false;
     islogitech:=false;
    end;
  mkeypressed:=false;
  left_mkey_pressed:=false;
  center_mkey_pressed:=false;
  right_mkey_pressed:=false;
end;

Procedure showmouse;
Var regs:registers;
begin
  regs.ax:=1;
  intr($33,regs);
end;

Procedure unshowmouse;
Var regs:registers;
begin
  regs.ax:=2;
  intr($33,regs);
end;

Procedure putatxy(x,y:integer);
Var regs:registers;
begin
  x:=x*8+4;
  y:=y*8+4;
  regs.ax:=4;
  regs.cx:=x;
  regs.dx:=y;
  intr($33,regs);
  mousex:=x;
  mousey:=y;
end;

Procedure setsensitivity(horizon,vertic,doub:integer);
Var regs:registers;
begin
  regs.ax:=26;
  regs.bx:=word(horizon);
  regs.cx:=word(vertic);
  regs.dx:=word(doub);
  intr($33,regs);
end;

Procedure getsensitivity(Var horiz,vert,double:integer);
Var regs:registers;
begin
  regs.ax:=27;
  intr($33,regs);
  horiz:=integer(lo(regs.bx));
  vert:=integer(lo(regs.cx));
  double:=integer(lo(regs.dx));
end;

Procedure setfastmode(switchspeed:integer);
Var regs:registers;
begin
  regs.ax:=19;
  regs.dx:=word(switchspeed);
  intr($33,regs);
end;

Procedure mouse_window(x1,y1,x2,y2:integer);
Var regs:registers;
begin
  {set min/max horizontal}
  regs.ax:=7;
  regs.cx:=word(x1*8);
  regs.dx:=word(x2*8);
  intr($33,regs);
  {set min/max vertical}
  regs.ax:=8;
  regs.cx:=word(y1*8);
  regs.dx:=word(y2*8);
  intr($33,regs);
end;

Procedure id;
Var regs:registers;
    h,v,d:integer;
begin
  regs.ax:=36;
  intr($33,regs);
  with regs do
    begin
      case integer(ch) of
        1 : writeln('Bus mouse driver');
        2 : writeln('Serial mouse driver');
        3 : writeln('InPort mouse driver');
        4 : writeln('PS/2 mouse driver');
        5 : writeln('Hewlett-Packard mouse driver');
      end;
      writeln('Version ',integer(bh),'.',integer(bl));
      writeln('IRQ line ',integer(cl));
    end;
  getsensitivity(h,v,d);
  writeln('Horizontal factor = ',h);
  writeln('Vertical factor   = ',v);
  write('Turbo threshold   = ',d);
  waitforaction;
end;

constructor winda.init(a,b,c,d:integer;t:string;a1,a2,a3:word);
begin
  x1:=a;
  y1:=b;
  x2:=c;
  y2:=d;
  title:=t;
  ta:=a1;
  fg:=a2;
  bg:=a3;
end;

Procedure winda.storescreen;

   {*********************************************************************}
   { This Procedure stores a portion of the screen to the heap           }
   { x1            = column of upper left corner                         }
   { y1            = row of upper left corner                            }
   { x2            = column of lower right corner                        }
   { y2            = row of lower right corner                           }
   { holding_place = generic pointer to where the screen data is on heap }

   Procedure SCREEN2RAM2(x1,y1,x2,y2: integer;Var holding_place:pointer);
   type artype = array[1..videobuffersize] of word;
   Var d:word;
      x,y,z:integer;
      junk:^artype;
      size_of_screen_chunk:integer;
   begin
      if (x2 <= x1) or   {if invalid coordinates, then just exit and}
         (y2 <= y1) then {set pointer to nil                        }
         begin
           holding_place:=nil;
           exit;
         end;
      size_of_screen_chunk:=(y2-y1+1)*(x2-x1+1)*2;
      getmem(junk,word(size_of_screen_chunk));
      if monochrome then
         d:= $B000
      else
         d:=$B800;
      z:=1;
      for y:=y1 to y2 do {vertical row}
       begin
        for x:=x1 to x2 do {horizontal column}
          begin
            junk^[z]:=memw[d:word(((y-1)*160)+(2*(x-1)))];
            z:=z+1;
          end;
       end;
      holding_place:=junk;
   end;

     Procedure border(x1,y1,x2,y2:integer;title:string);
     const
      ULCORNER = CHR(201);
      URCORNER = CHR(187);
      LLCORNER = CHR(200);
      LRCORNER = CHR(188);
      HBAR     = CHR(205);
      VBAR     = CHR(186);
     Var
      i,j,k    : integer;
     BEGIN
        window(1,1,80,screeny);
        highvideo;
        writeat(white,x1,y1,ulcorner);

        if title = '' then
           FOR i:=x1+1 to x2-1 DO
               writeat(white,i,y1,hbar)
        else
          begin
            {title...}
            K:=length(title);    {length of title plus ends}
            J:=x2-x1-1;            {length of space to put title in}
            K:=(j-k) div 2;        {k = half of space left}
            for i:=x1+1 to x1+k-1 do
              writeat(white,i,y1,hbar);
            writeat(white,x1+k,y1,chr(181));
            writeat(ta,x1+k+1,y1,title);
            writeat(white,x1+k+1+length(title),y1,chr(198));
            for i:=x1+k+1+length(title)+1 to x2-1 do
              writeat(white,i,y1,hbar);
          end;

        writeat(white,x2,y1,urcorner);
        FOR i:=y1+1 to y2-1 DO
            BEGIN
              writeat(white,x1,i,vbar);
              writeat(white,x2,i,vbar);
            END;
        writeat(white,x1,y2,llcorner);

        FOR i:=x1+1 to x2-1 DO
           writeat(white,i,y2,hbar);

        writeat(white,x2,y2,lrcorner);
     END;

begin
  oldwindowmin:=windmin;
  oldwindowmax:=windmax;
  oldx:=wherex;
  oldy:=wherey;
  screen2ram2(x1-1,y1-1,x2+1,y2+1,screenvar);
  border(x1-1,y1-1,x2+1,y2+1,title);
  window(x1,y1,x2,y2);
  clrscr;
end;

destructor winda.done;
begin
end;

Procedure winda.restorescreen;

    {*********************************************************************}
    { This Procedure restores a portion of the screen from the heap       }
    { x1            = column of upper left corner                         }
    { y1            = row of upper left corner                            }
    { x2            = column of lower right corner                        }
    { y2            = row of lower right corner                           }
    { holding_place = generic pointer to where the screen data is on heap }

    Procedure RAM2SCREEN2(x1,y1,x2,y2: integer;Var holding_place:pointer);
    type artype = array[1..videobuffersize] of word;
    Var d:word;
        x,y,z:integer;
        junk:^artype;
        size_of_screen_chunk:integer;
    begin
       if (x2 <= x1) or   {if invalid coordinates, then just exit and}
          (y2 <= y1) then {set pointer to nil                        }
          begin
            holding_place:=nil;
            exit;
          end;
       size_of_screen_chunk:=(y2-y1+1)*(x2-x1+1)*2;
       junk:=holding_place;
       if monochrome then
          d:=$B000
       else
          d:=$B800;
       z:=1;
       for y:=y1 to y2 do {vertical row}
        begin
         for x:=x1 to x2 do {horizontal column}
           begin
             memw[d:word(((y-1)*160)+(2*(x-1)))]:=junk^[z];
             z:=z+1;
           end;
        end;
       freemem(junk,size_of_screen_chunk);
    end;

begin
  window(lo(oldwindowmin)+1,hi(oldwindowmin)+1,   {restore old window}
         lo(oldwindowmax)+1,hi(oldwindowmax)+1);  {coordinates       }
  ram2screen2(x1-1,y1-1,x2+1,y2+1,screenvar);
  gotoxy(oldx,oldy);
end;

constructor pop.init(a,b,c,d:integer;t,s:string;a1,a2,a3:word);
begin
  winda.init(a,b,c,d,t,a1,a2,a3);
  msg:=s;
end;

Procedure pop.showit;
Var ch:char;
begin
  storescreen;
  writeat(white,1,1,msg);
   if alert and stimulus then
     begin
       repeat
         whooop(220,880,5,2);
         delay(200);
         if mouse_exists then
            mouseinfo
         else
            mkeypressed:=false;
       until (keypressed or mkeypressed);
       if keypressed then
         begin
           ch:=readkey;
           if ch = #0 then
              ch:=readkey;
         end;
     end
    else
     waitforaction;
  restorescreen;
end;

destructor pop.done;
begin
  winda.done;
end;

constructor menu.init(a,b,c,d:integer;t:string;a1,a2,a3:word);
begin
  winda.init(a,b,c,d,t,a1,a2,a3);
  itemcount:=0;
  maxwidth:=0;
  item:=nil;
  current:=nil;
end;

Procedure menu.nukethelist;
begin
  current:=item;
  while current <> nil do
    begin
      item:=current^.next;
      dispose(current);
      current:=item;
    end;
  itemcount:=0;
end;

destructor menu.done;
begin
  menu.nukethelist;
  winda.done;
end;

Procedure menu.add2menu(labelname:string;procname:window_action);
Var k:menuitemptr;
begin
  if maxwidth < length(labelname) then
     maxwidth := length(labelname);
  itemcount:=itemcount+1;
  new(k);
  k^.itemlabel:=labelname;
  k^.proc:=procname;
  k^.next:=nil;
  if item = nil then
    begin
      item:=k;
      current:=k;
      k^.prev:=nil;
    end
  else
    begin
      k^.prev:=current;
      current^.next:=k;
      current:=k;
    end;
end;

Procedure menu.pickmenu;
Var disphight,
    j,w:integer;
    tchar:char;

     Function nextkey:char;
     Var inchar:char;
     begin
        repeat
           {nothing}
        until keypressed;
        inchar := readkey;
        if inchar = chr(0) then
           inchar := readkey;
        nextkey:=inchar;
     end;

     Function mousenextkey:char;
     Var inchar:char;
         v:integer;
         crud,crud2:string;
     begin
        mouseinfo;
        repeat
          mouseinfo;
          v:=(mousey div 8)-y1+1;
        until (  keypressed or
                 mkeypressed or
                 (v <> w)  );
        if keypressed then
          begin
            inchar := readkey;
            if inchar = chr(0) then
               inchar := readkey;
            mousenextkey:=inchar;
          end
        else
          if not mkeypressed then
              if v > w then
                 mousenextkey:=chr(80) {up}
              else
                 mousenextkey:=chr(72);{down}
     end;

     Procedure up_arrow;
     Var tVar:integer;
     begin
       if current = item then
         begin
           if mouse_exists then
              putatxy(x1+10,y1+w-1);
           exit;
         end;
       writeat(fg,1,w,current^.itemlabel);
       current:=current^.prev;
       if w > 1 then
         w:=w-1
       else
         begin
           gotoxy(1,1);
           insline;
         end;
      writeat(bg,1,w,current^.itemlabel);
      if mouse_exists then
         putatxy(x1+10,y1+w-1);
     end;

     Procedure down_arrow;
     begin
       if current^.next = nil then
         begin
           if mouse_exists then
              putatxy(x1+10,y1+w-1);
           exit;
         end;

       writeat(fg,1,w,current^.itemlabel);
       current:=current^.next;

       if (w=disphight) and (disphight<itemcount) then
         begin
           gotoxy(1,1);
           delline;
         end
       else
         w:=w+1;
       writeat(bg,1,w,current^.itemlabel);
       if mouse_exists then
          putatxy(x1+10,y1+w-1);
     end;

     Procedure call_the_Procedure;
     begin
       current^.proc;       {execute the proper procedure}
       if mouse_exists then {reset mouse window, put mouse back in right spot}
         begin
           mouse_window(x1,y1-1,
                        x2,y2+1);
           putatxy(x1+10,y1+w-1);
         end;
       global_choice := 1;
     end;

   function min(a,b:integer):integer;
   begin
     if a < b then
        min:=a
     else
        min:=b;
   end;

begin
   if stimulus then
      whooop(500,1800,17,1);
   if maxwidth < (length(title)+2) then
      maxwidth := length(title)+2;
   x1:=((80-(maxwidth+1)) div 2) +1;
   if itemcount < (screeny-2) then
      y1:=((screeny-itemcount) div 2)+1
   else
      y1:=2;
   x2:=x1+maxwidth-1;
   disphight:=min(itemcount,(screeny-2));
   y2:=y1+disphight-1;
   if (maxwidth < 10) and (disphight < itemcount) then
      maxwidth :=10;  {to make room for 'scroll' message}
   storescreen;
   clrscr;

   current:=item;
   for j:=1 to disphight do
     begin
       writeat(fg,1,j,current^.itemlabel);
       current:=current^.next;
     end;
   if disphight < itemcount then
      writeat(white+blink,2,disphight+1,'»Scroll«');
   current:=item;
   writeat(bg,1,1,current^.itemlabel);

   if mouse_exists then
    begin
      mouse_window(x1,y1-1,
                  x2,y2+1);
      putatxy(x1+10,y1);
    end;

   gotoxy(1,1);
   w:=1;
   global_choice:=0;
   quit:=false;
   up1level:=false;
   global_choice:=0;
   repeat
       if mouse_exists then
          tchar:=mousenextkey
       else
          tchar:=nextkey;
       if (not mkeypressed) or (not mouse_exists) then
         case tchar of
           chr(68) : quit:=true;               {f10}
           chr(13) : call_the_Procedure;       {Enter}
           chr(72) : up_arrow;                 {up arrow}
           chr(80) : down_arrow;               {down arrow}
           chr(27) : up1level:=true;           {esc}
         else
           sound(440);
           delay(200);
           nosound;
         end
       else
         case whichmkey of
           1 : call_the_Procedure; {left mouse key pressed}
           2 : up1level:=true;     {right mouse key pressed}
         3,4 : quit:=true;         {both mouse keys pressed,
                                    center key on logitech}
         else
           sound(440);
           delay(200);
           nosound;
         end;
   until quit or up1level;

   if up1level then up1level:=false;
   restorescreen;
end;

constructor popfetch.init(a,b,c,d:integer;t,s:string;a1,a2,a3:word);
begin
  winda.init(a,b,c,d,t,a1,a2,a3);
  msg:=s;
end;

Function popfetch.fetchit:string;
Var a:string;
    ch:char;
    p:integer;

   function nextkey:char;
   begin
     if mouse_exists then
       repeat
         mouseinfo
       until keypressed or mkeypressed
     else
       repeat
       until keypressed;

     if keypressed then
       nextkey:=readkey
     else
       case whichmkey of
           1 : nextkey:=chr(13);
       2,3,4 : nextkey:=chr(27);
       end;
   end;

begin
  storescreen;
  p:=length(msg);
  write(msg);
  a:='';
  ch:=nextkey;
  while not (ord(ch) in [13,27]) do
    if ord(ch)=8 then  {backspace key}
      begin
       if length(a) <= 1 then
        a:=''
       else
        a:=copy(a,1,length(a)-1);
       if wherex-1 > p then
          gotoxy(wherex-1,1);
       clreol;
       ch:=nextkey;
      end
    else
     begin
      write(ch);
      a:=a+ch;
      ch:=nextkey;
     end;
  if ord(ch) = 27 then
     fetchit:=''
  else
     fetchit:=a;
  restorescreen;
end;

destructor popfetch.done;
begin
  winda.done;
end;

{ initialize static Variables }
begin
    stimulus:=false;
    alert:=false;
    quit:=false;
    up1level:=false;
    global_choice:=0;
    mouseinit;
    heaperror:=@heapfunc;
END.