wl_lib_0.1.3_1c94dc7c/src/wl-images.adb

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
with Ada.Exceptions;

package body WL.Images is

   ------------
   -- Create --
   ------------

   procedure Create
     (Image  : in out Image_Type'Class;
      Width  : Pixel_X_Count;
      Height : Pixel_Y_Count;
      Layers : Layer_Count := 1)
   is
      Layer      : Image_Layer_Record := (Width, Height, others => <>);
   begin
      for I in 1 .. Layers loop
         Layer.Data := new Image_Data (1 .. Width, 1 .. Height);
         Image.Layers.Append (Layer);
      end loop;
   end Create;

   ----------
   -- Read --
   ----------

   procedure Read
     (Reader : Image_Reader'Class;
      Path   : String;
      Image  : out Image_Type'Class)
   is
      File : WL.Binary_IO.File_Type;
   begin
      WL.Binary_IO.Open (File, WL.Binary_IO.In_File, Path);
      Reader.Read (File, Image);
      WL.Binary_IO.Close (File);
   exception
      when E : others =>
         raise Constraint_Error with
           "Unable to read from '"
           & Path & "': " & Ada.Exceptions.Exception_Message (E);
   end Read;

   ---------------
   -- Set_Color --
   ---------------

   procedure Set_Color
     (Image : in out Image_Type'Class;
      X     : Pixel_X_Range;
      Y     : Pixel_Y_Range;
      Color : Image_Color)
   is
   begin
      Image.Set_Color (1, X, Y, Color);
   end Set_Color;

   ---------------
   -- Set_Color --
   ---------------

   procedure Set_Color
     (Image : in out Image_Type'Class;
      Layer : Layer_Index;
      X     : Pixel_X_Range;
      Y     : Pixel_Y_Range;
      Color : Image_Color)
   is
   begin
      Image.Layers (Layer).Data (X, Y) := Color;
   end Set_Color;

   -----------
   -- Write --
   -----------

   procedure Write
     (Writer : Image_Writer'Class;
      Path   : String;
      Image  : Image_Type'Class)
   is
      File : WL.Binary_IO.File_Type;
   begin
      WL.Binary_IO.Create (File, WL.Binary_IO.Out_File, Path);
      Writer.Write (File, Image);
      WL.Binary_IO.Close (File);
   exception
      when E : others =>
         raise Constraint_Error with
           "Unable to write to '"
           & Path & "': " & Ada.Exceptions.Exception_Message (E);
   end Write;

end WL.Images;