1 ! Copyright (C) 2009 Daniel Ehrenberg
2 ! See https://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
8 FROM: io.encodings.ascii => ascii ;
9 IN: io.encodings.gb18030
13 gb18030 "GB18030" register-encoding
17 ! GB to mean GB18030 is a terrible abuse of notation
20 ! https://source.icu-project.org/repos/icu/data/trunk/charset/data/xml/gb-18030-2000.xml
23 ! https://www-128.ibm.com/developerworks/library/u-china.html
25 : linear ( bytes -- num )
26 ! This hard-codes bMin and bMax
28 10 * + 126 * + 10 * + ; foldable
30 TUPLE: range ufirst ulast bfirst blast ;
32 : b>byte-array ( string -- byte-array )
33 split-words [ hex> ] B{ } map-as ;
35 : add-range ( contained ranges -- )
38 [ "uFirst" attr hex> ]
40 [ "bFirst" attr b>byte-array linear ]
41 [ "bLast" attr b>byte-array linear ]
45 : add-mapping ( contained mapping -- )
47 [ "b" attr b>byte-array ]
51 : xml>gb-data ( stream -- mapping ranges )
53 H{ } clone :> mapping V{ } clone :> ranges
57 { "range" [ ranges add-range ] }
58 { "a" [ mapping add-mapping ] }
62 ] each-element mapping ranges
65 : unlinear ( num -- bytes )
66 B{ 0x81 0x30 0x81 0x30 } linear -
71 4byte-array reverse! ;
73 : >interval-map-by ( start-quot end-quot value-quot seq -- interval-map )
74 '[ _ [ @ 2array ] _ tri ] { } map>assoc <interval-map> ; inline
76 : ranges-u>gb ( ranges -- interval-map )
77 [ ufirst>> ] [ ulast>> ] [ ] >interval-map-by ;
79 : ranges-gb>u ( ranges -- interval-map )
80 [ bfirst>> ] [ blast>> ] [ ] >interval-map-by ;
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
91 : lookup-range ( char -- byte-array )
92 dup u>gb get-global interval-at [
93 [ ufirst>> - ] [ bfirst>> ] bi + unlinear
94 ] [ encode-error ] if* ;
96 M: gb18030 encode-char
98 [ mapping get-global at ] [ lookup-range ] ?unless
101 : second-byte? ( ch -- ? ) ! of a double-byte character
102 { [ 0x40 0x7E between? ] [ 0x80 0xfe between? ] } 1|| ;
104 : quad-1/3? ( ch -- ? ) 0x81 0xfe between? ;
106 : quad-2/4? ( ch -- ? ) 0x30 0x39 between? ;
108 : last-bytes? ( byte-array -- ? )
109 { [ length 2 = ] [ first quad-1/3? ] [ second quad-2/4? ] } 1&& ;
111 : decode-quad ( byte-array -- char )
112 dup mapping get-global value-at [ ] [
113 linear dup gb>u get-global interval-at [
114 [ bfirst>> - ] [ ufirst>> ] bi +
115 ] [ drop replacement-char ] if*
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 ;
123 : two-byte ( stream byte -- char )
125 { [ dup not ] [ 3drop replacement-char ] }
126 { [ dup second-byte? ] [ 2byte-array mapping get-global value-at nip ] }
127 { [ dup quad-2/4? ] [ four-byte ] }
128 [ 3drop replacement-char ]
131 M: gb18030 decode-char
132 drop dup stream-read1 {
133 { [ dup not ] [ 2drop f ] }
134 { [ dup ascii? ] [ nip 1byte-array mapping get-global value-at ] }
135 { [ dup quad-1/3? ] [ two-byte ] }
136 [ 2drop replacement-char ]