basis/unicode/collation/collation-tests.factor

   1 USING: arrays assocs compression.zlib fry grouping hash-sets
   2 io.encodings.binary io.encodings.string io.encodings.utf8
   3 io.files kernel math math.order math.parser sequences sets
   4 splitting strings tools.test unicode ;
   5 IN: unicode.collation.tests
   6
   7 : test-equality ( str1 str2 -- ? ? ? ? )
   8     { primary= secondary= tertiary= quaternary= }
   9     [ execute( a b -- ? ) ] 2with map
  10     first4 ;
  11
  12 { f f f f } [ "hello" "hi" test-equality ] unit-test
  13 { t f f f } [ "hello" "h\u0000e9llo" test-equality ] unit-test
  14 { t t f f } [ "hello" "HELLO" test-equality ] unit-test
  15 { t t t f } [ "hello" "h e l l o." test-equality ] unit-test
  16 { t t t t } [ "hello" "\0hello\0" test-equality ] unit-test
  17 { { "good bye" "goodbye" "hello" "HELLO" } }
  18 [ { "HELLO" "goodbye" "good bye" "hello" } sort-strings ] unit-test
  19
  20 : collation-test-lines ( -- lines )
  21     "vocab:unicode/UCA/CollationTest_SHIFTED.txt.zip"
  22     binary file-contents uncompress utf8 decode lines
  23     [ "#" head? ] reject harvest ;
  24
  25 : parse-collation-test-shifted ( -- lines )
  26     collation-test-lines
  27     [ ";" split first " " split [ hex> ] "" map-as ] map ;
  28
  29 : tail-from-last ( string char -- string' )
  30     '[ _ = ] dupd find-last drop 1 + tail ; inline
  31
  32 : line>test-weights ( string -- pair )
  33     ";" split1 [
  34         " " split [ hex> ] map
  35     ] [
  36         "#" split1 nip CHAR: [ tail-from-last
  37         "]" split1 drop
  38         "|" split 4 head
  39         [ " " split harvest [ hex> ] map ] map
  40     ] bi* 2array ;
  41
  42 ! These tests actually would pass if I didn't fix up
  43 ! the ducet table for Tibetan. It took me way too long to realize
  44 ! that the Unicode committee recommends fixing Tibetan collation
  45 ! yet ships tests that collation fails if you fix it.
  46 ! (Specifically the ducet entries for { 0x0FB2 0x0F71 } and { 0x0FB3 0x0F71 }
  47 ! cause these tests to fail)
  48 : xfailed-collation-tests ( -- seq )
  49     HS{
  50         { 3958 3953 820 }
  51
  52         { 4018 820 3953 3968 }
  53         { 4018 820 3968 3953 }
  54         { 4018 3953 1 3968 97 }
  55         { 4018 820 3969 }
  56
  57         { 3960 3953 820 }
  58         { 4019 820 3953 3968 }
  59         { 4019 820 3968 3953 }
  60         { 4019 3953 820 3968 }
  61         { 4019 3953 1 3968 97 }
  62     } ;
  63
  64 : parse-collation-test-weights ( -- weights )
  65     collation-test-lines
  66     [ line>test-weights ] map
  67     [ first xfailed-collation-tests in? ] reject ;
  68
  69 : calculate-collation ( chars collation -- collation-calculated collation-answer )
  70     [ >string collation-key/nfd drop ] [ { 0 } join ] bi* ;
  71
  72 : find-bad-collations ( pairs -- seq )
  73     [ first2 calculate-collation sequence= ] reject ;
  74
  75 { { } }
  76 [ parse-collation-test-weights find-bad-collations ] unit-test
  77
  78 { { } } [
  79     parse-collation-test-shifted
  80     2 clump >hash-set
  81
  82     ! Remove these two expected-fail Tibetan collation comparison tests
  83     ! They are bad tests once you fix up the ducet table with { 0x0FB2 0x0F71 } and { 0x0FB3 0x0F71 }
  84     {
  85         { { 4018 820 3969 } { 3959 33 } }
  86         { { 4019 3953 820 3968 } { 3961 33 } }
  87         { { 4019 98 } { 4019 3953 1 3968 97 } }
  88         { { 4028 98 } { 4018 3953 1 3968 97 } }
  89     } [ [ >string ] bi@ ] assoc-map >hash-set diff members
  90
  91     [ string<=> { +lt+ +eq+ } member? ] assoc-reject
  92 ] unit-test
  93
  94 ! XXX: Once again, these tests pass if you don't
  95 ! fix up the ducet table for { 0x0FB2 0x0F71 } and { 0x0FB3 0x0F71 }
  96 ! { +lt+ } [ { 4018 820 3969 } { 3959 33 } [ >string ] bi@ string<=> ] unit-test
  97 ! { +lt+ } [ { 4019 3953 820 3968 } { 3961 33 } [ >string ] bi@ string<=> ] unit-test