File Coverage

blib/lib/Ordeal/Model/Evaluator.pm
Criterion Covered Total %
statement 116 169 68.6
branch 16 26 61.5
condition 2 6 33.3
subroutine 22 28 78.5
pod 13 13 100.0
total 169 242 69.8


line stmt bran cond sub pod time code
1             package Ordeal::Model::Evaluator;
2              
3             # vim: ts=3 sts=3 sw=3 et ai :
4              
5 6     6   109 use 5.020;
  6         19  
6 6     6   41 use strict; # redundant, but still useful to document
  6         12  
  6         119  
7 6     6   28 use warnings;
  6         12  
  6         321  
8             { our $VERSION = '0.004'; }
9 6     6   36 use Scalar::Util qw< blessed >;
  6         10  
  6         282  
10 6     6   33 use Mo qw< build default >;
  6         12  
  6         25  
11 6     6   1610 use Ouch;
  6         14  
  6         31  
12 6     6   2992 use Ordeal::Model::Deck;
  6         19  
  6         178  
13 6     6   2561 use Ordeal::Model::Shuffle;
  6         15  
  6         196  
14              
15 6     6   41 use Exporter qw< import >;
  6         11  
  6         298  
16             our @EXPORT_OK = qw< EVALUATE >;
17              
18 6     6   37 use experimental qw< signatures postderef >;
  6         12  
  6         21  
19 6     6   1315 no warnings qw< experimental::signatures experimental::postderef >;
  6         13  
  6         9839  
