Folds

February 2, 2018

Here they are:

(define (foldr f a xs)
  (if (null? xs) a
    (f (car xs) (foldr f a (cdr xs)))))
(define (foldl f a xs)
  (if (null? xs) a
    (foldl f (f a (car xs)) (cdr xs))))
(define (foldr1 f xs)
  (if (null? (cdr xs)) (car xs)
    (f (car xs) (foldr1 f (cdr xs)))))
(define (foldl1 f xs)
  (foldl f (car xs) (cdr xs)))
(define (scan f a xs)
  (define (scanx f a xs)
    (if (null? xs) xs
      (scan f (f a (car xs)) (cdr xs))))
  (cons a (scanx f a xs)))

Foldr and foldl are the obvious recursive definitions.Foldl1 simply extracts the first item from the input list and calls foldl. Be sure to examine closely the local function and recursion of scan.

By the way, it is possible to implement foldl in terms of foldr:

(define (foldl-from-foldr f a xs)
  ((foldr (lambda (item accum)
            (lambda (x) (accum (f item x))))
          (lambda (x) x)
          xs)
   a))

Here, we accumulate lambdas that contain delayed computations, rather than values, and at the end the entire chain of lambdas is applied to the base value to ignite the computation; the initial lambda is the identity procedure. This works the same way as normal foldl:

