89 lines
2.4 KiB
Factor
89 lines
2.4 KiB
Factor
! Copyright (C) 2008, 2009 Daniel Ehrenberg.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: combinators.short-circuit kernel locals namespaces sbufs
|
|
sequences splitting unicode.categories unicode.data ;
|
|
QUALIFIED: ascii
|
|
IN: unicode.case
|
|
|
|
SYMBOL: locale ! Just casing locale, or overall?
|
|
|
|
<PRIVATE
|
|
|
|
: i-dot? ( locale -- ? )
|
|
{ "tr" "az" } member? ; inline
|
|
|
|
: lithuanian? ( locale -- ? ) "lt" = ; inline
|
|
|
|
: lithuanian>upper ( string -- lower )
|
|
"i\u000307" "i" replace
|
|
"j\u000307" "j" replace ;
|
|
|
|
: mark-above? ( ch -- ? )
|
|
combining-class 230 = ;
|
|
|
|
:: with-rest ( seq quot: ( seq -- seq ) -- seq )
|
|
seq unclip quot dip prefix ; inline
|
|
|
|
: add-dots ( seq -- seq )
|
|
[ [ { } ] [
|
|
[
|
|
dup first
|
|
{ [ mark-above? ] [ CHAR: combining-ogonek = ] } 1||
|
|
[ CHAR: combining-dot-above prefix ] when
|
|
] map
|
|
] if-empty ] with-rest ; inline
|
|
|
|
: lithuanian>lower ( string -- lower )
|
|
"I" split add-dots "I" join
|
|
"J" split add-dots "J" join ; inline
|
|
|
|
: turk>upper ( string -- upper-i )
|
|
"i" "I\u000307" replace ; inline
|
|
|
|
: turk>lower ( string -- lower-i )
|
|
"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
|
|
|
|
! this duplicate unicode to prevent dependencies
|
|
CATEGORY-NOT: (uncased) Lu Ll Lt Lm Mn Me ;
|
|
|
|
: sigma-map ( string -- string )
|
|
{ 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 )
|
|
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>
|