1--
2-- Convert any image or animation file to PPM file(s).
3--
4-- Small-size demo for the GID (Generic Image Decoder) package.
5-- For a larger example, look for to_bmp.adb .
6--
7
8with GID;
9
10with Ada.Calendar;
11with Ada.Characters.Handling;           use Ada.Characters.Handling;
12with Ada.Command_Line;                  use Ada.Command_Line;
13with Ada.Streams.Stream_IO;             use Ada.Streams.Stream_IO;
14with Ada.Text_IO;                       use Ada.Text_IO;
15with Ada.Unchecked_Deallocation;
16
17with Interfaces;
18
19procedure Mini is
20
21  procedure Blurb is
22  begin
23    Put_Line(Standard_Error, "Mini * Converts any image file to a PPM file");
24    Put_Line(Standard_Error, "Simple test for the GID (Generic Image Decoder) package");
25    Put_Line(Standard_Error, "Package version " & GID.version & " dated " & GID.reference);
26    Put_Line(Standard_Error, "URL: " & GID.web);
27    New_Line(Standard_Error);
28    Put_Line(Standard_Error, "Syntax:");
29    Put_Line(Standard_Error, "mini <image_1> [<image_2>...]");
30    New_Line(Standard_Error);
31  end Blurb;
32
33  use Interfaces;
34
35  type Byte_Array is array(Integer range <>) of Unsigned_8;
36  type p_Byte_Array is access Byte_Array;
37  procedure Dispose is new Ada.Unchecked_Deallocation(Byte_Array, p_Byte_Array);
38
39  img_buf: p_Byte_Array:= null;
40
41  -- Load image into a 24-bit truecolor RGB raw bitmap (for a PPM output)
42  procedure Load_raw_image(
43    image : in out GID.Image_descriptor;
44    buffer: in out p_Byte_Array;
45    next_frame: out Ada.Calendar.Day_Duration
46  )
47  is
48    subtype Primary_color_range is Unsigned_8;
49    image_width : constant Positive:= GID.Pixel_width(image);
50    image_height: constant Positive:= GID.Pixel_height(image);
51    idx: Natural;
52    --
53    procedure Set_X_Y (x, y: Natural) is
54    begin
55      idx:= 3 * (x + image_width * (image_height - 1 - y));
56    end Set_X_Y;
57    --
58    procedure Put_Pixel (
59      red, green, blue : Primary_color_range;
60      alpha            : Primary_color_range
61    )
62    is
63    pragma Warnings(off, alpha); -- alpha is just ignored
64    begin
65      buffer(idx..idx+2):= (red, green, blue);
66      idx:= idx + 3;
67      -- ^ GID requires us to look to next pixel on the right for next time.
68    end Put_Pixel;
69
70    stars: Natural:= 0;
71    procedure Feedback(percents: Natural) is
72      so_far: constant Natural:= percents / 5;
73    begin
74      for i in stars+1..so_far loop
75        Put( Standard_Error, '*');
76      end loop;
77      stars:= so_far;
78    end Feedback;
79
80    procedure Load_image is
81      new GID.Load_image_contents(
82        Primary_color_range, Set_X_Y,
83        Put_Pixel, Feedback, GID.fast
84      );
85
86  begin
87    Dispose(buffer);
88    buffer:= new Byte_Array(0..3 * image_width * image_height - 1);
89    Load_image(image, next_frame);
90  end Load_raw_image;
91
92  procedure Dump_PPM(name: String; i: GID.Image_descriptor) is
93    f: Ada.Streams.Stream_IO.File_Type;
94  begin
95    Create(f, Out_File, name & ".ppm");
96    -- PPM Header:
97    String'Write(
98      Stream(f),
99      "P6 " &
100      Integer'Image(GID.Pixel_width(i)) &
101      Integer'Image(GID.Pixel_height(i)) & " 255" & ASCII.LF
102    );
103    -- PPM raw BGR image:
104    Byte_Array'Write(Stream(f), img_buf.all);
105    -- ^ slow on some Ada systems, see to_bmp to have a faster version
106    Close(f);
107  end Dump_PPM;
108
109  procedure Process(name: String) is
110    f: Ada.Streams.Stream_IO.File_Type;
111    i: GID.Image_descriptor;
112    up_name: constant String:= To_Upper(name);
113    --
114    next_frame, current_frame: Ada.Calendar.Day_Duration:= 0.0;
115  begin
116    --
117    -- Load the image in its original format
118    --
119    Open(f, In_File, name);
120    Put_Line(Standard_Error, "Processing " & name & "...");
121    --
122    GID.Load_image_header(
123      i,
124      Stream(f).all,
125      try_tga =>
126        name'Length >= 4 and then
127        up_name(up_name'Last-3..up_name'Last) = ".TGA"
128    );
129    Put_Line(Standard_Error, ".........v.........v");
130    --
131    loop
132      Load_raw_image(i, img_buf, next_frame);
133      Dump_PPM(name & Duration'Image(current_frame), i);
134      New_Line(Standard_Error);
135      exit when next_frame = 0.0;
136      current_frame:= next_frame;
137    end loop;
138    Close(f);
139  end Process;
140
141begin
142  if Argument_Count=0 then
143    Blurb;
144    return;
145  end if;
146  for i in 1..Argument_Count loop
147    Process(Argument(i));
148  end loop;
149end Mini;
150