1---------------------------------
2-- GID - Generic Image Decoder --
3---------------------------------
4--
5--  Copyright (c) Gautier de Montmollin 2010 .. 2015
6--
7--  Permission is hereby granted, free of charge, to any person obtaining a copy
8--  of this software and associated documentation files (the "Software"), to deal
9--  in the Software without restriction, including without limitation the rights
10--  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
11--  copies of the Software, and to permit persons to whom the Software is
12--  furnished to do so, subject to the following conditions:
13--
14--  The above copyright notice and this permission notice shall be included in
15--  all copies or substantial portions of the Software.
16--
17--  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
18--  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
19--  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
20--  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
21--  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
22--  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
23--  THE SOFTWARE.
24--
25-- NB: this is the MIT License, as found 2-May-2010 on the site
26-- http://www.opensource.org/licenses/mit-license.php
27
28with GID.Headers,
29     GID.Decoding_BMP,
30     GID.Decoding_GIF,
31     GID.Decoding_JPG,
32     GID.Decoding_PNG,
33     GID.Decoding_PNM,
34     GID.Decoding_TGA;
35
36with Ada.Unchecked_Deallocation;
37
38package body GID is
39
40  --  Internal: a few header items (palette, some large JPEG tables)
41  --  are heap allocated; we need to release them upon finalization
42  --  or descriptor reuse.
43
44  procedure Clear_heap_allocated_memory (Object : in out Image_descriptor) is
45    procedure Dispose is
46      new Ada.Unchecked_Deallocation(Color_table, p_Color_table);
47    procedure Dispose is
48      new Ada.Unchecked_Deallocation(
49        JPEG_defs.VLC_table,
50        JPEG_defs.p_VLC_table
51      );
52  begin
53    -- Deterministic garbage collection
54    Dispose(Object.palette);
55    for ad in JPEG_defs.VLC_defs_type'Range(1) loop
56      for idx in JPEG_defs.VLC_defs_type'Range(2) loop
57        Dispose(Object.JPEG_stuff.vlc_defs(ad, idx));
58      end loop;
59    end loop;
60  end Clear_heap_allocated_memory;
61
62  -----------------------
63  -- Load_image_header --
64  -----------------------
65
66  procedure Load_image_header (
67    image   :    out Image_descriptor;
68    from    : in out Ada.Streams.Root_Stream_Type'Class;
69    try_tga :        Boolean:= False
70  )
71  is
72  begin
73    Clear_heap_allocated_memory(image);
74    image.stream:= from'Unchecked_Access;
75    --
76    --  Load the very first symbols of the header,
77    --  this identifies the image format.
78    --
79    Headers.Load_signature(image, try_tga);
80    --
81    case image.format is
82      when BMP =>
83        Headers.Load_BMP_header(image);
84      when FITS =>
85        Headers.Load_FITS_header(image);
86      when GIF =>
87        Headers.Load_GIF_header(image);
88      when JPEG =>
89        Headers.Load_JPEG_header(image);
90      when PNG =>
91        Headers.Load_PNG_header(image);
92      when PNM =>
93        Headers.Load_PNM_header(image);
94      when TGA =>
95        Headers.Load_TGA_header(image);
96      when TIFF =>
97        Headers.Load_TIFF_header(image);
98    end case;
99  end Load_image_header;
100
101  -----------------
102  -- Pixel_width --
103  -----------------
104
105  function Pixel_width (image: Image_descriptor) return Positive is
106  begin
107    return image.width;
108  end Pixel_width;
109
110  ------------------
111  -- Pixel_height --
112  ------------------
113
114  function Pixel_height (image: Image_descriptor) return Positive is
115  begin
116    return image.height;
117  end Pixel_height;
118
119  function Display_orientation (image: Image_descriptor) return Orientation is
120  begin
121    return image.display_orientation;
122  end Display_orientation;
123
124  -------------------------
125  -- Load_image_contents --
126  -------------------------
127
128  procedure Load_image_contents (
129    image     : in out Image_descriptor;
130    next_frame:    out Ada.Calendar.Day_Duration
131  )
132  is
133    procedure BMP_Load is
134      new Decoding_BMP.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback );
135
136    procedure GIF_Load is
137      new Decoding_GIF.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback, mode );
138
139    procedure JPG_Load is
140      new Decoding_JPG.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback );
141
142    procedure PNG_Load is
143      new Decoding_PNG.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback );
144
145    procedure PNM_Load is
146      new Decoding_PNM.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback );
147
148    procedure TGA_Load is
149      new Decoding_TGA.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback );
150
151  begin
152    next_frame:= 0.0;
153    -- ^ value updated in case of animation and when
154    --   current frame is not the last frame
155    case image.format is
156      when BMP =>
157        BMP_Load(image);
158      when GIF =>
159        GIF_Load(image, next_frame);
160      when JPEG =>
161        JPG_Load(image, next_frame);
162      when PNG =>
163        PNG_Load(image);
164      when PNM =>
165        PNM_Load(image);
166      when TGA =>
167        TGA_Load(image);
168      when others =>
169        raise known_but_unsupported_image_format;
170    end case;
171  end Load_image_contents;
172
173  ---------------------------------------
174  -- Some informations about the image --
175  ---------------------------------------
176
177  function Format (image: Image_descriptor) return Image_format_type is
178  begin
179    return image.format;
180  end Format;
181
182  function Detailed_format (image: Image_descriptor) return String is
183  begin
184    return Bounded_255.To_String(image.detailed_format);
185  end Detailed_format;
186
187  function Subformat (image: Image_descriptor) return Integer is
188  begin
189    return image.subformat_id;
190  end Subformat;
191
192  function Bits_per_pixel (image: Image_descriptor) return Positive is
193  begin
194    return image.bits_per_pixel;
195  end Bits_per_pixel;
196
197  function RLE_encoded (image: Image_descriptor) return Boolean is
198  begin
199    return image.RLE_encoded;
200  end RLE_encoded;
201
202  function Interlaced (image: Image_descriptor) return Boolean is
203  begin
204    return image.interlaced;
205  end Interlaced;
206
207  function Greyscale (image: Image_descriptor) return Boolean is
208  begin
209    return image.greyscale;
210  end Greyscale;
211
212  function Has_palette (image: Image_descriptor) return Boolean is
213  begin
214    return image.palette /= null;
215  end Has_palette;
216
217  function Expect_transparency (image: Image_descriptor) return Boolean is
218  begin
219    return image.transparency;
220  end Expect_transparency;
221
222  procedure Adjust (Object : in out Image_descriptor) is
223  begin
224    -- Clone the palette
225    Object.palette:= new Color_table'(Object.palette.all);
226  end Adjust;
227
228  procedure Finalize (Object : in out Image_descriptor) is
229  begin
230    Clear_heap_allocated_memory(Object);
231  end Finalize;
232
233end GID;
234