Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2009-02-15 20:06:23 -06:00
commit 723dcd334f
11 changed files with 17631 additions and 31 deletions

View File

@ -24,7 +24,16 @@ SINGLETONS: photometric-interpretation
photometric-interpretation-white-is-zero
photometric-interpretation-black-is-zero
photometric-interpretation-rgb
photometric-interpretation-palette-color ;
photometric-interpretation-palette-color
photometric-interpretation-transparency-mask
photometric-interpretation-separated
photometric-interpretation-ycbcr
photometric-interpretation-cielab
photometric-interpretation-icclab
photometric-interpretation-itulab
photometric-interpretation-logl
photometric-interpretation-logluv ;
ERROR: bad-photometric-interpretation n ;
: lookup-photometric-interpretation ( n -- singleton )
{
@ -32,21 +41,73 @@ ERROR: bad-photometric-interpretation n ;
{ 1 [ photometric-interpretation-black-is-zero ] }
{ 2 [ photometric-interpretation-rgb ] }
{ 3 [ photometric-interpretation-palette-color ] }
{ 4 [ photometric-interpretation-transparency-mask ] }
{ 5 [ photometric-interpretation-separated ] }
{ 6 [ photometric-interpretation-ycbcr ] }
{ 8 [ photometric-interpretation-cielab ] }
{ 9 [ photometric-interpretation-icclab ] }
{ 10 [ photometric-interpretation-itulab ] }
{ 32844 [ photometric-interpretation-logl ] }
{ 32845 [ photometric-interpretation-logluv ] }
[ bad-photometric-interpretation ]
} case ;
SINGLETONS: compression
compression-none
compression-CCITT-2
compression-CCITT-3
compression-CCITT-4
compression-lzw
compression-pack-bits ;
compression-jpeg-old
compression-jpeg-new
compression-adobe-deflate
compression-9
compression-10
compression-deflate
compression-next
compression-ccittrlew
compression-pack-bits
compression-thunderscan
compression-it8ctpad
compression-it8lw
compression-it8mp
compression-it8bl
compression-pixarfilm
compression-pixarlog
compression-dcs
compression-jbig
compression-sgilog
compression-sgilog24
compression-jp2000 ;
ERROR: bad-compression n ;
: lookup-compression ( n -- compression )
{
{ 1 [ compression-none ] }
{ 2 [ compression-CCITT-2 ] }
{ 3 [ compression-CCITT-3 ] }
{ 4 [ compression-CCITT-4 ] }
{ 5 [ compression-lzw ] }
{ 6 [ compression-jpeg-old ] }
{ 7 [ compression-jpeg-new ] }
{ 8 [ compression-adobe-deflate ] }
{ 9 [ compression-9 ] }
{ 10 [ compression-10 ] }
{ 32766 [ compression-next ] }
{ 32771 [ compression-ccittrlew ] }
{ 32773 [ compression-pack-bits ] }
{ 32809 [ compression-thunderscan ] }
{ 32895 [ compression-it8ctpad ] }
{ 32896 [ compression-it8lw ] }
{ 32897 [ compression-it8mp ] }
{ 32898 [ compression-it8bl ] }
{ 32908 [ compression-pixarfilm ] }
{ 32909 [ compression-pixarlog ] }
{ 32946 [ compression-deflate ] }
{ 32947 [ compression-dcs ] }
{ 34661 [ compression-jbig ] }
{ 34676 [ compression-sgilog ] }
{ 34677 [ compression-sgilog24 ] }
{ 34712 [ compression-jp2000 ] }
[ bad-compression ]
} case ;
@ -86,6 +147,7 @@ ERROR: bad-planar-configuration n ;
} case ;
SINGLETONS: sample-format
sample-format-none
sample-format-unsigned-integer
sample-format-signed-integer
sample-format-ieee-float
@ -94,6 +156,7 @@ ERROR: bad-sample-format n ;
: lookup-sample-format ( sequence -- object )
[
{
{ 0 [ sample-format-none ] }
{ 1 [ sample-format-unsigned-integer ] }
{ 2 [ sample-format-signed-integer ] }
{ 3 [ sample-format-ieee-float ] }
@ -117,12 +180,37 @@ ERROR: bad-extra-samples n ;
SINGLETONS: image-length image-width x-resolution y-resolution
rows-per-strip strip-offsets strip-byte-counts bits-per-sample
samples-per-pixel new-subfile-type orientation software
date-time photoshop exif-ifd sub-ifd inter-color-profile
samples-per-pixel new-subfile-type subfile-type orientation
software date-time photoshop exif-ifd sub-ifd inter-color-profile
xmp iptc fill-order document-name page-number page-name
x-position y-position
x-position y-position host-computer copyright artist
min-sample-value max-sample-value make model cell-width cell-length
gray-response-unit gray-response-curve color-map threshholding
image-description free-offsets free-byte-counts tile-width tile-length
matteing data-type image-depth tile-depth
ycbcr-subsampling gdal-metadata
tile-offsets tile-byte-counts jpeg-qtables jpeg-dctables jpeg-actables
ycbcr-positioning ycbcr-coefficients reference-black-white halftone-hints
jpeg-interchange-format
jpeg-interchange-format-length
jpeg-restart-interval jpeg-tables
t4-options clean-fax-data bad-fax-lines consecutive-bad-fax-lines
sto-nits print-image-matching-info
unhandled-ifd-entry ;
SINGLETONS: jpeg-proc
jpeg-proc-baseline
jpeg-proc-lossless ;
ERROR: bad-jpeg-proc n ;
: lookup-jpeg-proc ( sequence -- object )
{
{ 1 [ jpeg-proc-baseline ] }
{ 14 [ jpeg-proc-lossless ] }
[ bad-jpeg-proc ]
} case ;
ERROR: bad-tiff-magic bytes ;
: tiff-endianness ( byte-array -- ? )
{
@ -146,12 +234,12 @@ ERROR: bad-tiff-magic bytes ;
4 read endian>
4 read endian> <ifd-entry> ;
: read-ifds ( tiff -- tiff )
dup ifd-offset>> seek-absolute seek-input
: read-ifds ( tiff offset -- tiff )
seek-absolute seek-input
2 read endian>
dup [ read-ifd ] replicate
4 read endian>
[ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi ;
[ <ifd> push-ifd ] [ dup 0 = [ drop ] [ read-ifds ] if ] bi ;
ERROR: no-tag class ;
@ -242,43 +330,92 @@ ERROR: bad-small-ifd-type n ;
: process-ifd-entry ( ifd-entry -- value class )
[ ifd-entry-value ] [ tag>> ] bi {
{ 254 [ new-subfile-type ] }
{ 255 [ subfile-type ] }
{ 256 [ image-width ] }
{ 257 [ image-length ] }
{ 258 [ bits-per-sample ] }
{ 259 [ lookup-compression compression ] }
{ 262 [ lookup-photometric-interpretation photometric-interpretation ] }
{ 263 [ threshholding ] }
{ 264 [ cell-width ] }
{ 265 [ cell-length ] }
{ 266 [ fill-order ] }
{ 269 [ ascii decode document-name ] }
{ 270 [ ascii decode image-description ] }
{ 271 [ ascii decode make ] }
{ 272 [ ascii decode model ] }
{ 273 [ strip-offsets ] }
{ 274 [ orientation ] }
{ 277 [ samples-per-pixel ] }
{ 278 [ rows-per-strip ] }
{ 279 [ strip-byte-counts ] }
{ 280 [ min-sample-value ] }
{ 281 [ max-sample-value ] }
{ 282 [ first x-resolution ] }
{ 283 [ first y-resolution ] }
{ 284 [ planar-configuration ] }
{ 285 [ page-name ] }
{ 286 [ x-position ] }
{ 287 [ y-position ] }
{ 288 [ free-offsets ] }
{ 289 [ free-byte-counts ] }
{ 290 [ gray-response-unit ] }
{ 291 [ gray-response-curve ] }
{ 292 [ t4-options ] }
{ 296 [ lookup-resolution-unit resolution-unit ] }
{ 297 [ page-number ] }
{ 305 [ ascii decode software ] }
{ 306 [ ascii decode date-time ] }
{ 315 [ ascii decode artist ] }
{ 316 [ ascii decode host-computer ] }
{ 317 [ lookup-predictor predictor ] }
{ 320 [ color-map ] }
{ 321 [ halftone-hints ] }
{ 322 [ tile-width ] }
{ 323 [ tile-length ] }
{ 324 [ tile-offsets ] }
{ 325 [ tile-byte-counts ] }
{ 326 [ bad-fax-lines ] }
{ 327 [ clean-fax-data ] }
{ 328 [ consecutive-bad-fax-lines ] }
{ 330 [ sub-ifd ] }
{ 338 [ lookup-extra-samples extra-samples ] }
{ 339 [ lookup-sample-format sample-format ] }
{ 347 [ jpeg-tables ] }
{ 512 [ lookup-jpeg-proc jpeg-proc ] }
{ 513 [ jpeg-interchange-format ] }
{ 514 [ jpeg-interchange-format-length ] }
{ 515 [ jpeg-restart-interval ] }
{ 519 [ jpeg-qtables ] }
{ 520 [ jpeg-dctables ] }
{ 521 [ jpeg-actables ] }
{ 529 [ ycbcr-coefficients ] }
{ 530 [ ycbcr-subsampling ] }
{ 531 [ ycbcr-positioning ] }
{ 532 [ reference-black-white ] }
{ 700 [ utf8 decode xmp ] }
{ 32995 [ matteing ] }
{ 32996 [ data-type ] }
{ 32997 [ image-depth ] }
{ 32998 [ tile-depth ] }
{ 33432 [ copyright ] }
{ 33723 [ iptc ] }
{ 34377 [ photoshop ] }
{ 34665 [ exif-ifd ] }
{ 33723 [ iptc ] }
{ 34675 [ inter-color-profile ] }
{ 37439 [ sto-nits ] }
{ 42112 [ gdal-metadata ] }
{ 50341 [ print-image-matching-info ] }
[ nip unhandled-ifd-entry swap ]
} case ;
: process-ifd ( ifd -- ifd )
dup ifd-entries>>
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
: process-ifds ( parsed-tiff -- parsed-tiff )
[
[
dup ifd-entries>>
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags
] map
] change-ifds ;
ERROR: unhandled-compression compression ;
@ -361,6 +498,8 @@ ERROR: unknown-component-order ifd ;
] }
{ extra-samples-unspecified-alpha-data [
] }
{ extra-samples-unassociated-alpha-data [
] }
[ bad-extra-samples ]
} case ;
@ -374,23 +513,36 @@ ERROR: unknown-component-order ifd ;
: tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ;
: load-tiff ( path -- parsed-tiff )
: with-tiff-endianness ( parsed-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline
: load-tiff-ifds ( path -- parsed-tiff )
binary [
<parsed-tiff>
read-header dup endianness>> [
read-ifds
dup ifds>> [
process-ifd read-strips
uncompress-strips
strips>bitmap
fix-bitmap-endianness
strips-predictor
dup extra-samples tag? [ handle-alpha-data ] when
drop
] each
] with-endianness
read-header [
dup ifd-offset>> read-ifds
process-ifds
] with-tiff-endianness
] with-file-reader ;
: process-tif-ifds ( parsed-tiff -- parsed-tiff )
dup ifds>> [
read-strips
uncompress-strips
strips>bitmap
fix-bitmap-endianness
strips-predictor
dup extra-samples tag? [ handle-alpha-data ] when
drop
] each ;
: load-tiff ( path -- parsed-tiff )
[ load-tiff-ifds ] [
binary [
[ process-tif-ifds ] with-tiff-endianness
] with-file-reader
] bi ;
! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image )
drop load-tiff tiff>image ;

View File

@ -0,0 +1 @@
Yun, Jonghyouk

File diff suppressed because it is too large Load Diff

View File

@ -0,0 +1,46 @@
! Copyright (C) 2009 Yun, Jonghyouk.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays byte-arrays io io.encodings io.encodings.korean
io.encodings.korean.private io.encodings.string io.streams.string
kernel locals multiline namespaces sequences strings tools.test ;
IN: io.encodings.korean.tests
! convert cp949 <> unicode
[ f ] [ HEX: 80 cp949>unicode ] unit-test
[ f ] [ HEX: ff cp949>unicode ] unit-test
[ HEX: ac02 ] [ HEX: 8141 cp949>unicode ] unit-test
[ HEX: 7f ] [ HEX: 7f cp949>unicode ] unit-test
[ HEX: c724 ] [ HEX: c0b1 cp949>unicode ] unit-test
[ HEX: 8141 ] [ HEX: ac02 unicode>cp949 ] unit-test
[ HEX: 7f ] [ HEX: 7f unicode>cp949 ] unit-test
[ HEX: c0b1 ] [ HEX: c724 unicode>cp949 ] unit-test
: phrase-unicode ( -- s )
"\u00b3d9\u00d574\u00bb3c\u00acfc \u00bc31\u00b450\u00c0b0\u00c774!" ;
: phrase-cp949 ( -- s )
{
HEX: b5 HEX: bf HEX: c7 HEX: d8
HEX: b9 HEX: b0 HEX: b0 HEX: fa
HEX: 20 HEX: b9 HEX: e9 HEX: b5
HEX: ce HEX: bb HEX: ea HEX: c0
HEX: cc HEX: 21
} ;
: phrase-unicode>cp949 ( -- s )
phrase-unicode cp949 encode ;
: phrase-cp949>unicode ( -- s )
phrase-cp949 cp949 decode ;
[ t ] [ phrase-unicode>cp949 >array phrase-cp949 = ] unit-test
[ t ] [ phrase-cp949>unicode phrase-unicode = ] unit-test
[ t ] [ phrase-cp949 1 head* cp949 decode phrase-unicode 1 head* = ] unit-test
[ t ] [ phrase-cp949 3 head* cp949 decode phrase-unicode 2 head* = ] unit-test
[ t ] [ phrase-cp949 2 head* cp949 decode phrase-unicode 2 head* CHAR: replacement-character suffix = ] unit-test

View File

@ -0,0 +1,79 @@
! Copyright (C) 2009 Yun, Jonghyouk.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs byte-arrays combinators io io.encodings
io.encodings.ascii io.encodings.iana io.files kernel locals math
math.order math.parser memoize multiline sequences splitting
values hashtables io.binary ;
IN: io.encodings.korean
SINGLETON: cp949
cp949 "EUC-KR" register-encoding
<PRIVATE
! parse cp949.txt > table
: cp949.txt-lines ( -- seq )
! "cp949.txt" from ...
! <http://unicode.org/Public/MAPPINGS/VENDORS/MICSFT/WINDOWS/CP949.TXT>
"resource:basis/io/encodings/korean/data/cp949.txt"
ascii file-lines ;
: drop-comments ( seq -- newseq )
[ "#" split1 drop ] map harvest ;
: split-column ( line -- columns )
"\t" split 2 head ;
: parse-hex ( s -- n )
2 short tail hex> ;
: parse-line ( line -- code-unicode )
split-column [ parse-hex ] map ;
: process-codetable-lines ( lines -- assoc )
drop-comments [ parse-line ] map ;
! convert cp949 <> unicode
MEMO: cp949>unicode-table ( -- hashtable )
cp949.txt-lines process-codetable-lines >hashtable ;
MEMO: unicode>cp949-table ( -- hashtable )
cp949>unicode-table [ swap ] assoc-map ;
unicode>cp949-table drop
: cp949>unicode ( b -- u )
cp949>unicode-table at ;
: unicode>cp949 ( u -- b )
unicode>cp949-table at ;
: cp949-1st? ( n -- ? )
dup [ HEX: 81 HEX: fe between? ] when ;
: byte? ( n -- ? )
0 HEX: ff between? ;
M:: cp949 encode-char ( char stream encoding -- )
char unicode>cp949 byte?
[ char 1byte-array stream stream-write ] [
char unicode>cp949
h>b/b swap 2byte-array
stream stream-write
] if ;
: decode-char-step2 ( c stream -- char )
stream-read1
[ 2byte-array be> cp949>unicode ]
[ drop replacement-char ] if* ;
M:: cp949 decode-char ( stream encoding -- char/f )
stream stream-read1
{
{ [ dup not ] [ drop f ] }
{ [ dup cp949-1st? ] [ stream decode-char-step2 ] }
[ ]
} cond ;

View File

@ -0,0 +1 @@
Korean text encodings

View File

@ -0,0 +1 @@
text

View File

@ -65,7 +65,6 @@
;;; Editing commands:
(defvar fuel-edit--word-history nil)
(defvar fuel-edit--previous-location nil)
(defun fuel-edit-vocabulary (&optional refresh vocab)
"Visits vocabulary file in Emacs.
@ -129,7 +128,7 @@ was last invoked."
(interactive)
(condition-case nil
(pop-tag-mark)
(error "No previous location for find word or vocab invokation")))
(error "No previous location for find word or vocab invocation")))
(defvar fuel-edit--buffer-history nil)

