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 make unicode.syntax
   4 unicode.normalize math unicode.categories combinators unicode.syntax
   5 assocs strings splitting kernel accessors unicode.breaks fry ;
   6 IN: unicode.case
   7
   8 <PRIVATE
   9 : at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
  10
  11 : ch>lower ( ch -- lower ) simple-lower at-default ;
  12 : ch>upper ( ch -- upper ) simple-upper at-default ;
  13 : ch>title ( ch -- title ) simple-title at-default ;
  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 ;
  25
  26 : i-dot? ( -- ? )
  27     locale get { "tr" "az" } member? ;
  28
  29 : lithuanian? ( -- ? ) locale get "lt" = ;
  30
  31 : dot-over ( -- ch ) HEX: 307 ;
  32
  33 : lithuanian>upper ( string -- lower )
  34     "i\u000307" "i" replace
  35     "j\u000307" "j" replace ;
  36
  37 : mark-above? ( ch -- ? )
  38     combining-class 230 = ;
  39
  40 : with-rest ( seq quot: ( seq -- seq ) -- seq )
  41     [ unclip ] dip swap slip prefix ; inline
  42
  43 : add-dots ( seq -- seq )
  44     [ [ "" ] [
  45         dup first mark-above?
  46         [ CHAR: combining-dot-above prefix ] when
  47     ] if-empty ] with-rest ;
  48
  49 : lithuanian>lower ( string -- lower )
  50     "i" split add-dots "i" join
  51     "j" split add-dots "i" join ;
  52
  53 : turk>upper ( string -- upper-i )
  54     "i" "I\u000307" replace ;
  55
  56 : turk>lower ( string -- lower-i )
  57     "I\u000307" "i" replace
  58     "I" "\u000131" replace ;
  59
  60 : fix-sigma-end ( string -- string )
  61     [ "" ] [
  62         dup peek CHAR: greek-small-letter-sigma =
  63         [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when
  64     ] if-empty ;
  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 ;
  74
  75 : final-sigma ( string -- string )
  76     CHAR: greek-capital-letter-sigma
  77     over member? [ sigma-map ] when ;
  78
  79 : map-case ( string string-quot char-quot -- case )
  80     [
  81         [
  82             [ dup special-casing at ] 2dip
  83             [ [ % ] compose ] [ [ , ] compose ] bi* ?if
  84         ] 2curry each
  85     ] "" make ; inline
  86
  87 PRIVATE>
  88
  89 : >lower ( string -- lower )
  90     i-dot? [ turk>lower ] when final-sigma
  91     [ lower>> ] [ ch>lower ] map-case ;
  92
  93 : >upper ( string -- upper )
  94     i-dot? [ turk>upper ] when
  95     [ upper>> ] [ ch>upper ] map-case ;
  96
  97 <PRIVATE
  98
  99 : (>title) ( string -- title )
 100     i-dot? [ turk>upper ] when
 101     [ title>> ] [ ch>title ] map-case ;
 102
 103 : title-word ( string -- title )
 104     unclip 1string [ >lower ] [ (>title) ] bi* prepend ;
 105
 106 PRIVATE>
 107
 108 : >title ( string -- title )
 109     final-sigma >words [ title-word ] map concat ;
 110
 111 : >case-fold ( string -- fold )
 112     >upper >lower ;
 113
 114 : lower? ( string -- ? ) dup >lower = ;
 115
 116 : upper? ( string -- ? ) dup >upper = ;
 117
 118 : title? ( string -- ? ) dup >title = ;
 119
 120 : case-fold? ( string -- ? ) dup >case-fold = ;