|
996
|
1 package Language::INTERCAL::Numbers;
|
|
|
2
|
|
|
3 # Numbers which never drop bits, no matter how hard you shake them
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Numbers.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
19 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
20 use Language::INTERCAL::DataItem '1.-94.-2';
|
|
|
21 use vars qw(@ISA);
|
|
|
22 @ISA = qw(Language::INTERCAL::DataItem);
|
|
|
23
|
|
|
24 my @twospotbits = qw(32 20 16 12 12 10);
|
|
|
25 my @spotbits = qw(16 10 8 6 6 5);
|
|
|
26
|
|
|
27 sub new {
|
|
|
28 @_ or croak "Usage: new Language::INTERCAL::Numbers" .
|
|
|
29 "[::Spot|::Twospot|BITS, ] VALUE";
|
|
|
30 my $class = shift;
|
|
|
31 my $bits;
|
|
|
32 if ($class->isa('Language::INTERCAL::Numbers::Spot')) {
|
|
|
33 @_ == 1 or croak "Usage: new $class VALUE";
|
|
|
34 $bits = 16;
|
|
|
35 } elsif ($class->isa('Language::INTERCAL::Numbers::Twospot')) {
|
|
|
36 @_ == 1 or croak "Usage: new $class VALUE";
|
|
|
37 $bits = 32;
|
|
|
38 } else {
|
|
|
39 @_ == 2 or croak "Usage: new $class BITS, BITS";
|
|
|
40 $bits = shift;
|
|
|
41 $bits > 32 and croak "Invalid number of BITS";
|
|
|
42 $class .= $bits > 16 ? '::Twospot' : '::Spot';
|
|
|
43 $bits = $bits > 16 ? 32 : 16;
|
|
|
44 }
|
|
|
45 my ($value) = @_;
|
|
|
46 if (ref $value) {
|
|
|
47 UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers')
|
|
|
48 or faint(SP_NUMBER, 'Is a reference');
|
|
|
49 $value = $value->{value};
|
|
|
50 }
|
|
|
51 $bits <= 16 && $value > 0xffff and faint(SP_SPOTS, $value, 'one spot');
|
|
|
52 $value > 0xffffffff and faint(SP_SPOTS, $value, 'two spots');
|
|
|
53 my $type = $bits <= 16 ? 'Spot' : 'Twospot';
|
|
|
54 bless {
|
|
|
55 bits => $bits <= 16 ? 16 : 32,
|
|
|
56 value => $value,
|
|
|
57 overload => undef,
|
|
|
58 }, $class;
|
|
|
59 }
|
|
|
60
|
|
|
61 sub num_digits {
|
|
|
62 @_ == 2 or croak "Usage: NUMBER/CLASS->num_digits(BASE)";
|
|
|
63 my ($num, $base) = @_;
|
|
|
64 $base >= 2 && $base <= 7 or croak "Invalid BASE";
|
|
|
65 $base -= 2;
|
|
|
66 $num->isa('Language::INTERCAL::Numbers::Spot')
|
|
|
67 and return $spotbits[$base];
|
|
|
68 $num->isa('Language::INTERCAL::Numbers::Twospot')
|
|
|
69 and return $twospotbits[$base];
|
|
|
70 croak "Invalid NUMBER/CLASS";
|
|
|
71 }
|
|
|
72
|
|
|
73 sub from_digits {
|
|
|
74 @_ > 3
|
|
|
75 or croak "Usage: Language::INTERCAL::Numbers->from_digits(BASE, DIGITS)";
|
|
|
76 my ($class, $base, @values) = @_;
|
|
|
77 my $type;
|
|
|
78 if (@values == $spotbits[$base - 2]) {
|
|
|
79 $type = 'Language::INTERCAL::Numbers::Spot';
|
|
|
80 } elsif (@values == $twospotbits[$base - 2]) {
|
|
|
81 $type = 'Language::INTERCAL::Numbers::Twospot';
|
|
|
82 } else {
|
|
|
83 faint(SP_DIGITS, $base, scalar(@values))
|
|
|
84 }
|
|
|
85 my $value = 0;
|
|
|
86 for my $n (@values) {
|
|
|
87 $value = $value * $base + $n % $base;
|
|
|
88 }
|
|
|
89 $type->new($value);
|
|
|
90 }
|
|
|
91
|
|
|
92 sub _assign {
|
|
|
93 @_ == 2 or croak "Usage: NUMBER->assign(VALUE)";
|
|
|
94 my ($num, $value) = @_;
|
|
|
95 if (ref $value) {
|
|
|
96 UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers')
|
|
|
97 or faint(SP_NUMBER, 'Is a reference');
|
|
|
98 $value = $value->{value};
|
|
|
99 }
|
|
|
100 $num->{bits} <= 16 && $value > 0xffff
|
|
|
101 and faint(SP_SPOTS, $value, 'one spot');
|
|
|
102 $value > 0xffffffff and faint(SP_SPOTS, $value, 'two spots');
|
|
|
103 $num->{value} = $value;
|
|
|
104 $num;
|
|
|
105 }
|
|
|
106
|
|
|
107 sub as_list {
|
|
|
108 @_ == 1 or croak "Usage: NUMBER->as_list";
|
|
|
109 my ($num) = @_;
|
|
|
110 ($num);
|
|
|
111 }
|
|
|
112
|
|
|
113 sub copy {
|
|
|
114 @_ == 1 or croak "Usage: NUMBER->copy";
|
|
|
115 my ($num) = @_;
|
|
|
116 bless {
|
|
|
117 value => $num->{value},
|
|
|
118 bits => $num->{bits},
|
|
|
119 overload => $num->{overload},
|
|
|
120 }, ref $num;
|
|
|
121 }
|
|
|
122
|
|
|
123 sub digits {
|
|
|
124 @_ == 2 or croak "Usage: NUMBER->digits(BASE)";
|
|
|
125 my ($num, $base) = @_;
|
|
|
126 faint(SP_BASE, $base) if $base < 2 || $base > 7;
|
|
|
127 my $bits = $num->{bits} < 17
|
|
|
128 ? $spotbits[$base - 2]
|
|
|
129 : $twospotbits[$base - 2];
|
|
|
130 my $orig = $num->{value};
|
|
|
131 my $value = $orig;
|
|
|
132 my @result = ();
|
|
|
133 for (my $n = 0; $n < $bits; $n++) {
|
|
|
134 unshift @result, $value % $base;
|
|
|
135 $value = int($value / $base);
|
|
|
136 }
|
|
|
137 $value and faint(SP_DIGITS, $base, $orig);
|
|
|
138 @result;
|
|
|
139 }
|
|
|
140
|
|
|
141 sub elements { 1 }
|
|
|
142
|
|
|
143 sub number {
|
|
|
144 @_ == 1 or croak "Usage: NUMBER->number";
|
|
|
145 my ($num) = @_;
|
|
|
146 $num->{value};
|
|
|
147 }
|
|
|
148
|
|
|
149 sub print {
|
|
|
150 @_ == 1 or croak "Usage: NUMBER->print";
|
|
|
151 my ($num) = @_;
|
|
|
152 '#' . $num->{value};
|
|
|
153 }
|
|
|
154
|
|
|
155 # some methods in case these values are used as array/class
|
|
|
156
|
|
|
157 sub as_string { faint(SP_NOARRAY); }
|
|
|
158 sub filehandle { faint(SP_NOTCLASS); }
|
|
|
159 sub _get { faint(SP_NOARRAY); }
|
|
|
160 sub hybrid { faint(SP_NOARRAY); }
|
|
|
161 sub range { faint(SP_NOARRAY); }
|
|
|
162 sub _store { faint(SP_NOARRAY); }
|
|
|
163 sub tail { faint(SP_NOARRAY); }
|
|
|
164
|
|
|
165 package Language::INTERCAL::Numbers::Spot;
|
|
|
166
|
|
|
167 use Carp;
|
|
|
168 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
169
|
|
|
170 use vars qw(@ISA);
|
|
|
171 @ISA = qw(Language::INTERCAL::Numbers);
|
|
|
172
|
|
|
173 sub spot {
|
|
|
174 @_ == 1 or croak "Usage: NUMBER->spot";
|
|
|
175 goto &Language::INTERCAL::Numbers::copy;
|
|
|
176 }
|
|
|
177
|
|
|
178 sub twospot {
|
|
|
179 @_ == 1 or croak "Usage: NUMBER->twospot";
|
|
|
180 my ($num) = @_;
|
|
|
181 my $value = $num->{value};
|
|
|
182 bless {
|
|
|
183 value => $value,
|
|
|
184 bits => 32,
|
|
|
185 overload => $num->{overload},
|
|
|
186 }, 'Language::INTERCAL::Numbers::Twospot';
|
|
|
187 }
|
|
|
188
|
|
|
189 package Language::INTERCAL::Numbers::Twospot;
|
|
|
190
|
|
|
191 use Carp;
|
|
|
192 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
193
|
|
|
194 use vars qw(@ISA);
|
|
|
195 @ISA = qw(Language::INTERCAL::Numbers);
|
|
|
196
|
|
|
197 sub spot {
|
|
|
198 @_ == 1 or croak "Usage: NUMBER->spot";
|
|
|
199 my ($num) = @_;
|
|
|
200 my $value = $num->{value};
|
|
|
201 $value > 0xffff and faint(SP_SPOTS, $value, 'one spot');
|
|
|
202 bless {
|
|
|
203 value => $value,
|
|
|
204 bits => 16,
|
|
|
205 overload => $num->{overload},
|
|
|
206 }, 'Language::INTERCAL::Numbers::Spot';
|
|
|
207 }
|
|
|
208
|
|
|
209 sub twospot {
|
|
|
210 @_ == 1 or croak "Usage: NUMBER->twospot";
|
|
|
211 goto &Language::INTERCAL::Numbers::copy;
|
|
|
212 }
|
|
|
213
|
|
|
214 1;
|
