io.encodings.korean iso2022kr encode-char working...

diff --git a/basis/io/encodings/korean/korean.factor b/basis/io/encodings/korean/korean.factor
index fecf339bdbcadc37c86075d73ed07f8d545f3dfe..4ac1a870747a2c80be8bd153c6a1391b25da2445 100644 (file)
--- a/basis/io/encodings/korean/korean.factor
+++ b/basis/io/encodings/korean/korean.factor
@@ -3,7 +3,8 @@
 USING: assocs byte-arrays combinators io io.encodings
 io.encodings.ascii io.encodings.iana io.files kernel locals math
 math.order math.parser values multiline sequences splitting
-values hashtables io.binary io.encodings.asian ;
+values hashtables io.binary io.encodings.asian math.ranges
+namespaces ;
 IN: io.encodings.korean
 
 
@@ -13,7 +14,8 @@ cp949 "EUC-KR" register-encoding
 
 SINGLETON: johab
 
-! johab "JOHAB" register-encoding
+SINGLETON: iso2022kr
+
 
 
 <PRIVATE
@@ -99,6 +101,68 @@ M: johab decode-char ( stream encoding -- char/f )
     drop [ johab>unicode ] [ johab-1st? ] decode-char-mb ;
 
 
+! iso-2022-kr encodings
+
+: shift-in ( -- c ) HEX: 0F ;
+: shift-out ( -- c ) HEX: 0E ;
+: designator ( -- s ) { CHAR: $ CHAR: \ CHAR: ) CHAR: C } ;
+
+: GR-range ( -- r ) HEX: A1 HEX: FE [a,b] ;
+: GL-range ( -- r ) HEX: 21 HEX: 7E [a,b] ;
+
+: GR>GL ( -- assoc )
+    GR-range GL-range zip >hashtable ;
+
+: GL>GR ( -- assoc )
+    GL-range GR-range zip >hashtable ;
+
+
+SYMBOL: *iso2022kr-status*
+
+H{ } *iso2022kr-status* set-global
+
+: iso2022kr-stream-get-status ( stream -- so/si/f )
+    *iso2022kr-status* get-global swap at ;
+
+: iso2022kr-stream-get-status* ( stream -- so/si )
+    iso2022kr-stream-get-status
+    [ shift-in ] unless* ;
+
+:: iso2022kr-stream-set-status ( stream so/si -- )
+    so/si stream *iso2022kr-status* get-global set-at ;
+
+: iso2022kr-stream-shift-out? ( stream -- ? )
+    iso2022kr-stream-get-status* shift-out = ;
+
+
+M: iso2022kr encode-char ( char stream encoding -- )
+    drop
+    [let | stream [ ]
+           char [ ] |
+        char unicode>cp949 byte?
+        [
+            ! if <SO> written, then enclose with <SI>.
+            stream iso2022kr-stream-shift-out?
+            [ shift-in 1byte-array stream stream-write ] [ ] if
+            ! plain ascii
+            char 1byte-array stream stream-write
+        ]
+        [
+            ! if <SO> is closed, then start it.
+            stream iso2022kr-stream-shift-out? not
+            [ shift-out 1byte-array stream stream-write ] [ ] if
+            !
+            char unicode>cp949 h>b/b swap 2byte-array
+            ! GR -> GL
+            [ GR>GL at ] map
+            !
+            stream stream-write
+        ] if
+    ] ;
+
+
+
+
 PRIVATE>