#!/usr/bin/perl

use strict;
use warnings;

my $l1 = [ "a", [qw(b c)], "d" ];
my $l2 = [ qw(a b c d) ];

print_fringe($l1);
print "same\n" if samefringe($l1, $l2);

sub print_fringe {
  my $x = shift;
  print_fringec(
    sub {
      my $c = shift;
      genfringe($x, $c, \&eof);
    },
  );
}

sub print_fringec {
  my $xg = shift;
  $xg->(
    sub {
      my ($x, $eofx, $xg) = @_;
      ( $eofx ) || do { print "F: $x\n"; print_fringec($xg) };
    }
  );
}

#defun eof (c) (funcall c nil t nil))        ; empty generator, send e
+of flag.
sub eof {
  my $c = shift;
  $c->(undef, 1, undef);
}

#(defun samefringe (x y)                                   ; "lazy" sa
+mefringe.
#  (samefringec #'(lambda (c) (genfringe x c #'eof))
#               #'(lambda (c) (genfringe y c #'eof))))
sub samefringe {
  my ($x, $y) = @_;
  samefringec(
    sub {
      my $c = shift;
      genfringe($x, $c, \&eof);
    },
    sub {
      my $c = shift;
      genfringe($y, $c, \&eof);
    },
  );
}

#(defun samefringec (xg yg)  ; check equality of leaves generated by g
+enfringe.
#  (funcall xg                  ; We don't need Scheme 1st class conti
+nuations.
#   #'(lambda (x eofx xg)   ; receive 1st elt., eof flag, & generator 
+for rest.
#       (funcall yg
#        #'(lambda (y eofy yg)
#            (or (and eofx eofy)      ; equal if both reach eof simult
+aneously.
#                (and (eql x y) (samefringec xg yg))))))))
sub samefringec {
  my ($xg, $yg) = @_;
  $xg->(
    sub {
      my ($x, $eofx, $xg) = @_;
      $yg->(
        sub {
          my ($y, $eofy, $yg) = @_;
          ( $eofx && $eofy ) || ( $x eq $y and samefringec($xg, $yg) )
+;
        }
      );
    }
  );
}

#(defun genfringe (x consumer genrest)  ; call consumer with leaves fo
+und in x.
#  (if (atom x) (funcall consumer x nil genrest)   ; send 1st elt. & ~
+eof flag.
#    (genfringel x consumer genrest)))
sub genfringe {
  my ($x, $consumer, $genrest) = @_;
  ref($x)
    ? genfringel( $x, $consumer, $genrest )
    : $consumer->( $x, undef, $genrest );
}

#(defun genfringel (xl consumer genrest)
#  (if (null xl) (funcall genrest consumer)
#    (genfringe (car xl) consumer
#     #'(lambda (consumer) (genfringel (cdr xl) consumer genrest)))))
sub genfringel {
  my ($xl, $consumer, $genrest) = @_;
  return $genrest->($consumer) if !$xl;
  genfringe( car($xl), $consumer,
    sub {
      my $consumer = shift;
      genfringel( cdr($xl), $consumer, $genrest );
    }
  );
}

sub car { $_[0][0] }
sub cdr { lcdr(@{$_[0]}) }
sub lcdr { shift; return @_ ? \@_ : undef }
[download]