home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / nicol / sti_tmnu / menucomp.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-04-06  |  15.5 KB  |  428 lines
  1. program MenuCompiler;                       { menu compiler program         }
  2. {$I-}                                       { turn off I/O checking         }
  3.  
  4. Uses
  5.   STI_STRN;
  6.  
  7. Const
  8.   MAXSTRLEN = 60;
  9.  
  10. Type
  11.   Dumm = array[1..2] of byte;
  12.   Head = record
  13.            Name      : string[MAXSTRLEN];
  14.            Version   : word;
  15.            Mode      : byte;
  16.            Save      : boolean;
  17.            BackColor : byte;
  18.            InputS    : byte;
  19.            NumMenus  : word;
  20.          end;
  21.   Sel  = record
  22.            Prompt    : string[MAXSTRLEN];
  23.            Jump      : boolean;
  24.            Value     : word;
  25.          end;
  26.   Posy = record
  27.            MenuID    : word;
  28.            Position  : longint;
  29.          end;
  30.   Ent  = record
  31.            MenuID    : word;
  32.            MenuTitle : string[MAXSTRLEN];
  33.            MenuType  : byte;
  34.            BorderType: byte;
  35.            BodyCol   : byte;
  36.            BorderCol : byte;
  37.            TextCol   : byte;
  38.            HighLight : byte;
  39.            PromptCol : byte;
  40.            TitleCol  : byte;
  41.            Size      : array[1..4] of byte;
  42.            SelectNum : word;
  43.          end;
  44.  
  45. Var
  46.   InputFile   : text;                       { input file                    }
  47.   OutputFile  : file;                       { output file                   }
  48.   Buffer      : string;                     { parse buffer                  }
  49.   Token       : string;                     { current token                 }
  50.   Header      : Head;                       { menu file header              }
  51.   HeadWRFlag  : boolean;                    { has the header been written   }
  52.   Buff        : Posy;                       { position buffer               }
  53.   Menu        : Ent;                        { currently processed menu      }
  54.   Select      : Sel;                        { currently processed selection }
  55.  
  56. {---------------------------------------------------------------------------}
  57.  
  58. procedure Error(Message : string);
  59.  
  60. begin
  61.   writeln;
  62.   writeln('Error : ',Message);
  63.   writeln;
  64.   halt;
  65. end;
  66.  
  67. {---------------------------------------------------------------------------}
  68.  
  69. procedure Usage;
  70.  
  71. begin
  72.   writeln;
  73.   writeln('Usage : MENUCOMP <inputfile> <menufile>');
  74.   writeln;
  75.   halt;
  76. end;
  77.  
  78. {---------------------------------------------------------------------------}
  79.  
  80. procedure Message;
  81.  
  82. begin
  83.   writeln;
  84.   writeln('                                 MENUCOMP');
  85.   writeln('                          The STI Menu Compiler');
  86.   writeln('         Copyright (C) 1990,1991,1992 By Sofware Technology International');
  87.   writeln('                            All Rights Reserved');
  88. end;
  89.  
  90. {---------------------------------------------------------------------------}
  91.  
  92. procedure SetFiles;
  93.  
  94. begin
  95.   assign(InputFile,ParamStr(1));
  96.   reset(InputFile);
  97.   if IOResult <> 0 then
  98.     Error('Could not open '+UpCaseStr(ParamStr(1)));
  99.   assign(OutputFile,ParamStr(2));
  100.   rewrite(OutputFile,1);
  101.   if IOResult <> 0 then
  102.     Error('Could not open '+UpCaseStr(ParamStr(2)));
  103. end;
  104.  
  105. {---------------------------------------------------------------------------}
  106.  
  107. function KeySearch(InString : string) : word;
  108.  
  109. begin
  110.   if InString = '%VERSION'                   then KeySearch := 0   else
  111.   if InString = '%MENUFILE'                  then KeySearch := 1   else
  112.   if InString = '%MODE'                      then KeySearch := 2   else
  113.   if InString = '%SAVE'                      then KeySearch := 3   else
  114.   if InString = '%BACKGROUND'                then KeySearch := 4   else
  115.   if InString = '%INPUT'                     then KeySearch := 5   else
  116.   if InString = '%MENU'                      then KeySearch := 6   else
  117.   if InString = '%MENU_TYPE'                 then KeySearch := 7   else
  118.   if InString = '%BODY_COLOR'                then KeySearch := 8   else
  119.   if InString = '%BORDER_COLOR'              then KeySearch := 9   else
  120.   if InString = '%TEXT_COLOR'                then KeySearch := 10  else
  121.   if InString = '%HIGHLIGHT_COLOR'           then KeySearch := 11  else
  122.   if InString = '%PROMPT_COLOR'              then KeySearch := 12  else
  123.   if InString = '%TITLE_COLOR'               then KeySearch := 13  else
  124.   if InString = '%SIZE'                      then KeySearch := 14  else
  125.   if InString = '%SELECTIONS'                then KeySearch := 15  else
  126.   if InString = '%END_MENU'                  then KeySearch := 16  else
  127.   if InString = '%END_MENUFILE'              then KeySearch := 17  else
  128.   if InString = '%NUMBER_MENUS'              then KeySearch := 18  else
  129.   if InString = '%BORDER_TYPE'               then KeySearch := 19  else
  130.   if InString = '%SELECTION'                 then KeySearch := 20  else
  131.  
  132.   if InString = 'BLACK'                      then KeySearch := 31  else
  133.   if InString = 'BLUE'                       then KeySearch := 32  else
  134.   if InString = 'GREEN'                      then KeySearch := 33  else
  135.   if InString = 'CYAN'                       then KeySearch := 34  else
  136.   if InString = 'RED'                        then KeySearch := 35  else
  137.   if InString = 'MAGENTA'                    then KeySearch := 36  else
  138.   if InString = 'YELLOW'                     then KeySearch := 37  else
  139.   if InString = 'WHITE'                      then KeySearch := 38  else
  140.   if InString = 'GREYTILED'                  then KeySearch := 39  else
  141.   if InString = 'BLACKREVERSE'               then KeySearch := 40  else
  142.   if InString = 'BLUEREVERSE'                then KeySearch := 41  else
  143.   if InString = 'GREENREVERSE'               then KeySearch := 42  else
  144.   if InString = 'CYANREVERSE'                then KeySearch := 43  else
  145.   if InString = 'REDREVERSE'                 then KeySearch := 44  else
  146.   if InString = 'MAGENTAREVERSE'             then KeySearch := 45  else
  147.   if InString = 'YELLOWREVERSE'              then KeySearch := 46  else
  148.   if InString = 'WHITEREVERSE'               then KeySearch := 47  else
  149.  
  150.  
  151.   if InString = 'NOBORDER'                   then KeySearch := 48  else
  152.   if InString = 'SPACEBORDER'                then KeySearch := 49  else
  153.   if InString = 'SINGLELINE'                 then KeySearch := 50  else
  154.   if InString = 'ROUNDCORNERSINGLE'          then KeySearch := 51  else
  155.   if InString = 'BIGBLOCK'                   then KeySearch := 52  else
  156.   if InString = 'THICKTOPTHINSIDES'          then KeySearch := 53  else
  157.   if InString = 'THICKDIAGONALCORNER'        then KeySearch := 54  else
  158.  
  159.   if InString = 'KEYS'                       then KeySearch := 90  else
  160.   if InString = 'MOUSE'                      then KeySearch := 91  else
  161.   if InString = 'BOTH'                       then KeySearch := 92  else
  162.      Error('Unrecognised token : '+InString);
  163. end;
  164.  
  165. {---------------------------------------------------------------------------}
  166.  
  167. procedure Write_Header;
  168.  
  169. Var
  170.   Loop  : word;
  171.   Dummy : Posy;
  172.  
  173. begin
  174.   Dummy.MenuID   := 0;
  175.   Dummy.Position := 0;
  176.   Seek(OutputFile,0);
  177.   BlockWrite(OutputFile,Header,sizeof(Header));
  178.   for Loop := 1 to Header.NumMenus do
  179.     BlockWrite(OutputFile,Dummy,sizeof(Posy));
  180. end;
  181.  
  182. {---------------------------------------------------------------------------}
  183.  
  184. procedure Write_Menu;
  185.  
  186. begin
  187.   Seek(OutputFile,sizeof(Header)+ (sizeof(Posy)*(Buff.MenuID-1)));
  188.   BlockWrite(OutputFile,Buff,sizeof(Posy));
  189.   Seek(OutputFile,Buff.Position);
  190.   BlockWrite(OutputFile,Menu,sizeof(Ent));
  191. end;
  192.  
  193. {---------------------------------------------------------------------------}
  194.  
  195. procedure Semantic_Action(KeyValue : word);
  196.  
  197. Var
  198.   Loop : word;
  199.   Test : integer;
  200.  
  201. begin
  202.   case KeyValue of
  203.     0  :  begin                             { %VERSION     X   X            }
  204.             Parse(Buffer,Token,' '#9);
  205.             Val(Token,Dumm(Header.Version)[1],Test);
  206.             Parse(Buffer,Token,' '#9);
  207.             Val(Token,Dumm(Header.Version)[2],Test);
  208.             Buffer := '';
  209.           end;
  210.     1  :  begin                             { %MENUFILE    "STRING"         }
  211.             FillChar(Header,32,sizeof(Head));
  212.             Header.Name := '';
  213.             Loop := pos('"',Buffer)+1;
  214.             while Buffer[Loop] <> '"' do
  215.               begin
  216.                 Header.Name := Header.Name + Buffer[Loop];
  217.                 Inc(Loop);
  218.               end;
  219.             Header.Name := Header.Name + #26' ';
  220.             Buffer := '';
  221.           end;
  222.     2  :  begin                             { %MODE TEXT/GRAPHICS           }
  223.             Parse(Buffer,Token,' '#9);
  224.             Token := UpCaseStr(Token);
  225.             if Token = 'TEXT' then
  226.               Header.Mode := 1
  227.             else if Token = 'GRAPHICS' then
  228.               Header.Mode := 2
  229.             else
  230.               Error('Unknown MODE : '+Token);
  231.             Buffer := '';
  232.           end;
  233.     3  :  begin                              { %SAVE YES/NO                 }
  234.             Parse(Buffer,Token,' '#9);
  235.             Token := UpCaseStr(Token);
  236.             if Token = 'YES' then
  237.               Header.Save := TRUE
  238.             else
  239.               Header.Save := FALSE;
  240.             Buffer := '';
  241.           end;
  242.     4  :  begin                             { %BACKGROUND   COLOR           }
  243.             Parse(Buffer,Token,' '#9);
  244.             Token := UpCaseStr(Token);
  245.             Header.BackColor := KeySearch(Token)-31;
  246.             Buffer := '';
  247.           end;
  248.     5  :  begin                             { %INPUT KEYS/MOUSE/BOTH        }
  249.             Parse(Buffer,Token,' '#9);
  250.             Token := UpCaseStr(Token);
  251.             Header.InputS := KeySearch(Token)-90;
  252.             Buffer := '';
  253.           end;
  254.     6  :  begin                             { %MENU XXXXX  "TITLE"/NULL    }
  255.             FillChar(Buff,32,sizeof(Posy));
  256.             FillChar(Menu,32,sizeof(Ent));
  257.             if not(HeadWRFlag) then
  258.               begin
  259.                 Write_Header;
  260.                 HeadWRFlag := TRUE;
  261.               end;
  262.             Buff.Position := FilePos(OutputFile);
  263.             Parse(Buffer,Token,' '#9);
  264.             Val(Token,Buff.MenuID,Test);
  265.             Menu.MenuID    := Buff.MenuID;
  266.             Menu.MenuTitle := '';
  267.             Loop := Pos('"',Buffer)+1;
  268.             if Loop > 1 then
  269.               begin
  270.                 while Buffer[Loop] <> '"' do
  271.                   begin
  272.                     if Buffer[Loop] = #13 then
  273.                       Error('Unterminated String in %MENU');
  274.                     Menu.MenuTitle := Menu.MenuTitle + Buffer[Loop];
  275.                     Inc(Loop);
  276.                   end;
  277.               end;
  278.             Buffer := '';
  279.           end;
  280.     7  :  begin                             { %MENUTYPE BAR/BOX             }
  281.             Parse(Buffer,Token,' '#9);
  282.             Token := UpCaseStr(Token);
  283.             if Token = 'BAR' then
  284.               Menu.MenuType := 1
  285.             else if Token = 'BOX' then
  286.               Menu.MenuType := 2
  287.             else
  288.               Error('Unrecognised menu type : '+Token);
  289.             Buffer := '';
  290.           end;
  291.     8  :  begin                             { %BODY_COLOR  COLOR            }
  292.             Parse(Buffer,Token,' '#9);
  293.             Token := UpCaseStr(Token);
  294.             Menu.BodyCol := KeySearch(Token)-31;
  295.             Buffer := '';
  296.           end;
  297.     9  :  begin                             { %BORDER_COLOR  COLOR          }
  298.             Parse(Buffer,Token,' '#9);
  299.             Token := UpCaseStr(Token);
  300.             Menu.BorderCol := KeySearch(Token)-31;
  301.             Buffer := '';
  302.           end;
  303.     10 :  begin                             { %TEXT_COLOR   COLOR           }
  304.             Parse(Buffer,Token,' '#9);
  305.             Token := UpCaseStr(Token);
  306.             Menu.TextCol := KeySearch(Token)-31;
  307.             Buffer := '';
  308.           end;
  309.     11 :  begin                             { %HIGHLIGHT_COLOR COLOR        }
  310.             Parse(Buffer,Token,' '#9);
  311.             Token := UpCaseStr(Token);
  312.             Menu.HighLight := KeySearch(Token)-31;
  313.             Buffer := '';
  314.           end;
  315.     12 :  begin                              { %PROMPT_COLOR   COLOR        }
  316.             Parse(Buffer,Token,' '#9);
  317.             Token := UpCaseStr(Token);
  318.             Menu.PromptCol := KeySearch(Token)-31;
  319.             Buffer := '';
  320.           end;
  321.     13 :  begin                              { %TITLE_COLOR  COLOR          }
  322.             Parse(Buffer,Token,' '#9);
  323.             Token := UpCaseStr(Token);
  324.             Menu.TitleCol := KeySearch(Token)-31;
  325.             Buffer := '';
  326.           end;
  327.     14 :  begin                             { %SIZE X1 Y1 X2 Y2             }
  328.             Parse(Buffer,Token,' '#9);
  329.             Val(Token,Menu.Size[1],Test);
  330.             Parse(Buffer,Token,' '#9);
  331.             Val(Token,Menu.Size[2],Test);
  332.             Parse(Buffer,Token,' '#9);
  333.             Val(Token,Menu.Size[3],Test);
  334.             Parse(Buffer,Token,' '#9);
  335.             Val(Token,Menu.Size[4],Test);
  336.             Buffer := '';
  337.           end;
  338.     15 :  begin                             { %SELECTIONS   XXXX            }
  339.             Parse(Buffer,Token,' '#9);
  340.             Val(Token,Menu.SelectNum,Test);
  341.             Buffer := '';
  342.             Write_Menu;
  343.           end;
  344.     16 :  begin                             { %END_MENU                     }
  345.           end;
  346.     17 :  begin                             { %END_MENUFILE                 }
  347.             Header.Name[length(Header.Name)] :=
  348.               char((FileSize(OutputFile) div 128)+2);
  349.             Seek(OutputFile,0);
  350.             BlockWrite(OutputFile,Header,sizeof(Header));
  351.             close(OutputFile);
  352.           end;
  353.     18 :  begin                             { %NUMBER_MENUS  XXXXX          }
  354.             Parse(Buffer,Token,' '#9);
  355.             Val(Token,Header.NumMenus,Test);
  356.             Buffer := '';
  357.           end;
  358.     19 :  begin                             { %BORDER_TYPE TYPE             }
  359.             Parse(Buffer,Token,' '#9);
  360.             Token := UpCaseStr(Token);
  361.             Menu.BorderType := KeySearch(Token)-48;
  362.             Buffer := '';
  363.           end;
  364.     20 :  begin                             { %SELECTION "PROMPT" RETURN/GOTO XX }
  365.             FillChar(Select,32,sizeof(Sel));
  366.             Loop := Pos('"',Buffer)+1;
  367.             Select.Prompt := '';
  368.             while Buffer[Loop] <> '"' do
  369.               begin
  370.                 Select.Prompt := Select.Prompt + Buffer[Loop];
  371.                 Inc(Loop);
  372.               end;
  373.             Buffer := Copy(Buffer,Loop+1,255);
  374.             Parse(Buffer,Token,' '#9);
  375.             Token := UpCaseStr(Token);
  376.             if Token = 'RETURN' then
  377.               Select.Jump := FALSE
  378.             else if Token = 'GOTO' then
  379.               Select.Jump := TRUE
  380.             else
  381.               Error('Unrecognised RETURN/GOTO : '+Token);
  382.             Parse(Buffer,Token,' '#9);
  383.             Val(Token,Select.Value,Test);
  384.             Buffer := '';
  385.             BlockWrite(OutputFile,Select,sizeof(Sel));
  386.           end;
  387.     else
  388.       Error('Unknown  Command : '+Token);
  389.   end;{case}
  390. end;
  391.  
  392. {---------------------------------------------------------------------------}
  393.  
  394. procedure ParseMenu;
  395.  
  396. var
  397.   Count : word;
  398.  
  399. begin
  400.   Count := 0;
  401.   HeadWRFlag := FALSE;
  402.   while not(eof(InputFile)) do
  403.     begin
  404.       Inc(Count);
  405.       readln(InputFile,Buffer);
  406.       write(#13,'Compiled ',Count,' Lines  ');
  407.       while Buffer <> '' do
  408.         begin
  409.           Parse(Buffer,Token,' '#9);
  410.           if Token[1] = ';' then
  411.             Buffer := ''
  412.           else
  413.             Semantic_Action(KeySearch(UpCaseStr(Token)));
  414.         end;
  415.     end;
  416.   close(InputFile);
  417. end;
  418.  
  419. {---------------------------------------------------------------------------}
  420.  
  421. begin
  422.   Message;
  423.   if ParamCount < 2 then
  424.     Usage;
  425.   SetFiles;
  426.   ParseMenu;
  427. end.
  428.