--  Copyright © 2026 Lingenic LLC. All rights reserved.
--  Licensed under the Lingenic Source-Available License v2.3.
--  Production use requires a separate license from Licensor.
--  See LICENSE.md and COPYRIGHT in the project root.
--

-------------------------------------------------------------------------------
--  Lingenic-Text — Collation conformance test
--
--  Verifies the Unicode Collation Algorithm implementation against:
--
--    1. CollationTest_NON_IGNORABLE_SHORT.txt
--       Every consecutive pair of lines should Compare as Less or Equal
--       using Non_Ignorable variable weighting.
--
--    2. CollationTest_SHIFTED_SHORT.txt
--       Same test using Shifted variable weighting.
--
--  Each non-comment line contains space-separated hex codepoints.
--  The file is in collation order: each line must collate >= the previous.
-------------------------------------------------------------------------------

with Ada.Text_IO;
with Lingenic_Text.Collation;
with Lingenic_Text.Collation_Spec;
with Lingenic_Text.Normalization;
with Lingenic_Text.Properties;
with Lingenic_Text.UTF8;

procedure Test_Collation is

   use Ada.Text_IO;
   use Lingenic_Text;
   use Lingenic_Text.Collation;
   use Lingenic_Text.Collation_Spec;

   Init_OK : Boolean;

   ---------------------------------------------------------------------------
   --  Hex parsing
   ---------------------------------------------------------------------------

   function Is_Hex_Char (C : Character) return Boolean is
     (C in '0' .. '9' or C in 'A' .. 'F' or C in 'a' .. 'f');

   function Hex_To_CP (S : String) return Natural is
      Val : Natural := 0;
   begin
      for I in S'Range loop
         Val := Val * 16;
         case S (I) is
            when '0' .. '9' =>
               Val := Val + (Character'Pos (S (I)) - Character'Pos ('0'));
            when 'A' .. 'F' =>
               Val := Val + (Character'Pos (S (I)) - Character'Pos ('A') + 10);
            when 'a' .. 'f' =>
               Val := Val + (Character'Pos (S (I)) - Character'Pos ('a') + 10);
            when others =>
               return 0;
         end case;
      end loop;
      return Val;
   end Hex_To_CP;

   ---------------------------------------------------------------------------
   --  UTF-8 encoding buffer
   ---------------------------------------------------------------------------

   Max_Bytes : constant := 256;

   type UTF8_Buffer is record
      Data : Byte_Array (1 .. Max_Bytes) := [others => 0];
      Len  : Natural := 0;
   end record;

   procedure Encode_CP
     (CP  : Codepoint;
      Buf : in out UTF8_Buffer)
   is
      Pos     : Positive;
      Enc_Len : Positive;
   begin
      if Buf.Len >= Max_Bytes - 3 then
         return;
      end if;
      Pos := Buf.Len + 1;
      if Is_Scalar_Value (CP) then
         UTF8.Encode (CP, Buf.Data, Pos, Enc_Len);
         Buf.Len := Buf.Len + Enc_Len;
      end if;
   end Encode_CP;

   ---------------------------------------------------------------------------
   --  Parse a line of hex codepoints into a UTF-8 buffer
   ---------------------------------------------------------------------------

   procedure Parse_Line
     (Line          : String;
      Buf           : out UTF8_Buffer;
      Has_Surrogate : out Boolean)
   is
      I   : Natural := Line'First;
      Tok_Start : Natural;
      CP  : Natural;
   begin
      Buf := (Data => [others => 0], Len => 0);
      Has_Surrogate := False;

      while I <= Line'Last loop
         --  Skip spaces
         while I <= Line'Last and then Line (I) = ' ' loop
            I := I + 1;
         end loop;

         exit when I > Line'Last;

         --  Stop at comment '#'
         exit when Line (I) = '#';

         --  Read hex token
         if Is_Hex_Char (Line (I)) then
            Tok_Start := I;
            while I <= Line'Last and then Is_Hex_Char (Line (I)) loop
               I := I + 1;
            end loop;
            CP := Hex_To_CP (Line (Tok_Start .. I - 1));
            if CP >= 16#D800# and then CP <= 16#DFFF# then
               Has_Surrogate := True;
            end if;
            if CP <= Max_Codepoint and then Is_Scalar_Value (CP) then
               Encode_CP (CP, Buf);
            end if;
         else
            I := I + 1;
         end if;
      end loop;
   end Parse_Line;

   ---------------------------------------------------------------------------
   --  Convert a UTF-8 buffer to a hex codepoint string (e.g. "0041 0042")
   ---------------------------------------------------------------------------

   function Hex_Digit (N : Natural) return Character is
     (if N < 10 then Character'Val (Character'Pos ('0') + N)
      else Character'Val (Character'Pos ('A') + N - 10));

   function CP_To_Hex (CP : Natural) return String is
      --  Always emit at least 4 hex digits; use more for supplementary CPs.
      Buf : String (1 .. 6) := [others => '0'];
      V   : Natural := CP;
      I   : Natural := 6;
   begin
      while V > 0 and then I >= 1 loop
         Buf (I) := Hex_Digit (V mod 16);
         V := V / 16;
         I := I - 1;
      end loop;
      --  Return at least 4 digits
      if CP <= 16#FFFF# then
         return Buf (3 .. 6);
      else
         return Buf (1 .. 6);
      end if;
   end CP_To_Hex;

   function Buffer_To_Hex (Buf : UTF8_Buffer) return String is
      --  Maximum: 64 codepoints * 7 chars each ("10FFFF ") = 448 chars
      Result : String (1 .. 512) := [others => ' '];
      Pos    : Natural := 1;  --  position in Buf.Data
      Out_I  : Natural := 0;  --  chars written to Result
      CP     : Codepoint;
      Len    : Positive;
      Valid  : Boolean;
   begin
      if Buf.Len = 0 then
         return "(empty)";
      end if;
      while Pos <= Buf.Len loop
         UTF8.Decode (Buf.Data (1 .. Buf.Len), Pos, CP, Len, Valid);
         if not Valid then
            --  Skip invalid byte
            Pos := Pos + 1;
         else
            if Out_I > 0 then
               Out_I := Out_I + 1;
               Result (Out_I) := ' ';
            end if;
            declare
               Hex : constant String := CP_To_Hex (CP);
            begin
               for J in Hex'Range loop
                  Out_I := Out_I + 1;
                  exit when Out_I > Result'Last;
                  Result (Out_I) := Hex (J);
               end loop;
            end;
            Pos := Pos + Len;
         end if;
      end loop;
      return Result (1 .. Out_I);
   end Buffer_To_Hex;

   ---------------------------------------------------------------------------
   --  Run one test file
   ---------------------------------------------------------------------------

   procedure Run_Test
     (Filename : String;
      Option   : Variable_Weight_Option;
      Total    : in out Natural;
      Passed   : in out Natural;
      Failed   : in out Natural)
   is
      File       : File_Type;
      Prev_Buf   : UTF8_Buffer := (Data => [others => 0], Len => 0);
      Curr_Buf   : UTF8_Buffer;
      Have_Prev  : Boolean := False;
      Prev_Has_Surr : Boolean := False;
      Curr_Has_Surr : Boolean := False;
      Result     : Comparison_Result;
      OK         : Boolean;
      Line_Num   : Natural := 0;
      Data_Lines : Natural := 0;
      Skipped    : Natural := 0;
      Surr_Skip  : Natural := 0;
   begin
      Open (File, In_File, Filename);

      while not End_Of_File (File) loop
         declare
            Line : constant String := Get_Line (File);
         begin
            Line_Num := Line_Num + 1;

            --  Skip empty lines and comments
            if Line'Length = 0 then
               null;
            elsif Line (Line'First) = '#' then
               null;
            else
               --  Data line
               Parse_Line (Line, Curr_Buf, Curr_Has_Surr);

               if Curr_Buf.Len = 0 then
                  --  Empty after parsing — skip
                  null;
               elsif Curr_Has_Surr or else Prev_Has_Surr then
                  --  UTF-8 cannot encode surrogates, so lines containing
                  --  them produce mangled buffers.  Skip the comparison.
                  Surr_Skip := Surr_Skip + 1;
               elsif Have_Prev and then Prev_Buf.Len > 0 then
                  Data_Lines := Data_Lines + 1;

                  Compare
                    (Left    => Prev_Buf.Data (1 .. Prev_Buf.Len),
                     Right   => Curr_Buf.Data (1 .. Curr_Buf.Len),
                     Option  => Option,
                     Result  => Result,
                     Success => OK);

                  Total := Total + 1;

                  if not OK then
                     Skipped := Skipped + 1;
                     --  Don't count as failure; Compare may fail on
                     --  very long inputs or buffer overflow
                  elsif Result = Greater then
                     Failed := Failed + 1;
                     if Failed <= 20 then
                        Put_Line ("  FAIL at line" & Natural'Image (Line_Num)
                                  & ": previous > current");
                        Put_Line ("    prev: " & Buffer_To_Hex (Prev_Buf));
                        Put_Line ("    curr: " & Buffer_To_Hex (Curr_Buf));
                     end if;
                  else
                     Passed := Passed + 1;
                  end if;
               end if;

               Have_Prev := True;
               Prev_Buf  := Curr_Buf;
               Prev_Has_Surr := Curr_Has_Surr;
            end if;
         end;
      end loop;

      Close (File);

      Put_Line ("  Data lines:" & Natural'Image (Data_Lines));
      if Surr_Skip > 0 then
         Put_Line ("  Skipped (surrogates):" & Natural'Image (Surr_Skip));
      end if;
      if Skipped > 0 then
         Put_Line ("  Skipped (Compare failed):" & Natural'Image (Skipped));
      end if;
   end Run_Test;

   Total_All  : Natural := 0;
   Passed_All : Natural := 0;
   Failed_All : Natural := 0;

begin
   --  Initialize dependencies
   Properties.Initialize ("ucd", Init_OK);
   if not Init_OK then
      Put_Line ("FAIL: Properties.Initialize failed");
      return;
   end if;

   Normalization.Initialize ("ucd", Init_OK);
   if not Init_OK then
      Put_Line ("FAIL: Normalization.Initialize failed");
      return;
   end if;

   Collation.Initialize ("ucd", Init_OK);
   if not Init_OK then
      Put_Line ("FAIL: Collation.Initialize failed");
      return;
   end if;

   Put_Line ("Collation conformance test");
   Put_Line ("==========================");
   New_Line;

   --  Test 1: NON_IGNORABLE
   Put_Line ("Test 1: CollationTest_NON_IGNORABLE_SHORT.txt");
   Run_Test
     ("ucd/CollationTest/CollationTest_NON_IGNORABLE_SHORT.txt",
      Non_Ignorable, Total_All, Passed_All, Failed_All);
   New_Line;

   --  Test 2: SHIFTED
   Put_Line ("Test 2: CollationTest_SHIFTED_SHORT.txt");
   Run_Test
     ("ucd/CollationTest/CollationTest_SHIFTED_SHORT.txt",
      Shifted, Total_All, Passed_All, Failed_All);
   New_Line;

   --  Summary
   Put_Line ("========================================");
   Put_Line ("Total comparisons:" & Natural'Image (Total_All));
   Put_Line ("Passed:" & Natural'Image (Passed_All));
   Put_Line ("Failed:" & Natural'Image (Failed_All));
   New_Line;

   if Failed_All = 0 then
      Put_Line ("ALL COLLATION CONFORMANCE TESTS PASSED");
   else
      Put_Line ("SOME TESTS FAILED");
   end if;
end Test_Collation;