Goldilocks (subset) in perl 5 & 6

goldilocks_1_port_from_js.pl

use 5.016;
use warnings;

# Inspired by: http://news.ycombinator.com/item?id=5024754 | http://news.ycombinator.com/item?id=5025485
# (port of) - https://gist.github.com/3755270

package Bear {
    sub new {
        my ($class, $porridge, $chair, $bed) = @_;
        bless {
            porridge => $porridge,
            chair    => $chair,
            bed      => $bed,
        }, $class;
    }
}

my %daddy = ("bear's" => Bear->new('too hot', 'too big', 'too hard'));

my %mummy = ("bear's" => Bear->new('too cold', 'too big', 'too soft'));
 
my %baby  = ("bear's" => Bear->new('just right', 'just right', 'just right'));

package Goldilocks {
    
    sub said {
        my ($self, $bear, $item) = @_;
        my $that = $bear->{$item} eq 'just right' ? 'Aah this' : 'This';
        say "$that $item is $bear->{$item}";
    }

    sub ate {
        my ($self, $bear, $porridge) = @_;
        Goldilocks->said($bear, $porridge);
    }

    # prefer to keep "on" & "in" in separate pkg rather than in Goldilocks and just returning $self
    sub sat   { bless {}, 'Goldilocks::Sat' }
    sub slept { bless {}, 'Goldilocks::Slept' }
}

sub Goldilocks::Sat::on   { my ($self, $bear, $chair) = @_; Goldilocks->said($bear, $chair) }
sub Goldilocks::Slept::in { my ($self, $bear, $bed) = @_;   Goldilocks->said($bear, $bed) }


Goldilocks->ate( $daddy{"bear's"}, 'porridge' );
Goldilocks->ate( $mummy{"bear's"}, 'porridge' );
Goldilocks->ate( $baby{"bear's"}, 'porridge' );

Goldilocks->sat->on( $daddy{"bear's"}, 'chair' );
Goldilocks->sat->on( $mummy{"bear's"}, 'chair' );
Goldilocks->sat->on( $baby{"bear's"}, 'chair' );

Goldilocks->slept->in( $daddy{"bear's"}, 'bed' );
Goldilocks->slept->in( $mummy{"bear's"}, 'bed' );
Goldilocks->slept->in( $baby{"bear's"}, 'bed' );

goldilocks_2_refactored.pl

use 5.016;
use warnings;

# refactored:   * Moved boiler plate out to BEGIN {}
#               * create some methods dynamically
#               * and used those dang nice (but naughty!) indirect object method calls :)

my $bears = Bears->left_cottage_for_a_walk();

Goldilocks->ate( daddy $bears 'porridge' );
Goldilocks->ate( mummy $bears 'porridge' );
Goldilocks->ate( baby  $bears 'porridge' );

Goldilocks->sat->on( daddy $bears 'chair' );
Goldilocks->sat->on( mummy $bears 'chair' );
Goldilocks->sat->on( baby  $bears 'chair' );

Goldilocks->slept->in( daddy $bears 'bed' );
Goldilocks->slept->in( mummy $bears 'bed' );
Goldilocks->slept->in( baby  $bears 'bed' );

BEGIN {
    package Bear {
        sub new {
            my ($class, $porridge, $chair, $bed) = @_;
            bless {
                porridge => $porridge,
                chair    => $chair,
                bed      => $bed,
            }, $class;
        }
    }

    package Bears {
        sub left_cottage_for_a_walk {
            bless {
                daddy => Bear->new('too hot', 'too big', 'too hard'),
                mummy => Bear->new('too cold', 'too big', 'too soft'),
                baby  => Bear->new( ('just right') x 3 ),
            }, shift;
        }

        no strict 'refs';
        for my $f (qw/daddy mummy baby/) {
            *{'Bears::' . $f} = sub { my ($self, $item) = @_; ($item, $self->{$f}->{$item}) }
        }
    }

    sub Goldilocks::said {
        shift;
        my ($item, $is) = @_;
        my $that = $is eq 'just right' ? 'Aah this' : 'This';
        say "Goldilocks says: $that $item is $is";
    }

    my $p = 'Goldilocks::';
    no strict 'refs';

    for my $f (qw/ate Sat::on Slept::in/) { *{$p . $f} = \&{$p . 'said'} }

    for my $f (qw/sat slept/) { *{$p . $f} = sub { bless {}, $p . ucfirst $f } }
}

goldilocks_3_redux.pl

use 5.016;
use warnings;

# now using perl4 namespaces! :)

