Help language development. Donate to The Perl Foundation

Game::Entities zef:jjatria last updated on 2021-11-14

t/entities.t
#!/usr/bin/env raku

use Test;
use Game::Entities;

class Named { has Str $.name }
role  Aging { has Int $.age }
class Other { }

subtest 'Basic operations' => {
    with Game::Entities.new {
        my $a = .create;
        my $b = .create;

        nok .check( $a, Named ), 'A does not have Named';

        .add: $a, Named.new( name => 'old' );
        .add: $a, Named.new( name => 'new' );

         ok .check( $a, Named ), 'A has Named';
        nok .check( $b, Named ), 'B does not have Named';

        is .get( $a, Named ).name, 'new', 'Adding component replaces';

        is .delete( $a, Named ), Nil, 'delete returns Nil';

        nok .check( $a, Named ), 'A does not have Named';

        .delete: $a, Named;

        nok .check( $a, Named ), 'Deleting is idempotent';

        is .get( $a, Named ), Named, 'Getting returns type object';

        { # Operations with multiple components
            my $e = .create:
                Named.new( name => 'list' ),
                Aging.new( age  => 42     ),
                Other.new;

            my ( $name, $age, $other ) = .get: $e, Named, Aging, Other;
            is $name.name, 'list', 'Got name with list';
            is $age.age,   42,     'Got age with list';
            is ?$other,    True,   'Got other with list';

            .delete: $e, Named, Aging, Other;
            is .check( $e, Other ), False, 'Deleted component with list';

            .add: $e, Named, Aging, Other;
            for Named, Aging, Other -> $c {
                is .check( $e, $c ), True, "Added '{ $c.^name }' with list";
            }
        }
    }
}

subtest 'Delete entities' => {
    with Game::Entities.new {
        my $a = .create: Named.new( name => 'a' ), Other;
        .delete: $a;

        nok .get( $a, Other ), 'A does not have Other';
        nok .get( $a, Named ), 'A does not have Named';
    }
}

subtest 'Recycling GUIDs' => {
    with Game::Entities.new {
        is .alive, 0, 'Right number of alive entities when none created';

        # Create 10 entities; will use the first 10 entity IDs ( 0 .. 9 )
        my @e = .create xx 10;

        is .created, 10, 'Right number of created entities when all alive';
        is .alive,   10, 'Right number of alive entities when all alive';
        is .valid(10),   True,  'Entity is valid';
        is .valid(11),   False, 'Entity is not valid';

        # Delete the entities we've just generated
        # Will mark their IDs as ready to be recycled
        for @e -> $e { .delete: $e }

        is .created, 10, 'Right number of created entities when all dead';
        is .alive,    0, 'Right number of alive entities when all dead';
        is .valid(9),     False, 'Entity is not valid';

        # Create 20 entities
        # They should re-use the first 10 IDs and use the next 10 ( 0 .. 19 )
        @e = .create(Other) xx 20;
        is @e.map( * +& 0xFFFFF ).sort, 1 .. 20,
            'Recycled and generated the right IDs';

        is .valid(@e[8]), True, 'Entity is valid';
        is .alive, 20, 'Recorded the right number of alive entities after recycling';
        is .view(Other).map({1}).sum, 20, 'Only alive entities match view';

        is .clear, Nil, 'clear returns Nil';
        is .alive,   0, 'No alive entities after clearing';
        is .created, 0, 'No created entities after clearing';
    }
}

