# This is a Perl5 file

# ChangeLog
#
# 2005-10-06
# * Fixed perlification of arrays -- basically it used to be
#     join ",", map { ~$_ }     @elems;  # it's now:
#     join ",", map { $_.perl } @elems;
# * Don't output "..." to create ranges, but "..", so .perl will return valid
#   Perl 6 code for lazy/infinite arrays:
#     (1, 2 ... 42)  # wrong
#     (1, 2 .. 42)   # correct
# * The perlification of an array containing only one element is now ($item,)
#   instead of ($item) (($item) is not an array, but ($item,) is).
#
# 2005-09-12
# * several fixes: @a[1,2].delete; @a.uniq; (-Inf..Inf); (-Inf..0) 
#
# 2005-09-08
# * finite sub-slices work: ($x,@a[1..3])=(1,2,3,4)
#
# 2005-09-05
# * delete slice
#
# 2005-08-31
# * New methods: keys(), values(), pairs(), kv(), pick()
#
# 2005-08-29
# * Lazy lists are deep cloned when Array is cloned
#
# 2005-08-29
# * Full support for lazy splicing and sparse array
# * Added support for store() past the end of the array
# * Simplified fetch()
#
# 2005-08-27
# * Fixed fetch/store single elements from a lazy slice
# * Fixed fetch/store of whole lazy slice
#   supports syntax: @a = (0..Inf); @a[1,10,100..10000] = @a[500..30000]
#   (needs optimization)
# * New method tied()
# * Fixed binding of fetched result
# * Fixed stringification of unboxed values
# * New parameter 'max' in perl() and str() methods - controls how many elements
#   of the lazy array are stringified.
# * Array is stringified using parenthesis.
#
# 2005-08-26
# * New internal class 'Perl6::Slice'
#   supports syntax: @a = (2,3,4,5); @a[1,2] = @a[0,3]
#
# 2005-08-12
# * store(List) actually means store([List])
# * fixed new(), elems(), pop(), shift(), fetch()
# * fixed "defined $i" to "elems == 0" in push/pop
#
# 2005-08-11
# * fixed some syntax errors
#
# 2005-08-10
# * Ported from Perl6 version

# BUGS
# - Infinite sub slices are not supported yet:
#   ($x,@a[1..99])=(1,2,3,4)   - ok - non-finite sub-slice
#   (@a[1..Inf])=(1,2,3,4)     - ok - not a sub-slice
#   ($x,@a[1..Inf])=(1,2,3,4)  - not supported

# RECENTLY FIXED
#   @a[10,100,1000,10000,100000]=(1..9999999) 
#        returned undef (the list went into array element zero)

# TODO - @a[1].delete doesn't work

# TODO - tied arrays should use the standard Perl 5 interface
#        test push, scalar, etc - with @INC

# TODO - PIL-Run - (1,undef,2) returns (1,2) - but (1,\undef,2) works
# TODO - PIL-Run - grep() using 'Code'

# TODO - finish lazy slices
#        @a[1..100000000]=@b[1..20000000]
#        (@a[1..100],@b[1..50])=(@a[1..50],@b[1..100])

# TODO - check specification of Array, Hash, Pair stringification

# TODO - sum()
# TODO - there are too many methods under AUTOLOAD - upgrade them to real methods
#
# TODO - optimize Eager array to O(1)
#      - currently disabled with "if 0 &&" (Perl6::Container::Array)
#
# TODO - ($a,undef,$b) = @a - fixed, add test
#      - (@a[1..10],$a,undef,$b) = @a
#      - ($a,@x[1,2])=(4,5,6)
#
# TODO - @a[1] == Scalar
# TODO - test - @a[1] := $x

# TODO - tied arrays are copied in "Eager" mode?
#        (PerlJam) - well, I wouldn't think you'd have to copy them all at once.
#        Each element of @a would be sort of a lazy proxy for each element in the tied array @b

# TODO - @a[1..2]=(1,2) 
#        &postcircumfix:<[ ]> has to be "is rw"
#        &infix:<,> has to be is rw, too (think ($a, undef, $b) = (1,2,3))

# TODO - store(List) actually means store([List]), Perl6 version
# TODO - fix "defined $i" to "elems == 0" in push/pop, Perl6 version
# TODO - splice() should accept a 'List' object, Perl6 version too
#
# TODO - Tests: - add to t/data_types/lazy_lists.t
# TODO - fetch/store should not destroy binding
# TODO - test splice offset == 0, 1, 2, -1, -2, -Inf, Inf
# TODO - test splice length == 0, 1, 2, Inf, negative
# TODO - test splice list == (), (1), (1,2), Iterators, ...
# TODO - test splice an empty array
# TODO - test multi-dimensional array

# Notes:
# * Cell is implemented in the Perl6::Container::Scalar package

use strict;
use Carp;

use Perl6::MetaModel;
use Perl6::Value;
use Perl6::Container::Scalar;

use constant Inf => Perl6::Value::Num::Inf;

my $class_description = '-0.0.1-cpan:FGLOCK';

# ------ Perl6::Slice -----

