home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TPW60.ZIP / TPW60.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-03-07  |  6.8 KB  |  244 lines
  1. unit TPW60;
  2.  
  3. interface
  4.  
  5. uses
  6.   crt;
  7.  
  8. const
  9.   maxitem = 10;  {Maximum items in a menu list}
  10.   mw = 30;       {Maximum windows open at one time}
  11.   hidecursor : integer = 8192;
  12.  
  13. type
  14.   str80 = string[80];
  15.   BytePtr = ^Byte;
  16.   TPWrec = Record
  17.              wrow,wrows,wcol,wcols,wattr,wshdw:integer;wlastx,wlasty:byte;
  18.            end;
  19.   ItemList= array [1..MaxItem] of string[40];
  20.   menurec = record
  21.               item:itemlist;
  22.               itemcount,startpos,curntpos,hlattr,flattr,bartype:integer;
  23.               flon:boolean;
  24.             end;
  25.  
  26. var
  27.   TPWstat : array [0..mw] of TPWrec;
  28.   TPWptr  : array [1..mw] of BytePtr;
  29.   oldcursor: integer;
  30.   IDX : byte;
  31.  
  32. procedure TPWprint(row,col:integer;strdat:str80;tattr:integer);
  33. procedure TPWfill (row,col,rows,cols:integer;ch:char;tattr:integer);
  34. procedure TPWattr (row,col,rows,cols,tattr:integer);
  35. procedure TPWprintc(row,colL,colR:integer;strdat:str80;tattr:integer);
  36. procedure TPWborder(colornum:integer);
  37. procedure TPWbox(col,row,col1,row1,wattr,wbattr,brdrsel,zoom,sattr,shadow:integer;TPWptr:byteptr);
  38. procedure TPWrbox(row,col,rows,cols,shadow:integer;TPWptr:byteptr);
  39. procedure TPWtitle(loc,row,col,rows,cols:integer;strdat:str80;tattr:integer);
  40. procedure MakeWindow(row,col,rows,cols,wtattr,wbtattr,brdrsel,stattr,shadow,zoom:integer);
  41. procedure MakeBox(row,col,rows,cols,wtattr,wbtattr,brdrsel,stattr,shadow,zoom:integer);
  42. procedure TitleWindow(dir,tattr:integer;title:str80);
  43. procedure RemoveWindow;
  44. procedure ClearWindow;
  45. procedure PrtWindow(row,col:integer;strdat:str80);
  46. procedure PrtCWindow(row:integer;strdat:str80);
  47. procedure CursorChange(new:integer;var old:integer);
  48. procedure MakeMenu(var menu:menurec);
  49. procedure VideoOn;
  50. procedure VideoOff;
  51. procedure EGA43;
  52. function  Attr  (fore,back:integer):integer;
  53.  
  54. implementation
  55.  
  56. {$L TPW60}
  57. procedure TPWprint;     external;
  58. procedure TPWprintc;    external;
  59. procedure TPWfill;      external;
  60. procedure TPWattr;      external;
  61. procedure TPWborder;    external;
  62. procedure TPWbox;       external;
  63. procedure TPWrbox;      external;
  64. procedure TPWtitle;     external;
  65. procedure VideoOff;     external;
  66. procedure VideoOn;      external;
  67. procedure EGA43;        external;
  68.  
  69. function attr;
  70.   var temp:byte;
  71.   begin
  72.     temp := (back*16)+fore;
  73.     if fore>15 then temp := temp+112;
  74.     attr := temp
  75.   end;
  76.  
  77. procedure makewindow;
  78. var
  79.   wsize:integer;
  80. begin
  81.   if IDX>=mw then writeln('Too many windows!')
  82.   else
  83.   begin
  84.     if shadow <1 then wsize:=(cols*rows*2) else wsize:=((rows+1)*(cols+2)*2);
  85.     if (0<memavail) and (memavail<=(wsize shr 4)) then
  86.       writeln('No memory available!')
  87.     else
  88.     begin
  89.       TPWstat[IDX].wlastx := wherex;
  90.       TPWstat[IDX].wlasty := wherey;
  91.       IDX:= IDX+1;
  92.       with TPWstat[IDX] do
  93.       begin
  94.         wrow  := row; wcol  := col;   wrows := rows;
  95.         wcols := cols;wattr := wtattr;wshdw := shadow;
  96.       end;
  97.       getmem(TPWptr[IDX],wsize);
  98.       TPWbox(col-1,row-1,col+cols-2,row+rows-2,wtattr,wbtattr,brdrsel,zoom,stattr,shadow,TPWptr[IDX]);
  99.       window(col+1,row+1,col+cols-2,row+rows-2);
  100.       textattr := wtattr;
  101.       gotoxy(1,1);
  102.     end
  103.   end;
  104. end;
  105.  
  106. procedure titlewindow;
  107. begin
  108.   with tpwstat[IDX] do
  109.   begin
  110.     TPWtitle(dir,wrow,wcol,wrows,wcols,title,tattr);
  111.   end;
  112. end;
  113.  
  114. procedure removewindow;
  115. var
  116.   wsize:integer;
  117. begin
  118.   if IDX=0 then writeln('No windows left!')
  119.   else
  120.   begin
  121.     with TPWstat[IDX] do
  122.     begin
  123.       if wshdw < 1 then wsize:=(wcols*wrows*2) else wsize:=((wrows+1)*(wcols+2)*2);
  124.       TPWrbox(wrow,wcol,wrows,wcols,wshdw,TPWptr[IDX]);
  125.       freemem(TPWptr[IDX],wsize);
  126.     end;
  127.     IDX:=IDX-1;
  128.     with TPWstat[IDX] do
  129.     begin
  130.       if IDX=0 then window(1,1,80,25) else window(wcol+1,wrow+1,wcol+wcols-2,wrow+wrows-2);
  131.       textattr:=wattr;
  132.       gotoxy(wlastx,wlasty);
  133.     end;
  134.   end;
  135. end;
  136.  
  137. procedure clearwindow;
  138. begin
  139.   with TPWstat[IDX] do
  140.   begin
  141.     TPWfill(wrow+1,wcol+1,wrows-2,wcols-2,' ',wattr);
  142.   end;
  143. end;
  144.  
  145. procedure prtwindow;
  146. begin
  147.   with TPWstat[IDX] do
  148.   begin
  149.     TPWprint(wrow+row,wcol+col,strdat,wattr);
  150.   end;
  151. end;
  152.  
  153. procedure prtcwindow;
  154. begin
  155.   with TPWstat[IDX] do
  156.   begin
  157.     TPWprintc(wrow+row,wcol,wcol+wcols,strdat,wattr);
  158.   end;
  159. end;
  160.  
  161. procedure makebox;
  162. begin
  163.   TPWbox(col-1,row-1,col+cols-2,row+rows-2,wtattr,wbtattr,brdrsel,zoom,stattr,shadow,NIL);
  164. end;
  165.  
  166. procedure cursorchange;
  167. begin
  168.   inline($31/$C0/$8E/$C0/$26/$A1/$60/$04/$C4/$7E/<OLD/$AB/
  169.          $B4/$01/$8B/$4E/<NEW/$CD/$10);
  170. end;
  171.  
  172. procedure makemenu;
  173. var
  174.   done:boolean;
  175.   mloop : integer;
  176.   ch    : char;
  177.   ch1   : char;
  178. begin
  179.   done := false;
  180.   with TPWstat[IDX],menu do
  181.   begin
  182.     for mloop := 1 to itemcount do
  183.     begin
  184.       TPWprint(wrow+mloop,wcol+(wcols shr 1)-length(item[mloop]) shr 1,item[mloop],wattr);
  185.       if flon then TPWprint(wrow+mloop,wcol+(wcols shr 1)-length(item[mloop]) shr 1,item[mloop][1],FLattr);
  186.     end;
  187.     if curntpos = 0 then if startpos = 0 then curntpos:=1 else curntpos := startpos;
  188.     repeat
  189.       case bartype of
  190.         1 : TPWattr(wrow+curntpos,wcol+1,1,wcols-2,hlattr);
  191.         2 : TPWattr(wrow+curntpos,wcol+(wcols shr 1) - (length(item[curntpos]) shr 1)-1,1,
  192.                               length(item[curntpos]) + 2,hlattr);
  193.         3 : TPWprint(wrow+curntpos,wcol+(wcols shr 1)-length(item[curntpos]) shr 1-2,'═',hlattr);
  194.       end;
  195.       ch:=readkey;
  196.       if ch=#0 then ch1:=readkey;
  197.       case bartype of
  198.         3 : TPWprint(wrow+curntpos,wcol+(wcols shr 1)-length(item[curntpos]) shr 1-2,'  ',wattr)
  199.         else
  200.           TPWattr(wrow+curntpos,wcol+1,1,wcols-2,wattr);
  201.           TPWprint(wrow+curntpos,wcol+(wcols shr 1)-length(item[curntpos]) shr 1,item[curntpos],wattr);
  202.           if flon then TPWprint(wrow+curntpos,wcol+(wcols shr 1)-length(item[curntpos]) shr 1,item[curntpos][1],FLattr);
  203.       end;
  204.       if (bartype<>0) and (ch=#0) then
  205.         case ord(ch1) of
  206.           72,75,45,56,52 : curntpos := pred(curntpos);
  207.           80,77,43,50,54 : curntpos := succ(curntpos);
  208.         end;
  209.       if flon then
  210.         for mloop := 1 to itemcount do
  211.         begin
  212.           if upcase(ch) = upcase(item[mloop][1]) then
  213.           begin
  214.             curntpos := mloop;
  215.             done := true;
  216.           end;
  217.         end;
  218.       if (not flon) or (bartype <> 0) then if ch = #13 then done := true;
  219.       if ch = #27 then
  220.         begin
  221.           curntpos := 0;
  222.           done := true;
  223.         end;
  224.       if curntpos > itemcount then curntpos := 1;
  225.       if curntpos < 1 then curntpos := itemcount;
  226.     until done;
  227.   end;
  228. end;
  229.  
  230. begin
  231.   IDX := 0;
  232.   with TPWstat[IDX] do
  233.   begin
  234.     Wrow    := 1;
  235.     Wcol    := 1;
  236.     Wrows   := 25;
  237.     Wcols   := 80;
  238.     Wattr   := attr(7,0);
  239.     Wlastx  := WhereX;
  240.     Wlasty  := WhereY;
  241.     TPWfill ( 1, 1,25,80,' ',Wattr);
  242.   end;
  243. end.
  244.