--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with System;

with Ada.Exceptions;
with Ada.Real_Time;
with Ada.Unchecked_Deallocation;

with GL.Low_Level.Enums;
with GL.Types;
with GL.Pixels.Queries;

with Orka.Jobs;
with Orka.Logging;
with Orka.KTX;

package body Orka.Resources.Textures.KTX is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;

   package Messages is new Orka.Logging.Messages (Resource_Loader);

   type KTX_Load_Job is new Jobs.Abstract_Job and Jobs.GPU_Job with record
      Data    : Loaders.Resource_Data;
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Context : Jobs.Execution_Context'Class);

   -----------------------------------------------------------------------------

   use all type Ada.Real_Time.Time;

   function Read_Texture
     (Bytes : Byte_Array_Pointers.Constant_Reference;
      Path  : String;
      Start : Ada.Real_Time.Time) return GL.Objects.Textures.Texture
   is
      T1 : Ada.Real_Time.Time renames Start;
      T2 : constant Ada.Real_Time.Time := Clock;

      use Ada.Streams;
      use GL.Low_Level.Enums;
      use type GL.Types.Size;

      T3, T4, T5, T6 : Ada.Real_Time.Time;
   begin
      if not Orka.KTX.Valid_Identifier (Bytes) then
         raise Texture_Load_Error with Path & " is not a KTX file";
      end if;

      declare
         Header : constant Orka.KTX.Header := Orka.KTX.Get_Header (Bytes);
         Levels : constant GL.Types.Size   := GL.Types.Size'Max (1, Header.Mipmap_Levels);

         Texture  : GL.Objects.Textures.Texture (Header.Kind);

         Width  : constant GL.Types.Size := Header.Width;
         Height :          GL.Types.Size := Header.Height;
         Depth  :          GL.Types.Size := Header.Depth;
      begin
         T3 := Clock;

         --  Allocate storage
         case Header.Kind is
            when Texture_2D_Array =>
               Depth := Header.Array_Elements;
            when Texture_1D_Array =>
               Height := Header.Array_Elements;
               pragma Assert (Depth = 0);
            when Texture_Cube_Map_Array =>
               --  For a cube map array, depth is the number of layer-faces
               Depth := Header.Array_Elements * 6;
            when Texture_3D =>
               null;
            when Texture_2D | Texture_Cube_Map =>
               pragma Assert (Depth = 0);
            when Texture_1D =>
               if Header.Compressed then
                  raise Texture_Load_Error with Path & " has unknown 1D compressed format";
               end if;
               pragma Assert (Height = 0);
               pragma Assert (Depth = 0);
            when others =>
               raise Program_Error;
         end case;

         if Header.Compressed then
            Texture.Allocate_Storage (Levels, 1, Header.Compressed_Format,
              Width, Height, Depth);
         else
            Texture.Allocate_Storage (Levels, 1, Header.Internal_Format,
              Width, Height, Depth);
         end if;

         case Header.Kind is
            when Texture_1D =>
               Height := 1;
               Depth  := 1;
            when Texture_1D_Array | Texture_2D =>
               Depth := 1;
            when Texture_2D_Array | Texture_3D =>
               null;
            when Texture_Cube_Map | Texture_Cube_Map_Array =>
               --  Texture_Cube_Map uses 2D storage, but 3D load operation
               --  according to table 8.15 of the OpenGL specification

               --  For a cube map, depth is the number of faces, for
               --  a cube map array, depth is the number of layer-faces
               Depth := GL.Types.Size'Max (1, Header.Array_Elements) * 6;
            when others =>
               raise Program_Error;
         end case;
         T4 := Clock;

         --  TODO Handle KTXorientation key value pair

         --  Upload texture data
         declare
            Image_Size_Index : Stream_Element_Offset
              := Orka.KTX.Get_Data_Offset (Bytes, Header.Bytes_Key_Value);

            Cube_Map : constant Boolean := Header.Kind = Texture_Cube_Map;
         begin
            for Level in 0 .. Levels - 1 loop
               declare
                  Face_Size : constant Natural := Orka.KTX.Get_Length (Bytes, Image_Size_Index);
                  --  If not Cube_Map, then Face_Size is the size of the whole level

                  Cube_Padding : constant Natural := 3 - ((Face_Size + 3) mod 4);
                  Image_Size   : constant Natural
                    := (if Cube_Map then (Face_Size + Cube_Padding) * 6 else Face_Size);
                  -- If Cube_Map then Levels = 1 so no need to add it to the expression

                  --  Compute size of the whole mipmap level
                  Mip_Padding : constant Natural := 3 - ((Image_Size + 3) mod 4);
                  Mipmap_Size : constant Natural := 4 + Image_Size + Mip_Padding;

                  Offset : constant Stream_Element_Offset := Image_Size_Index + 4;
                  pragma Assert
                    (Offset + Stream_Element_Offset (Image_Size) - 1 <= Bytes.Value'Last);
                  Image_Data : constant System.Address := Bytes (Offset)'Address;
                  --  TODO Unpack_Alignment must be 4, but Load_From_Data wants 1 | 2 | 4
                  --  depending on Header.Data_Type

                  Level_Width  : constant GL.Types.Size := Texture.Width  (Level);
                  Level_Height : constant GL.Types.Size := Texture.Height (Level);
                  Level_Depth  : constant GL.Types.Size := Texture.Depth  (Level);
               begin
                  if Header.Compressed then
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Compressed_Format, GL.Types.Int (Image_Size), Image_Data);
                  else
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Format, Header.Data_Type, Image_Data);
                  end if;

                  Image_Size_Index := Image_Size_Index + Stream_Element_Offset (Mipmap_Size);
               end;
            end loop;
         end;
         T5 := Clock;

         --  Generate a full mipmap pyramid if Mipmap_Levels = 0
         if Header.Mipmap_Levels = 0 then
            Texture.Generate_Mipmap;
         end if;
         T6 := Clock;

         Messages.Log (Info, "Loaded texture " & Path & " in " &
           Logging.Trim (Logging.Image (T6 - T1)));
         Messages.Log (Info, "  size:   " &
            Logging.Trim (Width'Image) & " x " &
            Logging.Trim (Height'Image) & " x " &
            Logging.Trim (Depth'Image) &
            ", mipmap levels:" & Levels'Image);
         Messages.Log (Info, "  kind:   " & Header.Kind'Image);
         if Header.Compressed then
            Messages.Log (Info, "  format: " & Header.Compressed_Format'Image);
         else
            Messages.Log (Info, "  format: " & Header.Internal_Format'Image);
         end if;

         Messages.Log (Info, "  statistics:");
         Messages.Log (Info, "    reading file:   " & Logging.Image (T2 - T1));
         Messages.Log (Info, "    parsing header: " & Logging.Image (T3 - T2));
         Messages.Log (Info, "    storage:        " & Logging.Image (T4 - T3));
         Messages.Log (Info, "    buffers:        " & Logging.Image (T5 - T4));
         if Header.Mipmap_Levels = 0 then
            Messages.Log (Info, "    generating mipmap:" & Logging.Image (T6 - T5));
         end if;

         return Texture;
      end;
   exception
      when Error : Orka.KTX.Invalid_Enum_Error =>
         declare
            Message : constant String := Ada.Exceptions.Exception_Message (Error);
         begin
            raise Texture_Load_Error with Path & " has " & Message;
         end;
   end Read_Texture;

   function Read_Texture
     (Location : Locations.Location_Ptr;
      Path     : String) return GL.Objects.Textures.Texture
   is
      Start_Time : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
   begin
      return Read_Texture (Location.Read_Data (Path).Get, Path, Start_Time);
   end Read_Texture;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Context : Jobs.Execution_Context'Class)
   is
      Bytes : Byte_Array_Pointers.Constant_Reference := Object.Data.Bytes.Get;
      Path  : String renames SU.To_String (Object.Data.Path);

      Resource : constant Texture_Ptr := new Texture'(others => <>);
   begin
      Resource.Texture.Replace_Element (Read_Texture (Bytes, Path, Object.Data.Start_Time));

      --  Register resource at the resource manager
      Object.Manager.Add_Resource (Path, Resource_Ptr (Resource));
   end Execute;

   -----------------------------------------------------------------------------
   --                                 Loader                                  --
   -----------------------------------------------------------------------------

   type KTX_Loader is limited new Loaders.Loader with record
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   function Extension (Object : KTX_Loader) return Loaders.Extension_String is ("ktx");

   overriding
   procedure Load
     (Object   : KTX_Loader;
      Data     : Loaders.Resource_Data;
      Enqueue  : not null access procedure (Element : Jobs.Job_Ptr);
      Location : Locations.Location_Ptr)
   is
      Job : constant Jobs.Job_Ptr := new KTX_Load_Job'
        (Jobs.Abstract_Job with
          Data    => Data,
          Manager => Object.Manager);
   begin
      Enqueue (Job);
   end Load;

   function Create_Loader
     (Manager : Managers.Manager_Ptr) return Loaders.Loader_Ptr
   is (new KTX_Loader'(Manager => Manager));

   -----------------------------------------------------------------------------
   --                                 Writer                                  --
   -----------------------------------------------------------------------------

   procedure Write_Texture
     (Texture  : GL.Objects.Textures.Texture;
      Location : Locations.Writable_Location_Ptr;
      Path     : String)
   is
      package Textures renames GL.Objects.Textures;
      package Pointers is new Textures.Texture_Pointers (Byte_Pointers);

      Format    : GL.Pixels.Format    := GL.Pixels.RGBA;
      Data_Type : GL.Pixels.Data_Type := GL.Pixels.Float;
      --  Note: unused if texture is compressed

      Base_Level : constant := 0;

      use Ada.Streams;
      use all type GL.Low_Level.Enums.Texture_Kind;
      use type GL.Types.Size;

      Compressed : constant Boolean := Texture.Compressed;

      Header : Orka.KTX.Header (Compressed);

      function Convert
        (Bytes : in out GL.Types.UByte_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);

         procedure Free is new Ada.Unchecked_Deallocation
           (Object => GL.Types.UByte_Array, Name => GL.Types.UByte_Array_Access);
      begin
         for Index in Bytes'Range loop
            declare
               Target_Index : constant Stream_Element_Offset
                 := Stream_Element_Offset (Index - Bytes'First + 1);
            begin
               Result (Target_Index) := Stream_Element (Bytes (Index));
            end;
         end loop;
         Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Convert
        (Bytes : in out Pointers.Element_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);
      begin
         Result.all := Bytes.all;
         Pointers.Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Get_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : Pointers.Element_Array_Access;
      begin
         Data := Pointers.Get_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Format, Data_Type);
         return Convert (Data);
      end Get_Data;

      function Get_Compressed_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : GL.Types.UByte_Array_Access;
      begin
         Data := Textures.Get_Compressed_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Texture.Compressed_Format);
         return Convert (Data);
      end Get_Compressed_Data;
   begin
      Header.Kind := Texture.Kind;

      Header.Width := Texture.Width (Base_Level);
      case Texture.Kind is
         when Texture_3D =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := Texture.Depth (Base_Level);
         when Texture_2D | Texture_2D_Array | Texture_Cube_Map | Texture_Cube_Map_Array =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := 0;
         when Texture_1D | Texture_1D_Array =>
            Header.Height := 0;
            Header.Depth  := 0;
         when others =>
            raise Program_Error;
      end case;

      case Texture.Kind is
         when Texture_1D_Array =>
            Header.Array_Elements := Texture.Height (Base_Level);
         when Texture_2D_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level);
         when Texture_Cube_Map_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level) / 6;
         when Texture_1D | Texture_2D | Texture_3D | Texture_Cube_Map =>
            Header.Array_Elements := 0;
         when others =>
            raise Program_Error;
      end case;

      Header.Mipmap_Levels   := Texture.Mipmap_Levels;
      Header.Bytes_Key_Value := 0;

      if Compressed then
         Header.Compressed_Format := Texture.Compressed_Format;
      else
         declare
            Internal_Format : constant GL.Pixels.Internal_Format
              := Texture.Internal_Format;
         begin
            Format := GL.Pixels.Queries.Get_Texture_Format (Internal_Format, Texture.Kind);
            Data_Type := GL.Pixels.Queries.Get_Texture_Type (Internal_Format, Texture.Kind);

            Header.Internal_Format := Internal_Format;
            Header.Format    := Format;
            Header.Data_Type := Data_Type;
         end;
      end if;

      declare
         function Get_Level_Data
           (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
         is (if Compressed then Get_Compressed_Data (Level) else Get_Data (Level));

         Bytes : constant Byte_Array_Pointers.Pointer
           := Orka.KTX.Create_KTX_Bytes (Header, Get_Level_Data'Access);
      begin
         Location.Write_Data (Path, Bytes.Get);
      end;
   end Write_Texture;

end Orka.Resources.Textures.KTX;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with System;

with Ada.Exceptions;
with Ada.Real_Time;
with Ada.Unchecked_Deallocation;

with GL.Low_Level.Enums;
with GL.Types;
with GL.Pixels.Extensions;
with GL.Pixels.Queries;

with Orka.Jobs;
with Orka.Logging;
with Orka.KTX;

package body Orka.Resources.Textures.KTX is

   use all type Orka.Logging.Source;
   use all type Orka.Logging.Severity;

   package Messages is new Orka.Logging.Messages (Resource_Loader);

   type KTX_Load_Job is new Jobs.Abstract_Job and Jobs.GPU_Job with record
      Data    : Loaders.Resource_Data;
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Context : Jobs.Execution_Context'Class);

   -----------------------------------------------------------------------------

   use all type Ada.Real_Time.Time;

   function Read_Texture
     (Bytes : Byte_Array_Pointers.Constant_Reference;
      Path  : String;
      Start : Ada.Real_Time.Time) return GL.Objects.Textures.Texture
   is
      T1 : Ada.Real_Time.Time renames Start;
      T2 : constant Ada.Real_Time.Time := Clock;

      use Ada.Streams;
      use GL.Low_Level.Enums;
      use type GL.Types.Size;

      T3, T4, T5, T6 : Ada.Real_Time.Time;
   begin
      if not Orka.KTX.Valid_Identifier (Bytes) then
         raise Texture_Load_Error with Path & " is not a KTX file";
      end if;

      declare
         Header : constant Orka.KTX.Header := Orka.KTX.Get_Header (Bytes);
         Levels : constant GL.Types.Size   := GL.Types.Size'Max (1, Header.Mipmap_Levels);

         Texture  : GL.Objects.Textures.Texture (Header.Kind);

         Width  : constant GL.Types.Size := Header.Width;
         Height :          GL.Types.Size := Header.Height;
         Depth  :          GL.Types.Size := Header.Depth;
      begin
         T3 := Clock;

         if not Header.Compressed
           and then Header.Data_Type in GL.Pixels.Extensions.Packed_Data_Type
         then
            raise GL.Feature_Not_Supported_Exception with
              "Packed data type " & Header.Data_Type'Image & " is not supported yet";
         end if;

         --  Allocate storage
         case Header.Kind is
            when Texture_2D_Array =>
               Depth := Header.Array_Elements;
            when Texture_1D_Array =>
               Height := Header.Array_Elements;
               pragma Assert (Depth = 0);
            when Texture_Cube_Map_Array =>
               --  For a cube map array, depth is the number of layer-faces
               Depth := Header.Array_Elements * 6;
            when Texture_3D =>
               null;
            when Texture_2D | Texture_Cube_Map =>
               pragma Assert (Depth = 0);
            when Texture_1D =>
               if Header.Compressed then
                  raise Texture_Load_Error with Path & " has unknown 1D compressed format";
               end if;
               pragma Assert (Height = 0);
               pragma Assert (Depth = 0);
            when others =>
               raise Program_Error;
         end case;

         if Header.Compressed then
            Texture.Allocate_Storage (Levels, 1, Header.Compressed_Format,
              Width, Height, Depth);
         else
            Texture.Allocate_Storage (Levels, 1, Header.Internal_Format,
              Width, Height, Depth);
         end if;

         case Header.Kind is
            when Texture_1D =>
               Height := 1;
               Depth  := 1;
            when Texture_1D_Array | Texture_2D =>
               Depth := 1;
            when Texture_2D_Array | Texture_3D =>
               null;
            when Texture_Cube_Map | Texture_Cube_Map_Array =>
               --  Texture_Cube_Map uses 2D storage, but 3D load operation
               --  according to table 8.15 of the OpenGL specification

               --  For a cube map, depth is the number of faces, for
               --  a cube map array, depth is the number of layer-faces
               Depth := GL.Types.Size'Max (1, Header.Array_Elements) * 6;
            when others =>
               raise Program_Error;
         end case;
         T4 := Clock;

         --  TODO Handle KTXorientation key value pair

         --  Upload texture data
         declare
            Image_Size_Index : Stream_Element_Offset
              := Orka.KTX.Get_Data_Offset (Bytes, Header.Bytes_Key_Value);

            Cube_Map : constant Boolean := Header.Kind = Texture_Cube_Map;
         begin
            for Level in 0 .. Levels - 1 loop
               declare
                  Face_Size : constant Natural := Orka.KTX.Get_Length (Bytes, Image_Size_Index);
                  --  If not Cube_Map, then Face_Size is the size of the whole level

                  Cube_Padding : constant Natural := 3 - ((Face_Size + 3) mod 4);
                  Image_Size   : constant Natural
                    := (if Cube_Map then (Face_Size + Cube_Padding) * 6 else Face_Size);
                  -- If Cube_Map then Levels = 1 so no need to add it to the expression

                  --  Compute size of the whole mipmap level
                  Mip_Padding : constant Natural := 3 - ((Image_Size + 3) mod 4);
                  Mipmap_Size : constant Natural := 4 + Image_Size + Mip_Padding;

                  Offset : constant Stream_Element_Offset := Image_Size_Index + 4;
                  pragma Assert
                    (Offset + Stream_Element_Offset (Image_Size) - 1 <= Bytes.Value'Last);
                  Image_Data : constant System.Address := Bytes (Offset)'Address;
                  --  TODO Unpack_Alignment must be 4, but Load_From_Data wants 1 | 2 | 4
                  --  depending on Header.Data_Type

                  Level_Width  : constant GL.Types.Size := Texture.Width  (Level);
                  Level_Height : constant GL.Types.Size := Texture.Height (Level);
                  Level_Depth  : constant GL.Types.Size := Texture.Depth  (Level);
               begin
                  if Header.Compressed then
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Compressed_Format, GL.Types.Int (Image_Size), Image_Data);
                  else
                     Texture.Load_From_Data (Level, 0, 0, 0, Level_Width, Level_Height, Level_Depth,
                       Header.Format, Header.Data_Type, Image_Data);
                  end if;

                  Image_Size_Index := Image_Size_Index + Stream_Element_Offset (Mipmap_Size);
               end;
            end loop;
         end;
         T5 := Clock;

         --  Generate a full mipmap pyramid if Mipmap_Levels = 0
         if Header.Mipmap_Levels = 0 then
            Texture.Generate_Mipmap;
         end if;
         T6 := Clock;

         Messages.Log (Info, "Loaded texture " & Path & " in " &
           Logging.Trim (Logging.Image (T6 - T1)));
         Messages.Log (Info, "  size:   " &
            Logging.Trim (Width'Image) & " x " &
            Logging.Trim (Height'Image) & " x " &
            Logging.Trim (Depth'Image) &
            ", mipmap levels:" & Levels'Image);
         Messages.Log (Info, "  kind:   " & Header.Kind'Image);
         if Header.Compressed then
            Messages.Log (Info, "  format: " & Header.Compressed_Format'Image);
         else
            Messages.Log (Info, "  format: " & Header.Internal_Format'Image);
         end if;

         Messages.Log (Info, "  statistics:");
         Messages.Log (Info, "    reading file:   " & Logging.Image (T2 - T1));
         Messages.Log (Info, "    parsing header: " & Logging.Image (T3 - T2));
         Messages.Log (Info, "    storage:        " & Logging.Image (T4 - T3));
         Messages.Log (Info, "    buffers:        " & Logging.Image (T5 - T4));
         if Header.Mipmap_Levels = 0 then
            Messages.Log (Info, "    generating mipmap:" & Logging.Image (T6 - T5));
         end if;

         return Texture;
      end;
   exception
      when Error : Orka.KTX.Invalid_Enum_Error =>
         declare
            Message : constant String := Ada.Exceptions.Exception_Message (Error);
         begin
            raise Texture_Load_Error with Path & " has " & Message;
         end;
   end Read_Texture;

   function Read_Texture
     (Location : Locations.Location_Ptr;
      Path     : String) return GL.Objects.Textures.Texture
   is
      Start_Time : constant Ada.Real_Time.Time := Ada.Real_Time.Clock;
   begin
      return Read_Texture (Location.Read_Data (Path).Get, Path, Start_Time);
   end Read_Texture;

   overriding
   procedure Execute
     (Object  : KTX_Load_Job;
      Context : Jobs.Execution_Context'Class)
   is
      Bytes : Byte_Array_Pointers.Constant_Reference := Object.Data.Bytes.Get;
      Path  : String renames SU.To_String (Object.Data.Path);

      Resource : constant Texture_Ptr := new Texture'(others => <>);
   begin
      Resource.Texture.Replace_Element (Read_Texture (Bytes, Path, Object.Data.Start_Time));

      --  Register resource at the resource manager
      Object.Manager.Add_Resource (Path, Resource_Ptr (Resource));
   end Execute;

   -----------------------------------------------------------------------------
   --                                 Loader                                  --
   -----------------------------------------------------------------------------

   type KTX_Loader is limited new Loaders.Loader with record
      Manager : Managers.Manager_Ptr;
   end record;

   overriding
   function Extension (Object : KTX_Loader) return Loaders.Extension_String is ("ktx");

   overriding
   procedure Load
     (Object   : KTX_Loader;
      Data     : Loaders.Resource_Data;
      Enqueue  : not null access procedure (Element : Jobs.Job_Ptr);
      Location : Locations.Location_Ptr)
   is
      Job : constant Jobs.Job_Ptr := new KTX_Load_Job'
        (Jobs.Abstract_Job with
          Data    => Data,
          Manager => Object.Manager);
   begin
      Enqueue (Job);
   end Load;

   function Create_Loader
     (Manager : Managers.Manager_Ptr) return Loaders.Loader_Ptr
   is (new KTX_Loader'(Manager => Manager));

   -----------------------------------------------------------------------------
   --                                 Writer                                  --
   -----------------------------------------------------------------------------

   procedure Write_Texture
     (Texture  : GL.Objects.Textures.Texture;
      Location : Locations.Writable_Location_Ptr;
      Path     : String)
   is
      package Textures renames GL.Objects.Textures;
      package Pointers is new Textures.Texture_Pointers (Byte_Pointers);

      Format    : GL.Pixels.Format    := GL.Pixels.RGBA;
      Data_Type : GL.Pixels.Data_Type := GL.Pixels.Float;
      --  Note: unused if texture is compressed

      Base_Level : constant := 0;

      use Ada.Streams;
      use all type GL.Low_Level.Enums.Texture_Kind;
      use type GL.Types.Size;

      Compressed : constant Boolean := Texture.Compressed;

      Header : Orka.KTX.Header (Compressed);

      function Convert
        (Bytes : in out GL.Types.UByte_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);

         procedure Free is new Ada.Unchecked_Deallocation
           (Object => GL.Types.UByte_Array, Name => GL.Types.UByte_Array_Access);
      begin
         for Index in Bytes'Range loop
            declare
               Target_Index : constant Stream_Element_Offset
                 := Stream_Element_Offset (Index - Bytes'First + 1);
            begin
               Result (Target_Index) := Stream_Element (Bytes (Index));
            end;
         end loop;
         Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Convert
        (Bytes : in out Pointers.Element_Array_Access) return Byte_Array_Pointers.Pointer
      is
         Pointer : Byte_Array_Pointers.Pointer;
         Result  : constant Byte_Array_Access := new Byte_Array (1 .. Bytes'Length);
      begin
         Result.all := Bytes.all;
         Pointers.Free (Bytes);
         Pointer.Set (Result);
         return Pointer;
      end Convert;

      function Get_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : Pointers.Element_Array_Access;
      begin
         Data := Pointers.Get_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Format, Data_Type);
         return Convert (Data);
      end Get_Data;

      function Get_Compressed_Data
        (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
      is
         Data : GL.Types.UByte_Array_Access;
      begin
         Data := Textures.Get_Compressed_Data (Texture, Level, 0, 0, 0,
           Texture.Width (Level), Texture.Height (Level), Texture.Depth (Level),
           Texture.Compressed_Format);
         return Convert (Data);
      end Get_Compressed_Data;
   begin
      Header.Kind := Texture.Kind;

      Header.Width := Texture.Width (Base_Level);
      case Texture.Kind is
         when Texture_3D =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := Texture.Depth (Base_Level);
         when Texture_2D | Texture_2D_Array | Texture_Cube_Map | Texture_Cube_Map_Array =>
            Header.Height := Texture.Height (Base_Level);
            Header.Depth  := 0;
         when Texture_1D | Texture_1D_Array =>
            Header.Height := 0;
            Header.Depth  := 0;
         when others =>
            raise Program_Error;
      end case;

      case Texture.Kind is
         when Texture_1D_Array =>
            Header.Array_Elements := Texture.Height (Base_Level);
         when Texture_2D_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level);
         when Texture_Cube_Map_Array =>
            Header.Array_Elements := Texture.Depth (Base_Level) / 6;
         when Texture_1D | Texture_2D | Texture_3D | Texture_Cube_Map =>
            Header.Array_Elements := 0;
         when others =>
            raise Program_Error;
      end case;

      Header.Mipmap_Levels   := Texture.Mipmap_Levels;
      Header.Bytes_Key_Value := 0;

      if Compressed then
         Header.Compressed_Format := Texture.Compressed_Format;
      else
         declare
            Internal_Format : constant GL.Pixels.Internal_Format
              := Texture.Internal_Format;
         begin
            Format := GL.Pixels.Queries.Get_Texture_Format (Internal_Format, Texture.Kind);
            Data_Type := GL.Pixels.Queries.Get_Texture_Type (Internal_Format, Texture.Kind);

            Header.Internal_Format := Internal_Format;
            Header.Format    := Format;
            Header.Data_Type := Data_Type;
         end;
      end if;

      declare
         function Get_Level_Data
           (Level : Textures.Mipmap_Level) return Byte_Array_Pointers.Pointer
         is (if Compressed then Get_Compressed_Data (Level) else Get_Data (Level));

         Bytes : constant Byte_Array_Pointers.Pointer
           := Orka.KTX.Create_KTX_Bytes (Header, Get_Level_Data'Access);
      begin
         Location.Write_Data (Path, Bytes.Get);
      end;
   end Write_Texture;

end Orka.Resources.Textures.KTX;

orka: Raise exception if KTX file uses an uncompressed packed data type

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  EL.Functions -- Default function mapper
--  Copyright (C) 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  The default function mapper allows to register
--  The expression context provides information to resolve runtime
--  information when evaluating an expression.  The context provides
--  a resolver whose role is to find variables given their name.

package body EL.Functions.Default is

   --  ------------------------------
   --  Default Function mapper
   --  ------------------------------
   --

   use Function_Maps;

   --  ------------------------------
   --  Find the function knowing its name.
   --  ------------------------------
   function Get_Function (Mapper    : Default_Function_Mapper;
                          Namespace : String;
                          Name      : String) return Function_Access is
      Full_Name : constant String := Namespace & ":" & Name;
      C : constant Cursor := Mapper.Map.Find (Key => To_Unbounded_String (Full_Name));
   begin
      if Has_Element (C) then
         return Element (C);
      end if;
      raise No_Function;
   end Get_Function;

   --  ------------------------------
   --  Bind a name to a function.
   --  ------------------------------
   procedure Set_Function (Mapper    : in out Default_Function_Mapper;
                           Namespace : in String;
                           Name      : in String;
                           Func      : in Function_Access) is
      Full_Name : constant String := Namespace & ":" & Name;
   begin
      Mapper.Map.Include (Key => To_Unbounded_String (Full_Name), New_Item => Func);
   end Set_Function;

   --  ------------------------------
   --  Truncate the string representation represented by Value to
   --  the length specified by Size.
   --  ------------------------------
   function Truncate (Value : EL.Objects.Object;
                      Size  : EL.Objects.Object) return EL.Objects.Object is
      Cnt : constant Integer := To_Integer (Size);
   begin
      if Cnt <= 0 then
         return To_Object (String '(""));
      end if;
      if Get_Type (Value) = TYPE_WIDE_STRING then
         declare
            S : constant Wide_Wide_String := To_Wide_Wide_String (Value);
         begin
            return To_Object (S (1 .. Cnt));
         end;
      else
         --  Optimized case: use a String if we can.
         declare
            S : constant String := To_String (Value);
         begin
            return To_Object (S (1 .. Cnt));
         end;
      end if;
   end Truncate;

end EL.Functions.Default;

-----------------------------------------------------------------------
--  EL.Functions -- Default function mapper
--  Copyright (C) 2009, 2010 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------

--  The default function mapper allows to register
--  The expression context provides information to resolve runtime
--  information when evaluating an expression.  The context provides
--  a resolver whose role is to find variables given their name.

package body EL.Functions.Default is

   --  ------------------------------
   --  Default Function mapper
   --  ------------------------------
   --

   use Function_Maps;

   --  ------------------------------
   --  Find the function knowing its name.
   --  ------------------------------
   function Get_Function (Mapper    : Default_Function_Mapper;
                          Namespace : String;
                          Name      : String) return Function_Access is
      Full_Name : constant String := Namespace & ":" & Name;
      C : constant Cursor := Mapper.Map.Find (Key => To_Unbounded_String (Full_Name));
   begin
      if Has_Element (C) then
         return Element (C);
      end if;
      raise No_Function with "Function '" & Full_Name & "' not found";
   end Get_Function;

   --  ------------------------------
   --  Bind a name to a function.
   --  ------------------------------
   procedure Set_Function (Mapper    : in out Default_Function_Mapper;
                           Namespace : in String;
                           Name      : in String;
                           Func      : in Function_Access) is
      Full_Name : constant String := Namespace & ":" & Name;
   begin
      Mapper.Map.Include (Key => To_Unbounded_String (Full_Name), New_Item => Func);
   end Set_Function;

   --  ------------------------------
   --  Truncate the string representation represented by Value to
   --  the length specified by Size.
   --  ------------------------------
   function Truncate (Value : EL.Objects.Object;
                      Size  : EL.Objects.Object) return EL.Objects.Object is
      Cnt : constant Integer := To_Integer (Size);
   begin
      if Cnt <= 0 then
         return To_Object (String '(""));
      end if;
      if Get_Type (Value) = TYPE_WIDE_STRING then
         declare
            S : constant Wide_Wide_String := To_Wide_Wide_String (Value);
         begin
            return To_Object (S (1 .. Cnt));
         end;
      else
         --  Optimized case: use a String if we can.
         declare
            S : constant String := To_String (Value);
         begin
            return To_Object (S (1 .. Cnt));
         end;
      end if;
   end Truncate;

end EL.Functions.Default;

Add a message in the Not_Found exception


-- Copyright 2021 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

name = "GitLab"
type = "api"

function start()
    set_rate_limit(1)
end

function check()
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c ~= nil and c.key ~= nil and c.key ~= "") then
        return true
    end
    return false
end

function vertical(ctx, domain)
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c == nil or c.key == nil or c.key == "") then
        return
    end

    local scopes = {"issues", "blobs", "notes"}
    for _, s in pairs(scopes) do
        scrape(ctx, {
            url=build_url(domain, s),
            headers={['PRIVATE-TOKEN']=c.key},
        })
    end
end

function build_url(domain, scope)
    return "https://gitlab.com/api/v4/search?scope=" .. scope .. "&search=" .. domain
end

-- Copyright 2021 Jeff Foley. All rights reserved.
-- Use of this source code is governed by Apache 2 LICENSE that can be found in the LICENSE file.

name = "GitLab"
type = "api"

function start()
    set_rate_limit(1)
end

function check()
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c ~= nil and c.key ~= nil and c.key ~= "") then
        return true
    end
    return false
end

function vertical(ctx, domain)
    local c
    local cfg = datasrc_config()
    if cfg ~= nil then
        c = cfg.credentials
    end

    if (c == nil or c.key == nil or c.key == "") then
        return
    end

    local scopes = {"issues", "blobs", "notes"}
    for _, s in pairs(scopes) do
        scrape(ctx, {
            url=build_url(domain, s),
            headers={['PRIVATE-TOKEN']=c.key},
        })
    end
end

function build_url(domain, scope)
    return "https://gitlab.com/api/v4/search?scope=" .. scope .. "&search=" .. domain:gsub("%.", "[.]")
end

Fix Gitlab data source script

Fix Gitlab data source script


--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Ada.Numerics.Generic_Elementary_Functions;

package body Orka.Transforms.SIMD_Quaternions is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (Vectors.Element_Type);

   function Vector_Part (Elements : Quaternion) return Vector4 is
   begin
      return Result : Vector4 := Vector4 (Elements) do
         Result (W) := 0.0;
      end return;
   end Vector_Part;

   function "*" (Left, Right : Quaternion) return Quaternion is
      use Vectors;

      Lv : constant Vector4 := Vector_Part (Left);
      Rv : constant Vector4 := Vector_Part (Right);

      Ls : constant Vectors.Element_Type := Left (W);
      Rs : constant Vectors.Element_Type := Right (W);

      V : constant Vector4 := Ls * Rv + Rs * Lv + Vectors.Cross (Lv, Rv);
      S : constant Element_Type := Ls * Rs - Vectors.Dot (Lv, Rv);
   begin
      return Result : Quaternion := Quaternion (V) do
         Result (W) := S;
      end return;
   end "*";

   function Conjugate (Elements : Quaternion) return Quaternion is
      Element_W : constant Vectors.Element_Type := Elements (W);

      use Vectors;
   begin
      return Result : Quaternion := Quaternion (-Vector4 (Elements)) do
         Result (W) := Element_W;
      end return;
   end Conjugate;

   function Norm (Elements : Quaternion) return Vectors.Element_Type is
     (Vectors.Magnitude (Vector4 (Elements)));

   function Normalize (Elements : Quaternion) return Quaternion is
     (Quaternion (Vectors.Normalize (Vector4 (Elements))));

   function Normalized (Elements : Quaternion) return Boolean is
     (Vectors.Normalized (Vector4 (Elements)));

   function To_Axis_Angle (Elements : Quaternion) return Axis_Angle is
      use type Vectors.Element_Type;

      Angle : constant Vectors.Element_Type := EF.Arccos (Elements (W)) * 2.0;
      SA    : constant Vectors.Element_Type := EF.Sin (Angle / 2.0);

      use Vectors;

      Axis : Vector4 := Vector4 (Elements) * (1.0 / SA);
   begin
      Axis (W) := 0.0;
      return (Axis => Axis, Angle => Angle);
   end To_Axis_Angle;

   function R
     (Axis  : Vector4;
      Angle : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;

      CA : constant Vectors.Element_Type := EF.Cos (Angle / 2.0);
      SA : constant Vectors.Element_Type := EF.Sin (Angle / 2.0);

      use Vectors;
   begin
      return Result : Quaternion := Quaternion (Axis * SA) do
         Result (W) := CA;
      end return;
   end R;

   function R (Left, Right : Vector4) return Quaternion is
      use type Vectors.Element_Type;

      S : constant Vector4 := Vectors.Normalize (Left);
      T : constant Vector4 := Vectors.Normalize (Right);

      E   : constant Vectors.Element_Type := Vectors.Dot (S, T);
      SRE : constant Vectors.Element_Type := EF.Sqrt (2.0 * (1.0 + E));

      use Vectors;
   begin
      --  Division by zero if Left and Right are in opposite direction.
      --  Use rotation axis perpendicular to s and angle of 180 degrees
      if SRE /= 0.0 then
         --  Equation 4.53 from chapter 4.3 Quaternions from Real-Time Rendering
         --  (third edition, 2008)
         declare
            Result : Quaternion := Quaternion ((1.0 / SRE) * Vectors.Cross (S, T));
         begin
            Result (W) := SRE / 2.0;
            return Normalize (Result);
         end;
      else
         if abs S (Z) < abs S (X) then
            return R ((S (Y), -S (X), 0.0, 0.0), Ada.Numerics.Pi);
         else
            return R ((0.0, -S (Z), S (Y), 0.0), Ada.Numerics.Pi);
         end if;
      end if;
   end R;

   function Difference (Left, Right : Quaternion) return Quaternion is
   begin
      return Right * Conjugate (Left);
   end Difference;

   procedure Rotate_At_Origin
     (Vector   : in out Vector4;
      Elements : Quaternion)
   is
      Result : Vectors.Vector_Type;
   begin
      Result := Vectors.Vector_Type (Elements * Quaternion (Vector) * Conjugate (Elements));
      Vector := Result;
   end Rotate_At_Origin;

   function Lerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;
      use Vectors;
   begin
      return Normalize (Quaternion ((1.0 - Time) * Vector4 (Left) + Time * Vector4 (Right)));
   end Lerp;

   function Slerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;

      Cos_Angle : constant Vectors.Element_Type := Vectors.Dot (Vector4 (Left), Vector4 (Right));
      Angle     : constant Vectors.Element_Type := EF.Arccos (Cos_Angle);

      SA : constant Vectors.Element_Type := EF.Sin (Angle);

      SL : constant Vectors.Element_Type := EF.Sin ((1.0 - Time) * Angle);
      SR : constant Vectors.Element_Type := EF.Sin (Time * Angle);

      use Vectors;
   begin
      return Quaternion ((SL / SA) * Vector4 (Left) + (SR / SA) * Vector4 (Right));
   end Slerp;

   function Image (Elements : Quaternion) return String is
     (Vectors.Image (Vectors.Vector_Type (Elements)));

end Orka.Transforms.SIMD_Quaternions;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2017 onox <denkpadje@gmail.com>
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.

with Ada.Numerics.Generic_Elementary_Functions;

package body Orka.Transforms.SIMD_Quaternions is

   package EF is new Ada.Numerics.Generic_Elementary_Functions (Vectors.Element_Type);

   function Vector_Part (Elements : Quaternion) return Vector4 is
   begin
      return Result : Vector4 := Vector4 (Elements) do
         Result (W) := 0.0;
      end return;
   end Vector_Part;

   function "*" (Left, Right : Quaternion) return Quaternion is
      use Vectors;

      Lv : constant Vector4 := Vector_Part (Left);
      Rv : constant Vector4 := Vector_Part (Right);

      Ls : constant Vectors.Element_Type := Left (W);
      Rs : constant Vectors.Element_Type := Right (W);

      V : constant Vector4 := Ls * Rv + Rs * Lv + Vectors.Cross (Lv, Rv);
      S : constant Element_Type := Ls * Rs - Vectors.Dot (Lv, Rv);
   begin
      return Result : Quaternion := Quaternion (V) do
         Result (W) := S;
      end return;
   end "*";

   function Conjugate (Elements : Quaternion) return Quaternion is
      Element_W : constant Vectors.Element_Type := Elements (W);

      use Vectors;
   begin
      return Result : Quaternion := Quaternion (-Vector4 (Elements)) do
         Result (W) := Element_W;
      end return;
   end Conjugate;

   function Norm (Elements : Quaternion) return Vectors.Element_Type is
     (Vectors.Magnitude (Vector4 (Elements)));

   function Normalize (Elements : Quaternion) return Quaternion is
     (Quaternion (Vectors.Normalize (Vector4 (Elements))));

   function Normalized (Elements : Quaternion) return Boolean is
     (Vectors.Normalized (Vector4 (Elements)));

   function To_Axis_Angle (Elements : Quaternion) return Axis_Angle is
      use type Vectors.Element_Type;

      Angle : constant Vectors.Element_Type := EF.Arccos (Elements (W)) * 2.0;
      SA    : constant Vectors.Element_Type := EF.Sin (Angle / 2.0);
   begin
      if SA /= 0.0 then
         declare
            use Vectors;
            Axis : Vector4 := Vector4 (Elements) * (1.0 / SA);
         begin
            Axis (W) := 0.0;
            return (Axis => Axis, Angle => Angle);
         end;
      else
         --  Singularity occurs when angle is 0. Return an arbitrary axis
         return (Axis => (1.0, 0.0, 0.0, 0.0), Angle => 0.0);
      end if;
   end To_Axis_Angle;

   function R
     (Axis  : Vector4;
      Angle : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;

      CA : constant Vectors.Element_Type := EF.Cos (Angle / 2.0);
      SA : constant Vectors.Element_Type := EF.Sin (Angle / 2.0);

      use Vectors;
   begin
      return Result : Quaternion := Quaternion (Axis * SA) do
         Result (W) := CA;
      end return;
   end R;

   function R (Left, Right : Vector4) return Quaternion is
      use type Vectors.Element_Type;

      S : constant Vector4 := Vectors.Normalize (Left);
      T : constant Vector4 := Vectors.Normalize (Right);

      E   : constant Vectors.Element_Type := Vectors.Dot (S, T);
      SRE : constant Vectors.Element_Type := EF.Sqrt (2.0 * (1.0 + E));

      use Vectors;
   begin
      --  Division by zero if Left and Right are in opposite direction.
      --  Use rotation axis perpendicular to s and angle of 180 degrees
      if SRE /= 0.0 then
         --  Equation 4.53 from chapter 4.3 Quaternions from Real-Time Rendering
         --  (third edition, 2008)
         declare
            Result : Quaternion := Quaternion ((1.0 / SRE) * Vectors.Cross (S, T));
         begin
            Result (W) := SRE / 2.0;
            return Normalize (Result);
         end;
      else
         if abs S (Z) < abs S (X) then
            return R ((S (Y), -S (X), 0.0, 0.0), Ada.Numerics.Pi);
         else
            return R ((0.0, -S (Z), S (Y), 0.0), Ada.Numerics.Pi);
         end if;
      end if;
   end R;

   function Difference (Left, Right : Quaternion) return Quaternion is
   begin
      return Right * Conjugate (Left);
   end Difference;

   procedure Rotate_At_Origin
     (Vector   : in out Vector4;
      Elements : Quaternion)
   is
      Result : Vectors.Vector_Type;
   begin
      Result := Vectors.Vector_Type (Elements * Quaternion (Vector) * Conjugate (Elements));
      Vector := Result;
   end Rotate_At_Origin;

   function Lerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;
      use Vectors;
   begin
      return Normalize (Quaternion ((1.0 - Time) * Vector4 (Left) + Time * Vector4 (Right)));
   end Lerp;

   function Slerp
     (Left, Right : Quaternion;
      Time        : Vectors.Element_Type) return Quaternion
   is
      use type Vectors.Element_Type;

      Cos_Angle : constant Vectors.Element_Type := Vectors.Dot (Vector4 (Left), Vector4 (Right));
      Angle     : constant Vectors.Element_Type := EF.Arccos (Cos_Angle);

      SA : constant Vectors.Element_Type := EF.Sin (Angle);

      SL : constant Vectors.Element_Type := EF.Sin ((1.0 - Time) * Angle);
      SR : constant Vectors.Element_Type := EF.Sin (Time * Angle);

      use Vectors;
   begin
      return Quaternion ((SL / SA) * Vector4 (Left) + (SR / SA) * Vector4 (Right));
   end Slerp;

   function Image (Elements : Quaternion) return String is
     (Vectors.Image (Vectors.Vector_Type (Elements)));

end Orka.Transforms.SIMD_Quaternions;

orka: Fix function To_Axis_Angle to handle singularity at 0 deg rotation

Signed-off-by: onox <34c1d3d2d1347bea60a26f46574de21a7a79b6d5@gmail.com>


-----------------------------------------------------------------------
--  util-encoders-base64 -- Encode/Decode a stream in base64adecimal
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2016, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Streams;
package body Util.Encoders.Base64 is

   use Interfaces;
   use Ada;

   use type Ada.Streams.Stream_Element_Offset;

   --  ------------------------------
   --  Encode the 64-bit value to LEB128 and then base64url.
   --  ------------------------------
   function Encode (Value : in Interfaces.Unsigned_64) return String is
      E       : Encoder;
      Data    : Ada.Streams.Stream_Element_Array (1 .. 10);
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
      Result  : String (1 .. 16);
      Buf     : Ada.Streams.Stream_Element_Array (1 .. Result'Length);
      for Buf'Address use Result'Address;
      pragma Import (Ada, Buf);
   begin
      --  Encode the integer to LEB128 in the data buffer.
      Encode_LEB128 (Into => Data,
                     Pos  => Data'First,
                     Val  => Value,
                     Last => Last);

      --  Encode the data buffer in base64url.
      E.Set_URL_Mode (True);
      E.Transform (Data    => Data (Data'First .. Last),
                   Into    => Buf,
                   Last    => Last,
                   Encoded => Encoded);

      --  Strip the '=' or '==' at end of base64url.
      if Result (Positive (Last)) /= '=' then
         return Result (Result'First .. Positive (Last));
      elsif Result (Positive (Last) - 1) /= '=' then
         return Result (Result'First .. Positive (Last) - 1);
      else
         return Result (Result'First .. Positive (Last) - 2);
      end if;
   end Encode;

   --  ------------------------------
   --  Decode the base64url string and then the LEB128 integer.
   --  Raise the Encoding_Error if the string is invalid and cannot be decoded.
   --  ------------------------------
   function Decode (Value : in String) return Interfaces.Unsigned_64 is
      D       : Decoder;
      Buf     : Ada.Streams.Stream_Element_Array (1 .. Value'Length + 2);
      R       : Ada.Streams.Stream_Element_Array (1 .. Value'Length + 2);
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
      Result  : Interfaces.Unsigned_64;
      End_Pos : constant Ada.Streams.Stream_Element_Offset
        := Value'Length + ((4 - (Value'Length mod 4)) mod 4);
   begin
      Util.Streams.Copy (Into => Buf (1 .. Value'Length), From => Value);

      --  Set back the '=' for the base64url (pad to multiple of 4.
      Buf (Value'Length + 1) := Character'Pos ('=');
      Buf (Value'Length + 2) := Character'Pos ('=');

      --  Decode using base64url
      D.Set_URL_Mode (True);
      D.Transform (Data    => Buf (Buf'First .. End_Pos),
                   Into    => R,
                   Last    => Last,
                   Encoded => Encoded);
      if Encoded /= End_Pos then
         raise Encoding_Error with "Input string is too short";
      end if;

      --  Decode the LEB128 number.
      Decode_LEB128 (From => R (R'First .. Last),
                     Pos  => R'First,
                     Val  => Result,
                     Last => Encoded);

      --  Check that everything was decoded.
      if Last + 1 /= Encoded then
         raise Encoding_Error with "Input string contains garbage at the end";
      end if;
      return Result;
   end Decode;

   --  ------------------------------
   --  Encodes the binary input stream represented by Data into
   --  the a base64 output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in out Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is

      Pos      : Ada.Streams.Stream_Element_Offset := Into'First;
      I        : Ada.Streams.Stream_Element_Offset := Data'First;
      C1, C2   : Unsigned_8;

      Alphabet : constant Alphabet_Access := E.Alphabet;

   begin
      while I <= Data'Last loop
         if Pos + 4 > Into'Last + 1 then
            Last    := Pos - 1;
            Encoded := I - 1;
            return;
         end if;

         --  Encode the first byte, add padding if necessary.
         C1 := Unsigned_8 (Data (I));
         Into (Pos) := Alphabet (Shift_Right (C1, 2));
         if I = Data'Last then
            Into (Pos + 1) := Alphabet (Shift_Left (C1 and 3, 4));
            Into (Pos + 2) := Character'Pos ('=');
            Into (Pos + 3) := Character'Pos ('=');
            Last := Pos + 3;
            Encoded := Data'Last;
            return;
         end if;

         --  Encode the second byte, add padding if necessary.
         C2 := Unsigned_8 (Data (I + 1));
         Into (Pos + 1) := Alphabet (Shift_Left (C1 and 16#03#, 4) or Shift_Right (C2, 4));
         if I = Data'Last - 1 then
            Into (Pos + 2) := Alphabet (Shift_Left (C2 and 16#0F#, 2));
            Into (Pos + 3) := Character'Pos ('=');
            Last := Pos + 3;
            Encoded := Data'Last;
            return;
         end if;

         --  Encode the third byte
         C1 := Unsigned_8 (Data (I + 2));
         Into (Pos + 2) := Alphabet (Shift_Left (C2 and 16#0F#, 2) or Shift_Right (C1, 6));
         Into (Pos + 3) := Alphabet (C1 and 16#03F#);
         Pos := Pos + 4;
         I   := I + 3;
      end loop;
      Last    := Pos - 1;
      Encoded := Data'Last;
   end Transform;

   --  ------------------------------
   --  Set the encoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   procedure Set_URL_Mode (E    : in out Encoder;
                           Mode : in Boolean) is
   begin
      if Mode then
         E.Alphabet := BASE64_URL_ALPHABET'Access;
      else
         E.Alphabet := BASE64_ALPHABET'Access;
      end if;
   end Set_URL_Mode;

   --  ------------------------------
   --  Create a base64 encoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   function Create_URL_Encoder return Transformer_Access is
   begin
      return new Encoder '(Alphabet => BASE64_URL_ALPHABET'Access);
   end Create_URL_Encoder;

   --  ------------------------------
   --  Decodes the base64 input stream represented by Data into
   --  the binary output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in out Decoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is

      use Ada.Streams;

      Pos      : Ada.Streams.Stream_Element_Offset := Into'First;
      I        : Ada.Streams.Stream_Element_Offset := Data'First;
      C1, C2   : Ada.Streams.Stream_Element;
      Val1, Val2 : Unsigned_8;

      Values : constant Alphabet_Values_Access := E.Values;

   begin
      while I <= Data'Last loop
         if Pos + 3 > Into'Last + 1 then
            Last    := Pos - 1;
            Encoded := I - 1;
            return;
         end if;

         --  Decode the first two bytes to produce the first output byte
         C1 := Data (I);
         Val1 := Values (C1);
         if (Val1 and 16#C0#) /= 0 then
            raise Encoding_Error with "Invalid character '" & Character'Val (C1) & "'";
         end if;

         C2 := Data (I + 1);
         Val2 := Values (C2);
         if (Val2 and 16#C0#) /= 0 then
            raise Encoding_Error with "Invalid character '" & Character'Val (C2) & "'";
         end if;

         Into (Pos) := Stream_Element (Shift_Left (Val1, 2) or Shift_Right (Val2, 4));

         if I + 2 > Data'Last then
            Encoded := I + 1;
            Last    := Pos;
            return;
         end if;

         --  Decode the next byte
         C1 := Data (I + 2);
         Val1 := Values (C1);
         if (Val1 and 16#C0#) /= 0 then
            if C1 /= Character'Pos ('=') then
               raise Encoding_Error with "Invalid character '" & Character'Val (C1) & "'";
            end if;
            Encoded := I + 3;
            Last    := Pos;
            return;
         end if;

         Into (Pos + 1) := Stream_Element (Shift_Left (Val2, 4) or Shift_Right (Val1, 2));

         if I + 3 > Data'Last then
            Encoded := I + 2;
            Last    := Pos + 1;
            return;
         end if;

         C2 := Data (I + 3);
         Val2 := Values (C2);
         if (Val2 and 16#C0#) /= 0 then
            if C2 /= Character'Pos ('=') then
               raise Encoding_Error with "Invalid character '" & Character'Val (C2) & "'";
            end if;
            Encoded := I + 3;
            Last    := Pos + 1;
            return;
         end if;

         Into (Pos + 2) := Stream_Element (Shift_Left (Val1, 6) or Val2);
         Pos := Pos + 3;
         I   := I + 4;
      end loop;
      Last    := Pos - 1;
      Encoded := Data'Last;
   end Transform;

   --  ------------------------------
   --  Set the decoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   procedure Set_URL_Mode (E    : in out Decoder;
                           Mode : in Boolean) is
   begin
      if Mode then
         E.Values := BASE64_URL_VALUES'Access;
      else
         E.Values := BASE64_VALUES'Access;
      end if;
   end Set_URL_Mode;

   --  ------------------------------
   --  Create a base64 decoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   function Create_URL_Decoder return Transformer_Access is
   begin
      return new Decoder '(Values => BASE64_URL_VALUES'Access);
   end Create_URL_Decoder;

end Util.Encoders.Base64;

-----------------------------------------------------------------------
--  util-encoders-base64 -- Encode/Decode a stream in base64adecimal
--  Copyright (C) 2009, 2010, 2011, 2012, 2013, 2016, 2017 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Util.Streams;
package body Util.Encoders.Base64 is

   use Interfaces;
   use Ada;

   use type Ada.Streams.Stream_Element_Offset;

   --  ------------------------------
   --  Encode the 64-bit value to LEB128 and then base64url.
   --  ------------------------------
   function Encode (Value : in Interfaces.Unsigned_64) return String is
      E       : Encoder;
      Data    : Ada.Streams.Stream_Element_Array (1 .. 10);
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
      Result  : String (1 .. 16);
      Buf     : Ada.Streams.Stream_Element_Array (1 .. Result'Length);
      for Buf'Address use Result'Address;
      pragma Import (Ada, Buf);
   begin
      --  Encode the integer to LEB128 in the data buffer.
      Encode_LEB128 (Into => Data,
                     Pos  => Data'First,
                     Val  => Value,
                     Last => Last);

      --  Encode the data buffer in base64url.
      E.Set_URL_Mode (True);
      E.Transform (Data    => Data (Data'First .. Last),
                   Into    => Buf,
                   Last    => Last,
                   Encoded => Encoded);
      E.Finish (Into => Buf (Last + 1 .. Buf'Last),
                Last => Last);

      --  Strip the '=' or '==' at end of base64url.
      if Result (Positive (Last)) /= '=' then
         return Result (Result'First .. Positive (Last));
      elsif Result (Positive (Last) - 1) /= '=' then
         return Result (Result'First .. Positive (Last) - 1);
      else
         return Result (Result'First .. Positive (Last) - 2);
      end if;
   end Encode;

   --  ------------------------------
   --  Decode the base64url string and then the LEB128 integer.
   --  Raise the Encoding_Error if the string is invalid and cannot be decoded.
   --  ------------------------------
   function Decode (Value : in String) return Interfaces.Unsigned_64 is
      D       : Decoder;
      Buf     : Ada.Streams.Stream_Element_Array (1 .. Value'Length + 2);
      R       : Ada.Streams.Stream_Element_Array (1 .. Value'Length + 2);
      Last    : Ada.Streams.Stream_Element_Offset;
      Encoded : Ada.Streams.Stream_Element_Offset;
      Result  : Interfaces.Unsigned_64;
      End_Pos : constant Ada.Streams.Stream_Element_Offset
        := Value'Length + ((4 - (Value'Length mod 4)) mod 4);
   begin
      if Buf'Length < End_Pos then
         raise Encoding_Error with "Input string is too short";
      end if;
      Util.Streams.Copy (Into => Buf (1 .. Value'Length), From => Value);

      --  Set back the '=' for the base64url (pad to multiple of 4.
      Buf (Value'Length + 1) := Character'Pos ('=');
      Buf (Value'Length + 2) := Character'Pos ('=');

      --  Decode using base64url
      D.Set_URL_Mode (True);
      D.Transform (Data    => Buf (Buf'First .. End_Pos),
                   Into    => R,
                   Last    => Last,
                   Encoded => Encoded);
      if Encoded /= End_Pos then
         raise Encoding_Error with "Input string is too short";
      end if;

      --  Decode the LEB128 number.
      Decode_LEB128 (From => R (R'First .. Last),
                     Pos  => R'First,
                     Val  => Result,
                     Last => Encoded);

      --  Check that everything was decoded.
      if Last + 1 /= Encoded then
         raise Encoding_Error with "Input string contains garbage at the end";
      end if;
      return Result;
   end Decode;

   --  ------------------------------
   --  Encodes the binary input stream represented by Data into
   --  the a base64 output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in out Encoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is

      Pos      : Ada.Streams.Stream_Element_Offset := Into'First;
      I        : Ada.Streams.Stream_Element_Offset := Data'First;
      C1, C2   : Unsigned_8;

      Alphabet : constant Alphabet_Access := E.Alphabet;

   begin
      while E.Count /= 0 and I <= Data'Last loop
         if E.Count = 2 then
            C1 := E.Value;
            C2 := Unsigned_8 (Data (I));
            Into (Pos) := Alphabet (Shift_Left (C1 and 16#03#, 4) or Shift_Right (C2, 4));
            Pos := Pos + 1;
            I := I + 1;
            E.Count := 1;
            E.Value := C2;
         else
            C2 := E.Value;
            C1 := Unsigned_8 (Data (I));
            Into (Pos) := Alphabet (Shift_Left (C2 and 16#0F#, 2) or Shift_Right (C1, 6));
            Into (Pos + 1) := Alphabet (C1 and 16#03F#);
            Pos := Pos + 2;
            I := I + 1;
            E.Count := 0;
         end if;
      end loop;
      while I <= Data'Last loop
         if Pos + 4 > Into'Last + 1 then
            Last    := Pos - 1;
            Encoded := I - 1;
            E.Count := 0;
            return;
         end if;

         --  Encode the first byte, add padding if necessary.
         C1 := Unsigned_8 (Data (I));
         Into (Pos) := Alphabet (Shift_Right (C1, 2));
         if I = Data'Last then
            E.Value := C1;
            E.Count := 2;
            Last := Pos;
            Encoded := Data'Last;
            return;
         end if;

         --  Encode the second byte, add padding if necessary.
         C2 := Unsigned_8 (Data (I + 1));
         Into (Pos + 1) := Alphabet (Shift_Left (C1 and 16#03#, 4) or Shift_Right (C2, 4));
         if I = Data'Last - 1 then
            E.Value := C2;
            E.Count := 1;
            Last := Pos + 1;
            Encoded := Data'Last;
            return;
         end if;

         --  Encode the third byte
         C1 := Unsigned_8 (Data (I + 2));
         Into (Pos + 2) := Alphabet (Shift_Left (C2 and 16#0F#, 2) or Shift_Right (C1, 6));
         Into (Pos + 3) := Alphabet (C1 and 16#03F#);
         Pos := Pos + 4;
         I   := I + 3;
      end loop;
      E.Count := 0;
      Last    := Pos - 1;
      Encoded := Data'Last;
   end Transform;

   --  ------------------------------
   --  Finish encoding the input array.
   --  ------------------------------
   overriding
   procedure Finish (E    : in out Encoder;
                     Into : in out Ada.Streams.Stream_Element_Array;
                     Last : in out Ada.Streams.Stream_Element_Offset) is
      Pos : constant Ada.Streams.Stream_Element_Offset := Into'First;
   begin
      if E.Count = 2 then
         Into (Pos) := E.Alphabet (Shift_Left (E.Value and 3, 4));
         Into (Pos + 1) := Character'Pos ('=');
         Into (Pos + 2) := Character'Pos ('=');
         Last := Pos + 2;
         E.Count := 0;
      elsif E.Count = 1 then
         Into (Pos) := E.Alphabet (Shift_Left (E.Value and 16#0F#, 2));
         Into (Pos + 1) := Character'Pos ('=');
         Last := Pos + 1;
         E.Count := 0;
      else
         Last := Pos - 1;
      end if;
   end Finish;

   --  ------------------------------
   --  Set the encoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   procedure Set_URL_Mode (E    : in out Encoder;
                           Mode : in Boolean) is
   begin
      if Mode then
         E.Alphabet := BASE64_URL_ALPHABET'Access;
      else
         E.Alphabet := BASE64_ALPHABET'Access;
      end if;
   end Set_URL_Mode;

   --  ------------------------------
   --  Create a base64 encoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   function Create_URL_Encoder return Transformer_Access is
   begin
      return new Encoder '(Alphabet => BASE64_URL_ALPHABET'Access, others => <>);
   end Create_URL_Encoder;

   --  ------------------------------
   --  Decodes the base64 input stream represented by Data into
   --  the binary output stream Into.
   --
   --  If the transformer does not have enough room to write the result,
   --  it must return in Encoded the index of the last encoded
   --  position in the Data stream.
   --
   --  The transformer returns in Last the last valid position
   --  in the output stream Into.
   --
   --  The Encoding_Error exception is raised if the input
   --  stream cannot be transformed.
   --  ------------------------------
   overriding
   procedure Transform (E       : in out Decoder;
                        Data    : in Ada.Streams.Stream_Element_Array;
                        Into    : out Ada.Streams.Stream_Element_Array;
                        Last    : out Ada.Streams.Stream_Element_Offset;
                        Encoded : out Ada.Streams.Stream_Element_Offset) is

      use Ada.Streams;

      Pos      : Ada.Streams.Stream_Element_Offset := Into'First;
      I        : Ada.Streams.Stream_Element_Offset := Data'First;
      C1, C2   : Ada.Streams.Stream_Element;
      Val1, Val2 : Unsigned_8;

      Values : constant Alphabet_Values_Access := E.Values;

   begin
      while I <= Data'Last loop
         if Pos + 3 > Into'Last + 1 then
            Last    := Pos - 1;
            Encoded := I - 1;
            return;
         end if;

         --  Decode the first two bytes to produce the first output byte
         C1 := Data (I);
         Val1 := Values (C1);
         if (Val1 and 16#C0#) /= 0 then
            raise Encoding_Error with "Invalid character '" & Character'Val (C1) & "'";
         end if;

         C2 := Data (I + 1);
         Val2 := Values (C2);
         if (Val2 and 16#C0#) /= 0 then
            raise Encoding_Error with "Invalid character '" & Character'Val (C2) & "'";
         end if;

         Into (Pos) := Stream_Element (Shift_Left (Val1, 2) or Shift_Right (Val2, 4));

         if I + 2 > Data'Last then
            Encoded := I + 1;
            Last    := Pos;
            return;
         end if;

         --  Decode the next byte
         C1 := Data (I + 2);
         Val1 := Values (C1);
         if (Val1 and 16#C0#) /= 0 then
            if C1 /= Character'Pos ('=') then
               raise Encoding_Error with "Invalid character '" & Character'Val (C1) & "'";
            end if;
            Encoded := I + 3;
            Last    := Pos;
            return;
         end if;

         Into (Pos + 1) := Stream_Element (Shift_Left (Val2, 4) or Shift_Right (Val1, 2));

         if I + 3 > Data'Last then
            Encoded := I + 2;
            Last    := Pos + 1;
            return;
         end if;

         C2 := Data (I + 3);
         Val2 := Values (C2);
         if (Val2 and 16#C0#) /= 0 then
            if C2 /= Character'Pos ('=') then
               raise Encoding_Error with "Invalid character '" & Character'Val (C2) & "'";
            end if;
            Encoded := I + 3;
            Last    := Pos + 1;
            return;
         end if;

         Into (Pos + 2) := Stream_Element (Shift_Left (Val1, 6) or Val2);
         Pos := Pos + 3;
         I   := I + 4;
      end loop;
      Last    := Pos - 1;
      Encoded := Data'Last;
   end Transform;

   --  ------------------------------
   --  Set the decoder to use the base64 URL alphabet when Mode is True.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   procedure Set_URL_Mode (E    : in out Decoder;
                           Mode : in Boolean) is
   begin
      if Mode then
         E.Values := BASE64_URL_VALUES'Access;
      else
         E.Values := BASE64_VALUES'Access;
      end if;
   end Set_URL_Mode;

   --  ------------------------------
   --  Create a base64 decoder using the URL alphabet.
   --  The URL alphabet uses the '-' and '_' instead of the '+' and '/' characters.
   --  ------------------------------
   function Create_URL_Decoder return Transformer_Access is
   begin
      return new Decoder '(Values => BASE64_URL_VALUES'Access);
   end Create_URL_Decoder;

end Util.Encoders.Base64;

Implement the Finish operation to handle the end of a Base64 conversion


-----------------------------------------------------------------------
--  util-serialize-tools -- Tools to Serialize objects in various formats
--  Copyright (C) 2012, 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Containers;

with Util.Streams.Texts;
with Util.Streams.Buffered;
with Util.Serialize.Mappers.Record_Mapper;
package body Util.Serialize.Tools is

   type Object_Field is (FIELD_NAME, FIELD_VALUE);
   type Object_Map_Access is access all Util.Beans.Objects.Maps.Map'Class;

   type Object_Mapper_Context is record
      Map  : Object_Map_Access;
      Name : Util.Beans.Objects.Object;
   end record;
   type Object_Mapper_Context_Access is access all Object_Mapper_Context;

   procedure Set_Member (Into  : in out Object_Mapper_Context;
                         Field : in Object_Field;
                         Value : in Util.Beans.Objects.Object);

   procedure Set_Member (Into  : in out Object_Mapper_Context;
                         Field : in Object_Field;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_VALUE =>
            Into.Map.Include (Util.Beans.Objects.To_String (Into.Name), Value);
            Into.Name := Util.Beans.Objects.Null_Object;

      end case;
   end Set_Member;

   package Object_Mapper is new
     Util.Serialize.Mappers.Record_Mapper (Element_Type        => Object_Mapper_Context,
                                           Element_Type_Access => Object_Mapper_Context_Access,
                                           Fields              => Object_Field,
                                           Set_Member          => Set_Member);

   JSON_Mapping : aliased Object_Mapper.Mapper;

   --  -----------------------
   --  Serialize the objects defined in the object map Map into the Output
   --  JSON stream.  Use the Name as the name of the JSON object.
   --  -----------------------
   procedure To_JSON (Output : in out Util.Serialize.IO.JSON.Output_Stream;
                      Name   : in String;
                      Map    : in Util.Beans.Objects.Maps.Map) is
      use type Ada.Containers.Count_Type;

      procedure Write (Name  : in String;
                       Value : in Util.Beans.Objects.Object);

      procedure Write (Name  : in String;
                       Value : in Util.Beans.Objects.Object) is
      begin
         Output.Start_Entity (Name => "");
         Output.Write_Attribute (Name  => "name",
                                 Value => Util.Beans.Objects.To_Object (Name));
         Output.Write_Attribute (Name  => "value",
                                 Value => Value);
         Output.End_Entity (Name => "");
      end Write;

   begin
      if Map.Length > 0 then
         declare
            Iter : Util.Beans.Objects.Maps.Cursor := Map.First;
         begin
            Output.Start_Array (Name => Name);
            while Util.Beans.Objects.Maps.Has_Element (Iter) loop
               Util.Beans.Objects.Maps.Query_Element (Iter, Write'Access);
               Util.Beans.Objects.Maps.Next (Iter);
            end loop;
            Output.End_Array (Name => Name);
         end;
      end if;
   end To_JSON;

   --  -----------------------
   --  Serialize the objects defined in the object map Map into an XML stream.
   --  Returns the JSON string that contains a serialization of the object maps.
   --  -----------------------
   function To_JSON (Map : in Util.Beans.Objects.Maps.Map) return String is
      use type Ada.Containers.Count_Type;
   begin
      if Map.Length = 0 then
         return "";
      end if;
      declare
         Output : Util.Serialize.IO.JSON.Output_Stream;
      begin
         Output.Initialize (Size => 10000);
         Output.Start_Document;
         To_JSON (Output, "params", Map);
         Output.End_Document;
         return Util.Streams.Texts.To_String (Util.Streams.Buffered.Buffered_Stream (Output));
      end;
   end To_JSON;

   --  -----------------------
   --  Deserializes the JSON content passed in Content and restore the object map
   --  with their values.  The object map passed in Map can contain existing values.
   --  They will be overriden by the JSON values.
   --  -----------------------
   procedure From_JSON (Content : in String;
                        Map     : in out Util.Beans.Objects.Maps.Map) is
      Parser  : Util.Serialize.IO.JSON.Parser;
      Context : aliased Object_Mapper_Context;
   begin
      if Content'Length > 0 then
         Context.Map := Map'Unchecked_Access;
         Parser.Add_Mapping ("/params", JSON_Mapping'Access);
         Object_Mapper.Set_Context (Parser, Context'Unchecked_Access);
         Parser.Parse_String (Content);
      end if;
   end From_JSON;

   --  -----------------------
   --  Deserializes the JSON content passed in Content and restore the object map
   --  with their values.
   --  Returns the object map that was restored.
   --  -----------------------
   function From_JSON (Content : in String) return Util.Beans.Objects.Maps.Map is
      Result  : Util.Beans.Objects.Maps.Map;
   begin
      From_JSON (Content, Result);
      return Result;
   end From_JSON;

begin
   JSON_Mapping.Add_Mapping ("name", FIELD_NAME);
   JSON_Mapping.Add_Mapping ("value", FIELD_VALUE);
end Util.Serialize.Tools;

-----------------------------------------------------------------------
--  util-serialize-tools -- Tools to Serialize objects in various formats
--  Copyright (C) 2012, 2016 Stephane Carrez
--  Written by Stephane Carrez (Stephane.Carrez@gmail.com)
--
--  Licensed under the Apache License, Version 2.0 (the "License");
--  you may not use this file except in compliance with the License.
--  You may obtain a copy of the License at
--
--      http://www.apache.org/licenses/LICENSE-2.0
--
--  Unless required by applicable law or agreed to in writing, software
--  distributed under the License is distributed on an "AS IS" BASIS,
--  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
--  See the License for the specific language governing permissions and
--  limitations under the License.
-----------------------------------------------------------------------
with Ada.Containers;

with Util.Streams.Texts;
with Util.Streams.Buffered;
with Util.Serialize.Mappers.Record_Mapper;
package body Util.Serialize.Tools is

   type Object_Field is (FIELD_NAME, FIELD_VALUE);
   type Object_Map_Access is access all Util.Beans.Objects.Maps.Map'Class;

   type Object_Mapper_Context is record
      Map  : Object_Map_Access;
      Name : Util.Beans.Objects.Object;
   end record;
   type Object_Mapper_Context_Access is access all Object_Mapper_Context;

   procedure Set_Member (Into  : in out Object_Mapper_Context;
                         Field : in Object_Field;
                         Value : in Util.Beans.Objects.Object);

   procedure Set_Member (Into  : in out Object_Mapper_Context;
                         Field : in Object_Field;
                         Value : in Util.Beans.Objects.Object) is
   begin
      case Field is
         when FIELD_NAME =>
            Into.Name := Value;

         when FIELD_VALUE =>
            Into.Map.Include (Util.Beans.Objects.To_String (Into.Name), Value);
            Into.Name := Util.Beans.Objects.Null_Object;

      end case;
   end Set_Member;

   package Object_Mapper is new
     Util.Serialize.Mappers.Record_Mapper (Element_Type        => Object_Mapper_Context,
                                           Element_Type_Access => Object_Mapper_Context_Access,
                                           Fields              => Object_Field,
                                           Set_Member          => Set_Member);

   JSON_Mapping : aliased Object_Mapper.Mapper;

   --  -----------------------
   --  Serialize the objects defined in the object map Map into the Output
   --  JSON stream.  Use the Name as the name of the JSON object.
   --  -----------------------
   procedure To_JSON (Output : in out Util.Serialize.IO.JSON.Output_Stream'Class;
                      Name   : in String;
                      Map    : in Util.Beans.Objects.Maps.Map) is
      use type Ada.Containers.Count_Type;

      procedure Write (Name  : in String;
                       Value : in Util.Beans.Objects.Object);

      procedure Write (Name  : in String;
                       Value : in Util.Beans.Objects.Object) is
      begin
         Output.Start_Entity (Name => "");
         Output.Write_Attribute (Name  => "name",
                                 Value => Util.Beans.Objects.To_Object (Name));
         Output.Write_Attribute (Name  => "value",
                                 Value => Value);
         Output.End_Entity (Name => "");
      end Write;

   begin
      if Map.Length > 0 then
         declare
            Iter : Util.Beans.Objects.Maps.Cursor := Map.First;
         begin
            Output.Start_Array (Name => Name);
            while Util.Beans.Objects.Maps.Has_Element (Iter) loop
               Util.Beans.Objects.Maps.Query_Element (Iter, Write'Access);
               Util.Beans.Objects.Maps.Next (Iter);
            end loop;
            Output.End_Array (Name => Name);
         end;
      end if;
   end To_JSON;

   --  -----------------------
   --  Serialize the objects defined in the object map Map into an XML stream.
   --  Returns the JSON string that contains a serialization of the object maps.
   --  -----------------------
   function To_JSON (Map : in Util.Beans.Objects.Maps.Map) return String is
      use type Ada.Containers.Count_Type;
   begin
      if Map.Length = 0 then
         return "";
      end if;
      declare
         Buffer : aliased Util.Streams.Texts.Print_Stream;
         Output : Util.Serialize.IO.JSON.Output_Stream;
      begin
         Buffer.Initialize (Size => 10000);
         Output.Initialize (Buffer'Unchecked_Access);
         Output.Start_Document;
         To_JSON (Output, "params", Map);
         Output.End_Document;
         return Util.Streams.Texts.To_String (Util.Streams.Buffered.Buffered_Stream (Buffer));
      end;
   end To_JSON;

   --  -----------------------
   --  Deserializes the JSON content passed in Content and restore the object map
   --  with their values.  The object map passed in Map can contain existing values.
   --  They will be overriden by the JSON values.
   --  -----------------------
   procedure From_JSON (Content : in String;
                        Map     : in out Util.Beans.Objects.Maps.Map) is
      Parser  : Util.Serialize.IO.JSON.Parser;
      Context : aliased Object_Mapper_Context;
   begin
      if Content'Length > 0 then
         Context.Map := Map'Unchecked_Access;
         Parser.Add_Mapping ("/params", JSON_Mapping'Access);
         Object_Mapper.Set_Context (Parser, Context'Unchecked_Access);
         Parser.Parse_String (Content);
      end if;
   end From_JSON;

   --  -----------------------
   --  Deserializes the JSON content passed in Content and restore the object map
   --  with their values.
   --  Returns the object map that was restored.
   --  -----------------------
   function From_JSON (Content : in String) return Util.Beans.Objects.Maps.Map is
      Result  : Util.Beans.Objects.Maps.Map;
   begin
      From_JSON (Content, Result);
      return Result;
   end From_JSON;

begin
   JSON_Mapping.Add_Mapping ("name", FIELD_NAME);
   JSON_Mapping.Add_Mapping ("value", FIELD_VALUE);
end Util.Serialize.Tools;

Update TO_JSON to use a text buffer and configure the json output stream