Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Numbers.pm @ 12515:df8f62801bed draft default tip
<int-e> learn The password of the month is twenty-six characters long
author | HackEso <hackeso@esolangs.org> |
---|---|
date | Tue, 01 Oct 2024 11:58:37 +0100 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
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;