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