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

db4
Sam Anklesaria 2009-05-28 18:56:12 -05:00
commit 5f60825d6b
17 changed files with 211 additions and 73 deletions

View File

@ -6,43 +6,43 @@ IN: checksums.hmac.tests
[
"\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
] [
16 11 <string> "Hi There" md5 hmac-bytes >string ] unit-test
"Hi There" 16 11 <string> md5 hmac-bytes >string ] unit-test
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
[ "Jefe" "what do ya want for nothing?" md5 hmac-bytes >string ] unit-test
[ "what do ya want for nothing?" "Jefe" md5 hmac-bytes >string ] unit-test
[
"V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6"
]
[
16 HEX: aa <string>
50 HEX: dd <repetition> md5 hmac-bytes >string
50 HEX: dd <repetition>
16 HEX: aa <string> md5 hmac-bytes >string
] unit-test
[
"g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
] [
16 11 <string> "Hi There" sha1 hmac-bytes >string
"Hi There" 16 11 <string> sha1 hmac-bytes >string
] unit-test
[
"\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y"
] [
"Jefe" "what do ya want for nothing?" sha1 hmac-bytes >string
"what do ya want for nothing?" "Jefe" sha1 hmac-bytes >string
] unit-test
[
"\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb"
] [
16 HEX: aa <string>
50 HEX: dd <repetition> sha1 hmac-bytes >string
50 HEX: dd <repetition>
16 HEX: aa <string> sha1 hmac-bytes >string
] unit-test
[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
[ 20 HEX: b <string> "Hi There" sha-256 hmac-bytes hex-string ] unit-test
[ "Hi There" 20 HEX: b <string> sha-256 hmac-bytes hex-string ] unit-test
[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ]
[
"JefeJefeJefeJefeJefeJefeJefeJefe"
"what do ya want for nothing?" sha-256 hmac-bytes hex-string
"what do ya want for nothing?"
"JefeJefeJefeJefeJefeJefeJefeJefe" sha-256 hmac-bytes hex-string
] unit-test

View File

@ -13,27 +13,26 @@ IN: checksums.hmac
: ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
:: init-K ( K checksum checksum-state -- o i )
checksum-state block-size>> K length <
[ K checksum checksum-bytes ] [ K ] if
:: init-key ( checksum key checksum-state -- o i )
checksum-state block-size>> key length <
[ key checksum checksum-bytes ] [ key ] if
checksum-state block-size>> 0 pad-tail
[ checksum-state opad seq-bitxor ]
[ checksum-state ipad seq-bitxor ] bi ;
PRIVATE>
:: hmac-stream ( K stream checksum -- value )
K checksum dup initialize-checksum-state
dup :> checksum-state
init-K :> Ki :> Ko
:: hmac-stream ( stream key checksum -- value )
checksum initialize-checksum-state :> checksum-state
checksum key checksum-state init-key :> Ki :> Ko
checksum-state Ki add-checksum-bytes
stream add-checksum-stream get-checksum
checksum initialize-checksum-state
Ko add-checksum-bytes swap add-checksum-bytes
get-checksum ;
: hmac-file ( K path checksum -- value )
[ binary <file-reader> ] dip hmac-stream ;
: hmac-file ( path key checksum -- value )
[ binary <file-reader> ] 2dip hmac-stream ;
: hmac-bytes ( K seq checksum -- value )
[ binary <byte-reader> ] dip hmac-stream ;
: hmac-bytes ( seq key checksum -- value )
[ binary <byte-reader> ] 2dip hmac-stream ;

View File

@ -39,11 +39,6 @@ HELP: breakpoint-if
{ $values { "quot" { $quotation "( -- ? )" } } { "word" word } }
{ $description "Annotates a word definition to enter the single stepper if the quotation yields true." } ;
HELP: annotate-methods
{ $values
{ "word" word } { "quot" quotation } }
{ $description "Annotates the word -- for generic words, all its methods -- with the quotation." } ;
HELP: reset
{ $values
{ "word" word } }

View File

@ -39,6 +39,9 @@ M: object another-generic ;
[ "" ] [ [ 3 another-generic drop ] with-string-writer ] unit-test
! reset should do the right thing for generic words
[ ] [ \ another-generic watch ] unit-test
GENERIC: blah-generic ( a -- b )
M: string blah-generic ;

View File

@ -9,8 +9,7 @@ IN: tools.annotations
GENERIC: reset ( word -- )
M: generic reset
[ call-next-method ]
[ subwords [ reset ] each ] bi ;
subwords [ reset ] each ;
M: word reset
dup "unannotated-def" word-prop [
@ -22,6 +21,8 @@ M: word reset
ERROR: cannot-annotate-twice word ;
M: cannot-annotate-twice summary drop "Cannot annotate a word twice" ;
<PRIVATE
: check-annotate-twice ( word -- word )
@ -29,17 +30,19 @@ ERROR: cannot-annotate-twice word ;
cannot-annotate-twice
] when ;
: save-unannotated-def ( word -- )
dup def>> "unannotated-def" set-word-prop ;
: (annotate) ( word quot -- )
[ dup def>> ] dip call( old -- new ) define ;
PRIVATE>
: annotate ( word quot -- )
GENERIC# annotate 1 ( word quot -- )
M: generic annotate
[ "methods" word-prop values ] dip '[ _ annotate ] each ;
M: word annotate
[ check-annotate-twice ] dip
[ over save-unannotated-def (annotate) ] with-compilation-unit ;
[
[ dup def>> 2dup "unannotated-def" set-word-prop ] dip
call( old -- new ) define
] with-compilation-unit ;
<PRIVATE
@ -77,19 +80,11 @@ PRIVATE>
: watch-vars ( word vars -- )
dupd '[ [ _ _ ] dip (watch-vars) ] annotate ;
GENERIC# annotate-methods 1 ( word quot -- )
M: generic annotate-methods
[ "methods" word-prop values ] dip [ annotate ] curry each ;
M: word annotate-methods
annotate ;
: breakpoint ( word -- )
[ add-breakpoint ] annotate-methods ;
[ add-breakpoint ] annotate ;
: breakpoint-if ( word quot -- )
'[ [ _ [ [ break ] when ] ] dip 3append ] annotate-methods ;
'[ [ _ [ [ break ] when ] ] dip 3append ] annotate ;
SYMBOL: word-timing

View File

@ -26,7 +26,7 @@ HELP: with-disposal
HELP: with-destructors
{ $values { "quot" "a quotation" } }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors, on any object, by wrapping the object in a destructor and implementing " { $link dispose } " on that object type. After the quotation finishes, if an error was thrown, all destructors are called and the error is then rethrown. However, if the quotation was successful, only those destructors created with an 'always cleanup' flag will be destroyed." }
{ $description "Calls a quotation within a new dynamic scope. This quotation may register destructors using " { $link &dispose } " or " { $link |dispose } ". The former registers a destructor that will always run whether or not the quotation threw an error, and the latter registers a destructor that only runs if the quotation throws an error only. Destructors are run in reverse order from the order in which they were registered." }
{ $notes
"Destructors generalize " { $link with-disposal } ". The following two lines are equivalent, except that the second line establishes a new dynamic scope:"
{ $code

View File

@ -59,7 +59,7 @@ M: utf16be decode-char
] [ append-nums ] if ;
: begin-utf16le ( stream byte -- stream char )
over stream-read1 [ double-le ] [ drop replacement-char ] if* ;
over stream-read1 dup [ double-le ] [ 2drop replacement-char ] if ;
M: utf16le decode-char
drop dup stream-read1 dup [ begin-utf16le ] when nip ;
@ -68,36 +68,34 @@ M: utf16le decode-char
: encode-first ( char -- byte1 byte2 )
-10 shift
dup -8 shift BIN: 11011000 bitor
swap HEX: FF bitand ;
[ -8 shift BIN: 11011000 bitor ] [ HEX: FF bitand ] bi ;
: encode-second ( char -- byte3 byte4 )
BIN: 1111111111 bitand
dup -8 shift BIN: 11011100 bitor
swap BIN: 11111111 bitand ;
[ -8 shift BIN: 11011100 bitor ] [ BIN: 11111111 bitand ] bi ;
: stream-write2 ( stream char1 char2 -- )
rot [ stream-write1 ] curry bi@ ;
: stream-write2 ( char1 char2 stream -- )
[ stream-write1 ] curry bi@ ;
: char>utf16be ( stream char -- )
dup HEX: FFFF > [
HEX: 10000 -
2dup encode-first stream-write2
encode-second stream-write2
] [ h>b/b swap stream-write2 ] if ;
: char>utf16be ( char stream -- )
over HEX: FFFF > [
[ HEX: 10000 - ] dip
[ [ encode-first ] dip stream-write2 ]
[ [ encode-second ] dip stream-write2 ] 2bi
] [ [ h>b/b swap ] dip stream-write2 ] if ;
M: utf16be encode-char ( char stream encoding -- )
drop swap char>utf16be ;
drop char>utf16be ;
: char>utf16le ( char stream -- )
dup HEX: FFFF > [
HEX: 10000 -
2dup encode-first swap stream-write2
encode-second swap stream-write2
] [ h>b/b stream-write2 ] if ;
: char>utf16le ( stream char -- )
over HEX: FFFF > [
[ HEX: 10000 - ] dip
[ [ encode-first swap ] dip stream-write2 ]
[ [ encode-second swap ] dip stream-write2 ] 2bi
] [ [ h>b/b ] dip stream-write2 ] if ;
M: utf16le encode-char ( char stream encoding -- )
drop swap char>utf16le ;
drop char>utf16le ;
! UTF-16

View File

@ -28,7 +28,7 @@ PRIVATE>
: make-descriptive ( word -- )
dup [ ] [ def>> ] [ stack-effect ] tri [descriptive]
'[ drop _ ] annotate-methods ;
'[ drop _ ] annotate ;
: define-descriptive ( word def effect -- )
[ drop "descriptive-definition" set-word-prop ]

View File

@ -0,0 +1,2 @@
Kobi Lurie
Doug Coleman

View File

@ -0,0 +1,77 @@
! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors fry images.loader images.normalization
images.processing.rotation kernel literals math sequences
tools.test images.processing.rotation.private ;
IN: images.processing.rotation.tests
: first-row ( seq^2 -- seq ) first ;
: first-col ( seq^2 -- item ) harvest [ first ] map ;
: last-row ( seq^2 -- item ) last ;
: last-col ( seq^2 -- item ) harvest [ last ] map ;
: end-of-first-row ( seq^2 -- item ) first-row last ;
: first-of-first-row ( seq^2 -- item ) first-row first ;
: end-of-last-row ( seq^2 -- item ) last-row last ;
: first-of-last-row ( seq^2 -- item ) last-row first ;
<<
: clone-image ( image -- new-image )
clone [ clone ] change-bitmap ;
>>
CONSTANT: pasted-image
$[
"vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
load-image normalize-image clone-image
]
CONSTANT: pasted-image90
$[
"vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
load-image normalize-image clone-image
]
CONSTANT: lake-image
$[
"vocab:images/processing/rotation/test-bitmaps/lake.bmp"
load-image preprocess
]
[ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test
[ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test
[ t ] [ pasted-image dup clone-image 270 rotate 90 rotate = ] unit-test
[ t ] [
pasted-image dup clone-image dup { 90 180 90 } [ rotate drop ] with each =
] unit-test
[ t ] [
pasted-image 90 rotate
pasted-image90 =
] unit-test
[ t ] [
"vocab:images/processing/rotation/test-bitmaps/small.bmp"
load-image 90 rotate
"vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
load-image normalize-image =
] unit-test
[ t ] [
lake-image
[ first-of-first-row ]
[ 90 (rotate) end-of-first-row ] bi =
] unit-test
[ t ]
[ lake-image [ first-row ] [ 90 (rotate) last-col ] bi = ] unit-test
[ t ]
[ lake-image [ last-col ] [ 90 (rotate) last-row reverse ] bi = ] unit-test
[ t ]
[ lake-image [ last-row ] [ 90 (rotate) first-col ] bi = ] unit-test
[ t ]
[ lake-image [ first-col ] [ 90 (rotate) first-row reverse ] bi = ] unit-test

View File

@ -0,0 +1,71 @@
! Copyright (C) 2009 Kobi Lurie.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays colors combinators
combinators.short-circuit fry grouping images images.bitmap
images.loader images.normalization kernel locals math sequences ;
IN: images.processing.rotation
ERROR: unsupported-rotation degrees ;
<PRIVATE
: rotate-90 ( seq^3 -- seq^3 ) flip [ reverse ] map ;
: rotate-180 ( seq^3 -- seq^3 ) reverse [ reverse ] map ;
: rotate-270 ( seq^3 -- seq^3 ) flip reverse ;
: (rotate) ( seq n -- seq' )
{
{ 0 [ ] }
{ 90 [ rotate-90 ] }
{ 180 [ rotate-180 ] }
{ 270 [ rotate-270 ] }
[ unsupported-rotation ]
} case ;
: rows-remove-pad ( byte-rows -- pixels' )
[ dup length 4 mod head* ] map ;
: row-length ( image -- n )
[ bitmap>> length ] [ dim>> second ] bi /i ;
: image>byte-rows ( image -- byte-rows )
[ bitmap>> ] [ row-length ] bi group rows-remove-pad ;
: (seperate-to-pixels) ( byte-rows image -- pixel-rows )
component-order>> bytes-per-pixel '[ _ group ] map ;
: image>pixel-rows ( image -- pixel-rows )
[ image>byte-rows ] keep (seperate-to-pixels) ;
: flatten-table ( seq^3 -- seq )
[ concat ] map concat ;
: preprocess ( image -- pixelrows )
normalize-image image>pixel-rows ;
: ?reverse-dimensions ( image n -- )
{ 270 90 } member? [ [ reverse ] change-dim ] when drop ;
: normalize-degree ( n -- n' ) 360 rem ;
: processing-effect ( image quot -- image' )
'[ preprocess @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline
:: rotate' ( image n -- image )
n normalize-degree :> n'
image preprocess :> pixel-table
image n' ?reverse-dimensions
pixel-table n' (rotate) :> table-rotated
image table-rotated flatten-table >>bitmap ;
PRIVATE>
: rotate ( image n -- image' )
normalize-degree
[ '[ _ (rotate) ] processing-effect ] [ ?reverse-dimensions ] 2bi ;
: reflect-y-axis ( image -- image )
[ [ reverse ] map ] processing-effect ;
: reflect-x-axis ( image -- image )
[ reverse ] processing-effect ;

Binary file not shown.

After

Width:  |  Height:  |  Size: 43 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 43 KiB

Binary file not shown.

After

Width:  |  Height:  |  Size: 485 B

Binary file not shown.

After

Width:  |  Height:  |  Size: 454 B

Binary file not shown.

After

Width:  |  Height:  |  Size: 470 B

View File

@ -166,9 +166,7 @@ posting "POSTINGS"
[
f <blog>
[ deposit-blog-slots ]
[ "id" value >>id ]
[ update-tuple ]
tri
[ "id" value >>id update-tuple ] bi
<url>
"$planet/admin" >>path