Codebase list music123 / 69896b4
Replaced Ustring_List with Ada.Containers. During randomization, Indefinite_Vectors.Swap should swap references more efficiently than with Unbounded_String assignments and reallocation. nicolas.boulenguez 14 years ago
7 changed file(s) with 30 addition(s) and 196 deletion(s). Raw diff Collapse all Expand all
+0
-2
TODO less more
0 * CODING
1 - replace local vector tool by Ada.Containers.Vectors
20 * TRANSLATION
31 - -i message to translate
+3
-4
music123.adb less more
66
77 with Support_Routines; use Support_Routines;
88 with Intl; use Intl;
9 with UString_List; use UString_List;
109
1110 procedure Music123 is
1211 Arg_Num : Positive;
1716 Option_Eternal_Random : Boolean := False;
1817 Option_Ignore_Extension_Case : Boolean := False;
1918 Delay_Length : Duration := 0.5;
20 File_List : UString_List.Vector := New_Vector;
19 File_List : UString_List.Vector;
2120 Program_List : Tool_List.Vector;
2221
2322 function N (Msg : String) return String renames Gettext;
8786 if Check_Filename (Argument (I),
8887 Program_List,
8988 Option_Ignore_Extension_Case) then
90 Append (File_List, To_Unbounded_String (Argument (I)));
89 File_List.Append (Argument (I));
9190 end if;
9291 end loop;
9392 Arg_Num := Argument_Count + 1;
9897 if Check_Filename (Argument (Arg_Num),
9998 Program_List,
10099 Option_Ignore_Extension_Case) then
101 Append (File_List, To_Unbounded_String (Argument (Arg_Num)));
100 File_List.Append (Argument (Arg_Num));
102101 end if;
103102 end if;
104103 Arg_Num := Arg_Num + 1;
+23
-27
support_routines.adb less more
239239 Error (Error_String);
240240 raise Noted_Error;
241241 end if;
242 I := 1;
243 while I <= Length (File_List) loop
244 declare
245 Current_File : constant String := To_String (Get (File_List, I));
242 I := File_List.First_Index;
243 while I <= File_List.Last_Index loop
244 declare
245 Current_File : constant String := File_List.Element (I);
246246 begin
247247 if not File_Exists (Current_File) then
248 Remove (File_List, I);
248 File_List.Delete (I);
249249 I := I - 1;
250250 elsif Is_Directory (Current_File) then
251251 begin
252 Remove (File_List, I);
252 File_List.Delete (I);
253253 I := I - 1;
254254 if Option_Recurse then
255255 Open (Current_Directory, Current_File);
274274 Extension_List,
275275 Option_Ignore_Extension_Case)
276276 then
277 Append (File_List,
278 To_Unbounded_String (Full_Name));
277 File_List.Append (Full_Name);
279278 end if;
280279 end;
281280 end if;
290289 I := I + 1;
291290 end;
292291 end loop;
293 if Empty (File_List) then
292 if File_List.Is_Empty then
294293 Error (N ("No valid filenames found."));
295294 raise Noted_Error;
296295 end if;
299298
300299 procedure Randomize_Names (File_List : in out UString_List.Vector) is
301300
302 A, B : Unbounded_String;
303 J : UString_List.Index;
301 J : Positive;
304302 Gen : Generator;
305 Len : constant Integer := Length (File_List);
306303 begin
307304 Reset (Gen, Integer (Seconds (Clock) * 10.0));
308305 -- From Knuth, TAOCP vol. 2, edition 3, page 146, 3.4.2, algorithm P
309 for I in reverse 2 .. Len loop
310 J := Integer (Float'Floor (Random (Gen) * Float (I))) + 1;
311 A := Get (File_List, I);
312 B := Get (File_List, J);
313 Set (File_List, I, B);
314 Set (File_List, J, A);
306 for I in reverse File_List.First_Index + 1 .. File_List.Last_Index loop
307 J := Integer
308 (Float'Floor (Random (Gen)
309 * Float (I + File_List.First_Index - 1)))
310 + File_List.First_Index;
311 File_List.Swap (I, J);
315312 end loop;
316313 end Randomize_Names;
317314
341338 Option_Eternal_Random : in Boolean;
342339 Option_Ignore_Extension_Case : in Boolean
343340 ) is
344
345 Gen : Generator;
346 Len : Integer;
347341
348342 use Interfaces.C;
349343 function System (Command : char_array) return Integer;
381375 end if;
382376 end Play_A_Song;
383377
378 Gen : Generator;
384379 begin
385380 if Option_Eternal_Random then
386 Len := Length (File_List);
387381 Reset (Gen, Integer (Seconds (Clock) * 10.0));
388382 declare
389 Song_Number : Integer;
383 Len : constant Natural
384 := File_List.Last_Index - File_List.First_Index + 1;
385 Song_Number : Positive;
390386 begin
391387 loop
392388 Song_Number :=
393389 Integer (Float'Floor (Random (Gen) * Float (Len))) + 1;
394 Play_A_Song (To_String (Get (File_List, Song_Number)),
390 Play_A_Song (File_List.Element (Song_Number),
395391 Option_Quiet);
396392 end loop;
397393 end;
402398 end if;
403399
404400 <<Loop_Start>> null;
405 for I in 1 .. Length (File_List) loop
406 Play_A_Song (To_String (Get (File_List, I)), Option_Quiet);
401 for I in File_List.First_Index .. File_List.Last_Index loop
402 Play_A_Song (File_List.Element (I), Option_Quiet);
407403 delay (Delay_Length);
408404 end loop;
409405 if Option_Loop then
429425 Ada.Strings.Both);
430426 begin
431427 if Line /= "" and then Line (1) /= '#' then
432 Append (File_List, To_Unbounded_String (Line));
428 File_List.Append (Line);
433429 end if;
434430 end;
435431 end loop;
+4
-1
support_routines.ads less more
00 with Ada.Containers.Vectors;
1 with UString_List; use UString_List;
1 with Ada.Containers.Indefinite_Vectors;
22 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
33 with Intl;
44
55 package Support_Routines is
6
7 package UString_List is new Ada.Containers.Indefinite_Vectors
8 (Positive, String);
69
710 function N (Msg : String) return String renames Intl.Gettext;
811
+0
-4
ustring_list.ads less more
0 with Vector;
1 with Ada.Strings.Unbounded;
2
3 package UString_List is new Vector (Ada.Strings.Unbounded.Unbounded_String);
+0
-115
vector.adb less more
0 with Ada.Unchecked_Deallocation;
1
2 package body Vector is
3 -- if Debug then checks end if; must be constant to be optimized properly
4 -- which is the only point of Debug := False.
5 Debug : constant Boolean := True;
6 function Advance_N (Start : Index; Times : Integer) return Index;
7
8 procedure Delete is new Ada.Unchecked_Deallocation (Real_Vector, RV_Access);
9
10 function New_Vector return Vector is
11 New_Real_Length : constant Index := Advance (0);
12 New_Vect : Vector;
13 begin
14 New_Vect.Vect := new Real_Vector (1 .. New_Real_Length);
15 New_Vect.Length := 0;
16 New_Vect.Real_Length := New_Real_Length;
17 return New_Vect;
18 end New_Vector;
19
20 procedure Init (New_Vect : out Vector) is
21 New_Real_Length : constant Index := Advance (0);
22 begin
23 New_Vect.Vect := new Real_Vector (1 .. New_Real_Length);
24 New_Vect.Length := 0;
25 New_Vect.Real_Length := New_Real_Length;
26 end Init;
27
28 procedure Reinit (Vect : in out Vector) is
29 New_Real_Length : constant Index := Advance (0);
30 begin
31 Delete (Vect.Vect);
32 Vect.Vect := new Real_Vector (1 .. New_Real_Length);
33 Vect.Length := 0;
34 Vect.Real_Length := New_Real_Length;
35 end Reinit;
36
37 function Advance_N (Start : Index; Times : Integer) return Index is
38 Final_Size : Index := Start;
39 begin
40 for I in 1 .. Times loop
41 Final_Size := Advance (Final_Size);
42 end loop;
43 return Final_Size;
44 end Advance_N;
45 pragma Inline (Advance_N);
46
47 procedure Expand (Vect : in out Vector; Times : Integer := 1) is
48 New_Real_Length : constant Index := Advance_N (Vect.Real_Length, Times);
49 NRV_Access : RV_Access;
50 begin
51 NRV_Access := new Real_Vector (1 .. New_Real_Length);
52 for I in 1 .. Vect.Length loop
53 NRV_Access.all (I) := Vect.Vect.all (I);
54 end loop;
55 Delete (Vect.Vect);
56 Vect.Vect := NRV_Access;
57 Vect.Real_Length := New_Real_Length;
58 end Expand;
59
60 procedure Append (Vect : in out Vector; Tail : Component) is
61 begin
62 if Vect.Vect = null then
63 Init (Vect);
64 end if;
65 if Vect.Length = Vect.Real_Length then
66 Expand (Vect);
67 end if;
68 Vect.Vect.all (Vect.Length + 1) := Tail;
69 Vect.Length := Index'Succ (Vect.Length);
70 end Append;
71
72 function Get (Vect : Vector; Pos : Index) return Component is
73 begin
74 if Debug and then (Pos > Vect.Length or else Pos = 0) then
75 raise Bad_Position;
76 end if;
77 return Vect.Vect.all (Pos);
78 end Get;
79
80 procedure Set (Vect : in out Vector; Pos : in Index; Item : in Component) is
81 begin
82 if Debug and then Pos > Vect.Length then
83 raise Bad_Position;
84 end if;
85 Vect.Vect.all (Pos) := Item;
86 end Set;
87
88 procedure Remove (Vect : in out Vector; Pos : in Index) is begin
89 for I in Pos .. Vect.Length - 1 loop
90 Set (Vect, I, Get (Vect, I + 1));
91 end loop;
92 Vect.Length := Vect.Length - 1;
93 end Remove;
94
95 function Empty (Vect : Vector) return Boolean is begin
96 return Vect.Length = 0;
97 end Empty;
98
99 function Length (Vect : Vector) return Index is begin
100 return Vect.Length;
101 end Length;
102
103 function Advance (Old_Size : Natural) return Natural is
104 begin
105 if Old_Size < 250 then
106 return 500;
107 elsif Old_Size < 1_000_000 then
108 return Old_Size * 2;
109 else
110 return Old_Size + 1_000_000;
111 end if;
112 end Advance;
113
114 end Vector;
+0
-43
vector.ads less more
0 generic
1 type Component is private;
2 package Vector is
3
4 subtype Index is Natural;
5
6 type Vector is private;
7
8 Bad_Position : exception;
9
10 -- If the first operation is an append, then init is unnessecary.
11 function New_Vector return Vector;
12 procedure Init (New_Vect : out Vector);
13 procedure Reinit (Vect : in out Vector);
14 procedure Append (Vect : in out Vector; Tail : Component);
15 procedure Expand (Vect : in out Vector; Times : Integer := 1);
16 function Get (Vect : Vector; Pos : Index) return Component;
17 procedure Set (Vect : in out Vector; Pos : in Index; Item : in Component);
18 procedure Remove (Vect : in out Vector; Pos : in Index);
19 function Length (Vect : Vector) return Index;
20 function Empty (Vect : Vector) return Boolean;
21 function Advance (Old_Size : Index) return Index;
22
23 private
24
25 pragma Inline (Append);
26 pragma Inline (Expand);
27 pragma Inline (Get);
28 pragma Inline (Set);
29 pragma Inline (Length);
30 pragma Inline (Empty);
31
32 type Real_Vector is array (Index range <>) of Component;
33
34 type RV_Access is access Real_Vector;
35
36 type Vector is record
37 Length : Index; -- The index following the last one.
38 Real_Length : Index; -- The actual length of the vector
39 Vect : RV_Access;
40 end record;
41
42 end Vector;