1 files changed, 179 insertions, 0 deletions
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;
+
+