sub Perl6::Slice::new { 
    my $class = shift;
    my %param = @_;  
    #warn "NEW SLICE: ".Perl6::Value::stringify($param{array})." -- ".Perl6::Value::stringify($param{slice})."\n";
    bless { %param }, $class;
} 
sub Perl6::Slice::clone { 
    my $self = shift;
    return $self->unbind;
    #my $a = Array->new;
    #$a->push( $self->items );
    #$a = $a->clone;
    #return $a;
} 
sub Perl6::Slice::items {
    my $self = shift;
    #warn "SLICE ITEMS: ".Perl6::Value::stringify($self->{array})." -- ".Perl6::Value::stringify($self->{slice})."\n";
    #$self->{array}->items;
    my @a;
    warn "Infinite sub-slices are not supported yet" 
        if Perl6::Value::numify( $self->is_infinite );
    for ( 0 .. Perl6::Value::numify( $self->elems ) - 1 ) {
        push @a, $self->fetch( $_ );
    }
    # warn "    items: @a\n";
    return @a;
}
sub Perl6::Slice::fetch {
    my $self = shift;
    my $i = shift;
    my $pos = Perl6::Value::numify( $self->{slice}->fetch( $i ) );
    #warn "SLICE FETCH: at ($i) $pos -- @_ -- ".Perl6::Value::stringify($self->{array}->fetch( $pos, @_ ))."\n";
    return unless defined $pos && $pos >= 0;
    $self->{array}->fetch( $pos, @_ );
}
sub Perl6::Slice::store {
    my $self = shift;
    my $i = shift;
    my $pos = Perl6::Value::numify( $self->{slice}->fetch( $i ) );
    #warn "SLICE STORE: at ($i) $pos -- @_"."\n";
    return unless defined $pos && $pos >= 0;
    $self->{array}->store( $pos, @_ );
}
sub Perl6::Slice::is_infinite {
    my $self = shift; 
    $self->{slice}->is_infinite()->unboxed;
}
sub Perl6::Slice::elems {
    my $self = shift; 
    $self->{slice}->elems()->unboxed;
}
sub Perl6::Slice::unbind {
    # creates a new Array - not bound to the original array/slice
    my $self = shift; 
    #warn "SLICE UNBIND: ".Perl6::Value::stringify($self->{array})." -- ".Perl6::Value::stringify($self->{slice})."\n";
    my $ary = $self->{array};
    my @idx = $self->{slice}->items;
    my $result = Array->new;
    my $pos = 0;
    for my $i ( @idx ) {
        # warn "unbind() loop...";
        if ( UNIVERSAL::isa( $i, 'Perl6::Value::List' ) ) {
            die "Not implemented: instantiate lazy slice using a non-contiguous list"
                unless $i->is_contiguous;
            my $start = $i->start;
            my $end =   $i->end;
            die "Slice start/end is not defined"
                unless defined $end && defined $start;
            die "Not implemented: instantiate lazy slice using a reversed list"
                unless $end >= $start;
            #warn "unbind: Index: ". $i->str . "\n";
            # warn "Slicing from $start to $end";
            my $slice = $ary->splice( $start, ( $end - $start + 1 ) );
            my $elems = $slice->elems->unboxed;
            # warn "splice 2 - elems = $elems - slice isa $slice";
            $ary->splice( $start, 0, $slice );
            # warn "splice done";
            # items should be cloned before storing
            my @items = $slice->unboxed->items;
            @items = map {
                        # warn "unbind - elems ". $_->elems . "\n";
                        UNIVERSAL::isa( $_, 'Perl6::Value::List' ) ? $_->clone : $_
                    } @items;
            $result->push( @items );
            if ( $elems < ( $end - $start + 1 ) ) {
                my $diff = $end - $start + 1 - $elems;
                # warn "Missing $diff elements";
                $result->push( Perl6::Value::List->from_x( item => undef, count => $diff ) );
            }
            $pos = $pos + $end - $start + 1;
            # warn "pos = $pos";
        }
        else {
            # non-lazy slicing
            my $tmp = $ary->fetch( $i )->fetch;
            $result->store( $pos, $tmp );
            $pos++;            
        }
    }
    return $result;
}
sub Perl6::Slice::write_thru {
    # writes back to the bound Array using the slice as an index
    my $self = shift; 
    my $other = shift;
    #warn "SLICE WRITE THROUGH: ".Perl6::Value::stringify($self->{array})." -- ".Perl6::Value::stringify($self->{slice})."\n";
    #warn "               FROM: ".Perl6::Value::stringify($other)."\n";
    #warn "SLICE WRITE THROUGH: ".$self->{array}." -- ".$self->{slice}."\n";
    #warn "               FROM: ".$other."\n";
    my $ary = $self->{array};
    my @idx = $self->{slice}->items;
    my $pos = 0;
    for my $i ( @idx ) {
        #warn "write loop... ". Perl6::Value::stringify($i)." -- $i\n";
        if ( UNIVERSAL::isa( $i, 'Perl6::Value::List' ) ) {
            # warn "List -- ". $i->is_contiguous;
            die "Not implemented: instantiate lazy slice using a non-contiguous list"
                unless $i->is_contiguous;
            my $start = $i->start;
            my $end =   $i->end;
            die "Slice start/end is not defined"
                unless defined $end && defined $start;
            die "Not implemented: instantiate lazy slice using a reversed list"
                unless $end >= $start;
            #warn "write_thru: Slicing from position $pos to ( $start .. $end )\n";
            #warn "    Index: ". $i->str . "\n";
            # items should be cloned before storing
            #my $ary_elems = $ary->elems->unboxed;
            #warn "other.elems = ".$other->elems->unboxed."\n";
            my $max_ary_elems = $ary->elems->unboxed - $start;
            #warn "array has $ary_elems elements, starts in $start, max = $max_ary_elems\n";
            my $slice_size = $end - $start + 1;
            $slice_size = $max_ary_elems if $slice_size > $max_ary_elems;
            my $slice = $other->splice( $pos, $slice_size );
            my $elems = $slice->elems->unboxed;
            # warn "splice 3 - elems = $elems - slice isa $slice";
            my @items = $slice->unboxed->items;
            if ( $elems < $slice_size ) {
                my $diff = $slice_size - $elems;
                #warn "Missing $diff elements";
                push @items, Perl6::Value::List->from_x( item => undef, count => $diff )
                    if $diff > 0;
            }
            #warn "  STORE SLICE pos $pos to $start, $slice_size, @items";
            # TODO - XXX - don't use splice on slices, because it drops bindings
            $ary->splice( $start, $slice_size, @items );
            $pos = $pos + $slice_size;
            #warn "pos = $pos";
        }
        else {
            # non-lazy slicing
            my $tmp = $other->fetch( $pos )->fetch;
            $ary->store( $i, $tmp );
            $pos++;            
        }
    }
    return;
}

