From 1e7506f7c1ee92576d403308f47d0504e8ed1106 Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Thu, 7 May 2009 10:32:32 +0200
Subject: [PATCH 01/68] reworked insert, save and update; added save-deep

---
 extra/mongodb/tuple/tuple.factor | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor
index 9173957979..e5e4867d71 100644
--- a/extra/mongodb/tuple/tuple.factor
+++ b/extra/mongodb/tuple/tuple.factor
@@ -54,14 +54,22 @@ M: mdb-persistent id-selector
            <update> >upsert update ] assoc-each ; inline
 PRIVATE>
  
-: save-tuple ( tuple -- )
-   tuple>storable [ (save-tuples) ] assoc-each ;
+: save-tuple-deep ( tuple -- )
+    tuple>storable [ (save-tuples) ] assoc-each ; 
  
 : update-tuple ( tuple -- )
-   save-tuple ;
+    [ tuple-collection name>> ]
+    [ id-selector ]
+    [ tuple>assoc ] tri
+    <mdb-update-msg> update ;
+
+: save-tuple ( tuple -- )
+    update-tuple ;
 
 : insert-tuple ( tuple -- )
-   save-tuple ;
+   [ tuple-collection name>> ]
+   [ tuple>assoc ] bi
+   <mdb-insert-msg> save ;
 
 : delete-tuple ( tuple -- )
    [ tuple-collection name>> ] keep

From d047c5110f8991b7364fe708463452dccd05dae9 Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Thu, 7 May 2009 12:01:01 +0200
Subject: [PATCH 02/68] some bug fixes

---
 extra/mongodb/tuple/collection/collection.factor | 4 +++-
 extra/mongodb/tuple/tuple.factor                 | 2 +-
 2 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor
index 1bd2d94e69..60b2d25764 100644
--- a/extra/mongodb/tuple/collection/collection.factor
+++ b/extra/mongodb/tuple/collection/collection.factor
@@ -92,6 +92,8 @@ GENERIC: mdb-index-map ( tuple -- sequence )
       [ ] [ name>> ] bi  H{ } clone [ set-at ] keep
     ] [ 2drop H{ } clone ] if ;
 
+
+
 PRIVATE>
 
 : MDB_ADDON_SLOTS ( -- slots )
@@ -116,7 +118,7 @@ PRIVATE>
     [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline
 
 : set-index-map ( class index-list -- )
-    [ [ dup user-defined-key-index ] dip index-list>map  ] output>sequence
+    [ dup user-defined-key-index ] dip index-list>map 2array
     assoc-combine MDB_INDEX_MAP set-word-prop ; inline
 
 M: tuple-class tuple-collection ( tuple -- mdb-collection )
diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor
index e5e4867d71..8f7504d9bc 100644
--- a/extra/mongodb/tuple/tuple.factor
+++ b/extra/mongodb/tuple/tuple.factor
@@ -69,7 +69,7 @@ PRIVATE>
 : insert-tuple ( tuple -- )
    [ tuple-collection name>> ]
    [ tuple>assoc ] bi
-   <mdb-insert-msg> save ;
+   save ;
 
 : delete-tuple ( tuple -- )
    [ tuple-collection name>> ] keep

From a2abe1753f763b777a7d5e10d0d65d572442acb4 Mon Sep 17 00:00:00 2001
From: Diego Martinelli <martinelli.diego@gmail.com>
Date: Fri, 8 May 2009 10:33:20 +0200
Subject: [PATCH 03/68] Initial commit

---
 extra/hashcash/authors.txt     | 0
 extra/hashcash/hashcash.factor | 4 ++++
 2 files changed, 4 insertions(+)
 create mode 100755 extra/hashcash/authors.txt
 create mode 100755 extra/hashcash/hashcash.factor

diff --git a/extra/hashcash/authors.txt b/extra/hashcash/authors.txt
new file mode 100755
index 0000000000..e69de29bb2
diff --git a/extra/hashcash/hashcash.factor b/extra/hashcash/hashcash.factor
new file mode 100755
index 0000000000..fe7cf10bd3
--- /dev/null
+++ b/extra/hashcash/hashcash.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: hashcash

From 660bb079ae61f01191539e99861950b627f59514 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 09:51:57 -0500
Subject: [PATCH 04/68] cleaning up sha2

---
 basis/checksums/sha2/sha2.factor | 28 ++++++++++++++++------------
 1 file changed, 16 insertions(+), 12 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index 3b092a78de..b4b787a2b7 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -2,12 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings ;
+sbufs strings combinators.smart ;
 IN: checksums.sha2
 
 <PRIVATE
 
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
+SYMBOLS: vars K H process-M word-size block-size ;
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -18,13 +18,13 @@ CONSTANT: f 5
 CONSTANT: g 6
 CONSTANT: h 7
 
-: initial-H-256 ( -- seq )
+CONSTANT: initial-H-256
     {
         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
-    } ;
+    }
 
