From 68d7137a16dbf3ee2f9543582e771d67cb06b1a0 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 24 Apr 2009 02:16:05 -0400
Subject: [PATCH 01/72] Fix minor inconsistency in reference to var name
---
extra/benchmark/pidigits/pidigits.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor
index 5de5cc5e99..0f8a98e6f9 100644
--- a/extra/benchmark/pidigits/pidigits.factor
+++ b/extra/benchmark/pidigits/pidigits.factor
@@ -18,7 +18,7 @@ IN: benchmark.pidigits
: >matrix ( q s r t -- z )
4array 2 group ;
-: produce ( z n -- z' )
+: produce ( z y -- z' )
[ 10 ] dip -10 * 0 1 >matrix swap m. ;
: gen-x ( x -- matrix )
From 9981f6534fd7a9d80abcbdeae45c43438adf2165 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 1 May 2009 20:46:25 -0400
Subject: [PATCH 02/72] Use iota in Project Euler solutions
---
extra/project-euler/001/001.factor | 6 +++---
extra/project-euler/005/005.factor | 6 +++---
extra/project-euler/030/030.factor | 2 +-
extra/project-euler/048/048.factor | 4 ++--
extra/project-euler/055/055.factor | 2 +-
extra/project-euler/057/057.factor | 16 ++++++++--------
6 files changed, 18 insertions(+), 18 deletions(-)
diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor
index 0d4f5fb1bd..e4c8a20cb3 100644
--- a/extra/project-euler/001/001.factor
+++ b/extra/project-euler/001/001.factor
@@ -1,4 +1,4 @@
-! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
+! Copyright (c) 2007-2009 Aaron Schaefer, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.ranges project-euler.common sequences
sets ;
@@ -47,14 +47,14 @@ PRIVATE>
: euler001b ( -- answer )
- 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
+ 1000 iota [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
: euler001c ( -- answer )
- 1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+ 1000 iota [ { 3 5 } [ divisor? ] with any? ] filter sum ;
! [ euler001c ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
diff --git a/extra/project-euler/005/005.factor b/extra/project-euler/005/005.factor
index 7fef29a6b9..8512bc97fa 100644
--- a/extra/project-euler/005/005.factor
+++ b/extra/project-euler/005/005.factor
@@ -1,6 +1,6 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2009 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: math math.functions sequences project-euler.common ;
+USING: math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.005
! http://projecteuler.net/index.php?section=problems&id=5
@@ -18,7 +18,7 @@ IN: project-euler.005
! --------
: euler005 ( -- answer )
- 20 1 [ 1+ lcm ] reduce ;
+ 20 [1,b] 1 [ lcm ] reduce ;
! [ euler005 ] 100 ave-time
! 0 ms ave run time - 0.14 SD (100 trials)
diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor
index 54d48660d5..7c8334cfd4 100644
--- a/extra/project-euler/030/030.factor
+++ b/extra/project-euler/030/030.factor
@@ -38,7 +38,7 @@ IN: project-euler.030
PRIVATE>
: euler030 ( -- answer )
- 325537 [ dup sum-fifth-powers = ] filter sum 1- ;
+ 325537 iota [ dup sum-fifth-powers = ] filter sum 1- ;
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)
diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor
index e56b9e9548..640a3a68f6 100644
--- a/extra/project-euler/048/048.factor
+++ b/extra/project-euler/048/048.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions sequences project-euler.common ;
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.048
! http://projecteuler.net/index.php?section=problems&id=48
@@ -17,7 +17,7 @@ IN: project-euler.048
! --------
: euler048 ( -- answer )
- 1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ;
+ 1000 [1,b] [ dup ^ ] sigma 10 10 ^ mod ;
! [ euler048 ] 100 ave-time
! 276 ms run / 1 ms GC ave time - 100 trials
diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor
index 43f380b3ba..6154e29717 100644
--- a/extra/project-euler/055/055.factor
+++ b/extra/project-euler/055/055.factor
@@ -61,7 +61,7 @@ IN: project-euler.055
PRIVATE>
: euler055 ( -- answer )
- 10000 [ lychrel? ] count ;
+ 10000 iota [ lychrel? ] count ;
! [ euler055 ] 100 ave-time
! 478 ms ave run time - 30.63 SD (100 trials)
diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor
index 681a17dd9e..0c434f4506 100644
--- a/extra/project-euler/057/057.factor
+++ b/extra/project-euler/057/057.factor
@@ -11,14 +11,14 @@ IN: project-euler.057
! It is possible to show that the square root of two can be expressed
! as an infinite continued fraction.
-! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
+! √ 2 = 1 + 1/(2 + 1/(2 + 1/(2 + ... ))) = 1.414213...
! By expanding this for the first four iterations, we get:
-! 1 + 1/2 = 3/2 = 1.5
-! 1 + 1/(2 + 1/2) = 7/5 = 1.4
-! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
-! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
+! 1 + 1/2 = 3/2 = 1.5
+! 1 + 1/(2 + 1/2) = 7/5 = 1.4
+! 1 + 1/(2 + 1/(2 + 1/2)) = 17/12 = 1.41666...
+! 1 + 1/(2 + 1/(2 + 1/(2 + 1/2))) = 41/29 = 1.41379...
! The next three expansions are 99/70, 239/169, and 577/408, but the
! eighth expansion, 1393/985, is the first example where the number of
@@ -35,9 +35,9 @@ IN: project-euler.057
>fraction [ number>string length ] bi@ > ; inline
: euler057 ( -- answer )
- 0 1000 [ drop 2 + recip dup 1+ longer-numerator? ] count nip ;
+ 0 1000 iota [ drop 2 + recip dup 1+ longer-numerator? ] count nip ;
-! [ euler057 ] time
-! 3.375118 seconds
+! [ euler057 ] 100 ave-time
+! 1728 ms ave run time - 80.81 SD (100 trials)
SOLUTION: euler057
From e59e051c749201d85d754966b10aa2dd65cb636e Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 1 May 2009 22:26:49 -0400
Subject: [PATCH 03/72] Use [0,b) and iota where appropriate
---
extra/project-euler/001/001.factor | 4 ++--
extra/project-euler/018/018.factor | 4 ++--
extra/project-euler/027/027.factor | 5 ++---
extra/project-euler/030/030.factor | 4 ++--
extra/project-euler/032/032.factor | 2 +-
extra/project-euler/055/055.factor | 4 ++--
extra/project-euler/057/057.factor | 5 +++--
extra/project-euler/150/150.factor | 7 ++++---
8 files changed, 18 insertions(+), 17 deletions(-)
diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor
index e4c8a20cb3..204527418b 100644
--- a/extra/project-euler/001/001.factor
+++ b/extra/project-euler/001/001.factor
@@ -47,14 +47,14 @@ PRIVATE>
: euler001b ( -- answer )
- 1000 iota [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
+ 1000 [0,b) [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ;
! [ euler001b ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
: euler001c ( -- answer )
- 1000 iota [ { 3 5 } [ divisor? ] with any? ] filter sum ;
+ 1000 [0,b) [ { 3 5 } [ divisor? ] with any? ] filter sum ;
! [ euler001c ] 100 ave-time
! 0 ms ave run time - 0.06 SD (100 trials)
diff --git a/extra/project-euler/018/018.factor b/extra/project-euler/018/018.factor
index 9c7c4fee74..9189323121 100644
--- a/extra/project-euler/018/018.factor
+++ b/extra/project-euler/018/018.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2007 Samuel Tardieu, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math project-euler.common sequences ;
+USING: kernel math math.ranges project-euler.common sequences ;
IN: project-euler.018
! http://projecteuler.net/index.php?section=problems&id=18
@@ -66,7 +66,7 @@ IN: project-euler.018
91 71 52 38 17 14 91 43 58 50 27 29 48
63 66 04 68 89 53 67 30 73 16 69 87 40 31
04 62 98 27 23 09 70 98 73 93 38 53 60 04 23
- } 15 iota [ 1+ cut swap ] map nip ;
+ } 15 [1,b] [ cut swap ] map nip ;
PRIVATE>
diff --git a/extra/project-euler/027/027.factor b/extra/project-euler/027/027.factor
index 4bcfb66a94..f7bffbf665 100644
--- a/extra/project-euler/027/027.factor
+++ b/extra/project-euler/027/027.factor
@@ -1,7 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.primes project-euler.common sequences
-project-euler.common ;
+USING: kernel math math.primes math.ranges project-euler.common sequences ;
IN: project-euler.027
! http://projecteuler.net/index.php?section=problems&id=27
@@ -47,7 +46,7 @@ IN: project-euler.027
<PRIVATE
: source-027 ( -- seq )
- 1000 [ prime? ] filter [ dup [ neg ] map append ] keep
+ 1000 [0,b) [ prime? ] filter [ dup [ neg ] map append ] keep
cartesian-product [ first2 < ] filter ;
: quadratic ( b a n -- m )
diff --git a/extra/project-euler/030/030.factor b/extra/project-euler/030/030.factor
index 7c8334cfd4..2a75336a0d 100644
--- a/extra/project-euler/030/030.factor
+++ b/extra/project-euler/030/030.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions project-euler.common sequences ;
+USING: kernel math math.functions math.ranges project-euler.common sequences ;
IN: project-euler.030
! http://projecteuler.net/index.php?section=problems&id=30
@@ -38,7 +38,7 @@ IN: project-euler.030
PRIVATE>
: euler030 ( -- answer )
- 325537 iota [ dup sum-fifth-powers = ] filter sum 1- ;
+ 325537 [0,b) [ dup sum-fifth-powers = ] filter sum 1- ;
! [ euler030 ] 100 ave-time
! 1700 ms ave run time - 64.84 SD (100 trials)
diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor
index 64c9ec445e..814f8a5a63 100755
--- a/extra/project-euler/032/032.factor
+++ b/extra/project-euler/032/032.factor
@@ -28,7 +28,7 @@ IN: project-euler.032
: source-032 ( -- seq )
9 factorial iota [
- 9 permutation [ 1+ ] map 10 digits>integer
+ 9 permutation [ 1 + ] map 10 digits>integer
] map ;
: 1and4 ( n -- ? )
diff --git a/extra/project-euler/055/055.factor b/extra/project-euler/055/055.factor
index 6154e29717..07525fe6a4 100644
--- a/extra/project-euler/055/055.factor
+++ b/extra/project-euler/055/055.factor
@@ -1,6 +1,6 @@
! Copyright (c) 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser project-euler.common sequences ;
+USING: kernel math math.parser math.ranges project-euler.common sequences ;
IN: project-euler.055
! http://projecteuler.net/index.php?section=problems&id=55
@@ -61,7 +61,7 @@ IN: project-euler.055
PRIVATE>
: euler055 ( -- answer )
- 10000 iota [ lychrel? ] count ;
+ 10000 [0,b) [ lychrel? ] count ;
! [ euler055 ] 100 ave-time
! 478 ms ave run time - 30.63 SD (100 trials)
diff --git a/extra/project-euler/057/057.factor b/extra/project-euler/057/057.factor
index 0c434f4506..97789944fe 100644
--- a/extra/project-euler/057/057.factor
+++ b/extra/project-euler/057/057.factor
@@ -1,6 +1,7 @@
! Copyright (c) 2008 Samuel Tardieu
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.parser sequences project-euler.common ;
+USING: kernel math math.functions math.parser math.ranges project-euler.common
+ sequences ;
IN: project-euler.057
! http://projecteuler.net/index.php?section=problems&id=57
@@ -35,7 +36,7 @@ IN: project-euler.057
>fraction [ number>string length ] bi@ > ; inline
: euler057 ( -- answer )
- 0 1000 iota [ drop 2 + recip dup 1+ longer-numerator? ] count nip ;
+ 0 1000 [0,b) [ drop 2 + recip dup 1 + longer-numerator? ] count nip ;
! [ euler057 ] 100 ave-time
! 1728 ms ave run time - 80.81 SD (100 trials)
diff --git a/extra/project-euler/150/150.factor b/extra/project-euler/150/150.factor
index 314698534f..eeb4b0c315 100644
--- a/extra/project-euler/150/150.factor
+++ b/extra/project-euler/150/150.factor
@@ -1,6 +1,7 @@
! Copyright (c) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
-USING: hints kernel locals math math.order sequences sequences.private project-euler.common ;
+USING: hints kernel locals math math.order math.ranges project-euler.common
+ sequences sequences.private ;
IN: project-euler.150
! http://projecteuler.net/index.php?section=problems&id=150
@@ -50,13 +51,13 @@ IN: project-euler.150
615949 * 797807 + 20 2^ rem dup 19 2^ - ; inline
: sums-triangle ( -- seq )
- 0 1000 iota [ 1+ [ next ] replicate partial-sums ] map nip ;
+ 0 1000 [1,b] [ [ next ] replicate partial-sums ] map nip ;
:: (euler150) ( m -- n )
[let | table [ sums-triangle ] |
m [| x |
x 1+ [| y |
- m x - iota [| z |
+ m x - [0,b) [| z |
x z + table nth-unsafe
[ y z + 1+ swap nth-unsafe ]
[ y swap nth-unsafe ] bi -
From 17fa5ac5f1c20b1503f43bef37347311787e8b85 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sat, 2 May 2009 02:06:52 -0400
Subject: [PATCH 04/72] Add deck generation and shuffling to poker vocab
---
extra/poker/poker-tests.factor | 2 +-
extra/poker/poker.factor | 31 ++++++++++++++++++++++---------
2 files changed, 23 insertions(+), 10 deletions(-)
diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor
index ad371a6bff..e2d89620e6 100644
--- a/extra/poker/poker-tests.factor
+++ b/extra/poker/poker-tests.factor
@@ -1,4 +1,4 @@
-USING: accessors poker poker.private tools.test math.order kernel ;
+USING: accessors kernel math.order poker poker.private tools.test ;
IN: poker.tests
[ 134236965 ] [ "KD" >ckf ] unit-test
diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor
index e8e9fa23c5..15e9a96d42 100644
--- a/extra/poker/poker.factor
+++ b/extra/poker/poker.factor
@@ -1,7 +1,9 @@
-! Copyright (c) 2009 Aaron Schaefer.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors ascii binary-search combinators kernel locals math
- math.bitwise math.order poker.arrays sequences splitting ;
+! Copyright (c) 2009 Aaron Schaefer. All rights reserved.
+! The contents of this file are licensed under the Simplified BSD License
+! A copy of the license is available at http://factorcode.org/license.txt
+USING: accessors arrays ascii binary-search combinators kernel locals math
+ math.bitwise math.order poker.arrays random sequences sequences.product
+ splitting ;
IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
@@ -57,6 +59,8 @@ CONSTANT: TWO_PAIR 7
CONSTANT: ONE_PAIR 8
CONSTANT: HIGH_CARD 9
+CONSTANT: SUIT_STR { "C" "D" "H" "S" }
+
CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
@@ -108,6 +112,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
#! Cactus Kev Format
>upper 1 cut (>ckf) ;
+: parse-cards ( str -- seq )
+ " " split [ >ckf ] map ;
+
: flush? ( cards -- ? )
HEX: F000 [ bitand ] reduce 0 = not ;
@@ -165,6 +172,9 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
[ drop STRAIGHT_FLUSH ] ! 10 straight-flushes
} cond ;
+: card>string ( card -- str )
+ [ >card-rank ] [ >card-suit ] bi append ;
+
PRIVATE>
TUPLE: hand
@@ -176,13 +186,16 @@ M: hand equal?
over hand? [ [ value>> ] bi@ = ] [ 2drop f ] if ;
: <hand> ( str -- hand )
- " " split [ >ckf ] map
- dup hand-value hand boa ;
+ parse-cards dup hand-value hand boa ;
: >cards ( hand -- str )
- cards>> [
- [ >card-rank ] [ >card-suit ] bi append
- ] map " " join ;
+ cards>> [ card>string ] map " " join ;
: >value ( hand -- str )
hand-rank VALUE_STR nth ;
+
+: <deck> ( -- deck )
+ RANK_STR SUIT_STR 2array [ concat >ckf ] product-map ;
+
+ALIAS: shuffle randomize
+
From 71022f9940e6e047e8574a972fc98bb030405df0 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Tue, 5 May 2009 22:43:07 -0400
Subject: [PATCH 05/72] Add combination support to math.combinatorics
---
basis/math/combinatorics/combinatorics.factor | 72 ++++++++++++++-----
1 file changed, 56 insertions(+), 16 deletions(-)
diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor
index afdf4e378e..0ca306b68c 100644
--- a/basis/math/combinatorics/combinatorics.factor
+++ b/basis/math/combinatorics/combinatorics.factor
@@ -1,7 +1,7 @@
-! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
+! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel math math.order math.ranges mirrors
-namespaces sequences sorting fry ;
+USING: accessors assocs fry kernel locals math math.order math.ranges mirrors
+ namespaces sequences sorting ;
IN: math.combinatorics
<PRIVATE
@@ -12,14 +12,27 @@ IN: math.combinatorics
: twiddle ( n k -- n k )
2dup - dupd > [ dupd - ] when ; inline
-! See this article for explanation of the factoradic-based permutation methodology:
-! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
+PRIVATE>
+
+: factorial ( n -- n! )
+ 1 [ 1 + * ] reduce ;
+
+: nPk ( n k -- nPk )
+ 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
+
+: nCk ( n k -- nCk )
+ twiddle [ nPk ] keep factorial / ;
+
+
+! Factoradic-based permutation methodology
+
+<PRIVATE
: factoradic ( n -- factoradic )
- 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ;
+ 0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ;
: (>permutation) ( seq n -- seq )
- [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
+ [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ;
: >permutation ( factoradic -- permutation )
reverse 1 cut [ (>permutation) ] each ;
@@ -29,15 +42,6 @@ IN: math.combinatorics
PRIVATE>
-: factorial ( n -- n! )
- 1 [ 1+ * ] reduce ;
-
-: nPk ( n k -- nPk )
- 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
-
-: nCk ( n k -- nCk )
- twiddle [ nPk ] keep factorial / ;
-
: permutation ( n seq -- seq )
[ permutation-indices ] keep nths ;
@@ -53,3 +57,39 @@ PRIVATE>
: inverse-permutation ( seq -- permutation )
<enum> >alist sort-values keys ;
+
+
+! Combinadic-based combination methodology
+
+TUPLE: combination
+ { n integer }
+ { k integer } ;
+
+C: <combination> combination
+
+<PRIVATE
+
+: dual-index ( combination m -- x )
+ [ [ n>> ] [ k>> ] bi nCk 1 - ] dip - ;
+
+: largest-value ( a b x -- v )
+ #! TODO: use a binary search instead of find-last
+ [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ;
+
+:: next-values ( a b x -- a' b' x' v )
+ a b x largest-value dup :> v ! a'
+ b 1 - ! b'
+ x v b nCk - ! x'
+ v ; ! v == a'
+
+: initial-values ( combination m -- a b x )
+ [ [ n>> ] [ k>> ] [ ] tri ] dip dual-index ;
+
+: combinadic ( combination m -- combinadic )
+ initial-values [ over 0 > ] [ next-values ] produce
+ [ 3drop ] dip ;
+
+PRIVATE>
+
+: combination ( m combination -- seq )
+ swap [ drop n>> 1 - ] [ combinadic ] 2bi [ - ] with map ;
From eaeda30bb1f586d2c18e4d5804055ac1423c81cf Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 6 May 2009 01:17:35 -0400
Subject: [PATCH 06/72] Combinations now map to input sequences directly
---
basis/math/combinatorics/combinatorics.factor | 47 +++++++++++++------
1 file changed, 33 insertions(+), 14 deletions(-)
diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor
index 0ca306b68c..dd71ded8c2 100644
--- a/basis/math/combinatorics/combinatorics.factor
+++ b/basis/math/combinatorics/combinatorics.factor
@@ -52,7 +52,7 @@ PRIVATE>
[ [ length factorial ] keep ] dip
'[ _ permutation @ ] each ; inline
-: reduce-permutations ( seq initial quot -- result )
+: reduce-permutations ( seq identity quot -- result )
swapd each-permutation ; inline
: inverse-permutation ( seq -- permutation )
@@ -61,16 +61,13 @@ PRIVATE>
! Combinadic-based combination methodology
-TUPLE: combination
- { n integer }
- { k integer } ;
-
-C: <combination> combination
-
<PRIVATE
-: dual-index ( combination m -- x )
- [ [ n>> ] [ k>> ] bi nCk 1 - ] dip - ;
+TUPLE: combo
+ { seq sequence }
+ { k integer } ;
+
+C: <combo> combo
: largest-value ( a b x -- v )
#! TODO: use a binary search instead of find-last
@@ -82,14 +79,36 @@ C: <combination> combination
x v b nCk - ! x'
v ; ! v == a'
-: initial-values ( combination m -- a b x )
- [ [ n>> ] [ k>> ] [ ] tri ] dip dual-index ;
+: dual-index ( combo m -- x )
+ [ [ seq>> length ] [ k>> ] bi nCk 1 - ] dip - ;
-: combinadic ( combination m -- combinadic )
+: initial-values ( combo m -- a b x )
+ [ [ seq>> length ] [ k>> ] [ ] tri ] dip dual-index ;
+
+: combinadic ( combo m -- combinadic )
initial-values [ over 0 > ] [ next-values ] produce
[ 3drop ] dip ;
+: combination-indices ( m combo -- seq )
+ [ swap combinadic ] keep
+ seq>> length 1 - swap [ - ] with map ;
+
+: apply-combination ( m combo -- seq )
+ [ combination-indices ] keep seq>> nths ;
+
+: choose ( combo -- nCk )
+ [ seq>> length ] [ k>> ] bi nCk ;
+
PRIVATE>
-: combination ( m combination -- seq )
- swap [ drop n>> 1 - ] [ combinadic ] 2bi [ - ] with map ;
+: combination ( m seq k -- seq )
+ <combo> apply-combination ;
+
+: all-combinations ( seq k -- seq )
+ <combo> [ choose [0,b) ] keep
+ '[ _ apply-combination ] map ;
+
+: each-combination ( seq k quot -- )
+ [ <combo> [ choose [0,b) ] keep ] dip
+ '[ _ apply-combination @ ] each ; inline
+
From c9b97f3f9205c5c0066382a222afd66b0c772b36 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 6 May 2009 19:33:58 -0400
Subject: [PATCH 07/72] Add tests for combinations
---
.../combinatorics/combinatorics-tests.factor | 51 ++++++++++++++-----
1 file changed, 39 insertions(+), 12 deletions(-)
diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor
index 5ef435a4e0..8cd02399bc 100644
--- a/basis/math/combinatorics/combinatorics-tests.factor
+++ b/basis/math/combinatorics/combinatorics-tests.factor
@@ -1,18 +1,6 @@
USING: math.combinatorics math.combinatorics.private tools.test ;
IN: math.combinatorics.tests
-[ { } ] [ 0 factoradic ] unit-test
-[ { 1 0 } ] [ 1 factoradic ] unit-test
-[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
-
-[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
-[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
-[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
-
-[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
-[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
-[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
-
[ 1 ] [ 0 factorial ] unit-test
[ 1 ] [ 1 factorial ] unit-test
[ 3628800 ] [ 10 factorial ] unit-test
@@ -31,6 +19,19 @@ IN: math.combinatorics.tests
[ 2598960 ] [ 52 5 nCk ] unit-test
[ 2598960 ] [ 52 47 nCk ] unit-test
+
+[ { } ] [ 0 factoradic ] unit-test
+[ { 1 0 } ] [ 1 factoradic ] unit-test
+[ { 1 1 0 3 0 1 0 } ] [ 859 factoradic ] unit-test
+
+[ { 0 1 2 3 } ] [ { 0 0 0 0 } >permutation ] unit-test
+[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
+[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
+
+[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
+[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
+[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
+
[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "a" "b" "c" } ] [ 18 { "a" "b" "c" "d" } permutation ] unit-test
@@ -43,3 +44,29 @@ IN: math.combinatorics.tests
[ { 2 1 0 } ] [ { "c" "b" "a" } inverse-permutation ] unit-test
[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
+
+[ 2598960 ] [ 52 5 <combo> choose ] unit-test
+
+[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test
+[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test
+[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test
+[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test
+
+[ 9 ] [ 0 5 3 <combo> dual-index ] unit-test
+[ 0 ] [ 9 5 3 <combo> dual-index ] unit-test
+[ 179 ] [ 72 10 5 <combo> dual-index ] unit-test
+
+[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
+[ { 4 3 2 1 0 } ] [ 10 5 <combo> 0 combinadic ] unit-test
+[ { 8 6 3 1 0 } ] [ 10 5 <combo> 72 combinadic ] unit-test
+[ { 9 8 7 6 5 } ] [ 10 5 <combo> 251 combinadic ] unit-test
+
+[ { 0 1 2 } ] [ 0 5 3 <combo> combination-indices ] unit-test
+[ { 2 3 4 } ] [ 9 5 3 <combo> combination-indices ] unit-test
+
+[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
+[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
+
+[ { { "a" "b" } { "a" "c" }
+ { "a" "d" } { "b" "c" }
+ { "b" "d" } { "c" "d" } } ] [ { "a" "b" "c" "d" } 2 all-combinations ] unit-test
From 678f603aa5495f92285303f375635410b20c00cc Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 6 May 2009 20:18:21 -0400
Subject: [PATCH 08/72] Clean up combinations a bit
---
basis/math/combinatorics/combinatorics.factor | 19 ++++++++++---------
1 file changed, 10 insertions(+), 9 deletions(-)
diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor
index dd71ded8c2..b2e21e429a 100644
--- a/basis/math/combinatorics/combinatorics.factor
+++ b/basis/math/combinatorics/combinatorics.factor
@@ -46,7 +46,8 @@ PRIVATE>
[ permutation-indices ] keep nths ;
: all-permutations ( seq -- seq )
- [ length factorial ] keep '[ _ permutation ] map ;
+ [ length factorial ] keep
+ '[ _ permutation ] map ;
: each-permutation ( seq quot -- )
[ [ length factorial ] keep ] dip
@@ -69,6 +70,9 @@ TUPLE: combo
C: <combo> combo
+: choose ( combo -- nCk )
+ [ seq>> length ] [ k>> ] bi nCk ;
+
: largest-value ( a b x -- v )
#! TODO: use a binary search instead of find-last
[ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ;
@@ -79,26 +83,23 @@ C: <combo> combo
x v b nCk - ! x'
v ; ! v == a'
-: dual-index ( combo m -- x )
- [ [ seq>> length ] [ k>> ] bi nCk 1 - ] dip - ;
+: dual-index ( m combo -- m' )
+ choose 1 - swap - ;
-: initial-values ( combo m -- a b x )
- [ [ seq>> length ] [ k>> ] [ ] tri ] dip dual-index ;
+: initial-values ( combo m -- n k m )
+ [ [ seq>> length ] [ k>> ] bi ] dip ;
: combinadic ( combo m -- combinadic )
initial-values [ over 0 > ] [ next-values ] produce
[ 3drop ] dip ;
: combination-indices ( m combo -- seq )
- [ swap combinadic ] keep
+ [ tuck dual-index combinadic ] keep
seq>> length 1 - swap [ - ] with map ;
: apply-combination ( m combo -- seq )
[ combination-indices ] keep seq>> nths ;
-: choose ( combo -- nCk )
- [ seq>> length ] [ k>> ] bi nCk ;
-
PRIVATE>
: combination ( m seq k -- seq )
From 78037d8d0558d01abdc0609bddf23b53fe7cc6c0 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 6 May 2009 20:46:41 -0400
Subject: [PATCH 09/72] Use binary-search instead of find-last for combinations
---
basis/math/combinatorics/combinatorics.factor | 11 +++++++----
1 file changed, 7 insertions(+), 4 deletions(-)
diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor
index b2e21e429a..5bda23f738 100644
--- a/basis/math/combinatorics/combinatorics.factor
+++ b/basis/math/combinatorics/combinatorics.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007-2009 Slava Pestov, Doug Coleman, Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs fry kernel locals math math.order math.ranges mirrors
- namespaces sequences sorting ;
+USING: accessors assocs binary-search fry kernel locals math math.order
+ math.ranges mirrors namespaces sequences sorting ;
IN: math.combinatorics
<PRIVATE
@@ -74,8 +74,11 @@ C: <combo> combo
[ seq>> length ] [ k>> ] bi nCk ;
: largest-value ( a b x -- v )
- #! TODO: use a binary search instead of find-last
- [ [0,b) ] 2dip '[ _ nCk _ <= ] find-last nip ;
+ dup 0 = [
+ drop 1 - nip
+ ] [
+ [ [0,b) ] 2dip '[ _ nCk _ >=< ] search nip
+ ] if ;
:: next-values ( a b x -- a' b' x' v )
a b x largest-value dup :> v ! a'
From b84a3158fa47b9507fd495a75e7cfa63fe72691d Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 6 May 2009 21:27:04 -0400
Subject: [PATCH 10/72] Add docs for combination words
---
.../combinatorics/combinatorics-docs.factor | 70 +++++++++++++++++--
1 file changed, 63 insertions(+), 7 deletions(-)
diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor
index 514c808ee0..7f40969b95 100644
--- a/basis/math/combinatorics/combinatorics-docs.factor
+++ b/basis/math/combinatorics/combinatorics-docs.factor
@@ -1,37 +1,93 @@
-USING: help.markup help.syntax kernel math math.order sequences ;
+USING: help.markup help.syntax kernel math math.order multiline sequences ;
IN: math.combinatorics
HELP: factorial
{ $values { "n" "a non-negative integer" } { "n!" integer } }
{ $description "Outputs the product of all positive integers less than or equal to " { $snippet "n" } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "4 factorial ." "24" } } ;
+{ $examples
+ { $example "USING: math.combinatorics prettyprint ;"
+ "4 factorial ." "24" }
+} ;
HELP: nPk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nPk" integer } }
{ $description "Outputs the total number of unique permutations of size " { $snippet "k" } " (order does matter) that can be taken from a set of size " { $snippet "n" } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nPk ." "5040" } } ;
+{ $examples
+ { $example "USING: math.combinatorics prettyprint ;"
+ "10 4 nPk ." "5040" }
+} ;
HELP: nCk
{ $values { "n" "a non-negative integer" } { "k" "a non-negative integer" } { "nCk" integer } }
{ $description "Outputs the total number of unique combinations of size " { $snippet "k" } " (order does not matter) that can be taken from a set of size " { $snippet "n" } ". Commonly written as \"n choose k\"." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "10 4 nCk ." "210" } } ;
+{ $examples
+ { $example "USING: math.combinatorics prettyprint ;"
+ "10 4 nCk ." "210" }
+} ;
HELP: permutation
{ $values { "n" "a non-negative integer" } { "seq" sequence } { "seq" sequence } }
{ $description "Outputs the " { $snippet "nth" } " lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "Permutations are 0-based and a bounds error will be thrown if " { $snippet "n" } " is larger than " { $snippet "seq length factorial 1-" } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "1 3 permutation ." "{ 0 2 1 }" } { $example "USING: math.combinatorics prettyprint ;" "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" } } ;
+{ $examples
+ { $example "USING: math.combinatorics prettyprint ;"
+ "1 3 permutation ." "{ 0 2 1 }" }
+ { $example "USING: math.combinatorics prettyprint ;"
+ "5 { \"apple\" \"banana\" \"orange\" } permutation ." "{ \"orange\" \"banana\" \"apple\" }" }
+} ;
HELP: all-permutations
{ $values { "seq" sequence } { "seq" sequence } }
{ $description "Outputs a sequence containing all permutations of " { $snippet "seq" } " in lexicographical order." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" } } ;
+{ $examples
+ { $example "USING: math.combinatorics prettyprint ;"
+ "3 all-permutations ." "{ { 0 1 2 } { 0 2 1 } { 1 0 2 } { 1 2 0 } { 2 0 1 } { 2 1 0 } }" }
+} ;
+
+HELP: each-permutation
+{ $values { "seq" sequence } { "quot" { $quotation "( seq -- )" } } }
+{ $description "Applies the quotation to each permuation of " { $snippet "seq" } " in order." } ;
HELP: inverse-permutation
{ $values { "seq" sequence } { "permutation" sequence } }
{ $description "Outputs a sequence of indices representing the lexicographical permutation of " { $snippet "seq" } "." }
{ $notes "All items in " { $snippet "seq" } " must be comparable by " { $link <=> } "." }
-{ $examples { $example "USING: math.combinatorics prettyprint ;" "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" } { $example "USING: math.combinatorics prettyprint ;" "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" } } ;
+{ $examples
+ { $example "USING: math.combinatorics prettyprint ;"
+ "\"dcba\" inverse-permutation ." "{ 3 2 1 0 }" }
+ { $example "USING: math.combinatorics prettyprint ;"
+ "{ 12 56 34 78 } inverse-permutation ." "{ 0 2 1 3 }" }
+} ;
+
+HELP: combination
+{ $values { "m" "a non-negative integer" } { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
+{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." }
+{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." }
+{ $examples
+ { $example "USING: math.combinatorics prettyprint ;"
+ "6 7 iota 4 combination ." "{ 0 1 3 6 }" }
+ { $example "USING: math.combinatorics prettyprint ;"
+ "0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" }
+} ;
+
+HELP: all-combinations
+{ $values { "seq" sequence } { "k" "a non-negative integer" } { "seq" sequence } }
+{ $description "Outputs a sequence containing all combinations of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in lexicographical order." }
+{ $examples
+ { $example "USING: math.combinatorics prettyprint ;"
+ "{ \"a\" \"b\" \"c\" \"d\" } 2 all-combinations ."
+<" {
+ { "a" "b" }
+ { "a" "c" }
+ { "a" "d" }
+ { "b" "c" }
+ { "b" "d" }
+ { "c" "d" }
+}"> } } ;
+
+HELP: each-combination
+{ $values { "seq" sequence } { "k" "a non-negative integer" } { "quot" { $quotation "( seq -- )" } } }
+{ $description "Applies the quotation to each combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements, in order." } ;
IN: math.combinatorics.private
From 83e75166668a614c845e7d215805ca18b2112de6 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 6 May 2009 21:31:37 -0400
Subject: [PATCH 11/72] Use iota where necessary in tests
---
.../combinatorics/combinatorics-tests.factor | 24 +++++++++----------
1 file changed, 12 insertions(+), 12 deletions(-)
diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor
index 8cd02399bc..1bc4bbc825 100644
--- a/basis/math/combinatorics/combinatorics-tests.factor
+++ b/basis/math/combinatorics/combinatorics-tests.factor
@@ -28,9 +28,9 @@ IN: math.combinatorics.tests
[ { 0 1 3 2 } ] [ { 0 0 1 0 } >permutation ] unit-test
[ { 1 2 0 6 3 5 4 } ] [ { 1 1 0 3 0 1 0 } >permutation ] unit-test
-[ { 0 1 2 3 } ] [ 0 4 permutation-indices ] unit-test
-[ { 0 1 3 2 } ] [ 1 4 permutation-indices ] unit-test
-[ { 1 2 0 6 3 5 4 } ] [ 859 7 permutation-indices ] unit-test
+[ { 0 1 2 3 } ] [ 0 4 iota permutation-indices ] unit-test
+[ { 0 1 3 2 } ] [ 1 4 iota permutation-indices ] unit-test
+[ { 1 2 0 6 3 5 4 } ] [ 859 7 iota permutation-indices ] unit-test
[ { "a" "b" "c" "d" } ] [ 0 { "a" "b" "c" "d" } permutation ] unit-test
[ { "d" "c" "b" "a" } ] [ 23 { "a" "b" "c" "d" } permutation ] unit-test
@@ -45,24 +45,24 @@ IN: math.combinatorics.tests
[ { 3 0 2 1 } ] [ { 12 45 34 2 } inverse-permutation ] unit-test
-[ 2598960 ] [ 52 5 <combo> choose ] unit-test
+[ 2598960 ] [ 52 iota 5 <combo> choose ] unit-test
[ 6 3 13 6 ] [ 7 4 28 next-values ] unit-test
[ 5 2 3 5 ] [ 6 3 13 next-values ] unit-test
[ 3 1 0 3 ] [ 5 2 3 next-values ] unit-test
[ 0 0 0 0 ] [ 3 1 0 next-values ] unit-test
-[ 9 ] [ 0 5 3 <combo> dual-index ] unit-test
-[ 0 ] [ 9 5 3 <combo> dual-index ] unit-test
-[ 179 ] [ 72 10 5 <combo> dual-index ] unit-test
+[ 9 ] [ 0 5 iota 3 <combo> dual-index ] unit-test
+[ 0 ] [ 9 5 iota 3 <combo> dual-index ] unit-test
+[ 179 ] [ 72 10 iota 5 <combo> dual-index ] unit-test
[ { 5 3 2 1 } ] [ 7 4 <combo> 8 combinadic ] unit-test
-[ { 4 3 2 1 0 } ] [ 10 5 <combo> 0 combinadic ] unit-test
-[ { 8 6 3 1 0 } ] [ 10 5 <combo> 72 combinadic ] unit-test
-[ { 9 8 7 6 5 } ] [ 10 5 <combo> 251 combinadic ] unit-test
+[ { 4 3 2 1 0 } ] [ 10 iota 5 <combo> 0 combinadic ] unit-test
+[ { 8 6 3 1 0 } ] [ 10 iota 5 <combo> 72 combinadic ] unit-test
+[ { 9 8 7 6 5 } ] [ 10 iota 5 <combo> 251 combinadic ] unit-test
-[ { 0 1 2 } ] [ 0 5 3 <combo> combination-indices ] unit-test
-[ { 2 3 4 } ] [ 9 5 3 <combo> combination-indices ] unit-test
+[ { 0 1 2 } ] [ 0 5 iota 3 <combo> combination-indices ] unit-test
+[ { 2 3 4 } ] [ 9 5 iota 3 <combo> combination-indices ] unit-test
[ { "a" "b" "c" } ] [ 0 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
[ { "c" "d" "e" } ] [ 9 { "a" "b" "c" "d" "e" } 3 combination ] unit-test
From 5e4e1ee48fe313dc7771b83306ac0b7a53aad376 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 6 May 2009 21:44:25 -0400
Subject: [PATCH 12/72] Make a deck of cards an actual tuple
---
extra/poker/poker.factor | 8 ++++++--
1 file changed, 6 insertions(+), 2 deletions(-)
diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor
index 15e9a96d42..b4353dc925 100644
--- a/extra/poker/poker.factor
+++ b/extra/poker/poker.factor
@@ -194,8 +194,12 @@ M: hand equal?
: >value ( hand -- str )
hand-rank VALUE_STR nth ;
+TUPLE: deck
+ { cards sequence } ;
+
: <deck> ( -- deck )
- RANK_STR SUIT_STR 2array [ concat >ckf ] product-map ;
+ RANK_STR SUIT_STR 2array [ concat >ckf ] product-map deck boa ;
-ALIAS: shuffle randomize
+: shuffle ( deck -- deck )
+ [ randomize ] change-cards ;
From e2c73b543a59a0c68fd0d8cc8442eaedfdf0b6cd Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 7 May 2009 10:19:23 -0400
Subject: [PATCH 13/72] Add >5 card evaluator word to poker vocab
---
extra/poker/poker.factor | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor
index b4353dc925..df8d93d9fa 100644
--- a/extra/poker/poker.factor
+++ b/extra/poker/poker.factor
@@ -2,8 +2,8 @@
! The contents of this file are licensed under the Simplified BSD License
! A copy of the license is available at http://factorcode.org/license.txt
USING: accessors arrays ascii binary-search combinators kernel locals math
- math.bitwise math.order poker.arrays random sequences sequences.product
- splitting ;
+ math.bitwise math.combinatorics math.order poker.arrays random sequences
+ sequences.product splitting ;
IN: poker
! The algorithm used is based on Cactus Kev's Poker Hand Evaluator with
@@ -194,6 +194,9 @@ M: hand equal?
: >value ( hand -- str )
hand-rank VALUE_STR nth ;
+: best-hand ( str -- hand )
+ " " split 5 all-combinations [ " " join <hand> ] map infimum ;
+
TUPLE: deck
{ cards sequence } ;
From 0878006bd0d7b783062272a0eef1b57663995c59 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 7 May 2009 10:29:44 -0400
Subject: [PATCH 14/72] Speed up best-hand by not converting to ckf repeatedly
---
extra/poker/poker.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor
index df8d93d9fa..a749be239b 100644
--- a/extra/poker/poker.factor
+++ b/extra/poker/poker.factor
@@ -195,7 +195,8 @@ M: hand equal?
hand-rank VALUE_STR nth ;
: best-hand ( str -- hand )
- " " split 5 all-combinations [ " " join <hand> ] map infimum ;
+ parse-cards 5 all-combinations
+ [ dup hand-value hand boa ] map infimum ;
TUPLE: deck
{ cards sequence } ;
From 5e82d794df12897d34bc2b7a31549f2195c64048 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 7 May 2009 10:56:33 -0400
Subject: [PATCH 15/72] Eliminate stack shuffling by using bi in PE #25
---
extra/project-euler/025/025.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/project-euler/025/025.factor b/extra/project-euler/025/025.factor
index 80a933dc63..5dfe7b9f56 100644
--- a/extra/project-euler/025/025.factor
+++ b/extra/project-euler/025/025.factor
@@ -39,7 +39,7 @@ IN: project-euler.025
! Memoized brute force
MEMO: fib ( m -- n )
- dup 1 > [ 1- dup fib swap 1- fib + ] when ;
+ dup 1 > [ [ 1 - fib ] [ 2 - fib ] bi + ] when ;
<PRIVATE
From 766eb8b47e19ed17f35bb819b708546c2117435f Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 7 May 2009 11:20:01 -0400
Subject: [PATCH 16/72] Add docs for best-hand in poker vocab
---
extra/poker/poker-docs.factor | 8 ++++++++
1 file changed, 8 insertions(+)
diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor
index 09019a29d7..ad2131870e 100644
--- a/extra/poker/poker-docs.factor
+++ b/extra/poker/poker-docs.factor
@@ -28,3 +28,11 @@ HELP: >value
"\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
}
{ $notes "This should not be used as a basis for hand comparison." } ;
+
+HELP: best-hand
+{ $values { "str" string } { "hand" "a new hand" } }
+{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
+{ $examples
+ { $example "USING: kernel poker prettyprint ;"
+ "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" }
+} ;
From 246fb6672ea8b039538708be5dbd0f71c1781b7a Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 7 May 2009 16:54:49 -0400
Subject: [PATCH 17/72] Minor logical rearrangement
---
extra/poker/poker-docs.factor | 16 ++++++++--------
extra/poker/poker.factor | 8 ++++----
2 files changed, 12 insertions(+), 12 deletions(-)
diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor
index ad2131870e..ab0a59ed4f 100644
--- a/extra/poker/poker-docs.factor
+++ b/extra/poker/poker-docs.factor
@@ -12,6 +12,14 @@ HELP: <hand>
}
{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
+HELP: best-hand
+{ $values { "str" string } { "hand" "a new hand" } }
+{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
+{ $examples
+ { $example "USING: kernel poker prettyprint ;"
+ "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" }
+} ;
+
HELP: >cards
{ $values { "hand" "a hand" } { "str" string } }
{ $description "Outputs a string representation of a hand's cards." }
@@ -28,11 +36,3 @@ HELP: >value
"\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
}
{ $notes "This should not be used as a basis for hand comparison." } ;
-
-HELP: best-hand
-{ $values { "str" string } { "hand" "a new hand" } }
-{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
-{ $examples
- { $example "USING: kernel poker prettyprint ;"
- "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" }
-} ;
diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor
index a749be239b..b7661b83db 100644
--- a/extra/poker/poker.factor
+++ b/extra/poker/poker.factor
@@ -188,16 +188,16 @@ M: hand equal?
: <hand> ( str -- hand )
parse-cards dup hand-value hand boa ;
+: best-hand ( str -- hand )
+ parse-cards 5 all-combinations
+ [ dup hand-value hand boa ] map infimum ;
+
: >cards ( hand -- str )
cards>> [ card>string ] map " " join ;
: >value ( hand -- str )
hand-rank VALUE_STR nth ;
-: best-hand ( str -- hand )
- parse-cards 5 all-combinations
- [ dup hand-value hand boa ] map infimum ;
-
TUPLE: deck
{ cards sequence } ;
From 7f6998a8154babe8dcbb36a710372d0abd86b562 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 7 May 2009 18:33:55 -0400
Subject: [PATCH 18/72] Make next-odd public again as it's used elsewhere
---
basis/math/miller-rabin/miller-rabin.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor
index 9fd604a003..cb1d3723b4 100755
--- a/basis/math/miller-rabin/miller-rabin.factor
+++ b/basis/math/miller-rabin/miller-rabin.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Doug Coleman.
+! 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
@@ -13,8 +13,6 @@ IN: math.miller-rabin
: next-even ( m -- n ) >even 2 + ;
-: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
-
TUPLE: positive-even-expected n ;
:: (miller-rabin) ( n trials -- ? )
@@ -29,12 +27,14 @@ TUPLE: positive-even-expected n ;
] [
r iota [
2^ s * a swap n ^mod n - -1 =
- ] any? not
+ ] any? not
] if
] any? not ;
PRIVATE>
+: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ;
+
: miller-rabin* ( n numtrials -- ? )
over {
{ [ dup 1 <= ] [ 3drop f ] }
From d9e4f6e9cbe1df7a5f979d594a681147d9f490cc Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 7 May 2009 18:50:46 -0400
Subject: [PATCH 19/72] Update docs/summary for poker vocab
---
extra/poker/poker-docs.factor | 16 ++++++++++++----
extra/poker/summary.txt | 2 +-
2 files changed, 13 insertions(+), 5 deletions(-)
diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor
index ab0a59ed4f..388239d549 100644
--- a/extra/poker/poker-docs.factor
+++ b/extra/poker/poker-docs.factor
@@ -2,7 +2,7 @@ USING: help.markup help.syntax strings ;
IN: poker
HELP: <hand>
-{ $values { "str" string } { "hand" "a new hand" } }
+{ $values { "str" string } { "hand" "a new " { $link hand } } }
{ $description "Creates a new poker hand containing the cards specified in " { $snippet "str" } "." }
{ $examples
{ $example "USING: kernel math.order poker prettyprint ;"
@@ -13,7 +13,7 @@ HELP: <hand>
{ $notes "Cards may be specified in any order. Hands are directly comparable to each other on the basis of their computed value. Two hands are considered equal when they would tie in a game (despite being composed of different cards)." } ;
HELP: best-hand
-{ $values { "str" string } { "hand" "a new hand" } }
+{ $values { "str" string } { "hand" "a new " { $link hand } } }
{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
{ $examples
{ $example "USING: kernel poker prettyprint ;"
@@ -21,7 +21,7 @@ HELP: best-hand
} ;
HELP: >cards
-{ $values { "hand" "a hand" } { "str" string } }
+{ $values { "hand" hand } { "str" string } }
{ $description "Outputs a string representation of a hand's cards." }
{ $examples
{ $example "USING: poker prettyprint ;"
@@ -29,10 +29,18 @@ HELP: >cards
} ;
HELP: >value
-{ $values { "hand" "a hand" } { "str" string } }
+{ $values { "hand" hand } { "str" string } }
{ $description "Outputs a string representation of a hand's value." }
{ $examples
{ $example "USING: poker prettyprint ;"
"\"AC KC QC JC TC\" <hand> >value ." "\"Straight Flush\"" }
}
{ $notes "This should not be used as a basis for hand comparison." } ;
+
+HELP: <deck>
+{ $values { "deck" "a new " { $link deck } } }
+{ $description "Creates a standard deck of 52 cards." } ;
+
+HELP: shuffle
+{ $values { "deck" deck } { "deck" "a shuffled " { $link deck } } }
+{ $description "Shuffles the cards in " { $snippet "deck" } ", in-place, using the Fisher-Yates algorithm." } ;
diff --git a/extra/poker/summary.txt b/extra/poker/summary.txt
index c8efe851c8..8dbbe9bd74 100644
--- a/extra/poker/summary.txt
+++ b/extra/poker/summary.txt
@@ -1 +1 @@
-5-card poker hand evaluator
+Poker hand evaluator
From f465a013d7e93ea118df8634abf2a3cf2c2ed1d0 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 7 May 2009 21:23:58 -0400
Subject: [PATCH 20/72] Speed up best-hands a bit using reduce and add a test
---
basis/math/combinatorics/combinatorics.factor | 7 +++++++
extra/poker/poker-tests.factor | 2 ++
extra/poker/poker.factor | 6 +++---
3 files changed, 12 insertions(+), 3 deletions(-)
diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor
index 5bda23f738..bc09f9fe0f 100644
--- a/basis/math/combinatorics/combinatorics.factor
+++ b/basis/math/combinatorics/combinatorics.factor
@@ -116,3 +116,10 @@ PRIVATE>
[ <combo> [ choose [0,b) ] keep ] dip
'[ _ apply-combination @ ] each ; inline
+: map-combinations ( seq k quot -- )
+ [ <combo> [ choose [0,b) ] keep ] dip
+ '[ _ apply-combination @ ] map ; inline
+
+: reduce-combinations ( seq k identity quot -- result )
+ [ -rot ] dip each-combination ; inline
+
diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor
index e2d89620e6..3c8e5159ab 100644
--- a/extra/poker/poker-tests.factor
+++ b/extra/poker/poker-tests.factor
@@ -26,3 +26,5 @@ IN: poker.tests
[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test
+
+[ 190 ] [ "AS KD JC KH 2D 2S KH" best-hand value>> ] unit-test
diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor
index b7661b83db..baebb25572 100644
--- a/extra/poker/poker.factor
+++ b/extra/poker/poker.factor
@@ -179,7 +179,7 @@ PRIVATE>
TUPLE: hand
{ cards sequence }
- { value integer } ;
+ { value integer initial: 9999 } ;
M: hand <=> [ value>> ] compare ;
M: hand equal?
@@ -189,8 +189,8 @@ M: hand equal?
parse-cards dup hand-value hand boa ;
: best-hand ( str -- hand )
- parse-cards 5 all-combinations
- [ dup hand-value hand boa ] map infimum ;
+ parse-cards 5 hand new
+ [ dup hand-value hand boa min ] reduce-combinations ;
: >cards ( hand -- str )
cards>> [ card>string ] map " " join ;
From 3a636d67c45c948d6c07f1ac3225b96da43c6fd7 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 7 May 2009 23:11:44 -0400
Subject: [PATCH 21/72] Fix typo in poker test/doc example
---
extra/poker/poker-docs.factor | 2 +-
extra/poker/poker-tests.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/poker/poker-docs.factor b/extra/poker/poker-docs.factor
index 388239d549..fef47b859c 100644
--- a/extra/poker/poker-docs.factor
+++ b/extra/poker/poker-docs.factor
@@ -17,7 +17,7 @@ HELP: best-hand
{ $description "Creates a new poker hand containing the best possible combination of the cards specified in " { $snippet "str" } "." }
{ $examples
{ $example "USING: kernel poker prettyprint ;"
- "\"AS KD JC KH 2D 2S KH\" best-hand >value ." "\"Full House\"" }
+ "\"AS KD JC KH 2D 2S KC\" best-hand >value ." "\"Full House\"" }
} ;
HELP: >cards
diff --git a/extra/poker/poker-tests.factor b/extra/poker/poker-tests.factor
index 3c8e5159ab..6b05178462 100644
--- a/extra/poker/poker-tests.factor
+++ b/extra/poker/poker-tests.factor
@@ -27,4 +27,4 @@ IN: poker.tests
[ t ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ = ] unit-test
[ f ] [ "7C 5D 4H 3S 2C" "7D 5D 4D 3C 2S" [ <hand> ] bi@ eq? ] unit-test
-[ 190 ] [ "AS KD JC KH 2D 2S KH" best-hand value>> ] unit-test
+[ 190 ] [ "AS KD JC KH 2D 2S KC" best-hand value>> ] unit-test
From 58fdffee87af3e14a4e9a0f5db5d76c3ea01ca1d Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Fri, 8 May 2009 02:24:12 -0400
Subject: [PATCH 22/72] Make lookup indices zero-based for poker values
---
extra/poker/poker.factor | 26 +++++++++++++-------------
1 file changed, 13 insertions(+), 13 deletions(-)
diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor
index baebb25572..a5a5a93628 100644
--- a/extra/poker/poker.factor
+++ b/extra/poker/poker.factor
@@ -49,21 +49,21 @@ CONSTANT: QUEEN 10
CONSTANT: KING 11
CONSTANT: ACE 12
-CONSTANT: STRAIGHT_FLUSH 1
-CONSTANT: FOUR_OF_A_KIND 2
-CONSTANT: FULL_HOUSE 3
-CONSTANT: FLUSH 4
-CONSTANT: STRAIGHT 5
-CONSTANT: THREE_OF_A_KIND 6
-CONSTANT: TWO_PAIR 7
-CONSTANT: ONE_PAIR 8
-CONSTANT: HIGH_CARD 9
+CONSTANT: STRAIGHT_FLUSH 0
+CONSTANT: FOUR_OF_A_KIND 1
+CONSTANT: FULL_HOUSE 2
+CONSTANT: FLUSH 3
+CONSTANT: STRAIGHT 4
+CONSTANT: THREE_OF_A_KIND 5
+CONSTANT: TWO_PAIR 6
+CONSTANT: ONE_PAIR 7
+CONSTANT: HIGH_CARD 8
CONSTANT: SUIT_STR { "C" "D" "H" "S" }
CONSTANT: RANK_STR { "2" "3" "4" "5" "6" "7" "8" "9" "T" "J" "Q" "K" "A" }
-CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
+CONSTANT: VALUE_STR { "Straight Flush" "Four of a Kind" "Full House" "Flush"
"Straight" "Three of a Kind" "Two Pair" "One Pair" "High Card" }
: card-rank-prime ( rank -- n )
@@ -159,8 +159,8 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush"
[ drop "S" ]
} cond ;
-: hand-rank ( hand -- rank )
- value>> {
+: hand-rank ( value -- rank )
+ {
{ [ dup 6185 > ] [ drop HIGH_CARD ] } ! 1277 high card
{ [ dup 3325 > ] [ drop ONE_PAIR ] } ! 2860 one pair
{ [ dup 2467 > ] [ drop TWO_PAIR ] } ! 858 two pair
@@ -196,7 +196,7 @@ M: hand equal?
cards>> [ card>string ] map " " join ;
: >value ( hand -- str )
- hand-rank VALUE_STR nth ;
+ value>> hand-rank VALUE_STR nth ;
TUPLE: deck
{ cards sequence } ;
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 23/72] 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 24/72] 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 25/72] 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 ba213bdc342bd0b0c0957ed0bea3f087aba91b34 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 8 May 2009 13:00:34 -0500
Subject: [PATCH 26/72] make open-game-input and close-game-input do reference
counting. update demos to show this
---
extra/game-input/game-input-docs.factor | 4 +--
extra/game-input/game-input.factor | 48 ++++++++++++++-----------
extra/key-caps/key-caps.factor | 5 +--
extra/terrain/terrain.factor | 10 +++---
4 files changed, 38 insertions(+), 29 deletions(-)
diff --git a/extra/game-input/game-input-docs.factor b/extra/game-input/game-input-docs.factor
index b46cf9a295..4ef0acdaaf 100755
--- a/extra/game-input/game-input-docs.factor
+++ b/extra/game-input/game-input-docs.factor
@@ -27,10 +27,10 @@ ARTICLE: "game-input" "Game controller input"
{ $subsection mouse-state } ;
HELP: open-game-input
-{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ;
+{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
HELP: close-game-input
-{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid. If the game input interface is not opened, nothing happens." } ;
+{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
HELP: game-input-opened?
{ $values { "?" "a boolean" } }
diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor
index 8281b7bc4c..ccf5bd635b 100755
--- a/extra/game-input/game-input.factor
+++ b/extra/game-input/game-input.factor
@@ -1,34 +1,57 @@
-USING: arrays accessors continuations kernel system
+USING: arrays accessors continuations kernel math system
sequences namespaces init vocabs vocabs.loader combinators ;
IN: game-input
SYMBOLS: game-input-backend game-input-opened ;
+game-input-opened [ 0 ] initialize
+
HOOK: (open-game-input) game-input-backend ( -- )
HOOK: (close-game-input) game-input-backend ( -- )
HOOK: (reset-game-input) game-input-backend ( -- )
+HOOK: get-controllers game-input-backend ( -- sequence )
+
+HOOK: product-string game-input-backend ( controller -- string )
+HOOK: product-id game-input-backend ( controller -- id )
+HOOK: instance-id game-input-backend ( controller -- id )
+
+HOOK: read-controller game-input-backend ( controller -- controller-state )
+HOOK: calibrate-controller game-input-backend ( controller -- )
+
+HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
: game-input-opened? ( -- ? )
- game-input-opened get ;
+ game-input-opened get zero? not ;
<PRIVATE
M: f (reset-game-input) ;
: reset-game-input ( -- )
- game-input-opened off
(reset-game-input) ;
[ reset-game-input ] "game-input" add-init-hook
PRIVATE>
+ERROR: game-input-not-open ;
+
: open-game-input ( -- )
game-input-opened? [
(open-game-input)
- game-input-opened on
- ] unless ;
+ ] unless
+ game-input-opened [ 1+ ] change-global
+ reset-mouse ;
: close-game-input ( -- )
+ game-input-opened [
+ dup zero? [ game-input-not-open ] when
+ 1-
+ ] change-global
game-input-opened? [
(close-game-input)
reset-game-input
@@ -48,12 +71,6 @@ SYMBOLS:
pov-up pov-up-right pov-right pov-down-right
pov-down pov-down-left pov-left pov-up-left ;
-HOOK: get-controllers game-input-backend ( -- sequence )
-
-HOOK: product-string game-input-backend ( controller -- string )
-HOOK: product-id game-input-backend ( controller -- id )
-HOOK: instance-id game-input-backend ( controller -- id )
-
: find-controller-products ( product-id -- sequence )
get-controllers [ product-id = ] with filter ;
: find-controller-instance ( product-id instance-id -- controller/f )
@@ -63,25 +80,16 @@ HOOK: instance-id game-input-backend ( controller -- id )
[ instance-id = ] 2bi* and
] with with find nip ;
-HOOK: read-controller game-input-backend ( controller -- controller-state )
-HOOK: calibrate-controller game-input-backend ( controller -- )
-
TUPLE: keyboard-state keys ;
M: keyboard-state clone
call-next-method dup keys>> clone >>keys ;
-HOOK: read-keyboard game-input-backend ( -- keyboard-state )
-
TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
M: mouse-state clone
call-next-method dup buttons>> clone >>buttons ;
-HOOK: read-mouse game-input-backend ( -- mouse-state )
-
-HOOK: reset-mouse game-input-backend ( -- )
-
{
{ [ os windows? ] [ "game-input.dinput" require ] }
{ [ os macosx? ] [ "game-input.iokit" require ] }
diff --git a/extra/key-caps/key-caps.factor b/extra/key-caps/key-caps.factor
index 9f86336f96..b58870fadc 100755
--- a/extra/key-caps/key-caps.factor
+++ b/extra/key-caps/key-caps.factor
@@ -162,18 +162,19 @@ M: key-caps-gadget pref-dim* drop KEYBOARD-SIZE ;
relayout-1 ;
M: key-caps-gadget graft*
+ open-game-input
dup '[ _ update-key-caps-state ] FREQUENCY every >>alarm
drop ;
M: key-caps-gadget ungraft*
- alarm>> [ cancel-alarm ] when* ;
+ alarm>> [ cancel-alarm ] when*
+ close-game-input ;
M: key-caps-gadget handle-gesture
drop [ key-down? ] [ key-up? ] bi or not ;
: key-caps ( -- )
[
- open-game-input
<key-caps-gadget> { 5 5 } <border> "Key Caps" open-window
] with-ui ;
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index 725848abb7..50c88d6f00 100644
--- a/extra/terrain/terrain.factor
+++ b/extra/terrain/terrain.factor
@@ -10,7 +10,7 @@ IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
-CONSTANT: FAR-PLANE 1.0
+CONSTANT: FAR-PLANE 2.0
CONSTANT: EYE-START { 0.5 0.5 1.2 }
CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
@@ -126,8 +126,8 @@ M: terrain-world draw*
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 glTexParameteri
- GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP 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 ;
M: terrain-world begin-world
"2.0" { "GL_ARB_vertex_buffer_object" "GL_ARB_shader_objects" }
@@ -146,10 +146,11 @@ M: terrain-world begin-world
>>terrain-program
vertex-array >vertex-buffer >>terrain-vertex-buffer
TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
- reset-mouse
+ open-game-input
drop ;
M: terrain-world end-world
+ close-game-input
{
[ game-loop>> stop-loop ]
[ terrain-vertex-buffer>> delete-gl-buffer ]
@@ -177,7 +178,6 @@ M: terrain-world pref-dim* drop { 640 480 } ;
: terrain-window ( -- )
[
- open-game-input
f T{ world-attributes
{ world-class terrain-world }
{ title "Terrain" }
From 3bf813447655a188dafa3b896cec83d3b1a25502 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 May 2009 15:05:55 -0500
Subject: [PATCH 27/72] VM cleanup: replace some #defines with constants and
inline functions
---
vm/callstack.cpp | 18 ++++------
vm/callstack.hpp | 2 --
vm/code_block.cpp | 53 ++++++++++++++++++----------
vm/code_block.hpp | 13 +++----
vm/code_gc.cpp | 12 +++----
vm/code_gc.hpp | 6 ++--
vm/contexts.cpp | 6 ++--
vm/cpu-ppc.hpp | 2 +-
vm/data_gc.cpp | 83 ++++++++++++++++++++++----------------------
vm/data_gc.hpp | 22 ++++++------
vm/data_heap.cpp | 54 ++++++++++++++--------------
vm/data_heap.hpp | 22 ++++++------
vm/image.cpp | 16 ++++-----
vm/image.hpp | 4 +--
vm/layouts.hpp | 26 +++++++++-----
vm/math.cpp | 39 +++++++++++++--------
vm/math.hpp | 11 +++---
vm/write_barrier.hpp | 42 +++++++++++-----------
18 files changed, 229 insertions(+), 202 deletions(-)
diff --git a/vm/callstack.cpp b/vm/callstack.cpp
index d9ac8d6073..e7009183e9 100755
--- a/vm/callstack.cpp
+++ b/vm/callstack.cpp
@@ -24,10 +24,7 @@ void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
{
- cell top = (cell)FIRST_STACK_FRAME(stack);
- cell bottom = top + untag_fixnum(stack->length);
-
- iterate_callstack(top,bottom,iterator);
+ iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
}
callstack *allot_callstack(cell size)
@@ -75,7 +72,7 @@ PRIMITIVE(callstack)
size = 0;
callstack *stack = allot_callstack(size);
- memcpy(FIRST_STACK_FRAME(stack),top,size);
+ memcpy(stack->top(),top,size);
dpush(tag<callstack>(stack));
}
@@ -84,7 +81,7 @@ PRIMITIVE(set_callstack)
callstack *stack = untag_check<callstack>(dpop());
set_callstack(stack_chain->callstack_bottom,
- FIRST_STACK_FRAME(stack),
+ stack->top(),
untag_fixnum(stack->length),
memcpy);
@@ -173,12 +170,11 @@ PRIMITIVE(callstack_to_array)
dpush(tag<array>(frames));
}
-stack_frame *innermost_stack_frame(callstack *callstack)
+stack_frame *innermost_stack_frame(callstack *stack)
{
- stack_frame *top = FIRST_STACK_FRAME(callstack);
- cell bottom = (cell)top + untag_fixnum(callstack->length);
-
- stack_frame *frame = (stack_frame *)bottom - 1;
+ stack_frame *top = stack->top();
+ stack_frame *bottom = stack->bottom();
+ stack_frame *frame = bottom - 1;
while(frame >= top && frame_successor(frame) >= top)
frame = frame_successor(frame);
diff --git a/vm/callstack.hpp b/vm/callstack.hpp
index ec2e8e37d1..a128cfee47 100755
--- a/vm/callstack.hpp
+++ b/vm/callstack.hpp
@@ -6,8 +6,6 @@ inline static cell callstack_size(cell size)
return sizeof(callstack) + size;
}
-#define FIRST_STACK_FRAME(stack) (stack_frame *)((stack) + 1)
-
typedef void (*CALLSTACK_ITER)(stack_frame *frame);
stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
diff --git a/vm/code_block.cpp b/vm/code_block.cpp
index 083f7f49e6..c34f651750 100755
--- a/vm/code_block.cpp
+++ b/vm/code_block.cpp
@@ -3,6 +3,21 @@
namespace factor
{
+static relocation_type relocation_type_of(relocation_entry r)
+{
+ return (relocation_type)((r & 0xf0000000) >> 28);
+}
+
+static relocation_class relocation_class_of(relocation_entry r)
+{
+ return (relocation_class)((r & 0x0f000000) >> 24);
+}
+
+static cell relocation_offset_of(relocation_entry r)
+{
+ return (r & 0x00ffffff);
+}
+
void flush_icache_for(code_block *block)
{
flush_icache((cell)block,block->size);
@@ -125,11 +140,11 @@ void *get_rel_symbol(array *literals, cell index)
cell compute_relocation(relocation_entry rel, cell index, code_block *compiled)
{
array *literals = untag<array>(compiled->literals);
- cell offset = REL_OFFSET(rel) + (cell)compiled->xt();
+ cell offset = relocation_offset_of(rel) + (cell)compiled->xt();
#define ARG array_nth(literals,index)
- switch(REL_TYPE(rel))
+ switch(relocation_type_of(rel))
{
case RT_PRIMITIVE:
return (cell)primitives[untag_fixnum(ARG)];
@@ -174,7 +189,7 @@ void iterate_relocations(code_block *compiled, relocation_iterator iter)
{
relocation_entry rel = relocation->data<relocation_entry>()[i];
iter(rel,index,compiled);
- index += number_of_parameters(REL_TYPE(rel));
+ index += number_of_parameters(relocation_type_of(rel));
}
}
}
@@ -217,25 +232,25 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
store_address_2_2((cell *)offset,absolute_value);
break;
case RC_ABSOLUTE_PPC_2:
- store_address_masked((cell *)offset,absolute_value,REL_ABSOLUTE_PPC_2_MASK,0);
+ store_address_masked((cell *)offset,absolute_value,rel_absolute_ppc_2_mask,0);
break;
case RC_RELATIVE_PPC_2:
- store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_2_MASK,0);
+ store_address_masked((cell *)offset,relative_value,rel_relative_ppc_2_mask,0);
break;
case RC_RELATIVE_PPC_3:
- store_address_masked((cell *)offset,relative_value,REL_RELATIVE_PPC_3_MASK,0);
+ store_address_masked((cell *)offset,relative_value,rel_relative_ppc_3_mask,0);
break;
case RC_RELATIVE_ARM_3:
store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
- REL_RELATIVE_ARM_3_MASK,2);
+ rel_relative_arm_3_mask,2);
break;
case RC_INDIRECT_ARM:
store_address_masked((cell *)offset,relative_value - sizeof(cell),
- REL_INDIRECT_ARM_MASK,0);
+ rel_indirect_arm_mask,0);
break;
case RC_INDIRECT_ARM_PC:
store_address_masked((cell *)offset,relative_value - sizeof(cell) * 2,
- REL_INDIRECT_ARM_MASK,0);
+ rel_indirect_arm_mask,0);
break;
default:
critical_error("Bad rel class",klass);
@@ -245,12 +260,12 @@ void store_address_in_code_block(cell klass, cell offset, fixnum absolute_value)
void update_literal_references_step(relocation_entry rel, cell index, code_block *compiled)
{
- if(REL_TYPE(rel) == RT_IMMEDIATE)
+ if(relocation_type_of(rel) == RT_IMMEDIATE)
{
- cell offset = REL_OFFSET(rel) + (cell)(compiled + 1);
+ cell offset = relocation_offset_of(rel) + (cell)(compiled + 1);
array *literals = untag<array>(compiled->literals);
fixnum absolute_value = array_nth(literals,index);
- store_address_in_code_block(REL_CLASS(rel),offset,absolute_value);
+ store_address_in_code_block(relocation_class_of(rel),offset,absolute_value);
}
}
@@ -297,14 +312,14 @@ void relocate_code_block_step(relocation_entry rel, cell index, code_block *comp
tagged<byte_array>(compiled->relocation).untag_check();
#endif
- store_address_in_code_block(REL_CLASS(rel),
- REL_OFFSET(rel) + (cell)compiled->xt(),
+ store_address_in_code_block(relocation_class_of(rel),
+ relocation_offset_of(rel) + (cell)compiled->xt(),
compute_relocation(rel,index,compiled));
}
void update_word_references_step(relocation_entry rel, cell index, code_block *compiled)
{
- relocation_type type = REL_TYPE(rel);
+ relocation_type type = relocation_type_of(rel);
if(type == RT_XT || type == RT_XT_PIC || type == RT_XT_PIC_TAIL)
relocate_code_block_step(rel,index,compiled);
}
@@ -369,7 +384,7 @@ void mark_stack_frame_step(stack_frame *frame)
/* Mark code blocks executing in currently active stack frames. */
void mark_active_blocks(context *stacks)
{
- if(collecting_gen == TENURED)
+ if(collecting_gen == data->tenured())
{
cell top = (cell)stacks->callstack_top;
cell bottom = (cell)stacks->callstack_bottom;
@@ -410,7 +425,7 @@ void mark_object_code_block(object *object)
/* Perform all fixups on a code block */
void relocate_code_block(code_block *compiled)
{
- compiled->last_scan = NURSERY;
+ compiled->last_scan = data->nursery();
compiled->needs_fixup = false;
iterate_relocations(compiled,relocate_code_block_step);
flush_icache_for(compiled);
@@ -480,7 +495,7 @@ code_block *add_code_block(
/* compiled header */
compiled->type = type;
- compiled->last_scan = NURSERY;
+ compiled->last_scan = data->nursery();
compiled->needs_fixup = true;
compiled->relocation = relocation.value();
@@ -499,7 +514,7 @@ code_block *add_code_block(
/* next time we do a minor GC, we have to scan the code heap for
literals */
- last_code_heap_scan = NURSERY;
+ last_code_heap_scan = data->nursery();
return compiled;
}
diff --git a/vm/code_block.hpp b/vm/code_block.hpp
index fef5b15da4..d46cd9e885 100644
--- a/vm/code_block.hpp
+++ b/vm/code_block.hpp
@@ -51,17 +51,14 @@ enum relocation_class {
RC_INDIRECT_ARM_PC
};
-#define REL_ABSOLUTE_PPC_2_MASK 0xffff
-#define REL_RELATIVE_PPC_2_MASK 0xfffc
-#define REL_RELATIVE_PPC_3_MASK 0x3fffffc
-#define REL_INDIRECT_ARM_MASK 0xfff
-#define REL_RELATIVE_ARM_3_MASK 0xffffff
+static const cell rel_absolute_ppc_2_mask = 0xffff;
+static const cell rel_relative_ppc_2_mask = 0xfffc;
+static const cell rel_relative_ppc_3_mask = 0x3fffffc;
+static const cell rel_indirect_arm_mask = 0xfff;
+static const cell rel_relative_arm_3_mask = 0xffffff;
/* code relocation table consists of a table of entries for each fixup */
typedef u32 relocation_entry;
-#define REL_TYPE(r) (relocation_type)(((r) & 0xf0000000) >> 28)
-#define REL_CLASS(r) (relocation_class)(((r) & 0x0f000000) >> 24)
-#define REL_OFFSET(r) ((r) & 0x00ffffff)
void flush_icache_for(code_block *compiled);
diff --git a/vm/code_gc.cpp b/vm/code_gc.cpp
index 48cf8f7661..4710a1baa0 100755
--- a/vm/code_gc.cpp
+++ b/vm/code_gc.cpp
@@ -22,9 +22,9 @@ void new_heap(heap *heap, cell size)
static void add_to_free_list(heap *heap, free_heap_block *block)
{
- if(block->size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ if(block->size < free_list_count * block_size_increment)
{
- int index = block->size / BLOCK_SIZE_INCREMENT;
+ int index = block->size / block_size_increment;
block->next_free = heap->free.small_blocks[index];
heap->free.small_blocks[index] = block;
}
@@ -45,7 +45,7 @@ void build_free_list(heap *heap, cell size)
clear_free_list(heap);
- size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+ size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
heap_block *scan = first_block(heap);
free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
@@ -101,9 +101,9 @@ static free_heap_block *find_free_block(heap *heap, cell size)
{
cell attempt = size;
- while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT)
+ while(attempt < free_list_count * block_size_increment)
{
- int index = attempt / BLOCK_SIZE_INCREMENT;
+ int index = attempt / block_size_increment;
free_heap_block *block = heap->free.small_blocks[index];
if(block)
{
@@ -156,7 +156,7 @@ static free_heap_block *split_free_block(heap *heap, free_heap_block *block, cel
/* Allocate a block of memory from the mark and sweep GC heap */
heap_block *heap_allot(heap *heap, cell size)
{
- size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1);
+ size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
free_heap_block *block = find_free_block(heap,size);
if(block)
diff --git a/vm/code_gc.hpp b/vm/code_gc.hpp
index ebd6349ab9..1cfafb69c2 100755
--- a/vm/code_gc.hpp
+++ b/vm/code_gc.hpp
@@ -1,11 +1,11 @@
namespace factor
{
-#define FREE_LIST_COUNT 16
-#define BLOCK_SIZE_INCREMENT 32
+static const cell free_list_count = 16;
+static const cell block_size_increment = 32;
struct heap_free_list {
- free_heap_block *small_blocks[FREE_LIST_COUNT];
+ free_heap_block *small_blocks[free_list_count];
free_heap_block *large_blocks;
};
diff --git a/vm/contexts.cpp b/vm/contexts.cpp
index 239b70876a..b0a27ef18f 100644
--- a/vm/contexts.cpp
+++ b/vm/contexts.cpp
@@ -18,12 +18,12 @@ void reset_retainstack()
rs = rs_bot - sizeof(cell);
}
-#define RESERVED (64 * sizeof(cell))
+static const cell stack_reserved = (64 * sizeof(cell));
void fix_stacks()
{
- if(ds + sizeof(cell) < ds_bot || ds + RESERVED >= ds_top) reset_datastack();
- if(rs + sizeof(cell) < rs_bot || rs + RESERVED >= rs_top) reset_retainstack();
+ if(ds + sizeof(cell) < ds_bot || ds + stack_reserved >= ds_top) reset_datastack();
+ if(rs + sizeof(cell) < rs_bot || rs + stack_reserved >= rs_top) reset_retainstack();
}
/* called before entry into foreign C code. Note that ds and rs might
diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp
index ae7f93ebf7..b256b01c8b 100755
--- a/vm/cpu-ppc.hpp
+++ b/vm/cpu-ppc.hpp
@@ -27,7 +27,7 @@ inline static void check_call_site(cell return_address)
#endif
}
-#define B_MASK 0x3fffffc
+static const cell b_mask = 0x3fffffc;
inline static void *get_call_target(cell return_address)
{
diff --git a/vm/data_gc.cpp b/vm/data_gc.cpp
index c9dbe9a953..bcf6387639 100755
--- a/vm/data_gc.cpp
+++ b/vm/data_gc.cpp
@@ -9,15 +9,15 @@ bool performing_gc;
bool performing_compaction;
cell collecting_gen;
-/* if true, we collecting AGING space for the second time, so if it is still
-full, we go on to collect TENURED */
+/* if true, we collecting aging space for the second time, so if it is still
+full, we go on to collect tenured */
bool collecting_aging_again;
/* in case a generation fills up in the middle of a gc, we jump back
up to try collecting the next generation. */
jmp_buf gc_jmp;
-gc_stats stats[MAX_GEN_COUNT];
+gc_stats stats[max_gen_count];
u64 cards_scanned;
u64 decks_scanned;
u64 card_scan_time;
@@ -36,7 +36,7 @@ data_heap *old_data_heap;
void init_data_gc()
{
performing_gc = false;
- last_code_heap_scan = NURSERY;
+ last_code_heap_scan = data->nursery();
collecting_aging_again = false;
}
@@ -66,11 +66,11 @@ static bool should_copy_p(object *untagged)
{
if(in_zone(newspace,untagged))
return false;
- if(collecting_gen == TENURED)
+ if(collecting_gen == data->tenured())
return true;
- else if(HAVE_AGING_P && collecting_gen == AGING)
- return !in_zone(&data->generations[TENURED],untagged);
- else if(collecting_gen == NURSERY)
+ else if(data->have_aging_p() && collecting_gen == data->aging())
+ return !in_zone(&data->generations[data->tenured()],untagged);
+ else if(collecting_gen == data->nursery())
return in_zone(&nursery,untagged);
else
{
@@ -186,19 +186,19 @@ static void copy_gen_cards(cell gen)
/* if we are collecting the nursery, we care about old->nursery pointers
but not old->aging pointers */
- if(collecting_gen == NURSERY)
+ if(collecting_gen == data->nursery())
{
- mask = CARD_POINTS_TO_NURSERY;
+ mask = card_points_to_nursery;
/* after the collection, no old->nursery pointers remain
anywhere, but old->aging pointers might remain in tenured
space */
- if(gen == TENURED)
- unmask = CARD_POINTS_TO_NURSERY;
+ if(gen == data->tenured())
+ unmask = card_points_to_nursery;
/* after the collection, all cards in aging space can be
cleared */
- else if(HAVE_AGING_P && gen == AGING)
- unmask = CARD_MARK_MASK;
+ else if(data->have_aging_p() && gen == data->aging())
+ unmask = card_mark_mask;
else
{
critical_error("bug in copy_gen_cards",gen);
@@ -208,20 +208,20 @@ static void copy_gen_cards(cell gen)
/* if we are collecting aging space into tenured space, we care about
all old->nursery and old->aging pointers. no old->aging pointers can
remain */
- else if(HAVE_AGING_P && collecting_gen == AGING)
+ else if(data->have_aging_p() && collecting_gen == data->aging())
{
if(collecting_aging_again)
{
- mask = CARD_POINTS_TO_AGING;
- unmask = CARD_MARK_MASK;
+ mask = card_points_to_aging;
+ unmask = card_mark_mask;
}
/* after we collect aging space into the aging semispace, no
old->nursery pointers remain but tenured space might still have
pointers to aging space. */
else
{
- mask = CARD_POINTS_TO_AGING;
- unmask = CARD_POINTS_TO_NURSERY;
+ mask = card_points_to_aging;
+ unmask = card_points_to_nursery;
}
}
else
@@ -366,8 +366,8 @@ static cell copy_next_from_aging(cell scan)
{
obj++;
- cell tenured_start = data->generations[TENURED].start;
- cell tenured_end = data->generations[TENURED].end;
+ cell tenured_start = data->generations[data->tenured()].start;
+ cell tenured_end = data->generations[data->tenured()].end;
cell newspace_start = newspace->start;
cell newspace_end = newspace->end;
@@ -421,17 +421,17 @@ static cell copy_next_from_tenured(cell scan)
void copy_reachable_objects(cell scan, cell *end)
{
- if(collecting_gen == NURSERY)
+ if(collecting_gen == data->nursery())
{
while(scan < *end)
scan = copy_next_from_nursery(scan);
}
- else if(HAVE_AGING_P && collecting_gen == AGING)
+ else if(data->have_aging_p() && collecting_gen == data->aging())
{
while(scan < *end)
scan = copy_next_from_aging(scan);
}
- else if(collecting_gen == TENURED)
+ else if(collecting_gen == data->tenured())
{
while(scan < *end)
scan = copy_next_from_tenured(scan);
@@ -443,12 +443,12 @@ static void begin_gc(cell requested_bytes)
{
if(growing_data_heap)
{
- if(collecting_gen != TENURED)
+ if(collecting_gen != data->tenured())
critical_error("Invalid parameters to begin_gc",0);
old_data_heap = data;
set_data_heap(grow_data_heap(old_data_heap,requested_bytes));
- newspace = &data->generations[TENURED];
+ newspace = &data->generations[data->tenured()];
}
else if(collecting_accumulation_gen_p())
{
@@ -491,12 +491,12 @@ static void end_gc(cell gc_elapsed)
if(collecting_accumulation_gen_p())
{
/* all younger generations except are now empty.
- if collecting_gen == NURSERY here, we only have 1 generation;
+ if collecting_gen == data->nursery() here, we only have 1 generation;
old-school Cheney collector */
- if(collecting_gen != NURSERY)
- reset_generations(NURSERY,collecting_gen - 1);
+ if(collecting_gen != data->nursery())
+ reset_generations(data->nursery(),collecting_gen - 1);
}
- else if(collecting_gen == NURSERY)
+ else if(collecting_gen == data->nursery())
{
nursery.here = nursery.start;
}
@@ -504,7 +504,7 @@ static void end_gc(cell gc_elapsed)
{
/* all generations up to and including the one
collected are now empty */
- reset_generations(NURSERY,collecting_gen);
+ reset_generations(data->nursery(),collecting_gen);
}
collecting_aging_again = false;
@@ -534,17 +534,17 @@ void garbage_collection(cell gen,
{
/* We have no older generations we can try collecting, so we
resort to growing the data heap */
- if(collecting_gen == TENURED)
+ if(collecting_gen == data->tenured())
{
growing_data_heap = true;
/* see the comment in unmark_marked() */
unmark_marked(&code);
}
- /* we try collecting AGING space twice before going on to
- collect TENURED */
- else if(HAVE_AGING_P
- && collecting_gen == AGING
+ /* we try collecting aging space twice before going on to
+ collect tenured */
+ else if(data->have_aging_p()
+ && collecting_gen == data->aging()
&& !collecting_aging_again)
{
collecting_aging_again = true;
@@ -575,7 +575,7 @@ void garbage_collection(cell gen,
{
code_heap_scans++;
- if(collecting_gen == TENURED)
+ if(collecting_gen == data->tenured())
free_unmarked(&code,(heap_iterator)update_literal_and_word_references);
else
copy_code_heap_roots();
@@ -595,7 +595,7 @@ void garbage_collection(cell gen,
void gc()
{
- garbage_collection(TENURED,false,0);
+ garbage_collection(data->tenured(),false,0);
}
PRIMITIVE(gc)
@@ -610,7 +610,7 @@ PRIMITIVE(gc_stats)
cell i;
u64 total_gc_time = 0;
- for(i = 0; i < MAX_GEN_COUNT; i++)
+ for(i = 0; i < max_gen_count; i++)
{
gc_stats *s = &stats[i];
result.add(allot_cell(s->collections));
@@ -635,8 +635,7 @@ PRIMITIVE(gc_stats)
void clear_gc_stats()
{
- int i;
- for(i = 0; i < MAX_GEN_COUNT; i++)
+ for(cell i = 0; i < max_gen_count; i++)
memset(&stats[i],0,sizeof(gc_stats));
cards_scanned = 0;
@@ -683,7 +682,7 @@ PRIMITIVE(become)
VM_C_API void minor_gc()
{
- garbage_collection(NURSERY,false,0);
+ garbage_collection(data->nursery(),false,0);
}
}
diff --git a/vm/data_gc.hpp b/vm/data_gc.hpp
index 01bff2ef68..2d6a1ab897 100755
--- a/vm/data_gc.hpp
+++ b/vm/data_gc.hpp
@@ -24,10 +24,10 @@ void gc();
inline static bool collecting_accumulation_gen_p()
{
- return ((HAVE_AGING_P
- && collecting_gen == AGING
+ return ((data->have_aging_p()
+ && collecting_gen == data->aging()
&& !collecting_aging_again)
- || collecting_gen == TENURED);
+ || collecting_gen == data->tenured());
}
void copy_handle(cell *handle);
@@ -39,7 +39,7 @@ void garbage_collection(volatile cell gen,
/* We leave this many bytes free at the top of the nursery so that inline
allocation (which does not call GC because of possible roots in volatile
registers) does not run out of memory */
-#define ALLOT_BUFFER_ZONE 1024
+static const cell allot_buffer_zone = 1024;
inline static object *allot_zone(zone *z, cell a)
{
@@ -63,11 +63,11 @@ inline static object *allot_object(header header, cell size)
object *obj;
- if(nursery.size - ALLOT_BUFFER_ZONE > size)
+ if(nursery.size - allot_buffer_zone > size)
{
/* If there is insufficient room, collect the nursery */
- if(nursery.here + ALLOT_BUFFER_ZONE + size > nursery.end)
- garbage_collection(NURSERY,false,0);
+ if(nursery.here + allot_buffer_zone + size > nursery.end)
+ garbage_collection(data->nursery(),false,0);
cell h = nursery.here;
nursery.here = h + align8(size);
@@ -77,20 +77,20 @@ inline static object *allot_object(header header, cell size)
tenured space */
else
{
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
/* If tenured space does not have enough room, collect */
if(tenured->here + size > tenured->end)
{
gc();
- tenured = &data->generations[TENURED];
+ tenured = &data->generations[data->tenured()];
}
/* If it still won't fit, grow the heap */
if(tenured->here + size > tenured->end)
{
- garbage_collection(TENURED,true,size);
- tenured = &data->generations[TENURED];
+ garbage_collection(data->tenured(),true,size);
+ tenured = &data->generations[data->tenured()];
}
obj = allot_zone(tenured,size);
diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp
index 9c84a993c8..d921d373da 100755
--- a/vm/data_heap.cpp
+++ b/vm/data_heap.cpp
@@ -26,10 +26,10 @@ cell init_zone(zone *z, cell size, cell start)
void init_card_decks()
{
- cell start = align(data->seg->start,DECK_SIZE);
- allot_markers_offset = (cell)data->allot_markers - (start >> CARD_BITS);
- cards_offset = (cell)data->cards - (start >> CARD_BITS);
- decks_offset = (cell)data->decks - (start >> DECK_BITS);
+ cell start = align(data->seg->start,deck_size);
+ allot_markers_offset = (cell)data->allot_markers - (start >> card_bits);
+ cards_offset = (cell)data->cards - (start >> card_bits);
+ decks_offset = (cell)data->decks - (start >> deck_bits);
}
data_heap *alloc_data_heap(cell gens,
@@ -37,9 +37,9 @@ data_heap *alloc_data_heap(cell gens,
cell aging_size,
cell tenured_size)
{
- young_size = align(young_size,DECK_SIZE);
- aging_size = align(aging_size,DECK_SIZE);
- tenured_size = align(tenured_size,DECK_SIZE);
+ young_size = align(young_size,deck_size);
+ aging_size = align(aging_size,deck_size);
+ tenured_size = align(tenured_size,deck_size);
data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
data->young_size = young_size;
@@ -58,42 +58,42 @@ data_heap *alloc_data_heap(cell gens,
return NULL; /* can't happen */
}
- total_size += DECK_SIZE;
+ total_size += deck_size;
data->seg = alloc_segment(total_size);
data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
- cell cards_size = total_size >> CARD_BITS;
+ cell cards_size = total_size >> card_bits;
data->allot_markers = (cell *)safe_malloc(cards_size);
data->allot_markers_end = data->allot_markers + cards_size;
data->cards = (cell *)safe_malloc(cards_size);
data->cards_end = data->cards + cards_size;
- cell decks_size = total_size >> DECK_BITS;
+ cell decks_size = total_size >> deck_bits;
data->decks = (cell *)safe_malloc(decks_size);
data->decks_end = data->decks + decks_size;
- cell alloter = align(data->seg->start,DECK_SIZE);
+ cell alloter = align(data->seg->start,deck_size);
- alloter = init_zone(&data->generations[TENURED],tenured_size,alloter);
- alloter = init_zone(&data->semispaces[TENURED],tenured_size,alloter);
+ alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter);
+ alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter);
if(data->gen_count == 3)
{
- alloter = init_zone(&data->generations[AGING],aging_size,alloter);
- alloter = init_zone(&data->semispaces[AGING],aging_size,alloter);
+ alloter = init_zone(&data->generations[data->aging()],aging_size,alloter);
+ alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter);
}
if(data->gen_count >= 2)
{
- alloter = init_zone(&data->generations[NURSERY],young_size,alloter);
- alloter = init_zone(&data->semispaces[NURSERY],0,alloter);
+ alloter = init_zone(&data->generations[data->nursery()],young_size,alloter);
+ alloter = init_zone(&data->semispaces[data->nursery()],0,alloter);
}
- if(data->seg->end - alloter > DECK_SIZE)
+ if(data->seg->end - alloter > deck_size)
critical_error("Bug in alloc_data_heap",alloter);
return data;
@@ -141,12 +141,12 @@ void clear_allot_markers(cell from, cell to)
/* NOTE: reverse order due to heap layout. */
card *first_card = addr_to_allot_marker((object *)data->generations[to].start);
card *last_card = addr_to_allot_marker((object *)data->generations[from].end);
- memset(first_card,INVALID_ALLOT_MARKER,last_card - first_card);
+ memset(first_card,invalid_allot_marker,last_card - first_card);
}
void reset_generation(cell i)
{
- zone *z = (i == NURSERY ? &nursery : &data->generations[i]);
+ zone *z = (i == data->nursery() ? &nursery : &data->generations[i]);
z->here = z->start;
if(secure_gc)
@@ -169,11 +169,11 @@ void reset_generations(cell from, cell to)
void set_data_heap(data_heap *data_)
{
data = data_;
- nursery = data->generations[NURSERY];
+ nursery = data->generations[data->nursery()];
init_card_decks();
- clear_cards(NURSERY,TENURED);
- clear_decks(NURSERY,TENURED);
- clear_allot_markers(NURSERY,TENURED);
+ clear_cards(data->nursery(),data->tenured());
+ clear_decks(data->nursery(),data->tenured());
+ clear_allot_markers(data->nursery(),data->tenured());
}
void init_data_heap(cell gens,
@@ -298,7 +298,7 @@ PRIMITIVE(data_room)
cell gen;
for(gen = 0; gen < data->gen_count; gen++)
{
- zone *z = (gen == NURSERY ? &nursery : &data->generations[gen]);
+ zone *z = (gen == data->nursery() ? &nursery : &data->generations[gen]);
a.add(tag_fixnum((z->end - z->here) >> 10));
a.add(tag_fixnum((z->size) >> 10));
}
@@ -314,7 +314,7 @@ cell heap_scan_ptr;
/* Disables GC and activates next-object ( -- obj ) primitive */
void begin_scan()
{
- heap_scan_ptr = data->generations[TENURED].start;
+ heap_scan_ptr = data->generations[data->tenured()].start;
gc_off = true;
}
@@ -328,7 +328,7 @@ cell next_object()
if(!gc_off)
general_error(ERROR_HEAP_SCAN,F,F,NULL);
- if(heap_scan_ptr >= data->generations[TENURED].here)
+ if(heap_scan_ptr >= data->generations[data->tenured()].here)
return F;
object *obj = (object *)heap_scan_ptr;
diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp
index bec86a2d0d..567c8f9944 100644
--- a/vm/data_heap.hpp
+++ b/vm/data_heap.hpp
@@ -34,20 +34,22 @@ struct data_heap {
cell *decks;
cell *decks_end;
+
+ /* the 0th generation is where new objects are allocated. */
+ cell nursery() { return 0; }
+
+ /* where objects hang around */
+ cell aging() { return gen_count - 2; }
+
+ /* the oldest generation */
+ cell tenured() { return gen_count - 1; }
+
+ bool have_aging_p() { return gen_count > 2; }
};
extern data_heap *data;
-/* the 0th generation is where new objects are allocated. */
-#define NURSERY 0
-/* where objects hang around */
-#define AGING (data->gen_count-2)
-#define HAVE_AGING_P (data->gen_count>2)
-/* the oldest generation */
-#define TENURED (data->gen_count-1)
-
-#define MIN_GEN_COUNT 1
-#define MAX_GEN_COUNT 3
+static const cell max_gen_count = 3;
inline static bool in_zone(zone *z, object *pointer)
{
diff --git a/vm/image.cpp b/vm/image.cpp
index fd547cca50..9205aad260 100755
--- a/vm/image.cpp
+++ b/vm/image.cpp
@@ -31,7 +31,7 @@ static void load_data_heap(FILE *file, image_header *h, vm_parameters *p)
clear_gc_stats();
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
fixnum bytes_read = fread((void*)tenured->start,1,h->data_size,file);
@@ -92,10 +92,10 @@ bool save_image(const vm_char *filename)
return false;
}
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
- h.magic = IMAGE_MAGIC;
- h.version = IMAGE_VERSION;
+ h.magic = image_magic;
+ h.version = image_version;
h.data_relocation_base = tenured->start;
h.data_size = tenured->here - tenured->start;
h.code_relocation_base = code.seg->start;
@@ -165,7 +165,7 @@ static void data_fixup(cell *cell)
if(immediate_p(*cell))
return;
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
*cell += (tenured->start - data_relocation_base);
}
@@ -271,7 +271,7 @@ void relocate_data()
data_fixup(&bignum_pos_one);
data_fixup(&bignum_neg_one);
- zone *tenured = &data->generations[TENURED];
+ zone *tenured = &data->generations[data->tenured()];
for(relocating = tenured->start;
relocating < tenured->here;
@@ -313,10 +313,10 @@ void load_image(vm_parameters *p)
if(fread(&h,sizeof(image_header),1,file) != 1)
fatal_error("Cannot read image header",0);
- if(h.magic != IMAGE_MAGIC)
+ if(h.magic != image_magic)
fatal_error("Bad image: magic number check failed",h.magic);
- if(h.version != IMAGE_VERSION)
+ if(h.version != image_version)
fatal_error("Bad image: version number check failed",h.version);
load_data_heap(file,&h,p);
diff --git a/vm/image.hpp b/vm/image.hpp
index c306f322de..807a7a6bcf 100755
--- a/vm/image.hpp
+++ b/vm/image.hpp
@@ -1,8 +1,8 @@
namespace factor
{
-#define IMAGE_MAGIC 0x0f0e0d0c
-#define IMAGE_VERSION 4
+static const cell image_magic = 0x0f0e0d0c;
+static const cell image_version = 4;
struct image_header {
cell magic;
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
index f8d114210a..42fba35741 100755
--- a/vm/layouts.hpp
+++ b/vm/layouts.hpp
@@ -23,8 +23,15 @@ inline static cell align(cell a, cell b)
return (a + (b-1)) & ~(b-1);
}
-#define align8(a) align(a,8)
-#define align_page(a) align(a,getpagesize())
+inline static cell align8(cell a)
+{
+ return align(a,8);
+}
+
+inline static cell align_page(cell a)
+{
+ return align(a,getpagesize());
+}
#define WORD_SIZE (signed)(sizeof(cell)*8)
@@ -297,12 +304,6 @@ struct dll : public object {
void *dll;
};
-struct callstack : public object {
- static const cell type_number = CALLSTACK_TYPE;
- /* tagged */
- cell length;
-};
-
struct stack_frame
{
void *xt;
@@ -310,6 +311,15 @@ struct stack_frame
cell size;
};
+struct callstack : public object {
+ static const cell type_number = CALLSTACK_TYPE;
+ /* tagged */
+ cell length;
+
+ stack_frame *top() { return (stack_frame *)(this + 1); }
+ stack_frame *bottom() { return (stack_frame *)((cell)(this + 1) + untag_fixnum(length)); }
+};
+
struct tuple : public object {
static const cell type_number = TUPLE_TYPE;
/* tagged layout */
diff --git a/vm/math.cpp b/vm/math.cpp
index 7a2abe7463..76f2c88f38 100755
--- a/vm/math.cpp
+++ b/vm/math.cpp
@@ -24,8 +24,8 @@ PRIMITIVE(fixnum_divint)
fixnum y = untag_fixnum(dpop()); \
fixnum x = untag_fixnum(dpeek());
fixnum result = x / y;
- if(result == -FIXNUM_MIN)
- drepl(allot_integer(-FIXNUM_MIN));
+ if(result == -fixnum_min)
+ drepl(allot_integer(-fixnum_min));
else
drepl(tag_fixnum(result));
}
@@ -34,9 +34,9 @@ PRIMITIVE(fixnum_divmod)
{
cell y = ((cell *)ds)[0];
cell x = ((cell *)ds)[-1];
- if(y == tag_fixnum(-1) && x == tag_fixnum(FIXNUM_MIN))
+ if(y == tag_fixnum(-1) && x == tag_fixnum(fixnum_min))
{
- ((cell *)ds)[-1] = allot_integer(-FIXNUM_MIN);
+ ((cell *)ds)[-1] = allot_integer(-fixnum_min);
((cell *)ds)[0] = tag_fixnum(0);
}
else
@@ -50,9 +50,20 @@ PRIMITIVE(fixnum_divmod)
* If we're shifting right by n bits, we won't overflow as long as none of the
* high WORD_SIZE-TAG_BITS-n bits are set.
*/
-#define SIGN_MASK(x) ((x) >> (WORD_SIZE - 1))
-#define BRANCHLESS_MAX(x,y) ((x) - (((x) - (y)) & SIGN_MASK((x) - (y))))
-#define BRANCHLESS_ABS(x) ((x ^ SIGN_MASK(x)) - SIGN_MASK(x))
+static inline fixnum sign_mask(fixnum x)
+{
+ return x >> (WORD_SIZE - 1);
+}
+
+static inline fixnum branchless_max(fixnum x, fixnum y)
+{
+ return (x - ((x - y) & sign_mask(x - y)));
+}
+
+static inline fixnum branchless_abs(fixnum x)
+{
+ return (x ^ sign_mask(x)) - sign_mask(x);
+}
PRIMITIVE(fixnum_shift)
{
@@ -63,14 +74,14 @@ PRIMITIVE(fixnum_shift)
return;
else if(y < 0)
{
- y = BRANCHLESS_MAX(y,-WORD_SIZE + 1);
+ y = branchless_max(y,-WORD_SIZE + 1);
drepl(tag_fixnum(x >> -y));
return;
}
else if(y < WORD_SIZE - TAG_BITS)
{
fixnum mask = -((fixnum)1 << (WORD_SIZE - 1 - TAG_BITS - y));
- if(!(BRANCHLESS_ABS(x) & mask))
+ if(!(branchless_abs(x) & mask))
{
drepl(tag_fixnum(x << y));
return;
@@ -226,7 +237,7 @@ cell unbox_array_size()
case FIXNUM_TYPE:
{
fixnum n = untag_fixnum(dpeek());
- if(n >= 0 && n < (fixnum)ARRAY_SIZE_MAX)
+ if(n >= 0 && n < (fixnum)array_size_max)
{
dpop();
return n;
@@ -236,7 +247,7 @@ cell unbox_array_size()
case BIGNUM_TYPE:
{
bignum * zero = untag<bignum>(bignum_zero);
- bignum * max = cell_to_bignum(ARRAY_SIZE_MAX);
+ bignum * max = cell_to_bignum(array_size_max);
bignum * n = untag<bignum>(dpeek());
if(bignum_compare(n,zero) != bignum_comparison_less
&& bignum_compare(n,max) == bignum_comparison_less)
@@ -248,7 +259,7 @@ cell unbox_array_size()
}
}
- general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(ARRAY_SIZE_MAX),NULL);
+ general_error(ERROR_ARRAY_SIZE,dpop(),tag_fixnum(array_size_max),NULL);
return 0; /* can't happen */
}
@@ -428,7 +439,7 @@ VM_C_API void box_unsigned_cell(cell cell)
VM_C_API void box_signed_8(s64 n)
{
- if(n < FIXNUM_MIN || n > FIXNUM_MAX)
+ if(n < fixnum_min || n > fixnum_max)
dpush(tag<bignum>(long_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
@@ -450,7 +461,7 @@ VM_C_API s64 to_signed_8(cell obj)
VM_C_API void box_unsigned_8(u64 n)
{
- if(n > FIXNUM_MAX)
+ if(n > fixnum_max)
dpush(tag<bignum>(ulong_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
diff --git a/vm/math.hpp b/vm/math.hpp
index 198960d3b5..7828aa3e6c 100644
--- a/vm/math.hpp
+++ b/vm/math.hpp
@@ -5,10 +5,9 @@ extern cell bignum_zero;
extern cell bignum_pos_one;
extern cell bignum_neg_one;
-#define cell_MAX (cell)(-1)
-#define FIXNUM_MAX (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1)
-#define FIXNUM_MIN (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)))
-#define ARRAY_SIZE_MAX ((cell)1 << (WORD_SIZE - TAG_BITS - 2))
+static const fixnum fixnum_max = (((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)) - 1);
+static const fixnum fixnum_min = (-((fixnum)1 << (WORD_SIZE - TAG_BITS - 1)));
+static const fixnum array_size_max = ((cell)1 << (WORD_SIZE - TAG_BITS - 2));
PRIMITIVE(fixnum_add);
PRIMITIVE(fixnum_subtract);
@@ -45,7 +44,7 @@ PRIMITIVE(byte_array_to_bignum);
inline static cell allot_integer(fixnum x)
{
- if(x < FIXNUM_MIN || x > FIXNUM_MAX)
+ if(x < fixnum_min || x > fixnum_max)
return tag<bignum>(fixnum_to_bignum(x));
else
return tag_fixnum(x);
@@ -53,7 +52,7 @@ inline static cell allot_integer(fixnum x)
inline static cell allot_cell(cell x)
{
- if(x > (cell)FIXNUM_MAX)
+ if(x > (cell)fixnum_max)
return tag<bignum>(cell_to_bignum(x));
else
return tag_fixnum(x);
diff --git a/vm/write_barrier.hpp b/vm/write_barrier.hpp
index eaede538ed..0006581034 100755
--- a/vm/write_barrier.hpp
+++ b/vm/write_barrier.hpp
@@ -12,24 +12,24 @@ VM_C_API factor::cell decks_offset;
namespace factor
{
-/* if CARD_POINTS_TO_NURSERY is set, CARD_POINTS_TO_AGING must also be set. */
-#define CARD_POINTS_TO_NURSERY 0x80
-#define CARD_POINTS_TO_AGING 0x40
-#define CARD_MARK_MASK (CARD_POINTS_TO_NURSERY | CARD_POINTS_TO_AGING)
+/* if card_points_to_nursery is set, card_points_to_aging must also be set. */
+static const cell card_points_to_nursery = 0x80;
+static const cell card_points_to_aging = 0x40;
+static const cell card_mark_mask = (card_points_to_nursery | card_points_to_aging);
typedef u8 card;
-#define CARD_BITS 8
-#define CARD_SIZE (1<<CARD_BITS)
-#define ADDR_CARD_MASK (CARD_SIZE-1)
+static const cell card_bits = 8;
+static const cell card_size = (1<<card_bits);
+static const cell addr_card_mask = (card_size-1);
inline static card *addr_to_card(cell a)
{
- return (card*)(((cell)(a) >> CARD_BITS) + cards_offset);
+ return (card*)(((cell)(a) >> card_bits) + cards_offset);
}
inline static cell card_to_addr(card *c)
{
- return ((cell)c - cards_offset) << CARD_BITS;
+ return ((cell)c - cards_offset) << card_bits;
}
inline static cell card_offset(card *c)
@@ -39,48 +39,48 @@ inline static cell card_offset(card *c)
typedef u8 card_deck;
-#define DECK_BITS (CARD_BITS + 10)
-#define DECK_SIZE (1<<DECK_BITS)
-#define ADDR_DECK_MASK (DECK_SIZE-1)
+static const cell deck_bits = (card_bits + 10);
+static const cell deck_size = (1<<deck_bits);
+static const cell addr_deck_mask = (deck_size-1);
inline static card_deck *addr_to_deck(cell a)
{
- return (card_deck *)(((cell)a >> DECK_BITS) + decks_offset);
+ return (card_deck *)(((cell)a >> deck_bits) + decks_offset);
}
inline static cell deck_to_addr(card_deck *c)
{
- return ((cell)c - decks_offset) << DECK_BITS;
+ return ((cell)c - decks_offset) << deck_bits;
}
inline static card *deck_to_card(card_deck *d)
{
- return (card *)((((cell)d - decks_offset) << (DECK_BITS - CARD_BITS)) + cards_offset);
+ return (card *)((((cell)d - decks_offset) << (deck_bits - card_bits)) + cards_offset);
}
-#define INVALID_ALLOT_MARKER 0xff
+static const cell invalid_allot_marker = 0xff;
extern cell allot_markers_offset;
inline static card *addr_to_allot_marker(object *a)
{
- return (card *)(((cell)a >> CARD_BITS) + allot_markers_offset);
+ return (card *)(((cell)a >> card_bits) + allot_markers_offset);
}
/* the write barrier must be called any time we are potentially storing a
pointer from an older generation to a younger one */
inline static void write_barrier(object *obj)
{
- *addr_to_card((cell)obj) = CARD_MARK_MASK;
- *addr_to_deck((cell)obj) = CARD_MARK_MASK;
+ *addr_to_card((cell)obj) = card_mark_mask;
+ *addr_to_deck((cell)obj) = card_mark_mask;
}
/* we need to remember the first object allocated in the card */
inline static void allot_barrier(object *address)
{
card *ptr = addr_to_allot_marker(address);
- if(*ptr == INVALID_ALLOT_MARKER)
- *ptr = ((cell)address & ADDR_CARD_MASK);
+ if(*ptr == invalid_allot_marker)
+ *ptr = ((cell)address & addr_card_mask);
}
}
From 9992817c65c323ede1ca552d7781601604227294 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 8 May 2009 15:07:15 -0500
Subject: [PATCH 28/72] input grabbing support
---
basis/core-graphics/core-graphics.factor | 9 +++++++++
basis/core-graphics/types/types.factor | 5 ++++-
basis/math/rectangles/rectangles.factor | 2 ++
basis/ui/backend/backend.factor | 6 +++++-
basis/ui/backend/cocoa/cocoa.factor | 11 +++++++++++
basis/ui/backend/windows/windows.factor | 8 ++++++++
basis/ui/gadgets/worlds/worlds.factor | 7 +++++--
basis/ui/ui.factor | 15 ++++++++++++---
basis/windows/user32/user32.factor | 4 ++--
extra/terrain/terrain.factor | 1 +
10 files changed, 59 insertions(+), 9 deletions(-)
diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor
index 5e95e2e36e..924f7130f0 100644
--- a/basis/core-graphics/core-graphics.factor
+++ b/basis/core-graphics/core-graphics.factor
@@ -105,6 +105,15 @@ CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
+FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
+
+FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
+FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
+
+FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
+
+FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
+
<PRIVATE
: bitmap-flags ( -- flags )
diff --git a/basis/core-graphics/types/types.factor b/basis/core-graphics/types/types.factor
index 13e4285ea1..0acdad9c0c 100644
--- a/basis/core-graphics/types/types.factor
+++ b/basis/core-graphics/types/types.factor
@@ -90,5 +90,8 @@ TYPEDEF: void* CGContextRef
TYPEDEF: uint CGBitmapInfo
TYPEDEF: int CGLError
+TYPEDEF: int CGError
+TYPEDEF: uint CGDirectDisplayID
+TYPEDEF: int boolean_t
TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
\ No newline at end of file
+TYPEDEF: int CGLContextParameter
diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor
index 90174d144e..340eafa37d 100644
--- a/basis/math/rectangles/rectangles.factor
+++ b/basis/math/rectangles/rectangles.factor
@@ -21,6 +21,8 @@ M: rect pprint*
: rect-extent ( rect -- loc ext ) rect-bounds over v+ ;
+: rect-center ( rect -- center ) rect-bounds 2 v/n v+ ;
+
: with-rect-extents ( rect1 rect2 loc-quot: ( loc1 loc2 -- ) ext-quot: ( ext1 ext2 -- ) -- )
[ [ rect-extent ] bi@ ] 2dip bi-curry* bi* ; inline
diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor
index 9c844d3663..63d551798c 100755
--- a/basis/ui/backend/backend.factor
+++ b/basis/ui/backend/backend.factor
@@ -31,4 +31,8 @@ HOOK: offscreen-pixels ui-backend ( world -- alien w h )
'[ select-gl-context @ ]
[ flush-gl-context gl-error ] bi ; inline
-HOOK: (with-ui) ui-backend ( quot -- )
\ No newline at end of file
+HOOK: (with-ui) ui-backend ( quot -- )
+
+HOOK: (grab-input) ui-backend ( handle -- )
+
+HOOK: (ungrab-input) ui-backend ( handle -- )
diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor
index ef5c80dcdb..47a3bfc1a6 100755
--- a/basis/ui/backend/cocoa/cocoa.factor
+++ b/basis/ui/backend/cocoa/cocoa.factor
@@ -122,6 +122,17 @@ M:: cocoa-ui-backend (open-window) ( world -- )
M: cocoa-ui-backend (close-window) ( handle -- )
window>> -> release ;
+M: cocoa-ui-backend (grab-input) ( handle -- )
+ 0 CGAssociateMouseAndMouseCursorPosition drop
+ CGMainDisplayID CGDisplayHideCursor drop
+ window>> -> frame CGRect>rect rect-center
+ first2 <CGPoint> CGWarpMouseCursorPosition drop ;
+
+M: cocoa-ui-backend (ungrab-input) ( handle -- )
+ drop
+ CGMainDisplayID CGDisplayShowCursor drop
+ 1 CGAssociateMouseAndMouseCursorPosition drop ;
+
M: cocoa-ui-backend close-window ( gadget -- )
find-world [
handle>> [
diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index 24ae72740f..c2d330b9dd 100755
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -706,6 +706,14 @@ M: windows-ui-backend beep ( -- )
: hwnd>RECT ( hwnd -- RECT )
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
+M: windows-ui-backend (grab-input) ( handle -- )
+ 0 ShowCursor drop
+ hWnd>> hwnd>RECT ClipCursor drop ;
+M: windows-ui-backend (ungrab-input) ( handle -- )
+ drop
+ f ClipCursor drop
+ 1 ShowCursor drop ;
+
: fullscreen-flags ( -- n )
{ WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 3568559eac..eec5666f0e 100755
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -11,7 +11,7 @@ CONSTANT: default-world-pixel-format-attributes
{ windowed double-buffered T{ depth-bits { value 16 } } }
TUPLE: world < track
- active? focused?
+ active? focused? grab-input?
layers
title status status-owner
text-handle handle images
@@ -20,6 +20,7 @@ TUPLE: world < track
TUPLE: world-attributes
{ world-class initial: world }
+ grab-input?
title
status
gadgets
@@ -63,13 +64,15 @@ M: world request-focus-on ( child gadget -- )
vertical swap new-track
t >>root?
t >>active?
- { 0 0 } >>window-loc ;
+ { 0 0 } >>window-loc
+ f >>grab-input? ;
: apply-world-attributes ( world attributes -- world )
{
[ title>> >>title ]
[ status>> >>status ]
[ pixel-format-attributes>> >>pixel-format-attributes ]
+ [ grab-input?>> >>grab-input? ]
[ gadgets>> [ 1 track-add ] each ]
} cleave ;
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index b73de68e26..d53d4c6753 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -41,14 +41,23 @@ SYMBOL: windows
lose-focus swap each-gesture
gain-focus swap each-gesture ;
+: ?grab-input ( world -- )
+ dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
+
+: ?ungrab-input ( world -- )
+ dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
+
: focus-world ( world -- )
t >>focused?
- dup raised-window
- focus-path f focus-gestures ;
+ [ ?grab-input ] [
+ dup raised-window
+ focus-path f focus-gestures
+ ] bi ;
: unfocus-world ( world -- )
f >>focused?
- focus-path f swap focus-gestures ;
+ [ ?ungrab-input ]
+ [ focus-path f swap focus-gestures ] bi ;
: try-to-open-window ( world -- )
{
diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor
index 1e694bcbe4..b6caa7c039 100644
--- a/basis/windows/user32/user32.factor
+++ b/basis/windows/user32/user32.factor
@@ -654,7 +654,7 @@ FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ;
! FUNCTION: ClientThreadSetup
! FUNCTION: ClientToScreen
! FUNCTION: CliImmSetHotKey
-! FUNCTION: ClipCursor
+FUNCTION: int ClipCursor ( RECT* clipRect ) ;
FUNCTION: BOOL CloseClipboard ( ) ;
! FUNCTION: CloseDesktop
! FUNCTION: CloseWindow
@@ -1363,7 +1363,7 @@ CONSTANT: HWND_TOP f
! FUNCTION: SetWindowWord
! FUNCTION: SetWinEventHook
! FUNCTION: ShowCaret
-! FUNCTION: ShowCursor
+FUNCTION: int ShowCursor ( BOOL show ) ;
! FUNCTION: ShowOwnedPopups
! FUNCTION: ShowScrollBar
! FUNCTION: ShowStartGlass
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index 50c88d6f00..3f94b93138 100644
--- a/extra/terrain/terrain.factor
+++ b/extra/terrain/terrain.factor
@@ -186,5 +186,6 @@ M: terrain-world pref-dim* drop { 640 480 } ;
double-buffered
T{ depth-bits { value 24 } }
} }
+ { grab-input? t }
} open-window
] with-ui ;
From ace084b633ecff0f2a673e235eccad7fce719389 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 May 2009 15:15:10 -0500
Subject: [PATCH 29/72] Need to include unistd.h
---
vm/master.hpp | 1 +
1 file changed, 1 insertion(+)
diff --git a/vm/master.hpp b/vm/master.hpp
index 6409d65494..6164c9ea30 100755
--- a/vm/master.hpp
+++ b/vm/master.hpp
@@ -19,6 +19,7 @@
#include <stdlib.h>
#include <string.h>
#include <time.h>
+#include <unistd.h>
#include <sys/param.h>
/* C++ headers */
From 367724f41e8182013a9affdca7e6663d253b7e0e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 May 2009 15:23:44 -0500
Subject: [PATCH 30/72] Fix Windows compile error
---
vm/layouts.hpp | 5 -----
vm/math.cpp | 2 +-
vm/segments.hpp | 5 +++++
3 files changed, 6 insertions(+), 6 deletions(-)
diff --git a/vm/layouts.hpp b/vm/layouts.hpp
index 42fba35741..40fd699e18 100755
--- a/vm/layouts.hpp
+++ b/vm/layouts.hpp
@@ -28,11 +28,6 @@ inline static cell align8(cell a)
return align(a,8);
}
-inline static cell align_page(cell a)
-{
- return align(a,getpagesize());
-}
-
#define WORD_SIZE (signed)(sizeof(cell)*8)
#define TAG_MASK 7
diff --git a/vm/math.cpp b/vm/math.cpp
index 76f2c88f38..eff129a5c9 100755
--- a/vm/math.cpp
+++ b/vm/math.cpp
@@ -461,7 +461,7 @@ VM_C_API s64 to_signed_8(cell obj)
VM_C_API void box_unsigned_8(u64 n)
{
- if(n > fixnum_max)
+ if(n > (u64)fixnum_max)
dpush(tag<bignum>(ulong_long_to_bignum(n)));
else
dpush(tag_fixnum(n));
diff --git a/vm/segments.hpp b/vm/segments.hpp
index a715b4dabc..36b5bc747b 100644
--- a/vm/segments.hpp
+++ b/vm/segments.hpp
@@ -7,4 +7,9 @@ struct segment {
cell end;
};
+inline static cell align_page(cell a)
+{
+ return align(a,getpagesize());
+}
+
}
From 2295c967fab18d4f40147cc3d4d85c86e6da4ed9 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 8 May 2009 15:49:29 -0500
Subject: [PATCH 31/72] clip to window client area when grabbing on windows
---
basis/ui/backend/windows/windows.factor | 10 ++++++++--
1 file changed, 8 insertions(+), 2 deletions(-)
diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index c2d330b9dd..ba4926d97e 100755
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations
command-line shuffle opengl ui.render ascii math.bitwise locals
accessors math.rectangles math.order ascii calendar
io.encodings.utf16n windows.errors literals ui.pixel-formats
-ui.pixel-formats.private memoize classes ;
+ui.pixel-formats.private memoize classes struct-arrays ;
IN: ui.backend.windows
SINGLETON: windows-ui-backend
@@ -703,12 +703,18 @@ M: windows-ui-backend beep ( -- )
"MONITORINFOEX" <c-object> dup length over set-MONITORINFOEX-cbSize
[ GetMonitorInfo win32-error=0/f ] keep MONITORINFOEX-rcMonitor ;
+: client-area>RECT ( hwnd -- RECT )
+ "RECT" <c-object>
+ [ GetClientRect win32-error=0/f ]
+ [ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
+ [ nip ] 2tri ;
+
: hwnd>RECT ( hwnd -- RECT )
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep ;
M: windows-ui-backend (grab-input) ( handle -- )
0 ShowCursor drop
- hWnd>> hwnd>RECT ClipCursor drop ;
+ hWnd>> client-area>RECT ClipCursor drop ;
M: windows-ui-backend (ungrab-input) ( handle -- )
drop
f ClipCursor drop
From 8151796b06fe36857c98a311bc3008959c730b21 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 8 May 2009 14:09:57 -0700
Subject: [PATCH 32/72] Add missing ClientToScreen export to windows.user32
---
basis/windows/user32/user32.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
mode change 100644 => 100755 basis/windows/user32/user32.factor
diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor
old mode 100644
new mode 100755
index b6caa7c039..2272695953
--- a/basis/windows/user32/user32.factor
+++ b/basis/windows/user32/user32.factor
@@ -652,7 +652,7 @@ FUNCTION: HDC BeginPaint ( HWND hwnd, LPPAINTSTRUCT lpPaint ) ;
FUNCTION: HWND ChildWindowFromPoint ( HWND hWndParent, POINT point ) ;
! FUNCTION: ChildWindowFromPointEx
! FUNCTION: ClientThreadSetup
-! FUNCTION: ClientToScreen
+FUNCTION: BOOL ClientToScreen ( HWND hWnd, POINT* point ) ;
! FUNCTION: CliImmSetHotKey
FUNCTION: int ClipCursor ( RECT* clipRect ) ;
FUNCTION: BOOL CloseClipboard ( ) ;
From 1644d882333a4882fa72c030f815af65a8c6bb9a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 8 May 2009 16:18:56 -0500
Subject: [PATCH 33/72] add escape key to terrain demo
---
extra/terrain/terrain.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index 3f94b93138..6617275784 100644
--- a/extra/terrain/terrain.factor
+++ b/extra/terrain/terrain.factor
@@ -111,6 +111,7 @@ TUPLE: terrain-world < world
key-s keys nth [ world move-backward ] when
key-a keys nth [ world move-leftward ] when
key-d keys nth [ world move-rightward ] when
+ key-escape keys nth [ world close-window ] when
world read-mouse rotate-with-mouse
reset-mouse ;
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 34/72] 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 66b1fdd9160db6fed629a22a9726916a03ba955e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 8 May 2009 17:22:04 -0500
Subject: [PATCH 35/72] oops. got the game-input reference counting backward.
also, let go of the mouse state in cocoa backend when closing game-input
---
extra/game-input/game-input.factor | 2 +-
extra/game-input/iokit/iokit.factor | 1 +
2 files changed, 2 insertions(+), 1 deletion(-)
diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor
index ccf5bd635b..922906df48 100755
--- a/extra/game-input/game-input.factor
+++ b/extra/game-input/game-input.factor
@@ -55,7 +55,7 @@ ERROR: game-input-not-open ;
game-input-opened? [
(close-game-input)
reset-game-input
- ] when ;
+ ] unless ;
: with-game-input ( quot -- )
open-game-input [ close-game-input ] [ ] cleanup ; inline
diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor
index 0cc8b5d51f..de1529f8df 100755
--- a/extra/game-input/iokit/iokit.factor
+++ b/extra/game-input/iokit/iokit.factor
@@ -304,6 +304,7 @@ M: iokit-game-input-backend (close-game-input)
f
] change-global
f +keyboard-state+ set-global
+ f +mouse-state+ set-global
f +controller-states+ set-global
] when ;
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 36/72] 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 04a70da513d1da2ac81291307d1efe19b341cc47 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Fri, 8 May 2009 17:41:22 -0500
Subject: [PATCH 37/72] Fix compile error in cpu-ppc.hpp
---
vm/cpu-ppc.hpp | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp
index b256b01c8b..6ae2cce27d 100755
--- a/vm/cpu-ppc.hpp
+++ b/vm/cpu-ppc.hpp
@@ -35,7 +35,7 @@ inline static void *get_call_target(cell return_address)
check_call_site(return_address);
cell insn = *(cell *)return_address;
- cell unsigned_addr = (insn & B_MASK);
+ cell unsigned_addr = (insn & b_mask);
fixnum signed_addr = (fixnum)(unsigned_addr << 6) >> 6;
return (void *)(signed_addr + return_address);
}
@@ -48,7 +48,7 @@ inline static void set_call_target(cell return_address, void *target)
cell insn = *(cell *)return_address;
fixnum relative_address = ((cell)target - return_address);
- insn = ((insn & ~B_MASK) | (relative_address & B_MASK));
+ insn = ((insn & ~b_mask) | (relative_address & b_mask));
*(cell *)return_address = insn;
/* Flush the cache line containing the call we just patched */
From ea85f298d18fe3d4c7d42624effcedc40eec539e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 May 2009 18:00:53 -0500
Subject: [PATCH 38/72] math.combinatorics: fix unit test and help lint
---
basis/math/combinatorics/combinatorics-docs.factor | 2 +-
basis/math/combinatorics/combinatorics-tests.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/math/combinatorics/combinatorics-docs.factor b/basis/math/combinatorics/combinatorics-docs.factor
index 7f40969b95..041539c981 100644
--- a/basis/math/combinatorics/combinatorics-docs.factor
+++ b/basis/math/combinatorics/combinatorics-docs.factor
@@ -64,7 +64,7 @@ HELP: combination
{ $description "Outputs the " { $snippet "mth" } " lexicographical combination of " { $snippet "seq" } " choosing " { $snippet "k" } " elements." }
{ $notes "Combinations are 0-based and a bounds error will be thrown if " { $snippet "m" } " is larger than " { $snippet "seq length k nCk" } "." }
{ $examples
- { $example "USING: math.combinatorics prettyprint ;"
+ { $example "USING: math.combinatorics sequences prettyprint ;"
"6 7 iota 4 combination ." "{ 0 1 3 6 }" }
{ $example "USING: math.combinatorics prettyprint ;"
"0 { \"a\" \"b\" \"c\" \"d\" } 2 combination ." "{ \"a\" \"b\" }" }
diff --git a/basis/math/combinatorics/combinatorics-tests.factor b/basis/math/combinatorics/combinatorics-tests.factor
index 1bc4bbc825..ca6ec9cb53 100644
--- a/basis/math/combinatorics/combinatorics-tests.factor
+++ b/basis/math/combinatorics/combinatorics-tests.factor
@@ -1,4 +1,4 @@
-USING: math.combinatorics math.combinatorics.private tools.test ;
+USING: math.combinatorics math.combinatorics.private tools.test sequences ;
IN: math.combinatorics.tests
[ 1 ] [ 0 factorial ] unit-test
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 39/72] 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 cd4530adca9aa1189a16228e60ba5ac1d959d08a Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 8 May 2009 18:47:44 -0500
Subject: [PATCH 40/72] iokit game-input backend improvements: - avoid some
needless allocation when dispatching input events - some gamepads claim to be
pointers too; only match actual mouses - don't mess with the calibration
settings if the axis min/max attributes aren't available
also, throw a more helpful error when plist> fails
---
basis/cocoa/plists/plists.factor | 11 +++-
extra/game-input/iokit/iokit.factor | 82 ++++++++++++++++-------------
2 files changed, 54 insertions(+), 39 deletions(-)
diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor
index 31b59a6eac..ceb097bb3a 100644
--- a/basis/cocoa/plists/plists.factor
+++ b/basis/cocoa/plists/plists.factor
@@ -4,7 +4,7 @@
USING: strings arrays hashtables assocs sequences fry macros
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types words core-foundation
+combinators alien.c-types words core-foundation quotations
core-foundation.data core-foundation.utilities ;
IN: cocoa.plists
@@ -41,10 +41,16 @@ DEFER: plist>
*void* [ -> release "read-plist failed" throw ] when* ;
MACRO: objc-class-case ( alist -- quot )
- [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
+ [
+ dup callable?
+ [ first2 [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip 2array ]
+ unless
+ ] map '[ _ cond ] ;
PRIVATE>
+ERROR: invalid-plist-object object ;
+
: plist> ( plist -- value )
{
{ NSString [ (plist-NSString>) ] }
@@ -53,6 +59,7 @@ PRIVATE>
{ NSArray [ (plist-NSArray>) ] }
{ NSDictionary [ (plist-NSDictionary>) ] }
{ NSObject [ ] }
+ [ invalid-plist-object ]
} objc-class-case ;
: read-plist ( path -- assoc )
diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor
index de1529f8df..42189a8787 100755
--- a/extra/game-input/iokit/iokit.factor
+++ b/extra/game-input/iokit/iokit.factor
@@ -8,6 +8,8 @@ IN: game-input.iokit
SINGLETON: iokit-game-input-backend
+SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
+
iokit-game-input-backend game-input-backend set-global
: hid-manager-matching ( matching-seq -- alien )
@@ -23,7 +25,6 @@ iokit-game-input-backend game-input-backend set-global
CONSTANT: game-devices-matching-seq
{
- H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers
H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
@@ -88,17 +89,17 @@ CONSTANT: hat-switch-matching-hash
game-devices-matching-seq hid-manager-matching ;
: device-property ( device key -- value )
- <NSString> IOHIDDeviceGetProperty plist> ;
+ <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
: element-property ( element key -- value )
- <NSString> IOHIDElementGetProperty plist> ;
+ <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
: set-element-property ( element key value -- )
[ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
: transfer-element-property ( element from-key to-key -- )
- [ dupd element-property ] dip swap set-element-property ;
+ [ dupd element-property ] dip swap
+ [ set-element-property ] [ 2drop ] if* ;
: mouse-device? ( device -- ? )
{
- [ 1 1 IOHIDDeviceConformsTo ]
[ 1 2 IOHIDDeviceConformsTo ]
} 1|| ;
@@ -113,28 +114,31 @@ CONSTANT: hat-switch-matching-hash
[ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
2array ;
-: button? ( {usage-page,usage} -- ? )
- first 9 = ; inline
-: keyboard-key? ( {usage-page,usage} -- ? )
- first 7 = ; inline
+: button? ( element -- ? )
+ IOHIDElementGetUsagePage 9 = ; inline
+: keyboard-key? ( element -- ? )
+ IOHIDElementGetUsagePage 7 = ; inline
+: axis? ( element -- ? )
+ IOHIDElementGetUsagePage 1 = ; inline
+
: x-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 30 } = ; inline
+ IOHIDElementGetUsage HEX: 30 = ; inline
: y-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 31 } = ; inline
+ IOHIDElementGetUsage HEX: 31 = ; inline
: z-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 32 } = ; inline
+ IOHIDElementGetUsage HEX: 32 = ; inline
: rx-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 33 } = ; inline
+ IOHIDElementGetUsage HEX: 33 = ; inline
: ry-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 34 } = ; inline
+ IOHIDElementGetUsage HEX: 34 = ; inline
: rz-axis? ( {usage-page,usage} -- ? )
- { 1 HEX: 35 } = ; inline
+ IOHIDElementGetUsage HEX: 35 = ; inline
: slider? ( {usage-page,usage} -- ? )
- { 1 HEX: 36 } = ; inline
+ IOHIDElementGetUsage HEX: 36 = ; inline
: wheel? ( {usage-page,usage} -- ? )
- { 1 HEX: 38 } = ; inline
+ IOHIDElementGetUsage HEX: 38 = ; inline
: hat-switch? ( {usage-page,usage} -- ? )
- { 1 HEX: 39 } = ; inline
+ IOHIDElementGetUsage HEX: 39 = ; inline
CONSTANT: pov-values
{
@@ -152,42 +156,46 @@ CONSTANT: pov-values
: pov-value ( value -- pov-direction )
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
-: record-button ( hid-value usage state -- )
- [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ;
+: record-button ( hid-value element state -- )
+ [ button-value ] [ IOHIDElementGetUsage 1- ] [ buttons>> ] tri* set-nth ;
: record-controller ( controller-state value -- )
- dup IOHIDValueGetElement element-usage {
+ dup IOHIDValueGetElement {
{ [ dup button? ] [ rot record-button ] }
- { [ dup x-axis? ] [ drop axis-value >>x drop ] }
- { [ dup y-axis? ] [ drop axis-value >>y drop ] }
- { [ dup z-axis? ] [ drop axis-value >>z drop ] }
- { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
- { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
- { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
- { [ dup slider? ] [ drop axis-value >>slider drop ] }
- { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+ { [ dup axis? ] [ {
+ { [ dup x-axis? ] [ drop axis-value >>x drop ] }
+ { [ dup y-axis? ] [ drop axis-value >>y drop ] }
+ { [ dup z-axis? ] [ drop axis-value >>z drop ] }
+ { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
+ { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
+ { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
+ { [ dup slider? ] [ drop axis-value >>slider drop ] }
+ { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+ [ 3drop ]
+ } cond ] }
[ 3drop ]
} cond ;
-SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
-
: ?set-nth ( value nth seq -- )
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
: record-keyboard ( value -- )
- dup IOHIDValueGetElement element-usage keyboard-key? [
+ dup IOHIDValueGetElement keyboard-key? [
[ IOHIDValueGetIntegerValue c-bool> ]
[ IOHIDValueGetElement IOHIDElementGetUsage ] bi
+keyboard-state+ get ?set-nth
] [ drop ] if ;
: record-mouse ( value -- )
- dup IOHIDValueGetElement element-usage {
+ dup IOHIDValueGetElement {
{ [ dup button? ] [ +mouse-state+ get record-button ] }
- { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
- { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
- { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
- { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
+ { [ dup axis? ] [ {
+ { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
+ { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
+ { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
+ { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
+ [ 2drop ]
+ } cond ] }
[ 2drop ]
} cond ;
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 41/72] 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 77c8f383720b54386c17a7f8474f945a9343d67e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 8 May 2009 19:16:45 -0500
Subject: [PATCH 42/72] a little bit more rice on game-input.iokit
---
extra/game-input/iokit/iokit.factor | 50 ++++++++++++++++-------------
1 file changed, 27 insertions(+), 23 deletions(-)
diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor
index 42189a8787..5f09a054f9 100755
--- a/extra/game-input/iokit/iokit.factor
+++ b/extra/game-input/iokit/iokit.factor
@@ -1,7 +1,7 @@
USING: cocoa cocoa.plists core-foundation iokit iokit.hid
kernel cocoa.enumeration destructors math.parser cocoa.application
sequences locals combinators.short-circuit threads
-namespaces assocs vectors arrays combinators
+namespaces assocs vectors arrays combinators hints alien
core-foundation.run-loop accessors sequences.private
alien.c-types math parser game-input vectors ;
IN: game-input.iokit
@@ -99,9 +99,7 @@ CONSTANT: hat-switch-matching-hash
[ set-element-property ] [ 2drop ] if* ;
: mouse-device? ( device -- ? )
- {
- [ 1 2 IOHIDDeviceConformsTo ]
- } 1|| ;
+ 1 2 IOHIDDeviceConformsTo ;
: controller-device? ( device -- ? )
{
@@ -156,12 +154,12 @@ CONSTANT: pov-values
: pov-value ( value -- pov-direction )
IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
-: record-button ( hid-value element state -- )
- [ button-value ] [ IOHIDElementGetUsage 1- ] [ buttons>> ] tri* set-nth ;
+: record-button ( state hid-value element -- )
+ [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
: record-controller ( controller-state value -- )
dup IOHIDValueGetElement {
- { [ dup button? ] [ rot record-button ] }
+ { [ dup button? ] [ record-button ] }
{ [ dup axis? ] [ {
{ [ dup x-axis? ] [ drop axis-value >>x drop ] }
{ [ dup y-axis? ] [ drop axis-value >>y drop ] }
@@ -176,29 +174,35 @@ CONSTANT: pov-values
[ 3drop ]
} cond ;
+HINTS: record-controller { controller-state alien } ;
+
: ?set-nth ( value nth seq -- )
2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
-: record-keyboard ( value -- )
- dup IOHIDValueGetElement keyboard-key? [
+: record-keyboard ( keyboard-state value -- )
+ dup IOHIDValueGetElement dup keyboard-key? [
[ IOHIDValueGetIntegerValue c-bool> ]
- [ IOHIDValueGetElement IOHIDElementGetUsage ] bi
- +keyboard-state+ get ?set-nth
- ] [ drop ] if ;
+ [ IOHIDElementGetUsage ] bi*
+ rot ?set-nth
+ ] [ 3drop ] if ;
-: record-mouse ( value -- )
+HINTS: record-keyboard { array alien } ;
+
+: record-mouse ( mouse-state value -- )
dup IOHIDValueGetElement {
- { [ dup button? ] [ +mouse-state+ get record-button ] }
+ { [ dup button? ] [ record-button ] }
{ [ dup axis? ] [ {
- { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] }
- { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] }
- { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] }
- { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] }
- [ 2drop ]
+ { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
+ { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
+ { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
+ { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
+ [ 3drop ]
} cond ] }
- [ 2drop ]
+ [ 3drop ]
} cond ;
+HINTS: record-mouse { mouse-state alien } ;
+
M: iokit-game-input-backend read-mouse
+mouse-state+ get ;
@@ -271,8 +275,8 @@ M: iokit-game-input-backend reset-mouse
{ [ sender controller-device? ] [
sender +controller-states+ get at value record-controller
] }
- { [ sender mouse-device? ] [ value record-mouse ] }
- [ value record-keyboard ]
+ { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
+ [ +keyboard-state+ get value record-keyboard ]
} cond
] IOHIDValueCallback ;
@@ -297,7 +301,7 @@ M: iokit-game-input-backend (open-game-input)
} cleave ;
M: iokit-game-input-backend (reset-game-input)
- { +hid-manager+ +keyboard-state+ +controller-states+ }
+ { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
[ f swap set-global ] each ;
M: iokit-game-input-backend (close-game-input)
From b1fffc26f88283ec68986e7b37ade59cf43398fc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 May 2009 21:33:49 -0500
Subject: [PATCH 43/72] mason.report: Remove superfluous text
---
extra/mason/report/report.factor | 3 +--
1 file changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor
index 0340941449..6e48e7cf04 100644
--- a/extra/mason/report/report.factor
+++ b/extra/mason/report/report.factor
@@ -112,8 +112,7 @@ IN: mason.report
benchmark-error-vocabs-file
benchmark-error-messages-file
error-dump
-
- "Benchmark timings"
+
benchmarks-file eval-file benchmarks-table
] output>array
] with-report ;
From 1d747ea9116df0ee43179634ab7d420d2e8ed11a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 8 May 2009 21:34:28 -0500
Subject: [PATCH 44/72] specialized-arrays: fix tests on PowerPC
---
.../specialized-arrays-tests.factor | 11 +++++++++--
1 file changed, 9 insertions(+), 2 deletions(-)
diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor
index f64542fa00..1e470b699a 100644
--- a/basis/specialized-arrays/specialized-arrays-tests.factor
+++ b/basis/specialized-arrays/specialized-arrays-tests.factor
@@ -2,7 +2,8 @@ IN: specialized-arrays.tests
USING: tools.test specialized-arrays sequences
specialized-arrays.int specialized-arrays.bool
specialized-arrays.ushort alien.c-types accessors kernel
-specialized-arrays.direct.int specialized-arrays.char arrays ;
+specialized-arrays.direct.int specialized-arrays.char
+specialized-arrays.uint arrays combinators ;
[ t ] [ { 1 2 3 } >int-array int-array? ] unit-test
@@ -10,7 +11,13 @@ specialized-arrays.direct.int specialized-arrays.char arrays ;
[ 2 ] [ int-array{ 1 2 3 } second ] unit-test
-[ t ] [ { t f t } >bool-array underlying>> { 1 0 1 } >char-array underlying>> = ] unit-test
+[ t ] [
+ { t f t } >bool-array underlying>>
+ { 1 0 1 } "bool" heap-size {
+ { 1 [ >char-array ] }
+ { 4 [ >uint-array ] }
+ } case underlying>> =
+] unit-test
[ ushort-array{ 1234 } ] [
little-endian? B{ 210 4 } B{ 4 210 } ? byte-array>ushort-array
From 9021062795d7e2d02c49303b6201a3052dac9432 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 09:49:31 -0500
Subject: [PATCH 45/72] fp-nan? was defined incorrectly. while i'm here, let's
add some more float manipulation words
---
core/math/math-docs.factor | 33 +++++++++++++++++++-
core/math/math-tests.factor | 17 +++++++++++
core/math/math.factor | 60 +++++++++++++++++++++++++++++--------
3 files changed, 97 insertions(+), 13 deletions(-)
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index c28bf062c1..75370d6cfd 100644
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -245,10 +245,22 @@ HELP: times
{ $example "USING: io math ;" "3 [ \"Hi\" print ] times" "Hi\nHi\nHi" }
} ;
+HELP: fp-special?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE special value (Not-a-Number or Infinity). While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
HELP: fp-nan?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+HELP: fp-qnan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Quiet Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
+HELP: fp-snan?
+{ $values { "x" real } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "x" } " is an IEEE Signaling Not-a-Number value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." } ;
+
HELP: fp-infinity?
{ $values { "x" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." }
@@ -257,7 +269,26 @@ HELP: fp-infinity?
{ $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
} ;
-{ fp-nan? fp-infinity? } related-words
+HELP: fp-nan-payload
+{ $values { "x" real } { "bits" integer } }
+{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;
+
+HELP: <fp-nan>
+{ $values { "payload" integer } { "float" float } }
+{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." }
+{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ;
+
+{ fp-special? fp-nan? fp-qnan? fp-snan? fp-infinity? fp-nan-payload <fp-nan> } related-words
+
+HELP: next-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the least representable " { $link float } " value greater than " { $snippet "m" } "." } ;
+
+HELP: prev-float
+{ $values { "m" float } { "n" float } }
+{ $description "Returns the greatest representable " { $link float } " value less than " { $snippet "m" } "." } ;
+
+{ next-float prev-float } related-words
HELP: real-part
{ $values { "z" number } { "x" real } }
diff --git a/core/math/math-tests.factor b/core/math/math-tests.factor
index c2077eb790..b7cc51e669 100644
--- a/core/math/math-tests.factor
+++ b/core/math/math-tests.factor
@@ -12,7 +12,24 @@ IN: math.tests
[ f ] [ 1/0. fp-nan? ] unit-test
[ f ] [ -1/0. fp-nan? ] unit-test
[ t ] [ -0/0. fp-nan? ] unit-test
+[ t ] [ 1 <fp-nan> fp-nan? ] unit-test
+! [ t ] [ 1 <fp-nan> fp-snan? ] unit-test
+! [ f ] [ 1 <fp-nan> fp-qnan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-nan? ] unit-test
+[ f ] [ HEX: 8000000000001 <fp-nan> fp-snan? ] unit-test
+[ t ] [ HEX: 8000000000001 <fp-nan> fp-qnan? ] unit-test
[ t ] [ 1/0. fp-infinity? ] unit-test
[ t ] [ -1/0. fp-infinity? ] unit-test
[ f ] [ -0/0. fp-infinity? ] unit-test
+
+[ f ] [ 0 <fp-nan> fp-nan? ] unit-test
+[ t ] [ 0 <fp-nan> fp-infinity? ] unit-test
+
+[ 0.0 ] [ -0.0 next-float ] unit-test
+[ t ] [ 1.0 dup next-float < ] unit-test
+[ t ] [ -1.0 dup next-float < ] unit-test
+
+[ -0.0 ] [ 0.0 prev-float ] unit-test
+[ t ] [ 1.0 dup prev-float > ] unit-test
+[ t ] [ -1.0 dup prev-float > ] unit-test
diff --git a/core/math/math.factor b/core/math/math.factor
index 8e0000326f..6a087ec909 100755
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -81,26 +81,62 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ;
UNION: number real complex ;
+GENERIC: fp-special? ( x -- ? )
GENERIC: fp-nan? ( x -- ? )
+GENERIC: fp-qnan? ( x -- ? )
+GENERIC: fp-snan? ( x -- ? )
+GENERIC: fp-infinity? ( x -- ? )
+GENERIC: fp-nan-payload ( x -- bits )
+M: object fp-special?
+ drop f ;
M: object fp-nan?
drop f ;
-
-M: float fp-nan?
- double>bits -51 shift HEX: fff [ bitand ] keep = ;
-
-GENERIC: fp-infinity? ( x -- ? )
-
+M: object fp-qnan?
+ drop f ;
+M: object fp-snan?
+ drop f ;
M: object fp-infinity?
drop f ;
+M: object fp-nan-payload
+ drop f ;
-M: float fp-infinity? ( float -- ? )
+M: float fp-special?
+ double>bits -52 shift HEX: 7ff [ bitand ] keep = ;
+
+M: float fp-nan-payload
+ double>bits HEX: fffffffffffff bitand ; foldable flushable
+
+M: float fp-nan?
+ dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ;
+
+M: float fp-qnan?
+ dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ;
+
+M: float fp-snan?
+ dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ;
+
+M: float fp-infinity?
+ dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ;
+
+: <fp-nan> ( payload -- nan )
+ HEX: 7ff0000000000000 bitor bits>double ; foldable flushable
+
+: next-float ( m -- n )
double>bits
- dup -52 shift HEX: 7ff [ bitand ] keep = [
- HEX: fffffffffffff bitand 0 =
- ] [
- drop f
- ] if ;
+ dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
+ dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
+ 1 + bits>double ! positive
+ ] if
+ ] if ; foldable flushable
+
+: prev-float ( m -- n )
+ double>bits
+ dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
+ dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
+ 1 - bits>double ! positive non-zero
+ ] if
+ ] if ; foldable flushable
: next-power-of-2 ( m -- n )
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
From a66de23b54299dabfbae1147e0a25259d7dba443 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 11:15:06 -0500
Subject: [PATCH 46/72] gravity, jetpack, collision detection for terrain demo
---
extra/terrain/shaders/shaders.factor | 10 +--
extra/terrain/terrain.factor | 114 ++++++++++++++++++---------
2 files changed, 81 insertions(+), 43 deletions(-)
diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor
index 2dc793f078..c341545956 100644
--- a/extra/terrain/shaders/shaders.factor
+++ b/extra/terrain/shaders/shaders.factor
@@ -4,15 +4,14 @@ IN: terrain.shaders
STRING: terrain-vertex-shader
uniform sampler2D heightmap;
+uniform vec4 component_scale;
varying vec2 heightcoords;
-const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
-
float height(sampler2D map, vec2 coords)
{
vec4 v = texture2D(map, coords);
- return dot(v, COMPONENT_SCALE);
+ return dot(v, component_scale);
}
void main()
@@ -27,15 +26,14 @@ void main()
STRING: terrain-pixel-shader
uniform sampler2D heightmap;
+uniform vec4 component_scale;
varying vec2 heightcoords;
-const vec4 COMPONENT_SCALE = vec4(0.5, 0.01, 0.002, 0.0);
-
float height(sampler2D map, vec2 coords)
{
vec4 v = texture2D(map, coords);
- return dot(v, COMPONENT_SCALE);
+ return dot(v, component_scale);
}
void main()
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index 6617275784..c6dce2d9c2 100644
--- a/extra/terrain/terrain.factor
+++ b/extra/terrain/terrain.factor
@@ -1,6 +1,6 @@
USING: accessors arrays combinators game-input
-game-input.scancodes game-loop kernel literals locals math
-math.constants math.functions math.matrices math.order
+game-input.scancodes game-loop grouping kernel literals locals
+math math.constants math.functions math.matrices math.order
math.vectors opengl opengl.capabilities opengl.gl
opengl.shaders opengl.textures opengl.textures.private
sequences sequences.product specialized-arrays.float
@@ -9,19 +9,27 @@ ui.gadgets.worlds ui.pixel-formats ;
IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
-CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
-CONSTANT: FAR-PLANE 2.0
-CONSTANT: EYE-START { 0.5 0.5 1.2 }
+CONSTANT: NEAR-PLANE $[ 1.0 2048.0 / ]
+CONSTANT: FAR-PLANE 1.0
+CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
+CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ]
+CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
+CONSTANT: JUMP $[ 1.0 1024.0 / ]
CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
-CONSTANT: MOVEMENT-SPEED $[ 1.0 512.0 / ]
+CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ]
+CONSTANT: FRICTION 0.95
+CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.002 0.0 }
CONSTANT: terrain-vertex-size { 512 512 }
CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
+TUPLE: player
+ location yaw pitch velocity ;
+
TUPLE: terrain-world < world
- eye yaw pitch
+ player
terrain terrain-segment terrain-texture terrain-program
terrain-vertex-buffer
game-loop ;
@@ -35,9 +43,10 @@ TUPLE: terrain-world < world
GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
GL_MODELVIEW glMatrixMode
glLoadIdentity
+ player>>
[ pitch>> 1.0 0.0 0.0 glRotatef ]
[ yaw>> 0.0 1.0 0.0 glRotatef ]
- [ eye>> vneg first3 glTranslatef ] tri ;
+ [ location>> vneg first3 glTranslatef ] tri ;
: vertex-array-vertex ( x z -- vertex )
[ terrain-vertex-distance first * ]
@@ -79,47 +88,77 @@ TUPLE: terrain-world < world
p cos :> cosp
p sin :> sinp
- cosy 0.0 siny neg 3array
- siny sinp * cosp cosy sinp * 3array
- siny cosp * sinp neg cosy cosp * 3array 3array
+ cosy 0.0 siny neg 3array
+ siny sinp * cosp cosy sinp * 3array
+ siny cosp * sinp neg cosy cosp * 3array 3array
v swap v.m ;
-: forward-vector ( world -- v )
- [ yaw>> ] [ pitch>> ] bi
+: forward-vector ( player -- v )
+ yaw>> 0.0
{ 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
-: rightward-vector ( world -- v )
- [ yaw>> ] [ pitch>> ] bi
+: rightward-vector ( player -- v )
+ yaw>> 0.0
{ $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
-: move-forward ( world -- )
- dup forward-vector [ v+ ] curry change-eye drop ;
-: move-backward ( world -- )
- dup forward-vector [ v- ] curry change-eye drop ;
-: move-leftward ( world -- )
- dup rightward-vector [ v- ] curry change-eye drop ;
-: move-rightward ( world -- )
- dup rightward-vector [ v+ ] curry change-eye drop ;
+: walk-forward ( player -- )
+ dup forward-vector [ v+ ] curry change-velocity drop ;
+: walk-backward ( player -- )
+ dup forward-vector [ v- ] curry change-velocity drop ;
+: walk-leftward ( player -- )
+ dup rightward-vector [ v- ] curry change-velocity drop ;
+: walk-rightward ( player -- )
+ dup rightward-vector [ v+ ] curry change-velocity drop ;
+: jump ( player -- )
+ [ { 0.0 $ JUMP 0.0 } v+ ] change-velocity drop ;
-: rotate-with-mouse ( world mouse -- )
+: clamp-pitch ( pitch -- pitch' )
+ 90.0 min -90.0 max ;
+
+: rotate-with-mouse ( player mouse -- )
[ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
- [ dy>> MOUSE-SCALE * [ + ] curry change-pitch ] bi
+ [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi
drop ;
:: handle-input ( world -- )
+ world player>> :> player
read-keyboard keys>> :> keys
- key-w keys nth [ world move-forward ] when
- key-s keys nth [ world move-backward ] when
- key-a keys nth [ world move-leftward ] when
- key-d keys nth [ world move-rightward ] when
+ key-w keys nth [ player walk-forward ] when
+ key-s keys nth [ player walk-backward ] when
+ key-a keys nth [ player walk-leftward ] when
+ key-d keys nth [ player walk-rightward ] when
+ key-space keys nth [ player jump ] when
key-escape keys nth [ world close-window ] when
- world read-mouse rotate-with-mouse
+ player read-mouse rotate-with-mouse
reset-mouse ;
-M: terrain-world tick*
- [ handle-input ] keep
- ! [ eye>> ] [ yaw>> ] [ pitch>> ] tri 3array P ! debug
+: apply-friction ( velocity -- velocity' )
+ FRICTION v*n ;
+
+: apply-gravity ( velocity -- velocity' )
+ 1 over [ GRAVITY - ] change-nth ;
+
+: pixel ( coords dim -- index )
+ [ drop first ] [ [ second ] [ first ] bi* * ] 2bi + ;
+
+: terrain-height-at ( segment point -- height )
+ over dim>> [ v* vfloor ] [ pixel >integer ] bi
+ swap bitmap>> 4 <groups> nth COMPONENT-SCALE v. 255.0 / ;
+
+: collide ( segment location -- location' )
+ [ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ]
+ [ [ 1 ] 2dip [ max ] with change-nth ]
+ [ ] tri ;
+
+: tick-player ( world player -- )
+ [ apply-friction apply-gravity ] change-velocity
+ dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
+ P
drop ;
+M: terrain-world tick*
+ [ dup focused?>> [ handle-input ] [ drop ] if ]
+ [ dup player>> tick-player ] bi ;
+
M: terrain-world draw*
nip draw-world ;
@@ -137,9 +176,7 @@ M: terrain-world begin-world
GL_TEXTURE_2D glEnable
GL_VERTEX_ARRAY glEnableClientState
0.5 0.5 0.5 1.0 glClearColor
- EYE-START >>eye
- 0.0 >>yaw
- 0.0 >>pitch
+ PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
<terrain> [ >>terrain ] keep
{ 0 0 } terrain-segment [ >>terrain-segment ] keep
make-texture [ set-heightmap-texture-parameters ] keep >>terrain-texture
@@ -169,7 +206,8 @@ 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
+ [ "heightmap" glGetUniformLocation 0 glUniform1i ]
+ [ "component_scale" glGetUniformLocation COMPONENT-SCALE first4 glUniform4f ] bi
terrain-vertex-buffer>> draw-vertex-buffer
] with-gl-program ]
tri gl-error ;
@@ -190,3 +228,5 @@ M: terrain-world pref-dim* drop { 640 480 } ;
{ grab-input? t }
} open-window
] with-ui ;
+
+MAIN: terrain-window
From b0d7e38b2fa390d30b8fcb82e57fe47c1e63ce90 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 11:36:24 -0500
Subject: [PATCH 47/72] bilerp collision height
---
extra/terrain/terrain.factor | 24 ++++++++++++++++++------
1 file changed, 18 insertions(+), 6 deletions(-)
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index c6dce2d9c2..083b162c01 100644
--- a/extra/terrain/terrain.factor
+++ b/extra/terrain/terrain.factor
@@ -137,12 +137,25 @@ TUPLE: terrain-world < world
: apply-gravity ( velocity -- velocity' )
1 over [ GRAVITY - ] change-nth ;
-: pixel ( coords dim -- index )
- [ drop first ] [ [ second ] [ first ] bi* * ] 2bi + ;
+:: pixel-indices ( coords dim -- indices )
+ coords vfloor [ >integer ] map :> floor-coords
+ floor-coords first2 dim first * + :> base-index
+ base-index dim first + :> next-row-index
-: terrain-height-at ( segment point -- height )
- over dim>> [ v* vfloor ] [ pixel >integer ] bi
- swap bitmap>> 4 <groups> nth COMPONENT-SCALE v. 255.0 / ;
+ base-index
+ base-index 1 +
+ next-row-index
+ next-row-index 1 + 4array ;
+
+:: terrain-height-at ( segment point -- height )
+ segment dim>> :> dim
+ dim point v* :> pixel
+ pixel dup vfloor v- :> pixel-mantissa
+ segment bitmap>> 4 <groups> :> pixels
+ pixel dim pixel-indices :> indices
+
+ indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map
+ first4 [ pixel-mantissa first lerp ] 2bi@ pixel-mantissa second lerp ;
: collide ( segment location -- location' )
[ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ]
@@ -152,7 +165,6 @@ TUPLE: terrain-world < world
: tick-player ( world player -- )
[ apply-friction apply-gravity ] change-velocity
dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
- P
drop ;
M: terrain-world tick*
From dd9af334a988a92eb9b11a419e0db1a768fede7d Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 11:43:04 -0500
Subject: [PATCH 48/72] send bilerp upstream to spawn
---
basis/math/vectors/vectors-tests.factor | 2 ++
basis/math/vectors/vectors.factor | 4 ++++
extra/terrain/terrain.factor | 2 +-
3 files changed, 7 insertions(+), 1 deletion(-)
diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor
index b4b12d619b..968af6a3aa 100644
--- a/basis/math/vectors/vectors-tests.factor
+++ b/basis/math/vectors/vectors-tests.factor
@@ -14,3 +14,5 @@ USING: math.vectors tools.test ;
[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test
[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test
+
+[ 1.125 ] [ 0.0 1.0 2.0 4.0 { 0.5 0.25 } bilerp ] unit-test
diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor
index eb203a5f12..17f6c39f04 100644
--- a/basis/math/vectors/vectors.factor
+++ b/basis/math/vectors/vectors.factor
@@ -41,6 +41,10 @@ IN: math.vectors
: set-axis ( u v axis -- w )
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
+: bilerp ( aa ba ab bb {t,u} -- a_tu )
+ [ first lerp ] [ second lerp ] bi-curry
+ [ 2bi@ ] [ call ] bi* ;
+
: vlerp ( a b t -- a_t )
[ lerp ] 3map ;
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index 083b162c01..d58aa4ec30 100644
--- a/extra/terrain/terrain.factor
+++ b/extra/terrain/terrain.factor
@@ -155,7 +155,7 @@ TUPLE: terrain-world < world
pixel dim pixel-indices :> indices
indices [ pixels nth COMPONENT-SCALE v. 255.0 / ] map
- first4 [ pixel-mantissa first lerp ] 2bi@ pixel-mantissa second lerp ;
+ first4 pixel-mantissa bilerp ;
: collide ( segment location -- location' )
[ [ first ] [ third ] bi 2array terrain-height-at PLAYER-HEIGHT + ]
From 84c7f10ab7dbc5e0d3d901b848ef018ddb39a86d Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 12:53:01 -0500
Subject: [PATCH 49/72] factor game-input and game-loop mgmt out to a
game-world base object
---
extra/game-worlds/game-worlds.factor | 24 ++++++++++++++++++++++++
extra/terrain/terrain.factor | 27 ++++++++++-----------------
2 files changed, 34 insertions(+), 17 deletions(-)
create mode 100644 extra/game-worlds/game-worlds.factor
diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor
new file mode 100644
index 0000000000..864bd28fc1
--- /dev/null
+++ b/extra/game-worlds/game-worlds.factor
@@ -0,0 +1,24 @@
+USING: accessors game-input game-loop kernel ui.gadgets
+ui.gadgets.worlds ui.gestures ;
+IN: game-worlds
+
+TUPLE: game-world < world
+ game-loop ;
+
+GENERIC: tick-length ( world -- millis )
+
+M: game-world draw*
+ nip draw-world ;
+
+M: game-world begin-world
+ dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
+ drop
+ open-game-input ;
+
+M: game-world end-world
+ close-game-input
+ [ [ stop-loop ] when* f ] change-game-loop
+ drop ;
+
+M: game-world focusable-child* drop t ;
+
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index d58aa4ec30..fe105b2e52 100644
--- a/extra/terrain/terrain.factor
+++ b/extra/terrain/terrain.factor
@@ -1,11 +1,11 @@
-USING: accessors arrays combinators game-input
-game-input.scancodes game-loop grouping kernel literals locals
+USING: accessors arrays combinators game-input game-loop
+game-input.scancodes grouping kernel literals locals
math math.constants math.functions math.matrices math.order
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 ;
+ui.gadgets.worlds ui.pixel-formats game-worlds method-chains ;
IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
@@ -15,7 +15,6 @@ CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
CONSTANT: PLAYER-HEIGHT $[ 3.0 1024.0 / ]
CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
CONSTANT: JUMP $[ 1.0 1024.0 / ]
-CONSTANT: TICK-LENGTH $[ 1000 30 /i ]
CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ]
CONSTANT: FRICTION 0.95
@@ -28,11 +27,13 @@ CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
TUPLE: player
location yaw pitch velocity ;
-TUPLE: terrain-world < world
+TUPLE: terrain-world < game-world
player
terrain terrain-segment terrain-texture terrain-program
- terrain-vertex-buffer
- game-loop ;
+ terrain-vertex-buffer ;
+
+M: terrain-world tick-length
+ drop 1000 30 /i ;
: frustum ( dim -- -x x -y y near far )
dup first2 min v/n
@@ -171,9 +172,6 @@ M: terrain-world tick*
[ dup focused?>> [ handle-input ] [ drop ] if ]
[ dup player>> tick-player ] bi ;
-M: terrain-world draw*
- nip draw-world ;
-
: set-heightmap-texture-parameters ( texture -- )
GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glTexParameteri
@@ -181,7 +179,7 @@ M: terrain-world draw*
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP_TO_EDGE glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP_TO_EDGE glTexParameteri ;
-M: terrain-world begin-world
+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
@@ -195,14 +193,10 @@ M: terrain-world begin-world
terrain-vertex-shader terrain-pixel-shader <simple-gl-program>
>>terrain-program
vertex-array >vertex-buffer >>terrain-vertex-buffer
- TICK-LENGTH over <game-loop> [ >>game-loop ] keep start-loop
- open-game-input
drop ;
-M: terrain-world end-world
- close-game-input
+AFTER: terrain-world end-world
{
- [ game-loop>> stop-loop ]
[ terrain-vertex-buffer>> delete-gl-buffer ]
[ terrain-program>> delete-gl-program ]
[ terrain-texture>> delete-texture ]
@@ -224,7 +218,6 @@ M: terrain-world draw-world*
] with-gl-program ]
tri gl-error ;
-M: terrain-world focusable-child* drop t ;
M: terrain-world pref-dim* drop { 640 480 } ;
: terrain-window ( -- )
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 50/72] 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 51/72] 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 4367068ba60d2899f062a03c96f1bf8723863d31 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 14:31:33 -0500
Subject: [PATCH 52/72] save off the tick-slice when draw*-ing a game-world
---
extra/game-worlds/game-worlds.factor | 7 ++++---
1 file changed, 4 insertions(+), 3 deletions(-)
diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor
index 864bd28fc1..fa6b326fa9 100644
--- a/extra/game-worlds/game-worlds.factor
+++ b/extra/game-worlds/game-worlds.factor
@@ -1,14 +1,15 @@
-USING: accessors game-input game-loop kernel ui.gadgets
+USING: accessors game-input game-loop kernel math ui.gadgets
ui.gadgets.worlds ui.gestures ;
IN: game-worlds
TUPLE: game-world < world
- game-loop ;
+ game-loop
+ { tick-slice float initial: 0.0 } ;
GENERIC: tick-length ( world -- millis )
M: game-world draw*
- nip draw-world ;
+ swap >>tick-slice draw-world ;
M: game-world begin-world
dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
From 8cbcb87152cef62bd8719f0f4f41f424de88fc4c Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 14:33:17 -0500
Subject: [PATCH 53/72] don't mess with the orphaned nodes when pop-front-ing
or pop-back-ing a dlist. add a dlist-filter word that drops off all nodes
that don't satisfy a predicate
---
basis/dlists/dlists-tests.factor | 5 +++++
basis/dlists/dlists.factor | 7 +++++--
2 files changed, 10 insertions(+), 2 deletions(-)
diff --git a/basis/dlists/dlists-tests.factor b/basis/dlists/dlists-tests.factor
index 3689680157..8072c93753 100755
--- a/basis/dlists/dlists-tests.factor
+++ b/basis/dlists/dlists-tests.factor
@@ -79,3 +79,8 @@ IN: dlists.tests
[ V{ f 3 1 f } ] [ <dlist> 1 over push-front 3 over push-front f over push-front f over push-back dlist>seq ] unit-test
[ V{ } ] [ <dlist> dlist>seq ] unit-test
+
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 2 4 } ] [ <dlist> { 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
+[ V{ 0 2 4 } ] [ <dlist> { 0 1 2 3 4 5 } over push-all-back [ even? ] dlist-filter dlist>seq ] unit-test
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index 3d7224ed16..89675c6469 100755
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -95,7 +95,7 @@ M: dlist pop-front* ( dlist -- )
[
[
[ empty-dlist ] unless*
- [ f ] change-next drop
+ next>>
f over set-prev-when
] change-front drop
] keep
@@ -108,7 +108,7 @@ M: dlist pop-back* ( dlist -- )
[
[
[ empty-dlist ] unless*
- [ f ] change-prev drop
+ prev>>
f over set-next-when
] change-back drop
] keep
@@ -157,6 +157,9 @@ M: dlist clear-deque ( dlist -- )
: 1dlist ( obj -- dlist ) <dlist> [ push-front ] keep ;
+: dlist-filter ( dlist quot -- dlist )
+ over [ '[ dup obj>> @ [ drop ] [ _ delete-node ] if ] dlist-each-node ] keep ; inline
+
M: dlist clone
<dlist> [ '[ _ push-back ] dlist-each ] keep ;
From 4ee4357e75f1af23950e0eb4622c83d5b2cb8ae5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 9 May 2009 18:17:30 -0500
Subject: [PATCH 54/72] Fix negative zero smashing with bootstrap
---
basis/bootstrap/image/image.factor | 3 +++
core/math/math.factor | 2 ++
2 files changed, 5 insertions(+)
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index 55e6a31491..92d75604e0 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -52,6 +52,9 @@ GENERIC: (eql?) ( obj1 obj2 -- ? )
M: integer (eql?) = ;
+M: float (eql?)
+ over float? [ fp-bitwise= ] [ 2drop f ] if ;
+
M: sequence (eql?)
over sequence? [
2dup [ length ] bi@ =
diff --git a/core/math/math.factor b/core/math/math.factor
index 6a087ec909..da9bc4d1b5 100755
--- a/core/math/math.factor
+++ b/core/math/math.factor
@@ -81,6 +81,8 @@ TUPLE: complex { real real read-only } { imaginary real read-only } ;
UNION: number real complex ;
+: fp-bitwise= ( x y -- ? ) [ double>bits ] bi@ = ; inline
+
GENERIC: fp-special? ( x -- ? )
GENERIC: fp-nan? ( x -- ? )
GENERIC: fp-qnan? ( x -- ? )
From cbb1f1c60b3f224cf8c9e9913818b5afeee4a596 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 20:15:03 -0500
Subject: [PATCH 55/72] docs for dlist-filter
---
basis/dlists/dlists-docs.factor | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/basis/dlists/dlists-docs.factor b/basis/dlists/dlists-docs.factor
index 12e39746c7..e210ad35ce 100755
--- a/basis/dlists/dlists-docs.factor
+++ b/basis/dlists/dlists-docs.factor
@@ -15,6 +15,7 @@ $nl
"Iterating over elements:"
{ $subsection dlist-each }
{ $subsection dlist-find }
+{ $subsection dlist-filter }
{ $subsection dlist-any? }
"Deleting a node matching a predicate:"
{ $subsection delete-node-if* }
@@ -40,6 +41,11 @@ HELP: dlist-find
"This operation is O(n)."
} ;
+HELP: dlist-filter
+{ $values { "dlist" { $link dlist } } { "quot" quotation } { "dlist" { $link dlist } } }
+{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, removing the corresponding nodes if the quotation returns " { $link f } "." }
+{ $side-effects { "dlist" } } ;
+
HELP: dlist-any?
{ $values { "dlist" { $link dlist } } { "quot" quotation } { "?" "a boolean" } }
{ $description "Just like " { $link dlist-find } " except it doesn't return the object." }
From e4059d8393c81efe4ff7ebdb01e630d492ffbe19 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 20:15:55 -0500
Subject: [PATCH 56/72] clamp coordinates when doing terrain collision
detection past the edge of the segment
---
extra/terrain/terrain.factor | 5 ++++-
1 file changed, 4 insertions(+), 1 deletion(-)
diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor
index fe105b2e52..590244ca6a 100644
--- a/extra/terrain/terrain.factor
+++ b/extra/terrain/terrain.factor
@@ -138,8 +138,11 @@ M: terrain-world tick-length
: apply-gravity ( velocity -- velocity' )
1 over [ GRAVITY - ] change-nth ;
+: clamp-coords ( coords dim -- coords' )
+ [ { 0 0 } vmax ] dip { 2 2 } v- vmin ;
+
:: pixel-indices ( coords dim -- indices )
- coords vfloor [ >integer ] map :> floor-coords
+ coords vfloor [ >integer ] map dim clamp-coords :> floor-coords
floor-coords first2 dim first * + :> base-index
base-index dim first + :> next-row-index
From 7584b3075593b95689df75c2d69ebec261157db6 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 9 May 2009 20:23:56 -0500
Subject: [PATCH 57/72] "math" help-lint
---
core/math/math-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index 75370d6cfd..e5f68a511c 100644
--- a/core/math/math-docs.factor
+++ b/core/math/math-docs.factor
@@ -274,7 +274,7 @@ HELP: fp-nan-payload
{ $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;
HELP: <fp-nan>
-{ $values { "payload" integer } { "float" float } }
+{ $values { "payload" integer } { "nan" float } }
{ $description "Constructs an IEEE Not-a-Number value with a payload of " { $snippet "payload" } "." }
{ $notes "A " { $snippet "payload" } " of " { $snippet "0" } " will construct an Infinity value." } ;
From cda3685c4dcd632b4b73412a6d36f22192a75f1e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 9 May 2009 20:24:17 -0500
Subject: [PATCH 58/72] Eliminate prettyprinter dependency from UI
---
basis/math/rectangles/prettyprint/authors.txt | 1 +
basis/math/rectangles/prettyprint/prettyprint.factor | 7 +++++++
basis/math/rectangles/rectangles.factor | 9 +++++----
basis/ui/gadgets/gadgets.factor | 10 +++++-----
basis/ui/gadgets/prettyprint/authors.txt | 1 +
basis/ui/gadgets/prettyprint/prettyprint.factor | 7 +++++++
6 files changed, 26 insertions(+), 9 deletions(-)
create mode 100644 basis/math/rectangles/prettyprint/authors.txt
create mode 100644 basis/math/rectangles/prettyprint/prettyprint.factor
create mode 100644 basis/ui/gadgets/prettyprint/authors.txt
create mode 100644 basis/ui/gadgets/prettyprint/prettyprint.factor
diff --git a/basis/math/rectangles/prettyprint/authors.txt b/basis/math/rectangles/prettyprint/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/math/rectangles/prettyprint/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/math/rectangles/prettyprint/prettyprint.factor b/basis/math/rectangles/prettyprint/prettyprint.factor
new file mode 100644
index 0000000000..c23be50029
--- /dev/null
+++ b/basis/math/rectangles/prettyprint/prettyprint.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors math.rectangles kernel prettyprint.custom prettyprint.backend ;
+IN: math.rectangles.prettyprint
+
+M: rect pprint*
+ \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
diff --git a/basis/math/rectangles/rectangles.factor b/basis/math/rectangles/rectangles.factor
index 340eafa37d..c8569dfdb9 100644
--- a/basis/math/rectangles/rectangles.factor
+++ b/basis/math/rectangles/rectangles.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays sequences math math.vectors accessors
-parser prettyprint.custom prettyprint.backend ;
+parser ;
IN: math.rectangles
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
@@ -10,9 +10,6 @@ TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
SYNTAX: RECT: scan-object scan-object <rect> parsed ;
-M: rect pprint*
- \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
-
: <zero-rect> ( -- rect ) rect new ; inline
: point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
@@ -64,3 +61,7 @@ M: rect contains-point?
[ [ loc>> ] dip (>>loc) ]
[ [ dim>> ] dip (>>dim) ]
2bi ; inline
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "math.rectangles.prettyprint" require ] when
\ No newline at end of file
diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
index f9f397d46f..5dd1710cdd 100644
--- a/basis/ui/gadgets/gadgets.factor
+++ b/basis/ui/gadgets/gadgets.factor
@@ -3,8 +3,7 @@
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals
-prettyprint.backend prettyprint.custom ;
+concurrency.flags math.order math.rectangles fry locals ;
IN: ui.gadgets
! Values for orientation slot
@@ -28,9 +27,6 @@ interior
boundary
model ;
-! Don't print gadgets with RECT: syntax
-M: gadget pprint* pprint-tuple ;
-
M: gadget equal? 2drop f ;
M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
@@ -397,3 +393,7 @@ M: f request-focus-on 2drop ;
: focus-path ( gadget -- seq )
[ focus>> ] follow ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "ui.gadgets.prettyprint" require ] when
\ No newline at end of file
diff --git a/basis/ui/gadgets/prettyprint/authors.txt b/basis/ui/gadgets/prettyprint/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/ui/gadgets/prettyprint/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/ui/gadgets/prettyprint/prettyprint.factor b/basis/ui/gadgets/prettyprint/prettyprint.factor
new file mode 100644
index 0000000000..82a89eda11
--- /dev/null
+++ b/basis/ui/gadgets/prettyprint/prettyprint.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ui.gadgets prettyprint.backend prettyprint.custom ;
+IN: ui.gadgets.prettyprint
+
+! Don't print gadgets with RECT: syntax
+M: gadget pprint* pprint-tuple ;
\ No newline at end of file
From aa3aa715beac977f8f207e5d090f7b0a03780a0b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 9 May 2009 20:24:32 -0500
Subject: [PATCH 59/72] Slightly more space-efficient dispatch table
representation
---
core/generic/single/single.factor | 2 +-
vm/dispatch.cpp | 11 +++++------
2 files changed, 6 insertions(+), 7 deletions(-)
diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor
index 36a76153f9..8d84b21bf7 100644
--- a/core/generic/single/single.factor
+++ b/core/generic/single/single.factor
@@ -163,7 +163,7 @@ M: hi-tag-dispatch-engine compile-engine
: build-fast-hash ( methods -- buckets )
>alist V{ } clone [ hashcode 1array ] distribute-buckets
- [ compile-engines* >alist >array ] map ;
+ [ compile-engines* >alist { } join ] map ;
M: echelon-dispatch-engine compile-engine
dup n>> 0 = [
diff --git a/vm/dispatch.cpp b/vm/dispatch.cpp
index 847a19d738..4a1411733e 100755
--- a/vm/dispatch.cpp
+++ b/vm/dispatch.cpp
@@ -8,15 +8,14 @@ cell megamorphic_cache_misses;
static cell search_lookup_alist(cell table, cell klass)
{
- array *pairs = untag<array>(table);
- fixnum index = array_capacity(pairs) - 1;
+ array *elements = untag<array>(table);
+ fixnum index = array_capacity(elements) - 2;
while(index >= 0)
{
- array *pair = untag<array>(array_nth(pairs,index));
- if(array_nth(pair,0) == klass)
- return array_nth(pair,1);
+ if(array_nth(elements,index) == klass)
+ return array_nth(elements,index + 1);
else
- index--;
+ index -= 2;
}
return F;
From d90bb0f336a214a65053c1657681adc86937d7c3 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 10 May 2009 10:41:50 -0500
Subject: [PATCH 60/72] 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 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 61/72] 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 62/72] 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 63/72] 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 64/72] 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 65/72] 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 66/72] 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 783c452a6ad0955495d3a1eed0f7e8b122eb3a60 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 10 May 2009 13:45:58 -0500
Subject: [PATCH 67/72] 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 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 68/72] 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 69/72] 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 70/72] 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 71/72] 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 72/72] 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