# ------ end Perl6::Slice -----

class1 'Array'.$class_description => {
    is => [ $::Object ],
    class => {
        attrs => [],
        methods => {}
    },
    instance => {
        attrs => [ [ '$:cell' => { 
                        access => 'rw', 
                        build => sub { 
                            # warn " ---- new @_ ---- ";
                            my $cell = Perl6::Cell->new;
                            my $h = Perl6::Container::Array->new( items => [ @_ ] );
                            $cell->{v} = $h;
                            $cell->{type} = 'Array';
                            return $cell;
                        } } ] ],
        DESTROY => sub {
            # _('$:cell' => undef); # XXX - MM2.0 gc workaround
        },
        methods => { 

            # @a := @b 
            'bind' =>     sub {
                my ( $self, $thing ) = @_;
                die "argument to Array bind() must be a Array"
                    unless $thing->cell->{type} eq 'Array';
                _('$:cell', $thing->cell);
                return $self;
            },
            'cell' =>     sub { _('$:cell') },  # cell() is used by bind() / XXX - just rename $:cell to $.cell
            'id' =>       sub { _('$:cell')->{id} },  

            'tieable' =>  sub { _('$:cell')->{tieable} != 0 },
            'tie' =>      sub { shift; _('$:cell')->tie(@_) },
            'untie' =>    sub { _('$:cell')->untie },
            'tied' =>     sub { _('$:cell')->{tied} },

             # See perl5/Perl6-MetaModel/t/14_AUTOLOAD.t  
            'isa' =>      sub { ::next_METHOD() },
            'does' =>     sub { ::next_METHOD() },
            'ref' =>      sub { $::CLASS }, 
            'unboxed' =>  sub { 
                _('$:cell')->{tied} ? _('$:cell')->{tied} : _('$:cell')->{v}
            },
            'undefine' => sub { (shift)->store( Array->new ) },
            'delete' =>   sub {
                # delete a slice, returns deleted items
                my ( $self, @list ) = @_;
                #warn "Trying to delete() a non-slice" unless $self->tied;

                if ( UNIVERSAL::isa( $self->tied, 'Perl6::Slice' ) ) {
                    # delete from slice
                    my $ret = Array->new();
                    $ret = $self->clone;
                    $self->store( Perl6::Value::List->from_x( item => undef, count => Inf ) );
                    return $ret;
                }

                #warn "DELETE LIST @list";
                $self->slice( @list )->delete( 
                    Perl6::Value::List->from_num_range( start => 0, end => Inf ) 
                );
                
            },
            'slice' =>    sub {
                # Returns an array whose fetch/store are bound to this array
                my ( $self, @list ) = @_;

                my $list = $list[0];
                if ( !Perl6::Value::p6v_isa($list,'Array') ) {
                    $list = Array->new();
                    $list->push( $_ ) for @list;
                }

                # given $list = (4,5,6)
                # given an index $i = 1
                #   get $list[$i] == 5
                #   ignore request if index == undef
                #   store/fetch from array[$list[$i]] == array[5]
                my $ret = Array->new();
                $ret->cell->{tieable} = 1;
                my $proxy = Perl6::Slice->new( 
                    array => $self, 
                    slice => $list,   
                );
                $ret->tie( $proxy );
                return $ret;
            },
            'zip' => sub {
                my ( $array, @array_list ) = map {
                        Perl6::Value::p6v_isa( $_, 'Array' ) ? 
                        $_->to_list : 
                        warn "Argument to zip() must be an Array"; 
                    } @_; 
                my $res = Array->new;
                $res->push( $array->zip( @array_list ) );
                return $res;
            },
            'map' => sub {
                my $array = shift;  $array = $array->clone->to_list;
                my $code = shift;
                die "Argument to map() must be a Code" unless Perl6::Value::p6v_isa( $code, 'Code' );
                my $res = Array->new;
                $res->push( $array->map( $code ) );
                return $res;
            },
            'kv' => sub  { 
                my $array = shift; 
                my $keys = $array->keys;
                my $values = $array->values;
                return $keys->zip( $values );
            },
            'pairs' => sub  { 
                my $array = shift; 
                $array = $array->clone;
                my $shifted = 0;
                my $popped = $array->elems->unboxed - 1;
                my $ret = Array->new();
                # XXX - rewrite this using map()
                $ret->push(
                    # XXX - TODO - optimization - shift_n, pop_n
                    Perl6::Value::List->new(
                        cstart => sub { 
                            return Pair->new( 
                                '$.key' =>   $shifted++, 
                                '$.value' => $array->shift )
                        },
                        cend =>   sub { 
                            return Pair->new( 
                                '$.key' =>   $popped--, 
                                '$.value' => $array->pop )
                        },
                        celems => sub { $array->elems->unboxed },
                        is_lazy => 1,
                    )
                );
                return $ret;
            },
            'values' => sub  { 
                my $array = shift; 
                return $array->clone;
            },
            'keys' => sub  { 
                my $array = shift; 
                my $ret = Array->new();
                $ret->push(
                    Perl6::Value::List->from_num_range( 
                        start => 0, 
                        end =>   $array->elems->unboxed - 1 ) ); 
                return $ret;
            },
            'pick' => sub  { 
                my $array = shift; 
                my $n = $array->elems->unboxed;
                $n = 10E9 if $n == &Inf;
                return $array->fetch( int( rand( $n ) ) );
            },
            'AUTOLOAD' => sub {
                my ($self, @param) = @_;
                my $method = __('$AUTOLOAD');
                my $tmp = $self->unboxed;
                # warn "AUTOLOAD ",ref($tmp), ' ', $method, " @param == " . $tmp->$method( @param );

                @param = 
                    map {
                        # Perl6::Value::p6v_isa( $_, 'Array' ) ? $_->unboxed->items :  
                        Perl6::Value::p6v_isa( $_, 'List' ) ? $_->unboxed :  
                        UNIVERSAL::isa( $_, 'Perl6::Container::Array' ) ? $_->items : 
                        $_ 
                    } @param;
                
                if ( $method eq 'clone' || $method eq 'splice' || $method eq 'reverse' ) {
                    my $ret = Array->new();
                    my @result = $tmp->$method( @param )->items;
                    $ret->unboxed->push( @result );
                    #warn "-- @result "; # . Perl6::Value::stringify($result->shift). " ... ". Perl6::Value::stringify($result->pop);
                    #warn "reversed: ".$ret->str->unboxed;
                    #use Data::Dumper; $Data::Dumper::Indent=1;
                    #print Dumper($ret);
                    return $ret;
                }
                
                if ( $method eq 'push'   || $method eq 'unshift' || $method eq 'store' ) {
                    #warn "STORING THINGS $method @param";
                    if ( $method eq 'store' && @param == 1 ) {
                        # whole Array store
                        #warn "WHOLE ARRAY STORE";
                        # XXX - what if the array is tied?
                        #  @a = (2,3,4,5); @a[1,2] = @a[0,3]
                        my $other = $param[0];
                        # if ( $self->cell->{tied} ||
                        #      $other->cell->{tied} ) 
                        
                        # if ( $other->is_infinite->unboxed ) {
                        #    die "Infinite slices and tied arrays are not yet fully supported";
                        # }

                        if ( Perl6::Value::p6v_isa( $other, 'Array' ) ) {
                            if ( UNIVERSAL::isa( $other->tied, 'Perl6::Slice' ) ) {
                                # unbind the slice from the original arrays
                                $other = $other->tied->unbind;
                            }
                        }
                        else {
                            my $tmp = Array->new();
                            $tmp->push( $other );
                            $other = $tmp;
                        }

                        my @items = $other->unboxed->items;  
                        if ( UNIVERSAL::isa( $self->tied, 'Perl6::Slice' ) ) {
                            #warn "WRITE THROUGH ".Perl6::Value::stringify($other);
                            $self->tied->write_thru( $other );
                            return $other;
                            #return $self;
                        }
                        #warn "got @items - current = ". $self->cell->{v};

                        # unbind cells
                        @items = map {
                                Perl6::Value::p6v_isa($_,'Scalar') ? $_->fetch : $_
                            } @items;

                        my $ret = Perl6::Container::Array->from_list( @items );
                        $self->cell->{v} = $ret;
                        return $self;
                    }

                    if ( $method eq 'store' ) {
                        #warn "STORING @param";
                        my $pos = shift @param;
                        my $elem = $tmp->fetch( $pos );
                        if ( Perl6::Value::p6v_isa( $elem, 'Scalar' ) ) {
                            #warn "CELL TO STORE IS A SCALAR: $elem";
                            $elem->store( @param );
                        }
                        else
                        {
                            #warn "CELL TO STORE IS NOT YET A SCALAR: $elem";
                            my $scalar = Scalar->new();
                            $scalar->store( @param );
                            $tmp->store( $pos, $scalar );
                        }
                        return $self;
                    }

                    #for ( @param ) {
                    #    next if UNIVERSAL::isa( $_, 'Perl6::Value::List' );
                    #    next if Perl6::Value::p6v_isa( $_, 'Scalar' );
                    #    next if Perl6::Value::p6v_isa( $_, 'Array' );
                    #    next if Perl6::Value::p6v_isa( $_, 'Hash' );
                    #    my $tmp = $_;
                    #    $_ = Scalar->new();
                    #    $_->store( $tmp );
                    #    warn " SCALAR ",$_->str->unboxed;
                    #};
                    #warn "Array.$method PARAM @param\n";
                    $tmp->$method( @param );
                    return $self;
                }

                if ( $method eq 'fetch' ) {
                    # warn "FETCHING THINGS @param";
                    if ( @param == 0 ) {
                        # whole Array fetch
                        return $self;
                    }
                    my $elem = $tmp->$method( @param );
                    my $scalar;
                    if ( Perl6::Value::p6v_isa( $elem, 'Scalar' ) ) {
                        #warn "FETCHED CELL IS A SCALAR: $elem";
                        $scalar = $elem;
                    }
                    else
                    {
                        #warn "FETCHED CELL IS NOT YET A SCALAR: $elem [ @param ]";
                        $scalar = Scalar->new();
                        $scalar->store( $elem );
                        # replace Value with Scalar
                        #warn "STORE = @param, $scalar";
                        # XXX - TODO - test with multi-dim fetch
                        $self->store( @param, $scalar );
                        $scalar = $tmp->$method( @param );
                    }
                    return $scalar;
                    #my $ret = Scalar->new();
                    #$ret->bind( $scalar );
                    #return $ret;
                }

                if ( $method eq 'pop'   || $method eq 'shift' ) {
                    my $elem = $tmp->$method( @param );
                    unless ( Perl6::Value::p6v_isa( $elem, 'Scalar' ) ) {
                        # XXX - I think only fetch() need to return Scalar 
                        my $scalar = Scalar->new();
                        $scalar->store( $elem );
                        return $scalar;
                    }
                    return $elem;
                }

                if ( $method eq 'elems' || $method eq 'int' || $method eq 'num' ) {
                    return Int->new( '$.unboxed' => $tmp->elems( @param ) )
                }
                if ( $method eq 'exists' ) {
                    # XXX - TODO - recursive to other dimensions
                    return Bit->new( '$.unboxed' => ($tmp->elems > Perl6::Value::numify($param[0]) ) )
                }
                if ( $method eq 'is_infinite' ) {
                    return Bit->new( '$.unboxed' => $tmp->$method( @param ) )
                }
                
                return $tmp->$method( @param );
            },
            
            str => sub {
                #warn "PRINT @_\n";
                my $self = shift;
                my %param = @_;
                my $samples = $param{'max'};
                # my $self = $array->unboxed; # _('$:cell')->{tied} ? _('$:cell')->{tied} : _('$:cell')->{v};
                # warn "ELEMS ",$self->elems;
                $samples-- if defined $samples;
                $samples = 100 unless defined $samples || $self->is_infinite; 
                $samples = 2   unless defined $samples;
                my @start;
                my @end;
                my $tmp;
                for ( 0 .. $samples ) {
                    no warnings 'numeric';
                    last if $_ >= Perl6::Value::numify( $self->elems );
                    $tmp = $self->fetch( $_ );
                    $tmp = Perl6::Value::stringify( $tmp );
                    push @start, $tmp;
                    last if $tmp eq 'Inf' || $tmp eq '-Inf';
                }
                for ( map { - $_ - 1 } 0 .. $samples ) {
                    no warnings 'numeric';
                    # warn "  UNSHIFT: ".$self->elems->unboxed." ".Perl6::Value::numify( $self->elems )." + $_ >= scalar ".(scalar @start)."\n";
                    last unless Perl6::Value::numify( $self->elems ) + $_ >= scalar @start;
                    $tmp = $self->fetch( $_ );
                    $tmp = Perl6::Value::stringify( $tmp );
                    unshift @end, $tmp;
                    last if $tmp eq 'Inf' || $tmp eq '-Inf';
                }
                my $str = '';
                if ( @start > 0 ) {
                    if ( Perl6::Value::numify( $self->elems ) == ( scalar @start + scalar @end ) ) {
                        $str =  join( ' ', map { Perl6::Value::stringify($_) } @start, @end );
                    }
                    else {
                        $str =  join( ' ', map { Perl6::Value::stringify($_) } @start ) .
                                ' .. ' . 
                                join( ' ', map { Perl6::Value::stringify($_) } @end );
                    }
                }
                return Str->new( '$.unboxed' => $str );                
            },
            perl => sub {
                #warn "PRINT @_\n";
                my $self = shift;
                my %param = @_;
                my $samples = $param{'max'};
                # my $self = $array->unboxed; # _('$:cell')->{tied} ? _('$:cell')->{tied} : _('$:cell')->{v};
                # warn "ELEMS ",$self->elems;
                $samples-- if defined $samples;
                $samples = 100 unless defined $samples || $self->is_infinite; 
                $samples = 2   unless defined $samples;
                my @start;
                my @end;
                my $tmp;
                for ( 0 .. $samples ) {
                    no warnings 'numeric';
                    last if $_ >= Perl6::Value::numify( $self->elems );
                    $tmp = $self->fetch( $_ );
                    $tmp = Perl6::Value::stringify( $tmp->perl );
                    push @start, $tmp;
                    last if $tmp eq 'Inf' || $tmp eq '-Inf';
                }
                for ( map { - $_ - 1 } 0 .. $samples ) {
                    no warnings 'numeric';
                    # warn "  UNSHIFT: ".$self->elems->unboxed." ".Perl6::Value::numify( $self->elems )." + $_ >= scalar ".(scalar @start)."\n";
                    last unless Perl6::Value::numify( $self->elems ) + $_ >= scalar @start;
                    $tmp = $self->fetch( $_ );
                    $tmp = Perl6::Value::stringify( $tmp->perl );
                    unshift @end, $tmp;
                    last if $tmp eq 'Inf' || $tmp eq '-Inf';
                }
                my $str = '';
                if ( @start > 0 ) {
                    if ( Perl6::Value::numify( $self->elems ) == ( scalar @start + scalar @end ) ) {
                        $str =  join( ', ', @start, @end );
                    }
                    else {
                        $str =  join( ', ', @start ) .
                                ' .. ' . 
                                join( ', ', @end );
                    }
                }
                # Ensure that ($only_one_item,).perl gets perlificated
                # correctly (i.e. not ($item), but ($item,)).
                $str .= "," if Perl6::Value::numify( $self->elems ) == 1;
                return Str->new( '$.unboxed' => '(' . $str . ')' );                
            },
        },
    }
};

