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
   4 unicode.normalize math unicode.categories combinators
   5 assocs strings splitting kernel accessors ;
   6 IN: unicode.case
   7
   8 : at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ;
   9
  10 : ch>lower ( ch -- lower ) simple-lower at-default ;
  11 : ch>upper ( ch -- upper ) simple-upper at-default ;
  12 : ch>title ( ch -- title ) simple-title at-default ;
  13
  14 SYMBOL: locale ! Just casing locale, or overall?
  15
  16 : i-dot? ( -- ? )
  17     locale get { "tr" "az" } member? ;
  18
  19 : lithuanian? ( -- ? ) locale get "lt" = ;
  20
  21 : dot-over ( -- ch ) HEX: 307 ;
  22
  23 : lithuanian-ch>upper ( ? next ch -- ? )
  24     rot [ 2drop f ]
  25     [ swap dot-over = over "ij" member? and swap , ] if ;
  26
  27 : lithuanian>upper ( string -- lower )
  28     [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ;
  29
  30 : mark-above? ( ch -- ? )
  31     combining-class 230 = ;
  32
  33 : lithuanian-ch>lower ( next ch -- )
  34     ! This fails to add a dot above in certain edge cases
  35     ! where there is a non-above combining mark before an above one
  36     ! in Lithuanian
  37     dup , "IJ" member? swap mark-above? and [ dot-over , ] when ;
  38
  39 : lithuanian>lower ( string -- lower )
  40     [ [ lithuanian-ch>lower ] each-next ] "" make ;
  41
  42 : turk-ch>upper ( ch -- )
  43     dup CHAR: i =
  44     [ drop CHAR: I , dot-over , ] [ , ] if ;
  45
  46 : turk>upper ( string -- upper-i )
  47     [ [ turk-ch>upper ] each ] "" make ;
  48
  49 : turk-ch>lower ( ? next ch -- ? )
  50     {
  51         { [ rot ] [ 2drop f ] }
  52         { [ dup CHAR: I = ] [
  53             drop dot-over =
  54             dup CHAR: i HEX: 131 ? ,
  55         ] }
  56         [ , drop f ]
  57     } cond ;
  58
  59 : turk>lower ( string -- lower-i )
  60     [ f swap [ turk-ch>lower ] each-next drop ] "" make ;
  61
  62 : word-boundary ( prev char -- new ? )
  63     dup non-starter? [ drop dup ] when
  64     swap uncased? ;
  65
  66 : sigma-map ( string -- string )
  67     [
  68         swap [ uncased? ] keep not or
  69         [ drop HEX: 3C2 ] when
  70     ] map-next ;
  71
  72 : final-sigma ( string -- string )
  73     HEX: 3A3 over member? [ sigma-map ] when ;
  74
  75 : map-case ( string string-quot char-quot -- case )
  76     [
  77         [
  78             [ dup special-casing at ] 2dip
  79             [ [ % ] compose ] [ [ , ] compose ] bi* ?if
  80         ] 2curry each
  81     ] "" make ; inline
  82
  83 : >lower ( string -- lower )
  84     i-dot? [ turk>lower ] when
  85     final-sigma [ lower>> ] [ ch>lower ] map-case ;
  86
  87 : >upper ( string -- upper )
  88     i-dot? [ turk>upper ] when
  89     [ upper>> ] [ ch>upper ] map-case ;
  90
  91 : >title ( string -- title )
  92     final-sigma
  93     CHAR: \s swap
  94     [ tuck word-boundary swapd
  95         [ title>> ] [ lower>> ] if ]
  96     [ tuck word-boundary swapd
  97         [ ch>title ] [ ch>lower ] if ]
  98     map-case nip ;
  99
 100 : >case-fold ( string -- fold )
 101     >upper >lower ;
 102
 103 : lower? ( string -- ? ) dup >lower = ;
 104
 105 : upper? ( string -- ? ) dup >upper = ;
 106
 107 : title? ( string -- ? ) dup >title = ;
 108
 109 : case-fold? ( string -- ? ) dup >case-fold = ;