1 ! Copyright (C) 2008 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: unicode.data sequences sequences.next namespaces make
4 unicode.normalize math unicode.categories combinators
5 assocs strings splitting kernel accessors ;
8 : at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
10 : ch>lower ( ch -- lower ) simple-lower at-default ;
11 : ch>upper ( ch -- upper ) simple-upper at-default ;
12 : ch>title ( ch -- title ) simple-title at-default ;
14 SYMBOL: locale ! Just casing locale, or overall?
17 locale get { "tr" "az" } member? ;
19 : lithuanian? ( -- ? ) locale get "lt" = ;
21 : dot-over ( -- ch ) HEX: 307 ;
23 : lithuanian-ch>upper ( ? next ch -- ? )
25 [ swap dot-over = over "ij" member? and swap , ] if ;
27 : lithuanian>upper ( string -- lower )
28 [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ;
30 : mark-above? ( ch -- ? )
31 combining-class 230 = ;
33 : lithuanian-ch>lower ( next ch -- )
34 ! This fails to add a dot above in certain edge cases
35 ! where there is a non-above combining mark before an above one
37 dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
39 : lithuanian>lower ( string -- lower )
40 [ [ lithuanian-ch>lower ] each-next ] "" make ;
42 : turk-ch>upper ( ch -- )
44 [ drop CHAR: I , dot-over , ] [ , ] if ;
46 : turk>upper ( string -- upper-i )
47 [ [ turk-ch>upper ] each ] "" make ;
49 : turk-ch>lower ( ? next ch -- ? )
51 { [ rot ] [ 2drop f ] }
54 dup CHAR: i HEX: 131 ? ,
59 : turk>lower ( string -- lower-i )
60 [ f swap [ turk-ch>lower ] each-next drop ] "" make ;
62 : word-boundary ( prev char -- new ? )
63 dup non-starter? [ drop dup ] when
66 : sigma-map ( string -- string )
68 swap [ uncased? ] keep not or
69 [ drop HEX: 3C2 ] when
72 : final-sigma ( string -- string )
73 HEX: 3A3 over member? [ sigma-map ] when ;
75 : map-case ( string string-quot char-quot -- case )
78 [ dup special-casing at ] 2dip
79 [ [ % ] compose ] [ [ , ] compose ] bi* ?if
83 : >lower ( string -- lower )
84 i-dot? [ turk>lower ] when
85 final-sigma [ lower>> ] [ ch>lower ] map-case ;
87 : >upper ( string -- upper )
88 i-dot? [ turk>upper ] when
89 [ upper>> ] [ ch>upper ] map-case ;
91 : >title ( string -- title )
94 [ tuck word-boundary swapd
95 [ title>> ] [ lower>> ] if ]
96 [ tuck word-boundary swapd
97 [ ch>title ] [ ch>lower ] if ]
100 : >case-fold ( string -- fold )
103 : lower? ( string -- ? )
105 : upper? ( string -- ? )
107 : title? ( string -- ? )
109 : case-fold? ( string -- ? )