-- 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;