Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TPW73.ZIP/TPW73.PAS

Pascal/Delphi Source File | 1989-07-11 | 15.4 KB | 550 lines

{$A+,B-,D+,E-,F-,I-,L+,N-,O-,R-,S-,V-}

unit TPW73;

interface

uses dos,crt;

type
  ItemList  = array [1..15] of string;
  vmenurec  = record
                item:itemlist;
                liveitem : string;
                itemcount,startpos,curntpos,
                hlattr,flattr,noattr,bartype:integer;
                flon:boolean;
              end;
  hmenurec  = record
                item    : itemlist;
                subitem : string;
                itemcount,startpos,curntpos,hlattr,flattr:integer;
                menuspaces,barloc:integer;
                flon:boolean;
              end;
  str76     = string[76];
  lstarray  = array[0..1000] of ^str76;

var
  winspeed : word;
  HeapTop  : ^Integer;
  ch1,ch2  : char;
  stathold : word;

procedure SPrint   (row,col:integer;strdat:string;tattr:integer);
procedure SFill    (row,col,rows,cols:integer;ch:char;tattr:integer);
procedure SColor   (row,col,rows,cols,tattr:integer);
procedure SPrintc  (row,colL,colR:integer;strdat:string;tattr:integer);
procedure openwin  (row,col,rows,cols,wtattr,wbtattr,brdrsel,stattr,shadow,zoom:integer);
procedure fakewin  (row,col,rows,cols,wtattr,wbtattr,brdrsel,stattr,shadow,zoom:integer);
procedure titlewin (dir,tattr:integer;title:string);
procedure closewin;
procedure printwin (row,col:integer;strdat:string);
procedure printcwin(row:integer;strdat:string);
procedure scrollwin(dir:char);
procedure MakeHMenu(var menu:hmenurec);
procedure MakeVMenu(var menu:vmenurec);
procedure CursorOff;
procedure CursorOn;
procedure Getkey(var ch1:char; var ch2:char);
function  Attr     (fore,back:integer):integer;
function  CurDisplay : byte;
function  MakeLmenu(PtrArray:lstarray;NumRecs,StartPos:integer;hlattr:integer):integer;

implementation

const
  ftable : array [0..16,1..6] of char =
             ('      ' , '┌┐└┘│─' , '╔╗╚╝║═' , '╒╕╘╛│═' , '╓╖╙╜║─',
                         '██████' , '░░░░░░' , '▒▒▒▒▒▒' , '▓▓▓▓▓▓' ,
                         '┬┬└┘│─' , '╦╦╚╝║═' , '╤╤╘╛│═' , '╥╥╙╜║─',
                         '├┤└┘│─' , '╠╣╚╝║═' , '╞╡╘╛│═' , '╟╢╙╜║─');

type
  BytePtr  = ^Byte;
  ScrRec   = Record
                wrow, wrows,wcol,wcols,wattr,wbattr,
                wbrdr,wshdw,wlastx,wlasty:integer;
              end;

var
  ScrStat   : array [0..30] of ScrRec;
  ScrPtr    : array [1..30] of BytePtr;
  IDX       : byte;
  hmenuopen : boolean;
  vmenuopen : boolean;
  movbar    : integer;

{$L TPW73}
procedure SPrint;     external;
procedure SFill;      external;
procedure SColor;     external;
procedure openbox (row,col,rows,cols,wattr,wbattr,brdrsel,zoom,sattr,shadow:integer;ScrPtr:BytePtr); external;
procedure closebox(row,col,rows,cols,shadow:integer;ScrPtr:byteptr);                                 external;
procedure titlebox(loc,row,col,rows,cols:integer;strdat:string;tattr:integer);                       external;
procedure scroll  (dir:char;memarr:byteptr;row,col,rows,cols:integer);                               external;
procedure cursoroff;  external;
procedure cursoron;   external;
function  CurDisplay; external;
function  attr;       external;

procedure getkey;
begin
  ch2 := #0;
  ch1 := readkey;
  If ch1 = #0 then ch2 := readkey;
end;

procedure openwin;
var
  wsize:integer;
