1 ! Copyright (C) 2008 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators
4 combinators.short-circuit kernel locals make math math.order
5 math.parser namespaces sequences simple-flat-file splitting
13 TUPLE: weight primary secondary tertiary ignorable? ;
15 : parse-weight ( string -- weight )
17 weight new swap rest unclip CHAR: * = swapd >>ignorable?
18 swap "." split first3 [ hex> ] tri@
19 [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*
22 : parse-keys ( string -- chars )
23 " " split [ hex> ] "" map-as ;
25 : parse-ducet ( file -- ducet )
27 [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ;
29 "vocab:unicode/collation/allkeys.txt" parse-ducet ducet set-global
31 ! Fix up table for long contractions
32 : help-one ( assoc key -- )
33 ! Need to be more general? Not for DUCET, apparently
34 2 head 2dup swap key? [ 2drop ] [
35 [ [ 1string of ] with { } map-as concat ]
39 : insert-helpers ( assoc -- )
40 dup keys [ length 3 >= ] filter
41 [ help-one ] with each ;
43 ducet get-global insert-helpers
45 :: base ( char -- base )
47 { [ char 0x03400 0x04DB5 between? ] [ 0xFB80 ] } ! Extension A
48 { [ char 0x20000 0x2A6D6 between? ] [ 0xFB80 ] } ! Extension B
49 { [ char 0x04E00 0x09FC3 between? ] [ 0xFB40 ] } ! CJK
53 : AAAA ( char -- weight )
54 [ base ] [ -15 shift ] bi + 0x20 2 f weight boa ;
56 : BBBB ( char -- weight )
57 0x7FFF bitand 0x8000 bitor 0 0 f weight boa ;
59 : illegal? ( char -- ? )
61 [ "Noncharacter_Code_Point" property? ]
65 : derive-weight ( char -- weights )
69 [ AAAA ] [ BBBB ] bi 2array
72 : building-last ( -- char )
73 building get [ 0 ] [ last last ] if-empty ;
75 : blocked? ( char -- ? )
76 combining-class dup { 0 f } member?
77 [ drop building-last non-starter? ]
78 [ building-last combining-class = ] if ;
80 : possible-bases ( -- slice-of-building )
81 building get dup [ first non-starter? not ] find-last
82 drop [ 0 ] unless* tail-slice ;
84 :: ?combine ( char slice i -- ? )
85 i slice nth char suffix :> str
86 str ducet get-global key? dup
87 [ str i slice set-nth ] when ;
90 dup blocked? [ 1string , ] [
91 dup possible-bases dup length <iota>
92 [ ?combine ] 2with any?
93 [ drop ] [ 1string , ] if
96 : string>graphemes ( string -- graphemes )
97 [ [ add ] each ] { } make ;
99 : graphemes>weights ( graphemes -- weights )
101 dup weight? [ 1array ] ! From tailoring
102 [ dup ducet get-global at [ ] [ derive-weight ] ?if ] if
103 ] { } map-as concat ;
105 : append-weights ( weights quot -- )
106 [ [ ignorable?>> ] reject ] dip map
107 [ zero? ] reject % 0 , ; inline
109 : variable-weight ( weight -- )
110 dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if , ;
112 : weights>bytes ( weights -- byte-array )
115 [ [ primary>> ] append-weights ]
116 [ [ secondary>> ] append-weights ]
117 [ [ tertiary>> ] append-weights ]
118 [ [ variable-weight ] each ]
124 : completely-ignorable? ( weight -- ? )
127 [ secondary>> zero? ]
131 : filter-ignorable ( weights -- weights' )
133 [ nip ] [ primary>> zero? and ] 2bi
134 [ swap ignorable?>> or ]
135 [ swap completely-ignorable? or not ] 2bi