# ----- unboxed functions

package Perl6::Container::Array;

use strict;
use Perl6::Value;
use Perl6::Value::List;
use Carp;

use constant Inf => Perl6::Value::Num::Inf;

sub new {
    my $class = shift;
    my %param = @_;
    my @items = @{$param{items}};
    # warn "-- new -- @items --";
    return bless { items => \@items }, $class;
}

sub clone { 
    # XXX - TODO - clone Scalars
    my $self = bless { %{ $_[0] } }, ref $_[0];
    @{$self->{items}} = map {
            UNIVERSAL::isa( $_, 'Perl6::Value::List' ) ? $_->clone : $_
        } @{$self->{items}};
    return $self;
}

sub sum { 
    my $self = shift;
    my $sum = 0;
    for ( @{$self->{items}} ) {
        if ( UNIVERSAL::isa( $_, 'Perl6::Value::List' ) ) {
            $sum += $_->sum
        }
        elsif ( ref( $_ ) ) {
            $sum += $_->num->unboxed
        }
        else {
            $sum += $_
        }
    }
    return $sum;
}

sub items {
    my $self = shift;
    # my @x = %$self;  warn "-- items -- @x --";
    return @{$self->{items}};
}

sub from_list {
    my $class = shift;
    $class->new( items => [@_] );
}