20              
21             has _dc => (); # deck cache
22             has _model => ();
23             has _rs => (
24             default => sub {
25             require Ordeal::Model::ChaCha20;
26             return Ordeal::Model::ChaCha20->new;
27             }
28             );
29             has _stack => ();
30              
31 2     2 1 75 sub BUILD ($self) {
  2         4  
  2         3  
32 2 50       13 my $m = delete($self->{model}) or ouch 400, 'no model provided';
33 2         9 $self->_model($m);
34             $self->_rs(delete $self->{random_source})
35 2 50       17 if exists $self->{random_source};
36 2         19 $self->_dc({});
37 2         9 $self->_stack([]);
38 2         9 return $self;
39             }
40              
41 2     2 1 31 sub EVALUATE (%args) {
  2         6  
  2         3  
42 2 50       16 my $ast = delete($args{ast}) or ouch 400, 'no ast provided';
43 2         18 return __PACKAGE__->new(%args)->_eval($ast);
44             }
45              
46 10     10   17 sub _eval ($self, $ast) {
  10         17  
  10         14  
  10         11  
47 10         35 my ($op, @params) = $ast->@*;
48 10 50       16 my $method = eval {
49 10 50       25 die '' if substr($op, 0, 1) eq '_'; # no "private" stuff
50 10 50       31 die '' if lc($op) ne $op; # no "uppercase" stuff
51 10         42 $self->can($op);
52             } or ouch 400, 'unknown op', $op;
53 10         27 return $self->$method(@params);
54             }
55              
56 4     4   6 sub _get_integer ($self, $n) {
  4         5  
  4         7  
  4         6  
57 4         9 push $self->_stack->@*, 0;
58 4         19 ($n) = $self->_unroll($n);
59 4         9 pop $self->_stack->@*;
60 4         20 return $n;
61             }
62              
63 4     4   8 sub _shuffle ($self, $deck) {
  4         7  
  4         6  
  4         6  
64 4 100       20 $deck = Ordeal::Model::Deck->new(cards => $deck) unless blessed $deck;
65 4         38 return Ordeal::Model::Shuffle->new(
66             auto_reshuffle => 0,
67             deck => $deck,
68             default_n_draw => $deck->n_cards,
69             random_source => $self->_rs,
70             )->sort;
71             } ## end sub _shuffle ($self, $deck)
72              
73 8     8   11 sub _unroll ($self, @potentials) {
  8         11  
  8         22  
  8         11  
74 8         14 my $N = $self->_stack->[-1];
75 18 100       43 return map { $N ? ($_ % $N) : $_ } map {
76 8 100       31 ref($_) ? $self->_eval($_) : $_;
  10         28  
77             } @potentials;
78             }
79              
80 2     2 1 3 sub math_subtract ($self, $t1, $t2) {
  2         4  
  2         12  
  2         5  
  2         2  
81 2         8 return $self->_get_integer($t1) - $self->_get_integer($t2);
82             }
83              
84 0     0 1 0 sub random ($self, @potentials) {
  0         0  
  0         0  
  0         0  
85 0         0 my @candidates = $self->_unroll(@potentials);
86 0         0 return $candidates[$self->_rs->int_rand(0, $#candidates)];
87             }
88              
89 2     2 1 3 sub range ($self, $lo, $hi) {
  2         4  
  2         20  
  2         4  
  2         2  
90 2         8 ($lo, $hi) = $self->_unroll($lo, $hi);
91 2         8 return $lo .. $hi;
92             }
93              
94 0     0 1 0 sub repeat ($self, $s_ast, $n) {
  0         0  
  0         0  
  0         0  
  0         0  
95 0         0 $n = $self->_get_integer($n);
96 0         0 my @cards;
97 0         0 while ($n-- > 0) {
98 0         0 my $s = $self->_eval($s_ast);
99 0         0 push @cards, $s->draw;
100             }
101 0         0 return $self->_shuffle(\@cards);
102             }
103              
104 0     0 1 0 sub replicate ($self, $s_ast, $n) {
  0         0  
  0         0  
  0         0  
  0         0  
105 0         0 $n = $self->_get_integer($n);
106 0         0 my $s = $self->_eval($s_ast);
107 0         0 my @cards = $s->draw;
108 0         0 return $self->_shuffle([(@cards) x $n]);
109             }
110              
111 2     2 1 5 sub resolve ($self, $shuffle) {
  2         3  
  2         4  
  2         10  
112 2 50 33     11 return $shuffle
113             if blessed($shuffle) && $shuffle->isa('Ordeal::Model::Shuffle');
114 2   33     14 my $deck = $self->_dc->{$shuffle} //= $self->_model->get_deck($shuffle);
115 2         31 return $self->_shuffle($deck);
116             }
117              
118 2     2 1 3 sub shuffle ($self, $s_ast) { return $self->_eval($s_ast)->shuffle }
  2         4  
  2         3  
  2         3  
  2         6  
119              
120 2     2 1 4 sub slice ($self, $s_ast, @slices) {
  2         4  
  2         3  
  2         4  
  2         2  
121 2 50       8 my $s = $self->_eval($s_ast) # 400's upon error
122             or ouch 500, 'slice: invalid AST', $s_ast; # "my" error => 500
123              
124 2         7 push $self->_stack->@*, $s->deck->n_cards;
125 2         15 my @indexes = $self->_unroll(@slices);
126 2         7 pop $self->_stack->@*;
127              
128 2         7 my $max = 0;
129 2 100       12 $max = ($max < $_ ? $_ : $max) for @indexes;
130 2         8 my @cards = $s->draw($max + 1);
131 2         12 return $self->_shuffle([@cards[@indexes]]);
132             }
133              
134 0     0 1   sub sort ($self, $s_ast) { return $self->_eval($s_ast)->sort }
  0            
  0            
  0            
  0            
135              
136 0     0 1   sub subtract ($self, $s1_ast, $s2_ast) {
  0            
  0            
  0            
  0            
137 0           my $s1 = $self->_eval($s1_ast);
138 0           my $s2 = $self->_eval($s2_ast);
139 0           my @cards = $s1->draw;
140 0           for my $deleted ($s2->draw) {
141 0           for my $i (0 .. $#cards) {
142 0 0         next if $cards[$i] ne $deleted;
143 0           splice @cards, $i, 1;
144 0           last;
145             }
146             }
147 0           return $self->_shuffle(\@cards);
148             }
149              
150 0     0 1   sub sum ($self, $s1_ast, $s2_ast) {
  0            
  0            
  0            
  0            
151 0           my $s1 = $self->_eval($s1_ast);
152 0           my $s2 = $self->_eval($s2_ast);
153 0           return $self->_shuffle([$s1->draw, $s2->draw]);
154             }
155              
156             1;