{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Graphics.Text.Annotation where
import Graphics.Dynamic.Plot.Colour
import Graphics.Dynamic.Plot.Internal.Types
import qualified Prelude
import Diagrams.Prelude ((^&), (&), _x, _y, (|||), (===))
import qualified Diagrams.Prelude as Dia
import qualified Diagrams.TwoD.Size as Dia
import qualified Diagrams.TwoD.Types as DiaTypes
import qualified Diagrams.TwoD.Text as DiaTxt
import Diagrams.BoundingBox (BoundingBox)
import qualified Diagrams.BoundingBox as DiaBB
import qualified Diagrams.Backend.Cairo as Cairo
import qualified Diagrams.Backend.Cairo.Text as CairoTxt
import Control.Monad.Trans (liftIO)
import qualified Control.Category.Hask as Hask
import Control.Category.Constrained.Prelude hiding ((^))
import Control.Arrow.Constrained hiding ((|||))
import Control.Monad.Constrained
import Control.Lens hiding ((...), (<.>))
import Control.Lens.TH
import Data.List (foldl', sort, intercalate, isPrefixOf, isInfixOf, find, zip4)
import qualified Data.Vector as Arr
import Data.Maybe
import Data.Semigroup
import Data.Foldable (fold, foldMap)
import Data.Function (on)
import Data.VectorSpace
import Data.Basis
import Data.AffineSpace
import Data.Manifold.PseudoAffine
import Data.Manifold.TreeCover
import qualified Data.Map.Lazy as Map
import Data.Tagged
import Text.Printf
prettyFloatShow :: Int -> Double -> String
prettyFloatShow _ 0 = "0"
prettyFloatShow preci x
| preci >= 0, preci < 4 = show $ round x
| preci < 0, preci > -2 = printf "%.1f" x
| otherwise = case ceiling (0.01 + lg (abs x/10^^(preci+1))) + preci of
0 | preci < 0 -> printf "%.*f"
(-preci)
x
expn | expn>preci -> printf "%.*f×₁₀%s"
(expn-preci)
(x/10^^expn)
(showExponentAsSuperscript expn)
| otherwise -> printf "%i×₁₀%s"
(round $ x/10^^expn :: Int)
(showExponentAsSuperscript expn)
showExponentAsSuperscript :: Int -> String
showExponentAsSuperscript = map sup . show
where sup ch = case lookup ch $ zip "0123456789-"
"⁰¹²³⁴⁵⁶⁷⁸⁹⁻" of
Just ch -> ch
maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . reads
data Annotation = Annotation {
getAnnotation :: AnnotationObj
, placement :: AnnotationPlace
, isOptional :: Bool
}
data AnnotationObj = TextAnnotation TextObj TextAlignment
data AnnotationPlace = ExactPlace R2
data TextObj = PlainText String
fromPlaintextObj :: TextObj -> String
fromPlaintextObj (PlainText t) = t
data TextAlignment = TextAlignment { hAlign, vAlign :: Alignment }
data Alignment = AlignBottom | AlignMid | AlignTop
type TxtStyle = Dia.Style Dia.V2 R
data DiagramTK = DiagramTK { textTools :: TextTK, viewScope :: GraphWindowSpecR2 }
data TextTK = TextTK { txtCairoStyle :: TxtStyle
, txtSize, xAspect, padding, extraTopPad :: R }
defaultTxtStyle :: TxtStyle
defaultTxtStyle = mempty & Dia.fontSizeO 9
& Dia.fc Dia.grey
& Dia.lc Dia.grey
prerenderAnnotation :: DiagramTK -> Annotation -> IO PlainGraphicsR2
prerenderAnnotation (DiagramTK{ textTools = TextTK{..}, viewScope = GraphWindowSpecR2{..} })
(Annotation{..})
| TextAnnotation (PlainText str) (TextAlignment{..}) <- getAnnotation
, ExactPlace p₀ <- placement = do
let dtxAlign = DiaTxt.BoxAlignedText
(case hAlign of {AlignBottom -> 0; AlignMid -> 0.5; AlignTop -> 1})
(case vAlign of {AlignBottom -> 0; AlignMid -> 0.5; AlignTop -> 1})
rnTextLines <- mapM (CairoTxt.textVisualBoundedIO txtCairoStyle
. DiaTxt.Text mempty dtxAlign )
$ lines str
let lineWidths = map ((/6 ) .
Dia.width) rnTextLines
nLines = length lineWidths
lineHeight = 1 + extraTopPad + 2*padding
ζx = ζy * xAspect
ζy = txtSize
width = (maximum $ 0 : lineWidths) + 2*padding
height = fromIntegral nLines * lineHeight
y₀ = case vAlign of
AlignBottom -> padding
AlignMid -> 0
AlignTop -> - padding
fullText = mconcat $ zipWith3 ( \n w ->
let y = n' * lineHeight
n' = n - case vAlign of
AlignTop -> 0
AlignMid -> fromIntegral nLines / 2
AlignBottom -> fromIntegral nLines
in (Dia.translate $ Dia.r2 (case hAlign of
AlignBottom -> ( padding, y₀-y )
AlignMid -> ( 0 , y₀-y )
AlignTop -> (-padding, y₀-y )
) ) ) [0..] lineWidths rnTextLines
p = px ^& py
where px = max l' . min r' $ p₀^._x
py = max b' . min t' $ p₀^._y
(l', r') = case hAlign of
AlignBottom -> (lBound , rBound - w )
AlignMid -> (lBound + w/2, rBound - w/2)
AlignTop -> (lBound + w , rBound )
(b', t') = case vAlign of
AlignBottom -> (bBound' , tBound - 2*h )
AlignMid -> (bBound' + h/2, tBound - 3*h/2)
AlignTop -> (bBound' + h , tBound - h )
w = ζx * width; h = 1.5 * ζy * height
bBound' = bBound + lineHeight*ζy
return . Dia.translate p . Dia.scaleX ζx . Dia.scaleY ζy
$ Dia.lc Dia.grey fullText
lg :: Floating a => a -> a
lg = logBase 10
data LegendEntry = LegendEntry {
_plotObjectTitle :: TextObj
, _plotObjRepresentativeColour :: Maybe PColour
, _customLegendObject :: Option ()
}
makeLenses ''LegendEntry
instance HasColour LegendEntry where
asAColourWith sch = asAColourWith sch . _plotObjRepresentativeColour
prerenderLegend :: TextTK -> ColourScheme -> LegendDisplayConfig
-> [LegendEntry] -> IO (Maybe PlainGraphicsR2)
prerenderLegend _ _ _ [] = return mempty
prerenderLegend TextTK{..} cscm layoutSpec l = do
let bgColour = cscm neutral
lRends <- forM l `id`\legEntry -> do
txtR <- CairoTxt.textVisualBoundedIO txtCairoStyle
$ DiaTxt.Text mempty (DiaTxt.BoxAlignedText 0 0.5)
(fromPlaintextObj $ legEntry^.plotObjectTitle)
let h = Dia.height txtR
return $ Dia.hsep 5 [ Dia.rect h h & Dia.fcA
(asAColourWith cscm legEntry)
, txtR
] & Dia.centerXY
& Dia.frame 2
& Dia.alignL
let szSpec = Dia.getSpec (layoutSpec ^. legendPrerenderSize)
hLine = maximum $ Dia.height <$> lRends
nLines = case szSpec of
DiaTypes.V2 _ Nothing -> length l
DiaTypes.V2 _ (Just hMax) -> max 1 . floor $ hMax / hLine
lRends2D = Dia.hsep (txtSize*2) $ Dia.vcat <$> takes nLines lRends
w = case szSpec of
DiaTypes.V2 Nothing _ -> Dia.width lRends2D
DiaTypes.V2 (Just wM) _ -> wM
h = Dia.height lRends2D
return . pure
$ ( lRends2D & Dia.centerXY & Dia.translate (3^&3) )
<> ( Dia.rect (w+1) (h+1) & Dia.fcA (cscm $ paler grey) )
where takes :: Int -> [a] -> [[a]]
takes n [] = []
takes n l = case splitAt n l of
(h,r) -> h : takes n r