## 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.

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;
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);
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
{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

```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],[]]
```