Mercurial > repo

comparison interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Numbers.pm @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
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;