{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TemplateHaskell       #-}

-------------------------------------------------------------------------------
-- |
-- Module      :  Diagrams.Backend.Rasterific.Text
-- Copyright   :  (c) 2015 diagrams-rasterific team (see LICENSE)
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  diagrams-discuss@googlegroups.com
--
-- Experimental module to create text with an envelope and trace. The
-- texterifc functions build diagrams with text size of @'local' 1@ and
-- a s specified slant and weight. The size should be changed only with
-- the scale functions and changing the slant and/or weight after the
-- text has benn created can result in an slightly incorrect envelope.
-------------------------------------------------------------------------------
module Diagrams.Backend.Rasterific.Text
  ( texterific'
  , texterific
  , fromFontStyle
  , textBoundingBox
  ) where

import           Graphics.Text.TrueType    hiding (BoundingBox)

import           Diagrams.Prelude
import           Diagrams.TwoD.Text        hiding (Font)

import           Data.FileEmbed            (embedDir)
import           Data.ByteString           (ByteString)
import           Data.ByteString.Lazy      (fromStrict)

-- | Get the 'BoundingBox' for some font with the origin at the start of
--   the baseline.
textBoundingBox :: RealFloat n => Font -> PointSize -> String -> BoundingBox V2 n
textBoundingBox :: Font -> PointSize -> String -> BoundingBox V2 n
textBoundingBox Font
f PointSize
p String
s = Point V2 n -> Point V2 n -> BoundingBox V2 n
forall (v :: * -> *) n.
(Additive v, Foldable v, Ord n) =>
Point v n -> Point v n -> BoundingBox v n
fromCorners
                        (n -> n -> Point V2 n
forall n. n -> n -> P2 n
mkP2 (n
2n -> n -> n
forall a. Num a => a -> a -> a
*(BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_xMin BoundingBox
bb)              ((BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_yMin BoundingBox
bb))
                        (n -> n -> Point V2 n
forall n. n -> n -> P2 n
mkP2 ((BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_xMax BoundingBox
bb n -> n -> n
forall a. Num a => a -> a -> a
+ (BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_xMin BoundingBox
bb) ((BoundingBox -> Float) -> BoundingBox -> n
r2f BoundingBox -> Float
_yMax BoundingBox
bb))
  where
    r2f :: (BoundingBox -> Float) -> BoundingBox -> n
r2f = (Float -> n) -> (BoundingBox -> Float) -> BoundingBox -> n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Float -> n
forall a b. (Real a, Fractional b) => a -> b
realToFrac
    bb :: BoundingBox
bb = Font -> Dpi -> PointSize -> String -> BoundingBox
stringBoundingBox Font
f Dpi
96 PointSize
p String
s

-- | Create a primitive text diagram from the given 'FontSlant',
--   'FontWeight', and string, with baseline alignment, envelope and trace
--   based on the 'BoundingBox' of the text.
texterific' :: (TypeableFloat n, Renderable (Text n) b)
            => FontSlant -> FontWeight -> String -> QDiagram b V2 n Any
texterific' :: FontSlant -> FontWeight -> String -> QDiagram b V2 n Any
texterific' FontSlant
fs FontWeight
fw String
s = Colour Double -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall n a c.
(InSpace V2 n a, Color c, Typeable n, Floating n, HasStyle a) =>
c -> a -> a
recommendFillColor Colour Double
forall a. Num a => Colour a
black (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a n. (N a ~ n, Typeable n, Num n, HasStyle a) => n -> a -> a
fontSizeL n
1
                    (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontSlant -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a. HasStyle a => FontSlant -> a -> a
fontSlant FontSlant
fs (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any
-> QDiagram b V2 n Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FontWeight -> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a. HasStyle a => FontWeight -> a -> a
fontWeight FontWeight
fw
                    (QDiagram b V2 n Any -> QDiagram b V2 n Any)
-> QDiagram b V2 n Any -> QDiagram b V2 n Any
forall a b. (a -> b) -> a -> b
$ Prim b V2 n
-> Envelope V2 n
-> Trace V2 n
-> SubMap b V2 n Any
-> Query V2 n Any
-> QDiagram b V2 n Any
forall b (v :: * -> *) n m.
Prim b v n
-> Envelope v n
-> Trace v n
-> SubMap b v n m
-> Query v n m
-> QDiagram b v n m
mkQD (Text n -> Prim b (V (Text n)) (N (Text n))
forall p b.
(Transformable p, Typeable p, Renderable p b) =>
p -> Prim b (V p) (N p)
Prim (Text n -> Prim b (V (Text n)) (N (Text n)))
-> Text n -> Prim b (V (Text n)) (N (Text n))
forall a b. (a -> b) -> a -> b
$ T2 n -> TextAlignment n -> String -> Text n
forall n. T2 n -> TextAlignment n -> String -> Text n
Text T2 n
forall a. Monoid a => a
mempty TextAlignment n
forall n. TextAlignment n
BaselineText String
s)
                           (BoundingBox V2 n
-> Envelope (V (BoundingBox V2 n)) (N (BoundingBox V2 n))
forall a. Enveloped a => a -> Envelope (V a) (N a)
getEnvelope BoundingBox V2 n
bb)
                           (BoundingBox V2 n
-> Trace (V (BoundingBox V2 n)) (N (BoundingBox V2 n))
forall a. Traced a => a -> Trace (V a) (N a)
getTrace BoundingBox V2 n
bb)
                           SubMap b V2 n Any
forall a. Monoid a => a
mempty
                           (BoundingBox V2 n
-> Query (V (BoundingBox V2 n)) (N (BoundingBox V2 n)) Any
forall t m. HasQuery t m => t -> Query (V t) (N t) m
getQuery BoundingBox V2 n
bb)
  where
    bb :: BoundingBox V2 n
bb = Font -> PointSize -> String -> BoundingBox V2 n
forall n.
RealFloat n =>
Font -> PointSize -> String -> BoundingBox V2 n
textBoundingBox Font
fnt (Float -> PointSize
PointSize Float
1) String
s
    fnt :: Font
fnt = FontSlant -> FontWeight -> Font
fromFontStyle FontSlant
fs FontWeight
fw

-- | Create a primitive text diagram from the given string, with
--   baseline alignment, envelope and trace based on the 'BoundingBox'
--   of the text.  Designed to be a replacement for the function 'text'
--   in Diagrams.TwoD.Text.
texterific :: (TypeableFloat n, Renderable (Text n) b) => String -> QDiagram b V2 n Any
texterific :: String -> QDiagram b V2 n Any
texterific String
s = FontSlant -> FontWeight -> String -> QDiagram b V2 n Any
forall n b.
(TypeableFloat n, Renderable (Text n) b) =>
FontSlant -> FontWeight -> String -> QDiagram b V2 n Any
texterific' FontSlant
FontSlantNormal FontWeight
FontWeightNormal String
s

-- | Get an OpenSans font with the given 'FontSlant' and 'FontWeight'.
fromFontStyle :: FontSlant -> FontWeight -> Font
fromFontStyle :: FontSlant -> FontWeight -> Font
fromFontStyle FontSlant
FontSlantItalic  FontWeight
FontWeightBold   = Font
openSansBoldItalic
fromFontStyle FontSlant
FontSlantOblique FontWeight
FontWeightBold   = Font
openSansBoldItalic
fromFontStyle FontSlant
FontSlantNormal  FontWeight
FontWeightBold   = Font
openSansBold
fromFontStyle FontSlant
FontSlantItalic  FontWeight
FontWeightNormal = Font
openSansItalic
fromFontStyle FontSlant
FontSlantOblique FontWeight
FontWeightNormal = Font
openSansItalic
fromFontStyle FontSlant
_                FontWeight
_                = Font
openSansRegular

fonts :: [(FilePath,ByteString)]
fonts :: [(String, ByteString)]
fonts = $(embedDir "fonts")

-- Read a static font file which is included with the package.
staticFont :: String -> Font
staticFont :: String -> Font
staticFont String
nm = case String -> [(String, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
nm [(String, ByteString)]
fonts of
   Maybe ByteString
Nothing -> String -> Font
forall a. HasCallStack => String -> a
error (String
"Font not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm)
   Just ByteString
f  -> case ByteString -> Either String Font
decodeFont (ByteString -> ByteString
fromStrict ByteString
f) of
                Right Font
r -> Font
r
                Left String
e  -> String -> Font
forall a. HasCallStack => String -> a
error String
e

openSansRegular :: Font
openSansRegular :: Font
openSansRegular = String -> Font
staticFont String
"OpenSans-Regular.ttf"

openSansBold :: Font
openSansBold :: Font
openSansBold = String -> Font
staticFont String
"OpenSans-Bold.ttf"

openSansItalic :: Font
openSansItalic :: Font
openSansItalic = String -> Font
staticFont String
"OpenSans-Italic.ttf"

openSansBoldItalic :: Font
openSansBoldItalic :: Font
openSansBoldItalic = String -> Font
staticFont String
"OpenSans-BoldItalic.ttf"