path: root/src/preferences.adb

with Ada.Strings.Unbounded;
with Ada.Strings.Maps;


--  This source is licensed under Creative Commons CC0 v1.0.
--
--  To read the full text, see license.txt in the main directory of this repository
--  or go to https://creativecommons.org/publicdomain/zero/1.0/legalcode.txt
--
--  For a human readable summary, go to https://creativecommons.org/publicdomain/zero/1.0/


package body Preferences is


    package S renames Ada.Strings;
    package SU renames Ada.Strings.Unbounded;
    package SM renames Ada.Strings.Maps;




    generic
        type Range_Type is range <>;
        type Array_Type is array (Range_Type) of Natural;
    procedure Index_And_Count
           (Input : in     Array_Type;
            Value : in     Natural;
            Index :    out Range_Type;
            Count :    out Natural);


    procedure Index_And_Count
           (Input : in     Array_Type;
            Value : in     Natural;
            Index :    out Range_Type;
            Count :    out Natural) is
    begin
        Count := 0;
        for I in Range_Type loop
            if Input (I) = Value then
                Index := I;
                Count := Count + 1;
            end if;
        end loop;
    end Index_And_Count;




    --  Looks at the raw ranking list above the line and the Above_Ballot and
    --  turns it into a list of CandidateIDs in the order they were ranked.
    function Extract_Formal
           (Above_Input  : in     Above_Pref_Array;
            Formal_Prefs :    out Preference_Array)
        return Boolean
    is
        procedure Above_IC is new Index_And_Count
               (Above_Range, Above_Pref_Array);

        Extracted : Natural := 0;
        Working_Index : Above_Range;
        Working_Count : Natural;
        Formal_Index : Preference_Range := Preference_Range'First;
    begin
        Formal_Prefs := (others => Candidates.No_Candidate);
        Pref_Loop :
        for I in Above_Range loop
            Above_IC (Above_Input, Integer (I), Working_Index, Working_Count);
            exit when Working_Count /= 1;
            Extracted := Extracted + 1;
            for C of Above_Ballot.Element (Integer (Working_Index)) loop
                exit Pref_Loop when Formal_Index > Preference_Range'Last;
                Formal_Prefs (Formal_Index) := C;
                Formal_Index := Formal_Index + 1;
            end loop;
        end loop Pref_Loop;
        return Extracted >= Min_Above_Line;
    end Extract_Formal;




    --  Looks at the raw ranking list below the line and the Below_Ballot and
    --  turns it into a list of CandidateIDs in the order they were ranked.
    function Extract_Formal
           (Below_Input  : in     Below_Pref_Array;
            Formal_Prefs :    out Preference_Array)
        return Boolean
    is
        procedure Below_IC is new Index_And_Count
               (Below_Range, Below_Pref_Array);

        Extracted : Natural := 0;
        Working_Index : Below_Range;
        Working_Count : Natural;
        Formal_Index : Preference_Range := Preference_Range'First;
    begin
        Formal_Prefs := (others => Candidates.No_Candidate);
        if Formal_Index > Preference_Range'Last then
            return Extracted >= Min_Below_Line;
        end if;
        for I in Below_Range loop
            Below_IC (Below_Input, Integer (I), Working_Index, Working_Count);
            exit when Working_Count /= 1;
            Formal_Prefs (Formal_Index) := Below_Ballot.Element (Integer (Working_Index));
            Extracted := Extracted + 1;
            exit when Formal_Index = Preference_Range'Last;
            Formal_Index := Formal_Index + 1;
        end loop;
        return Extracted >= Min_Below_Line;
    end Extract_Formal;




    function Mark
           (Input     : in     SU.Unbounded_String;
            Output    :    out Natural;
            Remaining :    out SU.Unbounded_String)
        return Boolean is
    begin
        if  SU.Length (Input) > 0 and then
           (SU.Element (Input, 1) = '/' or else
            SU.Element (Input, 1) = '*')
        then
            Output := 1;
            Remaining := SU.Tail (Input, SU.Length (Input) - 1);
            return True;
        else
            return False;
        end if;
    end Mark;




    function Number
           (Input     : in     SU.Unbounded_String;
            Output    :    out Natural;
            Remaining :    out SU.Unbounded_String)
        return Boolean
    is
        First, Last : Natural;
    begin
        SU.Find_Token (Input, SM.To_Set ("1234567890"), S.Inside, First, Last);
        if First = 1 and Last > 0 then
            Output := Integer'Value (SU.Slice (Input, First, Last));
            Remaining := SU.Unbounded_Slice (Input, Last + 1, SU.Length (Input));
            return True;
        else
            return False;
        end if;
    end Number;




    function Comma
           (Input     : in     SU.Unbounded_String;
            Remaining :    out SU.Unbounded_String)
        return Boolean is
    begin
        if  SU.Length (Input) > 0 and then
            SU.Element (Input, 1) = ','
        then
            Remaining := SU.Tail (Input, SU.Length (Input) - 1);
            return True;
        else
            return False;
        end if;
    end Comma;




    generic
        type Range_Type is range <>;
        type Array_Type is array (Range_Type) of Natural;
    function Raw_Prefs
           (Input     : in     SU.Unbounded_String;
            Output    :    out Array_Type;
            Remaining :    out SU.Unbounded_String)
        return Boolean;


    function Raw_Prefs
           (Input     : in     SU.Unbounded_String;
            Output    :    out Array_Type;
            Remaining :    out SU.Unbounded_String)
        return Boolean
    is
        Working_Num : Natural;
        Index : Range_Type := Range_Type'First;
        This_In, This_Remaining : SU.Unbounded_String;
    begin
        Output := (others => 0);
        if Index > Range_Type'Last then
            Remaining := Input;
            return True;
        end if;
        This_In := Input;

        loop
            if  Number (This_In, Working_Num, This_Remaining) or else
                Mark (This_In, Working_Num, This_Remaining)
            then
                Output (Index) := Working_Num;
            else
                This_Remaining := This_In;
            end if;
            exit when Index = Range_Type'Last;
            Index := Index + 1;
            if not Comma (This_Remaining, This_In) then
                return False;
            end if;
        end loop;

        Remaining := This_Remaining;
        return True;
    end Raw_Prefs;




    procedure Optional_Line_Ending
           (Input     : in     SU.Unbounded_String;
            Remaining :    out SU.Unbounded_String) is
    begin
        if  SU.Length (Input) > 1 and then
            SU.Slice (Input, 1, 2) = Character'Val (13) & Character'Val (10)
        then
            Remaining := SU.Tail (Input, SU.Length (Input) - 2);
        elsif
            SU.Length (Input) > 0 and then
           (SU.Element (Input, 1) = Character'Val (13) or else
            SU.Element (Input, 1) = Character'Val (10))
        then
            Remaining := SU.Tail (Input, SU.Length (Input) - 1);
        else
            Remaining := Input;
        end if;
    end Optional_Line_Ending;




    function Parse_Preferences
           (Input : in String)
        return Preference_Array
    is
        use type SU.Unbounded_String;

        Above_Line : Above_Pref_Array;
        Below_Line : Below_Pref_Array;

        function Parse_Above_Line is new Raw_Prefs
               (Above_Range, Above_Pref_Array);

        function Parse_Below_Line is new Raw_Prefs
               (Below_Range, Below_Pref_Array);

        Result : Preference_Array;

        This_In, This_Remaining : SU.Unbounded_String;
    begin
        This_In := SU.To_Unbounded_String (Input);

        if  not Parse_Above_Line (This_In, Above_Line, This_Remaining) or else
            not Comma (This_Remaining, This_In) or else
            not Parse_Below_Line (This_In, Below_Line, This_Remaining)
        then
            return Empty_Array;
        end if;

        Optional_Line_Ending (This_Remaining, This_In);

        if  SU.Length (This_In) > 0 or else
           (not Extract_Formal (Below_Line, Result) and then
            not Extract_Formal (Above_Line, Result))
        then
            return Empty_Array;
        end if;

        return Result;
    end Parse_Preferences;


end Preferences;