Merge pull request #78 from jacereda/divide-and-conquer-traverse-2

Divide and conquer traverse 2

Author: garyb

bower.json

@@ -25,6 +25,7 @@
     "purescript-assert": "#compiler/0.12",
     "purescript-console": "#compiler/0.12",
     "purescript-integers": "#compiler/0.12",
-    "purescript-math": "#compiler/0.12"
+    "purescript-math": "#compiler/0.12",
+    "purescript-unsafe-coerce": "#compiler/0.12"
   }
 }

src/Data/Traversable.js

@@ -3,59 +3,49 @@
 // jshint maxparams: 3
 
 exports.traverseArrayImpl = function () {
-  function Cont(fn) {
-    this.fn = fn;
+  function array1(a) {
+    return [a];
   }
 
-  var emptyList = {};
-
-  var ConsCell = function (head, tail) {
-    this.head = head;
-    this.tail = tail;
-  };
+  function array2(a) {
+    return function (b) {
+      return [a, b];
+    };
+  }
 
-  function consList(x) {
-    return function (xs) {
-      return new ConsCell(x, xs);
+  function array3(a) {
+    return function (b) {
+      return function (c) {
+        return [a, b, c];
+      };
     };
   }
 
-  function listToArray(list) {
-    var arr = [];
-    var xs = list;
-    while (xs !== emptyList) {
-      arr.push(xs.head);
-      xs = xs.tail;
-    }
-    return arr;
+  function concat2(xs) {
+    return function (ys) {
+      return xs.concat(ys);
+    };
   }
 
   return function (apply) {
     return function (map) {
       return function (pure) {
         return function (f) {
-          var buildFrom = function (x, ys) {
-            return apply(map(consList)(f(x)))(ys);
-          };
-
-          var go = function (acc, currentLen, xs) {
-            if (currentLen === 0) {
-              return acc;
-            } else {
-              var last = xs[currentLen - 1];
-              return new Cont(function () {
-                return go(buildFrom(last, acc), currentLen - 1, xs);
-              });
-            }
-          };
-
           return function (array) {
-            var result = go(pure(emptyList), array.length, array);
-            while (result instanceof Cont) {
-              result = result.fn();
+            function go(bot, top) {
+              switch (top - bot) {
+              case 0: return pure([]);
+              case 1: return map(array1)(f(array[bot]));
+              case 2: return apply(map(array2)(f(array[bot])))(f(array[bot + 1]));
+              case 3: return apply(apply(map(array3)(f(array[bot])))(f(array[bot + 1])))(f(array[bot + 2]));
+              default:
+                // This slightly tricky pivot selection aims to produce two
+                // even-length partitions where possible.
+                var pivot = bot + Math.floor((top - bot) / 4) * 2;
+                return apply(map(concat2)(go(bot, pivot)))(go(pivot, top));
+              }
             }
-
-            return map(listToArray)(result);
+            return go(0, array.length);
           };
         };
       };

test/Main.js

@@ -7,3 +7,13 @@ exports.arrayFrom1UpTo = function (n) {
   }
   return result;
 };
+
+exports.arrayReplicate = function (n) {
+  return function (x) {
+    var result = [];
+    for (var i = 1; i <= n; i++) {
+      result.push(x);
+    }
+    return result;
+  };
+};

test/Main.purs

@@ -2,24 +2,34 @@ module Test.Main where
 
 import Prelude
 
-import Effect (Effect)
-import Effect.Console (log)
 import Data.Bifoldable (class Bifoldable, bifoldl, bifoldr, bifoldMap, bifoldrDefault, bifoldlDefault, bifoldMapDefaultR, bifoldMapDefaultL)
 import Data.Bifunctor (class Bifunctor, bimap)
 import Data.Bitraversable (class Bitraversable, bisequenceDefault, bitraverse, bisequence, bitraverseDefault)
 import Data.Foldable (class Foldable, find, findMap, fold, indexl, indexr, foldMap, foldMapDefaultL, foldMapDefaultR, foldl, foldlDefault, foldr, foldrDefault, length, maximum, maximumBy, minimum, minimumBy, null, surroundMap)
 import Data.FoldableWithIndex (class FoldableWithIndex, findWithIndex, foldMapWithIndex, foldMapWithIndexDefaultL, foldMapWithIndexDefaultR, foldlWithIndex, foldlWithIndexDefault, foldrWithIndex, foldrWithIndexDefault, surroundMapWithIndex)
 import Data.Function (on)
 import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
-import Data.Int (toNumber)
+import Data.Int (toNumber, pow)
 import Data.Maybe (Maybe(..))
 import Data.Monoid.Additive (Additive(..))
+import Data.Newtype (unwrap)
 import Data.Traversable (class Traversable, sequenceDefault, traverse, sequence, traverseDefault)
 import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
+import Effect (Effect, foreachE)
+import Effect.Console (log)
 import Math (abs)
-import Test.Assert (assert)
+import Test.Assert (assert, assert')
+import Unsafe.Coerce (unsafeCoerce)
 
 foreign import arrayFrom1UpTo :: Int -> Array Int
+foreign import arrayReplicate :: forall a. Int -> a -> Array a
+
+foldableLength :: forall f a. Foldable f => f a -> Int
+foldableLength = unwrap <<< foldMap (const (Additive 1))
+
+-- Ensure that a value is evaluated 'lazily' by treating it as an Eff action.
+deferEff :: forall a. (Unit -> a) -> Effect a
+deferEff = unsafeCoerce
 
 main :: Effect Unit
 main = do
@@ -43,8 +53,9 @@ main = do
   log "Test foldrDefault"
   testFoldableFoldrDefault 20
 
-  log "Test traversableArray instance"
-  testTraversableArrayWith 20
+  foreachE [1,2,3,4,5,10,20] \i -> do
+    log $ "Test traversableArray instance with an array of size: " <> show i
+    testTraversableArrayWith i
 
   log "Test traversableArray instance is stack safe"
   testTraversableArrayWith 20000
@@ -234,19 +245,33 @@ testFoldableWithIndexLawsOn c f g = do
   assert $ foldMapWithIndex f c == foldrWithIndexDefault (\i x y -> f i x <> y) mempty c
 
 testTraversableFWith
-  :: forall f 
+  :: forall f
    . Traversable f
   => Eq (f Int)
   => (Int -> f Int)
   -> Int
   -> Effect Unit
 testTraversableFWith f n = do
   let dat = f n
+  let len = foldableLength dat
+
+  _ <- traverse pure dat
+
+  assert' "traverse Just == Just" $ traverse Just dat == Just dat
+  assert' "traverse pure == pure (Array)" $ traverse pure dat == [dat]
+
+  when (len <= 10) do
+    result <- deferEff \_ -> traverse (\x -> [x,x]) dat == arrayReplicate (pow 2 len) dat
+    assert' "traverse with Array as underlying applicative" result
+
+  assert' "traverse (const Nothing) == const Nothing" $
+    traverse (const Nothing :: Int -> Maybe Int) dat == Nothing
+
+  assert' "sequence <<< map f == traverse f" $
+    sequence (map Just dat) == traverse Just dat
 
-  assert $ traverse Just dat == Just dat
-  assert $ traverse pure dat == [dat]
-  assert $ traverse (\x -> if x < 10 then Just x else Nothing) dat == Nothing
-  assert $ sequence (map Just dat) == traverse Just dat
+  assert' "underlying applicative" $
+    (traverse pure dat :: Unit -> f Int) unit == dat
 
 testTraversableArrayWith :: Int -> Effect Unit
 testTraversableArrayWith = testTraversableFWith arrayFrom1UpTo