1. -- 
  2. -- Copyright (c) 2012 Kevin Wellwood 
  3. -- All rights reserved. 
  4. -- 
  5. -- This source code is distributed under the Modified BSD License. For terms and 
  6. -- conditions, see license.txt. 
  7. -- 
  8.  
  9. with Allegro.Color;                     use Allegro.Color; 
  10. with Objects;                           use Objects; 
  11.  
  12. private with Allegro.Fonts; 
  13. private with Resources; 
  14.  
  15. package Fonts is 
  16.  
  17.     -- A Font represents a specific font of a specific size. Two Font instances 
  18.     -- are required to work with the same font in two different font sizes. 
  19.     type Font is abstract new Limited_Object with private; 
  20.     type A_Font is access all Font'Class; 
  21.  
  22.     -- Loads a font from disk at a specific size. The file format will be 
  23.     -- automatically detected; it must be a supported font format. An exception 
  24.     -- will be raised on error. 
  25.     function Load_Font( filename : String; size : Positive ) return A_Font; 
  26.     pragma Precondition( filename'Length > 0 ); 
  27.  
  28.     -- Renders a string onto the drawing target. 
  29.     procedure Draw_String( this  : not null access Font'Class; 
  30.                            str   : String; 
  31.                            x, y  : Float; 
  32.                            color : Allegro_Color ); 
  33.  
  34.     -- Returns the height in pixels of a string rendered with the font. 
  35.     function Text_Height( this : not null access Font'Class ) return Positive; 
  36.  
  37.     -- Returns the length in pixels of a string rendered with the font. 
  38.     function Text_Length( this : not null access Font'Class; 
  39.                           str  : String ) return Natural; 
  40.  
  41.     -- Deletes a font. 
  42.     procedure Delete( this : in out A_Font ); 
  43.     pragma Postcondition( this = null ); 
  44.  
  45.     -- Raised by Initialize on error, or on failure to load a font. Check the 
  46.     -- exception's message for details. 
  47.     FONT_EXCEPTION : exception; 
  48.  
  49. private 
  50.  
  51.     use Allegro.Fonts; 
  52.     use Resources; 
  53.  
  54.     type Font is new Limited_Object with 
  55.         record 
  56.             ptr  : A_Allegro_Font := null; 
  57.             size : Positive := 1; 
  58.             res  : A_Resource_File := null;       -- backs the Allegro file 
  59.                                                   -- that backs the Allegro font 
  60.  
  61.             -- the drawn flag is a workaround to ensure that the font is 
  62.             -- loaded on the drawing thread being being drawn. if the font has 
  63.             -- not been drawn yet, it will be reloaded by the Textout procedure 
  64.             -- immediately before drawing the first time. 
  65.             drawn : Boolean := False; 
  66.         end record; 
  67.  
  68.     -- Raises an exception on error loading 'filename'. 
  69.     procedure Construct( this     : access Font; 
  70.                          filename : String; 
  71.                          size     : Positive ); 
  72.  
  73.     procedure Delete( this : in out Font ); 
  74.  
  75. end Fonts;