15.4.888  src/lib/src/expanding-rw-vector.pkg

## expanding-rw-vector.pkg

# Compiled by:
#     src/lib/std/standard.lib

# Typeagnostic Rw_Vectors of unbounded length


stipulate
    package rwv =  rw_vector;           # rw_vector             is from   src/lib/std/src/rw-vector.pkg
    package xns =  exceptions;          # exceptions            is from   src/lib/std/exceptions.pkg
herein

    package expanding_rw_vector
    :       Expanding_Rw_Vector         # Expanding_Rw_Vector   is from   src/lib/src/expanding-rw-vector.api
    {
        Rw_Vector(X) =  BLOCK ( (Ref( rwv::Rw_Vector(X) ), X, Ref( Int )) );

        exception INDEX_OUT_OF_BOUNDS =  xns::INDEX_OUT_OF_BOUNDS;
        exception SIZE                =  xns::SIZE;

        fun rw_vector (size, default)
            =
            BLOCK (REF (rwv::make_rw_vector (size, default)), default, REF(-1));


        # from_list (l, v) creates an rw_vector using the list of values l
        # plus the default value v.
        # NOTE: Once Typelocked_Rw_Vector includes arrayoflist, this will become trivial.
        #
        fun from_list (init_list, default)
            =
            {   len =  length  init_list;
                #
                arr =  rwv::make_rw_vector (len, default);

                fun set ([], _)     =>  ();
                    #
                    set (x ! r, i)  =>  {   rwv::set (arr, i, x);
                                            set (r, i+1);
                                        };
                end;

                set (init_list, 0);
                BLOCK (REF arr, default, REF (len - 1));
            };

        # from_fn (size, fill, default) acts like rw_vector::from_fn, plus 
        # stores default value default.  Raises SIZE if size < 0.
        #
        fun from_fn (size, fill_g, default)
            =
            BLOCK (REF (rwv::from_fn (size, fill_g)), default, REF (size - 1));


        fun copy_rw_subvector (BLOCK (arr, default, bnd), lo, hi)
            =
            {   arrval = *arr;
                bnd = *bnd;

                fun copy i
                    =
                    rwv::get (arrval, i+lo);

                if   (hi <= bnd)   BLOCK (REF (rwv::from_fn ( hi-lo, copy)), default, REF ( hi-lo));
                elif (lo <= bnd)   BLOCK (REF (rwv::from_fn (bnd-lo, copy)), default, REF (bnd-lo));
                else               rw_vector (0, default);
                fi;
            };

        fun default (BLOCK(_, default, _))
            =
            default;

        fun get (BLOCK (arr, default, _), idx)
            =
            (rwv::get (*arr, idx)) 
            except
                INDEX_OUT_OF_BOUNDS
                    =
                    if (idx < 0)   raise exception INDEX_OUT_OF_BOUNDS;
                    else           default;
                    fi;

        fun bound (BLOCK(_, _, bnd))
            =
            *bnd;

        fun expand (arr, oldlen, newlen, default)
            =
            rwv::from_fn (newlen, fillfn)
            where
                fun fillfn i
                    =
                    if (i < oldlen)   rwv::get (arr, i);
                    else              default;
                    fi;
            end;

        fun set (BLOCK (arr, default, bnd), idx, v)
            =
            {   len =  rwv::length *arr;
                #
                if (idx >= len)
                    #
                    arr :=  expand (*arr, len, int::max (len+len, idx+1), default); 
                fi;

                rwv::set (*arr, idx, v);

                if(*bnd <  idx)
                    bnd := idx;
                fi;
            };

        fun truncate (a as BLOCK (arr, default, bndref), size)
            =
            {   bnd    =  *bndref;
                newbnd =  size - 1;

                arr_val    =  *arr;
                array_size =  rwv::length  arr_val;

                fun fill_default (i, stop)
                    =
                    if (i != stop)
                        #
                        rwv::set (arr_val, i, default);
                        #
                        fill_default (i - 1, stop);
                    fi;

                if (newbnd < 0)
                    #
                    bndref :=  -1;
                    arr    :=   rwv::make_rw_vector (0, default);
                    #
                elif (newbnd < bnd)
                    #
                    if (3 * size < array_size)
                        #
                        (copy_rw_subvector (a, 0, newbnd))
                            ->
                            BLOCK (arr', _, bnd');

                        bndref :=  *bnd';
                        arr    :=  *arr';
                    else
                        fill_default (bnd, newbnd);
                    fi;

                fi;
            };

    };                                                                  # package expanding_rw_vector   # This was dynamic-array.pkg.
end;