diff options
| -rw-r--r-- | src/deck_io.adb | 40 | ||||
| -rw-r--r-- | src/fmd.adb | 179 | ||||
| -rw-r--r-- | src/fmd.ads | 134 |
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, '<', "<"); + Escape (Text, '>', ">"); + Escape (Text, '"', """); + 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; + + |