sub _shift_n { 
    my $array = shift;
    my $length = shift;
    my @ret;
    my @tmp = @{$array->{items}};
    if ( $length == Inf ) {
        my $len = $array->elems;
        @{$array->{items}} = ();
        return ( $len, @tmp );
    }
    my $ret_length = 0;
    while ( @tmp ) {
        # warn "ret $ret_length == ".scalar(@ret)." length $length";
        last if $ret_length >= $length;
        if ( 0 && UNIVERSAL::isa( $tmp[0], 'ARRAY') ) {
            if ( @{$tmp[0]} ) {
                my $diff = $length - $ret_length;
                my @i = splice( @{$tmp[0]}, 0, $diff );
                push @ret, \@i;
                $ret_length += @i;
                last if $ret_length >= $length;
            }
            else {
                shift @tmp;
            }
            next;
        }
        if ( UNIVERSAL::isa( $tmp[0], 'Perl6::Value::List') ) {
            if ( $tmp[0]->elems > 0 ) {
                # my $i = $tmp[0]->shift;
                my $li = $tmp[0];
                my $diff = $length - $ret_length;
                my $i = $li->shift_n( $diff );
                push @ret, $i;
                if ( UNIVERSAL::isa( $i, 'Perl6::Value::List') ) {
                    $ret_length += $i->elems;
                }
                else {
                    $ret_length++;
                }
                # warn "push list ". $i->start . ".." . $i->end . " now length=$ret_length";
                last if $ret_length >= $length;
            }
            else {
                shift @tmp;
            }
            next;
        }
        push @ret, shift @tmp;
        $ret_length++;
    };
    @{$array->{items}} = @tmp;
    # warn "ret @ret ; array @tmp ";
    return ( $ret_length, @ret );
}

