home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TPW73.ZIP / TPD73.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-07-11  |  13.8 KB  |  479 lines
  1. uses
  2.   dos,
  3.   crt,
  4.   tpw73;
  5.  
  6. var
  7.   mmenu       : hmenurec;
  8.   smenu       : vmenurec;
  9.   emenu       : vmenurec;
  10.   hmenu       : vmenurec;
  11.   done        : boolean;
  12.   menunoattr  : integer;
  13.   x           : integer;
  14.   msg,msg1    : string;
  15.   ch1,ch2     : char;
  16.  
  17. procedure initmenus;
  18. begin
  19.   if lastmode = 7 then
  20.   begin
  21.     menunoattr := attr(0,0);
  22.     winspeed := 3500;
  23.   end else menunoattr := attr(8,1);
  24.   with mmenu do
  25.   begin
  26.     curntpos   := 0;
  27.     item[1]    := 'Frames';
  28.     item[2]    := 'Titles';
  29.     item[3]    := 'Shadows';
  30.     item[4]    := 'Demos';
  31.     item[5]    := 'Menus';
  32.     item[6]    := 'Quit';
  33.     itemcount  := 6;
  34.     startpos   := 1;
  35.     hlattr     := attr(0,7);
  36.     flattr     := attr(15,1);
  37.     flon       := true;
  38.     menuspaces := 6;
  39.     barloc     := 1;
  40.     subitem    :='001110';
  41.   end;
  42.   with smenu do
  43.   begin
  44.     startpos   := 0;
  45.     liveitem   := '11011011';
  46.     curntpos   := 0;
  47.     item[1]    := 'Flat         (   0)';
  48.     item[2]    := 'Reattribute  (1, 2)';
  49.     item[3]    := 'Solid        (3, 4)';
  50.     item[4]    := 'Light Hatch  (5, 6)';
  51.     item[5]    := 'Medium Hatch (7, 8)';
  52.     item[6]    := 'Heavy Hatch  (9,10)';
  53.     item[7]    := 'Activate Items 3,6 ';
  54.     item[8]    := 'Deact. Items   3,6 ';
  55.     itemcount  := 8;
  56.     hlattr     := attr(0,7);
  57.     flattr     := attr(15,1);
  58.     noattr     := menunoattr;
  59.     bartype    := 1;
  60.     flon       := true;
  61.   end;
  62.   with hmenu do
  63.   begin
  64.     startpos   := 0;
  65.     liveitem   := '1111';
  66.     curntpos   := 0;
  67.     item[1]    := 'First Letter';
  68.     item[2]    := 'Menu Bars   ';
  69.     item[3]    := 'Types       ';
  70.     item[4]    := 'General     ';
  71.     itemcount  := 4;
  72.     hlattr     := attr(0,7);
  73.     flattr     := attr(15,1);
  74.     noattr     := menunoattr;
  75.     bartype    := 1;
  76.     flon       := true;
  77.   end;
  78.   with emenu do
  79.   begin
  80.     startpos   := 0;
  81.     liveitem   := '111';
  82.     curntpos   := 0;
  83.     item[1]    := 'Pop Windows ';
  84.     item[2]    := 'Zoom Windows';
  85.     item[3]    := 'List Window ';
  86.     itemcount  := 3;
  87.     hlattr     := attr(0,7);
  88.     flattr     := attr(15,1);
  89.     noattr     := menunoattr;
  90.     bartype    := 1;
  91.     flon       := true;
  92.   end;
  93. end;
  94.  
  95. procedure continue;
  96. begin
  97.   sprintc(25,1,80,'             Press any key to continue...            ',attr(14,7));
  98.   repeat
  99.     getkey(ch1,ch2);
  100.   until ch1 <> #0;
  101.   sprintc(25,1,80,'Use arrow keys to change selection - Return to select',attr(0,7));
  102. end;
  103.  
  104. procedure fdemo;
  105. begin
  106.   openwin(5,15,6,15,attr(15,2),attr(15,2),0,0,1,0);
  107.   titlewin(2,attr(14,2),'[ Style 0 ]');
  108.   openwin(5,34,6,15,attr(15,5),attr(15,5),1,7,1,0);
  109.   titlewin(2,attr(14,5),'[ Style 1 ]');
  110.   openwin(5,53,6,15,attr(15,3),attr(15,3),2,7,1,0);
  111.   titlewin(2,attr(14,3),'[ Style 2 ]');
  112.   openwin(8,5,6,15,attr(15,4),attr(15,4),3,7,1,0);
  113.   titlewin(2,attr(14,4),'[ Style 3 ]');
  114.   openwin(8,24,6,15,attr(15,3),attr(15,3),4,7,1,0);
  115.   titlewin(2,attr(14,3),'[ Style 4 ]');
  116.   openwin(8,43,6,15,attr(15,6),attr(15,6),5,7,1,0);
  117.   titlewin(2,attr(14,6),'[ Style 5 ]');
  118.   openwin(8,62,6,15,attr(15,5),attr(15,5),6,7,1,0);
  119.   titlewin(2,attr(14,5),'[ Style 6 ]');
  120.   openwin(11,15,6,15,attr(15,2),attr(15,2),7,7,1,0);
  121.   titlewin(2,attr(14,2),'[ Style 7 ]');
  122.   openwin(11,34,6,15,attr(15,7),attr(15,7),8,7,1,0);
  123.   titlewin(2,attr(14,7),'[ Style 8 ]');
  124.   openwin(11,53,6,15,attr(15,4),attr(15,4),9,7,1,0);
  125.   titlewin(2,attr(14,4),'[ Style 9 ]');
  126.   openwin(14,5,6,15,attr(15,7),attr(15,7),10,7,1,0);
  127.   titlewin(2,attr(14,7),'[ Style 10]');
  128.   openwin(14,24,6,15,attr(15,6),attr(15,6),11,7,1,0);
  129.   titlewin(2,attr(14,6),'[ Style 11]');
  130.   openwin(14,43,6,15,attr(15,5),attr(15,5),12,7,1,0);
  131.   titlewin(2,attr(14,5),'[ Style 12]');
  132.   openwin(14,62,6,15,attr(15,2),attr(15,2),13,7,1,0);
  133.   titlewin(2,attr(14,2),'[ Style 13]');
  134.   openwin(17,15,6,15,attr(15,3),attr(15,3),14,7,1,0);
  135.   titlewin(2,attr(14,3),'[ Style 14]');
  136.   openwin(17,34,6,15,attr(15,2),attr(15,2),15,7,1,0);
  137.   titlewin(2,attr(14,2),'[ Style 15]');
  138.   openwin(17,53,6,15,attr(15,7),attr(15,7),16,7,1,0);
  139.   titlewin(2,attr(14,7),'[ Style 16]');
  140.   continue;
  141.   for x := 1 to 17 do closewin;
  142. end;
  143.  
  144. procedure tdemo;
  145. begin
  146.   openwin(8,8,10,68,attr(15,5),attr(15,5),2,0,1,0);
  147.   printcwin(3,'Titles may be placed in any of six different locations');
  148.   printcwin(4,'and in any color attribute!');
  149.   for x:=1 to 6 do
  150.   begin
  151.     str(x,msg);
  152.     msg := '[ LOCATION '+MSG+' ]';
  153.     titlewin(x,attr(9+x,5),msg);
  154.     delay(1000);
  155.   end;
  156.   continue;
  157.   closewin;
  158. end;
  159.  
  160. procedure sdemo;
  161. begin
  162.   openwin(3,30,10,25,attr(7,1),attr(15,1),10,7,1,0);
  163.   done := false;
  164.   with smenu do
  165.   begin
  166.     while not done do
  167.     begin
  168.       makevmenu(smenu);
  169.       case curntpos of
  170.         1 : begin
  171.               openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
  172.               titlewin(2,attr(15,5),' FLAT ');
  173.               openwin(11,8,10,30,attr(15,3),attr(0,3),1,0,0,0);
  174.               openwin(11,43,10,30,attr(15,7),attr(1,7),1,0,0,0);
  175.               continue;
  176.               closewin;
  177.               closewin;
  178.               closewin;
  179.             end;
  180.         2 : begin
  181.               openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
  182.               titlewin(2,attr(15,5),' REATTRIBUTE ');
  183.               openwin(11,8,10,30,attr(15,3),attr(0,3),2,7,1,0);
  184.               printcwin(7,'Left Shadow');
  185.               openwin(11,43,10,30,attr(15,7),attr(1,7),2,7,2,0);
  186.               printcwin(7,'Right Shadow');
  187.               continue;
  188.               closewin;
  189.               closewin;
  190.               closewin;
  191.             end;
  192.         3 : begin
  193.               openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
  194.               titlewin(2,attr(15,5),' SOLID ');
  195.               openwin(11,8,10,30,attr(15,3),attr(0,3),2,0,3,0);
  196.               printcwin(7,'Left Shadow');
  197.               openwin(11,43,10,30,attr(15,7),attr(1,7),2,0,4,0);
  198.               printcwin(7,'Right Shadow');
  199.               continue;
  200.               closewin;
  201.               closewin;
  202.               closewin;
  203.             end;
  204.         4 : begin
  205.               openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
  206.               titlewin(2,attr(15,5),' LT. HATCH ');
  207.               openwin(11,8,10,30,attr(15,3),attr(0,3),2,attr(0,7),5,0);
  208.               printcwin(7,'Left Shadow');
  209.               openwin(11,43,10,30,attr(15,7),attr(1,7),2,attr(0,7),6,0);
  210.               printcwin(7,'Right Shadow');
  211.               continue;
  212.               closewin;
  213.               closewin;
  214.               closewin;
  215.             end;
  216.         5 : begin
  217.               openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
  218.               titlewin(2,attr(15,5),' MED. HATCH ');
  219.               openwin(11,8,10,30,attr(15,3),attr(0,3),2,attr(0,7),7,0);
  220.               printcwin(7,'Left Shadow');
  221.               openwin(11,43,10,30,attr(15,7),attr(1,7),2,attr(0,7),8,0);
  222.               printcwin(7,'Right Shadow');
  223.               continue;
  224.               closewin;
  225.               closewin;
  226.               closewin;
  227.             end;
  228.         6 : begin
  229.               openwin(10,4,7,74,attr(15,5),attr(15,5),2,0,0,0);
  230.               titlewin(2,attr(15,5),' HEAVY HATCH ');
  231.               openwin(11,8,10,30,attr(15,3),attr(0,3),2,attr(0,7),9,0);
  232.               printcwin(7,'Left Shadow');
  233.               openwin(11,43,10,30,attr(15,7),attr(1,7),2,attr(0,7),10,0);
  234.               printcwin(7,'Right Shadow');
  235.               continue;
  236.               closewin;
  237.               closewin;
  238.               closewin;
  239.             end;
  240.         7 : begin
  241.               liveitem[3] := '1';
  242.               liveitem[6] := '1';
  243.             end;
  244.         8 : begin
  245.               liveitem[3] := '0';
  246.               liveitem[6] := '0';
  247.             end;
  248.       else
  249.         closewin;
  250.         done := true;
  251.       end;
  252.     end;
  253.     done := false;
  254.   end;
  255. end;
  256.  
  257. procedure showfile;
  258. var
  259.   source      : text;
  260.   txtstr      : string;
  261.   txtarray    : lstarray;
  262.   rec         : word;
  263.  
  264. begin
  265.   rec := 0;
  266.   Assign(Source,'LMENUTP.TXT');
  267.   {$I-} Reset(Source); {$I+}
  268.   if ioresult = 0  then
  269.   begin
  270.     mark(heaptop);
  271.     repeat
  272.       {$I-} readln(source,txtstr); {$I+}
  273.       if ioresult = 0 then
  274.       begin
  275.         inc(rec);
  276.         new(TxtArray[rec]);
  277.         TxtArray[rec]^ := txtstr;
  278.       end;
  279.     until eof(source);
  280.     close(source);
  281.     openwin(7,7,12,16,attr(1,7),attr(1,7),2,0,1,0);
  282.     titlewin(2,attr(1,7),' KEYWORDS ');
  283.     titlewin(5,attr(1,7),' more ');
  284.     x := MakeLMenu(txtarray,rec,1,attr(7,1));
  285.     closewin;
  286.     if x <> 0 then
  287.     begin
  288.       openwin(12,24,7,34,attr(1,7),attr(1,7),2,0,1,1);
  289.       printcwin(2,'Record selected:');
  290.       printcwin(4,txtarray[x]^);
  291.       continue;
  292.       closewin;
  293.     end;
  294.     release(heaptop);
  295.   end;
  296. end;
  297.  
  298. procedure edemo;
  299. begin
  300.   openwin(3,43,5,18,attr(7,1),attr(15,1),10,attr(7,0),1,0);
  301.   done := false;
  302.   with emenu do
  303.   begin
  304.     while not done do
  305.     begin
  306.       makevmenu(emenu);
  307.       case curntpos of
  308.         1 : begin
  309.               openwin(8,8,10,65,attr(15,5),attr(15,5),2,0,1,0);
  310.               printcwin(3,'Windows can be popped');
  311.               printcwin(4,'onto the screen.');
  312.               delay(2000);
  313.               openwin(5,5,10,50,attr(0,2),attr(14,2),2,7,1,0);
  314.               delay(2000);
  315.               openwin(13,15,10,60,attr(1,3),attr(15,3),3,7,1,0);
  316.               delay(2000);
  317.               openwin(7,33,10,45,attr(14,5),attr(14,5),1,7,1,0);
  318.               continue;
  319.               for x := 1 to 4 do
  320.               begin
  321.                 closewin;
  322.               end;
  323.             end;
  324.         2 : begin
  325.               openwin(8,8,10,65,attr(15,5),attr(15,5),2,0,1,0);
  326.               printcwin(3,'Windows can be zoomed');
  327.               printcwin(4,'onto the screen.');
  328.               delay(2000);
  329.               openwin(5,5,10,50,attr(0,2),attr(14,2),2,7,1,1);
  330.               delay(2000);
  331.               openwin(13,15,10,60,attr(1,3),attr(15,3),3,7,1,1);
  332.               delay(2000);
  333.               openwin(7,33,10,45,attr(14,5),attr(14,5),1,7,1,1);
  334.               delay(2000);
  335.               openwin(7,20,12,40,attr(15,4),attr(14,4),2,7,1,1);
  336.               printcwin(5,'HOW ABOUT THAT !!!');
  337.               continue;
  338.               for x := 1 to 5 do
  339.               begin
  340.                 closewin;
  341.               end;
  342.             end;
  343.          3: showfile;
  344.       else
  345.         closewin;
  346.         done := true;
  347.       end;
  348.     end;
  349.     done := false;
  350.   end;
  351. end;
  352.  
  353. procedure flhelp;
  354. begin
  355.   openwin(12,13,7,55,attr(1,7),attr(1,7),2,0,1,1);
  356.   titlewin(2,attr(15,7),'[ FIRST LETTER ]');
  357.   printwin(1,2,'To activate First Letter control you must set two');
  358.   printwin(2,2,'variables.  FLOn must be set to true and you can');
  359.   printwin(3,2,'set FLattr to the desired color you wish.  Thats');
  360.   printwin(4,2,'all there is to it.  Just be sure all strings begin');
  361.   printwin(5,2,'with a different letter.');
  362.   continue;
  363.   closewin;
  364. end;
  365.  
  366. procedure barhelp;
  367. begin
  368.   openwin(12,13,7,55,attr(1,7),attr(1,7),2,0,1,1);
  369.   titlewin(2,attr(15,7),'[ MENUBARS ]');
  370.   printwin(1,2,'There are currently four menu bar types:');
  371.   printwin(2,2,'  0 - No visible bar    1 - Full width bar');
  372.   printwin(3,2,'  2 - String width bar  3 - Pointer');
  373.   printwin(4,2,'You control what type is active by setting BarType');
  374.   printwin(5,2,'equal to the type desired.');
  375.   continue;
  376.   closewin;
  377. end;
  378.  
  379. procedure typehelp;
  380. begin
  381.   openwin(12,13,7,55,attr(1,7),attr(1,7),2,0,1,1);
  382.   titlewin(2,attr(15,7),'[ MENUTYPES ]');
  383.   printwin(1,2,'There are currently two menu types:');
  384.   printwin(2,2,'  Standard Vertical Menu (Makevmenu)');
  385.   printwin(3,2,'  Horizontal Menu        (Makehmenu)');
  386.   printwin(4,2,'  List Menu              (Makelmenu)');
  387.   continue;
  388.   closewin;
  389. end;
  390.  
  391. procedure generalhelp;
  392. begin
  393.   openwin(12,13,7,55,attr(1,7),attr(1,7),2,0,1,1);
  394.   titlewin(2,attr(15,7),'[ GENERAL ]');
  395.   printwin(1,2,'Remember MakeMenu is only a procedure executed in a');
  396.   printwin(2,2,'predefined window so all window effects can be used');
  397.   printwin(3,2,'to enhance your menu.  Including border and shadow,');
  398.   printwin(4,2,'as well as growing and all various color attribute');
  399.   printwin(5,2,'combinations.  The choices are almost endless!');
  400.   continue;
  401.   closewin;
  402. end;
  403.  
  404. procedure hdemo;
  405. begin
  406.   openwin(3,54,6,18,attr(7,1),attr(15,1),10,attr(7,0),1,0);
  407.   done := false;
  408.   with hmenu do
  409.   begin
  410.     while not done do
  411.     begin
  412.       makevmenu(hmenu);
  413.       case curntpos of
  414.         1 : flhelp;
  415.         2 : barhelp;
  416.         3 : typehelp;
  417.         4 : generalhelp;
  418.       else
  419.         closewin;
  420.         done := true;
  421.       end;
  422.     end;
  423.     done := false;
  424.   end;
  425. end;
  426.  
  427. begin
  428.   clrscr;
  429.   cursoroff;
  430.   openwin(5,20,11,40,attr(15,7),textattr,2,0,0,0);
  431.   printcwin(2,'TPW73');
  432.   case CurDisplay of
  433.     0 : msg := 'MONO';
  434.     1 : msg := 'CGA';
  435.     2 : msg := 'EGA';
  436.     3 : msg := 'MCGA';
  437.     4 : msg := 'VGA';
  438.   end;
  439.   str(lastmode:1,msg1);
  440.   msg := msg + ' monitor in video mode '+msg1;
  441.   printcwin(3,msg);
  442.   printcwin(5,'Copyright (C) 1988');
  443.   printcwin(6,'by Richard D. Fothergill');
  444.   initmenus;
  445.   x := 0;
  446.   while not keypressed and (x < 25000) do inc(x);
  447.   closewin;
  448.   if keypressed then getkey(ch1,ch2);
  449.   done := false;
  450.   openwin(1,1,3,80,attr(7,1),attr(15,1),2,0,0,0);
  451.   fakewin(3,1,22,80,attr(7,1),attr(15,1),14,0,0,0);
  452.   sprint(25,1,'             Use arrow keys to change selection - Return to select              ',attr(0,7));
  453.   with mmenu do
  454.   begin
  455.     while not done do
  456.     begin
  457.       makehmenu(mmenu);
  458.       case curntpos of
  459.         1 : fdemo;
  460.         2 : tdemo;
  461.         3 : sdemo;
  462.         4 : edemo;
  463.         5 : hdemo;
  464.       else
  465.         closewin;
  466.         clrscr;
  467.         openwin(9,16,8,52,attr(0,7),attr(1,7),2,0,0,0);
  468.         printcwin(3,'T P W');
  469.         printcwin(4,'7.3');
  470.         delay(3000);
  471.         closewin;
  472.         done := true;
  473.       end;
  474.     end;
  475.   end;
  476.   cursoron;
  477.   clrscr;
  478. end.
  479.