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


with

    Ada.Characters.Latin_1,
    Ada.Strings.Fixed,
    Ada.Strings.Maps,
    Ada.Text_IO,
    Datatypes;

use

    Ada.Text_IO;


package body FMD is


    package Latin renames Ada.Characters.Latin_1;
    package Strfix renames Ada.Strings.Fixed;
    package Strmap renames Ada.Strings.Maps;

    function "*"
           (Left  : in Natural;
            Right : in Character)
        return String
        renames Ada.Strings.Fixed."*";




    procedure Put_Header
           (File_Handle : in Ada.Text_IO.File_Type;
            Version     : in String := "1.4") is
    begin
        Put_Line (File_Handle, "<?xml version=""1.0"" encoding=""UTF-8""?>");
        Put_Line (File_Handle, "<!DOCTYPE freshmemory-dict>");
        Put_Line (File_Handle, "<dict version=""" & Version & """>");
    end Put_Header;




    procedure Put_Fields
           (File_Handle : in Ada.Text_IO.File_Type;
            Field_IDs   : in Datatypes.Field_ID_Vector)
    is
        Text : SU.Unbounded_String;
    begin
        Put_Line (File_Handle, (4 * ' ') & "<fields>");
        for FID of Field_IDs loop
            Text := Prep (SU.Unbounded_String (FID));
            Put_Line (File_Handle, (8 * ' ') & "<field>" & (-Text) & "</field>");
        end loop;
        Put_Line (File_Handle, (4 * ' ') & "</fields>");
    end Put_Fields;




    procedure Start_Pack_Section
           (File_Handle : in Ada.Text_IO.File_Type) is
    begin
        Put_Line (File_Handle, (4 * ' ') & "<packs>");
    end Start_Pack_Section;


    procedure Put_Pack
           (File_Handle : in Ada.Text_IO.File_Type;
            Q_Data      : in Datatypes.Field_ID_Vector;
            A_Data      : in Datatypes.Field_ID_Vector)
    is
        Text : SU.Unbounded_String;
    begin
        Put_Line (File_Handle, (8 * ' ') & "<pack>");
        Text := Prep (SU.Unbounded_String (Q_Data.First_Element));
        Put_Line (File_Handle, (12 * ' ') & "<qst>" & (-Text) & "</qst>");
        for I in Datatypes.Field_Ordinal range
            Datatypes.Field_Ordinal'Succ (Q_Data.First_Index) .. Q_Data.Last_Index
        loop
            Text := Prep (SU.Unbounded_String (Q_Data.Element (I)));
            --  Fresh Memory unfortunately cannot cope with multiple question fields
            Put_Line (File_Handle, (12 * ' ') & "<!--" & "<qst>" & (-Text) & "</qst>" & "-->");
        end loop;
        for FID of A_Data loop
            Text := Prep (SU.Unbounded_String (FID));
            Put_Line (File_Handle, (12 * ' ') & "<ans>" & (-Text) & "</ans>");
        end loop;
        Put_Line (File_Handle, (8 * ' ') & "</pack>");
    end Put_Pack;


    procedure End_Pack_Section
           (File_Handle : in Ada.Text_IO.File_Type) is
    begin
        Put_Line (File_Handle, (4 * ' ') & "</packs>");
    end End_Pack_Section;




    procedure Start_Entry_Section
           (File_Handle : in Ada.Text_IO.File_Type) is
    begin
        Put_Line (File_Handle, (4 * ' ') & "<entries>");
    end Start_Entry_Section;


    procedure Put_Entry
           (File_Handle : in Ada.Text_IO.File_Type;
            Data        : in Datatypes.Field_Vector;
            Quantity    : in Positive)
    is
        use type Datatypes.Field_Ordinal;
        Counter : Positive := 1;
        Position : Datatypes.Field_Ordinal := Data.First_Index;
        Text : SU.Unbounded_String;
    begin
        Put_Line (File_Handle, (8 * ' ') & "<e>");
        while Counter <= Quantity loop
            if Position <= Data.Last_Index then
                Text := Prep (SU.Unbounded_String (Data.Element (Position)));
                Put_Line (File_Handle, (12 * ' ') & "<f>" & (-Text) & "</f>");
            else
                Put_Line (File_Handle, (12 * ' ') & "<f></f>");
            end if;
            Position := Datatypes.Field_Ordinal'Succ (Position);
            Counter := Counter + 1;
        end loop;
        Put_Line (File_Handle, (8 * ' ') & "</e>");
    end Put_Entry;


    procedure End_Entry_Section
           (File_Handle : in Ada.Text_IO.File_Type) is
    begin
        Put_Line (File_Handle, (4 * ' ') & "</entries>");
    end End_Entry_Section;




    procedure Put_Footer
           (File_Handle : in Ada.Text_IO.File_Type) is
    begin
        Put_Line (File_Handle, "</dict>");
    end Put_Footer;




    procedure Replace_All
           (Text : in out SU.Unbounded_String;
            Char : in     Character;
            Sub  : in     String)
    is
        Position : Natural;
    begin
        loop
            Position := SU.Index (Text, Strmap.To_Set (Char));
            exit when Position = 0;
            SU.Replace_Slice (Text, Position, Position, Sub);
        end loop;
    end Replace_All;


    procedure Replace_All
           (Text : in out SU.Unbounded_String;
            Item : in     String;
            Sub  : in     String)
    is
        Position : Natural;
    begin
        loop
            Position := SU.Index (Text, Item);
            exit when Position = 0;
            SU.Replace_Slice (Text, Position, Position + Item'Length - 1, Sub);
        end loop;
    end Replace_All;


    function Prep
           (Text : in SU.Unbounded_String)
        return SU.Unbounded_String
    is
        Result : SU.Unbounded_String := Text;
    begin
        --  Fresh Memory needs these character codes
        Replace_All (Result, '<', "&lt;");
        Replace_All (Result, '>', "&gt;");
        Replace_All (Result, '"', "&quot;");

        --  Not sure why these cause Fresh Memory to not load the dict
        --  Replace_All (Result, Latin.CR & Latin.LF, "<br>");
        --  Replace_All (Result, Latin.LF, "<br>");

        --  Fresh memory doesn't recognise these character codes so get rid of them
        --  Note that this list may not be complete
        Replace_All (Result, "&ndash;", "–");
        Replace_All (Result, "&rsquo;", "’");
        Replace_All (Result, "&lsquo;", "‘");
        Replace_All (Result, "&rdquo;", "”");
        Replace_All (Result, "&ldquo;", "“");

        return Result;
    end Prep;


end FMD;