-! Copyright (C) 2008 Daniel Ehrenberg.
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: unicode.data sequences sequences.next namespaces make
-unicode.normalize math unicode.categories combinators
-assocs strings splitting kernel accessors ;
+USING: combinators.short-circuit kernel namespaces sbufs
+sequences splitting unicode.categories unicode.data ;
+QUALIFIED: ascii
IN: unicode.case
-: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
-
-: ch>lower ( ch -- lower ) simple-lower at-default ;
-: ch>upper ( ch -- upper ) simple-upper at-default ;
-: ch>title ( ch -- title ) simple-title at-default ;
-
SYMBOL: locale ! Just casing locale, or overall?
-: i-dot? ( -- ? )
- locale get { "tr" "az" } member? ;
-
-: lithuanian? ( -- ? ) locale get "lt" = ;
+<PRIVATE
-: dot-over ( -- ch ) HEX: 307 ;
+: i-dot? ( locale -- ? )
+ { "tr" "az" } member? ; inline
-: lithuanian-ch>upper ( ? next ch -- ? )
- rot [ 2drop f ]
- [ swap dot-over = over "ij" member? and swap , ] if ;
+: lithuanian? ( locale -- ? ) "lt" = ; inline
: lithuanian>upper ( string -- lower )
- [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ;
+ "i\u000307" "i" replace
+ "j\u000307" "j" replace ;
: mark-above? ( ch -- ? )
combining-class 230 = ;
-: lithuanian-ch>lower ( next ch -- )
- ! This fails to add a dot above in certain edge cases
- ! where there is a non-above combining mark before an above one
- ! in Lithuanian
- dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
+:: with-rest ( seq quot: ( seq -- seq ) -- seq )
+ seq unclip quot dip prefix ; inline
-: lithuanian>lower ( string -- lower )
- [ [ lithuanian-ch>lower ] each-next ] "" make ;
+: add-dots ( seq -- seq )
+ [ [ { } ] [
+ [
+ dup first
+ { [ mark-above? ] [ CHAR: combining-ogonek = ] } 1||
+ [ CHAR: combining-dot-above prefix ] when
+ ] map
+ ] if-empty ] with-rest ; inline
-: turk-ch>upper ( ch -- )
- dup CHAR: i =
- [ drop CHAR: I , dot-over , ] [ , ] if ;
+: lithuanian>lower ( string -- lower )
+ "I" split add-dots "I" join
+ "J" split add-dots "J" join ; inline
: turk>upper ( string -- upper-i )
- [ [ turk-ch>upper ] each ] "" make ;
-
-: turk-ch>lower ( ? next ch -- ? )
- {
- { [ rot ] [ 2drop f ] }
- { [ dup CHAR: I = ] [
- drop dot-over =
- dup CHAR: i HEX: 131 ? ,
- ] }
- [ , drop f ]
- } cond ;
+ "i" "I\u000307" replace ; inline
: turk>lower ( string -- lower-i )
- [ f swap [ turk-ch>lower ] each-next drop ] "" make ;
+ "I\u000307" "i" replace
+ "I" "\u000131" replace ; inline
+
+: fix-sigma-end ( string -- string )
+ [ "" ] [
+ dup last CHAR: greek-small-letter-sigma =
+ [ but-last CHAR: greek-small-letter-final-sigma suffix ] when
+ ] if-empty ; inline
-: word-boundary ( prev char -- new ? )
- dup non-starter? [ drop dup ] when
- swap uncased? ;
+! this duplicate unicode to prevent dependencies
+CATEGORY-NOT: (uncased) Lu Ll Lt Lm Mn Me ;
: sigma-map ( string -- string )
- [
- swap [ uncased? ] keep not or
- [ drop HEX: 3C2 ] when
- ] map-next ;
+ { CHAR: greek-capital-letter-sigma } split [ [
+ [ { CHAR: greek-small-letter-sigma } ] [
+ dup first (uncased)?
+ CHAR: greek-small-letter-final-sigma
+ CHAR: greek-small-letter-sigma ? prefix
+ ] if-empty
+ ] map ] with-rest concat fix-sigma-end ; inline
: final-sigma ( string -- string )
- HEX: 3A3 over member? [ sigma-map ] when ;
-
-: map-case ( string string-quot char-quot -- case )
- [
- [
- [ dup special-casing at ] 2dip
- [ [ % ] compose ] [ [ , ] compose ] bi* ?if
- ] 2curry each
- ] "" make ; inline
-
-: >lower ( string -- lower )
- i-dot? [ turk>lower ] when
- final-sigma [ lower>> ] [ ch>lower ] map-case ;
-
-: >upper ( string -- upper )
- i-dot? [ turk>upper ] when
- [ upper>> ] [ ch>upper ] map-case ;
-
-: >title ( string -- title )
- final-sigma
- CHAR: \s swap
- [ tuck word-boundary swapd
- [ title>> ] [ lower>> ] if ]
- [ tuck word-boundary swapd
- [ ch>title ] [ ch>lower ] if ]
- map-case nip ;
-
-: >case-fold ( string -- fold )
- >upper >lower ;
-
-: lower? ( string -- ? ) dup >lower = ;
-
-: upper? ( string -- ? ) dup >upper = ;
-
-: title? ( string -- ? ) dup >title = ;
-
-: case-fold? ( string -- ? ) dup >case-fold = ;
+ CHAR: greek-capital-letter-sigma
+ over member? [ sigma-map ] when
+ "" like ; inline
+
+:: map-case ( string string-quot char-quot -- case )
+ string length <sbuf> :> out
+ string [
+ dup special-case
+ [ string-quot call out push-all ]
+ [ char-quot call out push ] ?if
+ ] each out "" like ; inline
+
+: locale>lower ( string -- string' )
+ locale get
+ [ i-dot? [ turk>lower ] when ]
+ [ lithuanian? [ lithuanian>lower ] when ] bi ;
+
+: locale>upper ( string -- string' )
+ locale get
+ [ i-dot? [ turk>upper ] when ]
+ [ lithuanian? [ lithuanian>upper ] when ] bi ;
+
+PRIVATE>
projects / factor.git / blobdiff