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

package Language::INTERCAL::Arrays;

# Tails and hybrids; also shark fins

# 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/Arrays.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::Numbers '1.-94.-2';
use Language::INTERCAL::DataItem '1.-94.-2';
use vars qw(@ISA);
@ISA = qw(Language::INTERCAL::DataItem);

sub new {
    @_ or croak
	"Usage: new Language::INTERCAL::Arrays [::TYPE | BITS], SUBSCRIPTS";
    my $class = shift;
    my $bits;
    if ($class->isa('Language::INTERCAL::Arrays::Tail')) {
	@_ == 1 or croak "Usage: new $class SUBSCRIPTS";
	$bits = 16;
    } elsif ($class->isa('Language::INTERCAL::Arrays::Hybrid')) {
	@_ == 1 or croak "Usage: new $class SUBSCRIPTS";
	$bits = 32;
    } else {
	@_ == 2 or croak "Usage: new $class BITS, SUBSCRIPTS";
	my $bits = shift;
	$bits > 32 and croak "Invalid number of BITS";
	$bits = $bits > 16 ? 32 : 16;
	$class .= $bits > 16 ? '::Hybrid' : '::Tail';
    }
    my @subscripts = _make_subscripts(undef, @_);
    bless {
	subscripts => \@subscripts,
	value => {},
	bits => $bits,
	overload => undef,
    }, $class;
}

sub copy {
    @_ == 1 or croak "Usage: ARRAY->copy";
    my ($arr) = @_;
    bless {
	map {
	    my $v = $arr->{$_};
	    if (ref $v) {
		$v = [@$v] if ref $v eq 'ARRAY';
		$v = {%$v} if ref $v eq 'HASH';
	    }
	    ($_, $v);
	} keys %$arr
    }, ref $arr;
}

sub _store {
    @_ == 3 or croak "Usage: ARRAY->store(SUBSCRIPTS, VALUE)";
    my ($arr, $subscripts, $value) = @_;
    my @subscripts = _make_subscripts($arr, $subscripts);
    my $bits = $arr->{bits};
    if (ref $value) {
	UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers')
	    or faint(SP_INVARRAY, 'Not a number');
	$value = $bits > 16 ? $value->twospot : $value->spot;
    } else {
	defined $value && $value =~ /^\d+$/
	    or faint(SP_INVARRAY, 'Not a number');
	$value = new Language::INTERCAL::Numbers $bits, $value;
    }
    my $sv = join(' ', @subscripts);
    if (! exists $arr->{value}{$sv}) {
	$arr->{value}{$sv} =
	    new Language::INTERCAL::Numbers $arr->{bits}, $value;
    } else {
	$arr->{value}{$sv}->assign($value);
    }
    $arr;
}

sub _get {
    @_ == 2 or croak "Usage: ARRAY->get(SUBSCRIPTS)";
    my ($arr, $subscripts) = @_;
    my $place = join(' ', _make_subscripts($arr, $subscripts));
    return $arr->{value}{$place}->value if exists $arr->{value}{$place};
    new Language::INTERCAL::Numbers $arr->bits, 0;
}

sub elements {
    @_ == 1 or croak "Usage: ARRAY->elements";
    my ($arr) = @_;
    return 0 unless @{$arr->{subscripts}};
    my $elems = 1;
    $elems *= $_ for @{$arr->{subscripts}};
    $elems;
}

sub subscripts {
    @_ == 1 or croak "Usage: ARRAY->subscripts";
    my ($arr) = @_;
    return () unless @{$arr->{subscripts}};
    @{$arr->{subscripts}};
}

sub range {
    @_ == 3 or croak "Usage: ARRAY->range(START, LEN)";
    my ($arr, $start, $len) = @_;
    my $el = $arr->elements;
    $start > 0 && $start <= $el
	or faint(SP_SUBSCRIPT, 'range start outside array');
    $start--;
    $len >= 0 && $start + $len <= $el
	or faint(SP_SUBSCRIPT, 'range length outside array');
    my @a = _as_list($arr);
    return (ref $arr)->from_list([splice(@a, $start, $len)]);
}

sub as_string {
    @_ == 1 or croak "Usage: ARRAY->as_string";
    my ($arr) = @_;
    pack('C*', map { $_->number & 0xff } $arr->as_list);
}

sub sparse_list {
    @_ == 1 or croak "Usage: ARRAY->sparse_list";
    my ($arr) = @_;
    return () unless @{$arr->{subscripts}};
    _sparse_list($arr);
}

sub _sparse_list {
    my ($arr, @subs) = @_;
    if (@subs >= @{$arr->{subscripts}}) {
	my $s = join(' ', @subs);
	return [$arr->{value}{$s}, @subs] if exists $arr->{value}{$s};
	return ();
    }
    my $max = $arr->{subscripts}[scalar @subs];
    map { _sparse_list($arr, @subs, $_) } (1..$max);
}

sub as_list {
    @_ == 1 or croak "Usage: ARRAY->as_list";
    my ($arr) = @_;
    return () unless @{$arr->{subscripts}};
    _as_list($arr);
}

