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 combinators.smart kernel locals make
5 math math.order math.parser namespaces sequences
6 simple-flat-file splitting strings unicode.data ;
13 TUPLE: weight-levels primary secondary tertiary ignorable? ;
14 : <weight-levels> ( primary secondary tertiary -- weight-levels> )
18 swap >>primary ; inline
20 : parse-weight ( string -- weight )
22 weight-levels new swap rest unclip CHAR: * = swapd >>ignorable?
23 swap "." split first3 [ hex> ] tri@
24 [ >>primary ] [ >>secondary ] [ >>tertiary ] tri*
27 : parse-keys ( string -- chars )
28 " " split [ hex> ] "" map-as ;
30 : parse-ducet ( file -- ducet )
31 load-data-file [ [ parse-keys ] [ parse-weight ] bi* ] H{ } assoc-map-as ;
33 "vocab:unicode/UCA/allkeys.txt" parse-ducet ducet set-global
35 ! Fix up table for long contractions
36 : help-one ( assoc key -- )
37 ! Need to be more general? Not for DUCET, apparently
38 2 head 2dup swap key? [ 2drop ] [
39 [ [ 1string of ] with { } map-as concat ]
43 : insert-helpers ( assoc -- )
44 dup keys [ length 3 >= ] filter [ help-one ] with each ;
46 ducet get-global insert-helpers
48 : tangut-block? ( char -- ? )
49 ! Tangut Block, Tangut Components Block
50 { [ 0x17000 0x187FF between? ] [ 0x18800 0x18AFF between? ] } 1|| ; inline
52 ! Unicode TR10 - Computing Implicit Weights
53 : base ( char -- base )
55 { [ dup 0x03400 0x04DB5 between? ] [ drop 0xFB80 ] } ! Extension A
56 { [ dup 0x20000 0x2A6D6 between? ] [ drop 0xFB80 ] } ! Extension B
57 { [ dup 0x2A700 0x2B734 between? ] [ drop 0xFB80 ] } ! Extension C
58 { [ dup 0x2B740 0x2B81D between? ] [ drop 0xFB80 ] } ! Extension D
59 { [ dup 0x2B820 0x2CEA1 between? ] [ drop 0xFB80 ] } ! Extension E
60 { [ dup 0x04E00 0x09FD5 between? ] [ drop 0xFB40 ] } ! CJK
61 [ drop 0xFBC0 ] ! Other
64 : tangut-AAAA ( char -- weight-levels )
65 drop 0xfb00 0x0020 0x0002 <weight-levels> ; inline
67 : tangut-BBBB ( char -- weight-levels )
68 0x17000 - 0x8000 bitor 0 0 <weight-levels> ; inline
70 : AAAA ( char -- weight-levels )
71 [ base ] [ -15 shift ] bi + 0x0020 0x0002 <weight-levels> ; inline
73 : BBBB ( char -- weight-levels )
74 0x7FFF bitand 0x8000 bitor 0 0 <weight-levels> ; inline
76 : illegal? ( char -- ? )
78 [ "Noncharacter_Code_Point" property? ]
82 : derive-weight ( 1string -- weight-levels-pair )
85 [ tangut-AAAA ] [ tangut-BBBB ] bi 2array
90 [ AAAA ] [ BBBB ] bi 2array
94 : building-last ( -- char )
95 building get [ 0 ] [ last last ] if-empty ;
97 : blocked? ( char -- ? )
98 combining-class dup { 0 f } member?
99 [ drop building-last non-starter? ]
100 [ building-last combining-class = ] if ;
102 : possible-bases ( -- slice-of-building )
103 building get dup [ first non-starter? not ] find-last
104 drop [ 0 ] unless* tail-slice ;
106 :: ?combine ( char slice i -- ? )
107 i slice nth char suffix :> str
108 str ducet get-global key? dup
109 [ str i slice set-nth ] when ;
112 dup blocked? [ 1string , ] [
113 dup possible-bases dup length <iota>
114 [ ?combine ] 2with any?
115 [ drop ] [ 1string , ] if
118 : string>graphemes ( string -- graphemes )
119 [ [ add ] each ] { } make ;
121 : char>weight-levels ( 1string -- weight-levels )
122 ducet get-global ?at [ derive-weight ] unless ; inline
124 : graphemes>weights ( graphemes -- weights )
127 [ 1array ] ! From tailoring
128 [ char>weight-levels ] if
129 ] { } map-as concat ;
131 : append-weights ( weight-levels quot -- seq )
132 [ [ ignorable?>> ] reject ] dip
133 map [ zero? ] reject ; inline
135 : variable-weight ( weight-levels -- obj )
136 dup ignorable?>> [ primary>> ] [ drop 0xFFFF ] if ;
138 : weights>bytes ( weights -- array )
141 [ [ primary>> ] append-weights { 0 } ]
142 [ [ secondary>> ] append-weights { 0 } ]
143 [ [ tertiary>> ] append-weights { 0 } ]
144 [ [ [ secondary>> ] [ tertiary>> ] bi [ zero? ] bi@ and not ] filter [ variable-weight ] map ]
146 ] { } append-outputs-as ;
150 : completely-ignorable? ( weight -- ? )
153 [ secondary>> zero? ]
157 : filter-ignorable ( weights -- weights' )
159 [ nip ] [ primary>> zero? and ] 2bi
160 [ swap ignorable?>> or ]
161 [ swap completely-ignorable? or not ] 2bi