What is your favourite cleverly written functional code?

Question

What are your favourite short, mind-blowing snippets in functional languages?

My two favourite ones are (Haskell):

powerset = filterM (const [True, False]) 

foldl f v xs = foldr (\x g a -> g (f a x)) id xs v -- from Hutton's tutorial

(I tagged the question as Haskell, but examples in all languages - including non-FP ones - are welcome as long as they are in functional spirit.)

Answer 1

bwp xs = map snd $ sort $ zip (rots xs) (rrot xs)
rots xs = take (length xs) (iterate lrot xs)
lrot xs = tail xs ++ [head xs]
rrot xs = last xs : init xs

The (forwards) Burrows-Wheeler Transform, from a Functional Pearl paper. BWT is used as the second stage in the bzip2 compression (after run-length encoding), grouping similar features together to make most inputs more compressible by the following stages.

The paper also has a couple implementations for the inverse, also elegant but not quite as short.

Answer 2

If C++ metaprogramming counts, I choose the first metaprogram ever created :)

// Prime number computation by Erwin Unruh
template <int i> struct D { D(void*); operator int(); };

template <int p, int i> struct is_prime {
    enum { prim = (p%i) && is_prime<(i > 2 ? p : 0), i -1> :: prim };
    };

template < int i > struct Prime_print {
    Prime_print<i-1> a;
    enum { prim = is_prime<i, i-1>::prim };
    void f() { D<i> d = prim; }
    };

struct is_prime<0,0> { enum {prim=1}; };
struct is_prime<0,1> { enum {prim=1}; };
struct Prime_print<2> { enum {prim = 1}; void f() { D<2> d = prim; } };
#ifndef LAST
#define LAST 10
#endif
main () {
    Prime_print<LAST> a;
    }

Answer 3

Definitely this one (from wikipedia) for a short RPN-interpreter.

calc = foldl f [] . words
  where 
    f (x:y:zs) "+" = (y + x):zs
    f (x:y:zs) "-" = (y - x):zs
    f (x:y:zs) "*" = (y * x):zs
    f (x:y:zs) "/" = (y / x):zs
    f xs y = read y : xs

And to bring a slightly more complicated example ;-): Linq raytracer

Answer 4

Calculating the list of all Fibonacci numbers, lazily. Code snippet written in Scala.

class ConsStream[T](str: => Stream[T]) {
  def ::(element: T) = Stream.cons(element, str)
}

implicit def stream2ConsStream[T](str: => Stream[T]) = new ConsStream[T](str)

lazy val fib: Stream[BigInt] = 0 :: 1 :: fib.zip(fib.tail).map(n => n._1 + n._2)

This can be made shorter (but not as nice) without using the implicit conversion that adds the :: operator to a Stream, by writing

lazy val fib: Stream[BigInt] = 
  Stream.cons(0, Stream.cons(1, fib.zip(fib.tail).map(n => n._1 + n._2)))

-- Flaviu Cipcigan

Answer 5

I'm always impressed when I see Haskell functions that feed part of their output into the input of the same function.

As a contrived example, I'll show how to find the mean average of a list.

This basic example requires 2 traversals through the list:

average_basic :: [Double] -> Double
average_basic xs = sum xs / length xs

This example leverages the power of lazy evaluation to feed part of the results of a function back into the function call itself:

average :: [Double] -> Double
average xs = s
  -- avg calculates the length of a list, then feeds that result back into itself
  -- to total up the average number.
  where (s, len) = avg len xs

-- Given the length of a list, scan through it calculating the average and length
-- along the way.
avg :: Double -> [Double] -> (Double, Double)
avg len xs = foldl' op (0, 0) xs
  where op (res, l) x = (res + x / len, l + 1)

example run:

Prelude> :m +Data.List
Prelude Data.List> let avg len xs = foldl' op (0, 0) xs where op (res, l) x = (res + x / len, l + 1)

Prelude Data.List> let average xs = s where (s, len) = avg len xs
Prelude Data.List> average [1..10]
5.5
Prelude Data.List>

Answer 6

As noted by Ron Jeffries on his blog

#define pi 3.14159

//z = radius
//a = thickness
float volume (float a, float z) { return pi*z*z*a; }

Answer 7

Courtesy of Douglas Crockford:

function Y(le) {
    return (function (f) {
        return f(f);
    }(function (f) {
        return le(function (x) {
            return f(f)(x);
        });
    }));
}

And the inevitable application:

var factorial = Y(function (fac) {
    return function (n) {
        return n <= 2 ? n : n * fac(n - 1);
    };
});

var number120 = factorial(5);

For more exploration of the fine line between clever and stupid, see Evolution of a Haskell Programmer.

Answer 8

I got this from Sean Seefried. Here we use tying the knot to replace all leaves of a tree with the minimal leaf value in a single pass.

