1 ! Copyright (C) 2009 Daniel Ehrenberg, Jonghyouk Yun.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel io.encodings accessors assocs sequences biassocs generic
4 math.order simple-flat-file io io.binary byte-arrays locals combinators
5 words classes.singleton fry classes.parser parser quotations ;
8 TUPLE: euc { table biassoc } ;
15 M: euc encode-char ( char stream encoding -- )
16 swapd table>> value-at [
18 [ swap stream-write1 ] [
19 h>b/b swap 2byte-array
22 ] [ throw-encode-error ] if* ;
24 : euc-multibyte? ( ch -- ? )
27 :: decode-multibyte ( ch stream encoding -- char )
29 [ ch swap 2byte-array be> encoding table>> at ]
30 [ replacement-char ] if* ;
32 M:: euc decode-char ( stream encoding -- char/f )
35 { [ dup not ] [ drop f ] }
36 { [ dup euc-multibyte? ] [ stream encoding decode-multibyte ] }
37 [ encoding table>> at ]
40 : define-method ( class word definition -- )
41 [ create-method ] dip define ;
45 : setup-euc ( word file-name -- singleton-class biassoc )
46 [ dup define-singleton-class ]
47 [ flat-file>biassoc ] bi* ;
49 :: define-recursive-methods ( class data words -- )
51 class word [ drop data word execute ] define-method
54 : euc-methods ( singleton-class biassoc -- )
55 [ euc-table set-word-prop ] [
57 { <encoder> <decoder> }
58 define-recursive-methods
61 : define-euc ( word file-name -- )
62 setup-euc euc-methods ;
67 ! EUC: euc-kr "vocab:io/encodings/korean/cp949.txt"
68 scan-new-class scan-object define-euc ;