nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add initial prototype.

Browse Source
This commit is contained in:
Rod Kay
2022-07-31 17:34:54 +10:00
commit 54a53b2ac0
1421 changed files with 358874 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

99
3-mid/opengl/source/lean/text/opengl-font-texture.adb Normal file
View File

@@ -0,0 +1,99 @@
with
openGL.FontImpl.texture,
ada.unchecked_Deallocation;
package body openGL.Font.texture
is
---------
-- Forge
--
function to_Font_texture (fontFilePath : in String) return Font.texture.item
is
begin
return Self : Font.texture.item
do
Self.define (fontImpl.texture.new_FontImpl_texture (Self'Access,
fontFilePath));
end return;
end to_Font_texture;
function new_Font_texture (fontFilePath : in String) return Font.texture.view
is
Self : constant Font.texture.view := new Font.texture.item;
begin
Self.define (fontImpl.Texture.new_FontImpl_texture (Self,
fontFilePath));
return Self;
end new_Font_texture;
function to_Font_texture (pBufferBytes : in FontImpl.unsigned_char_Pointer;
bufferSizeInBytes : in Natural) return Font.texture.item
is
begin
return Self : Font.texture.item
do
Self.define (fontImpl.Texture.new_FontImpl_texture (Self'Access,
pBufferBytes,
bufferSizeInBytes).all'Access);
end return;
end to_Font_texture;
overriding
procedure destruct (Self : in out Item)
is
begin
destruct (openGL.Font.item (Self)); -- Destroy base class.
end destruct;
procedure free (Self : in out View)
is
procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
begin
Self.destruct;
deallocate (Self);
end free;
--------------
-- Attributes
--
function gl_Texture (Self : in Item) return openGL.Texture.texture_Name
is
begin
return fontImpl.texture.view (Self.Impl).gl_Texture;
end gl_Texture;
function Quad (Self : in Item; for_Character : in Character) return GlyphImpl.Texture.Quad_t
is
begin
return fontImpl.texture.view (Self.Impl).Quad (for_Character);
end Quad;
--------------
-- Operations
--
overriding
function MakeGlyph (Self : access Item; Slot : in freetype_c.FT_GlyphSlot.item) return glyph.Container.Glyph_view
is
type FontImpl_texture_view is access all FontImpl.texture.Item'Class;
myimpl : constant FontImpl_texture_view := FontImpl_texture_view (Self.impl);
begin
if myimpl = null then
return null;
end if;
return myimpl.MakeGlyphImpl (Slot);
end MakeGlyph;
end openGL.Font.texture;

68
3-mid/opengl/source/lean/text/opengl-font-texture.ads Normal file
View File

@@ -0,0 +1,68 @@
with
openGL.Texture,
openGL.GlyphImpl.texture;
package openGL.Font.texture
--
-- A texture font is a specialisation of the font class for handling texture mapped fonts.
--
is
type Item is new Font.item with private;
type View is access all Item'Class;
---------
-- Forge
--
function to_Font_texture (fontFilePath : in String) return Font.texture.item;
--
--
-- Open and read a font file. Sets Error flag.
function new_Font_texture (fontFilePath : in String) return Font.texture.view;
function to_Font_texture (pBufferBytes : in FontImpl.unsigned_char_Pointer;
bufferSizeInBytes : in Natural) return Font.texture.item;
--
-- Open and read a font from a buffer in memory. Sets Error flag.
--
-- The buffer is owned by the client and is NOT copied by FTGL. The
-- pointer must be valid while using FTGL.
--
-- pBufferBytes: The in-memory buffer.
-- bufferSizeInBytes: The length of the buffer in bytes.
overriding
procedure destruct (Self : in out Item);
procedure free (Self : in out View);
--------------
-- Attributes
--
function gl_Texture (Self : in Item) return openGL.Texture.texture_Name;
function Quad (Self : in Item; for_Character : in Character) return GlyphImpl.Texture.Quad_t;
private
type Item is new Font.item with null record;
overriding
function MakeGlyph (Self : access Item; Slot : in freetype_c.FT_GlyphSlot.item) return glyph.Container.Glyph_view;
--
-- Construct a glyph of the correct type.
--
-- Clients must override the function and return their specialised FTGlyph.
-- Returns an FTGlyph or null on failure.
--
-- Slot: A FreeType glyph slot.
end openGL.Font.texture;

245
3-mid/opengl/source/lean/text/opengl-font.adb Normal file
View File

@@ -0,0 +1,245 @@
with
ada.unchecked_Deallocation,
ada.unchecked_Conversion;
package body openGL.Font
is
-----------
-- Utility
--
function Hash (the_Id : in font_Id) return ada.Containers.Hash_type
is
use ada.Containers;
begin
return Hash (the_Id.Name) + Hash_type (the_Id.Size);
end Hash;
---------
-- Forge
--
procedure define (Self : in out Item; fontFilePath : in String)
is
begin
Self.Impl := new FontImpl.item;
Self.Impl.define (Self'Access, fontFilePath);
end define;
procedure define (Self : in out Item; pBufferBytes : in FontImpl.unsigned_char_Pointer;
bufferSizeInBytes : in Natural)
is
begin
Self.Impl := new FontImpl.item;
Self.Impl.define (Self'Access, pBufferBytes, bufferSizeInBytes);
end define;
procedure define (Self : in out Item; pImpl : in FontImpl.view)
is
begin
Self.Impl := pImpl;
end define;
procedure destruct (Self : in out Item)
is
procedure free is new ada.unchecked_Deallocation (FontImpl.item'Class,
FontImpl.view);
begin
Self.Impl.destruct;
free (Self.Impl);
end destruct;
procedure free (Self : in out View)
is
procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
begin
Self.destruct;
deallocate (Self);
end free;
--------------
-- Attributes
--
function CharMap (Self : in Item; Encoding : in freetype_c.FT_Encoding) return Boolean
is
begin
return Self.impl.CharMap (Encoding);
end CharMap;
function CharMapCount (Self : in Item) return Natural
is
begin
return Self.impl.CharMapCount;
end CharMapCount;
function CharMapList (Self : access Item) return freetype.face.FT_Encodings_view
is
begin
return Self.impl.CharMapList;
end CharMapList;
function Ascender (Self : in Item) return Real
is
begin
return Self.impl.Ascender;
end Ascender;
function Descender (Self : in Item) return Real
is
begin
return Self.impl.Descender;
end Descender;
function LineHeight (Self : in Item) return Real
is
begin
return Self.impl.LineHeight;
end LineHeight;
function FaceSize (Self : access Item; Size : in Natural;
x_Res, y_Res : in Natural) return Boolean
is
begin
return Self.impl.FaceSize (Size, x_Res, y_Res);
end FaceSize;
function FaceSize (Self : in Item) return Natural
is
begin
return Self.impl.FaceSize;
end FaceSize;
procedure Depth (Self : in out Item; Depth : in Real)
is
begin
Self.impl.Depth (Depth);
end Depth;
procedure Outset (Self : in out Item; Outset : in Real)
is
begin
Self.impl.Outset (Outset);
end Outset;
procedure Outset (Self : in out Item; Front : in Real;
Back : in Real)
is
begin
Self.impl.Outset (Front, Back);
end Outset;
function BBox (Self : access Item; Text : in String;
Length : in Integer := -1;
Position : in Vector_3 := Origin_3D;
Spacing : in Vector_3 := Origin_3D) return Bounds
is
begin
return Self.impl.BBox (Text, Length, Position, Spacing);
end BBox;
function Error (Self : in Item) return freetype_c.FT_Error
is
begin
return Self.impl.Err;
end Error;
--------------
-- Operations
--
function attach (Self : in Item; Font_File_Path : in String) return Boolean
is
begin
return Self.impl.attach (Font_File_Path);
end Attach;
function attach (Self : in Item; pBufferBytes : in FontImpl.unsigned_char_Pointer;
bufferSizeInBytes : in Natural) return Boolean
is
begin
return Self.impl.Attach (pBufferBytes, bufferSizeInBytes);
end Attach;
procedure glyph_load_Flags (Self : in out Item; Flags : in freetype_c.FT_Int)
is
begin
Self.impl.GlyphLoadFlags (Flags);
end glyph_load_Flags;
function Advance (Self : access Item; Text : in String;
Length : in Integer := -1;
Spacing : in Vector_3 := Origin_3D) return Real
is
begin
return Self.impl.Advance (Text, Length, Spacing);
end Advance;
function kern_Advance (Self : in Item; From, To : in Character) return Real
is
begin
return Self.impl.kern_Advance (From, To);
end kern_Advance;
function x_PPEM (Self : in Item) return Real
is
begin
return Self.impl.x_PPEM;
end x_PPEM;
function x_Scale (Self : in Item) return Real
is
begin
return Self.impl.x_Scale;
end x_Scale;
function y_Scale (Self : in Item) return Real
is
begin
return Self.impl.y_Scale;
end y_Scale;
function check_Glyphs (Self : access Item; Text : in String;
Length : in Integer := -1;
Position : in Vector_3 := Origin_3D;
Spacing : in Vector_3 := Origin_3D;
Mode : in fontImpl.RenderMode := fontImpl.RENDER_ALL) return Vector_3
is
function to_Integer is new ada.Unchecked_Conversion (fontImpl.RenderMode, Integer);
begin
return Self.impl.Render (Text,
Length,
Position,
Spacing,
to_Integer (Mode));
end check_Glyphs;
end openGL.Font;

274
3-mid/opengl/source/lean/text/opengl-font.ads Normal file
View File

@@ -0,0 +1,274 @@
with
openGL.Glyph.Container,
openGL.FontImpl,
freetype.Face,
freetype_c.FT_GlyphSlot,
ada.Containers.hashed_Maps;
package openGL.Font
--
-- Specific font classes are derived from this class. It uses the helper
-- classes 'freetype_c.Face' and 'freetype_c.FTSize' to access the Freetype library.
--
-- This class is abstract and derived classes must implement the protected
-- 'MakeGlyph' function to create glyphs of the appropriate type.
--
is
type Item is abstract tagged limited private;
type View is access all Item'Class;
----------
-- Font_Id
--
type font_Id is
record
Name : asset_Name;
Size : Integer;
end record;
function Hash (the_Id : in font_Id) return ada.Containers.Hash_type;
------------
-- Font Maps
--
package font_id_Maps_of_font is new ada.Containers.hashed_Maps (Key_Type => font_Id,
Element_Type => Font.view,
Hash => Hash,
Equivalent_Keys => "=");
subtype font_id_Map_of_font is font_id_Maps_of_font.Map;
---------
-- Forge
--
procedure destruct (Self : in out Item);
procedure free (Self : in out View);
--------------
-- Attributes
--
function CharMap (Self : in Item; Encoding : in freetype_c.FT_Encoding) return Boolean;
--
-- Set the character map for the face.
--
-- Encoding: Freetype enumerate for char map code.
--
-- Returns True if charmap was valid and set correctly.
function CharMapCount (Self : in Item) return Natural;
--
-- Get the number of character maps in this face.
--
-- Returns the character map count.
function CharMapList (Self : access Item) return freetype.face.FT_Encodings_view;
--
-- Get a list of character maps in this face.
--
-- Returns aceess to the array of encodings.
function Ascender (Self : in Item) return Real;
--
-- Get the global ascender height for the face.
--
-- Returns the Ascender height.
function Descender (Self : in Item) return Real;
--
-- Gets the global descender height for the face.
--
-- Returns the Descender height.
function LineHeight (Self : in Item) return Real;
--
-- Gets the line spacing for the font.
--
-- Returns the line height.
function FaceSize (Self : access Item; size : in Natural;
x_Res, y_Res : in Natural) return Boolean;
--
-- Set the character size for the current face.
--
-- Returns True if size was set correctly.
function FaceSize (Self : in Item) return Natural;
--
-- Get the current face size in points (1/72 inch).
--
-- Returns the face size.
procedure Depth (Self : in out Item; Depth : in Real);
--
-- Set the extrusion distance for the font. Only implemented by FTExtrudeFont.
--
-- Depth: The extrusion distance.
procedure Outset (Self : in out Item; Outset : in Real);
--
-- Set the outset distance for the font. Only implemented by FTOutlineFont, FTPolygonFont and FTExtrudeFont.
--
-- Outset: The outset distance.
procedure Outset (Self : in out Item; Front : in Real;
Back : in Real);
--
-- Set the front and back outset distances for the font. Only implemented by FTExtrudeFont.
--
-- Front: The front outset distance.
-- Back: The back outset distance.
function BBox (Self : access Item; Text : in String;
Length : in Integer := -1;
Position : in Vector_3 := Origin_3D;
Spacing : in Vector_3 := Origin_3D) return Bounds;
--
-- Get the bounding box for a string.
--
-- Text: A character buffer.
-- Length: The length of the string. If < 0 then all characters will be checked until a null character is encountered.
-- Position: The pen position of the first character.
-- Spacing: A displacement vector to add after each character has been checked.
--
-- Returns the corresponding bounding box.
function Error (Self : in Item) return freetype_c.FT_Error;
--
-- Queries the font for errors.
--
-- Returns the current error code.
--------------
-- Operations
--
function attach (Self : in Item; Font_File_Path : in String) return Boolean;
--
-- Attach auxilliary file to font e.g font metrics.
-- Note: Not all font formats implement this function.
--
-- fontFilePath: The auxilliary font file path.
--
-- Returns True if file has been attached successfully.
function attach (Self : in Item; pBufferBytes : in FontImpl.unsigned_char_Pointer;
bufferSizeInBytes : in Natural) return Boolean;
--
-- Attach auxilliary data to font e.g font metrics, from memory.
-- Note: Not all font formats implement this function.
--
-- 'pBufferBytes' The in-memory buffer.
-- 'bufferSizeInBytes' The length of the buffer in bytes.
--
-- Returns True if file has been attached successfully.
procedure glyph_load_Flags (Self : in out Item; Flags : in freetype_c.FT_Int);
--
-- Set the glyph loading flags. By default, fonts use the most
-- sensible flags when loading a font's glyph using FT_Load_Glyph().
-- This function allows to override the default flags.
--
-- Flags: The glyph loading flags.
function Advance (Self : access Item; Text : in String;
Length : in Integer := -1;
Spacing : in Vector_3 := Origin_3D) return Real;
--
-- Get the advance for a string.
--
-- Text: String to be checked.
-- Length: The length of the string. If < 0 then all characters will be checked until
-- a null character is encountered.
-- Spacing: A displacement vector to add after each character has been checked.
--
-- Returns the string's advance width.
function kern_Advance (Self : in Item; From, To : in Character) return Real;
function x_PPEM (Self : in Item) return Real;
function x_Scale (Self : in Item) return Real;
function y_Scale (Self : in Item) return Real;
function check_Glyphs (Self : access Item; Text : in String;
Length : in Integer := -1;
Position : in Vector_3 := math.Origin_3D;
Spacing : in Vector_3 := math.Origin_3D;
Mode : in fontImpl.RenderMode := fontImpl.RENDER_ALL) return Vector_3;
--
-- Render a string of characters.
--
-- Text: String to be output.
-- Length: The length of the string. If < 0 then all characters will be displayed until a null character is encountered.
-- Position: The pen position of the first character.
-- Spacing: A displacement vector to add after each character has been displayed
-- Mode: Render mode to use for display.
--
-- Returns the new pen position after the last character was output.
function MakeGlyph (Self : access Item; Slot : in freetype_c.FT_GlyphSlot.item) return glyph.Container.Glyph_view
is abstract;
--
-- Construct a glyph of the correct type.
-- Clients must override the function and return their specialised glyph.
--
-- Slot: A FreeType glyph slot.
--
-- Returns an FTGlyph or null on failure.
private
type Item is abstract tagged limited
record
Impl : FontImpl.view; -- Internal FTGL FTFont implementation object. For private use only.
end record;
procedure define (Self : in out Item; fontFilePath : in String);
--
-- Open and read a font file. Sets Error flag.
procedure define (Self : in out Item; pBufferBytes : in FontImpl.unsigned_char_Pointer;
bufferSizeInBytes : in Natural);
--
-- Open and read a font from a buffer in memory. Sets Error flag.
-- The buffer is owned by the client and is NOT copied by FTGL. The pointer must be valid while using FTGL.
procedure define (Self : in out Item; pImpl : in FontImpl.view);
--
-- Internal FTGL FTFont constructor. For private use only.
--
-- pImpl: An internal implementation object, which will be destroyed upon FTFont deletion.
end openGL.Font;

157
3-mid/opengl/source/lean/text/opengl-glyph-container.adb Normal file
View File

@@ -0,0 +1,157 @@
with
ada.unchecked_Deallocation;
package body openGL.Glyph.Container
is
---------
--- Forge
--
function to_glyph_Container (parent_Face : in freetype.Face.view) return openGL.glyph.Container.item
is
Self : openGL.glyph.Container.item;
begin
Self.Face := parent_Face;
Self.Err := 0;
Self.charMap := new freetype.charMap.Item' (freetype.charMap.to_charMap (Self.Face));
return Self;
end to_glyph_Container;
procedure destruct (Self : in out Item)
is
use Glyph_Vectors;
procedure deallocate is new ada.unchecked_Deallocation (openGL.Glyph.item'Class, Glyph_view);
procedure deallocate is new ada.unchecked_Deallocation (freetype.charMap.item'Class, charMap_view);
Cursor : Glyph_Vectors.Cursor := Self.Glyphs.First;
the_Glyph : Glyph_view;
begin
while has_Element (Cursor)
loop
the_Glyph := Element (Cursor);
deallocate (the_Glyph);
next (Cursor);
end loop;
Self.Glyphs .clear;
Self.charMap.destruct;
deallocate (Self.charMap);
end destruct;
--------------
-- Attributes
--
function CharMap (Self : access Item; Encoding : in freeType_c.FT_Encoding) return Boolean
is
Result : constant Boolean := Self.charMap.CharMap (Encoding);
begin
Self.Err := Self.charMap.Error;
return Result;
end CharMap;
function FontIndex (Self : in Item; Character : in freetype.charMap.characterCode) return Natural
is
begin
return Natural (Self.charMap.FontIndex (Character));
end FontIndex;
procedure add (Self : in out Item; Glyph : in Glyph_view;
Character : in freetype.charMap.characterCode)
is
begin
Self.glyphs.append (Glyph);
Self.charMap.insertIndex (Character, Self.Glyphs.Length);
end add;
function Glyph (Self : in Item; Character : in freetype.charMap.characterCode) return Glyph_view
is
use type freetype.charMap.glyphIndex;
Index : constant freetype.charMap.glyphIndex := Self.charMap.GlyphListIndex (Character);
begin
if Index = -1
then return null;
else return Self.Glyphs.Element (Integer (Index));
end if;
end Glyph;
function BBox (Self : in Item; Character : in freetype.charMap.characterCode) return Bounds
is
begin
return Self.Glyph (Character).BBox;
end BBox;
function Advance (Self : in Item; Character : in freetype.charMap.characterCode;
nextCharacterCode : in freetype.charMap.characterCode) return Real
is
Left : constant freetype.charMap.glyphIndex := Self.charMap.FontIndex (Character);
Right : constant freetype.charMap.glyphIndex := Self.charMap.FontIndex (nextCharacterCode);
begin
return Real (Self.Face.KernAdvance (Integer (Left),
Integer (Right)) (1) + Float (Self.Glyph (Character).Advance));
end Advance;
function Error (Self : in Item) return freetype_c.FT_Error
is
begin
return Self.Err;
end Error;
--------------
-- Operations
--
function render (Self : access Item; Character : in freetype.charMap.characterCode;
nextCharacterCode : in freetype.charMap.characterCode;
penPosition : in Vector_3;
renderMode : in Integer) return Vector_3
is
use type freetype_c.FT_Error,
freetype.charMap.glyphIndex;
Left : constant freetype.charMap.glyphIndex := Self.charMap.FontIndex (Character) - 0;
Right : constant freetype.charMap.glyphIndex := Self.charMap.FontIndex (nextCharacterCode) - 0;
ft_kernAdvance : constant freetype.Vector_3 := Self.Face.KernAdvance (Integer (Left),
Integer (Right));
kernAdvance : Vector_3 := [ft_kernAdvance (1),
ft_kernAdvance (2),
ft_kernAdvance (3)];
Index : freetype.charMap.glyphIndex;
begin
if Self.Face.Error = 0
then
Index := Self.charMap.GlyphListIndex (Character);
kernAdvance := kernAdvance + Self.Glyphs.Element (Integer (Index)).Render (penPosition,
renderMode);
else
raise openGL.Error with "Unable to render character '" & Character'Image & "'";
end if;
return kernAdvance;
end Render;
end openGL.Glyph.Container;

127
3-mid/opengl/source/lean/text/opengl-glyph-container.ads Normal file
View File

@@ -0,0 +1,127 @@
with
freetype.Face,
freetype.charMap;
private
with
ada.Containers.Vectors;
package openGL.Glyph.Container
--
-- Contains the post processed Glyph objects.
--
is
type Item is tagged private;
type Glyph_view is access all Glyph.item'Class;
---------
-- Forge
--
function to_glyph_Container (parent_Face : in freetype.Face.view) return glyph.Container.item;
--
-- parent_Face: The Freetype face.
procedure destruct (Self : in out Item);
--------------
-- Attributes
--
function CharMap (Self : access Item; Encoding : in freeType_c.FT_Encoding) return Boolean;
--
-- Sets the character map for the face.
--
-- Encoding: The Freetype encoding symbol.
--
-- Returns True if charmap was valid and set correctly.
function FontIndex (Self : in Item; Character : in freetype.charMap.characterCode) return Natural;
--
-- Get the font index of the input character.
--
-- Character: The character code of the requested glyph in the current encoding (eg apple roman).
--
-- Returns the font index for the character.
procedure add (Self : in out Item; Glyph : in Glyph_view;
Character : in freetype.charMap.characterCode);
--
-- Adds a glyph to this glyph list.
--
-- Glyph: The FTGlyph to be inserted into the container.
-- Character: The char code of the glyph NOT the glyph index.
function Glyph (Self : in Item; Character : in freetype.charMap.characterCode) return Glyph_view;
--
-- Get a glyph from the glyph list.
--
-- Character: The char code of the glyph NOT the glyph index.
--
-- Returns a Glyph or null is it hasn't been loaded.
function BBox (Self : in Item; Character : in freetype.charMap.characterCode) return Bounds;
--
-- Get the bounding box for a character.
--
-- Character: The char code of the glyph NOT the glyph index.
function Advance (Self : in Item; Character : in freetype.charMap.characterCode;
nextCharacterCode : in freetype.charMap.characterCode) return Real;
--
-- Character: Glyph index of the character.
-- nextCharacterCode: The next glyph in a string.
--
-- Returns the kerned advance width for a glyph.
function Error (Self : in Item) return freetype_c.FT_Error;
--
-- Queries the glyph container for errors.
--
-- Returns the current error code.
--------------
-- Operations
--
function render (Self : access Item; Character : in freetype.charMap.characterCode;
nextCharacterCode : in freetype.charMap.characterCode;
penPosition : in Vector_3;
renderMode : in Integer) return Vector_3;
--
-- Renders a character.
--
-- Character: The glyph to be Rendered.
-- nextCharacterCode: The next glyph in the string. Used for kerning.
-- penPosition: The position to Render the glyph.
-- renderMode: Render mode to display.
--
-- Returns the distance to advance the pen position after rendering,
private
type charMap_view is access all freetype.charMap.item'class;
package glyph_Vectors is new ada.Containers.Vectors (Positive, Glyph_view);
type Item is tagged
record
Face : freetype.Face.view; -- The FTGL face.
charMap : charMap_view; -- The character map object associated with the current face.
Glyphs : glyph_Vectors.Vector; -- A structure to hold the glyphs.
Err : freeType_c.FT_Error; -- Current error code. Zero means no error.
end record;
end openGL.Glyph.Container;

60
3-mid/opengl/source/lean/text/opengl-glyph-texture.adb Normal file
View File

@@ -0,0 +1,60 @@
package body openGL.Glyph.texture
is
---------
-- Forge
--
function to_Glyph (glyth_Slot : in freetype_c.FT_GlyphSlot.item;
texture_Id : in openGL.Texture.texture_Name;
xOffset, yOffset : in Integer;
Width, Height : in Integer) return Glyph.texture.item
is
Self : Glyph .texture.item;
Impl : constant GlyphImpl.texture.view := GlyphImpl.texture.new_GlyphImpl (glyth_Slot,
texture_Id,
xOffset, yOffset,
Width, Height);
begin
Self.define (Impl.all'Access);
return Self;
end to_Glyph;
function new_Glyph (glyth_Slot : in freetype_c.FT_GlyphSlot.item;
texture_Id : in openGL.Texture.texture_Name;
xOffset, yOffset : in Integer;
Width, Height : in Integer) return Glyph.texture.view
is
begin
return new Glyph.texture.item' (to_Glyph (glyth_Slot,
texture_Id,
xOffset, yOffset,
Width, Height));
end new_Glyph;
--------------
-- Attributes
--
function Quad (Self : in Item; Pen : in Vector_3) return GlyphImpl.texture.Quad_t
is
begin
return GlyphImpl.texture.view (Self.Impl).Quad (Pen);
end Quad;
--------------
-- Operations
--
overriding function render (Self : in Item; Pen : in Vector_3;
renderMode : in Integer) return Vector_3
is
begin
return GlyphImpl.texture.view (Self.Impl).renderImpl (Pen, renderMode);
end render;
end openGL.Glyph.texture;

69
3-mid/opengl/source/lean/text/opengl-glyph-texture.ads Normal file
View File

@@ -0,0 +1,69 @@
with
openGL.Texture,
openGL.GlyphImpl.Texture,
freetype_c.FT_GlyphSlot;
package openGL.Glyph.texture
--
-- A specialisation of Glyph for creating texture glyphs.
--
is
type Item is new Glyph.item with private;
type View is access all Item'Class;
-----------
-- Forge
--
function to_Glyph (glyth_Slot : in freetype_c.FT_GlyphSlot.item;
texture_Id : in openGL.Texture.texture_Name;
xOffset, yOffset : in Integer;
Width, Height : in Integer) return Glyph.texture.item;
--
-- glyth_Slot: The Freetype glyph to be processed.
-- texture_id: The id of the texture that this glyph will be drawn in.
-- xOffset, yOffset: The x and y offset into the parent texture to draw this glyph.
-- Width, Height: The width and height (number of rows) of the parent texture.
function new_Glyph (glyth_Slot : in freetype_c.FT_GlyphSlot.item;
texture_Id : in openGL.Texture.texture_Name;
xOffset, yOffset : in Integer;
Width, Height : in Integer) return Glyph.texture.view;
--
-- glyth_Slot: The Freetype glyph to be processed.
-- texture_Id: The id of the texture that this glyph will be drawn in.
-- xOffset, yOffset: The x,y offset into the parent texture to draw this glyph.
-- Width, Height: The width and height (number of rows) of the parent texture.
--------------
-- Attributes
--
function Quad (Self : in Item; Pen : in Vector_3) return GlyphImpl.texture.Quad_t;
---------------
-- Operations
--
overriding
function render (Self : in Item; Pen : in Vector_3;
renderMode : in Integer) return Vector_3;
--
-- Render this glyph at the current pen position.
--
-- Pen: The current pen position.
-- renderMode: Render mode to display.
--
-- Returns the advance distance for this glyph.
private
type Item is new Glyph.item with null record;
end openGL.Glyph.texture;

60
3-mid/opengl/source/lean/text/opengl-glyph.adb Normal file
View File

@@ -0,0 +1,60 @@
with
ada.unchecked_Deallocation;
package body openGL.Glyph
is
---------
-- Forge
--
procedure define (Self : in out Item; glyth_Slot : in freetype_c.FT_GlyphSlot.item)
is
begin
Self.Impl := new GlyphImpl.item;
Self.Impl.define (glyth_Slot);
end define;
procedure define (Self : in out Item; pImpl : in GlyphImpl.view)
is
begin
Self.Impl := pImpl;
end define;
procedure destruct (Self : in out Item)
is
procedure deallocate is new ada.unchecked_Deallocation (GlyphImpl.item'Class,
GlyphImpl.view);
begin
deallocate (Self.Impl);
end destruct;
--------------
-- Attributes
--
function Advance (Self : in Item) return Real
is
begin
return Self.Impl.Advance;
end Advance;
function BBox (Self : in Item) return Bounds
is
begin
return Self.Impl.BBox;
end BBox;
function Error (Self : in Item) return GlyphImpl.Error_Kind
is
begin
return Self.Impl.Error;
end Error;
end openGL.Glyph;

68
3-mid/opengl/source/lean/text/opengl-glyph.ads Normal file
View File

@@ -0,0 +1,68 @@
with
freeType_c.FT_GlyphSlot,
openGL.GlyphImpl;
package openGL.Glyph
--
-- Glyph is the base class for openGL glyphs.
--
-- It provides the interface between Freetype glyphs and their openGL
-- renderable counterparts.
--
-- This is an abstract class and derived classes must implement the 'Render' function.
--
is
type Item is abstract tagged private;
---------
-- Forge
--
procedure destruct (Self : in out Item);
--------------
-- Attributes
--
function Advance (Self : in Item) return Real; -- Return the advance width for this glyph.
function BBox (Self : in Item) return Bounds; -- Return the bounding box for this glyph.
function Error (Self : in Item) return GlyphImpl.Error_Kind; -- Return the current error code.
--------------
--- Operations
--
function render (Self : in Item; Pen : in Vector_3;
renderMode : in Integer) return Vector_3
is abstract;
--
-- Renders this glyph at the current pen position.
--
-- Pen: The current pen position.
-- renderMode: Render mode to display.
---
-- Returns the advance distance for this glyph.
private
type Item is abstract tagged
record
Impl : GlyphImpl.view; -- Internal FTGL FTGlyph implementation object. For private use only.
end record;
procedure define (Self : in out Item; glyth_Slot : in freetype_c.FT_GlyphSlot.item);
--
-- glyth_Slot: The Freetype glyph to be processed.
procedure define (Self : in out Item; pImpl : in GlyphImpl.view);
--
-- Internal FTGL FTGlyph constructor. For private use only.
--
-- pImpl: An internal implementation object. Will be destroyed upon FTGlyph deletion.
end openGL.Glyph;

341
3-mid/opengl/source/lean/text/private/opengl-fontimpl-texture.adb Normal file
View File

@@ -0,0 +1,341 @@
with
openGL.Glyph.texture,
openGL.Glyph.Container,
openGL.Palette,
openGL.Tasks,
GL.Binding,
GL.lean,
GL.Pointers,
freetype_c.Binding,
ada.unchecked_Conversion;
package body openGL.FontImpl.Texture
is
---------
-- Forge
--
function to_FontImpl_texture (ftFont : access Font.item'Class;
fontFilePath : in String) return fontImpl.texture.item
is
use freetype_c.Binding;
Success : Boolean;
begin
return Self : fontImpl.texture.item
do
define (Self'Access, ftFont, fontFilePath);
Self.load_Flags := freetype_c.FT_Int (FT_LOAD_NO_HINTING_flag or FT_LOAD_NO_BITMAP_flag);
Self.numGlyphs := Self.Face.GlyphCount;
Self.remGlyphs := Self.numGlyphs;
Success := Self.FaceSize (20);
if not Success then
raise Error with "Unable to set font facesize for '" & fontFilePath & "'.";
end if;
end return;
end to_FontImpl_texture;
function new_FontImpl_texture (ftFont : access Font.item'Class;
fontFilePath : in String) return access fontImpl.texture.item'Class
is
use freetype_c.Binding;
Self : constant fontImpl.texture.view := new fontImpl.texture.item;
Success : Boolean;
begin
define (Self, ftFont, fontFilePath);
Self.load_Flags := freetype_c.FT_Int (FT_LOAD_NO_HINTING_flag or FT_LOAD_NO_BITMAP_flag);
Self.numGlyphs := Self.Face.GlyphCount;
Self.remGlyphs := Self.numGlyphs;
Success := Self.FaceSize (20);
if not Success then
raise Error with "Unable to set font facesize for '" & fontFilePath & "'.";
end if;
return Self;
end new_FontImpl_texture;
function to_FontImpl_texture (ftFont : access openGL.Font.item'Class;
pBufferBytes : in unsigned_char_Pointer;
bufferSizeInBytes : in Natural) return fontImpl.texture.item
is
use freetype_c.Binding;
begin
return Self : fontImpl.texture.item
do
define (Self'Access, ftFont, pBufferBytes, bufferSizeInBytes);
Self.load_Flags := freetype_c.FT_Int ( FT_LOAD_NO_HINTING_flag
or FT_LOAD_NO_BITMAP_flag);
Self.numGlyphs := Self.face.GlyphCount;
Self.remGlyphs := Self.numGlyphs;
end return;
end to_FontImpl_texture;
function new_FontImpl_texture (ftFont : access Font.item'Class;
pBufferBytes : in unsigned_char_Pointer;
bufferSizeInBytes : in Natural) return fontImpl.texture.view
is
begin
return new fontImpl.texture.item' (to_FontImpl_texture (ftFont,
pBufferBytes,
bufferSizeInBytes));
end new_FontImpl_texture;
procedure free_Textures (Self : in out Item)
is
use texture_name_Vectors,
GL.lean;
Cursor : texture_name_Vectors.Cursor := Self.textureIDList.First;
the_Name : aliased openGL.Texture.texture_Name;
begin
Tasks.check;
while has_Element (Cursor)
loop
the_Name := Element (Cursor);
glDeleteTextures (1, the_Name'Access);
next (Cursor);
end loop;
end free_Textures;
overriding
procedure destruct (Self : in out Item)
is
use type ada.Containers.Count_type;
begin
destruct (FontImpl.item (Self)); -- Destroy base class.
if Self.textureIDList.Length > 0
then
Self.free_Textures;
end if;
end destruct;
--------------
-- Attributes
--
overriding
function FaceSize (Self : access Item; Size : in Natural;
x_Res, y_Res : in Natural := 72) return Boolean
is
type access_FontImpl is access all FontImpl.item;
Success : Boolean;
begin
if not Self.textureIDList.is_empty
then
Self.free_Textures;
Self.textureIDList.clear;
Self.numGlyphs := Self.Face.GlyphCount;
Self.remGlyphs := Self.numGlyphs;
end if;
Success := access_FontImpl (Self).FaceSize (Size, x_Res, y_Res);
return Success;
end FaceSize;
function Render (Self : access Item; Text : in String;
Length : in Integer;
Position : in Vector_3;
Spacing : in Vector_3;
Mode : in renderMode) return Vector_3
is
use GL,
GL.Binding;
function to_Integer is new ada.unchecked_Conversion (fontImpl.RenderMode, Integer);
Tmp : Vector_3;
begin
Tasks.check;
glEnable (GL_BLEND);
glBlendFunc (GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
glEnable (GL_TEXTURE_2D);
GlyphImpl.texture.ResetActiveTexture;
Tmp := FontImpl.item (Self.all).Render (Text, Length,
Position, Spacing,
to_Integer (Mode));
return Tmp;
end Render;
function MakeGlyphImpl (Self : access Item; ftGlyph : in freetype_c.FT_GlyphSlot.item) return access Glyph.item'Class
is
tempGlyph : Glyph.Container.Glyph_view;
begin
Self.glyphHeight := Integer (Self.charSize.Height + 0.5);
Self.glyphWidth := Integer (Self.charSize.Width + 0.5);
if Self.glyphHeight < 1 then Self.glyphHeight := 1; end if;
if Self.glyphWidth < 1 then Self.glyphWidth := 1; end if;
if Self.textureIDList.is_empty
then
Self.textureIDList.append (Self.CreateTexture);
Self.xOffset := Self.Padding;
Self.yOffset := Self.Padding;
end if;
if Self.xOffset > (Integer (Self.textureWidth) - Self.glyphWidth)
then
Self.xOffset := Self.Padding;
Self.yOffset := Self.yOffset + Self.glyphHeight;
if Self.yOffset > (Integer (Self.textureHeight) - Self.glyphHeight)
then
Self.textureIDList.append (Self.CreateTexture);
Self.yOffset := Self.Padding;
end if;
end if;
tempGlyph := openGL.Glyph.texture.new_Glyph (ftGlyph,
Self.textureIDList.last_Element,
Self.xOffset,
Self.yOffset,
Integer (Self.textureWidth),
Integer (Self.textureHeight)).all'Access;
Self.xOffset := Self.xOffset + Integer ( tempGlyph.BBox.Box.Upper (1)
- tempGlyph.BBox.Box.Lower (1)
+ Real (Self.Padding)
+ 0.5);
Self.remGlyphs := Self.remGlyphs - 1;
return tempGlyph;
end MakeGlyphImpl;
function Quad (Self : access Item; for_Character : in Character) return GlyphImpl.texture.Quad_t
is
use freetype.charMap;
Success : constant Boolean := Self.CheckGlyph (to_characterCode (for_Character)) with unreferenced;
the_Glyph : constant Glyph.Container.Glyph_view := Self.glyphList.Glyph (to_characterCode (for_Character));
begin
return Glyph.texture.item (the_Glyph.all).Quad ([0.0, 0.0, 0.0]);
end Quad;
procedure CalculateTextureSize (Self : in out Item)
is
use openGL.Texture,
GL,
GL.Binding;
use type GL.GLsizei;
H : Integer;
begin
Tasks.check;
if Self.maximumGLTextureSize = 0
then
Self.maximumGLTextureSize := 1024;
glGetIntegerv (GL_MAX_TEXTURE_SIZE, Self.maximumGLTextureSize'Access);
pragma assert (Self.maximumGLTextureSize /= 0); -- If you hit this then you have an invalid openGL context.
end if;
begin
Self.textureWidth := Power_of_2_Ceiling ( (Self.remGlyphs * Self.glyphWidth)
+ (Self.Padding * 2));
exception
when constraint_Error =>
Self.textureWidth := Self.maximumGLTextureSize;
end;
if Self.textureWidth > Self.maximumGLTextureSize
then Self.textureWidth := Self.maximumGLTextureSize;
end if;
H := Integer ( Real (Integer (Self.textureWidth) - (Self.Padding * 2))
/ Real (Self.glyphWidth)
+ 0.5);
Self.textureHeight := Power_of_2_Ceiling ( ((Self.numGlyphs / H) + 1)
* Self.glyphHeight);
if Self.textureHeight > Self.maximumGLTextureSize
then Self.textureHeight := Self.maximumGLTextureSize;
end if;
end CalculateTextureSize;
function CreateTexture (Self : access Item) return openGL.Texture.texture_Name
is
use openGL.Palette,
GL,
GL.Binding;
begin
Tasks.check;
Self.CalculateTextureSize;
declare
use GL.Pointers;
the_Image : Image (1 .. Index_t (self.textureHeight),
1 .. Index_t (Self.textureWidth)) := (others => [others => +Black]);
textID : aliased openGL.Texture.texture_Name;
begin
glGenTextures (1, textID'Access);
glBindTexture (GL_TEXTURE_2D, textID);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
glTexParameteri (GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR);
glTexImage2D (GL_TEXTURE_2D,
0, GL_ALPHA,
Self.textureWidth, Self.textureHeight,
0, GL_ALPHA,
GL_UNSIGNED_BYTE,
to_GLvoid_access (the_Image (1, 1).Red'Access));
return textID;
end;
end CreateTexture;
function gl_Texture (Self : in Item) return openGL.Texture.texture_Name
is
begin
return Self.textureIDList.last_Element;
end gl_Texture;
end openGL.FontImpl.Texture;

128
3-mid/opengl/source/lean/text/private/opengl-fontimpl-texture.ads Normal file
View File

@@ -0,0 +1,128 @@
with
openGL.Texture,
openGL.GlyphImpl.texture,
freetype_c.FT_GlyphSlot,
ada.Containers.Vectors;
private
with
GL;
package openGL.FontImpl.texture
--
-- Implements a texture font.
--
is
type Item is new FontImpl.item with private;
type View is access all Item'Class;
---------
-- Forge
--
function to_FontImpl_texture (ftFont : access openGL.Font.item'Class;
fontFilePath : in String) return fontImpl.texture.item;
function new_FontImpl_texture (ftFont : access openGL.Font.item'Class;
fontFilePath : in String) return access fontImpl.texture.item'Class;
function to_FontImpl_texture (ftFont : access openGL.Font.item'Class;
pBufferBytes : in unsigned_char_Pointer;
bufferSizeInBytes : in Natural) return fontImpl.texture.item;
function new_FontImpl_texture (ftFont : access openGL.Font.item'Class;
pBufferBytes : in unsigned_char_Pointer;
bufferSizeInBytes : in Natural) return fontImpl.texture.view;
overriding
procedure destruct (Self : in out Item);
--------------
-- Attributes
--
overriding
function FaceSize (Self : access Item; Size : in Natural;
x_Res,
y_Res : in Natural := 72) return Boolean;
--
-- Set the char size for the current face.
--
-- Returns True if size was set correctly.
function render (Self : access Item; Text : in String;
Length : in Integer;
Position : in Vector_3;
Spacing : in Vector_3;
Mode : in renderMode) return Vector_3;
function Quad (Self : access Item; for_Character : in Character) return openGL.GlyphImpl.Texture.Quad_t;
---------------
--- 'Protected'
--
function MakeGlyphImpl (Self : access Item; ftGlyph : in freetype_c.FT_GlyphSlot.item) return access Glyph.item'Class;
--
-- Create an FTTextureGlyph object for the base class.
function gl_Texture (Self : in Item) return openGL.Texture.texture_Name;
private
use type openGL.Texture.texture_Name;
package texture_name_Vectors is new ada.Containers.Vectors (Positive, openGL.Texture.texture_Name);
type Item is new FontImpl.item with
record
maximumGLTextureSize : aliased gl.GLsizei := 0; -- The max texture dimension on this openGL implemetation.
textureWidth : gl.GLsizei := 0; -- The min texture width required to hold the glyphs.
textureHeight : gl.GLsizei := 0; -- The min texture height required to hold the glyphs.
textureIDList : texture_name_Vectors.Vector;
-- An array of texture ids.
glyphHeight : Integer := 0; -- The max height for glyphs in the current font.
glyphWidth : Integer := 0; -- The max width for glyphs in the current font.
Padding : Natural := 3; -- A value to be added to the height and width to ensure that
numGlyphs : Natural; -- glyphs don't overlap in the texture.
remGlyphs : Natural;
xOffset, yOffset : Integer := 0;
end record;
procedure CalculateTextureSize (Self : in out Item);
--
-- Get the size of a block of memory required to layout the glyphs
--
-- Calculates a width and height based on the glyph sizes and the
-- number of glyphs. It over estimates.
function CreateTexture (Self : access Item) return openGL.Texture.texture_Name;
--
-- Creates a 'blank' openGL texture object.
--
-- The format is GL_ALPHA and the params are
-- * GL_TEXTURE_WRAP_S = GL_CLAMP
-- * GL_TEXTURE_WRAP_T = GL_CLAMP
-- * GL_TEXTURE_MAG_FILTER = GL_LINEAR
-- * GL_TEXTURE_MIN_FILTER = GL_LINEAR
-- * Note that mipmapping is NOT used
procedure free_Textures (Self : in out Item);
end openGL.FontImpl.Texture;

517
3-mid/opengl/source/lean/text/private/opengl-fontimpl.adb Normal file
View File

@@ -0,0 +1,517 @@
with
openGL.Font,
freetype_c.Binding,
freetype_c.FT_GlyphSlot,
freetype_c.Pointers,
freetype_c.FT_Size_Metrics,
ada.unchecked_Deallocation;
package body openGL.FontImpl
is
use freetype_c.Pointers;
-----------
-- Utility
--
procedure deallocate is new ada.unchecked_Deallocation (Glyph.Container.item'Class,
glyph_Container_view);
---------
-- Forge
--
procedure define (Self : access Item; ftFont : access Font.item'Class;
fontFilePath : in String)
is
use freetype.Face,
openGL.Glyph.container,
Freetype_C,
Freetype_C.Binding;
use type FT_Error;
begin
Self.Face := Forge.to_Face (fontFilePath, precomputeKerning => True);
Self.load_Flags := FT_Int (FT_LOAD_DEFAULT_flag);
Self.Intf := ftFont;
Self.Err := Self.face.Error;
if Self.Err = 0
then
Self.glyphList := new Glyph.Container.item' (to_glyph_Container (Self.Face'Access));
else
raise Error with "Unable to create face for font '" & fontFilePath & "'.";
end if;
end define;
procedure define (Self : access Item; ftFont : access Font.item'Class;
pBufferBytes : access C.unsigned_char;
bufferSizeInBytes : in Integer)
is
use freetype.Face,
openGL.Glyph.container,
Freetype_C,
Freetype_c.Binding;
use type FT_Error;
begin
Self.Face := Forge.to_Face (pBufferBytes, bufferSizeInBytes, precomputeKerning => True);
Self.load_Flags := FT_Int (FT_LOAD_DEFAULT_flag);
Self.Intf := ftFont;
Self.Err := Self.face.Error;
if Self.Err = 0
then
Self.glyphList := new Glyph.Container.item' (to_glyph_Container (Self.Face'Access));
end if;
end define;
procedure destruct (Self : in out Item)
is
begin
if Self.glyphList /= null
then
Self.glyphList.destruct;
deallocate (Self.glyphList);
end if;
end destruct;
--------------
-- Attributes
--
function Err (Self : in Item) return freetype_c.FT_Error
is
begin
return Self.Err;
end Err;
function attach (Self : access Item; fontFilePath : in String) return Boolean
is
begin
if not Self.Face.attach (fontFilePath)
then
Self.Err := Self.Face.Error;
return False;
end if;
Self.Err := 0;
return True;
end attach;
function attach (Self : access Item; pBufferBytes : access C.unsigned_char;
bufferSizeInBytes : in Integer) return Boolean
is
begin
if not Self.Face.attach (pBufferBytes, bufferSizeInBytes)
then
Self.Err := Self.Face.Error;
return False;
end if;
Self.Err := 0;
return True;
end attach;
procedure GlyphLoadFlags (Self : in out Item; Flags : in freetype_c.FT_Int)
is
begin
Self.load_Flags := Flags;
end GlyphLoadFlags;
function CharMap (Self : access Item; Encoding : in freetype_c.FT_Encoding) return Boolean
is
Result : constant Boolean := Self.glyphList.CharMap (Encoding);
begin
Self.Err := Self.glyphList.Error;
return Result;
end CharMap;
function CharMapCount (Self : in Item) return Natural
is
begin
return Self.Face.CharMapCount;
end CharMapCount;
function CharMapList (Self : access Item) return freetype.face.FT_Encodings_view
is
begin
return Self.Face.CharMapList;
end CharMapList;
function Ascender (Self : in Item) return Real
is
begin
return Self.charSize.Ascender;
end Ascender;
function Descender (Self : in Item) return Real
is
begin
return Self.charSize.Descender;
end Descender;
function LineHeight (Self : in Item) return Real
is
begin
return Self.charSize.Height;
end LineHeight;
function FaceSize (Self : access Item; Size : in Natural;
x_Res, y_Res : in Natural) return Boolean
is
use Glyph.Container;
use type freetype_c.FT_Error;
begin
if Self.glyphList /= null
then
Self.glyphList.destruct;
deallocate (Self.glyphList);
end if;
Self.charSize := Self.Face.Size (Size, x_Res, y_Res);
Self.Err := Self.Face.Error;
if Self.Err /= 0 then
return False;
end if;
Self.glyphList := new Glyph.Container.item' (to_glyph_Container (Self.Face'unchecked_Access));
return True;
end FaceSize;
function FaceSize (Self : in Item) return Natural
is
begin
return Self.charSize.CharSize;
end FaceSize;
procedure Depth (Self : in out Item; Depth : in Real)
is
begin
null; -- NB: This is 'null' in FTGL also.
end Depth;
procedure Outset (Self : in out Item; Outset : in Real)
is
begin
null; -- NB: This is 'null' in FTGL also.
end Outset;
procedure Outset (Self : in out Item; Front : in Real;
Back : in Real)
is
begin
null; -- NB: This is 'null' in FTGL also.
end Outset;
function CheckGlyph (Self : access Item; Character : in freetype.charmap.CharacterCode) return Boolean
is
use type Glyph.Container.Glyph_view,
freetype_c.FT_Error;
glyphIndex : freetype.charMap.glyphIndex;
ftSlot : freetype_c.FT_GlyphSlot.item;
tempGlyph : glyph.Container.Glyph_view;
begin
if Self.glyphList.Glyph (Character) /= null
then
return True;
end if;
glyphIndex := freetype.charMap.glyphIndex (Self.glyphList.FontIndex (Character));
ftSlot := Self.Face.Glyph (glyphIndex, Self.load_flags);
if ftSlot = null
then
Self.Err := Self.Face.Error;
return False;
end if;
if Self.Intf = null
then
raise Error with "CheckGlyph ~ Self.Intf = null";
end if;
tempGlyph := Self.Intf.MakeGlyph (ftSlot);
if tempGlyph = null
then
if Self.Err = 0 then
Self.Err := 16#13#;
end if;
return False;
end if;
if Self.glyphList.Glyph (character) = null
then
Self.glyphList.add (tempGlyph, Character);
end if;
return True;
end CheckGlyph;
function BBox (Self : access Item; Text : in String;
Length : in Integer;
Position : in Vector_3;
Spacing : in Vector_3) return Bounds
is
pragma unreferenced (Length);
use freetype.charMap,
Geometry_3d;
Pos : Vector_3 := Position;
totalBBox : Bounds := null_Bounds;
begin
if Text = ""
then
totalBBox.Box := totalBBox.Box or Pos;
set_Ball_from_Box (totalBBox);
return totalBBox;
end if;
-- Only compute the bounds if string is non-empty.
--
if Text'Length > 0 -- TODO: Rid this useless check.
then
-- For multibyte, we can't rely on sizeof (T) == character
--
declare
use type freetype.charMap.characterCode;
thisChar : Character;
nextChar : Character;
begin
-- Expand totalBox by each glyph in string
--
for i in Text'Range
loop
thisChar := Text (i);
if i /= Text'Last
then nextChar := Text (i + 1);
else nextChar := ' ';
end if;
if Self.CheckGlyph (to_characterCode (thisChar))
then
declare
tempBBox : Bounds := Self.glyphList.BBox (to_characterCode (thisChar));
begin
tempBBox.Box := tempBBox.Box + Pos;
totalBBox.Box := totalBBox.Box or tempBBox.Box;
Pos := Pos + spacing;
Pos := Pos + Vector_3' (Self.glyphList.Advance (to_characterCode (thisChar),
to_characterCode (nextChar)),
0.0,
0.0);
end;
end if;
end loop;
end;
end if;
set_Ball_from_Box (totalBBox);
return totalBBox;
end BBox;
function kern_Advance (Self : in Item; From, To : in Character) return Real
is
use freetype.charMap;
begin
return Self.glyphList.Advance (to_characterCode (From),
to_characterCode (To));
end kern_Advance;
function x_PPEM (Self : in Item) return Real
is
use freetype_c.Binding;
ft_Size : constant FT_SizeRec_Pointer := FT_Face_Get_Size (Self.Face.freetype_Face);
ft_Metrics : constant freetype_c.FT_Size_Metrics.item := FT_Size_Get_Metrics (ft_Size);
begin
return Real (ft_Metrics.x_PPEM);
end x_PPEM;
function x_Scale (Self : in Item) return Real
is
use freetype_c.Binding;
ft_Size : constant FT_SizeRec_Pointer := FT_Face_Get_Size (Self.Face.freetype_Face);
ft_Metrics : constant freetype_c.FT_Size_Metrics.item := FT_Size_Get_Metrics (ft_Size);
begin
return Real (ft_Metrics.x_Scale);
end x_Scale;
function y_Scale (Self : in Item) return Real
is
use freetype_c.Binding;
ft_Size : constant FT_SizeRec_Pointer := FT_Face_Get_Size (Self.Face.freetype_Face);
ft_Metrics : constant freetype_c.FT_Size_Metrics.item := FT_Size_Get_Metrics (ft_Size);
begin
return Real (ft_Metrics.y_Scale);
end y_Scale;
function Advance (Self : access Item; Text : in String;
Length : in Integer;
Spacing : in Vector_3) return Real
is
pragma unreferenced (Length);
Advance : Real := 0.0;
ustr : Integer := 1;
i : Integer := 0;
begin
while i < Text'Length
loop
declare
use freetype.charMap;
use type freetype.charmap.characterCode;
thisChar : constant Character := Text (ustr);
nextChar : Character;
begin
ustr := ustr + 1;
if ustr <= Text'Length
then nextChar := Text (ustr);
else nextChar := Character'Val (0);
end if;
if nextChar /= Character'Val (0)
and then Self.CheckGlyph (to_characterCode (thisChar))
then
Advance := Advance + Self.glyphList.Advance (to_characterCode (thisChar),
to_characterCode (nextChar));
end if;
if nextChar /= Character'Val (0)
then
Advance := Advance + Spacing (1);
end if;
i := i + 1;
end;
end loop;
return advance;
end Advance;
--------------
--- Operations
--
function render (Self : access Item; Text : in String;
Length : in Integer;
Position : in Vector_3;
Spacing : in Vector_3;
renderMode : in Integer) return Vector_3
is
use type freetype.charMap.characterCode;
ustr : Integer := 1;
i : Integer := 0;
Pos : Vector_3 := Position;
begin
while (Length < 0 and then i < Text'Length)
or else (Length >= 0 and then i < Length)
loop
declare
use freetype.charMap;
thisChar : constant Character := Text (ustr);
nextChar : Character;
begin
ustr := ustr + 1;
if ustr <= Text'Length
then nextChar := Text (ustr);
else nextChar := Character'Val (0);
end if;
if nextChar /= Character'Val (0)
and then Self.CheckGlyph (to_characterCode (thisChar))
then
Pos := Pos + Self.glyphList.render (to_characterCode (thisChar),
to_characterCode (nextChar),
Position,
renderMode);
end if;
if nextChar /= Character'Val (0)
then
Pos := Pos + Spacing;
end if;
i := i + 1;
end;
end loop;
return Pos;
end Render;
end openGL.FontImpl;

153
3-mid/opengl/source/lean/text/private/opengl-fontimpl.ads Normal file
View File

@@ -0,0 +1,153 @@
with
openGL.Glyph.Container,
freetype.Face,
freetype.charMap,
Freetype_C,
interfaces.C.Pointers;
limited
with
openGL.Font;
private
with
freetype.face_Size;
package openGL.FontImpl
--
-- Implements an openGL font.
--
is
type Item is tagged limited private;
type View is access all Item'Class;
---------
-- Types
--
type RenderMode is (RENDER_FRONT, RENDER_BACK, RENDER_SIDE, RENDER_ALL);
for RenderMode use (RENDER_FRONT => 16#0001#,
RENDER_BACK => 16#0002#,
RENDER_SIDE => 16#0004#,
RENDER_ALL => 16#ffff#);
type TextAlignment is (ALIGN_LEFT, ALIGN_CENTER, ALIGN_RIGHT, ALIGN_JUSTIFY);
for TextAlignment use (ALIGN_LEFT => 0,
ALIGN_CENTER => 1,
ALIGN_RIGHT => 2,
ALIGN_JUSTIFY => 3);
-- unsigned_char_Pointer
--
use Interfaces;
type unsigned_char_array is array (C.size_t range <>) of aliased C.unsigned_char;
package unsigned_char_Pointers is new C.Pointers (Index => C.size_t,
Element => C.unsigned_char,
Element_array => unsigned_char_array,
default_Terminator => 0);
subtype unsigned_char_Pointer is unsigned_char_Pointers.Pointer;
---------
-- Forge
--
procedure define (Self : access Item; ftFont : access Font.item'Class;
fontFilePath : in String);
procedure define (Self : access Item; ftFont : access Font.item'Class;
pBufferBytes : access C.unsigned_char;
bufferSizeInBytes : in Integer);
procedure destruct (Self : in out Item);
---------------
-- 'Protected' ~ For derived class use only.
--
function Err (Self : in Item) return freetype_c.FT_Error;
function attach (Self : access Item; fontFilePath : in String) return Boolean;
function attach (Self : access Item; pBufferBytes : access C.unsigned_char;
bufferSizeInBytes : in Integer) return Boolean;
function FaceSize (Self : access Item; Size : in Natural;
x_Res,
y_Res : in Natural) return Boolean;
function FaceSize (Self : in Item) return Natural;
procedure Depth (Self : in out Item; Depth : in Real);
procedure Outset (Self : in out Item; Outset : in Real);
procedure Outset (Self : in out Item; Front : in Real;
Back : in Real);
procedure GlyphLoadFlags (Self : in out Item; Flags : in freetype_c.FT_Int);
function CharMap (Self : access Item; Encoding : in freetype_c.FT_Encoding) return Boolean;
function CharMapCount (Self : in Item) return Natural;
function CharMapList (Self : access Item) return freetype.face.FT_Encodings_view;
function Ascender (Self : in Item) return Real;
function Descender (Self : in Item) return Real;
function LineHeight (Self : in Item) return Real;
function BBox (Self : access Item; Text : in String;
Length : in Integer;
Position : in Vector_3;
Spacing : in Vector_3) return Bounds;
function Advance (Self : access Item; Text : in String;
Length : in Integer;
Spacing : in Vector_3) return Real;
function kern_Advance (Self : in Item; From, To : in Character) return Real;
function x_PPEM (Self : in Item) return Real;
function x_Scale (Self : in Item) return Real;
function y_Scale (Self : in Item) return Real;
function render (Self : access Item; Text : in String;
Length : in Integer;
Position : in Vector_3;
Spacing : in Vector_3;
renderMode : in Integer) return Vector_3;
private
type glyph_Container_view is access all openGL.Glyph.Container.item'Class;
type Item is tagged limited
record
Face : aliased freetype.Face.item; -- Current face object.
charSize : freetype.face_Size.item; -- Current size object.
load_Flags : freetype_c.FT_Int; -- The default glyph loading flags.
Err : freetype_c.FT_Error; -- Current error code. Zero means no error.
Intf : access Font.item'Class; -- A link back to the interface of which we implement.
glyphList : Glyph_Container_view; -- An object that holds a list of glyphs
Pen : Vector_3; -- Current pen or cursor position;
end record;
function CheckGlyph (Self : access Item; Character : in freetype.charmap.CharacterCode) return Boolean;
--
-- Check that the glyph at <code>chr</code> exist. If not load it.
--
-- Character: The character index.
--
-- Returns true if the glyph can be created.
end openGL.FontImpl;

178
3-mid/opengl/source/lean/text/private/opengl-glyphimpl-texture.adb Normal file
View File

@@ -0,0 +1,178 @@
with
openGL.Tasks,
openGL.Errors,
GL.Binding,
GL.Pointers,
freetype_c.Binding,
freetype_c.FT_Bitmap,
interfaces.C;
package body openGL.GlyphImpl.texture
is
-----------
-- Globals
--
activeTextureID : openGL.texture.texture_Name; -- TODO: Check C source for how this is used.
pragma Unreferenced (activeTextureID);
--
-- The texture index of the currently active texture
--
-- We keep track of the currently active texture to try to reduce the
-- number of texture bind operations.
procedure ResetActiveTexture
is
begin
activeTextureID := 0;
end ResetActiveTexture;
---------
-- Forge
--
function new_GlyphImpl (glyth_Slot : in freetype_c.FT_GlyphSlot.item;
texture_Id : in openGL.Texture.texture_Name;
xOffset, yOffset : in Integer;
Width, Height : in Integer) return GlyphImpl.texture.view
is
use freetype_C,
freetype_C.Binding,
GL,
GL.Binding;
use type interfaces.C.unsigned,
GLint;
Self : constant GlyphImpl.texture.view := new GlyphImpl.texture.item;
begin
Tasks.check;
Self.define (glyth_Slot);
Self.destWidth := 0;
Self.destHeight := 0;
Self.glTextureID := texture_Id;
Self.Err := FT_Render_Glyph (glyth_Slot,
FT_RENDER_MODE_NORMAL);
if Self.Err /= no_Error
then
raise openGL.Error with "FT_Render_Glyph failed with error code: " & Self.Err'Image;
end if;
if FT_GlyphSlot_Get_Format (glyth_Slot) /= get_FT_GLYPH_FORMAT_BITMAP
then
raise openGL.Error with "Glyph is not a bitmap format.";
end if;
declare
use GL.Pointers;
Bitmap : constant freetype_C.FT_Bitmap.item := FT_GlyphSlot_Get_Bitmap (glyth_Slot);
begin
Self.destWidth := Bitmap.Width;
Self.destHeight := Bitmap.Rows;
if Self.destWidth /= 0
and then Self.destHeight /= 0
then
glPixelStorei (GL_UNPACK_ALIGNMENT, 1);
glBindTexture (GL_TEXTURE_2D, Self.glTextureID);
Errors.log;
glTexSubImage2D (GL_TEXTURE_2D, 0,
GLint (xOffset), GLint (yOffset),
Self.destWidth, Self.destHeight,
GL_ALPHA,
GL_UNSIGNED_BYTE,
to_GLvoid_access (Bitmap.Buffer));
Errors.log;
end if;
end;
-- 0
-- +----+
-- | |
-- | |
-- | |
-- +----+
-- 1
Self.UV (1).S := Real (xOffset) / Real (Width);
Self.UV (1).T := Real (yOffset) / Real (Height);
Self.UV (2).S := Real (GLint (xOffset) + Self.destWidth) / Real (Width);
Self.UV (2).T := Real (GLint (yOffset) + Self.destHeight) / Real (Height);
Self.Corner := [Real (FT_GlyphSlot_Get_bitmap_left (glyth_Slot)),
Real (FT_GlyphSlot_Get_bitmap_top (glyth_Slot)),
0.0];
declare
use openGL.Primitive;
the_Indices : constant openGL.Indices := [1, 2, 3, 4];
begin
Self.Primitive := Primitive.indexed.new_Primitive (triangle_Fan, the_Indices);
end;
return Self;
end new_GlyphImpl;
--------------
-- Attributes
--
function Quad (Self : in Item; Pen : in Vector_3) return Quad_t
is
dx : constant Real := Real'Floor (Pen (1) + Self.Corner (1));
dy : constant Real := Real'Floor (Pen (2) + Self.Corner (2));
the_Quad : aliased constant Quad_t := (NW => (Site => [dx,
dy,
0.0],
Coords => [S => Self.UV (1).S,
T => Self.UV (1).T]),
SW => (Site => [dx,
dy - Real (Self.destHeight),
0.0],
Coords => [S => Self.UV (1).S,
T => Self.UV (2).T]),
SE => (Site => [dx + Real (Self.destWidth),
dy - Real (Self.destHeight),
0.0],
Coords => [S => Self.UV (2).S,
T => Self.UV (2).T]),
NE => (Site => [dx + Real (Self.destWidth),
dy,
0.0],
Coords => [S => Self.UV (2).S,
T => Self.UV (1).T]),
Advance => Self.Advance);
begin
return the_Quad;
end Quad;
--------------
-- Operations
--
function renderImpl (Self : in Item; Pen : in Vector_3;
renderMode : in Integer) return Vector_3
is
pragma unreferenced (renderMode);
begin
return Self.Advance;
end renderImpl;
end openGL.GlyphImpl.Texture;

99
3-mid/opengl/source/lean/text/private/opengl-glyphimpl-texture.ads Normal file
View File

@@ -0,0 +1,99 @@
with
openGL.Texture,
freetype_c.FT_GlyphSlot;
private
with
openGL.Geometry.lit_textured,
openGL.Primitive.indexed,
GL;
package openGL.GlyphImpl.texture
--
-- Implements a texture-based glyph.
--
is
type Item is new GlyphImpl.item with private;
type View is access all Item'Class;
---------
-- Types
--
type Vertex is
record
Site : Vector_3;
Coords : Coordinate_2D;
end record;
type Quad_t is
record
NW, NE,
SW, SE : Vertex;
Advance : Vector_3;
end record;
---------
-- Forge
--
function new_GlyphImpl (glyth_Slot : in freetype_c.FT_GlyphSlot.item;
texture_Id : in openGL.Texture.texture_Name;
xOffset, yOffset : in Integer;
Width, Height : in Integer) return GlyphImpl.texture.view;
--
-- glyth_Slot: The Freetype glyph to be processed.
-- texture_Id: The Id of the texture that this glyph will be drawn in.
-- xOffset, yOffset: The x any y offset into the parent texture to draw this glyph.
-- Width, Height: The width and height (number of rows) of the parent texture.
--------------
-- Attributes
--
function Quad (Self : in Item; Pen : in Vector_3) return Quad_t;
--------------
-- Operations
--
function renderImpl (Self : in Item; Pen : in Vector_3;
renderMode : in Integer) return Vector_3;
--
-- Pen: The current pen position.
-- renderMode: Render mode to display.
--
-- Returns the advance distance for this glyph.
-------------
-- Protected - for derived class use only.
--
procedure ResetActiveTexture;
--
-- Reset the currently active texture to zero to get into a known
-- state before drawing a string. This is to get around possible threading issues.
private
type Item is new GlyphImpl.item with
record
destWidth, -- The width and height of the glyph 'image'.
destHeight : GL.GLint;
Corner : Vector_3; -- Vector from the pen site to the top left of the pixmap.
UV : Coordinates_2D (1 .. 2); -- The texture co-ords of this glyph within the texture.
glTextureID : openGL.texture.texture_Name; -- The texture index that this glyph is contained in.
Geometry : access Geometry.lit_textured.item;
Primitive : openGL.Primitive.indexed.view;
end record;
end openGL.GlyphImpl.texture;

94
3-mid/opengl/source/lean/text/private/opengl-glyphimpl.adb Normal file
View File

@@ -0,0 +1,94 @@
with
freetype_c.Binding,
freetype_c.FT_BBox,
freetype_c.FT_Vector;
package body openGL.GlyphImpl
is
-----------
-- Utility
--
function Bounds_of (glyth_Slot : in freetype_c.FT_GlyphSlot.item) return Bounds
is
use freetype_c.Binding;
bBox : aliased freetype_c.FT_BBox.item;
the_Bounds : Bounds;
begin
FT_Outline_Get_CBox (FT_GlyphSlot_Get_Outline (glyth_Slot).all'unchecked_Access,
bBox'unchecked_Access);
the_Bounds := (Ball => <>,
Box => (Lower => [1 => Real (bbox.xMin) / 64.0,
2 => Real (bbox.yMin) / 64.0,
3 => 0.0],
Upper => [1 => Real (bbox.xMax) / 64.0,
2 => Real (bbox.yMax) / 64.0,
3 => 0.0]));
set_Ball_from_Box (the_Bounds);
return the_Bounds;
end Bounds_of;
---------
-- Forge
--
procedure define (Self : in out Item; glyth_Slot : in freetype_c.FT_GlyphSlot.item)
is
use type freetype_c.FT_GlyphSlot.item;
begin
Self.Err := no_Error;
if glyth_Slot /= null
then
Self.bBox := Bounds_of (glyth_Slot);
declare
use freetype_c.Binding;
the_Advance : constant freetype_c.FT_Vector.item := FT_GlyphSlot_Get_Advance (glyth_Slot);
begin
Self.Advance := [Real (the_Advance.x) / 64.0,
Real (the_Advance.y) / 64.0,
0.0];
end;
end if;
end define;
procedure destruct (Self : in out Item)
is
begin
null;
end destruct;
--------------
-- Attributes
--
function Advance (Self : in Item) return Real
is
begin
return Self.Advance (1);
end Advance;
function BBox (Self : in Item) return Bounds
is
begin
return Self.bBox;
end BBox;
function Error (Self : in Item) return error_Kind
is
begin
return Self.Err;
end Error;
end openGL.GlyphImpl;

51
3-mid/opengl/source/lean/text/private/opengl-glyphimpl.ads Normal file
View File

@@ -0,0 +1,51 @@
with
freetype_C.FT_GlyphSlot;
package openGL.GlyphImpl
--
-- Implements an openGL glyph.
--
is
type Item is tagged private;
type View is access all Item'Class;
---------
-- Types
--
subtype error_Kind is freetype_C.FT_Error;
no_Error : constant error_Kind;
---------
-- Forge
--
procedure define (Self : in out Item; glyth_Slot : in freetype_c.FT_GlyphSlot.item);
--
-- glyth_Slot: The Freetype glyph to be processed.
--------------
-- Attributes
--
function Advance (Self : in Item) return Real; -- The advance distance for this glyph.
function BBox (Self : in Item) return Bounds; -- Return the bounding box for this glyph.
function Error (Self : in Item) return error_Kind; -- Return the current error code.
private
type Item is tagged
record
Advance : Vector_3;
bBox : Bounds;
Err : error_Kind;
end record;
procedure destruct (Self : in out Item);
no_Error : constant error_Kind := 0;
end openGL.GlyphImpl;