summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/deck_io.adb40
-rw-r--r--src/fmd.adb179
-rw-r--r--src/fmd.ads134
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;
+
+