From 6c106fb4229f58174df2ceeda5be96a6ad913420 Mon Sep 17 00:00:00 2001
From: John Benediktsson <mrjbq7@gmail.com>
Date: Tue, 9 Apr 2013 12:07:49 -0700
Subject: [PATCH] math.factorials: more factorial words.

---
 extra/math/factorials/factorials-tests.factor |  6 +++++
 extra/math/factorials/factorials.factor       | 25 +++++++++++++++++--
 2 files changed, 29 insertions(+), 2 deletions(-)

diff --git a/extra/math/factorials/factorials-tests.factor b/extra/math/factorials/factorials-tests.factor
index 8a94308e3e..d708f7974f 100644
--- a/extra/math/factorials/factorials-tests.factor
+++ b/extra/math/factorials/factorials-tests.factor
@@ -65,3 +65,9 @@ IN: math.factorials
 [ 10 iota [ alternating-factorial ] map ] unit-test
 
 { { 1 1 2 9 262144 } } [ 5 iota [ exponential-factorial ] map ] unit-test
+
+{ V{ 2 3 5 7 23 719 5039 } }
+[ 10,000 iota [ factorial-prime? ] filter ] unit-test
+
+{ V{ 3 5 7 29 31 211 2309 2311 } }
+[ 10,000 iota [ primorial-prime? ] filter ] unit-test
diff --git a/extra/math/factorials/factorials.factor b/extra/math/factorials/factorials.factor
index 1f03a28456..8da12f447c 100644
--- a/extra/math/factorials/factorials.factor
+++ b/extra/math/factorials/factorials.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2013 John Benediktsson
 ! See http://factorcode.org/license.txt for BSD license
 
-USING: combinators fry kernel math math.functions math.primes
-math.ranges memoize sequences ;
+USING: combinators combinators.short-circuit fry kernel math
+math.functions math.primes math.ranges memoize sequences ;
 
 IN: math.factorials
 
@@ -101,3 +101,24 @@ ALIAS: pochhammer rising-factorial
 
 : exponential-factorial ( n -- m )
     dup 1 > [ [1,b] 1 [ swap ^ ] reduce ] [ drop 1 ] if ;
+
+: factorial-prime? ( n -- ? )
+    {
+        [ prime? ]
+        [
+            1 1 [ pick over - 1 <= ] [
+                drop [ 1 + ] [ factorial ] bi
+            ] until nip - abs 1 =
+        ]
+    } 1&& ;
+
+: primorial-prime? ( n -- ? )
+    {
+        [ prime? ]
+        [ 2 > ]
+        [
+            1 1 [ pick over - 1 <= ] [
+                drop [ 1 + ] [ primorial ] bi
+            ] until nip - abs 1 =
+        ]
+    } 1&& ;