home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / menu / overdriv / menupull.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1980-01-01  |  17.6 KB  |  513 lines
  1. UNIT MENUPULL;
  2.  
  3. INTERFACE
  4. USES IOSTUFF,CRT,DOS;
  5.  
  6. PROCEDURE RestoreWorkScreen;
  7. PROCEDURE SaveWorkScreen;
  8. PROCEDURE SetMain(MenuStr:AnyStr);
  9. PROCEDURE SetSub(Sub:Integer;SubStr:LongStr);
  10. PROCEDURE WriteSub(Sub:Integer);
  11. PROCEDURE WriteMain;
  12. PROCEDURE RebuildIt;
  13. FUNCTION  PickSub(Sub:Integer) : Char;
  14. FUNCTION  PickMain : Char;
  15.  
  16. IMPLEMENTATION
  17.  
  18. CONST
  19.   ColorF1   = Yellow;     { Menu Colors }
  20.   ColorB1   = Blue;
  21.   ColorF2   = LightCyan;  { First Letter Colors }
  22.   ColorB2   = Blue;
  23.   ColorF3   = Black;      { Reverse Video bar cursor }
  24.   ColorB3   = LightGray;
  25.   ColorF4   = LightGray;  { Border around submenu }
  26.   ColorB4   = Black;
  27.   MaxMenuItems    = 12;
  28.   MaxSubMenuItems = 12;
  29.   Sp              = 3;    { Number of additional pad spaces between  }
  30.                           { menu picks.  Sp = 3 gives 4 spaces total }
  31.  
  32.   XPos = 1; YPos = 1;     { Position of main menu. 1st pick padded with Sp above }
  33.  
  34. VAR
  35.  
  36.   MenuMsg   : Array[1..MaxMenuItems] of ShortStr;      { Main menu messages }
  37.   MenuLtr   : Array[1..MaxMenuItems] of Char;        { 1st letter of Main }
  38.   SubMenuMsg: Array[1..MaxMenuItems,                 { Sub menu messages }
  39.                     1..MaxSubMenuItems] of ShortStr;
  40.   SubMenuLtr: Array[1..MaxMenuItems,                 { Sub menu 1st letter }
  41.                     1..MaxSubMenuItems] of Char;
  42.   MenuOfs   : Array[1..MaxMenuItems] of Integer;     { Offset of main menu }
  43.   NumPicks  : Integer;                               { Number of main picks }
  44.   NumSubs   : Array[1..MaxMenuItems] of Integer;     { Number of sub picks }
  45.   Longest   : Array[1..MaxMenuItems] of Integer;     { longest string in subs }
  46.   Pick      : Integer;                     { Current main pick }
  47.   LastPick  : Integer;                     { Last main pick }
  48.   XP1,YP1   : Integer;                     { top left of submenu location }
  49.   XP2,YP2   : Integer;                     { bottom right of submenu location }
  50.   SPick     : Integer;                     { Current submenu pick }
  51.   LastSPick : Integer;                     { Last submenu pick }
  52.   WorkScreen : Screen;      { Used to save screen contents -- see IOStuff }
  53.   MenuScreen : Screen;      { Used to save screen contents -- see IOStuff }
  54.   RebuildMenu : Boolean;    { Switch to rebuild menu over new screen }
  55.   JustWroteSub: Boolean;    { Switch to skip rewriting submenu }
  56.   FirstTime   : Boolean;    { Used to skip some cleanup logic first time thru }
  57.  
  58. {============================================================================}
  59. PROCEDURE RestoreWorkScreen;
  60.  
  61. { Restores the working screen to its appearance at the last SaveWorkScreen }
  62.  
  63.  BEGIN
  64.   If Color then MoveToScreen(WorkScreen,CS,4000)
  65.            else Move(WorkScreen,MS,4000);
  66.  END;
  67.  
  68. {============================================================================}
  69. PROCEDURE SaveWorkScreen;
  70.  
  71. { Saves a new working screen.  Should be called in the main program }
  72. { any time you fiddle with the screen and want to save it }
  73.  
  74.  BEGIN
  75.   If Color then MoveFromScreen(CS,WorkScreen,4000)
  76.            else Move(MS,WorkScreen,4000);
  77.  
  78.   JustWroteSub := false;         { set these switches to rebuild menu }
  79.   RebuildMenu := true;
  80.  
  81.  END;
  82.  
  83. {============================================================================}
  84. PROCEDURE RestoreMenuScreen;
  85. { Used to save the contents of the screen after the main menu line written }
  86.  
  87.  BEGIN
  88.   If Color then MoveToScreen(MenuScreen,CS,4000)
  89.            else Move(MenuScreen,MS,4000);
  90.  END;
  91.  
  92. {============================================================================}
  93. PROCEDURE SaveMenuScreen;
  94. { Restores the screen to its appearance after the main menu line written }
  95.  
  96.  BEGIN
  97.   If Color then MoveFromScreen(CS,MenuScreen,4000)
  98.            else Move(MS,MenuScreen,4000);
  99.  END;
  100.  
  101. {============================================================================}
  102. PROCEDURE RebuildIt;
  103. { Flips the switches that trigger a complete rebuild of menus }
  104. { This is more efficient when you don't care if the screen is saved }
  105.  
  106.  BEGIN
  107.   JustWroteSub := false;         { set these switches to rebuild menu }
  108.   RebuildMenu := true;
  109.  END;
  110.  
  111. {============================================================================}
  112.   PROCEDURE SetMain(MenuStr:AnyStr);
  113.  
  114. { This Procedure sets the main (bar) menu.  Menu contents are contained in  }
  115. { string MenuStr and are delimited by an /.  Don't forget the last / }
  116.  
  117.   VAR
  118.     CPos     : Integer;       { Parsing variables }
  119.     Len,II   : Integer;
  120.     SaveAttr : Byte;
  121.  
  122.   BEGIN
  123.     SaveAttr := TextAttr;    { Save the colors }
  124.     Pick := 1;               { 1st pick }
  125.     LastPick := 1;
  126.     CPos := 1;
  127.     NumPicks := 0;
  128.     FirstTime := true;
  129.     SaveWorkScreen;         { Save the screen for restoration later }
  130.                             { SaveWorkScreen also triggers rebuild }
  131.     Repeat                  { Parse the main menu string }
  132.  
  133.       If NumPicks < MaxMenuItems then NumPicks := NumPicks + 1;
  134.                           { Find next substring delimited by an / }
  135.       Len := Pos('/',Copy(MenuStr,CPos,Length(MenuStr)+1-CPos))-1;
  136.                           { copy the substring into menu message array }
  137.       MenuMsg[NumPicks] := Copy(MenuStr,CPos,Len);
  138.                           { get the first letter of the menu message }
  139.       MenuLtr[NumPicks] := UpCase(MenuMsg[NumPicks,1]);
  140.                           { Calc menu offset.  Sp is pad spaces between picks}
  141.       MenuOfs[NumPicks] := CPos+Sp*(NumPicks);
  142.  
  143.       NumSubs[NumPicks] := 0;     {Initialize number of sub picks under this pick }
  144.  
  145.       CPos := CPos+Len+1;         { move parsing position to next substring }
  146.     Until CPos >= Length(MenuStr);
  147.  
  148.     TextAttr := SaveAttr;                              { restore colors }
  149.  
  150.   END;
  151.  
  152. {============================================================================}
  153.   PROCEDURE SetSub(Sub:Integer;SubStr:LongStr);
  154.  
  155. { This Procedure sets the sub menu.  Menu contents are contained in   }
  156. { string SubStr and are delimited by an /.  Don't forget the last /. }
  157. { Variable Sub is the number of the main menu the SubStr goes with }
  158.  
  159.   VAR
  160.     CPos,P,Len : Integer;
  161.  
  162.   BEGIN
  163.     CPos := 1;                  { Initialization }
  164.     NumSubs[Sub] := 0;
  165.     Longest[Sub] := 0;
  166.     Repeat           { String Parsing loop }
  167.                      { First increment the number of menu picks }
  168.       If NumSubs[Sub] < MaxMenuItems then NumSubs[Sub] := NumSubs[Sub] + 1;
  169.                      { Get the next substring delimited by a / }
  170.       Len := Pos('/',Copy(SubStr,CPos,Length(SubStr)+1-CPos))-1;
  171.                      { Copy the substring into the menu message }
  172.       SubMenuMsg[Sub,NumSubs[Sub]] := Copy(SubStr,CPos,Len);
  173.                      { Get the first letter }
  174.       SubMenuLtr[Sub,NumSubs[Sub]] := UpCase(SubMenuMsg[Sub,NumSubs[Sub],1]);
  175.                      { Remember the longest string length for padding later }
  176.       If Length(SubMenuMsg[Sub,NumSubs[Sub]]) > Longest[Sub]
  177.         then Longest[Sub] := Length(SubMenuMsg[Sub,NumSubs[Sub]]);
  178.       CPos := CPos+Len+1;            { Move parsing position to next string }
  179.     Until CPos >= Length(SubStr);    { End of parsing loop }
  180.  
  181.     For P := 1 to NumSubs[Sub] do Begin    { pad all strings to same length }
  182.       Len := Length(SubMenuMsg[Sub,P]);
  183.       FillChar(SubMenuMsg[Sub,P,Len+1],Longest[Sub]-Len,' '); { Pad with blanks }
  184.       SubMenuMsg[Sub,P,0] := Chr(Longest[Sub]);               { reset length }
  185.     End;
  186.  
  187.    SPick := 1;                 { Initialize submenu pick index here }
  188.    LastSPick := 1;
  189.  
  190.   END;
  191.  
  192. {============================================================================}
  193.   PROCEDURE WriteSub(Sub:Integer);
  194.  
  195. { This Procedure writes out the submenu }
  196.  
  197.   VAR
  198.     II       : Integer;
  199.     SaveAttr : Byte;
  200.  
  201.   BEGIN
  202.     If NumSubs[Sub] = 0 then exit;
  203.     SaveAttr := TextAttr;            { Save the color attributes }
  204.     XP1 := XPos+MenuOfs[Sub];
  205.     YP1 := YPos+2;
  206.     XP2 := XPos+MenuOfs[Sub]+Longest[Sub]+1;
  207.     YP2 := YPos+NumSubs[Sub]+1;
  208.     SavePartScreen(XP1-1,YP1-1,XP2+1,YP2+1);
  209.                                      { Draw a single line border }
  210.     SetColor(ColorF4,ColorB4);
  211.     SBorder(XP1-1,YP1-1,XP2+1,YP2+1,'');
  212.  
  213.     For II := 1 to NumSubs[Sub] do begin   { Write the menu messages }
  214.       SetColor(ColorF1,ColorB1);
  215.       WriteSt(' '+SubMenuMsg[Sub,II]+' ',XP1,YP1+II-1);
  216.       SetColor(ColorF2,ColorB2);
  217.       WriteCh(SubMenuLtr[Sub,II],XP1+1,YP1+II-1);
  218.     End;
  219.     TextAttr := SaveAttr;            { Restore the color attributes }
  220.  
  221.   END;
  222.  
  223. {============================================================================}
  224.   PROCEDURE WriteMain;
  225.  
  226. { This Procedure writes out the main menu }
  227.  
  228.   VAR
  229.     II       : Integer;
  230.     SaveAttr : Byte;
  231.   BEGIN
  232.     SaveAttr := TextAttr;        { Save the color attributes }
  233.     SetColor(ColorF1,ColorB1);
  234.     GoToXY(1,YPos);ClrEol;       { Clear the menu line }
  235.  
  236.     For II := 1 to NumPicks do begin  { Write the menu messages }
  237.  
  238.       SetColor(ColorF1,ColorB1);
  239.       WriteSt(MenuMsg[II],XPos+MenuOfs[II],YPos);  { Write Picks }
  240.       SetColor(ColorF2,ColorB2);
  241.       WriteCh(MenuLtr[II],XPos+MenuOfs[II],YPos);  { Write 1st letter }
  242.     End;
  243.     SaveMenuScreen;       { Save the screen image }
  244.     TextAttr := SaveAttr;
  245.    END;
  246. {============================================================================}
  247.   FUNCTION PickSub(Sub : Integer) : Char;
  248.  
  249. { This Function plays with the submenu and returns the first character }
  250. { of the selected menu item }
  251.  
  252. CONST
  253.      UpArrow   = #72;        { Keystrokes used }
  254.      Downarrow = #80;
  255.      EnterKey  = #13;
  256.      EscKey    = #27;
  257.      Abort     = #0;
  258. VAR
  259.   II        : Integer;       { General purpose loop index }
  260.   Ch        : Char;          { Keystroke character }
  261.   SubExit   : Boolean;       { Exit switch }
  262.   BeepOn    : Boolean;
  263.   FunctKey  : Boolean;       { True if dey is function key }
  264.   ExitCond  : Integer;       { Used for different exit conditions }
  265.   SaveAttr  : Byte;          { Color attributes }
  266.  
  267. BEGIN
  268.  SaveAttr := TextAttr;       { Save the current colors }
  269.  HideCursor;                 { Hide the cursor }
  270.  SubExit := False;          { Initialze exit switch }
  271.  ExitCond := 1;
  272.  If (SPick < 1) or (SPick > NumSubs[Sub]) then SPick := 1;
  273.  If (LastSPick < 1) or (LastSPick > NumSubs[Sub]) then LastSPick := 1;
  274.  
  275. If not JustWroteSub then begin
  276.  
  277.  If RebuildMenu then begin
  278.  
  279.    If not FirstTime then RestoreWorkScreen;
  280.    WriteMain;               { Reconstruct the main menu }
  281.    SetColor(ColorF3,ColorB3);
  282.                             { Rewrite active main menu pick in reverse }
  283.    WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  284.    WriteSub(Pick); { Reconstruct the submenu }
  285.    RebuildMenu := false;
  286.  End
  287.  else begin
  288.  
  289.    RestoreMenuScreen;
  290.    SetColor(ColorF3,ColorB3);
  291.                             { Rewrite active main menu pick in reverse }
  292.    WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  293.    WriteSub(Pick); { Reconstruct the submenu }
  294.  End;
  295.  
  296.  
  297. End;
  298.    FirstTime := False;
  299.    JustWroteSub := False;
  300.    SetColor(ColorF3,ColorB3);
  301.                             { Rewrite active sub menu pick in reverse }
  302.    WriteSt(' '+SubMenuMsg[Sub,SPick]+' ',XPos+MenuOfs[Sub],YPos+SPick+1);
  303.    LastSPick := SPick;
  304.  
  305.  Repeat     { Main keystroke reading loop -- continue until enter or escape }
  306.  
  307.    If SPick <> LastSPick then Begin
  308.                                     { First restore the last pick }
  309.       SetColor(ColorF1,ColorB1);
  310.       WriteSt(' '+SubMenuMsg[Sub,LastSPick]+' ',XPos+MenuOfs[Sub],YPos+LastSPick+1);
  311.       SetColor(ColorF2,ColorB2);
  312.       WriteCh(SubMenuLtr[Sub,LastSPick],XPos+MenuOfs[Sub]+1,YPos+LastSPick+1);
  313.                                     { Highlight new pick in reverse }
  314.       SetColor(ColorF3,ColorB3);
  315.       WriteSt(' '+SubMenuMsg[Sub,SPick]+' ',XPos+MenuOfs[Sub],YPos+SPick+1);
  316.  
  317.       LastSPick := SPick;            { Set last pick to current pick }
  318.  
  319.    End;
  320.      Ch := Readkey;     { Read a key }
  321.      If Ch  <> #0 then FunctKey := False else
  322.      Begin
  323.        Ch := ReadKey;
  324.        FunctKey := True;
  325.      End;
  326.  
  327.  
  328.   If not FunctKey then Case Ch of     { Handle non function keys here }
  329.     #32..#125: Begin                  { Check input char against 1st letters }
  330.                 BeepOn := True;
  331.                  For II := 1 to NumSubs[Sub] do Begin
  332.                                        { got a match }
  333.                    If UpCase(Ch) = SubMenuLtr[Sub,II] then Begin
  334.                       SPick := II;      { Set pick index to the matched char }
  335.                       SubExit := True; { Turn on exit switch }
  336.                       BeepOn := False;
  337.                    End;
  338.                  End;
  339.                 If BeepOn then Beep;    { You hit a bad character }
  340.                End;
  341.     EnterKey   : Begin                  { Ordinary exit }
  342.                 ExitCond := 1;
  343.                 SubExit := true;
  344.                End;
  345.     EscKey   : Begin                    { Abort exit }
  346.                 ExitCond := 2;
  347.                 SPick := 0;
  348.                 SubExit := true;
  349.                End;
  350.  
  351.    End; {case not functkey}
  352.  
  353.   If FunctKey then  Case Ch of            { Handle function keys here }
  354.        UpArrow   : SPick := Pred(SPick);  { Move up one }
  355.        DownArrow : SPick := Succ(SPick);  { Move down one }
  356.        Else Beep;
  357.  
  358.      End; {case functkey}
  359.  
  360.  
  361.    If SPick > NumSubs[Sub] then SPick := 1;    { Make sure Pick in bounds }
  362.    If SPick < 1 then Begin                     { User exited with up arrow }
  363.                 ExitCond := 2;                 { Handle like abort }
  364.                 SubExit := true;
  365.                End;
  366.  
  367.  
  368.  
  369.  Until SubExit;         { Bottom of big key reading loop }
  370.  
  371.       SetColor(ColorF1,ColorB1);   { Restore last pick on submenu }
  372.       WriteSt(' '+SubMenuMsg[Sub,LastSPick]+' ',XPos+MenuOfs[Sub],YPos+LastSPick+1);
  373.       SetColor(ColorF2,ColorB2);
  374.       WriteCh(SubMenuLtr[Sub,LastSPick],XPos+MenuOfs[Sub]+1,YPos+LastSPick+1);
  375.  
  376.  Case ExitCond of
  377.  2: Begin
  378.       PickSub := Abort;
  379.       JustWroteSub := true;
  380.      End;
  381.  
  382.  1: Begin
  383.       PickSub := SubMenuLtr[Sub,SPick];  {set function to letter }
  384.                                     { Highlight new pick in reverse }
  385.       SetColor(ColorF3,ColorB3);
  386.       WriteSt(' '+SubMenuMsg[Sub,SPick]+' ',XPos+MenuOfs[Sub],YPos+SPick+1);
  387.  
  388.      JustWroteSub := false;
  389.     End;
  390.  
  391.   End; {case}
  392.                          { Clean up and get out }
  393.  
  394.  ShowCursor;
  395.  TextAttr := SaveAttr;   { Restore colors }
  396. End;
  397.  
  398. {============================================================================}
  399. FUNCTION PickMain : Char;
  400.  
  401. { This Function returns the first character of the main menu item }
  402. { the user selected }
  403.  
  404. CONST
  405.      LeftArrow   = #75;      { Keystrokes used }
  406.      RightArrow  = #77;
  407.      DownArrow   = #80;
  408.      EnterKey    = #13;
  409.      EscKey      = #27;
  410.      Abort       = #0;
  411. VAR
  412.   II        : Integer;       { General purpose loop index }
  413.   Ch        : Char;          { Keystroke read in }
  414.   MainExit  : Boolean;       { Exit switch }
  415.   BeepOn    : Boolean;
  416.   FunctKey  : Boolean;       { True if input char is a function key }
  417.   SaveAttr : Byte;           { Save color attributes }
  418.  
  419. BEGIN
  420.  SaveAttr := TextAttr;       { Initialization }
  421.  MainExit := False;
  422.  HideCursor;
  423.  If (Pick < 1) or (Pick > NumPicks) then Pick := 1;
  424.  If Not JustWroteSub then begin
  425.   If RebuildMenu then begin
  426.  
  427.  
  428.     RestoreWorkScreen;
  429.  
  430.     WriteMain;               { Reconstruct the main menu }
  431.     SetColor(ColorF3,ColorB3);
  432.                              { Rewrite active main menu pick in reverse }
  433.     WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  434.     WriteSub(Pick); { Reconstruct the submenu }
  435.     RebuildMenu := false;
  436.   End
  437.   else begin
  438.     RestoreMenuScreen;
  439.     SetColor(ColorF3,ColorB3);
  440.                              { Rewrite active main menu pick in reverse }
  441.     WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);
  442.     WriteSub(Pick); { Reconstruct the submenu }
  443.   End;
  444.  
  445. End;
  446.  
  447.  Repeat                     { main keystroke loop }
  448.  
  449.      Ch := Readkey;
  450.      If Ch  <> #0 then FunctKey := False else
  451.      Begin
  452.        Ch := ReadKey;
  453.        FunctKey := True;
  454.      End;
  455.  
  456.  
  457.   If not FunctKey then Case Ch of
  458.     #32..#125: Begin
  459.                 BeepOn := True;
  460.                  For II := 1 to NumPicks do Begin
  461.                    If UpCase(Ch) = UpCase(MenuLtr[II]) then Begin
  462.                       Pick := II;
  463.                       MainExit := True;
  464.                       BeepOn := False;
  465.                    End;
  466.                  End;
  467.                 If BeepOn then Beep;
  468.                End;
  469.     EnterKey,
  470.     EscKey : MainExit := True;
  471.  
  472.    End; {case not functkey}
  473.  
  474.   If FunctKey then  Case Ch of
  475.        LeftArrow   : Pick := Pred(Pick);
  476.        RightArrow  : Pick := Succ(Pick);
  477.        DownArrow   : If NumSubs[Pick] > 0 then MainExit := true else beep;
  478.  
  479.        Else Beep;
  480.  
  481.      End; {case functkey}
  482.  
  483.  
  484.    If Pick > NumPicks then Pick := 1;
  485.    If Pick < 1 then Pick := NumPicks;
  486.  
  487. If Pick <> LastPick then Begin
  488.  
  489.    SetColor(ColorF1,ColorB1);
  490.    WriteSt(' '+MenuMsg[LastPick]+' ',XPos+MenuOfs[LastPick]-1,YPos);  { Write Picks }
  491.    SetColor(ColorF2,ColorB2);
  492.    WriteCh(MenuLtr[LastPick],XPos+MenuOfs[LastPick],YPos);  { Write 1st letter }
  493.    If NumSubs[LastPick] > 0 then RestorePartScreen(XP1-1,YP1-1,XP2+1,YP2+1);
  494.    SetColor(ColorF3,ColorB3);
  495.    WriteSt(' '+MenuMsg[Pick]+' ',XPos-1+MenuOfs[Pick],YPos);  { Write a new pick }
  496.    WriteSub(Pick);
  497.    LastPick := Pick;
  498.  End;
  499.  
  500.  Until MainExit;
  501.  
  502.  If Ch = EscKey then PickMain := Abort
  503.                 else PickMain := MenuLtr[Pick];
  504.  
  505.  JustWroteSub := true;
  506.  SPick := 1;
  507.  LastSPick := 1;
  508.  ShowCursor;
  509.  TextAttr := SaveAttr;
  510. End;
  511.  
  512. END. {of unit}
  513.