summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c_fl_label.cpp96
-rw-r--r--src/c_fl_label.h45
-rw-r--r--src/fltk-labels.adb358
-rw-r--r--src/fltk-labels.ads155
4 files changed, 654 insertions, 0 deletions
diff --git a/src/c_fl_label.cpp b/src/c_fl_label.cpp
new file mode 100644
index 0000000..71b81ba
--- /dev/null
+++ b/src/c_fl_label.cpp
@@ -0,0 +1,96 @@
+
+
+// Programmed by Jedidiah Barber
+// Released into the public domain
+
+
+#include <FL/Fl_Widget.H>
+#include <FL/Fl_Image.H>
+#include "c_fl_label.h"
+#include "c_fl_type.h"
+
+
+
+
+LABEL new_fl_label(const char * v, int f, int s, unsigned int h, int k, unsigned int p) {
+ Fl_Label *l = new Fl_Label;
+ l->value = v;
+ l->font = f;
+ l->size = s;
+ l->color = h;
+ l->align_ = p;
+ l->type = (uchar)k;
+ return l;
+}
+
+void free_fl_label(LABEL l) {
+ delete reinterpret_cast<Fl_Label*>(l);
+}
+
+
+
+
+void fl_label_set_value(LABEL l, const char * v) {
+ reinterpret_cast<Fl_Label*>(l)->value = v;
+}
+
+int fl_label_get_font(LABEL l) {
+ return reinterpret_cast<Fl_Label*>(l)->font;
+}
+
+void fl_label_set_font(LABEL l, int f) {
+ reinterpret_cast<Fl_Label*>(l)->font = f;
+}
+
+int fl_label_get_size(LABEL l) {
+ return reinterpret_cast<Fl_Label*>(l)->size;
+}
+
+void fl_label_set_size(LABEL l, int s) {
+ reinterpret_cast<Fl_Label*>(l)->size = s;
+}
+
+unsigned int fl_label_get_color(LABEL l) {
+ return reinterpret_cast<Fl_Label*>(l)->color;
+}
+
+void fl_label_set_color(LABEL l, unsigned int h) {
+ reinterpret_cast<Fl_Label*>(l)->color = h;
+}
+
+int fl_label_get_type(LABEL l) {
+ return (int)reinterpret_cast<Fl_Label*>(l)->type;
+}
+
+void fl_label_set_type(LABEL l, int k) {
+ reinterpret_cast<Fl_Label*>(l)->type = (uchar)k;
+}
+
+unsigned int fl_label_get_align(LABEL l) {
+ return reinterpret_cast<Fl_Label*>(l)->align_;
+}
+
+void fl_label_set_align(LABEL l, unsigned int p) {
+ reinterpret_cast<Fl_Label*>(l)->align_ = p;
+}
+
+void fl_label_set_image(LABEL l, void * i) {
+ reinterpret_cast<Fl_Label*>(l)->image = reinterpret_cast<Fl_Image*>(i);
+}
+
+void fl_label_set_deimage(LABEL l, void * i) {
+ reinterpret_cast<Fl_Label*>(l)->deimage = reinterpret_cast<Fl_Image*>(i);
+}
+
+
+
+
+void fl_label_draw(LABEL l, int x, int y, int w, int h, unsigned int p) {
+ reinterpret_cast<Fl_Label*>(l)->draw(x, y, w, h, p);
+}
+
+void fl_label_measure(LABEL l, int &w, int &h) {
+ reinterpret_cast<Fl_Label*>(l)->measure(w, h);
+}
+
+
diff --git a/src/c_fl_label.h b/src/c_fl_label.h
new file mode 100644
index 0000000..ea69d51
--- /dev/null
+++ b/src/c_fl_label.h
@@ -0,0 +1,45 @@
+
+
+// Programmed by Jedidiah Barber
+// Released into the public domain
+
+
+#ifndef FL_LABEL_GUARD
+#define FL_LABEL_GUARD
+
+
+
+
+typedef void* LABEL;
+
+
+
+
+extern "C" LABEL new_fl_label(const char * v, int f, int s, unsigned int h, int k, unsigned int p);
+extern "C" void free_fl_label(LABEL l);
+
+
+
+
+extern "C" void fl_label_set_value(LABEL l, const char * v);
+extern "C" int fl_label_get_font(LABEL l);
+extern "C" void fl_label_set_font(LABEL l, int f);
+extern "C" int fl_label_get_size(LABEL l);
+extern "C" void fl_label_set_size(LABEL l, int s);
+extern "C" unsigned int fl_label_get_color(LABEL l);
+extern "C" void fl_label_set_color(LABEL l, unsigned int h);
+extern "C" int fl_label_get_type(LABEL l);
+extern "C" void fl_label_set_type(LABEL l, int k);
+extern "C" unsigned int fl_label_get_align(LABEL l);
+extern "C" void fl_label_set_align(LABEL l, unsigned int p);
+extern "C" void fl_label_set_image(LABEL l, void * i);
+extern "C" void fl_label_set_deimage(LABEL l, void * i);
+
+
+extern "C" void fl_label_draw(LABEL l, int x, int y, int w, int h, unsigned int p);
+extern "C" void fl_label_measure(LABEL l, int &w, int &h);
+
+
+#endif
+
+
diff --git a/src/fltk-labels.adb b/src/fltk-labels.adb
new file mode 100644
index 0000000..493ac8d
--- /dev/null
+++ b/src/fltk-labels.adb
@@ -0,0 +1,358 @@
+
+
+-- Programmed by Jedidiah Barber
+-- Released into the public domain
+
+
+with
+
+ Interfaces.C.Strings;
+
+
+package body FLTK.Labels is
+
+
+ ------------------------
+ -- Functions From C --
+ ------------------------
+
+ function new_fl_label
+ (V : in Interfaces.C.Strings.chars_ptr;
+ F : in Interfaces.C.int;
+ S : in Interfaces.C.int;
+ H : in Interfaces.C.unsigned;
+ K : in Interfaces.C.int;
+ P : in Interfaces.C.unsigned)
+ return Storage.Integer_Address;
+ pragma Import (C, new_fl_label, "new_fl_label");
+ pragma Inline (new_fl_label);
+
+ procedure free_fl_label
+ (L : in Storage.Integer_Address);
+ pragma Import (C, free_fl_label, "free_fl_label");
+ pragma Inline (free_fl_label);
+
+
+
+
+ procedure fl_label_set_value
+ (L : in Storage.Integer_Address;
+ V : in Interfaces.C.Strings.chars_ptr);
+ pragma Import (C, fl_label_set_value, "fl_label_set_value");
+ pragma Inline (fl_label_set_value);
+
+ function fl_label_get_font
+ (L : in Storage.Integer_Address)
+ return Interfaces.C.int;
+ pragma Import (C, fl_label_get_font, "fl_label_get_font");
+ pragma Inline (fl_label_get_font);
+
+ procedure fl_label_set_font
+ (L : in Storage.Integer_Address;
+ F : in Interfaces.C.int);
+ pragma Import (C, fl_label_set_font, "fl_label_set_font");
+ pragma Inline (fl_label_set_font);
+
+ function fl_label_get_size
+ (L : in Storage.Integer_Address)
+ return Interfaces.C.int;
+ pragma Import (C, fl_label_get_size, "fl_label_get_size");
+ pragma Inline (fl_label_get_size);
+
+ procedure fl_label_set_size
+ (L : in Storage.Integer_Address;
+ S : in Interfaces.C.int);
+ pragma Import (C, fl_label_set_size, "fl_label_set_size");
+ pragma Inline (fl_label_set_size);
+
+ function fl_label_get_color
+ (L : in Storage.Integer_Address)
+ return Interfaces.C.unsigned;
+ pragma Import (C, fl_label_get_color, "fl_label_get_color");
+ pragma Inline (fl_label_get_color);
+
+ procedure fl_label_set_color
+ (L : in Storage.Integer_Address;
+ H : in Interfaces.C.unsigned);
+ pragma Import (C, fl_label_set_color, "fl_label_set_color");
+ pragma Inline (fl_label_set_color);
+
+ function fl_label_get_type
+ (L : in Storage.Integer_Address)
+ return Interfaces.C.int;
+ pragma Import (C, fl_label_get_type, "fl_label_get_type");
+ pragma Inline (fl_label_get_type);
+
+ procedure fl_label_set_type
+ (L : in Storage.Integer_Address;
+ K : in Interfaces.C.int);
+ pragma Import (C, fl_label_set_type, "fl_label_set_type");
+ pragma Inline (fl_label_set_type);
+
+ function fl_label_get_align
+ (L : in Storage.Integer_Address)
+ return Interfaces.C.unsigned;
+ pragma Import (C, fl_label_get_align, "fl_label_get_align");
+ pragma Inline (fl_label_get_align);
+
+ procedure fl_label_set_align
+ (L : in Storage.Integer_Address;
+ P : in Interfaces.C.unsigned);
+ pragma Import (C, fl_label_set_align, "fl_label_set_align");
+ pragma Inline (fl_label_set_align);
+
+ procedure fl_label_set_image
+ (L, I : in Storage.Integer_Address);
+ pragma Import (C, fl_label_set_image, "fl_label_set_image");
+ pragma Inline (fl_label_set_image);
+
+ procedure fl_label_set_deimage
+ (L, I : in Storage.Integer_Address);
+ pragma Import (C, fl_label_set_deimage, "fl_label_set_deimage");
+ pragma Inline (fl_label_set_deimage);
+
+
+
+
+ procedure fl_label_draw
+ (L : in Storage.Integer_Address;
+ X, Y, W, H : in Interfaces.C.int;
+ P : in Interfaces.C.unsigned);
+ pragma Import (C, fl_label_draw, "fl_label_draw");
+ pragma Inline (fl_label_draw);
+
+ procedure fl_label_measure
+ (L : in Storage.Integer_Address;
+ W, H : out Interfaces.C.int);
+ pragma Import (C, fl_label_measure, "fl_label_measure");
+ pragma Inline (fl_label_measure);
+
+
+
+
+ -----------------------------------
+ -- Controlled Type Subprograms --
+ -----------------------------------
+
+ procedure Finalize
+ (This : in out Label) is
+ begin
+ if This.Void_Ptr /= Null_Pointer and then
+ This in Label'Class
+ then
+ free_fl_label (This.Void_Ptr);
+ Interfaces.C.Strings.Free (This.My_Text);
+ This.Void_Ptr := Null_Pointer;
+ end if;
+ Finalize (Wrapper (This));
+ end Finalize;
+
+
+
+
+ -----------------
+ -- Label API --
+ -----------------
+
+ package body Forge is
+
+ function Create
+ (Value : in String;
+ Font : in Font_Kind := Helvetica;
+ Size : in Font_Size := Normal_Size;
+ Hue : in Color := Foreground_Color;
+ Kind : in Label_Kind := Normal_Label;
+ Place : in Alignment := Align_Center;
+ Active : access FLTK.Images.Image'Class := null;
+ Inactive : access FLTK.Images.Image'Class := null)
+ return Label is
+ begin
+ return This : Label do
+ This.My_Text := Interfaces.C.Strings.New_String (Value);
+ This.Void_Ptr := new_fl_label
+ (This.My_Text, -- Interfaces.C.Strings.chars_ptr
+ Font_Kind'Pos (Font), -- Interfaces.C.int
+ Interfaces.C.int (Size),
+ Interfaces.C.unsigned (Hue),
+ Label_Kind'Pos (Kind), -- Interfaces.C.int
+ Interfaces.C.unsigned (Place));
+ This.Set_Active (Active);
+ This.Set_Inactive (Inactive);
+ end return;
+ end Create;
+
+ end Forge;
+
+
+
+
+ function Get_Value
+ (This : in Label)
+ return String is
+ begin
+ return Interfaces.C.Strings.Value (This.My_Text);
+ end Get_Value;
+
+
+ procedure Set_Value
+ (This : in out Label;
+ Text : in String) is
+ begin
+ Interfaces.C.Strings.Free (This.My_Text);
+ This.My_Text := Interfaces.C.Strings.New_String (Text);
+ fl_label_set_value (This.Void_Ptr, This.My_Text);
+ end Set_Value;
+
+
+ function Get_Font
+ (This : in Label)
+ return Font_Kind is
+ begin
+ return Font_Kind'Val (fl_label_get_font (This.Void_Ptr));
+ end Get_Font;
+
+
+ procedure Set_Font
+ (This : in out Label;
+ Font : in Font_Kind) is
+ begin
+ fl_label_set_font (This.Void_Ptr, Font_Kind'Pos (Font));
+ end Set_Font;
+
+
+ function Get_Size
+ (This : in Label)
+ return Font_Size is
+ begin
+ return Font_Size (fl_label_get_size (This.Void_Ptr));
+ end Get_Size;
+
+
+ procedure Set_Size
+ (This : in out Label;
+ Size : in Font_Size) is
+ begin
+ fl_label_set_size (This.Void_Ptr, Interfaces.C.int (Size));
+ end Set_Size;
+
+
+ function Get_Color
+ (This : in Label)
+ return Color is
+ begin
+ return Color (fl_label_get_color (This.Void_Ptr));
+ end Get_Color;
+
+
+ procedure Set_Color
+ (This : in out Label;
+ Hue : in Color) is
+ begin
+ fl_label_set_color (This.Void_Ptr, Interfaces.C.unsigned (Hue));
+ end Set_Color;
+
+
+ function Get_Kind
+ (This : in Label)
+ return Label_Kind is
+ begin
+ return Label_Kind'Val (fl_label_get_type (This.Void_Ptr));
+ end Get_Kind;
+
+
+ procedure Set_Kind
+ (This : in out Label;
+ Kind : in Label_Kind) is
+ begin
+ fl_label_set_type (This.Void_Ptr, Label_Kind'Pos (Kind));
+ end Set_Kind;
+
+
+ function Get_Alignment
+ (This : in Label)
+ return Alignment is
+ begin
+ return Alignment (fl_label_get_align (This.Void_Ptr));
+ end Get_Alignment;
+
+
+ procedure Set_Alignment
+ (This : in out Label;
+ Place : in Alignment) is
+ begin
+ fl_label_set_align (This.Void_Ptr, Interfaces.C.unsigned (Place));
+ end Set_Alignment;
+
+
+ function Get_Active
+ (This : in Label)
+ return access FLTK.Images.Image'Class is
+ begin
+ return This.My_Active;
+ end Get_Active;
+
+
+ procedure Set_Active
+ (This : in out Label;
+ Pic : access FLTK.Images.Image'Class) is
+ begin
+ if Pic /= null then
+ fl_label_set_image (This.Void_Ptr, Wrapper (Pic.all).Void_Ptr);
+ else
+ fl_label_set_image (This.Void_Ptr, Null_Pointer);
+ end if;
+ This.My_Active := Pic;
+ end Set_Active;
+
+
+ function Get_Inactive
+ (This : in Label)
+ return access FLTK.Images.Image'Class is
+ begin
+ return This.My_Inactive;
+ end Get_Inactive;
+
+
+ procedure Set_Inactive
+ (This : in out Label;
+ Pic : access FLTK.Images.Image'Class) is
+ begin
+ if Pic /= null then
+ fl_label_set_deimage (This.Void_Ptr, Wrapper (Pic.all).Void_Ptr);
+ else
+ fl_label_set_deimage (This.Void_Ptr, Null_Pointer);
+ end if;
+ This.My_Inactive := Pic;
+ end Set_Inactive;
+
+
+
+
+ procedure Draw
+ (This : in out Label;
+ X, Y, W, H : in Integer;
+ Place : in Alignment) is
+ begin
+ fl_label_draw
+ (This.Void_Ptr,
+ Interfaces.C.int (X),
+ Interfaces.C.int (Y),
+ Interfaces.C.int (W),
+ Interfaces.C.int (H),
+ Interfaces.C.unsigned (Place));
+ end Draw;
+
+ procedure Measure
+ (This : in Label;
+ W, H : out Integer) is
+ begin
+ fl_label_measure
+ (This.Void_Ptr,
+ Interfaces.C.int (W),
+ Interfaces.C.int (H));
+ end Measure;
+
+
+end FLTK.Labels;
+
+
diff --git a/src/fltk-labels.ads b/src/fltk-labels.ads
new file mode 100644
index 0000000..5e13a2e
--- /dev/null
+++ b/src/fltk-labels.ads
@@ -0,0 +1,155 @@
+
+
+-- Programmed by Jedidiah Barber
+-- Released into the public domain
+
+
+with
+
+ FLTK.Images;
+
+private with
+
+ Interfaces.C.Strings;
+
+
+package FLTK.Labels is
+
+
+ type Label is new Wrapper with private;
+
+ type Label_Reference (Data : not null access Label'Class) is limited null record
+ with Implicit_Dereference => Data;
+
+
+
+
+ package Forge is
+
+ function Create
+ (Value : in String;
+ Font : in Font_Kind := Helvetica;
+ Size : in Font_Size := Normal_Size;
+ Hue : in Color := Foreground_Color;
+ Kind : in Label_Kind := Normal_Label;
+ Place : in Alignment := Align_Center;
+ Active : access FLTK.Images.Image'Class := null;
+ Inactive : access FLTK.Images.Image'Class := null)
+ return Label;
+
+ end Forge;
+
+
+
+
+ function Get_Value
+ (This : in Label)
+ return String;
+
+ procedure Set_Value
+ (This : in out Label;
+ Text : in String);
+
+ function Get_Font
+ (This : in Label)
+ return Font_Kind;
+
+ procedure Set_Font
+ (This : in out Label;
+ Font : in Font_Kind);
+
+ function Get_Size
+ (This : in Label)
+ return Font_Size;
+
+ procedure Set_Size
+ (This : in out Label;
+ Size : in Font_Size);
+
+ function Get_Color
+ (This : in Label)
+ return Color;
+
+ procedure Set_Color
+ (This : in out Label;
+ Hue : in Color);
+
+ function Get_Kind
+ (This : in Label)
+ return Label_Kind;
+
+ procedure Set_Kind
+ (This : in out Label;
+ Kind : in Label_Kind);
+
+ function Get_Alignment
+ (This : in Label)
+ return Alignment;
+
+ procedure Set_Alignment
+ (This : in out Label;
+ Place : in Alignment);
+
+ function Get_Active
+ (This : in Label)
+ return access FLTK.Images.Image'Class;
+
+ procedure Set_Active
+ (This : in out Label;
+ Pic : access FLTK.Images.Image'Class);
+
+ function Get_Inactive
+ (This : in Label)
+ return access FLTK.Images.Image'Class;
+
+ procedure Set_Inactive
+ (This : in out Label;
+ Pic : access FLTK.Images.Image'Class);
+
+
+
+
+ procedure Draw
+ (This : in out Label;
+ X, Y, W, H : in Integer;
+ Place : in Alignment);
+
+ procedure Measure
+ (This : in Label;
+ W, H : out Integer);
+
+
+private
+
+
+ type Label is new Wrapper with record
+ My_Active : access FLTK.Images.Image'Class;
+ My_Inactive : access FLTK.Images.Image'Class;
+ My_Text : Interfaces.C.Strings.chars_ptr;
+ end record;
+
+ overriding procedure Finalize
+ (This : in out Label);
+
+
+ pragma Inline (Get_Value);
+ pragma Inline (Get_Font);
+ pragma Inline (Set_Font);
+ pragma Inline (Get_Size);
+ pragma Inline (Set_Size);
+ pragma Inline (Get_Color);
+ pragma Inline (Set_Color);
+ pragma Inline (Get_Kind);
+ pragma Inline (Set_Kind);
+ pragma Inline (Get_Alignment);
+ pragma Inline (Set_Alignment);
+ pragma Inline (Get_Active);
+ pragma Inline (Get_Inactive);
+
+ pragma Inline (Draw);
+ pragma Inline (Measure);
+
+
+end FLTK.Labels;
+
+
generated by cgit (git 2.30.0) at 2025-01-15 18:52:28 +0000