1. with Allegro.Bitmaps;                   use Allegro.Bitmaps; 
  2. with Allegro.Truecolor;                 use Allegro.Truecolor; 
  3. with Drawing_Contexts;                  use Drawing_Contexts; 
  4. with Font_API;                          use Font_API; 
  5. with Objects;                           use Objects; 
  6. with Scaling;                           use Scaling; 
  7.  
  8. private with Ada.Containers.Indefinite_Ordered_Maps; 
  9.  
  10. package Themes is 
  11.  
  12.     -- enumeration for text/icon alignment 
  13.     type Align_Type is ( Align_Left, Align_Center, Align_Right ); 
  14.  
  15.     -- enumeration of border styles 
  16.     type Border_Type is ( Border_None, Border_Raised, Border_Sunk, Border_Line ); 
  17.  
  18.     -- enumeration of the different purposes a widget has for user-defined 
  19.     -- colors. not all widgets use colors for every purpose. 
  20.     type Color_Purpose is ( Background, 
  21.                             Foreground, 
  22.                             Selected, 
  23.                             Selected_Text, 
  24.                             Text ); 
  25.  
  26.     -- an array of colors, one for each potential purpose in a widget 
  27.     type Colors_Array is array (Color_Purpose) of Color_Type; 
  28.  
  29.     DEFAULT_FONT_NAME : constant String := "standard";    -- default gui font 
  30.     DEFAULT_FONT_SIZE : constant Positive := 14;          -- default font size 
  31.  
  32.     ---------------------------------------------------------------------------- 
  33.  
  34.     -- A Theme is an abstract class used by widgets to provide the GUI's look 
  35.     -- and feel. The Theme is a singleton object. 
  36.     type Theme is abstract new Limited_Object with private; 
  37.     type A_Theme is access all Theme'Class; 
  38.  
  39.     -- Returns the width in pixels of borders drawn by the Theme. 
  40.     function Border_Width( this : access Theme ) return Natural; 
  41.  
  42.     -- Returns the Theme's default color for a 'purpose'. 
  43.     function Color( this : access Theme; purpose : Color_Purpose ) return Color_Type; 
  44.  
  45.     -- Draws a rectangular border from x1, y1 to x2, y2 using 'border' as the 
  46.     -- border type and 'color' as the border's dominant color. 
  47.     procedure Draw_Border( this   : access Theme; 
  48.                            dc     : Drawing_Context; 
  49.                            border : Border_Type; 
  50.                            x1, y1, 
  51.                            x2, y2 : Integer; 
  52.                            color  : Color_Type ); 
  53.  
  54.     -- Draws a filled rectangle of 'color' (unless 'color' is transparent) from 
  55.     -- x1, y1 to x2, y2 and a border of type 'border' with 'color' as the 
  56.     -- border's dominant color. 
  57.     procedure Draw_Box( this   : access Theme; 
  58.                         dc     : Drawing_Context; 
  59.                         x1, y1, 
  60.                         x2, y2 : Integer; 
  61.                         color  : Color_Type; 
  62.                         border : Border_Type := Border_None ); 
  63.  
  64.     -- Draws a label composed of the given icon, some horizontal spacing, and 
  65.     -- the given text. If the icon or the text is ommitted, the spacing that 
  66.     -- would separate the two will also be ommitted. The 'smooth' argument 
  67.     -- enables text anti-aliasing. The 'align' argument determines the alignment 
  68.     -- for the icon and text as a group within the width of the area given for 
  69.     -- the label by x1 and x2. The label will be centered vertically between 
  70.     -- y1 and y2. 
  71.     procedure Draw_Label( this     : access Theme; 
  72.                           dc       : Drawing_Context; 
  73.                           x1, y1, 
  74.                           x2, y2   : Integer; 
  75.                           icon     : A_Bitmap; 
  76.                           text     : String; 
  77.                           fontName : String; 
  78.                           fontSize : Positive; 
  79.                           color    : Color_Type; 
  80.                           align    : Align_Type; 
  81.                           smooth   : Boolean := False ); 
  82.     pragma Precondition( fontName'Length > 0 ); 
  83.  
  84.     -- Synchronously retrieves a bitmap by tile id. 
  85.     function Get_Bitmap( this : access Theme; 
  86.                          id   : Natural ) return A_Bitmap is abstract; 
  87.  
  88.     -- Returns a reference to a previously loaded font. If the font by this name 
  89.     -- and in this size has not been loaded previously, it will be reloaded in 
  90.     -- the new size 'size'. If the font 'name' is unknown or it can't be 
  91.     -- reloaded in the requested size, an exception will be raised. 
  92.     function Get_Font( this : not null access Theme'Class; 
  93.                        name : String; 
  94.                        size : Positive ) return Font_Type; 
  95.     pragma Precondition( name'Length > 0 ); 
  96.  
  97.     -- Returns the height in pixels of any text drawn in the given font. Zero is 
  98.     -- returned if the font hasn't been loaded. 
  99.     function Get_Text_Height( this     : not null access Theme'Class; 
  100.                               fontName : String; 
  101.                               fontSize : Positive ) return Natural; 
  102.     pragma Precondition( fontName'Length > 0 ); 
  103.  
  104.     -- Returns the id number of a tile referenced by name in the theme's tile 
  105.     -- library. 
  106.     function Get_ID( this : access Theme; name : String ) return Natural is abstract; 
  107.  
  108.     -- Returns the theme's current scaling filter type. 
  109.     function Get_Scaling_Filter( this : not null access Theme'Class ) return Filter_Type; 
  110.  
  111.     -- Returns the width in pixels of 'text' in the given font. Zero is returned 
  112.     -- if the font hasn't been loaded. 
  113.     function Get_Text_Width( this     : not null access Theme'Class; 
  114.                              text     : String; 
  115.                              fontName : String; 
  116.                              fontSize : Positive ) return Natural; 
  117.     pragma Precondition( fontName'Length > 0 ); 
  118.  
  119.     -- Returns the minimum height in pixels required to draw a label with the 
  120.     -- given icon and text. If Draw_Label is overridden, this function should 
  121.     -- also be appropriately overridden to return the correct height. 
  122.     function Label_Height( this     : access Theme; 
  123.                            icon     : A_Bitmap; 
  124.                            text     : String; 
  125.                            fontName : String; 
  126.                            fontSize : Positive ) return Natural; 
  127.     pragma Precondition( fontName'Length > 0 ); 
  128.  
  129.     -- Returns the minimum width in pixels required to draw a label with the 
  130.     -- given icon and text. If Draw_Label is overridden, this function should 
  131.     -- also be appropriately overridden to return the correct width. 
  132.     function Label_Width( this     : access Theme; 
  133.                           icon     : A_Bitmap; 
  134.                           text     : String; 
  135.                           fontName : String; 
  136.                           fontSize : Positive ) return Natural; 
  137.     pragma Precondition( fontName'Length > 0 ); 
  138.  
  139.     -- Registers a font file with a font name. The font will be loaded first at 
  140.     -- size DEFAULT_FONT_SIZE. If the file at 'path' can't be loaded, a 
  141.     -- Resource_Error exception will be raised. 
  142.     procedure Register_Font( this : not null access Theme'Class; 
  143.                              path : String; 
  144.                              name : String ); 
  145.  
  146.     -- Sets the theme's current scaling filter type. 
  147.     procedure Set_Scaling_Filter( this   : not null access Theme'Class; 
  148.                                   filter : Filter_Type ); 
  149.  
  150.     ---------------------------------------------------------------------------- 
  151.  
  152.     -- Creates the global theme instance. Raises an exception on error. 
  153.     procedure Create_Theme; 
  154.  
  155.     -- Deletes the global theme instance. 
  156.     procedure Delete_Theme; 
  157.  
  158.     -- Returns a reference to the global theme or null, if it has not been 
  159.     -- created. 
  160.     function Get return A_Theme; 
  161.  
  162. private 
  163.  
  164.     package Font_Maps is new Ada.Containers.Indefinite_Ordered_Maps( String, 
  165.                                                                      Font_Type, 
  166.                                                                      "<", 
  167.                                                                      "=" ); 
  168.  
  169.     package Font_Paths is new Ada.Containers.Indefinite_Ordered_Maps( String, 
  170.                                                                       String, 
  171.                                                                       "<", 
  172.                                                                       "=" ); 
  173.  
  174.     type Theme is abstract new Limited_Object with 
  175.         record 
  176.             colors    : Colors_Array := Colors_Array'(others => 0); 
  177.             fonts     : Font_Maps.Map; 
  178.             fontPaths : Font_Paths.Map; 
  179.             filter    : Filter_Type := Filter_Nearest; 
  180.         end record; 
  181.  
  182.     procedure Construct( this : access Theme ); 
  183.  
  184.     procedure Delete( this : in out Theme ); 
  185.  
  186.     -- 'path' is either the name of the font file to load (the path will be 
  187.     -- resolved using the Resources package), or an absolute path to the file. 
  188.     -- 'name' is the simple name of the font for later reference (name is case 
  189.     -- insensitive). An exception will be raised on error. 
  190.     function Load_Font( this : not null access Theme'Class; 
  191.                         path : String; 
  192.                         name : String; 
  193.                         size : Positive ) return Font_Type; 
  194.     pragma Precondition( name'Length > 0 ); 
  195.  
  196.     -- Deletes the Theme. 
  197.     procedure Delete( this : in out A_Theme ); 
  198.     pragma Postcondition( this = null ); 
  199.  
  200.     ---------------------------------------------------------------------------- 
  201.  
  202.     -- An allocator function for creating Theme instances. 
  203.     type Allocator is access function return A_Theme; 
  204.  
  205.     -- Registers the allocator that will be used to create the global Theme 
  206.     -- instance. This should be called at elaboration time. 
  207.     procedure Register_Allocator( allocate : not null Allocator ); 
  208.  
  209. end Themes;