basis/unicode/breaks/breaks.factor

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