-: K-256 ( -- seq )
+CONSTANT: K-256
     {
         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
         HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
@@ -42,17 +42,21 @@ CONSTANT: h 7
         HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
         HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
-    } ;
+    }
 
 : s0-256 ( x -- x' )
-    [ -7 bitroll-32 ] keep
-    [ -18 bitroll-32 ] keep
-    -3 shift bitxor bitxor ; inline
+    [
+        [ -7 bitroll-32 ]
+        [ -18 bitroll-32 ]
+        [ -3 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : s1-256 ( x -- x' )
-    [ -17 bitroll-32 ] keep
-    [ -19 bitroll-32 ] keep
-    -10 shift bitxor bitxor ; inline
+    [
+        [ -17 bitroll-32 ]
+        [ -19 bitroll-32 ]
+        [ -10 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : process-M-256 ( seq n -- )
     [ 16 - swap nth ] 2keep

From 3f5e93d29a9fc953abc1ac75b9ae3e66fa83f604 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 10:04:31 -0500
Subject: [PATCH 05/68] more refactoring on sha2

---
 basis/checksums/sha2/sha2.factor | 40 ++++++++++++++++++--------------
 1 file changed, 22 insertions(+), 18 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index b4b787a2b7..57a1db5ac1 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings combinators.smart ;
+sbufs strings combinators.smart math.ranges fry combinators ;
 IN: checksums.sha2
 
 <PRIVATE
@@ -58,34 +58,38 @@ CONSTANT: K-256
         [ -10 shift ] tri
     ] [ bitxor ] reduce-outputs ; inline
 
-: process-M-256 ( seq n -- )
-    [ 16 - swap nth ] 2keep
-    [ 15 - swap nth s0-256 ] 2keep
-    [ 7 - swap nth ] 2keep
-    [ 2 - swap nth s1-256 ] 2keep
-    [ + + w+ ] 2dip swap set-nth ; inline
+: process-M-256 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
 
 : prepare-message-schedule ( seq -- w-seq )
     word-size get group [ be> ] map block-size get 0 pad-tail
-    dup 16 64 dup <slice> [
-        process-M-256
-    ] with each ;
+    16 64 [a,b) over '[ _ process-M-256 ] each ;
 
 : ch ( x y z -- x' )
     [ bitxor bitand ] keep bitxor ;
 
 : maj ( x y z -- x' )
-    [ [ bitand ] 2keep bitor ] dip bitand bitor ;
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
 
 : S0-256 ( x -- x' )
-    [ -2 bitroll-32 ] keep
-    [ -13 bitroll-32 ] keep
-    -22 bitroll-32 bitxor bitxor ; inline
+    [
+        [ -2 bitroll-32 ]
+        [ -13 bitroll-32 ]
+        [ -22 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : S1-256 ( x -- x' )
-    [ -6 bitroll-32 ] keep
-    [ -11 bitroll-32 ] keep
-    -25 bitroll-32 bitxor bitxor ; inline
+    [
+        [ -6 bitroll-32 ]
+        [ -11 bitroll-32 ]
+        [ -25 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
 
@@ -118,7 +122,7 @@ CONSTANT: K-256
     ] with each vars get H get [ w+ ] 2map H set ;
 
 : seq>byte-array ( n seq -- string )
-    [ swap [ >be % ] curry each ] B{ } make ;
+    [ swap '[ _ >be % ] each ] B{ } make ;
 
 : preprocess-plaintext ( string big-endian? -- padded-string )
     #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits

From 0fe5aaf5f86f3559a185a0d0909959661bf5e576 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 10:52:25 -0500
Subject: [PATCH 06/68] more refactoring on sha2

---
 basis/checksums/sha2/sha2.factor | 114 +++++++++++++++++--------------
 1 file changed, 62 insertions(+), 52 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index 57a1db5ac1..cd67418516 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -2,12 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings combinators.smart math.ranges fry combinators ;
+sbufs strings combinators.smart math.ranges fry combinators
+accessors ;
 IN: checksums.sha2
 
 <PRIVATE
 
-SYMBOLS: vars K H process-M word-size block-size ;
+SYMBOLS: H word-size block-size ;
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -58,25 +59,6 @@ CONSTANT: K-256
         [ -10 shift ] tri
     ] [ bitxor ] reduce-outputs ; inline
 
-: process-M-256 ( n seq -- )
-    {
-        [ [ 16 - ] dip nth ]
-        [ [ 15 - ] dip nth s0-256 ]
-        [ [ 7 - ] dip nth ]
-        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
-        [ ]
-    } 2cleave set-nth ; inline
-
-: prepare-message-schedule ( seq -- w-seq )
-    word-size get group [ be> ] map block-size get 0 pad-tail
-    16 64 [a,b) over '[ _ process-M-256 ] each ;
-
-: ch ( x y z -- x' )
-    [ bitxor bitand ] keep bitxor ;
-
-: maj ( x y z -- x' )
-    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
-
 : S0-256 ( x -- x' )
     [
         [ -2 bitroll-32 ]
@@ -91,21 +73,42 @@ CONSTANT: K-256
         [ -25 bitroll-32 ] tri
     ] [ bitxor ] reduce-outputs ; inline
 
-: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
+: process-M-256 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
 
-: T1 ( W n -- T1 )
-    [ swap nth ] keep
-    K get nth +
-    e vars get slice3 ch +
-    e vars get nth S1-256 +
-    h vars get nth w+ ;
+: ch ( x y z -- x' )
+    [ bitxor bitand ] keep bitxor ;
 
-: T2 ( -- T2 )
-    a vars get nth S0-256
-    a vars get slice3 maj w+ ;
+: maj ( x y z -- x' )
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
 
-: update-vars ( T1 T2 -- )
-    vars get
+: prepare-message-schedule ( seq -- w-seq )
+    word-size get <sliced-groups> [ be> ] map block-size get 0 pad-tail
+    16 64 [a,b) over '[ _ process-M-256 ] each ;
+
+: slice3 ( n seq -- a b c )
+    [ dup 3 + ] dip <slice> first3 ; inline
+
+: T1 ( W n H -- T1 )
+    [
+        [ swap nth ] keep
+        K-256 nth +
+    ] dip
+    [ e swap slice3 ch w+ ]
+    [ e swap nth S1-256 w+ ]
+    [ h swap nth w+ ] tri ;
+
+: T2 ( H -- T2 )
+    [ a swap nth S0-256 ]
+    [ a swap slice3 maj w+ ] bi ;
+
+: update-H ( T1 T2 H -- )
     h g pick exchange
     g f pick exchange
     f e pick exchange
@@ -115,28 +118,35 @@ CONSTANT: K-256
     b a pick exchange
     [ w+ a ] dip set-nth ;
 
-: process-chunk ( M -- )
-    H get clone vars set
-    prepare-message-schedule block-size get [
-        T1 T2 update-vars
-    ] with each vars get H get [ w+ ] 2map H set ;
+: process-chunk ( M block-size H-cloned -- )
+    [
+        '[
+            _
+            [ T1 ]
+            [ T2 ]
+            [ update-H ] tri 
+        ] with each
+    ] keep H get [ w+ ] 2map H set ;
 
-: seq>byte-array ( n seq -- string )
-    [ swap '[ _ >be % ] each ] B{ } make ;
-
-: preprocess-plaintext ( string big-endian? -- padded-string )
-    #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
-    [ >sbuf ] dip over [
+: pad-initial-bytes ( string -- padded-string )
+    dup [
         HEX: 80 ,
-        dup length HEX: 3f bitand
-        calculate-pad-length 0 <string> %
-        length 3 shift 8 rot [ >be ] [ >le ] if %
-    ] "" make over push-all ;
+        length 
+        [ HEX: 3f bitand calculate-pad-length 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+: seq>byte-array ( seq n -- string )
+    '[ _ >be ] map B{ } join ;
 
 : byte-array>sha2 ( byte-array -- string )
-    t preprocess-plaintext
-    block-size get group [ process-chunk ] each
-    4 H get seq>byte-array ;
+    pad-initial-bytes
+    block-size get <sliced-groups>
+    [
+        prepare-message-schedule
+        block-size get H get clone process-chunk
+    ] each
+    H get 4 seq>byte-array ;
 
 PRIVATE>
 
@@ -146,9 +156,9 @@ INSTANCE: sha-256 checksum
 
 M: sha-256 checksum-bytes
     drop [
-        K-256 K set
         initial-H-256 H set
         4 word-size set
         64 block-size set
         byte-array>sha2
+
     ] with-scope ;

From 3292ceaf46bb7695a7924a9e87ae7e79bb02a876 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 17:18:43 -0500
Subject: [PATCH 07/68] move sha2 state to a tuple

---
 basis/checksums/sha2/sha2.factor | 36 +++++++++++++++++++-------------
 1 file changed, 22 insertions(+), 14 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index cd67418516..ff19c4c9a8 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -8,7 +8,7 @@ IN: checksums.sha2
 
 <PRIVATE
 
-SYMBOLS: H word-size block-size ;
+SYMBOL: sha2
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -89,7 +89,7 @@ CONSTANT: K-256
     [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
 
 : prepare-message-schedule ( seq -- w-seq )
-    word-size get <sliced-groups> [ be> ] map block-size get 0 pad-tail
+    sha2 get word-size>> <sliced-groups> [ be> ] map sha2 get block-size>> 0 pad-tail
     16 64 [a,b) over '[ _ process-M-256 ] each ;
 
 : slice3 ( n seq -- a b c )
@@ -98,7 +98,7 @@ CONSTANT: K-256
 : T1 ( W n H -- T1 )
     [
         [ swap nth ] keep
-        K-256 nth +
+        sha2 get K>> nth +
     ] dip
     [ e swap slice3 ch w+ ]
     [ e swap nth S1-256 w+ ]
@@ -126,7 +126,7 @@ CONSTANT: K-256
             [ T2 ]
             [ update-H ] tri 
         ] with each
-    ] keep H get [ w+ ] 2map H set ;
+    ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ;
 
 : pad-initial-bytes ( string -- padded-string )
     dup [
@@ -141,12 +141,12 @@ CONSTANT: K-256
 
 : byte-array>sha2 ( byte-array -- string )
     pad-initial-bytes
-    block-size get <sliced-groups>
+    sha2 get block-size>> <sliced-groups>
     [
         prepare-message-schedule
-        block-size get H get clone process-chunk
+        sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk
     ] each
-    H get 4 seq>byte-array ;
+    sha2 get H>> 4 seq>byte-array ;
 
 PRIVATE>
 
@@ -154,11 +154,19 @@ SINGLETON: sha-256
 
 INSTANCE: sha-256 checksum
 
-M: sha-256 checksum-bytes
-    drop [
-        initial-H-256 H set
-        4 word-size set
-        64 block-size set
-        byte-array>sha2
+TUPLE: sha2-state K H word-size block-size ;
 
-    ] with-scope ;
+TUPLE: sha-256-state < sha2-state ;
+
+: <sha-256-state> ( -- sha2-state )
+    sha-256-state new
+        K-256 >>K
+        initial-H-256 >>H
+        4 >>word-size
+        64 >>block-size ; 
+
+M: sha-256 checksum-bytes
+    drop
+    <sha-256-state> sha2 [
+        byte-array>sha2
+    ] with-variable ;

From 884fdc8ceb497a94e478d14d162b36959fe0dbb5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 17:39:11 -0500
Subject: [PATCH 08/68] remove dynamic variables from sha2

---
 basis/checksums/sha2/sha2.factor | 89 +++++++++++++++-----------------
 1 file changed, 41 insertions(+), 48 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index ff19c4c9a8..d019a6913b 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -3,7 +3,7 @@
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
 sbufs strings combinators.smart math.ranges fry combinators
-accessors ;
+accessors locals ;
 IN: checksums.sha2
 
 <PRIVATE
@@ -83,26 +83,31 @@ CONSTANT: K-256
     } 2cleave set-nth ; inline
 
 : ch ( x y z -- x' )
-    [ bitxor bitand ] keep bitxor ;
+    [ bitxor bitand ] keep bitxor ; inline
 
 : maj ( x y z -- x' )
-    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
-
-: prepare-message-schedule ( seq -- w-seq )
-    sha2 get word-size>> <sliced-groups> [ be> ] map sha2 get block-size>> 0 pad-tail
-    16 64 [a,b) over '[ _ process-M-256 ] each ;
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
 
 : slice3 ( n seq -- a b c )
     [ dup 3 + ] dip <slice> first3 ; inline
 
-: T1 ( W n H -- T1 )
-    [
-        [ swap nth ] keep
-        sha2 get K>> nth +
-    ] dip
-    [ e swap slice3 ch w+ ]
-    [ e swap nth S1-256 w+ ]
-    [ h swap nth w+ ] tri ;
+: pad-initial-bytes ( string -- padded-string )
+    dup [
+        HEX: 80 ,
+        length
+        [ HEX: 3f bitand calculate-pad-length 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+: seq>byte-array ( seq n -- string )
+    '[ _ >be ] map B{ } join ;
+
+:: T1 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-256 w+
+    h H nth w+ ;
 
 : T2 ( H -- T2 )
     [ a swap nth S0-256 ]
@@ -116,37 +121,28 @@ CONSTANT: K-256
     d c pick exchange
     c b pick exchange
     b a pick exchange
-    [ w+ a ] dip set-nth ;
+    [ w+ a ] dip set-nth ; inline
 
-: process-chunk ( M block-size H-cloned -- )
-    [
-        '[
-            _
-            [ T1 ]
-            [ T2 ]
-            [ update-H ] tri 
-        ] with each
-    ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ;
+: prepare-message-schedule ( seq sha2 -- w-seq )
+    [ word-size>> <sliced-groups> [ be> ] map ]
+    [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ;
 
-: pad-initial-bytes ( string -- padded-string )
-    dup [
-        HEX: 80 ,
-        length 
-        [ HEX: 3f bitand calculate-pad-length 0 <string> % ]
-        [ 3 shift 8 >be % ] bi
-    ] "" make append ;
-
-: seq>byte-array ( seq n -- string )
-    '[ _ >be ] map B{ } join ;
-
-: byte-array>sha2 ( byte-array -- string )
-    pad-initial-bytes
-    sha2 get block-size>> <sliced-groups>
-    [
-        prepare-message-schedule
-        sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk
+:: process-chunk ( M block-size cloned-H sha2 -- )
+    block-size [
+        M cloned-H sha2 T1
+        cloned-H T2
+        cloned-H update-H 
     ] each
-    sha2 get H>> 4 seq>byte-array ;
+    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ;
+
+:: byte-array>sha2 ( bytes state -- string )
+    bytes pad-initial-bytes
+    state block-size>> <sliced-groups>
+    [
+        state prepare-message-schedule
+        state [ block-size>> ] [ H>> clone ] bi state process-chunk
+    ] each
+    state H>> 4 seq>byte-array ;
 
 PRIVATE>
 
@@ -163,10 +159,7 @@ TUPLE: sha-256-state < sha2-state ;
         K-256 >>K
         initial-H-256 >>H
         4 >>word-size
-        64 >>block-size ; 
+        64 >>block-size ;
 
 M: sha-256 checksum-bytes
-    drop
-    <sha-256-state> sha2 [
-        byte-array>sha2
-    ] with-variable ;
+    drop <sha-256-state> byte-array>sha2 ;

From 5451d8f97675193b7e574d71a22bb814fae14c08 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 18:11:13 -0500
Subject: [PATCH 09/68] support sha-224, add constants for all sha2

---
 basis/checksums/sha2/sha2-tests.factor |  43 ++++++++--
 basis/checksums/sha2/sha2.factor       | 108 +++++++++++++++++++++----
 2 files changed, 130 insertions(+), 21 deletions(-)

diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor
index 2f4e3c51c4..1476f04e75 100644
--- a/basis/checksums/sha2/sha2-tests.factor
+++ b/basis/checksums/sha2/sha2-tests.factor
@@ -1,7 +1,36 @@
-USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
+USING: arrays kernel math namespaces sequences tools.test
+checksums.sha2 checksums ;
+IN: checksums.sha2.tests
+
+: test-checksum ( text identifier -- checksum )
+    checksum-bytes hex-string ;
+
+[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
+[
+    "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
+    sha-224 test-checksum
+] unit-test
+
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
+[ "" sha-256 test-checksum ] unit-test
+
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
+[ "abc" sha-256 test-checksum ] unit-test
+
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
+[ "message digest" sha-256 test-checksum ] unit-test
+
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
+[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
+
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
+[
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+    sha-256 test-checksum
+] unit-test
+
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
+[
+    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+    sha-256 test-checksum
+] unit-test
diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index d019a6913b..6a695b0965 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -19,12 +19,42 @@ CONSTANT: f 5
 CONSTANT: g 6
 CONSTANT: h 7
 
+CONSTANT: initial-H-224
+    {
+        HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
+        HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
+    }
+
 CONSTANT: initial-H-256
     {
         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
     }
 
+CONSTANT: initial-H-384
+    {
+        HEX: cbbb9d5dc1059ed8
+        HEX: 629a292a367cd507
+        HEX: 9159015a3070dd17
+        HEX: 152fecd8f70e5939
+        HEX: 67332667ffc00b31
+        HEX: 8eb44a8768581511
+        HEX: db0c2e0d64f98fa7
+        HEX: 47b5481dbefa4fa4
+    }
+
+CONSTANT: initial-H-512
+    {
+        HEX: 6a09e667f3bcc908
+        HEX: bb67ae8584caa73b
+        HEX: 3c6ef372fe94f82b
+        HEX: a54ff53a5f1d36f1
+        HEX: 510e527fade682d1
+        HEX: 9b05688c2b3e6c1f
+        HEX: 1f83d9abfb41bd6b
+        HEX: 5be0cd19137e2179
+    }
+
 CONSTANT: K-256
     {
         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
@@ -45,6 +75,29 @@ CONSTANT: K-256
         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
     }
 
+CONSTANT: K-384
+    {
+        HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 
+        HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 
+        HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 
+        HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 
+        HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 
+        HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df 
+        HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b 
+        HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 
+        HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 
+        HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 
+        HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 
+        HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec 
+        HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b 
+        HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 
+        HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b 
+        HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c 
+        HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
+    }
+
+ALIAS: K-512 K-384
+
 : s0-256 ( x -- x' )
     [
         [ -7 bitroll-32 ]
@@ -107,11 +160,11 @@ CONSTANT: K-256
     n sha2 K>> nth +
     e H slice3 ch w+
     e H nth S1-256 w+
-    h H nth w+ ;
+    h H nth w+ ; inline
 
 : T2 ( H -- T2 )
     [ a swap nth S0-256 ]
-    [ a swap slice3 maj w+ ] bi ;
+    [ a swap slice3 maj w+ ] bi ; inline
 
 : update-H ( T1 T2 H -- )
     h g pick exchange
@@ -125,33 +178,53 @@ CONSTANT: K-256
 
 : prepare-message-schedule ( seq sha2 -- w-seq )
     [ word-size>> <sliced-groups> [ be> ] map ]
-    [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ;
+    [
+        block-size>> 0 pad-tail 16 64 [a,b) over
+        '[ _ process-M-256 ] each
+    ] bi ; inline
 
 :: process-chunk ( M block-size cloned-H sha2 -- )
     block-size [
         M cloned-H sha2 T1
         cloned-H T2
-        cloned-H update-H 
+        cloned-H update-H
     ] each
-    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ;
+    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
 
-:: byte-array>sha2 ( bytes state -- string )
-    bytes pad-initial-bytes
-    state block-size>> <sliced-groups>
-    [
-        state prepare-message-schedule
-        state [ block-size>> ] [ H>> clone ] bi state process-chunk
-    ] each
-    state H>> 4 seq>byte-array ;
+: sha2-steps ( sliced-groups state -- )
+    '[
+        _
+        [ prepare-message-schedule ]
+        [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
+    ] each ;
+
+: byte-array>sha2 ( bytes state -- )
+    [ [ pad-initial-bytes ] [ block-size>> ] bi* <sliced-groups> ]
+    [ sha2-steps ] bi ;
 
 PRIVATE>
 
+SINGLETON: sha-224
 SINGLETON: sha-256
+SINGLETON: sha-384
+SINGLETON: sha-512
 
+INSTANCE: sha-224 checksum
 INSTANCE: sha-256 checksum
+INSTANCE: sha-384 checksum
+INSTANCE: sha-512 checksum
 
 TUPLE: sha2-state K H word-size block-size ;
 
+TUPLE: sha-224-state < sha2-state ;
+
+: <sha-224-state> ( -- sha2-state )
+    sha-224-state new
+        K-256 >>K
+        initial-H-224 >>H
+        4 >>word-size
+        64 >>block-size ;
+
 TUPLE: sha-256-state < sha2-state ;
 
 : <sha-256-state> ( -- sha2-state )
@@ -161,5 +234,12 @@ TUPLE: sha-256-state < sha2-state ;
         4 >>word-size
         64 >>block-size ;
 
+M: sha-224 checksum-bytes
+    drop <sha-224-state>
+    [ byte-array>sha2 ]
+    [ H>> 7 head 4 seq>byte-array ] bi ;
+
 M: sha-256 checksum-bytes
-    drop <sha-256-state> byte-array>sha2 ;
+    drop <sha-256-state>
+    [ byte-array>sha2 ]
+    [ H>> 4 seq>byte-array ] bi ;

From c0a3ef631a8d2b028cfd1ad2c79bcbaa2ae1dd27 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 19:00:06 -0500
Subject: [PATCH 10/68] implementing sha2 512

---
 basis/checksums/common/common.factor   |  3 +
 basis/checksums/sha2/sha2-tests.factor |  6 ++
 basis/checksums/sha2/sha2.factor       | 93 +++++++++++++++++++-------
 3 files changed, 78 insertions(+), 24 deletions(-)

diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor
index 0ae4328446..01cc2cb739 100644
--- a/basis/checksums/common/common.factor
+++ b/basis/checksums/common/common.factor
@@ -9,6 +9,9 @@ SYMBOL: bytes-read
 : calculate-pad-length ( length -- length' )
     [ 56 < 55 119 ? ] keep - ;
 
+: calculate-pad-length-long ( length -- length' )
+    [ 112 < 111 249 ? ] keep - ;
+
 : pad-last-block ( str big-endian? length -- str )
     [
         [ % ] 2dip HEX: 80 ,
diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor
index 1476f04e75..f224d497a6 100644
--- a/basis/checksums/sha2/sha2-tests.factor
+++ b/basis/checksums/sha2/sha2-tests.factor
@@ -34,3 +34,9 @@ IN: checksums.sha2.tests
     "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
     sha-256 test-checksum
 ] 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 6a695b0965..1abed088a3 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -6,9 +6,31 @@ sbufs strings combinators.smart math.ranges fry combinators
 accessors locals ;
 IN: checksums.sha2
 
-<PRIVATE
+SINGLETON: sha-224
+SINGLETON: sha-256
+SINGLETON: sha-384
+SINGLETON: sha-512
 
-SYMBOL: sha2
+INSTANCE: sha-224 checksum
+INSTANCE: sha-256 checksum
+INSTANCE: sha-384 checksum
+INSTANCE: sha-512 checksum
+
+TUPLE: sha2-state K H word-size block-size ;
+
+TUPLE: sha2-short < sha2-state ;
+
+TUPLE: sha2-long < sha2-state ;
+
+TUPLE: sha-224-state < sha2-short ;
+
+TUPLE: sha-256-state < sha2-short ;
+
+TUPLE: sha-384-state < sha2-long ;
+
+TUPLE: sha-512-state < sha2-long ;
+
+<PRIVATE
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -77,6 +99,10 @@ CONSTANT: K-256
 
 CONSTANT: K-384
     {
+
+        HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc 
+        HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118 
+        HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
         HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 
         HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 
         HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 
@@ -144,14 +170,25 @@ ALIAS: K-512 K-384
 : slice3 ( n seq -- a b c )
     [ dup 3 + ] dip <slice> first3 ; inline
 
-: pad-initial-bytes ( string -- padded-string )
+GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
+
+M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
+    drop
     dup [
         HEX: 80 ,
         length
-        [ HEX: 3f bitand calculate-pad-length 0 <string> % ]
+        [ 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 16 >be % ] bi
+    ] "" make append ;
+
 : seq>byte-array ( seq n -- string )
     '[ _ >be ] map B{ } join ;
 
@@ -179,7 +216,7 @@ ALIAS: K-512 K-384
 : prepare-message-schedule ( seq sha2 -- w-seq )
     [ word-size>> <sliced-groups> [ be> ] map ]
     [
-        block-size>> 0 pad-tail 16 64 [a,b) over
+        block-size>> [ 0 pad-tail 16 ] keep [a,b) over
         '[ _ process-M-256 ] each
     ] bi ; inline
 
@@ -199,25 +236,9 @@ ALIAS: K-512 K-384
     ] each ;
 
 : byte-array>sha2 ( bytes state -- )
-    [ [ pad-initial-bytes ] [ block-size>> ] bi* <sliced-groups> ]
+    [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
     [ sha2-steps ] bi ;
 
-PRIVATE>
-
-SINGLETON: sha-224
-SINGLETON: sha-256
-SINGLETON: sha-384
-SINGLETON: sha-512
-
-INSTANCE: sha-224 checksum
-INSTANCE: sha-256 checksum
-INSTANCE: sha-384 checksum
-INSTANCE: sha-512 checksum
-
-TUPLE: sha2-state K H word-size block-size ;
-
-TUPLE: sha-224-state < sha2-state ;
-
 : <sha-224-state> ( -- sha2-state )
     sha-224-state new
         K-256 >>K
@@ -225,8 +246,6 @@ TUPLE: sha-224-state < sha2-state ;
         4 >>word-size
         64 >>block-size ;
 
-TUPLE: sha-256-state < sha2-state ;
-
 : <sha-256-state> ( -- sha2-state )
     sha-256-state new
         K-256 >>K
@@ -234,6 +253,22 @@ TUPLE: sha-256-state < sha2-state ;
         4 >>word-size
         64 >>block-size ;
 
+: <sha-384-state> ( -- sha2-state )
+    sha-384-state new
+        K-384 >>K
+        initial-H-384 >>H
+        8 >>word-size
+        80 >>block-size ;
+
+: <sha-512-state> ( -- sha2-state )
+    sha-512-state new
+        K-512 >>K
+        initial-H-512 >>H
+        8 >>word-size
+        80 >>block-size ;
+
+PRIVATE>
+
 M: sha-224 checksum-bytes
     drop <sha-224-state>
     [ byte-array>sha2 ]
@@ -243,3 +278,13 @@ M: sha-256 checksum-bytes
     drop <sha-256-state>
     [ byte-array>sha2 ]
     [ H>> 4 seq>byte-array ] bi ;
+
+M: sha-384 checksum-bytes
+    drop <sha-384-state>
+    [ byte-array>sha2 ]
+    [ H>> 6 head 8 seq>byte-array ] bi ;
+
+M: sha-512 checksum-bytes
+    drop <sha-512-state>
+    [ byte-array>sha2 ]
+    [ H>> 8 seq>byte-array ] bi ;

From dedb1d753660d719bf9b3924179359b2458765f6 Mon Sep 17 00:00:00 2001
From: Diego Martinelli <martinelli.diego@gmail.com>
Date: Sat, 9 May 2009 17:23:41 +0200
Subject: [PATCH 11/68] Main implementation done. Need docs and tests.

---
 extra/hashcash/authors.txt     |  1 +
 extra/hashcash/hashcash.factor | 90 +++++++++++++++++++++++++++++++++-
 2 files changed, 89 insertions(+), 2 deletions(-)

diff --git a/extra/hashcash/authors.txt b/extra/hashcash/authors.txt
index e69de29bb2..f6e3b59c4c 100755
--- a/extra/hashcash/authors.txt
+++ b/extra/hashcash/authors.txt
@@ -0,0 +1 @@
+Diego Martinelli
diff --git a/extra/hashcash/hashcash.factor b/extra/hashcash/hashcash.factor
index fe7cf10bd3..3e75aad94c 100755
--- a/extra/hashcash/hashcash.factor
+++ b/extra/hashcash/hashcash.factor
@@ -1,4 +1,90 @@
-! Copyright (C) 2009 Your name.
+! Copyright (C) 2009 Diego Martinelli.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ;
+USING: accessors byte-arrays calendar calendar.format 
+checksums checksums.openssl classes.tuple 
+fry kernel make math math.functions math.parser math.ranges 
+present random sequences splitting strings syntax ;
 IN: hashcash
+
+! Hashcash implementation
+! Reference materials listed below:
+! 
+! http://hashcash.org
+! http://en.wikipedia.org/wiki/Hashcash
+! http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash
+! 
+! And the reference implementation (in python):
+! http://www.gnosis.cx/download/gnosis/util/hashcash.py
+
+<PRIVATE
+
+! Return a string with today's date in the form YYMMDD
+: get-date ( -- str )
+    now [ year>> 100 mod pad-00 ] 
+        [ month>> pad-00 ] 
+        [ day>> pad-00 ] tri 3append ;
+
+! Random salt is formed by ascii characters
+! between 33 and 126
+: available-chars ( -- seq )
+    33 126 [a,b] [ CHAR: : = not ] filter ;
+
+PRIVATE>
+
+! Generate a 'length' long random salt
+: salt ( length -- salted )
+    available-chars '[ _ random ] "" replicate-as ;
+
+TUPLE: hashcash version bits date resource ext salt suffix ;
+
+: <hashcash> ( -- tuple )
+    hashcash new
+        1 >>version
+        20 >>bits
+        get-date >>date
+        8 salt >>salt ;
+
+M: hashcash string>> 
+    tuple-slots [ present ] map ":" join ;
+
+<PRIVATE
+
+: sha1-checksum ( str -- bytes )
+    openssl-sha1 checksum-bytes ; inline
+
+: set-suffix ( tuple guess -- tuple )
+    >hex >>suffix ;
+
+: get-bits ( bytes -- str )
+    [ >bin 8 CHAR: 0 pad-head ] { } map-as concat ;
+
+: checksummed-bits ( tuple -- relevant-bits )
+    dup string>> sha1-checksum
+    swap bits>> 8 / ceiling head get-bits ;
+
+: all-char-zero? ( seq -- ? )
+    [ CHAR: 0 = ] all? ; inline
+
+: valid-guess? ( checksum tuple -- ? )
+    bits>> head all-char-zero? ;
+
+: (mint) ( tuple counter -- tuple ) 
+    2dup set-suffix checksummed-bits pick 
+    valid-guess? [ drop ] [ 1+ (mint) ] if ;
+
+PRIVATE>
+
+: mint* ( tuple -- str )
+    0 (mint) string>> ;
+
+: mint ( resource -- str )
+    <hashcash>
+        swap >>resource
+    mint* ;
+
+! One might wanna add check based on the date,
+! passing a 'good-until' duration param
+: check-stamp ( stamp -- ? )
+    dup ":" split [ sha1-checksum get-bits ] dip
+    second string>number head all-char-zero? ;
+

From d22474e4fc46447ae3b6b92ee5fe084e28b2d0a8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.(none)>
Date: Sat, 9 May 2009 13:54:18 -0500
Subject: [PATCH 12/68] use bi, call >string on c-strings from tar

---
 extra/crypto/hmac/hmac.factor | 4 ++--
 extra/tar/tar.factor          | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor
index 6e6229f182..9a668aa23a 100755
--- a/extra/crypto/hmac/hmac.factor
+++ b/extra/crypto/hmac/hmac.factor
@@ -31,8 +31,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
 
 : init-hmac ( K -- o i )
     64 0 pad-tail 
-    [ opad seq-bitxor ] keep
-    ipad seq-bitxor ;
+    [ opad seq-bitxor ]
+    [ ipad seq-bitxor ] bi ;
 
 PRIVATE>
 
diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
index e281871252..93554c146a 100755
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -18,7 +18,7 @@ ERROR: checksum-error header ;
 : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
 
 : read-c-string ( n -- str/f )
-    read [ zero? ] trim-tail [ f ] when-empty ;
+    read [ zero? ] trim-tail [ f ] when-empty >string ;
 
 : read-tar-header ( -- obj )
     \ tar-header new

From 3be7034b5e8f9428a2fd564c32590954a66fa2c4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.(none)>
Date: Sat, 9 May 2009 13:54:42 -0500
Subject: [PATCH 13/68] 64-bit add/subtract/multiply

---
 basis/math/bitwise/bitwise.factor | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
index 73d111f91e..4fe2340643 100755
--- a/basis/math/bitwise/bitwise.factor
+++ b/basis/math/bitwise/bitwise.factor
@@ -35,6 +35,11 @@ IN: math.bitwise
 : w- ( int int -- int ) - 32 bits ; inline
 : w* ( int int -- int ) * 32 bits ; inline
 
+! 64-bit arithmetic
+: W+ ( int int -- int ) + 64 bits ; inline
+: W- ( int int -- int ) - 64 bits ; inline
+: W* ( int int -- int ) * 64 bits ; inline
+
 ! flags
 MACRO: flags ( values -- )
     [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;

From ef5c9844e4fe34e207f6795605c44d05746d5e3c Mon Sep 17 00:00:00 2001
From: Diego Martinelli <martinelli.diego@gmail.com>
Date: Sun, 10 May 2009 14:20:23 +0200
Subject: [PATCH 14/68] Done with docs and unit tests.

---
 extra/hashcash/hashcash.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/hashcash/hashcash.factor b/extra/hashcash/hashcash.factor
index 3e75aad94c..1eb690b20f 100755
--- a/extra/hashcash/hashcash.factor
+++ b/extra/hashcash/hashcash.factor
@@ -74,10 +74,10 @@ M: hashcash string>>
 
 PRIVATE>
 
-: mint* ( tuple -- str )
+: mint* ( tuple -- stamp )
     0 (mint) string>> ;
 
-: mint ( resource -- str )
+: mint ( resource -- stamp )
     <hashcash>
         swap >>resource
     mint* ;

From 85facc27d6c610fabc142cc1476c44d5f59b2ec0 Mon Sep 17 00:00:00 2001
From: Diego Martinelli <martinelli.diego@gmail.com>
Date: Sun, 10 May 2009 14:27:35 +0200
Subject: [PATCH 15/68] Ops.

---
 extra/hashcash/hashcash-docs.factor  | 60 ++++++++++++++++++++++++++++
 extra/hashcash/hashcash-tests.factor | 15 +++++++
 extra/hashcash/summary.txt           |  1 +
 3 files changed, 76 insertions(+)
 create mode 100644 extra/hashcash/hashcash-docs.factor
 create mode 100644 extra/hashcash/hashcash-tests.factor
 create mode 100644 extra/hashcash/summary.txt

diff --git a/extra/hashcash/hashcash-docs.factor b/extra/hashcash/hashcash-docs.factor
new file mode 100644
index 0000000000..2cfe0bb68e
--- /dev/null
+++ b/extra/hashcash/hashcash-docs.factor
@@ -0,0 +1,60 @@
+USING: help.markup help.syntax kernel math ;
+IN: hashcash
+
+ARTICLE: "hashcash" "Hashcash"
+"Hashcash is a denial-of-service counter measure tool."
+$nl
+"A hashcash stamp constitutes a proof-of-work which takes a parameterizable amount of work to compute for the sender. The recipient can verify received hashcash stamps efficiently."
+$nl
+"More info on hashcash:"
+$nl
+{ $url "http://www.hashcash.org/" } $nl
+{ $url "http://en.wikipedia.org/wiki/Hashcash" } $nl
+{ $url "http://www.ibm.com/developerworks/linux/library/l-hashcash.html?ca=dgr-lnxw01HashCash" } $nl
+"This library provide basic utilities for hashcash creation and validation."
+$nl
+"Creating stamps:"
+{ $subsection mint }
+{ $subsection mint* }
+"Validation:"
+{ $subsection check-stamp }
+"Hashcash tuple and constructor:"
+{ $subsection hashcash }
+{ $subsection <hashcash> }
+"Utilities:"
+{ $subsection salt } ;
+
+{ mint mint* <hashcash> check-stamp salt } related-words
+
+HELP: mint
+{ $values { "resource" "a string" } { "stamp" "generated stamp" } }
+{ $description "This word generate a valid stamp with default parameters and the specified resource." } ;
+
+HELP: mint*
+{ $values { "tuple" "a tuple" } { "stamp" "generated stamp" } }
+{ $description "As " { $snippet "mint" } " but it takes an hashcash tuple as a parameter." } ;
+
+HELP: check-stamp
+{ $values { "stamp" "a string" } { "?" boolean } }
+{ $description "Check for stamp's validity. Only supports hashcash version 1." } ;
+
+HELP: salt
+{ $values { "length" integer } { "salted" "a string" } }
+{ $description "It generates a random string of " { $snippet "length" } " characters." } ;
+
+HELP: <hashcash>
+{ $values { "tuple" object } }
+{ $description "It fill an hashcash tuple with the default values: 1 as hashcash version, 20 as bits, today's date as date and a random 8 character long salt" } ;
+
+HELP: hashcash
+{ $class-description "An hashcash object. An hashcash have the following slots:"
+    { $table
+        { { $slot "version" } "The version number. Only version 1 is supported." }
+        { { $slot "bits" } "The claimed bit value." }
+        { { $slot "date" } "The date a stamp was minted." }
+        { { $slot "resource" } "The resource for which a stamp is minted." }
+        { { $slot "ext" } "Extensions that a specialized application may want." }
+        { { $slot "salt" } "A random salt." }
+        { { $slot "suffix" } "The computed suffix. This is supposed to be manipulated by the library." }
+    }
+} ;
diff --git a/extra/hashcash/hashcash-tests.factor b/extra/hashcash/hashcash-tests.factor
new file mode 100644
index 0000000000..efef40acfa
--- /dev/null
+++ b/extra/hashcash/hashcash-tests.factor
@@ -0,0 +1,15 @@
+USING: accessors sequences tools.test hashcash ;
+
+[ t ] [ "foo@bar.com" mint check-stamp ] unit-test
+
+[ t ] [ 
+    <hashcash> 
+        "foo@bar.com" >>resource 
+        16 >>bits 
+    mint* check-stamp ] unit-test
+
+[ t ] [ 
+    "1:20:040927:mertz@gnosis.cx::odVZhQMP:7ca28" check-stamp
+] unit-test
+
+[ 8 ] [ 8 salt length ] unit-test
diff --git a/extra/hashcash/summary.txt b/extra/hashcash/summary.txt
new file mode 100644
index 0000000000..e5ec1d4064
--- /dev/null
+++ b/extra/hashcash/summary.txt
@@ -0,0 +1 @@
+Hashcash implementation

From b4108c21f005f42a8bbe597238cd6d8954945c0a Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 12:18:59 -0500
Subject: [PATCH 16/68] working on sha2

---
 basis/checksums/common/common.factor   |  2 +-
 basis/checksums/sha2/sha2-tests.factor |  4 +-
 basis/checksums/sha2/sha2.factor       | 90 +++++++++++++++-----------
 3 files changed, 56 insertions(+), 40 deletions(-)

diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor
index 01cc2cb739..76675f9413 100644
--- a/basis/checksums/common/common.factor
+++ b/basis/checksums/common/common.factor
@@ -10,7 +10,7 @@ SYMBOL: bytes-read
     [ 56 < 55 119 ? ] keep - ;
 
 : calculate-pad-length-long ( length -- length' )
-    [ 112 < 111 249 ? ] keep - ;
+    [ 120 < 119 247 ? ] keep - ;
 
 : pad-last-block ( str big-endian? length -- str )
     [
diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor
index f224d497a6..c14ea5a98d 100644
--- a/basis/checksums/sha2/sha2-tests.factor
+++ b/basis/checksums/sha2/sha2-tests.factor
@@ -38,5 +38,5 @@ IN: checksums.sha2.tests
 
 
 
-[ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
-[ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] 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 1abed088a3..12e32f6c69 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -8,13 +8,9 @@ IN: checksums.sha2
 
 SINGLETON: sha-224
 SINGLETON: sha-256
-SINGLETON: sha-384
-SINGLETON: sha-512
 
 INSTANCE: sha-224 checksum
 INSTANCE: sha-256 checksum
-INSTANCE: sha-384 checksum
-INSTANCE: sha-512 checksum
 
 TUPLE: sha2-state K H word-size block-size ;
 
@@ -26,10 +22,6 @@ TUPLE: sha-224-state < sha2-short ;
 
 TUPLE: sha-256-state < sha2-short ;
 
-TUPLE: sha-384-state < sha2-long ;
-
-TUPLE: sha-512-state < sha2-long ;
-
 <PRIVATE
 
 CONSTANT: a 0
@@ -152,6 +144,34 @@ ALIAS: K-512 K-384
         [ -25 bitroll-32 ] tri
     ] [ bitxor ] reduce-outputs ; inline
 
+: s0-512 ( x -- x' )
+    [
+        [ -1 bitroll-64 ]
+        [ -8 bitroll-64 ]
+        [ -7 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: s1-512 ( x -- x' )
+    [
+        [ -19 bitroll-64 ]
+        [ -61 bitroll-64 ]
+        [ -6 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: S0-512 ( x -- x' )
+    [
+        [ -28 bitroll-64 ]
+        [ -34 bitroll-64 ]
+        [ -39 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: S1-512 ( x -- x' )
+    [
+        [ -14 bitroll-64 ]
+        [ -18 bitroll-64 ]
+        [ -41 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
 : process-M-256 ( n seq -- )
     {
         [ [ 16 - ] dip nth ]
@@ -161,6 +181,15 @@ ALIAS: K-512 K-384
         [ ]
     } 2cleave set-nth ; inline
 
+: process-M-512 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-512 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
 : ch ( x y z -- x' )
     [ bitxor bitand ] keep bitxor ; inline
 
@@ -186,23 +215,34 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
         HEX: 80 ,
         length
         [ 128 mod calculate-pad-length-long 0 <string> % ]
-        [ 3 shift 16 >be % ] bi
+        [ 3 shift 8 >be % ] bi
     ] "" make append ;
 
 : seq>byte-array ( seq n -- string )
     '[ _ >be ] map B{ } join ;
 
-:: T1 ( n M H sha2 -- T1 )
+:: T1-256 ( n M H sha2 -- T1 )
     n M nth
     n sha2 K>> nth +
     e H slice3 ch w+
     e H nth S1-256 w+
     h H nth w+ ; inline
 
-: T2 ( H -- T2 )
+: T2-256 ( H -- T2 )
     [ a swap nth S0-256 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
+:: T1-512 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-512 w+
+    h H nth w+ ; inline
+
+: T2-512 ( H -- T2 )
+    [ a swap nth S0-512 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
 : update-H ( T1 T2 H -- )
     h g pick exchange
     g f pick exchange
@@ -222,8 +262,8 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
 
 :: process-chunk ( M block-size cloned-H sha2 -- )
     block-size [
-        M cloned-H sha2 T1
-        cloned-H T2
+        M cloned-H sha2 T1-256
+        cloned-H T2-256
         cloned-H update-H
     ] each
     cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
@@ -253,20 +293,6 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
         4 >>word-size
         64 >>block-size ;
 
-: <sha-384-state> ( -- sha2-state )
-    sha-384-state new
-        K-384 >>K
-        initial-H-384 >>H
-        8 >>word-size
-        80 >>block-size ;
-
-: <sha-512-state> ( -- sha2-state )
-    sha-512-state new
-        K-512 >>K
-        initial-H-512 >>H
-        8 >>word-size
-        80 >>block-size ;
-
 PRIVATE>
 
 M: sha-224 checksum-bytes
@@ -278,13 +304,3 @@ M: sha-256 checksum-bytes
     drop <sha-256-state>
     [ byte-array>sha2 ]
     [ H>> 4 seq>byte-array ] bi ;
-
-M: sha-384 checksum-bytes
-    drop <sha-384-state>
-    [ byte-array>sha2 ]
-    [ H>> 6 head 8 seq>byte-array ] bi ;
-
-M: sha-512 checksum-bytes
-    drop <sha-512-state>
-    [ byte-array>sha2 ]
-    [ H>> 8 seq>byte-array ] bi ;

From 6b1f60f550d2448c511ba4d95a90d351a0914d25 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 12:24:19 -0500
Subject: [PATCH 17/68] move math.miller-rabin to math.primes.miller-rabin

---
 basis/math/{ => primes}/miller-rabin/authors.txt               | 0
 basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor  | 0
 basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor | 0
 basis/math/{ => primes}/miller-rabin/miller-rabin.factor       | 0
 basis/math/{ => primes}/miller-rabin/summary.txt               | 0
 5 files changed, 0 insertions(+), 0 deletions(-)
 rename basis/math/{ => primes}/miller-rabin/authors.txt (100%)
 rename basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor (100%)
 rename basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor (100%)
 rename basis/math/{ => primes}/miller-rabin/miller-rabin.factor (100%)
 rename basis/math/{ => primes}/miller-rabin/summary.txt (100%)

diff --git a/basis/math/miller-rabin/authors.txt b/basis/math/primes/miller-rabin/authors.txt
similarity index 100%
rename from basis/math/miller-rabin/authors.txt
rename to basis/math/primes/miller-rabin/authors.txt
diff --git a/basis/math/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
similarity index 100%
rename from basis/math/miller-rabin/miller-rabin-docs.factor
rename to basis/math/primes/miller-rabin/miller-rabin-docs.factor
diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
similarity index 100%
rename from basis/math/miller-rabin/miller-rabin-tests.factor
rename to basis/math/primes/miller-rabin/miller-rabin-tests.factor
diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor
similarity index 100%
rename from basis/math/miller-rabin/miller-rabin.factor
rename to basis/math/primes/miller-rabin/miller-rabin.factor
diff --git a/basis/math/miller-rabin/summary.txt b/basis/math/primes/miller-rabin/summary.txt
similarity index 100%
rename from basis/math/miller-rabin/summary.txt
rename to basis/math/primes/miller-rabin/summary.txt

From 79265b50d99d14f273fa3b0d6381efbff3615974 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 12:24:43 -0500
Subject: [PATCH 18/68] update usages of miller-rabin

---
 basis/math/primes/miller-rabin/miller-rabin-docs.factor  | 8 ++++----
 basis/math/primes/miller-rabin/miller-rabin-tests.factor | 6 +++---
 basis/math/primes/miller-rabin/miller-rabin.factor       | 2 +-
 basis/math/primes/primes.factor                          | 5 +++--
 extra/crypto/rsa/rsa.factor                              | 4 ++--
 extra/project-euler/common/common.factor                 | 2 +-
 extra/random/blum-blum-shub/blum-blum-shub.factor        | 2 +-
 7 files changed, 15 insertions(+), 14 deletions(-)

diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
index 4aa318f674..2455dafdd5 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel sequences math ;
-IN: math.miller-rabin
+IN: math.primes.miller-rabin
 
 HELP: find-relative-prime
 { $values
@@ -82,8 +82,8 @@ HELP: unique-primes
 }
 { $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
 
-ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
-"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
+ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test"
+"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
 "The Miller-Rabin probabilistic primality test:"
 { $subsection miller-rabin }
 { $subsection miller-rabin* }
@@ -97,4 +97,4 @@ ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
 { $subsection next-safe-prime }
 { $subsection random-safe-prime } ;
 
-ABOUT: "math.miller-rabin"
+ABOUT: "math.primes.miller-rabin"
diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
index 9981064ec0..9c635c8f38 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
@@ -1,6 +1,6 @@
-USING: math.miller-rabin tools.test kernel sequences
-math.miller-rabin.private math ;
-IN: math.miller-rabin.tests
+USING: math.primes.miller-rabin tools.test kernel sequences
+math.primes.miller-rabin.private math ;
+IN: math.primes.miller-rabin.tests
 
 [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
 [ t ] [ 2 miller-rabin ] unit-test
diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor
index 991924dfe4..35ee97a897 100755
--- a/basis/math/primes/miller-rabin/miller-rabin.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin.factor
@@ -3,7 +3,7 @@
 USING: combinators kernel locals math math.functions math.ranges
 random sequences sets combinators.short-circuit math.bitwise
 math math.order ;
-IN: math.miller-rabin
+IN: math.primes.miller-rabin
 
 : >odd ( n -- int ) 0 set-bit ; foldable
 
diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor
index 688fdad713..fa1cd5cb63 100644
--- a/basis/math/primes/primes.factor
+++ b/basis/math/primes/primes.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.functions math.miller-rabin
-math.order math.primes.erato math.ranges sequences ;
+USING: combinators kernel math math.functions
+math.primes.miller-rabin math.order math.primes.erato
+math.ranges sequences ;
 IN: math.primes
 
 <PRIVATE
diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor
index 373dd9637c..1da170d197 100644
--- a/extra/crypto/rsa/rsa.factor
+++ b/extra/crypto/rsa/rsa.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.miller-rabin kernel math math.functions namespaces
-sequences accessors ;
+USING: math.primes.miller-rabin kernel math math.functions
+namespaces sequences accessors ;
 IN: crypto.rsa
 
 ! The private key is the only secret.
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index c2ffe26d94..84291f2ce8 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007-2009 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel lists make math math.functions math.matrices
-    math.miller-rabin math.order math.parser math.primes.factors
+    math.primes.miller-rabin math.order math.parser math.primes.factors
     math.primes.lists math.ranges math.ratios namespaces parser prettyprint
     quotations sequences sorting strings unicode.case vocabs vocabs.parser
     words ;
diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor
index dc764fd040..4a52a2f79c 100755
--- a/extra/random/blum-blum-shub/blum-blum-shub.factor
+++ b/extra/random/blum-blum-shub/blum-blum-shub.factor
@@ -1,5 +1,5 @@
 USING: kernel math sequences namespaces
-math.miller-rabin math.functions accessors random ;
+math.primes.miller-rabin math.functions accessors random ;
 IN: random.blum-blum-shub
 
 ! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n

From 0801dbc6940ffb52600724abcc9518b7f0660d57 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 12:59:35 -0500
Subject: [PATCH 19/68] add lucas-lehmer primality test

---
 basis/math/primes/lucas-lehmer/authors.txt    |  1 +
 .../lucas-lehmer/lucas-lehmer-docs.factor     | 25 +++++++++++++++++
 .../lucas-lehmer/lucas-lehmer-tests.factor    | 13 +++++++++
 .../primes/lucas-lehmer/lucas-lehmer.factor   | 27 +++++++++++++++++++
 4 files changed, 66 insertions(+)
 create mode 100644 basis/math/primes/lucas-lehmer/authors.txt
 create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor
 create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor
 create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer.factor

diff --git a/basis/math/primes/lucas-lehmer/authors.txt b/basis/math/primes/lucas-lehmer/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/math/primes/lucas-lehmer/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor
new file mode 100644
index 0000000000..582b59b69a
--- /dev/null
+++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: math.primes.lucas-lehmer
+
+HELP: lucas-lehmer
+{ $values
+    { "p" "a prime number" }
+    { "?" "a boolean" }
+}
+{ $description "Runs the Lucas-Lehmer test on the prime " { $snippet "p" } " and returns " { $link t } " if " { $snippet "(2 ^ p) - 1" } " is prime." }
+{ $examples
+    { $example "! Test that (2 ^ 61) - 1 is prime:"
+               "USING: math.primes.lucas-lehmer prettyprint ;"
+               "61 lucas-lehmer ."
+               "t"
+    }
+} ;
+
+ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test"
+"The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl
+"Run the Lucas-Lehmer test:"
+{ $subsection lucas-lehmer } ;
+
+ABOUT: "math.primes.lucas-lehmer"
diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor
new file mode 100644
index 0000000000..b114fa8553
--- /dev/null
+++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor
@@ -0,0 +1,13 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.primes.lucas-lehmer ;
+IN: math.primes.lucas-lehmer.tests
+
+[ t ] [ 2 lucas-lehmer ] unit-test
+[ t ] [ 3 lucas-lehmer ] unit-test
+[ f ] [ 4 lucas-lehmer ] unit-test
+[ t ] [ 5 lucas-lehmer ] unit-test
+[ f ] [ 6 lucas-lehmer ] unit-test
+[ f ] [ 11 lucas-lehmer ] unit-test
+[ t ] [ 13 lucas-lehmer ] unit-test
+[ t ] [ 61 lucas-lehmer ] unit-test
diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor
new file mode 100644
index 0000000000..a8bf097dbe
--- /dev/null
+++ b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor
@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators fry kernel locals math
+math.primes combinators.short-circuit ;
+IN: math.primes.lucas-lehmer
+
+ERROR: invalid-lucas-lehmer-candidate obj ;
+
+<PRIVATE
+
+: do-lucas-lehmer ( p -- ? )
+    [ drop 4 ] [ 2 - ] [ 2^ 1 - ] tri
+    '[ sq 2 - _ mod ] times 0 = ;
+
+: lucas-lehmer-guard ( obj -- obj )
+    dup { [ integer? ] [ 0 > ] } 1&&
+    [ invalid-lucas-lehmer-candidate ] unless ;
+
+PRIVATE>
+
+: lucas-lehmer ( p -- ? )
+    lucas-lehmer-guard
+    {
+        { [ dup 2 = ] [ drop t ] }
+        { [ dup prime? ] [ do-lucas-lehmer ] }
+        [ drop f ]
+    } cond ;

From 0e0662ffc5f23ed4bd0f2091020a0f2b86001084 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:39:08 -0500
Subject: [PATCH 20/68] move random-bits* to random, work on docs

---
 .../mersenne-twister-tests.factor                 |  2 +-
 basis/random/random-docs.factor                   | 15 +++++++++++++--
 basis/random/random-tests.factor                  |  2 ++
 basis/random/random.factor                        |  5 ++++-
 4 files changed, 20 insertions(+), 4 deletions(-)

diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor
index c35d7488ac..651e43ef5b 100644
--- a/basis/random/mersenne-twister/mersenne-twister-tests.factor
+++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor
@@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests
     100 [ 100 random ] replicate ;
 
 : test-rng ( seed quot -- )
-    [  <mersenne-twister> ] dip with-random ; inline
+    [ <mersenne-twister> ] dip with-random ; inline
 
 [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
 
diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor
index c7600a731f..222ecaf935 100755
--- a/basis/random/random-docs.factor
+++ b/basis/random/random-docs.factor
@@ -40,9 +40,17 @@ HELP: random-bytes
 } ;
 
 HELP: random-bits
-{ $values { "n" "an integer" } { "r" "a random integer" } }
+{ $values { "numbits" integer } { "r" "a random integer" } }
 { $description "Outputs an random integer n bits in length." } ;
 
+HELP: random-bits*
+{ $values
+    { "numbits" integer }
+    { "n" integer }
+}
+{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
+
+
 HELP: with-random
 { $values { "tuple" "a random generator" } { "quot" "a quotation" } }
 { $description "Calls the quotation with the random generator in a dynamic variable.  All random numbers will be generated using this random generator." } ;
@@ -93,6 +101,9 @@ $nl
 "Randomizing a sequence:"
 { $subsection randomize }
 "Deleting a random element from a sequence:"
-{ $subsection delete-random } ;
+{ $subsection delete-random }
+"Random numbers with " { $snippet "n" } " bits:"
+{ $subsection random-bits }
+{ $subsection random-bits* } ;
 
 ABOUT: "random"
diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor
index 9607627b3d..2b6ac9b1b8 100644
--- a/basis/random/random-tests.factor
+++ b/basis/random/random-tests.factor
@@ -23,3 +23,5 @@ IN: random.tests
 
 [ f ]
 [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
+
+[ 49 ] [ 50 random-bits* log2 ] unit-test
diff --git a/basis/random/random.factor b/basis/random/random.factor
index 6b02c8a3e8..661e771258 100755
--- a/basis/random/random.factor
+++ b/basis/random/random.factor
@@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
 
 PRIVATE>
 
-: random-bits ( n -- r ) 2^ random-integer ;
+: random-bits ( numbits -- r ) 2^ random-integer ;
+
+: random-bits* ( numbits -- n )
+    1 - [ random-bits ] keep set-bit ;
 
 : random ( seq -- elt )
     [ f ] [

From 18add4b769b02b63ddc37639a0746e576ed189c9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:42:41 -0500
Subject: [PATCH 21/68] add next-odd etc to math.bitwise

---
 basis/math/bitwise/bitwise.factor | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
index 4fe2340643..ff4806348b 100755
--- a/basis/math/bitwise/bitwise.factor
+++ b/basis/math/bitwise/bitwise.factor
@@ -111,3 +111,10 @@ PRIVATE>
 : >signed ( x n -- y )
     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 
+: >odd ( n -- int ) 0 set-bit ; foldable
+
+: >even ( n -- int ) 0 clear-bit ; foldable
+
+: next-even ( m -- n ) >even 2 + ; foldable
+
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable

From 8f51f87a8f6d317c6d31b49770ae53b8209d7417 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:47:51 -0500
Subject: [PATCH 22/68] more docs for math.primes, move words out of
 miller-rabin

---
 .../miller-rabin/miller-rabin-docs.factor     | 74 +----------------
 .../miller-rabin/miller-rabin-tests.factor    |  5 +-
 .../primes/miller-rabin/miller-rabin.factor   | 83 +------------------
 basis/math/primes/primes-docs.factor          | 50 ++++++++++-
 basis/math/primes/primes-tests.factor         | 13 ++-
 basis/math/primes/primes.factor               | 43 +++++++++-
 6 files changed, 105 insertions(+), 163 deletions(-)

diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
index 2455dafdd5..2d19d51e06 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
@@ -3,20 +3,6 @@
 USING: help.markup help.syntax kernel sequences math ;
 IN: math.primes.miller-rabin
 
-HELP: find-relative-prime
-{ $values
-    { "n" integer }
-    { "p" integer }
-}
-{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
-
-HELP: find-relative-prime*
-{ $values
-    { "n" integer } { "guess" integer }
-    { "p" integer }
-}
-{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
-
 HELP: miller-rabin
 { $values
     { "n" integer }
@@ -33,68 +19,10 @@ HELP: miller-rabin*
 }
 { $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
 
-HELP: next-prime
-{ $values
-    { "n" integer }
-    { "p" integer }
-}
-{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ;
-
-HELP: next-safe-prime
-{ $values
-    { "n" integer }
-    { "q" integer }
-}
-{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
-
-HELP: random-bits*
-{ $values
-    { "numbits" integer }
-    { "n" integer }
-}
-{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
-
-HELP: random-prime
-{ $values
-    { "numbits" integer }
-    { "p" integer }
-}
-{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
-
-HELP: random-safe-prime
-{ $values
-    { "numbits" integer }
-    { "p" integer }
-}
-{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
-
-HELP: safe-prime?
-{ $values
-    { "q" integer }
-    { "?" "a boolean" }
-}
-{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
-
-HELP: unique-primes
-{ $values
-    { "numbits" integer } { "n" integer }
-    { "seq" sequence }
-}
-{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
-
 ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test"
 "The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
 "The Miller-Rabin probabilistic primality test:"
 { $subsection miller-rabin }
-{ $subsection miller-rabin* }
-"Generating relative prime numbers:"
-{ $subsection find-relative-prime }
-{ $subsection find-relative-prime* }
-"Generating prime numbers:"
-{ $subsection next-prime }
-{ $subsection random-prime }
-"Generating safe prime numbers:"
-{ $subsection next-safe-prime }
-{ $subsection random-safe-prime } ;
+{ $subsection miller-rabin* } ;
 
 ABOUT: "math.primes.miller-rabin"
diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
index 9c635c8f38..aeae6cac1b 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
@@ -1,5 +1,6 @@
-USING: math.primes.miller-rabin tools.test kernel sequences
-math.primes.miller-rabin.private math ;
+USING: kernel math math.primes math.primes.miller-rabin
+math.primes.miller-rabin.private math.primes.safe
+math.primes.safe.private random sequences tools.test ;
 IN: math.primes.miller-rabin.tests
 
 [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor
index 35ee97a897..b0dfc4ed35 100755
--- a/basis/math/primes/miller-rabin/miller-rabin.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin.factor
@@ -1,18 +1,9 @@
 ! Copyright (c) 2008-2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel locals math math.functions math.ranges
-random sequences sets combinators.short-circuit math.bitwise
-math math.order ;
+USING: combinators combinators.short-circuit kernel locals math
+math.functions math.ranges random sequences sets ;
 IN: math.primes.miller-rabin
 
-: >odd ( n -- int ) 0 set-bit ; foldable
-
-: >even ( n -- int ) 0 clear-bit ; foldable
-
-: next-even ( m -- n ) >even 2 + ;
-
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
-
 <PRIVATE
 
 :: (miller-rabin) ( n trials -- ? )
@@ -42,73 +33,3 @@ PRIVATE>
     } cond ;
 
 : miller-rabin ( n -- ? ) 10 miller-rabin* ;
-
-ERROR: prime-range-error n ;
-
-: next-prime ( n -- p )
-    dup 1 < [ prime-range-error ] when
-    dup 1 = [
-        drop 2
-    ] [
-        next-odd dup miller-rabin [ next-prime ] unless
-    ] if ;
-
-: random-bits* ( numbits -- n )
-    1 - [ random-bits ] keep set-bit ;
-
-: random-prime ( numbits -- p )
-    random-bits* next-prime ;
-
-ERROR: no-relative-prime n ;
-
-<PRIVATE
-
-: (find-relative-prime) ( n guess -- p )
-    over 1 <= [ over no-relative-prime ] when
-    dup 1 <= [ drop 3 ] when
-    2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
-
-PRIVATE>
-
-: find-relative-prime* ( n guess -- p )
-    #! find a prime relative to n with initial guess
-    >odd (find-relative-prime) ;
-
-: find-relative-prime ( n -- p )
-    dup random find-relative-prime* ;
-
-ERROR: too-few-primes ;
-
-: unique-primes ( numbits n -- seq )
-    #! generate two primes
-    swap
-    dup 5 < [ too-few-primes ] when
-    2dup [ random-prime ] curry replicate
-    dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
-
-! Safe primes are of the form p = 2q + 1, p,q are prime
-! See http://en.wikipedia.org/wiki/Safe_prime
-
-<PRIVATE
-
-: safe-prime-candidate? ( n -- ? )
-    1 + 6 divisor? ;
-
-: next-safe-prime-candidate ( n -- candidate )
-    next-prime dup safe-prime-candidate?
-    [ next-safe-prime-candidate ] unless ;
-
-PRIVATE>
-
-: safe-prime? ( q -- ? )
-    {
-        [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ]
-        [ miller-rabin ]
-    } 1&& ;
-
-: next-safe-prime ( n -- q )
-    next-safe-prime-candidate
-    dup safe-prime? [ next-safe-prime ] unless ;
-
-: random-safe-prime ( numbits -- p )
-    random-bits* next-safe-prime ;
diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor
index c7dbc950e8..fa991e800f 100644
--- a/basis/math/primes/primes-docs.factor
+++ b/basis/math/primes/primes-docs.factor
@@ -1,10 +1,10 @@
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax math sequences ;
 IN: math.primes
 
 { next-prime prime? } related-words
 
 HELP: next-prime
-{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } }
+{ $values { "n" integer } { "p" "a prime number" } }
 { $description "Return the next prime number greater than " { $snippet "n" } "." } ;
 
 HELP: prime?
@@ -20,3 +20,49 @@ HELP: primes-upto
 HELP: primes-between
 { $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } }
 { $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ;
+
+HELP: find-relative-prime
+{ $values
+    { "n" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
+
+HELP: find-relative-prime*
+{ $values
+    { "n" integer } { "guess" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
+
+HELP: random-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: unique-primes
+{ $values
+    { "numbits" integer } { "n" integer }
+    { "seq" sequence }
+}
+{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
+
+
+ARTICLE: "math.primes" "Prime numbers"
+"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers." $nl
+"Testing if a number is prime:"
+{ $subsection prime? }
+"Generating prime numbers:"
+{ $subsection next-prime }
+{ $subsection primes-upto }
+{ $subsection primes-between }
+{ $subsection random-prime }
+"Generating relative prime numbers:"
+{ $subsection find-relative-prime }
+{ $subsection find-relative-prime* }
+"Make a sequence of random prime numbers:"
+{ $subsection unique-primes } ;
+
+ABOUT: "math.primes"
diff --git a/basis/math/primes/primes-tests.factor b/basis/math/primes/primes-tests.factor
index db738399ef..6580f0780e 100644
--- a/basis/math/primes/primes-tests.factor
+++ b/basis/math/primes/primes-tests.factor
@@ -1,4 +1,6 @@
-USING: arrays math.primes tools.test ;
+USING: arrays math math.primes math.primes.miller-rabin
+tools.test ;
+IN: math.primes.tests
 
 { 1237 } [ 1234 next-prime ] unit-test
 { f t } [ 1234 prime? 1237 prime? ] unit-test
@@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ;
 
 { { 4999963 4999999 5000011 5000077 5000081 } }
 [ 4999962 5000082 primes-between >array ] unit-test
+
+[ 2 ] [ 1 next-prime ] unit-test
+[ 3 ] [ 2 next-prime ] unit-test
+[ 5 ] [ 3 next-prime ] unit-test
+[ 101 ] [ 100 next-prime ] unit-test
+[ t ] [ 2135623355842621559 miller-rabin ] unit-test
+[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
+
+[ 49 ] [ 50 random-prime log2 ] unit-test
diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor
index fa1cd5cb63..e3985fc600 100644
--- a/basis/math/primes/primes.factor
+++ b/basis/math/primes/primes.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.functions
-math.primes.miller-rabin math.order math.primes.erato
-math.ranges sequences ;
+USING: combinators kernel math math.bitwise math.functions
+math.order math.primes.erato math.primes.miller-rabin
+math.ranges random sequences sets fry ;
 IN: math.primes
 
 <PRIVATE
@@ -22,7 +22,11 @@ PRIVATE>
     } cond ; foldable
 
 : next-prime ( n -- p )
-    next-odd [ dup really-prime? ] [ 2 + ] until ; foldable
+    dup 2 < [
+        drop 2
+    ] [
+        next-odd [ dup really-prime? ] [ 2 + ] until
+    ] if ; foldable
 
 : primes-between ( low high -- seq )
     [ dup 3 max dup even? [ 1 + ] when ] dip
@@ -32,3 +36,34 @@ PRIVATE>
 : primes-upto ( n -- seq ) 2 swap primes-between ;
 
 : coprime? ( a b -- ? ) gcd nip 1 = ; foldable
+
+: random-prime ( numbits -- p )
+    random-bits* next-prime ;
+
+: estimated-primes ( m -- n )
+    dup log / ; foldable
+
+ERROR: no-relative-prime n ;
+
+<PRIVATE
+
+: (find-relative-prime) ( n guess -- p )
+    over 1 <= [ over no-relative-prime ] when
+    dup 1 <= [ drop 3 ] when
+    2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
+
+PRIVATE>
+
+: find-relative-prime* ( n guess -- p )
+    #! find a prime relative to n with initial guess
+    >odd (find-relative-prime) ;
+
+: find-relative-prime ( n -- p )
+    dup random find-relative-prime* ;
+
+ERROR: too-few-primes n numbits ;
+
+: unique-primes ( n numbits -- seq )
+    2dup 2^ estimated-primes > [ too-few-primes ] when
+    2dup '[ _ random-prime ] replicate
+    dup all-unique? [ 2nip ] [ drop unique-primes ] if ;

From 4b7e1eef118df7dd81828ee624f289adf4c9e544 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:48:09 -0500
Subject: [PATCH 23/68] update using

---
 extra/project-euler/046/046.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/extra/project-euler/046/046.factor b/extra/project-euler/046/046.factor
index e4b8dcc955..0aa9eafe58 100755
--- a/extra/project-euler/046/046.factor
+++ b/extra/project-euler/046/046.factor
@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.primes math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.primes math.ranges
+sequences project-euler.common math.bitwise ;
 IN: project-euler.046
 
 ! http://projecteuler.net/index.php?section=problems&id=46

From bfb350745642c98895fe970d72c4a3ec91e6fd2d Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:49:40 -0500
Subject: [PATCH 24/68] make a new vocabulary for safe primes

---
 basis/math/primes/safe/authors.txt       |  1 +
 basis/math/primes/safe/safe-docs.factor  | 38 ++++++++++++++++++++++++
 basis/math/primes/safe/safe-tests.factor | 14 +++++++++
 basis/math/primes/safe/safe.factor       | 29 ++++++++++++++++++
 4 files changed, 82 insertions(+)
 create mode 100644 basis/math/primes/safe/authors.txt
 create mode 100644 basis/math/primes/safe/safe-docs.factor
 create mode 100644 basis/math/primes/safe/safe-tests.factor
 create mode 100644 basis/math/primes/safe/safe.factor

diff --git a/basis/math/primes/safe/authors.txt b/basis/math/primes/safe/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/math/primes/safe/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/math/primes/safe/safe-docs.factor b/basis/math/primes/safe/safe-docs.factor
new file mode 100644
index 0000000000..861fc4e4ed
--- /dev/null
+++ b/basis/math/primes/safe/safe-docs.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit help.markup help.syntax kernel
+math math.functions math.primes random ;
+IN: math.primes.safe
+
+HELP: next-safe-prime
+{ $values
+    { "n" integer }
+    { "q" integer }
+}
+{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
+
+HELP: random-safe-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: safe-prime?
+{ $values
+    { "q" integer }
+    { "?" "a boolean" }
+}
+{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
+
+
+ARTICLE: "math.primes.safe" "Safe prime numbers"
+"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl
+
+"Testing if a number is a safe prime:"
+{ $subsection safe-prime? }
+"Generating safe prime numbers:"
+{ $subsection next-safe-prime }
+{ $subsection random-safe-prime } ;
+
+ABOUT: "math.primes.safe"
diff --git a/basis/math/primes/safe/safe-tests.factor b/basis/math/primes/safe/safe-tests.factor
new file mode 100644
index 0000000000..ef9aa9246f
--- /dev/null
+++ b/basis/math/primes/safe/safe-tests.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.primes.safe math.primes.safe.private tools.test ;
+IN: math.primes.safe.tests
+
+[ 863 ] [ 862 next-safe-prime ] unit-test
+[ f ] [ 862 safe-prime? ] unit-test
+[ t ] [ 7 safe-prime? ] unit-test
+[ f ] [ 31 safe-prime? ] unit-test
+[ t ] [ 47 safe-prime-candidate? ] unit-test
+[ t ] [ 47 safe-prime? ] unit-test
+[ t ] [ 863 safe-prime? ] unit-test
+
+[ 47 ] [ 31 next-safe-prime ] unit-test
diff --git a/basis/math/primes/safe/safe.factor b/basis/math/primes/safe/safe.factor
new file mode 100644
index 0000000000..a3becb628f
--- /dev/null
+++ b/basis/math/primes/safe/safe.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit kernel math math.functions
+math.primes random ;
+IN: math.primes.safe
+
+<PRIVATE
+
+: safe-prime-candidate? ( n -- ? )
+    1 + 6 divisor? ;
+
+: next-safe-prime-candidate ( n -- candidate )
+    next-prime dup safe-prime-candidate?
+    [ next-safe-prime-candidate ] unless ;
+
+PRIVATE>
+
+: safe-prime? ( q -- ? )
+    {
+        [ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ]
+        [ prime? ]
+    } 1&& ;
+
+: next-safe-prime ( n -- q )
+    next-safe-prime-candidate
+    dup safe-prime? [ next-safe-prime ] unless ;
+
+: random-safe-prime ( numbits -- p )
+    random-bits* next-safe-prime ;

From e946777fbbcf848644c8c1871f24cc8e865fbe29 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 14:01:21 -0500
Subject: [PATCH 25/68] link to prime tests from prime docs

---
 basis/math/primes/factors/factors.factor | 3 ++-
 basis/math/primes/primes-docs.factor     | 3 +--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor
index 278bf70b3d..f5fa468687 100644
--- a/basis/math/primes/factors/factors.factor
+++ b/basis/math/primes/factors/factors.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.functions math.primes sequences ;
+USING: arrays combinators kernel make math math.functions
+math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE
diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor
index fa991e800f..71bf3ac2c8 100644
--- a/basis/math/primes/primes-docs.factor
+++ b/basis/math/primes/primes-docs.factor
@@ -49,9 +49,8 @@ HELP: unique-primes
 }
 { $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
 
-
 ARTICLE: "math.primes" "Prime numbers"
-"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers." $nl
+"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl
 "Testing if a number is prime:"
 { $subsection prime? }
 "Generating prime numbers:"

From 23e3c55d2f595a2e4c6f3a5cb418e4562c6439aa Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 14:08:03 -0500
Subject: [PATCH 26/68] dont load safe primes in miller rabin tests

---
 .../miller-rabin/miller-rabin-tests.factor    | 21 +------------------
 1 file changed, 1 insertion(+), 20 deletions(-)

diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
index aeae6cac1b..d201abfef8 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
@@ -1,6 +1,4 @@
-USING: kernel math math.primes math.primes.miller-rabin
-math.primes.miller-rabin.private math.primes.safe
-math.primes.safe.private random sequences tools.test ;
+USING: kernel math.primes.miller-rabin sequences tools.test ;
 IN: math.primes.miller-rabin.tests
 
 [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
@@ -8,23 +6,6 @@ IN: math.primes.miller-rabin.tests
 [ t ] [ 3 miller-rabin ] unit-test
 [ f ] [ 36 miller-rabin ] unit-test
 [ t ] [ 37 miller-rabin ] unit-test
-[ 2 ] [ 1 next-prime ] unit-test
-[ 3 ] [ 2 next-prime ] unit-test
-[ 5 ] [ 3 next-prime ] unit-test
-[ 101 ] [ 100 next-prime ] unit-test
 [ t ] [ 2135623355842621559 miller-rabin ] unit-test
-[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
-
-[ 863 ] [ 862 next-safe-prime ] unit-test
-[ f ] [ 862 safe-prime? ] unit-test
-[ t ] [ 7 safe-prime? ] unit-test
-[ f ] [ 31 safe-prime? ] unit-test
-[ t ] [ 47 safe-prime-candidate? ] unit-test
-[ t ] [ 47 safe-prime? ] unit-test
-[ t ] [ 863 safe-prime? ] unit-test
 
 [ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
-
-[ 47 ] [ 31 next-safe-prime ] unit-test
-[ 49 ] [ 50 random-prime log2 ] unit-test
-[ 49 ] [ 50 random-bits* log2 ] unit-test

From 5e07dc04a5dd5eb36d7cdb12cd5605f0b255c25f Mon Sep 17 00:00:00 2001
From: "U-C4\\Administrator" <Administrator@k.(none)>
Date: Sun, 10 May 2009 14:24:13 -0500
Subject: [PATCH 27/68] use change-global in a couple of places, formatting

---
 basis/ui/backend/windows/windows.factor | 15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)

diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index ba4926d97e..2cf4091937 100755
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -616,19 +616,21 @@ M: windows-ui-backend do-events
     GetDoubleClickTime milliseconds double-click-timeout set-global ;
 
 : cleanup-win32-ui ( -- )
-    class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
-    msg-obj get-global [ free ] when*
-    f class-name-ptr set-global
-    f msg-obj set-global ;
+    class-name-ptr [
+        [ [ f UnregisterClass drop ] [ free ] bi ] when* f
+    ] change-global
+    msg-obj change-global [ [ free ] when* f ] ;
 
-: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
+: get-dc ( world -- )
+    handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
 
 : get-rc ( world -- )
     handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
     [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
 
 : set-pixel-format ( pixel-format hdc -- )
-    swap handle>> "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
+    swap handle>>
+    "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
 
 : setup-gl ( world -- )
     [ get-dc ] keep
@@ -715,6 +717,7 @@ M: windows-ui-backend beep ( -- )
 M: windows-ui-backend (grab-input) ( handle -- )
     0 ShowCursor drop
     hWnd>> client-area>RECT ClipCursor drop ;
+
 M: windows-ui-backend (ungrab-input) ( handle -- )
     drop
     f ClipCursor drop

From a366909c25437b49daa3a3a035f500657481ba49 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Sun, 10 May 2009 15:28:22 -0500
Subject: [PATCH 28/68] Removing slip usage from basis

---
 basis/cocoa/application/application.factor         |  2 +-
 basis/compiler/codegen/codegen.factor              |  3 +--
 basis/stack-checker/known-words/known-words.factor | 14 +-------------
 basis/xml/xml.factor                               |  2 +-
 4 files changed, 4 insertions(+), 17 deletions(-)

diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index 8b33986fc2..66093645c1 100644
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -14,7 +14,7 @@ NSApplicationDelegateReplyCancel
 NSApplicationDelegateReplyFailure ;
 
 : with-autorelease-pool ( quot -- )
-    NSAutoreleasePool -> new slip -> release ; inline
+    NSAutoreleasePool -> new [ call ] [ -> release ] bi* ; inline
 
 : NSApp ( -- app ) NSApplication -> sharedApplication ;
 
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 47593878fa..c7b67b72b4 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -444,8 +444,7 @@ TUPLE: callback-context ;
 
 : do-callback ( quot token -- )
     init-catchstack
-    dup 2 setenv
-    slip
+    [ 2 setenv call ] keep
     wait-to-return ; inline
 
 : callback-return-quot ( ctype -- quot )
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index 7603324200..56ef67d2a8 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -95,15 +95,6 @@ M: composed infer-call*
 M: object infer-call*
     "literal quotation" literal-expected ;
 
-: infer-nslip ( n -- )
-    [ infer->r infer-call ] [ infer-r> ] bi ;
-
-: infer-slip ( -- ) 1 infer-nslip ;
-
-: infer-2slip ( -- ) 2 infer-nslip ;
-
-: infer-3slip ( -- ) 3 infer-nslip ;
-
 : infer-ndip ( word n -- )
     [ literals get ] 2dip
     [ '[ _ def>> infer-quot-here ] ]
@@ -180,9 +171,6 @@ M: object infer-call*
         { \ declare [ infer-declare ] }
         { \ call [ infer-call ] }
         { \ (call) [ infer-call ] }
-        { \ slip [ infer-slip ] }
-        { \ 2slip [ infer-2slip ] }
-        { \ 3slip [ infer-3slip ] }
         { \ dip [ infer-dip ] }
         { \ 2dip [ infer-2dip ] }
         { \ 3dip [ infer-3dip ] }
@@ -216,7 +204,7 @@ M: object infer-call*
     "local-word-def" word-prop infer-quot-here ;
 
 {
-    declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose
+    declare call (call) dip 2dip 3dip curry compose
     execute (execute) call-effect-unsafe execute-effect-unsafe if
     dispatch <tuple-boa> exit load-local load-locals get-local
     drop-locals do-primitive alien-invoke alien-indirect
diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor
index fba2eafaba..9df7165e6c 100755
--- a/basis/xml/xml.factor
+++ b/basis/xml/xml.factor
@@ -143,7 +143,7 @@ PRIVATE>
 <PRIVATE
 
 : call-under ( quot object -- quot )
-    swap dup slip ; inline
+    swap [ call ] keep ; inline
 
 : xml-loop ( quot: ( xml-elem -- ) -- )
     parse-text call-under

From dc1b97e70ab9eaa8b9453b30ce57a5399582ad88 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 09:51:57 -0500
Subject: [PATCH 29/68] cleaning up sha2

---
 basis/checksums/sha2/sha2.factor | 28 ++++++++++++++++------------
 1 file changed, 16 insertions(+), 12 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index 3b092a78de..b4b787a2b7 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -2,12 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings ;
+sbufs strings combinators.smart ;
 IN: checksums.sha2
 
 <PRIVATE
 
-SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
+SYMBOLS: vars K H process-M word-size block-size ;
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -18,13 +18,13 @@ CONSTANT: f 5
 CONSTANT: g 6
 CONSTANT: h 7
 
-: initial-H-256 ( -- seq )
+CONSTANT: initial-H-256
     {
         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
-    } ;
+    }
 
-: K-256 ( -- seq )
+CONSTANT: K-256
     {
         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
         HEX: 3956c25b HEX: 59f111f1 HEX: 923f82a4 HEX: ab1c5ed5
@@ -42,17 +42,21 @@ CONSTANT: h 7
         HEX: 391c0cb3 HEX: 4ed8aa4a HEX: 5b9cca4f HEX: 682e6ff3
         HEX: 748f82ee HEX: 78a5636f HEX: 84c87814 HEX: 8cc70208
         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
-    } ;
+    }
 
 : s0-256 ( x -- x' )
-    [ -7 bitroll-32 ] keep
-    [ -18 bitroll-32 ] keep
-    -3 shift bitxor bitxor ; inline
+    [
+        [ -7 bitroll-32 ]
+        [ -18 bitroll-32 ]
+        [ -3 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : s1-256 ( x -- x' )
-    [ -17 bitroll-32 ] keep
-    [ -19 bitroll-32 ] keep
-    -10 shift bitxor bitxor ; inline
+    [
+        [ -17 bitroll-32 ]
+        [ -19 bitroll-32 ]
+        [ -10 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : process-M-256 ( seq n -- )
     [ 16 - swap nth ] 2keep

From 5b70d3cccecdbeafb9c97b1d0a00c067ee35d7c5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 10:04:31 -0500
Subject: [PATCH 30/68] more refactoring on sha2

---
 basis/checksums/sha2/sha2.factor | 40 ++++++++++++++++++--------------
 1 file changed, 22 insertions(+), 18 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index b4b787a2b7..57a1db5ac1 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings combinators.smart ;
+sbufs strings combinators.smart math.ranges fry combinators ;
 IN: checksums.sha2
 
 <PRIVATE
@@ -58,34 +58,38 @@ CONSTANT: K-256
         [ -10 shift ] tri
     ] [ bitxor ] reduce-outputs ; inline
 
-: process-M-256 ( seq n -- )
-    [ 16 - swap nth ] 2keep
-    [ 15 - swap nth s0-256 ] 2keep
-    [ 7 - swap nth ] 2keep
-    [ 2 - swap nth s1-256 ] 2keep
-    [ + + w+ ] 2dip swap set-nth ; inline
+: process-M-256 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
 
 : prepare-message-schedule ( seq -- w-seq )
     word-size get group [ be> ] map block-size get 0 pad-tail
-    dup 16 64 dup <slice> [
-        process-M-256
-    ] with each ;
+    16 64 [a,b) over '[ _ process-M-256 ] each ;
 
 : ch ( x y z -- x' )
     [ bitxor bitand ] keep bitxor ;
 
 : maj ( x y z -- x' )
-    [ [ bitand ] 2keep bitor ] dip bitand bitor ;
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
 
 : S0-256 ( x -- x' )
-    [ -2 bitroll-32 ] keep
-    [ -13 bitroll-32 ] keep
-    -22 bitroll-32 bitxor bitxor ; inline
+    [
+        [ -2 bitroll-32 ]
+        [ -13 bitroll-32 ]
+        [ -22 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : S1-256 ( x -- x' )
-    [ -6 bitroll-32 ] keep
-    [ -11 bitroll-32 ] keep
-    -25 bitroll-32 bitxor bitxor ; inline
+    [
+        [ -6 bitroll-32 ]
+        [ -11 bitroll-32 ]
+        [ -25 bitroll-32 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
 
 : slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
 
@@ -118,7 +122,7 @@ CONSTANT: K-256
     ] with each vars get H get [ w+ ] 2map H set ;
 
 : seq>byte-array ( n seq -- string )
-    [ swap [ >be % ] curry each ] B{ } make ;
+    [ swap '[ _ >be % ] each ] B{ } make ;
 
 : preprocess-plaintext ( string big-endian? -- padded-string )
     #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits

From 0dd2aa643acf460d0cb039d4b7eed7461fa3ea06 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 10:52:25 -0500
Subject: [PATCH 31/68] more refactoring on sha2

---
 basis/checksums/sha2/sha2.factor | 114 +++++++++++++++++--------------
 1 file changed, 62 insertions(+), 52 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index 57a1db5ac1..cd67418516 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -2,12 +2,13 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
-sbufs strings combinators.smart math.ranges fry combinators ;
+sbufs strings combinators.smart math.ranges fry combinators
+accessors ;
 IN: checksums.sha2
 
 <PRIVATE
 
-SYMBOLS: vars K H process-M word-size block-size ;
+SYMBOLS: H word-size block-size ;
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -58,25 +59,6 @@ CONSTANT: K-256
         [ -10 shift ] tri
     ] [ bitxor ] reduce-outputs ; inline
 
-: process-M-256 ( n seq -- )
-    {
-        [ [ 16 - ] dip nth ]
-        [ [ 15 - ] dip nth s0-256 ]
-        [ [ 7 - ] dip nth ]
-        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
-        [ ]
-    } 2cleave set-nth ; inline
-
-: prepare-message-schedule ( seq -- w-seq )
-    word-size get group [ be> ] map block-size get 0 pad-tail
-    16 64 [a,b) over '[ _ process-M-256 ] each ;
-
-: ch ( x y z -- x' )
-    [ bitxor bitand ] keep bitxor ;
-
-: maj ( x y z -- x' )
-    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
-
 : S0-256 ( x -- x' )
     [
         [ -2 bitroll-32 ]
@@ -91,21 +73,42 @@ CONSTANT: K-256
         [ -25 bitroll-32 ] tri
     ] [ bitxor ] reduce-outputs ; inline
 
-: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
+: process-M-256 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-256 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
 
-: T1 ( W n -- T1 )
-    [ swap nth ] keep
-    K get nth +
-    e vars get slice3 ch +
-    e vars get nth S1-256 +
-    h vars get nth w+ ;
+: ch ( x y z -- x' )
+    [ bitxor bitand ] keep bitxor ;
 
-: T2 ( -- T2 )
-    a vars get nth S0-256
-    a vars get slice3 maj w+ ;
+: maj ( x y z -- x' )
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
 
-: update-vars ( T1 T2 -- )
-    vars get
+: prepare-message-schedule ( seq -- w-seq )
+    word-size get <sliced-groups> [ be> ] map block-size get 0 pad-tail
+    16 64 [a,b) over '[ _ process-M-256 ] each ;
+
+: slice3 ( n seq -- a b c )
+    [ dup 3 + ] dip <slice> first3 ; inline
+
+: T1 ( W n H -- T1 )
+    [
+        [ swap nth ] keep
+        K-256 nth +
+    ] dip
+    [ e swap slice3 ch w+ ]
+    [ e swap nth S1-256 w+ ]
+    [ h swap nth w+ ] tri ;
+
+: T2 ( H -- T2 )
+    [ a swap nth S0-256 ]
+    [ a swap slice3 maj w+ ] bi ;
+
+: update-H ( T1 T2 H -- )
     h g pick exchange
     g f pick exchange
     f e pick exchange
@@ -115,28 +118,35 @@ CONSTANT: K-256
     b a pick exchange
     [ w+ a ] dip set-nth ;
 
-: process-chunk ( M -- )
-    H get clone vars set
-    prepare-message-schedule block-size get [
-        T1 T2 update-vars
-    ] with each vars get H get [ w+ ] 2map H set ;
+: process-chunk ( M block-size H-cloned -- )
+    [
+        '[
+            _
+            [ T1 ]
+            [ T2 ]
+            [ update-H ] tri 
+        ] with each
+    ] keep H get [ w+ ] 2map H set ;
 
-: seq>byte-array ( n seq -- string )
-    [ swap '[ _ >be % ] each ] B{ } make ;
-
-: preprocess-plaintext ( string big-endian? -- padded-string )
-    #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
-    [ >sbuf ] dip over [
+: pad-initial-bytes ( string -- padded-string )
+    dup [
         HEX: 80 ,
-        dup length HEX: 3f bitand
-        calculate-pad-length 0 <string> %
-        length 3 shift 8 rot [ >be ] [ >le ] if %
-    ] "" make over push-all ;
+        length 
+        [ HEX: 3f bitand calculate-pad-length 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+: seq>byte-array ( seq n -- string )
+    '[ _ >be ] map B{ } join ;
 
 : byte-array>sha2 ( byte-array -- string )
-    t preprocess-plaintext
-    block-size get group [ process-chunk ] each
-    4 H get seq>byte-array ;
+    pad-initial-bytes
+    block-size get <sliced-groups>
+    [
+        prepare-message-schedule
+        block-size get H get clone process-chunk
+    ] each
+    H get 4 seq>byte-array ;
 
 PRIVATE>
 
@@ -146,9 +156,9 @@ INSTANCE: sha-256 checksum
 
 M: sha-256 checksum-bytes
     drop [
-        K-256 K set
         initial-H-256 H set
         4 word-size set
         64 block-size set
         byte-array>sha2
+
     ] with-scope ;

From 7a849022f4baf1aedb6c2ba9ebbe604fde244c8c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 17:18:43 -0500
Subject: [PATCH 32/68] move sha2 state to a tuple

---
 basis/checksums/sha2/sha2.factor | 36 +++++++++++++++++++-------------
 1 file changed, 22 insertions(+), 14 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index cd67418516..ff19c4c9a8 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -8,7 +8,7 @@ IN: checksums.sha2
 
 <PRIVATE
 
-SYMBOLS: H word-size block-size ;
+SYMBOL: sha2
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -89,7 +89,7 @@ CONSTANT: K-256
     [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
 
 : prepare-message-schedule ( seq -- w-seq )
-    word-size get <sliced-groups> [ be> ] map block-size get 0 pad-tail
+    sha2 get word-size>> <sliced-groups> [ be> ] map sha2 get block-size>> 0 pad-tail
     16 64 [a,b) over '[ _ process-M-256 ] each ;
 
 : slice3 ( n seq -- a b c )
@@ -98,7 +98,7 @@ CONSTANT: K-256
 : T1 ( W n H -- T1 )
     [
         [ swap nth ] keep
-        K-256 nth +
+        sha2 get K>> nth +
     ] dip
     [ e swap slice3 ch w+ ]
     [ e swap nth S1-256 w+ ]
@@ -126,7 +126,7 @@ CONSTANT: K-256
             [ T2 ]
             [ update-H ] tri 
         ] with each
-    ] keep H get [ w+ ] 2map H set ;
+    ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ;
 
 : pad-initial-bytes ( string -- padded-string )
     dup [
@@ -141,12 +141,12 @@ CONSTANT: K-256
 
 : byte-array>sha2 ( byte-array -- string )
     pad-initial-bytes
-    block-size get <sliced-groups>
+    sha2 get block-size>> <sliced-groups>
     [
         prepare-message-schedule
-        block-size get H get clone process-chunk
+        sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk
     ] each
-    H get 4 seq>byte-array ;
+    sha2 get H>> 4 seq>byte-array ;
 
 PRIVATE>
 
@@ -154,11 +154,19 @@ SINGLETON: sha-256
 
 INSTANCE: sha-256 checksum
 
-M: sha-256 checksum-bytes
-    drop [
-        initial-H-256 H set
-        4 word-size set
-        64 block-size set
-        byte-array>sha2
+TUPLE: sha2-state K H word-size block-size ;
 
-    ] with-scope ;
+TUPLE: sha-256-state < sha2-state ;
+
+: <sha-256-state> ( -- sha2-state )
+    sha-256-state new
+        K-256 >>K
+        initial-H-256 >>H
+        4 >>word-size
+        64 >>block-size ; 
+
+M: sha-256 checksum-bytes
+    drop
+    <sha-256-state> sha2 [
+        byte-array>sha2
+    ] with-variable ;

From e033f92e0ceac8c27d102792c8757db9b88c56ee Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 17:39:11 -0500
Subject: [PATCH 33/68] remove dynamic variables from sha2

---
 basis/checksums/sha2/sha2.factor | 89 +++++++++++++++-----------------
 1 file changed, 41 insertions(+), 48 deletions(-)

diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index ff19c4c9a8..d019a6913b 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -3,7 +3,7 @@
 USING: kernel splitting grouping math sequences namespaces make
 io.binary math.bitwise checksums checksums.common
 sbufs strings combinators.smart math.ranges fry combinators
-accessors ;
+accessors locals ;
 IN: checksums.sha2
 
 <PRIVATE
@@ -83,26 +83,31 @@ CONSTANT: K-256
     } 2cleave set-nth ; inline
 
 : ch ( x y z -- x' )
-    [ bitxor bitand ] keep bitxor ;
+    [ bitxor bitand ] keep bitxor ; inline
 
 : maj ( x y z -- x' )
-    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ;
-
-: prepare-message-schedule ( seq -- w-seq )
-    sha2 get word-size>> <sliced-groups> [ be> ] map sha2 get block-size>> 0 pad-tail
-    16 64 [a,b) over '[ _ process-M-256 ] each ;
+    [ [ bitand ] [ bitor ] 2bi ] dip bitand bitor ; inline
 
 : slice3 ( n seq -- a b c )
     [ dup 3 + ] dip <slice> first3 ; inline
 
-: T1 ( W n H -- T1 )
-    [
-        [ swap nth ] keep
-        sha2 get K>> nth +
-    ] dip
-    [ e swap slice3 ch w+ ]
-    [ e swap nth S1-256 w+ ]
-    [ h swap nth w+ ] tri ;
+: pad-initial-bytes ( string -- padded-string )
+    dup [
+        HEX: 80 ,
+        length
+        [ HEX: 3f bitand calculate-pad-length 0 <string> % ]
+        [ 3 shift 8 >be % ] bi
+    ] "" make append ;
+
+: seq>byte-array ( seq n -- string )
+    '[ _ >be ] map B{ } join ;
+
+:: T1 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-256 w+
+    h H nth w+ ;
 
 : T2 ( H -- T2 )
     [ a swap nth S0-256 ]
@@ -116,37 +121,28 @@ CONSTANT: K-256
     d c pick exchange
     c b pick exchange
     b a pick exchange
-    [ w+ a ] dip set-nth ;
+    [ w+ a ] dip set-nth ; inline
 
-: process-chunk ( M block-size H-cloned -- )
-    [
-        '[
-            _
-            [ T1 ]
-            [ T2 ]
-            [ update-H ] tri 
-        ] with each
-    ] keep sha2 get H>> [ w+ ] 2map sha2 get (>>H) ;
+: prepare-message-schedule ( seq sha2 -- w-seq )
+    [ word-size>> <sliced-groups> [ be> ] map ]
+    [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ;
 
-: pad-initial-bytes ( string -- padded-string )
-    dup [
-        HEX: 80 ,
-        length 
-        [ HEX: 3f bitand calculate-pad-length 0 <string> % ]
-        [ 3 shift 8 >be % ] bi
-    ] "" make append ;
-
-: seq>byte-array ( seq n -- string )
-    '[ _ >be ] map B{ } join ;
-
-: byte-array>sha2 ( byte-array -- string )
-    pad-initial-bytes
-    sha2 get block-size>> <sliced-groups>
-    [
-        prepare-message-schedule
-        sha2 get [ block-size>> ] [ H>> clone ] bi process-chunk
+:: process-chunk ( M block-size cloned-H sha2 -- )
+    block-size [
+        M cloned-H sha2 T1
+        cloned-H T2
+        cloned-H update-H 
     ] each
-    sha2 get H>> 4 seq>byte-array ;
+    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ;
+
+:: byte-array>sha2 ( bytes state -- string )
+    bytes pad-initial-bytes
+    state block-size>> <sliced-groups>
+    [
+        state prepare-message-schedule
+        state [ block-size>> ] [ H>> clone ] bi state process-chunk
+    ] each
+    state H>> 4 seq>byte-array ;
 
 PRIVATE>
 
@@ -163,10 +159,7 @@ TUPLE: sha-256-state < sha2-state ;
         K-256 >>K
         initial-H-256 >>H
         4 >>word-size
-        64 >>block-size ; 
+        64 >>block-size ;
 
 M: sha-256 checksum-bytes
-    drop
-    <sha-256-state> sha2 [
-        byte-array>sha2
-    ] with-variable ;
+    drop <sha-256-state> byte-array>sha2 ;

From 0e4f82f663a166581990fefb806ad545d9c2eaff Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 18:11:13 -0500
Subject: [PATCH 34/68] support sha-224, add constants for all sha2

---
 basis/checksums/sha2/sha2-tests.factor |  43 ++++++++--
 basis/checksums/sha2/sha2.factor       | 108 +++++++++++++++++++++----
 2 files changed, 130 insertions(+), 21 deletions(-)

diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor
index 2f4e3c51c4..1476f04e75 100644
--- a/basis/checksums/sha2/sha2-tests.factor
+++ b/basis/checksums/sha2/sha2-tests.factor
@@ -1,7 +1,36 @@
-USING: arrays kernel math namespaces sequences tools.test checksums.sha2 checksums ;
-[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ] [ "" sha-256 checksum-bytes hex-string ] unit-test
-[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ] [ "abc" sha-256 checksum-bytes hex-string ] unit-test
-[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ] [ "message digest" sha-256 checksum-bytes hex-string ] unit-test
-[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ] [ "abcdefghijklmnopqrstuvwxyz" sha-256 checksum-bytes hex-string ] unit-test
-[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" sha-256 checksum-bytes hex-string ] unit-test
-[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" sha-256 checksum-bytes hex-string ] unit-test
+USING: arrays kernel math namespaces sequences tools.test
+checksums.sha2 checksums ;
+IN: checksums.sha2.tests
+
+: test-checksum ( text identifier -- checksum )
+    checksum-bytes hex-string ;
+
+[ "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525" ]
+[
+    "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq"
+    sha-224 test-checksum
+] unit-test
+
+[ "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]
+[ "" sha-256 test-checksum ] unit-test
+
+[ "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" ]
+[ "abc" sha-256 test-checksum ] unit-test
+
+[ "f7846f55cf23e14eebeab5b4e1550cad5b509e3348fbc4efa3a1413d393cb650" ]
+[ "message digest" sha-256 test-checksum ] unit-test
+
+[ "71c480df93d6ae2f1efad1447c66c9525e316218cf51fc8d9ed832f2daf18b73" ]
+[ "abcdefghijklmnopqrstuvwxyz" sha-256 test-checksum ] unit-test
+
+[ "db4bfcbd4da0cd85a60c3c37d3fbd8805c77f15fc6b1fdfe614ee0a7c8fdb4c0" ]
+[
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
+    sha-256 test-checksum
+] unit-test
+
+[ "f371bc4a311f2b009eef952dd83ca80e2b60026c8e935592d0f9c308453c813e" ]
+[
+    "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
+    sha-256 test-checksum
+] unit-test
diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index d019a6913b..6a695b0965 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -19,12 +19,42 @@ CONSTANT: f 5
 CONSTANT: g 6
 CONSTANT: h 7
 
+CONSTANT: initial-H-224
+    {
+        HEX: c1059ed8 HEX: 367cd507 HEX: 3070dd17 HEX: f70e5939
+        HEX: ffc00b31 HEX: 68581511 HEX: 64f98fa7 HEX: befa4fa4
+    }
+
 CONSTANT: initial-H-256
     {
         HEX: 6a09e667 HEX: bb67ae85 HEX: 3c6ef372 HEX: a54ff53a
         HEX: 510e527f HEX: 9b05688c HEX: 1f83d9ab HEX: 5be0cd19
     }
 
+CONSTANT: initial-H-384
+    {
+        HEX: cbbb9d5dc1059ed8
+        HEX: 629a292a367cd507
+        HEX: 9159015a3070dd17
+        HEX: 152fecd8f70e5939
+        HEX: 67332667ffc00b31
+        HEX: 8eb44a8768581511
+        HEX: db0c2e0d64f98fa7
+        HEX: 47b5481dbefa4fa4
+    }
+
+CONSTANT: initial-H-512
+    {
+        HEX: 6a09e667f3bcc908
+        HEX: bb67ae8584caa73b
+        HEX: 3c6ef372fe94f82b
+        HEX: a54ff53a5f1d36f1
+        HEX: 510e527fade682d1
+        HEX: 9b05688c2b3e6c1f
+        HEX: 1f83d9abfb41bd6b
+        HEX: 5be0cd19137e2179
+    }
+
 CONSTANT: K-256
     {
         HEX: 428a2f98 HEX: 71374491 HEX: b5c0fbcf HEX: e9b5dba5
@@ -45,6 +75,29 @@ CONSTANT: K-256
         HEX: 90befffa HEX: a4506ceb HEX: bef9a3f7 HEX: c67178f2
     }
 
+CONSTANT: K-384
+    {
+        HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 
+        HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 
+        HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 
+        HEX: 983e5152ee66dfab HEX: a831c66d2db43210 HEX: b00327c898fb213f HEX: bf597fc7beef0ee4 
+        HEX: c6e00bf33da88fc2 HEX: d5a79147930aa725 HEX: 06ca6351e003826f HEX: 142929670a0e6e70 
+        HEX: 27b70a8546d22ffc HEX: 2e1b21385c26c926 HEX: 4d2c6dfc5ac42aed HEX: 53380d139d95b3df 
+        HEX: 650a73548baf63de HEX: 766a0abb3c77b2a8 HEX: 81c2c92e47edaee6 HEX: 92722c851482353b 
+        HEX: a2bfe8a14cf10364 HEX: a81a664bbc423001 HEX: c24b8b70d0f89791 HEX: c76c51a30654be30 
+        HEX: d192e819d6ef5218 HEX: d69906245565a910 HEX: f40e35855771202a HEX: 106aa07032bbd1b8 
+        HEX: 19a4c116b8d2d0c8 HEX: 1e376c085141ab53 HEX: 2748774cdf8eeb99 HEX: 34b0bcb5e19b48a8 
+        HEX: 391c0cb3c5c95a63 HEX: 4ed8aa4ae3418acb HEX: 5b9cca4f7763e373 HEX: 682e6ff3d6b2b8a3 
+        HEX: 748f82ee5defb2fc HEX: 78a5636f43172f60 HEX: 84c87814a1f0ab72 HEX: 8cc702081a6439ec 
+        HEX: 90befffa23631e28 HEX: a4506cebde82bde9 HEX: bef9a3f7b2c67915 HEX: c67178f2e372532b 
+        HEX: ca273eceea26619c HEX: d186b8c721c0c207 HEX: eada7dd6cde0eb1e HEX: f57d4f7fee6ed178 
+        HEX: 06f067aa72176fba HEX: 0a637dc5a2c898a6 HEX: 113f9804bef90dae HEX: 1b710b35131c471b 
+        HEX: 28db77f523047d84 HEX: 32caab7b40c72493 HEX: 3c9ebe0a15c9bebc HEX: 431d67c49c100d4c 
+        HEX: 4cc5d4becb3e42b6 HEX: 597f299cfc657e2a HEX: 5fcb6fab3ad6faec HEX: 6c44198c4a475817
+    }
+
+ALIAS: K-512 K-384
+
 : s0-256 ( x -- x' )
     [
         [ -7 bitroll-32 ]
@@ -107,11 +160,11 @@ CONSTANT: K-256
     n sha2 K>> nth +
     e H slice3 ch w+
     e H nth S1-256 w+
-    h H nth w+ ;
+    h H nth w+ ; inline
 
 : T2 ( H -- T2 )
     [ a swap nth S0-256 ]
-    [ a swap slice3 maj w+ ] bi ;
+    [ a swap slice3 maj w+ ] bi ; inline
 
 : update-H ( T1 T2 H -- )
     h g pick exchange
@@ -125,33 +178,53 @@ CONSTANT: K-256
 
 : prepare-message-schedule ( seq sha2 -- w-seq )
     [ word-size>> <sliced-groups> [ be> ] map ]
-    [ block-size>> 0 pad-tail 16 64 [a,b) over '[ _ process-M-256 ] each ] bi ;
+    [
+        block-size>> 0 pad-tail 16 64 [a,b) over
+        '[ _ process-M-256 ] each
+    ] bi ; inline
 
 :: process-chunk ( M block-size cloned-H sha2 -- )
     block-size [
         M cloned-H sha2 T1
         cloned-H T2
-        cloned-H update-H 
+        cloned-H update-H
     ] each
-    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ;
+    cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
 
-:: byte-array>sha2 ( bytes state -- string )
-    bytes pad-initial-bytes
-    state block-size>> <sliced-groups>
-    [
-        state prepare-message-schedule
-        state [ block-size>> ] [ H>> clone ] bi state process-chunk
-    ] each
-    state H>> 4 seq>byte-array ;
+: sha2-steps ( sliced-groups state -- )
+    '[
+        _
+        [ prepare-message-schedule ]
+        [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi
+    ] each ;
+
+: byte-array>sha2 ( bytes state -- )
+    [ [ pad-initial-bytes ] [ block-size>> ] bi* <sliced-groups> ]
+    [ sha2-steps ] bi ;
 
 PRIVATE>
 
+SINGLETON: sha-224
 SINGLETON: sha-256
+SINGLETON: sha-384
+SINGLETON: sha-512
 
+INSTANCE: sha-224 checksum
 INSTANCE: sha-256 checksum
+INSTANCE: sha-384 checksum
+INSTANCE: sha-512 checksum
 
 TUPLE: sha2-state K H word-size block-size ;
 
+TUPLE: sha-224-state < sha2-state ;
+
+: <sha-224-state> ( -- sha2-state )
+    sha-224-state new
+        K-256 >>K
+        initial-H-224 >>H
+        4 >>word-size
+        64 >>block-size ;
+
 TUPLE: sha-256-state < sha2-state ;
 
 : <sha-256-state> ( -- sha2-state )
@@ -161,5 +234,12 @@ TUPLE: sha-256-state < sha2-state ;
         4 >>word-size
         64 >>block-size ;
 
+M: sha-224 checksum-bytes
+    drop <sha-224-state>
+    [ byte-array>sha2 ]
+    [ H>> 7 head 4 seq>byte-array ] bi ;
+
 M: sha-256 checksum-bytes
-    drop <sha-256-state> byte-array>sha2 ;
+    drop <sha-256-state>
+    [ byte-array>sha2 ]
+    [ H>> 4 seq>byte-array ] bi ;

From 097ce4c6dda63ea96cc73d3d9082871b347e2d46 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 8 May 2009 19:00:06 -0500
Subject: [PATCH 35/68] implementing sha2 512

---
 basis/checksums/common/common.factor   |  3 +
 basis/checksums/sha2/sha2-tests.factor |  6 ++
 basis/checksums/sha2/sha2.factor       | 93 +++++++++++++++++++-------
 3 files changed, 78 insertions(+), 24 deletions(-)

diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor
index 0ae4328446..01cc2cb739 100644
--- a/basis/checksums/common/common.factor
+++ b/basis/checksums/common/common.factor
@@ -9,6 +9,9 @@ SYMBOL: bytes-read
 : calculate-pad-length ( length -- length' )
     [ 56 < 55 119 ? ] keep - ;
 
+: calculate-pad-length-long ( length -- length' )
+    [ 112 < 111 249 ? ] keep - ;
+
 : pad-last-block ( str big-endian? length -- str )
     [
         [ % ] 2dip HEX: 80 ,
diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor
index 1476f04e75..f224d497a6 100644
--- a/basis/checksums/sha2/sha2-tests.factor
+++ b/basis/checksums/sha2/sha2-tests.factor
@@ -34,3 +34,9 @@ IN: checksums.sha2.tests
     "12345678901234567890123456789012345678901234567890123456789012345678901234567890"
     sha-256 test-checksum
 ] 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 6a695b0965..1abed088a3 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -6,9 +6,31 @@ sbufs strings combinators.smart math.ranges fry combinators
 accessors locals ;
 IN: checksums.sha2
 
-<PRIVATE
+SINGLETON: sha-224
+SINGLETON: sha-256
+SINGLETON: sha-384
+SINGLETON: sha-512
 
-SYMBOL: sha2
+INSTANCE: sha-224 checksum
+INSTANCE: sha-256 checksum
+INSTANCE: sha-384 checksum
+INSTANCE: sha-512 checksum
+
+TUPLE: sha2-state K H word-size block-size ;
+
+TUPLE: sha2-short < sha2-state ;
+
+TUPLE: sha2-long < sha2-state ;
+
+TUPLE: sha-224-state < sha2-short ;
+
+TUPLE: sha-256-state < sha2-short ;
+
+TUPLE: sha-384-state < sha2-long ;
+
+TUPLE: sha-512-state < sha2-long ;
+
+<PRIVATE
 
 CONSTANT: a 0
 CONSTANT: b 1
@@ -77,6 +99,10 @@ CONSTANT: K-256
 
 CONSTANT: K-384
     {
+
+        HEX: 428a2f98d728ae22 HEX: 7137449123ef65cd HEX: b5c0fbcfec4d3b2f HEX: e9b5dba58189dbbc 
+        HEX: 3956c25bf348b538 HEX: 59f111f1b605d019 HEX: 923f82a4af194f9b HEX: ab1c5ed5da6d8118 
+        HEX: d807aa98a3030242 HEX: 12835b0145706fbe HEX: 243185be4ee4b28c HEX: 550c7dc3d5ffb4e2
         HEX: 72be5d74f27b896f HEX: 80deb1fe3b1696b1 HEX: 9bdc06a725c71235 HEX: c19bf174cf692694 
         HEX: e49b69c19ef14ad2 HEX: efbe4786384f25e3 HEX: 0fc19dc68b8cd5b5 HEX: 240ca1cc77ac9c65 
         HEX: 2de92c6f592b0275 HEX: 4a7484aa6ea6e483 HEX: 5cb0a9dcbd41fbd4 HEX: 76f988da831153b5 
@@ -144,14 +170,25 @@ ALIAS: K-512 K-384
 : slice3 ( n seq -- a b c )
     [ dup 3 + ] dip <slice> first3 ; inline
 
-: pad-initial-bytes ( string -- padded-string )
+GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
+
+M: sha2-short pad-initial-bytes ( string sha2 -- padded-string )
+    drop
     dup [
         HEX: 80 ,
         length
-        [ HEX: 3f bitand calculate-pad-length 0 <string> % ]
+        [ 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 16 >be % ] bi
+    ] "" make append ;
+
 : seq>byte-array ( seq n -- string )
     '[ _ >be ] map B{ } join ;
 
@@ -179,7 +216,7 @@ ALIAS: K-512 K-384
 : prepare-message-schedule ( seq sha2 -- w-seq )
     [ word-size>> <sliced-groups> [ be> ] map ]
     [
-        block-size>> 0 pad-tail 16 64 [a,b) over
+        block-size>> [ 0 pad-tail 16 ] keep [a,b) over
         '[ _ process-M-256 ] each
     ] bi ; inline
 
@@ -199,25 +236,9 @@ ALIAS: K-512 K-384
     ] each ;
 
 : byte-array>sha2 ( bytes state -- )
-    [ [ pad-initial-bytes ] [ block-size>> ] bi* <sliced-groups> ]
+    [ [ pad-initial-bytes ] [ nip block-size>> ] 2bi <sliced-groups> ]
     [ sha2-steps ] bi ;
 
-PRIVATE>
-
-SINGLETON: sha-224
-SINGLETON: sha-256
-SINGLETON: sha-384
-SINGLETON: sha-512
-
-INSTANCE: sha-224 checksum
-INSTANCE: sha-256 checksum
-INSTANCE: sha-384 checksum
-INSTANCE: sha-512 checksum
-
-TUPLE: sha2-state K H word-size block-size ;
-
-TUPLE: sha-224-state < sha2-state ;
-
 : <sha-224-state> ( -- sha2-state )
     sha-224-state new
         K-256 >>K
@@ -225,8 +246,6 @@ TUPLE: sha-224-state < sha2-state ;
         4 >>word-size
         64 >>block-size ;
 
-TUPLE: sha-256-state < sha2-state ;
-
 : <sha-256-state> ( -- sha2-state )
     sha-256-state new
         K-256 >>K
@@ -234,6 +253,22 @@ TUPLE: sha-256-state < sha2-state ;
         4 >>word-size
         64 >>block-size ;
 
+: <sha-384-state> ( -- sha2-state )
+    sha-384-state new
+        K-384 >>K
+        initial-H-384 >>H
+        8 >>word-size
+        80 >>block-size ;
+
+: <sha-512-state> ( -- sha2-state )
+    sha-512-state new
+        K-512 >>K
+        initial-H-512 >>H
+        8 >>word-size
+        80 >>block-size ;
+
+PRIVATE>
+
 M: sha-224 checksum-bytes
     drop <sha-224-state>
     [ byte-array>sha2 ]
@@ -243,3 +278,13 @@ M: sha-256 checksum-bytes
     drop <sha-256-state>
     [ byte-array>sha2 ]
     [ H>> 4 seq>byte-array ] bi ;
+
+M: sha-384 checksum-bytes
+    drop <sha-384-state>
+    [ byte-array>sha2 ]
+    [ H>> 6 head 8 seq>byte-array ] bi ;
+
+M: sha-512 checksum-bytes
+    drop <sha-512-state>
+    [ byte-array>sha2 ]
+    [ H>> 8 seq>byte-array ] bi ;

From 6913653d6233b93eb700edc4e1abd5b285fef5e0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.(none)>
Date: Sat, 9 May 2009 13:54:18 -0500
Subject: [PATCH 36/68] use bi, call >string on c-strings from tar

---
 extra/crypto/hmac/hmac.factor | 4 ++--
 extra/tar/tar.factor          | 2 +-
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/crypto/hmac/hmac.factor b/extra/crypto/hmac/hmac.factor
index 6e6229f182..9a668aa23a 100755
--- a/extra/crypto/hmac/hmac.factor
+++ b/extra/crypto/hmac/hmac.factor
@@ -31,8 +31,8 @@ MEMO: opad ( -- seq ) 64 HEX: 5c <array> ;
 
 : init-hmac ( K -- o i )
     64 0 pad-tail 
-    [ opad seq-bitxor ] keep
-    ipad seq-bitxor ;
+    [ opad seq-bitxor ]
+    [ ipad seq-bitxor ] bi ;
 
 PRIVATE>
 
diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor
index e281871252..93554c146a 100755
--- a/extra/tar/tar.factor
+++ b/extra/tar/tar.factor
@@ -18,7 +18,7 @@ ERROR: checksum-error header ;
 : trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
 
 : read-c-string ( n -- str/f )
-    read [ zero? ] trim-tail [ f ] when-empty ;
+    read [ zero? ] trim-tail [ f ] when-empty >string ;
 
 : read-tar-header ( -- obj )
     \ tar-header new

From 97da4e994bc148aa782fd5098d838fb788f90f72 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.(none)>
Date: Sat, 9 May 2009 13:54:42 -0500
Subject: [PATCH 37/68] 64-bit add/subtract/multiply

---
 basis/math/bitwise/bitwise.factor | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
index 73d111f91e..4fe2340643 100755
--- a/basis/math/bitwise/bitwise.factor
+++ b/basis/math/bitwise/bitwise.factor
@@ -35,6 +35,11 @@ IN: math.bitwise
 : w- ( int int -- int ) - 32 bits ; inline
 : w* ( int int -- int ) * 32 bits ; inline
 
+! 64-bit arithmetic
+: W+ ( int int -- int ) + 64 bits ; inline
+: W- ( int int -- int ) - 64 bits ; inline
+: W* ( int int -- int ) * 64 bits ; inline
+
 ! flags
 MACRO: flags ( values -- )
     [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;

From f0bd82b2dd7f08f1d024c8b8d8a57ec053dfd5bb Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Thu, 7 May 2009 10:32:32 +0200
Subject: [PATCH 38/68] reworked insert, save and update; added save-deep

---
 extra/mongodb/tuple/tuple.factor | 16 ++++++++++++----
 1 file changed, 12 insertions(+), 4 deletions(-)

diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor
index 9173957979..e5e4867d71 100644
--- a/extra/mongodb/tuple/tuple.factor
+++ b/extra/mongodb/tuple/tuple.factor
@@ -54,14 +54,22 @@ M: mdb-persistent id-selector
            <update> >upsert update ] assoc-each ; inline
 PRIVATE>
  
-: save-tuple ( tuple -- )
-   tuple>storable [ (save-tuples) ] assoc-each ;
+: save-tuple-deep ( tuple -- )
+    tuple>storable [ (save-tuples) ] assoc-each ; 
  
 : update-tuple ( tuple -- )
-   save-tuple ;
+    [ tuple-collection name>> ]
+    [ id-selector ]
+    [ tuple>assoc ] tri
+    <mdb-update-msg> update ;
+
+: save-tuple ( tuple -- )
+    update-tuple ;
 
 : insert-tuple ( tuple -- )
-   save-tuple ;
+   [ tuple-collection name>> ]
+   [ tuple>assoc ] bi
+   <mdb-insert-msg> save ;
 
 : delete-tuple ( tuple -- )
    [ tuple-collection name>> ] keep

From 5399fe1d3dbeb5ee4d13b98401041694bfffd4b0 Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Thu, 7 May 2009 12:01:01 +0200
Subject: [PATCH 39/68] some bug fixes

---
 extra/mongodb/tuple/collection/collection.factor | 4 +++-
 extra/mongodb/tuple/tuple.factor                 | 2 +-
 2 files changed, 4 insertions(+), 2 deletions(-)

diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor
index 1bd2d94e69..60b2d25764 100644
--- a/extra/mongodb/tuple/collection/collection.factor
+++ b/extra/mongodb/tuple/collection/collection.factor
@@ -92,6 +92,8 @@ GENERIC: mdb-index-map ( tuple -- sequence )
       [ ] [ name>> ] bi  H{ } clone [ set-at ] keep
     ] [ 2drop H{ } clone ] if ;
 
+
+
 PRIVATE>
 
 : MDB_ADDON_SLOTS ( -- slots )
@@ -116,7 +118,7 @@ PRIVATE>
     [ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline
 
 : set-index-map ( class index-list -- )
-    [ [ dup user-defined-key-index ] dip index-list>map  ] output>sequence
+    [ dup user-defined-key-index ] dip index-list>map 2array
     assoc-combine MDB_INDEX_MAP set-word-prop ; inline
 
 M: tuple-class tuple-collection ( tuple -- mdb-collection )
diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor
index e5e4867d71..8f7504d9bc 100644
--- a/extra/mongodb/tuple/tuple.factor
+++ b/extra/mongodb/tuple/tuple.factor
@@ -69,7 +69,7 @@ PRIVATE>
 : insert-tuple ( tuple -- )
    [ tuple-collection name>> ]
    [ tuple>assoc ] bi
-   <mdb-insert-msg> save ;
+   save ;
 
 : delete-tuple ( tuple -- )
    [ tuple-collection name>> ] keep

From 87caa8d7a000361e37a19579136cb9baeb2f29ab Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Sun, 10 May 2009 11:54:42 +0200
Subject: [PATCH 40/68] added delete-tuples word

---
 extra/mongodb/tuple/tuple.factor | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor
index 8f7504d9bc..1b4b3cd4f1 100644
--- a/extra/mongodb/tuple/tuple.factor
+++ b/extra/mongodb/tuple/tuple.factor
@@ -75,6 +75,9 @@ PRIVATE>
    [ tuple-collection name>> ] keep
    id-selector delete ;
 
+: delete-tuples ( seq -- )
+    [ delete-tuple ] each ;
+
 : tuple>query ( tuple -- query )
    [ tuple-collection name>> ] keep
    tuple>selector <query> ;

From e301d29f903fd9a11427ee6fbe339b26ea557df5 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 10 May 2009 10:41:50 -0500
Subject: [PATCH 41/68] cut perlin-noise time in half

---
 .../math/polynomials/polynomials-docs.factor  |  10 +-
 basis/math/polynomials/polynomials.factor     |  12 +-
 basis/math/vectors/vectors.factor             |  10 ++
 .../affine-transforms.factor                  |   2 +
 extra/noise/noise.factor                      | 105 ++++++++++--------
 5 files changed, 85 insertions(+), 54 deletions(-)

diff --git a/basis/math/polynomials/polynomials-docs.factor b/basis/math/polynomials/polynomials-docs.factor
index edffa5377d..6617556270 100644
--- a/basis/math/polynomials/polynomials-docs.factor
+++ b/basis/math/polynomials/polynomials-docs.factor
@@ -93,7 +93,13 @@ HELP: pdiff
 { $description "Finds the derivative of " { $snippet "p" } "." } ;
 
 HELP: polyval
-{ $values { "p" "a polynomial" } { "x" number } { "p[x]" number } }
+{ $values { "x" number } { "p" "a polynomial" } { "p[x]" number } }
 { $description "Evaluate " { $snippet "p" } " with the input " { $snippet "x" } "." }
-{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } 2 polyval ." "5" } } ;
+{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval ." "5" } } ;
 
+HELP: polyval*
+{ $values { "p" "a literal polynomial" } }
+{ $description "Macro version of " { $link polyval } ". Evaluates the literal polynomial " { $snippet "p" } " at the value off the top of the stack." }
+{ $examples { $example "USING: math.polynomials prettyprint ;" "2 { 1 0 1 } polyval* ." "5" } } ;
+
+{ polyval polyval* } related-words
diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor
index f65c4ecaaf..fd6eda4a90 100644
--- a/basis/math/polynomials/polynomials.factor
+++ b/basis/math/polynomials/polynomials.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel make math math.order math.vectors sequences
-    splitting vectors ;
+    splitting vectors macros combinators ;
 IN: math.polynomials
 
 <PRIVATE
@@ -80,6 +80,12 @@ PRIVATE>
 : pdiff ( p -- p' )
     dup length v* { 0 } ?head drop ;
 
-: polyval ( p x -- p[x] )
-    [ dup length ] dip powers v. ;
+: polyval ( x p -- p[x] )
+    [ length swap powers ] [ nip ] 2bi v. ;
+
+MACRO: polyval* ( p -- )
+    reverse
+    [ 1 tail [ \ * swap \ + [ ] 3sequence ] map ]
+    [ first \ drop swap [ ] 2sequence ] bi
+    prefix \ cleave [ ] 2sequence ;
 
diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor
index 17f6c39f04..bad2733bbf 100644
--- a/basis/math/vectors/vectors.factor
+++ b/basis/math/vectors/vectors.factor
@@ -41,6 +41,13 @@ IN: math.vectors
 : set-axis ( u v axis -- w )
     [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
 
+: 2tetra@ ( p q r s t u v w quot -- )
+    dup [ [ 2bi@ ] curry 4dip ] dip 2bi@ ; inline
+
+: trilerp ( aaa baa aba bba aab bab abb bbb {t,u,v} -- a_tuv )
+    [ first lerp ] [ second lerp ] [ third lerp ] tri-curry
+    [ 2tetra@ ] [ 2bi@ ] [ call ] tri* ;
+
 : bilerp ( aa ba ab bb {t,u} -- a_tu )
     [ first lerp ] [ second lerp ] bi-curry
     [ 2bi@ ] [ call ] bi* ;
@@ -72,3 +79,6 @@ HINTS: v. { array array } ;
 
 HINTS: vlerp { array array array } ;
 HINTS: vnlerp { array array object } ;
+
+HINTS: bilerp { object object object object array } ;
+HINTS: trilerp { object object object object object object object object array } ;
diff --git a/extra/math/affine-transforms/affine-transforms.factor b/extra/math/affine-transforms/affine-transforms.factor
index 20b73ba678..d1fd602f72 100644
--- a/extra/math/affine-transforms/affine-transforms.factor
+++ b/extra/math/affine-transforms/affine-transforms.factor
@@ -17,6 +17,8 @@ CONSTANT: identity-transform T{ affine-transform f { 1.0 0.0 } { 0.0 1.0 } { 0.0
     [ drop origin>> ] 2tri
     v+ v+ ;
 
+: <identity> ( -- a )
+    { 1.0 0.0 } { 0.0 1.0 } { 0.0 0.0 } <affine-transform> ;
 : <translation> ( origin -- a )
     [ { 1.0 0.0 } { 0.0 1.0 } ] dip <affine-transform> ;
 : <rotation> ( theta -- transform )
diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor
index c28768283c..46704eed36 100644
--- a/extra/noise/noise.factor
+++ b/extra/noise/noise.factor
@@ -1,61 +1,60 @@
 USING: byte-arrays combinators fry images kernel locals math
 math.affine-transforms math.functions math.order
 math.polynomials math.vectors random random.mersenne-twister
-sequences sequences.product ;
+sequences sequences.product hints arrays sequences.private
+combinators.short-circuit math.private ;
 IN: noise
 
 : <perlin-noise-table> ( -- table )
-    256 iota >byte-array randomize dup append ;
+    256 iota >byte-array randomize dup append ; inline
 
 : with-seed ( seed quot -- )
     [ <mersenne-twister> ] dip with-random ; inline
 
 <PRIVATE
 
-: fade ( point -- point' )
-    { 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ;
+: (fade) ( x y z -- x' y' z' )
+    [ { 0.0 0.0 0.0 10.0 -15.0 6.0 } polyval* ] tri@ ;
 
-:: grad ( hash gradients -- gradient )
-    hash 8  bitand zero? [ gradients first ] [ gradients second ] if
+HINTS: (fade) { float float float } ;
+
+: fade ( point -- point' )
+    first3 (fade) 3array ; inline
+
+:: grad ( hash x y z -- gradient )
+    hash 8  bitand zero? [ x ] [ y ] if
         :> u
     hash 12 bitand zero?
-    [ gradients second ]
-    [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if
+    [ y ] [ hash 13 bitand 12 = [ x ] [ z ] if ] if
         :> v
 
     hash 1 bitand zero? [ u ] [ u neg ] if
     hash 2 bitand zero? [ v ] [ v neg ] if + ;
 
+HINTS: grad { fixnum float float float } ;
+
 : unit-cube ( point -- cube )
-    [ floor >fixnum 256 mod ] map ;
+    [ floor >fixnum 256 rem ] map ;
 
-:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb )
-    cube first  :> x
-    cube second :> y
-    cube third  :> z
-    x     table nth y + :> a
-    x 1 + table nth y + :> b
+:: hashes ( table x y z -- aaa baa aba bba aab bab abb bbb )
+    x               table nth-unsafe y fixnum+fast :> a
+    x 1 fixnum+fast table nth-unsafe y fixnum+fast :> b
 
-    a     table nth z + :> aa
-    b     table nth z + :> ba
-    a 1 + table nth z + :> ab
-    b 1 + table nth z + :> bb
+    a               table nth-unsafe z fixnum+fast :> aa
+    b               table nth-unsafe z fixnum+fast :> ba
+    a 1 fixnum+fast table nth-unsafe z fixnum+fast :> ab
+    b 1 fixnum+fast table nth-unsafe z fixnum+fast :> bb
 
-    aa     table nth 
-    ba     table nth 
-    ab     table nth 
-    bb     table nth 
-    aa 1 + table nth 
-    ba 1 + table nth 
-    ab 1 + table nth 
-    bb 1 + table nth ;
+    aa               table nth-unsafe 
+    ba               table nth-unsafe 
+    ab               table nth-unsafe 
+    bb               table nth-unsafe 
+    aa 1 fixnum+fast table nth-unsafe 
+    ba 1 fixnum+fast table nth-unsafe 
+    ab 1 fixnum+fast table nth-unsafe 
+    bb 1 fixnum+fast table nth-unsafe ; inline
 
-:: 2tetra@ ( p q r s t u v w quot -- )
-    p q quot call
-    r s quot call
-    t u quot call
-    v w quot call
-    ; inline
+HINTS: hashes { byte-array fixnum fixnum fixnum } ;
 
 : >byte-map ( floats -- bytes )
     [ 255.0 * >fixnum ] B{ } map-as ;
@@ -63,26 +62,33 @@ IN: noise
 : >image ( bytes dim -- image )
     swap [ L f ] dip image boa ;
 
-PRIVATE>
-
-:: perlin-noise ( table point -- value )
+:: perlin-noise-unsafe ( table point -- value )
     point unit-cube :> cube
     point dup vfloor v- :> gradients
     gradients fade :> faded
 
-    table cube hashes {
-        [ gradients                       grad ]
-        [ gradients { -1.0  0.0  0.0 } v+ grad ]
-        [ gradients {  0.0 -1.0  0.0 } v+ grad ]
-        [ gradients { -1.0 -1.0  0.0 } v+ grad ]
-        [ gradients {  0.0  0.0 -1.0 } v+ grad ]
-        [ gradients { -1.0  0.0 -1.0 } v+ grad ]
-        [ gradients {  0.0 -1.0 -1.0 } v+ grad ]
-        [ gradients { -1.0 -1.0 -1.0 } v+ grad ]
+    table cube first3 hashes {
+        [ gradients first3                                    grad ]
+        [ gradients first3 [ 1.0 - ] [       ] [       ] tri* grad ]
+        [ gradients first3 [       ] [ 1.0 - ] [       ] tri* grad ]
+        [ gradients first3 [ 1.0 - ] [ 1.0 - ] [       ] tri* grad ]
+        [ gradients first3 [       ] [       ] [ 1.0 - ] tri* grad ]
+        [ gradients first3 [ 1.0 - ] [       ] [ 1.0 - ] tri* grad ]
+        [ gradients first3 [       ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
+        [ gradients first3 [ 1.0 - ] [ 1.0 - ] [ 1.0 - ] tri* grad ]
     } spread
-    [ faded first lerp ] 2tetra@
-    [ faded second lerp ] 2bi@
-    faded third lerp ;
+    faded trilerp ;
+
+ERROR: invalid-perlin-noise-table table ;
+
+: validate-table ( table -- table )
+    dup { [ byte-array? ] [ length 512 >= ] } 1&&
+    [ invalid-perlin-noise-table ] unless ;
+
+PRIVATE>
+
+: perlin-noise ( table point -- value )
+    [ validate-table ] dip perlin-noise-unsafe ; inline
 
 : normalize-0-1 ( sequence -- sequence' )
     [ supremum ] [ infimum [ - ] keep ] [ ] tri
@@ -92,7 +98,8 @@ PRIVATE>
     [ 0.0 max 1.0 min ] map ;
 
 : perlin-noise-map ( table transform dim -- map ) 
-    [ iota ] map [ a.v 0.0 suffix perlin-noise ] with with product-map ;
+    [ validate-table ] 2dip
+    [ iota ] map [ a.v 0.0 suffix perlin-noise-unsafe ] with with product-map ;
 
 : perlin-noise-byte-map ( table transform dim -- map )
     perlin-noise-map normalize-0-1 >byte-map ;

From 2ce5b4f3f65f32336d2b594f8fc76ceac36bd702 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 12:18:59 -0500
Subject: [PATCH 42/68] working on sha2

---
 basis/checksums/common/common.factor   |  2 +-
 basis/checksums/sha2/sha2-tests.factor |  4 +-
 basis/checksums/sha2/sha2.factor       | 90 +++++++++++++++-----------
 3 files changed, 56 insertions(+), 40 deletions(-)

diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor
index 01cc2cb739..76675f9413 100644
--- a/basis/checksums/common/common.factor
+++ b/basis/checksums/common/common.factor
@@ -10,7 +10,7 @@ SYMBOL: bytes-read
     [ 56 < 55 119 ? ] keep - ;
 
 : calculate-pad-length-long ( length -- length' )
-    [ 112 < 111 249 ? ] keep - ;
+    [ 120 < 119 247 ? ] keep - ;
 
 : pad-last-block ( str big-endian? length -- str )
     [
diff --git a/basis/checksums/sha2/sha2-tests.factor b/basis/checksums/sha2/sha2-tests.factor
index f224d497a6..c14ea5a98d 100644
--- a/basis/checksums/sha2/sha2-tests.factor
+++ b/basis/checksums/sha2/sha2-tests.factor
@@ -38,5 +38,5 @@ IN: checksums.sha2.tests
 
 
 
-[ "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909" ]
-[ "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" sha-512 test-checksum ] 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 1abed088a3..12e32f6c69 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -8,13 +8,9 @@ IN: checksums.sha2
 
 SINGLETON: sha-224
 SINGLETON: sha-256
-SINGLETON: sha-384
-SINGLETON: sha-512
 
 INSTANCE: sha-224 checksum
 INSTANCE: sha-256 checksum
-INSTANCE: sha-384 checksum
-INSTANCE: sha-512 checksum
 
 TUPLE: sha2-state K H word-size block-size ;
 
@@ -26,10 +22,6 @@ TUPLE: sha-224-state < sha2-short ;
 
 TUPLE: sha-256-state < sha2-short ;
 
-TUPLE: sha-384-state < sha2-long ;
-
-TUPLE: sha-512-state < sha2-long ;
-
 <PRIVATE
 
 CONSTANT: a 0
@@ -152,6 +144,34 @@ ALIAS: K-512 K-384
         [ -25 bitroll-32 ] tri
     ] [ bitxor ] reduce-outputs ; inline
 
+: s0-512 ( x -- x' )
+    [
+        [ -1 bitroll-64 ]
+        [ -8 bitroll-64 ]
+        [ -7 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: s1-512 ( x -- x' )
+    [
+        [ -19 bitroll-64 ]
+        [ -61 bitroll-64 ]
+        [ -6 shift ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: S0-512 ( x -- x' )
+    [
+        [ -28 bitroll-64 ]
+        [ -34 bitroll-64 ]
+        [ -39 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
+: S1-512 ( x -- x' )
+    [
+        [ -14 bitroll-64 ]
+        [ -18 bitroll-64 ]
+        [ -41 bitroll-64 ] tri
+    ] [ bitxor ] reduce-outputs ; inline
+
 : process-M-256 ( n seq -- )
     {
         [ [ 16 - ] dip nth ]
@@ -161,6 +181,15 @@ ALIAS: K-512 K-384
         [ ]
     } 2cleave set-nth ; inline
 
+: process-M-512 ( n seq -- )
+    {
+        [ [ 16 - ] dip nth ]
+        [ [ 15 - ] dip nth s0-512 ]
+        [ [ 7 - ] dip nth ]
+        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ ]
+    } 2cleave set-nth ; inline
+
 : ch ( x y z -- x' )
     [ bitxor bitand ] keep bitxor ; inline
 
@@ -186,23 +215,34 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
         HEX: 80 ,
         length
         [ 128 mod calculate-pad-length-long 0 <string> % ]
-        [ 3 shift 16 >be % ] bi
+        [ 3 shift 8 >be % ] bi
     ] "" make append ;
 
 : seq>byte-array ( seq n -- string )
     '[ _ >be ] map B{ } join ;
 
-:: T1 ( n M H sha2 -- T1 )
+:: T1-256 ( n M H sha2 -- T1 )
     n M nth
     n sha2 K>> nth +
     e H slice3 ch w+
     e H nth S1-256 w+
     h H nth w+ ; inline
 
-: T2 ( H -- T2 )
+: T2-256 ( H -- T2 )
     [ a swap nth S0-256 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
+:: T1-512 ( n M H sha2 -- T1 )
+    n M nth
+    n sha2 K>> nth +
+    e H slice3 ch w+
+    e H nth S1-512 w+
+    h H nth w+ ; inline
+
+: T2-512 ( H -- T2 )
+    [ a swap nth S0-512 ]
+    [ a swap slice3 maj w+ ] bi ; inline
+
 : update-H ( T1 T2 H -- )
     h g pick exchange
     g f pick exchange
@@ -222,8 +262,8 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
 
 :: process-chunk ( M block-size cloned-H sha2 -- )
     block-size [
-        M cloned-H sha2 T1
-        cloned-H T2
+        M cloned-H sha2 T1-256
+        cloned-H T2-256
         cloned-H update-H
     ] each
     cloned-H sha2 H>> [ w+ ] 2map sha2 (>>H) ; inline
@@ -253,20 +293,6 @@ M: sha2-long pad-initial-bytes ( string sha2 -- padded-string )
         4 >>word-size
         64 >>block-size ;
 
-: <sha-384-state> ( -- sha2-state )
-    sha-384-state new
-        K-384 >>K
-        initial-H-384 >>H
-        8 >>word-size
-        80 >>block-size ;
-
-: <sha-512-state> ( -- sha2-state )
-    sha-512-state new
-        K-512 >>K
-        initial-H-512 >>H
-        8 >>word-size
-        80 >>block-size ;
-
 PRIVATE>
 
 M: sha-224 checksum-bytes
@@ -278,13 +304,3 @@ M: sha-256 checksum-bytes
     drop <sha-256-state>
     [ byte-array>sha2 ]
     [ H>> 4 seq>byte-array ] bi ;
-
-M: sha-384 checksum-bytes
-    drop <sha-384-state>
-    [ byte-array>sha2 ]
-    [ H>> 6 head 8 seq>byte-array ] bi ;
-
-M: sha-512 checksum-bytes
-    drop <sha-512-state>
-    [ byte-array>sha2 ]
-    [ H>> 8 seq>byte-array ] bi ;

From 9ab5ffa636c61bf12a810f3e64d6b76bdebffa45 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 12:24:19 -0500
Subject: [PATCH 43/68] move math.miller-rabin to math.primes.miller-rabin

---
 basis/math/{ => primes}/miller-rabin/authors.txt               | 0
 basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor  | 0
 basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor | 0
 basis/math/{ => primes}/miller-rabin/miller-rabin.factor       | 0
 basis/math/{ => primes}/miller-rabin/summary.txt               | 0
 5 files changed, 0 insertions(+), 0 deletions(-)
 rename basis/math/{ => primes}/miller-rabin/authors.txt (100%)
 rename basis/math/{ => primes}/miller-rabin/miller-rabin-docs.factor (100%)
 rename basis/math/{ => primes}/miller-rabin/miller-rabin-tests.factor (100%)
 rename basis/math/{ => primes}/miller-rabin/miller-rabin.factor (100%)
 rename basis/math/{ => primes}/miller-rabin/summary.txt (100%)

diff --git a/basis/math/miller-rabin/authors.txt b/basis/math/primes/miller-rabin/authors.txt
similarity index 100%
rename from basis/math/miller-rabin/authors.txt
rename to basis/math/primes/miller-rabin/authors.txt
diff --git a/basis/math/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
similarity index 100%
rename from basis/math/miller-rabin/miller-rabin-docs.factor
rename to basis/math/primes/miller-rabin/miller-rabin-docs.factor
diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
similarity index 100%
rename from basis/math/miller-rabin/miller-rabin-tests.factor
rename to basis/math/primes/miller-rabin/miller-rabin-tests.factor
diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor
similarity index 100%
rename from basis/math/miller-rabin/miller-rabin.factor
rename to basis/math/primes/miller-rabin/miller-rabin.factor
diff --git a/basis/math/miller-rabin/summary.txt b/basis/math/primes/miller-rabin/summary.txt
similarity index 100%
rename from basis/math/miller-rabin/summary.txt
rename to basis/math/primes/miller-rabin/summary.txt

From f30cdb1ea3f2b5407b5111fed18492b0e1be50c6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 12:24:43 -0500
Subject: [PATCH 44/68] update usages of miller-rabin

---
 basis/math/primes/miller-rabin/miller-rabin-docs.factor  | 8 ++++----
 basis/math/primes/miller-rabin/miller-rabin-tests.factor | 6 +++---
 basis/math/primes/miller-rabin/miller-rabin.factor       | 2 +-
 basis/math/primes/primes.factor                          | 5 +++--
 extra/crypto/rsa/rsa.factor                              | 4 ++--
 extra/project-euler/common/common.factor                 | 2 +-
 extra/random/blum-blum-shub/blum-blum-shub.factor        | 2 +-
 7 files changed, 15 insertions(+), 14 deletions(-)

diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
index 4aa318f674..2455dafdd5 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel sequences math ;
-IN: math.miller-rabin
+IN: math.primes.miller-rabin
 
 HELP: find-relative-prime
 { $values
@@ -82,8 +82,8 @@ HELP: unique-primes
 }
 { $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
 
-ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
-"The " { $vocab-link "math.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
+ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test"
+"The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
 "The Miller-Rabin probabilistic primality test:"
 { $subsection miller-rabin }
 { $subsection miller-rabin* }
@@ -97,4 +97,4 @@ ARTICLE: "math.miller-rabin" "Miller-Rabin probabilistic primality test"
 { $subsection next-safe-prime }
 { $subsection random-safe-prime } ;
 
-ABOUT: "math.miller-rabin"
+ABOUT: "math.primes.miller-rabin"
diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
index 9981064ec0..9c635c8f38 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
@@ -1,6 +1,6 @@
-USING: math.miller-rabin tools.test kernel sequences
-math.miller-rabin.private math ;
-IN: math.miller-rabin.tests
+USING: math.primes.miller-rabin tools.test kernel sequences
+math.primes.miller-rabin.private math ;
+IN: math.primes.miller-rabin.tests
 
 [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
 [ t ] [ 2 miller-rabin ] unit-test
diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor
index 991924dfe4..35ee97a897 100755
--- a/basis/math/primes/miller-rabin/miller-rabin.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin.factor
@@ -3,7 +3,7 @@
 USING: combinators kernel locals math math.functions math.ranges
 random sequences sets combinators.short-circuit math.bitwise
 math math.order ;
-IN: math.miller-rabin
+IN: math.primes.miller-rabin
 
 : >odd ( n -- int ) 0 set-bit ; foldable
 
diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor
index 688fdad713..fa1cd5cb63 100644
--- a/basis/math/primes/primes.factor
+++ b/basis/math/primes/primes.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.functions math.miller-rabin
-math.order math.primes.erato math.ranges sequences ;
+USING: combinators kernel math math.functions
+math.primes.miller-rabin math.order math.primes.erato
+math.ranges sequences ;
 IN: math.primes
 
 <PRIVATE
diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor
index 373dd9637c..1da170d197 100644
--- a/extra/crypto/rsa/rsa.factor
+++ b/extra/crypto/rsa/rsa.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.miller-rabin kernel math math.functions namespaces
-sequences accessors ;
+USING: math.primes.miller-rabin kernel math math.functions
+namespaces sequences accessors ;
 IN: crypto.rsa
 
 ! The private key is the only secret.
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index c2ffe26d94..84291f2ce8 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007-2009 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays kernel lists make math math.functions math.matrices
-    math.miller-rabin math.order math.parser math.primes.factors
+    math.primes.miller-rabin math.order math.parser math.primes.factors
     math.primes.lists math.ranges math.ratios namespaces parser prettyprint
     quotations sequences sorting strings unicode.case vocabs vocabs.parser
     words ;
diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor
index dc764fd040..4a52a2f79c 100755
--- a/extra/random/blum-blum-shub/blum-blum-shub.factor
+++ b/extra/random/blum-blum-shub/blum-blum-shub.factor
@@ -1,5 +1,5 @@
 USING: kernel math sequences namespaces
-math.miller-rabin math.functions accessors random ;
+math.primes.miller-rabin math.functions accessors random ;
 IN: random.blum-blum-shub
 
 ! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n

From aae9b78219c426a1df7cd1883e20da19554c0504 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 12:59:35 -0500
Subject: [PATCH 45/68] add lucas-lehmer primality test

---
 basis/math/primes/lucas-lehmer/authors.txt    |  1 +
 .../lucas-lehmer/lucas-lehmer-docs.factor     | 25 +++++++++++++++++
 .../lucas-lehmer/lucas-lehmer-tests.factor    | 13 +++++++++
 .../primes/lucas-lehmer/lucas-lehmer.factor   | 27 +++++++++++++++++++
 4 files changed, 66 insertions(+)
 create mode 100644 basis/math/primes/lucas-lehmer/authors.txt
 create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor
 create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor
 create mode 100644 basis/math/primes/lucas-lehmer/lucas-lehmer.factor

diff --git a/basis/math/primes/lucas-lehmer/authors.txt b/basis/math/primes/lucas-lehmer/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/math/primes/lucas-lehmer/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor
new file mode 100644
index 0000000000..582b59b69a
--- /dev/null
+++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-docs.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel ;
+IN: math.primes.lucas-lehmer
+
+HELP: lucas-lehmer
+{ $values
+    { "p" "a prime number" }
+    { "?" "a boolean" }
+}
+{ $description "Runs the Lucas-Lehmer test on the prime " { $snippet "p" } " and returns " { $link t } " if " { $snippet "(2 ^ p) - 1" } " is prime." }
+{ $examples
+    { $example "! Test that (2 ^ 61) - 1 is prime:"
+               "USING: math.primes.lucas-lehmer prettyprint ;"
+               "61 lucas-lehmer ."
+               "t"
+    }
+} ;
+
+ARTICLE: "math.primes.lucas-lehmer" "Lucas-Lehmer Mersenne Primality test"
+"The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary tests numbers of the form " { $snippet "(2 ^ p) - 1" } " for primality, where " { $snippet "p" } " is prime." $nl
+"Run the Lucas-Lehmer test:"
+{ $subsection lucas-lehmer } ;
+
+ABOUT: "math.primes.lucas-lehmer"
diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor
new file mode 100644
index 0000000000..b114fa8553
--- /dev/null
+++ b/basis/math/primes/lucas-lehmer/lucas-lehmer-tests.factor
@@ -0,0 +1,13 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test math.primes.lucas-lehmer ;
+IN: math.primes.lucas-lehmer.tests
+
+[ t ] [ 2 lucas-lehmer ] unit-test
+[ t ] [ 3 lucas-lehmer ] unit-test
+[ f ] [ 4 lucas-lehmer ] unit-test
+[ t ] [ 5 lucas-lehmer ] unit-test
+[ f ] [ 6 lucas-lehmer ] unit-test
+[ f ] [ 11 lucas-lehmer ] unit-test
+[ t ] [ 13 lucas-lehmer ] unit-test
+[ t ] [ 61 lucas-lehmer ] unit-test
diff --git a/basis/math/primes/lucas-lehmer/lucas-lehmer.factor b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor
new file mode 100644
index 0000000000..a8bf097dbe
--- /dev/null
+++ b/basis/math/primes/lucas-lehmer/lucas-lehmer.factor
@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators fry kernel locals math
+math.primes combinators.short-circuit ;
+IN: math.primes.lucas-lehmer
+
+ERROR: invalid-lucas-lehmer-candidate obj ;
+
+<PRIVATE
+
+: do-lucas-lehmer ( p -- ? )
+    [ drop 4 ] [ 2 - ] [ 2^ 1 - ] tri
+    '[ sq 2 - _ mod ] times 0 = ;
+
+: lucas-lehmer-guard ( obj -- obj )
+    dup { [ integer? ] [ 0 > ] } 1&&
+    [ invalid-lucas-lehmer-candidate ] unless ;
+
+PRIVATE>
+
+: lucas-lehmer ( p -- ? )
+    lucas-lehmer-guard
+    {
+        { [ dup 2 = ] [ drop t ] }
+        { [ dup prime? ] [ do-lucas-lehmer ] }
+        [ drop f ]
+    } cond ;

From 02ddb8005df15b424e5d4e4f57988f9e8f69570c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:39:08 -0500
Subject: [PATCH 46/68] move random-bits* to random, work on docs

---
 .../mersenne-twister-tests.factor                 |  2 +-
 basis/random/random-docs.factor                   | 15 +++++++++++++--
 basis/random/random-tests.factor                  |  2 ++
 basis/random/random.factor                        |  5 ++++-
 4 files changed, 20 insertions(+), 4 deletions(-)

diff --git a/basis/random/mersenne-twister/mersenne-twister-tests.factor b/basis/random/mersenne-twister/mersenne-twister-tests.factor
index c35d7488ac..651e43ef5b 100644
--- a/basis/random/mersenne-twister/mersenne-twister-tests.factor
+++ b/basis/random/mersenne-twister/mersenne-twister-tests.factor
@@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests
     100 [ 100 random ] replicate ;
 
 : test-rng ( seed quot -- )
-    [  <mersenne-twister> ] dip with-random ; inline
+    [ <mersenne-twister> ] dip with-random ; inline
 
 [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
 
diff --git a/basis/random/random-docs.factor b/basis/random/random-docs.factor
index c7600a731f..222ecaf935 100755
--- a/basis/random/random-docs.factor
+++ b/basis/random/random-docs.factor
@@ -40,9 +40,17 @@ HELP: random-bytes
 } ;
 
 HELP: random-bits
-{ $values { "n" "an integer" } { "r" "a random integer" } }
+{ $values { "numbits" integer } { "r" "a random integer" } }
 { $description "Outputs an random integer n bits in length." } ;
 
+HELP: random-bits*
+{ $values
+    { "numbits" integer }
+    { "n" integer }
+}
+{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
+
+
 HELP: with-random
 { $values { "tuple" "a random generator" } { "quot" "a quotation" } }
 { $description "Calls the quotation with the random generator in a dynamic variable.  All random numbers will be generated using this random generator." } ;
@@ -93,6 +101,9 @@ $nl
 "Randomizing a sequence:"
 { $subsection randomize }
 "Deleting a random element from a sequence:"
-{ $subsection delete-random } ;
+{ $subsection delete-random }
+"Random numbers with " { $snippet "n" } " bits:"
+{ $subsection random-bits }
+{ $subsection random-bits* } ;
 
 ABOUT: "random"
diff --git a/basis/random/random-tests.factor b/basis/random/random-tests.factor
index 9607627b3d..2b6ac9b1b8 100644
--- a/basis/random/random-tests.factor
+++ b/basis/random/random-tests.factor
@@ -23,3 +23,5 @@ IN: random.tests
 
 [ f ]
 [ 100 [ { 0 1 } random ] replicate all-equal? ] unit-test
+
+[ 49 ] [ 50 random-bits* log2 ] unit-test
diff --git a/basis/random/random.factor b/basis/random/random.factor
index 6b02c8a3e8..661e771258 100755
--- a/basis/random/random.factor
+++ b/basis/random/random.factor
@@ -45,7 +45,10 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
 
 PRIVATE>
 
-: random-bits ( n -- r ) 2^ random-integer ;
+: random-bits ( numbits -- r ) 2^ random-integer ;
+
+: random-bits* ( numbits -- n )
+    1 - [ random-bits ] keep set-bit ;
 
 : random ( seq -- elt )
     [ f ] [

From 259fd34d4981369f5cd51e6e36216db9a87b6dad Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:42:41 -0500
Subject: [PATCH 47/68] add next-odd etc to math.bitwise

---
 basis/math/bitwise/bitwise.factor | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
index 4fe2340643..ff4806348b 100755
--- a/basis/math/bitwise/bitwise.factor
+++ b/basis/math/bitwise/bitwise.factor
@@ -111,3 +111,10 @@ PRIVATE>
 : >signed ( x n -- y )
     2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 
+: >odd ( n -- int ) 0 set-bit ; foldable
+
+: >even ( n -- int ) 0 clear-bit ; foldable
+
+: next-even ( m -- n ) >even 2 + ; foldable
+
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; foldable

From d5eace91d04ea66dc8a6ad2b29c058652726c894 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 10 May 2009 13:45:58 -0500
Subject: [PATCH 48/68] purple sky

---
 extra/terrain/shaders/shaders.factor | 34 +++++++++++++++++
 extra/terrain/terrain.factor         | 57 +++++++++++++++++++---------
 2 files changed, 74 insertions(+), 17 deletions(-)

diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor
index c341545956..bfb46b8ba1 100644
--- a/extra/terrain/shaders/shaders.factor
+++ b/extra/terrain/shaders/shaders.factor
@@ -1,6 +1,40 @@
 USING: multiline ;
 IN: terrain.shaders
 
+STRING: sky-vertex-shader
+
+uniform float sky_theta;
+varying vec3 direction;
+
+void main()
+{
+    vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0);
+    gl_Position = v;
+    float s = sin(sky_theta), c = cos(sky_theta);
+    direction = mat3(1, 0, 0,  0, c, s,  0, -s, c)
+        * (gl_ModelViewMatrixInverse * vec4(v.xyz, 0.0)).xyz;
+}
+
+;
+
+STRING: sky-pixel-shader
+
+uniform sampler2D sky;
+uniform float sky_gradient, sky_theta;
+
+const vec4 SKY_COLOR_A = vec4(0.25, 0.0, 0.5,  1.0),
+           SKY_COLOR_B = vec4(0.6,  0.5, 0.75, 1.0);
+
+varying vec3 direction;
+
+void main()
+{
+    float t = texture2D(sky, normalize(direction.xyz).xy * 0.5 + vec2(0.5)).x + sky_gradient;
+    gl_FragColor = mix(SKY_COLOR_A, SKY_COLOR_B, sin(6.28*t));
+}
+
+;
+
 STRING: terrain-vertex-shader
 
 uniform sampler2D heightmap;
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index 590244ca6a..411d34f44c 100644
--- a/extra/terrain/terrain.factor
+++ b/extra/terrain/terrain.factor
@@ -5,20 +5,23 @@ math.vectors opengl opengl.capabilities opengl.gl
 opengl.shaders opengl.textures opengl.textures.private
 sequences sequences.product specialized-arrays.float
 terrain.generation terrain.shaders ui ui.gadgets
-ui.gadgets.worlds ui.pixel-formats game-worlds method-chains ;
+ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
+math.affine-transforms noise ;
 IN: terrain
 
 CONSTANT: FOV $[ 2.0 sqrt 1+ ]
-CONSTANT: NEAR-PLANE $[ 1.0 2048.0 / ]
-CONSTANT: FAR-PLANE 1.0
+CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
+CONSTANT: FAR-PLANE 2.0
 CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
-CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ]
+CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ]
 CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
 CONSTANT: JUMP $[ 1.0 1024.0 / ]
 CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
 CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ]
 CONSTANT: FRICTION 0.95
-CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.002 0.0 }
+CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.0005 0.0 }
+CONSTANT: SKY-PERIOD 1200
+CONSTANT: SKY-SPEED 0.0005
 
 CONSTANT: terrain-vertex-size { 512 512 }
 CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
@@ -29,6 +32,7 @@ TUPLE: player
 
 TUPLE: terrain-world < game-world
     player
+    sky-image sky-texture sky-program
     terrain terrain-segment terrain-texture terrain-program
     terrain-vertex-buffer ;
 
@@ -41,7 +45,7 @@ M: terrain-world tick-length
     NEAR-PLANE FAR-PLANE ;
 
 : set-modelview-matrix ( gadget -- )
-    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+    GL_DEPTH_BUFFER_BIT glClear
     GL_MODELVIEW glMatrixMode
     glLoadIdentity
     player>>
@@ -175,24 +179,33 @@ M: terrain-world tick*
     [ dup focused?>> [ handle-input ] [ drop ] if ]
     [ dup player>> tick-player ] bi ;
 
-: set-heightmap-texture-parameters ( texture -- )
+: set-texture-parameters ( texture -- )
     GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
     GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
     GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_LINEAR glTexParameteri
     GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri
     GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
 
+: sky-gradient ( world -- t )
+    game-loop>> tick-number>> SKY-PERIOD mod SKY-PERIOD /f ;
+: sky-theta ( world -- theta )
+    game-loop>> tick-number>> SKY-SPEED * ;
+
 BEFORE: terrain-world begin-world
     "2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
     require-gl-version-or-extensions
     GL_DEPTH_TEST glEnable
     GL_TEXTURE_2D glEnable
     GL_VERTEX_ARRAY glEnableClientState
-    0.5 0.5 0.5 1.0 glClearColor
     PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
+    <perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
+    [ >>sky-image ] keep
+    make-texture [ set-texture-parameters ] keep >>sky-texture
     <terrain> [ >>terrain ] keep
     { 0 0 } terrain-segment [ >>terrain-segment ] keep
-    make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture
+    make-texture [ set-texture-parameters ] keep >>terrain-texture
+    sky-vertex-shader sky-pixel-shader <simple-gl-program>
+    >>sky-program
     terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
     >>terrain-program
     vertex-array >vertex-buffer >>terrain-vertex-buffer
@@ -203,6 +216,8 @@ AFTER: terrain-world end-world
         [ terrain-vertex-buffer>> delete-gl-buffer ]
         [ terrain-program>> delete-gl-program ]
         [ terrain-texture>> delete-texture ]
+        [ sky-program>> delete-gl-program ]
+        [ sky-texture>> delete-texture ]
     } cleave ;
 
 M: terrain-world resize-world
@@ -212,14 +227,22 @@ M: terrain-world resize-world
     [ frustum glFrustum ] bi ;
 
 M: terrain-world draw-world*
-    [ set-modelview-matrix ]
-    [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
-    [ dup terrain-program>> [
-        [ "heightmap" glGetUniformLocation 0 glUniform1i ]
-        [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi
-        terrain-vertex-buffer>> draw-vertex-buffer
-    ] with-gl-program ]
-    tri gl-error ;
+    {
+        [ set-modelview-matrix ]
+        [ terrain-texture>> GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
+        [ sky-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
+        [ GL_DEPTH_TEST glDisable dup sky-program>> [
+            [ nip "sky" glGetUniformLocation 1 glUniform1i ]
+            [ "sky_gradient" glGetUniformLocation swap sky-gradient glUniform1f ]
+            [ "sky_theta" glGetUniformLocation swap sky-theta glUniform1f ] 2tri
+            { -1.0 -1.0 } { 2.0 2.0 } gl-fill-rect
+        ] with-gl-program ]
+        [ GL_DEPTH_TEST glEnable dup terrain-program>> [
+            [ "heightmap" glGetUniformLocation 0 glUniform1i ]
+            [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi
+            terrain-vertex-buffer>> draw-vertex-buffer
+        ] with-gl-program ]
+    } cleave gl-error ;
 
 M: terrain-world pref-dim* drop { 640 480 } ;
 

From 93104742f886f6f39793d077fa626f7b7cdacfd5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:47:51 -0500
Subject: [PATCH 49/68] more docs for math.primes, move words out of
 miller-rabin

---
 .../miller-rabin/miller-rabin-docs.factor     | 74 +----------------
 .../miller-rabin/miller-rabin-tests.factor    |  5 +-
 .../primes/miller-rabin/miller-rabin.factor   | 83 +------------------
 basis/math/primes/primes-docs.factor          | 50 ++++++++++-
 basis/math/primes/primes-tests.factor         | 13 ++-
 basis/math/primes/primes.factor               | 43 +++++++++-
 6 files changed, 105 insertions(+), 163 deletions(-)

diff --git a/basis/math/primes/miller-rabin/miller-rabin-docs.factor b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
index 2455dafdd5..2d19d51e06 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-docs.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-docs.factor
@@ -3,20 +3,6 @@
 USING: help.markup help.syntax kernel sequences math ;
 IN: math.primes.miller-rabin
 
-HELP: find-relative-prime
-{ $values
-    { "n" integer }
-    { "p" integer }
-}
-{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
-
-HELP: find-relative-prime*
-{ $values
-    { "n" integer } { "guess" integer }
-    { "p" integer }
-}
-{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
-
 HELP: miller-rabin
 { $values
     { "n" integer }
@@ -33,68 +19,10 @@ HELP: miller-rabin*
 }
 { $description "Performs " { $snippet "numtrials" } " trials of the Miller-Rabin probabilistic primality test algorithm and returns true if prime." } ;
 
-HELP: next-prime
-{ $values
-    { "n" integer }
-    { "p" integer }
-}
-{ $description "Tests consecutive numbers for primality with " { $link miller-rabin } " and returns the next prime." } ;
-
-HELP: next-safe-prime
-{ $values
-    { "n" integer }
-    { "q" integer }
-}
-{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
-
-HELP: random-bits*
-{ $values
-    { "numbits" integer }
-    { "n" integer }
-}
-{ $description "Returns an integer exactly " { $snippet "numbits" } " in length, with the topmost bit set to one." } ;
-
-HELP: random-prime
-{ $values
-    { "numbits" integer }
-    { "p" integer }
-}
-{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
-
-HELP: random-safe-prime
-{ $values
-    { "numbits" integer }
-    { "p" integer }
-}
-{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
-
-HELP: safe-prime?
-{ $values
-    { "q" integer }
-    { "?" "a boolean" }
-}
-{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
-
-HELP: unique-primes
-{ $values
-    { "numbits" integer } { "n" integer }
-    { "seq" sequence }
-}
-{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
-
 ARTICLE: "math.primes.miller-rabin" "Miller-Rabin probabilistic primality test"
 "The " { $vocab-link "math.primes.miller-rabin" } " vocabulary implements the Miller-Rabin probabilistic primality test and utility words that use it in order to generate random prime numbers." $nl
 "The Miller-Rabin probabilistic primality test:"
 { $subsection miller-rabin }
-{ $subsection miller-rabin* }
-"Generating relative prime numbers:"
-{ $subsection find-relative-prime }
-{ $subsection find-relative-prime* }
-"Generating prime numbers:"
-{ $subsection next-prime }
-{ $subsection random-prime }
-"Generating safe prime numbers:"
-{ $subsection next-safe-prime }
-{ $subsection random-safe-prime } ;
+{ $subsection miller-rabin* } ;
 
 ABOUT: "math.primes.miller-rabin"
diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
index 9c635c8f38..aeae6cac1b 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
@@ -1,5 +1,6 @@
-USING: math.primes.miller-rabin tools.test kernel sequences
-math.primes.miller-rabin.private math ;
+USING: kernel math math.primes math.primes.miller-rabin
+math.primes.miller-rabin.private math.primes.safe
+math.primes.safe.private random sequences tools.test ;
 IN: math.primes.miller-rabin.tests
 
 [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
diff --git a/basis/math/primes/miller-rabin/miller-rabin.factor b/basis/math/primes/miller-rabin/miller-rabin.factor
index 35ee97a897..b0dfc4ed35 100755
--- a/basis/math/primes/miller-rabin/miller-rabin.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin.factor
@@ -1,18 +1,9 @@
 ! Copyright (c) 2008-2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel locals math math.functions math.ranges
-random sequences sets combinators.short-circuit math.bitwise
-math math.order ;
+USING: combinators combinators.short-circuit kernel locals math
+math.functions math.ranges random sequences sets ;
 IN: math.primes.miller-rabin
 
-: >odd ( n -- int ) 0 set-bit ; foldable
-
-: >even ( n -- int ) 0 clear-bit ; foldable
-
-: next-even ( m -- n ) >even 2 + ;
-
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
-
 <PRIVATE
 
 :: (miller-rabin) ( n trials -- ? )
@@ -42,73 +33,3 @@ PRIVATE>
     } cond ;
 
 : miller-rabin ( n -- ? ) 10 miller-rabin* ;
-
-ERROR: prime-range-error n ;
-
-: next-prime ( n -- p )
-    dup 1 < [ prime-range-error ] when
-    dup 1 = [
-        drop 2
-    ] [
-        next-odd dup miller-rabin [ next-prime ] unless
-    ] if ;
-
-: random-bits* ( numbits -- n )
-    1 - [ random-bits ] keep set-bit ;
-
-: random-prime ( numbits -- p )
-    random-bits* next-prime ;
-
-ERROR: no-relative-prime n ;
-
-<PRIVATE
-
-: (find-relative-prime) ( n guess -- p )
-    over 1 <= [ over no-relative-prime ] when
-    dup 1 <= [ drop 3 ] when
-    2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
-
-PRIVATE>
-
-: find-relative-prime* ( n guess -- p )
-    #! find a prime relative to n with initial guess
-    >odd (find-relative-prime) ;
-
-: find-relative-prime ( n -- p )
-    dup random find-relative-prime* ;
-
-ERROR: too-few-primes ;
-
-: unique-primes ( numbits n -- seq )
-    #! generate two primes
-    swap
-    dup 5 < [ too-few-primes ] when
-    2dup [ random-prime ] curry replicate
-    dup all-unique? [ 2nip ] [ drop unique-primes ] if ;
-
-! Safe primes are of the form p = 2q + 1, p,q are prime
-! See http://en.wikipedia.org/wiki/Safe_prime
-
-<PRIVATE
-
-: safe-prime-candidate? ( n -- ? )
-    1 + 6 divisor? ;
-
-: next-safe-prime-candidate ( n -- candidate )
-    next-prime dup safe-prime-candidate?
-    [ next-safe-prime-candidate ] unless ;
-
-PRIVATE>
-
-: safe-prime? ( q -- ? )
-    {
-        [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ]
-        [ miller-rabin ]
-    } 1&& ;
-
-: next-safe-prime ( n -- q )
-    next-safe-prime-candidate
-    dup safe-prime? [ next-safe-prime ] unless ;
-
-: random-safe-prime ( numbits -- p )
-    random-bits* next-safe-prime ;
diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor
index c7dbc950e8..fa991e800f 100644
--- a/basis/math/primes/primes-docs.factor
+++ b/basis/math/primes/primes-docs.factor
@@ -1,10 +1,10 @@
-USING: help.markup help.syntax ;
+USING: help.markup help.syntax math sequences ;
 IN: math.primes
 
 { next-prime prime? } related-words
 
 HELP: next-prime
-{ $values { "n" "an integer not smaller than 2" } { "p" "a prime number" } }
+{ $values { "n" integer } { "p" "a prime number" } }
 { $description "Return the next prime number greater than " { $snippet "n" } "." } ;
 
 HELP: prime?
@@ -20,3 +20,49 @@ HELP: primes-upto
 HELP: primes-between
 { $values { "low" "an integer" } { "high" "an integer" } { "seq" "a sequence" } }
 { $description "Return a sequence containing all the prime numbers between " { $snippet "low" } " and " { $snippet "high" } "." } ;
+
+HELP: find-relative-prime
+{ $values
+    { "n" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } "." } ;
+
+HELP: find-relative-prime*
+{ $values
+    { "n" integer } { "guess" integer }
+    { "p" integer }
+}
+{ $description "Returns a number that is relatively prime to " { $snippet "n" } ", starting by trying " { $snippet "guess" } "." } ;
+
+HELP: random-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a prime number exactly " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: unique-primes
+{ $values
+    { "numbits" integer } { "n" integer }
+    { "seq" sequence }
+}
+{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
+
+
+ARTICLE: "math.primes" "Prime numbers"
+"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers." $nl
+"Testing if a number is prime:"
+{ $subsection prime? }
+"Generating prime numbers:"
+{ $subsection next-prime }
+{ $subsection primes-upto }
+{ $subsection primes-between }
+{ $subsection random-prime }
+"Generating relative prime numbers:"
+{ $subsection find-relative-prime }
+{ $subsection find-relative-prime* }
+"Make a sequence of random prime numbers:"
+{ $subsection unique-primes } ;
+
+ABOUT: "math.primes"
diff --git a/basis/math/primes/primes-tests.factor b/basis/math/primes/primes-tests.factor
index db738399ef..6580f0780e 100644
--- a/basis/math/primes/primes-tests.factor
+++ b/basis/math/primes/primes-tests.factor
@@ -1,4 +1,6 @@
-USING: arrays math.primes tools.test ;
+USING: arrays math math.primes math.primes.miller-rabin
+tools.test ;
+IN: math.primes.tests
 
 { 1237 } [ 1234 next-prime ] unit-test
 { f t } [ 1234 prime? 1237 prime? ] unit-test
@@ -7,3 +9,12 @@ USING: arrays math.primes tools.test ;
 
 { { 4999963 4999999 5000011 5000077 5000081 } }
 [ 4999962 5000082 primes-between >array ] unit-test
+
+[ 2 ] [ 1 next-prime ] unit-test
+[ 3 ] [ 2 next-prime ] unit-test
+[ 5 ] [ 3 next-prime ] unit-test
+[ 101 ] [ 100 next-prime ] unit-test
+[ t ] [ 2135623355842621559 miller-rabin ] unit-test
+[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
+
+[ 49 ] [ 50 random-prime log2 ] unit-test
diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor
index fa1cd5cb63..e3985fc600 100644
--- a/basis/math/primes/primes.factor
+++ b/basis/math/primes/primes.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel math math.functions
-math.primes.miller-rabin math.order math.primes.erato
-math.ranges sequences ;
+USING: combinators kernel math math.bitwise math.functions
+math.order math.primes.erato math.primes.miller-rabin
+math.ranges random sequences sets fry ;
 IN: math.primes
 
 <PRIVATE
@@ -22,7 +22,11 @@ PRIVATE>
     } cond ; foldable
 
 : next-prime ( n -- p )
-    next-odd [ dup really-prime? ] [ 2 + ] until ; foldable
+    dup 2 < [
+        drop 2
+    ] [
+        next-odd [ dup really-prime? ] [ 2 + ] until
+    ] if ; foldable
 
 : primes-between ( low high -- seq )
     [ dup 3 max dup even? [ 1 + ] when ] dip
@@ -32,3 +36,34 @@ PRIVATE>
 : primes-upto ( n -- seq ) 2 swap primes-between ;
 
 : coprime? ( a b -- ? ) gcd nip 1 = ; foldable
+
+: random-prime ( numbits -- p )
+    random-bits* next-prime ;
+
+: estimated-primes ( m -- n )
+    dup log / ; foldable
+
+ERROR: no-relative-prime n ;
+
+<PRIVATE
+
+: (find-relative-prime) ( n guess -- p )
+    over 1 <= [ over no-relative-prime ] when
+    dup 1 <= [ drop 3 ] when
+    2dup gcd nip 1 > [ 2 + (find-relative-prime) ] [ nip ] if ;
+
+PRIVATE>
+
+: find-relative-prime* ( n guess -- p )
+    #! find a prime relative to n with initial guess
+    >odd (find-relative-prime) ;
+
+: find-relative-prime ( n -- p )
+    dup random find-relative-prime* ;
+
+ERROR: too-few-primes n numbits ;
+
+: unique-primes ( n numbits -- seq )
+    2dup 2^ estimated-primes > [ too-few-primes ] when
+    2dup '[ _ random-prime ] replicate
+    dup all-unique? [ 2nip ] [ drop unique-primes ] if ;

From 57ffb231dc1343b908d13e44857a322454ea2bf8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:48:09 -0500
Subject: [PATCH 50/68] update using

---
 extra/project-euler/046/046.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/extra/project-euler/046/046.factor b/extra/project-euler/046/046.factor
index e4b8dcc955..0aa9eafe58 100755
--- a/extra/project-euler/046/046.factor
+++ b/extra/project-euler/046/046.factor
@@ -1,6 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.primes math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.primes math.ranges
+sequences project-euler.common math.bitwise ;
 IN: project-euler.046
 
 ! http://projecteuler.net/index.php?section=problems&id=46

From 7869821de98d69d2ac319a8a4bb46b320c9547bc Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 13:49:40 -0500
Subject: [PATCH 51/68] make a new vocabulary for safe primes

---
 basis/math/primes/safe/authors.txt       |  1 +
 basis/math/primes/safe/safe-docs.factor  | 38 ++++++++++++++++++++++++
 basis/math/primes/safe/safe-tests.factor | 14 +++++++++
 basis/math/primes/safe/safe.factor       | 29 ++++++++++++++++++
 4 files changed, 82 insertions(+)
 create mode 100644 basis/math/primes/safe/authors.txt
 create mode 100644 basis/math/primes/safe/safe-docs.factor
 create mode 100644 basis/math/primes/safe/safe-tests.factor
 create mode 100644 basis/math/primes/safe/safe.factor

diff --git a/basis/math/primes/safe/authors.txt b/basis/math/primes/safe/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/math/primes/safe/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/math/primes/safe/safe-docs.factor b/basis/math/primes/safe/safe-docs.factor
new file mode 100644
index 0000000000..861fc4e4ed
--- /dev/null
+++ b/basis/math/primes/safe/safe-docs.factor
@@ -0,0 +1,38 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit help.markup help.syntax kernel
+math math.functions math.primes random ;
+IN: math.primes.safe
+
+HELP: next-safe-prime
+{ $values
+    { "n" integer }
+    { "q" integer }
+}
+{ $description "Tests consecutive numbers and returns the next safe prime. A safe prime is desirable in cryptography applications such as Diffie-Hellman and SRP6." } ;
+
+HELP: random-safe-prime
+{ $values
+    { "numbits" integer }
+    { "p" integer }
+}
+{ $description "Returns a safe prime number " { $snippet "numbits" } " bits in length, with the topmost bit set to one." } ;
+
+HELP: safe-prime?
+{ $values
+    { "q" integer }
+    { "?" "a boolean" }
+}
+{ $description "Tests whether the number is a safe prime. A safe prime " { $snippet "p" } " must be prime, as must " { $snippet "(p - 1) / 2" } "." } ;
+
+
+ARTICLE: "math.primes.safe" "Safe prime numbers"
+"The " { $vocab-link "math.primes.safe" } " vocabulary implements words to calculate safe prime numbers. Safe primes are of the form p = 2q + 1, where p,q are prime. Safe primes have desirable qualities for cryptographic applications." $nl
+
+"Testing if a number is a safe prime:"
+{ $subsection safe-prime? }
+"Generating safe prime numbers:"
+{ $subsection next-safe-prime }
+{ $subsection random-safe-prime } ;
+
+ABOUT: "math.primes.safe"
diff --git a/basis/math/primes/safe/safe-tests.factor b/basis/math/primes/safe/safe-tests.factor
new file mode 100644
index 0000000000..ef9aa9246f
--- /dev/null
+++ b/basis/math/primes/safe/safe-tests.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math.primes.safe math.primes.safe.private tools.test ;
+IN: math.primes.safe.tests
+
+[ 863 ] [ 862 next-safe-prime ] unit-test
+[ f ] [ 862 safe-prime? ] unit-test
+[ t ] [ 7 safe-prime? ] unit-test
+[ f ] [ 31 safe-prime? ] unit-test
+[ t ] [ 47 safe-prime-candidate? ] unit-test
+[ t ] [ 47 safe-prime? ] unit-test
+[ t ] [ 863 safe-prime? ] unit-test
+
+[ 47 ] [ 31 next-safe-prime ] unit-test
diff --git a/basis/math/primes/safe/safe.factor b/basis/math/primes/safe/safe.factor
new file mode 100644
index 0000000000..a3becb628f
--- /dev/null
+++ b/basis/math/primes/safe/safe.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators.short-circuit kernel math math.functions
+math.primes random ;
+IN: math.primes.safe
+
+<PRIVATE
+
+: safe-prime-candidate? ( n -- ? )
+    1 + 6 divisor? ;
+
+: next-safe-prime-candidate ( n -- candidate )
+    next-prime dup safe-prime-candidate?
+    [ next-safe-prime-candidate ] unless ;
+
+PRIVATE>
+
+: safe-prime? ( q -- ? )
+    {
+        [ 1 - 2 / dup integer? [ prime? ] [ drop f ] if ]
+        [ prime? ]
+    } 1&& ;
+
+: next-safe-prime ( n -- q )
+    next-safe-prime-candidate
+    dup safe-prime? [ next-safe-prime ] unless ;
+
+: random-safe-prime ( numbits -- p )
+    random-bits* next-safe-prime ;

From bf528dcdddcdf1544f9c94b54521c1128824dc63 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 14:01:21 -0500
Subject: [PATCH 52/68] link to prime tests from prime docs

---
 basis/math/primes/factors/factors.factor | 3 ++-
 basis/math/primes/primes-docs.factor     | 3 +--
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor
index 278bf70b3d..f5fa468687 100644
--- a/basis/math/primes/factors/factors.factor
+++ b/basis/math/primes/factors/factors.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.functions math.primes sequences ;
+USING: arrays combinators kernel make math math.functions
+math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE
diff --git a/basis/math/primes/primes-docs.factor b/basis/math/primes/primes-docs.factor
index fa991e800f..71bf3ac2c8 100644
--- a/basis/math/primes/primes-docs.factor
+++ b/basis/math/primes/primes-docs.factor
@@ -49,9 +49,8 @@ HELP: unique-primes
 }
 { $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
 
-
 ARTICLE: "math.primes" "Prime numbers"
-"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers." $nl
+"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl
 "Testing if a number is prime:"
 { $subsection prime? }
 "Generating prime numbers:"

From bfa9ea3fde91abe767ded6609c619a6500251252 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 14:08:03 -0500
Subject: [PATCH 53/68] dont load safe primes in miller rabin tests

---
 .../miller-rabin/miller-rabin-tests.factor    | 21 +------------------
 1 file changed, 1 insertion(+), 20 deletions(-)

diff --git a/basis/math/primes/miller-rabin/miller-rabin-tests.factor b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
index aeae6cac1b..d201abfef8 100644
--- a/basis/math/primes/miller-rabin/miller-rabin-tests.factor
+++ b/basis/math/primes/miller-rabin/miller-rabin-tests.factor
@@ -1,6 +1,4 @@
-USING: kernel math math.primes math.primes.miller-rabin
-math.primes.miller-rabin.private math.primes.safe
-math.primes.safe.private random sequences tools.test ;
+USING: kernel math.primes.miller-rabin sequences tools.test ;
 IN: math.primes.miller-rabin.tests
 
 [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test
@@ -8,23 +6,6 @@ IN: math.primes.miller-rabin.tests
 [ t ] [ 3 miller-rabin ] unit-test
 [ f ] [ 36 miller-rabin ] unit-test
 [ t ] [ 37 miller-rabin ] unit-test
-[ 2 ] [ 1 next-prime ] unit-test
-[ 3 ] [ 2 next-prime ] unit-test
-[ 5 ] [ 3 next-prime ] unit-test
-[ 101 ] [ 100 next-prime ] unit-test
 [ t ] [ 2135623355842621559 miller-rabin ] unit-test
-[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test
-
-[ 863 ] [ 862 next-safe-prime ] unit-test
-[ f ] [ 862 safe-prime? ] unit-test
-[ t ] [ 7 safe-prime? ] unit-test
-[ f ] [ 31 safe-prime? ] unit-test
-[ t ] [ 47 safe-prime-candidate? ] unit-test
-[ t ] [ 47 safe-prime? ] unit-test
-[ t ] [ 863 safe-prime? ] unit-test
 
 [ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test
-
-[ 47 ] [ 31 next-safe-prime ] unit-test
-[ 49 ] [ 50 random-prime log2 ] unit-test
-[ 49 ] [ 50 random-bits* log2 ] unit-test

From 4c465cd575d0874822cdd079de845a911fa9a552 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 16:33:43 -0500
Subject: [PATCH 54/68] fix using

---
 extra/crypto/rsa/rsa.factor                       | 4 ++--
 extra/random/blum-blum-shub/blum-blum-shub.factor | 4 ++--
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor
index 1da170d197..50ea84fd39 100644
--- a/extra/crypto/rsa/rsa.factor
+++ b/extra/crypto/rsa/rsa.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math.primes.miller-rabin kernel math math.functions
-namespaces sequences accessors ;
+USING: math.primes kernel math math.functions namespaces
+sequences accessors ;
 IN: crypto.rsa
 
 ! The private key is the only secret.
diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor
index 4a52a2f79c..8229abca69 100755
--- a/extra/random/blum-blum-shub/blum-blum-shub.factor
+++ b/extra/random/blum-blum-shub/blum-blum-shub.factor
@@ -1,5 +1,5 @@
-USING: kernel math sequences namespaces
-math.primes.miller-rabin math.functions accessors random ;
+USING: kernel math sequences namespaces math.primes
+math.functions accessors random ;
 IN: random.blum-blum-shub
 
 ! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n

From f6ff74596e98f4c86b95e7e197ae7e256a01eab5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Sun, 10 May 2009 16:39:17 -0500
Subject: [PATCH 55/68] Removing slip 2slip 3slip nslip

---
 basis/fry/fry-docs.factor                     |  1 -
 .../generalizations-docs.factor               | 17 -----------
 .../generalizations-tests.factor              |  2 --
 basis/generalizations/generalizations.factor  |  3 --
 core/combinators/combinators-docs.factor      | 11 ++------
 core/kernel/kernel-docs.factor                | 12 --------
 core/kernel/kernel.factor                     | 28 ++++---------------
 core/quotations/quotations.factor             |  2 +-
 extra/reports/noise/noise.factor              |  1 -
 9 files changed, 8 insertions(+), 69 deletions(-)

diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor
index 5d750775e5..32ad856d00 100644
--- a/basis/fry/fry-docs.factor
+++ b/basis/fry/fry-docs.factor
@@ -57,7 +57,6 @@ $nl
 "Here are some built-in combinators rewritten in terms of fried quotations:"
 { $table
     { { $link literalize } { $snippet ": literalize '[ _ ] ;" } }
-    { { $link slip } { $snippet ": slip '[ @ _ ] call ;" } }
     { { $link curry } { $snippet ": curry '[ _ @ ] ;" } }
     { { $link compose } { $snippet ": compose '[ @ @ ] ;" } }
     { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } }
diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor
index 3671511194..d6a3aa948a 100644
--- a/basis/generalizations/generalizations-docs.factor
+++ b/basis/generalizations/generalizations-docs.factor
@@ -161,22 +161,6 @@ HELP: ndip
     }
 } ;
 
-HELP: nslip
-{ $values { "n" integer } }
-{ $description "A generalization of " { $link slip } " that can work " 
-"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
-"removed from the stack, the quotation called, and the items restored."
-} 
-{ $examples
-  { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip 6 narray ." "{ 99 1 2 3 4 5 }" }
-  "Some core words expressed in terms of " { $link nslip } ":"
-    { $table
-        { { $link slip } { $snippet "1 nslip" } }
-        { { $link 2slip } { $snippet "2 nslip" } }
-        { { $link 3slip } { $snippet "3 nslip" } }
-    }
-} ;
-
 HELP: nkeep
 { $values { "quot" quotation } { "n" integer } }
 { $description "A generalization of " { $link keep } " that can work " 
@@ -339,7 +323,6 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
 
 ARTICLE: "combinator-generalizations" "Generalized combinators"
 { $subsection ndip }
-{ $subsection nslip }
 { $subsection nkeep }
 { $subsection napply }
 { $subsection ncleave }
diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor
index 7ede271d01..d0f614f9cd 100644
--- a/basis/generalizations/generalizations-tests.factor
+++ b/basis/generalizations/generalizations-tests.factor
@@ -26,8 +26,6 @@ IN: generalizations.tests
 [ [ 1 ] 5 ndip ] must-infer
 [ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
 
-[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
-{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
 { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
 [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index 139b7a528a..397166a418 100644
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -60,9 +60,6 @@ MACRO: ntuck ( n -- )
 MACRO: ndip ( quot n -- )
     [ '[ _ dip ] ] times ;
 
-MACRO: nslip ( n -- )
-    '[ [ call ] _ ndip ] ;
-
 MACRO: nkeep ( quot n -- )
     tuck '[ _ ndup _ _ ndip ] ;
 
diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor
index 8b301affbd..1a17e8c1fb 100755
--- a/core/combinators/combinators-docs.factor
+++ b/core/combinators/combinators-docs.factor
@@ -62,9 +62,6 @@ $nl
     ": dip   [ ] bi* ;"
     ": 2dip  [ ] [ ] tri* ;"
     ""
-    ": slip  [ call ] [ ] bi* ;"
-    ": 2slip [ call ] [ ] [ ] tri* ;"
-    ""
     ": nip   [ drop ] [ ] bi* ;"
     ": 2nip  [ drop ] [ drop ] [ ] tri* ;"
     ""
@@ -121,7 +118,7 @@ $nl
 { $subsection both? }
 { $subsection either? } ;
 
-ARTICLE: "slip-keep-combinators" "Retain stack combinators"
+ARTICLE: "retainstack-combinators" "Retain stack combinators"
 "Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using a set of combinators."
 $nl
 "The dip combinators invoke the quotation at the top of the stack, hiding the values underneath:"
@@ -129,10 +126,6 @@ $nl
 { $subsection 2dip }
 { $subsection 3dip }
 { $subsection 4dip }
-"The slip combinators invoke a quotation further down on the stack. They are most useful for implementing other combinators:"
-{ $subsection slip }
-{ $subsection 2slip }
-{ $subsection 3slip }
 "The keep combinators invoke a quotation which takes a number of values off the stack, and then they restore those values:"
 { $subsection keep }
 { $subsection 2keep }
@@ -259,7 +252,7 @@ ARTICLE: "conditionals" "Conditional combinators"
 
 ARTICLE: "dataflow-combinators" "Data flow combinators"
 "Data flow combinators pass values between quotations:"
-{ $subsection "slip-keep-combinators" }
+{ $subsection "retainstack-combinators" }
 { $subsection "cleave-combinators" }
 { $subsection "spread-combinators" }
 { $subsection "apply-combinators" }
diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor
index e67e2bc0dd..22e0e76451 100644
--- a/core/kernel/kernel-docs.factor
+++ b/core/kernel/kernel-docs.factor
@@ -212,18 +212,6 @@ HELP: call-clear ( quot -- )
 { $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." }
 { $notes "Used to implement " { $link "threads" } "." } ;
 
-HELP: slip
-{ $values { "quot" quotation } { "x" object } }
-{ $description "Calls a quotation while hiding the top of the stack." } ;
-
-HELP: 2slip
-{ $values { "quot" quotation } { "x" object } { "y" object } }
-{ $description "Calls a quotation while hiding the top two stack elements." } ;
-
-HELP: 3slip
-{ $values { "quot" quotation } { "x" object } { "y" object } { "z" object } }
-{ $description "Calls a quotation while hiding the top three stack elements." } ;
-
 HELP: keep
 { $values { "quot" { $quotation "( x -- ... )" } } { "x" object } }
 { $description "Call a quotation with a value on the stack, restoring the value when the quotation returns." }
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 6245080225..d6350e0420 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -58,37 +58,19 @@ DEFER: if
 : ?if ( default cond true false -- )
     pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
 
-! Slippers and dippers.
+! Dippers.
 ! Not declared inline because the compiler special-cases them
 
-: slip ( quot x -- x )
-    #! 'slip' and 'dip' can be defined in terms of each other
-    #! because the JIT special-cases a 'dip' preceeded by
-    #! a literal quotation.
-    [ call ] dip ;
+: dip ( x quot -- x ) swap [ call ] dip ;
 
-: 2slip ( quot x y -- x y )
-    #! '2slip' and '2dip' can be defined in terms of each other
-    #! because the JIT special-cases a '2dip' preceeded by
-    #! a literal quotation.
-    [ call ] 2dip ;
+: 2dip ( x y quot -- x y ) -rot [ call ] 2dip ;
 
-: 3slip ( quot x y z -- x y z )
-    #! '3slip' and '3dip' can be defined in terms of each other
-    #! because the JIT special-cases a '3dip' preceeded by
-    #! a literal quotation.
-    [ call ] 3dip ;
-
-: dip ( x quot -- x ) swap slip ;
-
-: 2dip ( x y quot -- x y ) -rot 2slip ;
-
-: 3dip ( x y z quot -- x y z ) -roll 3slip ;
+: 3dip ( x y z quot -- x y z ) -roll [ call ] 3dip ;
 
 : 4dip ( w x y z quot -- w x y z ) swap [ 3dip ] dip ; inline
 
 ! Keepers
-: keep ( x quot -- x ) over slip ; inline
+: keep ( x quot -- x ) over [ call ] dip ; inline
 
 : 2keep ( x y quot -- x y ) [ 2dup ] dip 2dip ; inline
 
diff --git a/core/quotations/quotations.factor b/core/quotations/quotations.factor
index 3245ac1e20..af3c110d61 100644
--- a/core/quotations/quotations.factor
+++ b/core/quotations/quotations.factor
@@ -19,7 +19,7 @@ M: quotation call (call) ;
 
 M: curry call uncurry call ;
 
-M: compose call uncompose slip call ;
+M: compose call uncompose [ call ] dip call ;
 
 M: wrapper equal?
     over wrapper? [ [ wrapped>> ] bi@ = ] [ 2drop f ] if ;
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 89e00f88c5..51196279ff 100755
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -52,7 +52,6 @@ IN: reports.noise
         { nkeep 5 }
         { npick 6 }
         { nrot 5 }
-        { nslip 5 }
         { ntuck 6 }
         { nwith 4 }
         { over 2 }

From 9488e7853294d005742dc56952495dbb0056d1cf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Sun, 10 May 2009 16:39:51 -0500
Subject: [PATCH 56/68] clean up contents and lines words; contents never
 outputs f now

---
 basis/io/launcher/unix/unix-tests.factor      |  2 +-
 basis/io/streams/string/string-tests.factor   |  2 ++
 core/io/io-docs.factor                        |  8 ++---
 core/io/io.factor                             | 36 ++++++++++++-------
 .../byte-array/byte-array-tests.factor        |  1 +
 core/sequences/sequences-docs.factor          |  8 ++++-
 core/sequences/sequences.factor               | 27 +++++++-------
 7 files changed, 54 insertions(+), 30 deletions(-)

diff --git a/basis/io/launcher/unix/unix-tests.factor b/basis/io/launcher/unix/unix-tests.factor
index 99d45e4fd7..852d8171e4 100644
--- a/basis/io/launcher/unix/unix-tests.factor
+++ b/basis/io/launcher/unix/unix-tests.factor
@@ -48,7 +48,7 @@ concurrency.promises threads unix.process ;
     try-process
 ] unit-test
 
-[ f ] [
+[ "" ] [
     "cat"
     "launcher-test-1" temp-file
     2array
diff --git a/basis/io/streams/string/string-tests.factor b/basis/io/streams/string/string-tests.factor
index 967c0d4613..27971f1431 100644
--- a/basis/io/streams/string/string-tests.factor
+++ b/basis/io/streams/string/string-tests.factor
@@ -2,6 +2,8 @@ USING: io.streams.string io kernel arrays namespaces make
 tools.test ;
 IN: io.streams.string.tests
 
+[ "" ] [ "" [ contents ] with-string-reader ] unit-test
+
 [ "line 1" CHAR: l ]
 [
     "line 1\nline 2\nline 3" <string-reader>
diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor
index 97b143e989..ac74e6b11e 100644
--- a/core/io/io-docs.factor
+++ b/core/io/io-docs.factor
@@ -239,13 +239,13 @@ HELP: each-block
 { $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ;
 
 HELP: stream-contents
-{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a stream. If the stream is empty, outputs "  { $link f } "." }
+{ $values { "stream" "an input stream" } { "seq" { $or string byte-array } } }
+{ $description "Reads all elements in the given stream until the stream is exhausted. The type of the sequence depends on the stream's element type." }
 $io-error ;
 
 HELP: contents
-{ $values { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." }
+{ $values { "seq" { $or string byte-array } } }
+{ $description "Reads all elements in the " { $link input-stream } " until the stream is exhausted. The type of the sequence depends on the stream's element type." }
 $io-error ;
 
 ARTICLE: "stream-protocol" "Stream protocol"
diff --git a/core/io/io.factor b/core/io/io.factor
index b43098bcd4..669f104a5f 100644
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables generic kernel math namespaces make sequences
-continuations destructors assocs ;
+continuations destructors assocs combinators ;
 IN: io
 
 SYMBOLS: +byte+ +character+ ;
@@ -20,7 +20,9 @@ GENERIC: stream-flush ( stream -- )
 GENERIC: stream-nl ( stream -- )
 
 ERROR: bad-seek-type type ;
+
 SINGLETONS: seek-absolute seek-relative seek-end ;
+
 GENERIC: stream-seek ( n seek-type stream -- )
 
 : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ;
@@ -68,29 +70,39 @@ SYMBOL: error-stream
 
 : bl ( -- ) " " write ;
 
-: stream-lines ( stream -- seq )
-    [ [ readln dup ] [ ] produce nip ] with-input-stream ;
-
-: lines ( -- seq )
-    input-stream get stream-lines ;
-
 <PRIVATE
 
 : each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
     [ dup ] compose swap while drop ; inline
 
+: stream-element-exemplar ( type -- exemplar )
+    {
+        { +byte+ [ B{ } ] }
+        { +character+ [ "" ] }
+    } case ;
+
+: element-exemplar ( -- exemplar )
+    input-stream get
+    stream-element-type
+    stream-element-exemplar ;
+
 PRIVATE>
 
 : each-line ( quot -- )
     [ readln ] each-morsel ; inline
 
-: stream-contents ( stream -- seq )
-    [
-        [ 65536 read-partial dup ] [ ] produce nip concat f like
-    ] with-input-stream ;
+: lines ( -- seq )
+    [ ] accumulator [ each-line ] dip { } like ;
+
+: stream-lines ( stream -- seq )
+    [ lines ] with-input-stream ;
 
 : contents ( -- seq )
-    input-stream get stream-contents ;
+    [ 65536 read-partial dup ] [ ] produce nip
+    element-exemplar concat-as ;
+
+: stream-contents ( stream -- seq )
+    [ contents ] with-input-stream ;
 
 : each-block ( quot: ( block -- ) -- )
     [ 8192 read-partial ] each-morsel ; inline
diff --git a/core/io/streams/byte-array/byte-array-tests.factor b/core/io/streams/byte-array/byte-array-tests.factor
index 0cd35dfa21..43a8373232 100644
--- a/core/io/streams/byte-array/byte-array-tests.factor
+++ b/core/io/streams/byte-array/byte-array-tests.factor
@@ -1,6 +1,7 @@
 USING: tools.test io.streams.byte-array io.encodings.binary
 io.encodings.utf8 io kernel arrays strings namespaces ;
 
+[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test
 [ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
 [ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
 
diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor
index cfd96789b4..b6cfface12 100755
--- a/core/sequences/sequences-docs.factor
+++ b/core/sequences/sequences-docs.factor
@@ -533,12 +533,18 @@ HELP: concat
 { $description "Concatenates a sequence of sequences together into one sequence. If " { $snippet "seq" } " is empty, outputs " { $snippet "{ }" } ", otherwise the resulting sequence is of the same class as the first element of " { $snippet "seq" } "." }
 { $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as the first element of " { $snippet "seq" } "." } ;
 
+HELP: concat-as
+{ $values { "seq" sequence } { "exemplar" sequence } { "newseq" sequence } }
+{ $description "Concatenates a sequence of sequences together into one sequence with the same type as " { $snippet "exemplar" } "." }
+{ $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." } ;
+
 HELP: join
 { $values { "seq" sequence } { "glue" sequence } { "newseq" sequence } }
 { $description "Concatenates a sequence of sequences together into one sequence, placing a copy of " { $snippet "glue" } " between each pair of sequences. The resulting sequence is of the same class as " { $snippet "glue" } "." }
+{ $notes "If the " { $snippet "glue" } " sequence is empty, this word calls " { $link concat-as } "." }
 { $errors "Throws an error if one of the sequences in " { $snippet "seq" } " contains elements not permitted in sequences of the same class as " { $snippet "glue" } "." } ;
 
-{ join concat } related-words
+{ join concat concat-as } related-words
 
 HELP: peek
 { $values { "seq" sequence } { "elt" object } }
diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index d60602fc71..dd48501fa0 100755
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -704,13 +704,14 @@ PRIVATE>
 : sum-lengths ( seq -- n )
     0 [ length + ] reduce ;
 
+: concat-as ( seq exemplar -- newseq )
+    swap [ { } ] [
+        [ sum-lengths over new-resizable ] keep
+        [ over push-all ] each
+    ] if-empty swap like ;
+
 : concat ( seq -- newseq )
-    [ { } ] [
-        [ sum-lengths ] keep
-        [ first new-resizable ] keep
-        [ [ over push-all ] each ] keep
-        first like
-    ] if-empty ;
+    [ { } ] [ dup first concat-as ] if-empty ;
 
 <PRIVATE
 
@@ -720,12 +721,14 @@ PRIVATE>
 PRIVATE>
 
 : join ( seq glue -- newseq )
-    [
-        2dup joined-length over new-resizable [
-            [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
-            interleave
-        ] keep
-    ] keep like ;
+    dup empty? [ concat-as ] [
+        [
+            2dup joined-length over new-resizable [
+                [ [ push-all ] 2curry ] [ [ nip push-all ] 2curry ] 2bi
+                interleave
+            ] keep
+        ] keep like
+    ] if ;
 
 : padding ( seq n elt quot -- newseq )
     [

From 04408ba62a321aeb2f0e25666f19373be04b288e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Sun, 10 May 2009 16:40:19 -0500
Subject: [PATCH 57/68] mason: add retries in another place, and add a type
 declaration

---
 extra/mason/common/common.factor |  4 ++--
 extra/mason/notify/notify.factor | 12 +++++++-----
 2 files changed, 9 insertions(+), 7 deletions(-)

diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor
index d020c68fc4..b7545a3c9e 100755
--- a/extra/mason/common/common.factor
+++ b/extra/mason/common/common.factor
@@ -5,12 +5,12 @@ math.functions make io io.files io.pathnames io.directories
 io.directories.hierarchy io.launcher io.encodings.utf8 prettyprint
 combinators.short-circuit parser combinators calendar
 calendar.format arrays mason.config locals system debugger fry
-continuations ;
+continuations strings ;
 IN: mason.common
 
 SYMBOL: current-git-id
 
-ERROR: output-process-error output process ;
+ERROR: output-process-error { output string } { process process } ;
 
 M: output-process-error error.
     [ "Process:" print process>> . nl ]
diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor
index 96e31c4a45..c75014e1b0 100644
--- a/extra/mason/notify/notify.factor
+++ b/extra/mason/notify/notify.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays accessors io io.sockets io.encodings.utf8 io.files
 io.launcher kernel make mason.config mason.common mason.email
-mason.twitter namespaces sequences prettyprint ;
+mason.twitter namespaces sequences prettyprint fry ;
 IN: mason.notify
 
 : status-notify ( input-file args -- )
@@ -14,10 +14,12 @@ IN: mason.notify
             target-cpu get ,
             target-os get ,
         ] { } make prepend
-        <process>
-            swap >>command
-            swap [ +closed+ ] unless* >>stdin
-        try-output-process
+        [ 5 ] 2dip '[
+            <process>
+                _ >>command
+                _ [ +closed+ ] unless* >>stdin
+            try-output-process
+        ] retry
     ] [ 2drop ] if ;
 
 : notify-begin-build ( git-id -- )

From 65faa3fda3239f7db334fcd1833dfc8503e48746 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Sun, 10 May 2009 17:03:41 -0500
Subject: [PATCH 58/68] Fix unit tests and load errors for slip removal

---
 basis/compiler/tests/curry.factor                    |  2 +-
 .../escape-analysis/escape-analysis-tests.factor     |  2 +-
 .../tree/tuple-unboxing/tuple-unboxing-tests.factor  |  2 +-
 basis/stack-checker/stack-checker-tests.factor       |  2 +-
 basis/windows/com/com.factor                         |  2 +-
 basis/windows/com/wrapper/wrapper.factor             |  2 +-
 core/kernel/kernel-tests.factor                      | 12 ++++--------
 extra/crypto/timing/authors.txt                      |  1 -
 extra/crypto/timing/timing-tests.factor              |  4 ----
 extra/crypto/timing/timing.factor                    |  8 --------
 extra/reports/noise/noise.factor                     |  3 ---
 extra/spider/unique-deque/unique-deque.factor        |  4 ++--
 12 files changed, 12 insertions(+), 32 deletions(-)
 delete mode 100755 extra/crypto/timing/authors.txt
 delete mode 100644 extra/crypto/timing/timing-tests.factor
 delete mode 100644 extra/crypto/timing/timing.factor

diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor
index 32611ba87a..b541e19f34 100644
--- a/basis/compiler/tests/curry.factor
+++ b/basis/compiler/tests/curry.factor
@@ -33,7 +33,7 @@ IN: compiler.tests.curry
 ] unit-test
 
 : foobar ( quot: ( -- ) -- )
-    dup slip swap [ foobar ] [ drop ] if ; inline recursive
+    [ call ] keep swap [ foobar ] [ drop ] if ; inline recursive
 
 [ ] [ [ [ f ] foobar ] compile-call ] unit-test
 
diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 5f89372ebe..3d9d77ae56 100644
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -302,7 +302,7 @@ C: <ro-box> ro-box
 [ 0 ] [ [ 1 cons boa "x" get slot ] count-unboxed-allocations ] unit-test
 
 : impeach-node ( quot: ( node -- ) -- )
-    dup slip impeach-node ; inline recursive
+    [ call ] keep impeach-node ; inline recursive
 
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index 70670648b1..0d5f05fab0 100644
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -39,7 +39,7 @@ TUPLE: empty-tuple ;
 
 ! A more complicated example
 : impeach-node ( quot: ( node -- ) -- )
-    dup slip impeach-node ; inline recursive
+    [ call ] keep impeach-node ; inline recursive
 
 : bleach-node ( quot: ( node -- ) -- )
     [ bleach-node ] curry [ ] compose impeach-node ; inline recursive
diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor
index 919cd098f6..201f3ce30b 100644
--- a/basis/stack-checker/stack-checker-tests.factor
+++ b/basis/stack-checker/stack-checker-tests.factor
@@ -180,7 +180,7 @@ DEFER: blah4
     over [
         2drop
     ] [
-        [ swap slip ] keep swap bad-combinator
+        [ dip ] keep swap bad-combinator
     ] if ; inline recursive
 
 [ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail
diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor
index af828c9145..d485692a91 100644
--- a/basis/windows/com/com.factor
+++ b/basis/windows/com/com.factor
@@ -40,6 +40,6 @@ COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046}
     IUnknown::Release drop ; inline
 
 : with-com-interface ( interface quot -- )
-    over [ slip ] [ com-release ] [ ] cleanup ; inline
+    over [ com-release ] curry [ ] cleanup ; inline
 
 DESTRUCTOR: com-release
diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor
index e78c987cd4..9d52378da9 100755
--- a/basis/windows/com/wrapper/wrapper.factor
+++ b/basis/windows/com/wrapper/wrapper.factor
@@ -93,7 +93,7 @@ unless
 
 : compile-alien-callback ( word return parameters abi quot -- word )
     '[ _ _ _ _ alien-callback ]
-    [ [ (( -- alien )) define-declared ] pick slip ]
+    [ [ (( -- alien )) define-declared ] pick [ call ] dip ]
     with-compilation-unit ;
 
 : (callback-word) ( function-name interface-name counter -- word )
diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor
index 5a88db4f9e..c8e0fcd2a9 100644
--- a/core/kernel/kernel-tests.factor
+++ b/core/kernel/kernel-tests.factor
@@ -61,20 +61,16 @@ IN: kernel.tests
 [ 2 ] [ f 2 xor ] unit-test
 [ f ] [ f f xor ] unit-test
 
-[ slip ] must-fail
+[ dip ] must-fail
 [ ] [ :c ] unit-test
 
-[ 1 slip ] must-fail
+[ 1 [ call ] dip ] must-fail
 [ ] [ :c ] unit-test
 
-[ 1 2 slip ] must-fail
+[ 1 2 [ call ] dip ] must-fail
 [ ] [ :c ] unit-test
 
-[ 1 2 3 slip ] must-fail
-[ ] [ :c ] unit-test
-
-
-[ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test
+[ 5 ] [ 1 [ 2 2 + ] dip + ] unit-test
 
 [ [ ] keep ] must-fail
 
diff --git a/extra/crypto/timing/authors.txt b/extra/crypto/timing/authors.txt
deleted file mode 100755
index 7c1b2f2279..0000000000
--- a/extra/crypto/timing/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/crypto/timing/timing-tests.factor b/extra/crypto/timing/timing-tests.factor
deleted file mode 100644
index 9afb913724..0000000000
--- a/extra/crypto/timing/timing-tests.factor
+++ /dev/null
@@ -1,4 +0,0 @@
-USING: crypto.timing kernel tools.test system math ;
-IN: crypto.timing.tests
-
-[ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test
diff --git a/extra/crypto/timing/timing.factor b/extra/crypto/timing/timing.factor
deleted file mode 100644
index b2a59a1851..0000000000
--- a/extra/crypto/timing/timing.factor
+++ /dev/null
@@ -1,8 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math threads system calendar ;
-IN: crypto.timing
-
-: with-timing ( quot n -- )
-    #! force the quotation to execute in, at minimum, n milliseconds
-    millis 2slip millis - + milliseconds sleep ; inline
diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor
index 51196279ff..f5c2ea9811 100755
--- a/extra/reports/noise/noise.factor
+++ b/extra/reports/noise/noise.factor
@@ -19,13 +19,11 @@ IN: reports.noise
         { 2keep 1 }
         { 2nip 2 }
         { 2over 4 }
-        { 2slip 2 }
         { 2swap 3 }
         { 3curry 2 }
         { 3drop 1 }
         { 3dup 2 }
         { 3keep 3 }
-        { 3slip 3 }
         { 4drop 2 }
         { 4dup 3 }
         { compose 1/2 }
@@ -58,7 +56,6 @@ IN: reports.noise
         { pick 4 }
         { roll 4 }
         { rot 3 }
-        { slip 1 }
         { spin 3 }
         { swap 1 }
         { swapd 3 }
diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor
index b26797f8d5..b4bbc9fbf8 100644
--- a/extra/spider/unique-deque/unique-deque.factor
+++ b/extra/spider/unique-deque/unique-deque.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs deques dlists kernel spider ;
+USING: accessors assocs deques dlists kernel ;
 IN: spider.unique-deque
 
 TUPLE: todo-url url depth ;
@@ -32,6 +32,6 @@ TUPLE: unique-deque assoc deque ;
 
 : slurp-deque-when ( deque quot1 quot2: ( value -- ) -- )
     pick deque-empty? [ 3drop ] [
-        [ [ pop-front dup ] 2dip slip [ t ] compose [ drop f ] if ]
+        [ [ pop-front dup ] 2dip [ call ] dip [ t ] compose [ drop f ] if ]
         [ roll [ slurp-deque-when ] [ 3drop ] if ] 3bi
     ] if ; inline recursive

From 028235b9ffc8972bbf74d41eee1ef970ac01d007 Mon Sep 17 00:00:00 2001
From: Bruno Deferrari <utizoc@gmail.com>
Date: Sun, 10 May 2009 20:06:28 -0300
Subject: [PATCH 59/68] extra.redis: Vocabulary for communicating with the
 Redis key-value database

---
 extra/redis/authors.txt                       |   1 +
 extra/redis/command-writer/authors.txt        |   1 +
 .../command-writer-tests.factor               | 138 ++++++++++++++++++
 .../command-writer/command-writer.factor      | 104 +++++++++++++
 extra/redis/command-writer/summary.txt        |   1 +
 extra/redis/redis.factor                      |  74 ++++++++++
 extra/redis/response-parser/authors.txt       |   1 +
 .../response-parser-tests.factor              |  20 +++
 .../response-parser/response-parser.factor    |  27 ++++
 extra/redis/response-parser/summary.txt       |   1 +
 extra/redis/summary.txt                       |   1 +
 11 files changed, 369 insertions(+)
 create mode 100644 extra/redis/authors.txt
 create mode 100644 extra/redis/command-writer/authors.txt
 create mode 100644 extra/redis/command-writer/command-writer-tests.factor
 create mode 100644 extra/redis/command-writer/command-writer.factor
 create mode 100644 extra/redis/command-writer/summary.txt
 create mode 100644 extra/redis/redis.factor
 create mode 100644 extra/redis/response-parser/authors.txt
 create mode 100644 extra/redis/response-parser/response-parser-tests.factor
 create mode 100644 extra/redis/response-parser/response-parser.factor
 create mode 100644 extra/redis/response-parser/summary.txt
 create mode 100644 extra/redis/summary.txt

diff --git a/extra/redis/authors.txt b/extra/redis/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/redis/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/redis/command-writer/authors.txt b/extra/redis/command-writer/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/redis/command-writer/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/redis/command-writer/command-writer-tests.factor b/extra/redis/command-writer/command-writer-tests.factor
new file mode 100644
index 0000000000..901c4e41f3
--- /dev/null
+++ b/extra/redis/command-writer/command-writer-tests.factor
@@ -0,0 +1,138 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test redis.command-writer io.streams.string ;
+IN: redis.command-writer.tests
+
+#! Connection
+[ "QUIT\r\n" ] [ [ quit ] with-string-writer ] unit-test
+
+[ "PING\r\n" ] [ [ ping ] with-string-writer ] unit-test
+
+[ "AUTH password\r\n" ] [ [ "password" auth ] with-string-writer ] unit-test
+
+#! String values
+[ "SET key 3\r\nfoo\r\n" ] [ [ "foo" "key" set ] with-string-writer ] unit-test
+
+[ "GET key\r\n" ] [ [ "key" get ] with-string-writer ] unit-test
+
+[ "GETSET key 3\r\nfoo\r\n" ] [
+    [ "foo" "key" getset ] with-string-writer
+] unit-test
+
+[ "MGET key1 key2 key3\r\n" ] [
+    [ { "key1" "key2" "key3" } mget ] with-string-writer
+] unit-test
+
+[ "SETNX key 3\r\nfoo\r\n" ] [
+    [ "foo" "key" setnx ] with-string-writer
+] unit-test
+
+[ "INCR key\r\n" ] [ [ "key" incr ] with-string-writer ] unit-test
+
+[ "INCRBY key 7\r\n" ] [ [ 7 "key" incrby ] with-string-writer ] unit-test
+
+[ "DECR key\r\n" ] [ [ "key" decr ] with-string-writer ] unit-test
+
+[ "DECRBY key 7\r\n" ] [ [ 7 "key" decrby ] with-string-writer ] unit-test
+
+[ "EXISTS key\r\n" ] [ [ "key" exists ] with-string-writer ] unit-test
+
+[ "DEL key\r\n" ] [ [ "key" del ] with-string-writer ] unit-test
+
+[ "TYPE key\r\n" ] [ [ "key" type ] with-string-writer ] unit-test
+
+#! Key space
+[ "KEYS pat*\r\n" ] [ [ "pat*" keys ] with-string-writer ] unit-test
+
+[ "RANDOMKEY\r\n" ] [ [ randomkey ] with-string-writer ] unit-test
+
+[ "RENAME key newkey\r\n" ] [
+    [ "newkey" "key" rename ] with-string-writer
+] unit-test
+
+[ "RENAMENX key newkey\r\n" ] [
+    [ "newkey" "key" renamenx ] with-string-writer
+] unit-test
+
+[ "DBSIZE\r\n" ] [ [ dbsize ] with-string-writer ] unit-test
+
+[ "EXPIRE key 7\r\n" ] [ [ 7 "key" expire ] with-string-writer ] unit-test
+
+#! Lists
+[ "RPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" rpush ] with-string-writer ] unit-test
+
+[ "LPUSH key 3\r\nfoo\r\n" ] [ [ "foo" "key" lpush ] with-string-writer ] unit-test
+
+[ "LLEN key\r\n" ] [ [ "key" llen ] with-string-writer ] unit-test
+
+[ "LRANGE key 5 9\r\n" ] [ [ 5 9 "key" lrange ] with-string-writer ] unit-test
+
+[ "LTRIM key 5 9\r\n" ] [ [ 5 9 "key" ltrim ] with-string-writer ] unit-test
+
+[ "LINDEX key 7\r\n" ] [ [ 7 "key" lindex ] with-string-writer ] unit-test
+
+[ "LSET key 0 3\r\nfoo\r\n" ] [ [ "foo" 0 "key" lset ] with-string-writer ] unit-test
+
+[ "LREM key 1 3\r\nfoo\r\n" ] [ [ "foo" 1 "key" lrem ] with-string-writer ] unit-test
+
+[ "LPOP key\r\n" ] [ [ "key" lpop ] with-string-writer ] unit-test
+
+[ "RPOP key\r\n" ] [ [ "key" rpop ] with-string-writer ] unit-test
+
+#! Sets
+[ "SADD key 3\r\nfoo\r\n" ] [ [ "foo" "key" sadd ] with-string-writer ] unit-test
+
+[ "SREM key 3\r\nfoo\r\n" ] [ [ "foo" "key" srem ] with-string-writer ] unit-test
+
+[ "SMOVE srckey dstkey 3\r\nfoo\r\n" ] [
+    [ "foo" "dstkey" "srckey" smove ] with-string-writer
+] unit-test
+
+[ "SCARD key\r\n" ] [ [ "key" scard ] with-string-writer ] unit-test
+
+[ "SISMEMBER key 3\r\nfoo\r\n" ] [
+    [ "foo" "key" sismember ] with-string-writer
+] unit-test
+
+[ "SINTER key1 key2 key3\r\n" ] [
+    [ { "key1" "key2" "key3" } sinter ] with-string-writer
+] unit-test
+
+[ "SINTERSTORE dstkey key1 key2 key3\r\n" ] [
+    [ { "key1" "key2" "key3" } "dstkey" sinterstore ] with-string-writer
+] unit-test
+
+[ "SUNION key1 key2 key3\r\n" ] [
+    [ { "key1" "key2" "key3" } sunion ] with-string-writer
+] unit-test
+
+[ "SUNIONSTORE dstkey key1 key2 key3\r\n" ] [
+    [ { "key1" "key2" "key3" } "dstkey" sunionstore ] with-string-writer
+] unit-test
+
+[ "SMEMBERS key\r\n" ] [ [ "key" smembers ] with-string-writer ] unit-test
+
+#! Multiple db
+[ "SELECT 2\r\n" ] [ [ 2 select ] with-string-writer ] unit-test
+
+[ "MOVE key 2\r\n" ] [ [ 2 "key" move ] with-string-writer ] unit-test
+
+[ "FLUSHDB\r\n" ] [ [ flushdb ] with-string-writer ] unit-test
+
+[ "FLUSHALL\r\n" ] [ [ flushall ] with-string-writer ] unit-test
+
+#! Sorting
+
+#! Persistence control
+[ "SAVE\r\n" ] [ [ save ] with-string-writer ] unit-test
+
+[ "BGSAVE\r\n" ] [ [ bgsave ] with-string-writer ] unit-test
+
+[ "LASTSAVE\r\n" ] [ [ lastsave ] with-string-writer ] unit-test
+
+[ "SHUTDOWN\r\n" ] [ [ shutdown ] with-string-writer ] unit-test
+
+#! Remote server control
+[ "INFO\r\n" ] [ [ info ] with-string-writer ] unit-test
+
+[ "MONITOR\r\n" ] [ [ monitor ] with-string-writer ] unit-test
diff --git a/extra/redis/command-writer/command-writer.factor b/extra/redis/command-writer/command-writer.factor
new file mode 100644
index 0000000000..e5e635f457
--- /dev/null
+++ b/extra/redis/command-writer/command-writer.factor
@@ -0,0 +1,104 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.crlf kernel math.parser sequences strings interpolate locals ;
+IN: redis.command-writer
+
+<PRIVATE
+
+GENERIC: write-value-with-length ( value -- )
+
+M: string write-value-with-length
+    [ length number>string write crlf ]
+    [ write ] bi ;
+
+: space ( -- ) CHAR: space write1 ;
+
+: write-key/value ( value key -- )
+    write space
+    write-value-with-length ;
+
+: write-key/integer ( integer key -- )
+    write space
+    number>string write ;
+
+PRIVATE>
+
+#! Connection
+: quit ( -- ) "QUIT" write crlf ;
+: ping ( -- ) "PING" write crlf ;
+: auth ( password -- ) "AUTH " write write crlf ;
+
+#! String values
+: set ( value key -- ) "SET " write write-key/value crlf ;
+: get ( key -- ) "GET " write write crlf ;
+: getset ( value key -- ) "GETSET " write write-key/value crlf ;
+: mget ( keys -- ) "MGET " write " " join write crlf ;
+: setnx ( value key -- ) "SETNX " write write-key/value crlf ;
+: incr ( key -- ) "INCR " write write crlf ;
+: incrby ( integer key -- ) "INCRBY " write write-key/integer crlf ;
+: decr ( key -- ) "DECR " write write crlf ;
+: decrby ( integer key -- ) "DECRBY " write write-key/integer crlf ;
+: exists ( key -- ) "EXISTS " write write crlf ;
+: del ( key -- ) "DEL " write write crlf ;
+: type ( key -- ) "TYPE " write write crlf ;
+
+#! Key space
+: keys ( pattern -- ) "KEYS " write write crlf ;
+: randomkey ( -- ) "RANDOMKEY" write crlf ;
+: rename ( newkey key -- ) "RENAME " write write space write crlf ;
+: renamenx ( newkey key -- ) "RENAMENX " write write space write crlf ;
+: dbsize ( -- ) "DBSIZE" write crlf ;
+: expire ( integer key -- ) "EXPIRE " write write-key/integer crlf ;
+
+#! Lists
+: rpush ( value key -- ) "RPUSH " write write-key/value crlf ;
+: lpush ( value key -- ) "LPUSH " write write-key/value crlf ;
+: llen ( key -- ) "LLEN " write write crlf ;
+: lrange ( start end key -- )
+    "LRANGE " write write [ space number>string write ] bi@ crlf ;
+: ltrim ( start end key -- )
+    "LTRIM " write write [ space number>string write ] bi@ crlf ;
+: lindex ( integer key -- ) "LINDEX " write write-key/integer crlf ;
+: lset ( value index key -- )
+    "LSET " write write-key/integer space write-value-with-length crlf ;
+: lrem ( value amount key -- )
+    "LREM " write write-key/integer space write-value-with-length crlf ;
+: lpop ( key -- ) "LPOP " write write crlf ;
+: rpop ( key -- ) "RPOP " write write crlf ;
+
+#! Sets
+: sadd ( member key -- )
+    "SADD " write write space write-value-with-length crlf ;
+: srem  ( member key -- )
+    "SREM " write write space write-value-with-length crlf ;
+: smove ( member newkey key -- )
+    "SMOVE " write write space write space write-value-with-length crlf ;
+: scard ( key -- ) "SCARD " write write crlf ;
+: sismember ( member key -- )
+    "SISMEMBER " write write space write-value-with-length crlf ;
+: sinter ( keys -- ) "SINTER " write " " join write crlf ;
+: sinterstore ( keys destkey -- )
+    "SINTERSTORE " write write space " " join write crlf ;
+: sunion ( keys -- ) "SUNION " write " " join write crlf ;
+: sunionstore ( keys destkey -- )
+    "SUNIONSTORE " write write " " join space write crlf ;
+: smembers ( key -- ) "SMEMBERS " write write crlf ;
+
+#! Multiple db
+: select ( integer -- ) "SELECT " write number>string write crlf ;
+: move ( integer key -- ) "MOVE " write write-key/integer crlf ;
+: flushdb ( -- ) "FLUSHDB" write crlf ;
+: flushall ( -- ) "FLUSHALL" write crlf ;
+
+#! Sorting
+! sort
+
+#! Persistence control
+: save ( -- ) "SAVE" write crlf ;
+: bgsave ( -- ) "BGSAVE" write crlf ;
+: lastsave ( -- ) "LASTSAVE" write crlf ;
+: shutdown ( -- ) "SHUTDOWN" write crlf ;
+
+#! Remote server control
+: info ( -- ) "INFO" write crlf ;
+: monitor ( -- ) "MONITOR" write crlf ;
diff --git a/extra/redis/command-writer/summary.txt b/extra/redis/command-writer/summary.txt
new file mode 100644
index 0000000000..917b915546
--- /dev/null
+++ b/extra/redis/command-writer/summary.txt
@@ -0,0 +1 @@
+Definitions of messages sent to Redis
diff --git a/extra/redis/redis.factor b/extra/redis/redis.factor
new file mode 100644
index 0000000000..1f6d732407
--- /dev/null
+++ b/extra/redis/redis.factor
@@ -0,0 +1,74 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: io redis.response-parser redis.command-writer ;
+IN: redis
+
+#! Connection
+: redis-quit ( -- ) quit flush ;
+: redis-ping ( -- response ) ping flush read-response ;
+: redis-auth ( password -- response ) auth flush read-response ;
+
+#! String values
+: redis-set ( value key -- response ) set flush read-response ;
+: redis-get ( key -- response ) get flush read-response ;
+: redis-getset ( value key -- response ) getset flush read-response ;
+: redis-mget ( keys -- response ) mget flush read-response ;
+: redis-setnx ( value key -- response ) setnx flush read-response ;
+: redis-incr ( key -- response ) incr flush read-response ;
+: redis-incrby ( integer key -- response ) incrby flush read-response ;
+: redis-decr ( key -- response ) decr flush read-response ;
+: redis-decrby ( integer key -- response ) decrby flush read-response ;
+: redis-exists ( key -- response ) exists flush read-response ;
+: redis-del ( key -- response ) del flush read-response ;
+: redis-type ( key -- response ) type flush read-response ;
+
+#! Key space
+: redis-keys ( pattern -- response ) keys flush read-response ;
+: redis-randomkey ( -- response ) randomkey flush read-response ;
+: redis-rename ( newkey key -- response ) rename flush read-response ;
+: redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
+: redis-dbsize ( -- response ) dbsize flush read-response ;
+: redis-expire ( integer key -- response ) expire flush read-response ;
+
+#! Lists
+: redis-rpush ( value key -- response ) rpush flush read-response ;
+: redis-lpush ( value key -- response ) lpush flush read-response ;
+: redis-llen ( key -- response ) llen flush read-response ;
+: redis-lrange ( start end key -- response ) lrange flush read-response ;
+: redis-ltrim ( start end key -- response ) ltrim flush read-response ;
+: redis-lindex ( integer key -- response ) lindex flush read-response ;
+: redis-lset ( value index key -- response ) lset flush read-response ;
+: redis-lrem ( value amount key -- response ) lrem flush read-response ;
+: redis-lpop ( key -- response ) lpop flush read-response ;
+: redis-rpop ( key -- response ) rpop flush read-response ;
+
+#! Sets
+: redis-sadd ( member key -- response ) sadd flush read-response ;
+: redis-srem  ( member key -- response ) srem flush read-response ;
+: redis-smove ( member newkey key -- response ) smove flush read-response ;
+: redis-scard ( key -- response ) scard flush read-response ;
+: redis-sismember ( member key -- response ) sismember flush read-response ;
+: redis-sinter ( keys -- response ) sinter flush read-response ;
+: redis-sinterstore ( keys destkey -- response ) sinterstore flush read-response ;
+: redis-sunion ( keys -- response ) sunion flush read-response ;
+: redis-sunionstore ( keys destkey -- response ) sunionstore flush read-response ;
+: redis-smembers ( key -- response ) smembers flush read-response ;
+
+#! Multiple db
+: redis-select ( integer -- response ) select flush read-response ;
+: redis-move ( integer key -- response ) move flush read-response ;
+: redis-flushdb ( -- response ) flushdb flush read-response ;
+: redis-flushall ( -- response ) flushall flush read-response ;
+
+#! Sorting
+! sort
+
+#! Persistence control
+: redis-save ( -- response ) save flush read-response ;
+: redis-bgsave ( -- response ) bgsave flush read-response ;
+: redis-lastsave ( -- response ) lastsave flush read-response ;
+: redis-shutdown ( -- response ) shutdown flush read-response ;
+
+#! Remote server control
+: redis-info ( -- response ) info flush read-response ;
+: redis-monitor ( -- response ) monitor flush read-response ;
diff --git a/extra/redis/response-parser/authors.txt b/extra/redis/response-parser/authors.txt
new file mode 100644
index 0000000000..f4a8cb1dc2
--- /dev/null
+++ b/extra/redis/response-parser/authors.txt
@@ -0,0 +1 @@
+Bruno Deferrari
diff --git a/extra/redis/response-parser/response-parser-tests.factor b/extra/redis/response-parser/response-parser-tests.factor
new file mode 100644
index 0000000000..bde36114c3
--- /dev/null
+++ b/extra/redis/response-parser/response-parser-tests.factor
@@ -0,0 +1,20 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test redis.response-parser io.streams.string ;
+IN: redis.response-parser.tests
+
+[ 1 ] [ ":1\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ "hello" ] [ "$5\r\nhello\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ f ] [ "$-1\r\n" [ read-response ] with-string-reader ] unit-test
+
+[ { "hello" "world!" } ] [
+    "*2\r\n$5\r\nhello\r\n$6\r\nworld!\r\n" [ read-response ] with-string-reader
+] unit-test
+
+[ { "hello" f "world!" } ] [
+    "*3\r\n$5\r\nhello\r\n$-1\r\n$6\r\nworld!\r\n" [
+        read-response
+    ] with-string-reader
+] unit-test
diff --git a/extra/redis/response-parser/response-parser.factor b/extra/redis/response-parser/response-parser.factor
new file mode 100644
index 0000000000..3d92d553b0
--- /dev/null
+++ b/extra/redis/response-parser/response-parser.factor
@@ -0,0 +1,27 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators io kernel math math.parser sequences ;
+IN: redis.response-parser
+
+<PRIVATE
+
+: read-bulk ( n -- bytes ) dup 0 < [ drop f ] [ read 2 read drop ] if ;
+: (read-multi-bulk) ( -- bytes ) readln rest string>number read-bulk ;
+: read-multi-bulk ( n -- seq/f )
+    dup 0 < [ drop f ] [
+        iota [ drop (read-multi-bulk) ] map
+    ] if ;
+
+: handle-response ( string -- string ) ; ! TODO
+: handle-error ( string -- string ) ; ! TODO
+
+PRIVATE>
+
+: read-response ( -- response )
+    readln unclip {
+        { CHAR: : [ string>number ] }
+        { CHAR: + [ handle-response ] }
+        { CHAR: $ [ string>number read-bulk ] }
+        { CHAR: * [ string>number read-multi-bulk ] }
+        { CHAR: - [ handle-error ] }
+    } case ;
diff --git a/extra/redis/response-parser/summary.txt b/extra/redis/response-parser/summary.txt
new file mode 100644
index 0000000000..b89407c7b4
--- /dev/null
+++ b/extra/redis/response-parser/summary.txt
@@ -0,0 +1 @@
+Parser for responses sent by the Redis server
diff --git a/extra/redis/summary.txt b/extra/redis/summary.txt
new file mode 100644
index 0000000000..0cd6e69e38
--- /dev/null
+++ b/extra/redis/summary.txt
@@ -0,0 +1 @@
+Words for communicating with the Redis key-value database

From c92afaf38508640ca67986419e585c3451b31dff Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 10 May 2009 18:20:19 -0500
Subject: [PATCH 60/68] fix rsa tests

---
 extra/crypto/rsa/rsa.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor
index 50ea84fd39..f4ef4687b5 100644
--- a/extra/crypto/rsa/rsa.factor
+++ b/extra/crypto/rsa/rsa.factor
@@ -21,7 +21,7 @@ C: <rsa> rsa
 CONSTANT: public-key 65537
 
 : rsa-primes ( numbits -- p q )
-    2/ 2 unique-primes first2 ;
+    2/ 2 swap unique-primes first2 ;
 
 : modulus-phi ( numbits -- n phi ) 
     #! Loop until phi is not divisible by the public key.

From c32927bfeadf6c18c21d62a7ade87e57e7c61361 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Sun, 10 May 2009 18:54:56 -0500
Subject: [PATCH 61/68] Fix unit test failures caused by change to 'contents'
 word

---
 basis/base64/base64-tests.factor          |  2 +-
 basis/urls/encoding/encoding-tests.factor |  4 ++--
 basis/urls/urls.factor                    | 14 ++++++++------
 3 files changed, 11 insertions(+), 9 deletions(-)

diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor
index 9094286575..e962fa7e59 100644
--- a/basis/base64/base64-tests.factor
+++ b/basis/base64/base64-tests.factor
@@ -4,7 +4,7 @@ IN: base64.tests
 
 [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
 ] unit-test
-[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
+[ "" ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
 [ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
 [ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
 [ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test
diff --git a/basis/urls/encoding/encoding-tests.factor b/basis/urls/encoding/encoding-tests.factor
index 78e31a764d..f3e0497588 100644
--- a/basis/urls/encoding/encoding-tests.factor
+++ b/basis/urls/encoding/encoding-tests.factor
@@ -2,8 +2,8 @@ IN: urls.encoding.tests
 USING: urls.encoding tools.test arrays kernel assocs present accessors ;
 
 [ "~hello world" ] [ "%7ehello world" url-decode ] unit-test
-[ f ] [ "%XX%XX%XX" url-decode ] unit-test
-[ f ] [ "%XX%XX%X" url-decode ] unit-test
+[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
+[ "" ] [ "%XX%XX%X" url-decode ] unit-test
 
 [ "hello world" ] [ "hello%20world" url-decode ] unit-test
 [ " ! "         ] [ "%20%21%20"     url-decode ] unit-test
diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index 1e886ae3e2..a72fac567a 100644
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -25,12 +25,14 @@ TUPLE: url protocol username password host port path query anchor ;
     ] if ;
 
 : parse-host ( string -- host port )
-    ":" split1 [ url-decode ] [
-        dup [
-            string>number
-            dup [ "Invalid port" throw ] unless
-        ] when
-    ] bi* ;
+    [
+        ":" split1 [ url-decode ] [
+            dup [
+                string>number
+                dup [ "Invalid port" throw ] unless
+            ] when
+        ] bi*
+    ] [ f f ] if* ;
 
 GENERIC: >url ( obj -- url )
 

From 9986f6e23e756cc9a3198be6a4f31ca79d847c73 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@shill.internal.stack-effects.com>
Date: Sun, 10 May 2009 19:01:38 -0500
Subject: [PATCH 62/68] Fix bool type on PowerPC

---
 basis/alien/c-types/c-types.factor | 9 +++++----
 basis/cpu/ppc/ppc.factor           | 8 +++++++-
 2 files changed, 12 insertions(+), 5 deletions(-)

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 6067c90f2d..df5a5bbba8 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -259,8 +259,9 @@ M: long-long-type box-return ( type -- )
     [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
     (( value -- c-ptr )) define-inline ;
 
-: c-bool> ( int -- ? )
-    0 = not ; inline
+: >c-bool ( ? -- int ) 1 0 ? ; inline
+
+: c-bool> ( int -- ? ) 0 = not ; inline
 
 : define-primitive-type ( type name -- )
     [ typedef ]
@@ -409,8 +410,8 @@ CONSTANT: primitive-types
     "uchar" define-primitive-type
 
     <c-type>
-        [ alien-unsigned-1 zero? not ] >>getter
-        [ [ 1 0 ? ] 2dip set-alien-unsigned-1 ] >>setter
+        [ alien-unsigned-1 c-bool> ] >>getter
+        [ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
         1 >>size
         1 >>align
         "box_boolean" >>boxer
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 442dd8e7ea..314ea830f8 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -713,4 +713,10 @@ USE: vocabs.loader
 } cond
 
 "complex-double" c-type t >>return-in-registers? drop
-"bool" c-type 4 >>size 4 >>align drop
\ No newline at end of file
+
+"bool" c-type
+4 >>size
+4 >>align
+[ alien-unsigned-1 c-bool> ] >>getter
+[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
+drop
\ No newline at end of file

From 05e0171dea6296ddc58027d1f49d488e798a00d5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 10 May 2009 19:10:20 -0500
Subject: [PATCH 63/68] cpu.ppc: really fix bool type

---
 basis/cpu/ppc/ppc.factor | 22 +++++++++++++---------
 1 file changed, 13 insertions(+), 9 deletions(-)

diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 314ea830f8..dc7108b3a1 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -2,11 +2,11 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sequences kernel combinators make math
 math.order math.ranges system namespaces locals layouts words
-alien alien.c-types literals cpu.architecture cpu.ppc.assembler
-cpu.ppc.assembler.backend literals compiler.cfg.registers
+alien alien.accessors alien.c-types literals cpu.architecture
+cpu.ppc.assembler cpu.ppc.assembler.backend literals compiler.cfg.registers
 compiler.cfg.instructions compiler.constants compiler.codegen
 compiler.codegen.fixup compiler.cfg.intrinsics
-compiler.cfg.stack-frame ;
+compiler.cfg.stack-frame compiler.units ;
 IN: cpu.ppc
 
 ! PowerPC register assignments:
@@ -714,9 +714,13 @@ USE: vocabs.loader
 
 "complex-double" c-type t >>return-in-registers? drop
 
-"bool" c-type
-4 >>size
-4 >>align
-[ alien-unsigned-1 c-bool> ] >>getter
-[ [ >c-bool ] 2dip set-alien-unsigned-1 ] >>setter
-drop
\ No newline at end of file
+[
+    <c-type>
+        [ alien-unsigned-4 c-bool> ] >>getter
+        [ [ >c-bool ] 2dip set-alien-unsigned-4 ] >>setter
+        4 >>size
+        4 >>align
+        "box_boolean" >>boxer
+        "to_boolean" >>unboxer
+    "bool" define-primitive-type
+] with-compilation-unit

From ba1795c85446b1b69029a196ac4a8e2fe7e82dde Mon Sep 17 00:00:00 2001
From: "U-C4\\Administrator" <Administrator@k.(none)>
Date: Sun, 10 May 2009 19:20:04 -0500
Subject: [PATCH 64/68] add a find-by-extensions word

---
 .../io/directories/search/search-docs.factor  | 35 +++++++++++++++++--
 basis/io/directories/search/search.factor     |  9 ++++-
 extra/id3/id3.factor                          |  3 +-
 3 files changed, 41 insertions(+), 6 deletions(-)

diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor
index a6c82a1bff..6bfaa07227 100644
--- a/basis/io/directories/search/search-docs.factor
+++ b/basis/io/directories/search/search-docs.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel quotations ;
+USING: help.markup help.syntax kernel quotations sequences ;
 IN: io.directories.search
 
 HELP: each-file
@@ -57,6 +57,32 @@ HELP: find-all-in-directories
 }
 { $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ;
 
+HELP: find-by-extension
+{ $values
+    { "path" "a pathname string" } { "extension" "a file extension" }
+    { "seq" sequence }
+}
+{ $description "Searches a directory for all files with the given extension. File extension and filenames are converted to lower-case and compared using the " { $link tail? } " word. The file extension should contain the period." }
+{ $examples
+    { $unchecked-example
+        "USING: io.directories.search ;"
+        "\"/\" \".mp3\" find-by-extension"
+    }
+} ;
+
+HELP: find-by-extensions
+{ $values
+    { "path" "a pathname string" } { "extensions" "a sequence of file extensions" }
+    { "seq" sequence }
+}
+{ $description "Searches a directory for all files in the given list of extensions. File extensions and filenames are converted to lower-case and compared using the " { $link tail? } " word. File extensions should contain the period." }
+{ $examples
+    { $unchecked-example
+        "USING: io.directories.search ;"
+        "\"/\" { \".jpg\" \".gif\" \".tiff\" \".png\" \".bmp\" } find-by-extensions"
+    }
+} ;
+
 { find-file find-all-files find-in-directories find-all-in-directories } related-words
 
 ARTICLE: "io.directories.search" "Searching directories"
@@ -65,10 +91,13 @@ ARTICLE: "io.directories.search" "Searching directories"
 { $subsection recursive-directory-files }
 { $subsection recursive-directory-entries }
 { $subsection each-file }
-"Finding files:"
+"Finding files by name:"
 { $subsection find-file }
 { $subsection find-all-files }
 { $subsection find-in-directories }
-{ $subsection find-all-in-directories } ;
+{ $subsection find-all-in-directories }
+"Finding files by extension:"
+{ $subsection find-by-extension }
+{ $subsection find-by-extensions } ;
 
 ABOUT: "io.directories.search"
diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor
index f7d18306f8..3fbf09a3c3 100755
--- a/basis/io/directories/search/search.factor
+++ b/basis/io/directories/search/search.factor
@@ -3,7 +3,7 @@
 USING: accessors arrays continuations deques dlists fry
 io.directories io.files io.files.info io.pathnames kernel
 sequences system vocabs.loader locals math namespaces
-sorting assocs calendar threads io math.parser ;
+sorting assocs calendar threads io math.parser unicode.case ;
 IN: io.directories.search
 
 : qualified-directory-entries ( path -- seq )
@@ -106,4 +106,11 @@ ERROR: file-not-found path bfs? quot ;
         ] { } map>assoc
     ] with-qualified-directory-entries sort-values ;
 
+: find-by-extensions ( path extensions -- seq )
+    [ >lower ] map
+    '[ >lower _ [ tail? ] with any? ] find-all-files ;
+    
+: find-by-extension ( path extension -- seq )
+    1array find-by-extensions ;
+
 os windows? [ "io.directories.search.windows" require ] when
diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor
index 79df00ff5e..6acace8582 100644
--- a/extra/id3/id3.factor
+++ b/extra/id3/id3.factor
@@ -233,8 +233,7 @@ PRIVATE>
 : genre ( id3 -- string/f )
     "TCON" find-id3-frame parse-genre ;
 
-: find-mp3s ( path -- seq )
-    [ >lower ".mp3" tail? ] find-all-files ;
+: find-mp3s ( path -- seq ) ".mp3" find-by-extension ;
 
 ERROR: id3-parse-error path error ;
 

From 9de34ab3cd7ff621a2be49dbfcaa3ebff2d68b95 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 10 May 2009 21:33:13 -0500
Subject: [PATCH 65/68] Fix deployment of UI apps and implement various tricks
 to make deployed images smaller

---
 basis/cocoa/messages/messages.factor         |  2 +-
 basis/tools/deploy/deploy-docs.factor        |  2 +
 basis/tools/deploy/deploy-tests.factor       |  4 ++
 basis/tools/deploy/shaker/shaker.factor      | 68 +++++++++++---------
 basis/tools/deploy/shaker/strip-cocoa.factor |  9 ++-
 basis/ui/gadgets/worlds/worlds.factor        |  2 +-
 basis/ui/gestures/gestures.factor            | 12 ++--
 basis/ui/pixel-formats/pixel-formats.factor  |  4 +-
 extra/spheres/deploy.factor                  | 19 +++---
 extra/terrain/deploy.factor                  | 15 +++++
 10 files changed, 87 insertions(+), 50 deletions(-)
 create mode 100644 extra/terrain/deploy.factor

diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 65bb2c02ef..fdd4ba81d7 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -68,7 +68,7 @@ MACRO: (send) ( selector super? -- quot )
     [ dup lookup-method ] dip
     [ make-prepare-send ] 2keep
     super-message-senders message-senders ? get at
-    '[ _ call _ execute ] ;
+    1quotation append ;
 
 : send ( receiver args... selector -- return... ) f (send) ; inline
 
diff --git a/basis/tools/deploy/deploy-docs.factor b/basis/tools/deploy/deploy-docs.factor
index 4c03047eb8..71701b6a56 100644
--- a/basis/tools/deploy/deploy-docs.factor
+++ b/basis/tools/deploy/deploy-docs.factor
@@ -29,6 +29,8 @@ ARTICLE: "tools.deploy.caveats" "Deploy tool caveats"
 "In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
 { $heading "Behavior of " { $link POSTPONE: execute( } }
 "Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
+{ $heading "Behavior of " { $link POSTPONE: call-next-method } }
+"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications."
 { $heading "Error reporting" }
 "If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
 { $heading "Choosing the right deploy flags" }
diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor
index 3bebf7236d..1c12e8b781 100644
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/basis/tools/deploy/deploy-tests.factor
@@ -20,6 +20,10 @@ io.directories tools.deploy.test ;
 
 [ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
 
+[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test
+
 [ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
 
 os macosx? [
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 816dbb7979..7bbc726d30 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -1,13 +1,11 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.backend io.streams.c init fry
-namespaces make assocs kernel parser lexer strings.parser vocabs
-sequences words memory kernel.private
-continuations io vocabs.loader system strings sets
-vectors quotations byte-arrays sorting compiler.units
-definitions generic generic.standard tools.deploy.config ;
+USING: arrays accessors io.backend io.streams.c init fry namespaces
+make assocs kernel parser lexer strings.parser vocabs sequences words
+memory kernel.private continuations io vocabs.loader system strings
+sets vectors quotations byte-arrays sorting compiler.units definitions
+generic generic.standard tools.deploy.config combinators classes ;
 QUALIFIED: bootstrap.stage2
-QUALIFIED: classes
 QUALIFIED: command-line
 QUALIFIED: compiler.errors
 QUALIFIED: continuations
@@ -193,6 +191,11 @@ IN: tools.deploy.shaker
     strip-word-names? [ dup strip-word-names ] when
     2drop ;
 
+: strip-compiler-classes ( -- )
+    "Stripping compiler classes" show
+    "compiler" child-vocabs [ words ] map concat [ class? ] filter
+    [ dup implementors [ "methods" word-prop delete-at ] with each ] each ;
+
 : strip-default-methods ( -- )
     strip-debugger? [
         "Stripping default methods" show
@@ -255,14 +258,14 @@ IN: tools.deploy.shaker
             {
                 gensym
                 name>char-hook
-                classes:next-method-quot-cache
-                classes:class-and-cache
-                classes:class-not-cache
-                classes:class-or-cache
-                classes:class<=-cache
-                classes:classes-intersect-cache
-                classes:implementors-map
-                classes:update-map
+                next-method-quot-cache
+                class-and-cache
+                class-not-cache
+                class-or-cache
+                class<=-cache
+                classes-intersect-cache
+                implementors-map
+                update-map
                 command-line:main-vocab-hook
                 compiled-crossref
                 compiled-generic-crossref
@@ -334,8 +337,16 @@ IN: tools.deploy.shaker
     [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
     become ; inline
 
-: compress-byte-arrays ( -- )
-    [ byte-array? ] [ ] "byte arrays" compress ;
+: compress-objects ( -- )
+    [
+        {
+            [ dup array? [ empty? ] [ drop f ] if ]
+            [ byte-array? ]
+            [ string? ]
+            [ wrapper? ]
+        } cleave
+        or or or
+    ] [ ] "objects" compress ;
 
 : remain-compiled ( old new -- old new )
     #! Quotations which were formerly compiled must remain
@@ -349,12 +360,6 @@ IN: tools.deploy.shaker
     [ quotation? ] [ remain-compiled ] "quotations" compress
     [ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
 
-: compress-strings ( -- )
-    [ string? ] [ ] "strings" compress ;
-
-: compress-wrappers ( -- )
-    [ wrapper? ] [ ] "wrappers" compress ;
-
 SYMBOL: deploy-vocab
 
 : [:c] ( -- word ) ":c" "debugger" lookup ;
@@ -385,18 +390,23 @@ SYMBOL: deploy-vocab
     t "quiet" set-global
     f output-stream set-global ;
 
+: unsafe-next-method-quot ( method -- quot )
+    [ "method-class" word-prop ]
+    [ "method-generic" word-prop ] bi
+    next-method 1quotation ;
+
 : compute-next-methods ( -- )
     [ standard-generic? ] instances [
         "methods" word-prop [
-            nip
-            dup next-method-quot "next-method-quot" set-word-prop
+            nip dup
+            unsafe-next-method-quot
+            "next-method-quot" set-word-prop
         ] assoc-each
     ] each
     "vocab:tools/deploy/shaker/next-methods.factor" run-file ;
 
 : strip ( -- )
     init-stripper
-    strip-default-methods
     strip-libc
     strip-call
     strip-cocoa
@@ -404,14 +414,14 @@ SYMBOL: deploy-vocab
     compute-next-methods
     strip-init-hooks
     strip-c-io
+    strip-compiler-classes
+    strip-default-methods
     f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
     deploy-vocab get vocab-main deploy-boot-quot
     stripped-word-props
     stripped-globals strip-globals
-    compress-byte-arrays
+    compress-objects
     compress-quotations
-    compress-strings
-    compress-wrappers
     strip-words ;
 
 : deploy-error-handler ( quot -- )
diff --git a/basis/tools/deploy/shaker/strip-cocoa.factor b/basis/tools/deploy/shaker/strip-cocoa.factor
index df64443b7b..133308b732 100644
--- a/basis/tools/deploy/shaker/strip-cocoa.factor
+++ b/basis/tools/deploy/shaker/strip-cocoa.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
 namespaces kernel kernel.private words compiler.units sequences
-init vocabs ;
+init vocabs memoize accessors ;
 IN: tools.deploy.shaker.cocoa
 
 : pool ( obj -- obj' ) \ pool get [ ] cache ;
@@ -42,3 +42,8 @@ H{ } clone \ pool [
         [ get values compile ] each
     ] bind
 ] with-variable
+
+\ make-prepare-send reset-memoized
+\ <selector> reset-memoized
+
+\ (send) def>> second clear-assoc
\ No newline at end of file
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index eec5666f0e..2e7b84ef6e 100755
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models
 namespaces opengl opengl.textures sequences io combinators
 combinators.short-circuit fry math.vectors math.rectangles cache
 ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors literals ;
+ui.pixel-formats destructors literals ;
 IN: ui.gadgets.worlds
 
 CONSTANT: default-world-pixel-format-attributes
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 7e038ef2e0..073b2d5e26 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -3,8 +3,8 @@
 USING: accessors arrays assocs kernel math math.order models
 namespaces make sequences words strings system hashtables math.parser
 math.vectors classes.tuple classes boxes calendar alarms combinators
-sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
-unicode.categories combinators.short-circuit ;
+sets columns fry deques ui.gadgets ui.gadgets.private ascii
+combinators.short-circuit ;
 IN: ui.gestures
 
 GENERIC: handle-gesture ( gesture gadget -- ? )
@@ -296,10 +296,10 @@ HOOK: modifiers>string os ( modifiers -- string )
 M: macosx modifiers>string
     [
         {
-            { A+ [ "\u{place-of-interest-sign}" ] }
-            { M+ [ "\u{option-key}" ] }
-            { S+ [ "\u{upwards-white-arrow}" ] }
-            { C+ [ "\u{up-arrowhead}" ] }
+            { A+ [ "\u002318" ] }
+            { M+ [ "\u002325" ] }
+            { S+ [ "\u0021e7" ] }
+            { C+ [ "\u002303" ] }
         } case
     ] map "" join ;
 
diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor
index 52abf44362..a280ab0666 100644
--- a/basis/ui/pixel-formats/pixel-formats.factor
+++ b/basis/ui/pixel-formats/pixel-formats.factor
@@ -1,6 +1,6 @@
 USING: accessors assocs classes destructors functors kernel
 lexer math parser sequences specialized-arrays.int ui.backend
-words.symbol ;
+words ;
 IN: ui.pixel-formats
 
 SYMBOLS:
@@ -71,7 +71,7 @@ GENERIC: >PFA ( attribute -- pfas )
 
 M: object >PFA
     drop { } ;
-M: symbol >PFA
+M: word >PFA
     TABLE at [ { } ] unless* ;
 M: pixel-format-attribute >PFA
     dup class TABLE at
diff --git a/extra/spheres/deploy.factor b/extra/spheres/deploy.factor
index d6591a1a26..22c5de0963 100644
--- a/extra/spheres/deploy.factor
+++ b/extra/spheres/deploy.factor
@@ -1,14 +1,15 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-reflection 1 }
-    { deploy-word-defs? f }
-    { deploy-word-props? f }
-    { deploy-name "Spheres" }
-    { deploy-compiler? t }
-    { deploy-math? t }
-    { deploy-io 1 }
-    { deploy-threads? t }
-    { "stop-after-last-window?" t }
     { deploy-ui? t }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { deploy-math? t }
+    { deploy-io 2 }
     { deploy-c-types? f }
+    { deploy-name "Spheres" }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { "stop-after-last-window?" t }
+    { deploy-compiler? t }
+    { deploy-threads? t }
 }
diff --git a/extra/terrain/deploy.factor b/extra/terrain/deploy.factor
new file mode 100644
index 0000000000..e51f8d13e6
--- /dev/null
+++ b/extra/terrain/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-ui? t }
+    { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-c-types? f }
+    { deploy-name "Terrain" }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { "stop-after-last-window?" t }
+    { deploy-compiler? t }
+    { deploy-threads? t }
+}

From 3fe5bb872b515cf5cc60fa1e6597498096448882 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 11 May 2009 00:32:22 -0500
Subject: [PATCH 66/68] Deploy tool always uses optimizing compiler now

---
 basis/none/deploy.factor                     |  1 -
 basis/tools/deploy/backend/backend.factor    | 16 ++++++++--------
 basis/tools/deploy/config/config-docs.factor |  6 ------
 basis/tools/deploy/config/config.factor      |  2 --
 basis/tools/deploy/deploy-tests.factor       |  3 +--
 basis/tools/deploy/shaker/shaker.factor      | 19 ++++++++++---------
 basis/tools/deploy/test/1/deploy.factor      |  1 -
 basis/tools/deploy/test/10/deploy.factor     |  1 -
 basis/tools/deploy/test/11/deploy.factor     |  1 -
 basis/tools/deploy/test/12/deploy.factor     |  1 -
 basis/tools/deploy/test/13/deploy.factor     |  1 -
 basis/tools/deploy/test/2/deploy.factor      |  1 -
 basis/tools/deploy/test/3/deploy.factor      |  1 -
 basis/tools/deploy/test/4/deploy.factor      |  1 -
 basis/tools/deploy/test/5/deploy.factor      |  1 -
 basis/tools/deploy/test/6/deploy.factor      |  1 -
 basis/tools/deploy/test/7/deploy.factor      |  1 -
 basis/tools/deploy/test/8/8.factor           | 11 -----------
 basis/tools/deploy/test/8/deploy.factor      | 15 ---------------
 basis/tools/deploy/test/9/deploy.factor      |  1 -
 basis/ui/tools/deploy/deploy.factor          |  1 -
 extra/4DNav/deploy.factor                    |  1 -
 extra/benchmark/fib6/deploy.factor           |  1 -
 extra/benchmark/regex-dna/deploy.factor      |  1 -
 extra/bunny/deploy.factor                    |  1 -
 extra/chicago-talk/deploy.factor             |  1 -
 extra/color-picker/deploy.factor             |  1 -
 extra/drills/deployed/deploy.factor          |  1 -
 extra/gesture-logger/deploy.factor           |  1 -
 extra/hello-ui/deploy.factor                 | 18 +++++++++---------
 extra/hello-unicode/deploy.factor            |  1 -
 extra/hello-world/deploy.factor              |  1 -
 extra/jamshred/deploy.factor                 |  1 -
 extra/joystick-demo/deploy.factor            |  1 -
 extra/maze/deploy.factor                     | 18 +++++++++---------
 extra/merger/deploy.factor                   |  1 -
 extra/minneapolis-talk/deploy.factor         |  1 -
 extra/nehe/deploy.factor                     |  1 -
 extra/spheres/deploy.factor                  |  1 -
 extra/sudoku/deploy.factor                   |  1 -
 extra/terrain/deploy.factor                  |  1 -
 extra/tetris/deploy.factor                   |  1 -
 extra/webkit-demo/deploy.factor              |  1 -
 43 files changed, 37 insertions(+), 105 deletions(-)
 delete mode 100644 basis/tools/deploy/test/8/8.factor
 delete mode 100644 basis/tools/deploy/test/8/deploy.factor

diff --git a/basis/none/deploy.factor b/basis/none/deploy.factor
index f604beab3f..06cc8c6a20 100644
--- a/basis/none/deploy.factor
+++ b/basis/none/deploy.factor
@@ -6,7 +6,6 @@ H{
     { deploy-name "none" }
     { "stop-after-last-window?" t }
     { deploy-c-types? f }
-    { deploy-compiler? f }
     { deploy-io 1 }
     { deploy-ui? f }
     { deploy-reflection 1 }
diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor
index b74548a65f..ba82276927 100755
--- a/basis/tools/deploy/backend/backend.factor
+++ b/basis/tools/deploy/backend/backend.factor
@@ -43,14 +43,14 @@ CONSTANT: theme-path "basis/ui/gadgets/theme/"
     [ my-arch make-image ] unless ;
 
 : bootstrap-profile ( -- profile )
-    {
-        { "math"     deploy-math?     }
-        { "compiler" deploy-compiler? }
-        { "threads"  deploy-threads?  }
-        { "ui"       deploy-ui?       }
-        { "unicode"  deploy-unicode?  }
-    } [ nip get ] assoc-filter keys
-    native-io? [ "io" suffix ] when ;
+    [
+        deploy-math? get [ "math" , ] when
+        deploy-threads? get [ "threads" , ] when
+        "compiler" ,
+        deploy-ui? get [ "ui" , ] when
+        deploy-unicode? get [ "unicode" , ] when
+        native-io? [ "io" , ] when
+    ] { } make ;
 
 : staging-image-name ( profile -- name )
     "staging."
diff --git a/basis/tools/deploy/config/config-docs.factor b/basis/tools/deploy/config/config-docs.factor
index c8249e4e41..bd612c644a 100644
--- a/basis/tools/deploy/config/config-docs.factor
+++ b/basis/tools/deploy/config/config-docs.factor
@@ -5,7 +5,6 @@ IN: tools.deploy.config
 ARTICLE: "deploy-flags" "Deployment flags"
 "There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
 { $subsection deploy-math?     }
-{ $subsection deploy-compiler? }
 { $subsection deploy-unicode?   }
 { $subsection deploy-threads?  }
 { $subsection deploy-ui?       }
@@ -53,11 +52,6 @@ HELP: deploy-math?
 $nl
 "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
 
-HELP: deploy-compiler?
-{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
-$nl
-"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
-
 HELP: deploy-unicode?
 { $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
 $nl
diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor
index 63c8393b51..89d1fe3821 100644
--- a/basis/tools/deploy/config/config.factor
+++ b/basis/tools/deploy/config/config.factor
@@ -7,7 +7,6 @@ IN: tools.deploy.config
 SYMBOL: deploy-name
 
 SYMBOL: deploy-ui?
-SYMBOL: deploy-compiler?
 SYMBOL: deploy-math?
 SYMBOL: deploy-unicode?
 SYMBOL: deploy-threads?
@@ -55,7 +54,6 @@ SYMBOL: deploy-image
         { deploy-ui?                f }
         { deploy-io                 2 }
         { deploy-reflection         1 }
-        { deploy-compiler?          t }
         { deploy-threads?           t }
         { deploy-unicode?           f }
         { deploy-math?              t }
diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor
index 1c12e8b781..842faba640 100644
--- a/basis/tools/deploy/deploy-tests.factor
+++ b/basis/tools/deploy/deploy-tests.factor
@@ -11,7 +11,7 @@ io.directories tools.deploy.test ;
 
 [ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
 
-[ "staging.math-compiler-threads-ui-strip.image" ] [
+[ "staging.math-threads-compiler-ui-strip.image" ] [
     "hello-ui" deploy-config
     [ bootstrap-profile staging-image-name file-name ] bind
 ] unit-test
@@ -88,7 +88,6 @@ M: quit-responder call-responder*
 {
     "tools.deploy.test.6"
     "tools.deploy.test.7"
-    "tools.deploy.test.8"
     "tools.deploy.test.9"
     "tools.deploy.test.10"
     "tools.deploy.test.11"
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 7bbc726d30..d79326ddc4 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -337,16 +337,17 @@ IN: tools.deploy.shaker
     [ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
     become ; inline
 
+: compress-object? ( obj -- ? )
+    {
+        { [ dup array? ] [ empty? ] }
+        { [ dup byte-array? ] [ drop t ] }
+        { [ dup string? ] [ drop t ] }
+        { [ dup wrapper? ] [ drop t ] }
+        [ drop f ]
+    } cond ;
+
 : compress-objects ( -- )
-    [
-        {
-            [ dup array? [ empty? ] [ drop f ] if ]
-            [ byte-array? ]
-            [ string? ]
-            [ wrapper? ]
-        } cleave
-        or or or
-    ] [ ] "objects" compress ;
+    [ compress-object? ] [ ] "objects" compress ;
 
 : remain-compiled ( old new -- old new )
     #! Quotations which were formerly compiled must remain
diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor
index 6d6a1c1bd3..509024a5c3 100644
--- a/basis/tools/deploy/test/1/deploy.factor
+++ b/basis/tools/deploy/test/1/deploy.factor
@@ -8,7 +8,6 @@ H{
     { deploy-math? t }
     { deploy-io 2 }
     { deploy-name "tools.deploy.test.1" }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
 }
diff --git a/basis/tools/deploy/test/10/deploy.factor b/basis/tools/deploy/test/10/deploy.factor
index 3f5940651d..c42063f644 100644
--- a/basis/tools/deploy/test/10/deploy.factor
+++ b/basis/tools/deploy/test/10/deploy.factor
@@ -4,7 +4,6 @@ H{
     { deploy-unicode? f }
     { deploy-io 2 }
     { deploy-word-props? f }
-    { deploy-compiler? f }
     { deploy-threads? f }
     { deploy-word-defs? f }
     { "stop-after-last-window?" t }
diff --git a/basis/tools/deploy/test/11/deploy.factor b/basis/tools/deploy/test/11/deploy.factor
index 42f707b332..4828f70d90 100644
--- a/basis/tools/deploy/test/11/deploy.factor
+++ b/basis/tools/deploy/test/11/deploy.factor
@@ -9,7 +9,6 @@ H{
     { deploy-math? f }
     { deploy-unicode? f }
     { deploy-threads? f }
-    { deploy-compiler? f }
     { deploy-io 2 }
     { deploy-ui? f }
 }
diff --git a/basis/tools/deploy/test/12/deploy.factor b/basis/tools/deploy/test/12/deploy.factor
index 638e1ca000..a3aaa3bca2 100644
--- a/basis/tools/deploy/test/12/deploy.factor
+++ b/basis/tools/deploy/test/12/deploy.factor
@@ -9,7 +9,6 @@ H{
     { deploy-io 2 }
     { deploy-ui? f }
     { deploy-name "tools.deploy.test.12" }
-    { deploy-compiler? f }
     { deploy-word-defs? f }
     { deploy-threads? f }
 }
diff --git a/basis/tools/deploy/test/13/deploy.factor b/basis/tools/deploy/test/13/deploy.factor
index 9513192311..d175075c14 100644
--- a/basis/tools/deploy/test/13/deploy.factor
+++ b/basis/tools/deploy/test/13/deploy.factor
@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-threads? t }
-    { deploy-compiler? t }
     { deploy-math? t }
     { deploy-io 2 }
     { "stop-after-last-window?" t }
diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor
index 1457769ce1..10cd7a85d9 100644
--- a/basis/tools/deploy/test/2/deploy.factor
+++ b/basis/tools/deploy/test/2/deploy.factor
@@ -8,7 +8,6 @@ H{
     { deploy-math? t }
     { deploy-io 2 }
     { deploy-name "tools.deploy.test.2" }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
 }
diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor
index f3131237bf..b72b00d1e4 100644
--- a/basis/tools/deploy/test/3/deploy.factor
+++ b/basis/tools/deploy/test/3/deploy.factor
@@ -6,7 +6,6 @@ H{
     { "stop-after-last-window?" t }
     { deploy-word-defs? f }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-threads? t }
     { deploy-io 3 }
     { deploy-math? t }
diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor
index 981bbcf982..b2f22055c4 100644
--- a/basis/tools/deploy/test/4/deploy.factor
+++ b/basis/tools/deploy/test/4/deploy.factor
@@ -8,7 +8,6 @@ H{
     { deploy-math? t }
     { deploy-io 2 }
     { deploy-name "tools.deploy.test.4" }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
 }
diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor
index 22f5021497..3f9b7f1599 100644
--- a/basis/tools/deploy/test/5/deploy.factor
+++ b/basis/tools/deploy/test/5/deploy.factor
@@ -8,7 +8,6 @@ H{
     { deploy-math? t }
     { deploy-io 3 }
     { deploy-name "tools.deploy.test.5" }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
 }
diff --git a/basis/tools/deploy/test/6/deploy.factor b/basis/tools/deploy/test/6/deploy.factor
index c474fcdadf..b86bfdb31a 100644
--- a/basis/tools/deploy/test/6/deploy.factor
+++ b/basis/tools/deploy/test/6/deploy.factor
@@ -5,7 +5,6 @@ H{
     { deploy-io 1 }
     { deploy-name "tools.deploy.test.6" }
     { deploy-math? t }
-    { deploy-compiler? t }
     { deploy-ui? f }
     { deploy-c-types? f }
     { deploy-word-defs? f }
diff --git a/basis/tools/deploy/test/7/deploy.factor b/basis/tools/deploy/test/7/deploy.factor
index bc374f1088..d1e93fc7c2 100644
--- a/basis/tools/deploy/test/7/deploy.factor
+++ b/basis/tools/deploy/test/7/deploy.factor
@@ -6,7 +6,6 @@ H{
     { deploy-io 2 }
     { deploy-math? t }
     { "stop-after-last-window?" t }
-    { deploy-compiler? t }
     { deploy-unicode? f }
     { deploy-c-types? f }
     { deploy-reflection 1 }
diff --git a/basis/tools/deploy/test/8/8.factor b/basis/tools/deploy/test/8/8.factor
deleted file mode 100644
index c495928bf2..0000000000
--- a/basis/tools/deploy/test/8/8.factor
+++ /dev/null
@@ -1,11 +0,0 @@
-USING: kernel ;
-IN: tools.deploy.test.8
-
-: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
-: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
-
-: literal-merge-test ( -- )
-    literal-merge-test-1
-    literal-merge-test-2 eq? t assert= ;
-
-MAIN: literal-merge-test
diff --git a/basis/tools/deploy/test/8/deploy.factor b/basis/tools/deploy/test/8/deploy.factor
deleted file mode 100644
index 3bea1edfc7..0000000000
--- a/basis/tools/deploy/test/8/deploy.factor
+++ /dev/null
@@ -1,15 +0,0 @@
-USING: tools.deploy.config ;
-H{
-    { deploy-name "tools.deploy.test.8" }
-    { deploy-c-types? f }
-    { deploy-word-props? f }
-    { deploy-ui? f }
-    { deploy-reflection 1 }
-    { deploy-compiler? f }
-    { deploy-unicode? f }
-    { deploy-io 1 }
-    { deploy-word-defs? f }
-    { deploy-threads? f }
-    { "stop-after-last-window?" t }
-    { deploy-math? f }
-}
diff --git a/basis/tools/deploy/test/9/deploy.factor b/basis/tools/deploy/test/9/deploy.factor
index 91b1da5697..caddbe36d0 100644
--- a/basis/tools/deploy/test/9/deploy.factor
+++ b/basis/tools/deploy/test/9/deploy.factor
@@ -6,7 +6,6 @@ H{
     { "stop-after-last-window?" t }
     { deploy-word-defs? f }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-threads? f }
     { deploy-io 1 }
     { deploy-math? t }
diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor
index 6a8322ac02..d3c1278bf5 100644
--- a/basis/ui/tools/deploy/deploy.factor
+++ b/basis/ui/tools/deploy/deploy.factor
@@ -29,7 +29,6 @@ TUPLE: deploy-gadget < pack vocab settings ;
 
 : advanced-settings ( parent -- parent )
     "Advanced:" <label> add-gadget
-    deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
     deploy-math? get "Rational and complex number support" <checkbox> add-gadget
     deploy-threads? get "Threading support" <checkbox> add-gadget
     deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget
diff --git a/extra/4DNav/deploy.factor b/extra/4DNav/deploy.factor
index e39f91acf6..44481f49f9 100755
--- a/extra/4DNav/deploy.factor
+++ b/extra/4DNav/deploy.factor
@@ -7,7 +7,6 @@ H{
     { deploy-math? t }
     { deploy-threads? t }
     { deploy-reflection 3 }
-    { deploy-compiler? t }
     { deploy-unicode? t }
     { deploy-io 3 }
     { "stop-after-last-window?" t }
diff --git a/extra/benchmark/fib6/deploy.factor b/extra/benchmark/fib6/deploy.factor
index 3a367dcd51..92adf90802 100644
--- a/extra/benchmark/fib6/deploy.factor
+++ b/extra/benchmark/fib6/deploy.factor
@@ -6,7 +6,6 @@ H{
     { deploy-word-props? f }
     { deploy-ui? f }
     { deploy-io 1 }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
     { deploy-unicode? f }
diff --git a/extra/benchmark/regex-dna/deploy.factor b/extra/benchmark/regex-dna/deploy.factor
index 91edab430e..5f9fddf1a8 100644
--- a/extra/benchmark/regex-dna/deploy.factor
+++ b/extra/benchmark/regex-dna/deploy.factor
@@ -3,7 +3,6 @@ H{
     { deploy-word-defs? f }
     { deploy-word-props? f }
     { deploy-math? f }
-    { deploy-compiler? t }
     { deploy-ui? f }
     { deploy-c-types? f }
     { "stop-after-last-window?" t }
diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor
index 0954c9ad41..7cf6a3ecba 100755
--- a/extra/bunny/deploy.factor
+++ b/extra/bunny/deploy.factor
@@ -3,7 +3,6 @@ H{
     { deploy-io 3 }
     { deploy-word-defs? f }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-c-types? f }
     { deploy-name "Bunny" }
     { deploy-word-props? f }
diff --git a/extra/chicago-talk/deploy.factor b/extra/chicago-talk/deploy.factor
index 8f8adc18d8..0ef2551851 100755
--- a/extra/chicago-talk/deploy.factor
+++ b/extra/chicago-talk/deploy.factor
@@ -3,7 +3,6 @@ V{
     { deploy-ui? t }
     { deploy-io 1 }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-math? t }
     { deploy-word-props? f }
     { deploy-c-types? f }
diff --git a/extra/color-picker/deploy.factor b/extra/color-picker/deploy.factor
index eeeb63dd7d..1c24d9eacb 100755
--- a/extra/color-picker/deploy.factor
+++ b/extra/color-picker/deploy.factor
@@ -7,7 +7,6 @@ H{
     { deploy-unicode? f }
     { deploy-c-types? f }
     { deploy-word-defs? f }
-    { deploy-compiler? t }
     { deploy-io 2 }
     { deploy-reflection 1 }
     { "stop-after-last-window?" t }
diff --git a/extra/drills/deployed/deploy.factor b/extra/drills/deployed/deploy.factor
index 2f62912360..eaa0d3bb69 100644
--- a/extra/drills/deployed/deploy.factor
+++ b/extra/drills/deployed/deploy.factor
@@ -5,7 +5,6 @@ H{
     { deploy-math? t }
     { deploy-name "drills" }
     { deploy-ui? t }
-    { deploy-compiler? t }
     { "stop-after-last-window?" t }
     { deploy-word-props? f }
     { deploy-c-types? f }
diff --git a/extra/gesture-logger/deploy.factor b/extra/gesture-logger/deploy.factor
index 0692feb30d..124e2f0437 100755
--- a/extra/gesture-logger/deploy.factor
+++ b/extra/gesture-logger/deploy.factor
@@ -3,7 +3,6 @@ V{
     { deploy-ui? t }
     { deploy-io 1 }
     { deploy-reflection 3 }
-    { deploy-compiler? t }
     { deploy-math? t }
     { deploy-word-props? f }
     { deploy-c-types? f }
diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor
index 28ce8f519d..7fcc167cea 100644
--- a/extra/hello-ui/deploy.factor
+++ b/extra/hello-ui/deploy.factor
@@ -1,14 +1,14 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-threads? t }
-    { deploy-math? t }
-    { deploy-name "Hello world" }
-    { deploy-c-types? f }
-    { deploy-word-props? f }
-    { deploy-io 2 }
     { deploy-ui? t }
-    { "stop-after-last-window?" t }
-    { deploy-word-defs? f }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-c-types? f }
+    { deploy-name "Hello world" }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { "stop-after-last-window?" t }
+    { deploy-threads? t }
 }
diff --git a/extra/hello-unicode/deploy.factor b/extra/hello-unicode/deploy.factor
index f2f1c9fb18..106817aa50 100644
--- a/extra/hello-unicode/deploy.factor
+++ b/extra/hello-unicode/deploy.factor
@@ -3,7 +3,6 @@ H{
     { deploy-word-defs? f }
     { deploy-reflection 1 }
     { deploy-word-props? f }
-    { deploy-compiler? t }
     { deploy-threads? t }
     { deploy-unicode? f }
     { "stop-after-last-window?" t }
diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor
index aadffb6ae8..0852188761 100755
--- a/extra/hello-world/deploy.factor
+++ b/extra/hello-world/deploy.factor
@@ -2,7 +2,6 @@ USING: tools.deploy.config ;
 H{
     { deploy-unicode? f }
     { deploy-ui? f }
-    { deploy-compiler? t }
     { deploy-name "Hello world (console)" }
     { deploy-io 2 }
     { deploy-threads? f }
diff --git a/extra/jamshred/deploy.factor b/extra/jamshred/deploy.factor
index 9a18cf1f9b..867fb8d626 100644
--- a/extra/jamshred/deploy.factor
+++ b/extra/jamshred/deploy.factor
@@ -3,7 +3,6 @@ V{
     { deploy-ui? t }
     { deploy-io 1 }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-math? t }
     { deploy-word-props? f }
     { deploy-c-types? f }
diff --git a/extra/joystick-demo/deploy.factor b/extra/joystick-demo/deploy.factor
index 8f25662f9e..8ef5231362 100644
--- a/extra/joystick-demo/deploy.factor
+++ b/extra/joystick-demo/deploy.factor
@@ -10,5 +10,4 @@ H{
     { deploy-math? t }
     { "stop-after-last-window?" t }
     { deploy-ui? t }
-    { deploy-compiler? t }
 }
diff --git a/extra/maze/deploy.factor b/extra/maze/deploy.factor
index 1eda315617..9f5795d55a 100755
--- a/extra/maze/deploy.factor
+++ b/extra/maze/deploy.factor
@@ -1,14 +1,14 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-threads? t }
-    { deploy-math? t }
-    { deploy-name "Maze" }
-    { deploy-c-types? f }
-    { deploy-word-props? f }
-    { deploy-io 2 }
     { deploy-ui? t }
-    { "stop-after-last-window?" t }
-    { deploy-word-defs? f }
-    { deploy-compiler? t }
     { deploy-reflection 1 }
+    { deploy-unicode? f }
+    { deploy-math? t }
+    { deploy-io 2 }
+    { deploy-c-types? f }
+    { deploy-name "Maze" }
+    { deploy-word-props? f }
+    { deploy-word-defs? f }
+    { "stop-after-last-window?" t }
+    { deploy-threads? t }
 }
diff --git a/extra/merger/deploy.factor b/extra/merger/deploy.factor
index 54535d5bc8..adaab737c3 100644
--- a/extra/merger/deploy.factor
+++ b/extra/merger/deploy.factor
@@ -7,7 +7,6 @@ H{
     { "stop-after-last-window?" t }
     { deploy-ui? t }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-name "Merger" }
     { deploy-word-props? f }
     { deploy-threads? t }
diff --git a/extra/minneapolis-talk/deploy.factor b/extra/minneapolis-talk/deploy.factor
index 32b78a2c13..c74ff30487 100755
--- a/extra/minneapolis-talk/deploy.factor
+++ b/extra/minneapolis-talk/deploy.factor
@@ -3,7 +3,6 @@ V{
     { deploy-ui? t }
     { deploy-io 1 }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-math? t }
     { deploy-word-props? f }
     { deploy-c-types? f }
diff --git a/extra/nehe/deploy.factor b/extra/nehe/deploy.factor
index 6cf9543678..2d6bdec8a8 100755
--- a/extra/nehe/deploy.factor
+++ b/extra/nehe/deploy.factor
@@ -3,7 +3,6 @@ V{
     { deploy-ui? t }
     { deploy-io 1 }
     { deploy-reflection 1 }
-    { deploy-compiler? t }
     { deploy-math? t }
     { deploy-word-props? f }
     { deploy-c-types? f }
diff --git a/extra/spheres/deploy.factor b/extra/spheres/deploy.factor
index 22c5de0963..df314317cf 100644
--- a/extra/spheres/deploy.factor
+++ b/extra/spheres/deploy.factor
@@ -10,6 +10,5 @@ H{
     { deploy-word-props? f }
     { deploy-word-defs? f }
     { "stop-after-last-window?" t }
-    { deploy-compiler? t }
     { deploy-threads? t }
 }
diff --git a/extra/sudoku/deploy.factor b/extra/sudoku/deploy.factor
index 92c4395dec..c873600134 100755
--- a/extra/sudoku/deploy.factor
+++ b/extra/sudoku/deploy.factor
@@ -3,7 +3,6 @@ H{
     { deploy-word-defs? f }
     { deploy-name "Sudoku" }
     { deploy-threads? f }
-    { deploy-compiler? t }
     { deploy-math? t }
     { deploy-c-types? f }
     { deploy-io 2 }
diff --git a/extra/terrain/deploy.factor b/extra/terrain/deploy.factor
index e51f8d13e6..b51873a5ad 100644
--- a/extra/terrain/deploy.factor
+++ b/extra/terrain/deploy.factor
@@ -10,6 +10,5 @@ H{
     { deploy-word-props? f }
     { deploy-word-defs? f }
     { "stop-after-last-window?" t }
-    { deploy-compiler? t }
     { deploy-threads? t }
 }
diff --git a/extra/tetris/deploy.factor b/extra/tetris/deploy.factor
index 03ec5d4e64..a2d71ab08b 100755
--- a/extra/tetris/deploy.factor
+++ b/extra/tetris/deploy.factor
@@ -1,7 +1,6 @@
 USING: tools.deploy.config ;
 H{
     { deploy-ui? t }
-    { deploy-compiler? t }
     { deploy-threads? t }
     { deploy-word-props? f }
     { deploy-reflection 1 }
diff --git a/extra/webkit-demo/deploy.factor b/extra/webkit-demo/deploy.factor
index 322212c4fc..fb32044664 100644
--- a/extra/webkit-demo/deploy.factor
+++ b/extra/webkit-demo/deploy.factor
@@ -4,7 +4,6 @@ H{
     { deploy-threads? f }
     { deploy-word-defs? f }
     { deploy-ui? f }
-    { deploy-compiler? t }
     { deploy-word-props? f }
     { "stop-after-last-window?" t }
     { deploy-unicode? f }

From 838d1fad576996534218b9d865f74b355f070423 Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Mon, 11 May 2009 15:37:47 +0200
Subject: [PATCH 67/68] fixed serialization of factor words/quotations

---
 extra/bson/reader/reader.factor |  9 +++------
 extra/bson/writer/writer.factor | 26 +++++++++++---------------
 2 files changed, 14 insertions(+), 21 deletions(-)

diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor
index 96cde41c2b..9f1d8c31d2 100644
--- a/extra/bson/reader/reader.factor
+++ b/extra/bson/reader/reader.factor
@@ -181,19 +181,16 @@ M: bson-oid element-data-read ( type -- oid )
     read-longlong
     read-int32 oid boa ;
 
-M: bson-binary-custom element-binary-read ( size type -- dbref )
-    2drop
-    read-cstring
-    read-cstring objref boa ;
-
 M: bson-binary-bytes element-binary-read ( size type -- bytes )
     drop read ;
 
-M: bson-binary-function element-binary-read ( size type -- quot )
+M: bson-binary-custom element-binary-read ( size type -- quot )
     drop read bytes>object ;
 
 PRIVATE>
 
+USE: tools.continuations
+
 : stream>assoc ( exemplar -- assoc bytes-read )
     <state> dup state
     [ read-int32 >>size read-elements ] with-variable 
diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor
index 1b9d45b124..682257558f 100644
--- a/extra/bson/writer/writer.factor
+++ b/extra/bson/writer/writer.factor
@@ -62,7 +62,6 @@ M: t bson-type? ( boolean -- type ) drop T_Boolean ;
 M: f bson-type? ( boolean -- type ) drop T_Boolean ; 
 
 M: real bson-type? ( real -- type ) drop T_Double ; 
-M: word bson-type? ( word -- type ) drop T_String ; 
 M: tuple bson-type? ( tuple -- type ) drop T_Object ;  
 M: sequence bson-type? ( seq -- type ) drop T_Array ;
 M: string bson-type? ( string -- type ) drop T_String ; 
@@ -73,6 +72,7 @@ M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
 
 M: oid bson-type? ( word -- type ) drop T_OID ;
 M: objref bson-type? ( objref -- type ) drop T_Binary ;
+M: word bson-type? ( word -- type ) drop T_Binary ;
 M: quotation bson-type? ( quotation -- type ) drop T_Binary ; 
 M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; 
 
@@ -112,21 +112,8 @@ M: byte-array bson-write ( binary -- )
     T_Binary_Bytes write-byte
     write ; 
 
-M: quotation bson-write ( quotation -- )
-    object>bytes [ length write-int32 ] keep
-    T_Binary_Function write-byte
-    write ; 
-
 M: oid bson-write ( oid -- )
     [ a>> write-longlong ] [ b>> write-int32 ] bi ;
-
-M: objref bson-write ( objref -- )
-    [ binary ] dip
-    '[ _
-       [ ns>> write-cstring ]
-       [ objid>> write-cstring ] bi ] with-byte-writer
-    [ length write-int32 ] keep
-    T_Binary_Custom write-byte write ;
        
 M: mdbregexp bson-write ( regexp -- )
    [ regexp>> write-cstring ]
@@ -149,7 +136,16 @@ M: assoc bson-write ( assoc -- )
        [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
        write-eoo ] with-length-prefix ; 
 
-M: word bson-write name>> bson-write ;
+: (serialize-code) ( code -- )
+    object>bytes [ length write-int32 ] keep
+    T_Binary_Custom write-byte
+    write ;
+
+M: quotation bson-write ( quotation -- )
+    (serialize-code) ;
+    
+M: word bson-write ( word -- )
+    (serialize-code) ;
 
 PRIVATE>
 

From 0c3f7bf2d7833d13aa0ebafcf44c7b90c45aac58 Mon Sep 17 00:00:00 2001
From: Sascha Matzke <sascha.matzke@didolo.org>
Date: Mon, 11 May 2009 15:38:12 +0200
Subject: [PATCH 68/68] fixed update-tuple - called wrong constructor for
 update

---
 extra/mongodb/tuple/tuple.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor
index 1b4b3cd4f1..677fa09bf9 100644
--- a/extra/mongodb/tuple/tuple.factor
+++ b/extra/mongodb/tuple/tuple.factor
@@ -61,7 +61,7 @@ PRIVATE>
     [ tuple-collection name>> ]
     [ id-selector ]
     [ tuple>assoc ] tri
-    <mdb-update-msg> update ;
+    <update> update ;
 
 : save-tuple ( tuple -- )
     update-tuple ;