extra/unicode/breaks/breaks.factor

   1 USING: unicode kernel math const combinators splitting
   2 sequences math.parser io.files io assocs arrays namespaces
   3 ;
   4 IN: unicode.breaks
   5
   6 ENUM: Any L V T Extend Control CR LF graphemes ;
   7
   8 : jamo-class ( ch -- class )
   9     dup initial? [ drop L ]
  10     [ dup medial? [ drop V ] [ final? T Any ? ] if ] if ;
  11
  12 CATEGORY: grapheme-control Zl Zp Cc Cf ;
  13 : control-class ( ch -- class )
  14     {
  15         { CHAR: \r [ CR ] }
  16         { CHAR: \n [ LF ] }
  17         { HEX: 200C [ Extend ] }
  18         { HEX: 200D [ Extend ] }
  19         [ drop Control ]
  20     } case ;
  21
  22 : trim-blank ( str -- newstr )
  23     dup [ blank? not ] find-last 1+* head ;
  24
  25 : process-other-extend ( lines -- set )
  26     [ "#" split1 drop ";" split1 drop trim-blank ] map
  27     [ empty? not ] subset
  28     [ ".." split1 [ dup ] unless* [ hex> ] 2apply range ] map
  29     concat >set ;
  30
  31 : other-extend-lines ( -- lines )
  32     "extra/unicode/PropList.txt" resource-path <file-reader> lines ;
  33
  34 DEFER: other-extend
  35 : load-other-extend
  36     other-extend-lines process-other-extend
  37     \ other-extend define-value ; parsing
  38 load-other-extend
  39
  40 CATEGORY: (extend) Me Mn ;
  41 : extend? ( ch -- ? )
  42     [ (extend)? ] [ other-extend key? ] either ;
  43
  44 : grapheme-class ( ch -- class )
  45     {
  46         { [ dup jamo? ] [ jamo-class ] }
  47         { [ dup grapheme-control? ] [ control-class ] }
  48         { [ extend? ] [ Extend ] }
  49         { [ t ] [ Any ] }
  50     } cond ;
  51
  52 : init-grapheme-table ( -- table )
  53     graphemes [ drop graphemes f <array> ] map ;
  54
  55 SYMBOL: table
  56
  57 : finish-table ( -- table )
  58     table get [ [ 1 = ] map ] map ;
  59
  60 : set-table ( class1 class2 val -- )
  61     -rot table get nth [ swap or ] change-nth ;
  62
  63 : connect ( class1 class2 -- ) 1 set-table ;
  64 : disconnect ( class1 class2 -- ) 0 set-table ;
  65
  66 : connect-before ( class classes -- )
  67     [ connect ] curry* each ;
  68
  69 : connect-after ( classes class -- )
  70     [ connect ] curry each ;
  71
  72 : break-around ( classes1 classes2 -- )
  73     [ [ 2dup disconnect swap disconnect ] curry* each ] curry each ;
  74
  75 : make-grapheme-table ( -- )
  76     CR LF connect
  77     { Control CR LF } graphemes break-around
  78     L { L V } connect-before
  79     V { V T } connect-before
  80     T T connect
  81     graphemes Extend connect-after ;
  82
  83 DEFER: grapheme-table
  84 : load-grapheme-table
  85     init-grapheme-table table
  86     [ make-grapheme-table finish-table ] with-variable
  87     \ grapheme-table define-value ; parsing
  88 load-grapheme-table
  89
  90 : grapheme-break? ( class1 class2 -- ? )
  91     grapheme-table nth nth not ;
  92
  93 : chars ( i str n -- str[i] str[i+n] )
  94     swap >r dupd + r> [ ?nth ] curry 2apply ;
  95
  96 : next-grapheme-step ( i str -- i+1 str prev-class )
  97     2dup nth grapheme-class >r >r 1+ r> r> ;
  98
  99 : (next-grapheme) ( i str prev-class -- next-i )
 100     3dup drop bounds-check? [
 101         >r next-grapheme-step r> over grapheme-break?
 102         [ 2drop 1- ] [ (next-grapheme) ] if
 103     ] [ 2drop ] if ;
 104
 105 : next-grapheme ( i str -- next-i )
 106     next-grapheme-step (next-grapheme) ;
 107
 108 : (>graphemes) ( i str -- )
 109     2dup bounds-check? [
 110         dupd [ next-grapheme ] keep
 111         [ subseq , ] 2keep (>graphemes)
 112     ] [ 2drop ] if ;
 113 : >graphemes ( str -- graphemes )
 114     [ 0 swap (>graphemes) ] { } make* ;
 115
 116 : string-reverse ( str -- rts )
 117     >graphemes reverse concat ;
 118
 119 : prev-grapheme-step ( i str -- i-1 str prev-class )
 120     2dup nth grapheme-class >r >r 1- r> r> ;
 121
 122 : (prev-grapheme) ( i str next-class -- prev-i )
 123     pick zero? [
 124         >r prev-grapheme-step r> dupd grapheme-break?
 125         [ 2drop 1- ] [ (prev-grapheme) ] if
 126     ] [ 2drop ] if ;
 127
 128 : prev-grapheme ( i str -- prev-i )
 129     prev-grapheme-step (prev-grapheme) ;