basis/unicode/case/case.factor

   1 ! Copyright (C) 2008, 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: unicode.data sequences namespaces
   4 sbufs make unicode.normalize math hints
   5 unicode.categories combinators assocs combinators.short-circuit
   6 strings splitting kernel accessors unicode.breaks fry locals ;
   7 QUALIFIED: ascii
   8 IN: unicode.case
   9
  10 SYMBOL: locale ! Just casing locale, or overall?
  11
  12 <PRIVATE
  13
  14 : split-subseq ( string sep -- strings )
  15     [ dup ] swap '[ _ split1-slice swap ] produce nip ;
  16
  17 : replace ( old new str -- newstr )
  18     [ split-subseq ] dip join ; inline
  19
  20 : i-dot? ( -- ? )
  21     locale get { "tr" "az" } member? ;
  22
  23 : lt? ( -- ? )
  24     locale get "lt" = ;
  25
  26 : lithuanian? ( -- ? ) locale get "lt" = ;
  27
  28 : dot-over ( -- ch ) HEX: 307 ;
  29
  30 : lithuanian>upper ( string -- lower )
  31     "i\u000307" "i" replace
  32     "j\u000307" "j" replace ;
  33
  34 : mark-above? ( ch -- ? )
  35     combining-class 230 = ;
  36
  37 :: with-rest ( seq quot: ( seq -- seq ) -- seq )
  38     seq unclip quot dip prefix ; inline
  39
  40 : add-dots ( seq -- seq )
  41     [ [ { } ] [
  42         [
  43             dup first
  44             { [ mark-above? ] [ CHAR: combining-ogonek = ] } 1||
  45             [ CHAR: combining-dot-above prefix ] when
  46         ] map
  47     ] if-empty ] with-rest ; inline
  48
  49 : lithuanian>lower ( string -- lower )
  50     "I" split add-dots "I" join
  51     "J" split add-dots "J" join ; inline
  52
  53 : turk>upper ( string -- upper-i )
  54     "i" "I\u000307" replace ; inline
  55
  56 : turk>lower ( string -- lower-i )
  57     "I\u000307" "i" replace
  58     "I" "\u000131" replace ; inline
  59
  60 : fix-sigma-end ( string -- string )
  61     [ "" ] [
  62         dup last CHAR: greek-small-letter-sigma =
  63         [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
  64     ] if-empty ; inline
  65
  66 : sigma-map ( string -- string )
  67     { CHAR: greek-capital-letter-sigma } split [ [
  68         [ { CHAR: greek-small-letter-sigma } ] [
  69             dup first uncased?
  70             CHAR: greek-small-letter-final-sigma
  71             CHAR: greek-small-letter-sigma ? prefix
  72         ] if-empty
  73     ] map ] with-rest concat fix-sigma-end ; inline
  74
  75 : final-sigma ( string -- string )
  76     CHAR: greek-capital-letter-sigma
  77     over member? [ sigma-map ] when
  78     "" like ; inline
  79
  80 :: map-case ( string string-quot char-quot -- case )
  81     string length <sbuf> :> out
  82     string [
  83         dup special-case
  84         [ string-quot call out push-all ]
  85         [ char-quot call out push ] ?if
  86     ] each out "" like ; inline
  87
  88 PRIVATE>
  89
  90 : >lower ( string -- lower )
  91     i-dot? [ turk>lower ] when
  92     lt? [ lithuanian>lower ] when
  93     final-sigma
  94     [ lower>> ] [ ch>lower ] map-case ;
  95
  96 HINTS: >lower string ;
  97
  98 : >upper ( string -- upper )
  99     i-dot? [ turk>upper ] when
 100     lt? [ lithuanian>upper ] when
 101     [ upper>> ] [ ch>upper ] map-case ;
 102
 103 HINTS: >upper string ;
 104
 105 <PRIVATE
 106
 107 : (>title) ( string -- title )
 108     i-dot? [ turk>upper ] when
 109     lt? [ lithuanian>upper ] when
 110     [ title>> ] [ ch>title ] map-case ; inline
 111
 112 PRIVATE>
 113
 114 : capitalize ( string -- title )
 115     unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline
 116
 117 : >title ( string -- title )
 118     final-sigma >words [ capitalize ] map concat ;
 119
 120 HINTS: >title string ;
 121
 122 : >case-fold ( string -- fold )
 123     >upper >lower ;
 124
 125 : lower? ( string -- ? ) dup >lower = ;
 126
 127 : upper? ( string -- ? ) dup >upper = ;
 128
 129 : title? ( string -- ? ) dup >title = ;
 130
 131 : case-fold? ( string -- ? ) dup >case-fold = ;