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