From 4f7d80af7467fc83e062dc01b4324018e68d3b31 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 21 Apr 2005 04:49:19 +0000
Subject: [PATCH] some new math words, fix implementation of class< for unions

---
 library/collections/lists.factor  |  4 ++
 library/generic/union.factor      |  4 +-
 library/math/integer.factor       | 21 +++++++-
 library/math/math.factor          |  9 +---
 library/math/pow.factor           | 42 +++++++++++++---
 library/test/generic.factor       |  7 +++
 library/test/lists/lists.factor   |  3 ++
 library/test/math/bignum.factor   | 19 -------
 library/test/math/gcd.factor      | 27 ----------
 library/test/math/integer.factor  | 82 +++++++++++++++++++++++++++++++
 library/test/math/rational.factor | 27 ----------
 11 files changed, 155 insertions(+), 90 deletions(-)
 delete mode 100644 library/test/math/bignum.factor
 delete mode 100644 library/test/math/gcd.factor
 create mode 100644 library/test/math/integer.factor

diff --git a/library/collections/lists.factor b/library/collections/lists.factor
index 6d7303721f..b2a0e93aab 100644
--- a/library/collections/lists.factor
+++ b/library/collections/lists.factor
@@ -149,6 +149,10 @@ M: cons hashcode ( cons -- hash ) car hashcode ;
     #! list1.
     [ over contains? not ] subset nip ;
 
+: contained? ( list1 list2 -- ? )
+    #! Is every element of list1 in list2?
+    swap [ swap contains? ] all-with? ;
+
 : <queue> ( -- queue )
     #! Make a new functional queue.
     [[ [ ] [ ] ]] ;
