basis/io/encodings/gb18030/gb18030.factor

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