clc-intercal 1:1.0~4pre1.-94.-2-4 / usr / share / perl5 / Language / INTERCAL / Numbers.pm

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;