subtest 'Simple view' => {
    with Game::Entities.new -> \E {
        my $named   = E.create;
        my $aging   = E.create;
        my $both    = E.create;
        my $dead    = E.create;
        my $reverse = E.create;
        my $extra   = E.create;

        E.delete: $dead;

        E.add: $named,   Named.new: name => 'Pat';
        E.add: $aging,   Aging.new: age  => 10;
        E.add: $both,    Aging.new: age  => 20;
        E.add: $both,    Named.new: name => 'Tim';
        E.add: $reverse, Named.new: name => 'Mit';
        E.add: $reverse, Aging.new: age  => 2;
        E.add: $extra,   Named.new: name => 'Most';
        E.add: $extra,   Aging.new: age  => 200;
        E.add: $extra,   Other.new;

        # E.^dump-entities;

        my SetHash $set .= new;
        for E.view( Named ) -> (:value(($name)), |) {
            $set.set: $name.name;
        }

        ok $set ~~ set(< Pat Tim Mit Most >),
            'Iterate over simple view with for';

        $set .= new;
        E.view( Aging ).each: -> $a {
            # diag "I am { $a.age } years old";
            $set.set: $a.age;
        }

        ok $set ~~ set( 2, 10, 20, 200 ), 'Iterate over simple view with each';

        $set .= new;
        for E.view( Aging, Named ) {
            my ( $a, $n ) = E.get: .key, Aging, Named;
            # diag "My name is { $n.name }, and I am { $a.age } years old";
            $set.set: $n.name ~ ':' ~ $a.age;
        }

        ok $set ~~ set(< Tim:20 Mit:2 Most:200 >),
            'Iterate over complex view with for';

        $set .= new;
        E.view( Named, Aging ).each: -> $n, $a {
            # diag "My name is { $n.name }, and I am { $a.age } years old";
            $set.set: $n.name ~ ':' ~ $a.age;
        }

        ok $set ~~ set(< Tim:20 Mit:2 Most:200 >),
            'Iterate over complex view with each, arity matches view';

        $set .= new;
        E.view( Aging, Named ).each: -> $e, $, $n {
            my $a = E.get: $e, Aging;
            # diag "My name is { $n.name }, and I am { $a.age } years old";
            $set.set: $n.name ~ ':' ~ $a.age;
        }

        ok $set ~~ set(< Tim:20 Mit:2 Most:200 >),
            'Iterate over complex view with each, arity includes entity';

        $set .= new;
        E.view( Aging, Named ).each: -> $e, *@c {
            # diag "My name is { @c[1].name }, and I am { @c[0].age } years old";
            $set.set: @c[1].name ~ ':' ~ @c[0].age;
        }

        ok $set ~~ set(< Tim:20 Mit:2 Most:200 >),
            'Iterate over complex view with variadic block';

        $set .= new;
        E.view(*).each: -> $e {
            $set.set: $e ~ ':' ~ E.get( $e, Aging ).defined;
        }

        ok $set ~~ set(< 1:False 2:True 3:True 5:True 6:True >),
            'Iterate over all entities';

        is E.view(Aging).map(*.value), E.view(Aging).components,
            'Component list is equivalent to values of iterator';

        is E.view(Aging).map(*.key), E.view(Aging).entities,
            'Component list is equivalent to values of iterator';

        throws-like { E.view(Aging, Other).each: -> $g {} },
            X::AdHoc, message => /'The block passed to this view'/;

        subtest '^dump-entities' => {
            my $*OUT = $*ERR; # How to test output?
            is E.^dump-entities, Nil;
        }
    }
}

subtest 'Modifying view' => {
    with Game::Entities.new {
        my class X      { has $.value is rw = 10 }
        my class Y is X { }

        .create: Y.new( value => 7 ), X.new( value => 7 );
        .create: Y.new( value => 5 ), X.new( value => 5 );
        .create: Y.new,               X.new;

        .view(X, Y).each: -> \e, \x, \y {
            if --x.value < 5 {
                .delete: e;
                .create: X.new( value => 11 );
                .create: Y.new( value => 11 );
            }
        }

        my @x = gather .view(*).each: -> \e { take .value with .get: e, X }
        ok @x.sort ~~ ( 6, 9, 11 );

        my @y = gather .view(*).each: -> \e { take .value with .get: e, Y }
        ok @y.sort ~~ ( 7, 10, 11 );
    }
}

done-testing;