basis/unicode/breaks/breaks.factor

   1 USING: combinators.short-circuit unicode.categories kernel math
   2 combinators splitting sequences math.parser io.files io assocs
   3 arrays namespaces make math.ranges unicode.normalize values
   4 io.encodings.ascii unicode.syntax unicode.data compiler.units
   5 alien.syntax sets ;
   6 IN: unicode.breaks
   7
   8 C-ENUM: Any L V T Extend Control CR LF graphemes ;
   9
  10 : jamo-class ( ch -- class )
  11     dup initial? [ drop L ]
  12     [ dup medial? [ drop V ] [ final? T Any ? ] if ] if ;
  13
  14 CATEGORY: grapheme-control Zl Zp Cc Cf ;
  15 : control-class ( ch -- class )
  16     {
  17         { CHAR: \r [ CR ] }
  18         { CHAR: \n [ LF ] }
  19         { HEX: 200C [ Extend ] }
  20         { HEX: 200D [ Extend ] }
  21         [ drop Control ]
  22     } case ;
  23
  24 CATEGORY: (extend) Me Mn ;
  25 : extend? ( ch -- ? )
  26     { [ (extend)? ] [ "Other_Grapheme_Extend" property? ] } 1|| ;
  27
  28 : grapheme-class ( ch -- class )
  29     {
  30         { [ dup jamo? ] [ jamo-class ] }
  31         { [ dup grapheme-control? ] [ control-class ] }
  32         { [ extend? ] [ Extend ] }
  33         [ Any ]
  34     } cond ;
  35
  36 : init-grapheme-table ( -- table )
  37     graphemes [ graphemes f <array> ] replicate ;
  38
  39 SYMBOL: table
  40
  41 : finish-table ( -- table )
  42     table get [ [ 1 = ] map ] map ;
  43
  44 : set-table ( class1 class2 val -- )
  45     -rot table get nth [ swap or ] change-nth ;
  46
  47 : connect ( class1 class2 -- ) 1 set-table ;
  48 : disconnect ( class1 class2 -- ) 0 set-table ;
  49
  50 : connect-before ( class classes -- )
  51     [ connect ] with each ;
  52
  53 : connect-after ( classes class -- )
  54     [ connect ] curry each ;
  55
  56 : break-around ( classes1 classes2 -- )
  57     [ [ 2dup disconnect swap disconnect ] with each ] curry each ;
  58
  59 : make-grapheme-table ( -- )
  60     CR LF connect
  61     Control CR LF 3array graphemes break-around
  62     L L V 2array connect-before
  63     V V T 2array connect-before
  64     T T connect
  65     graphemes Extend connect-after ;
  66
  67 VALUE: grapheme-table
  68
  69 : grapheme-break? ( class1 class2 -- ? )
  70     grapheme-table nth nth not ;
  71
  72 : chars ( i str n -- str[i] str[i+n] )
  73     swap >r dupd + r> [ ?nth ] curry bi@ ;
  74
  75 : find-index ( seq quot -- i ) find drop ; inline
  76 : find-last-index ( seq quot -- i ) find-last drop ; inline
  77
  78 : first-grapheme ( str -- i )
  79     unclip-slice grapheme-class over
  80     [ grapheme-class tuck grapheme-break? ] find-index
  81     nip swap length or 1+ ;
  82
  83 : (>graphemes) ( str -- )
  84     [
  85         dup first-grapheme cut-slice
  86         swap , (>graphemes)
  87     ] unless-empty ;
  88
  89 : >graphemes ( str -- graphemes )
  90     [ (>graphemes) ] { } make ;
  91
  92 : string-reverse ( str -- rts )
  93     >graphemes reverse concat ;
  94
  95 : last-grapheme ( str -- i )
  96     unclip-last-slice grapheme-class swap
  97     [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ;
  98
  99 init-grapheme-table table
 100 [ make-grapheme-table finish-table ] with-variable
 101 to: grapheme-table