Goldilocks->ate( daddy bear's 'porridge' );     # '  oh those syntax highlighters!
Goldilocks->ate( mummy bear's 'porridge' );     # '
Goldilocks->ate( baby  bear's 'porridge' );     # '

Goldilocks->sat->on( daddy bear's 'chair' );    # '
Goldilocks->sat->on( mummy bear's 'chair' );    # '
Goldilocks->sat->on( baby  bear's 'chair' );    # '

Goldilocks->slept->in( daddy bear's 'bed' );    # '
Goldilocks->slept->in( mummy bear's 'bed' );    # '
Goldilocks->slept->in( baby  bear's 'bed' );    # '


BEGIN {
    package Bear {
        sub new {
            my ($class, $porridge, $chair, $bed) = @_;
            bless {
                porridge => $porridge,
                chair    => $chair,
                bed      => $bed,
            }, $class;
        }
    }

    package bear::s {
        our %bears = (
            daddy => Bear->new('too hot', 'too big', 'too hard'),
            mummy => Bear->new('too cold', 'too big', 'too soft'),
            baby  => Bear->new( ('just right') x 3 ),
        );

        no strict 'refs';
        for my $f (qw/daddy mummy baby/) {
            *{"bear::s::$f"} = sub { my ($self, $item) = @_; ($item, $bears{$f}->{$item}) }
        }
    }

    sub Goldilocks::said {
        shift;
        my ($item, $is) = @_;
        my $that = $is eq 'just right' ? 'Aah this' : 'This';
        say "$that $item is $is";
    }

    my $p = 'Goldilocks::';
    no strict 'refs';

    for my $f (qw/ate Sat::on Slept::in/) { *{$p . $f} = \&{$p . 'said'} }

    for my $f (qw/sat slept/) { *{$p . $f} = sub { bless {}, $p . ucfirst $f } }
}

goldilocks_4_first_stab_perl6.pl

use v6;

class Bear {
    has $.porridge;
    has $.chair;
    has $.bed;
}

# use infix operator to create English - daddy bear's 'porridge'
sub infix:<bear's>($bear, $item) { [$bear."$item"(), $item] }   # '

class Goldilocks::Sat {
    has $.goldie;
    method on (@about) { $.goldie.said(@about) }
}

class Goldilocks::Slept {
    has $.goldie;
    method in (@about) { $.goldie.said(@about) }
}

class Goldilocks {
    method said (@about) {
        my ($is, $item) = @about;
        my $that = $is eq 'just right' ?? 'Aah this' !! 'This';
        say "$that $item is $is";
    }

    method ate (@about) { self.said(@about) }
    method sat          { Goldilocks::Sat.new( goldie => self )   }
    method slept        { Goldilocks::Slept.new( goldie => self ) }
}

my ($daddy, $mummy, $baby) = 
    Bear.new( porridge => 'too hot',    chair => 'too big',    bed => 'too hard'   ),
    Bear.new( porridge => 'too cold',   chair => 'too big',    bed => 'too soft'   ),
    Bear.new( porridge => 'just right', chair => 'just right', bed => 'just right' );

my $goldilocks = Goldilocks.new;

$goldilocks.ate:      $daddy bear's 'porridge';   #'
$goldilocks.ate:      $mummy bear's 'porridge';   #'
$goldilocks.ate:      $baby  bear's 'porridge';   #'

$goldilocks.sat.on:   $daddy bear's 'chair';      #'
$goldilocks.sat.on:   $mummy bear's 'chair';      #'
$goldilocks.sat.on:   $baby  bear's 'chair';      #'

$goldilocks.slept.in: $daddy bear's 'bed';        #'
$goldilocks.slept.in: $mummy bear's 'bed';        #'
$goldilocks.slept.in: $baby  bear's 'bed';        #'

goldilocks_5_perl6.pl

use v6;

# OK - made cleaner (ie. no infix operator magic!)
#    - unfortunately indirect syntax didn't work (ala Perl5 example).
#    - so couldn't do something like:  daddy $bears: 'porridge';    :(
#    - but loved how the roles worked on Sat (.sat.on.) & Slept (.slept.in.)

class Bear {
    has $.porridge;
    has $.chair;
    has $.bed;

    method bears (Str $item) { [self."$item"(), $item] }  
}

class Goldilocks {
    my role Sat   { method on (@about) { self.said: @about }}
    my role Slept { method in (@about) { self.said: @about }}

    method said (@about) {
        my ($is, $item) = @about;
        my $that = $is eq 'just right' ?? 'Aah this' !! 'This';
        say "$that $item is $is";
    }

    method ate (@about) { self.said: @about }
    method sat          { self does Sat     }
    method slept        { self does Slept   }
}

my ($daddy, $mummy, $baby) = 
    Bear.new( :porridge<too hot>,    :chair<too big>,    :bed<too hard>   ),
    Bear.new( :porridge<too cold>,   :chair<too big>,    :bed<too soft>   ),
    Bear.new( :porridge<just right>, :chair<just right>, :bed<just right> );

my $goldilocks = Goldilocks.new;

$goldilocks.ate:      $daddy.bears('porridge');
$goldilocks.ate:      $mummy.bears('porridge');
$goldilocks.ate:      $baby.bears('porridge');

$goldilocks.sat.on:   $daddy.bears('chair');
$goldilocks.sat.on:   $mummy.bears('chair');
$goldilocks.sat.on:   $baby.bears('chair');

$goldilocks.slept.in: $daddy.bears('bed');
$goldilocks.slept.in: $mummy.bears('bed');
$goldilocks.slept.in: $baby.bears('bed');

goldilocks_first_stab_rebol.r2

REBOL []   ; The gist syntax highlighting for Rebol code now works!  Many thanks Github

make-bear: func [p c b] [
    make object! [
        bears: make object! [
            porridge: p
            chair:    c
            bed:      b
        ]
    ]
]

daddy: make-bear "too hot" "too big" "too hard"
mummy: make-bear "too cold" "too big" "too soft"
baby:  make-bear "just right" "just right" "just right"

Goldilocks: make object! [
    
    said: func [bear item] [
        use [this that] [
            that: get in bear item
            this: either (that == "just right") ["Aah this"] ["This"]
            print [this item "is" that]
        ]
    ]
 
    ate: func [bear porridge] [said bear porridge]

    sat: make object! [
        on: func [bear chair] [said bear chair]
    ]

    slept: make object! [
        in: func [bear bed] [said bear bed]
    ]
        
]

Goldilocks/ate      daddy/bears 'porridge
Goldilocks/sat/on   daddy/bears 'chair
Goldilocks/slept/in daddy/bears 'bed

Goldilocks/ate      mummy/bears 'porridge
Goldilocks/sat/on   mummy/bears 'chair
Goldilocks/slept/in mummy/bears 'bed

Goldilocks/ate      baby/bears 'porridge
Goldilocks/sat/on   baby/bears 'chair
Goldilocks/slept/in baby/bears 'bed