path: root/example/calc.adb

--  This source is licensed under the Sunset License v1.0


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

    --  <number> ::= <digits> . <digits> | <digits>
    --  <digits> ::= <zerotonine> <digits> | <zerotonine>
    --  <zerotonine> ::= 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

    --  <expr> ::= <sum> <endofinput>
    --  <sum> ::= <sum> + <product> | <sum> - <product> | <product>
    --  <product> ::= <product> * <power> | <product> / <power> | <power>
    --  <power> ::= <factor> ^ <factor> | <factor>
    --  <factor> ::= ( <sum> ) | <negative> | <number>
    --  <negative> := - <sum>


    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;