# # This software is Copyright 2005 by Elsevier Inc. You may use it # under the terms of the license at http://perl.plover.com/hop/LICENSE.txt . # ### ### promote_if_curried ### ## Chapter 7 section 1 sub promote_if { my $is_interesting = shift; return sub { my $element = shift; if ($is_interesting->($element->{_tag}) { return ['keeper', join '', map {$_->[1]} @_]; } else { return @_; } } } ## Chapter 7 section 1 my @tagged_texts = walk_html($tree, sub { ['maybe', $_[0]] }, promote_if('h1'), }); sub add2 { my ($s, $t) = @_; return unless $s && $t; node(head($s) + head($t), promise { add2(tail($s), tail($t)) }); } sub mul2 { my ($s, $t) = @_; return unless $s && $t; node(head($s) * head($t), promise { mul2(tail($s), tail($t)) }); } sub combine2 { my ($s, $t, $op) = @_; return unless $s && $t; node($op->(head($s), head($t)), promise { combine2(tail($s), tail($t), $op) }); } sub add2 { combine2(@_, sub { $_[0] + $_[1] }) } sub mul2 { combine2(@_, sub { $_[0] * $_[1] }) } sub combine2 { my $op = shift; return sub { my ($s, $t) = @_; return unless $s && $t; node($op->(head($s), head($t)), promise { combine2($op)->(tail($s), tail($t)) }); }; } $add2 = combine2(sub { $_[0] + $_[1] }); $mul2 = combine2(sub { $_[0] * $_[1] }); my $catstrs = combine2(sub { "$_[0]$_[1]" })->($s, $t); sub scale { my $s = shift; return sub { my $c = shift; return if $c == 0; transform { $_[0] * $c } $s; } } sub scale { my $c = shift; return sub { my $s = shift; transform { $_[0] * $c } $s; } } *double = scale(2); $s2 = double($s); sub slope { my ($f, $x) = @_; my $e = 0.00000095367431640625; ($f->($x+$e) - $f->($x-$e)) / (2*$e); } sub slope { my $f = shift; my $e = 0.00000095367431640625; return sub { my $x = shift; ($f->($x+$e) - $f->($x-$e)) / (2*$e); }; } sub slope { my $f = shift; my $e = 0.00000095367431640625; my $d = sub { my ($x) = shift; ($f->($x+$e) - $f->($x-$e)) / (2*$e); }; return @_ ? $d->(shift) : $d; } sub iterate_function { my ($f, $x) = @_; my $s; $s = node($x, promise { &transform($f, $s) }); } sub iterate_function { my $f = shift; return sub { my $x = shift; my $s; $s = node($x, promise { &transform($f, $s) }); }; } *upfrom = iterate_function(sub { $_[0] + 1 }); *pow2_from = iterate_function(sub { $_[0] * 2 }); sub combine2 { my $op = shift; return sub { my ($s, $t) = @_; return unless $s && $t; node($op->(head($s), head($t)), promise { combine2($op)->(tail($s), tail($t)) }); }; } sub combine2 { my $op = shift; my $r; $r = sub { my ($s, $t) = @_; return unless $s && $t; node($op->(head($s), head($t)), promise { $r->(tail($s), tail($t)) }); }; } map { $_ * 2 } (1..5); # returns 2, 4, 6, 8, 10 grep { $_ % 2 == 0 } (1..10); # returns 2, 4, 6, 8, 10 sub cmap (&) { my $f = shift; my $r = sub { my @result; for (@_) { push @result, $f->($_); } @result; }; return $r; } sub cgrep (&) { my $f = shift; my $r = sub { my @result; for (@_) { push @result, $_ if $f->($_); } @result; }; return $r; } $double = cmap { $_ * 2 }; $find_slashdot = cgrep { $_->{referer} =~ /slashdot/i }; sub cmap (&;@) { my $f = shift; my $r = sub { my @result; for (@_) { push @result, $f->($_); } @result; }; return @_ ? $r->(@_) : $r; } @doubles = cmap { $_ * 2 } (1..5); @evens = cgrep { $_ % 2 == 0 } (1..10); @doubles = cmap { $_ * 2 } @some_array; sub some_curried_function { my $first_arg = shift; my $r = sub { ... }; return @_ ? $r->(@_) : $r; } package Curry; use base 'Exporter'; @EXPORT = ('curry'); @EXPORT_OK = qw(curry_listfunc curry_n); sub curry_listfunc { my $f = shift; return sub { my $first_arg = shift; return sub { $f->($first_arg, @_) }; }; } sub curry { my $f = shift; return sub { my $first_arg = shift; my $r = sub { $f->($first_arg, @_) }; return @_ ? $r->(@_) : $r; }; } 1; sub imap (&$) { my ($transform, $it) = @_; return sub { my $next = NEXTVAL($it); return unless defined $next; return $transform->($next); } } my $doubles_iterator = imap { $_[0] * 2 } $it; my $doubles_a = imap { $_[0] * 2 } $it_a; my $doubles_b = imap { $_[0] * 2 } $it_b; my $doubles_c = imap { $_[0] * 2 } $it_c; my $doubles_a = double $it_a; my $doubles_b = double $it_b; my $doubles_c = double $it_c; my ($doubles_a, $doubles_b, $doubles_c) = map double($_), $it_a, $it_b, $it_c; *double = imap { $_[0] * 2 }; *double = curry(\&imap)->(sub { $_[0] * 2 }); *c_imap = curry(\&imap); *double = c_imap(sub { $_[0] * 2 }); sub curry { my $f = shift; return sub (&;@) { my $first_arg = shift; my $r = sub { $f->($first_arg, @_) }; return @_ ? $r->(@_) : $r; }; } BEGIN { *c_imap = curry(\&imap); } *double = c_imap { $_[0] * 2 }; $doubles_a = c_imap { $_[0] * 2 } $it_a; sub scale { my ($s, $c) = @_; $s->transform(sub { $_[0]*$c }); } sub { my $s = shift; my $r = sub { scale($s, @_) }; return @_ ? $r->(@_) : $r; } BEGIN { *c_scale = curry(\&scale) } my $double = c_scale(2); my $doubled_it = c_scale(2, $it); Type of arg 1 to main::c_scale must be block or sub {} (not constant item)... *c_scale = curry(\&scale); my $double = c_scale(2); my $doubled_it = c_scale(2, $it); *c_scale = curry(\&scale); my $double = eval 'c_scale(2)'; # Doesn't really work sub curry { my $f = shift; my $PROTOTYPE = shift; return sub ($PROTOTYPE) { my $first_arg = shift; my $r = sub { $f->($first_arg, @_) }; return @_ ? $r->(@_) : $r; }; } # Doesn't work before 5.8.1 use Scalar::Util 'set_prototype'; sub curry { my $f = shift; my $PROTOTYPE = shift; set_prototype(sub { my $first_arg = shift; my $r = sub { $f->($first_arg, @_) }; return @_ ? $r->(@_) : $r; }, $PROTOTYPE); } sub curry { my $f = shift; my $PROTOTYPE = shift; $PROTOTYPE = "($PROTOTYPE)" if defined $PROTOTYPE; my $CODE = q{sub PROTOTYPE { my $first_arg = shift; my $r = sub { $f->($first_arg, @_) }; return @_ ? $r->(@_) : $r; }}; $CODE =~ s/PROTOTYPE/$PROTOTYPE/; eval $CODE; } sub curry_n { my $N = shift; my $f = shift; my $c; $c = sub { if (@_ >= $N) { $f->(@_) } else { my @a = @_; curry_n($N-@a, sub { $f->(@a, @_) }); } }; } *add = curry_n(2, sub { $_[0] + $_[1] }); add(2, 3); # Returns 5 *increment = add(1); increment(8); # return 9 *csubstr = curry_n(3, sub { defined $_[3] ? substr($_[0], $_[1], $_[2], $_[3]) : substr($_[0], $_[1], $_[2]) }); # Just like regular substr $ss = csubstr($target, $start, $length); csubstr($target, $start, $length, $replacement); # Not just like regular substr $target = "I like pie"; # This '$part' function gets two arguments: a start position # and a length; it returns the apporpriate part of $target. $part = csubstr($target); my $ss = $part->($start, $length); # This function gets an argument N and returns that many characters # from the beginning of $target. $first_N_chars = csubstr($target, 0); my $prefix_3 = $first_N_chars->(3); # "I l" my $prefix_7 = $first_N_chars->(7); # "I like " sub dir_walk { unshift @_, undef if @_ < 3; my ($top, $filefunc, $dirfunc) = @_; my $r; $r = sub { my $DIR; my $top = shift; if (-d $top) { my $file; unless (opendir $DIR, $top) { warn "Couldn't open directory $code: $!; skipping.\n"; return; } my @results; while ($file = readdir $DIR) { next if $file eq '.' || $file eq '..'; push @results, $r->("$top/$file"); } return $dirfunc->($top, @results); } else { return $filefunc->($top); } }; defined($top) ? $r->($top) : $r; } sub max { my $max = shift; for (@_) { $max = $_ > $max ? $_ : $max } return $max; } sub min { my $min = shift; for (@_) { $min = $_ < $min ? $_ : $min } return $min; } sub maxstr { my $max = shift; for (@_) { $max = $_ gt $max ? $_ : $max } return $max; } sub minstr { my $min = shift; for (@_) { $min = $_ lt $min ? $_ : $min } return $min; } sub sum { my $sum = shift; for (@_) { $sum = $sum + $_ } return $sum; } sub reduce { my $code = shift; my $val = shift; for (@_) { $val = $code->($val, $_) } return $val; } reduce(sub { $_[0] + $_[1] }, @VALUES) == sum(@VALUES) reduce(sub { $_[0] > $_[1] ? $_[0] : $_[1] }, @VALUES) == max(@VALUES) reduce(sub { $a + $b }, @VALUES) reduce(sub { $a > $b ? $a : $b }, @VALUES) sub reduce (&@) { my $code = shift; my $val = shift; for (@_) { local ($a, $b) = ($val, $_); $val = $code->($val, $_) } return $val; } BEGIN { *reduce = curry(\&List::Util::reduce); *sum = reduce { $a + $b }; *max = reduce { $a > $b ? $a : $b }; } reduce { $a + 1 }; sub reduce (&$@) { my $code = shift; my $val = shift; for (@_) { local ($a, $b) = ($val, $_); $val = $code->($val, $_) } return $val; } sub reduce (&;$@) { my $code = shift; my $f = sub { my $base_val = shift; my $g = sub { my $val = $base_val; for (@_) { local ($a, $b) = ($val, $_); $val = $code->($val, $_); } return $val; }; @_ ? $g->(@_) : $g; }; @_ ? $f->(@_) : $f; } *listlength = reduce { $a + 1 } 0; *product = reduce { $a * $b } 1; *length_and_product = reduce { [$a->[0]+1, $a->[1]*$b] } [0, 1]; sub fold { my $f = shift; my $fold; $fold = sub { my $x = shift; sub { return $x unless @_; my $first = shift; $fold->($f->($x, $first), @_) } } } sub fold { my $f = shift; sub { my $x = shift; sub { my $r = $x; while (@_) { $r = $f->($r, shift()); } return $r; } } } sub interleave { my ($a, $b) = @_; return sub { my $next = $a->(); unless (defined $next) { $a = $b; $next = $a->(); } ($a, $b) = ($b, $a); $next; } } package Iterator_Logic; use base 'Exporter'; @EXPORT = qw(i_or_ i_or i_and_ i_and i_without_ i_without); sub i_or_ { my ($cmp, $a, $b) = @_; my ($av, $bv) = ($a->(), $b->()); return sub { if (! defined $av && ! defined $bv) { return } elsif (! defined $av) { $rv = $bv; $bv = $b->() } elsif (! defined $bv) { $rv = $av; $av = $a->() } else { my $d = $cmp->($av, $bv); if ($d < 0) { $rv = $av; $av = $a->() } elsif ($d > 0) { $rv = $bv; $bv = $b->() } else { $rv = $av; $av = $a->(); $bv = $b->() } } return $rv; } } use Curry; BEGIN { *i_or = curry(\&i_or_) } BEGIN { *numeric_or = i_or { $_[0] <=> $_[1] }; *alphabetic_or = i_or { $_[0] cmp $_[1] }; } $event_times = numeric_or($access_request_times, numeric_or($report_request_times, $server_start_times)); sub i_and_ { my ($cmp, $a, $b) = @_; my ($av, $bv) = ($a->(), $b->()); return sub { my $d; until (! defined $av || ! defined $bv || ($d = $cmp->($av, $bv)) == 0) { if ($d < 0) { $av = $a->() } else { $bv = $b->() } } return unless defined $av && defined $bv; my $rv = $av; ($av, $bv) = ($a->(), $b->()); return $rv; } } BEGIN { *i_and = curry \&i_and_ } my $dbh = FlatDB->new($datafile); $dbh->query($filename, $value); $dbh->callbackquery(sub { ... }); $dbh->select("STATE = 'NY' | OWES > 100 & STATE = 'MA'"); package FlatDB_Composable; use base 'FlatDB'; use base 'Exporter'; @EXPORT_OK = qw(query_or query_and query_not query_without); use Iterator_Logic; # usage: $dbh->query(fieldname, value) # returns all records for which (fieldname) matches (value) sub query { my $self = shift; my ($field, $value) = @_; my $fieldnum = $self->{FIELDNUM}{uc $field}; return unless defined $fieldnum; my $fh = $self->{FH}; seek $fh, 0, 0; <$fh>; # discard header line my $position = tell $fh; my $recno = 0; return sub { local $_; seek $fh, $position, 0; while (<$fh>) { chomp; $recno++; $position = tell $fh; my @fields = split $self->{FIELDSEP}; my $fieldval = $fields[$fieldnum]; return [$recno, @fields] if $fieldval eq $value; } return; }; } BEGIN { *query_or = i_or(sub { $_[0][0] <=> $_[1][0] }); *query_and = i_and(sub { $_[0][0] <=> $_[1][0] }); } BEGIN { *query_without = i_without(sub { $_[0][0] <=> $_[1][0] }); } sub callbackquery { my $self = shift; my $is_interesting = shift; my $fh = $self->{FH}; seek $fh, 0, SEEK_SET; <$fh>; # discard header line my $position = tell $fh; my $recno = 0; return sub { local $_; seek $fh, $position, SEEK_SET; while (<$fh>) { $position = tell $fh; chomp; $recno++; my %F; my @fieldnames = @{$self->{FIELDS}}; my @fields = split $self->{FIELDSEP}; for (0 .. $#fieldnames) { $F{$fieldnames[$_]} = $fields[$_]; } return [$recno, @fields] if $is_interesting->(%F); } return; }; } 1; "STATE = 'NY' | OWES > 100 & STATE = 'MA'" query_or($dbh->query('STATE', 'NY'), query_and($dbh->callbackquery(sub { $F{OWES} > 100 }), $dbh->query('STATE', 'MA') )) # $a but not $b sub i_without_ { my ($cmp, $a, $b) = @_; my ($av, $bv) = ($a->(), $b->()); return sub { while (defined $av) { my $d; while (defined $bv && ($d = $cmp->($av, $bv)) > 0) { $bv = $b->(); } if ( ! defined $bv || $d < 0 ) { my $rv = $av; $av = $a->(); return $rv; } else { $bv = $b->(); $av = $a->(); } } return; } } BEGIN { *i_without = curry \&i_without_; *query_without = i_without(sub { my ($a,$b) = @_; $a->[0] <=> $b->[0] }); } 1; sub query_not { my $self = shift; my $q = shift; query_without($self->all, $q); } sub all { $_[0]->callbackquery(sub { 1 }); } 1; package FlatDB_Overloaded; BEGIN { for my $f (qw(and or without)) { *{"query_$f"} = \&{"FlatDB_Composable::query_$f"}; } } use base 'FlatDB_Composable'; sub query { $self = shift; my $q = $self->SUPER::query(@_); bless $q => __PACKAGE__; } sub callbackquery { $self = shift; my $q = $self->SUPER::callbackquery(@_); bless $q => __PACKAGE__; } 1; use overload '|' => \&query_or, '&' => \&query_and, '-' => \&query_without, 'fallback' => 1; my ($ny, $debtor, $ma) = ($dbh->query('STATE', 'NY'), $dbh->callbackquery(sub { $F{OWES} > 100 }), $dbh->query('STATE', 'MA') ); my $interesting = query_or($ny, query_and($debtor, $ma)) my $interesting = $ny | $debtor & $ma;