--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2016 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_Matrices is

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

   function Diagonal (Elements : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      for Index in Elements'Range loop
         Result (Index) (Index) := Elements (Index);
      end loop;
      return Result;
   end Diagonal;

   function Main_Diagonal (Matrix : Matrix_Type) return Vector_Type is
     (Matrix (X) (X), Matrix (Y) (Y), Matrix (Z) (Z), Matrix (W) (W));

   function Trace (Matrix : Matrix_Type) return Element_Type is
     (Vectors.Sum (Main_Diagonal (Matrix)));

   function "*" (Left : Vector_Type; Right : Matrix_Type) return Vector_Type is
      Result : Vector_Type;
   begin
      for Column in Right'Range loop
         Result (Column) := Vectors.Dot (Left, Right (Column));
      end loop;

      return Result;
   end "*";

   function Outer (Left, Right : Vector_Type) return Matrix_Type is
      use Vectors;

      Result : Matrix_Type;
   begin
      for Index in Right'Range loop
         Result (Index) := Right (Index) * Left;
      end loop;

      return Result;
   end Outer;

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

   function T (Offset : Vectors.Point) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (W) := Vector_Type (Offset);
      return Result;
   end T;

   function T (Offset : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (W) := Offset;
      Result (W) (W) := 1.0;
      return Result;
   end T;

   function Rx (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (Y) := (0.0,  CA, SA, 0.0);
      Result (Z) := (0.0, -SA, CA, 0.0);
      return Result;
   end Rx;

   function Ry (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) := (CA, 0.0, -SA, 0.0);
      Result (Z) := (SA, 0.0,  CA, 0.0);
      return Result;
   end Ry;

   function Rz (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) := (CA,  SA, 0.0, 0.0);
      Result (Y) := (-SA, CA, 0.0, 0.0);
      return Result;
   end Rz;

   function R (Axis : Vector_Type; Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);

      MCA : constant Element_Type := 1.0 - CA;

      MCARXY : constant Element_Type := MCA * Axis (X) * Axis (Y);
      MCARXZ : constant Element_Type := MCA * Axis (X) * Axis (Z);
      MCARYZ : constant Element_Type := MCA * Axis (Y) * Axis (Z);

      RXSA : constant Element_Type := Axis (X) * SA;
      RYSA : constant Element_Type := Axis (Y) * SA;
      RZSA : constant Element_Type := Axis (Z) * SA;

      R11 : constant Element_Type := CA + MCA * Axis (X)**2;
      R12 : constant Element_Type := MCARXY + RZSA;
      R13 : constant Element_Type := MCARXZ - RYSA;

      R21 : constant Element_Type := MCARXY - RZSA;
      R22 : constant Element_Type := CA + MCA * Axis (Y)**2;
      R23 : constant Element_Type := MCARYZ + RXSA;

      R31 : constant Element_Type := MCARXZ + RYSA;
      R32 : constant Element_Type := MCARYZ - RXSA;
      R33 : constant Element_Type := CA + MCA * Axis (Z)**2;

      Result : Matrix_Type;
   begin
      Result (X) := (R11, R12, R13, 0.0);
      Result (Y) := (R21, R22, R23, 0.0);
      Result (Z) := (R31, R32, R33, 0.0);
      Result (W) := (0.0, 0.0, 0.0, 1.0);
      return Result;
   end R;

   function R (Quaternion : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) :=
        1.0 - 2.0 * (Quaternion (Y) * Quaternion (Y) + Quaternion (Z) * Quaternion (Z));
      Result (X) (Y) :=
        2.0 * (Quaternion (X) * Quaternion (Y) - Quaternion (Z) * Quaternion (W));
      Result (X) (Z) :=
        2.0 * (Quaternion (X) * Quaternion (Z) + Quaternion (Y) * Quaternion (W));

      Result (Y) (X) :=
        2.0 * (Quaternion (X) * Quaternion (Y) + Quaternion (Z) * Quaternion (W));
      Result (Y) (Y) :=
        1.0 - 2.0 * (Quaternion (X) * Quaternion (X) + Quaternion (Z) * Quaternion (Z));
      Result (Y) (Z) :=
        2.0 * (Quaternion (Y) * Quaternion (Z) - Quaternion (X) * Quaternion (W));

      Result (Z) (X) :=
        2.0 * (Quaternion (X) * Quaternion (Z) - Quaternion (Y) * Quaternion (W));
      Result (Z) (Y) :=
        2.0 * (Quaternion (Y) * Quaternion (Z) + Quaternion (X) * Quaternion (W));
      Result (Z) (Z) :=
        1.0 - 2.0 * (Quaternion (X) * Quaternion (X) + Quaternion (Y) * Quaternion (Y));

      return Result;
   end R;

   function S (Factors : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := Factors (X);
      Result (Y) (Y) := Factors (Y);
      Result (Z) (Z) := Factors (Z);
      return Result;
   end S;

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

   function FOV (Width, Distance : Element_Type) return Element_Type is
     (2.0 * EF.Arctan (Width  / (2.0 * Distance)));

   function Finite_Perspective (FOV, Aspect, Z_Near, Z_Far : Element_Type) return Matrix_Type is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [0, 1] instead of [-1 , 1]
      Result (Z) (Z) := Z_Far / (Z_Near - Z_Far);
      Result (W) (Z) := (Z_Near * Z_Far) / (Z_Near - Z_Far);

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);
      return Result;
   end Finite_Perspective;

   function Infinite_Perspective (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [0, 1] instead of [-1 , 1]
      Result (Z) (Z) := Element_Type (-1.0);
      Result (W) (Z) := -Z_Near;

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);

      return Result;
   end Infinite_Perspective;

   function Infinite_Perspective_Reversed_Z
     (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type
   is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [1, 0] instead of [-1 , 1]
      Result (Z) (Z) := Element_Type (0.0);
      Result (W) (Z) := Z_Near;

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);

      return Result;
   end Infinite_Perspective_Reversed_Z;

   function Orthographic (X_Mag, Y_Mag, Z_Near, Z_Far : Element_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := 2.0 / X_Mag;
      Result (Y) (Y) := 2.0 / Y_Mag;

      --  Depth normalized to [0, 1] instead of [-1, 1]
      Result (Z) (Z) := -1.0 / (Z_Far - Z_Near);
      Result (W) (Z) := -Z_Near / (Z_Far - Z_Near);

      return Result;
   end Orthographic;

end Orka.Transforms.SIMD_Matrices;

--  SPDX-License-Identifier: Apache-2.0
--
--  Copyright (c) 2016 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_Matrices is

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

   function Diagonal (Elements : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      for Index in Elements'Range loop
         Result (Index) (Index) := Elements (Index);
      end loop;
      return Result;
   end Diagonal;

   function Main_Diagonal (Matrix : Matrix_Type) return Vector_Type is
     (Matrix (X) (X), Matrix (Y) (Y), Matrix (Z) (Z), Matrix (W) (W));

   function Trace (Matrix : Matrix_Type) return Element_Type is
     (Vectors.Sum (Main_Diagonal (Matrix)));

   function "*" (Left : Vector_Type; Right : Matrix_Type) return Vector_Type is
      Result : Vector_Type;
   begin
      for Column in Right'Range loop
         Result (Column) := Vectors.Dot (Left, Right (Column));
      end loop;

      return Result;
   end "*";

   function Outer (Left, Right : Vector_Type) return Matrix_Type is
      use Vectors;

      Result : Matrix_Type;
   begin
      for Index in Right'Range loop
         Result (Index) := Right (Index) * Left;
      end loop;

      return Result;
   end Outer;

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

   function T (Offset : Vectors.Point) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (W) := Vector_Type (Offset);
      return Result;
   end T;

   function T (Offset : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (W) := Offset;
      Result (W) (W) := 1.0;
      return Result;
   end T;

   function Rx (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (Y) := (0.0,  CA, SA, 0.0);
      Result (Z) := (0.0, -SA, CA, 0.0);
      return Result;
   end Rx;

   function Ry (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) := (CA, 0.0, -SA, 0.0);
      Result (Z) := (SA, 0.0,  CA, 0.0);
      return Result;
   end Ry;

   function Rz (Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) := (CA,  SA, 0.0, 0.0);
      Result (Y) := (-SA, CA, 0.0, 0.0);
      return Result;
   end Rz;

   function R (Axis : Vector_Type; Angle : Element_Type) return Matrix_Type is
      CA : constant Element_Type := EF.Cos (Angle);
      SA : constant Element_Type := EF.Sin (Angle);

      MCA : constant Element_Type := 1.0 - CA;

      MCARXY : constant Element_Type := MCA * Axis (X) * Axis (Y);
      MCARXZ : constant Element_Type := MCA * Axis (X) * Axis (Z);
      MCARYZ : constant Element_Type := MCA * Axis (Y) * Axis (Z);

      RXSA : constant Element_Type := Axis (X) * SA;
      RYSA : constant Element_Type := Axis (Y) * SA;
      RZSA : constant Element_Type := Axis (Z) * SA;

      R11 : constant Element_Type := CA + MCA * Axis (X)**2;
      R12 : constant Element_Type := MCARXY + RZSA;
      R13 : constant Element_Type := MCARXZ - RYSA;

      R21 : constant Element_Type := MCARXY - RZSA;
      R22 : constant Element_Type := CA + MCA * Axis (Y)**2;
      R23 : constant Element_Type := MCARYZ + RXSA;

      R31 : constant Element_Type := MCARXZ + RYSA;
      R32 : constant Element_Type := MCARYZ - RXSA;
      R33 : constant Element_Type := CA + MCA * Axis (Z)**2;

      Result : Matrix_Type;
   begin
      Result (X) := (R11, R12, R13, 0.0);
      Result (Y) := (R21, R22, R23, 0.0);
      Result (Z) := (R31, R32, R33, 0.0);
      Result (W) := (0.0, 0.0, 0.0, 1.0);
      return Result;
   end R;

   function R (Quaternion : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;

      Q_X : constant Element_Type := Quaternion (X);
      Q_Y : constant Element_Type := Quaternion (Y);
      Q_Z : constant Element_Type := Quaternion (Z);
      Q_W : constant Element_Type := Quaternion (W);

      S : constant := 2.0;
      --  S = 2 / Norm (Quaternion)
   begin
      Result (X) (X) := 1.0 - S * (Q_Y * Q_Y + Q_Z * Q_Z);
      Result (X) (Y) := S * (Q_X * Q_Y - Q_Z * Q_W);
      Result (X) (Z) := S * (Q_X * Q_Z + Q_Y * Q_W);

      Result (Y) (X) := S * (Q_X * Q_Y + Q_Z * Q_W);
      Result (Y) (Y) := 1.0 - S * (Q_X * Q_X + Q_Z * Q_Z);
      Result (Y) (Z) := S * (Q_Y * Q_Z - Q_X * Q_W);

      Result (Z) (X) := S * (Q_X * Q_Z - Q_Y * Q_W);
      Result (Z) (Y) := S * (Q_Y * Q_Z + Q_X * Q_W);
      Result (Z) (Z) := 1.0 - S * (Q_X * Q_X + Q_Y * Q_Y);

      return Result;
   end R;

   function S (Factors : Vector_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := Factors (X);
      Result (Y) (Y) := Factors (Y);
      Result (Z) (Z) := Factors (Z);
      return Result;
   end S;

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

   function FOV (Width, Distance : Element_Type) return Element_Type is
     (2.0 * EF.Arctan (Width  / (2.0 * Distance)));

   function Finite_Perspective (FOV, Aspect, Z_Near, Z_Far : Element_Type) return Matrix_Type is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [0, 1] instead of [-1 , 1]
      Result (Z) (Z) := Z_Far / (Z_Near - Z_Far);
      Result (W) (Z) := (Z_Near * Z_Far) / (Z_Near - Z_Far);

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);
      return Result;
   end Finite_Perspective;

   function Infinite_Perspective (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [0, 1] instead of [-1 , 1]
      Result (Z) (Z) := Element_Type (-1.0);
      Result (W) (Z) := -Z_Near;

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);

      return Result;
   end Infinite_Perspective;

   function Infinite_Perspective_Reversed_Z
     (FOV, Aspect, Z_Near : Element_Type) return Matrix_Type
   is
      F : constant Element_Type := 1.0 / EF.Tan (0.5 * FOV);
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := F / Aspect;
      Result (Y) (Y) := F;

      --  Depth normalized to [1, 0] instead of [-1 , 1]
      Result (Z) (Z) := Element_Type (0.0);
      Result (W) (Z) := Z_Near;

      Result (Z) (W) := Element_Type (-1.0);
      Result (W) (W) := Element_Type (0.0);

      return Result;
   end Infinite_Perspective_Reversed_Z;

   function Orthographic (X_Mag, Y_Mag, Z_Near, Z_Far : Element_Type) return Matrix_Type is
      Result : Matrix_Type := Identity_Matrix;
   begin
      Result (X) (X) := 2.0 / X_Mag;
      Result (Y) (Y) := 2.0 / Y_Mag;

      --  Depth normalized to [0, 1] instead of [-1, 1]
      Result (Z) (Z) := -1.0 / (Z_Far - Z_Near);
      Result (W) (Z) := -Z_Near / (Z_Far - Z_Near);

      return Result;
   end Orthographic;

end Orka.Transforms.SIMD_Matrices;

transforms: Simplify function R converting a quaternion to a matrix

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


-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  Copyright (C) 2014, 2015 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.Strings;
with MAT.Formats;
package body MAT.Consoles is

   --  ------------------------------
   --  Print the title for the given field and setup the associated field size.
   --  ------------------------------
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive) is
   begin
      Console.Sizes (Field) := Length;
      if Console.Field_Count >= 1 then
         Console.Cols (Field) := Console.Cols (Console.Fields (Console.Field_Count))
           + Console.Sizes (Console.Fields (Console.Field_Count));
      else
         Console.Cols (Field) := 1;
      end if;
      Console.Field_Count := Console.Field_Count + 1;
      Console.Fields (Console.Field_Count) := Field;
      Console_Type'Class (Console).Print_Title (Field, Title);
   end Print_Title;

   --  ------------------------------
   --  Format the address and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr) is
      Value : constant String := MAT.Formats.Addr (Addr);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Field;

   --  ------------------------------
   --  Format the address range and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          From    : in MAT.Types.Target_Addr;
                          To      : in MAT.Types.Target_Addr) is
      From_Value : constant String := MAT.Formats.Addr (From);
      To_Value   : constant String := MAT.Formats.Addr (To);
   begin
      Console_Type'Class (Console).Print_Field (Field, From_Value & "-" & To_Value);
   end Print_Field;

   --  ------------------------------
   --  Format the size and print it for the given field.
   --  ------------------------------
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size) is
      Value : constant String := MAT.Formats.Size (Size);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Size;

   --  ------------------------------
   --  Format the thread information and print it for the given field.
   --  ------------------------------
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref) is
      Value : constant String := MAT.Types.Target_Thread_Ref'Image (Thread);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Thread;

   --  ------------------------------
   --  Format the time tick as a duration and print it for the given field.
   --  ------------------------------
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref) is
      Value : constant String := MAT.Formats.Duration (Duration);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Duration;

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT) is
      Val : constant String := Util.Strings.Image (Value);
   begin
      Console_Type'Class (Console).Print_Field (Field, Val, Justify);
   end Print_Field;

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT) is
      Item : String := Ada.Strings.Unbounded.To_String (Value);
      Size : constant Natural := Console.Sizes (Field);
   begin
      if Size <= Item'Length then
         Item (Item'Last - Size + 2 .. Item'Last - Size + 4) := "...";
         Console_Type'Class (Console).Print_Field (Field,
                                                   Item (Item'Last - Size + 2 .. Item'Last));
      else
         Console_Type'Class (Console).Print_Field (Field, Item, Justify);
      end if;
   end Print_Field;

