math.extras: adding integer-sqrt.

diff --git a/extra/math/extras/extras-tests.factor b/extra/math/extras/extras-tests.factor
index 1d10a680d9a2b5e1c66332ae71d1866c350d9f20..75caa52676fbdac6a36d4ff2a3126f83de92d690 100644 (file)
--- a/extra/math/extras/extras-tests.factor
+++ b/extra/math/extras/extras-tests.factor
@@ -151,3 +151,9 @@ tools.test ;
 { 1/5 } [ 3/5 1 kelly ] unit-test
 { 0 } [ 1/2 1 kelly ] unit-test
 { -1/5 } [ 2/5 1 kelly ] unit-test
+
+[ -1 integer-sqrt ] must-fail
+{ 0 } [ 0 integer-sqrt ] unit-test
+{ 3 } [ 12 integer-sqrt ] unit-test
+{ 4 } [ 16 integer-sqrt ] unit-test
+{ 44 } [ 2019 integer-sqrt ] unit-test

diff --git a/extra/math/extras/extras.factor b/extra/math/extras/extras.factor
index 8136bdbd555797bf61004dd483c3e940a10d6ef3..b38d98d0bf07e313ded3823d6d7de9cf5f0bf351 100644 (file)
--- a/extra/math/extras/extras.factor
+++ b/extra/math/extras/extras.factor
@@ -3,11 +3,11 @@
 
 USING: accessors arrays assocs assocs.extras byte-arrays
 combinators combinators.short-circuit compression.zlib fry
-grouping kernel locals math math.combinatorics math.constants
-math.functions math.order math.primes math.primes.factors
-math.ranges math.ranges.private math.statistics math.vectors
-memoize parser random sequences sequences.extras
-sequences.private sets sorting sorting.extras ;
+grouping kernel locals math math.bitwise math.combinatorics
+math.constants math.functions math.order math.primes
+math.primes.factors math.ranges math.ranges.private
+math.statistics math.vectors memoize parser random sequences
+sequences.extras sequences.private sets sorting sorting.extras ;
 
 IN: math.extras
 
@@ -357,3 +357,18 @@ M: iota sum-cubes sum sq ;
 
 : kelly ( winning-probability odds -- fraction )
     [ 1 + * 1 - ] [ / ] bi ;
+
+:: integer-sqrt ( m -- n )
+    m [ 0 ] [
+        dup 0 < [ non-negative-integer-expected ] when
+        bit-length 1 - 2 /i :> c
+        1 :> a!
+        0 :> d!
+        c bit-length <iota> <reversed> [| s |
+            d :> e
+            c s neg shift d!
+            a d e - 1 - shift
+            m 2 c * e - d - 1 + neg shift a /i + a!
+        ] each
+        a a sq m > [ 1 - ] when
+    ] if-zero ;