1 ! Copyright (C) 2008 Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: unicode.data sequences sequences.next namespaces
4 sbufs make unicode.syntax unicode.normalize math hints
5 unicode.categories combinators unicode.syntax assocs
6 strings splitting kernel accessors unicode.breaks fry locals ;
11 : at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; inline
13 : ch>lower ( ch -- lower ) simple-lower at-default ; inline
14 : ch>upper ( ch -- upper ) simple-upper at-default ; inline
15 : ch>title ( ch -- title ) simple-title at-default ; inline
18 SYMBOL: locale ! Just casing locale, or overall?
22 : split-subseq ( string sep -- strings )
23 [ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ;
25 : replace ( old new str -- newstr )
26 [ split-subseq ] dip join ; inline
29 locale get { "tr" "az" } member? ;
31 : lithuanian? ( -- ? ) locale get "lt" = ;
33 : dot-over ( -- ch ) HEX: 307 ;
35 : lithuanian>upper ( string -- lower )
36 "i\u000307" "i" replace
37 "j\u000307" "j" replace ;
39 : mark-above? ( ch -- ? )
40 combining-class 230 = ;
42 : with-rest ( seq quot: ( seq -- seq ) -- seq )
43 [ unclip ] dip swap slip prefix ; inline
45 : add-dots ( seq -- seq )
48 [ CHAR: combining-dot-above prefix ] when
49 ] if-empty ] with-rest ; inline
51 : lithuanian>lower ( string -- lower )
52 "i" split add-dots "i" join
53 "j" split add-dots "i" join ; inline
55 : turk>upper ( string -- upper-i )
56 "i" "I\u000307" replace ; inline
58 : turk>lower ( string -- lower-i )
59 "I\u000307" "i" replace
60 "I" "\u000131" replace ; inline
62 : fix-sigma-end ( string -- string )
64 dup peek CHAR: greek-small-letter-sigma =
65 [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
68 : sigma-map ( string -- string )
69 { CHAR: greek-capital-letter-sigma } split [ [
70 [ { CHAR: greek-small-letter-sigma } ] [
72 CHAR: greek-small-letter-final-sigma
73 CHAR: greek-small-letter-sigma ? prefix
75 ] map ] with-rest concat fix-sigma-end ; inline
77 : final-sigma ( string -- string )
78 CHAR: greek-capital-letter-sigma
79 over member? [ sigma-map ] when
82 :: map-case ( string string-quot char-quot -- case )
83 string length <sbuf> :> out
86 [ string-quot call out push-all ]
87 [ char-quot call out push ] ?if
88 ] each out "" like ; inline
92 : >lower ( string -- lower )
93 i-dot? [ turk>lower ] when final-sigma
94 [ lower>> ] [ ch>lower ] map-case ;
96 HINTS: >lower string ;
98 : >upper ( string -- upper )
99 i-dot? [ turk>upper ] when
100 [ upper>> ] [ ch>upper ] map-case ;
102 HINTS: >upper string ;
106 : (>title) ( string -- title )
107 i-dot? [ turk>upper ] when
108 [ title>> ] [ ch>title ] map-case ; inline
110 : title-word ( string -- title )
111 unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline
115 : >title ( string -- title )
116 final-sigma >words [ title-word ] map concat ;
118 HINTS: >title string ;
120 : >case-fold ( string -- fold )
123 : lower? ( string -- ? ) dup >lower = ;
125 : upper? ( string -- ? ) dup >upper = ;
127 : title? ( string -- ? ) dup >title = ;
129 : case-fold? ( string -- ? ) dup >case-fold = ;