{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Chart.Text
( TextOptions(..)
, TextPathOptions(..)
, TextSvgOptions(..)
, TextType(..)
, TextFont(..)
, textFont
, text_
, texts
, textChart
, textChart_
, LabelOptions(..)
, labelled
) where
import Chart.Core
import Chart.Rect
import Diagrams.Prelude hiding (Color, D, scale, (<>), (*.))
import Graphics.SVGFonts hiding (textFont)
import Graphics.SVGFonts.ReadFont
import NumHask.Pair
import NumHask.Prelude hiding (rotate)
import NumHask.Rect
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text as Text
import qualified Diagrams.TwoD.Size as D
import qualified Diagrams.TwoD.Text as D
newtype TextPathOptions = TextPathOptions
{ font :: TextFont
} deriving (Show, Generic)
instance Default TextPathOptions where
def = TextPathOptions Lin2
data TextFont
= Lin2
| FromFontFile Text
deriving (Show)
textFont :: TextFont -> PreparedFont Double
textFont Lin2 = unsafePerformIO lin2
textFont (FromFontFile f) = unsafePerformIO (loadFont (Text.unpack f))
data TextSvgOptions = TextSvgOptions
{ nudgeSize :: Double
, nudgeBottom :: Double
, nudgeMid :: Double
, nudgeTop :: Double
, svgFont :: Maybe Text
, sizeVert :: Double
, sizeHori :: Double
, textBox :: RectOptions
} deriving (Show, Generic)
instance Default TextSvgOptions where
def = TextSvgOptions 0.78 0.25 -0.10 0.25 Nothing 1.1 0.55 clear
data TextType
= TextPath TextPathOptions
| TextSvg TextSvgOptions
deriving (Show, Generic)
data TextOptions = TextOptions
{ size :: Double
, alignH :: AlignH
, alignV :: AlignV
, color :: AlphaColour Double
, textFillRule :: FillRule
, rotation :: Double
, textType :: TextType
} deriving (Show, Generic)
instance Default TextOptions where
def =
TextOptions
0.08
AlignCenter
AlignMid
(withOpacity black 0.33)
EvenOdd
0
(TextSvg def)
text_ :: TextOptions -> Text -> Chart b
text_ (TextOptions s ah av c fr rot (TextPath (TextPathOptions f))) t =
moveTo (p_ (Pair (alignHTU ah * D.width path) (av' * D.height path))) $
path # fcA c # lw 0 # fillRule fr # rotate (rot @@ deg)
where
path =
textSVG_ (TextOpts (textFont f) INSIDE_H KERN False s s) (Text.unpack t)
av' = case av of
AlignBottom -> 0
AlignMid -> -0.25
AlignTop -> -0.5
text_ (TextOptions s ah av c fr rot (TextSvg (TextSvgOptions ns nb nm nt f v h bx))) t =
txt #
moveTo (p_ (Pair 0 mv)) #
Chart.Core.scaleX (s * ns) #
Chart.Core.scaleY (s * ns) #
maybe identity (D.font . Text.unpack) f #
fcA c #
lw 0 #
fillRule fr #
rotate (rot @@ deg)
where
txt =
D.alignedText ah'' av'' (Text.unpack t) <>
Chart.Core.scaleX (h*fromIntegral(Text.length t))
(Chart.Core.scaleY v $
moveOriginTo (p_ (Pair boxh boxv)) $
rect_ bx one)
(ah'', boxh) = case ah of
AlignLeft -> (0, -0.5)
AlignCenter -> (0.5, 0)
AlignRight -> (1, 0.5)
(av'', mv, boxv) = case av of
AlignBottom -> (0.5, nb, 0)
AlignMid -> (0.5, nm, 0)
AlignTop -> (1, nt, 0.5)
texts :: (R2 r) =>
TextOptions -> [(Text, r Double)] -> Chart b
texts opts ts = mconcat $ (\(t, p) -> positioned p (text_ opts t)) <$> ts
textChart ::
(Traversable f)
=> [TextOptions]
-> Rect Double
-> Rect Double
-> [f (Text, Pair Double)]
-> Chart b
textChart optss asp r xyss =
mconcat $ getZipList $ texts <$> ZipList optss <*> ZipList (zipWith zip ts ps)
where
ts = toList . fmap fst <$> xyss
ps = projectss r asp $ toList . fmap snd <$> xyss
textChart_ ::
[TextOptions] -> Rect Double -> [[(Text, Pair Double)]] -> Chart b
textChart_ optss asp xyss =
textChart optss asp (range $ fmap snd . toList <$> xyss) xyss
data LabelOptions = LabelOptions
{ text :: TextOptions
, orientation :: Pair Double
, gap :: Double
} deriving (Show, Generic)
instance Default LabelOptions where
def = LabelOptions def (Pair 0 1) 0.05
labelled :: LabelOptions -> Text -> Chart b -> Chart b
labelled (LabelOptions texto o g) t ch =
beside (r_ o) (beside (r_ o) ch (strut (r_ o) # scale g)) (text_ texto t)