extra/unicode/case/case.factor

   1 USING: kernel unicode.data sequences sequences.next namespaces
   2 unicode.normalize math unicode.categories combinators
   3 assocs strings splitting ;
   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 : >lower ( string -- lower )
  85     i-dot? [ turk>lower ] when
  86     final-sigma [ code-point-lower ] [ ch>lower ] map-case ;
  87
  88 : >upper ( string -- upper )
  89     i-dot? [ turk>upper ] when
  90     [ code-point-upper ] [ ch>upper ] map-case ;
  91
  92 : >title ( string -- title )
  93     final-sigma
  94     CHAR: \s swap
  95     [ tuck word-boundary swapd
  96         [ code-point-title ] [ code-point-lower ] if ]
  97     [ tuck word-boundary swapd
  98         [ ch>title ] [ ch>lower ] if ]
  99     map-case nip ;
 100
 101 : >case-fold ( string -- fold )
 102     >upper >lower ;
 103
 104 : lower? ( string -- ? )
 105     dup >lower = ;
 106 : upper? ( string -- ? )
 107     dup >lower = ;
 108 : title? ( string -- ? )
 109     dup >title = ;
 110 : case-fold? ( string -- ? )
 111     dup >case-fold = ;