steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' into regexp

db4
Daniel Ehrenberg 2009-02-15 20:42:45 -06:00
parent 41312ae2e5 523e0d993d
commit 00c5395d31
17 changed files with 17780 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/cfg/builder/builder.factor
View File

@ -55,7 +55,7 @@ GENERIC: emit-node ( node -- next )
: begin-word ( -- ) : begin-word ( -- )
#! We store the basic block after the prologue as a loop #! 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. #! calls can skip an epilogue/prologue.
##prologue ##prologue
##branch ##branch

5
basis/endian/endian.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types namespaces io.binary fry USING: alien.c-types namespaces io.binary fry
kernel math grouping sequences ; kernel math grouping sequences math.bitwise ;
IN: endian IN: endian
SINGLETONS: big-endian little-endian ; SINGLETONS: big-endian little-endian ;
@ -9,9 +9,6 @@ SINGLETONS: big-endian little-endian ;
: compute-native-endianness ( -- class ) : compute-native-endianness ( -- class )
1 <int> *char 0 = big-endian little-endian ? ; 1 <int> *char 0 = big-endian little-endian ? ;
: >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
SYMBOL: native-endianness SYMBOL: native-endianness
native-endianness [ compute-native-endianness ] initialize native-endianness [ compute-native-endianness ] initialize

4
basis/farkup/farkup.factor
View File

@ -85,10 +85,10 @@ image-link = "[[image:" link-content "|" link-content "]]"
simple-link = "[[" link-content "]]" simple-link = "[[" link-content "]]"
=> [[ second >string dup simple-link-title link boa ]] => [[ 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 ]] => [[ [ second >string ] [ fourth >string ] bi link boa ]]
link = image-link | labelled-link | simple-link link = image-link | labeled-link | simple-link
escaped-char = "\" . escaped-char = "\" .
=> [[ second 1string ]] => [[ second 1string ]]

28
basis/images/images.factor
View File

