basis/unicode/breaks/breaks.factor

   1 ! Copyright (C) 2008 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators fry interval-maps
   4 kernel literals locals math namespaces parser sequences
   5 simple-flat-file unicode.categories unicode.data
   6 unicode.normalize.private words words.constant ;
   7 IN: unicode.breaks
   8
   9 <PRIVATE
  10
  11 ! Grapheme breaks
  12 <<
  13 CONSTANT: Any 0
  14 CONSTANT: L 1
  15 CONSTANT: V 2
  16 CONSTANT: T 3
  17 CONSTANT: LV 4
  18 CONSTANT: LVT 5
  19 CONSTANT: Extend 6
  20 CONSTANT: Control 7
  21 CONSTANT: CR 8
  22 CONSTANT: LF 9
  23 CONSTANT: SpacingMark 10
  24 CONSTANT: Prepend 11
  25 CONSTANT: graphemes 12
  26
  27 : jamo-class ( ch -- class )
  28     dup initial? [ drop L ]
  29     [ dup medial? [ drop V ] [ final? T Any ? ] if ] if ;
  30
  31 : hangul-class ( ch -- class )
  32     hangul-base - 0x1C mod zero? LV LVT ? ;
  33
  34 CATEGORY: grapheme-control Zl Zp Cc Cf ;
  35 : control-class ( ch -- class )
  36     {
  37         { CHAR: \r [ CR ] }
  38         { CHAR: \n [ LF ] }
  39         { 0x200C [ Extend ] }
  40         { 0x200D [ Extend ] }
  41         [ drop Control ]
  42     } case ;
  43
  44 CATEGORY: extend
  45     Me Mn |
  46     "Other_Grapheme_Extend" property? ;
  47
  48 : loe? ( ch -- ? )
  49     "Logical_Order_Exception" property? ;
  50
  51 CATEGORY: spacing Mc ;
  52
  53 : grapheme-class ( ch -- class )
  54     {
  55         { [ dup jamo? ] [ jamo-class ] }
  56         { [ dup hangul? ] [ hangul-class ] }
  57         { [ dup grapheme-control? ] [ control-class ] }
  58         { [ dup extend? ] [ drop Extend ] }
  59         { [ dup spacing? ] [ drop SpacingMark ] }
  60         { [ loe? ] [ Prepend ] }
  61         [ Any ]
  62     } cond ;
  63
  64 : init-table ( size -- table )
  65     dup [ f <array> ] curry replicate ;
  66
  67 SYMBOL: table
  68
  69 : finish-table ( -- table )
  70     table get [ [ 1 = ] map ] map ;
  71
  72 : eval-seq ( seq -- seq )
  73     [ dup word? [ execute( -- x ) ] when ] map ;
  74
  75 : (set-table) ( class1 class2 val -- )
  76     [ table get nth ] dip '[ _ or ] change-nth ;
  77
  78 : set-table ( classes1 classes2 val -- )
  79     [ [ eval-seq ] bi@ ] dip
  80     [ [ (set-table) ] curry with each ] 2curry each ;
  81
  82 : connect ( class1 class2 -- ) 1 set-table ;
  83 : disconnect ( class1 class2 -- ) 0 set-table ;
  84
  85 : make-grapheme-table ( -- )
  86     { CR } { LF } connect
  87     { Control CR LF } graphemes iota disconnect
  88     graphemes iota { Control CR LF } disconnect
  89     { L } { L V LV LVT } connect
  90     { LV V } { V T } connect
  91     { LVT T } { T } connect
  92     graphemes iota { Extend } connect
  93     graphemes iota { SpacingMark } connect
  94     { Prepend } graphemes iota connect ;
  95
  96 "grapheme-table" create-word-in
  97 graphemes init-table table
  98 [ make-grapheme-table finish-table ] with-variable
  99 define-constant
 100 >>
 101
 102 : grapheme-break? ( class1 class2 -- ? )
 103     grapheme-table nth nth not ;
 104
 105 ! Word breaks
 106 <<
 107 CONSTANT: wOther 0
 108 CONSTANT: wCR 1
 109 CONSTANT: wLF 2
 110 CONSTANT: wNewline 3
 111 CONSTANT: wExtend 4
 112 CONSTANT: wFormat 5
 113 CONSTANT: wKatakana 6
 114 CONSTANT: wALetter 7
 115 CONSTANT: wMidLetter 8
 116 CONSTANT: wMidNum 9
 117 CONSTANT: wMidNumLet 10
 118 CONSTANT: wNumeric 11
 119 CONSTANT: wExtendNumLet 12
 120 CONSTANT: unicode-words 13
 121
 122 ! Is there a way to avoid this?
 123 CONSTANT: word-break-classes H{
 124     { "Other" 0 } { "CR" 1 } { "LF" 2 } { "Newline" 3 }
 125     { "Extend" 4 } { "Format" 5 } { "Katakana" 6 }
 126     { "ALetter" 7 } { "MidLetter" 8 }
 127     { "MidNum" 9 } { "MidNumLet" 10 } { "Numeric" 11 }
 128     { "ExtendNumLet" 12 }
 129 }
 130
 131 "word-break-table" create-word-in
 132 "vocab:unicode/data/WordBreakProperty.txt"
 133 load-interval-file dup array>>
 134 [ 2 swap [ word-break-classes at ] change-nth ] each
 135 define-constant
 136 >>
 137
 138 : word-break-prop ( char -- word-break-prop )
 139     word-break-table interval-at wOther or ;
 140
 141 <<
 142 SYMBOL: check-letter-before
 143 SYMBOL: check-letter-after
 144 SYMBOL: check-number-before
 145 SYMBOL: check-number-after
 146
 147 : make-word-table ( -- )
 148     { wCR } { wLF } connect
 149     { wNewline wCR wLF } unicode-words iota disconnect
 150     unicode-words iota { wNewline wCR wLF } disconnect
 151     { wALetter } { wMidLetter wMidNumLet } check-letter-after set-table
 152     { wMidLetter wMidNumLet } { wALetter } check-letter-before set-table
 153     { wNumeric wALetter } { wNumeric wALetter } connect
 154     { wNumeric } { wMidNum wMidNumLet } check-number-after set-table
 155     { wMidNum wMidNumLet } { wNumeric } check-number-before set-table
 156     { wKatakana } { wKatakana } connect
 157     { wALetter wNumeric wKatakana wExtendNumLet } { wExtendNumLet }
 158     [ connect ] [ swap connect ] 2bi ;
 159
 160 : finish-word-table ( -- table )
 161     table get [
 162         [ { { 0 [ f ] } { 1 [ t ] } [ ] } case ] map
 163     ] map ;
 164
 165 "word-table" create-word-in
 166 unicode-words init-table table
 167 [ make-word-table finish-word-table ] with-variable
 168 define-constant
 169 >>
 170
 171 : word-table-nth ( class1 class2 -- ? )
 172     word-table nth nth ;
 173
 174 :: property-not= ( str i property -- ? )
 175     i [
 176         i str ?nth [ word-break-prop property = not ]
 177         [ f ] if*
 178     ] [ t ] if ;
 179
 180 : (format/extended?) ( class -- ? )
 181     ${ wExtend wFormat } member? ; inline
 182
 183 : format/extended? ( ch -- ? )
 184     word-break-prop (format/extended?) ;
 185
 186 : (walk-up) ( str i -- j )
 187     swap [ format/extended? not ] find-from drop ;
 188
 189 : walk-up ( str i -- j )
 190     dupd 1 + (walk-up) [ 1 + (walk-up) ] [ drop f ] if* ;
 191
 192 : (walk-down) ( str i -- j )
 193     swap [ format/extended? not ] find-last-from drop ;
 194
 195 : walk-down ( str i -- j )
 196     dupd (walk-down) [ 1 - (walk-down) ] [ drop f ] if* ;
 197
 198 : word-break? ( str i table-entry -- ? )
 199     {
 200         { t [ 2drop f ] }
 201         { f [ 2drop t ] }
 202         { check-letter-after
 203             [ dupd walk-up wALetter property-not= ] }
 204         { check-letter-before
 205             [ dupd walk-down wALetter property-not= ] }
 206         { check-number-after
 207             [ dupd walk-up wNumeric property-not= ] }
 208         { check-number-before
 209             [ dupd walk-down wNumeric property-not= ] }
 210     } case ;
 211
 212 :: word-break-next ( old-class new-char i str -- next-class ? )
 213     new-char word-break-prop :> new-class
 214     new-class (format/extended?)
 215     [ old-class dup ${ wCR wLF wNewline } member? ] [
 216         new-class old-class over word-table-nth
 217         [ str i 1 - ] dip word-break?
 218     ] if ;
 219
 220 PRIVATE>