end MAT.Consoles;

-----------------------------------------------------------------------
--  mat-consoles - Console interface
--  Copyright (C) 2014, 2015 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.Strings;
with MAT.Formats;
package body MAT.Consoles is

   --  ------------------------------
   --  Print the title for the given field and setup the associated field size.
   --  ------------------------------
   procedure Print_Title (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Title   : in String;
                          Length  : in Positive) is
   begin
      Console.Sizes (Field) := Length;
      if Console.Field_Count >= 1 then
         Console.Cols (Field) := Console.Cols (Console.Fields (Console.Field_Count))
           + Console.Sizes (Console.Fields (Console.Field_Count));
      else
         Console.Cols (Field) := 1;
      end if;
      Console.Field_Count := Console.Field_Count + 1;
      Console.Fields (Console.Field_Count) := Field;
      Console_Type'Class (Console).Print_Title (Field, Title);
   end Print_Title;

   --  ------------------------------
   --  Format the address and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Addr    : in MAT.Types.Target_Addr) is
      Value : constant String := MAT.Formats.Addr (Addr);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Field;

   --  ------------------------------
   --  Format the address range and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          From    : in MAT.Types.Target_Addr;
                          To      : in MAT.Types.Target_Addr) is
      From_Value : constant String := MAT.Formats.Addr (From);
      To_Value   : constant String := MAT.Formats.Addr (To);
   begin
      Console_Type'Class (Console).Print_Field (Field, From_Value & "-" & To_Value);
   end Print_Field;

   --  ------------------------------
   --  Format the size and print it for the given field.
   --  ------------------------------
   procedure Print_Size (Console : in out Console_Type;
                         Field   : in Field_Type;
                         Size    : in MAT.Types.Target_Size) is
      Value : constant String := MAT.Formats.Size (Size);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Size;

   --  ------------------------------
   --  Format the thread information and print it for the given field.
   --  ------------------------------
   procedure Print_Thread (Console : in out Console_Type;
                           Field   : in Field_Type;
                           Thread  : in MAT.Types.Target_Thread_Ref) is
      Value : constant String := MAT.Types.Target_Thread_Ref'Image (Thread);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Thread;

   --  ------------------------------
   --  Format the time tick as a duration and print it for the given field.
   --  ------------------------------
   procedure Print_Duration (Console  : in out Console_Type;
                             Field    : in Field_Type;
                             Duration : in MAT.Types.Target_Tick_Ref) is
      Value : constant String := MAT.Formats.Duration (Duration);
   begin
      Console_Type'Class (Console).Print_Field (Field, Value);
   end Print_Duration;

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Integer;
                          Justify : in Justify_Type := J_LEFT) is
      Val : constant String := Util.Strings.Image (Value);
   begin
      Console_Type'Class (Console).Print_Field (Field, Val, Justify);
   end Print_Field;

   --  ------------------------------
   --  Format the integer and print it for the given field.
   --  ------------------------------
   procedure Print_Field (Console : in out Console_Type;
                          Field   : in Field_Type;
                          Value   : in Ada.Strings.Unbounded.Unbounded_String;
                          Justify : in Justify_Type := J_LEFT) is
      Item : String := Ada.Strings.Unbounded.To_String (Value);
      Size : constant Natural := Console.Sizes (Field);
   begin
      if Size <= Item'Length then
         Item (Item'Last - Size + 2 .. Item'Last - Size + 4) := "...";
         Console_Type'Class (Console).Print_Field (Field,
                                                   Item (Item'Last - Size + 2 .. Item'Last));
      else
         Console_Type'Class (Console).Print_Field (Field, Item, Justify);
      end if;
   end Print_Field;

   --  ------------------------------
   --  Get the field count that was setup through the Print_Title calls.
   --  ------------------------------
   function Get_Field_Count (Console : in Console_Type) return Natural is
   begin
      return Console.Field_Count;
   end Get_Field_Count;

