Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Arrays.pm @ 3553:a2c0fbb7c2b1
<Roujo> revert
author | HackBot |
---|---|
date | Thu, 29 Aug 2013 20:30:48 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
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;