factor: trim some using lists

[factor.git] / basis / unicode / case / case.factor

diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor
index 65fab0ac382c5d3671a455902788cb1c4bdd7a30..d18e23dadec3891b8443cf9637ee79b908a3f576 100644 (file)
--- a/basis/unicode/case/case.factor
+++ b/basis/unicode/case/case.factor
@@ -1,34 +1,18 @@
-! Copyright (C) 2008 Daniel Ehrenberg.
+! Copyright (C) 2008, 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: unicode.data sequences namespaces
-sbufs make unicode.syntax unicode.normalize math hints
-unicode.categories combinators unicode.syntax assocs
-strings splitting kernel accessors unicode.breaks fry locals ;
+USING: combinators.short-circuit kernel namespaces sbufs
+sequences splitting unicode.categories unicode.data ;
 QUALIFIED: ascii
 IN: unicode.case
 
-<PRIVATE
-: ch>lower ( ch -- lower ) simple-lower at-default ; inline
-: ch>upper ( ch -- upper ) simple-upper at-default ; inline
-: ch>title ( ch -- title ) simple-title at-default ; inline
-PRIVATE>
-
 SYMBOL: locale ! Just casing locale, or overall?
 
 <PRIVATE
 
-: split-subseq ( string sep -- strings )
-    [ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ;
-
-: replace ( old new str -- newstr )
-    [ split-subseq ] dip join ; inline
-
-: i-dot? ( -- ? )
-    locale get { "tr" "az" } member? ;
-
-: lithuanian? ( -- ? ) locale get "lt" = ;
+: i-dot? ( locale -- ? )
+    { "tr" "az" } member? ; inline
 
-: dot-over ( -- ch ) HEX: 307 ;
+: lithuanian? ( locale -- ? ) "lt" = ; inline
 
 : lithuanian>upper ( string -- lower )
     "i\u000307" "i" replace
@@ -37,18 +21,21 @@ SYMBOL: locale ! Just casing locale, or overall?
 : mark-above? ( ch -- ? )
     combining-class 230 = ;
 
-: with-rest ( seq quot: ( seq -- seq ) -- seq )
-    [ unclip ] dip swap slip prefix ; inline
+:: with-rest ( seq quot: ( seq -- seq ) -- seq )
+    seq unclip quot dip prefix ; inline
 
 : add-dots ( seq -- seq )
-    [ [ "" ] [
-        dup first mark-above?
-        [ CHAR: combining-dot-above prefix ] when
+    [ [ { } ] [
+        [
+            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 "i" join ; inline
+    "I" split add-dots "I" join
+    "J" split add-dots "J" join ; inline
 
 : turk>upper ( string -- upper-i )
     "i" "I\u000307" replace ; inline
@@ -59,14 +46,17 @@ SYMBOL: locale ! Just casing locale, or overall?
 
 : fix-sigma-end ( string -- string )
     [ "" ] [
-        dup peek CHAR: greek-small-letter-sigma =
-        [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
+        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?
+            dup first (uncased)?
             CHAR: greek-small-letter-final-sigma
             CHAR: greek-small-letter-sigma ? prefix
         ] if-empty
@@ -80,48 +70,19 @@ SYMBOL: locale ! Just casing locale, or overall?
 :: map-case ( string string-quot char-quot -- case )
     string length <sbuf> :> out
     string [
-        dup special-casing at
+        dup special-case
         [ string-quot call out push-all ]
         [ char-quot call out push ] ?if
     ] each out "" like ; inline
 
-PRIVATE>
-
-: >lower ( string -- lower )
-    i-dot? [ turk>lower ] when final-sigma
-    [ lower>> ] [ ch>lower ] map-case ;
-
-HINTS: >lower string ;
-
-: >upper ( string -- upper )
-    i-dot? [ turk>upper ] when
-    [ upper>> ] [ ch>upper ] map-case ;
+: locale>lower ( string -- string' )
+    locale get
+    [ i-dot? [ turk>lower ] when ]
+    [ lithuanian? [ lithuanian>lower ] when ] bi ;
 
-HINTS: >upper string ;
-
-<PRIVATE
-
-: (>title) ( string -- title )
-    i-dot? [ turk>upper ] when
-    [ title>> ] [ ch>title ] map-case ; inline
-
-: title-word ( string -- title )
-    unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline
+: locale>upper ( string -- string' )
+    locale get
+    [ i-dot? [ turk>upper ] when ]
+    [ lithuanian? [ lithuanian>upper ] when ] bi ;
 
 PRIVATE>
-
-: >title ( string -- title )
-    final-sigma >words [ title-word ] map concat ;
-
-HINTS: >title string ;
-
-: >case-fold ( string -- fold )
-    >upper >lower ;
-
-: lower? ( string -- ? ) dup >lower = ;
-
-: upper? ( string -- ? ) dup >upper = ;
-
-: title? ( string -- ? ) dup >title = ;
-
-: case-fold? ( string -- ? ) dup >case-fold = ;