File Coverage

File:blib/lib/Language/Nouse.pm
Coverage:80.8%

linestmtbrancondsubtimecode
1package Language::Nouse;
2
3
3
3
3
3
15
6
22
use strict;
4
3
3
3
3
20
6
30
use warnings;
5
6our $VERSION = '0.04';
7
8sub new {
9
3
3
19
        my $class = shift;
10
3
13
        my $self = bless {}, $class;
11
12
3
10
        my $options = shift;
13
3
23
        $self->clear();
14
15
3
14
        $self->{sub_get} = \&NOUSE_DEFAULT_get;
16
3
12
        $self->{sub_put} = \&NOUSE_DEFAULT_put;
17
18
3
64
        return $self;
19}
20
21sub clear {
22
8
8
25
        my ($self) = @_;
23
8
31
        $self->{ring} = [];
24
8
26
        $self->{stack} = [];
25
8
26
        $self->{ring_pointer} = 0;
26}
27
28sub set_get {
29
0
0
0
        my ($self, $new) = @_;
30
0
0
        $self->{sub_get} = $new;
31}
32
33sub set_put {
34
1
1
4
        my ($self, $new) = @_;
35
1
4
        $self->{sub_put} = $new;
36}
37
38sub NOUSE_DEFAULT_get {
39
0
0
0
        return getc;
40}
41
42sub NOUSE_DEFAULT_put {
43
0
0
0
        print $_[0];
44}
45
46sub load_linenoise {
47
4
4
19
        my ($self, $input) = @_;
48
49
4
14
        $self->_reset_ring();
50
51
4
15
        my $op = qr/[#:<>+?^]/;
52
4
11
        my $mul = qr/[0-9a-z_]/;
53
54
4
10
        my $not_op = qr/[^#:<>+?^]/;
55
4
10
        my $not_mul = qr/[^0-9a-z_]/;
56
57
4
86
        while ($input =~ m/$not_op*($op)$not_mul*($mul)/g){
58
59
43
92
                my $this_op = $1;
60
43
86
                my $this_mul = $2;
61
62
43
121
                $this_op =~ y/#:<>+?^/0123456/;
63
64
43
100
153
                $this_mul = 10 + (ord($this_mul) - ord('a')) if ($this_mul =~ m/[a-z]/);
65
43
50
125
                $this_mul = 36 if ($this_mul eq '_');
66
67
43
115
                my $op_code = ($this_mul * 7) + $this_op;
68
69
43
43
71
439
                push @{$self->{ring}}, $op_code;
70        }
71
72}
73
74sub load_assembly {
75
4
4
14
        my ($self, $input) = @_;
76
77
4
13
        $self->_reset_ring();
78
79
4
18
        $input =~ s/#(.*?)(\r|\n|$)/$2/g;
80
81
4
23
        my @tokens = split /[,\n\r]/, $input;
82
83
4
14
        for my $token(@tokens){
84
16
71
                $token =~ s/\s*(.*?)\s*/$1/;
85
86
16
100
50
60
                        if ($token =~ m/(cut|paste|read|write|add|test|swap) (\d+)/i){
87
88
15
30
                                my $op = $1;
89
15
31
                                my $mul = $2;
90
91
15
0
0
50
50
100
100
100
100
50
130
0
0
                                if ($op eq 'cut'){$op = 0;}
92
3
8
                                elsif ($op eq 'paste'){$op = 1;}
93
3
6
                                elsif ($op eq 'read'){$op = 2;}
94
3
10
                                elsif ($op eq 'write'){$op = 3;}
95
3
6
                                elsif ($op eq 'add'){$op = 4;}
96
3
6
                                elsif ($op eq 'test'){$op = 5;}
97                                elsif ($op eq 'swap'){$op = 6;}
98
99
15
15
28
81
                                push @{$self->{ring}}, ($mul * 7) + $op;
100
101                        }elsif ($token =~ m/(\d+)/){
102
103
0
0
0
0
                                push @{$self->{ring}}, $1+0;
104
105                        }
106        }
107}
108
109sub get_linenoise {
110
36
36
102
        my ($self) = @_;
111
112
36
147
        $self->_reset_ring();
113
114
36
70
        my $buffer = '';
115
36
36
61
125
        for my $raw(@{$self->{ring}}){
116
943
2157
                my $op = $raw % 7;
117
943
2369
                my $mul = int($raw / 7);
118
119
943
1737
                $op =~ y/0123456/#:<>+?^/;
120
121
943
50
100
3939
                if ($mul == 36){
122
0
0
                        $mul = '_';
123                }elsif ($mul > 9){
124
656
1725
                        $mul = chr(ord('a') + ($mul - 10));
125                }
126
127
943
2768
                $buffer .= $op.$mul;
128        }
129
36
151
        return $buffer;
130}
131
132sub get_assembly {
133
5
5
14
        my ($self, $per_line) = @_;
134
135
5
16
        $self->_reset_ring();
136
137
5
50
20
        $per_line = 4 unless defined $per_line;
138
139
5
7
        my @ops;
140
141
5
5
10
19
        for my $raw(@{$self->{ring}}){
142
25
55
                my $op = $raw % 7;
143
25
60
                my $mul = int($raw / 7);
144
145
25
50
50
100
100
100
100
50
305
                if ($op == 0){
146
0
0
                        $op = 'cut';
147                }elsif ($op == 1){
148
0
0
                        $op = 'paste';
149                }elsif ($op == 2){
150
5
12
                        $op = 'read';
151                }elsif ($op == 3){
152
5
11
                        $op = 'write';
153                }elsif ($op == 4){
154
5
10
                        $op = 'add';
155                }elsif ($op == 5){
156
5
11
                        $op = 'test';
157                }elsif ($op == 6){
158
5
10
                        $op = 'swap';
159                }
160
161
25
103
                push @ops, "$op $mul";
162        }
163
164
5
11
        my $buffer = '';
165
5
16
        while (@ops){
166
10
60
                $buffer .= join(', ', splice @ops, 0, $per_line)."\n";
167        }
168
169
5
24
        return $buffer;
170}
171
172sub run {
173
0
0
0
        my ($self) = @_;
174
175
0
0
0
0
        while(scalar(@{$self->{ring}})){
176
0
0
                $self->step();
177        }
178}
179
180sub step {
181
30
30
192
        my ($self) = @_;
182
183
30
85
        my ($op, $mul, $raw) = $self->_get_op();
184
185
30
30
50
101
        my $skip = scalar(@{$self->{stack}}) * $mul;
186
30
51
        $skip++;
187
188
30
100
90
        if ($op == 0){
189                # cut
190
3
9
                $self->_skip($skip);
191
3
11
                $self->_push($self->_get_oprand());
192
3
12
                $self->_remove_op();
193
3
6
                $skip--;
194        }
195
196
30
100
90
        if ($op == 1){
197                # paste
198
1
3
                $self->_skip($skip);
199
1
1
50
1
5
                if (scalar(@{$self->{stack}})){
200
1
3
                        $self->_insert_op($self->_pop());
201                }else{
202
0
0
                        $self->_insert_op($self->_get_oprand());
203                }
204        }
205
206
30
50
80
        if ($op == 2){
207                # read
208
0
0
0
0
                my $in = &{$self->{sub_get}}();
209
0
0
0
                if (defined $in){
210
0
0
                        $self->_push(ord($in) % 256);
211                }
212        }
213
214
30
100
86
        if ($op == 3){
215                # write
216
14
14
50
22
56
                if (scalar(@{$self->{stack}})){
217
14
14
39
44
                        &{$self->{sub_put}}(chr($self->_peek()));
218                }
219        }
220
221
30
100
125
        if ($op == 4){
222                # add
223
11
11
50
18
42
                if (scalar(@{$self->{stack}})){
224
11
31
                        $self->_skip($skip);
225
11
28
                        my $oprand = $self->_get_oprand();
226
11
32
                $oprand += $self->_pop();
227
11
37
                        $self->_push($oprand % 256);
228                }
229        }
230
231
30
50
88
        if ($op == 5){
232                # test
233
0
0
0
0
0
                if (scalar(@{$self->{stack}})){
234
0
0
                        $self->_skip($skip);
235
0
0
                        my $oprand = $self->_get_oprand();
236
0
0
0
                        if ($oprand == $self->_peek()){
237
0
0
                                $self->_pop();
238                        }
239                }
240        }
241
242
30
100
84
        if ($op == 6){
243                # swap
244
1
4
                $self->_swap();
245        }
246
247
30
80
        $self->_skip($skip);
248}
249
250sub _skip {
251
45
45
122
        my ($self, $by) = @_;
252        # skip the ring pointer along by $by places
253
45
110
        $self->{ring_pointer} += $by;
254
255
45
45
70
179
        my $s = scalar(@{$self->{ring}});
256
45
100
127
        if ($s == 0){
257
1
2
                $self->{ring_pointer} = 0;
258
1
3
                return;
259        }
260
261
44
174
        $self->{ring_pointer} = $self->{ring_pointer} % $s;
262}
263
264sub _get_op {
265
30
30
72
        my ($self) = @_;
266
267
30
78
        my $raw = $self->_get_oprand();
268
30
72
        my $op = $raw % 7;
269
30
79
        my $mul = int($raw / 7);
270
271
30
105
        return ($op, $mul, $raw);
272}
273
274sub _get_oprand {
275
44
44
106
        my ($self) = @_;
276
44
44
50
64
168
        die "ARGH: The ring is empty and you're asking for an oprand!" if !scalar(@{$self->{ring}});
277
44
191
        return $self->{ring}->[$self->{ring_pointer}];
278}
279
280sub _push {
281
28
28
128
        my ($self, $value) = @_;
282
28
28
97
101
        push @{$self->{stack}}, $value;
283}
284
285sub _pop {
286
26
26
61
        my ($self) = @_;
287
26
26
44
88
        return pop @{$self->{stack}};
288}
289
290sub _peek {
291
14
14
34
        my ($self) = @_;
292
14
91
        my $data = $self->_pop();
293
14
41
        $self->_push($data);
294
14
36
        return $data;
295}
296
297sub _remove_op {
298
3
3
8
        my ($self) = @_;
299
3
3
6
13
        splice @{$self->{ring}}, $self->{ring_pointer}, 1;
300}
301
302sub _insert_op {
303
1
1
3
        my ($self, $value) = @_;
304
1
1
3
5
        splice @{$self->{ring}}, $self->{ring_pointer}, 0, ($value);
305}
306
307sub _reset_ring {
308
49
49
116
        my ($self) = @_;
309
310
49
128
        my $p = $self->{ring_pointer};
311
49
49
69
142
        my $l = scalar(@{$self->{ring}});
312
313
49
49
91
276
        my @new_ring = splice(@{$self->{ring}}, $p, $l-$p);
314
49
49
116
228
        push @new_ring, splice(@{$self->{ring}}, 0, $p);
315
316
49
152
        $self->{ring} = \@new_ring;
317
49
160
        $self->{ring_pointer} = 0;
318}
319
320sub _swap {
321
1
1
3
        my ($self) = @_;
322
323
1
1
2
5
        my @new_ring = @{$self->{stack}};
324
325
1
3
        my $p = $self->{ring_pointer};
326
1
1
2
4
        my $l = scalar(@{$self->{ring}});
327
328
1
1
2
12
        my @new_stack = splice(@{$self->{ring}}, $p, $l-$p);
329
1
1
4
4
        push @new_stack, splice(@{$self->{ring}}, 0, $p);
330
331
1
3
        $self->{stack} = \@new_stack;
332
1
4
        $self->{ring} = \@new_ring;
333
1
4
        $self->{ring_pointer} = 0;
334}
335
336
337sub debug {
338
0
0
        my ($self) = @_;
339
340
0
0
0
        print "RING: ".join(',',@{$self->{ring}})." STACK:".join(',',@{$self->{stack}})."\n";
341}
342
3431;
344