From b3f9e96403aa5cb9d7db2330aa579356d1d58b6f Mon Sep 17 00:00:00 2001 From: Jedidiah Barber Date: Mon, 23 Dec 2024 17:02:34 +1300 Subject: Tweaked the names of Surface_Device subhierarchy --- src/fltk-devices-surface-copy.adb | 156 ++++++++++++ src/fltk-devices-surface-copy.ads | 82 ++++++ src/fltk-devices-surface-image.adb | 171 +++++++++++++ src/fltk-devices-surface-image.ads | 96 +++++++ src/fltk-devices-surface-paged-printers.adb | 358 ++++++++++++++++++++++++++ src/fltk-devices-surface-paged-printers.ads | 141 +++++++++++ src/fltk-devices-surface-paged.adb | 359 +++++++++++++++++++++++++++ src/fltk-devices-surface-paged.ads | 153 ++++++++++++ src/fltk-devices-surface.adb | 93 +++++++ src/fltk-devices-surface.ads | 65 +++++ src/fltk-devices-surfaces-copy.adb | 155 ------------ src/fltk-devices-surfaces-copy.ads | 85 ------- src/fltk-devices-surfaces-image.adb | 170 ------------- src/fltk-devices-surfaces-image.ads | 100 -------- src/fltk-devices-surfaces-paged-printers.adb | 357 -------------------------- src/fltk-devices-surfaces-paged-printers.ads | 145 ----------- src/fltk-devices-surfaces-paged.adb | 358 -------------------------- src/fltk-devices-surfaces-paged.ads | 156 ------------ src/fltk-devices-surfaces.adb | 92 ------- src/fltk-devices-surfaces.ads | 68 ----- 20 files changed, 1674 insertions(+), 1686 deletions(-) create mode 100644 src/fltk-devices-surface-copy.adb create mode 100644 src/fltk-devices-surface-copy.ads create mode 100644 src/fltk-devices-surface-image.adb create mode 100644 src/fltk-devices-surface-image.ads create mode 100644 src/fltk-devices-surface-paged-printers.adb create mode 100644 src/fltk-devices-surface-paged-printers.ads create mode 100644 src/fltk-devices-surface-paged.adb create mode 100644 src/fltk-devices-surface-paged.ads create mode 100644 src/fltk-devices-surface.adb create mode 100644 src/fltk-devices-surface.ads delete mode 100644 src/fltk-devices-surfaces-copy.adb delete mode 100644 src/fltk-devices-surfaces-copy.ads delete mode 100644 src/fltk-devices-surfaces-image.adb delete mode 100644 src/fltk-devices-surfaces-image.ads delete mode 100644 src/fltk-devices-surfaces-paged-printers.adb delete mode 100644 src/fltk-devices-surfaces-paged-printers.ads delete mode 100644 src/fltk-devices-surfaces-paged.adb delete mode 100644 src/fltk-devices-surfaces-paged.ads delete mode 100644 src/fltk-devices-surfaces.adb delete mode 100644 src/fltk-devices-surfaces.ads (limited to 'src') diff --git a/src/fltk-devices-surface-copy.adb b/src/fltk-devices-surface-copy.adb new file mode 100644 index 0000000..fe96f91 --- /dev/null +++ b/src/fltk-devices-surface-copy.adb @@ -0,0 +1,156 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Devices.Surface.Copy is + + + function new_fl_copy_surface + (W, H : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_copy_surface, "new_fl_copy_surface"); + pragma Inline (new_fl_copy_surface); + + procedure free_fl_copy_surface + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_copy_surface, "free_fl_copy_surface"); + pragma Inline (free_fl_copy_surface); + + + + + function fl_copy_surface_get_w + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_copy_surface_get_w, "fl_copy_surface_get_w"); + pragma Inline (fl_copy_surface_get_w); + + function fl_copy_surface_get_h + (S : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_copy_surface_get_h, "fl_copy_surface_get_h"); + pragma Inline (fl_copy_surface_get_h); + + + + + procedure fl_copy_surface_draw + (S, W : in Storage.Integer_Address; + OX, OY : in Interfaces.C.int); + pragma Import (C, fl_copy_surface_draw, "fl_copy_surface_draw"); + pragma Inline (fl_copy_surface_draw); + + procedure fl_copy_surface_draw_decorated_window + (S, W : in Storage.Integer_Address; + OX, OY : in Interfaces.C.int); + pragma Import (C, fl_copy_surface_draw_decorated_window, + "fl_copy_surface_draw_decorated_window"); + pragma Inline (fl_copy_surface_draw_decorated_window); + + + + + procedure fl_copy_surface_set_current + (S : in Storage.Integer_Address); + pragma Import (C, fl_copy_surface_set_current, "fl_copy_surface_set_current"); + pragma Inline (fl_copy_surface_set_current); + + + + + procedure Finalize + (This : in out Copy_Surface) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_copy_surface (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + package body Forge is + + function Create + (W, H : in Natural) + return Copy_Surface is + begin + return This : Copy_Surface do + This.Void_Ptr := new_fl_copy_surface + (Interfaces.C.int (W), + Interfaces.C.int (H)); + end return; + end Create; + + pragma Inline (Create); + + end Forge; + + + + + function Get_W + (This : in Copy_Surface) + return Integer is + begin + return Integer (fl_copy_surface_get_w (This.Void_Ptr)); + end Get_W; + + + function Get_H + (This : in Copy_Surface) + return Integer is + begin + return Integer (fl_copy_surface_get_h (This.Void_Ptr)); + end Get_H; + + + + + procedure Draw_Widget + (This : in out Copy_Surface; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_copy_surface_draw + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Draw_Widget; + + + procedure Draw_Decorated_Window + (This : in out Copy_Surface; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_copy_surface_draw_decorated_window + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Draw_Decorated_Window; + + + + + procedure Set_Current + (This : in out Copy_Surface) is + begin + fl_copy_surface_set_current (This.Void_Ptr); + Current_Ptr := This'Unchecked_Access; + end Set_Current; + + +end FLTK.Devices.Surface.Copy; + + diff --git a/src/fltk-devices-surface-copy.ads b/src/fltk-devices-surface-copy.ads new file mode 100644 index 0000000..f5069c5 --- /dev/null +++ b/src/fltk-devices-surface-copy.ads @@ -0,0 +1,82 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups.Windows; + + +package FLTK.Devices.Surface.Copy is + + + type Copy_Surface is new Surface_Device with private; + + type Copy_Surface_Reference (Data : not null access Copy_Surface'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (W, H : in Natural) + return Copy_Surface; + + end Forge; + + + + + function Get_W + (This : in Copy_Surface) + return Integer; + + function Get_H + (This : in Copy_Surface) + return Integer; + + + + + procedure Draw_Widget + (This : in out Copy_Surface; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Draw_Decorated_Window + (This : in out Copy_Surface; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0); + + + + + procedure Set_Current + (This : in out Copy_Surface); + + +private + + + type Copy_Surface is new Surface_Device with null record; + + overriding procedure Finalize + (This : in out Copy_Surface); + + + pragma Inline (Get_W); + pragma Inline (Get_H); + + pragma Inline (Draw_Widget); + pragma Inline (Draw_Decorated_Window); + + pragma Inline (Set_Current); + + +end FLTK.Devices.Surface.Copy; + + diff --git a/src/fltk-devices-surface-image.adb b/src/fltk-devices-surface-image.adb new file mode 100644 index 0000000..d9a5e1b --- /dev/null +++ b/src/fltk-devices-surface-image.adb @@ -0,0 +1,171 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + + +package body FLTK.Devices.Surface.Image is + + + function new_fl_image_surface + (W, H, R : in Interfaces.C.int) + return Storage.Integer_Address; + pragma Import (C, new_fl_image_surface, "new_fl_image_surface"); + pragma Inline (new_fl_image_surface); + + procedure free_fl_image_surface + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_image_surface, "free_fl_image_surface"); + pragma Inline (free_fl_image_surface); + + + + + procedure fl_image_surface_draw + (S, I : in Storage.Integer_Address; + OX, OY : in Interfaces.C.int); + pragma Import (C, fl_image_surface_draw, "fl_image_surface_draw"); + pragma Inline (fl_image_surface_draw); + + procedure fl_image_surface_draw_decorated_window + (S, I : in Storage.Integer_Address; + OX, OY : in Interfaces.C.int); + pragma Import (C, fl_image_surface_draw_decorated_window, + "fl_image_surface_draw_decorated_window"); + pragma Inline (fl_image_surface_draw_decorated_window); + + + + + function fl_image_surface_image + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_image_surface_image, "fl_image_surface_image"); + pragma Inline (fl_image_surface_image); + + function fl_image_surface_highres_image + (S : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, fl_image_surface_highres_image, "fl_image_surface_highres_image"); + pragma Inline (fl_image_surface_highres_image); + + + + + procedure fl_image_surface_set_current + (S : in Storage.Integer_Address); + pragma Import (C, fl_image_surface_set_current, "fl_image_surface_set_current"); + pragma Inline (fl_image_surface_set_current); + + + + + procedure Finalize + (This : in out Image_Surface) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_image_surface (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + package body Forge is + + function Create + (W, H : in Integer; + Highres : in Boolean := False) + return Image_Surface is + begin + return This : Image_Surface do + This.Void_Ptr := new_fl_image_surface + (Interfaces.C.int (W), + Interfaces.C.int (H), + Boolean'Pos (Highres)); + This.High := Highres; + end return; + end Create; + + end Forge; + + + + + function Is_Highres + (This : in Image_Surface) + return Boolean is + begin + return This.High; + end Is_Highres; + + + + + procedure Draw_Widget + (This : in out Image_Surface; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_image_surface_draw + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Draw_Widget; + + + procedure Draw_Decorated_Window + (This : in out Image_Surface; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_image_surface_draw_decorated_window + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Draw_Decorated_Window; + + + + + function Get_Image + (This : in Image_Surface) + return FLTK.Images.RGB.RGB_Image is + begin + return Img : FLTK.Images.RGB.RGB_Image do + Wrapper (Img).Void_Ptr := fl_image_surface_image (This.Void_Ptr); + end return; + end Get_Image; + + + function Get_Highres_Image + (This : in Image_Surface) + return FLTK.Images.Shared.Shared_Image is + begin + return Img : FLTK.Images.Shared.Shared_Image do + Wrapper (Img).Void_Ptr := fl_image_surface_highres_image (This.Void_Ptr); + end return; + end Get_Highres_Image; + + + + + procedure Set_Current + (This : in out Image_Surface) is + begin + fl_image_surface_set_current (This.Void_Ptr); + Current_Ptr := This'Unchecked_Access; + end Set_Current; + + +end FLTK.Devices.Surface.Image; + + diff --git a/src/fltk-devices-surface-image.ads b/src/fltk-devices-surface-image.ads new file mode 100644 index 0000000..961a9b2 --- /dev/null +++ b/src/fltk-devices-surface-image.ads @@ -0,0 +1,96 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Images.RGB, + FLTK.Images.Shared, + FLTK.Widgets.Groups.Windows; + + +package FLTK.Devices.Surface.Image is + + + type Image_Surface is new Surface_Device with private; + + type Image_Surface_Reference (Data : not null access Image_Surface'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (W, H : in Integer; + Highres : in Boolean := False) + return Image_Surface; + + end Forge; + + + + + function Is_Highres + (This : in Image_Surface) + return Boolean; + + + + + procedure Draw_Widget + (This : in out Image_Surface; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Draw_Decorated_Window + (This : in out Image_Surface; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0); + + + + + function Get_Image + (This : in Image_Surface) + return FLTK.Images.RGB.RGB_Image; + + function Get_Highres_Image + (This : in Image_Surface) + return FLTK.Images.Shared.Shared_Image; + + + + + procedure Set_Current + (This : in out Image_Surface); + + +private + + + type Image_Surface is new Surface_Device with record + High : Boolean := False; + end record; + + overriding procedure Finalize + (This : in out Image_Surface); + + + pragma Inline (Is_Highres); + + pragma Inline (Draw_Widget); + pragma Inline (Draw_Decorated_Window); + + pragma Inline (Get_Image); + pragma Inline (Get_Highres_Image); + + pragma Inline (Set_Current); + + +end FLTK.Devices.Surface.Image; + + diff --git a/src/fltk-devices-surface-paged-printers.adb b/src/fltk-devices-surface-paged-printers.adb new file mode 100644 index 0000000..f5c964a --- /dev/null +++ b/src/fltk-devices-surface-paged-printers.adb @@ -0,0 +1,358 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Devices.Surface.Paged.Printers is + + + function new_fl_printer + return Storage.Integer_Address; + pragma Import (C, new_fl_printer, "new_fl_printer"); + pragma Inline (new_fl_printer); + + procedure free_fl_printer + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_printer, "free_fl_printer"); + pragma Inline (free_fl_printer); + + + + + function fl_printer_start_job + (D : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_printer_start_job, "fl_printer_start_job"); + pragma Inline (fl_printer_start_job); + + function fl_printer_start_job2 + (D : in Storage.Integer_Address; + C, F, T : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_printer_start_job2, "fl_printer_start_job2"); + pragma Inline (fl_printer_start_job2); + + procedure fl_printer_end_job + (D : in Storage.Integer_Address); + pragma Import (C, fl_printer_end_job, "fl_printer_end_job"); + pragma Inline (fl_printer_end_job); + + function fl_printer_start_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_printer_start_page, "fl_printer_start_page"); + pragma Inline (fl_printer_start_page); + + function fl_printer_end_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_printer_end_page, "fl_printer_end_page"); + pragma Inline (fl_printer_end_page); + + + + + procedure fl_printer_margins + (D : in Storage.Integer_Address; + L, T, R, B : out Interfaces.C.int); + pragma Import (C, fl_printer_margins, "fl_printer_margins"); + pragma Inline (fl_printer_margins); + + function fl_printer_printable_rect + (D : in Storage.Integer_Address; + W, H : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_printer_printable_rect, "fl_printer_printable_rect"); + pragma Inline (fl_printer_printable_rect); + + procedure fl_printer_get_origin + (D : in Storage.Integer_Address; + X, Y : out Interfaces.C.int); + pragma Import (C, fl_printer_get_origin, "fl_printer_get_origin"); + pragma Inline (fl_printer_get_origin); + + procedure fl_printer_set_origin + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_printer_set_origin, "fl_printer_set_origin"); + pragma Inline (fl_printer_set_origin); + + procedure fl_printer_rotate + (D : in Storage.Integer_Address; + R : in Interfaces.C.C_float); + pragma Import (C, fl_printer_rotate, "fl_printer_rotate"); + pragma Inline (fl_printer_rotate); + + procedure fl_printer_scale + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.C_float); + pragma Import (C, fl_printer_scale, "fl_printer_scale"); + pragma Inline (fl_printer_scale); + + procedure fl_printer_translate + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_printer_translate, "fl_printer_translate"); + pragma Inline (fl_printer_translate); + + procedure fl_printer_untranslate + (D : in Storage.Integer_Address); + pragma Import (C, fl_printer_untranslate, "fl_printer_untranslate"); + pragma Inline (fl_printer_untranslate); + + + + + procedure fl_printer_print_widget + (D, I : in Storage.Integer_Address; + DX, DY : in Interfaces.C.int); + pragma Import (C, fl_printer_print_widget, "fl_printer_print_widget"); + pragma Inline (fl_printer_print_widget); + + procedure fl_printer_print_window_part + (D, I : in Storage.Integer_Address; + X, Y, W, H, DX, DY : in Interfaces.C.int); + pragma Import (C, fl_printer_print_window_part, "fl_printer_print_window_part"); + pragma Inline (fl_printer_print_window_part); + + + + + procedure fl_printer_set_current + (D : in Storage.Integer_Address); + pragma Import (C, fl_printer_set_current, "fl_printer_set_current"); + pragma Inline (fl_printer_set_current); + + + + + procedure Finalize + (This : in out Printer) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_printer (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + package body Forge is + + function Create + return Printer is + begin + return This : Printer do + This.Void_Ptr := new_fl_printer; + end return; + end Create; + + pragma Inline (Create); + + end Forge; + + + + + procedure Start_Job + (This : in out Printer; + Count : in Natural) is + begin + if fl_printer_start_job + (This.Void_Ptr, Interfaces.C.int (Count)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure Start_Job + (This : in out Printer; + Count : in Natural; + From, To : in Positive) is + begin + if fl_printer_start_job2 + (This.Void_Ptr, + Interfaces.C.int (Count), + Interfaces.C.int (From), + Interfaces.C.int (To)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure End_Job + (This : in out Printer) is + begin + fl_printer_end_job (This.Void_Ptr); + end End_Job; + + + procedure Start_Page + (This : in out Printer) is + begin + if fl_printer_start_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end Start_Page; + + + procedure End_Page + (This : in out Printer) is + begin + if fl_printer_end_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end End_Page; + + + + + procedure Get_Margins + (This : in Printer; + Left, Top, Right, Bottom : out Integer) is + begin + fl_printer_margins + (This.Void_Ptr, + Interfaces.C.int (Left), + Interfaces.C.int (Top), + Interfaces.C.int (Right), + Interfaces.C.int (Bottom)); + end Get_Margins; + + + procedure Get_Printable_Rect + (This : in Printer; + W, H : out Integer) is + begin + if fl_printer_printable_rect + (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)) /= 0 + then + raise Page_Error; + end if; + end Get_Printable_Rect; + + + procedure Get_Origin + (This : in Printer; + X, Y : out Integer) is + begin + fl_printer_get_origin (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)); + end Get_Origin; + + + procedure Set_Origin + (This : in out Printer; + X, Y : in Integer) is + begin + fl_printer_set_origin + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Set_Origin; + + + procedure Rotate + (This : in out Printer; + Degrees : in Float) is + begin + fl_printer_rotate (This.Void_Ptr, Interfaces.C.C_float (Degrees)); + end Rotate; + + + procedure Scale + (This : in out Printer; + Factor : in Float) is + begin + fl_printer_scale (This.Void_Ptr, Interfaces.C.C_float (Factor), 0.0); + end Scale; + + + procedure Scale + (This : in out Printer; + Factor_X, Factor_Y : in Float) is + begin + fl_printer_scale + (This.Void_Ptr, + Interfaces.C.C_float (Factor_X), + Interfaces.C.C_float (Factor_Y)); + end Scale; + + + procedure Translate + (This : in out Printer; + Delta_X, Delta_Y : in Integer) is + begin + fl_printer_translate + (This.Void_Ptr, + Interfaces.C.int (Delta_X), + Interfaces.C.int (Delta_Y)); + end Translate; + + + procedure Untranslate + (This : in out Printer) is + begin + fl_printer_untranslate (This.Void_Ptr); + end Untranslate; + + + + + procedure Print_Widget + (This : in out Printer; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_printer_print_widget + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Widget; + + + procedure Print_Window_Part + (This : in out Printer; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + X, Y, W, H : in Integer; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_printer_print_window_part + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Window_Part; + + + + + procedure Set_Current + (This : in out Printer) is + begin + fl_printer_set_current (This.Void_Ptr); + Current_Ptr := This'Unchecked_Access; + end Set_Current; + + +end FLTK.Devices.Surface.Paged.Printers; + + diff --git a/src/fltk-devices-surface-paged-printers.ads b/src/fltk-devices-surface-paged-printers.ads new file mode 100644 index 0000000..ac5294d --- /dev/null +++ b/src/fltk-devices-surface-paged-printers.ads @@ -0,0 +1,141 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups.Windows; + + +package FLTK.Devices.Surface.Paged.Printers is + + + type Printer is new Paged_Device with private; + + type Printer_Reference (Data : not null access Printer'Class) is limited null record + with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + return Printer; + + end Forge; + + + + + procedure Start_Job + (This : in out Printer; + Count : in Natural); + + procedure Start_Job + (This : in out Printer; + Count : in Natural; + From, To : in Positive); + + procedure End_Job + (This : in out Printer); + + procedure Start_Page + (This : in out Printer); + + procedure End_Page + (This : in out Printer); + + + + + procedure Get_Margins + (This : in Printer; + Left, Top, Right, Bottom : out Integer); + + procedure Get_Printable_Rect + (This : in Printer; + W, H : out Integer); + + procedure Get_Origin + (This : in Printer; + X, Y : out Integer); + + procedure Set_Origin + (This : in out Printer; + X, Y : in Integer); + + procedure Rotate + (This : in out Printer; + Degrees : in Float); + + procedure Scale + (This : in out Printer; + Factor : in Float); + + procedure Scale + (This : in out Printer; + Factor_X, Factor_Y : in Float); + + procedure Translate + (This : in out Printer; + Delta_X, Delta_Y : in Integer); + + procedure Untranslate + (This : in out Printer); + + + + + procedure Print_Widget + (This : in out Printer; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Print_Window_Part + (This : in out Printer; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + X, Y, W, H : in Integer; + Offset_X, Offset_Y : in Integer := 0); + + + + + procedure Set_Current + (This : in out Printer); + + +private + + + type Printer is new Paged_Device with null record; + + overriding procedure Finalize + (This : in out Printer); + + + pragma Inline (Start_Job); + pragma Inline (End_Job); + pragma Inline (Start_Page); + pragma Inline (End_Page); + + pragma Inline (Get_Margins); + pragma Inline (Get_Printable_Rect); + pragma Inline (Get_Origin); + pragma Inline (Set_Origin); + pragma Inline (Rotate); + pragma Inline (Scale); + pragma Inline (Translate); + pragma Inline (Untranslate); + + pragma Inline (Print_Widget); + pragma Inline (Print_Window_Part); + + pragma Inline (Set_Current); + + +end FLTK.Devices.Surface.Paged.Printers; + + diff --git a/src/fltk-devices-surface-paged.adb b/src/fltk-devices-surface-paged.adb new file mode 100644 index 0000000..75957c5 --- /dev/null +++ b/src/fltk-devices-surface-paged.adb @@ -0,0 +1,359 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + Interfaces.C; + +use type + + Interfaces.C.int; + + +package body FLTK.Devices.Surface.Paged is + + + function new_fl_paged_device + return Storage.Integer_Address; + pragma Import (C, new_fl_paged_device, "new_fl_paged_device"); + pragma Inline (new_fl_paged_device); + + procedure free_fl_paged_device + (D : in Storage.Integer_Address); + pragma Import (C, free_fl_paged_device, "free_fl_paged_device"); + pragma Inline (free_fl_paged_device); + + + + + function fl_paged_device_start_job + (D : in Storage.Integer_Address; + C : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_start_job, "fl_paged_device_start_job"); + pragma Inline (fl_paged_device_start_job); + + function fl_paged_device_start_job2 + (D : in Storage.Integer_Address; + C, F, T : in Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_start_job2, "fl_paged_device_start_job2"); + pragma Inline (fl_paged_device_start_job2); + + procedure fl_paged_device_end_job + (D : in Storage.Integer_Address); + pragma Import (C, fl_paged_device_end_job, "fl_paged_device_end_job"); + pragma Inline (fl_paged_device_end_job); + + function fl_paged_device_start_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_start_page, "fl_paged_device_start_page"); + pragma Inline (fl_paged_device_start_page); + + function fl_paged_device_end_page + (D : in Storage.Integer_Address) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_end_page, "fl_paged_device_end_page"); + pragma Inline (fl_paged_device_end_page); + + + + + procedure fl_paged_device_margins + (D : in Storage.Integer_Address; + L, T, R, B : out Interfaces.C.int); + pragma Import (C, fl_paged_device_margins, "fl_paged_device_margins"); + pragma Inline (fl_paged_device_margins); + + function fl_paged_device_printable_rect + (D : in Storage.Integer_Address; + W, H : out Interfaces.C.int) + return Interfaces.C.int; + pragma Import (C, fl_paged_device_printable_rect, "fl_paged_device_printable_rect"); + pragma Inline (fl_paged_device_printable_rect); + + procedure fl_paged_device_get_origin + (D : in Storage.Integer_Address; + X, Y : out Interfaces.C.int); + pragma Import (C, fl_paged_device_get_origin, "fl_paged_device_get_origin"); + pragma Inline (fl_paged_device_get_origin); + + procedure fl_paged_device_set_origin + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_paged_device_set_origin, "fl_paged_device_set_origin"); + pragma Inline (fl_paged_device_set_origin); + + procedure fl_paged_device_rotate + (D : in Storage.Integer_Address; + R : in Interfaces.C.C_float); + pragma Import (C, fl_paged_device_rotate, "fl_paged_device_rotate"); + pragma Inline (fl_paged_device_rotate); + + procedure fl_paged_device_scale + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.C_float); + pragma Import (C, fl_paged_device_scale, "fl_paged_device_scale"); + pragma Inline (fl_paged_device_scale); + + procedure fl_paged_device_translate + (D : in Storage.Integer_Address; + X, Y : in Interfaces.C.int); + pragma Import (C, fl_paged_device_translate, "fl_paged_device_translate"); + pragma Inline (fl_paged_device_translate); + + procedure fl_paged_device_untranslate + (D : in Storage.Integer_Address); + pragma Import (C, fl_paged_device_untranslate, "fl_paged_device_untranslate"); + pragma Inline (fl_paged_device_untranslate); + + + + + procedure fl_paged_device_print_widget + (D, I : in Storage.Integer_Address; + DX, DY : in Interfaces.C.int); + pragma Import (C, fl_paged_device_print_widget, "fl_paged_device_print_widget"); + pragma Inline (fl_paged_device_print_widget); + + procedure fl_paged_device_print_window + (D, I : in Storage.Integer_Address; + DX, DY : in Interfaces.C.int); + pragma Import (C, fl_paged_device_print_window, "fl_paged_device_print_window"); + pragma Inline (fl_paged_device_print_window); + + procedure fl_paged_device_print_window_part + (D, I : in Storage.Integer_Address; + X, Y, W, H, DX, DY : in Interfaces.C.int); + pragma Import (C, fl_paged_device_print_window_part, "fl_paged_device_print_window_part"); + pragma Inline (fl_paged_device_print_window_part); + + + + + procedure Finalize + (This : in out Paged_Device) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_paged_device (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + package body Forge is + + function Create + return Paged_Device is + begin + return This : Paged_Device do + This.Void_Ptr := new_fl_paged_device; + end return; + end Create; + + pragma Inline (Create); + + end Forge; + + + + + procedure Start_Job + (This : in out Paged_Device; + Count : in Natural) is + begin + if fl_paged_device_start_job + (This.Void_Ptr, Interfaces.C.int (Count)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure Start_Job + (This : in out Paged_Device; + Count : in Natural; + From, To : in Positive) is + begin + if fl_paged_device_start_job2 + (This.Void_Ptr, + Interfaces.C.int (Count), + Interfaces.C.int (From), + Interfaces.C.int (To)) /= 0 + then + raise Page_Error; + end if; + end Start_Job; + + + procedure End_Job + (This : in out Paged_Device) is + begin + fl_paged_device_end_job (This.Void_Ptr); + end End_Job; + + + procedure Start_Page + (This : in out Paged_Device) is + begin + if fl_paged_device_start_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end Start_Page; + + + procedure End_Page + (This : in out Paged_Device) is + begin + if fl_paged_device_end_page (This.Void_Ptr) /= 0 then + raise Page_Error; + end if; + end End_Page; + + + + + procedure Get_Margins + (This : in Paged_Device; + Left, Top, Right, Bottom : out Integer) is + begin + fl_paged_device_margins + (This.Void_Ptr, + Interfaces.C.int (Left), + Interfaces.C.int (Top), + Interfaces.C.int (Right), + Interfaces.C.int (Bottom)); + end Get_Margins; + + + procedure Get_Printable_Rect + (This : in Paged_Device; + W, H : out Integer) is + begin + if fl_paged_device_printable_rect + (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)) /= 0 + then + raise Page_Error; + end if; + end Get_Printable_Rect; + + + procedure Get_Origin + (This : in Paged_Device; + X, Y : out Integer) is + begin + fl_paged_device_get_origin (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)); + end Get_Origin; + + + procedure Set_Origin + (This : in out Paged_Device; + X, Y : in Integer) is + begin + fl_paged_device_set_origin + (This.Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y)); + end Set_Origin; + + + procedure Rotate + (This : in out Paged_Device; + Degrees : in Float) is + begin + fl_paged_device_rotate (This.Void_Ptr, Interfaces.C.C_float (Degrees)); + end Rotate; + + + procedure Scale + (This : in out Paged_Device; + Factor : in Float) is + begin + fl_paged_device_scale (This.Void_Ptr, Interfaces.C.C_float (Factor), 0.0); + end Scale; + + + procedure Scale + (This : in out Paged_Device; + Factor_X, Factor_Y : in Float) is + begin + fl_paged_device_scale + (This.Void_Ptr, + Interfaces.C.C_float (Factor_X), + Interfaces.C.C_float (Factor_Y)); + end Scale; + + + procedure Translate + (This : in out Paged_Device; + Delta_X, Delta_Y : in Integer) is + begin + fl_paged_device_translate + (This.Void_Ptr, + Interfaces.C.int (Delta_X), + Interfaces.C.int (Delta_Y)); + end Translate; + + + procedure Untranslate + (This : in out Paged_Device) is + begin + fl_paged_device_untranslate (This.Void_Ptr); + end Untranslate; + + + + + procedure Print_Widget + (This : in out Paged_Device; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_paged_device_print_widget + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Widget; + + + procedure Print_Window + (This : in out Paged_Device; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_paged_device_print_window + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Window; + + + procedure Print_Window_Part + (This : in out Paged_Device; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + X, Y, W, H : in Integer; + Offset_X, Offset_Y : in Integer := 0) is + begin + fl_paged_device_print_window_part + (This.Void_Ptr, + Wrapper (Item).Void_Ptr, + Interfaces.C.int (X), + Interfaces.C.int (Y), + Interfaces.C.int (W), + Interfaces.C.int (H), + Interfaces.C.int (Offset_X), + Interfaces.C.int (Offset_Y)); + end Print_Window_Part; + + +end FLTK.Devices.Surface.Paged; + + diff --git a/src/fltk-devices-surface-paged.ads b/src/fltk-devices-surface-paged.ads new file mode 100644 index 0000000..1a3c13c --- /dev/null +++ b/src/fltk-devices-surface-paged.ads @@ -0,0 +1,153 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Widgets.Groups.Windows; + + +package FLTK.Devices.Surface.Paged is + + + type Paged_Device is new Surface_Device with private; + + type Paged_Device_Reference (Data : not null access Paged_Device'Class) is + limited null record with Implicit_Dereference => Data; + + type Page_Format is + (A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, + B0, B1, B2, B3, B4, B5, B6, B7, B8, B9, B10, + C5E, DLE, Executive, Folio, Ledger, + Legal, Letter, Tabloid, Envelope); + + type Page_Layout is + (Potrait, Landscape, Reversed, Orientation); + + + + + Page_Error : exception; + + + + + package Forge is + + function Create + return Paged_Device; + + end Forge; + + + + + procedure Start_Job + (This : in out Paged_Device; + Count : in Natural); + + procedure Start_Job + (This : in out Paged_Device; + Count : in Natural; + From, To : in Positive); + + procedure End_Job + (This : in out Paged_Device); + + procedure Start_Page + (This : in out Paged_Device); + + procedure End_Page + (This : in out Paged_Device); + + + + + procedure Get_Margins + (This : in Paged_Device; + Left, Top, Right, Bottom : out Integer); + + procedure Get_Printable_Rect + (This : in Paged_Device; + W, H : out Integer); + + procedure Get_Origin + (This : in Paged_Device; + X, Y : out Integer); + + procedure Set_Origin + (This : in out Paged_Device; + X, Y : in Integer); + + procedure Rotate + (This : in out Paged_Device; + Degrees : in Float); + + procedure Scale + (This : in out Paged_Device; + Factor : in Float); + + procedure Scale + (This : in out Paged_Device; + Factor_X, Factor_Y : in Float); + + procedure Translate + (This : in out Paged_Device; + Delta_X, Delta_Y : in Integer); + + procedure Untranslate + (This : in out Paged_Device); + + + + + procedure Print_Widget + (This : in out Paged_Device; + Item : in FLTK.Widgets.Widget'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Print_Window + (This : in out Paged_Device; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + Offset_X, Offset_Y : in Integer := 0); + + procedure Print_Window_Part + (This : in out Paged_Device; + Item : in FLTK.Widgets.Groups.Windows.Window'Class; + X, Y, W, H : in Integer; + Offset_X, Offset_Y : in Integer := 0); + + +private + + + type Paged_Device is new Surface_Device with null record; + + overriding procedure Finalize + (This : in out Paged_Device); + + + pragma Inline (Start_Job); + pragma Inline (End_Job); + pragma Inline (Start_Page); + pragma Inline (End_Page); + + pragma Inline (Get_Margins); + pragma Inline (Get_Printable_Rect); + pragma Inline (Get_Origin); + pragma Inline (Set_Origin); + pragma Inline (Rotate); + pragma Inline (Scale); + pragma Inline (Translate); + pragma Inline (Untranslate); + + pragma Inline (Print_Widget); + pragma Inline (Print_Window); + pragma Inline (Print_Window_Part); + + +end FLTK.Devices.Surface.Paged; + + diff --git a/src/fltk-devices-surface.adb b/src/fltk-devices-surface.adb new file mode 100644 index 0000000..fc8e077 --- /dev/null +++ b/src/fltk-devices-surface.adb @@ -0,0 +1,93 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +package body FLTK.Devices.Surface is + + + function new_fl_surface + (G : in Storage.Integer_Address) + return Storage.Integer_Address; + pragma Import (C, new_fl_surface, "new_fl_surface"); + pragma Inline (new_fl_surface); + + procedure free_fl_surface + (S : in Storage.Integer_Address); + pragma Import (C, free_fl_surface, "free_fl_surface"); + pragma Inline (free_fl_surface); + + + + + procedure fl_surface_set_current + (S : in Storage.Integer_Address); + pragma Import (C, fl_surface_set_current, "fl_surface_set_current"); + pragma Inline (fl_surface_set_current); + + function fl_surface_get_surface + return Storage.Integer_Address; + pragma Import (C, fl_surface_get_surface, "fl_surface_get_surface"); + pragma Inline (fl_surface_get_surface); + + + + + procedure Finalize + (This : in out Surface_Device) is + begin + if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then + free_fl_surface (This.Void_Ptr); + This.Void_Ptr := Null_Pointer; + end if; + end Finalize; + + + + + package body Forge is + + function Create + (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + return Surface_Device is + begin + return This : Surface_Device do + This.Void_Ptr := new_fl_surface (Wrapper (Graphics).Void_Ptr); + end return; + end Create; + + pragma Inline (Create); + + end Forge; + + + + + function Get_Current + return access Surface_Device'Class is + begin + return Current_Ptr; + end Get_Current; + + + procedure Set_Current + (This : in out Surface_Device) is + begin + fl_surface_set_current (This.Void_Ptr); + Current_Ptr := This'Unchecked_Access; + end Set_Current; + + + + +begin + + + Original_Surface.Void_Ptr := fl_surface_get_surface; + Original_Surface.Needs_Dealloc := False; + + +end FLTK.Devices.Surface; + + diff --git a/src/fltk-devices-surface.ads b/src/fltk-devices-surface.ads new file mode 100644 index 0000000..8ca367c --- /dev/null +++ b/src/fltk-devices-surface.ads @@ -0,0 +1,65 @@ + + +-- Programmed by Jedidiah Barber +-- Released into the public domain + + +with + + FLTK.Devices.Graphics; + + +package FLTK.Devices.Surface is + + + pragma Elaborate_Body (FLTK.Devices.Surface); + + + + + type Surface_Device is new Device with private; + + type Surface_Device_Reference (Data : not null access Surface_Device'Class) is + limited null record with Implicit_Dereference => Data; + + + + + package Forge is + + function Create + (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) + return Surface_Device; + + end Forge; + + + + + function Get_Current + return access Surface_Device'Class; + + procedure Set_Current + (This : in out Surface_Device); + + +private + + + type Surface_Device is new Device with null record; + + overriding procedure Finalize + (This : in out Surface_Device); + + + Original_Surface : aliased Surface_Device; + Current_Ptr : access Surface_Device'Class := Original_Surface'Access; + + + pragma Inline (Get_Current); + pragma Inline (Set_Current); + + +end FLTK.Devices.Surface; + + diff --git a/src/fltk-devices-surfaces-copy.adb b/src/fltk-devices-surfaces-copy.adb deleted file mode 100644 index 8c90ffb..0000000 --- a/src/fltk-devices-surfaces-copy.adb +++ /dev/null @@ -1,155 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Interfaces.C; - - -package body FLTK.Devices.Surfaces.Copy is - - - function new_fl_copy_surface - (W, H : in Interfaces.C.int) - return Storage.Integer_Address; - pragma Import (C, new_fl_copy_surface, "new_fl_copy_surface"); - pragma Inline (new_fl_copy_surface); - - procedure free_fl_copy_surface - (S : in Storage.Integer_Address); - pragma Import (C, free_fl_copy_surface, "free_fl_copy_surface"); - pragma Inline (free_fl_copy_surface); - - - - - function fl_copy_surface_get_w - (S : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_copy_surface_get_w, "fl_copy_surface_get_w"); - pragma Inline (fl_copy_surface_get_w); - - function fl_copy_surface_get_h - (S : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_copy_surface_get_h, "fl_copy_surface_get_h"); - pragma Inline (fl_copy_surface_get_h); - - - - - procedure fl_copy_surface_draw - (S, W : in Storage.Integer_Address; - OX, OY : in Interfaces.C.int); - pragma Import (C, fl_copy_surface_draw, "fl_copy_surface_draw"); - pragma Inline (fl_copy_surface_draw); - - procedure fl_copy_surface_draw_decorated_window - (S, W : in Storage.Integer_Address; - OX, OY : in Interfaces.C.int); - pragma Import (C, fl_copy_surface_draw_decorated_window, - "fl_copy_surface_draw_decorated_window"); - pragma Inline (fl_copy_surface_draw_decorated_window); - - - - - procedure fl_copy_surface_set_current - (S : in Storage.Integer_Address); - pragma Import (C, fl_copy_surface_set_current, "fl_copy_surface_set_current"); - pragma Inline (fl_copy_surface_set_current); - - - - - procedure Finalize - (This : in out Copy_Surface) is - begin - if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then - free_fl_copy_surface (This.Void_Ptr); - This.Void_Ptr := Null_Pointer; - end if; - end Finalize; - - - - - package body Forge is - - function Create - (W, H : in Natural) - return Copy_Surface is - begin - return This : Copy_Surface do - This.Void_Ptr := new_fl_copy_surface - (Interfaces.C.int (W), - Interfaces.C.int (H)); - end return; - end Create; - - pragma Inline (Create); - - end Forge; - - - - - function Get_W - (This : in Copy_Surface) - return Integer is - begin - return Integer (fl_copy_surface_get_w (This.Void_Ptr)); - end Get_W; - - - function Get_H - (This : in Copy_Surface) - return Integer is - begin - return Integer (fl_copy_surface_get_h (This.Void_Ptr)); - end Get_H; - - - - - procedure Draw_Widget - (This : in out Copy_Surface; - Item : in FLTK.Widgets.Widget'Class; - Offset_X, Offset_Y : in Integer := 0) is - begin - fl_copy_surface_draw - (This.Void_Ptr, - Wrapper (Item).Void_Ptr, - Interfaces.C.int (Offset_X), - Interfaces.C.int (Offset_Y)); - end Draw_Widget; - - - procedure Draw_Decorated_Window - (This : in out Copy_Surface; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - Offset_X, Offset_Y : in Integer := 0) is - begin - fl_copy_surface_draw_decorated_window - (This.Void_Ptr, - Wrapper (Item).Void_Ptr, - Interfaces.C.int (Offset_X), - Interfaces.C.int (Offset_Y)); - end Draw_Decorated_Window; - - - - - procedure Set_Current - (This : in out Copy_Surface) is - begin - fl_copy_surface_set_current (This.Void_Ptr); - Current_Ptr := This'Unchecked_Access; - end Set_Current; - - -end FLTK.Devices.Surfaces.Copy; - diff --git a/src/fltk-devices-surfaces-copy.ads b/src/fltk-devices-surfaces-copy.ads deleted file mode 100644 index 0e0e59b..0000000 --- a/src/fltk-devices-surfaces-copy.ads +++ /dev/null @@ -1,85 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - FLTK.Widgets.Groups.Windows; - - -package FLTK.Devices.Surfaces.Copy is - - - type Copy_Surface is new Surface_Device with private; - - type Copy_Surface_Reference (Data : not null access Copy_Surface'Class) is - limited null record with Implicit_Dereference => Data; - - - - - package Forge is - - function Create - (W, H : in Natural) - return Copy_Surface; - - end Forge; - - - - - function Get_W - (This : in Copy_Surface) - return Integer; - - function Get_H - (This : in Copy_Surface) - return Integer; - - - - - procedure Draw_Widget - (This : in out Copy_Surface; - Item : in FLTK.Widgets.Widget'Class; - Offset_X, Offset_Y : in Integer := 0); - - procedure Draw_Decorated_Window - (This : in out Copy_Surface; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - Offset_X, Offset_Y : in Integer := 0); - - - - - procedure Set_Current - (This : in out Copy_Surface); - - -private - - - type Copy_Surface is new Surface_Device with null record; - - overriding procedure Finalize - (This : in out Copy_Surface); - - - - - pragma Inline (Get_W); - pragma Inline (Get_H); - - - pragma Inline (Draw_Widget); - pragma Inline (Draw_Decorated_Window); - - - pragma Inline (Set_Current); - - -end FLTK.Devices.Surfaces.Copy; - diff --git a/src/fltk-devices-surfaces-image.adb b/src/fltk-devices-surfaces-image.adb deleted file mode 100644 index 56566ea..0000000 --- a/src/fltk-devices-surfaces-image.adb +++ /dev/null @@ -1,170 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Interfaces.C; - - -package body FLTK.Devices.Surfaces.Image is - - - function new_fl_image_surface - (W, H, R : in Interfaces.C.int) - return Storage.Integer_Address; - pragma Import (C, new_fl_image_surface, "new_fl_image_surface"); - pragma Inline (new_fl_image_surface); - - procedure free_fl_image_surface - (S : in Storage.Integer_Address); - pragma Import (C, free_fl_image_surface, "free_fl_image_surface"); - pragma Inline (free_fl_image_surface); - - - - - procedure fl_image_surface_draw - (S, I : in Storage.Integer_Address; - OX, OY : in Interfaces.C.int); - pragma Import (C, fl_image_surface_draw, "fl_image_surface_draw"); - pragma Inline (fl_image_surface_draw); - - procedure fl_image_surface_draw_decorated_window - (S, I : in Storage.Integer_Address; - OX, OY : in Interfaces.C.int); - pragma Import (C, fl_image_surface_draw_decorated_window, - "fl_image_surface_draw_decorated_window"); - pragma Inline (fl_image_surface_draw_decorated_window); - - - - - function fl_image_surface_image - (S : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_image_surface_image, "fl_image_surface_image"); - pragma Inline (fl_image_surface_image); - - function fl_image_surface_highres_image - (S : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, fl_image_surface_highres_image, "fl_image_surface_highres_image"); - pragma Inline (fl_image_surface_highres_image); - - - - - procedure fl_image_surface_set_current - (S : in Storage.Integer_Address); - pragma Import (C, fl_image_surface_set_current, "fl_image_surface_set_current"); - pragma Inline (fl_image_surface_set_current); - - - - - procedure Finalize - (This : in out Image_Surface) is - begin - if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then - free_fl_image_surface (This.Void_Ptr); - This.Void_Ptr := Null_Pointer; - end if; - end Finalize; - - - - - package body Forge is - - function Create - (W, H : in Integer; - Highres : in Boolean := False) - return Image_Surface is - begin - return This : Image_Surface do - This.Void_Ptr := new_fl_image_surface - (Interfaces.C.int (W), - Interfaces.C.int (H), - Boolean'Pos (Highres)); - This.High := Highres; - end return; - end Create; - - end Forge; - - - - - function Is_Highres - (This : in Image_Surface) - return Boolean is - begin - return This.High; - end Is_Highres; - - - - - procedure Draw_Widget - (This : in out Image_Surface; - Item : in FLTK.Widgets.Widget'Class; - Offset_X, Offset_Y : in Integer := 0) is - begin - fl_image_surface_draw - (This.Void_Ptr, - Wrapper (Item).Void_Ptr, - Interfaces.C.int (Offset_X), - Interfaces.C.int (Offset_Y)); - end Draw_Widget; - - - procedure Draw_Decorated_Window - (This : in out Image_Surface; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - Offset_X, Offset_Y : in Integer := 0) is - begin - fl_image_surface_draw_decorated_window - (This.Void_Ptr, - Wrapper (Item).Void_Ptr, - Interfaces.C.int (Offset_X), - Interfaces.C.int (Offset_Y)); - end Draw_Decorated_Window; - - - - - function Get_Image - (This : in Image_Surface) - return FLTK.Images.RGB.RGB_Image is - begin - return Img : FLTK.Images.RGB.RGB_Image do - Wrapper (Img).Void_Ptr := fl_image_surface_image (This.Void_Ptr); - end return; - end Get_Image; - - - function Get_Highres_Image - (This : in Image_Surface) - return FLTK.Images.Shared.Shared_Image is - begin - return Img : FLTK.Images.Shared.Shared_Image do - Wrapper (Img).Void_Ptr := fl_image_surface_highres_image (This.Void_Ptr); - end return; - end Get_Highres_Image; - - - - - procedure Set_Current - (This : in out Image_Surface) is - begin - fl_image_surface_set_current (This.Void_Ptr); - Current_Ptr := This'Unchecked_Access; - end Set_Current; - - -end FLTK.Devices.Surfaces.Image; - diff --git a/src/fltk-devices-surfaces-image.ads b/src/fltk-devices-surfaces-image.ads deleted file mode 100644 index f30133b..0000000 --- a/src/fltk-devices-surfaces-image.ads +++ /dev/null @@ -1,100 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - FLTK.Images.RGB, - FLTK.Images.Shared, - FLTK.Widgets.Groups.Windows; - - -package FLTK.Devices.Surfaces.Image is - - - type Image_Surface is new Surface_Device with private; - - type Image_Surface_Reference (Data : not null access Image_Surface'Class) is - limited null record with Implicit_Dereference => Data; - - - - - package Forge is - - function Create - (W, H : in Integer; - Highres : in Boolean := False) - return Image_Surface; - - end Forge; - - - - - function Is_Highres - (This : in Image_Surface) - return Boolean; - - - - - procedure Draw_Widget - (This : in out Image_Surface; - Item : in FLTK.Widgets.Widget'Class; - Offset_X, Offset_Y : in Integer := 0); - - procedure Draw_Decorated_Window - (This : in out Image_Surface; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - Offset_X, Offset_Y : in Integer := 0); - - - - - function Get_Image - (This : in Image_Surface) - return FLTK.Images.RGB.RGB_Image; - - function Get_Highres_Image - (This : in Image_Surface) - return FLTK.Images.Shared.Shared_Image; - - - - - procedure Set_Current - (This : in out Image_Surface); - - -private - - - type Image_Surface is new Surface_Device with record - High : Boolean := False; - end record; - - overriding procedure Finalize - (This : in out Image_Surface); - - - - - pragma Inline (Is_Highres); - - - pragma Inline (Draw_Widget); - pragma Inline (Draw_Decorated_Window); - - - pragma Inline (Get_Image); - pragma Inline (Get_Highres_Image); - - - pragma Inline (Set_Current); - - -end FLTK.Devices.Surfaces.Image; - diff --git a/src/fltk-devices-surfaces-paged-printers.adb b/src/fltk-devices-surfaces-paged-printers.adb deleted file mode 100644 index 601f425..0000000 --- a/src/fltk-devices-surfaces-paged-printers.adb +++ /dev/null @@ -1,357 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Interfaces.C; - -use type - - Interfaces.C.int; - - -package body FLTK.Devices.Surfaces.Paged.Printers is - - - function new_fl_printer - return Storage.Integer_Address; - pragma Import (C, new_fl_printer, "new_fl_printer"); - pragma Inline (new_fl_printer); - - procedure free_fl_printer - (D : in Storage.Integer_Address); - pragma Import (C, free_fl_printer, "free_fl_printer"); - pragma Inline (free_fl_printer); - - - - - function fl_printer_start_job - (D : in Storage.Integer_Address; - C : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_printer_start_job, "fl_printer_start_job"); - pragma Inline (fl_printer_start_job); - - function fl_printer_start_job2 - (D : in Storage.Integer_Address; - C, F, T : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_printer_start_job2, "fl_printer_start_job2"); - pragma Inline (fl_printer_start_job2); - - procedure fl_printer_end_job - (D : in Storage.Integer_Address); - pragma Import (C, fl_printer_end_job, "fl_printer_end_job"); - pragma Inline (fl_printer_end_job); - - function fl_printer_start_page - (D : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_printer_start_page, "fl_printer_start_page"); - pragma Inline (fl_printer_start_page); - - function fl_printer_end_page - (D : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_printer_end_page, "fl_printer_end_page"); - pragma Inline (fl_printer_end_page); - - - - - procedure fl_printer_margins - (D : in Storage.Integer_Address; - L, T, R, B : out Interfaces.C.int); - pragma Import (C, fl_printer_margins, "fl_printer_margins"); - pragma Inline (fl_printer_margins); - - function fl_printer_printable_rect - (D : in Storage.Integer_Address; - W, H : out Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_printer_printable_rect, "fl_printer_printable_rect"); - pragma Inline (fl_printer_printable_rect); - - procedure fl_printer_get_origin - (D : in Storage.Integer_Address; - X, Y : out Interfaces.C.int); - pragma Import (C, fl_printer_get_origin, "fl_printer_get_origin"); - pragma Inline (fl_printer_get_origin); - - procedure fl_printer_set_origin - (D : in Storage.Integer_Address; - X, Y : in Interfaces.C.int); - pragma Import (C, fl_printer_set_origin, "fl_printer_set_origin"); - pragma Inline (fl_printer_set_origin); - - procedure fl_printer_rotate - (D : in Storage.Integer_Address; - R : in Interfaces.C.C_float); - pragma Import (C, fl_printer_rotate, "fl_printer_rotate"); - pragma Inline (fl_printer_rotate); - - procedure fl_printer_scale - (D : in Storage.Integer_Address; - X, Y : in Interfaces.C.C_float); - pragma Import (C, fl_printer_scale, "fl_printer_scale"); - pragma Inline (fl_printer_scale); - - procedure fl_printer_translate - (D : in Storage.Integer_Address; - X, Y : in Interfaces.C.int); - pragma Import (C, fl_printer_translate, "fl_printer_translate"); - pragma Inline (fl_printer_translate); - - procedure fl_printer_untranslate - (D : in Storage.Integer_Address); - pragma Import (C, fl_printer_untranslate, "fl_printer_untranslate"); - pragma Inline (fl_printer_untranslate); - - - - - procedure fl_printer_print_widget - (D, I : in Storage.Integer_Address; - DX, DY : in Interfaces.C.int); - pragma Import (C, fl_printer_print_widget, "fl_printer_print_widget"); - pragma Inline (fl_printer_print_widget); - - procedure fl_printer_print_window_part - (D, I : in Storage.Integer_Address; - X, Y, W, H, DX, DY : in Interfaces.C.int); - pragma Import (C, fl_printer_print_window_part, "fl_printer_print_window_part"); - pragma Inline (fl_printer_print_window_part); - - - - - procedure fl_printer_set_current - (D : in Storage.Integer_Address); - pragma Import (C, fl_printer_set_current, "fl_printer_set_current"); - pragma Inline (fl_printer_set_current); - - - - - procedure Finalize - (This : in out Printer) is - begin - if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then - free_fl_printer (This.Void_Ptr); - This.Void_Ptr := Null_Pointer; - end if; - end Finalize; - - - - - package body Forge is - - function Create - return Printer is - begin - return This : Printer do - This.Void_Ptr := new_fl_printer; - end return; - end Create; - - pragma Inline (Create); - - end Forge; - - - - - procedure Start_Job - (This : in out Printer; - Count : in Natural) is - begin - if fl_printer_start_job - (This.Void_Ptr, Interfaces.C.int (Count)) /= 0 - then - raise Page_Error; - end if; - end Start_Job; - - - procedure Start_Job - (This : in out Printer; - Count : in Natural; - From, To : in Positive) is - begin - if fl_printer_start_job2 - (This.Void_Ptr, - Interfaces.C.int (Count), - Interfaces.C.int (From), - Interfaces.C.int (To)) /= 0 - then - raise Page_Error; - end if; - end Start_Job; - - - procedure End_Job - (This : in out Printer) is - begin - fl_printer_end_job (This.Void_Ptr); - end End_Job; - - - procedure Start_Page - (This : in out Printer) is - begin - if fl_printer_start_page (This.Void_Ptr) /= 0 then - raise Page_Error; - end if; - end Start_Page; - - - procedure End_Page - (This : in out Printer) is - begin - if fl_printer_end_page (This.Void_Ptr) /= 0 then - raise Page_Error; - end if; - end End_Page; - - - - - procedure Get_Margins - (This : in Printer; - Left, Top, Right, Bottom : out Integer) is - begin - fl_printer_margins - (This.Void_Ptr, - Interfaces.C.int (Left), - Interfaces.C.int (Top), - Interfaces.C.int (Right), - Interfaces.C.int (Bottom)); - end Get_Margins; - - - procedure Get_Printable_Rect - (This : in Printer; - W, H : out Integer) is - begin - if fl_printer_printable_rect - (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)) /= 0 - then - raise Page_Error; - end if; - end Get_Printable_Rect; - - - procedure Get_Origin - (This : in Printer; - X, Y : out Integer) is - begin - fl_printer_get_origin (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)); - end Get_Origin; - - - procedure Set_Origin - (This : in out Printer; - X, Y : in Integer) is - begin - fl_printer_set_origin - (This.Void_Ptr, - Interfaces.C.int (X), - Interfaces.C.int (Y)); - end Set_Origin; - - - procedure Rotate - (This : in out Printer; - Degrees : in Float) is - begin - fl_printer_rotate (This.Void_Ptr, Interfaces.C.C_float (Degrees)); - end Rotate; - - - procedure Scale - (This : in out Printer; - Factor : in Float) is - begin - fl_printer_scale (This.Void_Ptr, Interfaces.C.C_float (Factor), 0.0); - end Scale; - - - procedure Scale - (This : in out Printer; - Factor_X, Factor_Y : in Float) is - begin - fl_printer_scale - (This.Void_Ptr, - Interfaces.C.C_float (Factor_X), - Interfaces.C.C_float (Factor_Y)); - end Scale; - - - procedure Translate - (This : in out Printer; - Delta_X, Delta_Y : in Integer) is - begin - fl_printer_translate - (This.Void_Ptr, - Interfaces.C.int (Delta_X), - Interfaces.C.int (Delta_Y)); - end Translate; - - - procedure Untranslate - (This : in out Printer) is - begin - fl_printer_untranslate (This.Void_Ptr); - end Untranslate; - - - - - procedure Print_Widget - (This : in out Printer; - Item : in FLTK.Widgets.Widget'Class; - Offset_X, Offset_Y : in Integer := 0) is - begin - fl_printer_print_widget - (This.Void_Ptr, - Wrapper (Item).Void_Ptr, - Interfaces.C.int (Offset_X), - Interfaces.C.int (Offset_Y)); - end Print_Widget; - - - procedure Print_Window_Part - (This : in out Printer; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - X, Y, W, H : in Integer; - Offset_X, Offset_Y : in Integer := 0) is - begin - fl_printer_print_window_part - (This.Void_Ptr, - Wrapper (Item).Void_Ptr, - Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.int (Offset_X), - Interfaces.C.int (Offset_Y)); - end Print_Window_Part; - - - - - procedure Set_Current - (This : in out Printer) is - begin - fl_printer_set_current (This.Void_Ptr); - Current_Ptr := This'Unchecked_Access; - end Set_Current; - - -end FLTK.Devices.Surfaces.Paged.Printers; - diff --git a/src/fltk-devices-surfaces-paged-printers.ads b/src/fltk-devices-surfaces-paged-printers.ads deleted file mode 100644 index e1c2ee7..0000000 --- a/src/fltk-devices-surfaces-paged-printers.ads +++ /dev/null @@ -1,145 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - FLTK.Widgets.Groups.Windows; - - -package FLTK.Devices.Surfaces.Paged.Printers is - - - type Printer is new Paged_Surface with private; - - type Printer_Reference (Data : not null access Printer'Class) is limited null record - with Implicit_Dereference => Data; - - - - - package Forge is - - function Create - return Printer; - - end Forge; - - - - - procedure Start_Job - (This : in out Printer; - Count : in Natural); - - procedure Start_Job - (This : in out Printer; - Count : in Natural; - From, To : in Positive); - - procedure End_Job - (This : in out Printer); - - procedure Start_Page - (This : in out Printer); - - procedure End_Page - (This : in out Printer); - - - - - procedure Get_Margins - (This : in Printer; - Left, Top, Right, Bottom : out Integer); - - procedure Get_Printable_Rect - (This : in Printer; - W, H : out Integer); - - procedure Get_Origin - (This : in Printer; - X, Y : out Integer); - - procedure Set_Origin - (This : in out Printer; - X, Y : in Integer); - - procedure Rotate - (This : in out Printer; - Degrees : in Float); - - procedure Scale - (This : in out Printer; - Factor : in Float); - - procedure Scale - (This : in out Printer; - Factor_X, Factor_Y : in Float); - - procedure Translate - (This : in out Printer; - Delta_X, Delta_Y : in Integer); - - procedure Untranslate - (This : in out Printer); - - - - - procedure Print_Widget - (This : in out Printer; - Item : in FLTK.Widgets.Widget'Class; - Offset_X, Offset_Y : in Integer := 0); - - procedure Print_Window_Part - (This : in out Printer; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - X, Y, W, H : in Integer; - Offset_X, Offset_Y : in Integer := 0); - - - - - procedure Set_Current - (This : in out Printer); - - -private - - - type Printer is new Paged_Surface with null record; - - overriding procedure Finalize - (This : in out Printer); - - - - - pragma Inline (Start_Job); - pragma Inline (End_Job); - pragma Inline (Start_Page); - pragma Inline (End_Page); - - - pragma Inline (Get_Margins); - pragma Inline (Get_Printable_Rect); - pragma Inline (Get_Origin); - pragma Inline (Set_Origin); - pragma Inline (Rotate); - pragma Inline (Scale); - pragma Inline (Translate); - pragma Inline (Untranslate); - - - pragma Inline (Print_Widget); - pragma Inline (Print_Window_Part); - - - pragma Inline (Set_Current); - - -end FLTK.Devices.Surfaces.Paged.Printers; - diff --git a/src/fltk-devices-surfaces-paged.adb b/src/fltk-devices-surfaces-paged.adb deleted file mode 100644 index 5de3fec..0000000 --- a/src/fltk-devices-surfaces-paged.adb +++ /dev/null @@ -1,358 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - Interfaces.C; - -use type - - Interfaces.C.int; - - -package body FLTK.Devices.Surfaces.Paged is - - - function new_fl_paged_device - return Storage.Integer_Address; - pragma Import (C, new_fl_paged_device, "new_fl_paged_device"); - pragma Inline (new_fl_paged_device); - - procedure free_fl_paged_device - (D : in Storage.Integer_Address); - pragma Import (C, free_fl_paged_device, "free_fl_paged_device"); - pragma Inline (free_fl_paged_device); - - - - - function fl_paged_device_start_job - (D : in Storage.Integer_Address; - C : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_paged_device_start_job, "fl_paged_device_start_job"); - pragma Inline (fl_paged_device_start_job); - - function fl_paged_device_start_job2 - (D : in Storage.Integer_Address; - C, F, T : in Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_paged_device_start_job2, "fl_paged_device_start_job2"); - pragma Inline (fl_paged_device_start_job2); - - procedure fl_paged_device_end_job - (D : in Storage.Integer_Address); - pragma Import (C, fl_paged_device_end_job, "fl_paged_device_end_job"); - pragma Inline (fl_paged_device_end_job); - - function fl_paged_device_start_page - (D : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_paged_device_start_page, "fl_paged_device_start_page"); - pragma Inline (fl_paged_device_start_page); - - function fl_paged_device_end_page - (D : in Storage.Integer_Address) - return Interfaces.C.int; - pragma Import (C, fl_paged_device_end_page, "fl_paged_device_end_page"); - pragma Inline (fl_paged_device_end_page); - - - - - procedure fl_paged_device_margins - (D : in Storage.Integer_Address; - L, T, R, B : out Interfaces.C.int); - pragma Import (C, fl_paged_device_margins, "fl_paged_device_margins"); - pragma Inline (fl_paged_device_margins); - - function fl_paged_device_printable_rect - (D : in Storage.Integer_Address; - W, H : out Interfaces.C.int) - return Interfaces.C.int; - pragma Import (C, fl_paged_device_printable_rect, "fl_paged_device_printable_rect"); - pragma Inline (fl_paged_device_printable_rect); - - procedure fl_paged_device_get_origin - (D : in Storage.Integer_Address; - X, Y : out Interfaces.C.int); - pragma Import (C, fl_paged_device_get_origin, "fl_paged_device_get_origin"); - pragma Inline (fl_paged_device_get_origin); - - procedure fl_paged_device_set_origin - (D : in Storage.Integer_Address; - X, Y : in Interfaces.C.int); - pragma Import (C, fl_paged_device_set_origin, "fl_paged_device_set_origin"); - pragma Inline (fl_paged_device_set_origin); - - procedure fl_paged_device_rotate - (D : in Storage.Integer_Address; - R : in Interfaces.C.C_float); - pragma Import (C, fl_paged_device_rotate, "fl_paged_device_rotate"); - pragma Inline (fl_paged_device_rotate); - - procedure fl_paged_device_scale - (D : in Storage.Integer_Address; - X, Y : in Interfaces.C.C_float); - pragma Import (C, fl_paged_device_scale, "fl_paged_device_scale"); - pragma Inline (fl_paged_device_scale); - - procedure fl_paged_device_translate - (D : in Storage.Integer_Address; - X, Y : in Interfaces.C.int); - pragma Import (C, fl_paged_device_translate, "fl_paged_device_translate"); - pragma Inline (fl_paged_device_translate); - - procedure fl_paged_device_untranslate - (D : in Storage.Integer_Address); - pragma Import (C, fl_paged_device_untranslate, "fl_paged_device_untranslate"); - pragma Inline (fl_paged_device_untranslate); - - - - - procedure fl_paged_device_print_widget - (D, I : in Storage.Integer_Address; - DX, DY : in Interfaces.C.int); - pragma Import (C, fl_paged_device_print_widget, "fl_paged_device_print_widget"); - pragma Inline (fl_paged_device_print_widget); - - procedure fl_paged_device_print_window - (D, I : in Storage.Integer_Address; - DX, DY : in Interfaces.C.int); - pragma Import (C, fl_paged_device_print_window, "fl_paged_device_print_window"); - pragma Inline (fl_paged_device_print_window); - - procedure fl_paged_device_print_window_part - (D, I : in Storage.Integer_Address; - X, Y, W, H, DX, DY : in Interfaces.C.int); - pragma Import (C, fl_paged_device_print_window_part, "fl_paged_device_print_window_part"); - pragma Inline (fl_paged_device_print_window_part); - - - - - procedure Finalize - (This : in out Paged_Surface) is - begin - if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then - free_fl_paged_device (This.Void_Ptr); - This.Void_Ptr := Null_Pointer; - end if; - end Finalize; - - - - - package body Forge is - - function Create - return Paged_Surface is - begin - return This : Paged_Surface do - This.Void_Ptr := new_fl_paged_device; - end return; - end Create; - - pragma Inline (Create); - - end Forge; - - - - - procedure Start_Job - (This : in out Paged_Surface; - Count : in Natural) is - begin - if fl_paged_device_start_job - (This.Void_Ptr, Interfaces.C.int (Count)) /= 0 - then - raise Page_Error; - end if; - end Start_Job; - - - procedure Start_Job - (This : in out Paged_Surface; - Count : in Natural; - From, To : in Positive) is - begin - if fl_paged_device_start_job2 - (This.Void_Ptr, - Interfaces.C.int (Count), - Interfaces.C.int (From), - Interfaces.C.int (To)) /= 0 - then - raise Page_Error; - end if; - end Start_Job; - - - procedure End_Job - (This : in out Paged_Surface) is - begin - fl_paged_device_end_job (This.Void_Ptr); - end End_Job; - - - procedure Start_Page - (This : in out Paged_Surface) is - begin - if fl_paged_device_start_page (This.Void_Ptr) /= 0 then - raise Page_Error; - end if; - end Start_Page; - - - procedure End_Page - (This : in out Paged_Surface) is - begin - if fl_paged_device_end_page (This.Void_Ptr) /= 0 then - raise Page_Error; - end if; - end End_Page; - - - - - procedure Get_Margins - (This : in Paged_Surface; - Left, Top, Right, Bottom : out Integer) is - begin - fl_paged_device_margins - (This.Void_Ptr, - Interfaces.C.int (Left), - Interfaces.C.int (Top), - Interfaces.C.int (Right), - Interfaces.C.int (Bottom)); - end Get_Margins; - - - procedure Get_Printable_Rect - (This : in Paged_Surface; - W, H : out Integer) is - begin - if fl_paged_device_printable_rect - (This.Void_Ptr, Interfaces.C.int (W), Interfaces.C.int (H)) /= 0 - then - raise Page_Error; - end if; - end Get_Printable_Rect; - - - procedure Get_Origin - (This : in Paged_Surface; - X, Y : out Integer) is - begin - fl_paged_device_get_origin (This.Void_Ptr, Interfaces.C.int (X), Interfaces.C.int (Y)); - end Get_Origin; - - - procedure Set_Origin - (This : in out Paged_Surface; - X, Y : in Integer) is - begin - fl_paged_device_set_origin - (This.Void_Ptr, - Interfaces.C.int (X), - Interfaces.C.int (Y)); - end Set_Origin; - - - procedure Rotate - (This : in out Paged_Surface; - Degrees : in Float) is - begin - fl_paged_device_rotate (This.Void_Ptr, Interfaces.C.C_float (Degrees)); - end Rotate; - - - procedure Scale - (This : in out Paged_Surface; - Factor : in Float) is - begin - fl_paged_device_scale (This.Void_Ptr, Interfaces.C.C_float (Factor), 0.0); - end Scale; - - - procedure Scale - (This : in out Paged_Surface; - Factor_X, Factor_Y : in Float) is - begin - fl_paged_device_scale - (This.Void_Ptr, - Interfaces.C.C_float (Factor_X), - Interfaces.C.C_float (Factor_Y)); - end Scale; - - - procedure Translate - (This : in out Paged_Surface; - Delta_X, Delta_Y : in Integer) is - begin - fl_paged_device_translate - (This.Void_Ptr, - Interfaces.C.int (Delta_X), - Interfaces.C.int (Delta_Y)); - end Translate; - - - procedure Untranslate - (This : in out Paged_Surface) is - begin - fl_paged_device_untranslate (This.Void_Ptr); - end Untranslate; - - - - - procedure Print_Widget - (This : in out Paged_Surface; - Item : in FLTK.Widgets.Widget'Class; - Offset_X, Offset_Y : in Integer := 0) is - begin - fl_paged_device_print_widget - (This.Void_Ptr, - Wrapper (Item).Void_Ptr, - Interfaces.C.int (Offset_X), - Interfaces.C.int (Offset_Y)); - end Print_Widget; - - - procedure Print_Window - (This : in out Paged_Surface; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - Offset_X, Offset_Y : in Integer := 0) is - begin - fl_paged_device_print_window - (This.Void_Ptr, - Wrapper (Item).Void_Ptr, - Interfaces.C.int (Offset_X), - Interfaces.C.int (Offset_Y)); - end Print_Window; - - - procedure Print_Window_Part - (This : in out Paged_Surface; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - X, Y, W, H : in Integer; - Offset_X, Offset_Y : in Integer := 0) is - begin - fl_paged_device_print_window_part - (This.Void_Ptr, - Wrapper (Item).Void_Ptr, - Interfaces.C.int (X), - Interfaces.C.int (Y), - Interfaces.C.int (W), - Interfaces.C.int (H), - Interfaces.C.int (Offset_X), - Interfaces.C.int (Offset_Y)); - end Print_Window_Part; - - -end FLTK.Devices.Surfaces.Paged; - diff --git a/src/fltk-devices-surfaces-paged.ads b/src/fltk-devices-surfaces-paged.ads deleted file mode 100644 index 6c8a33d..0000000 --- a/src/fltk-devices-surfaces-paged.ads +++ /dev/null @@ -1,156 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - FLTK.Widgets.Groups.Windows; - - -package FLTK.Devices.Surfaces.Paged is - - - type Paged_Surface is new Surface_Device with private; - - type Paged_Surface_Reference (Data : not null access Paged_Surface'Class) is - limited null record with Implicit_Dereference => Data; - - type Page_Format is - (A0, A1, A2, A3, A4, A5, A6, A7, A8, A9, - B0, B1, B2, B3, B4, B5, B6, B7, B8, B9, B10, - C5E, DLE, Executive, Folio, Ledger, - Legal, Letter, Tabloid, Envelope); - - type Page_Layout is - (Potrait, Landscape, Reversed, Orientation); - - - - - Page_Error : exception; - - - - - package Forge is - - function Create - return Paged_Surface; - - end Forge; - - - - - procedure Start_Job - (This : in out Paged_Surface; - Count : in Natural); - - procedure Start_Job - (This : in out Paged_Surface; - Count : in Natural; - From, To : in Positive); - - procedure End_Job - (This : in out Paged_Surface); - - procedure Start_Page - (This : in out Paged_Surface); - - procedure End_Page - (This : in out Paged_Surface); - - - - - procedure Get_Margins - (This : in Paged_Surface; - Left, Top, Right, Bottom : out Integer); - - procedure Get_Printable_Rect - (This : in Paged_Surface; - W, H : out Integer); - - procedure Get_Origin - (This : in Paged_Surface; - X, Y : out Integer); - - procedure Set_Origin - (This : in out Paged_Surface; - X, Y : in Integer); - - procedure Rotate - (This : in out Paged_Surface; - Degrees : in Float); - - procedure Scale - (This : in out Paged_Surface; - Factor : in Float); - - procedure Scale - (This : in out Paged_Surface; - Factor_X, Factor_Y : in Float); - - procedure Translate - (This : in out Paged_Surface; - Delta_X, Delta_Y : in Integer); - - procedure Untranslate - (This : in out Paged_Surface); - - - - - procedure Print_Widget - (This : in out Paged_Surface; - Item : in FLTK.Widgets.Widget'Class; - Offset_X, Offset_Y : in Integer := 0); - - procedure Print_Window - (This : in out Paged_Surface; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - Offset_X, Offset_Y : in Integer := 0); - - procedure Print_Window_Part - (This : in out Paged_Surface; - Item : in FLTK.Widgets.Groups.Windows.Window'Class; - X, Y, W, H : in Integer; - Offset_X, Offset_Y : in Integer := 0); - - -private - - - type Paged_Surface is new Surface_Device with null record; - - overriding procedure Finalize - (This : in out Paged_Surface); - - - - - pragma Inline (Start_Job); - pragma Inline (End_Job); - pragma Inline (Start_Page); - pragma Inline (End_Page); - - - pragma Inline (Get_Margins); - pragma Inline (Get_Printable_Rect); - pragma Inline (Get_Origin); - pragma Inline (Set_Origin); - pragma Inline (Rotate); - pragma Inline (Scale); - pragma Inline (Translate); - pragma Inline (Untranslate); - - - pragma Inline (Print_Widget); - pragma Inline (Print_Window); - pragma Inline (Print_Window_Part); - - -end FLTK.Devices.Surfaces.Paged; - diff --git a/src/fltk-devices-surfaces.adb b/src/fltk-devices-surfaces.adb deleted file mode 100644 index 58a5fa0..0000000 --- a/src/fltk-devices-surfaces.adb +++ /dev/null @@ -1,92 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -package body FLTK.Devices.Surfaces is - - - function new_fl_surface - (G : in Storage.Integer_Address) - return Storage.Integer_Address; - pragma Import (C, new_fl_surface, "new_fl_surface"); - pragma Inline (new_fl_surface); - - procedure free_fl_surface - (S : in Storage.Integer_Address); - pragma Import (C, free_fl_surface, "free_fl_surface"); - pragma Inline (free_fl_surface); - - - - - procedure fl_surface_set_current - (S : in Storage.Integer_Address); - pragma Import (C, fl_surface_set_current, "fl_surface_set_current"); - pragma Inline (fl_surface_set_current); - - function fl_surface_get_surface - return Storage.Integer_Address; - pragma Import (C, fl_surface_get_surface, "fl_surface_get_surface"); - pragma Inline (fl_surface_get_surface); - - - - - procedure Finalize - (This : in out Surface_Device) is - begin - if This.Void_Ptr /= Null_Pointer and This.Needs_Dealloc then - free_fl_surface (This.Void_Ptr); - This.Void_Ptr := Null_Pointer; - end if; - end Finalize; - - - - - package body Forge is - - function Create - (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) - return Surface_Device is - begin - return This : Surface_Device do - This.Void_Ptr := new_fl_surface (Wrapper (Graphics).Void_Ptr); - end return; - end Create; - - pragma Inline (Create); - - end Forge; - - - - - function Get_Current - return access Surface_Device'Class is - begin - return Current_Ptr; - end Get_Current; - - - procedure Set_Current - (This : in out Surface_Device) is - begin - fl_surface_set_current (This.Void_Ptr); - Current_Ptr := This'Unchecked_Access; - end Set_Current; - - - - -begin - - - Original_Surface.Void_Ptr := fl_surface_get_surface; - Original_Surface.Needs_Dealloc := False; - - -end FLTK.Devices.Surfaces; - diff --git a/src/fltk-devices-surfaces.ads b/src/fltk-devices-surfaces.ads deleted file mode 100644 index c92f93b..0000000 --- a/src/fltk-devices-surfaces.ads +++ /dev/null @@ -1,68 +0,0 @@ - - --- Programmed by Jedidiah Barber --- Released into the public domain - - -with - - FLTK.Devices.Graphics; - - -package FLTK.Devices.Surfaces is - - - pragma Elaborate_Body (FLTK.Devices.Surfaces); - - - - - type Surface_Device is new Device with private; - - type Surface_Device_Reference (Data : not null access Surface_Device'Class) is - limited null record with Implicit_Dereference => Data; - - - - - package Forge is - - function Create - (Graphics : in out FLTK.Devices.Graphics.Graphics_Driver) - return Surface_Device; - - end Forge; - - - - - function Get_Current - return access Surface_Device'Class; - - procedure Set_Current - (This : in out Surface_Device); - - -private - - - type Surface_Device is new Device with null record; - - overriding procedure Finalize - (This : in out Surface_Device); - - - - - Original_Surface : aliased Surface_Device; - Current_Ptr : access Surface_Device'Class := Original_Surface'Access; - - - - - pragma Inline (Get_Current); - pragma Inline (Set_Current); - - -end FLTK.Devices.Surfaces; - -- cgit