data Tree
  = Fork Tree Tree
  | Leaf Int

aux i (Leaf i') = (i', Leaf i)
aux i (Fork t1 t2) =
  let (m1, t1') = aux i t1
      (m2, t2') = aux i t2
  in  (min m1 m2, Fork t1' t2')

replaceMin t =
  let (m, t') = aux m t in t'

Thus:

replaceMin (Fork (Leaf 4) (Leaf 7)) = Fork (Leaf 4) (Leaf 4)

Answer 9

My personal favourite is the recursive directory traversal function from Higher Order Perl. It was my first introduction to the power of functional programming (in this case the complete decoupling of the file tree traversal from the specific closures that act on the files and directories), and it really blew me away.

sub dir_walk {
   my ( $top, $file_func, $dir_func ) = @_;
   my $dh;

   if ( -d $top ) {
      my $file;
      unless ( opendir $dh, $top ) {
         warn "Couldn't open directory $top: $!; skipping.\n";
         return;
      }

      my @results;
      while ( $file = readdir $dh ) {
         next if $file eq '.' || $file eq '..';
         push @results, dir_walk("$top/$file", $file_func, $dir_func);
      }

      return $dir_func ? $dir_func->($top, @results) : ();      
   }
   else {   
      return $file_func ? $file_func->($top): ();      
   }
}

Answer 10

After reading Steven Huwig's post about a Javascript Y-Combinator I played around a bit with that idea. A simpler version of the Y-combinator would be this:

function Y(f) {
  return function recf(n) {
    return f(recf, n);
  }
}

This gives an easy implementation of the factorial function:

function facstep(rec, n) {
  if (n==0)
    return 1;
  return n * rec(n-1);
}

var fac = Y(facstep);

alert(fac(6));

The syntax for this can be simplified even more. By using some of Javascripts special features the recursive step can be passed implicitly as this while supporting any number of arguments for the "recursive" function:

function Y(f) {
  return function rec() {
    return f.apply(rec, arguments);
  }
}

function gcdstep(n, m) {
  // greatest common divisor
  if (n == m)
    return n;
  if (n > m)
    return this(n-m, m);
  else
    return this(m, n);
}

var gcd = Y(gcdstep);
alert(gcd(350, 40));

This syntax looks quite straight forward, but note that it's not normally possible for a Javascript function to refer to itself by using this, this normally refers to the object the function is a method of. In this case this references the function itself, due to the magic of the Y-combinator:

Answer 11

Breadth-first traversal of an n-ary tree in Haskell:

bfs t = (fmap . fmap) rootLabel $
          takeWhile (not . null) $
            iterate (>>= subForest) [t]

Answer 12

My "aha!" moment with JavaScript came when I was reading this memoization blog post. The relevant functional code, from that post was:

Bezier.prototype.getLength = function() {
  var length = ... // expensive computation
  this.getLength = function(){return length};
  return length;
}

Basically, the function overwrites itself with the answer after the first computation, make all subsequent calls memoized.

It was at this point that I realized how all my previous ill-conceived notions of JS were founded in ignorance. And it was at this point that I realized the true power of its functional aspects.

Answer 13

this is the scheme implementation of the omega combinator (essentially an infinite loop):

((call/cc call/cc) (call/cc call/cc))

Answer 14

I've always loved the Fibonacci numbers definition:

fibs = 0 : 1 : zipWith (+) fibs (tail fibs)

Or anything else co-recursive.

Answer 15

The biggest "Oh Wow!" moment I've had is with the exponentiation function in lambda calculus.

\ab.ba

results in a ^ b

Answer 16

My mind-blowing time happened while watching the SICP video lectures.
Data made of thin air. The functions as data containers.

More specifically, store a pair of data even if the language doesn't have a built-in data container.
That was my baptism on functional programming.

#lang scheme

;; Version 1    
(define (pair x y)
  (lambda (p)
    (cond ((> p 0) x)
          (else y))))

(define (pair-x z)
  (z 1))

(define (pair-y z)
  (z 0))

;; Version 2, Alonzo Church Pairs - Lambda Calculus
;; SICP exercise
(define (church-pair x y)
  (lambda (m) (m x y)))

(define (church-pair-x z)
  (z (lambda (x y) x)))

(define (church-pair-y z)
  (z (lambda (x y) y)))

Example:

> (define p (pair 7 8))
> (pair-x p)
7
> (pair-y p)
8
>

Answer 17

After reading about Haskell's currying capabilities, I said to myself: "I can do that in JavaScript". I did it and am very proud of it (hence this answer). The whole gist is on GitHub, but here goes:

var curry = function (f) {
    var array = Array.slice,
        prevArity = arguments[1] || f.length;

    return function () {
        var args = array(arguments),
            currArity = args.length;

        if (currArity >= prevArity) {
            return f.apply(this, args);
        }

        return curry(function () {
            return f.apply(this, args.concat(array(arguments)));
        }, prevArity - currArity);
    };
};

And these are some BDD specs for it:

$.describe("The curry() function", function () {
    $.it("should curry one argument functions", function () {
        var unary = curry(function (a) {
            return a;
        });

        var result = unary(1);

        $(result).should.equal(1);
    });

    $.it("should curry multi argument functions", function () {
        var nary = curry(function (a, b) {
            return a + b;
        });

        var result = nary(1)(2);

        $(result).should.equal(3);
    });

    $.it("should curry multi argument functions", function () {
        var nary = curry(function (a, b, c) {
            return a + b + c;
        });

        var result = nary(1, 2)(3);

        $(result).should.equal(6);
    });
});

Answer 18

C++ is to pointers as functional programming is to continuations: newbies are mystified by them both.

Start with a simple binary tree insert:

type 'a tree =
    | Node of 'a tree * 'a * 'a tree
    | Nil

let rec insert x = function
    | Nil -> Node(Nil, x, Nil)
    | Node(l, a, r) as node ->
        if x > a then Node(l, a, insert x r)
        elif x < a then Node(insert x l, a, r)
        else node

Simple, utilitarian, but its not tail-recursive. So, you go-go-gadget continuation passing style, and you get this:

let insert x tree =
    let rec loop cont x = function
        | Nil -> cont <| Node(Nil, x, Nil)
        | Node(l, a, r) as node ->
            if x > a then loop (fun r' -> cont <| Node(l, a, r')) x r
            elif x < a then loop (fun l' -> cont <| Node(l', a, r)) x l
            else cont node
    loop id x tree

At the expense of a little clarity, the algorithm is properly tail-recursive.

Here's a traditional and tail-recursive list append side-by-side:

let rec append a b =
    match a with
    | [] -> b
    | x::xs -> x::append xs b

let append2 a b =
    let rec loop cont = function
        | [] -> cont b
        | x::xs -> loop (fun xs' -> cont <| x::xs') xs
    loop id a

Answer 19

I like Duff's Device:

n=(count+7)/8;
switch(count%8){
case 0: do{ *to++ = *from++;
case 7:  *to++ = *from++;
case 6:  *to++ = *from++;
case 5:  *to++ = *from++;
case 4:  *to++ = *from++;
case 3:  *to++ = *from++;
case 2:  *to++ = *from++;
case 1:  *to++ = *from++;
    }while(--n>0);
}

This is essentially a loop unrolled custom memcpy, as opposed to the more straightforward implementation:

do{
  *to++=*from++;
}while(--count>0);

this version has ~8 times the number of comparisons, decrements and jumps.

You probably woudn't want to do something like this in the place of just using memcpy in most circumstances. I actually had call to use a similar construct recently to interleave some arrays and measured a fairly nice speed increase.

Answer 20

Problem:

Given 4 number a, b, c, and d; output the sequence of a, b and c along with arithmetic
operators such that the result is d. The arithmetic operations allowed are 
“+,-,/,*”.

I/p:    a,b,c,d
O/p:    <expression>
Eg.:
        I/p:    4        3      2       10
        O/p:    4+3*2=10

Solution: (in Scala)

object Aha {
  def main(args: Array[String]) {
    val (a, b, c, d) = (readInt, readInt, readInt, readInt)
    val operations = List[((Int, Int) => Int, Int, String)](
      ({_+_}, 1, "+"), ({_-_}, 1, "-"), ({_*_}, 2, "*"), ({_/_}, 2, "/")
    )
    for {
      (i, pi, si) <- operations
      (j, pj, sj) <- operations
      if((pi >= pj && j(i(a, b), c) == d) || (pi < pj && i(a, j(b, c)) == d))
    } println(a + si + b + sj + c + "=" + d)
  }
}

---

Same thing in C++ (with Boost):

#include <iostream>
#include <string>
#include <functional>

#include <boost/tuple/tuple.hpp>
#include <boost/function.hpp>
#include <boost/foreach.hpp>

using namespace std;
using namespace boost;

int main() {
  int a, b, c, d;
  cin >> a >> b >> c >> d;
  tuple<function<int(int, int)>, int, string> operations[] = {
    make_tuple(plus<int>(), 1, "+"),
    make_tuple(minus<int>(), 1, "-"),
    make_tuple(multiplies<int>(), 2, "*"),
    make_tuple(divides<int>(), 2, "/")
  };
  function<int(int, int)> i, j;
  int pi, pj;
  string si, sj;
  BOOST_FOREACH(tie(i, pi, si), operations) {
    BOOST_FOREACH(tie(j, pj, sj), operations) {
      if((pi >= pj && j(i(a, b), c) == d) || (pi < pj && i(a, j(b, c)) == d)) {
        cout << a << si << b << sj << c << "=" << d << endl;
      }
    }
  } 
}