sub _pop_n {
    my $array = shift;
    my $length = shift;
    my @ret;
    my @tmp = @{$array->{items}};
    if ( $length == Inf ) {
        my $len = $array->elems;
        @{$array->{items}} = ();
        return ( $len, @tmp );
    }
    my $ret_length = 0;
    while ( @tmp ) {
        # warn "ret ".scalar(@ret)." length $length";
        last if $ret_length >= $length;
        if ( 0 && UNIVERSAL::isa( $tmp[0], 'ARRAY') ) {
            if ( @{$tmp[0]} ) {
                my $diff = $length - $ret_length;
                my @i = splice( @{$tmp[0]}, -$diff, $diff );
                push @ret, \@i;
                $ret_length += @i;
                last if $ret_length >= $length;
            }
            else {
                shift @tmp;
            }
            next;
        }
        if ( UNIVERSAL::isa( $tmp[-1], 'Perl6::Value::List') ) {
            if ( $tmp[-1]->elems > 0 ) {
                # my $i = $tmp[-1]->pop;
                # unshift @ret, $i;
                my $li = $tmp[-1];
                my $diff = $length - $ret_length;
                my $i = $li->pop_n( $diff );
                unshift @ret, $i;
                if ( UNIVERSAL::isa( $i, 'Perl6::Value::List') ) {
                    $ret_length += $i->elems;
                }
                else {
                    $ret_length++;
                }
                # warn "pop list ". $i->start . ".." . $i->end . " now length=$ret_length";
                last if $ret_length >= $length;
            }
            else {
                pop @tmp;
            }
            next;
        }
        unshift @ret, pop @tmp;
        $ret_length++;
    };
    @{$array->{items}} = @tmp;
    # warn "ret @ret ; array @tmp ";
    return ( $ret_length, @ret );
}

