Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/SharkFin.pm @ 12267:7e5beba54694 draft
<b_jonas> slashlearn aoc//Advent of Code (AoC) is a series of programming puzzles that some regulars enjoy, found at "https://adventofcode.com/2019/about".
author | HackEso <hackeso@esolangs.org> |
---|---|
date | Mon, 16 Dec 2019 22:53:41 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
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;