From e2762a8a0dea2a93919db67d01ed7a48c8450400 Mon Sep 17 00:00:00 2001 From: Jed Barber Date: Sun, 13 Dec 2020 23:25:49 +1100 Subject: Calculator example program added --- example/calc.adb | 340 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 340 insertions(+) create mode 100644 example/calc.adb (limited to 'example/calc.adb') diff --git a/example/calc.adb b/example/calc.adb new file mode 100644 index 0000000..f7899f4 --- /dev/null +++ b/example/calc.adb @@ -0,0 +1,340 @@ + + +with + + Ada.Text_IO, + Ada.Strings.Unbounded, + Ada.Strings.Maps, + Ada.Strings.Fixed, + Ada.Command_Line, + Packrat.Standard, + Packrat.Utilities; + +use + + Ada.Text_IO; + + +procedure Calc is + + + type Lexer_Labels is (Whitespace, Decimal, Number, Bracket, Operator); + type Parser_Labels is (Sum, Product, Power, Factor, Negative); + + package My_Rat is new Packrat.Standard + (Lexer_Labels, Parser_Labels, Character, String); + + + + + -- Lexer Grammar + + -- ::= . | + -- ::= | + -- ::= 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 + + + function Is_Operator is new Packrat.Utilities.In_Set + (Ada.Strings.Maps.To_Set ("+-*/^")); + function Sat_Operator is new My_Rat.Lexers.Satisfy (Is_Operator); + function Operator is new My_Rat.Lexers.Stamp (Operator, Sat_Operator); + + function Is_Parens is new Packrat.Utilities.In_Set + (Ada.Strings.Maps.To_Set ("()")); + function Sat_Parens is new My_Rat.Lexers.Satisfy (Is_Parens); + function Bracket is new My_Rat.Lexers.Stamp (Bracket, Sat_Parens); + + function Sat_Digit is new My_Rat.Lexers.Satisfy (Packrat.Utilities.Is_Digit); + function Some_Digits is new My_Rat.Lexers.Many (Sat_Digit, 1); + function Number is new My_Rat.Lexers.Stamp (Number, Some_Digits); + + function Match_Point is new My_Rat.Lexers.Match ('.'); + function Decimal_Seq is new My_Rat.Lexers.Sequence + ((Some_Digits'Access, Match_Point'Access, Some_Digits'Access)); + function Decimal is new My_Rat.Lexers.Stamp (Decimal, Decimal_Seq); + + function Sat_Blank is new My_Rat.Lexers.Satisfy (Packrat.Utilities.Is_Whitespace); + function Many_Blank is new My_Rat.Lexers.Many (Sat_Blank, 1); + function Whitespace is new My_Rat.Lexers.Ignore (Whitespace, Many_Blank); + + package Scanner is new My_Rat.Lexers.Scan_Once + ((Whitespace'Access, Decimal'Access, Number'Access, + Bracket'Access, Operator'Access)); + + + + + -- Parser Grammar + + -- ::= + -- ::= + | - | + -- ::= * | / | + -- ::= ^ | + -- ::= ( ) | | + -- := - + + + package Sum_Redir is new My_Rat.Parsers.Redirect; + + function Is_Minus is new My_Rat.Lexer_Tokens.Is_Value ("-"); + function Sat_Minus is new My_Rat.Parsers.Satisfy (Is_Minus); + function Neg_Seq is new My_Rat.Parsers.Sequence_2 (Sat_Minus, Sum_Redir.Call); + function Negative is new My_Rat.Parsers.Stamp (Negative, Neg_Seq); + + function Is_Decimal is new My_Rat.Lexer_Tokens.Is_Label (Decimal); + function Is_Number is new My_Rat.Lexer_Tokens.Is_Label (Number); + function Is_Left_Parens is new My_Rat.Lexer_Tokens.Is_Value ("("); + function Is_Right_Parens is new My_Rat.Lexer_Tokens.Is_Value (")"); + function Sat_Decimal is new My_Rat.Parsers.Satisfy (Is_Decimal); + function Sat_Number is new My_Rat.Parsers.Satisfy (Is_Number); + function Sat_Left_Parens is new My_Rat.Parsers.Satisfy (Is_Left_Parens); + function Sat_Right_Parens is new My_Rat.Parsers.Satisfy (Is_Right_Parens); + function Fac_Num is new My_Rat.Parsers.Choice_2 (Sat_Decimal, Sat_Number); + function Fac_Between is new My_Rat.Parsers.Between + (Sat_Left_Parens, Sum_Redir.Call, Sat_Right_Parens); + function Fac_Choice is new My_Rat.Parsers.Choice + ((Fac_Between'Access, Negative'Access, Fac_Num'Access)); + function Factor is new My_Rat.Parsers.Stamp (Factor, Fac_Choice); + + function Is_Exp is new My_Rat.Lexer_Tokens.Is_Value ("^"); + function Sat_Exp is new My_Rat.Parsers.Satisfy (Is_Exp); + function Pow_Seq is new My_Rat.Parsers.Sequence + ((Factor'Access, Sat_Exp'Access, Factor'Access)); + function Pow_Choice is new My_Rat.Parsers.Choice_2 (Pow_Seq, Factor); + function Power is new My_Rat.Parsers.Stamp (Power, Pow_Choice); + + package Product_Redir is new My_Rat.Parsers.Redirect; + + function Is_Mult is new My_Rat.Lexer_Tokens.Is_Value ("*"); + function Is_Div is new My_Rat.Lexer_Tokens.Is_Value ("/"); + function Sat_Mult is new My_Rat.Parsers.Satisfy (Is_Mult); + function Sat_Div is new My_Rat.Parsers.Satisfy (Is_Div); + function Prod_Mul is new My_Rat.Parsers.Sequence + ((Product_Redir.Call'Access, Sat_Mult'Access, Power'Access)); + function Prod_Div is new My_Rat.Parsers.Sequence + ((Product_Redir.Call'Access, Sat_Div'Access, Power'Access)); + function Prod_Choice is new My_Rat.Parsers.Choice + ((Prod_Mul'Access, Prod_Div'Access, Power'Access)); + function Product is new My_Rat.Parsers.Stamp (Product, Prod_Choice); + + function Is_Plus is new My_Rat.Lexer_Tokens.Is_Value ("+"); + function Sat_Plus is new My_Rat.Parsers.Satisfy (Is_Plus); + function Sum_Plus is new My_Rat.Parsers.Sequence + ((Sum_Redir.Call'Access, Sat_Plus'Access, Product'Access)); + function Sum_Minus is new My_Rat.Parsers.Sequence + ((Sum_Redir.Call'Access, Sat_Minus'Access, Product'Access)); + function Sum_Choice is new My_Rat.Parsers.Choice + ((Sum_Plus'Access, Sum_Minus'Access, Product'Access)); + function Sum is new My_Rat.Parsers.Stamp (Sum, Sum_Choice); + + function Expr is new My_Rat.Parsers.Sequence_2 (Sum, My_Rat.Parsers.End_Of_Input); + + package Parser is new My_Rat.Parsers.Parse_Once (Expr); + + + + + type Calc_Result is delta 10.0**(-9) digits 18; + + + function Value + (Tok : in My_Rat.Parser_Tokens.Finished_Token_Type) + return String + is + Lexed : My_Rat.Lexer_Tokens.Token_Array := + My_Rat.Parser_Tokens.Value (Tok.Token); + begin + if Lexed'Length = 0 then + return ""; + else + return My_Rat.Lexer_Tokens.Value (Lexed (Lexed'First)); + end if; + end Value; + + + function Element + (Subs : in My_Rat.Parse_Graphs.Token_Group_Array; + Ind : in Positive) + return My_Rat.Parser_Tokens.Finished_Token_Type is + begin + return My_Rat.Parse_Graphs.Element (Subs (Subs'First), Ind); + end Element; + + + function Is_Integer + (Val : in Calc_Result) + return Boolean is + begin + return Val = Calc_Result (Integer (Val)); + end Is_Integer; + + + function To_Result + (Str : in String) + return Calc_Result + is + Point : Natural := Ada.Strings.Fixed.Index (Str, "."); + begin + if Point = 0 then + return Calc_Result (Integer'Value (Str)); + else + return Calc_Result (Integer'Value (Str (Str'First .. Point - 1))) + + Calc_Result (Integer'Value (Str (Point + 1 .. Str'Last))) / + Calc_Result (10 ** (Str'Last - Point)); + end if; + end To_Result; + + + function Evaluate + (Graph : in My_Rat.Parser_Result; + Position : in My_Rat.Parser_Tokens.Finished_Token_Type) + return Calc_Result + is + Subgroups : My_Rat.Parse_Graphs.Token_Group_Array := Graph.Subgroups (Position); + Temp : Calc_Result; + begin + case My_Rat.Parser_Tokens.Label (Position.Token) is + when Sum => + if Value (Position) = "+" then + return Evaluate (Graph, Element (Subgroups, 1)) + + Evaluate (Graph, Element (Subgroups, 2)); + elsif Value (Position) = "-" then + return Evaluate (Graph, Element (Subgroups, 1)) - + Evaluate (Graph, Element (Subgroups, 2)); + else + return Evaluate (Graph, Element (Subgroups, 1)); + end if; + when Product => + if Value (Position) = "*" then + return Evaluate (Graph, Element (Subgroups, 1)) * + Evaluate (Graph, Element (Subgroups, 2)); + elsif Value (Position) = "/" then + Temp := Evaluate (Graph, Element (Subgroups, 2)); + if Temp = 0.0 then + raise Constraint_Error with "Div by zero"; + end if; + return Evaluate (Graph, Element (Subgroups, 1)) / Temp; + else + return Evaluate (Graph, Element (Subgroups, 1)); + end if; + when Power => + if Value (Position) = "^" then + Temp := Evaluate (Graph, Element (Subgroups, 2)); + if not Is_Integer (Temp) then + raise Constraint_Error with "Non integer exponent"; + end if; + return Calc_Result + (Long_Float (Evaluate (Graph, Element (Subgroups, 1))) ** Integer (Temp)); + else + return Evaluate (Graph, Element (Subgroups, 1)); + end if; + when Factor => + if Subgroups'Length = 0 then + return To_Result (Value (Position)); + else + return Evaluate (Graph, Element (Subgroups, 1)); + end if; + when Negative => + return Calc_Result'(0.0) - Evaluate (Graph, Element (Subgroups, 1)); + end case; + end Evaluate; + + + function Image + (Val : in Calc_Result) + return String is + begin + return Val'Image; + end Image; + + + + + package SU renames Ada.Strings.Unbounded; + package Comlin renames Ada.Command_Line; + + Comlin_Input : SU.Unbounded_String; + Silent_Running : Boolean := False; + Real_Arg_Count : Natural := 0; + + +begin + + + Sum_Redir.Set (Sum'Access); + Product_Redir.Set (Product'Access); + + + for I in 1 .. Comlin.Argument_Count loop + if Comlin.Argument (I) /= "--silent" then + Real_Arg_Count := Real_Arg_Count + 1; + end if; + end loop; + + + if Real_Arg_Count = 0 then + Put_Line ("Command Line Calculator"); + New_Line; + Put_Line ("This program calculates elementary mathematical"); + Put_Line ("expressions it receives as command line arguments."); + Put_Line ("Naturally, it needs you to supply arguments for that."); + Put_Line ("You may have to use quotes to ensure the shell doesn't mess with input."); + New_Line; + Put_Line ("Accepted operators are + - * / ^ ()"); + Put_Line ("Please ensure exponents are always integers and divisors are never zero."); + New_Line; + Put_Line ("If you do not want to see any output beyond the answer,"); + Put_Line ("then use the --silent switch."); + return; + end if; + + + for I in 1 .. Comlin.Argument_Count loop + if Comlin.Argument (I) = "--silent" then + Silent_Running := True; + else + SU.Append (Comlin_Input, Comlin.Argument (I) & " "); + end if; + end loop; + SU.Delete (Comlin_Input, SU.Length (Comlin_Input), SU.Length (Comlin_Input)); + + + declare + Input : String := SU.To_String (Comlin_Input); + Lexed_Tokens : My_Rat.Lexer_Result := Scanner.Scan (Input); + Result_Graph : My_Rat.Parser_Result := Parser.Parse (Lexed_Tokens); + Calculated : Calc_Result := Evaluate (Result_Graph, Result_Graph.Root_Elements (1)); + begin + if Silent_Running then + Put_Line (Image (Calculated)); + return; + end if; + + Put_Line ("Input:"); + Put_Line (Input); + New_Line; + + Put_Line ("Lexer token output:"); + for T of Lexed_Tokens loop + Put (My_Rat.Lexer_Tokens.Debug_String (T)); + end loop; + New_Line; + + Put_Line ("Parser graph output:"); + Put_Line (My_Rat.Parse_Graphs.Debug_String (Result_Graph)); + New_Line; + + Put_Line ("Root tokens:"); + for T of Result_Graph.Root_Elements loop + Put (My_Rat.Parser_Tokens.Debug_String (T)); + end loop; + New_Line; + + Put_Line ("Calculated result:"); + Put_Line (Image (Calculated)); + end; + + +end Calc; + + -- cgit