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 unicode.syntax
5 assocs strings splitting kernel accessors unicode.breaks fry ;
9 : at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
12 : ch>lower ( ch -- lower ) simple-lower at-default ;
13 : ch>upper ( ch -- upper ) simple-upper at-default ;
14 : ch>title ( ch -- title ) simple-title at-default ;
16 SYMBOL: locale ! Just casing locale, or overall?
20 : split-subseq ( string sep -- strings )
21 [ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ;
23 : replace ( old new str -- newstr )
24 [ split-subseq ] dip join ;
27 locale get { "tr" "az" } member? ;
29 : lithuanian? ( -- ? ) locale get "lt" = ;
31 : dot-over ( -- ch ) HEX: 307 ;
33 : lithuanian>upper ( string -- lower )
34 "i\u000307" "i" replace
35 "j\u000307" "j" replace ;
37 : mark-above? ( ch -- ? )
38 combining-class 230 = ;
40 : with-rest ( seq quot: ( seq -- seq ) -- seq )
41 [ unclip ] dip swap slip prefix ; inline
43 : add-dots ( seq -- seq )
46 [ CHAR: combining-dot-above prefix ] when
47 ] if-empty ] with-rest ;
49 : lithuanian>lower ( string -- lower )
50 "i" split add-dots "i" join
51 "j" split add-dots "i" join ;
53 : turk>upper ( string -- upper-i )
54 "i" "I\u000307" replace ;
56 : turk>lower ( string -- lower-i )
57 "I\u000307" "i" replace
58 "I" "\u000131" replace ;
60 : fix-sigma-end ( string -- string )
62 dup peek CHAR: greek-small-letter-sigma =
63 [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
66 : sigma-map ( string -- string )
67 { CHAR: greek-capital-letter-sigma } split [ [
68 [ { CHAR: greek-small-letter-sigma } ] [
70 CHAR: greek-small-letter-final-sigma
71 CHAR: greek-small-letter-sigma ? prefix
73 ] map ] with-rest concat fix-sigma-end ;
75 : final-sigma ( string -- string )
76 CHAR: greek-capital-letter-sigma
77 over member? [ sigma-map ] when ;
79 : map-case ( string string-quot char-quot -- case )
82 [ dup special-casing at ] 2dip
83 [ [ % ] compose ] [ [ , ] compose ] bi* ?if
89 : >lower ( string -- lower )
90 i-dot? [ turk>lower ] when final-sigma
91 [ lower>> ] [ ch>lower ] map-case ;
93 : >upper ( string -- upper )
94 i-dot? [ turk>upper ] when
95 [ upper>> ] [ ch>upper ] map-case ;
99 : (>title) ( string -- title )
100 i-dot? [ turk>upper ] when
101 [ title>> ] [ ch>title ] map-case ;
103 : title-word ( string -- title )
104 unclip 1string [ >lower ] [ (>title) ] bi* prepend ;
108 : >title ( string -- title )
109 final-sigma >words [ title-word ] map concat ;
111 : >case-fold ( string -- fold )
114 : lower? ( string -- ? ) dup >lower = ;
116 : upper? ( string -- ? ) dup >upper = ;
118 : title? ( string -- ? ) dup >title = ;
120 : case-fold? ( string -- ? ) dup >case-fold = ;