@ -2,11 +2,12 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors grouping sequences combinators USING: kernel accessors grouping sequences combinators
math specialized-arrays.direct.uint byte-arrays 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 IN: images
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 ; R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
TUPLE: image dim component-order bitmap ; TUPLE: image dim component-order bitmap ;
@ -18,34 +19,37 @@ GENERIC: load-image* ( path tuple -- image )
3 <sliced-groups> 3 <sliced-groups>
[ 255 suffix ] map concat ; [ 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 ) : normalize-component-order ( image -- image )
dup component-order>> dup component-order>>
{ {
{ RGBA [ ] } { RGBA [ ] }
{ R32G32B32A32 [
[ normalize-floats ] change-bitmap
] }
{ R32G32B32 [ { R32G32B32 [
[ [ normalize-floats add-dummy-alpha ] change-bitmap
dup length 4 / <direct-uint-array> ] }
[ bits>float 255.0 * >integer ] map { R16G16B16A16 [
>byte-array add-dummy-alpha [ byte-array>ushort-array [ -8 shift ] B{ } map-as ] change-bitmap
] change-bitmap
] } ] }
{ R16G16B16 [ { R16G16B16 [
[ [
dup length 2 / <direct-ushort-array> byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha
[ -8 shift ] map
>byte-array add-dummy-alpha
] change-bitmap ] change-bitmap
] } ] }
{ BGRA [ { BGRA [
[ [
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each 4 <sliced-groups> dup [ 3 head-slice reverse-here ] each
] change-bitmap ] change-bitmap
] } ] }
{ RGB [ [ add-dummy-alpha ] change-bitmap ] } { RGB [ [ add-dummy-alpha ] change-bitmap ] }
{ BGR [ { BGR [
[ [
3 <sliced-groups> 3 <sliced-groups>
[ [ [ 0 3 ] dip <slice> reverse-here ] each ] [ [ 3 head-slice reverse-here ] each ]
[ add-dummy-alpha ] bi [ add-dummy-alpha ] bi
] change-bitmap ] change-bitmap
] } ] }

247
basis/images/tiff/tiff.factor
View File

@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences math.bitwise math.order math.parser pack prettyprint sequences
strings ; strings math.vectors specialized-arrays.float ;
IN: images.tiff IN: images.tiff
TUPLE: tiff-image < image ; TUPLE: tiff-image < image ;
@ -24,7 +24,16 @@ SINGLETONS: photometric-interpretation
photometric-interpretation-white-is-zero photometric-interpretation-white-is-zero
photometric-interpretation-black-is-zero photometric-interpretation-black-is-zero
photometric-interpretation-rgb 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 ; ERROR: bad-photometric-interpretation n ;
: lookup-photometric-interpretation ( n -- singleton ) : lookup-photometric-interpretation ( n -- singleton )
{ {
@ -32,21 +41,73 @@ ERROR: bad-photometric-interpretation n ;
{ 1 [ photometric-interpretation-black-is-zero ] } { 1 [ photometric-interpretation-black-is-zero ] }
{ 2 [ photometric-interpretation-rgb ] } { 2 [ photometric-interpretation-rgb ] }
{ 3 [ photometric-interpretation-palette-color ] } { 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 ] [ bad-photometric-interpretation ]
} case ; } case ;
SINGLETONS: compression SINGLETONS: compression
compression-none compression-none
compression-CCITT-2 compression-CCITT-2
compression-CCITT-3
compression-CCITT-4
compression-lzw 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 ; ERROR: bad-compression n ;
: lookup-compression ( n -- compression ) : lookup-compression ( n -- compression )
{ {
{ 1 [ compression-none ] } { 1 [ compression-none ] }
{ 2 [ compression-CCITT-2 ] } { 2 [ compression-CCITT-2 ] }
{ 3 [ compression-CCITT-3 ] }
{ 4 [ compression-CCITT-4 ] }
{ 5 [ compression-lzw ] } { 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 ] } { 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 ] [ bad-compression ]
} case ; } case ;
@ -86,6 +147,7 @@ ERROR: bad-planar-configuration n ;
} case ; } case ;
SINGLETONS: sample-format SINGLETONS: sample-format
sample-format-none
sample-format-unsigned-integer sample-format-unsigned-integer
sample-format-signed-integer sample-format-signed-integer
sample-format-ieee-float sample-format-ieee-float
@ -94,6 +156,7 @@ ERROR: bad-sample-format n ;
: lookup-sample-format ( sequence -- object ) : lookup-sample-format ( sequence -- object )
[ [
{ {
{ 0 [ sample-format-none ] }
{ 1 [ sample-format-unsigned-integer ] } { 1 [ sample-format-unsigned-integer ] }
{ 2 [ sample-format-signed-integer ] } { 2 [ sample-format-signed-integer ] }
{ 3 [ sample-format-ieee-float ] } { 3 [ sample-format-ieee-float ] }
@ -117,9 +180,36 @@ ERROR: bad-extra-samples n ;
SINGLETONS: image-length image-width x-resolution y-resolution SINGLETONS: image-length image-width x-resolution y-resolution
rows-per-strip strip-offsets strip-byte-counts bits-per-sample rows-per-strip strip-offsets strip-byte-counts bits-per-sample
samples-per-pixel new-subfile-type orientation software samples-per-pixel new-subfile-type subfile-type orientation
date-time photoshop exif-ifd sub-ifd inter-color-profile software date-time photoshop exif-ifd sub-ifd inter-color-profile
xmp iptc unhandled-ifd-entry ; 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 ; ERROR: bad-tiff-magic bytes ;
: tiff-endianness ( byte-array -- ? ) : tiff-endianness ( byte-array -- ? )
@ -144,12 +234,12 @@ ERROR: bad-tiff-magic bytes ;
4 read endian> 4 read endian>
4 read endian> <ifd-entry> ; 4 read endian> <ifd-entry> ;
: read-ifds ( tiff -- tiff ) : read-ifds ( tiff offset -- tiff )
dup ifd-offset>> seek-absolute seek-input seek-absolute seek-input
2 read endian> 2 read endian>
dup [ read-ifd ] replicate dup [ read-ifd ] replicate
4 read endian> 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 ; ERROR: no-tag class ;
@ -159,6 +249,9 @@ ERROR: no-tag class ;
: find-tag ( idf class -- tag ) : find-tag ( idf class -- tag )
swap processed-tags>> ?at [ no-tag ] unless ; swap processed-tags>> ?at [ no-tag ] unless ;
: tag? ( idf class -- tag )
swap processed-tags>> key? ;
: read-strips ( ifd -- ifd ) : read-strips ( ifd -- ifd )
dup dup
[ strip-byte-counts find-tag ] [ strip-byte-counts find-tag ]
@ -237,37 +330,92 @@ ERROR: bad-small-ifd-type n ;
: process-ifd-entry ( ifd-entry -- value class ) : process-ifd-entry ( ifd-entry -- value class )
[ ifd-entry-value ] [ tag>> ] bi { [ ifd-entry-value ] [ tag>> ] bi {
{ 254 [ new-subfile-type ] } { 254 [ new-subfile-type ] }
{ 255 [ subfile-type ] }
{ 256 [ image-width ] } { 256 [ image-width ] }
{ 257 [ image-length ] } { 257 [ image-length ] }
{ 258 [ bits-per-sample ] } { 258 [ bits-per-sample ] }
{ 259 [ lookup-compression compression ] } { 259 [ lookup-compression compression ] }
{ 262 [ lookup-photometric-interpretation photometric-interpretation ] } { 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 ] } { 273 [ strip-offsets ] }
{ 274 [ orientation ] } { 274 [ orientation ] }
{ 277 [ samples-per-pixel ] } { 277 [ samples-per-pixel ] }
{ 278 [ rows-per-strip ] } { 278 [ rows-per-strip ] }
{ 279 [ strip-byte-counts ] } { 279 [ strip-byte-counts ] }
{ 280 [ min-sample-value ] }
{ 281 [ max-sample-value ] }
{ 282 [ first x-resolution ] } { 282 [ first x-resolution ] }
{ 283 [ first y-resolution ] } { 283 [ first y-resolution ] }
{ 284 [ planar-configuration ] } { 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 ] } { 296 [ lookup-resolution-unit resolution-unit ] }
{ 297 [ page-number ] }
{ 305 [ ascii decode software ] } { 305 [ ascii decode software ] }
{ 306 [ ascii decode date-time ] } { 306 [ ascii decode date-time ] }
{ 315 [ ascii decode artist ] }
{ 316 [ ascii decode host-computer ] }
{ 317 [ lookup-predictor predictor ] } { 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 ] } { 330 [ sub-ifd ] }
{ 338 [ lookup-extra-samples extra-samples ] } { 338 [ lookup-extra-samples extra-samples ] }
{ 339 [ lookup-sample-format sample-format ] } { 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 ] } { 700 [ utf8 decode xmp ] }
{ 32995 [ matteing ] }
{ 32996 [ data-type ] }
{ 32997 [ image-depth ] }
{ 32998 [ tile-depth ] }
{ 33432 [ copyright ] }
{ 33723 [ iptc ] }
{ 34377 [ photoshop ] } { 34377 [ photoshop ] }
{ 34665 [ exif-ifd ] } { 34665 [ exif-ifd ] }
{ 33723 [ iptc ] }
{ 34675 [ inter-color-profile ] } { 34675 [ inter-color-profile ] }
{ 37439 [ sto-nits ] }
{ 42112 [ gdal-metadata ] }
{ 50341 [ print-image-matching-info ] }
[ nip unhandled-ifd-entry swap ] [ nip unhandled-ifd-entry swap ]
} case ; } case ;
: process-ifd ( ifd -- ifd ) : process-ifds ( parsed-tiff -- parsed-tiff )
[
[
dup ifd-entries>> 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 ; ERROR: unhandled-compression compression ;
@ -286,6 +434,27 @@ ERROR: unhandled-compression compression ;
: strips>bitmap ( ifd -- ifd ) : strips>bitmap ( ifd -- ifd )
dup strips>> concat >>bitmap ; 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 ; ERROR: unknown-component-order ifd ;
: fix-bitmap-endianness ( ifd -- ifd ) : fix-bitmap-endianness ( ifd -- ifd )
@ -302,13 +471,38 @@ ERROR: unknown-component-order ifd ;
: ifd-component-order ( ifd -- byte-order ) : ifd-component-order ( ifd -- byte-order )
bits-per-sample find-tag { bits-per-sample find-tag {
{ { 32 32 32 32 } [ R32G32B32A32 ] }
{ { 32 32 32 } [ R32G32B32 ] } { { 32 32 32 } [ R32G32B32 ] }
{ { 16 16 16 16 } [ R16G16B16A16 ] }
{ { 16 16 16 } [ R16G16B16 ] } { { 16 16 16 } [ R16G16B16 ] }
{ { 8 8 8 8 } [ RGBA ] } { { 8 8 8 8 } [ RGBA ] }
{ { 8 8 8 } [ RGB ] } { { 8 8 8 } [ RGB ] }
[ unknown-component-order ] [ unknown-component-order ]
} case ; } 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 ) : ifd>image ( ifd -- image )
{ {
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
@ -319,20 +513,35 @@ ERROR: unknown-component-order ifd ;
: tiff>image ( image -- image ) : tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ; 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 [ binary [
<parsed-tiff> <parsed-tiff>
read-header dup endianness>> [ read-header [
read-ifds dup ifd-offset>> read-ifds
process-ifds
] with-tiff-endianness
] with-file-reader ;
: process-tif-ifds ( parsed-tiff -- parsed-tiff )
dup ifds>> [ dup ifds>> [
process-ifd read-strips read-strips
uncompress-strips uncompress-strips
strips>bitmap strips>bitmap
fix-bitmap-endianness fix-bitmap-endianness
strips-predictor
dup extra-samples tag? [ handle-alpha-data ] when
drop drop
] each ] each ;
] with-endianness
] with-file-reader ; : 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 ! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image ) M: tiff-image load-image* ( path tiff-image -- image )

1
basis/io/encodings/korean/authors.txt Normal file
View File

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

17322
basis/io/encodings/korean/data/cp949.txt Normal file
View File

File diff suppressed because it is too large Load Diff

0
basis/io/encodings/korean/korean-docs.factor Normal file
View File

46
basis/io/encodings/korean/korean-tests.factor Normal file
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

79
basis/io/encodings/korean/korean.factor Normal file
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 ;

1
basis/io/encodings/korean/summary.txt Normal file
View File

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

1
basis/io/encodings/korean/tags.txt Normal file
View File

@ -0,0 +1 @@
text

4
basis/math/bitwise/bitwise.factor
View File

@ -102,3 +102,7 @@ PRIVATE>
: signed-be> ( bytes -- x ) : signed-be> ( bytes -- x )
<reversed> signed-le> ; <reversed> signed-le> ;
: >signed ( x n -- y )
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;

9
basis/random/random-docs.factor
View File

@ -57,6 +57,13 @@ HELP: with-system-random
{ with-random with-secure-random with-system-random } related-words { 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 HELP: delete-random
{ $values { $values
{ "seq" sequence } { "seq" sequence }
@ -83,6 +90,8 @@ $nl
{ $subsection with-secure-random } { $subsection with-secure-random }
"Implementation:" "Implementation:"
{ $subsection "random-protocol" } { $subsection "random-protocol" }
"Randomizing a sequence:"
{ $subsection randomize }
"Deleting a random element from a sequence:" "Deleting a random element from a sequence:"
{ $subsection delete-random } ; { $subsection delete-random } ;

8
basis/random/random-tests.factor
View File

@ -1,5 +1,5 @@
USING: random sequences tools.test kernel math math.functions USING: random sequences tools.test kernel math math.functions
sets ; sets grouping random.private ;
IN: random.tests IN: random.tests
[ 4 ] [ 4 random-bytes length ] unit-test [ 4 ] [ 4 random-bytes length ] unit-test
@ -17,3 +17,9 @@ IN: random.tests
[ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test [ t ] [ 1000 [ 400 random ] replicate prune length 256 > ] unit-test
[ f ] [ 0 random ] 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

6
basis/random/random.factor
View File

@ -52,8 +52,10 @@ PRIVATE>
[ length random-integer ] keep nth [ length random-integer ] keep nth
] if-empty ; ] if-empty ;
: randomize ( seq -- seq' ) : randomize ( seq -- seq )
dup length 1 (a,b] [ dup random pick exchange ] each ; dup length [ dup 1 > ]
[ [ random ] [ 1- ] bi [ pick exchange ] keep ]
[ ] while drop ;
: delete-random ( seq -- elt ) : delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ; [ length random-integer ] keep [ nth ] 2keep delete-nth ;

74
extra/twitter/twitter.factor
View File

@ -1,12 +1,40 @@
! Copyright (C) 2009 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators hashtables http USING: accessors assocs combinators hashtables http
http.client json.reader kernel macros namespaces sequences http.client json.reader kernel macros namespaces sequences
urls.secure urls.encoding ; urls.secure fry ;
IN: twitter IN: twitter
! Configuration
SYMBOLS: twitter-username twitter-password twitter-source ; SYMBOLS: twitter-username twitter-password twitter-source ;
twitter-source [ "factor" ] initialize 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 TUPLE: twitter-status
created-at created-at
id id
@ -28,8 +56,7 @@ TUPLE: twitter-user
protected? protected?
followers-count ; followers-count ;
MACRO: keys-boa ( keys class -- ) <PRIVATE
[ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ;
: <twitter-user> ( assoc -- user ) : <twitter-user> ( assoc -- user )
{ {
@ -64,37 +91,42 @@ MACRO: keys-boa ( keys class -- )
: json>twitter-status ( json-object -- tweet ) : json>twitter-status ( json-object -- tweet )
json> <twitter-status> ; json> <twitter-status> ;
: set-twitter-credentials ( username password -- ) PRIVATE>
[ twitter-username set ] [ twitter-password set ] bi* ;
: set-request-twitter-auth ( request -- request ) ! Updates
twitter-username twitter-password [ get ] bi@ set-basic-auth ; <PRIVATE
: update-post-data ( update -- assoc ) : 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 ) : (tweet) ( string -- json )
update-post-data "https://twitter.com/statuses/update.json" <post-request> update-post-data "update" twitter-url
set-request-twitter-auth <post-request> twitter-request ;
http-request nip ;
PRIVATE>
: tweet* ( string -- tweet ) : tweet* ( string -- tweet )
(tweet) json>twitter-status ; (tweet) json>twitter-status ;
: tweet ( string -- ) (tweet) drop ; : tweet ( string -- ) (tweet) drop ;
! Timelines
<PRIVATE
: timeline ( url -- tweets )
twitter-url <get-request>
twitter-request json>twitter-statuses ;
PRIVATE>
: public-timeline ( -- tweets ) : public-timeline ( -- tweets )
"https://twitter.com/statuses/public_timeline.json" <get-request> "public_timeline" timeline ;
set-request-twitter-auth
http-request nip json>twitter-statuses ;
: friends-timeline ( -- tweets ) : friends-timeline ( -- tweets )
"https://twitter.com/statuses/friends_timeline.json" <get-request> "friends_timeline" timeline ;
set-request-twitter-auth
http-request nip json>twitter-statuses ;
: user-timeline ( username -- tweets ) : user-timeline ( username -- tweets )
"https://twitter.com/statuses/user_timeline/" ".json" surround <get-request> "user_timeline/" prepend timeline ;
set-request-twitter-auth
http-request nip json>twitter-statuses ;