begin
  if shadow <1 then wsize:=(cols*rows*2) else wsize:=((rows+1)*(cols+2)*2);
  ScrStat[IDX].wlastx := wherex;
  ScrStat[IDX].wlasty := wherey;
  IDX:= IDX+1;
  with ScrStat[IDX] do
  begin
    wrow  := row; wcol  := col;   wrows := rows;   wbattr := wbtattr;
    wcols := cols;wattr := wtattr;wbrdr := brdrsel;wshdw  := shadow;
  end;
  getmem(ScrPtr[IDX],wsize);
  openbox(row,col,rows,cols,wtattr,wbtattr,brdrsel,zoom,stattr,shadow,ScrPtr[IDX]);
  window(col+1,row+1,col+cols-2,row+rows-2);
  textattr := wtattr;
  gotoxy(1,1);
end;

procedure titlewin;
begin
  with ScrStat[IDX] do titlebox(dir,wrow,wcol,wrows,wcols,title,tattr);
end;

procedure closewin;
var
  wsize:integer;
begin
  if idx > 0 then
    with ScrStat[IDX] do
    begin
      if wshdw < 1 then wsize:=(wcols*wrows*2) else wsize:=((wrows+1)*(wcols+2)*2);
      closebox(wrow,wcol,wrows,wcols,wshdw,ScrPtr[IDX]);
      freemem(ScrPtr[IDX],wsize);
    end;
    IDX:=IDX-1;
    with ScrStat[IDX] do
    begin
      if IDX=0 then window(1,1,80,25)
          else window(wcol+1,wrow+1,wcol+wcols-2,wrow+wrows-2);
      textattr:=wattr;
      gotoxy(wlastx,wlasty);
    end;
end;

procedure printwin;
begin
  with ScrStat[IDX] do SPrint(wrow+row,wcol+col,strdat,wattr);
end;

procedure Sprintc;
var
  col : integer;
begin
  col := (((colr-coll) shr 1) + coll) - ((length(strdat) shr 1));
  sprint(row,col,strdat,tattr);
end;

procedure printcwin;
begin
  with ScrStat[IDX] do SPrintc(wrow+row,wcol,wcol+wcols,strdat,wattr);
end;

procedure fakewin;
begin
  openbox(row,col,rows,cols,wtattr,wbtattr,brdrsel,zoom,stattr,shadow,NIL);
end;

procedure scrollwin;
var
  wsize : integer;
  memarr : byteptr;
begin
  with ScrStat[IDX] do
  begin
   wsize := (wcols-2)*(wrows-3)*2;
   getmem(memarr,wsize);
   if dir = 'U' then
   begin
     scroll('U',memarr,wrow+2,wcol+1,wrows-3,wcols-2);
     sfill(wrow+wrows-2,wcol+1,1,wcols-3,' ',wattr);
   end
   else
   begin
     scroll('D',memarr,wrow+1,wcol+1,wrows-3,wcols-2);
     sfill(wrow+1,wcol+1,1,wcols-3,' ',wattr);
   end;
   freemem(memarr,wsize);
 end;
end;

procedure MakeHMenu;
var
  done : boolean;
  mpos : integer;
  itemlen : integer;

{}procedure turnon;
  var
    x : integer;
  begin
    with ScrStat[IDX],menu do
    begin
      itemlen := 0;
      for x := 1 to curntpos-1 do itemlen := itemlen +length(item[x])+menuspaces;
      SColor(wrow+barloc,wcol+menuspaces+itemlen,1,length(item[curntpos]),hlattr);
    end;
  end;

{}procedure turnoff;
  begin
    with ScrStat[IDX], menu do
    begin
      SColor(wrow+barloc,wcol+menuspaces+itemlen,1,length(item[curntpos]),textattr);
      if flon then SPrint(wrow+barloc,wcol+menuspaces+itemlen,item[curntpos][1],FLattr);
    end;
  end;

begin
  itemlen := 0;
  done := false;
  hmenuopen := true;
  with ScrStat[IDX],menu do
  begin
    for mpos := 1 to itemcount do
    begin
      SPrint(wrow+barloc,wcol+menuspaces+itemlen,item[mpos],textattr);
      if flon then SPrint(wrow+barloc,wcol+menuspaces+itemlen,item[mpos][1],FLattr);
      itemlen := itemlen + length(item[mpos])+menuspaces;
    end;
    if curntpos = 0 then if startpos = 0 then curntpos:=1 else curntpos := startpos;
    if vmenuopen then
    begin
      curntpos := curntpos + movbar;
      if curntpos > itemcount then curntpos := 1;
      if curntpos < 1 then curntpos := itemcount;
    end;
    movbar := 0;
    repeat
      turnon;
      if vmenuopen and (subitem[curntpos] = '1') then done := true
      else
      begin
        getkey(ch1,ch2);
        if ch2 in [#75,#77,#71,#79] then
        begin
          turnoff;
          case ch2 of
            #75 : dec(curntpos);
            #77 : inc(curntpos);
            #71 : curntpos := 1;
            #79 : curntpos := itemcount;
          end;
          if curntpos > itemcount then curntpos := 1;
          if curntpos < 1 then curntpos := itemcount;
        end;
        if flon then
          for mpos := 1 to itemcount do
            if upcase(ch1) = upcase(item[mpos][1]) then
              begin
                turnoff;
                curntpos := mpos;
                turnon;
                done := true;
              end;
        if ch1 = #13 then done := true;
        if ch1 = #27 then
          begin
            curntpos := 0;
            done := true;
           hmenuopen := false;
          end;
        if (ch2 = #80) and (subitem[curntpos] = '1') then done := true;
      end;
    until done;
  end;
end;

procedure MakeVMenu;
var
  done:boolean;
  mdone:boolean;
  mpos : integer;

{}procedure turnon;
  begin
    with ScrStat[IDX],menu do
    begin
      case bartype of
        1 : SColor(wrow+curntpos,wcol+1,1,wcols-2,hlattr);
        2 : SColor(wrow+curntpos,wcol+(wcols shr 1) - (length(item[curntpos]) shr 1)-1,1,
                     length(item[curntpos]) + 2,hlattr);
        3 : SPrint(wrow+curntpos,wcol+(wcols shr 1)-length(item[curntpos]) shr 1-2,'═',hlattr);
      end;
    end;
  end;

{}procedure turnoff;
  begin
    with ScrStat[IDX], menu do
    begin
      case bartype of
        3 : SPrint(wrow+curntpos,wcol+(wcols shr 1)-length(item[curntpos]) shr 1-2,'  ',textattr)
        else
            SColor(wrow+curntpos,wcol+1,1,wcols-2,textattr);
            if flon then SPrint(wrow+curntpos,wcol+(wcols shr 1)-length(item[curntpos]) shr 1,
                                   item[curntpos][1],FLattr);
      end;
    end;
  end;

begin
  done := false;
  vmenuopen := true;
  with ScrStat[IDX],menu do
  begin
    if curntpos = 0 then if startpos = 0 then curntpos:=1 else curntpos := startpos;
    while liveitem[curntpos] <> '1' do inc(curntpos);
    if curntpos > itemcount then
    begin
      startpos := 0;
      curntpos := 0;
      done := true;
      vmenuopen := false;
      exit;
    end;
    for mpos := 1 to itemcount do
    begin
      if liveitem[mpos] = '0' then
        SPrint(wrow+mpos,wcol+(wcols shr 1)-length(item[mpos]) shr 1,item[mpos],noattr)
      else begin
        SPrint(wrow+mpos,wcol+(wcols shr 1)-length(item[mpos]) shr 1,item[mpos],textattr);
        if flon then SColor(wrow+mpos,wcol+(wcols shr 1)-length(item[mpos]) shr 1,1,1,FLattr);
      end;
    end;
    repeat
      turnon;
      getkey(ch1,ch2);
      if ch2 in [#72,#80,#71,#79] then
      begin
        turnoff;
        case ch2 of
          #72 : begin
                  dec(curntpos);
                  if curntpos < 1 then curntpos := itemcount;
                  while liveitem[curntpos] = '0' do
                  begin
                    dec(curntpos);
                    if curntpos < 1 then curntpos := itemcount;
                  end;
                end;
          #80 : begin
                  inc(curntpos);
                  if curntpos > itemcount then curntpos := 1;
                  while liveitem[curntpos] = '0' do
                  begin
                    inc(curntpos);
                    if curntpos > itemcount then curntpos := 1;
                  end;
                end;
          #71 : begin
                  curntpos := 1;
                  while liveitem[curntpos] = '0' do inc(curntpos);
                end;
          #79 : begin
                  curntpos := itemcount;
                  while liveitem[curntpos] = '0' do dec(curntpos);
                end;
        end;
      end;
      if hmenuopen and (ch2 in [#75,#77]) then
      begin
        case ch2 of
          #75 : movbar := -1;
          #77 : movbar := 1;
        end;
        done := true;
        startpos := curntpos;
        curntpos := 0;
      end;
      if flon then
        for mpos := 1 to itemcount do
        begin
          if (upcase(ch1) = upcase(item[mpos][1])) and
             (liveitem[mpos] <> '0')  then
            begin
              turnoff;
              curntpos := mpos;
              startpos := curntpos;
              turnon;
              done := true;
            end;
        end;
      if ch1 = #13 then done := true;
      if ch1 = #27 then
        begin
          curntpos := 0;
          done := true;
          vmenuopen := false;
        end;
    until done;
  end;
end;

function MakeLmenu;

var
  barpos,i : integer;
  recpos   : integer;

{}procedure drawlist;
  var j,k : integer;
  begin
    with ScrStat[IDX] do
    begin
      Sfill(wrow+1,wcol+1,wrows-2,wcols-2,' ',wattr);
      if NumRecs - recpos + 1< i then
      begin
         k := NumRecs-recpos+1;
      end else k := i;
      For j := 1 to k do
      begin
        printwin(j,2,PtrArray[j-1+recpos]^);
      end;
      if NumRecs - recpos + 1< i then BarPos := j;
    end;
  end;

begin
  BarPos := 1;
  with ScrStat[IDX] do
  begin
    if NumRecs > wrows-2 then i := wrows-2 else i := NumRecs;
    recpos := startpos;
    drawlist;
    if startpos <> 0 then barpos := 1;
    repeat
      Scolor(wrow+BarPos,wcol+1,1,wcols-2,hlattr);
      getkey(ch1,ch2);
      Scolor(wrow+BarPos,wcol+1,1,wcols-2,wattr);
      Case ch2 of
        #80 : begin
                if recpos < NumRecs then
                begin
                  inc(BarPos);
                  inc(recpos);
                  if BarPos > i then
                  begin
                    dec(BarPos);
                    if recpos <= NumRecs then Scrollwin('U')
                      else recpos := NumRecs;
                  end;
                end;
              end;
        #72 : Begin
                if recpos > 1 then
                begin
                  dec(BarPos);
                  dec(recpos);
                  if BarPos < 1 then
                  begin
                    inc(BarPos);
                    if recpos > 0 then Scrollwin('D')
                      else recpos := 1;
                  end;
                end;
              end;
        #73 : Begin
                if recpos  > 1 then
                Begin
                  if (BarPos = 1) then
                  begin
                    recpos := recpos - i;
                    If recpos < 1 then recpos := 1;
                    Drawlist;
                    BarPos := 1;
                  end
                  else
                  begin
                    recpos := recpos - BarPos + 1;
                    BarPos := 1;
                  end;
                end;
              end;
        #81 : Begin
                if recpos < NumRecs then
                Begin
                  if (BarPos = i) then
                  begin
                    recpos := recpos + 1;
                    Drawlist;
                    recpos := recpos + BarPos-1;
                  end
                  else
                  begin
                    if recpos + i - barpos > numrecs then
                    begin
                      barpos := barpos + numrecs - recpos;
                      recpos := numrecs;
                    end
                    else
                    begin
                      recpos := recpos + i - BarPos;
                      BarPos := i;
                    end;
                  end;
                end;
              end;
        #71 : Begin
                if recpos <> 1 then
                Begin
                  recpos := 1;
                  BarPos := 1;
                  if i <> NumRecs then Drawlist;
                end;
              end;
        #79 : Begin
                if recpos <> NumRecs then
                begin
                  recpos := NumRecs - i + 1;
                  if i <> NumRecs then Drawlist;
                  recpos := NumRecs;
                  BarPos := i;
                end;
              end;
      end;
      if ch1 <> #27 then Sprint(wrow+BarPos,wcol+2,PtrArray[recpos]^,hlattr);
    until (ch1 = #13) or (ch1 = #27);
    if ch1 = #27 then recpos := 0;
  end;
  MakeLmenu := recpos;
end;

begin
  IDX := 0;
  with ScrStat[IDX] do
  begin
    Wrow    := 1;
    Wcol    := 1;
    Wrows   := 25;
    Wcols   := 80;
    Wattr   := textattr;
    Wlastx  := WhereX;
    Wlasty  := WhereY;
  end;
  vmenuopen := false;
  hmenuopen := false;
  movbar := 0;
  winspeed := 500;
end.