sub elems {
    my $array = shift;
    my $count = 0;
    for ( @{$array->{items}} ) {
        $count += UNIVERSAL::isa( $_, 'ARRAY') ? 0 + @$_ :
                  UNIVERSAL::isa( $_, 'Perl6::Value::List') ? $_->elems  :
                  1;
    }
    $count;
}

sub is_infinite {
    my $array = shift;
    for ( @{$array->{items}} ) {
        return 1 if UNIVERSAL::isa( $_, 'Perl6::Value::List') && $_->is_infinite;
    }
    0;
}

sub is_lazy {
    my $array = shift;
    for ( @{$array->{items}} ) {
        return 1 if UNIVERSAL::isa( $_, 'Perl6::Value::List') && $_->is_lazy;
    }
    0;
}

sub flatten {
    # this needs optimization
    my $array = shift;
    my $ret = $array->clone;
    for ( @{$ret->{items}} ) {
        $_ = $_->flatten() if UNIVERSAL::isa( $_, 'Perl6::Value::List') && $_->is_lazy;
    }
    $ret;
}

sub splice { 
    my $array =  shift;
    my $offset = shift; $offset = Perl6::Value::numify( $offset ); $offset = 0   unless defined $offset;
    my $length = shift; $length = Perl6::Value::numify( $length ); $length = Inf unless defined $length;
    my @list = @_;
    my $class = ref($array);
    my ( @head, @body, @tail );
    my ( $len_head, $len_body, $len_tail );
    # print "items: ", $array->items, " splice: $offset, $length, ", @list, "\n";
    # print 'insert: ', $_, ' ', $_->ref for @list, "\n";
    # print " offset $offset length $length \n";
    if ( $offset >= 0 ) {
        ( $len_head, @head ) = $array->_shift_n( $offset );
        if ( $length >= 0 ) {
            #  head=shift offset -> body=shift length -> tail=remaining
            ( $len_body, @body ) = $array->_shift_n( $length );
            ( $len_tail, @tail ) = $array->_shift_n( Inf );
        }
        else {
            #  tail=pop length -> head=shift offset -> body=remaining 
            ( $len_tail, @tail ) = $array->_pop_n( -$length );
            ( $len_body, @body ) = $array->_shift_n( Inf );
        }
    }
    else {
        ( $len_tail, @tail ) = $array->_pop_n( -$offset );
        ( $len_head, @head ) = $array->_shift_n( Inf );
        if ( $length >= 0 ) {
            # negative offset, positive length
            #  tail=pop length -> head=remaining -> body=shift tail until body == length
            # make $#body = $length
            my $tail = $class->from_list( @tail );
            ( $len_body, @body ) = $tail->_shift_n( $length );
            @tail = $tail->items;
        }
        else {
            # negative offset, negative length
            #  tail=pop length -> head=remaining -> body=shift tail until tail == length
            # make $#tail = -$length
            my $body = $class->from_list( @tail );
            ( $len_tail, @tail ) = $body->_pop_n( -$length );
            @body = $body->items;
        }
    };
    # print "off: $offset len: $length head: @head body: @body tail: @tail list: @list\n";
    @{$array->{items}} = ( @head, @list, @tail );
    return $class->from_list( @body );
}

sub end  {
    my $array = shift;
    return unless $array->elems;
    my $x = $array->pop;
    $array->push( $x );
    return $x;
}

