From 052a0931d3cb0773d079effca272cf7c865f9f28 Mon Sep 17 00:00:00 2001
From: "U-C4\\Administrator" <Administrator@k.(none)>
Date: Sun, 10 May 2009 20:42:20 -0500
Subject: [PATCH 01/23] moving md5 state to a tuple, redoing hmac
---
.../checksums}/hmac/authors.txt | 0
.../checksums}/hmac/hmac-tests.factor | 20 ++--
basis/checksums/hmac/hmac.factor | 49 +++++++++
basis/checksums/md5/md5.factor | 102 +++++++++++-------
extra/crypto/hmac/hmac.factor | 55 ----------
5 files changed, 125 insertions(+), 101 deletions(-)
rename {extra/crypto => basis/checksums}/hmac/authors.txt (100%)
rename {extra/crypto => basis/checksums}/hmac/hmac-tests.factor (56%)
create mode 100755 basis/checksums/hmac/hmac.factor
delete mode 100755 extra/crypto/hmac/hmac.factor
diff --git a/extra/crypto/hmac/authors.txt b/basis/checksums/hmac/authors.txt
similarity index 100%
rename from extra/crypto/hmac/authors.txt
rename to basis/checksums/hmac/authors.txt
diff --git a/extra/crypto/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor
similarity index 56%
rename from extra/crypto/hmac/hmac-tests.factor
rename to basis/checksums/hmac/hmac-tests.factor
index 274e99d2f6..9541ca2f26 100755
--- a/extra/crypto/hmac/hmac-tests.factor
+++ b/basis/checksums/hmac/hmac-tests.factor
@@ -1,38 +1,42 @@
USING: kernel io strings byte-arrays sequences namespaces math
-parser crypto.hmac tools.test ;
-IN: crypto.hmac.tests
+parser checksums.hmac tools.test checksums.md5 checksums.sha1
+checksums.sha2 ;
+IN: checksums.hmac.tests
[
"\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d"
] [
- 16 11 <string> "Hi There" sequence>md5-hmac >string ] unit-test
+ 16 11 <string> "Hi There" md5 hmac-bytes >string ] unit-test
[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ]
-[ "Jefe" "what do ya want for nothing?" sequence>md5-hmac >string ] unit-test
+[ "Jefe" "what do ya want for nothing?" 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> sequence>md5-hmac >string
+ 50 HEX: dd <repetition> md5 hmac-bytes >string
] unit-test
[
"g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9"
] [
- 16 11 <string> "Hi There" sequence>sha1-hmac >string
+ 16 11 <string> "Hi There" 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?" sequence>sha1-hmac >string
+ "Jefe" "what do ya want for nothing?" 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> sequence>sha1-hmac >string
+ 50 HEX: dd <repetition> sha1 hmac-bytes >string
] unit-test
+
+[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
+[ HEX: b 20 <string> sha-256 hmac-bytes >string ] unit-test
diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor
new file mode 100755
index 0000000000..7350a02573
--- /dev/null
+++ b/basis/checksums/hmac/hmac.factor
@@ -0,0 +1,49 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays checksums checksums.md5 checksums.md5.private
+checksums.sha1 combinators fry io io.binary io.encodings.binary
+io.files io.streams.byte-array kernel math math.vectors memoize
+sequences ;
+IN: checksums.hmac
+
+<PRIVATE
+
+: sha1-hmac ( Ko Ki stream -- hmac )
+ initialize-sha1 process-sha1-block
+ stream>sha1 get-sha1
+ initialize-sha1
+ [ process-sha1-block ]
+ [ process-sha1-block ] bi* get-sha1 ;
+
+: md5-hmac ( Ko Ki stream -- hmac )
+ initialize-md5 process-md5-block
+ stream>md5 get-md5
+ initialize-md5
+ [ process-md5-block ]
+ [ process-md5-block ] bi* get-md5 ;
+
+: seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ;
+
+MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
+
+MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
+
+: init-K ( K -- o i )
+ 64 0 pad-tail
+ [ opad seq-bitxor ]
+ [ ipad seq-bitxor ] bi ;
+
+PRIVATE>
+
+: hmac ( K stream checksum -- value )
+ ;
+
+:: hmac-stream ( K stream checksum -- value )
+ K init-K :> i :> o
+ stream checksum checksum-stream ;
+
+: hmac-file ( K path checksum -- value )
+ [ binary <file-reader> ] dip hmac-stream ;
+
+: hmac-bytes ( K path checksum -- value )
+ [ binary <byte-reader> ] dip hmac-stream ;
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
index 29620b089d..eda977203a 100644
--- a/basis/checksums/md5/md5.factor
+++ b/basis/checksums/md5/md5.factor
@@ -3,57 +3,53 @@
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences byte-arrays locals sequences.private macros fry
-io.encodings.binary math.bitwise checksums
-checksums.common checksums.stream combinators ;
+io.encodings.binary math.bitwise checksums accessors
+checksums.common checksums.stream combinators combinators.smart ;
IN: checksums.md5
-! See http://www.faqs.org/rfcs/rfc1321.html
+TUPLE: md5-state bytes-read a b c d old-a old-b old-c old-d ;
+
+: <md5-state> ( -- md5-state )
+ md5-state new
+ 0 >>bytes-read
+ HEX: 67452301 [ >>a ] [ >>old-a ] bi
+ HEX: efcdab89 [ >>b ] [ >>old-b ] bi
+ HEX: 98badcfe [ >>c ] [ >>old-c ] bi
+ HEX: 10325476 [ >>d ] [ >>old-d ] bi ;
<PRIVATE
-SYMBOLS: a b c d old-a old-b old-c old-d ;
+: update-md5-state ( md5-state -- md5-state )
+ {
+ [ [ a>> ] [ ] [ old-a>> ] tri [ w+ ] change-a (>>old-a) ]
+ [ [ b>> ] [ ] [ old-b>> ] tri [ w+ ] change-b (>>old-b) ]
+ [ [ c>> ] [ ] [ old-c>> ] tri [ w+ ] change-c (>>old-c) ]
+ [ [ d>> ] [ ] [ old-d>> ] tri [ w+ ] change-d (>>old-d) ]
+ [ ]
+ } cleave ;
+
+: md5-state>bytes ( md5-state -- str )
+ [ { [ a>> ] [ b>> ] [ c>> ] [ d>> ] } cleave ] output>array
+ [ 4 >le ] map B{ } concat-as ;
: T ( N -- Y )
sin abs 32 2^ * >integer ; foldable
-: initialize-md5 ( -- )
- 0 bytes-read set
- HEX: 67452301 dup a set old-a set
- HEX: efcdab89 dup b set old-b set
- HEX: 98badcfe dup c set old-c set
- HEX: 10325476 dup d set old-d set ;
-
-: update-md ( -- )
- old-a a update-old-new
- old-b b update-old-new
- old-c c update-old-new
- old-d d update-old-new ;
-
-:: (ABCD) ( x a b c d k s i func -- )
- #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
- a [
- b get c get d get func call w+
- k x nth-unsafe w+
- i T w+
- s bitroll-32
- b get w+
- ] change ; inline
-
-: F ( X Y Z -- FXYZ )
+:: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
- pick bitnot bitand [ bitand ] [ bitor ] bi* ;
+ X Y bitand X bitnot Z bitand bitor ;
-: G ( X Y Z -- GXYZ )
+:: G ( X Y Z -- GXYZ )
#! G(X,Y,Z) = XZ v Y not(Z)
- dup bitnot rot bitand [ bitand ] [ bitor ] bi* ;
+ X Z bitand Y Z bitnot bitand bitor ;
: H ( X Y Z -- HXYZ )
#! H(X,Y,Z) = X xor Y xor Z
bitxor bitxor ;
-: I ( X Y Z -- IXYZ )
+:: I ( X Y Z -- IXYZ )
#! I(X,Y,Z) = Y xor (X v not(Z))
- rot swap bitnot bitor bitxor ;
+ Z bitnot X bitor Y bitxor ;
CONSTANT: S11 7
CONSTANT: S12 12
@@ -72,6 +68,35 @@ CONSTANT: S42 10
CONSTANT: S43 15
CONSTANT: S44 21
+
+
+
+SYMBOLS: a b c d old-a old-b old-c old-d ;
+
+: initialize-md5 ( -- )
+ 0 bytes-read set
+ HEX: 67452301 dup a set old-a set
+ HEX: efcdab89 dup b set old-b set
+ HEX: 98badcfe dup c set old-c set
+ HEX: 10325476 dup d set old-d set ;
+
+: update-md ( -- )
+ old-a a update-old-new
+ old-b b update-old-new
+ old-c c update-old-new
+ old-d d update-old-new ;
+
+
+:: (ABCD) ( x a b c d k s i func -- )
+ #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
+ a [
+ b get c get d get func call w+
+ k x nth-unsafe w+
+ i T w+
+ s bitroll-32
+ b get w+
+ ] change ; inline
+
MACRO: with-md5-round ( ops func -- )
'[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
@@ -173,9 +198,10 @@ MACRO: with-md5-round ( ops func -- )
[ (process-md5-block) ] each
] if ;
-: stream>md5 ( -- )
- 64 read [ process-md5-block ] keep
- length 64 = [ stream>md5 ] when ;
+: stream>md5 ( stream -- )
+ 64 over stream-read
+ [ process-md5-block ] [ length 64 = ] bi
+ [ stream>md5 ] [ drop ] if ;
: get-md5 ( -- str )
[ a b c d ] [ get 4 >le ] map concat >byte-array ;
@@ -186,5 +212,5 @@ SINGLETON: md5
INSTANCE: md5 stream-checksum
-M: md5 checksum-stream ( stream -- byte-array )
- drop [ initialize-md5 stream>md5 get-md5 ] with-input-stream ;
+M: md5 checksum-stream
+ drop initialize-md5 stream>md5 get-md5 ;
diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor
deleted file mode 100755
index 9a668aa23a..0000000000
--- a/extra/crypto/hmac/hmac.factor
+++ /dev/null
@@ -1,55 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators checksums checksums.md5
-checksums.sha1 checksums.md5.private io io.binary io.files
-io.streams.byte-array kernel math math.vectors memoize sequences
-io.encodings.binary ;
-IN: crypto.hmac
-
-<PRIVATE
-
-: sha1-hmac ( Ko Ki -- hmac )
- initialize-sha1 process-sha1-block
- stream>sha1 get-sha1
- initialize-sha1
- [ process-sha1-block ]
- [ process-sha1-block ] bi* get-sha1 ;
-
-: md5-hmac ( Ko Ki -- hmac )
- initialize-md5 process-md5-block
- stream>md5 get-md5
- initialize-md5
- [ process-md5-block ]
- [ process-md5-block ] bi* get-md5 ;
-
-: seq-bitxor ( seq seq -- seq )
- [ bitxor ] 2map ;
-
-MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
-
-MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
-
-: init-hmac ( K -- o i )
- 64 0 pad-tail
- [ opad seq-bitxor ]
- [ ipad seq-bitxor ] bi ;
-
-PRIVATE>
-
-: stream>sha1-hmac ( K stream -- hmac )
- [ init-hmac sha1-hmac ] with-input-stream ;
-
-: file>sha1-hmac ( K path -- hmac )
- binary <file-reader> stream>sha1-hmac ;
-
-: sequence>sha1-hmac ( K sequence -- hmac )
- binary <byte-reader> stream>sha1-hmac ;
-
-: stream>md5-hmac ( K stream -- hmac )
- [ init-hmac md5-hmac ] with-input-stream ;
-
-: file>md5-hmac ( K path -- hmac )
- binary <file-reader> stream>md5-hmac ;
-
-: sequence>md5-hmac ( K sequence -- hmac )
- binary <byte-reader> stream>md5-hmac ;
From 6dabec9ed8b7f42a688ba9d0ba7b5b5d33fc3729 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 23:06:33 -0500
Subject: [PATCH 02/23] md5 stores state in a tuple now
---
basis/checksums/md5/md5.factor | 132 ++++++++++++++-------------------
1 file changed, 57 insertions(+), 75 deletions(-)
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
index eda977203a..bf43805df2 100644
--- a/basis/checksums/md5/md5.factor
+++ b/basis/checksums/md5/md5.factor
@@ -7,49 +7,40 @@ io.encodings.binary math.bitwise checksums accessors
checksums.common checksums.stream combinators combinators.smart ;
IN: checksums.md5
-TUPLE: md5-state bytes-read a b c d old-a old-b old-c old-d ;
+TUPLE: md5-state bytes-read state old-state ;
: <md5-state> ( -- md5-state )
md5-state new
0 >>bytes-read
- HEX: 67452301 [ >>a ] [ >>old-a ] bi
- HEX: efcdab89 [ >>b ] [ >>old-b ] bi
- HEX: 98badcfe [ >>c ] [ >>old-c ] bi
- HEX: 10325476 [ >>d ] [ >>old-d ] bi ;
+ { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
+ [ clone >>state ] [ clone >>old-state ] bi ;
<PRIVATE
-: update-md5-state ( md5-state -- md5-state )
- {
- [ [ a>> ] [ ] [ old-a>> ] tri [ w+ ] change-a (>>old-a) ]
- [ [ b>> ] [ ] [ old-b>> ] tri [ w+ ] change-b (>>old-b) ]
- [ [ c>> ] [ ] [ old-c>> ] tri [ w+ ] change-c (>>old-c) ]
- [ [ d>> ] [ ] [ old-d>> ] tri [ w+ ] change-d (>>old-d) ]
- [ ]
- } cleave ;
+: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
-: md5-state>bytes ( md5-state -- str )
- [ { [ a>> ] [ b>> ] [ c>> ] [ d>> ] } cleave ] output>array
- [ 4 >le ] map B{ } concat-as ;
+: update-md5-state ( md5-state -- )
+ [ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
+ [ (>>old-state) ] [ (>>state) ] bi ;
: T ( N -- Y )
sin abs 32 2^ * >integer ; foldable
:: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
- X Y bitand X bitnot Z bitand bitor ;
+ X Y bitand X bitnot Z bitand bitor ; inline
:: G ( X Y Z -- GXYZ )
#! G(X,Y,Z) = XZ v Y not(Z)
- X Z bitand Y Z bitnot bitand bitor ;
+ X Z bitand Y Z bitnot bitand bitor ; inline
: H ( X Y Z -- HXYZ )
#! H(X,Y,Z) = X xor Y xor Z
- bitxor bitxor ;
+ bitxor bitxor ; inline
:: I ( X Y Z -- IXYZ )
#! I(X,Y,Z) = Y xor (X v not(Z))
- Z bitnot X bitor Y bitxor ;
+ Z bitnot X bitor Y bitxor ; inline
CONSTANT: S11 7
CONSTANT: S12 12
@@ -68,39 +59,27 @@ CONSTANT: S42 10
CONSTANT: S43 15
CONSTANT: S44 21
+CONSTANT: a 0
+CONSTANT: b 1
+CONSTANT: c 2
+CONSTANT: d 3
-
-
-SYMBOLS: a b c d old-a old-b old-c old-d ;
-
-: initialize-md5 ( -- )
- 0 bytes-read set
- HEX: 67452301 dup a set old-a set
- HEX: efcdab89 dup b set old-b set
- HEX: 98badcfe dup c set old-c set
- HEX: 10325476 dup d set old-d set ;
-
-: update-md ( -- )
- old-a a update-old-new
- old-b b update-old-new
- old-c c update-old-new
- old-d d update-old-new ;
-
-
-:: (ABCD) ( x a b c d k s i func -- )
+:: (ABCD) ( x V a b c d k s i quot -- )
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
- a [
- b get c get d get func call w+
+ a V [
+ b V nth-unsafe
+ c V nth-unsafe
+ d V nth-unsafe quot call w+
k x nth-unsafe w+
i T w+
s bitroll-32
- b get w+
- ] change ; inline
+ b V nth-unsafe w+
+ ] change-nth ; inline
-MACRO: with-md5-round ( ops func -- )
- '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
+MACRO: with-md5-round ( ops quot -- )
+ '[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
-: (process-md5-block-F) ( block -- )
+: (process-md5-block-F) ( block v -- )
{
[ a b c d 0 S11 1 ]
[ d a b c 1 S12 2 ]
@@ -118,9 +97,9 @@ MACRO: with-md5-round ( ops func -- )
[ d a b c 13 S12 14 ]
[ c d a b 14 S13 15 ]
[ b c d a 15 S14 16 ]
- } [ F ] with-md5-round ;
+ } [ F ] with-md5-round ; inline
-: (process-md5-block-G) ( block -- )
+: (process-md5-block-G) ( block v -- )
{
[ a b c d 1 S21 17 ]
[ d a b c 6 S22 18 ]
@@ -138,9 +117,9 @@ MACRO: with-md5-round ( ops func -- )
[ d a b c 2 S22 30 ]
[ c d a b 7 S23 31 ]
[ b c d a 12 S24 32 ]
- } [ G ] with-md5-round ;
+ } [ G ] with-md5-round ; inline
-: (process-md5-block-H) ( block -- )
+: (process-md5-block-H) ( block v -- )
{
[ a b c d 5 S31 33 ]
[ d a b c 8 S32 34 ]
@@ -158,9 +137,9 @@ MACRO: with-md5-round ( ops func -- )
[ d a b c 12 S32 46 ]
[ c d a b 15 S33 47 ]
[ b c d a 2 S34 48 ]
- } [ H ] with-md5-round ;
+ } [ H ] with-md5-round ; inline
-: (process-md5-block-I) ( block -- )
+: (process-md5-block-I) ( block v -- )
{
[ a b c d 0 S41 49 ]
[ d a b c 7 S42 50 ]
@@ -178,33 +157,36 @@ MACRO: with-md5-round ( ops func -- )
[ d a b c 11 S42 62 ]
[ c d a b 2 S43 63 ]
[ b c d a 9 S44 64 ]
- } [ I ] with-md5-round ;
+ } [ I ] with-md5-round ; inline
-: (process-md5-block) ( block -- )
- 4 <groups> [ le> ] map {
- [ (process-md5-block-F) ]
- [ (process-md5-block-G) ]
- [ (process-md5-block-H) ]
- [ (process-md5-block-I) ]
- } cleave
-
- update-md ;
-
-: process-md5-block ( str -- )
- dup length [ bytes-read [ + ] change ] keep 64 = [
- (process-md5-block)
+: (process-md5-block) ( block state -- )
+ [
+ [ 4 <groups> [ le> ] map ] [ state>> ] bi* {
+ [ (process-md5-block-F) ]
+ [ (process-md5-block-G) ]
+ [ (process-md5-block-H) ]
+ [ (process-md5-block-I) ]
+ } 2cleave
] [
- f bytes-read get pad-last-block
- [ (process-md5-block) ] each
+ nip update-md5-state
+ ] 2bi ;
+
+:: process-md5-block ( block state -- )
+ block length
+ [ state [ + ] change-bytes-read drop ] [ 64 = ] bi [
+ block state (process-md5-block)
+ ] [
+ block f state bytes-read>> pad-last-block
+ [ state (process-md5-block) ] each
] if ;
-: stream>md5 ( stream -- )
- 64 over stream-read
- [ process-md5-block ] [ length 64 = ] bi
- [ stream>md5 ] [ drop ] if ;
+:: stream>md5 ( stream state -- )
+ 64 stream stream-read
+ [ state process-md5-block ] [ length 64 = ] bi
+ [ stream state stream>md5 ] when ;
-: get-md5 ( -- str )
- [ a b c d ] [ get 4 >le ] map concat >byte-array ;
+: get-md5 ( md5-state -- bytes )
+ state>> [ 4 >le ] map B{ } concat-as ;
PRIVATE>
@@ -213,4 +195,4 @@ SINGLETON: md5
INSTANCE: md5 stream-checksum
M: md5 checksum-stream
- drop initialize-md5 stream>md5 get-md5 ;
+ drop <md5-state> [ stream>md5 ] [ get-md5 ] bi ;
From bee3c05fe9fe4327228e68901c24021bfc65115f Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Mon, 11 May 2009 11:37:21 -0500
Subject: [PATCH 03/23] working on checksums
---
basis/checksums/hmac/hmac.factor | 16 ++++++++++------
basis/checksums/md5/md5.factor | 31 ++++++++++++++++++++++---------
2 files changed, 32 insertions(+), 15 deletions(-)
diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor
index 7350a02573..fd7f6ef3a1 100755
--- a/basis/checksums/hmac/hmac.factor
+++ b/basis/checksums/hmac/hmac.factor
@@ -8,6 +8,7 @@ IN: checksums.hmac
<PRIVATE
+/*
: sha1-hmac ( Ko Ki stream -- hmac )
initialize-sha1 process-sha1-block
stream>sha1 get-sha1
@@ -15,12 +16,13 @@ IN: checksums.hmac
[ process-sha1-block ]
[ process-sha1-block ] bi* get-sha1 ;
-: md5-hmac ( Ko Ki stream -- hmac )
+ : md5-hmac ( Ko Ki stream -- hmac )
initialize-md5 process-md5-block
stream>md5 get-md5
initialize-md5
[ process-md5-block ]
[ process-md5-block ] bi* get-md5 ;
+*/
: seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ;
@@ -35,12 +37,14 @@ MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
PRIVATE>
-: hmac ( K stream checksum -- value )
- ;
-
:: hmac-stream ( K stream checksum -- value )
- K init-K :> i :> o
- stream checksum checksum-stream ;
+ K init-K :> Ki :> Ko
+ checksum initialize-checksum
+ Ki add-bytes
+ stream add-stream finish-checksum
+ checksum initialize-checksum
+ Ko add-bytes swap add-bytes
+ finish-checksum ;
: hmac-file ( K path checksum -- value )
[ binary <file-reader> ] dip hmac-stream ;
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
index bf43805df2..abdc3504cc 100644
--- a/basis/checksums/md5/md5.factor
+++ b/basis/checksums/md5/md5.factor
@@ -13,7 +13,7 @@ TUPLE: md5-state bytes-read state old-state ;
md5-state new
0 >>bytes-read
{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
- [ clone >>state ] [ clone >>old-state ] bi ;
+ [ clone >>state ] [ >>old-state ] bi ;
<PRIVATE
@@ -21,10 +21,10 @@ TUPLE: md5-state bytes-read state old-state ;
: update-md5-state ( md5-state -- )
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
- [ (>>old-state) ] [ (>>state) ] bi ;
+ [ (>>old-state) ] [ (>>state) ] bi ; inline
: T ( N -- Y )
- sin abs 32 2^ * >integer ; foldable
+ sin abs 32 2^ * >integer ; inline
:: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
@@ -179,15 +179,15 @@ MACRO: with-md5-round ( ops quot -- )
block f state bytes-read>> pad-last-block
[ state (process-md5-block) ] each
] if ;
-
-:: stream>md5 ( stream state -- )
- 64 stream stream-read
- [ state process-md5-block ] [ length 64 = ] bi
- [ stream state stream>md5 ] when ;
: get-md5 ( md5-state -- bytes )
state>> [ 4 >le ] map B{ } concat-as ;
+:: stream>md5 ( state stream -- )
+ 64 stream stream-read
+ [ state process-md5-block ] [ length 64 = ] bi
+ [ state stream stream>md5 ] when ;
+
PRIVATE>
SINGLETON: md5
@@ -195,4 +195,17 @@ SINGLETON: md5
INSTANCE: md5 stream-checksum
M: md5 checksum-stream
- drop <md5-state> [ stream>md5 ] [ get-md5 ] bi ;
+ drop [ <md5-state> ] dip [ stream>md5 ] [ drop get-md5 ] 2bi ;
+
+GENERIC: initialize-checksum ( checksum -- state )
+GENERIC# add-bytes 1 ( state bytes -- state )
+GENERIC# add-stream 1 ( state stream -- state )
+GENERIC: finish-checksum ( state -- bytes )
+
+M: md5 initialize-checksum drop <md5-state> ;
+
+M: md5-state finish-checksum get-md5 ;
+
+M: md5-state add-bytes over [ binary <byte-reader> stream>md5 ] dip ;
+
+M: md5-state add-stream over [ stream>md5 ] dip ;
From 89ccc4b00acddacca2545ef05e2f924f88ecfe36 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 16 May 2009 08:46:41 -0500
Subject: [PATCH 04/23] throw exceptions on png types we dont support
---
basis/compression/inflate/inflate.factor | 4 ++-
basis/images/png/png.factor | 32 ++++++++++++++++++++++--
2 files changed, 33 insertions(+), 3 deletions(-)
diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor
index 3e67b11cc7..3fe07b5994 100755
--- a/basis/compression/inflate/inflate.factor
+++ b/basis/compression/inflate/inflate.factor
@@ -200,7 +200,9 @@ PRIVATE>
: reverse-png-filter ( lines -- filtered )
dup first [ 0 ] replicate prefix
[ { 0 0 } prepend ] map
- 2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ;
+ 2 clump [
+ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
+ ] map concat ;
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader>
diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor
index bf13c43546..c5b84de221 100755
--- a/basis/images/png/png.factor
+++ b/basis/images/png/png.factor
@@ -65,14 +65,42 @@ ERROR: bad-checksum ;
: zlib-data ( png-image -- bytes )
chunks>> [ type>> "IDAT" = ] find nip data>> ;
-: decode-png ( image -- image )
+ERROR: unknown-color-type n ;
+ERROR: unimplemented-color-type image ;
+
+: inflate-data ( image -- bytes )
+ zlib-data zlib-inflate ;
+
+: decode-greyscale ( image -- image )
+ unimplemented-color-type ;
+
+: decode-truecolor ( image -- image )
{
- [ zlib-data zlib-inflate ]
+ [ inflate-data ]
[ dim>> first 3 * 1 + group reverse-png-filter ]
[ swap >byte-array >>bitmap drop ]
[ RGB >>component-order drop ]
[ ]
} cleave ;
+
+: decode-indexed-color ( image -- image )
+ unimplemented-color-type ;
+
+: decode-greyscale-alpha ( image -- image )
+ unimplemented-color-type ;
+
+: decode-truecolor-alpha ( image -- image )
+ unimplemented-color-type ;
+
+: decode-png ( image -- image )
+ dup color-type>> {
+ { 0 [ decode-greyscale ] }
+ { 2 [ decode-truecolor ] }
+ { 3 [ decode-indexed-color ] }
+ { 4 [ decode-greyscale-alpha ] }
+ { 6 [ decode-truecolor-alpha ] }
+ [ unknown-color-type ]
+ } case ;
: load-png ( path -- image )
[ binary <file-reader> ] [ file-info size>> ] bi
From e87021401683eba532fa1fa0b3ac054a98bcadf4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 16 May 2009 13:03:09 -0500
Subject: [PATCH 05/23] working on checksums
---
basis/checksums/hmac/hmac.factor | 2 +-
basis/checksums/md5/md5.factor | 48 +++++++-------------------------
core/checksums/checksums.factor | 34 ++++++++++++++++++++--
3 files changed, 43 insertions(+), 41 deletions(-)
diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor
index fd7f6ef3a1..17b391f215 100755
--- a/basis/checksums/hmac/hmac.factor
+++ b/basis/checksums/hmac/hmac.factor
@@ -49,5 +49,5 @@ PRIVATE>
: hmac-file ( K path checksum -- value )
[ binary <file-reader> ] dip hmac-stream ;
-: hmac-bytes ( K path checksum -- value )
+: hmac-bytes ( K seq checksum -- value )
[ binary <byte-reader> ] dip hmac-stream ;
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
index abdc3504cc..ee00817ea5 100644
--- a/basis/checksums/md5/md5.factor
+++ b/basis/checksums/md5/md5.factor
@@ -7,11 +7,13 @@ io.encodings.binary math.bitwise checksums accessors
checksums.common checksums.stream combinators combinators.smart ;
IN: checksums.md5
-TUPLE: md5-state bytes-read state old-state ;
+SINGLETON: md5
+INSTANCE: md5 stream-checksum
+
+TUPLE: md5-state < checksum-state state old-state ;
: <md5-state> ( -- md5-state )
- md5-state new
- 0 >>bytes-read
+ 64 md5-state new-checksum-state
{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
[ clone >>state ] [ >>old-state ] bi ;
@@ -159,7 +161,7 @@ MACRO: with-md5-round ( ops quot -- )
[ b c d a 9 S44 64 ]
} [ I ] with-md5-round ; inline
-: (process-md5-block) ( block state -- )
+M: md5-state checksum-block ( block state -- )
[
[ 4 <groups> [ le> ] map ] [ state>> ] bi* {
[ (process-md5-block-F) ]
@@ -171,41 +173,11 @@ MACRO: with-md5-round ( ops quot -- )
nip update-md5-state
] 2bi ;
-:: process-md5-block ( block state -- )
- block length
- [ state [ + ] change-bytes-read drop ] [ 64 = ] bi [
- block state (process-md5-block)
- ] [
- block f state bytes-read>> pad-last-block
- [ state (process-md5-block) ] each
- ] if ;
-
-: get-md5 ( md5-state -- bytes )
+: md5-state>checksum ( md5-state -- bytes )
state>> [ 4 >le ] map B{ } concat-as ;
-:: stream>md5 ( state stream -- )
- 64 stream stream-read
- [ state process-md5-block ] [ length 64 = ] bi
- [ state stream stream>md5 ] when ;
+M: md5-state get-checksum ( md5-state -- bytes )
+ clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
+ [ [ checksum-block ] curry each ] [ md5-state>checksum ] bi ;
PRIVATE>
-
-SINGLETON: md5
-
-INSTANCE: md5 stream-checksum
-
-M: md5 checksum-stream
- drop [ <md5-state> ] dip [ stream>md5 ] [ drop get-md5 ] 2bi ;
-
-GENERIC: initialize-checksum ( checksum -- state )
-GENERIC# add-bytes 1 ( state bytes -- state )
-GENERIC# add-stream 1 ( state stream -- state )
-GENERIC: finish-checksum ( state -- bytes )
-
-M: md5 initialize-checksum drop <md5-state> ;
-
-M: md5-state finish-checksum get-md5 ;
-
-M: md5-state add-bytes over [ binary <byte-reader> stream>md5 ] dip ;
-
-M: md5-state add-stream over [ stream>md5 ] dip ;
diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor
index 82918b6f81..4f12f5b45d 100644
--- a/core/checksums/checksums.factor
+++ b/core/checksums/checksums.factor
@@ -1,11 +1,41 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences math.parser io io.backend io.files
-kernel ;
+USING: accessors io io.backend io.files kernel math math.parser
+sequences vectors io.encodings.binary ;
IN: checksums
MIXIN: checksum
+TUPLE: checksum-state bytes-read block-size bytes ;
+
+: new-checksum-state ( block-size class -- checksum-state )
+ new
+ swap >>block-size
+ 0 >>bytes-read
+ V{ } clone >>bytes ; inline
+
+GENERIC: checksum-block ( bytes checksum -- )
+
+GENERIC: get-checksum ( checksum -- value )
+
+: add-checksum-bytes ( checksum-state data -- checksum-state )
+ over bytes>> [ push-all ] keep
+ [ dup length pick block-size>> >= ]
+ [
+ 64 cut-slice [
+ over [ checksum-block ]
+ [ [ 64 + ] change-bytes-read drop ] bi
+ ] dip
+ ] while >vector >>bytes ;
+
+: add-checksum-stream ( checksum-state stream -- checksum-state )
+ [
+ [ '[ [ _ ] dip add-checksum-bytes drop ] each-block ] keep
+ ] with-input-stream ;
+
+: add-checksum-file ( checksum-state path -- checksum-state )
+ binary <file-reader> add-checksum-stream ;
+
GENERIC: checksum-bytes ( bytes checksum -- value )
GENERIC: checksum-stream ( stream checksum -- value )
From d1468a33d1a7385ade48fb4efb947ad4050867b2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 16 May 2009 15:17:20 -0500
Subject: [PATCH 06/23] dont use fry in core
---
core/checksums/checksums.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor
index 4f12f5b45d..27ee6a3435 100644
--- a/core/checksums/checksums.factor
+++ b/core/checksums/checksums.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io io.backend io.files kernel math math.parser
-sequences vectors io.encodings.binary ;
+sequences vectors io.encodings.binary quotations ;
IN: checksums
MIXIN: checksum
@@ -30,7 +30,7 @@ GENERIC: get-checksum ( checksum -- value )
: add-checksum-stream ( checksum-state stream -- checksum-state )
[
- [ '[ [ _ ] dip add-checksum-bytes drop ] each-block ] keep
+ [ [ swap add-checksum-bytes drop ] curry each-block ] keep
] with-input-stream ;
: add-checksum-file ( checksum-state path -- checksum-state )
From 0bdccdb7acbcac5f6d8f0339d39cdb380c4709a8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 16 May 2009 18:00:56 -0500
Subject: [PATCH 07/23] checksums work now
---
basis/checksums/md5/md5-tests.factor | 21 ++++++++++++++++++
basis/checksums/md5/md5.factor | 32 ++++++++++++++++++----------
core/checksums/checksums.factor | 6 +++++-
3 files changed, 47 insertions(+), 12 deletions(-)
diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor
index 8e314f7c28..db15540f43 100644
--- a/basis/checksums/md5/md5-tests.factor
+++ b/basis/checksums/md5/md5-tests.factor
@@ -8,3 +8,24 @@ USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" >byte-array md5 checksum-bytes hex-string ] unit-test
+
+[
+ t
+] [
+ <md5-state> "asdf" add-checksum-bytes
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
+[
+ t
+] [
+ <md5-state> "" add-checksum-bytes
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
+[
+ t
+] [
+ <md5-state> "asdf" binary <byte-reader> add-checksum-stream
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
index ee00817ea5..97a263bab5 100644
--- a/basis/checksums/md5/md5.factor
+++ b/basis/checksums/md5/md5.factor
@@ -8,11 +8,12 @@ checksums.common checksums.stream combinators combinators.smart ;
IN: checksums.md5
SINGLETON: md5
+
INSTANCE: md5 stream-checksum
TUPLE: md5-state < checksum-state state old-state ;
-: <md5-state> ( -- md5-state )
+: <md5-state> ( -- md5 )
64 md5-state new-checksum-state
{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
[ clone >>state ] [ >>old-state ] bi ;
@@ -21,7 +22,7 @@ TUPLE: md5-state < checksum-state state old-state ;
: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
-: update-md5-state ( md5-state -- )
+: update-md5 ( md5 -- )
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
[ (>>old-state) ] [ (>>state) ] bi ; inline
@@ -69,13 +70,13 @@ CONSTANT: d 3
:: (ABCD) ( x V a b c d k s i quot -- )
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
a V [
- b V nth-unsafe
- c V nth-unsafe
- d V nth-unsafe quot call w+
- k x nth-unsafe w+
+ b V nth
+ c V nth
+ d V nth quot call w+
+ k x nth w+
i T w+
s bitroll-32
- b V nth-unsafe w+
+ b V nth w+
] change-nth ; inline
MACRO: with-md5-round ( ops quot -- )
@@ -170,14 +171,23 @@ M: md5-state checksum-block ( block state -- )
[ (process-md5-block-I) ]
} 2cleave
] [
- nip update-md5-state
+ nip update-md5
] 2bi ;
-: md5-state>checksum ( md5-state -- bytes )
+: md5>checksum ( md5 -- bytes )
state>> [ 4 >le ] map B{ } concat-as ;
-M: md5-state get-checksum ( md5-state -- bytes )
+M: md5-state clone ( md5 -- new-md5 )
+ call-next-method
+ [ clone ] change-state
+ [ clone ] change-old-state ;
+
+M: md5-state get-checksum ( md5 -- bytes )
clone [ bytes>> f ] [ bytes-read>> pad-last-block ] [ ] tri
- [ [ checksum-block ] curry each ] [ md5-state>checksum ] bi ;
+ [ [ checksum-block ] curry each ] [ md5>checksum ] bi ;
+
+M: md5 checksum-stream ( stream checksum -- byte-array )
+ drop
+ [ <md5-state> ] dip add-checksum-stream get-checksum ;
PRIVATE>
diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor
index 27ee6a3435..0910a3efac 100644
--- a/core/checksums/checksums.factor
+++ b/core/checksums/checksums.factor
@@ -14,6 +14,10 @@ TUPLE: checksum-state bytes-read block-size bytes ;
0 >>bytes-read
V{ } clone >>bytes ; inline
+M: checksum-state clone
+ call-next-method
+ [ clone ] change-bytes ;
+
GENERIC: checksum-block ( bytes checksum -- )
GENERIC: get-checksum ( checksum -- value )
@@ -26,7 +30,7 @@ GENERIC: get-checksum ( checksum -- value )
over [ checksum-block ]
[ [ 64 + ] change-bytes-read drop ] bi
] dip
- ] while >vector >>bytes ;
+ ] while >vector [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ;
: add-checksum-stream ( checksum-state stream -- checksum-state )
[
From c8e0b049a841fee7b851486bafc9a4f0f6558dcc Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 17 May 2009 10:10:14 -0500
Subject: [PATCH 08/23] fix a bug in inflate -- length table was one entry too
short
---
basis/compression/inflate/inflate.factor | 25 ++++++++++++------------
1 file changed, 13 insertions(+), 12 deletions(-)
diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor
index 3fe07b5994..7cb43ac68f 100755
--- a/basis/compression/inflate/inflate.factor
+++ b/basis/compression/inflate/inflate.factor
@@ -75,18 +75,20 @@ CONSTANT: length-table
19 23 27 31
35 43 51 59
67 83 99 115
- 131 163 195 227
+ 131 163 195 227 258
}
CONSTANT: dist-table
- { 1 2 3 4
- 5 7 9 13
- 17 25 33 49
- 65 97 129 193
- 257 385 513 769
- 1025 1537 2049 3073
- 4097 6145 8193 12289
- 16385 24577 }
+ {
+ 1 2 3 4
+ 5 7 9 13
+ 17 25 33 49
+ 65 97 129 193
+ 257 385 513 769
+ 1025 1537 2049 3073
+ 4097 6145 8193 12289
+ 16385 24577
+ }
: nth* ( n seq -- elt )
[ length 1- swap - ] [ nth ] bi ;
@@ -156,7 +158,7 @@ CONSTANT: dist-table
[ 1 bitstream bs:read 0 = ]
[
bitstream
- 2 bitstream bs:read ! B
+ 2 bitstream bs:read
{
{ 0 [ inflate-raw ] }
{ 1 [ inflate-static ] }
@@ -206,6 +208,5 @@ PRIVATE>
: zlib-inflate ( bytes -- bytes )
bs:<lsb0-bit-reader>
- [ check-zlib-header ]
- [ inflate-loop ] bi
+ [ check-zlib-header ] [ inflate-loop ] bi
inflate-lz77 ;
From b2ac4396c1f78e81dec1f9413e63e617573e2e0c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 17 May 2009 11:03:04 -0500
Subject: [PATCH 09/23] sha2 now uses the incremental checksum protocol
---
basis/checksums/md5/md5-tests.factor | 4 +-
basis/checksums/sha2/sha2.factor | 101 +++++++++++++--------------
2 files changed, 51 insertions(+), 54 deletions(-)
diff --git a/basis/checksums/md5/md5-tests.factor b/basis/checksums/md5/md5-tests.factor
index db15540f43..b7f388c002 100644
--- a/basis/checksums/md5/md5-tests.factor
+++ b/basis/checksums/md5/md5-tests.factor
@@ -1,4 +1,6 @@
-USING: kernel math namespaces checksums checksums.md5 tools.test byte-arrays ;
+USING: byte-arrays checksums checksums.md5 io.encodings.binary
+io.streams.byte-array kernel math namespaces tools.test ;
+
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" >byte-array md5 checksum-bytes hex-string ] unit-test
[ "0cc175b9c0f1b6a831c399e269772661" ] [ "a" >byte-array md5 checksum-bytes hex-string ] unit-test
diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index 12e32f6c69..509b047d2e 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -3,16 +3,16 @@
USING: kernel splitting grouping math sequences namespaces make
io.binary math.bitwise checksums checksums.common
sbufs strings combinators.smart math.ranges fry combinators
-accessors locals ;
+accessors locals checksums.stream multiline ;
IN: checksums.sha2
SINGLETON: sha-224
SINGLETON: sha-256
-INSTANCE: sha-224 checksum
-INSTANCE: sha-256 checksum
+INSTANCE: sha-224 stream-checksum
+INSTANCE: sha-256 stream-checksum
-TUPLE: sha2-state K H word-size block-size ;
+TUPLE: sha2-state < checksum-state K H word-size ;
TUPLE: sha2-short < sha2-state ;
@@ -22,6 +22,11 @@ TUPLE: sha-224-state < sha2-short ;
TUPLE: sha-256-state < sha2-short ;
+M: sha2-state clone
+ call-next-method
+ [ clone ] change-H
+ [ clone ] change-K ;
+
<PRIVATE
CONSTANT: a 0
@@ -116,6 +121,18 @@ CONSTANT: K-384
ALIAS: K-512 K-384
+: <sha-224-state> ( -- sha2-state )
+ 64 sha-224-state new-checksum-state
+ K-256 >>K
+ initial-H-224 >>H
+ 4 >>word-size ;
+
+: <sha-256-state> ( -- sha2-state )
+ 64 sha-256-state new-checksum-state
+ K-256 >>K
+ initial-H-256 >>H
+ 4 >>word-size ;
+
: s0-256 ( x -- x' )
[
[ -7 bitroll-32 ]
@@ -172,7 +189,7 @@ ALIAS: K-512 K-384
[ -41 bitroll-64 ] tri
] [ bitxor ] reduce-outputs ; inline
-: process-M-256 ( n seq -- )
+: prepare-M-256 ( n seq -- )
{
[ [ 16 - ] dip nth ]
[ [ 15 - ] dip nth s0-256 ]
@@ -181,7 +198,7 @@ ALIAS: K-512 K-384
[ ]
} 2cleave set-nth ; inline
-: process-M-512 ( n seq -- )
+: prepare-M-512 ( n seq -- )
{
[ [ 16 - ] dip nth ]
[ [ 15 - ] dip nth s0-512 ]
@@ -201,23 +218,6 @@ ALIAS: K-512 K-384
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
-M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
- drop
- dup [
- HEX: 80 ,
- length
- [ 64 mod calculate-pad-length 0 <string> % ]
- [ 3 shift 8 >be % ] bi
- ] "" make append ;
-
-M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
- drop dup [
- HEX: 80 ,
- length
- [ 128 mod calculate-pad-length-long 0 <string> % ]
- [ 3 shift 8 >be % ] bi
- ] "" make append ;
-
: seq>byte-array ( seq n -- string )
'[ _ >be ] map B{ } join ;
@@ -257,7 +257,7 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
[ word-size>> <sliced-groups> [ be> ] map ]
[
block-size>> [ 0 pad-tail 16 ] keep [a,b) over
- '[ _ process-M-256 ] each
+ '[ _ prepare-M-256 ] each
] bi ; inline
:: process-chunk ( M block-size cloned-H sha2 -- )
@@ -268,39 +268,34 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
] each
cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
-: sha2-steps ( sliced-groups state -- )
- '[
- _
- [ prepare-message-schedule ]
- [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
- ] each ;
+M: sha2-short checksum-block
+ [ prepare-message-schedule ]
+ [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
-: byte-array>sha2 ( bytes state -- )
- [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
- [ sha2-steps ] bi ;
+: sha-224>checksum ( sha2 -- bytes )
+ H>> 7 head 4 seq>byte-array ;
-: <sha-224-state> ( -- sha2-state )
- sha-224-state new
- K-256 >>K
- initial-H-224 >>H
- 4 >>word-size
- 64 >>block-size ;
+: sha-256>checksum ( sha2 -- bytes )
+ H>> 4 seq>byte-array ;
-: <sha-256-state> ( -- sha2-state )
- sha-256-state new
- K-256 >>K
- initial-H-256 >>H
- 4 >>word-size
- 64 >>block-size ;
+: pad-last-short-block ( state -- )
+ [ bytes>> t ] [ bytes-read>> pad-last-block ] [ ] tri
+ [ checksum-block ] curry each ;
PRIVATE>
-M: sha-224 checksum-bytes
- drop <sha-224-state>
- [ byte-array>sha2 ]
- [ H>> 7 head 4 seq>byte-array ] bi ;
+M: sha-224-state get-checksum
+ clone
+ [ pad-last-short-block ] [ sha-224>checksum ] bi ;
-M: sha-256 checksum-bytes
- drop <sha-256-state>
- [ byte-array>sha2 ]
- [ H>> 4 seq>byte-array ] bi ;
+M: sha-256-state get-checksum
+ clone
+ [ pad-last-short-block ] [ sha-256>checksum ] bi ;
+
+M: sha-224 checksum-stream ( stream checksum -- byte-array )
+ drop
+ [ <sha-224-state> ] dip add-checksum-stream get-checksum ;
+
+M: sha-256 checksum-stream ( stream checksum -- byte-array )
+ drop
+ [ <sha-256-state> ] dip add-checksum-stream get-checksum ;
From f1f1a26b6069a4006c9133a6f7d14cc76b2db380 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 17 May 2009 12:45:20 -0500
Subject: [PATCH 10/23] working on hmac
---
basis/checksums/hmac/hmac-tests.factor | 11 ++++--
basis/checksums/hmac/hmac.factor | 47 ++++++++++----------------
basis/checksums/md5/md5.factor | 5 ++-
basis/checksums/sha2/sha2-tests.factor | 2 --
basis/checksums/sha2/sha2.factor | 10 ++++--
core/checksums/checksums.factor | 5 +--
6 files changed, 41 insertions(+), 39 deletions(-)
diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor
index 9541ca2f26..8835bed981 100755
--- a/basis/checksums/hmac/hmac-tests.factor
+++ b/basis/checksums/hmac/hmac-tests.factor
@@ -1,6 +1,6 @@
USING: kernel io strings byte-arrays sequences namespaces math
parser checksums.hmac tools.test checksums.md5 checksums.sha1
-checksums.sha2 ;
+checksums.sha2 checksums ;
IN: checksums.hmac.tests
[
@@ -39,4 +39,11 @@ IN: checksums.hmac.tests
] unit-test
[ "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" ]
-[ HEX: b 20 <string> sha-256 hmac-bytes >string ] unit-test
+[ 20 HEX: b <string> "Hi There" sha-256 hmac-bytes hex-string ] unit-test
+
+[ "167f928588c5cc2eef8e3093caa0e87c9ff566a14794aa61648d81621a2a40c6" ]
+[
+ "JefeJefeJefeJefeJefeJefeJefeJefe"
+ "what do ya want for nothing?" sha-256 hmac-bytes hex-string
+] unit-test
+
diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor
index 17b391f215..538dfc92c8 100755
--- a/basis/checksums/hmac/hmac.factor
+++ b/basis/checksums/hmac/hmac.factor
@@ -3,48 +3,35 @@
USING: arrays checksums checksums.md5 checksums.md5.private
checksums.sha1 combinators fry io io.binary io.encodings.binary
io.files io.streams.byte-array kernel math math.vectors memoize
-sequences ;
+sequences locals accessors ;
IN: checksums.hmac
<PRIVATE
-/*
-: sha1-hmac ( Ko Ki stream -- hmac )
- initialize-sha1 process-sha1-block
- stream>sha1 get-sha1
- initialize-sha1
- [ process-sha1-block ]
- [ process-sha1-block ] bi* get-sha1 ;
-
- : md5-hmac ( Ko Ki stream -- hmac )
- initialize-md5 process-md5-block
- stream>md5 get-md5
- initialize-md5
- [ process-md5-block ]
- [ process-md5-block ] bi* get-md5 ;
-*/
-
: seq-bitxor ( seq seq -- seq ) [ bitxor ] 2map ;
-MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
+: opad ( checksum-state -- seq ) block-size>> HEX: 5c <array> ;
-MEMO: ipad ( -- seq ) 64 HEX: 36 <array> ;
+: ipad ( checksum-state -- seq ) block-size>> HEX: 36 <array> ;
-: init-K ( K -- o i )
- 64 0 pad-tail
- [ opad seq-bitxor ]
- [ ipad seq-bitxor ] bi ;
+:: init-K ( K checksum checksum-state -- o i )
+ checksum-state block-size>> K length <
+ [ K checksum checksum-bytes ] [ K ] 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 init-K :> Ki :> Ko
- checksum initialize-checksum
- Ki add-bytes
- stream add-stream finish-checksum
- checksum initialize-checksum
- Ko add-bytes swap add-bytes
- finish-checksum ;
+ K checksum dup initialize-checksum-state
+ dup :> checksum-state
+ init-K :> 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 ;
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
index 97a263bab5..026df34012 100644
--- a/basis/checksums/md5/md5.factor
+++ b/basis/checksums/md5/md5.factor
@@ -14,10 +14,13 @@ INSTANCE: md5 stream-checksum
TUPLE: md5-state < checksum-state state old-state ;
: <md5-state> ( -- md5 )
- 64 md5-state new-checksum-state
+ md5-state new-checksum-state
+ 64 >>block-size
{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
[ clone >>state ] [ >>old-state ] bi ;
+M: md5 initialize-checksum-state drop <md5-state> ;
+
<PRIVATE
: v-w+ ( v1 v2 -- v3 ) [ w+ ] 2map ;
diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor
index c14ea5a98d..010ca96d4f 100644
--- a/basis/checksums/sha2/sha2-tests.factor
+++ b/basis/checksums/sha2/sha2-tests.factor
@@ -36,7 +36,5 @@ IN: checksums.sha2.tests
] unit-test
-
-
! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test
diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index 509b047d2e..8992299db0 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -122,17 +122,23 @@ CONSTANT: K-384
ALIAS: K-512 K-384
: <sha-224-state> ( -- sha2-state )
- 64 sha-224-state new-checksum-state
+ sha-224-state new-checksum-state
+ 64 >>block-size
K-256 >>K
initial-H-224 >>H
4 >>word-size ;
: <sha-256-state> ( -- sha2-state )
- 64 sha-256-state new-checksum-state
+ sha-256-state new-checksum-state
+ 64 >>block-size
K-256 >>K
initial-H-256 >>H
4 >>word-size ;
+M: sha-224 initialize-checksum-state drop <sha-224-state> ;
+
+M: sha-256 initialize-checksum-state drop <sha-256-state> ;
+
: s0-256 ( x -- x' )
[
[ -7 bitroll-32 ]
diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor
index 0910a3efac..1d57823e18 100644
--- a/core/checksums/checksums.factor
+++ b/core/checksums/checksums.factor
@@ -8,9 +8,8 @@ MIXIN: checksum
TUPLE: checksum-state bytes-read block-size bytes ;
-: new-checksum-state ( block-size class -- checksum-state )
+: new-checksum-state ( class -- checksum-state )
new
- swap >>block-size
0 >>bytes-read
V{ } clone >>bytes ; inline
@@ -18,6 +17,8 @@ M: checksum-state clone
call-next-method
[ clone ] change-bytes ;
+GENERIC: initialize-checksum-state ( class -- checksum-state )
+
GENERIC: checksum-block ( bytes checksum -- )
GENERIC: get-checksum ( checksum -- value )
From 8b37eced0511d98c89d138215f5d876befac8b33 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 17 May 2009 13:36:53 -0500
Subject: [PATCH 11/23] use literal-arrays
---
basis/images/bitmap/bitmap-tests.factor | 18 +++++++++---------
1 file changed, 9 insertions(+), 9 deletions(-)
diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor
index 29ba3b9b80..ea8b0d4c0c 100644
--- a/basis/images/bitmap/bitmap-tests.factor
+++ b/basis/images/bitmap/bitmap-tests.factor
@@ -17,9 +17,9 @@ CONSTANT: test-41 "vocab:images/test-images/41red24bit.bmp"
CONSTANT: test-42 "vocab:images/test-images/42red24bit.bmp"
CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
-{
- $ test-bitmap8
- $ test-bitmap24
+${
+ test-bitmap8
+ test-bitmap24
"vocab:ui/render/test/reference.bmp"
} [ [ ] swap [ load-image drop ] curry unit-test ] each
@@ -34,11 +34,11 @@ CONSTANT: test-43 "vocab:images/test-images/43red24bit.bmp"
[
t
] [
- {
- $ test-40
- $ test-41
- $ test-42
- $ test-43
- $ test-bitmap24
+ ${
+ test-40
+ test-41
+ test-42
+ test-43
+ test-bitmap24
} [ test-bitmap-save ] all?
] unit-test
From ee6a8e78e7ae37b4dc22d10a59bb3bef8fe34520 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 17 May 2009 13:49:56 -0500
Subject: [PATCH 12/23] generalize sha1-interleave and move it to its own
vocabulary
---
basis/checksums/interleave/authors.txt | 1 +
.../interleave/interleave-tests.factor | 19 +++++++++++++++++++
basis/checksums/interleave/interleave.factor | 17 +++++++++++++++++
3 files changed, 37 insertions(+)
create mode 100644 basis/checksums/interleave/authors.txt
create mode 100644 basis/checksums/interleave/interleave-tests.factor
create mode 100644 basis/checksums/interleave/interleave.factor
diff --git a/basis/checksums/interleave/authors.txt b/basis/checksums/interleave/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/checksums/interleave/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/checksums/interleave/interleave-tests.factor b/basis/checksums/interleave/interleave-tests.factor
new file mode 100644
index 0000000000..060d35936f
--- /dev/null
+++ b/basis/checksums/interleave/interleave-tests.factor
@@ -0,0 +1,19 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test checksums.interleave checksums.sha1 ;
+IN: checksums.interleave.tests
+
+[
+ B{
+ 59 155 253 205 75 163 94 115 208 42 227 92 181 19 60 232
+ 119 65 178 131 210 48 241 230 204 216 30 156 4 215 80 84 93
+ 206 44 1 18 128 150 153
+ }
+] [
+ B{
+ 102 83 241 12 26 250 181 76 97 200 37 117 168 74 254 48 216
+ 170 26 58 150 150 179 24 153 146 191 225 203 127 166 167
+ }
+ sha1 interleaved-checksum
+] unit-test
+
diff --git a/basis/checksums/interleave/interleave.factor b/basis/checksums/interleave/interleave.factor
new file mode 100644
index 0000000000..caef033ec6
--- /dev/null
+++ b/basis/checksums/interleave/interleave.factor
@@ -0,0 +1,17 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs checksums grouping kernel locals math sequences ;
+IN: checksums.interleave
+
+: seq>2seq ( seq -- seq1 seq2 )
+ #! { abcdefgh } -> { aceg } { bdfh }
+ 2 group flip [ { } { } ] [ first2 ] if-empty ;
+
+: 2seq>seq ( seq1 seq2 -- seq )
+ #! { aceg } { bdfh } -> { abcdefgh }
+ [ zip concat ] keep like ;
+
+:: interleaved-checksum ( bytes checksum -- seq )
+ bytes [ zero? ] trim-head
+ dup length odd? [ rest-slice ] when
+ seq>2seq [ checksum checksum-bytes ] bi@ 2seq>seq ;
From e342082722c40f5a5f9f97378022b0f27b590cb6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 17 May 2009 17:50:31 -0500
Subject: [PATCH 13/23] fix sha1
---
basis/checksums/adler-32/adler-32.factor | 2 +-
basis/checksums/hmac/hmac-tests.factor | 4 +-
.../interleave/interleave-tests.factor | 2 +-
basis/checksums/sha1/authors.txt | 1 -
basis/checksums/sha1/sha1-docs.factor | 11 --
basis/checksums/sha1/sha1-tests.factor | 14 --
basis/checksums/sha1/sha1.factor | 134 ------------------
basis/checksums/sha1/summary.txt | 1 -
basis/checksums/sha2/sha2-tests.factor | 7 +
basis/checksums/sha2/sha2.factor | 114 ++++++++++++++-
10 files changed, 120 insertions(+), 170 deletions(-)
delete mode 100755 basis/checksums/sha1/authors.txt
delete mode 100644 basis/checksums/sha1/sha1-docs.factor
delete mode 100644 basis/checksums/sha1/sha1-tests.factor
delete mode 100644 basis/checksums/sha1/sha1.factor
delete mode 100644 basis/checksums/sha1/summary.txt
diff --git a/basis/checksums/adler-32/adler-32.factor b/basis/checksums/adler-32/adler-32.factor
index d5e153ba99..f66860dc63 100644
--- a/basis/checksums/adler-32/adler-32.factor
+++ b/basis/checksums/adler-32/adler-32.factor
@@ -10,6 +10,6 @@ CONSTANT: adler-32-modulus 65521
M: adler-32 checksum-bytes ( bytes checksum -- value )
drop
- [ sum 1+ ]
+ [ sum 1 + ]
[ [ dup length [1,b] <reversed> v. ] [ length ] bi + ] bi
[ adler-32-modulus mod ] bi@ 16 shift bitor ;
diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor
index 8835bed981..02dfc271a4 100755
--- a/basis/checksums/hmac/hmac-tests.factor
+++ b/basis/checksums/hmac/hmac-tests.factor
@@ -1,6 +1,6 @@
USING: kernel io strings byte-arrays sequences namespaces math
-parser checksums.hmac tools.test checksums.md5 checksums.sha1
-checksums.sha2 checksums ;
+parser checksums.hmac tools.test checksums.md5 checksums.sha2
+checksums ;
IN: checksums.hmac.tests
[
diff --git a/basis/checksums/interleave/interleave-tests.factor b/basis/checksums/interleave/interleave-tests.factor
index 060d35936f..14dddaafab 100644
--- a/basis/checksums/interleave/interleave-tests.factor
+++ b/basis/checksums/interleave/interleave-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test checksums.interleave checksums.sha1 ;
+USING: tools.test checksums.interleave checksums.sha2 ;
IN: checksums.interleave.tests
[
diff --git a/basis/checksums/sha1/authors.txt b/basis/checksums/sha1/authors.txt
deleted file mode 100755
index 7c1b2f2279..0000000000
--- a/basis/checksums/sha1/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/basis/checksums/sha1/sha1-docs.factor b/basis/checksums/sha1/sha1-docs.factor
deleted file mode 100644
index 2c9093865f..0000000000
--- a/basis/checksums/sha1/sha1-docs.factor
+++ /dev/null
@@ -1,11 +0,0 @@
-USING: help.markup help.syntax ;
-IN: checksums.sha1
-
-HELP: sha1
-{ $class-description "SHA1 checksum algorithm." } ;
-
-ARTICLE: "checksums.sha1" "SHA1 checksum"
-"The SHA1 checksum algorithm implements a one-way hash function. It is generally considered to be stronger than MD5, however there is a known algorithm for finding collisions more effectively than a brute-force search (" { $url "http://www.schneier.com/blog/archives/2005/02/sha1_broken.html" } ")."
-{ $subsection sha1 } ;
-
-ABOUT: "checksums.sha1"
diff --git a/basis/checksums/sha1/sha1-tests.factor b/basis/checksums/sha1/sha1-tests.factor
deleted file mode 100644
index 808d37d1e4..0000000000
--- a/basis/checksums/sha1/sha1-tests.factor
+++ /dev/null
@@ -1,14 +0,0 @@
-USING: arrays kernel math namespaces sequences tools.test checksums checksums.sha1 ;
-
-[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
-[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
-! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
-[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
-10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
-
-[
- ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099"
-] [
- "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7"
- sha1-interleave
-] unit-test
diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor
deleted file mode 100644
index 707aa66ba6..0000000000
--- a/basis/checksums/sha1/sha1.factor
+++ /dev/null
@@ -1,134 +0,0 @@
-! Copyright (C) 2006, 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel io io.encodings.binary io.files
-io.streams.byte-array math.vectors strings namespaces
-make math parser sequences assocs grouping vectors io.binary
-hashtables math.bitwise checksums checksums.common
-checksums.stream ;
-IN: checksums.sha1
-
-! Implemented according to RFC 3174.
-
-SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
-
-: get-wth ( n -- wth ) w get nth ; inline
-: shift-wth ( n -- x ) get-wth 1 bitroll-32 ; inline
-
-: initialize-sha1 ( -- )
- 0 bytes-read set
- HEX: 67452301 dup h0 set A set
- HEX: efcdab89 dup h1 set B set
- HEX: 98badcfe dup h2 set C set
- HEX: 10325476 dup h3 set D set
- HEX: c3d2e1f0 dup h4 set E set
- [
- 20 HEX: 5a827999 <array> %
- 20 HEX: 6ed9eba1 <array> %
- 20 HEX: 8f1bbcdc <array> %
- 20 HEX: ca62c1d6 <array> %
- ] { } make K set ;
-
-! W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16))
-: sha1-W ( t -- W_t )
- dup 3 - get-wth
- over 8 - get-wth bitxor
- over 14 - get-wth bitxor
- swap 16 - get-wth bitxor 1 bitroll-32 ;
-
-! f(t;B,C,D) = (B AND C) OR ((NOT B) AND D) ( 0 <= t <= 19)
-! f(t;B,C,D) = B XOR C XOR D (20 <= t <= 39)
-! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59)
-! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79)
-: sha1-f ( B C D t -- f_tbcd )
- 20 /i
- {
- { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
- { 1 [ bitxor bitxor ] }
- { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
- { 3 [ bitxor bitxor ] }
- } case ;
-
-: nth-int-be ( string n -- int )
- 4 * dup 4 + rot <slice> be> ; inline
-
-: make-w ( str -- )
- #! compute w, steps a-b of RFC 3174, section 6.1
- 16 [ nth-int-be w get push ] with each
- 16 80 dup <slice> [ sha1-W w get push ] each ;
-
-: init-letters ( -- )
- ! step c of RFC 3174, section 6.1
- h0 get A set
- h1 get B set
- h2 get C set
- h3 get D set
- h4 get E set ;
-
-: inner-loop ( n -- temp )
- ! TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t);
- [
- [ B get C get D get ] keep sha1-f ,
- dup get-wth ,
- K get nth ,
- A get 5 bitroll-32 ,
- E get ,
- ] { } make sum 32 bits ; inline
-
-: set-vars ( temp -- )
- ! E = D; D = C; C = S^30(B); B = A; A = TEMP;
- D get E set
- C get D set
- B get 30 bitroll-32 C set
- A get B set
- A set ;
-
-: calculate-letters ( -- )
- ! step d of RFC 3174, section 6.1
- 80 [ inner-loop set-vars ] each ;
-
-: update-hs ( -- )
- ! step e of RFC 3174, section 6.1
- A h0 update-old-new
- B h1 update-old-new
- C h2 update-old-new
- D h3 update-old-new
- E h4 update-old-new ;
-
-: (process-sha1-block) ( str -- )
- 80 <vector> w set make-w init-letters calculate-letters update-hs ;
-
-: process-sha1-block ( str -- )
- dup length [ bytes-read [ + ] change ] keep 64 = [
- (process-sha1-block)
- ] [
- t bytes-read get pad-last-block
- [ (process-sha1-block) ] each
- ] if ;
-
-: stream>sha1 ( -- )
- 64 read [ process-sha1-block ] keep
- length 64 = [ stream>sha1 ] when ;
-
-: get-sha1 ( -- str )
- [ [ h0 h1 h2 h3 h4 ] [ get 4 >be % ] each ] "" make ;
-
-SINGLETON: sha1
-
-INSTANCE: sha1 stream-checksum
-
-M: sha1 checksum-stream ( stream -- sha1 )
- drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
-
-: seq>2seq ( seq -- seq1 seq2 )
- #! { abcdefgh } -> { aceg } { bdfh }
- 2 group flip [ { } { } ] [ first2 ] if-empty ;
-
-: 2seq>seq ( seq1 seq2 -- seq )
- #! { aceg } { bdfh } -> { abcdefgh }
- [ zip concat ] keep like ;
-
-: sha1-interleave ( string -- seq )
- [ zero? ] trim-head
- dup length odd? [ rest ] when
- seq>2seq [ sha1 checksum-bytes ] bi@
- 2seq>seq ;
diff --git a/basis/checksums/sha1/summary.txt b/basis/checksums/sha1/summary.txt
deleted file mode 100644
index d8da1df0aa..0000000000
--- a/basis/checksums/sha1/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-SHA1 checksum algorithm
diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor
index 010ca96d4f..fa01796ae9 100644
--- a/basis/checksums/sha2/sha2-tests.factor
+++ b/basis/checksums/sha2/sha2-tests.factor
@@ -5,6 +5,13 @@ IN: checksums.sha2.tests
: test-checksum ( text identifier -- checksum )
checksum-bytes hex-string ;
+[ "a9993e364706816aba3e25717850c26c9cd0d89d" ] [ "abc" sha1 checksum-bytes hex-string ] unit-test
+[ "84983e441c3bd26ebaae4aa1f95129e5e54670f1" ] [ "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" sha1 checksum-bytes hex-string ] unit-test
+! [ "34aa973cd4c4daa4f61eeb2bdbad27316534016f" ] [ 1000000 CHAR: a fill string>sha1str ] unit-test ! takes a long time...
+[ "dea356a2cddd90c7a7ecedc5ebb563934f460452" ] [ "0123456701234567012345670123456701234567012345670123456701234567"
+10 swap <array> concat sha1 checksum-bytes hex-string ] unit-test
+
+
[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
[
"abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index 8992299db0..6c799d7e6e 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -3,15 +3,39 @@
USING: kernel splitting grouping math sequences namespaces make
io.binary math.bitwise checksums checksums.common
sbufs strings combinators.smart math.ranges fry combinators
-accessors locals checksums.stream multiline ;
+accessors locals checksums.stream multiline literals
+generalizations ;
IN: checksums.sha2
+SINGLETON: sha1
+INSTANCE: sha1 stream-checksum
+
SINGLETON: sha-224
SINGLETON: sha-256
INSTANCE: sha-224 stream-checksum
INSTANCE: sha-256 stream-checksum
+TUPLE: sha1-state < checksum-state K H W word-size ;
+
+CONSTANT: initial-H-sha1
+ {
+ HEX: 67452301
+ HEX: efcdab89
+ HEX: 98badcfe
+ HEX: 10325476
+ HEX: c3d2e1f0
+ }
+
+CONSTANT: K-sha1
+ $[
+ 20 HEX: 5a827999 <repetition>
+ 20 HEX: 6ed9eba1 <repetition>
+ 20 HEX: 8f1bbcdc <repetition>
+ 20 HEX: ca62c1d6 <repetition>
+ 4 { } nappend-as
+ ]
+
TUPLE: sha2-state < checksum-state K H word-size ;
TUPLE: sha2-short < sha2-state ;
@@ -121,6 +145,13 @@ CONSTANT: K-384
ALIAS: K-512 K-384
+: <sha1-state> ( -- sha1-state )
+ sha1-state new-checksum-state
+ 64 >>block-size
+ K-sha1 >>K
+ initial-H-sha1 >>H
+ 4 >>word-size ;
+
: <sha-224-state> ( -- sha2-state )
sha-224-state new-checksum-state
64 >>block-size
@@ -135,6 +166,8 @@ ALIAS: K-512 K-384
initial-H-256 >>H
4 >>word-size ;
+M: sha1 initialize-checksum-state drop <sha1-state> ;
+
M: sha-224 initialize-checksum-state drop <sha-224-state> ;
M: sha-256 initialize-checksum-state drop <sha-256-state> ;
@@ -224,9 +257,6 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
-: seq>byte-array ( seq n -- string )
- '[ _ >be ] map B{ } join ;
-
:: T1-256 ( n M H sha2 -- T1 )
n M nth
n sha2 K>> nth +
@@ -272,12 +302,18 @@ GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
cloned-H T2-256
cloned-H update-H
] each
- cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
+ sha2 [ cloned-H [ w+ ] 2map ] change-H drop ; inline
M: sha2-short checksum-block
[ prepare-message-schedule ]
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
+: seq>byte-array ( seq n -- string )
+ '[ _ >be ] map B{ } join ;
+
+: sha1>checksum ( sha2 -- bytes )
+ H>> 4 seq>byte-array ;
+
: sha-224>checksum ( sha2 -- bytes )
H>> 7 head 4 seq>byte-array ;
@@ -305,3 +341,71 @@ M: sha-224 checksum-stream ( stream checksum -- byte-array )
M: sha-256 checksum-stream ( stream checksum -- byte-array )
drop
[ <sha-256-state> ] dip add-checksum-stream get-checksum ;
+
+
+
+: sha1-W ( t seq -- )
+ {
+ [ [ 3 - ] dip nth ]
+ [ [ 8 - ] dip nth bitxor ]
+ [ [ 14 - ] dip nth bitxor ]
+ [ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
+ [ ]
+ } 2cleave set-nth ;
+
+: prepare-sha1-message-schedule ( seq -- w-seq )
+ 4 <sliced-groups> [ be> ] map
+ 80 0 pad-tail 16 80 [a,b) over
+ '[ _ sha1-W ] each ; inline
+
+: sha1-f ( B C D n -- f_nbcd )
+ 20 /i
+ {
+ { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
+ { 1 [ bitxor bitxor ] }
+ { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
+ { 3 [ bitxor bitxor ] }
+ } case ;
+
+:: inner-loop ( n H W K -- temp )
+ a H nth :> A
+ b H nth :> B
+ c H nth :> C
+ d H nth :> D
+ e H nth :> E
+ [
+ A 5 bitroll-32
+
+ B C D n sha1-f
+
+ E
+
+ n K nth
+
+ n W nth
+ ] sum-outputs 32 bits ;
+
+:: process-sha1-chunk ( bytes H W K state -- )
+ 80 [
+ H W K inner-loop
+ d H nth e H set-nth
+ c H nth d H set-nth
+ b H nth 30 bitroll-32 c H set-nth
+ a H nth b H set-nth
+ a H set-nth
+ ] each
+ state [ H [ w+ ] 2map ] change-H drop ; inline
+
+M:: sha1-state checksum-block ( bytes state -- )
+ bytes prepare-sha1-message-schedule state (>>W)
+
+ bytes
+ state [ H>> clone ] [ W>> ] [ K>> ] tri state process-sha1-chunk ;
+
+M: sha1-state get-checksum
+ clone
+ [ pad-last-short-block ] [ sha-256>checksum ] bi ;
+
+M: sha1 checksum-stream ( stream checksum -- byte-array )
+ drop
+ [ <sha1-state> ] dip add-checksum-stream get-checksum ;
From b352bbdc12908cab034cc78bb3cd83c3fd38ee16 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 17 May 2009 17:58:36 -0500
Subject: [PATCH 14/23] move sha1 and sha2 to checksums.sha, update usages
---
basis/checksums/hmac/hmac-tests.factor | 3 +--
basis/checksums/hmac/hmac.factor | 7 +++----
.../interleave/interleave-tests.factor | 2 +-
basis/checksums/openssl/openssl-docs.factor | 2 +-
basis/checksums/{sha2 => sha}/authors.txt | 0
basis/checksums/sha/sha-docs.factor | 18 ++++++++++++++++++
.../sha2-tests.factor => sha/sha-tests.factor} | 4 ++--
.../{sha2/sha2.factor => sha/sha.factor} | 2 +-
basis/checksums/sha/summary.txt | 1 +
basis/checksums/sha2/sha2-docs.factor | 11 -----------
basis/checksums/sha2/summary.txt | 1 -
basis/furnace/auth/auth-docs.factor | 2 +-
basis/furnace/auth/auth.factor | 2 +-
basis/uuid/uuid.factor | 3 +--
core/checksums/checksums-docs.factor | 3 +--
extra/benchmark/sha1/sha1.factor | 2 +-
extra/ecdsa/ecdsa-tests.factor | 4 ++--
17 files changed, 35 insertions(+), 32 deletions(-)
rename basis/checksums/{sha2 => sha}/authors.txt (100%)
create mode 100644 basis/checksums/sha/sha-docs.factor
rename basis/checksums/{sha2/sha2-tests.factor => sha/sha-tests.factor} (97%)
rename basis/checksums/{sha2/sha2.factor => sha/sha.factor} (99%)
create mode 100644 basis/checksums/sha/summary.txt
delete mode 100644 basis/checksums/sha2/sha2-docs.factor
delete mode 100644 basis/checksums/sha2/summary.txt
diff --git a/basis/checksums/hmac/hmac-tests.factor b/basis/checksums/hmac/hmac-tests.factor
index 02dfc271a4..ffae146614 100755
--- a/basis/checksums/hmac/hmac-tests.factor
+++ b/basis/checksums/hmac/hmac-tests.factor
@@ -1,5 +1,5 @@
USING: kernel io strings byte-arrays sequences namespaces math
-parser checksums.hmac tools.test checksums.md5 checksums.sha2
+parser checksums.hmac tools.test checksums.md5 checksums.sha
checksums ;
IN: checksums.hmac.tests
@@ -46,4 +46,3 @@ IN: checksums.hmac.tests
"JefeJefeJefeJefeJefeJefeJefeJefe"
"what do ya want for nothing?" sha-256 hmac-bytes hex-string
] unit-test
-
diff --git a/basis/checksums/hmac/hmac.factor b/basis/checksums/hmac/hmac.factor
index 538dfc92c8..b163766016 100755
--- a/basis/checksums/hmac/hmac.factor
+++ b/basis/checksums/hmac/hmac.factor
@@ -1,9 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays checksums checksums.md5 checksums.md5.private
-checksums.sha1 combinators fry io io.binary io.encodings.binary
-io.files io.streams.byte-array kernel math math.vectors memoize
-sequences locals accessors ;
+USING: accessors arrays checksums combinators fry io io.binary
+io.encodings.binary io.files io.streams.byte-array kernel
+locals math math.vectors memoize sequences ;
IN: checksums.hmac
<PRIVATE
diff --git a/basis/checksums/interleave/interleave-tests.factor b/basis/checksums/interleave/interleave-tests.factor
index 14dddaafab..9a66e5e316 100644
--- a/basis/checksums/interleave/interleave-tests.factor
+++ b/basis/checksums/interleave/interleave-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test checksums.interleave checksums.sha2 ;
+USING: tools.test checksums.interleave checksums.sha ;
IN: checksums.interleave.tests
[
diff --git a/basis/checksums/openssl/openssl-docs.factor b/basis/checksums/openssl/openssl-docs.factor
index b0cc8f9e53..27df72c4ea 100644
--- a/basis/checksums/openssl/openssl-docs.factor
+++ b/basis/checksums/openssl/openssl-docs.factor
@@ -32,6 +32,6 @@ ARTICLE: "checksums.openssl" "OpenSSL checksums"
"An example where we compute the SHA1 checksum of a string using the OpenSSL implementation of SHA1:"
{ $example "USING: byte-arrays checksums checksums.openssl ;" "\"hello world\" >byte-array openssl-sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" }
"If we use the Factor implementation, we get the same result, just slightly slower:"
-{ $example "USING: byte-arrays checksums checksums.sha1 ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
+{ $example "USING: byte-arrays checksums checksums.sha ;" "\"hello world\" >byte-array sha1 checksum-bytes hex-string ." "\"2aae6c35c94fcfb415dbe95f408b9ce91ee846ed\"" } ;
ABOUT: "checksums.openssl"
diff --git a/basis/checksums/sha2/authors.txt b/basis/checksums/sha/authors.txt
similarity index 100%
rename from basis/checksums/sha2/authors.txt
rename to basis/checksums/sha/authors.txt
diff --git a/basis/checksums/sha/sha-docs.factor b/basis/checksums/sha/sha-docs.factor
new file mode 100644
index 0000000000..780c2b39d8
--- /dev/null
+++ b/basis/checksums/sha/sha-docs.factor
@@ -0,0 +1,18 @@
+USING: help.markup help.syntax ;
+IN: checksums.sha
+
+HELP: sha-224
+{ $class-description "SHA-224 checksum algorithm." } ;
+
+HELP: sha-256
+{ $class-description "SHA-256 checksum algorithm." } ;
+
+ARTICLE: "checksums.sha" "SHA-2 checksum"
+"The SHA family of checksum algorithms are one-way hashes useful for checksumming data. SHA-1 is considered insecure, while SHA-2 It is generally considered to be pretty strong." $nl
+"SHA-2 checksums:"
+{ $subsection sha-224 }
+{ $subsection sha-256 }
+"SHA-1 checksum:"
+{ $subsection sha1 } ;
+
+ABOUT: "checksums.sha"
diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha/sha-tests.factor
similarity index 97%
rename from basis/checksums/sha2/sha2-tests.factor
rename to basis/checksums/sha/sha-tests.factor
index fa01796ae9..b70b5e7ba2 100644
--- a/basis/checksums/sha2/sha2-tests.factor
+++ b/basis/checksums/sha/sha-tests.factor
@@ -1,6 +1,6 @@
USING: arrays kernel math namespaces sequences tools.test
-checksums.sha2 checksums ;
-IN: checksums.sha2.tests
+checksums.sha checksums ;
+IN: checksums.sha.tests
: test-checksum ( text identifier -- checksum )
checksum-bytes hex-string ;
diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha/sha.factor
similarity index 99%
rename from basis/checksums/sha2/sha2.factor
rename to basis/checksums/sha/sha.factor
index 6c799d7e6e..287c39b2a1 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha/sha.factor
@@ -5,7 +5,7 @@ io.binary math.bitwise checksums checksums.common
sbufs strings combinators.smart math.ranges fry combinators
accessors locals checksums.stream multiline literals
generalizations ;
-IN: checksums.sha2
+IN: checksums.sha
SINGLETON: sha1
INSTANCE: sha1 stream-checksum
diff --git a/basis/checksums/sha/summary.txt b/basis/checksums/sha/summary.txt
new file mode 100644
index 0000000000..2dd351af0b
--- /dev/null
+++ b/basis/checksums/sha/summary.txt
@@ -0,0 +1 @@
+SHA checksum algorithms
diff --git a/basis/checksums/sha2/sha2-docs.factor b/basis/checksums/sha2/sha2-docs.factor
deleted file mode 100644
index 6a128552fd..0000000000
--- a/basis/checksums/sha2/sha2-docs.factor
+++ /dev/null
@@ -1,11 +0,0 @@
-USING: help.markup help.syntax ;
-IN: checksums.sha2
-
-HELP: sha-256
-{ $class-description "SHA-256 checksum algorithm." } ;
-
-ARTICLE: "checksums.sha2" "SHA2 checksum"
-"The SHA2 checksum algorithm implements a one-way hash function. It is generally considered to be pretty strong."
-{ $subsection sha-256 } ;
-
-ABOUT: "checksums.sha2"
diff --git a/basis/checksums/sha2/summary.txt b/basis/checksums/sha2/summary.txt
deleted file mode 100644
index 04365d439f..0000000000
--- a/basis/checksums/sha2/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-SHA2 checksum algorithm
diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor
index 3f1bcb6085..efd6a52ef0 100644
--- a/basis/furnace/auth/auth-docs.factor
+++ b/basis/furnace/auth/auth-docs.factor
@@ -1,6 +1,6 @@
USING: assocs classes help.markup help.syntax kernel
quotations strings words words.symbol furnace.auth.providers.db
-checksums.sha2 furnace.auth.providers math byte-arrays
+checksums.sha furnace.auth.providers math byte-arrays
http multiline ;
IN: furnace.auth
diff --git a/basis/furnace/auth/auth.factor b/basis/furnace/auth/auth.factor
index b9c961941c..831ec7f8fc 100644
--- a/basis/furnace/auth/auth.factor
+++ b/basis/furnace/auth/auth.factor
@@ -3,7 +3,7 @@
USING: accessors assocs namespaces kernel sequences sets
destructors combinators fry logging
io.encodings.utf8 io.encodings.string io.binary random
-checksums checksums.sha2 urls
+checksums checksums.sha urls
html.forms
http.server
http.server.filters
diff --git a/basis/uuid/uuid.factor b/basis/uuid/uuid.factor
index 2fd6ffdaec..4d284a1a40 100644
--- a/basis/uuid/uuid.factor
+++ b/basis/uuid/uuid.factor
@@ -1,7 +1,6 @@
! Copyright (C) 2008 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-
-USING: byte-arrays checksums checksums.md5 checksums.sha1
+USING: byte-arrays checksums checksums.md5 checksums.sha
kernel math math.parser math.ranges random unicode.case
sequences strings system io.binary ;
diff --git a/core/checksums/checksums-docs.factor b/core/checksums/checksums-docs.factor
index 6ef0e85025..a05bf3a685 100644
--- a/core/checksums/checksums-docs.factor
+++ b/core/checksums/checksums-docs.factor
@@ -47,8 +47,7 @@ $nl
"Checksum implementations:"
{ $subsection "checksums.crc32" }
{ $vocab-subsection "MD5 checksum" "checksums.md5" }
-{ $vocab-subsection "SHA1 checksum" "checksums.sha1" }
-{ $vocab-subsection "SHA2 checksum" "checksums.sha2" }
+{ $vocab-subsection "SHA checksums" "checksums.sha" }
{ $vocab-subsection "Adler-32 checksum" "checksums.adler-32" }
{ $vocab-subsection "OpenSSL checksums" "checksums.openssl" } ;
diff --git a/extra/benchmark/sha1/sha1.factor b/extra/benchmark/sha1/sha1.factor
index c1a7af2966..481bc31eb2 100644
--- a/extra/benchmark/sha1/sha1.factor
+++ b/extra/benchmark/sha1/sha1.factor
@@ -1,4 +1,4 @@
-USING: checksums checksums.sha1 sequences byte-arrays kernel ;
+USING: checksums checksums.sha sequences byte-arrays kernel ;
IN: benchmark.sha1
: sha1-file ( -- )
diff --git a/extra/ecdsa/ecdsa-tests.factor b/extra/ecdsa/ecdsa-tests.factor
index b319fa297b..2d9cda1460 100644
--- a/extra/ecdsa/ecdsa-tests.factor
+++ b/extra/ecdsa/ecdsa-tests.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Maxim Savchenko
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces ecdsa tools.test checksums checksums.sha2 ;
+USING: namespaces ecdsa tools.test checksums checksums.sha ;
IN: ecdsa.tests
SYMBOLS: priv-key pub-key signature ;
@@ -27,4 +27,4 @@ SYMBOLS: priv-key pub-key signature ;
message sha-256 checksum-bytes
signature get pub-key get
"prime256v1" [ set-public-key ecdsa-verify ] with-ec
-] unit-test
\ No newline at end of file
+] unit-test
From bd8673f766b98b89ed31afc8248530e1e13bd04e Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 17 May 2009 18:05:46 -0500
Subject: [PATCH 15/23] fix multiple using warning in stage1, core can't use
io.encodings.binary
---
core/bootstrap/stage1.factor | 8 ++++----
core/checksums/checksums.factor | 4 ++--
2 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index 088a8a6320..c7be17e38d 100644
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays debugger generic hashtables io assocs kernel.private
-kernel math memory namespaces make parser prettyprint sequences
-vectors words system splitting init io.files vocabs vocabs.loader
-debugger continuations ;
+USING: arrays assocs continuations debugger generic hashtables
+init io io.files kernel kernel.private make math memory
+namespaces parser prettyprint sequences splitting system
+vectors vocabs vocabs.loader words ;
QUALIFIED: bootstrap.image.private
IN: bootstrap.stage1
diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor
index 1d57823e18..9d40521fc8 100644
--- a/core/checksums/checksums.factor
+++ b/core/checksums/checksums.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io io.backend io.files kernel math math.parser
-sequences vectors io.encodings.binary quotations ;
+sequences vectors quotations ;
IN: checksums
MIXIN: checksum
@@ -39,7 +39,7 @@ GENERIC: get-checksum ( checksum -- value )
] with-input-stream ;
: add-checksum-file ( checksum-state path -- checksum-state )
- binary <file-reader> add-checksum-stream ;
+ normalize-path (file-reader) add-checksum-stream ;
GENERIC: checksum-bytes ( bytes checksum -- value )
From efde9b8d107d41b18c90459cd9f44e660d97b067 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 17 May 2009 18:18:07 -0500
Subject: [PATCH 16/23] callstack>array was keeping an uninitialized array
around across potential GCs; add more assertions
---
vm/callstack.cpp | 15 +++++++++------
vm/local_roots.hpp | 2 +-
2 files changed, 10 insertions(+), 7 deletions(-)
diff --git a/vm/callstack.cpp b/vm/callstack.cpp
index 4ef6db10bd..608a5c39e5 100755
--- a/vm/callstack.cpp
+++ b/vm/callstack.cpp
@@ -92,7 +92,9 @@ cell frame_executing(stack_frame *frame)
else
{
array *literals = untag<array>(compiled->literals);
- return array_nth(literals,0);
+ cell executing = array_nth(literals,0);
+ check_data_pointer((object *)executing);
+ return executing;
}
}
@@ -102,6 +104,7 @@ stack_frame *frame_successor(stack_frame *frame)
return (stack_frame *)((cell)frame - frame->size);
}
+/* Allocates memory */
cell frame_scan(stack_frame *frame)
{
if(frame_type(frame) == QUOTATION_TYPE)
@@ -133,12 +136,12 @@ struct stack_frame_counter {
struct stack_frame_accumulator {
cell index;
- array *frames;
- stack_frame_accumulator(cell count) : index(0), frames(allot_array_internal<array>(count)) {}
+ gc_root<array> frames;
+ stack_frame_accumulator(cell count) : index(0), frames(allot_array(count,F)) {}
void operator()(stack_frame *frame)
{
- set_array_nth(frames,index++,frame_executing(frame));
- set_array_nth(frames,index++,frame_scan(frame));
+ set_array_nth(frames.untagged(),index++,frame_executing(frame));
+ set_array_nth(frames.untagged(),index++,frame_scan(frame));
}
};
@@ -154,7 +157,7 @@ PRIMITIVE(callstack_to_array)
stack_frame_accumulator accum(counter.count);
iterate_callstack_object(callstack.untagged(),accum);
- dpush(tag<array>(accum.frames));
+ dpush(accum.frames.value());
}
stack_frame *innermost_stack_frame(callstack *stack)
diff --git a/vm/local_roots.hpp b/vm/local_roots.hpp
index e074d999e7..4cee1c8e09 100644
--- a/vm/local_roots.hpp
+++ b/vm/local_roots.hpp
@@ -12,7 +12,7 @@ DEFPUSHPOP(gc_local_,gc_locals)
template <typename T>
struct gc_root : public tagged<T>
{
- void push() { gc_local_push((cell)this); }
+ void push() { check_tagged_pointer(tagged<T>::value()); gc_local_push((cell)this); }
explicit gc_root(cell value_) : tagged<T>(value_) { push(); }
explicit gc_root(T *value_) : tagged<T>(value_) { push(); }
From 70020d59bd879f2da83fbe3e519e871ef59b1a94 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 17 May 2009 18:41:15 -0500
Subject: [PATCH 17/23] add some unit tests testing get-checksum
---
basis/checksums/sha/sha-tests.factor | 27 +++++++++++++++++++++++++--
1 file changed, 25 insertions(+), 2 deletions(-)
diff --git a/basis/checksums/sha/sha-tests.factor b/basis/checksums/sha/sha-tests.factor
index b70b5e7ba2..be431af311 100644
--- a/basis/checksums/sha/sha-tests.factor
+++ b/basis/checksums/sha/sha-tests.factor
@@ -1,5 +1,6 @@
-USING: arrays kernel math namespaces sequences tools.test
-checksums.sha checksums ;
+USING: arrays checksums checksums.sha checksums.sha.private
+io.encodings.binary io.streams.byte-array kernel math
+namespaces sequences tools.test ;
IN: checksums.sha.tests
: test-checksum ( text identifier -- checksum )
@@ -45,3 +46,25 @@ IN: checksums.sha.tests
! [ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
! [ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] unit-test
+
+[
+ t
+] [
+ <sha1-state> "asdf" binary <byte-reader> add-checksum-stream
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
+[
+ t
+] [
+ <sha-256-state> "asdf" binary <byte-reader> add-checksum-stream
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
+[
+ t
+] [
+ <sha-224-state> "asdf" binary <byte-reader> add-checksum-stream
+ [ get-checksum ] [ get-checksum ] bi =
+] unit-test
+
From 02b769475bfbc1009fb6d2098801a4e4670b0e84 Mon Sep 17 00:00:00 2001
From: "U-C4\\Administrator" <Administrator@k.(none)>
Date: Sun, 17 May 2009 20:29:32 -0500
Subject: [PATCH 18/23] fix duplicate using lines
---
basis/cpu/x86/64/64.factor | 2 +-
basis/io/backend/windows/windows.factor | 6 +++---
core/classes/predicate/predicate-docs.factor | 2 +-
3 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index ad1b487e44..b77539b7e7 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel math namespaces make sequences
system layouts alien alien.c-types alien.accessors alien.structs
-slots splitting assocs combinators make locals cpu.x86.assembler
+slots splitting assocs combinators locals cpu.x86.assembler
cpu.x86 cpu.architecture compiler.constants
compiler.codegen compiler.codegen.fixup
compiler.cfg.instructions compiler.cfg.builder
diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor
index 9f5c00cc5f..2e9aac2ac9 100755
--- a/basis/io/backend/windows/windows.factor
+++ b/basis/io/backend/windows/windows.factor
@@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.ports io.binary io.timeouts system
-windows.errors strings kernel math namespaces sequences
-windows.errors windows.kernel32 windows.shell32 windows.types
-windows.winsock splitting continuations math.bitwise accessors ;
+strings kernel math namespaces sequences windows.errors
+windows.kernel32 windows.shell32 windows.types windows.winsock
+splitting continuations math.bitwise accessors ;
IN: io.backend.windows
: set-inherit ( handle ? -- )
diff --git a/core/classes/predicate/predicate-docs.factor b/core/classes/predicate/predicate-docs.factor
index 3ea0a24674..552ff209b8 100644
--- a/core/classes/predicate/predicate-docs.factor
+++ b/core/classes/predicate/predicate-docs.factor
@@ -1,6 +1,6 @@
USING: generic help.markup help.syntax kernel kernel.private
namespaces sequences words arrays layouts help effects math
-layouts classes.private classes compiler.units ;
+classes.private classes compiler.units ;
IN: classes.predicate
ARTICLE: "predicates" "Predicate classes"
From 349adff19eef71e7e0d5830ad4329a675b0417af Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 17 May 2009 20:32:43 -0500
Subject: [PATCH 19/23] fix checksum test -- short circuit so correct error is
reported
---
basis/checksums/openssl/openssl-tests.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/checksums/openssl/openssl-tests.factor b/basis/checksums/openssl/openssl-tests.factor
index 253069c952..2a160e1486 100644
--- a/basis/checksums/openssl/openssl-tests.factor
+++ b/basis/checksums/openssl/openssl-tests.factor
@@ -1,6 +1,6 @@
+USING: accessors byte-arrays checksums checksums.openssl
+combinators.short-circuit kernel system tools.test ;
IN: checksums.openssl.tests
-USING: byte-arrays checksums.openssl checksums tools.test
-accessors kernel system ;
[
B{ 201 238 222 100 92 200 182 188 138 255 129 163 115 88 240 136 }
@@ -22,7 +22,7 @@ accessors kernel system ;
"Bad checksum test" >byte-array
"no such checksum" <openssl-checksum>
checksum-bytes
-] [ [ unknown-digest? ] [ name>> "no such checksum" = ] bi and ]
+] [ { [ unknown-digest? ] [ name>> "no such checksum" = ] } 1&& ]
must-fail-with
[ ] [ image openssl-sha1 checksum-file drop ] unit-test
From 909082e21236821273fe01926478aa7baad122f1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 17 May 2009 23:39:05 -0500
Subject: [PATCH 20/23] tools.disassembler.gdb: remove redundant using
---
basis/tools/disassembler/gdb/gdb.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/tools/disassembler/gdb/gdb.factor b/basis/tools/disassembler/gdb/gdb.factor
index 9076b67606..c4c724b696 100755
--- a/basis/tools/disassembler/gdb/gdb.factor
+++ b/basis/tools/disassembler/gdb/gdb.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov, Jorge Acereda Macia.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.files.temp io words alien kernel math.parser
-alien.syntax io.launcher system assocs arrays sequences
+alien.syntax io.launcher assocs arrays sequences
namespaces make system math io.encodings.ascii
accessors tools.disassembler ;
IN: tools.disassembler.gdb
From 4eab045deb13696f75b01b994f5ac26c4034a022 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 18 May 2009 00:24:24 -0500
Subject: [PATCH 21/23] add nth-unsafe to sequences.private, making md5 faster
---
basis/checksums/md5/md5.factor | 42 +++++++++++++++++----------------
core/checksums/checksums.factor | 14 ++++++-----
core/sequences/sequences.factor | 3 +++
3 files changed, 33 insertions(+), 26 deletions(-)
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
index 026df34012..89ff5d46a2 100644
--- a/basis/checksums/md5/md5.factor
+++ b/basis/checksums/md5/md5.factor
@@ -4,7 +4,8 @@ USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences byte-arrays locals sequences.private macros fry
io.encodings.binary math.bitwise checksums accessors
-checksums.common checksums.stream combinators combinators.smart ;
+checksums.common checksums.stream combinators combinators.smart
+specialized-arrays.uint literals ;
IN: checksums.md5
SINGLETON: md5
@@ -16,7 +17,7 @@ TUPLE: md5-state < checksum-state state old-state ;
: <md5-state> ( -- md5 )
md5-state new-checksum-state
64 >>block-size
- { HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
+ uint-array{ HEX: 67452301 HEX: efcdab89 HEX: 98badcfe HEX: 10325476 }
[ clone >>state ] [ >>old-state ] bi ;
M: md5 initialize-checksum-state drop <md5-state> ;
@@ -29,8 +30,10 @@ M: md5 initialize-checksum-state drop <md5-state> ;
[ state>> ] [ old-state>> v-w+ dup clone ] [ ] tri
[ (>>old-state) ] [ (>>state) ] bi ; inline
-: T ( N -- Y )
- sin abs 32 2^ * >integer ; inline
+CONSTANT: T
+ $[
+ 80 iota [ sin abs 32 2^ * >integer ] uint-array{ } map-as
+ ]
:: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
@@ -70,22 +73,22 @@ CONSTANT: b 1
CONSTANT: c 2
CONSTANT: d 3
-:: (ABCD) ( x V a b c d k s i quot -- )
+:: (ABCD) ( x state a b c d k s i quot -- )
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
- a V [
- b V nth
- c V nth
- d V nth quot call w+
- k x nth w+
- i T w+
+ a state [
+ b state nth-unsafe
+ c state nth-unsafe
+ d state nth-unsafe quot call w+
+ k x nth-unsafe w+
+ i T nth-unsafe w+
s bitroll-32
- b V nth w+
- ] change-nth ; inline
+ b state nth-unsafe w+ 32 bits
+ ] change-nth-unsafe ; inline
MACRO: with-md5-round ( ops quot -- )
'[ [ _ (ABCD) ] compose ] map '[ _ 2cleave ] ;
-: (process-md5-block-F) ( block v -- )
+: (process-md5-block-F) ( block state -- )
{
[ a b c d 0 S11 1 ]
[ d a b c 1 S12 2 ]
@@ -105,7 +108,7 @@ MACRO: with-md5-round ( ops quot -- )
[ b c d a 15 S14 16 ]
} [ F ] with-md5-round ; inline
-: (process-md5-block-G) ( block v -- )
+: (process-md5-block-G) ( block state -- )
{
[ a b c d 1 S21 17 ]
[ d a b c 6 S22 18 ]
@@ -125,7 +128,7 @@ MACRO: with-md5-round ( ops quot -- )
[ b c d a 12 S24 32 ]
} [ G ] with-md5-round ; inline
-: (process-md5-block-H) ( block v -- )
+: (process-md5-block-H) ( block state -- )
{
[ a b c d 5 S31 33 ]
[ d a b c 8 S32 34 ]
@@ -145,7 +148,7 @@ MACRO: with-md5-round ( ops quot -- )
[ b c d a 2 S34 48 ]
} [ H ] with-md5-round ; inline
-: (process-md5-block-I) ( block v -- )
+: (process-md5-block-I) ( block state -- )
{
[ a b c d 0 S41 49 ]
[ d a b c 7 S42 50 ]
@@ -167,7 +170,7 @@ MACRO: with-md5-round ( ops quot -- )
M: md5-state checksum-block ( block state -- )
[
- [ 4 <groups> [ le> ] map ] [ state>> ] bi* {
+ [ byte-array>uint-array ] [ state>> ] bi* {
[ (process-md5-block-F) ]
[ (process-md5-block-G) ]
[ (process-md5-block-H) ]
@@ -177,8 +180,7 @@ M: md5-state checksum-block ( block state -- )
nip update-md5
] 2bi ;
-: md5>checksum ( md5 -- bytes )
- state>> [ 4 >le ] map B{ } concat-as ;
+: md5>checksum ( md5 -- bytes ) state>> underlying>> ;
M: md5-state clone ( md5 -- new-md5 )
call-next-method
diff --git a/core/checksums/checksums.factor b/core/checksums/checksums.factor
index 9d40521fc8..0dd808c722 100644
--- a/core/checksums/checksums.factor
+++ b/core/checksums/checksums.factor
@@ -1,17 +1,17 @@
! Copyright (c) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io io.backend io.files kernel math math.parser
-sequences vectors quotations ;
+sequences byte-arrays byte-vectors quotations ;
IN: checksums
MIXIN: checksum
-TUPLE: checksum-state bytes-read block-size bytes ;
+TUPLE: checksum-state
+ { bytes-read integer } { block-size integer } { bytes byte-vector } ;
: new-checksum-state ( class -- checksum-state )
new
- 0 >>bytes-read
- V{ } clone >>bytes ; inline
+ BV{ } clone >>bytes ; inline
M: checksum-state clone
call-next-method
@@ -27,11 +27,13 @@ GENERIC: get-checksum ( checksum -- value )
over bytes>> [ push-all ] keep
[ dup length pick block-size>> >= ]
[
- 64 cut-slice [
+ 64 cut-slice [ >byte-array ] dip [
over [ checksum-block ]
[ [ 64 + ] change-bytes-read drop ] bi
] dip
- ] while >vector [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ;
+ ] while
+ >byte-vector
+ [ >>bytes ] [ length [ + ] curry change-bytes-read ] bi ;
: add-checksum-stream ( checksum-state stream -- checksum-state )
[
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 99dddb8aed..9b0f4c1530 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -88,6 +88,9 @@ M: sequence set-nth bounds-check set-nth-unsafe ;
M: sequence nth-unsafe nth ;
M: sequence set-nth-unsafe set-nth ;
+: change-nth-unsafe ( i seq quot -- )
+ [ [ nth-unsafe ] dip call ] 3keep drop set-nth-unsafe ; inline
+
! The f object supports the sequence protocol trivially
M: f length drop 0 ;
M: f nth-unsafe nip ;
From 54cb1b968644e7d4d6b6f783dc8a3bc6aad8f68a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 18 May 2009 02:16:03 -0500
Subject: [PATCH 22/23] median used the wrong algorithm. now it runs in O(n)
time. add kth-smallest word, used to implement median
---
basis/math/statistics/statistics-tests.factor | 18 ++++++
basis/math/statistics/statistics.factor | 58 ++++++++++++++++---
2 files changed, 67 insertions(+), 9 deletions(-)
diff --git a/basis/math/statistics/statistics-tests.factor b/basis/math/statistics/statistics-tests.factor
index b6ff421956..c160d57db7 100644
--- a/basis/math/statistics/statistics-tests.factor
+++ b/basis/math/statistics/statistics-tests.factor
@@ -13,6 +13,24 @@ IN: math.statistics.tests
[ 2 ] [ { 1 2 3 } median ] unit-test
[ 5/2 ] [ { 1 2 3 4 } median ] unit-test
+[ { } median ] must-fail
+[ { } upper-median ] must-fail
+[ { } lower-median ] must-fail
+
+[ 2 ] [ { 1 2 3 4 } lower-median ] unit-test
+[ 3 ] [ { 1 2 3 4 } upper-median ] unit-test
+[ 3 ] [ { 1 2 3 4 5 } lower-median ] unit-test
+[ 3 ] [ { 1 2 3 4 5 } upper-median ] unit-test
+
+
+[ 1 ] [ { 1 } lower-median ] unit-test
+[ 1 ] [ { 1 } upper-median ] unit-test
+[ 1 ] [ { 1 } median ] unit-test
+
+[ 1 ] [ { 1 2 } lower-median ] unit-test
+[ 2 ] [ { 1 2 } upper-median ] unit-test
+[ 3/2 ] [ { 1 2 } median ] unit-test
+
[ 1 ] [ { 1 2 3 } var ] unit-test
[ 1.0 ] [ { 1 2 3 } std ] unit-test
[ t ] [ { 1 2 3 4 } ste 0.6454972243679028 - .0001 < ] unit-test
diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor
index 4cd8c5b888..5b0439906c 100644
--- a/basis/math/statistics/statistics.factor
+++ b/basis/math/statistics/statistics.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Doug Coleman, Michael Judge.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel math math.analysis
-math.functions math.order sequences sorting ;
+math.functions math.order sequences sorting locals
+sequences.private ;
IN: math.statistics
: mean ( seq -- n )
@@ -13,13 +14,55 @@ IN: math.statistics
: harmonic-mean ( seq -- n )
[ recip ] sigma recip ;
-: median ( seq -- n )
+: slow-median ( seq -- n )
natural-sort dup length even? [
[ midpoint@ dup 1 - 2array ] keep nths mean
] [
[ midpoint@ ] keep nth
] if ;
+:: kth-smallest ( seq k -- elt )
+ #! Wirth's method, Algorithm's + Data structues = Programs p. 84
+ #! The algorithm modifiers seq, so we clone it
+ seq clone :> seq
+ 0 :> i!
+ 0 :> j!
+ 0 :> l!
+ 0 :> x!
+ seq length 1 - :> m!
+ [ l m < ]
+ [
+ k seq nth x!
+ l i!
+ m j!
+ [ i j <= ]
+ [
+ [ i seq nth-unsafe x < ] [ i 1 + i! ] while
+ [ x j seq nth-unsafe < ] [ j 1 - j! ] while
+ i j <= [
+ i j seq exchange
+ i 1 + i!
+ j 1 - j!
+ ] when
+ ] do while
+
+ j k < [ i l! ] when
+ k i < [ j m! ] when
+ ] while
+ k seq nth ; inline
+
+: lower-median ( seq -- elt )
+ dup dup length odd? [ midpoint@ ] [ midpoint@ 1 - ] if kth-smallest ;
+
+: upper-median ( seq -- elt )
+ dup midpoint@ kth-smallest ;
+
+: medians ( seq -- lower upper )
+ [ lower-median ] [ upper-median ] bi ;
+
+: median ( seq -- x )
+ dup length odd? [ lower-median ] [ medians + 2 / ] if ;
+
: minmax ( seq -- min max )
#! find the min and max of a seq in one pass
[ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ;
@@ -32,15 +75,13 @@ IN: math.statistics
dup length 1 <= [
drop 0
] [
- [ [ mean ] keep [ - sq ] with sigma ] keep
- length 1 - /
+ [ [ mean ] keep [ - sq ] with sigma ]
+ [ length 1 - ] bi /
] if ;
-: std ( seq -- x )
- var sqrt ;
+: std ( seq -- x ) var sqrt ;
-: ste ( seq -- x )
- [ std ] [ length ] bi sqrt / ;
+: ste ( seq -- x ) [ std ] [ length ] bi sqrt / ;
: ((r)) ( mean(x) mean(y) {x} {y} -- (r) )
! finds sigma((xi-mean(x))(yi-mean(y))
@@ -64,4 +105,3 @@ IN: math.statistics
[ (r) ] 2keep ! stack is mean(x) mean(y) r sx sy
swap / * ! stack is mean(x) mean(y) beta
[ swapd * - ] keep ;
-
From c045823182821f8b99540f37045585e7955eeab9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 18 May 2009 02:41:58 -0500
Subject: [PATCH 23/23] remove old median, fix docs
---
basis/math/statistics/statistics-docs.factor | 10 +++++-----
basis/math/statistics/statistics.factor | 15 ++++-----------
2 files changed, 9 insertions(+), 16 deletions(-)
diff --git a/basis/math/statistics/statistics-docs.factor b/basis/math/statistics/statistics-docs.factor
index 7a7eb70dd2..1a29d611f9 100644
--- a/basis/math/statistics/statistics-docs.factor
+++ b/basis/math/statistics/statistics-docs.factor
@@ -2,26 +2,26 @@ USING: help.markup help.syntax debugger ;
IN: math.statistics
HELP: geometric-mean
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the geometric mean of all elements in " { $snippet "seq" } ". The geometric mean measures the central tendency of a data set that minimizes the effects of extreme values." }
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } geometric-mean ." "1.81712059283214" } }
{ $errors "Throws a " { $link signal-error. } " (square-root of 0) if the sequence is empty." } ;
HELP: harmonic-mean
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the harmonic mean of the elements in " { $snippet "seq" } ". The harmonic mean is appropriate when the average of rates is desired." }
{ $notes "Positive reals only." }
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } harmonic-mean ." "6/11" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: mean
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the arithmetic mean of all elements in " { $snippet "seq" } "." }
{ $examples { $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } mean ." "2" } }
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: median
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the median of " { $snippet "seq" } " by sorting the sequence from lowest value to highest and outputting the middle one. If there is an even number of elements in the sequence, the median is not unique, so the mean of the two middle values is outputted." }
{ $examples
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } median ." "2" }
@@ -29,7 +29,7 @@ HELP: median
{ $errors "Throws a " { $link signal-error. } " (divide by zero) if the sequence is empty." } ;
HELP: range
-{ $values { "seq" "a sequence of numbers" } { "n" "a non-negative real number"} }
+{ $values { "seq" "a sequence of numbers" } { "x" "a non-negative real number"} }
{ $description "Computes the distance of the maximum and minimum values in " { $snippet "seq" } "." }
{ $examples
{ $example "USING: math.statistics prettyprint ;" "{ 1 2 3 } range ." "2" }
diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor
index 5b0439906c..3812e79ec5 100644
--- a/basis/math/statistics/statistics.factor
+++ b/basis/math/statistics/statistics.factor
@@ -5,22 +5,15 @@ math.functions math.order sequences sorting locals
sequences.private ;
IN: math.statistics
-: mean ( seq -- n )
+: mean ( seq -- x )
[ sum ] [ length ] bi / ;
-: geometric-mean ( seq -- n )
+: geometric-mean ( seq -- x )
[ length ] [ product ] bi nth-root ;
-: harmonic-mean ( seq -- n )
+: harmonic-mean ( seq -- x )
[ recip ] sigma recip ;
-: slow-median ( seq -- n )
- natural-sort dup length even? [
- [ midpoint@ dup 1 - 2array ] keep nths mean
- ] [
- [ midpoint@ ] keep nth
- ] if ;
-
:: kth-smallest ( seq k -- elt )
#! Wirth's method, Algorithm's + Data structues = Programs p. 84
#! The algorithm modifiers seq, so we clone it
@@ -67,7 +60,7 @@ IN: math.statistics
#! find the min and max of a seq in one pass
[ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ;
-: range ( seq -- n )
+: range ( seq -- x )
minmax swap - ;
: var ( seq -- x )