FMD output now functional, no media support yet

3 files changed, 352 insertions, 1 deletions

diff --git a/src/deck_io.adb b/src/deck_io.adb
index 9e5b4b7..8a3637e 100644
--- a/src/deck_io.adb
+++ b/src/deck_io.adb
@@ -8,6 +8,7 @@ with
     Ada.Strings.Maps,
     Ada.Text_IO,
     CSV,
+    FMD,
     GNAT.Regpat,
     GNATCOLL.JSON,
     UnZip;
@@ -377,6 +378,7 @@ package body Deck_IO is
                 end if;
             end loop;
             Close (File_Handle);
+            Counter := Counter + 1;
         end loop;
     end Write_CSV;
 
@@ -391,8 +393,44 @@ package body Deck_IO is
             Media     : in Media_Maps.Map;
             Overwrite : in Boolean := False)
     is
+        procedure Put_Fields is new FMD.Put_Fields (Field_Ordinal, Field_ID, Field_ID_Vectors);
+        procedure Put_Pack is new FMD.Put_Pack (Field_Ordinal, Field_ID, Field_ID_Vectors);
+        procedure Put_Entry is new FMD.Put_Entry (Field_Ordinal, Field, Field_Vectors);
+
+        Counter : Positive := 1;
+        Outname : SU.Unbounded_String;
+        File_Handle : File_Type;
+        Entry_Size : Positive;
     begin
-        null;
+        for C in Models.Iterate loop
+            Outname := Compose_Name (Directory, Basename, "fmd", Counter);
+            if FD.Exists (-Outname) then
+                if not Overwrite then
+                    raise FD.Name_Error;
+                else
+                    FD.Delete_File (-Outname);
+                end if;
+            end if;
+            Create (File_Handle, Out_File, -Outname);
+            Entry_Size := Positive (Model_Maps.Element (C).Fields.Length);
+            FMD.Put_Header (File_Handle);
+            Put_Fields (File_Handle, Model_Maps.Element (C).Fields);
+            FMD.Start_Pack_Section (File_Handle);
+            for Tmpl of Model_Maps.Element (C).Templates loop
+                Put_Pack (File_Handle, Tmpl.Question, Tmpl.Answer);
+            end loop;
+            FMD.End_Pack_Section (File_Handle);
+            FMD.Start_Entry_Section (File_Handle);
+            for N of Notes loop
+                if N.Model = Model_Maps.Key (C) then
+                    Put_Entry (File_Handle, N.Fields, Entry_Size);
+                end if;
+            end loop;
+            FMD.End_Entry_Section (File_Handle);
+            FMD.Put_Footer (File_Handle);
+            Close (File_Handle);
+            Counter := Counter + 1;
+        end loop;
     end Write_FMD;
 
 
