module Draw.Text (
      showTextAligned
    , plotText
    , PlotTextOptions(..)
    , HAlign(..)
    , VAlign(..)

    , module Data.Default.Class
) where



import           Data.Default.Class
import           Geometry
import qualified Graphics.PlotFont        as PF
import qualified Graphics.Rendering.Cairo as C



-- $setup
-- >>> import Draw
-- >>> import Geometry.Algorithms.Sampling
-- >>> import Geometry.Core                as G
-- >>> import Graphics.Rendering.Cairo     as C



-- | Vertical alignment
data VAlign = VTop | VCenter | VBottom deriving (VAlign -> VAlign -> Bool
(VAlign -> VAlign -> Bool)
-> (VAlign -> VAlign -> Bool) -> Eq VAlign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VAlign -> VAlign -> Bool
== :: VAlign -> VAlign -> Bool
$c/= :: VAlign -> VAlign -> Bool
/= :: VAlign -> VAlign -> Bool
Eq, Eq VAlign
Eq VAlign
-> (VAlign -> VAlign -> Ordering)
-> (VAlign -> VAlign -> Bool)
-> (VAlign -> VAlign -> Bool)
-> (VAlign -> VAlign -> Bool)
-> (VAlign -> VAlign -> Bool)
-> (VAlign -> VAlign -> VAlign)
-> (VAlign -> VAlign -> VAlign)
-> Ord VAlign
VAlign -> VAlign -> Bool
VAlign -> VAlign -> Ordering
VAlign -> VAlign -> VAlign
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: VAlign -> VAlign -> Ordering
compare :: VAlign -> VAlign -> Ordering
$c< :: VAlign -> VAlign -> Bool
< :: VAlign -> VAlign -> Bool
$c<= :: VAlign -> VAlign -> Bool
<= :: VAlign -> VAlign -> Bool
$c> :: VAlign -> VAlign -> Bool
> :: VAlign -> VAlign -> Bool
$c>= :: VAlign -> VAlign -> Bool
>= :: VAlign -> VAlign -> Bool
$cmax :: VAlign -> VAlign -> VAlign
max :: VAlign -> VAlign -> VAlign
$cmin :: VAlign -> VAlign -> VAlign
min :: VAlign -> VAlign -> VAlign
Ord, Int -> VAlign -> ShowS
[VAlign] -> ShowS
VAlign -> String
(Int -> VAlign -> ShowS)
-> (VAlign -> String) -> ([VAlign] -> ShowS) -> Show VAlign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VAlign -> ShowS
showsPrec :: Int -> VAlign -> ShowS
$cshow :: VAlign -> String
show :: VAlign -> String
$cshowList :: [VAlign] -> ShowS
showList :: [VAlign] -> ShowS
Show)

-- | Horizontal alignment
data HAlign = HLeft | HCenter | HRight deriving (HAlign -> HAlign -> Bool
(HAlign -> HAlign -> Bool)
-> (HAlign -> HAlign -> Bool) -> Eq HAlign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HAlign -> HAlign -> Bool
== :: HAlign -> HAlign -> Bool
$c/= :: HAlign -> HAlign -> Bool
/= :: HAlign -> HAlign -> Bool
Eq, Eq HAlign
Eq HAlign
-> (HAlign -> HAlign -> Ordering)
-> (HAlign -> HAlign -> Bool)
-> (HAlign -> HAlign -> Bool)
-> (HAlign -> HAlign -> Bool)
-> (HAlign -> HAlign -> Bool)
-> (HAlign -> HAlign -> HAlign)
-> (HAlign -> HAlign -> HAlign)
-> Ord HAlign
HAlign -> HAlign -> Bool
HAlign -> HAlign -> Ordering
HAlign -> HAlign -> HAlign
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HAlign -> HAlign -> Ordering
compare :: HAlign -> HAlign -> Ordering
$c< :: HAlign -> HAlign -> Bool
< :: HAlign -> HAlign -> Bool
$c<= :: HAlign -> HAlign -> Bool
<= :: HAlign -> HAlign -> Bool
$c> :: HAlign -> HAlign -> Bool
> :: HAlign -> HAlign -> Bool
$c>= :: HAlign -> HAlign -> Bool
>= :: HAlign -> HAlign -> Bool
$cmax :: HAlign -> HAlign -> HAlign
max :: HAlign -> HAlign -> HAlign
$cmin :: HAlign -> HAlign -> HAlign
min :: HAlign -> HAlign -> HAlign
Ord, Int -> HAlign -> ShowS
[HAlign] -> ShowS
HAlign -> String
(Int -> HAlign -> ShowS)
-> (HAlign -> String) -> ([HAlign] -> ShowS) -> Show HAlign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HAlign -> ShowS
showsPrec :: Int -> HAlign -> ShowS
$cshow :: HAlign -> String
show :: HAlign -> String
$cshowList :: [HAlign] -> ShowS
showList :: [HAlign] -> ShowS
Show)