> (foldl-from-foldr + 0 '(1 2 3 4))
10
> (foldl-from-foldr cons '() '(1 2 3 4))
(4 3 2 1)

It’s also possible to write foldr in terms of foldl, but it’s messy and has limitations; see https://wiki.haskell.org/Foldl_as_foldr if you are interested.

Here is the complete list of examples from the first page, including definitions of plusone and snoc:

> (foldr + 0 '(1 2 3 4))
10
> (foldl + 0 '(1 2 3 4))
10
> (foldr cons '() '(1 2 3 4))
(1 2 3 4)
> (foldl cons '() '(1 2 3 4))
((((() . 1) . 2) . 3) . 4)
> (define (plusone _ n) (+ n 1))
> (foldr plusone 0 '(1 2 3 4)) ; length
4
> (define (snoc xs x) (cons x xs))
> (foldl snoc '() '(1 2 3 4)) ; reverse
(4 3 2 1)
> (foldr1 max '(1 2 3 4))
4
> (foldl1 max '(1 2 3 4))
4
> (scan + 0 '(1 2 3 4))
(0 1 3 6 10)
> (map reverse (scan snoc '() '(1 2 3 4)))
(() (1) (1 2) (1 2 3) (1 2 3 4))

You can run the program at https://ideone.com/lgKnS1.

Advertisements

Pages: 1 2

5 Responses to “Folds”

  1. chaw said

    Here’s a fully tail-recursive solution in standard R7RS Scheme.

    (import (scheme base)
            (scheme write))
    
    (define (reverse-arguments proc)
      (lambda args
        (apply proc (reverse args))))
    
    (define snoc (reverse-arguments cons))
    
    (define-syntax show/result
      (syntax-rules ()
        ((_ e ...) (begin (begin (display 'e)
                                 (newline)
                                 (display e)
                                 (newline))
                          ...))))
    
    (define (foldl f a xs)
      (if (null? xs)
          a
          (foldl f (f a (car xs)) (cdr xs))))
    
    (show/result (foldl cons '() '(1 2 3))
                 (foldl snoc '() '(1 2 3)))
    
    (define (foldr f a xs)
      (let lp ((xs (reverse xs))
               (a a))
        (if (null? xs)
            a
            (lp (cdr xs)
                (f (car xs) a)))))
    
    (show/result (foldr + 0 '(1 2 3 4))
                 (foldl + 0 '(1 2 3 4))
                 (foldr cons '() '(1 2 3 4))
                 (foldl cons '() '(1 2 3 4))
                 (foldr (lambda (x y) (+ y 1)) 0 '(1 2 3 4))
                 (foldl snoc '() '(1 2 3 4)))
    
    (define (foldl1 f xs)
      (foldl f (car xs) (cdr xs)))
    
    (define (foldr1 f xs)
      (let ((xs (reverse xs)))
        (let lp ((xs (cdr xs))
                 (a (car xs)))
          (if (null? xs)
              a
              (lp (cdr xs)
                  (f (car xs) a))))))
    
    (show/result (foldr1 max '(1 2 3 4))
                 (foldl1 min '(1 2 3 4))
                 (foldr1 cons '(1 2 3 4))
                 (foldl1 cons '(1 2 3 4)))
    
    (define (scan f a xs)
      (let lp ((xs xs)
               (r (list a)))
        (if (null? xs)
            (reverse r) 
            (lp (cdr xs)
                (cons (f (car r) (car xs))
                      r)))))
    
    (show/result (scan + 0 '(1 2 3 4))
                 (scan snoc '() '(1 2 3 4)))
    

  2. Daniel said

    Here’s a solution in C.

    #include <stdio.h>
    #include <stdlib.h>
    #include <string.h>
    
    void foldr(void (*function)(const void* x, void* accumulatorp),
               void* accumulatorp,
               void* array,
               size_t nel,
               size_t width) {
      for (size_t i = 0; i < nel; ++i) {
        char* p = (char*)array;
        function(p + width * (nel - 1 - i), accumulatorp);
      }
    }
    
    void foldl(void (*function)(void* accumulatorp, const void* x),
               void* accumulatorp,
               void* array,
               size_t nel,
               size_t width) {
      for (size_t i = 0; i < nel; ++i) {
        char* p = (char*)array;
        function(accumulatorp, p + width * i);
      }
    }
    
    void foldr1(void (*function)(const void* x, void* accumulatorp),
                void* accumulatorp,
                void* array,
                size_t nel,
                size_t width) {
      memcpy(accumulatorp, array, width);
      foldr(function, accumulatorp, array, nel, width);
    }
    
    void foldl1(void (*function)(void* accumulatorp, const void* x),
                void* accumulatorp,
                void* array,
                size_t nel,
                size_t width) {
      memcpy(accumulatorp, array, width);
      foldl(function, accumulatorp, array, nel, width);
    }
    
    void scan(void (*function)(void* accumulatorp, const void* x),
              void* accumulatorp,
              void* input,
              size_t input_width,
              void* output,
              size_t output_width,
              size_t nel) {
      char* pin = (char*)input;
      char* pout = (char*)output;
      memcpy(pout, accumulatorp, output_width);
      for (size_t i = 0; i < nel; ++i) {
        function(accumulatorp, pin + input_width * i);
        memcpy(pout + output_width * (i + 1), accumulatorp, output_width);
      }
    }
    
    void addr(const void* x, void* accumulatorp) {
      *(int*)accumulatorp += *(int*)x;
    }
    
    void addl(void* accumulatorp, const void* x) {
      *(int*)accumulatorp += *(int*)x;
    }
    
    void appendr(const void* x, void* accumulatorp) {
      **((int**)accumulatorp) = *(int*)x;
      (*(int**)accumulatorp)++;
    }
    
    void appendl(void* accumulatorp, const void* x) {
      appendr(x, accumulatorp);
    }
    
    void plusoner(const void* x, void* accumulatorp) {
      (void)x;
      (*(int*)accumulatorp)++;
    }
    
    void maxr(const void* x, void* accumulatorp) {
      if (*(int*)x > *(int*)accumulatorp) {
        *(int*)accumulatorp = *(int*)x;
      }
    }
    
    void minl(void* accumulatorp, const void* x) {
      if (*(int*)x < *(int*)accumulatorp) {
        *(int*)accumulatorp = *(int*)x;
      }
    }
    
    void print_array(int* array, size_t nel) {
      printf("{");
      for (size_t i = 0; i < nel; ++i) {
        if (i > 0) printf(",");
        printf("%d", array[i]);
      }
      printf("}");
    }
    
    int main(void) {
      int array[] = {1,2,3,4};
      size_t nel = sizeof(array) / sizeof(int);
      {
        int accumulator = 0;
        foldr(addr, &accumulator, array, nel, sizeof(int));
        printf("foldr add 0 {1,2,3,4}\n  ");
        printf("%d\n", accumulator);
      }
      {
        int* accumulator_base = alloca(sizeof(int) * nel);
        int* accumulator = accumulator_base; 
        foldr(appendr, &accumulator_base, array, nel, sizeof(int));
        printf("foldr append {...} {1,2,3,4}\n  ");
        print_array(accumulator, nel);
        printf("\n");
      }
      {
        int* accumulator_base = alloca(sizeof(int) * nel);
        int* accumulator = accumulator_base; 
        foldl(appendl, &accumulator_base, array, nel, sizeof(int));
        printf("foldl append {...} {1,2,3,4}\n  ");
        print_array(accumulator, nel);
        printf("\n");
      }
      {
        int accumulator = 0;
        foldr(plusoner, &accumulator, array, nel, sizeof(int));
        printf("foldr plusone 0 {1,2,3,4}\n  ");
        printf("%d\n", accumulator);
      }
      {
        int accumulator;
        foldr1(maxr, &accumulator, array, nel, sizeof(int));
        printf("foldr1 max {1,2,3,4}\n  ");
        printf("%d\n", accumulator);
      }
      {
        int accumulator;
        foldl1(minl, &accumulator, array, nel, sizeof(int));
        printf("foldl1 min {1,2,3,4}\n  ");
        printf("%d\n", accumulator);
      }
      {
        int accumulator = 0;
        int output[nel+1];
        scan(addl, &accumulator, array, sizeof(int), output, sizeof(int), nel);
        printf("scan add {1,2,3,4}\n  ");
        print_array(output, nel+1);
        printf("\n");
      }
      return 0;
    }
    

    Output:

    foldr add 0 {1,2,3,4}
      10
    foldr append {...} {1,2,3,4}
      {4,3,2,1}
    foldl append {...} {1,2,3,4}
      {1,2,3,4}
    foldr plusone 0 {1,2,3,4}
      4
    foldr1 max {1,2,3,4}
      4
    foldl1 min {1,2,3,4}
      1
    scan add {1,2,3,4}
      {0,1,3,6,10}
    
  3. matthew said

    Folds make sense for any algebraic data type, so we can fold over trees, for example:

    data Tree a = Nil | Tree (Tree a) a (Tree a) deriving (Show)
    fold f x Nil = x
    fold f x (Tree t1 n t2) = f (fold f x t1) n (fold f x t2)
    
    dup = fold Tree Nil -- Duplicate
    rev = fold (flip3 Tree) Nil where
      flip3 f a b c = f c b a
    flatten = fold f Nil where
      f Nil a t = Tree Nil a t
      f (Tree t1 a1 t2) a2 t3 = Tree t1 a1 (f t2 a2 t3)
    tsum = fold add3 0 where
      add3 a b c = a+b+c
    
    t :: Tree Integer
    t = Tree (Tree Nil 1 Nil) 2 (Tree (Tree Nil 3 Nil) 4 Nil)
    
    main =
      print (tsum t) >>
      print (dup t) >>
      print (rev t) >> 
      print (flatten t) >> 
      return()
    

    Implementation of the various derived folds is left as an exercise.

  4. matthew said

    Here’s one that takes a two-argument function:

    mfold :: (a -> b -> b) -> b -> Tree a -> b
    mfold f x Nil = x
    mfold f x (Tree t1 n t2) = mfold f (f n (mfold f x t1)) t2
    tsum = mfold (+) 0 -- add up elements, again
    tolist = mfold (:) [] -- list fringe (in reverse!)
    
  5. Globules said

    Here’s some Haskell…

    import Prelude hiding (foldl, foldl1, foldr, foldr1, scanl, scanr,
                           all, any, map, maximum, minimum)
    import qualified Data.List
    
    foldr :: (a -> b -> b) -> b -> [a] -> b
    foldr _ e []     = e
    foldr f e (x:xs) = x `f` foldr f e xs
    
    foldr1 :: (a -> a -> a) -> [a] -> a
    foldr1 _ []     = error "called foldr1 with empty list"
    foldr1 f (x:xs) = foldr f x xs
    
    scanr :: (a -> b -> b) -> b -> [a] -> [b]
    scanr f e = foldr (\x (y:ys) -> x `f` y : (y:ys)) [e]
    
    foldl :: (b -> a -> b) -> b -> [a] -> b
    foldl _ e []     = e
    foldl f e (x:xs) = foldl f (e `f` x) xs
    
    foldl1 :: (a -> a -> a) -> [a] -> a
    foldl1 _ []     = error "called foldl1 with empty list"
    foldl1 f (x:xs) = foldl f x xs
    
    scanl :: (b -> a -> b) -> b -> [a] -> [b]
    scanl _ e []     = [e]
    scanl f e (x:xs) = e : scanl f (e `f` x) xs
    
    --------------------------------------------------------------------------------
    
    -- Here are various familiar functions implemented using our folds and scans.
    -- 
    -- Note that they may not be the most efficient implementations in Haskell,
    -- especially those based on left folds.
    
    map :: (a -> b) -> [a] -> [b]
    map f = foldr (\x xs -> f x : xs) []
    
    maximum :: Ord a => [a] -> a
    maximum = foldr1 max
    
    minimum :: Ord a => [a] -> a
    minimum = foldl1 min
    
    any :: (a -> Bool) -> [a] -> Bool
    any p = foldr (\x b -> p x || b) False
    
    all :: (a -> Bool) -> [a] -> Bool
    all p = foldl (\b x -> p x && b) True
    
    inits :: [a] -> [[a]]
    inits = scanl (\xs x -> xs ++ [x]) []
    
    tails :: [a] -> [[a]]
    tails = scanr (:) []
    
    --------------------------------------------------------------------------------
    
    test :: (Eq d, Show d) => (a -> b -> c -> d) ->
                              (a -> b -> c -> d) ->
                              a -> b -> c ->
                              IO ()
    test f1 f2 g e xs =
      let r1 = f1 g e xs
          r2 = f2 g e xs
      in putStrLn $ show r1 ++ " == " ++ show r2 ++ " ?  " ++ show (r1 == r2)
    
    main :: IO ()
    main = do
      let xs = [1..5] :: [Int]
      
      -- Check that our functions give the same results as the standard ones.
      
      test Data.List.foldr foldr (+) 0 xs                   -- sum
      test Data.List.foldr foldr (*) 1 xs                   -- product
      test Data.List.foldr foldr (-) 3 xs
      test Data.List.foldr foldr (:) [] xs                  -- id
      test Data.List.foldr foldr (\y ys -> ys ++ [y]) [] xs -- reverse
    
      test Data.List.foldl foldl (+) 0 xs                   -- sum
      test Data.List.foldl foldl (*) 1 xs                   -- product
      test Data.List.foldl foldl (-) 3 xs
      test Data.List.foldl foldl (\ys y -> ys ++ [y]) [] xs -- id
      test Data.List.foldl foldl (flip (:)) [] xs           -- reverse
      
      -- Exercise our versions of some common functions.
      
      print $ map (+2) xs
      print $ maximum xs
      print $ minimum xs
      print $ any (> 3) xs
      print $ all (> 3) xs
      print $ inits xs
      print $ tails xs
    
    $ ./folds 
    15 == 15 ?  True
    120 == 120 ?  True
    0 == 0 ?  True
    [1,2,3,4,5] == [1,2,3,4,5] ?  True
    [5,4,3,2,1] == [5,4,3,2,1] ?  True
    15 == 15 ?  True
    120 == 120 ?  True
    -12 == -12 ?  True
    [1,2,3,4,5] == [1,2,3,4,5] ?  True
    [5,4,3,2,1] == [5,4,3,2,1] ?  True
    [3,4,5,6,7]
    5
    1
    True
    False
    [[],[1],[1,2],[1,2,3],[1,2,3,4],[1,2,3,4,5]]
    [[1,2,3,4,5],[2,3,4,5],[3,4,5],[4,5],[5],[]]
    

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

%d bloggers like this: