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