I was working my way through reading Iterators: Signs of Weakness in Object-Oriented Languages until I came to the samefringe function (which checks to see if two lists -- array references in the code here -- have the same "fringe" -- update: i.e. they have identical "leaves" or they have the same contents if both lists are "flattened"), when I reached a "Huh, what's going on?" moment...I still don't entirely get it, but rewriting it in perl helps some. The main weakness in this perl version is that cdr() is O(N) (update: because I'm using straight array references instead of real linked lists as Joost points out below), though still fairly fast here. A minor weakness is not having named parameters...but it was marginally educational anyway. I wrote the printfringe() function while debugging samefringe(). Enjoy! or not :-) 

#!/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]

Replies are listed 'Best First'.
Re: No Iterators Allowed
by Joost (Canon) on Feb 27, 2008 at 23:34 UTC
    Of course, cdr doesn't have to be O(N) if you implement lists like lisp does (in Lisp, lists are just particular arrangements of 2-element cons cells): 
    # pack 2 elements into a cons cell
# if the second element is a cons cell or undef, the result is conside
+red a list
sub cons {
  [$_[0],$_[1]];
}

# return the first element in a list.
# or to put it another way, return the first of the 2 elements of the 
+given cell
sub car {
  ref $_[0] ? $_[0][0] : undef;
}

# return the "remaining list" (everything except the first element) in
+ a list.
# or to put it another way, return the second element of a cons cell
sub cdr {
  ref $_[0] ? $_[0][1] : undef;
}

    [download]
    The disadvantage ofcourse is that these lists don't act like perl arrays.

    update: fixed the cdr() definition

    "What should it profit a man, if he should win a flame war, yet lose his cool?"
[reply]
[d/l]
      Yeah, I know I could have implemented real linked lists, but I just wanted to keep things simple, and also, it would make the initialization of the passed in lists messier looking :-)

      But it would be nice if you could make it O(1) anyway without linked lists.

[reply]
        But it would be nice if you could make it O(1) anyway without linked lists.
        You could implement cdr as returning a shared hash slice. With some XS hacking you can probably make it work for some cases. Though you may have to make arrays immutable to do it right :-)

        update: it seems to me you could implement this in pure perl using tied arrays. But it would get more inefficient for each slice-of-a-slice-of-a-slice.

        "What should it profit a man, if he should win a flame war, yet lose his cool?"
[reply]
Re: No Iterators Allowed
by Jenda (Abbot) on Feb 29, 2008 at 00:09 UTC

    I'm probably missing something but ... fringe of a list (containing string/numbers and lists containing strins/numbers and lists containing ...) are the strings/numbers in a totally flattened list, right? So the samefringe() function should check that the list contains the same strings/numbers in the same order disregarding the structure, right? Without creating the totally flattened lists, right? (Sorry I got lost in the maze so I have no idea whether you do or don't create some lists like that or modify the data structure along the way.)

    use strict;
use warnings;

sub samefringe {
    my ($x, $y) = @_;
    my ($ix, $iy) = (0,0);
    samefringe_r($x, $y, $ix, $iy) and $#{$x}+1 == $ix and $#{$y}+1 ==
+ $iy;
}

sub samefringe_r {
    my ($x, $y, $ix, $iy) = @_;

    while ($ix <= $#{$x} and $iy <= $#{$y}) {
        if (ref($x->[$ix])) {
            my $i_ix = 0;
            samefringe_r( $x->[$ix], $y, $i_ix, $iy) or return;
            $ix++;
        } elsif (ref($y->[$iy])) {
            my $i_iy = 0;
            samefringe_r( $x, $y->[$ix], $ix, $i_iy) or return
            $iy++;
        } elsif ($x->[$ix] ne $y->[$iy]) {
            return
        } else {
            $ix++;
            $iy++;
        }
    }
    $_[2]=$ix;$_[3]=$iy;
    return 1;
}

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

print "1 x 2, should be same : ".(samefringe($l1, $l2) ? 'same' : 'dif
+f')."\n";

print "1 x 3, should be diff : ".(samefringe($l1, $l3) ? 'same' : 'dif
+f')."\n";
print "1 x 4, should be diff : ".(samefringe($l1, $l4) ? 'same' : 'dif
+f')."\n";
print "2 x 3, should be diff : ".(samefringe($l2, $l3) ? 'same' : 'dif
+f')."\n";
print "2 x 4, should be diff : ".(samefringe($l2, $l4) ? 'same' : 'dif
+f')."\n";

    [download]

    Jenda
    Support Denmark!
    Defend the free world!

[reply]
[d/l]
      Here's how I might have done it if I were using iterators (which uses an explicit stack that the solutions in the referenced document in the OP avoid):
      sub samefringe {
  my ( $x, $y ) = map { fringe_iter($_) } @_;
  my ( $next_x, $next_y );
  while ( 1 ) {
    ( $next_x, $next_y ) = ( $x->(), $y->() );
    last unless $next_x and $next_y;
    return unless $next_x eq $next_y;
  }
  return ( $next_y || $next_y ) ? 0 : 1;
}

sub fringe_iter {
  my $list = shift;
  my @arr = @$list;
  sub {
    while (1) {
      my $reftype = ref($arr[0]);
      return shift @arr unless $reftype;
      unshift @arr, fringe_iter(shift @arr) if $reftype eq 'ARRAY';
      my $next = $arr[0]->();
      if ( $next ) {
        unshift @arr, $next;
      } else {
        shift @arr;
      }
    }
  }
}

      [download]
[reply]
[d/l]

Back to Meditations