--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interps/clc-intercal/inst/lib/perl5/Language/INTERCAL/Arrays.pm	Sun Dec 09 19:30:08 2012 +0000
@@ -0,0 +1,306 @@
+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;