basis/io/encodings/gb18030/gb18030.factor

   1 ! Copyright (C) 2009 Daniel Ehrenberg
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: xml xml.data kernel io io.encodings interval-maps splitting fry
   4 math.parser sequences combinators assocs locals accessors math arrays
   5 byte-arrays values ascii io.files biassocs math.order
   6 combinators.short-circuit io.binary io.encodings.iana ;
   7 FROM: io.encodings.ascii => ascii ;
   8 IN: io.encodings.gb18030
   9
  10 SINGLETON: gb18030
  11
  12 gb18030 "GB18030" register-encoding
  13
  14 <PRIVATE
  15
  16 ! GB to mean GB18030 is a terrible abuse of notation
  17
  18 ! Resource file from:
  19 ! http://source.icu-project.org/repos/icu/data/trunk/charset/data/xml/gb-18030-2000.xml
  20
  21 ! Algorithms from:
  22 ! http://www-128.ibm.com/developerworks/library/u-china.html
  23
  24 : linear ( bytes -- num )
  25     ! This hard-codes bMin and bMax
  26     reverse first4
  27     10 * + 126 * + 10 * + ; foldable
  28
  29 TUPLE: range ufirst ulast bfirst blast ;
  30
  31 : b>byte-array ( string -- byte-array )
  32     " " split [ hex> ] B{ } map-as ;
  33
  34 : add-range ( contained ranges -- )
  35     [
  36         {
  37             [ "uFirst" attr hex> ]
  38             [ "uLast" attr hex> ]
  39             [ "bFirst" attr b>byte-array linear ]
  40             [ "bLast" attr b>byte-array linear ]
  41         } cleave range boa
  42     ] dip push ;
  43
  44 : add-mapping ( contained mapping -- )
  45     [
  46         [ "b" attr b>byte-array ]
  47         [ "u" attr hex> ] bi
  48     ] dip set-at ;
  49
  50 : xml>gb-data ( stream -- mapping ranges )
  51     [let
  52         H{ } clone :> mapping V{ } clone :> ranges
  53         [
  54             dup contained? [
  55                 dup name>> main>> {
  56                     { "range" [ ranges add-range ] }
  57                     { "a" [ mapping add-mapping ] }
  58                     [ 2drop ]
  59                 } case
  60             ] [ drop ] if
  61         ] each-element mapping ranges
  62     ] ;
  63
  64 : unlinear ( num -- bytes )
  65     B{ 0x81 0x30 0x81 0x30 } linear -
  66     10 /mod 0x30 + swap
  67     126 /mod 0x81 + swap
  68     10 /mod 0x30 + swap
  69     0x81 +
  70     4byte-array reverse! ;
  71
  72 : >interval-map-by ( start-quot end-quot value-quot seq -- interval-map )
  73     '[ _ [ @ 2array ] _ tri ] { } map>assoc <interval-map> ; inline
  74
  75 : ranges-u>gb ( ranges -- interval-map )
  76     [ ufirst>> ] [ ulast>> ] [ ] >interval-map-by ;
  77
  78 : ranges-gb>u ( ranges -- interval-map )
  79     [ bfirst>> ] [ blast>> ] [ ] >interval-map-by ;
  80
  81 VALUE: gb>u
  82 VALUE: u>gb
  83 VALUE: mapping
  84
  85 "vocab:io/encodings/gb18030/gb-18030-2000.xml"
  86 ascii <file-reader> xml>gb-data
  87 [ ranges-u>gb \ u>gb set-value ] [ ranges-gb>u \ gb>u set-value ] bi
  88 >biassoc \ mapping set-value
  89
  90 : lookup-range ( char -- byte-array )
  91     dup u>gb interval-at [
  92         [ ufirst>> - ] [ bfirst>> ] bi + unlinear
  93     ] [ encode-error ] if* ;
  94
  95 M: gb18030 encode-char ( char stream encoding -- )
  96     drop [
  97         dup mapping at
  98         [ ] [ lookup-range ] ?if
  99     ] dip stream-write ;
 100
 101 : second-byte? ( ch -- ? ) ! of a double-byte character
 102     { [ 0x40 0x7E between? ] [ 0x80 0xfe between? ] } 1||  ;
 103
 104 : quad-1/3? ( ch -- ? ) 0x81 0xfe between? ;
 105
 106 : quad-2/4? ( ch -- ? ) 0x30 0x39 between? ;
 107
 108 : last-bytes? ( byte-array -- ? )
 109     { [ length 2 = ] [ first quad-1/3? ] [ second quad-2/4? ] } 1&& ;
 110
 111 : decode-quad ( byte-array -- char )
 112     dup mapping value-at [ ] [
 113         linear dup gb>u interval-at [
 114             [ bfirst>> - ] [ ufirst>> ] bi +
 115         ] [ drop replacement-char ] if*
 116     ] ?if ;
 117
 118 : four-byte ( stream byte1 byte2 -- char )
 119     rot 2 swap stream-read dup last-bytes?
 120     [ first2 4byte-array decode-quad ]
 121     [ 3drop replacement-char ] if ;
 122
 123 : two-byte ( stream byte -- char )
 124     over stream-read1 {
 125         { [ dup not ] [ 3drop replacement-char ] }
 126         { [ dup second-byte? ] [ 2byte-array mapping value-at nip ] }
 127         { [ dup quad-2/4? ] [ four-byte ] }
 128         [ 3drop replacement-char ]
 129     } cond ;
 130
 131 M: gb18030 decode-char ( stream encoding -- char )
 132     drop dup stream-read1 {
 133         { [ dup not ] [ 2drop f ] }
 134         { [ dup ascii? ] [ nip 1byte-array mapping value-at ] }
 135         { [ dup quad-1/3? ] [ two-byte ] }
 136         [ 2drop replacement-char ]
 137     } cond ;