sub _as_list {
    my ($arr, @subs) = @_;
    if (@subs >= @{$arr->{subscripts}}) {
	my $s = join(' ', @subs);
	return $arr->{value}{$s} if exists $arr->{value}{$s};
	return new Language::INTERCAL::Numbers $arr->bits, 0;
    }
    my $max = $arr->{subscripts}[scalar @subs];
    map { _as_list($arr, @subs, $_) } (1..$max);
}

sub from_list {
    @_ or croak "Usage: from_list Language::INTERCAL::Arrays " .
		"[::TYPE | BITS], VALUES";
    my $class = shift;
    if ($class->isa('Language::INTERCAL::Arrays::Tail')) {
	@_ == 1 or croak "Usage: from_list $class LIST";
    } elsif ($class->isa('Language::INTERCAL::Arrays::Hybrid')) {
	@_ == 1 or croak "Usage: from_list $class LIST";
    } else {
	@_ == 2 or croak "Usage: from_list $class BITS, LIST";
	my $bits = shift;
	$bits > 32 and croak "Invalid number of BITS";
	$class .= $bits > 16 ? '::Hybrid' : '::Tail';
    }
    my ($values) = @_;
    my $arr = $class->new([@$values ? scalar @$values : ()]);
    for (my $i = 1; $i <= @$values; $i++) {
	$arr->store([$i], $values->[$i - 1]);
    }
    $arr;
}

sub _assign {
    @_ == 2 or croak "Usage: ARRAY->assign(VALUE)";
    my ($arr, $value) = @_;
    my @subscripts = _make_subscripts(undef, $value);
    $arr->{subscripts} = \@subscripts;
    $arr->{value} = {};
    $arr;
}

sub print {
    @_ == 1 or croak "Usage: ARRAY->print";
    my ($arr) = @_;
    my $s = $arr->{subscripts};
    return "[]" unless $s && @$s;
    _print($arr, [], @$s);
}

sub _print {
    my ($arr, $sp, @s) = @_;
    if (@s) {
	my $m = shift @s;
	my @v = map { _print($arr, [@$sp, $_], @s) } (1..$m);
	return '[' . join(', ', @v) . ']';
    } else {
	my $s = join(' ', @$sp);
	return $arr->{value}{$s}->print if exists $arr->{value}{$s};
	return '#0';
    }
}

sub replace {
    @_ == 2 or croak "Usage: ARRAY->replace(LIST)";
    my ($arr, $list) = @_;
    faint(SP_NODIM) unless @{$arr->{subscripts}};
    _replace($arr, $list);
    faint(SP_ARRAY, "Too many elements") if @$list;
    $arr;
}

sub _replace {
    my ($arr, $list, @subs) = @_;
    if (@subs >= @{$arr->{subscripts}}) {
	my $s = join(' ', @subs);
	my $num = @$list ? shift @$list : 0;
	if (exists $arr->{value}{$s}) {
	    $arr->{value}{$s}->assign($num);
	} else {
	    $arr->{value}{$s} =
		Language::INTERCAL::Numbers->new($arr->bits, $num);
	}
	return;
    }
    my $max = $arr->{subscripts}[scalar @subs];
    for (my $s = 1; $s <= $max; $s++) {
	_replace($arr, $list, @subs, $s);
    }
}

# some methods in case arrays are used as numbers or class

sub digits { faint(SP_ISARRAY); }
sub filehandle { faint(SP_NOTCLASS); }
sub number { faint(SP_ISARRAY); }
sub spot { faint(SP_ISARRAY) }
sub twospot { faint(SP_ISARRAY) }

package Language::INTERCAL::Arrays::Tail;

use Carp;
use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);

use vars qw(@ISA);
@ISA = qw(Language::INTERCAL::Arrays);

sub tail {
    @_ == 1 or croak "Usage: ARRAY->tail";
    goto &Language::INTERCAL::Arrays::copy;
}

sub hybrid {
    @_ == 1 or croak "Usage: ARRAY->hybrid";
    my ($arr) = @_;
    my $h = new Language::INTERCAL::Arrays::Hybrid $arr->{subscripts};
    for my $k (keys %{$arr->{value}}) {
	my $v = $arr->{value}{$k};
	$h->{value} = $v->twospot;
    }
    $h;
}

package Language::INTERCAL::Arrays::Hybrid;

use Carp;
use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);

use vars qw(@ISA);
@ISA = qw(Language::INTERCAL::Arrays);

sub tail {
    @_ == 1 or croak "Usage: ARRAY->tail";
    my ($arr) = @_;
    my $t = new Language::INTERCAL::Arrays::Tail $arr->{subscripts};
    for my $k (keys %{$arr->{value}}) {
	my $v = $arr->{value}{$k};
	$t->{value} = $v->spot;
    }
    $t;
}

sub hybrid {
    @_ == 1 or croak "Usage: ARRAY->hybrid";
    goto &Language::INTERCAL::Arrays::copy;
}

1;