A derivation of the Y combinator implemented in perl

#! /usr/bin/perl
use warnings;
use strict;

# This was created after reading
# http://weblog.raganwald.com/2007/02/but-y-wou...
# which encouraged us to read "The Why of Y" by Richard Gabriel, which
# is available at http://www.dreamsongs.com/NewFiles/WhyOfY.pdf... and
# implement a Y combinator in our favorite language.  I have been
# messing around with scheme for about a year now and I though I could
# translate Richard Gabriel's code to Perl.  This is my attempt.  It
# baby steps through the same derivation Richard uses.

# Start with the canonical recursive function, factorial.
sub fact {
  my $n = shift;
  return 1 if $n < 2;
  return $n * fact( $n - 1 );
}

# Here is a baseline check.  Hopefully the result will stay the same while
# we mess with the implementation.
print fact( 10 ), "\n";

# Here is an factorial implementation that maintains an explicit
# reference to the recursive function.
sub fact1 {
  my $f = shift;
  my $n = shift;
  return 1 if $n < 2;
  return $n * $f->( $f, $n - 1 );
}

# We have to call it with a reference to itself.
print fact1( \&fact1, 10 ), "\n"; # Result check

# We can separate the handling of the function reference from the
# arguments to the function using a technique called currying.  Currying
# converts a function of two arguments into a function of one argument
# that returns a function of one argument that returns the result.
sub fact2 {
  my $f = shift;
  return sub {
    my $n = shift;
    return 1 if $n < 2;
    return $n * $f->($f)->( $n - 1 );
  };
}

# I still have to use a reference to the function itself.
print fact2( \&fact2 )->( 10 ), "\n"; # Result check

# Notice the in fifth line of fact2 where $f is called with $f as it's
# argument.  This is why the Y combinator is call a fixed point
# operator.  I don't understand all the theoretical implications of
# this, but I think it is the key to the Y combinator's theoretical
# power.  Note also that this only works when we kick the whole
# process off with fact2( \&fact2 )->( * ).  At this point calling the
# function and the functions implementation are tightly coupled
# together.  I try to clean that up by making things more complicated.

# We create an anonymous subroutine that encapsulates most of the work
# in the inner subroutine in fact2.  We name this subroutine $h
# before calling it because we will want a handle on it in a few
# steps.
sub fact3 {
  my $f = shift;
  return sub {
    my $m = shift;
    my $h = sub {
      my $n = shift;
      return 1 if $n < 2;
      return $n * $f->($f)->( $n - 1 );
    };
    $h->( $m );
  };
}

# The call mechanism remains the same.
print fact3( \&fact3 )->( 10 ), "\n"; # Result check

# Now we apply a transformation to $h similar to the one used to create
# fact1 from fact.
sub fact4 {
  my $f = shift;
  return sub {
    my $m = shift;
    my $h = sub {
      my $q = shift;
      my $n = shift;
      return 1 if $n < 2;
      return $n * $q->( $n - 1 );
    };
    $h->( $f->( $f ), $m );
  }
}

# Notice that the fixed point application $f->($f) has been moved out
# of $h by the introduction of the function reference $q, which
# receives the result of $f->($f) when $h is called.

# The call mechanism remains the same.
print fact4( \&fact4 )->( 10 ), "\n"; # Result check

# Now re-apply the transformation from fact1 to fact2 on the innermost
# subroutine of fact4, i.e. separate the handling of the anonymous
# function argument from the argument to the recursive function using
# currying.
sub fact5 {
  my $f = shift;
  return sub {
    my $n = shift;
    my $h = sub {
      my $q = shift;
      return sub {
        my $n = shift;
        return 1 if $n < 2;
        return $n * $q->( $n - 1 );
      };
    };
    $h->( $f->( $f ))->( $n );
  }
}

# The call mechanism remains the same.
print fact5( \&fact5 )->( 10 ), "\n";

# There are a couple of things to notice here.  First, notice that the
# subroutine returned from $h contains all the "factorial logic".  It
# looks almost exactly like our original factorial function except
# instead of recursing on a named function it recurses on $q which
# fact5 arranges to be the function returned from $h.  Second, notice
# that $h does not have to be defined nested inside the anonymous
# function returned from fact5.  fact6 moves it all the way out.

my $h = sub {
  my $q = shift;
  return sub {
    my $n = shift;
    return 1 if $n < 2;
    return $n * $q->( $n - 1 );
  };
};

sub fact6 {
  my $f = shift;
  return sub {
    my $n = shift;
    $h->( $f->( $f ) )->( $n );
  }
}

# The same external interface.
print fact6( \&fact6 )->( 10 ), "\n";

# Now we wrap a function around fact6 and the recursive application of
# fact6 to a reference of itself, convert fact6 to an anonymous
# function which we store in a variable named $g, and voila, we end
# up with the Y combinator.

sub Y {
  my $h = shift;
  my $g = sub {
    my $f = shift;
    return sub {
      my $n = shift;
      $h->( $f->( $f ) )->( $n );
    };
  };
  $g->( $g );
}

# We pass the function we used to have in $h as the argument to Y, and
# it gets bound as a function parameter.
my $fact   Y( sub {
       my $q = shift;
       sub {
         my $n = shift;
         return 1 if $n < 2;
         return $n * $q->( $n - 1 );
       }
     }
   );

# Since $g->( $g ) is now encapsulated in Y we no longer need it in
# the calling syntax.
print $fact->( 10 ), "\n";

# While factorial is the most common recursive example it is easily
# and efficiently implemented iteratively, so it isn't the best
# demonstration of the power of recursive functions.  Enumerating tree
# structure elements is a great example of a problem that recursive
# algorithms solve easily.  This example shows how to use Y to
# recursively enumerate the contents of a directory tree.
my $files   Y( sub {
       my $f = shift;
       sub {
         my $file = shift;
         return $file unless -d $file;
         return () if( $file =~ qr{\.{1,2}} );
         opendir DIR, $file or die "unable to open dir $file";
         return $file, map { $f->( "$file\\$_" ) } readdir DIR;
       }
     }
   );

# This requires a path to a directory with some sub directories in it.
# It recusivly lists files and directories under it.
print join "\n", $files->( 'D:\pub\src\perl\ycombinator' );