sub fetch {
    # XXX - this is inefficient because it needs 2 splices
    # see also: splice()
    my $array = shift;
    my $pos =   shift; $pos = Perl6::Value::numify( $pos );
    
    #use Data::Dumper;
    #warn "-- array -- ". Dumper( $array );
    #warn "uninitialized value used in numeric context"
    #    unless defined $pos;  
    return if $pos >= $array->elems;

    my $ret = $array->splice( $pos, 1 );
    ($ret) = @{$ret->{items}};
    $ret = $ret->shift if UNIVERSAL::isa( $ret, 'Perl6::Value::List' );
    if ( $pos < 0 ) {
        if ( $pos == -1 ) {
            $array->push( $ret );
        }
        else {
            $array->splice( $pos+1, 0, $ret );
        }
    }
    else {
        $array->splice( $pos, 0, $ret );
    }
    # warn "FETCH $pos returns $ret";
    return $ret;
}

sub store {
    my $array = shift;
    my $pos =   shift; $pos = Perl6::Value::numify( $pos );
    my $item  = shift;
    # warn "uninitialized value used in numeric context"
    #    unless defined $pos;  
    if ( UNIVERSAL::isa( $item, 'Perl6::Value::List') ) {
        my $class = ref($array);
        $item = $class->new( items => [$item] );
    }
    if ( $pos <= $array->elems ) {
        # 'Array' takes care of proper cell re-binding 
        my $scalar = $array->fetch( $pos );
        if ( Perl6::Value::p6v_isa( $scalar, 'Scalar' ) ) {
            # warn "Store to scalar\n";
            $scalar->store( $item );
        }
        else {
            $array->splice( $pos, 1, $item );
        }
        return $array;
    }
    # store after the end 
    my $fill = Perl6::Value::List->from_x( item => undef, count => ( $pos - $array->elems ) );
    push @{$array->{items}}, $fill, $item;
    return $array;
}

sub reverse {
    my $array = shift;
    my @rev = reverse @{$array->{items}};
    @rev = map {
            UNIVERSAL::isa( $_, 'ARRAY' ) ? [ reverse( @$_ ) ] : 
            UNIVERSAL::isa( $_, 'Perl6::Value::List' ) ? $_->reverse : 
            $_
        } @rev;
    return Perl6::Container::Array->from_list( @rev );
}

sub to_list {
    my $array = shift;
    my $ret = $array->clone;
    # XXX - TODO - optimization - return the internal list object, if there is one
    # XXX - TODO - optimization - add shift_n, pop_n closures
    return Perl6::Value::List->new(
            cstart => sub { $ret->shift },
            cend =>   sub { $ret->pop },
            celems => sub { $ret->elems },
            is_lazy => $ret->is_lazy,
        )
}

sub unshift {
    my $array = shift;
    unshift @{$array->{items}}, @_;
    return $array;
}

sub push {
    my $array = shift;
    push @{$array->{items}}, @_;
    return $array;
}

sub pop {
    my $array = shift;
    my ( $length, $ret ) = $array->_pop_n( 1 );
    # warn "POP $length -- ". $ret->elems if UNIVERSAL::isa( $ret, 'Perl6::Value::List' );
    $ret = $ret->shift if UNIVERSAL::isa( $ret, 'Perl6::Value::List' );
    return $ret;
}

sub shift {
    my $array = shift;
    my ( $length, $ret ) = $array->_shift_n( 1 );
    # warn "SHIFT $length -- ". $ret->elems if UNIVERSAL::isa( $ret, 'Perl6::Value::List' );
    $ret = $ret->shift if UNIVERSAL::isa( $ret, 'Perl6::Value::List' );
    return $ret;
}

package Perl6::Container::Array::Native;

sub new {
    my $class = shift;
    # arrayref => \@INC;
    bless { @_ }, $class;
}

sub store {
    my ( $this, $key, $value ) = @_;
    my $s = Perl6::Value::numify( $key );
    $this->{arrayref}[$s] = $value->unboxed;
    return $value;
}
sub fetch {
    my ( $this, $key ) = @_;
    my $s = Perl6::Value::numify( $key );
    $this->{arrayref}[$s]
}
sub push {
    my ( $this, $value ) = @_;
    push @{$this->{arrayref}}, $value->unboxed;
    return $value;
}
sub unshift {
    my ( $this, $value ) = @_;
    unshift @{$this->{arrayref}}, $value->unboxed;
    return $value;
}
sub pop {
    my ( $this ) = @_;
    return pop @{$this->{arrayref}};
}
sub shift {
    my ( $this ) = @_;
    return shift @{$this->{arrayref}};
}
sub delete {
    my ( $this, $key ) = @_;
    my $s = Perl6::Value::numify( $key );
    my $r = delete $this->{arrayref}[$s];
}
sub clear {
    my ( $this ) = @_;
    @{$this->{arrayref}} = ();
}
sub elems {
    my ( $this ) = @_;
    scalar @{$this->{arrayref}};
}
sub items {
    my ( $this ) = @_;
    @{$this->{arrayref}};
}

1;
__END__

=head1 NAME

Perl6::Container::Array - Perl extension for Perl6 "Array" class

=head1 SYNOPSIS

  use Perl6::Container::Array;

  ...

=head1 DESCRIPTION

...


=head1 SEE ALSO

Pugs

=head1 AUTHOR

Flavio S. Glock, E<lt>fglock@gmail.com<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2005 by Flavio S. Glock

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
at your option, any later version of Perl 5 you may have available.


=cut