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 : i-dot? ( locale -- ? )
  15     { "tr" "az" } member? ; inline
  16
  17 : lithuanian? ( locale -- ? ) "lt" = ; inline
  18
  19 : lithuanian>upper ( string -- lower )
  20     "i\u000307" "i" replace
  21     "j\u000307" "j" replace ;
  22
  23 : mark-above? ( ch -- ? )
  24     combining-class 230 = ;
  25
  26 :: with-rest ( seq quot: ( seq -- seq ) -- seq )
  27     seq unclip quot dip prefix ; inline
  28
  29 : add-dots ( seq -- seq )
  30     [ [ { } ] [
  31         [
  32             dup first
  33             { [ mark-above? ] [ CHAR: combining-ogonek = ] } 1||
  34             [ CHAR: combining-dot-above prefix ] when
  35         ] map
  36     ] if-empty ] with-rest ; inline
  37
  38 : lithuanian>lower ( string -- lower )
  39     "I" split add-dots "I" join
  40     "J" split add-dots "J" join ; inline
  41
  42 : turk>upper ( string -- upper-i )
  43     "i" "I\u000307" replace ; inline
  44
  45 : turk>lower ( string -- lower-i )
  46     "I\u000307" "i" replace
  47     "I" "\u000131" replace ; inline
  48
  49 : fix-sigma-end ( string -- string )
  50     [ "" ] [
  51         dup last CHAR: greek-small-letter-sigma =
  52         [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
  53     ] if-empty ; inline
  54
  55 : sigma-map ( string -- string )
  56     { CHAR: greek-capital-letter-sigma } split [ [
  57         [ { CHAR: greek-small-letter-sigma } ] [
  58             dup first uncased?
  59             CHAR: greek-small-letter-final-sigma
  60             CHAR: greek-small-letter-sigma ? prefix
  61         ] if-empty
  62     ] map ] with-rest concat fix-sigma-end ; inline
  63
  64 : final-sigma ( string -- string )
  65     CHAR: greek-capital-letter-sigma
  66     over member? [ sigma-map ] when
  67     "" like ; inline
  68
  69 :: map-case ( string string-quot char-quot -- case )
  70     string length <sbuf> :> out
  71     string [
  72         dup special-case
  73         [ string-quot call out push-all ]
  74         [ char-quot call out push ] ?if
  75     ] each out "" like ; inline
  76
  77 : locale>lower ( string -- string' )
  78     locale get
  79     [ i-dot? [ turk>lower ] when ]
  80     [ lithuanian? [ lithuanian>lower ] when ] bi ;
  81
  82 : locale>upper ( string -- string' )
  83     locale get
  84     [ i-dot? [ turk>upper ] when ]
  85     [ lithuanian? [ lithuanian>upper ] when ] bi ;
  86
  87 PRIVATE>
  88
  89 : >lower ( string -- lower )
  90     locale>lower final-sigma
  91     [ lower>> ] [ ch>lower ] map-case ;
  92
  93 HINTS: >lower string ;
  94
  95 : >upper ( string -- upper )
  96     locale>upper
  97     [ upper>> ] [ ch>upper ] map-case ;
  98
  99 HINTS: >upper string ;
 100
 101 <PRIVATE
 102
 103 : (>title) ( string -- title )
 104     locale>upper
 105     [ title>> ] [ ch>title ] map-case ; inline
 106
 107 PRIVATE>
 108
 109 : capitalize ( string -- title )
 110     unclip-slice 1string [ >lower ] [ (>title) ] bi*
 111     "" prepend-as ; inline
 112
 113 : >title ( string -- title )
 114     final-sigma >words [ capitalize ] map! concat ;
 115
 116 HINTS: >title string ;
 117
 118 : >case-fold ( string -- fold )
 119     >upper >lower ;
 120
 121 : lower? ( string -- ? ) dup >lower = ;
 122
 123 : upper? ( string -- ? ) dup >upper = ;
 124
 125 : title? ( string -- ? ) dup >title = ;
 126
 127 : case-fold? ( string -- ? ) dup >case-fold = ;