lib/Data/SExpression/Util.pm

   1 package Data::SExpression::Util;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6 use parent qw/Exporter/;
   7
   8 our %EXPORT_TAGS = ( 'all' => [
   9         qw/cons
  10            append
  11            mapcar
  12            rev
  13            position
  14           /]);
  15
  16 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  17
  18 our $VERSION = '0.000_001';
  19
  20 use Data::SExpression::Cons;
  21
  22 sub cons {
  23         my ($car, $cdr) = @_;
  24         Data::SExpression::Cons->new($car, $cdr);
  25 }
  26
  27 sub append {
  28         my ($expr, $rest) = @_;
  29         if (defined $expr) {
  30                 cons $expr->car, append($expr->cdr, $rest)
  31         } else {
  32                 $rest
  33         }
  34 }
  35
  36 sub mapcar (&@);
  37
  38 sub mapcar (&@) {
  39         my ($block, $expr) = @_;
  40         if (defined $expr) {
  41                 my $result;
  42                 do {
  43                         local $_ = $expr->car;
  44                         $result = $block->()
  45                 };
  46                 cons $result, mapcar { $block->($_) } $expr->cdr
  47         } else {
  48                 undef
  49         }
  50 }
  51
  52 sub revacc {
  53         my ($expr, $acc) = @_;
  54         if (defined $expr) {
  55                 revacc ($expr->cdr, cons($expr->car, $acc))
  56         } else {
  57                 $acc
  58         }
  59 }
  60
  61 sub rev {
  62         my ($expr) = @_;
  63         revacc $expr, undef;
  64 }
  65
  66 sub positionacc {
  67         my ($expr, $list, $acc) = @_;
  68         if (!defined $list) {
  69                 undef
  70         } elsif ($list->car eq $expr) {
  71                 $acc
  72         } else {
  73                 positionacc($expr, $list->cdr, $acc + 1)
  74         }
  75 }
  76
  77 sub position {
  78         my ($expr, $list) = @_;
  79         positionacc $expr, $list, 0
  80 }
  81
  82 1;
  83 __END__
  84
  85 =encoding utf-8
  86
  87 =head1 NAME
  88
  89 Data::SExpression::Util - routines for processing linked lists
  90
  91 =head1 SYNOPSIS
  92
  93   use Data::SExpression::Util qw/:all/;
  94   my $list = cons 1, cons 2, cons 3, undef; # (1 2 3)
  95   my $other_list = cons 4, cons 5, undef; # (4 5)
  96
  97   $list = append $list, $other_list; # $list is now (1 2 3 4 5)
  98
  99   say position 1, $list; # 0
 100   say position 4, $list; # 3
 101   say 'undef' unless defined position 0, $list; # undef
 102
 103   $list = rev $list; # (5 4 3 2 1)
 104   $list = mapcar { $_ + 1 } $list; # (6 5 4 3 2)
 105
 106   say position 2, $list; # 4
 107
 108 =head1 DESCRIPTION
 109
 110 Data::SExpression::Util contains several routines for processing
 111 linked lists (represented L<Data::SExpression::Cons> objects). These
 112 are analogous to Lisp functions with the same names.
 113
 114 Right now very few functions are implemented, more will come in the
 115 next version.
 116
 117 The list of functions is:
 118
 119 =over
 120
 121 =item B<append>(I<$list>, I<$other_list>)
 122
 123 Appends the list I<$other_list> at the end of the list I<$list>.
 124
 125 =item B<mapcar> { I<block> } I<$list>
 126
 127 Analogous to Perl's map function. Runs I<block> with each element of
 128 the list I<$list> as $_, and then returns a containing all of the
 129 result.
 130
 131 =item B<rev>(I<$list>)
 132
 133 Reverses a list
 134
 135 =item B<position>(I<$elt>, I<$list>)
 136
 137 Searches for I<$elt> in I<$list> and returns the first matching
 138 element (comparison is done via eq).
 139
 140 =back
 141
 142 =head1 AUTHOR
 143
 144 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 145
 146 =head1 COPYRIGHT AND LICENSE
 147
 148 Copyright (C) 2018 by Marius Gavrilescu
 149
 150 This library is free software; you can redistribute it and/or modify
 151 it under the same terms as Perl itself, either Perl version 5.24.1 or,
 152 at your option, any later version of Perl 5 you may have available.
 153
 154
 155 =cut