examples/algorithms/attrgrammar.pl

   1 #!/usr/bin/perl
   2
   3 # This is just a hand-written lazy attribute grammar to help
   4 # me decide if I want to port L::AG to Perl 6 (i.e. whether
   5 # pugs is going to give me too much bullshit like it did
   6 # last time I tried to port an object-oriented module).
   7 # So far, it looks pretty good.
   8
   9 class Thunk {
  10     method call () {
  11         my $thunk = $.code;
  12         if $thunk {
  13             undefine $.code;
  14             return $.value = $thunk();
  15         }
  16         else {
  17             return $.value;
  18         }
  19     }
  20
  21     has $.code;
  22     has $.value;
  23 }
  24
  25 sub thunk(&code) {
  26     return Thunk.new(code => &code);
  27 }
  28
  29 class Leaf {
  30     method visit ($parent) {
  31         my $compute = {
  32             min     => thunk { $.value },
  33             result  => thunk { Leaf.new(value => $compute<gmin>.call) },
  34             gmin    => thunk { $parent<gmin>.call },
  35         };
  36         return $compute;
  37     }
  38
  39     has $.value;
  40 }
  41
  42 class Branch {
  43     method visit ($parent) {
  44         my ($lvis, $rvis);
  45         my $compute = {
  46             min     => thunk { min($lvis<min>.call, $rvis<min>.call) },
  47             result  => thunk { Branch.new(left => $lvis<result>.call, right => $rvis<result>.call) },
  48             gmin    => thunk { $parent<gmin>.call },
  49         };
  50         ($lvis, $rvis) = ($.left.visit($compute), $.right.visit($compute));
  51         return $compute;
  52     }
  53
  54     has $.left;
  55     has $.right;
  56 }
  57
  58 class Root {
  59     method visit ($parent) {
  60         my $tvis;
  61         my $compute = {
  62             result => thunk { $tvis<result>.call },
  63             gmin   => thunk { $tvis<min>.call },
  64         };
  65         $tvis = $.tree.visit($compute);
  66         $compute;
  67     }
  68
  69     has $.tree;
  70 }
  71
  72 my $tree = Root.new(
  73     tree => Branch.new(
  74         left  => Leaf.new(value => 1),
  75         right => Branch.new(
  76             left  => Branch.new(
  77                 left  => Leaf.new(value => 2),
  78                 right => Leaf.new(value => 3),
  79             ),
  80             right => Leaf.new(value => -3),
  81         ),
  82     ),
  83 );
  84
  85 say $tree.perl;
  86 say $tree.visit( {} ).<result>.call.perl;