diff options
Diffstat (limited to 'src/deckdata-fmd.adb')
| -rw-r--r-- | src/deckdata-fmd.adb | 212 |
1 files changed, 212 insertions, 0 deletions
diff --git a/src/deckdata-fmd.adb b/src/deckdata-fmd.adb new file mode 100644 index 0000000..10040a0 --- /dev/null +++ b/src/deckdata-fmd.adb @@ -0,0 +1,212 @@ + + +-- This source is licensed under the Sunset License v1.0 + + +with + + Ada.Characters.Latin_1, + Ada.Strings.Fixed, + Ada.Strings.Maps, + Ada.Text_IO; + +use + + Ada.Text_IO; + + +package body Deckdata.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 Field_ID_Vector) + is + Text : SU.Unbounded_String; + begin + Put_Line (File_Handle, (4 * ' ') & "<fields>"); + for FID of Field_IDs loop + Text := Prep (SU.Unbounded_String (FID)); + 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 Field_ID_Vector; + A_Data : in Field_ID_Vector) + is + Text : SU.Unbounded_String; + begin + Put_Line (File_Handle, (8 * ' ') & "<pack>"); + Text := Prep (SU.Unbounded_String (Q_Data.First_Element)); + Put_Line (File_Handle, (12 * ' ') & "<qst>" & (-Text) & "</qst>"); + for I in Field_Ordinal + range Field_Ordinal'Succ (Q_Data.First_Index) .. Q_Data.Last_Index + loop + Text := Prep (SU.Unbounded_String (Q_Data.Element (I))); + -- 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 := Prep (SU.Unbounded_String (FID)); + 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 Field_Vector; + Quantity : in Positive) + is + Counter : Positive := 1; + Position : Field_Ordinal := 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 := Prep (SU.Unbounded_String (Data.Element (Position))); + Put_Line (File_Handle, (12 * ' ') & "<f>" & (-Text) & "</f>"); + else + Put_Line (File_Handle, (12 * ' ') & "<f></f>"); + end if; + Position := Field_Ordinal'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 Replace_All + (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 Replace_All; + + + procedure Replace_All + (Text : in out SU.Unbounded_String; + Item : in String; + Sub : in String) + is + Position : Natural; + begin + loop + Position := SU.Index (Text, Item); + exit when Position = 0; + SU.Replace_Slice (Text, Position, Position + Item'Length - 1, Sub); + end loop; + end Replace_All; + + + function Prep + (Text : in SU.Unbounded_String) + return SU.Unbounded_String + is + Result : SU.Unbounded_String := Text; + begin + -- Fresh Memory needs these character codes + Replace_All (Result, '<', "<"); + Replace_All (Result, '>', ">"); + Replace_All (Result, '"', """); + + -- Not sure why these cause Fresh Memory to not load the dict + -- Replace_All (Result, Latin.CR & Latin.LF, "<br>"); + -- Replace_All (Result, Latin.LF, "<br>"); + + -- Fresh memory doesn't recognise these character codes so get rid of them + -- Note that this list may not be complete + Replace_All (Result, "–", "–"); + Replace_All (Result, "’", "’"); + Replace_All (Result, "‘", "‘"); + Replace_All (Result, "”", "”"); + Replace_All (Result, "“", "“"); + + return Result; + end Prep; + + +end Deckdata.FMD; + + |