path: root/src/libao.adb

--  Programmed by Jedidiah Barber
--  Released into the public domain


pragma Ada_2012;


with

    Ada.Containers,
    Ada.Strings.Fixed,
    Ada.Strings.Maps,
    Interfaces.C.Strings,
    System.Storage_Elements;

use type

    Ada.Containers.Count_Type,
    Interfaces.C.int,
    Interfaces.C.Strings.chars_ptr,
    System.Address;


package body Libao is


    package Str  renames Ada.Strings;
    package SFix renames Ada.Strings.Fixed;
    package SMap renames Ada.Strings.Maps;




    ------------------------
    --  Constants From C  --
    ------------------------

    type_live : constant Interfaces.C.int;
    pragma Import (C, type_live, "type_live");

    type_file : constant Interfaces.C.int;
    pragma Import (C, type_file, "type_file");


    sample_little_endian : constant Interfaces.C.int;
    pragma Import (C, sample_little_endian, "sample_little_endian");

    sample_big_endian : constant Interfaces.C.int;
    pragma Import (C, sample_big_endian, "sample_big_endian");

    sample_native_endian : constant Interfaces.C.int;
    pragma Import (C, sample_native_endian, "sample_native_endian");


    error_no_driver : constant Interfaces.C.int;
    pragma Import (C, error_no_driver, "error_no_driver");

    error_not_file : constant Interfaces.C.int;
    pragma Import (C, error_not_file, "error_not_file");

    error_not_live : constant Interfaces.C.int;
    pragma Import (C, error_not_live, "error_not_live");

    error_bad_option : constant Interfaces.C.int;
    pragma Import (C, error_bad_option, "error_bad_option");

    error_open_device : constant Interfaces.C.int;
    pragma Import (C, error_open_device, "error_open_device");

    error_open_file : constant Interfaces.C.int;
    pragma Import (C, error_open_file, "error_open_file");

    error_file_exists : constant Interfaces.C.int;
    pragma Import (C, error_file_exists, "error_file_exists");

    error_bad_format : constant Interfaces.C.int;
    pragma Import (C, error_bad_format, "error_bad_format");

    error_fail : constant Interfaces.C.int;
    pragma Import (C, error_fail, "error_fail");




    ------------------------
    --  Functions From C  --
    ------------------------

    procedure ao_initialize;
    pragma Import (C, ao_initialize, "ao_initialize");

    procedure ao_shutdown;
    pragma Import (C, ao_shutdown, "ao_shutdown");


    function ao_append_option
           (Options : in out Storage.Integer_Address;
            Key     : in     Interfaces.C.char_array;
            Value   : in     Interfaces.C.char_array)
        return Interfaces.C.int;
    pragma Import (C, ao_append_option, "ao_append_option");

    function ao_append_global_option
           (Key   : in Interfaces.C.char_array;
            Value : in Interfaces.C.char_array)
        return Interfaces.C.int;
    pragma Import (C, ao_append_global_option, "ao_append_global_option");

    procedure ao_free_options
           (Options : in Storage.Integer_Address);
    pragma Import (C, ao_free_options, "ao_free_options");

    function ao_open_live
           (Driver_ID : in Interfaces.C.int;
            Format    : in Storage.Integer_Address;
            Options   : in Storage.Integer_Address)
        return Storage.Integer_Address;
    pragma Import (C, ao_open_live, "ao_open_live");

    function ao_open_file
           (Driver_ID : in Interfaces.C.int;
            Filename  : in Interfaces.C.char_array;
            Overwrite : in Interfaces.C.int;
            Format    : in Storage.Integer_Address;
            Options   : in Storage.Integer_Address)
        return Storage.Integer_Address;
    pragma Import (C, ao_open_file, "ao_open_file");

    function ao_play
           (Output_Device : in Storage.Integer_Address;
            Samples       : in Storage.Integer_Address;
            Num_Bytes     : in Interfaces.Unsigned_32)
        return Interfaces.C.int;
    pragma Import (C, ao_play, "ao_play");

    function ao_close
           (Output_Device : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, ao_close, "ao_close");


    function ao_driver_id
           (Short_Name : in Interfaces.C.char_array)
        return Interfaces.C.int;
    pragma Import (C, ao_driver_id, "ao_driver_id");

    function ao_default_driver_id
        return Interfaces.C.int;
    pragma Import (C, ao_default_driver_id, "ao_default_driver_id");

    function ao_driver_info
           (Ident : in Interfaces.C.int)
        return Storage.Integer_Address;
    pragma Import (C, ao_driver_info, "ao_driver_info");

    function ao_driver_info_list
           (Count : out Interfaces.C.int)
        return Storage.Integer_Address;
    pragma Import (C, ao_driver_info_list, "ao_driver_info_list");

    function ao_file_extension
           (Ident : in Interfaces.C.int)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, ao_file_extension, "ao_file_extension");


    function ao_is_big_endian
        return Interfaces.C.int;
    pragma Import (C, ao_is_big_endian, "ao_is_big_endian");


    function info_item_get
           (Infos : in Storage.Integer_Address;
            Index : in Interfaces.C.int)
        return Storage.Integer_Address;
    pragma Import (C, info_item_get, "info_item_get");
    pragma Inline (info_item_get);


    function info_kind_get
           (Item : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, info_kind_get, "info_kind_get");
    pragma Inline (info_kind_get);

    function info_name_get
           (Item : in Storage.Integer_Address)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, info_name_get, "info_name_get");
    pragma Inline (info_name_get);

    function info_short_name_get
           (Item : in Storage.Integer_Address)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, info_short_name_get, "info_short_name_get");
    pragma Inline (info_short_name_get);

    function info_preferred_byte_format_get
           (Item : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, info_preferred_byte_format_get, "info_preferred_byte_format_get");
    pragma Inline (info_preferred_byte_format_get);

    function info_priority_get
           (Item : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, info_priority_get, "info_priority_get");
    pragma Inline (info_priority_get);

    function info_comment_get
           (Item : in Storage.Integer_Address)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, info_comment_get, "info_comment_get");
    pragma Inline (info_comment_get);

    function info_option_count_get
           (Item : in Storage.Integer_Address)
        return Interfaces.C.int;
    pragma Import (C, info_option_count_get, "info_option_count_get");
    pragma Inline (info_option_count_get);

    function info_option_key_get
           (Item  : in Storage.Integer_Address;
            Index : in Interfaces.C.int)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, info_option_key_get, "info_option_key_get");
    pragma Inline (info_option_key_get);


    function get_errno
        return Interfaces.C.int;
    pragma Import (C, get_errno, "get_errno");
    pragma Inline (get_errno);


    function option_key
           (Item : in Storage.Integer_Address)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, option_key, "option_key");
    pragma Inline (option_key);

    function option_value
           (Item : in Storage.Integer_Address)
        return Interfaces.C.Strings.chars_ptr;
    pragma Import (C, option_value, "option_value");
    pragma Inline (option_value);

    function option_next
           (Item : in Storage.Integer_Address)
        return Storage.Integer_Address;
    pragma Import (C, option_next, "option_next");
    pragma Inline (option_next);




    ------------------------
    --  Internal Utility  --
    ------------------------

    procedure Do_Append
           (Ptr_List : in out Address_Vectors.Vector;
            Key      : in     Interfaces.C.char_array;
            Value    : in     Interfaces.C.char_array)
    is
        Result : Interfaces.C.int;
        Head   : Storage.Integer_Address := Head_Pointer (Ptr_List);
    begin
        Result := ao_append_option (Head, Key, Value);
        if Result = 0 then
            raise Storage_Error;
        elsif Result /= 1 then
            raise Program_Error;
        else
            if Ptr_List.Length = 0 then
                Ptr_List.Append (Head);
            else
                Ptr_List.Append (option_next (Ptr_List.Last_Element));
            end if;
        end if;
    end Do_Append;

    procedure Do_Close
           (Ptr : in Storage.Integer_Address)
    is
        Result : Interfaces.C.int := ao_close (Ptr);
    begin
        if Result = 0 then
            raise Close_Device_Error;
        elsif Result /= 1 then
            raise Program_Error;
        end if;
    end Do_Close;

    function Head_Pointer
           (This : in Address_Vectors.Vector)
        return Storage.Integer_Address is
    begin
        if This.Length = 0 then
            return Null_Pointer;
        else
            return This.First_Element;
        end if;
    end Head_Pointer;




    -----------------------------------
    --  Controlled Type Subprograms  --
    -----------------------------------

    procedure Adjust
           (This : in out Option_List)
    is
        Old : Storage.Integer_Address := Head_Pointer (This.Ptr_List);
    begin
        This.Ptr_List := Address_Vectors.Empty_Vector;
        while Old /= Null_Pointer loop
            Do_Append
               (This.Ptr_List,
                Interfaces.C.Strings.Value (option_key (Old)),
                Interfaces.C.Strings.Value (option_value (Old)));
            Old := option_next (Old);
        end loop;
    end Adjust;

    procedure Finalize
           (This : in out Option_List) is
    begin
        ao_free_options (Head_Pointer (This.Ptr_List));
    end Finalize;

    procedure Adjust
           (This : in out Sample_Format) is
    begin
        This.C_Struct.Matrix := Interfaces.C.Strings.New_String
            (Interfaces.C.Strings.Value (This.C_Struct.Matrix));
    end Adjust;

    procedure Finalize
           (This : in out Sample_Format) is
    begin
        Interfaces.C.Strings.Free (This.C_Struct.Matrix);
    end Finalize;

    procedure Finalize
           (This : in out Final_Controller) is
    begin
        for Addy of Device_List loop
            Do_Close (Addy);
        end loop;
        ao_shutdown;
    end Finalize;




    ---------------------------------
    --  Data Types and Structures  --
    ---------------------------------

    function Kind
           (Attributes : in Info)
        return Output_Kind
    is
        Value : Interfaces.C.int := info_kind_get (Attributes.Ptr);
    begin
        if Value = type_live then
            return Live_Output;
        elsif Value = type_file then
            return File_Output;
        else
            raise Program_Error;
        end if;
    end Kind;

    function Name
           (Attributes : in Info)
        return String is
    begin
        return Interfaces.C.Strings.Value (info_name_get (Attributes.Ptr));
    end Name;

    function Short_Name
           (Attributes : in Info)
        return String is
    begin
        return Interfaces.C.Strings.Value (info_short_name_get (Attributes.Ptr));
    end Short_Name;

    function Preferred_Byte_Format
           (Attributes : in Info)
        return Endianness
    is
        Value : Interfaces.C.int := info_preferred_byte_format_get (Attributes.Ptr);
    begin
        if Value = sample_little_endian then
            return Little_Endian;
        elsif Value = sample_big_endian then
            return Big_Endian;
        elsif Value = sample_native_endian then
            return Machine_Native;
        else
            raise Program_Error; --  libao would be doing weird shit to get here
        end if;
    end Preferred_Byte_Format;

    function Priority_Level
           (Attributes : in Info)
        return Natural is
    begin
        return Natural (info_priority_get (Attributes.Ptr));
    end Priority_Level;

    function Comment
           (Attributes : in Info)
        return String is
    begin
        return Interfaces.C.Strings.Value (info_comment_get (Attributes.Ptr));
    end Comment;

    function Option_Count
           (Attributes : in Info)
        return Natural is
    begin
        return Natural (info_option_count_get (Attributes.Ptr));
    end Option_Count;

    function Option_Key
           (Attributes : in Info;
            Index      : in Positive)
        return String is
    begin
        return Interfaces.C.Strings.Value
            (info_option_key_get (Attributes.Ptr, Interfaces.C.int (Index) - 1));
    end Option_Key;


    function Length
           (Options : in Option_List)
        return Natural is
    begin
        return Natural (Options.Ptr_List.Length);
    end Length;

    function Key
           (Options : in Option_List;
            Index   : in Positive)
        return String is
    begin
        return Interfaces.C.Strings.Value (option_key (Options.Ptr_List.Element (Index)));
    end Key;

    function Value
           (Options : in Option_List;
            Index   : in Positive)
        return String is
    begin
        return Interfaces.C.Strings.Value (option_value (Options.Ptr_List.Element (Index)));
    end Value;


    function Image_Length
           (Channel : in Channel_Mnemonic)
        return Positive is
    begin
        case Channel is
            when L | R | C | M | X =>
                return 1;
            when CL | CR | BL | BR | BC | SL | SR | A1 | A2 | A3 | A4 =>
                return 2;
            when LFE =>
                return 3;
        end case;
    end Image_Length;

    function Image_Length
           (Channel_Matrix : in Mnemonic_Array)
        return Natural
    is
        --  Start by counting all the commas
        Result : Integer := Channel_Matrix'Length - 1;
    begin
        if Channel_Matrix'Length = 0 then
            return 0;
        end if;
        for Channel of Channel_Matrix loop
            Result := Result + Image_Length (Channel);
        end loop;
        return Result;
    end Image_Length;

    function Image
           (Channel_Matrix : in Mnemonic_Array)
        return String
    is
        Result    : String (1 .. Image_Length (Channel_Matrix));
        Position  : Integer := 1;
        Token_End : Positive;
    begin
        for Index in Integer range Channel_Matrix'First .. Channel_Matrix'Last - 1 loop
            Token_End := Position + Image_Length (Channel_Matrix (Index));
            Result (Position .. Token_End) := Channel_Matrix (Index)'Image & ",";
            Position := Token_End + 1;
        end loop;
        Result (Position .. Result'Last) := Channel_Matrix (Channel_Matrix'Last)'Image;
        return Result;
    end Image;

    function Create
           (Bits, Rate, Channels : in Positive;
            Byte_Format          : in Endianness;
            Channel_Matrix       : in Mnemonic_Array)
        return Sample_Format is
    begin
        return This : Sample_Format := (Ada.Finalization.Controlled with
            C_Struct =>
               (Bits        => Interfaces.C.int (Bits),
                Rate        => Interfaces.C.int (Rate),
                Channels    => Interfaces.C.int (Channels),
                Byte_Format => (case Byte_Format is
                    when Little_Endian  => sample_little_endian,
                    when Big_Endian     => sample_big_endian,
                    when Machine_Native => sample_native_endian),
                Matrix      => Interfaces.C.Strings.New_String (Image (Channel_Matrix))));
    end Create;

    function Bits
           (Format : in Sample_Format)
        return Positive is
    begin
        return Positive (Format.C_Struct.Bits);
    end Bits;

    function Rate
           (Format : in Sample_Format)
        return Positive is
    begin
        return Positive (Format.C_Struct.Rate);
    end Rate;

    function Channels
           (Format : in Sample_Format)
        return Positive is
    begin
        return Positive (Format.C_Struct.Channels);
    end Channels;

    function Byte_Format
           (Format : in Sample_Format)
        return Endianness is
    begin
        if Format.C_Struct.Byte_Format = sample_little_endian then
            return Little_Endian;
        elsif Format.C_Struct.Byte_Format = sample_big_endian then
            return Big_Endian;
        elsif Format.C_Struct.Byte_Format = sample_native_endian then
            return Machine_Native;
        else
            raise Constraint_Error;
        end if;
    end Byte_Format;

    function Channel_Matrix
           (Format : in Sample_Format)
        return Mnemonic_Array
    is
        Input  : String := Interfaces.C.Strings.Value (Format.C_Struct.Matrix);
        Result : Mnemonic_Array (1 .. SFix.Count (Input, SMap.To_Set (',')) + 1);
        First  : Positive := 1;
        Last   : Natural;
        Place  : Positive := 1;
    begin
        if Input'Length = 0 then
            return Empty : Mnemonic_Array (1 .. 0);
        end if;
        while First <= Input'Last loop
            SFix.Find_Token
               (Source => Input,
                Set    => SMap.To_Set (','),
                From   => First,
                Test   => Str.Outside,
                First  => First,
                Last   => Last);
            exit when Last = 0;
            Result (Place) := Channel_Mnemonic'Value (Input (First .. Last));
            Place := Place + 1;
            First := Last + 1;
        end loop;
        return Result;
    end Channel_Matrix;




    --------------------------------------
    --  Device Setup/Playback/Teardown  --
    --------------------------------------

    procedure Append
           (This  : in out Option_List;
            Key   : in     String;
            Value : in     String) is
    begin
        Do_Append (This.Ptr_List, Interfaces.C.To_C (Key), Interfaces.C.To_C (Value));
    end Append;

    procedure Append_Global_Option
           (Key   : in String;
            Value : in String)
    is
        Result : Interfaces.C.int;
    begin
        Result := ao_append_global_option
           (Interfaces.C.To_C (Key),
            Interfaces.C.To_C (Value));
        if Result = 0 then
            raise Storage_Error;
        elsif Result /= 1 then
            raise Program_Error;
        end if;
    end Append_Global_Option;

    procedure Open_Live
           (Output    : in out Device;
            Driver_ID : in     Driver_ID_Number;
            Format    : in     Sample_Format'Class;
            Options   : in     Option_List'Class)
    is
        Result : Storage.Integer_Address := ao_open_live
           (Driver_ID => Interfaces.C.int (Driver_ID),
            Format    => Storage.To_Integer (Format.C_Struct'Address),
            Options   => Head_Pointer (Options.Ptr_List));
        My_Errno : Interfaces.C.int;
    begin
        if Result = Null_Pointer then
            My_Errno := get_errno;
            if My_Errno = error_no_driver then
                raise No_Driver_Error;
            elsif My_Errno = error_not_live then
                raise Not_Live_Error;
            elsif My_Errno = error_bad_option then
                raise Bad_Option_Error;
            elsif My_Errno = error_open_device then
                raise Open_Device_Error;
            elsif My_Errno = error_bad_format then
                raise Bad_Format_Error;
            elsif My_Errno = error_fail then
                raise General_Failure;
            else
                raise Program_Error;
            end if;
        else
            Output.Close;
            Device_List.Append (Result);
            Output.Ptr := Result;
        end if;
    end Open_Live;

    procedure Open_File
           (Output    : in out Device;
            Driver_ID : in     Driver_ID_Number;
            Filename  : in     String;
            Format    : in     Sample_Format'Class;
            Options   : in     Option_List'Class;
            Overwrite : in     Boolean := False)
    is
        Result : Storage.Integer_Address := ao_open_file
           (Driver_ID => Interfaces.C.int (Driver_ID),
            Filename  => Interfaces.C.To_C (Filename),
            Overwrite => Boolean'Pos (Overwrite),
            Format    => Storage.To_Integer (Format.C_Struct'Address),
            Options   => Head_Pointer (Options.Ptr_List));
        My_Errno : Interfaces.C.int;
    begin
        if Result = Null_Pointer then
            My_Errno := get_errno;
            if My_Errno = error_no_driver then
                raise No_Driver_Error;
            elsif My_Errno = error_not_file then
                raise Not_File_Error;
            elsif My_Errno = error_bad_option then
                raise Bad_Option_Error;
            elsif My_Errno = error_open_file then
                raise Open_File_Error;
            elsif My_Errno = error_file_exists then
                raise File_Exists_Error;
            elsif My_Errno = error_bad_format then
                raise Bad_Format_Error;
            elsif My_Errno = error_fail then
                raise General_Failure;
            else
                raise Program_Error;
            end if;
        else
            Output.Close;
            Device_List.Append (Result);
            Output.Ptr := Result;
        end if;
    end Open_File;

    procedure Play
           (Output  : in Device;
            Samples : in Data_Buffer)
    is
        Result : Interfaces.C.int := ao_play
           (Output_Device => Output.Ptr,
            Samples       => Storage.To_Integer (Samples'Address),
            Num_Bytes     => Interfaces.Unsigned_32 (Samples'Length));
    begin
        if Result = 0 then
            raise General_Failure;
        end if;
    end Play;

    procedure Close
           (Output : in out Device)
    is
        Found : Boolean := False;
    begin
        for Index in reverse Integer range Device_List.First_Index .. Device_List.Last_Index loop
            if Device_List.Element (Index) = Output.Ptr then
                Device_List.Delete (Index);
                Found := True;
            end if;
        end loop;
        if Found then
            Do_Close (Output.Ptr);
        end if;
        Output.Ptr := Null_Pointer;
    end Close;




    --------------------------
    --  Driver Information  --
    --------------------------

    function Driver_ID
           (Short_Name : in String)
        return Driver_ID_Number
    is
        Result : Interfaces.C.int;
    begin
        Result := ao_driver_id (Interfaces.C.To_C (Short_Name));
        if Result = -1 then
            raise No_Driver_Error;
        elsif Result < 0 then
            raise Program_Error;
        end if;
        return Driver_ID_Number (Result);
    end Driver_ID;

    function Default_Driver_ID
        return Driver_ID_Number
    is
        Result : Interfaces.C.int;
    begin
        Result := ao_default_driver_id;
        if Result = -1 then
            raise No_Device_Error;
        elsif Result < 0 then
            raise Program_Error;
        end if;
        return Driver_ID_Number (Result);
    end Default_Driver_ID;

    function Driver_Info
           (Ident : in Driver_ID_Number)
        return Info
    is
        Result : Storage.Integer_Address;
    begin
        Result := ao_driver_info (Interfaces.C.int (Ident));
        if Result = Null_Pointer then
            raise No_Driver_Error;
        else
            return (Ptr => Result);
        end if;
    end Driver_Info;

    function Driver_Info_List
        return Info_Array
    is
        Count : Interfaces.C.int;
        Carr  : Storage.Integer_Address;
    begin
        Carr := ao_driver_info_list (Count);
        return Actual : Info_Array (1 .. Positive (Count)) do
            for N in Integer range Actual'First .. Actual'Last loop
                Actual (N) := (Ptr => info_item_get (Carr, Interfaces.C.int (N - 1)));
            end loop;
        end return;
    end Driver_Info_List;

    function File_Extension
           (Ident : in Driver_ID_Number)
        return String
    is
        Result : Interfaces.C.Strings.chars_ptr := ao_file_extension (Interfaces.C.int (Ident));
    begin
        if Result = Interfaces.C.Strings.Null_Ptr then
            return "";
        else
            return Interfaces.C.Strings.Value (Result);
        end if;
    end File_Extension;




    ---------------------
    --  Miscellaneous  --
    ---------------------

    function Is_Big_Endian
        return Boolean is
    begin
        case ao_is_big_endian is
            when 1 => return True;
            when 0 => return False;
            when others => raise Program_Error;
        end case;
    end Is_Big_Endian;




begin

    ao_initialize;

end Libao;