steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

unicode.collation: minor cleanup.

paths
John Benediktsson 2018-03-14 15:45:01 -07:00
parent c5a7ce216b
commit 5acacf109b
1 changed files with 22 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
basis/unicode/collation/collation.factor
View File

@ -42,12 +42,12 @@ TUPLE: weight primary secondary tertiary ignorable? ;
ducet get-global insert-helpers ducet get-global insert-helpers
: base ( char -- base ) :: base ( char -- base )
{ {
{ [ dup 0x3400 0x4DB5 between? ] [ drop 0xFB80 ] } ! Extension A { [ char 0x03400 0x04DB5 between? ] [ 0xFB80 ] } ! Extension A
{ [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B { [ char 0x20000 0x2A6D6 between? ] [ 0xFB80 ] } ! Extension B
{ [ dup 0x4E00 0x9FC3 between? ] [ drop 0xFB40 ] } ! CJK { [ char 0x04E00 0x09FC3 between? ] [ 0xFB40 ] } ! CJK
[ drop 0xFBC0 ] ! Other [ 0xFBC0 ] ! Other
} cond ; } cond ;
: AAAA ( char -- weight ) : AAAA ( char -- weight )
@ -57,15 +57,20 @@ ducet get-global insert-helpers
0x7FFF bitand 0x8000 bitor 0 0 f weight boa ; 0x7FFF bitand 0x8000 bitor 0 0 f weight boa ;
: illegal? ( char -- ? ) : illegal? ( char -- ? )
{ [ "Noncharacter_Code_Point" property? ] [ category "Cs" = ] } 1|| ; {
[ "Noncharacter_Code_Point" property? ]
[ category "Cs" = ]
} 1|| ;
: derive-weight ( char -- weights ) : derive-weight ( char -- weights )
first dup illegal? first dup illegal? [
[ drop { } ] drop { }
[ [ AAAA ] [ BBBB ] bi 2array ] if ; ] [
[ AAAA ] [ BBBB ] bi 2array
] if ;
: building-last ( -- char ) : building-last ( -- char )
building get empty? [ 0 ] [ building get last last ] if ; building get [ 0 ] [ last last ] if-empty ;
: blocked? ( char -- ? ) : blocked? ( char -- ? )
combining-class dup { 0 f } member? combining-class dup { 0 f } member?
@ -98,8 +103,8 @@ ducet get-global insert-helpers
] { } map-as concat ; ] { } map-as concat ;
: append-weights ( weights quot -- ) : append-weights ( weights quot -- )
[ [ ignorable?>> ] reject ] dip [ [ ignorable?>> ] reject ] dip map
map [ zero? ] reject % 0 , ; inline [ zero? ] reject % 0 , ; inline
: variable-weight ( weight -- ) : variable-weight ( weight -- )
dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if , ; dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if , ;
@ -117,8 +122,11 @@ ducet get-global insert-helpers
PRIVATE> PRIVATE>
: completely-ignorable? ( weight -- ? ) : completely-ignorable? ( weight -- ? )
[ primary>> ] [ secondary>> ] [ tertiary>> ] tri {
[ zero? ] tri@ and and ; [ primary>> zero? ]
[ secondary>> zero? ]
[ tertiary>> zero? ]
} 1&& ;
: filter-ignorable ( weights -- weights' ) : filter-ignorable ( weights -- weights' )
f swap [ f swap [