View File

@ -88,7 +88,6 @@
(t 'default))))
((or (char-equal c ?U) (char-equal c ?C))
'factor-font-lock-parsing-word)
((char-equal c ?\() 'factor-font-lock-stack-effect)
((char-equal c ?\") 'factor-font-lock-string)
(t 'factor-font-lock-comment)))))

View File

@ -136,7 +136,7 @@
(fuel-syntax--second-word-regex '("&:" "SYMBOL:" "VAR:")))
(defconst fuel-syntax--stack-effect-regex
"\\( ( .* )\\)\\|\\( (( .* ))\\)")
"\\( ( [^\n]* )\\)\\|\\( (( [^\n]* ))\\)")
(defconst fuel-syntax--using-lines-regex "^USING: +\\([^;]+\\);")
@ -239,6 +239,8 @@
(modify-syntax-entry ?\r " " table)
(modify-syntax-entry ?\ " " table)
(modify-syntax-entry ?\n " " table)
(modify-syntax-entry ?\( "()" table)
(modify-syntax-entry ?\) ")(" table)
table))
(defconst fuel-syntax--syntactic-keywords
@ -247,8 +249,6 @@
;; Comments:
("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">"))
("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">"))
(" \\((\\)( \\([^\n]*\\) )\\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
(" \\((\\) \\([^\n]*\\) \\()\\)\\( \\|\n\\)" (1 "<b") (2 "w") (3 ">b"))
;; Strings
("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
(3 "\"") (5 "\""))