basis/unicode/case/case.factor

   1 ! Copyright (C) 2008, 2009 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: combinators.short-circuit kernel namespaces sbufs
   4 sequences splitting unicode.categories unicode.data ;
   5 QUALIFIED: ascii
   6 IN: unicode.case
   7
   8 SYMBOL: locale ! Just casing locale, or overall?
   9
  10 <PRIVATE
  11
  12 : i-dot? ( locale -- ? )
  13     { "tr" "az" } member? ; inline
  14
  15 : lithuanian? ( locale -- ? ) "lt" = ; inline
  16
  17 : lithuanian>upper ( string -- lower )
  18     "i\u000307" "i" replace
  19     "j\u000307" "j" replace ;
  20
  21 : mark-above? ( ch -- ? )
  22     combining-class 230 = ;
  23
  24 :: with-rest ( seq quot: ( seq -- seq ) -- seq )
  25     seq unclip quot dip prefix ; inline
  26
  27 : add-dots ( seq -- seq )
  28     [ [ { } ] [
  29         [
  30             dup first
  31             { [ mark-above? ] [ CHAR: combining-ogonek = ] } 1||
  32             [ CHAR: combining-dot-above prefix ] when
  33         ] map
  34     ] if-empty ] with-rest ; inline
  35
  36 : lithuanian>lower ( string -- lower )
  37     "I" split add-dots "I" join
  38     "J" split add-dots "J" join ; inline
  39
  40 : turk>upper ( string -- upper-i )
  41     "i" "I\u000307" replace ; inline
  42
  43 : turk>lower ( string -- lower-i )
  44     "I\u000307" "i" replace
  45     "I" "\u000131" replace ; inline
  46
  47 : fix-sigma-end ( string -- string )
  48     [ "" ] [
  49         dup last CHAR: greek-small-letter-sigma =
  50         [ but-last CHAR: greek-small-letter-final-sigma suffix ] when
  51     ] if-empty ; inline
  52
  53 ! this duplicate unicode to prevent dependencies
  54 CATEGORY-NOT: (uncased) Lu Ll Lt Lm Mn Me ;
  55
  56 : sigma-map ( string -- string )
  57     { CHAR: greek-capital-letter-sigma } split [ [
  58         [ { CHAR: greek-small-letter-sigma } ] [
  59             dup first (uncased)?
  60             CHAR: greek-small-letter-final-sigma
  61             CHAR: greek-small-letter-sigma ? prefix
  62         ] if-empty
  63     ] map ] with-rest concat fix-sigma-end ; inline
  64
  65 : final-sigma ( string -- string )
  66     CHAR: greek-capital-letter-sigma
  67     over member? [ sigma-map ] when
  68     "" like ; inline
  69
  70 :: map-case ( string string-quot char-quot -- case )
  71     string length <sbuf> :> out
  72     string [
  73         dup special-case
  74         [ string-quot call out push-all ]
  75         [ char-quot call out push ] ?if
  76     ] each out "" like ; inline
  77
  78 : locale>lower ( string -- string' )
  79     locale get
  80     [ i-dot? [ turk>lower ] when ]
  81     [ lithuanian? [ lithuanian>lower ] when ] bi ;
  82
  83 : locale>upper ( string -- string' )
  84     locale get
  85     [ i-dot? [ turk>upper ] when ]
  86     [ lithuanian? [ lithuanian>upper ] when ] bi ;
  87
  88 PRIVATE>