Mercurial > repo
diff interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Numbers.pm @ 996:859f9b4339e6
<Gregor> tar xf egobot.tar.xz
author | HackBot |
---|---|
date | Sun, 09 Dec 2012 19:30:08 +0000 |
parents | |
children |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Numbers.pm Sun Dec 09 19:30:08 2012 +0000 @@ -0,0 +1,214 @@ +package Language::INTERCAL::Numbers; + +# Numbers which never drop bits, no matter how hard you shake them + +# This file is part of CLC-INTERCAL + +# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved. + +# CLC-INTERCAL is copyrighted software. However, permission to use, modify, +# and distribute it is granted provided that the conditions set out in the +# licence agreement are met. See files README and COPYING in the distribution. + +use strict; +use vars qw($VERSION $PERVERSION); +($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Numbers.pm 1.-94.-2") =~ /\s(\S+)$/; + +use Carp; +use Language::INTERCAL::Exporter '1.-94.-2'; +use Language::INTERCAL::Splats '1.-94.-2', qw(:SP); +use Language::INTERCAL::DataItem '1.-94.-2'; +use vars qw(@ISA); +@ISA = qw(Language::INTERCAL::DataItem); + +my @twospotbits = qw(32 20 16 12 12 10); +my @spotbits = qw(16 10 8 6 6 5); + +sub new { + @_ or croak "Usage: new Language::INTERCAL::Numbers" . + "[::Spot|::Twospot|BITS, ] VALUE"; + my $class = shift; + my $bits; + if ($class->isa('Language::INTERCAL::Numbers::Spot')) { + @_ == 1 or croak "Usage: new $class VALUE"; + $bits = 16; + } elsif ($class->isa('Language::INTERCAL::Numbers::Twospot')) { + @_ == 1 or croak "Usage: new $class VALUE"; + $bits = 32; + } else { + @_ == 2 or croak "Usage: new $class BITS, BITS"; + $bits = shift; + $bits > 32 and croak "Invalid number of BITS"; + $class .= $bits > 16 ? '::Twospot' : '::Spot'; + $bits = $bits > 16 ? 32 : 16; + } + my ($value) = @_; + if (ref $value) { + UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers') + or faint(SP_NUMBER, 'Is a reference'); + $value = $value->{value}; + } + $bits <= 16 && $value > 0xffff and faint(SP_SPOTS, $value, 'one spot'); + $value > 0xffffffff and faint(SP_SPOTS, $value, 'two spots'); + my $type = $bits <= 16 ? 'Spot' : 'Twospot'; + bless { + bits => $bits <= 16 ? 16 : 32, + value => $value, + overload => undef, + }, $class; +} + +sub num_digits { + @_ == 2 or croak "Usage: NUMBER/CLASS->num_digits(BASE)"; + my ($num, $base) = @_; + $base >= 2 && $base <= 7 or croak "Invalid BASE"; + $base -= 2; + $num->isa('Language::INTERCAL::Numbers::Spot') + and return $spotbits[$base]; + $num->isa('Language::INTERCAL::Numbers::Twospot') + and return $twospotbits[$base]; + croak "Invalid NUMBER/CLASS"; +} + +sub from_digits { + @_ > 3 + or croak "Usage: Language::INTERCAL::Numbers->from_digits(BASE, DIGITS)"; + my ($class, $base, @values) = @_; + my $type; + if (@values == $spotbits[$base - 2]) { + $type = 'Language::INTERCAL::Numbers::Spot'; + } elsif (@values == $twospotbits[$base - 2]) { + $type = 'Language::INTERCAL::Numbers::Twospot'; + } else { + faint(SP_DIGITS, $base, scalar(@values)) + } + my $value = 0; + for my $n (@values) { + $value = $value * $base + $n % $base; + } + $type->new($value); +} + +sub _assign { + @_ == 2 or croak "Usage: NUMBER->assign(VALUE)"; + my ($num, $value) = @_; + if (ref $value) { + UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers') + or faint(SP_NUMBER, 'Is a reference'); + $value = $value->{value}; + } + $num->{bits} <= 16 && $value > 0xffff + and faint(SP_SPOTS, $value, 'one spot'); + $value > 0xffffffff and faint(SP_SPOTS, $value, 'two spots'); + $num->{value} = $value; + $num; +} + +sub as_list { + @_ == 1 or croak "Usage: NUMBER->as_list"; + my ($num) = @_; + ($num); +} + +sub copy { + @_ == 1 or croak "Usage: NUMBER->copy"; + my ($num) = @_; + bless { + value => $num->{value}, + bits => $num->{bits}, + overload => $num->{overload}, + }, ref $num; +} + +sub digits { + @_ == 2 or croak "Usage: NUMBER->digits(BASE)"; + my ($num, $base) = @_; + faint(SP_BASE, $base) if $base < 2 || $base > 7; + my $bits = $num->{bits} < 17 + ? $spotbits[$base - 2] + : $twospotbits[$base - 2]; + my $orig = $num->{value}; + my $value = $orig; + my @result = (); + for (my $n = 0; $n < $bits; $n++) { + unshift @result, $value % $base; + $value = int($value / $base); + } + $value and faint(SP_DIGITS, $base, $orig); + @result; +} + +sub elements { 1 } + +sub number { + @_ == 1 or croak "Usage: NUMBER->number"; + my ($num) = @_; + $num->{value}; +} + +sub print { + @_ == 1 or croak "Usage: NUMBER->print"; + my ($num) = @_; + '#' . $num->{value}; +} + +# some methods in case these values are used as array/class + +sub as_string { faint(SP_NOARRAY); } +sub filehandle { faint(SP_NOTCLASS); } +sub _get { faint(SP_NOARRAY); } +sub hybrid { faint(SP_NOARRAY); } +sub range { faint(SP_NOARRAY); } +sub _store { faint(SP_NOARRAY); } +sub tail { faint(SP_NOARRAY); } + +package Language::INTERCAL::Numbers::Spot; + +use Carp; +use Language::INTERCAL::Splats '1.-94.-2', qw(:SP); + +use vars qw(@ISA); +@ISA = qw(Language::INTERCAL::Numbers); + +sub spot { + @_ == 1 or croak "Usage: NUMBER->spot"; + goto &Language::INTERCAL::Numbers::copy; +} + +sub twospot { + @_ == 1 or croak "Usage: NUMBER->twospot"; + my ($num) = @_; + my $value = $num->{value}; + bless { + value => $value, + bits => 32, + overload => $num->{overload}, + }, 'Language::INTERCAL::Numbers::Twospot'; +} + +package Language::INTERCAL::Numbers::Twospot; + +use Carp; +use Language::INTERCAL::Splats '1.-94.-2', qw(:SP); + +use vars qw(@ISA); +@ISA = qw(Language::INTERCAL::Numbers); + +sub spot { + @_ == 1 or croak "Usage: NUMBER->spot"; + my ($num) = @_; + my $value = $num->{value}; + $value > 0xffff and faint(SP_SPOTS, $value, 'one spot'); + bless { + value => $value, + bits => 16, + overload => $num->{overload}, + }, 'Language::INTERCAL::Numbers::Spot'; +} + +sub twospot { + @_ == 1 or croak "Usage: NUMBER->twospot"; + goto &Language::INTERCAL::Numbers::copy; +} + +1;