-- | Like Cairo’s 'showText', but with alignment parameters. Since Cairo’s text API
-- is pretty wonky, you may have to sprinkle this with 'moveTo'/'moveToVec' or
-- 'newPath'.
--
-- <<docs/haddock/Draw/Text/show_text_aligned.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/Text/show_text_aligned.svg" 200 30 $ \_ -> do
--     coordinateSystem CairoStandard_ZeroTopLeft_XRight_YDown
--     C.moveTo (200/2) (30/2)
--     C.scale 3 3
--     showTextAligned HCenter VCenter "Hello world!"
-- :}
-- Generated file: size 8KB, crc32: 0xefcaecf4
showTextAligned
    :: C.CairoString string
    => HAlign -- ^ Horizontal alignment
    -> VAlign -- ^ Vertical alignment
    -> string -- ^ Text
    -> C.Render ()
showTextAligned :: forall string.
CairoString string =>
HAlign -> VAlign -> string -> Render ()
showTextAligned HAlign
hAlign VAlign
vAlign string
str = do
    (Double
w,Double
h) <- do TextExtents
ex <- string -> Render TextExtents
forall string. CairoString string => string -> Render TextExtents
C.textExtents string
str
                (Double, Double) -> Render (Double, Double)
forall a. a -> Render a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TextExtents -> Double
C.textExtentsWidth TextExtents
ex, TextExtents -> Double
C.textExtentsHeight TextExtents
ex)
    let dx :: Double
dx = case HAlign
hAlign of
            HAlign
HLeft   -> Double
0
            HAlign
HCenter -> -Double
wDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
            HAlign
HRight  -> -Double
w
        dy :: Double
dy = case VAlign
vAlign of
            VAlign
VTop    -> Double
h
            VAlign
VCenter -> Double
hDouble -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
2
            VAlign
VBottom -> Double
0
    Double -> Double -> Render ()
C.relMoveTo Double
dx Double
dy
    string -> Render ()
forall string. CairoString string => string -> Render ()
C.showText string
str
    Render ()
C.newPath -- The text API is wonky, it kinda-sorta moves the pointer but not really.
              -- newPath clears the path, so we get no leaks from the text.

data PlotTextOptions = PlotTextOptions
    { PlotTextOptions -> Vec2
_textStartingPoint :: Vec2
        -- ^ Starting point
    , PlotTextOptions -> Double
_textHeight :: Double
        -- ^ Height of the letter /X/'. 'def'ault: 12
    , PlotTextOptions -> HAlign
_textHAlign :: HAlign
        -- Horizontal alignment of text relative to the starting point. 'def'ault: 'HLeft'
    , PlotTextOptions -> VAlign
_textVAlign :: VAlign
        -- Vertical alignment of the text relative to the X height
        -- (i.e. not including undercut letters like "g"). 'def'ault: 'HBottom'
    }

instance Default PlotTextOptions where
    def :: PlotTextOptions
def = PlotTextOptions
        { _textStartingPoint :: Vec2
_textStartingPoint = Vec2
forall v. VectorSpace v => v
zero
        , _textHeight :: Double
_textHeight = Double
12
        , _textHAlign :: HAlign
_textHAlign = HAlign
HLeft
        , _textVAlign :: VAlign
_textVAlign = VAlign
VBottom
        }

