diff options
Diffstat (limited to 'src/fmd.adb')
-rw-r--r-- | src/fmd.adb | 179 |
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, '<', "<"); + Escape (Text, '>', ">"); + Escape (Text, '"', """); + end Standard_Escapes; + + +end FMD; + + |