diff --git a/library/generic/union.factor b/library/generic/union.factor
index 244523b832..0dfccbdaa0 100644
--- a/library/generic/union.factor
+++ b/library/generic/union.factor
@@ -20,7 +20,9 @@ union [
 
 union 55 "priority" set-word-prop
 
-union [ 2drop t ] "class<" set-word-prop
+union [
+    swap builtin-supertypes swap builtin-supertypes contained?
+] "class<" set-word-prop
 
 : union-predicate ( definition -- list )
     [
diff --git a/library/math/integer.factor b/library/math/integer.factor
index 992e52ec51..a00be15092 100644
--- a/library/math/integer.factor
+++ b/library/math/integer.factor
@@ -1,12 +1,29 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: math
+USING: errors generic kernel math ;
+
 BUILTIN: fixnum 0 ;
 BUILTIN: bignum 1 ;
 UNION: integer fixnum bignum ;
 
+: (gcd) ( b a y x -- a d )
+    dup 0 number= [
+        drop nip
+    ] [
+        tuck /mod >r pick * swap >r swapd - r> r> (gcd)
+    ] ifte ;
+
+: gcd ( x y -- a d )
+    #! Compute the greatest common divisor d and multiplier a
+    #! such that a*x=d mod y.
+    swap 0 1 2swap (gcd) abs ;
+
+: mod-inv ( x n -- y )
+    #! Compute the multiplicative inverse of x mod n.
+    gcd 1 = [ "Non-trivial divisor found" throw ] unless ;
+
 IN: math-internals
-USING: errors generic kernel math ;
 
 : fraction> ( a b -- a/b )
     dup 1 number= [
@@ -25,7 +42,7 @@ USING: errors generic kernel math ;
         dup 0 < [
             swap neg swap neg
         ] when
-        2dup gcd tuck /i >r /i r> fraction>
+        2dup gcd nip tuck /i >r /i r> fraction>
     ] ifte ; inline
 
 M: fixnum number=
diff --git a/library/math/math.factor b/library/math/math.factor
index 7ebef9d0c8..972ae0f053 100644
--- a/library/math/math.factor
+++ b/library/math/math.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: math
-USING: generic kernel math-internals ;
+USING: errors generic kernel math-internals ;
 
 ! Math operations
 2GENERIC: number= ( x y -- ? )
@@ -55,13 +55,6 @@ GENERIC: bitnot ( n -- n )
 
 GENERIC: abs ( z -- |z| )
 
-: (gcd) ( x y -- z )
-    dup 0 number= [ drop ] [ tuck mod (gcd) ] ifte ;
-
-: gcd ( x y -- z )
-    #! Greatest common divisor.
-    abs swap abs 2dup < [ swap ] when (gcd) ;
-
 : align ( offset width -- offset )
     2dup mod dup 0 number= [ 2drop ] [ - + ] ifte ;
 
diff --git a/library/math/pow.factor b/library/math/pow.factor
index eaf68852bb..3b72f69d94 100644
--- a/library/math/pow.factor
+++ b/library/math/pow.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2004, 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: math
-USING: math math-internals kernel ;
+USING: errors kernel math math-internals ;
 
 ! Power-related functions:
-!     exp log sqrt pow
+!     exp log sqrt pow ^mod
 
 : exp >rect swap fexp swap polar> ;
 : log >polar swap flog swap rect> ;
@@ -16,15 +16,45 @@ USING: math math-internals kernel ;
         swap fsqrt swap 2 / polar>
     ] ifte ;
 
+GENERIC: ^ ( z w -- z^w )
+
 : ^mag ( w abs arg -- magnitude )
     >r >r >rect swap r> swap fpow r> rot * fexp / ;
 
 : ^theta ( w abs arg -- theta )
     >r >r >rect r> flog * swap r> * + ;
 
-: ^ ( z w -- z^w )
-    over real? over integer? and [
-        fpow
+M: number ^ ( z w -- z^w )
+    swap >polar 3dup ^theta >r ^mag r> polar> ;
+
+: each-bit ( n quot -- | quot: 0/1 -- )
+    #! Apply the quotation to each bit of the number. The number
+    #! must be positive.
+    over 0 number= [
+        2drop
     ] [
-        swap >polar 3dup ^theta >r ^mag r> polar>
+        2dup >r >r >r 1 bitand r> call r> -1 shift r> each-bit
+    ] ifte ; inline
+
+: (integer^) ( z w -- z^w )
+    1 swap [ 1 number= [ dupd * ] when >r sq r> ] each-bit nip ;
+
+M: integer ^ ( z w -- z^w )
+    over 0 number= over 0 number= and [
+        "0^0 is not defined" throw
+    ] [
+        dup 0 < [ neg ^ recip ] [ (integer^) ] ifte
+    ] ifte ;
+
+: (^mod) ( n z w -- z^w )
+    1 swap [
+        1 number= [ dupd * pick mod ] when >r sq over mod r>
+    ] each-bit 2nip ;
+
+: ^mod ( z w n -- z^w )
+    #! Compute z^w mod n.
+    over 0 < [
+        [ >r neg r> ^mod ] keep mod-inv
+    ] [
+        -rot (^mod)
     ] ifte ;
diff --git a/library/test/generic.factor b/library/test/generic.factor
index c9ffbb9b38..7adeefad35 100644
--- a/library/test/generic.factor
+++ b/library/test/generic.factor
@@ -145,3 +145,10 @@ M: sequence testing 4 ;
 
 ! Bootstrap hashing
 [ f ] [ \ f \ unparse "methods" word-prop hash not ] unit-test
+
+GENERIC: union-containment
+M: integer union-containment drop 1 ;
+M: number union-containment drop 2 ;
+
+[ 1 ] [ 1 union-containment ] unit-test
+[ 2 ] [ 1.0 union-containment ] unit-test
diff --git a/library/test/lists/lists.factor b/library/test/lists/lists.factor
index ba0cd81e00..fa5e89ceed 100644
--- a/library/test/lists/lists.factor
+++ b/library/test/lists/lists.factor
@@ -49,3 +49,6 @@ USING: kernel lists sequences test ;
 [ [ 1 2 3 ] ] [ [ 1 2 3 4 ] 3 head ] unit-test
 
 [ [ 1 3 ] ] [ [ 2 ] [ 1 2 3 ] difference ] unit-test
+
+[ t ] [ [ 1 2 3 ] [ 1 2 3 4 5 ] contained? ] unit-test
+[ f ] [ [ 1 2 3 6 ] [ 1 2 3 4 5 ] contained? ] unit-test
diff --git a/library/test/math/bignum.factor b/library/test/math/bignum.factor
deleted file mode 100644
index c3b9e87517..0000000000
--- a/library/test/math/bignum.factor
+++ /dev/null
@@ -1,19 +0,0 @@
-IN: temporary
-USE: math
-USE: test
-USE: unparser
-USE: kernel
-
-[ -1 ] [ -1 >bignum >fixnum ] unit-test
-
-[ "8589934592" ]
-[ 134217728 dup + dup + dup + dup + dup + dup + unparse ]
-unit-test
-
-[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test
-[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
-[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
-[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
-[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
-[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
-[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
diff --git a/library/test/math/gcd.factor b/library/test/math/gcd.factor
deleted file mode 100644
index a1cd67b9e4..0000000000
--- a/library/test/math/gcd.factor
+++ /dev/null
@@ -1,27 +0,0 @@
-IN: temporary
-USE: math
-USE: test
-
-[ 100 ] [ 100 100 gcd ] unit-test
-[ 100 ] [ 1000 100 gcd ] unit-test
-[ 100 ] [ 100 1000 gcd ] unit-test
-[ 4 ] [ 132 64 gcd ] unit-test
-[ 4 ] [ -132 64 gcd ] unit-test
-[ 4 ] [ -132 -64 gcd ] unit-test
-[ 4 ] [ 132 -64 gcd ] unit-test
-[ 4 ] [ -132 -64 gcd ] unit-test
-
-[ 100 ] [ 100 >bignum 100 >bignum gcd ] unit-test
-[ 100 ] [ 1000 >bignum 100 >bignum gcd ] unit-test
-[ 100 ] [ 100 >bignum 1000 >bignum gcd ] unit-test
-[ 4 ] [ 132 >bignum 64 >bignum gcd ] unit-test
-[ 4 ] [ -132 >bignum 64 >bignum gcd ] unit-test
-[ 4 ] [ -132 >bignum -64 >bignum gcd ] unit-test
-[ 4 ] [ 132 >bignum -64 >bignum gcd ] unit-test
-[ 4 ] [ -132 >bignum -64 >bignum gcd ] unit-test
-
-[ 6 ] [
-    1326264299060955293181542400000006
-    1591517158873146351817850880000000
-    gcd
-] unit-test
diff --git a/library/test/math/integer.factor b/library/test/math/integer.factor
new file mode 100644
index 0000000000..3b79bbe074
--- /dev/null
+++ b/library/test/math/integer.factor
@@ -0,0 +1,82 @@
+IN: temporary
+USING: kernel math test unparser ;
+
+[ "-8" ] [ -8 unparse ] unit-test
+
+[ t ] [ 0 fixnum? ] unit-test
+[ t ] [ 31415 number? ] unit-test
+[ t ] [ 31415 >bignum number? ] unit-test
+[ t ] [ 2345621 fixnum? ] unit-test
+
+[ t ] [ 2345621 dup >bignum >fixnum = ] unit-test
+
+[ t ] [ 0 >fixnum 0 >bignum = ] unit-test
+[ f ] [ 0 >fixnum 1 >bignum = ] unit-test
+[ f ] [ 1 >bignum 0 >bignum = ] unit-test
+[ t ] [ 0 >bignum 0 >fixnum = ] unit-test
+
+[ t ] [ 0 >bignum bignum? ] unit-test
+[ f ] [ 0 >fixnum bignum? ] unit-test
+[ f ] [ 0 >fixnum bignum? ] unit-test
+[ t ] [ 0 >fixnum fixnum? ] unit-test
+
+[ -1 ] [ 1 neg ] unit-test
+[ -1 ] [ 1 >bignum neg ] unit-test
+
+[ 9 3 ] [ 93 10 /mod ] unit-test
+[ 9 3 ] [ 93 >bignum 10 /mod ] unit-test
+
+[ 5 ] [ 2 >bignum 3 >bignum + ] unit-test
+
+[ 100 ] [ 100 100 gcd nip ] unit-test
+[ 100 ] [ 1000 100 gcd nip ] unit-test
+[ 100 ] [ 100 1000 gcd nip ] unit-test
+[ 4 ] [ 132 64 gcd nip ] unit-test
+[ 4 ] [ -132 64 gcd nip ] unit-test
+[ 4 ] [ -132 -64 gcd nip ] unit-test
+[ 4 ] [ 132 -64 gcd nip ] unit-test
+[ 4 ] [ -132 -64 gcd nip ] unit-test
+
+[ 100 ] [ 100 >bignum 100 >bignum gcd nip ] unit-test
+[ 100 ] [ 1000 >bignum 100 >bignum gcd nip ] unit-test
+[ 100 ] [ 100 >bignum 1000 >bignum gcd nip ] unit-test
+[ 4 ] [ 132 >bignum 64 >bignum gcd nip ] unit-test
+[ 4 ] [ -132 >bignum 64 >bignum gcd nip ] unit-test
+[ 4 ] [ -132 >bignum -64 >bignum gcd nip ] unit-test
+[ 4 ] [ 132 >bignum -64 >bignum gcd nip ] unit-test
+[ 4 ] [ -132 >bignum -64 >bignum gcd nip ] unit-test
+
+[ 6 ] [
+    1326264299060955293181542400000006
+    1591517158873146351817850880000000
+    gcd nip
+] unit-test
+
+: verify-gcd ( x y )
+    2dup gcd ( a d )
+    >r rot * swap rem r> = ; 
+
+[ t ] [ 123 124 verify-gcd ] unit-test
+[ t ] [ 50 120 verify-gcd ] unit-test
+[ 3 ] [ 5 7 mod-inv ] unit-test
+[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
+
+[ -1 ] [ -1 >bignum >fixnum ] unit-test
+
+[ "8589934592" ]
+[ 134217728 dup + dup + dup + dup + dup + dup + unparse ]
+unit-test
+
+[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test
+[ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
+[ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
+[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
+[ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
+[ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
+[ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test
+
+[ 0 0 ^ ] unit-test-fails
+[ 1 ] [ 10 0 ^ ] unit-test
+[ 1/8 ] [ 1/2 3 ^ ] unit-test
+[ 1/8 ] [ 2 -3 ^ ] unit-test
+[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
diff --git a/library/test/math/rational.factor b/library/test/math/rational.factor
index 019fde2c7a..b6aea26359 100644
--- a/library/test/math/rational.factor
+++ b/library/test/math/rational.factor
@@ -4,33 +4,6 @@ USE: math
 USE: test
 USE: unparser
 
-[ "-8" ] [ -8 unparse ] unit-test
-
-[ t ] [ 0 fixnum? ] unit-test
-[ t ] [ 31415 number? ] unit-test
-[ t ] [ 31415 >bignum number? ] unit-test
-[ t ] [ 2345621 fixnum? ] unit-test
-
-[ t ] [ 2345621 dup >bignum >fixnum = ] unit-test
-
-[ t ] [ 0 >fixnum 0 >bignum = ] unit-test
-[ f ] [ 0 >fixnum 1 >bignum = ] unit-test
-[ f ] [ 1 >bignum 0 >bignum = ] unit-test
-[ t ] [ 0 >bignum 0 >fixnum = ] unit-test
-
-[ t ] [ 0 >bignum bignum? ] unit-test
-[ f ] [ 0 >fixnum bignum? ] unit-test
-[ f ] [ 0 >fixnum bignum? ] unit-test
-[ t ] [ 0 >fixnum fixnum? ] unit-test
-
-[ -1 ] [ 1 neg ] unit-test
-[ -1 ] [ 1 >bignum neg ] unit-test
-
-[ 9 3 ] [ 93 10 /mod ] unit-test
-[ 9 3 ] [ 93 >bignum 10 /mod ] unit-test
-
-[ 5 ] [ 2 >bignum 3 >bignum + ] unit-test
-
 [ 1/2 ] [ 1 >bignum 2 >bignum / ] unit-test
 [ t ] [ 10 3 / ratio? ] unit-test
 [ f ] [ 10 2 / ratio? ] unit-test