end MAT.Consoles;

Implement the Get_Field_Count function

Implement the Get_Field_Count function


-----------------------------------------------------------------------
--  util-refs -- Reference Counting
--  Copyright (C) 2010, 2011, 2015, 2019 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.Finalization;
with Util.Concurrent.Counters;

--  The Util.Refs package provides support to implement object reference counting.
--
--  The data type to share through reference counting has to inherit from Ref_Entity
--  and the generic package References has to be instantiated.
--

--    type Data is new Util.Refs.Ref_Entity with record ... end record;
--    type Data_Access is access all Data;
--
--    package Data_Ref is new Utils.Refs.References (Data, Data_Access);
--

--
--  The reference is used as follows:
--
--

--     D  : Data_Ref.Ref := Data_Ref.Create;  --  Allocate and get a reference
--     D2 : Data_Ref.Ref := D;                --  Share reference
--     D.Value.XXXX  := 0;                    --  Set data member XXXX
--

--
--  When a reference is shared in a multi-threaded environment, the reference has to
--  be protected by using the References.Atomic_Ref type.
--
--     R : Data_Ref.Atomic_Ref;
--
--  The reference is then obtained by the protected operation Get.
--
--     D : Data_Ref.Ref := R.Get;
--
package Util.Refs is

   pragma Preelaborate;

   --  Root of referenced objects.
   type Ref_Entity is abstract tagged limited private;

   --  Finalize the referenced object.  This is called before the object is freed.
   procedure Finalize (Object : in out Ref_Entity) is null;

   generic
      type Element_Type (<>) is new Ref_Entity with private;
      type Element_Access is access all Element_Type;
   package Indefinite_References is

      type Element_Accessor (Element : not null access Element_Type) is limited private
        with Implicit_Dereference => Element;

      type Ref is new Ada.Finalization.Controlled with private;

      --  Create an element and return a reference to that element.
      function Create (Value : in Element_Access) return Ref;

      function Value (Object : in Ref'Class) return Element_Accessor with Inline_Always;

      --  Returns true if the reference does not contain any element.
      function Is_Null (Object : in Ref'Class) return Boolean with Inline_Always;

      function "=" (Left, Right : in Ref'Class) return Boolean with Inline_Always;

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set
      generic
      package Atomic is
         protected type Atomic_Ref is
            --  Get the reference
            function Get return Ref;

            --  Change the reference
            procedure Set (Object : in Ref);
         private
            Value : Ref;
         end Atomic_Ref;
      end Atomic;

   private

      type Element_Accessor (Element : not null access Element_Type) is null record;

      type Ref is new Ada.Finalization.Controlled with record
         Target : Element_Access := null;
      end record;

      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      overriding
      procedure Finalize (Obj : in out Ref);

      --  Update the reference counter after an assignment.
      overriding
      procedure Adjust (Obj : in out Ref);

   end Indefinite_References;

   generic
      type Element_Type is new Ref_Entity with private;
      type Element_Access is access all Element_Type;
   package References is
      package IR is new Indefinite_References (Element_Type, Element_Access);

      subtype Ref is IR.Ref;
      subtype Element_Accessor is IR.Element_Accessor;

      --  Create an element and return a reference to that element.
      function Create return Ref;

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set

   end References;

   generic
      type Element_Type is limited private;
      with procedure Finalize (Object : in out Element_Type) is null;
   package General_References is

      type Element_Accessor (Element : not null access Element_Type) is limited private
        with Implicit_Dereference => Element;

      type Ref is new Ada.Finalization.Controlled with private;

      --  Create an element and return a reference to that element.
      function Create return Ref;

      function Value (Object : in Ref'Class) return Element_Accessor with Inline_Always;

      --  Returns true if the reference does not contain any element.
      function Is_Null (Object : in Ref'Class) return Boolean with Inline_Always;

      function "=" (Left, Right : in Ref'Class) return Boolean with Inline_Always;

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set
      generic
      package Atomic is
         protected type Atomic_Ref is
            --  Get the reference
            function Get return Ref;

            --  Change the reference
            procedure Set (Object : in Ref);
         private
            Value : Ref;
         end Atomic_Ref;
      end Atomic;

   private

      type Element_Accessor (Element : not null access Element_Type) is null record;

      type Ref_Data is limited record
         Ref_Counter : Util.Concurrent.Counters.Counter;
         Data        : aliased Element_Type;
      end record;
      type Ref_Data_Access is access all Ref_Data;

      type Ref is new Ada.Finalization.Controlled with record
         Target : Ref_Data_Access := null;
      end record;

      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      overriding
      procedure Finalize (Obj : in out Ref);

      --  Update the reference counter after an assignment.
      overriding
      procedure Adjust (Obj : in out Ref);

   end General_References;

private

   type Ref_Entity is abstract tagged limited record
      Ref_Counter : Util.Concurrent.Counters.Counter;
   end record;

end Util.Refs;

-----------------------------------------------------------------------
--  util-refs -- Reference Counting
--  Copyright (C) 2010, 2011, 2015, 2019 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.Finalization;
with Util.Concurrent.Counters;

--  The Util.Refs package provides support to implement object reference counting.
--
--  The data type to share through reference counting has to inherit from Ref_Entity
--  and the generic package References has to be instantiated.
--

--    type Data is new Util.Refs.Ref_Entity with record ... end record;
--    type Data_Access is access all Data;
--
--    package Data_Ref is new Utils.Refs.References (Data, Data_Access);
--

--
--  The reference is used as follows:
--
--

--     D  : Data_Ref.Ref := Data_Ref.Create;  --  Allocate and get a reference
--     D2 : Data_Ref.Ref := D;                --  Share reference
--     D.Value.XXXX  := 0;                    --  Set data member XXXX
--

--
--  When a reference is shared in a multi-threaded environment, the reference has to
--  be protected by using the References.Atomic_Ref type.
--
--     R : Data_Ref.Atomic_Ref;
--
--  The reference is then obtained by the protected operation Get.
--
--     D : Data_Ref.Ref := R.Get;
--
package Util.Refs is

   pragma Preelaborate;

   --  Root of referenced objects.
   type Ref_Entity is abstract tagged limited private;

   --  Finalize the referenced object.  This is called before the object is freed.
   procedure Finalize (Object : in out Ref_Entity) is null;

   generic
      type Element_Type (<>) is new Ref_Entity with private;
      type Element_Access is access all Element_Type;
   package Indefinite_References is

      type Element_Accessor (Element : not null access Element_Type) is limited private
        with Implicit_Dereference => Element;

      type Ref is new Ada.Finalization.Controlled with private;

      --  Create an element and return a reference to that element.
      function Create (Value : in Element_Access) return Ref;

      function Value (Object : in Ref'Class) return Element_Accessor with Inline;

      --  Returns true if the reference does not contain any element.
      function Is_Null (Object : in Ref'Class) return Boolean with Inline_Always;

      function "=" (Left, Right : in Ref'Class) return Boolean with Inline_Always;

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set
      generic
      package Atomic is
         protected type Atomic_Ref is
            --  Get the reference
            function Get return Ref;

            --  Change the reference
            procedure Set (Object : in Ref);
         private
            Value : Ref;
         end Atomic_Ref;
      end Atomic;

   private

      type Element_Accessor (Element : not null access Element_Type) is null record;

      type Ref is new Ada.Finalization.Controlled with record
         Target : Element_Access := null;
      end record;

      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      overriding
      procedure Finalize (Obj : in out Ref);

      --  Update the reference counter after an assignment.
      overriding
      procedure Adjust (Obj : in out Ref);

   end Indefinite_References;

   generic
      type Element_Type is new Ref_Entity with private;
      type Element_Access is access all Element_Type;
   package References is
      package IR is new Indefinite_References (Element_Type, Element_Access);

      subtype Ref is IR.Ref;
      subtype Element_Accessor is IR.Element_Accessor;

      --  Create an element and return a reference to that element.
      function Create return Ref;

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set

   end References;

   generic
      type Element_Type is limited private;
      with procedure Finalize (Object : in out Element_Type) is null;
   package General_References is

      type Element_Accessor (Element : not null access Element_Type) is limited private
        with Implicit_Dereference => Element;

      type Ref is new Ada.Finalization.Controlled with private;

      --  Create an element and return a reference to that element.
      function Create return Ref;

      function Value (Object : in Ref'Class) return Element_Accessor with Inline_Always;

      --  Returns true if the reference does not contain any element.
      function Is_Null (Object : in Ref'Class) return Boolean with Inline_Always;

      function "=" (Left, Right : in Ref'Class) return Boolean with Inline_Always;

      --  The Atomic_Ref protected type defines a reference to an
      --  element which can be obtained and changed atomically.  The default
      --  Ada construct:
      --
      --     Ref1 := Ref2;
      --
      --  does not guarantee atomicity of the copy (assignment) and the increment
      --  of the reference counter (Adjust operation).  To replace shared reference
      --  by another one, the whole assignment and Adjust have to be protected.
      --  This is achieved by this protected type through the Get and Set
      generic
      package Atomic is
         protected type Atomic_Ref is
            --  Get the reference
            function Get return Ref;

            --  Change the reference
            procedure Set (Object : in Ref);
         private
            Value : Ref;
         end Atomic_Ref;
      end Atomic;

   private

      type Element_Accessor (Element : not null access Element_Type) is null record;

      type Ref_Data is limited record
         Ref_Counter : Util.Concurrent.Counters.Counter;
         Data        : aliased Element_Type;
      end record;
      type Ref_Data_Access is access all Ref_Data;

      type Ref is new Ada.Finalization.Controlled with record
         Target : Ref_Data_Access := null;
      end record;

      --  Release the reference.  Invoke Finalize and free the storage if it was
      --  the last reference.
      overriding
      procedure Finalize (Obj : in out Ref);

      --  Update the reference counter after an assignment.
      overriding
      procedure Adjust (Obj : in out Ref);

   end General_References;

private

   type Ref_Entity is abstract tagged limited record
      Ref_Counter : Util.Concurrent.Counters.Counter;
   end record;

end Util.Refs;

Remove Inline_Always for the Value since it does not compile with gcc 5 on Ubuntu 16.04


-----------------------------------------------------------------------
--  asf.servlets.files -- Static file servlet
--  Copyright (C) 2010, 2011, 2013 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.Files;
with Util.Strings;
with Util.Streams;
with Util.Streams.Files;
with Ada.Streams;
with Ada.Streams.Stream_IO;

with Ada.Directories;

with ASF.Streams;
with ASF.Applications;
package body ASF.Servlets.Files is

   use Ada.Streams;
   use Ada.Streams.Stream_IO;
   use Ada.Directories;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out File_Servlet;
                         Context : in Servlet_Registry'Class) is
      Dir      : constant String := Context.Get_Init_Parameter (ASF.Applications.VIEW_DIR);
      Def_Type : constant String := Context.Get_Init_Parameter ("content-type.default");
   begin
      Server.Dir := new String '(Dir);
      Server.Default_Content_Type := new String '(Def_Type);
   end Initialize;

   --  ------------------------------
   --  Returns the time the Request object was last modified, in milliseconds since
   --  midnight January 1, 1970 GMT.  If the time is unknown, this method returns
   --  a negative number (the default).
   --
   --  Servlets that support HTTP GET requests and can quickly determine their
   --  last modification time should override this method. This makes browser and
   --  proxy caches work more effectively, reducing the load on server and network
   --  resources.
   --  ------------------------------
   function Get_Last_Modified (Server  : in File_Servlet;
                               Request : in Requests.Request'Class)
                               return Ada.Calendar.Time is
      pragma Unreferenced (Server, Request);
   begin
      return Ada.Calendar.Clock;
   end Get_Last_Modified;

   --  ------------------------------
   --  Set the content type associated with the given file
   --  ------------------------------
   procedure Set_Content_Type (Server   : in File_Servlet;
                               Path     : in String;
                               Response : in out Responses.Response'Class) is
      Pos : constant Natural := Util.Strings.Rindex (Path, '.');
   begin
      if Pos = 0 then
         Response.Set_Content_Type (Server.Default_Content_Type.all);
         return;
      end if;
      if Path (Pos .. Path'Last) = ".css" then
         Response.Set_Content_Type ("text/css");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".js" then
         Response.Set_Content_Type ("text/javascript");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".html" then
         Response.Set_Content_Type ("text/html");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".txt" then
         Response.Set_Content_Type ("text/plain");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".png" then
         Response.Set_Content_Type ("image/png");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".jpg" then
         Response.Set_Content_Type ("image/jpg");
         return;
      end if;
   end Set_Content_Type;

   --  ------------------------------
   --  Called by the server (via the service method) to allow a servlet to handle
   --  a GET request.
   --
   --  Overriding this method to support a GET request also automatically supports
   --  an HTTP HEAD request. A HEAD request is a GET request that returns no body
   --  in the response, only the request header fields.
   --
   --  When overriding this method, read the request data, write the response headers,
   --  get the response's writer or output stream object, and finally, write the
   --  response data. It's best to include content type and encoding.
   --  When using a PrintWriter object to return the response, set the content type
   --  before accessing the PrintWriter object.
   --
   --  The servlet container must write the headers before committing the response,
   --  because in HTTP the headers must be sent before the response body.
   --
   --  Where possible, set the Content-Length header (with the
   --  Response.Set_Content_Length method), to allow the servlet container
   --  to use a persistent connection to return its response to the client,
   --  improving performance. The content length is automatically set if the entire
   --  response fits inside the response buffer.
   --
   --  When using HTTP 1.1 chunked encoding (which means that the response has a
   --  Transfer-Encoding header), do not set the Content-Length header.
   --
   --  The GET method should be safe, that is, without any side effects for which
   --  users are held responsible. For example, most form queries have no side effects.
   --  If a client request is intended to change stored data, the request should use
   --  some other HTTP method.
   --
   --  The GET method should also be idempotent, meaning that it can be safely repeated.
   --  Sometimes making a method safe also makes it idempotent. For example, repeating
   --  queries is both safe and idempotent, but buying a product online or modifying
   --  data is neither safe nor idempotent.
   --
   --  If the request is incorrectly formatted, Do_Get  returns an HTTP "Bad Request"
   --  ------------------------------
   procedure Do_Get (Server   : in File_Servlet;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is

      use Util.Files;

      URI  : constant String := Request.Get_Path_Info;
      Path : constant String := Find_File_Path (Name => URI, Paths => Server.Dir.all);
   begin
      if not Ada.Directories.Exists (Path)
        or else Ada.Directories.Kind (Path) /= Ada.Directories.Ordinary_File then
         Response.Send_Error (Responses.SC_NOT_FOUND);
         return;
      end if;

      File_Servlet'Class (Server).Set_Content_Type (Path, Response);
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Input  : Util.Streams.Files.File_Stream;
      begin
         Input.Open (Name => Path, Mode => In_File);
         Util.Streams.Copy (From => Input, Into => Output);
      end;
   end Do_Get;

end ASF.Servlets.Files;

-----------------------------------------------------------------------
--  asf.servlets.files -- Static file servlet
--  Copyright (C) 2010, 2011, 2013, 2015 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.Files;
with Util.Strings;
with Util.Streams;
with Util.Streams.Files;
with Ada.Streams;
with Ada.Streams.Stream_IO;

with Ada.Directories;

with ASF.Streams;
with ASF.Applications;
package body ASF.Servlets.Files is

   use Ada.Streams;
   use Ada.Streams.Stream_IO;
   use Ada.Directories;

   --  ------------------------------
   --  Called by the servlet container to indicate to a servlet that the servlet
   --  is being placed into service.
   --  ------------------------------
   procedure Initialize (Server  : in out File_Servlet;
                         Context : in Servlet_Registry'Class) is
      Dir      : constant String := Context.Get_Init_Parameter (ASF.Applications.VIEW_DIR);
      Def_Type : constant String := Context.Get_Init_Parameter ("content-type.default");
   begin
      Server.Dir := new String '(Dir);
      Server.Default_Content_Type := new String '(Def_Type);
   end Initialize;

   --  ------------------------------
   --  Returns the time the Request object was last modified, in milliseconds since
   --  midnight January 1, 1970 GMT.  If the time is unknown, this method returns
   --  a negative number (the default).
   --
   --  Servlets that support HTTP GET requests and can quickly determine their
   --  last modification time should override this method. This makes browser and
   --  proxy caches work more effectively, reducing the load on server and network
   --  resources.
   --  ------------------------------
   function Get_Last_Modified (Server  : in File_Servlet;
                               Request : in Requests.Request'Class)
                               return Ada.Calendar.Time is
      pragma Unreferenced (Server, Request);
   begin
      return Ada.Calendar.Clock;
   end Get_Last_Modified;

   --  ------------------------------
   --  Set the content type associated with the given file
   --  ------------------------------
   procedure Set_Content_Type (Server   : in File_Servlet;
                               Path     : in String;
                               Response : in out Responses.Response'Class) is
      Pos : constant Natural := Util.Strings.Rindex (Path, '.');
   begin
      if Pos = 0 then
         Response.Set_Content_Type (Server.Default_Content_Type.all);
         return;
      end if;
      if Path (Pos .. Path'Last) = ".css" then
         Response.Set_Content_Type ("text/css");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".js" then
         Response.Set_Content_Type ("text/javascript");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".html" then
         Response.Set_Content_Type ("text/html");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".txt" then
         Response.Set_Content_Type ("text/plain");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".png" then
         Response.Set_Content_Type ("image/png");
         return;
      end if;
      if Path (Pos .. Path'Last) = ".jpg" then
         Response.Set_Content_Type ("image/jpg");
         return;
      end if;
      Response.Set_Content_Type (Server.Default_Content_Type.all);
   end Set_Content_Type;

   --  ------------------------------
   --  Called by the server (via the service method) to allow a servlet to handle
   --  a GET request.
   --
   --  Overriding this method to support a GET request also automatically supports
   --  an HTTP HEAD request. A HEAD request is a GET request that returns no body
   --  in the response, only the request header fields.
   --
   --  When overriding this method, read the request data, write the response headers,
   --  get the response's writer or output stream object, and finally, write the
   --  response data. It's best to include content type and encoding.
   --  When using a PrintWriter object to return the response, set the content type
   --  before accessing the PrintWriter object.
   --
   --  The servlet container must write the headers before committing the response,
   --  because in HTTP the headers must be sent before the response body.
   --
   --  Where possible, set the Content-Length header (with the
   --  Response.Set_Content_Length method), to allow the servlet container
   --  to use a persistent connection to return its response to the client,
   --  improving performance. The content length is automatically set if the entire
   --  response fits inside the response buffer.
   --
   --  When using HTTP 1.1 chunked encoding (which means that the response has a
   --  Transfer-Encoding header), do not set the Content-Length header.
   --
   --  The GET method should be safe, that is, without any side effects for which
   --  users are held responsible. For example, most form queries have no side effects.
   --  If a client request is intended to change stored data, the request should use
   --  some other HTTP method.
   --
   --  The GET method should also be idempotent, meaning that it can be safely repeated.
   --  Sometimes making a method safe also makes it idempotent. For example, repeating
   --  queries is both safe and idempotent, but buying a product online or modifying
   --  data is neither safe nor idempotent.
   --
   --  If the request is incorrectly formatted, Do_Get  returns an HTTP "Bad Request"
   --  ------------------------------
   procedure Do_Get (Server   : in File_Servlet;
                     Request  : in out Requests.Request'Class;
                     Response : in out Responses.Response'Class) is

      use Util.Files;

      URI  : constant String := Request.Get_Path_Info;
      Path : constant String := Find_File_Path (Name => URI, Paths => Server.Dir.all);
   begin
      if not Ada.Directories.Exists (Path)
        or else Ada.Directories.Kind (Path) /= Ada.Directories.Ordinary_File
      then
         Response.Send_Error (Responses.SC_NOT_FOUND);
         return;
      end if;

      File_Servlet'Class (Server).Set_Content_Type (Path, Response);
      declare
         Output : ASF.Streams.Print_Stream := Response.Get_Output_Stream;
         Input  : Util.Streams.Files.File_Stream;
      begin
         Input.Open (Name => Path, Mode => In_File);
         Util.Streams.Copy (From => Input, Into => Output);
      end;
   end Do_Get;

end ASF.Servlets.Files;

Use the default content type when the file extension is not recognized


-----------------------------------------------------------------------
--  security-oauth -- OAuth Security
--  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.
-----------------------------------------------------------------------

--  == OAuth ==
--  The <b>Security.OAuth</b> package defines and implements the OAuth 2.0 authorization
--  framework as defined by the IETF working group.
--  See http://tools.ietf.org/html/draft-ietf-oauth-v2-26
package Security.OAuth is

   --  OAuth 2.0: Section 10.2.2. Initial Registry Contents
   --  RFC 6749: 11.2.2.  Initial Registry Contents
   CLIENT_ID         : constant String := "client_id";
   CLIENT_SECRET     : constant String := "client_secret";
   RESPONSE_TYPE     : constant String := "response_type";
   REDIRECT_URI      : constant String := "redirect_uri";
   SCOPE             : constant String := "scope";
   STATE             : constant String := "state";
   CODE              : constant String := "code";
   ERROR_DESCRIPTION : constant String := "error_description";
   ERROR_URI         : constant String := "error_uri";
   GRANT_TYPE        : constant String := "grant_type";
   ACCESS_TOKEN      : constant String := "access_token";
   TOKEN_TYPE        : constant String := "token_type";
   EXPIRES_IN        : constant String := "expires_in";
   USERNAME          : constant String := "username";
   PASSWORD          : constant String := "password";
   REFRESH_TOKEN     : constant String := "refresh_token";

   --  RFC 6749: 5.2.  Error Response
   INVALID_REQUEST        : aliased constant String := "invalid_request";
   INVALID_CLIENT         : aliased constant String := "invalid_client";
   INVALID_GRANT          : aliased constant String := "invalid_grant";
   UNAUTHORIZED_CLIENT    : aliased constant String := "unauthorized_client";
   UNSUPPORTED_GRANT_TYPE : aliased constant String := "unsupported_grant_type";
   INVALID_SCOPE          : aliased constant String := "invalid_scope";

   --  RFC 6749: 4.1.2.1.  Error Response
   ACCESS_DENIED             : aliased constant String := "access_denied";
   UNSUPPORTED_RESPONSE_TYPE : aliased constant String := "unsupported_response_type";
   SERVER_ERROR              : aliased constant String := "server_error";
   TEMPORARILY_UNAVAILABLE   : aliased constant String := "temporarily_unavailable";

end Security.OAuth;

-----------------------------------------------------------------------
--  security-oauth -- OAuth Security
--  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.Strings.Unbounded;

--  == OAuth ==
--  The Security.OAuth package defines and implements the OAuth 2.0 authorization
--  framework as defined by the IETF working group.
--  See http://tools.ietf.org/html/draft-ietf-oauth-v2-26
package Security.OAuth is

   --  OAuth 2.0: Section 10.2.2. Initial Registry Contents
   --  RFC 6749: 11.2.2.  Initial Registry Contents
   CLIENT_ID         : constant String := "client_id";
   CLIENT_SECRET     : constant String := "client_secret";
   RESPONSE_TYPE     : constant String := "response_type";
   REDIRECT_URI      : constant String := "redirect_uri";
   SCOPE             : constant String := "scope";
   STATE             : constant String := "state";
   CODE              : constant String := "code";
   ERROR_DESCRIPTION : constant String := "error_description";
   ERROR_URI         : constant String := "error_uri";
   GRANT_TYPE        : constant String := "grant_type";
   ACCESS_TOKEN      : constant String := "access_token";
   TOKEN_TYPE        : constant String := "token_type";
   EXPIRES_IN        : constant String := "expires_in";
   USERNAME          : constant String := "username";
   PASSWORD          : constant String := "password";
   REFRESH_TOKEN     : constant String := "refresh_token";

   --  RFC 6749: 5.2.  Error Response
   INVALID_REQUEST        : aliased constant String := "invalid_request";
   INVALID_CLIENT         : aliased constant String := "invalid_client";
   INVALID_GRANT          : aliased constant String := "invalid_grant";
   UNAUTHORIZED_CLIENT    : aliased constant String := "unauthorized_client";
   UNSUPPORTED_GRANT_TYPE : aliased constant String := "unsupported_grant_type";
   INVALID_SCOPE          : aliased constant String := "invalid_scope";

   --  RFC 6749: 4.1.2.1.  Error Response
   ACCESS_DENIED             : aliased constant String := "access_denied";
   UNSUPPORTED_RESPONSE_TYPE : aliased constant String := "unsupported_response_type";
   SERVER_ERROR              : aliased constant String := "server_error";
   TEMPORARILY_UNAVAILABLE   : aliased constant String := "temporarily_unavailable";

   --  ------------------------------
   --  Application
   --  ------------------------------
   --  The Application holds the necessary information to let a user
   --  grant access to its protected resources on the resource server.  It contains
   --  information that allows the OAuth authorization server to identify the
   --  application (client id and secret key).
   type Application is tagged private;

private

   type Application is tagged record
      Client_Id   : Ada.Strings.Unbounded.Unbounded_String;
      Secret      : Ada.Strings.Unbounded.Unbounded_String;
      Callback    : Ada.Strings.Unbounded.Unbounded_String;
   end record;

end Security.OAuth;

Move the declaration of the Application type from OAuth.Clients to the OAuth package so that the definition can be shared between OAuth.Clients and OAuth.Servers


-----------------------------------------------------------------------
--  gen-artifacts-docs -- Artifact for documentation
--  Copyright (C) 2012 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.Indefinite_Vectors;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Strings.Unbounded;

with DOM.Core;
with Gen.Model.Packages;

--  The Gen.Artifacts.Docs package is an artifact for the generation of
--  application documentation.  Its purpose is to scan the project source files
--  and extract some interesting information for a developer's guide.  The artifact
--  scans the Ada source files, the XML configuration files, the XHTML files.
--
--  The generated documentation is intended to be published on a web site.
--  The Google Wiki style is generated by default.
--
--  1/ In the first step, the project files are scanned and the useful
--     documentation is extracted.
--
--  2/ In the second step, the documentation is merged and reconciled.  Links to
--     documentation pages and references are setup and the final pages are generated.
--
--  Ada
--  ---
--  The documentation starts at the first '== TITLE ==' marker and finishes before the
--  package specification.
--
--  XHTML
--  -----
--  Same as Ada.
--
--  XML Files
--  ----------
--  The documentation is part of the XML and the documentation or description
--  tags are extracted.
package Gen.Artifacts.Docs is

   --  ------------------------------
   --  Documentation artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   overriding
   procedure Initialize (Handler : in out Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class);

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

private

   type Line_Type (Len : Natural) is record
      Content : String (1 .. Len);
   end record;

   package Line_Vectors is
      new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                             Element_Type => Line_Type);

   type Doc_State is (IN_PARA, IN_SEPARATOR, IN_CODE, IN_CODE_SEPARATOR, IN_LIST);

   type File_Document is record
      Name  : Ada.Strings.Unbounded.Unbounded_String;
      State : Doc_State := IN_PARA;
      Lines : Line_Vectors.Vector;
   end record;

   package Doc_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => File_Document,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Returns True if the line indicates a bullet or numbered list.
   function Is_List (Line : in String) return Boolean;

   --  Returns True if the line indicates a code sample.
   function Is_Code (Line : in String) return Boolean;

   --  Append a raw text line to the document.
   procedure Append_Line (Doc  : in out File_Document;
                          Line : in String);

   --  Analyse the documentation line and collect the documentation text.
   procedure Append (Doc   : in out File_Document;
                     Line  : in String);

   --  After having collected the documentation, terminate the document by making sure
   --  the opened elements are closed.
   procedure Finish (Doc : in out File_Document);

   --  Set the name associated with the document extract.
   procedure Set_Name (Doc  : in out File_Document;
                       Name : in String);

   --  Read the Ada specification file and collect the useful documentation.
   --  To keep the implementation simple, we don't use the ASIS packages to scan and extract
   --  the documentation.  We don't need to look at the Ada specification itself.  Instead,
   --  we assume that the Ada source follows some Ada style guidelines.
   procedure Read_Ada_File (File   : in String;
                            Result : in out File_Document);

   type Artifact is new Gen.Artifacts.Artifact with record
      A : Natural;
   end record;

end Gen.Artifacts.Docs;

-----------------------------------------------------------------------
--  gen-artifacts-docs -- Artifact for documentation
--  Copyright (C) 2012 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.Indefinite_Vectors;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Strings.Unbounded;

with DOM.Core;
with Gen.Model.Packages;

--  The Gen.Artifacts.Docs package is an artifact for the generation of
--  application documentation.  Its purpose is to scan the project source files
--  and extract some interesting information for a developer's guide.  The artifact
--  scans the Ada source files, the XML configuration files, the XHTML files.
--
--  The generated documentation is intended to be published on a web site.
--  The Google Wiki style is generated by default.
--
--  1/ In the first step, the project files are scanned and the useful
--     documentation is extracted.
--
--  2/ In the second step, the documentation is merged and reconciled.  Links to
--     documentation pages and references are setup and the final pages are generated.
--
--  Ada
--  ---
--  The documentation starts at the first '== TITLE ==' marker and finishes before the
--  package specification.
--
--  XHTML
--  -----
--  Same as Ada.
--
--  XML Files
--  ----------
--  The documentation is part of the XML and the documentation or description
--  tags are extracted.
package Gen.Artifacts.Docs is

   --  Tag marker (same as Java).
   TAG_CHAR     : constant Character := '@';

   --  Specific tags recognized when analyzing the documentation.
   TAG_AUTHOR   : constant String := "author";
   TAG_TITLE    : constant String := "title";
   TAG_INCLUDE  : constant String := "include";
   TAG_SEE      : constant String := "see";

   --  ------------------------------
   --  Documentation artifact
   --  ------------------------------
   type Artifact is new Gen.Artifacts.Artifact with private;

   --  After the configuration file is read, processes the node whose root
   --  is passed in Node and initializes the Model with the information.
   overriding
   procedure Initialize (Handler : in out Artifact;
                         Path    : in String;
                         Node    : in DOM.Core.Node;
                         Model   : in out Gen.Model.Packages.Model_Definition'Class;
                         Context : in out Generator'Class);

   --  Prepare the model after all the configuration files have been read and before
   --  actually invoking the generation.
   overriding
   procedure Prepare (Handler : in out Artifact;
                      Model   : in out Gen.Model.Packages.Model_Definition'Class;
                      Context : in out Generator'Class);

private

   type Line_Type (Len : Natural) is record
      Content : String (1 .. Len);
   end record;

   package Line_Vectors is
      new Ada.Containers.Indefinite_Vectors (Index_Type   => Positive,
                                             Element_Type => Line_Type);

   type Doc_State is (IN_PARA, IN_SEPARATOR, IN_CODE, IN_CODE_SEPARATOR, IN_LIST);

   type File_Document is record
      Name  : Ada.Strings.Unbounded.Unbounded_String;
      Title : Ada.Strings.Unbounded.Unbounded_String;
      State : Doc_State := IN_PARA;
      Lines : Line_Vectors.Vector;
   end record;

   package Doc_Maps is
     new Ada.Containers.Indefinite_Hashed_Maps (Key_Type        => String,
                                                Element_Type    => File_Document,
                                                Hash            => Ada.Strings.Hash,
                                                Equivalent_Keys => "=");

   --  Returns True if the line indicates a bullet or numbered list.
   function Is_List (Line : in String) return Boolean;

   --  Returns True if the line indicates a code sample.
   function Is_Code (Line : in String) return Boolean;

   --  Append a raw text line to the document.
   procedure Append_Line (Doc  : in out File_Document;
                          Line : in String);

   --  Analyse the documentation line and collect the documentation text.
   procedure Append (Doc   : in out File_Document;
                     Line  : in String);

   --  After having collected the documentation, terminate the document by making sure
   --  the opened elements are closed.
   procedure Finish (Doc : in out File_Document);

   --  Set the name associated with the document extract.
   procedure Set_Name (Doc  : in out File_Document;
                       Name : in String);

   --  Read the Ada specification file and collect the useful documentation.
   --  To keep the implementation simple, we don't use the ASIS packages to scan and extract
   --  the documentation.  We don't need to look at the Ada specification itself.  Instead,
   --  we assume that the Ada source follows some Ada style guidelines.
   procedure Read_Ada_File (File   : in String;
                            Result : in out File_Document);

   type Artifact is new Gen.Artifacts.Artifact with record
      A : Natural;
   end record;

end Gen.Artifacts.Docs;

Add some special tags that allow to perform specific processing in the documentation


pragma License (Modified_GPL);
------------------------------------------------------------------------------
-- EMAIL: <darkestkhan@gmail.com>                                           --
-- License: Modified GNU GPLv3 or any later as published by Free Software   --
--  Foundation (GMGPL, see COPYING file).                                   --
--                                                                          --
--                    Copyright © 2014 darkestkhan                          --
------------------------------------------------------------------------------
--  This Program 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 3 of the license, or     --
--                 (at your option) any later version.                      --
--                                                                          --
--      This Program 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 program.  If not, see <http://www.gnu.org/licenses/>.  --
--                                                                          --
-- 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 System;

with Oto.Binary;
use Oto;
package Oto.ALC is

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

                              ---------------
                              -- T Y P E S --
                              ---------------

  ---------------------------------------------------------------------------
  -- Due to the fact that only pointers to device and context are passed
  -- we ar going to use System.Address for them.
  subtype Context is System.Address;
  subtype Device  is System.Address;

  subtype Bool    is Binary.Byte;
  subtype Char    is Binary.S_Byte;
  subtype Double  is Long_Float;
  subtype Enum    is Binary.S_Word;
  subtype Int     is Integer;
  subtype Pointer is System.Address;
  subtype Short   is Binary.S_Short;
  subtype SizeI   is Integer;
  subtype UByte   is Binary.Byte;
  subtype UInt    is Binary.Word;
  subtype UShort  is Binary.Short;

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

                          -----------------------
                          -- C O N S T A N T S --
                          -----------------------

  ---------------------------------------------------------------------------
  -- Bool constants.
  ALC_FALSE                                : constant Bool := 0;
  ALC_TRUE                                 : constant Bool := 1;

  -- Followed by <Int> Hz
  ALC_FREQUENCY                            : constant Enum := 16#1007#;

  -- Followed by <Int> Hz
  ALC_REFRESH                              : constant Enum := 16#1008#;

  -- Followed by AL_TRUE, AL_FALSE
  ALC_SYNC                                 : constant Enum := 16#1009#;

  -- Followed by <Int> Num of requested Mono (3D) Sources
  ALC_MONO_SOURCES                         : constant Enum := 16#1010#;

  -- Followed by <Int> Num of requested Stereo Sources
  ALC_STEREO_SOURCES                       : constant Enum := 16#1011#;

  -- Errors
  -- No error
  ALC_NO_ERROR                             : constant Enum := 0;

  -- No device
  ALC_INVALID_DEVICE                       : constant Enum := 16#A001#;

  -- Invalid context ID
  ALC_INVALID_CONTEXT                      : constant Enum := 16#A002#;

  -- Bad enum
  ALC_INVALID_ENUM                         : constant Enum := 16#A003#;

  -- Bad value
  ALC_INVALID_VALUE                        : constant Enum := 16#A004#;

  -- Out of memory.
  ALC_OUT_OF_MEMORY                        : constant Enum := 16#A005#;

  -- The Specifier string for default device
  ALC_DEFAULT_DEVICE_SPECIFIER             : constant Enum := 16#1004#;
  ALC_DEVICE_SPECIFIER                     : constant Enum := 16#1005#;
  ALC_EXTENSIONS                           : constant Enum := 16#1006#;

  ALC_MAJOR_VERSION                        : constant Enum := 16#1000#;
  ALC_MINOR_VERSION                        : constant Enum := 16#1001#;

  ALC_ATTRIBUTES_SIZE                      : constant Enum := 16#1002#;
  ALC_ALL_ATTRIBUTES                       : constant Enum := 16#1003#;

  -- Capture extension
  ALC_EXT_CAPTURE                          : constant Enum := 1;
  ALC_CAPTURE_DEVICE_SPECIFIER             : constant Enum := 16#310#;
  ALC_CAPTURE_DEFAULT_DEVICE_SPECIFIER     : constant Enum := 16#311#;
  ALC_CAPTURE_SAMPLES                      : constant Enum := 16#312#;

  -- ALC_ENUMERATE_ALL_EXT enums
  ALC_ENUMERATE_ALL_EXT                    : constant Enum := 1;
  ALC_DEFAULT_ALL_DEVICES_SPECIFIER        : constant Enum := 16#1012#;
  ALC_ALL_DEVICES_SPECIFIER                : constant Enum := 16#1013#;

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

                    ---------------------------
                    -- S U B P R O G R A M S --
                    ---------------------------

  ---------------------------------------------------------------------------
  -- Context Management
  function Create_Context
    ( ADevice: in Device;
      Attr_List: in Pointer
    ) return Context;
--ALC_API ALCcontext *    ALC_APIENTRY alcCreateContext( ALCdevice *device, const ALCint* attrlist );

  function Make_Context_Current (AContext: in Context) return Bool;
--ALC_API ALCboolean      ALC_APIENTRY alcMakeContextCurrent( ALCcontext *context );

  procedure Process_Context (AContext: in Context);
--ALC_API void            ALC_APIENTRY alcProcessContext( ALCcontext *context );

  procedure Suspend_Context (AContext: in Context);
--ALC_API void            ALC_APIENTRY alcSuspendContext( ALCcontext *context );

  procedure Destroy_Context (AContext: in Context);
--ALC_API void            ALC_APIENTRY alcDestroyContext( ALCcontext *context );

  function Get_Current_Context return Context;
--ALC_API ALCcontext *    ALC_APIENTRY alcGetCurrentContext( void );

  function Get_Contexts_Device (AContext: in Context) return Device;
--ALC_API ALCdevice*      ALC_APIENTRY alcGetContextsDevice( ALCcontext *context );

  -- Device Management
  function Open_Device (Device_Name: in String) return Device;
  Pragma Inline (Open_Device);

  function Close_Device (ADevice: in Device) return Bool;

  -- Error support.
  -- Obtain the most recent Context error
  function Get_Error (ADevice: in Device) return Enum;

  -- Extension support.
  -- Query for the presence of an extension, and obtain any appropriate
  -- function pointers and enum values.
  function Is_Extension_Present
    ( ADevice: in Device;
      Ext_Name: in String
    ) return Bool;
  Pragma Inline (Is_Extension_Present);

  function Get_Proc_Address
    ( ADevice: in Device;
      Func_Name: in String
    ) return Pointer;
  Pragma Inline (Get_Proc_Address);

  function Get_Enum_Value
    ( ADevice: in Device;
      Enum_Name: in String
    ) return Enum;
  Pragma Inline (Get_Enum_Value);

  -- Query functions
  function Get_String (ADevice: in Device; Param: in Enum) return String;
  Pragma Inline (Get_String);

  procedure Get_Integer
    ( ADevice: in Device;
      Param: in Enum;
      Size: in SizeI;
      Data: in Pointer
    );

  -- Capture functions
  function Capture_Open_Device
    ( Device_Name: in String;
      Frequency: in UInt;
      Format: in Enum;
      Buffer_Size: in SizeI
    ) return Device;
  Pragma Inline (Capture_Open_Device);

  function Capture_Close_Device (ADevice: in Device) return Bool;

  procedure Capture_Start (ADevice: in Device);

  procedure Capture_Stop (ADevice: in Device);

  procedure Capture_Samples
    ( ADevice: in Device;
      Buffer: in Pointer;
      Samples: in SizeI
    );

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

private

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

                            -------------------
                            -- I M P O R T S --
                            -------------------

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

  Pragma Import (StdCall, Create_Context, "alcCreateContext");
  Pragma Import (StdCall, Make_Context_Current, "alcMakeContextCurrent");
  Pragma Import (StdCall, Process_Context, "alcProcessContext");
  Pragma Import (StdCall, Suspend_Context, "alcSuspendContext");
  Pragma Import (StdCall, Destroy_Context, "alcDestroyContext");
  Pragma Import (StdCall, Get_Current_Context, "alcGetCurrentContext");
  Pragma Import (StdCall, Get_Contexts_Device, "alcGetContextsDevice");
  Pragma Import (StdCall, Close_Device, "alcCloseDevice");
  Pragma Import (StdCall, Get_Error, "alcGetError");
  Pragma Import (StdCall, Get_Integer, "alcGetIntegerv");
  Pragma Import (StdCall, Capture_Close_Device, "alcCaptureCloseDevice");
  Pragma Import (StdCall, Capture_Start, "alcCaptureStart");
  Pragma Import (StdCall, Capture_Stop, "alcCaptureStop");
  Pragma Import (StdCall, Capture_Samples, "alcCaptureSamples");

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

end Oto.ALC;

pragma License (Modified_GPL);
------------------------------------------------------------------------------
-- EMAIL: <darkestkhan@gmail.com>                                           --
-- License: Modified GNU GPLv3 or any later as published by Free Software   --
--  Foundation (GMGPL, see COPYING file).                                   --
--                                                                          --
--                    Copyright © 2014 darkestkhan                          --
------------------------------------------------------------------------------
--  This Program 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 3 of the license, or     --
--                 (at your option) any later version.                      --
--                                                                          --
--      This Program 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 program.  If not, see <http://www.gnu.org/licenses/>.  --
--                                                                          --
-- 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 System;

with Oto.Binary;
use Oto;
package Oto.ALC is

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

                              ---------------
                              -- T Y P E S --
                              ---------------

  ---------------------------------------------------------------------------
  -- Due to the fact that only pointers to device and context are passed
  -- we ar going to use System.Address for them.
  subtype Context is System.Address;
  subtype Device  is System.Address;

  subtype Bool    is Binary.Byte;
  subtype Char    is Binary.S_Byte;
  subtype Double  is Long_Float;
  subtype Enum    is Binary.S_Word;
  subtype Int     is Integer;
  subtype Pointer is System.Address;
  subtype Short   is Binary.S_Short;
  subtype SizeI   is Integer;
  subtype UByte   is Binary.Byte;
  subtype UInt    is Binary.Word;
  subtype UShort  is Binary.Short;

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

                          -----------------------
                          -- C O N S T A N T S --
                          -----------------------

  ---------------------------------------------------------------------------
  -- Bool constants.
  ALC_FALSE                                : constant Bool := 0;
  ALC_TRUE                                 : constant Bool := 1;

  -- Followed by <Int> Hz
  ALC_FREQUENCY                            : constant Enum := 16#1007#;

  -- Followed by <Int> Hz
  ALC_REFRESH                              : constant Enum := 16#1008#;

  -- Followed by AL_TRUE, AL_FALSE
  ALC_SYNC                                 : constant Enum := 16#1009#;

  -- Followed by <Int> Num of requested Mono (3D) Sources
  ALC_MONO_SOURCES                         : constant Enum := 16#1010#;

  -- Followed by <Int> Num of requested Stereo Sources
  ALC_STEREO_SOURCES                       : constant Enum := 16#1011#;

  -- Errors
  -- No error
  ALC_NO_ERROR                             : constant Enum := 0;

  -- No device
  ALC_INVALID_DEVICE                       : constant Enum := 16#A001#;

  -- Invalid context ID
  ALC_INVALID_CONTEXT                      : constant Enum := 16#A002#;

  -- Bad enum
  ALC_INVALID_ENUM                         : constant Enum := 16#A003#;

  -- Bad value
  ALC_INVALID_VALUE                        : constant Enum := 16#A004#;

  -- Out of memory.
  ALC_OUT_OF_MEMORY                        : constant Enum := 16#A005#;

  -- The Specifier string for default device
  ALC_DEFAULT_DEVICE_SPECIFIER             : constant Enum := 16#1004#;
  ALC_DEVICE_SPECIFIER                     : constant Enum := 16#1005#;
  ALC_EXTENSIONS                           : constant Enum := 16#1006#;

  ALC_MAJOR_VERSION                        : constant Enum := 16#1000#;
  ALC_MINOR_VERSION                        : constant Enum := 16#1001#;

  ALC_ATTRIBUTES_SIZE                      : constant Enum := 16#1002#;
  ALC_ALL_ATTRIBUTES                       : constant Enum := 16#1003#;

  -- Capture extension
  ALC_EXT_CAPTURE                          : constant Enum := 1;
  ALC_CAPTURE_DEVICE_SPECIFIER             : constant Enum := 16#310#;
  ALC_CAPTURE_DEFAULT_DEVICE_SPECIFIER     : constant Enum := 16#311#;
  ALC_CAPTURE_SAMPLES                      : constant Enum := 16#312#;

  -- ALC_ENUMERATE_ALL_EXT enums
  ALC_ENUMERATE_ALL_EXT                    : constant Enum := 1;
  ALC_DEFAULT_ALL_DEVICES_SPECIFIER        : constant Enum := 16#1012#;
  ALC_ALL_DEVICES_SPECIFIER                : constant Enum := 16#1013#;

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

                    ---------------------------
                    -- S U B P R O G R A M S --
                    ---------------------------

  ---------------------------------------------------------------------------
  -- Context Management
  function Create_Context
    ( ADevice: in Device;
      Attr_List: in Pointer
    ) return Context;

  function Make_Context_Current (AContext: in Context) return Bool;

  procedure Process_Context (AContext: in Context);

  procedure Suspend_Context (AContext: in Context);

  procedure Destroy_Context (AContext: in Context);

  function Get_Current_Context return Context;

  function Get_Contexts_Device (AContext: in Context) return Device;

  -- Device Management
  function Open_Device (Device_Name: in String) return Device;
  Pragma Inline (Open_Device);

  function Close_Device (ADevice: in Device) return Bool;

  -- Error support.
  -- Obtain the most recent Context error
  function Get_Error (ADevice: in Device) return Enum;

  -- Extension support.
  -- Query for the presence of an extension, and obtain any appropriate
  -- function pointers and enum values.
  function Is_Extension_Present
    ( ADevice: in Device;
      Ext_Name: in String
    ) return Bool;
  Pragma Inline (Is_Extension_Present);

  function Get_Proc_Address
    ( ADevice: in Device;
      Func_Name: in String
    ) return Pointer;
  Pragma Inline (Get_Proc_Address);

  function Get_Enum_Value
    ( ADevice: in Device;
      Enum_Name: in String
    ) return Enum;
  Pragma Inline (Get_Enum_Value);

  -- Query functions
  function Get_String (ADevice: in Device; Param: in Enum) return String;
  Pragma Inline (Get_String);

  procedure Get_Integer
    ( ADevice: in Device;
      Param: in Enum;
      Size: in SizeI;
      Data: in Pointer
    );

  -- Capture functions
  function Capture_Open_Device
    ( Device_Name: in String;
      Frequency: in UInt;
      Format: in Enum;
      Buffer_Size: in SizeI
    ) return Device;
  Pragma Inline (Capture_Open_Device);

  function Capture_Close_Device (ADevice: in Device) return Bool;

  procedure Capture_Start (ADevice: in Device);

  procedure Capture_Stop (ADevice: in Device);

  procedure Capture_Samples
    ( ADevice: in Device;
      Buffer: in Pointer;
      Samples: in SizeI
    );

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

private

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

                            -------------------
                            -- I M P O R T S --
                            -------------------

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

  Pragma Import (StdCall, Create_Context, "alcCreateContext");
  Pragma Import (StdCall, Make_Context_Current, "alcMakeContextCurrent");
  Pragma Import (StdCall, Process_Context, "alcProcessContext");
  Pragma Import (StdCall, Suspend_Context, "alcSuspendContext");
  Pragma Import (StdCall, Destroy_Context, "alcDestroyContext");
  Pragma Import (StdCall, Get_Current_Context, "alcGetCurrentContext");
  Pragma Import (StdCall, Get_Contexts_Device, "alcGetContextsDevice");
  Pragma Import (StdCall, Close_Device, "alcCloseDevice");
  Pragma Import (StdCall, Get_Error, "alcGetError");
  Pragma Import (StdCall, Get_Integer, "alcGetIntegerv");
  Pragma Import (StdCall, Capture_Close_Device, "alcCaptureCloseDevice");
  Pragma Import (StdCall, Capture_Start, "alcCaptureStart");
  Pragma Import (StdCall, Capture_Stop, "alcCaptureStop");
  Pragma Import (StdCall, Capture_Samples, "alcCaptureSamples");

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

end Oto.ALC;

Delete C definitions of subprograms.

ALC: Delete C definitions of subprograms.

Signed-off-by: darkestkhan <e9a7a7cf2a6af79e93742343a7a5cac5d90f9bd2@gmail.com>