basis/unicode/case/case.factor

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