package Language::INTERCAL::SharkFin;

# Special version of Language::INTERCAL::Arrays used for "Shark Fin"
# registers

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

my %types = (
    vector => [\&_code_vector, \&_decode_vector],
);

sub new {
    @_ == 3 || @_ == 4
	or croak "Usage: Language::INTERCAL::SharkFin->new(TYPE, OBJECT [,VALUE])";
    my ($class, $type, $object, @value) = @_;
    exists $types{$type} or faint(SP_SPECIAL, "(type $type)");
    my $arr;
    if (@value) {
	@value = &{$types{$type}[0]}($object, @value);
	# note, we don't use SUPER here, rather we rebless later
	$arr = Language::INTERCAL::Arrays::Tail->from_list(\@value);
    } else {
	$arr = Language::INTERCAL::Arrays::Tail->new([]);
    }
    $arr->{sharkfin} = {
	object => $object,
	type => $types{$type}[0],
	typename => $type,
	decode => $types{$type}[1],
    };
    bless $arr, $class;
}

sub type {
    @_ == 1 or croak "Usage: SHARKFIN->type";
    my ($arr) = @_;
    $arr->{sharkfin}{typename};
}

sub _assign {
    @_ == 2 or croak "Usage: SHARKFIN->assign(VALUE)";
    my ($arr, $value) = @_;
    exists $arr->{sharkfin} or faint(SP_NOSPECIAL);
    $arr->{sharkfin}{type} or faint(SP_NOSPECIAL);
    my @value = &{$arr->{sharkfin}{type}}($arr->{sharkfin}{object}, $value);
    $arr->SUPER::_assign(@value ? [scalar @value] : []);
    for (my $i = 1; $i <= @value; $i++) {
	$arr->_store([$i], $value[$i - 1]);
    }
    $arr;
}

sub _get_number {
    my ($value) = @_;
    return $value->spot->number
	if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
    return $value
	if ! ref $value && defined $value && $value =~ /^\d+$/;
    faint(SP_INVARRAY, 'Not a number');
}

sub _get_vector {
    my ($value) = @_;
    return $value->spot->number
	if ref $value && UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
    return $value
	if ! ref $value && defined $value && $value =~ /^\d+$/;
    return (unpack('C*', $value), 0)
	if ! ref $value && defined $value;
    return ( map { _get_number($_) } @$value )
	if ref $value eq 'ARRAY';
    faint(SP_INVARRAY, 'Not a number');
}

sub _code_vector {
    my ($object, $value) = @_;
    if (ref $value) {
	return ( map { _get_vector($_) } @$value )
	    if ref $value eq 'ARRAY';
	return ( $value->spot->number )
	    if UNIVERSAL::isa($value, 'Language::INTERCAL::Numbers');
	return ((map { $_->spot->number } $value->tail->as_list))
	    if UNIVERSAL::isa($value, 'Language::INTERCAL::Arrays');
	faint(SP_NOARRAY, "Not an array");
    }
    if (defined $value) {
	return (unpack('C*', $value));
    }
    faint(SP_NOARRAY, "Not an array");
}

sub _decode_vector {
    my ($object, $value) = @_;
    my @list = map { $_->number } $value->as_list;
    pop @list while @list && $list[-1] == 0;
    my $list = pack('C*', @list);
    $list =~ s/([\\'])/\\$1/g;
    $list = "'$list'" if $list =~ /['\s\\]/;
    $list;
}

sub print {
    @_ == 1 or croak "Usage: SHARKFIN->print";
    my ($arr) = @_;
    my $s = $arr->{sharkfin};
    return &{$s->{decode}}($s->{object}, $arr) if $s->{decode};
    $arr->SUPER::print;
}

sub range {
    @_ == 3 or croak "Usage: SHARKFIN->range(START, LEN)";
    my ($arr, $start, $len) = @_;
    # we just rebless it to a Tail and use their range()
    bless $arr, 'Language::INTERCAL::Arrays::Tail';
    $arr->range($start, $len);
}

1;