with Text_Io; use Text_Io;
with PragmARC.Ansi_Tty_Control; use PragmARC.Ansi_Tty_Control;
with PragmARC.Menu_Handler;
with Portmidi, Porttime; use Portmidi, Porttime;
with Ada.Strings, Ada.Strings.Fixed; use Ada.Strings;
with Calendar; use Calendar;
package body Generic_Orchester is
procedure Start(Orchester : in T_Orchester) is
begin
for I in Orchester'Range loop
if Orchester(I) /= null and then
Orchester(I).Configured then
Put_Line("Start instrument " & Integer'Image(I));
Orchester(I).Radias_Driver.Start;
end if;
end loop;
end Start;
procedure Stop(Orchester : in T_Orchester) is
begin
for I in Orchester'Range loop
if Orchester(I) /= null and then
Orchester(I).Configured then
Orchester(I).Radias_Driver.stop;
end if;
end loop;
end Stop;
package Menuconfig is new PragmARC.Menu_Handler(80,30);
use Menuconfig, Menuconfig.V_String;
procedure Destroy(Orchester : in out T_Orchester) is
begin
for I in Orchester'Range loop
Orchester(I).Radias_Driver.halt;
Orchester(I) := null;
end loop;
end Destroy;
procedure Afficher(Orchester : in T_Orchester) is
begin
Put_Line("N° , Model , Name , Statut" );
for I in Orchester'Range loop
if Orchester(I) /= null then
Put(Integer'Image(I) & ", " );
Put(T_Model'Image(Orchester(I).Model) & ", " );
Put(Orchester(I).Name.all & ", " );
if Orchester(I).Configured then
Put("Configured" );
else
Put("Not configured" );
end if;
New_Line;
end if;
end loop;
end Afficher;
procedure Create(Instrument : out Radias_access);
procedure Configure(Orchester : in out T_Orchester) is
Empty : Boolean := True;
Main_Choice : Positive range 1..6;
line : String(1..256);
Last,
Instrument_Choice : Natural := 0;
begin
loop
case Empty is
when False =>
declare
Main_Menu : Menu_Info :=
(6, True,
To_Bounded_String("Configuration" ),
(To_Bounded_String("Charger un fichier de configuration" ),
To_Bounded_String("Ajouter un instrument" ),
To_Bounded_String("Supprimer un instrument" ),
To_Bounded_String("Configurer un instrument" ),
To_Bounded_String("Sauvegarder la configuration" ),
To_Bounded_String("Retour a l'ecran principal" )),
4);
begin
Main_Choice := Process(Main_Menu);
end;
when True =>
declare
Main_Menu : Menu_Info :=
(3, True,
To_Bounded_String("Configuration" ),
(To_Bounded_String("Charger un fichier de configuration" ),
To_Bounded_String("Ajouter un instrument" ),
To_Bounded_String("Retour a l'ecran principal" )),
2);
begin
Main_Choice := Process(Main_Menu);
end;
end case;
case Empty is
when False =>
case Main_Choice is
when 1 =>
null;
when 2 =>
null;
when 3 =>
null;
when 4 =>
loop
begin
Put(Clear_Screen);
Afficher(Orchester);
Put("Entrez le N° de l'instrument : " );
Get_line(line, Last);
if Last /= 0 then
Instrument_Choice :=
Natural'Value(Line(1..Last));
else
raise Program_Error;
end if;
if Orchester(Instrument_choice) /= null then
case Orchester(Instrument_choice).Model is
when Unknow =>
null;
when Radias =>
Radias_Configuration
(Orchester(Instrument_Choice));
end case;
end if;
exit;
exception
when Program_Error =>
null;
end;
end loop;
when 5 =>
null;
when 6 =>
exit;
end case;
when True =>
case Main_Choice is
when 1 =>
null;
when 2 =>
if Orchester(1) /= null then
raise Program_Error;
else
Create(Orchester(1));
Empty := False;
end if;
when 3 =>
exit;
when others =>
null;
end case;
end case;
end loop;
end Configure;
use DeviceInfo_Conversion;
use ErrorText_Conversion;
function Model(Name : in string) return T_Model is
Value : T_Model := Unknow;
begin
Value := T_Model'Value
(Name(Name'First..Fixed.Index(Name, " ", forward)));
return Value;
exception
when Constraint_Error =>
return Unknow;
end Model;
type T_Status is (Null_Item, Noteon, Noteoff, Eq, Fx1, Fx2, MstFx);
function Status(Message : Interfaces.C.long) return T_Status;
function data1(Message : Interfaces.C.long) return String;
function data2(Message : Interfaces.C.long) return String;
task body T_Radias_Driver is
task type T_Input_Driver is
entry Halt;
end T_Input_Driver;
task body T_Input_Driver is
task type T_Input is
entry Initialize;
entry Send(Message : out C.Long);
end T_Input;
task body T_Input is
Pm_Event : PmEvent;
begin
accept Initialize;
loop
Pm_Event.Message := Read_handler(Radias.Input.All);
accept Send(Message : out C.Long) do
Message := Pm_Event.Message;
end Send;
end loop;
end T_Input;
The_Chord : T_Chord(1..24);
The_Status : T_Status;
Step_Time : Time := clock;
Step_Length : Duration := 0.1;
Index : Natural := 0;
Message : C.Long;
Input : T_Input;
End_Of_Task : Boolean := False;
begin
Input.Initialize;
while not End_Of_Task loop
select
accept Halt do
End_Of_Task := True;
end Halt;
or
delay 0.0;
end select;
select
Input.Send(Message);
The_Status := Status(Message);
case The_Status is
when Noteon =>
if Clock < Step_Time then
if Index < 5 then
Index := Index + 1;
The_Chord(Index) := (T_value'Value("16#" & data1(Message) & '#') ,T_value'Value("16#" & data2(Message) & '#' ));
end if;
else
if Index /= 0 then
Receive(The_Chord(1..Index));
Index := 0;
end if;
Index := 1;
The_Chord(Index) := (T_value'Value("16#" & data1(Message) & '#') ,T_value'Value("16#" & data2(Message) & '#' ));
Step_Time := Clock + 0.125;
end if;
when Noteoff =>
null;
when others =>
Receive(Message);
end case;
or
delay 0.1;
if Index /= 0 then
Receive(The_Chord(1..Index));
Index := 0;
end if;
end select;
end loop;
abort Input;
end T_Input_Driver;
type Input_Driver_Access is access T_Input_Driver;
Input_driver : Input_Driver_Access;
The_Status : T_Status;
Suspended, End_Of_Task : Boolean := False;
begin
if Radias.With_Input then
Input_driver := new T_Input_Driver;
end if;
while not End_Of_Task loop
select
accept Start do
Put_Line("Starting All timbre..." );
for I in Radias.Timbres'Range loop
Put_Line("Starting timbre N°" & Integer'Image(I));
if Radias.Timbres(I) /= null and then
Radias.Timbres(I).Drums then
Radias.Timbres(I).Drums_Driver.Start;
elsif Radias.Timbres(I) /= null then
Radias.Timbres(I).Timbre_Driver.Start;
end if;
Put_Line("Timbre N°" & Integer'Image(I) & "Started." );
end loop;
Suspended := False;
end Start;
or
accept Halt do
Input_Driver.Halt;
for I in Radias.Timbres'Range loop
if Radias.Timbres(I) /= null and then
Radias.Timbres(I).Drums then
Radias.Timbres(I).Drums_Driver.Halt;
elsif Radias.Timbres(I) /= null then
Radias.Timbres(I).Timbre_Driver.Halt;
end if;
end loop;
Suspended := True;
End_Of_Task := True;
end Halt;
end select;
while not Suspended loop
select
accept Stop do
for I in Radias.Timbres'Range loop
if Radias.Timbres(I) /= null and then
Radias.Timbres(I).Drums then
Radias.Timbres(I).Drums_Driver.Stop;
elsif Radias.Timbres(I) /= null then
Radias.Timbres(I).Timbre_Driver.Stop;
end if;
end loop;
Suspended := True;
end Stop;
or
accept Halt do
Input_Driver.Halt;
for I in Radias.Timbres'Range loop
if Radias.Timbres(I) /= null and then
Radias.Timbres(I).Drums then
Radias.Timbres(I).Drums_Driver.Halt;
elsif Radias.Timbres(I) /= null then
Radias.Timbres(I).Timbre_Driver.Halt;
end if;
end loop;
Suspended := True;
End_Of_Task := True;
end Halt;
or
accept Receive(Message : in C.Long) do
The_Status := Status(Message);
case The_Status is
when Eq =>
null;
when Fx1 =>
null;
when Fx2 =>
null;
when MstFx =>
null;
when others =>
null;
end case;
end Receive;
or
accept Receive(Chord : in T_Chord) do
null;
end Receive;
end select;
end loop;
end loop;
end T_Radias_Driver;
procedure Create(Instrument : out Radias_Access) is
line : String(1..256);
Last,
Choice : Natural := 0;
The_Deviceinfo : DeviceInfo;
Name : T_ErrorText;
With_Input : Boolean;
Current_Model : T_Model := Unknow;
begin
loop
Put("Souhaitez vous connecter un controleur ? (O/N)" );
Get_Immediate(Line(1));
case Line(1) is
when 'n' | 'N' =>
With_Input := False;
exit;
when 'o' | 'O' =>
With_Input := True;
exit;
when others =>
null;
end case;
end loop;
New_Line;
case With_Input is
when False =>
put_Line("Connexion d'un instrument MIDI sans controler..." );
when True =>
Put_Line("Connexion d'un instrument MIDI avec controler..." );
end case;
loop
Put_Line("Choisissez un peripherique de sortie..." );
begin
Put_line("ID, Peripherique" );
for I in 0..Pm_CountDevices-1 loop
The_DeviceInfo :=
DeviceInfo_Conversion.To_pointer(Pm_GetDeviceInfo(I)).all;
if The_Deviceinfo.Output = 1 then
Name := To_Pointer(The_Deviceinfo.name).all;
Put(Integer'Image(I));
Put_line(", " & C.To_Ada(Name));
end if;
end loop;
Put("Entrez l'ID de l'instrument et 'Entree' pour terminer : " );
Get_line(line, Last);
if Last /= 0 then
Choice := Natural'Value(Line(1..Last));
else
raise Program_Error;
end if;
case Choice is
when 0..255 =>
The_DeviceInfo :=
DeviceInfo_Conversion.To_pointer(Pm_GetDeviceInfo(choice)).all;
if The_Deviceinfo.Output = 1 then
Name := To_Pointer(The_Deviceinfo.name).all;
end if;
Current_Model := Model(C.To_Ada(Name));
case Current_Model is
when Unknow =>
raise Program_Error;
when Radias =>
Instrument := new T_Radias(With_Input);
Instrument.Model := Radias;
Instrument.Name := new String '(C.To_Ada(Name));
Instrument.output := new System.Address ' (output_Open_Handler(Choice));
end case;
exit;
when others =>
New_Line;
end case;
exception
when others =>
Last := 0;
Put("Appuyez sur entree pour poursuivre" );
Skip_Line;
New_Line;
end;
end loop;
case With_Input is
when False =>
null;
when True =>
loop
Put_Line("Choisissez un peripherique d'entree..." );
begin
Put_line("ID, Peripherique" );
for I in 0..Pm_CountDevices-1 loop
The_DeviceInfo :=
DeviceInfo_Conversion.To_pointer
(Pm_GetDeviceInfo(I)).all;
if The_Deviceinfo.input = 1 then
Name := To_Pointer(The_Deviceinfo.name).all;
Put(Integer'Image(I));
Put_line(", " & Interfaces.C.To_Ada(Name));
end if;
end loop;
Put("Entrez l'ID du controleur et 'Entree' pour terminer : " );
Get_line(line, Last);
if Last /= 0 then
Choice := Natural'Value(Line(1..Last));
else
return;
end if;
case Choice is
when 0..255 =>
Instrument.Input := new System.Address ' (Input_Open_Handler(Choice));
exit;
when others =>
New_Line;
end case;
exception
when others =>
Last := 0;
Put("Press any key to continue" );
Skip_Line;
New_Line;
end;
end loop;
end case;
end Create;
procedure Configure(Timbre : in Timbre_Access; Num : in Positive);
procedure Radias_Configuration(Radias : in Radias_access) is
Channel : Integer;
line : String(1..256);
Last,
Choice : Natural := 0;
With_Drums : Boolean;
Max_Timbres : Positive;
begin
loop
begin
Put("Entrez le N° de canal pour l'acheminement global : " );
Get_line(line, Last);
if Last /= 0 then
Channel := Natural'Value(Line(1..Last));
else
raise Program_Error;
end if;
case Channel is
when 1..16 =>
Radias.Global_Channel := T_Channel(Channel - 1);
exit;
when others =>
New_Line;
end case;
exception
when others =>
Last := 0;
Put("Appuyez sur entree pour poursuivre" );
Skip_Line;
New_Line;
end;
end loop;
loop
begin
Put("Combien de timbre souhaitez vous initialiser : " );
Get_line(line, Last);
if Last /= 0 then
Choice := Natural'Value(Line(1..Last));
else
raise Program_Error;
end if;
case choice is
when 1..4 =>
Radias.timbres := new T_Timbres_Table(1..Choice);
Max_Timbres := Choice;
exit;
when others =>
New_Line;
end case;
exception
when others =>
Last := 0;
Put("Appuyez sur entree pour poursuivre" );
Skip_Line;
New_Line;
end;
end loop;
loop
Put("Souhaitez vous configurer un timbre pour les drums ? (O/N)" );
Get_Immediate(Line(1));
case Line(1) is
when 'n' | 'N' =>
With_Drums := False;
exit;
when 'o' | 'O' =>
With_Drums := True;
exit;
when others =>
null;
end case;
New_Line;
end loop;
New_Line;
if With_Drums then
loop
begin
Put("Entrez le N° du timbre pour les drums : " );
Get_line(line, Last);
if Last /= 0 then
Choice := Natural'Value(Line(1..Last));
else
raise Program_Error;
end if;
if Choice <= Max_Timbres then
Radias.Timbres(Choice) := new T_Timbre(True, Radias.Output);
exit;
end if;
exception
when others =>
Last := 0;
Put("Appuyez sur entree pour poursuivre" );
Skip_Line;
New_Line;
end;
end loop;
end if;
for I in 1..Radias.Timbres'Length loop
if Radias.Timbres(I) = null then
Radias.Timbres(I) := new T_Timbre(False, Radias.output);
end if;
end loop;
for I in 1..Radias.Timbres'Length loop
Configure(Radias.Timbres(I), I);
end loop;
Radias.Radias_Driver := new T_Radias_Driver(Radias);
Radias.Configured := True;
end Radias_Configuration;
procedure Configure(Timbre : in Timbre_Access; Num : in Positive) is
Channel : Integer;
line : String(1..256);
Last,
Choice : Natural := 0;
begin
if Timbre = null then
raise Timbre_error;
end if;
loop
begin
Put("Entrez le N° de canal pour le timbre N°" &
Integer'Image(Num) & " : " );
Get_line(line, Last);
if Last /= 0 then
Channel := integer'Value(Line(1..Last));
else
raise Program_Error;
end if;
case Channel is
when 1..16 =>
timbre.Channel := T_Channel(Channel - 1);
exit;
when others =>
New_Line;
end case;
exception
when Program_error =>
Last := 0;
Put("Appuyez sur entree pour poursuivre" );
Skip_Line;
New_Line;
end;
end loop;
end Configure;
function Status(Message : Interfaces.C.long) return T_Status is
begin
if Hex_Image(Interfaces.C.Long(Message))' Length > 3 then
if Hex_Image(Interfaces.C.Long(Message))
(Hex_Image(Interfaces.C.Long(Message))' Length-1) =
'9' then
Put("others ::= " & Hex_Image(Interfaces.C.Long(Message)));
return Noteon;
elsif Hex_Image(Interfaces.C.Long(Message))
(Hex_Image(Interfaces.C.Long(Message))' Length-1) =
'8' then
Put("others ::= " & Hex_Image(Interfaces.C.Long(Message)));
return Noteoff;
else
Put("others ::= " & Hex_Image(Interfaces.C.Long(Message)));
return Null_Item;
end if;
else
Put("others ::= " & Hex_Image(Interfaces.C.Long(Message)));
return Null_Item;
end if;
end Status;
function data1(Message : Interfaces.C.long) return string is
begin
return Hex_Image(Interfaces.C.Long(Message))
(Hex_Image(Interfaces.C.Long(Message))' Length-3..
Hex_Image(Interfaces.C.Long(Message)) 'Length-2);
end data1;
function data2(Message : Interfaces.C.long) return string is
begin
return Hex_Image(Interfaces.C.Long(Message))
(Hex_Image(Interfaces.C.Long(Message))' Length-5..
Hex_Image(Interfaces.C.Long(Message)) 'Length-4);
end data2;
task body T_Drums_Driver is
Suspended, End_Of_Task : Boolean := False;
begin
while not End_Of_Task loop
select
accept Start do
Suspended := False;
end Start;
or
accept Halt do
Suspended := True;
End_Of_Task := True;
end Halt;
end select;
while not Suspended loop
select
accept Stop do
Suspended := True;
end Stop;
or
accept Halt do
Suspended := True;
End_Of_Task := True;
end Halt;
or
accept Receive(Chord : in T_Chord) do
null;
end Receive;
end select;
end loop;
end loop;
end T_Drums_Driver;
task body T_Timbre_Driver is
Suspended, End_Of_Task : Boolean := False;
begin
while not End_Of_Task loop
select
accept Start do
Suspended := False;
end Start;
or
accept Halt do
Suspended := True;
End_Of_Task := True;
end Halt;
end select;
while not Suspended loop
select
accept Stop do
Suspended := True;
end Stop;
or
accept Halt do
Suspended := True;
End_Of_Task := True;
end Halt;
or
accept Receive(Chord : in T_Chord) do
null;
end Receive;
end select;
end loop;
end loop;
end T_Timbre_Driver;
end Generic_Orchester;