diff --git a/src/fmd.adb b/src/fmd.adb
new file mode 100644
index 0000000..ae11660
--- /dev/null
+++ b/src/fmd.adb
@@ -0,0 +1,179 @@
+
+
+with
+
+    Ada.Characters.Latin_1,
+    Ada.Strings.Fixed,
+    Ada.Strings.Maps,
+    Ada.Text_IO;
+
+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 Data_Vectors.Vector)
+    is
+        Text : SU.Unbounded_String;
+    begin
+        Put_Line (File_Handle, (4 * ' ') & "<fields>");
+        for FID of Field_IDs loop
+            Text := To_Unbounded_String (FID);
+            Standard_Escapes (Text);
+            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 Data_Vectors.Vector;
+            A_Data      : in Data_Vectors.Vector)
+    is
+        Text : SU.Unbounded_String;
+    begin
+        Put_Line (File_Handle, (8 * ' ') & "<pack>");
+        Text := To_Unbounded_String (Q_Data.First_Element);
+        Standard_Escapes (Text);
+        Put_Line (File_Handle, (12 * ' ') & "<qst>" & (-Text) & "</qst>");
+        for I in Vector_Index range Vector_Index'Succ (Q_Data.First_Index) .. Q_Data.Last_Index loop
+            Text := To_Unbounded_String (Q_Data.Element (I));
+            Standard_Escapes (Text);
+            --  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 := To_Unbounded_String (FID);
+            Standard_Escapes (Text);
+            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 Data_Vectors.Vector;
+            Quantity    : in Positive)
+    is
+        Counter : Positive := 1;
+        Position : Vector_Index := 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 := To_Unbounded_String (Data.Element (Position));
+                Standard_Escapes (Text);
+                Put_Line (File_Handle, (12 * ' ') & "<f>" & (-Text) & "</f>");
+            else
+                Put_Line (File_Handle, (12 * ' ') & "<f></f>");
+            end if;
+            Position := Vector_Index'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 Escape
+           (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 Escape;
+
+
+    procedure Standard_Escapes
+           (Text : in out SU.Unbounded_String) is
+    begin
+        Escape (Text, '<', "&lt;");
+        Escape (Text, '>', "&gt;");
+        Escape (Text, '"', "&quot;");
+    end Standard_Escapes;
+
+
+end FMD;
+
+
diff --git a/src/fmd.ads b/src/fmd.ads
new file mode 100644
index 0000000..fe720d5
--- /dev/null
+++ b/src/fmd.ads
@@ -0,0 +1,134 @@
+
+
+with
+
+    Ada.Containers.Vectors,
+    Ada.Strings.Unbounded,
+    Ada.Text_IO;
+
+private with
+
+    Ada.Strings.Fixed,
+    Ada.Strings.Maps;
+
+
+package FMD is
+
+
+    procedure Put_Header
+           (File_Handle : in Ada.Text_IO.File_Type;
+            Version     : in String := "1.4");
+
+
+
+
+    generic
+
+        type Vector_Index is range <>;
+        type Vector_Data is private;
+
+        with package Data_Vectors is new Ada.Containers.Vectors (Vector_Index, Vector_Data);
+
+        with function To_Unbounded_String
+               (Data : in Vector_Data)
+            return Ada.Strings.Unbounded.Unbounded_String is <>;
+
+    procedure Put_Fields
+           (File_Handle : in Ada.Text_IO.File_Type;
+            Field_IDs   : in Data_Vectors.Vector);
+
+
+
+
+    procedure Start_Pack_Section
+           (File_Handle : in Ada.Text_IO.File_Type);
+
+
+    generic
+
+        type Vector_Index is range <>;
+        type Vector_Data is private;
+
+        with package Data_Vectors is new Ada.Containers.Vectors (Vector_Index, Vector_Data);
+
+        with function To_Unbounded_String
+               (Data : in Vector_Data)
+            return Ada.Strings.Unbounded.Unbounded_String is <>;
+
+    procedure Put_Pack
+           (File_Handle : in Ada.Text_IO.File_Type;
+            Q_Data      : in Data_Vectors.Vector;
+            A_Data      : in Data_Vectors.Vector)
+    with Pre => not Q_Data.Is_Empty and not A_Data.Is_Empty;
+
+
+    procedure End_Pack_Section
+           (File_Handle : in Ada.Text_IO.File_Type);
+
+
+
+
+    procedure Start_Entry_Section
+           (File_Handle : in Ada.Text_IO.File_Type);
+
+
+    generic
+
+        type Vector_Index is range <>;
+        type Vector_Data is private;
+
+        with package Data_Vectors is new Ada.Containers.Vectors (Vector_Index, Vector_Data);
+
+        with function To_Unbounded_String
+               (Data : in Vector_Data)
+            return Ada.Strings.Unbounded.Unbounded_String is <>;
+
+    procedure Put_Entry
+           (File_Handle : in Ada.Text_IO.File_Type;
+            Data        : in Data_Vectors.Vector;
+            Quantity    : in Positive);
+
+
+    procedure End_Entry_Section
+           (File_Handle : in Ada.Text_IO.File_Type);
+
+
+
+
+    procedure Put_Footer
+           (File_Handle : in Ada.Text_IO.File_Type);
+
+
+private
+
+
+    package SU renames Ada.Strings.Unbounded;
+
+
+    function "+"
+           (S : in String)
+        return SU.Unbounded_String
+        renames SU.To_Unbounded_String;
+
+    function "-"
+           (US : in SU.Unbounded_String)
+        return String
+        renames SU.To_String;
+
+
+
+
+    procedure Escape
+           (Text : in out SU.Unbounded_String;
+            Char : in     Character;
+            Sub  : in     String)
+    with Pre => Ada.Strings.Fixed.Count (Sub, Ada.Strings.Maps.To_Set (Char)) = 0;
+
+
+    procedure Standard_Escapes
+           (Text : in out SU.Unbounded_String);
+
+
+end FMD;
+
+