-- | Some text as pure geometry.
--
-- <<docs/haddock/Draw/Text/plot_text.svg>>
--
-- === __(image code)__
-- >>> :{
-- haddockRender "Draw/Text/plot_text.svg" 200 30 $ \_ -> do
--     let opts = PlotTextOptions
--             { _textStartingPoint = Vec2 (200/2) (30/2)
--             , _textHeight = 20
--             , _textHAlign = HCenter
--             , _textVAlign = VCenter }
--         glyphs = plotText opts "Hello world!"
--     for_ glyphs $ \glyph -> sketch glyph >> stroke
-- :}
-- Generated file: size 7KB, crc32: 0xd253d9dd
plotText :: PlotTextOptions -> String -> [Polyline]
plotText :: PlotTextOptions -> String -> [Polyline]
plotText PlotTextOptions
options String
text = Transformation -> [Polyline] -> [Polyline]
forall geo. Transform geo => Transformation -> geo -> geo
transform (Vec2 -> Transformation
translate (PlotTextOptions -> Vec2
_textStartingPoint PlotTextOptions
options) Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation
scaleToHeight Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation
halign Transformation -> Transformation -> Transformation
forall a. Semigroup a => a -> a -> a
<> Transformation
valign) [Polyline]
glyphs
  where
    glyphs :: [Polyline]
glyphs = PFStroke -> Polyline
pfPolyline (PFStroke -> Polyline) -> [PFStroke] -> [Polyline]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlotFont -> String -> [PFStroke]
PF.render' PlotFont
PF.canvastextFont String
text
    BoundingBox (Vec2 Double
xMin Double
_) (Vec2 Double
xMax Double
_) = [Polyline] -> BoundingBox
forall a. HasBoundingBox a => a -> BoundingBox
boundingBox [Polyline]
glyphs
    halign :: Transformation
halign = case PlotTextOptions -> HAlign
_textHAlign PlotTextOptions
options of
        HAlign
HLeft -> Transformation
forall a. Monoid a => a
mempty
        HAlign
HRight -> Vec2 -> Transformation
translate (Double -> Double -> Vec2
Vec2 (-Double
xMax) Double
0)
        HAlign
HCenter -> Vec2 -> Transformation
translate (Double -> Double -> Vec2
Vec2 (- (Double
xMin Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
xMax) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2) Double
0)
    valign :: Transformation
valign = case PlotTextOptions -> VAlign
_textVAlign PlotTextOptions
options of
        VAlign
VBottom -> Transformation
forall a. Monoid a => a
mempty
        VAlign
VTop -> Vec2 -> Transformation
translate (Double -> Double -> Vec2
Vec2 Double
0 (-Double
pfXHeight))
        VAlign
VCenter -> Vec2 -> Transformation
translate (Double -> Double -> Vec2
Vec2 Double
0 (- Double
pfXHeight Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2))
    scaleToHeight :: Transformation
scaleToHeight = Double -> Transformation
scale (PlotTextOptions -> Double
_textHeight PlotTextOptions
options Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
pfXHeight)

pfXHeight :: Double
pfXHeight :: Double
pfXHeight = Double
y
  where
    (Double
_, Double
y) = [Polyline] -> (Double, Double)
forall a. HasBoundingBox a => a -> (Double, Double)
boundingBoxSize (String -> [Polyline]
letter String
"X")
    letter :: String -> [Polyline]
letter String
l = PFStroke -> Polyline
pfPolyline (PFStroke -> Polyline) -> [PFStroke] -> [Polyline]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PlotFont -> String -> [PFStroke]
PF.render' PlotFont
PF.canvastextFont String
l

pfPolyline :: PF.PFStroke -> Polyline
pfPolyline :: PFStroke -> Polyline
pfPolyline = [Vec2] -> Polyline
Polyline ([Vec2] -> Polyline)
-> (PFStroke -> [Vec2]) -> PFStroke -> Polyline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Double, Double) -> Vec2) -> PFStroke -> [Vec2]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Double -> Double -> Vec2) -> (Double, Double) -> Vec2
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Double -> Double -> Vec2
Vec2)