Merge branch 'master' into regexp
Daniel Ehrenberg
commit
00c5395d31
|
|
@ -55,7 +55,7 @@ GENERIC: emit-node ( node -- next )
|
|||
|
||||
: begin-word ( -- )
|
||||
#! We store the basic block after the prologue as a loop
|
||||
#! labelled by the current word, so that self-recursive
|
||||
#! labeled by the current word, so that self-recursive
|
||||
#! calls can skip an epilogue/prologue.
|
||||
##prologue
|
||||
##branch
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types namespaces io.binary fry
|
||||
kernel math grouping sequences ;
|
||||
kernel math grouping sequences math.bitwise ;
|
||||
IN: endian
|
||||
|
||||
SINGLETONS: big-endian little-endian ;
|
||||
|
|
@ -9,9 +9,6 @@ SINGLETONS: big-endian little-endian ;
|
|||
: compute-native-endianness ( -- class )
|
||||
1 <int> *char 0 = big-endian little-endian ? ;
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
SYMBOL: native-endianness
|
||||
native-endianness [ compute-native-endianness ] initialize
|
||||
|
||||
|
|
|
|||
|
|
@ -85,10 +85,10 @@ image-link = "[[image:" link-content "|" link-content "]]"
|
|||
simple-link = "[[" link-content "]]"
|
||||
=> [[ second >string dup simple-link-title link boa ]]
|
||||
|
||||
labelled-link = "[[" link-content "|" link-content "]]"
|
||||
labeled-link = "[[" link-content "|" link-content "]]"
|
||||
=> [[ [ second >string ] [ fourth >string ] bi link boa ]]
|
||||
|
||||
link = image-link | labelled-link | simple-link
|
||||
link = image-link | labeled-link | simple-link
|
||||
|
||||
escaped-char = "\" .
|
||||
=> [[ second 1string ]]
|
||||
|
|
|
|||
|
|
@ -2,11 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors grouping sequences combinators
|
||||
math specialized-arrays.direct.uint byte-arrays
|
||||
specialized-arrays.direct.ushort ;
|
||||
specialized-arrays.direct.ushort specialized-arrays.uint
|
||||
specialized-arrays.ushort specialized-arrays.float ;
|
||||
IN: images
|
||||
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
R16G16B16 R32G32B32 ;
|
||||
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
|
||||
|
||||
TUPLE: image dim component-order bitmap ;
|
||||
|
||||
|
|
@ -18,34 +19,37 @@ GENERIC: load-image* ( path tuple -- image )
|
|||
3 <sliced-groups>
|
||||
[ 255 suffix ] map concat ;
|
||||
|
||||
: normalize-floats ( byte-array -- byte-array )
|
||||
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>>
|
||||
{
|
||||
{ RGBA [ ] }
|
||||
{ R32G32B32A32 [
|
||||
[ normalize-floats ] change-bitmap
|
||||
] }
|
||||
{ R32G32B32 [
|
||||
[
|
||||
dup length 4 / <direct-uint-array>
|
||||
[ bits>float 255.0 * >integer ] map
|
||||
>byte-array add-dummy-alpha
|
||||
] change-bitmap
|
||||
[ normalize-floats add-dummy-alpha ] change-bitmap
|
||||
] }
|
||||
{ R16G16B16A16 [
|
||||
[ byte-array>ushort-array [ -8 shift ] B{ } map-as ] change-bitmap
|
||||
] }
|
||||
{ R16G16B16 [
|
||||
[
|
||||
dup length 2 / <direct-ushort-array>
|
||||
[ -8 shift ] map
|
||||
>byte-array add-dummy-alpha
|
||||
byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha
|
||||
] change-bitmap
|
||||
] }
|
||||
{ BGRA [
|
||||
[
|
||||
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||
4 <sliced-groups> dup [ 3 head-slice reverse-here ] each
|
||||
] change-bitmap
|
||||
] }
|
||||
{ RGB [ [ add-dummy-alpha ] change-bitmap ] }
|
||||
{ BGR [
|
||||
[
|
||||
3 <sliced-groups>
|
||||
[ [ [ 0 3 ] dip <slice> reverse-here ] each ]
|
||||
[ [ 3 head-slice reverse-here ] each ]
|
||||
[ add-dummy-alpha ] bi
|
||||
] change-bitmap
|
||||
] }
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io
|
|||
io.binary io.encodings.ascii io.encodings.binary
|
||||
io.encodings.string io.encodings.utf8 io.files kernel math
|
||||
math.bitwise math.order math.parser pack prettyprint sequences
|
||||
strings ;
|
||||
strings math.vectors specialized-arrays.float ;
|
||||
IN: images.tiff
|
||||
|
||||
TUPLE: tiff-image < image ;
|
||||
|
|
@ -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,9 +180,36 @@ 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
|
||||
xmp iptc unhandled-ifd-entry ;
|
||||
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 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 -- ? )
|
||||
|
|
@ -144,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 ;
|
||||
|
||||
|
|
@ -159,6 +249,9 @@ ERROR: no-tag class ;
|
|||
: find-tag ( idf class -- tag )
|
||||
swap processed-tags>> ?at [ no-tag ] unless ;
|
||||
|
||||
: tag? ( idf class -- tag )
|
||||
swap processed-tags>> key? ;
|
||||
|
||||
: read-strips ( ifd -- ifd )
|
||||
dup
|
||||
[ strip-byte-counts find-tag ]
|
||||
|
|
@ -237,37 +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 )
|
||||
: process-ifds ( parsed-tiff -- parsed-tiff )
|
||||
[
|
||||
[
|
||||
dup ifd-entries>>
|
||||
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
|
||||
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags
|
||||
] map
|
||||
] change-ifds ;
|
||||
|
||||
ERROR: unhandled-compression compression ;
|
||||
|
||||
|
|
@ -286,6 +434,27 @@ ERROR: unhandled-compression compression ;
|
|||
: strips>bitmap ( ifd -- ifd )
|
||||
dup strips>> concat >>bitmap ;
|
||||
|
||||
: (strips-predictor) ( ifd -- ifd )
|
||||
[ ]
|
||||
[ image-width find-tag ]
|
||||
[ samples-per-pixel find-tag ] tri
|
||||
[ * ] keep
|
||||
'[
|
||||
_ group [ _ group [ rest ] [ first ] bi
|
||||
[ v+ ] accumulate swap suffix concat ] map
|
||||
concat >byte-array
|
||||
] change-bitmap ;
|
||||
|
||||
: strips-predictor ( ifd -- ifd )
|
||||
dup predictor tag? [
|
||||
dup predictor find-tag
|
||||
{
|
||||
{ predictor-none [ ] }
|
||||
{ predictor-horizontal-differencing [ (strips-predictor) ] }
|
||||
[ bad-predictor ]
|
||||
} case
|
||||
] when ;
|
||||
|
||||
ERROR: unknown-component-order ifd ;
|
||||
|
||||
: fix-bitmap-endianness ( ifd -- ifd )
|
||||
|
|
@ -302,13 +471,38 @@ ERROR: unknown-component-order ifd ;
|
|||
|
||||
: ifd-component-order ( ifd -- byte-order )
|
||||
bits-per-sample find-tag {
|
||||
{ { 32 32 32 32 } [ R32G32B32A32 ] }
|
||||
{ { 32 32 32 } [ R32G32B32 ] }
|
||||
{ { 16 16 16 16 } [ R16G16B16A16 ] }
|
||||
{ { 16 16 16 } [ R16G16B16 ] }
|
||||
{ { 8 8 8 8 } [ RGBA ] }
|
||||
{ { 8 8 8 } [ RGB ] }
|
||||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: handle-alpha-data ( ifd -- ifd )
|
||||
dup extra-samples find-tag {
|
||||
{ extra-samples-associated-alpha-data [
|
||||
[
|
||||
B{ } like dup
|
||||
byte-array>float-array
|
||||
4 <sliced-groups>
|
||||
[
|
||||
dup fourth dup 0 = [
|
||||
2drop
|
||||
] [
|
||||
[ 3 head-slice ] dip '[ _ / ] change-each
|
||||
] if
|
||||
] each
|
||||
] change-bitmap
|
||||
] }
|
||||
{ extra-samples-unspecified-alpha-data [
|
||||
] }
|
||||
{ extra-samples-unassociated-alpha-data [
|
||||
] }
|
||||
[ bad-extra-samples ]
|
||||
} case ;
|
||||
|
||||
: ifd>image ( ifd -- image )
|
||||
{
|
||||
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
|
||||
|
|
@ -319,20 +513,35 @@ 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
|
||||
read-header [
|
||||
dup ifd-offset>> read-ifds
|
||||
process-ifds
|
||||
] with-tiff-endianness
|
||||
] with-file-reader ;
|
||||
|
||||
: process-tif-ifds ( parsed-tiff -- parsed-tiff )
|
||||
dup ifds>> [
|
||||
process-ifd read-strips
|
||||
read-strips
|
||||
uncompress-strips
|
||||
strips>bitmap
|
||||
fix-bitmap-endianness
|
||||
strips-predictor
|
||||
dup extra-samples tag? [ handle-alpha-data ] when
|
||||
drop
|
||||
] each
|
||||
] with-endianness
|
||||
] with-file-reader ;
|
||||
] 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 )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Yun, Jonghyouk
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Korean text encodings
|
||||
|
|
@ -0,0 +1 @@
|
|||
text
|
||||
|
|
@ -102,3 +102,7 @@ PRIVATE>
|
|||
|
||||
: signed-be> ( bytes -- x )
|
||||
<reversed> signed-le> ;
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -57,6 +57,13 @@ HELP: with-system-random
|
|||
|
||||
{ with-random with-secure-random with-system-random } related-words
|
||||
|
||||
HELP: randomize
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Randomizes a sequence in-place with the Fisher-Yates algorithm and returns the sequence." } ;
|
||||
|
||||
HELP: delete-random
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
|
|
@ -83,6 +90,8 @@ $nl
|
|||
{ $subsection with-secure-random }
|
||||
"Implementation:"
|
||||
{ $subsection "random-protocol" }
|
||||
"Randomizing a sequence:"
|
||||
{ $subsection randomize }
|
||||
"Deleting a random element from a sequence:"
|
||||
{ $subsection delete-random } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: random sequences tools.test kernel math math.functions
|
||||
sets ;
|
||||
sets grouping random.private ;
|
||||
IN: random.tests
|
||||
|
||||
[ 4 ] [ 4 random-bytes length ] unit-test
|
||||
|
|
@ -17,3 +17,9 @@ IN: random.tests
|
|||
[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
|
||||
|
||||
[ f ] [ 0 random ] unit-test
|
||||
|
||||
[ { } ] [ { } randomize ] unit-test
|
||||
[ { 1 } ] [ { 1 } randomize ] unit-test
|
||||
|
||||
[ f ]
|
||||
[ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
|
||||
|
|
|
|||
|
|
@ -52,8 +52,10 @@ PRIVATE>
|
|||
[ length random-integer ] keep nth
|
||||
] if-empty ;
|
||||
|
||||
: randomize ( seq -- seq' )
|
||||
dup length 1 (a,b] [ dup random pick exchange ] each ;
|
||||
: randomize ( seq -- seq )
|
||||
dup length [ dup 1 > ]
|
||||
[ [ random ] [ 1- ] bi [ pick exchange ] keep ]
|
||||
[ ] while drop ;
|
||||
|
||||
: delete-random ( seq -- elt )
|
||||
[ length random-integer ] keep [ nth ] 2keep delete-nth ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,40 @@
|
|||
! Copyright (C) 2009 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators hashtables http
|
||||
http.client json.reader kernel macros namespaces sequences
|
||||
urls.secure urls.encoding ;
|
||||
urls.secure fry ;
|
||||
IN: twitter
|
||||
|
||||
! Configuration
|
||||
SYMBOLS: twitter-username twitter-password twitter-source ;
|
||||
|
||||
twitter-source [ "factor" ] initialize
|
||||
|
||||
: set-twitter-credentials ( username password -- )
|
||||
[ twitter-username set ] [ twitter-password set ] bi* ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! Utilities
|
||||
MACRO: keys-boa ( keys class -- )
|
||||
[ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
|
||||
|
||||
! Twitter requests
|
||||
|
||||
: twitter-url ( string -- url )
|
||||
"https://twitter.com/statuses/" ".json" surround ;
|
||||
|
||||
: set-request-twitter-auth ( request -- request )
|
||||
twitter-username get twitter-password get set-basic-auth ;
|
||||
|
||||
: twitter-request ( request -- data )
|
||||
set-request-twitter-auth
|
||||
http-request nip ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! Data types
|
||||
|
||||
TUPLE: twitter-status
|
||||
created-at
|
||||
id
|
||||
|
|
@ -28,8 +56,7 @@ TUPLE: twitter-user
|
|||
protected?
|
||||
followers-count ;
|
||||
|
||||
MACRO: keys-boa ( keys class -- )
|
||||
[ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ;
|
||||
<PRIVATE
|
||||
|
||||
: <twitter-user> ( assoc -- user )
|
||||
{
|
||||
|
|
@ -64,37 +91,42 @@ MACRO: keys-boa ( keys class -- )
|
|||
: json>twitter-status ( json-object -- tweet )
|
||||
json> <twitter-status> ;
|
||||
|
||||
: set-twitter-credentials ( username password -- )
|
||||
[ twitter-username set ] [ twitter-password set ] bi* ;
|
||||
PRIVATE>
|
||||
|
||||
: set-request-twitter-auth ( request -- request )
|
||||
twitter-username twitter-password [ get ] bi@ set-basic-auth ;
|
||||
! Updates
|
||||
<PRIVATE
|
||||
|
||||
: update-post-data ( update -- assoc )
|
||||
"status" associate
|
||||
[ twitter-source get "source" ] dip [ set-at ] keep ;
|
||||
[
|
||||
"status" set
|
||||
twitter-source get "source" set
|
||||
] H{ } make-assoc ;
|
||||
|
||||
: (tweet) ( string -- json )
|
||||
update-post-data "https://twitter.com/statuses/update.json" <post-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip ;
|
||||
update-post-data "update" twitter-url
|
||||
<post-request> twitter-request ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: tweet* ( string -- tweet )
|
||||
(tweet) json>twitter-status ;
|
||||
|
||||
: tweet ( string -- ) (tweet) drop ;
|
||||
|
||||
! Timelines
|
||||
<PRIVATE
|
||||
|
||||
: timeline ( url -- tweets )
|
||||
twitter-url <get-request>
|
||||
twitter-request json>twitter-statuses ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: public-timeline ( -- tweets )
|
||||
"https://twitter.com/statuses/public_timeline.json" <get-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip json>twitter-statuses ;
|
||||
"public_timeline" timeline ;
|
||||
|
||||
: friends-timeline ( -- tweets )
|
||||
"https://twitter.com/statuses/friends_timeline.json" <get-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip json>twitter-statuses ;
|
||||
"friends_timeline" timeline ;
|
||||
|
||||
: user-timeline ( username -- tweets )
|
||||
"https://twitter.com/statuses/user_timeline/" ".json" surround <get-request>
|
||||
set-request-twitter-auth
|
||||
http-request nip json>twitter-statuses ;
|
||||
"user_timeline/" prepend timeline ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue