--                                                                    --
--  package                         Copyright (c)  Dmitry A. Kazakov  --
--     Strings_Edit.Roman_Edit                     Luebeck            --
--  Implementation                                 Spring, 2002       --
--                                                                    --
--                                Last revision :  21:03 21 Apr 2009  --
--                                                                    --
--  This  library  is  free software; you can redistribute it and/or  --
--  modify it under the terms of the GNU General Public  License  as  --
--  published by the Free Software Foundation; either version  2  of  --
--  the License, or (at your option) any later version. This library  --
--  is distributed in the hope that it will be useful,  but  WITHOUT  --
--  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 along with  --
--  this library; if not, write to  the  Free  Software  Foundation,  --
--  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.    --
--                                                                    --
--  As a special exception, if other files instantiate generics from  --
--  this unit, or you link this unit with other files to produce  an  --
--  executable, this unit does not by  itself  cause  the  resulting  --
--  executable to be covered by the GNU General Public License. This  --
--  exception  does not however invalidate any other reasons why the  --
--  executable file might be covered by the GNU Public License.       --
--____________________________________________________________________--

with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.IO_Exceptions;       use Ada.IO_Exceptions;

package body Strings_Edit.Roman_Edit is
   procedure Get
             (  Source  : in String;
                Pointer : in out Integer;
                Value   : out Roman;
                First   : in Roman := Roman'First;
                Last    : in Roman := Roman'Last;
                ToFirst : in Boolean := False;
                ToLast  : in Boolean := False
             )  is
      Result : Integer := 0;
      Index  : Integer := Pointer;
      function Get (Letter : Character) return Boolean;
      pragma Inline (Get);
      function Get (Letter : Character) return Boolean is
      begin
         if (  Letter /= '.'
            and then
               Index <= Source'Last
            and then
               To_Lower (Source (Index)) = Letter
            )
         then
            Index := Index + 1;
            return True;
         else
            return False;
         end if;
      end Get;
      function Get (I, V, X : Character) return Integer is
      begin
         if Get (I) then
            if Get (I) then
               if Get (I) then
                  return 3;
               else
                  return 2;
               end if;
            elsif Get (V) then
               return 4;
            elsif Get (X) then 
               return 9;
            else
               return 1;
            end if;
         elsif Get (V) then
            if Get (I) then
               if Get (I) then
                  if Get (I) then
                     return 8;
                  else
                     return 7;
                  end if;
               else
                  return 6;
               end if;
            else
               return 5;
            end if;
         else
            return 0;
         end if;
      end Get;
   begin
      if Index < Source'First then
         raise Layout_Error;
      end if;
      if Index > Source'Last then
         if Index - 1 > Source'Last then
            raise Layout_Error;
         else
            raise End_Error;
         end if;
      end if;
      Result := Get ('m', '.', '.');
      Result := Result * 10 + Get ('c', 'd', 'm');
      Result := Result * 10 + Get ('x', 'l', 'c');
      Result := Result * 10 + Get ('i', 'v', 'x');
      if Index = Pointer then
         raise End_Error;
      end if;
      if Result < Integer (First) then
         if ToFirst then
            Value := First;
         else
            raise Constraint_Error;
         end if;
      elsif Result > Integer (Last) then
         if ToLast then
            Value := Last;
         else
            raise Constraint_Error;
         end if;
      else
         Pointer := Index;
         Value := Roman (Result);
      end if;
   end Get;

   function Value
            (  Source  : in String;
               First   : in Roman := Roman'First;
               Last    : in Roman := Roman'Last;
               ToFirst : in Boolean := False;
               ToLast  : in Boolean := False
            )  return Roman is
      Result  : Roman;
      Pointer : Integer := Source'First;
   begin
      Get (Source, Pointer, SpaceAndTab);
      Get (Source, Pointer, Result, First, Last, ToFirst, ToLast);
      Get (Source, Pointer, SpaceAndTab);
      if Pointer /= Source'Last + 1 then
         raise Data_Error;
      end if;
      return Result;
   end Value;

   procedure Put
             (  Destination : in out String;
                Pointer     : in out Integer;
                Value       : in Roman;
	        LowerCase   : in Boolean := False;
                Field       : in Natural := 0;
                Justify     : in Alignment := Left;
                Fill        : in Character := ' '
             )  is
      subtype Digit is Integer range 0..9;
      type Decimal is array (Integer range 1..4) of Digit;
      Encoded : Decimal;
      Result  : String (1..16);
      Index   : Integer := Result'First;
      Number  : Integer := Integer (Value);
      procedure Put (Letter : Character);
      pragma Inline (Put);
      procedure Put (Letter : Character) is
      begin
         Result (Index) := Letter;
         Index := Index + 1;
      end Put;
      procedure Put (Figure : Digit; I, V, X : Character) is
      begin
         case Figure is
            when 0 => null;
            when 1 => Put (I);
            when 2 => Put (I); Put (I);
            when 3 => Put (I); Put (I); Put (I);
            when 4 => Put (I); Put (V);
            when 5 => Put (V);
            when 6 => Put (V); Put (I);
            when 7 => Put (V); Put (I);  Put (I);
            when 8 => Put (V); Put (I);  Put (I);  Put (I);
            when 9 => Put (I); Put (X);
         end case;
      end Put;
   begin
      for Position in reverse Decimal'Range loop
         Encoded (Position) := Number mod 10;
         Number := Number / 10;
      end loop;
      if LowerCase then
         Put (Encoded (1), 'm', 'm', 'm');
         Put (Encoded (2), 'c', 'd', 'm');
         Put (Encoded (3), 'x', 'l', 'c');
         Put (Encoded (4), 'i', 'v', 'x');
      else
         Put (Encoded (1), 'M', 'M', 'M');
         Put (Encoded (2), 'C', 'D', 'M');
         Put (Encoded (3), 'X', 'L', 'C');
         Put (Encoded (4), 'I', 'V', 'X');
      end if;
      Put
      (  Destination,
         Pointer,
         Result (Result'First..Index - 1),
         Field,
         Justify,
         Fill
      );
   end Put;

   function Image
            (  Value     : in Roman;
               LowerCase : in Boolean := False
            )  return String is
      Text    : String (1..16);
      Pointer : Integer := Text'First;
   begin
      Put (Text, Pointer, Value, LowerCase);
      return Text (Text'First..Pointer - 1);
   end Image;

end Strings_Edit.Roman_Edit;
