home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TTT405.ZIP / MENUTTT.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-07-17  |  19.5 KB  |  507 lines
  1. {$S-,R-,V-,D-,T-}
  2. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  3. {         TechnoJocks Turbo Toolkit v4.05           Released: Jul 18, 1988    }
  4. {                                                                             }
  5. {         Module: MenuTTT     --    menu displaying procedures                }
  6. {                                                                             }
  7. {                  Copyright R. D. Ainsbury (c) 1986-88                       }
  8. {\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\}
  9.  
  10. Unit MenuTTT;
  11.  
  12. interface
  13.  
  14. Uses CRT, FastTTT, DOS, WinTTT, KeyTTT;
  15.  
  16.  
  17. const
  18.    Max_Choices = 30;
  19. type
  20.    Menu_record = record
  21.                   Heading1     : string;                { '' for no heading}
  22.                   Heading2     : string;
  23.                   Topic        : array[1..Max_Choices] of string;
  24.                   TotalPicks   : integer;
  25.                   PicksPerLine : byte;
  26.                   AddPrefix    : byte;                    {0 no, 1 No.'s, 2 Lets}
  27.                   TopLeftXY    : array[1..2] of byte;     {X,Y}
  28.                   Boxtype      : byte;                    {0,1,2,3, >3}
  29.                   Colors       : array[1..5] of byte;     {HF,HB,LF,LB,Box}
  30.                   Margins      : byte;
  31.                   AllowEsc     : boolean;                 {true if Esc will exit}
  32.                 end;
  33.  
  34. Procedure DisplayMenu(MenuDef: Menu_record;
  35.                       Window:Boolean;
  36.                       var Choice,Errorcode : integer);
  37. Implementation
  38.  
  39. Procedure MenuError(Code:byte);    {fatal error -- msg and halt}
  40. var Message:string;
  41. begin
  42.     {Clrscr;}
  43.     Case Code of
  44.     1 : Message := 'Fatal Error 1: Too Many Picks to display. Change PicksPerLine';
  45.     else Message := 'Aborting';
  46.     end; {case}
  47.     WriteAT(1,12,black,lightgray,Message);
  48.     Repeat Until keypressed;
  49.     Halt;
  50. end;    {proc MenuError}
  51.  
  52.  
  53. Procedure DisplayMenu(MenuDef: Menu_record;
  54.                       Window:Boolean;
  55.                       var Choice,Errorcode : integer);
  56. Const
  57. Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  58. Numbers  = '123456789';
  59. var
  60. I,J,X2,Y2,heading_Lines : integer;
  61. TextWidth : byte;
  62.  
  63.  
  64.     Function Int_to_Str(Number:Integer):string;
  65.     var Temp : string;
  66.     begin
  67.        Str(Number,temp);
  68.        Int_to_Str := temp;
  69.     end;
  70.  
  71.     Function  Str_to_Int(Str:string):integer;
  72.     var temp,code : integer;
  73.     begin
  74.         If length(Str) = 0 then
  75.            Str_to_Int := 0
  76.         else
  77.         begin
  78.             val(Str,temp,code);
  79.             if code = 0 then
  80.                Str_to_Int := temp
  81.             else
  82.                Str_to_Int := 0;
  83.         end;
  84.     end;
  85.  
  86.    Procedure GetDimensions;
  87.    var Fullwidth,MaxWidth: integer;
  88.  
  89.      Procedure Validate_Prefix;         { 0   no prefix  }
  90.      begin                              { 1   numbers prefix}
  91.          with MenuDef do                { 2   letters prefix}
  92.          begin                          { 3   function key prefix}
  93.              If PicksPerLine < 1 then PicksPerLine := 1;
  94.              If (TotalPicks = 10) and (AddPrefix = 1) then
  95.                 AddPrefix := 3;
  96.              If (TotalPicks > 10) and (AddPrefix in [1,3]) then
  97.                 AddPrefix := 2;
  98.              If (Addprefix > 3) or (TotalPicks > 26) or (Addprefix < 0) then
  99.                 Addprefix := 0;
  100.              end; {do}
  101.      end; {Validate_Prefix}
  102.  
  103.    Procedure Add_Prefix;
  104.    var I : integer;
  105.    begin
  106.        With MenuDef do
  107.        begin
  108.            Case AddPrefix of
  109.            1 : for I := 1 to TotalPicks do
  110.                    Topic[I] := int_to_str(I) + ' ' + Topic[I];
  111.            2 : for I := 1 to TotalPicks do
  112.                    Topic[I] := Copy(Alphabet,I,1) + ' ' + Topic[I];
  113.            3 : If TotalPicks < 10 then
  114.                   for I := 1 to TotalPicks do
  115.                       Topic[I] := 'F'+Int_to_Str(I) + ' ' + Topic[I]
  116.                else
  117.                begin                           {add extra space for F10 }
  118.                    for I := 1 to 9 do
  119.                        Topic[I] := 'F'+Int_to_Str(I) + '  ' + Topic[I];
  120.                    Topic[10] := 'F10 '+ Topic[10];
  121.                end;
  122.            end; {case}
  123.        end;  {do}
  124.    end;  {proc Add_Prefix}
  125.  
  126.      Procedure Find_Longest_Topic;
  127.      var
  128.        I,J: integer;
  129.      begin
  130.          with MenuDef do
  131.          begin
  132.              Textwidth := 0;
  133.              For I := 1 to TotalPicks do
  134.                  If length(Topic[I]) > TextWidth then
  135.                     Textwidth := length(Topic[I]);         {find the longest text}
  136.          end;  {with}
  137.      end;   {Proc Find_Widest_Line}
  138.  
  139.    Procedure Adjust_Text_Width(Len:integer);
  140.    var I,J : integer;
  141.    begin
  142.        With MenuDef do
  143.        begin
  144.            For I := 1 to TotalPicks do
  145.                If length(Topic[I]) > Len then         {reduce it}
  146.                   Delete(Topic[I],succ(Len),length(Topic[I]) - Len)
  147.                else                                  {expand it}
  148.                   For J := length(Topic[I]) + 1 to Textwidth do
  149.                       Topic[I] :=  Topic[I] + ' ';
  150.        end; {do}
  151.    end;
  152.  
  153.    Procedure Determine_MaxWidth;
  154.    {findout the max internal menu space - MaxWidth}
  155.    begin
  156.        with MenuDef do
  157.        begin
  158.            If margins < 0 then Margins := 0;
  159.            If not (BoxType in [0..9]) then
  160.               BoxType := 0;
  161.            MaxWidth := 80 - 2*Margins - 1; {-1 for arrow symbol to left of pick}
  162.            Case BoxType of
  163.            1..4 : MaxWidth := MaxWidth - 2;     {box sides}
  164.            5    : MaxWidth := pred(MaxWidth);    {box shadow}
  165.            6..9 : MaxWidth := MaxWidth - 3;     {box sides and shadow}
  166.            end;
  167.        end; {with}
  168.    end;
  169.  
  170.    Procedure Validate_PicksPerLine;
  171.    begin
  172.        With MenuDef do
  173.        begin
  174.            If succ(TextWidth)*PicksPerLine <= MaxWidth then
  175.               exit;  {no adjustment necessary, everything fits}
  176.            If (TextWidth-2)*PicksPerLine <= Maxwidth  then
  177.                TextWidth := pred(MaxWidth div PicksperLine)
  178.            else
  179.            begin
  180.                While succ(TextWidth)*PicksPerLine > MaxWidth do
  181.                      PicksPerLine := pred(PicksPerLine);
  182.                If PicksPerLine = 0 then
  183.                begin
  184.                    TextWidth := pred(MaxWidth);
  185.                    PicksPerLine := 1;
  186.                end;
  187.            end;
  188.        end; {with}
  189.    end;  {Proc Validate_PicksPerLine}
  190.  
  191.    Procedure Determine_X_Dimensions;
  192.    {Checks to see if the menu will fit, if it won't it changes something!}
  193.    begin
  194.        With MenuDef do
  195.        begin
  196.            Fullwidth := succ(Textwidth)*PicksPerLine + 2*Margins;
  197.            Case BoxType of
  198.            1..4 : FullWidth := FullWidth + 2;     {box sides}
  199.            5    : FullWidth := succ(FullWidth);   {box shadow}
  200.            6..9 : FullWidth := FullWidth + 3;     {box sides and shadow}
  201.            end; {Case}
  202.            If TopleftXY[1] < 1 then
  203.               TopleftXY[1] := (80 - Fullwidth)  div 2;
  204.            If TopLeftXY[1] + Fullwidth < 80 then
  205.               X2 := TopleftXY[1] + Fullwidth
  206.            else
  207.            begin
  208.                X2 := 80;
  209.                TopLeftXY[1] := 80 - Fullwidth + 1;
  210.            end;
  211.        end; {with}
  212.    end; {Proc Determine_X_Dimensions}
  213.  
  214.    Procedure Determine_Y_Dimensions;
  215.    var
  216.       BoxLines,
  217.       TopicLines,
  218.       FullDepth  : integer;
  219.    begin
  220.        With MenuDef do
  221.        begin
  222.            TopicLines := TotalPicks div PicksPerLine;  {no of full rows of picks}
  223.            If TotalPicks mod PicksPerLine > 0 then     {+1 if partial row of picks}
  224.               TopicLines := succ(TopicLines);
  225.            Case BoxType of
  226.            0    : Boxlines := 0;
  227.            1..5 : BoxLines :=  2;     {box sides}
  228.            6..9: BoxLines :=  3;     {box sides and shadow}
  229.            end;
  230.            Heading_Lines := 0;
  231.            If length(Heading1) > 0 then
  232.               Heading_Lines := succ(Heading_Lines);
  233.            If length(Heading2) > 0 then
  234.               Heading_Lines := succ(Heading_Lines);
  235.            If Heading_Lines > 0 then                   {add a line for a gap}
  236.               Heading_Lines := succ(Heading_Lines);    {gap above topics}
  237.            If BoxType = 5 then
  238.               Heading_Lines := succ(Heading_Lines);
  239.            Fulldepth := BoxLines+TopicLines+Heading_Lines;
  240.            If Heading_Lines > 0 then
  241.              Fulldepth := succ(Fulldepth);  {+1 gap below topics if headings}
  242.            If FullDepth > 25 then   {if it doesn't fit, drop off topics}
  243.            begin
  244.                If Heading_Lines > 0 then
  245.                   TotalPicks :=  (25 - BoxLines -Heading_Lines-1)*PicksPerLine
  246.                else
  247.                   TotalPicks :=  (25 - BoxLines - Heading_Lines)*PicksPerLine;
  248.                FullDepth := 25;
  249.            end;
  250.            If TopLeftXY[2] <= 0 then
  251.               TopLeftXY[2] := (25 - Fulldepth) div 2 +1;
  252.            If TopLeftXY[2] + Fulldepth - 1 <= 25 then
  253.            begin
  254.                If BoxType > 4 then   {shadow}
  255.                   Y2 := TopleftXY[2] + pred(Fulldepth) - 1
  256.                else
  257.                   Y2 := TopleftXY[2] + pred(Fulldepth);
  258.            end
  259.            else
  260.            begin
  261.                If BoxType > 4 then   {shadow}
  262.                   Y2 := 24
  263.                else
  264.                   Y2 := 25;
  265.                TopLeftXY[2] := 25 - Fulldepth + 1;
  266.            end;
  267.    end;   {do}
  268.    end; {Proc Determine_Y_Dimensions}
  269.  
  270.    begin                              {Get_Dimensions}
  271.        Validate_Prefix;
  272.        Add_Prefix;
  273.        Find_Longest_Topic;
  274.        Determine_MaxWidth;
  275.        Validate_PicksPerLine;
  276.        Adjust_Text_Width(TextWidth);
  277.        Determine_X_Dimensions;
  278.        Determine_Y_Dimensions;
  279.    end;   {proc GetDimensions}
  280.  
  281.    Procedure Write_Text(Item:integer;Highlight:boolean);
  282.    Var X,Y,A:integer;
  283.    begin
  284.        With MenuDEf do
  285.        begin
  286.            A := Item mod PicksPerLine;
  287.            Y := Item div PicksPerLine +TopleftXY[2] + ord(A <> 0);
  288.            Y := Y + Heading_lines - ord(Boxtype = 0);
  289.            If A = 0 then A := PicksPerLine;      {A is now the no of picks from left}
  290.            X := (A - 1)*(TextWidth + 1)+Margins+
  291.                 TopleftXY[1]+1 + ord(BoxType > 0);          {title width + 1 for a space}
  292.            If Highlight then
  293.            begin
  294.                WriteAt(X,Y,colors[1],colors[2],Topic[item]);
  295.                WriteAT(pred(X),Y,colors[5],colors[2],chr(16));  {write arrow head}
  296.            end
  297.            else
  298.            begin
  299.                WriteAT(X,Y,colors[3],colors[4],Topic[item]);
  300.                WriteAT(pred(X),Y,colors[3],colors[4],' ');       {remove arrow head}
  301.            end;
  302.        end;  {do}
  303.    end;  {Proc Write_Text}
  304.  
  305.    Procedure CreateMenu;
  306.    var I : integer;
  307.    begin
  308.    with MenuDef do
  309.    begin
  310.     If Window then
  311.            MkWin(TopleftXY[1],TopLeftXY[2],X2,Y2,colors[3],colors[4],0+shadow)
  312.     else
  313.     begin
  314.         ClearText(TopleftXY[1],TopLeftXY[2],X2,Y2,colors[3],colors[4]);
  315.         If (BoxType in [5..9]) and (TopleftXY[1] > 1) then      {draw a shadow}
  316.         begin
  317.             For I := TopleftXY[2]+1 to Y2+1 do
  318.                 WriteAt(pred(TopLeftXY[1]),I,colors[3],black,' ');
  319.             WriteAt(TopLeftXY[1],succ(Y2),colors[3],black,
  320.                 replicate(X2-succ(TopLeftXY[1]),' '));
  321.         end;
  322.     end;
  323.     Case Boxtype of
  324.     1..4: Box(TopLeftXY[1],TopLeftXY[2],X2,Y2,colors[5],colors[4],Boxtype);
  325.     5   : begin
  326.               WriteAT(TopleftXY[1],TopleftXY[2],colors[5],colors[4],
  327.                       replicate(succ(X2 - TopleftXY[1]),chr(223)));
  328.               WriteAT(TopleftXY[1],TopleftXY[2]+Heading_Lines-1,colors[5],colors[4],
  329.                       replicate(succ(X2 - TopleftXY[1]),chr(196)));
  330.           end;
  331.     6..9:Box(TopLeftXY[1],TopLeftXY[2],X2,Y2,colors[5],colors[4],Boxtype-5);
  332.     end; {case}
  333.  
  334.     If length(Heading1) > 0 then
  335.        WriteBetween(TopleftXY[1],X2,
  336.                     TopLeftXY[2]+ord(BoxType > 0),
  337.                     colors[1],colors[4],Heading1);
  338.     If length(Heading2) > 0 then
  339.        WriteBetween(TopleftXY[1],X2,
  340.                     TopLeftXY[2]+ord(BoxType > 0)+ord(Heading_Lines <> 2),
  341.                     colors[1],colors[4],Heading2);
  342.     For I := 1 to TotalPicks do
  343.         Write_Text(I,false);
  344.     Write_Text(Choice,True);       {Highlight Default}
  345.    end; {do}
  346.    end; {Proc CreateMenu}
  347.  
  348.    Procedure Process_Keystrokes;
  349.    var
  350.      Selected: Boolean;
  351.      CHpk:char;
  352.      Oldchoice:integer;
  353.    begin
  354.    Selected := false;
  355.    With MenuDef do
  356.    begin
  357.        Repeat
  358.              Chpk := GetKey;
  359.              Case upcase(CHpk) of
  360.              #208 : begin       {Cursor Down}
  361.                         Write_text(Choice,false);
  362.                         Choice := Choice + PicksPerLine;
  363.                         If Choice > TotalPicks then
  364.                            Choice := (Choice mod PicksPerLine) + 1;
  365.                         Write_Text(Choice,true);
  366.                     end;
  367.              #129 : If Choice + PicksPerLine  <= TotalPicks then  {Mouse Down}
  368.                     begin
  369.                         Write_text(Choice,false);
  370.                         Choice := Choice + PicksPerLine;
  371.                         Write_Text(Choice,true);
  372.                     end;
  373.              #200 : begin       {cursor up}
  374.                         Write_Text(Choice,false);
  375.                         Choice := Choice - PicksPerLine;
  376.                         If Choice < 1 then
  377.                         begin
  378.                            Choice := Choice + PicksPerline;
  379.                            Choice :=
  380.                              ((TotalPicks div PicksPerLine)*PicksPerLine)
  381.                              - PicksPerLine + 1 + Choice - 2;
  382.                            If Choice + PicksPerLine <= TotalPicks then
  383.                               Choice := Choice + PicksPerLine;   {phew!}
  384.                         end;
  385.                         Write_Text(Choice,true);
  386.                     end;
  387.              #128 : If Choice - PicksPerLine > 0 then   {Mouse up}
  388.                     begin
  389.                         Write_Text(Choice,false);
  390.                         Choice := Choice - PicksPerLine;
  391.                         Write_Text(Choice,true);
  392.                     end;
  393.              #203 : begin       {cursor left}
  394.                         Write_Text(Choice,False);
  395.                         Choice := pred(choice);
  396.                         If choice = 0 then Choice := TotalPicks;
  397.                         Write_Text(Choice,true);
  398.                     end;
  399.              #130 : If (pred(Choice) > 0)  {mouse left}
  400.                     and ( Choice mod PicksPerLine <> 1) then
  401.                     begin
  402.                         Write_Text(Choice,False);
  403.                         Choice := pred(choice);
  404.                         Write_Text(Choice,true);
  405.                     end;
  406.              ' ',
  407.              #205 : begin        {cursor right}
  408.                         Write_Text(Choice,false);
  409.                         Choice := succ(Choice);
  410.                         If choice > TotalPicks then Choice := 1;
  411.                         Write_Text(Choice,true);
  412.                     end;
  413.              #131 : If (succ(Choice) <= TotalPicks) {Mouse right}
  414.                     and ( Choice mod PicksPerLine <> 0) then
  415.                     begin
  416.                         Write_Text(Choice,false);
  417.                         Choice := succ(Choice);
  418.                         Write_Text(Choice,true);
  419.                     end;
  420.              #199 : begin         {home key}
  421.                         Write_Text(Choice,false);
  422.                         Choice := 1;
  423.                         Write_Text(Choice,true);
  424.                     end;
  425.              #207 : begin         {end key}
  426.                         Write_Text(Choice,false);
  427.                         Choice := TotalPicks;
  428.                         Write_Text(Choice,true);
  429.                     end;
  430.              #133,                 {Mouse enter}
  431.              #13  : begin          {enter key}
  432.                         Selected := true;
  433.                         Errorcode := 0;
  434.                     end;
  435.              #132,                    {Mouse Esc}
  436.              #27  : If AllowEsc then  {Esc}
  437.                     begin
  438.                         Selected := true;
  439.                         ErrorCode := 1;
  440.                     end
  441.                     else
  442.                     begin
  443.                         Write_Text(Choice,false);
  444.                         Choice := TotalPicks;
  445.                         Write_Text(Choice,true);
  446.                     end;
  447.              #187..#196 : If Addprefix = 3 then   {F1 to F10}
  448.                           begin
  449.                               Oldchoice := Choice;
  450.                               Case Upcase(Chpk) of
  451.                               #187 : If TotalPicks >= 1  then choice := 1 else choice := 0;
  452.                               #188 : If TotalPicks >= 2  then choice := 2 else choice := 0;
  453.                               #189 : If TotalPicks >= 3  then choice := 3 else choice := 0;
  454.                               #190 : If TotalPicks >= 4  then choice := 4 else choice := 0;
  455.                               #191 : If TotalPicks >= 5  then choice := 5 else choice := 0;
  456.                               #192 : If TotalPicks >= 6  then choice := 6 else choice := 0;
  457.                               #193 : If TotalPicks >= 7  then choice := 7 else choice := 0;
  458.                               #194 : If TotalPicks >= 8  then choice := 8 else choice := 0;
  459.                               #195 : If TotalPicks >= 9  then choice := 9 else choice := 0;
  460.                               #196 : If TotalPicks >= 10 then choice := 10 else choice := 0;
  461.                               end;  {case}
  462.                               If Choice = 0 then
  463.                                  Choice := Oldchoice
  464.                               else
  465.                               begin
  466.                                   Write_Text(Oldchoice,false);
  467.                                   Write_Text(Choice,true);
  468.                                   Selected := true;
  469.                                   Errorcode := 0;
  470.                               end;
  471.                           end;
  472.              '0'..'9': If (AddPrefix in [1,3]) then   {Number or Function Prefix} {4.02}
  473.                        begin
  474.                            If (Str_to_int(CHpk) in [1..TotalPicks]) then
  475.                            begin
  476.                                Write_Text(Choice,false);
  477.                                Choice := Str_to_Int(CHpk);
  478.                                Write_Text(Choice,true);
  479.                                Selected := true;
  480.                                ErrorCode := 0;
  481.                            end;
  482.                        end;
  483.              'A'..'Z': If AddPrefix = 2 then
  484.                           If (pos(upcase(CHpk),Alphabet) in [1..TotalPicks]) then
  485.                           begin
  486.                               Write_Text(Choice,false);
  487.                               Choice := pos(upcase(CHpk),Alphabet);
  488.                               Write_Text(Choice,true);
  489.                               Selected := true;
  490.                               Errorcode := 0;
  491.                           end;
  492.                        end;
  493.        Until Selected;
  494.    end; {do}
  495.   end; {proc Process_keystrokes}
  496.  
  497. begin
  498.    GetDimensions;
  499.    CreateMenu;
  500.    Horiz_Sensitivity := 2;  {two cursors left/right before mouse returns}
  501.    Process_Keystrokes;
  502.    If Window then RmWin;
  503. end;        {Main Procedure DisplayMenu}
  504.  
  505.  
  506. end.
  507.