------------------------------------------------------------------------------
-- BUSH Arrays Package Parser                                               --
--                                                                          --
-- Part of BUSH                                                             --
------------------------------------------------------------------------------
--                                                                          --
--              Copyright (C) 2001-2005 Ken O. Burtch & FSF                 --
--                                                                          --
-- This is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  This is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with this;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- This is maintained at http://www.pegasoft.ca                             --
--                                                                          --
------------------------------------------------------------------------------

with gnat.bubble_sort_a,
     gnat.heap_sort_a,
     ada.numerics.float_random,
     bush_os,
     string_util,
     world,
     scanner_arrays,
     parser,
     parser_aux;
use  bush_os,
     string_util,
     world,
     scanner_arrays,
     parser,
     parser_aux;

package body parser_arrays is


---------------------------------------------------------
-- PARSE THE FILES PACKAGE
---------------------------------------------------------

procedure ParseArraysFirst( f : out unbounded_string; kind : out identifier ) is
  -- Syntax: arrays.first( arraytypeorvar );
  -- Source: arraytypeorvar'first
  var_id   : identifier;
  array_id : arrayID;
begin
  expect( arrays_first_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     array_id := arrayID( to_numeric( identifiers( var_id ).value ) );
     kind := indexType( array_id );
     f := to_unbounded_string( long_integer'image( firstBound( array_id ) ) );
  end if;
end ParseArraysFirst;

procedure ParseArraysLast( f : out unbounded_string; kind : out identifier ) is
  -- Syntax: arrays.last( arraytypeorvar );
  -- Source: arraytypeorvar'last
  var_id   : identifier;
  array_id : arrayID;
begin
  expect( arrays_last_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     array_id := arrayID( to_numeric( identifiers( var_id ).value ) );
     kind := indexType( array_id );
     f := to_unbounded_string( long_integer'image( lastBound( array_id ) ) );
  end if;
end ParseArraysLast;

procedure ParseArraysLength( f : out unbounded_string ) is
  -- Syntax: arrays.length( arraytypeorvar );
  -- Source: arraytypeorvar'length
  var_id   : identifier;
  array_id : arrayID;
begin
  expect( arrays_length_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     array_id := arrayID( to_numeric( identifiers( var_id ).value ) );
     f := to_unbounded_string( long_integer'image( lastBound( array_id ) - firstBound( array_id ) + 1 ) );
  end if;
end ParseArraysLength;

-------------------------------------------------------------------------------
-- Array Sorts 
-------------------------------------------------------------------------------

-- Stuff for Sorting with GNAT packages
-- I'm concerned that GNAT uses integers for indexes in sorts...may not
-- work with long_integer arrays on some platforms...assuming peole would
-- have such friggin' huge arrays in the first place.

arrayIdBeingSorted     : arrayID;
offsetArrayBeingSorted : long_integer;
ZeroElement            : unbounded_string;

procedure moveElement( From, To : natural ) is
  data : unbounded_string;
begin
  if From = 0 then
     data := ZeroElement;
  else
     data := arrayElement( arrayIdBeingSorted, long_integer(From)+offsetArrayBeingSorted);
  end if;
  if To = 0 then
     ZeroElement := data;
  else
     assignElement( arrayIdBeingSorted, long_integer(To)+offsetArrayBeingSorted, data );
   end if;
end moveElement;

function Lt_string( Op1, Op2 : natural ) return boolean is
  data1, data2 : unbounded_string;
begin
  if Op1 = 0 then
     data1 := ZeroElement;
  else
     data1 := arrayElement( arrayIdBeingSorted, long_integer( Op1 )+offsetArrayBeingSorted);
  end if;
  if Op2 = 0 then
     data2 := ZeroElement;
  else
     data2 := arrayElement( arrayIdBeingSorted, long_integer( Op2 )+offsetArrayBeingSorted);
  end if;
  return data1 < data2;
end Lt_string;

function Lt_string_descending( Op1, Op2 : natural ) return boolean is
  data1, data2 : unbounded_string;
begin
  if Op1 = 0 then
     data1 := ZeroElement;
  else
     data1 := arrayElement( arrayIdBeingSorted, long_integer( Op1 )+offsetArrayBeingSorted);
  end if;
  if Op2 = 0 then
     data2 := ZeroElement;
  else
     data2 := arrayElement( arrayIdBeingSorted, long_integer( Op2 )+offsetArrayBeingSorted);
  end if;
  return data1 > data2;
end Lt_string_descending;

function Lt_numeric( Op1, Op2 : natural ) return boolean is
  data1, data2 : unbounded_string;
begin
  if Op1 = 0 then
     data1 := ZeroElement;
  else
     data1 := arrayElement( arrayIdBeingSorted, long_integer( Op1 )+offsetArrayBeingSorted);
  end if;
  if Op2 = 0 then
     data2 := ZeroElement;
  else
     data2 := arrayElement( arrayIdBeingSorted, long_integer( Op2 )+offsetArrayBeingSorted);
  end if;
  return to_numeric( data1 ) < to_numeric( data2 );
end Lt_numeric;

function Lt_numeric_descending( Op1, Op2 : natural ) return boolean is
  data1, data2 : unbounded_string;
begin
  if Op1 = 0 then
     data1 := ZeroElement;
  else
     data1 := arrayElement( arrayIdBeingSorted, long_integer( Op1 )+offsetArrayBeingSorted);
  end if;
  if Op2 = 0 then
     data2 := ZeroElement;
  else
     data2 := arrayElement( arrayIdBeingSorted, long_integer( Op2 )+offsetArrayBeingSorted);
  end if;
  return to_numeric( data1 ) > to_numeric( data2 );
end Lt_numeric_descending;

procedure ParseArraysBubbleSort is
  var_id : identifier;
  first, last : long_integer;
  kind   : identifier;
begin
  expect( arrays_bubble_sort_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     arrayIdBeingSorted := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( arrayIdBeingSorted );
     last  := lastBound( arrayIdBeingSorted );
     offsetArrayBeingSorted := first-1;
     kind := getUniType( identifiers( var_id ).kind );
     if kind = uni_string_t or kind = universal_t then
        GNAT.Bubble_Sort_A.Sort( natural( last - first ) + 1, moveElement'access, lt_string'access );
     elsif kind = uni_numeric_t or kind = root_enumerated_t then
        GNAT.Bubble_Sort_A.Sort( natural( last - first ) + 1, moveElement'access, lt_numeric'access );
     else
        err( "unable to sort this element type" );
     end if;
  end if;
end ParseArraysBubbleSort;

procedure ParseArraysBubbleSortDescending is
  var_id : identifier;
  first, last : long_integer;
  kind   : identifier;
begin
  expect( arrays_bubble_sort_descending_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     arrayIdBeingSorted := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( arrayIdBeingSorted );
     last  := lastBound( arrayIdBeingSorted );
     offsetArrayBeingSorted := first-1;
     kind := getUniType( identifiers( var_id ).kind );
     if kind = uni_string_t or kind = universal_t then
        GNAT.Bubble_Sort_A.Sort( natural( last - first ) + 1, moveElement'access, lt_string_descending'access );
     elsif kind = uni_numeric_t or kind = root_enumerated_t then
        GNAT.Bubble_Sort_A.Sort( natural( last - first ) + 1, moveElement'access, lt_numeric_descending'access );
     else
        err( "unable to sort this element type" );
     end if;
  end if;
end ParseArraysBubbleSortDescending;

procedure ParseArraysHeapSort is
  var_id : identifier;
  first, last : long_integer;
  kind   : identifier;
begin
  expect( arrays_heap_sort_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     arrayIdBeingSorted := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( arrayIdBeingSorted );
     last  := lastBound( arrayIdBeingSorted );
     offsetArrayBeingSorted := first-1;
     kind := getUniType( identifiers( var_id ).kind );
     if kind = uni_string_t or kind = universal_t then
        GNAT.Heap_Sort_A.Sort( natural( last - first ) + 1, moveElement'access, lt_string'access );
     elsif kind = uni_numeric_t or kind = root_enumerated_t then
        GNAT.Heap_Sort_A.Sort( natural( last - first ) + 1, moveElement'access, lt_numeric'access );
     else
        err( "unable to sort this element type" );
     end if;
  end if;
end ParseArraysHeapSort;

procedure ParseArraysHeapSortDescending is
  var_id : identifier;
  first, last : long_integer;
  kind   : identifier;
begin
  expect( arrays_heap_sort_descending_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     arrayIdBeingSorted := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( arrayIdBeingSorted );
     last  := lastBound( arrayIdBeingSorted );
     offsetArrayBeingSorted := first-1;
     kind := getUniType( identifiers( var_id ).kind );
     if kind = uni_string_t or kind = universal_t then
        GNAT.Heap_Sort_A.Sort( natural( last - first ) + 1, moveElement'access, lt_string_descending'access );
     elsif kind = uni_numeric_t or kind = root_enumerated_t then
        GNAT.Heap_Sort_A.Sort( natural( last - first ) + 1, moveElement'access, lt_numeric_descending'access );
     else
        err( "unable to sort this element type" );
     end if;
  end if;
end ParseArraysHeapSortDescending;

procedure ParseArraysShuffle is
  var_id : identifier;
  first, last : long_integer;
  newpos : natural;
  len    : long_integer;
  array_id : arrayID;
begin
  expect( arrays_shuffle_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     array_id := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( array_id );
     last  := lastBound( array_id );
     len   := last-first+1;
     for i in 1..len loop
       newpos := natural( 1.0 + long_float'truncation( long_float( len ) *
             long_float( Ada.Numerics.Float_Random.Random( random_generator
) ) ) );

         moveElement( integer(i), 0 );
         moveElement( integer(newpos), integer(i) );
         moveElement( 0, integer(newpos) );
     end loop;
  end if;
end ParseArraysShuffle;

procedure ParseArraysReverse is
  var_id : identifier;
  first, last : long_integer;
  newpos : natural;
  len    : long_integer;
  array_id : arrayID;
begin
  expect( arrays_reverse_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     array_id := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( array_id );
     last  := lastBound( array_id );
     len   := last-first+1;
     for i in 1..len loop
         newpos := natural( len - i );
         moveElement( integer(i), 0 );
         moveElement( integer(newpos), integer(i) );
         moveElement( 0, integer(newpos) );
     end loop;
  end if;
end ParseArraysReverse;

procedure ParseArraysShiftRight is
  var_id : identifier;
  first, last : long_integer;
  len    : long_integer;
begin
  expect( arrays_shift_right_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     arrayIdBeingSorted := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( arrayIdBeingSorted );
     last  := lastBound( arrayIdBeingSorted );
     len   := last-first+1;
     offsetArrayBeingSorted := first-1;
     for i in reverse 1..len-1 loop
         moveElement( integer(i), integer(i+1) );
     end loop;
  end if;
end ParseArraysShiftRight;

procedure ParseArraysShiftLeft is
  var_id : identifier;
  first, last : long_integer;
  len    : long_integer;
begin
  expect( arrays_shift_left_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     arrayIdBeingSorted := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( arrayIdBeingSorted );
     last  := lastBound( arrayIdBeingSorted );
     len   := last-first+1;
     offsetArrayBeingSorted := first-1;
     for i in 1..len-1 loop
         moveElement( integer(i+1), integer(i) );
     end loop;
  end if;
end ParseArraysShiftLeft;

procedure ParseArraysRotateRight is
  var_id : identifier;
  first, last : long_integer;
  len    : long_integer;
begin
  expect( arrays_rotate_right_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     arrayIdBeingSorted := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( arrayIdBeingSorted );
     last  := lastBound( arrayIdBeingSorted );
     len   := last-first+1;
     offsetArrayBeingSorted := first-1;
     moveElement( integer( len ), 0 );
     for i in reverse 1..len-1 loop
         moveElement( integer(i), integer(i+1) );
     end loop;
     moveElement( 0, 1 );
  end if;
end ParseArraysRotateRight;

procedure ParseArraysRotateLeft is
  var_id : identifier;
  first, last : long_integer;
  len    : long_integer;
begin
  expect( arrays_rotate_left_t );
  expect( symbol_t, "(" );
  ParseIdentifier( var_id );
  if identifiers( var_id ).class = typeClass or identifiers( var_id ).class = subClass then
     var_id := getBaseType( var_id );
     if not identifiers( var_id ).list then
        err( "Array or array type expected" );
     end if;
  elsif not (class_ok( var_id, otherClass ) and identifiers( var_id ).list) then
     err( "Array or array type expected" );
  end if;
  expect( symbol_t, ")" );
  if isExecutingCommand then
     arrayIdBeingSorted := arrayID( to_numeric( identifiers( var_id ).value ) );
     first := firstBound( arrayIdBeingSorted );
     last  := lastBound( arrayIdBeingSorted );
     len   := last-first+1;
     offsetArrayBeingSorted := first-1;
     moveElement( 1, 0 );
     for i in 1..len-1 loop
         moveElement( integer(i+1), integer(i) );
     end loop;
     moveElement( 0, integer( len ) );
  end if;
end ParseArraysRotateLeft;

-------------------------------------------------------------------------------
-- Housekeeping
-------------------------------------------------------------------------------

procedure StartupArrays is
begin
  declareFunction( arrays_first_t, "arrays.first" );
  declareFunction( arrays_last_t, "arrays.last" );
  declareFunction( arrays_length_t, "arrays.length" );
  declareProcedure( arrays_bubble_sort_t, "arrays.bubble_sort" );
  declareProcedure( arrays_bubble_sort_descending_t, "arrays.bubble_sort_descending" );
  declareProcedure( arrays_heap_sort_t, "arrays.heap_sort" );
  declareProcedure( arrays_heap_sort_descending_t, "arrays.heap_sort_descending" );
  declareProcedure( arrays_shuffle_t, "arrays.shuffle" );
  declareProcedure( arrays_reverse_t, "arrays.reverse" );
  declareProcedure( arrays_rotate_left_t, "arrays.rotate_left" );
  declareProcedure( arrays_rotate_right_t, "arrays.rotate_right" );
  declareProcedure( arrays_shift_left_t, "arrays.shift_left" );
  declareProcedure( arrays_shift_right_t, "arrays.shift_right" );
end StartupArrays;

procedure ShutdownArrays is
begin
  null;
end ShutdownArrays;

end parser_arrays;