FontSupport.hs

{-# LANGUAGE RankNTypes                 #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Kernel.Base.FontSupport
-- Copyright   :  (c) Stephen Tetley 2010-2011
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Data types representing font metrics.
-- 
--------------------------------------------------------------------------------

module Wumpus.Basic.Kernel.Base.FontSupport
  ( 

    FontName
  , CodePoint
  , FontDef(..)
  , FontFamily(..)
  , regularWeight
  , boldWeight
  , italicWeight
  , boldItalicWeight

  , CharWidthLookup

  , FontMetrics(..)

  , FontTable
  , emptyFontTable
  , lookupFont
  , insertFont

  , FontLoadMsg
  , FontLoadLog
  , fontLoadMsg

  , FontLoadResult(..)
  , printLoadErrors

  , monospace_metrics

  
  ) where

import Wumpus.Basic.Utils.HList

import Wumpus.Core                              -- package: wumpus-core

import qualified Data.Map      as Map
import Data.Monoid



type FontName = String

-- | A Unicode code-point.
--
type CodePoint = Int

-- | FontDef wraps @FontFace@ from Wumpus-Core with file name
-- information for the font loaders.
--
data FontDef = FontDef
      { font_def_face   :: FontFace
      , gs_file_name    :: String
      , afm_file_name   :: String
      }
  deriving (Eq,Ord,Show)



-- | A family group of FontDefs (regular, bold, italic and 
-- bold-italic).
--
-- It is convenient for some higher-level text objects in Wumpus 
-- (particularly @Doc@ in Wumpus-Drawing) to treat a font and its
-- standard weights as the same entity. This allows @Doc@ API to 
-- provide a @bold@ operation to simply change to the the bold
-- weight of the current family, rather than use the primitive 
-- @set_font@ operation to change to an explicitly named font.
--
--
data FontFamily = FontFamily
      { ff_regular      :: FontDef
      , ff_bold         :: Maybe FontDef
      , ff_italic       :: Maybe FontDef
      , ff_bold_italic  :: Maybe FontDef  
      }

-- | Extract the regular weight 'FontDef' from a 'FontFamily'.
--
regularWeight :: FontFamily -> FontDef
regularWeight = ff_regular


-- | Extract the bold weight 'FontDef' from a 'FontFamily'.
--
-- Note - this falls back to the regular weight if the font family 
-- has no bold weight. To get the bold weight or @Nothing@ if it
-- is not present use the record selector @ff_bold@.
--
boldWeight :: FontFamily -> FontDef
boldWeight s = maybe (ff_regular s) id $ ff_bold s


-- | Extract the @italic@ weight 'FontDef' from a 'FontFamily'.
--
-- Note - this falls back to the regular weight if the font family 
-- has no italic weight. To get the italic weight or @Nothing@ if 
-- it is not present use the record selector @ff_italic@.
--
italicWeight :: FontFamily -> FontDef
italicWeight s = maybe (ff_regular s) id $ ff_italic s


-- | Extract the @bold-italic@ weight 'FontDef' from a 
-- 'FontFamily'.
--
-- Note - this falls back to the regular weight if the font family 
-- has no bold-italic weight. To get the bold-italic weight or 
-- @Nothing@ if it is not present use the record selector 
-- @ff_bold_italic@.
--
boldItalicWeight :: FontFamily -> FontDef
boldItalicWeight s = maybe (ff_regular s) id $ ff_bold_italic s



-- | A lookup function from code point to /width vector/.
--
-- The unit is always stored as a Double representing PostScript
-- points.
--
-- Note - in PostScript terminology a width vector is not obliged
-- to be left-to-right (writing direction 0). It could be 
-- top-to-bottom (writing direction 1).
--
type CharWidthLookup = CodePoint -> Vec2 Double



-- | 'FontMetrics' store a subset of the properties available in 
-- a font file - enough to calculate accurate bounding boxes and
-- positions for text.
--
-- > Bounding box representing the maximum glyph area.
-- > Width vectors for each character.
-- > Cap height
-- > Descender depth.
--
-- Because Wumpus always needs font metrics respective to the 
-- current point size, the actual fields are all functions.
--
data FontMetrics = FontMetrics
    { get_bounding_box          :: FontSize -> BoundingBox Double
    , get_cw_table              :: FontSize -> CharWidthLookup
    , get_cap_height            :: FontSize -> Double
    , get_descender             :: FontSize -> Double
    , get_underline_position    :: FontSize -> Double
    , get_underline_thickness   :: FontSize -> Double
    }


-- | A map between a font name and the respective FontMetrics.
--
newtype FontTable = FontTable { 
          getFontTable :: Map.Map FontName FontMetrics }



instance Monoid FontTable where
  mempty        = emptyFontTable
  a `mappend` b = FontTable $ getFontTable a `mappend` getFontTable b


emptyFontTable :: FontTable
emptyFontTable = FontTable $ Map.empty


-- | 'FontLoadMsg' - type synonym for String.
--
type FontLoadMsg        = String

-- | 'FontLoadLog' is a Hughes list of Strings, so it supports 
-- efficient append.
--
newtype FontLoadLog     = FontLoadLog { getFontLoadLog :: H FontLoadMsg }


instance Monoid FontLoadLog where
  mempty        = FontLoadLog $ emptyH
  a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b


fontLoadMsg :: String -> FontLoadLog 
fontLoadMsg = FontLoadLog . wrapH


-- Need a synonym for @FontLoading@...
data FontLoadResult = FontLoadResult
      { loaded_font_table    :: FontTable
      , loader_errors        :: FontLoadLog
      }


-- | Print the loader errors from the 'FontLoadResult' to std-out.
--
printLoadErrors :: FontLoadResult -> IO ()
printLoadErrors = mapM_ putStrLn . toListH . getFontLoadLog . loader_errors

--------------------------------------------------------------------------------


-- | 'lookupFont' : @ name * font_table -> Maybe FontMetrics @ 
-- 
-- Lookup a font in the font_table.
-- 
lookupFont :: FontName -> FontTable -> Maybe FontMetrics
lookupFont name = Map.lookup name . getFontTable

-- | 'insertFont' : @ name * font_metrics * font_table -> FontTable @ 
-- 
-- Insert a named font into the font_table.
-- 
insertFont :: FontName -> FontMetrics -> FontTable -> FontTable
insertFont name ops = 
    FontTable . Map.insert name ops . getFontTable

-- | This ignores the Char code lookup and just returns the 
-- default advance vector.
--
monospace_metrics :: FontMetrics
monospace_metrics = FontMetrics
    { get_bounding_box          = \sz -> BBox (lowerLeft sz) (upperRight sz)
    , get_cw_table              = \sz _ -> hvec (upscale sz width_vec) 
    , get_cap_height            = \sz -> upscale sz cap_height
    , get_descender             = \sz -> upscale sz descender
    , get_underline_position    = \sz -> upscale sz underline_pos
    , get_underline_thickness   = \sz -> upscale sz underline_width
    }
  where
    llx             = (-23)  / 1000
    lly             = (-250) / 1000
    urx             = 715    / 1000
    ury             = 805    / 1000
    width_vec       = 600    / 1000
    cap_height      = 562    / 1000
    descender       = (-157) / 1000
    underline_pos   = (-100) / 1000
    underline_width = 50     / 1000

    upscale sz d    = d * fromIntegral sz
    lowerLeft sz    = P2 (upscale sz llx) (upscale sz lly) 
    upperRight sz   = P2 (upscale sz urx) (upscale sz ury)