basis/unicode/case/case.factor

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