wumpus-basic-0.13.0: src/Wumpus/Basic/Text/LRText.hs
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Basic.Text.LRText
-- Copyright : (c) Stephen Tetley 2010
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : unstable
-- Portability : GHC
--
-- Left-to-right measured text. The text uses glyph metrics so it
-- can be positioned accurately.
--
--------------------------------------------------------------------------------
module Wumpus.Basic.Text.LRText
(
singleLineBL
, singleLineCC
, multiAlignLeft
, multiAlignCenter
, multiAlignRight
) where
import Wumpus.Basic.Graphic
import Wumpus.Core -- package: wumpus-core
import Wumpus.Core.Text.GlyphIndices
import Data.AffineSpace -- package: vector-space
import Data.VectorSpace
import Data.Char
import Data.Foldable ( foldrM )
import qualified Data.Map as Map
import Data.Maybe
-- One line of multiline text
--
data InterimText1 u = InterimText1
{ text1_escaped :: EscapedText
, text1_advance :: (AdvanceVec u)
}
deriving (Eq,Show)
singleLineBL :: (Ord u, FromPtSize u)
=> String -> BoundedLocGraphic u
singleLineBL ss = interimText1 ss >>= singleLRText id
singleLineCC :: (Fractional u, Ord u, FromPtSize u)
=> String -> BoundedLocGraphic u
singleLineCC ss = glyphCapHeight >>= \cap_h ->
interimText1 ss >>= \interim ->
let hw = 0.5 * advanceH (text1_advance interim)
in singleLRText (.-^ vec hw (0.5 * cap_h)) interim
-- | Draw multi-line text, aligned to the left.
--
-- The input string is split on newline with the Prelude function
-- @lines@. The supplied point is the center of the text.
--
multiAlignLeft :: (Fractional u, Ord u, FromPtSize u)
=> String -> BoundedLocGraphic u
multiAlignLeft =
multiAligned drawLeftAligned1 (\wv pt -> pt .-^ hvec (0.5 * advanceH wv))
-- | Draw multi-line text, aligned on the horizontal center.
--
-- The input string is split on newline with the Prelude function
-- @lines@. The supplied point is the center of the text.
--
multiAlignCenter :: (Fractional u, Ord u, FromPtSize u)
=> String -> BoundedLocGraphic u
multiAlignCenter =
multiAligned drawCenterAligned1 (\_ pt -> pt)
-- | Draw multi-line text, aligned to the right.
--
-- The input string is split on newline with the Prelude function
-- @lines@. The supplied point is the center of the text.
--
multiAlignRight :: (Fractional u, Ord u, FromPtSize u)
=> String -> BoundedLocGraphic u
multiAlignRight =
multiAligned drawRightAligned1 (\wv pt -> pt .+^ hvec (0.5 * advanceH wv))
-- Build multi-line aligned text.
--
-- The drawF functions regard the supplied point differently, for
-- instance @drawRightAligned1@ regards the point as
-- baseline-right.
--
-- The dispF are applied to a point which is initially in the
-- center of the drawing - for right aligned text it is displaced
-- to the right (half the max width vectoer), for left aligned
-- text it is displaced to the left. Center aligned text is not
-- displaced.
--
multiAligned :: (Fractional u, Ord u, FromPtSize u)
=> (InterimText1 u -> Point2 u -> BoundedGraphic u)
-> (AdvanceVec u -> Point2 u -> Point2 u)
-> String -> BoundedLocGraphic u
multiAligned drawF dispF ss =
linesToInterims ss >>= \(wv,xs) ->
glyphCapHeight >>= \cap_h ->
baselineSpacing >>= \base_span ->
promote1 $ \p0 -> let p1 = dispF wv p0
axs = annotateStartPoints cap_h base_span p1 xs
in mergeLines drawF p1 axs
-- This needs sorting out so as not to throw an error
--
mergeLines :: (Num u, Ord u)
=> (InterimText1 u -> Point2 u -> BoundedGraphic u)
-> Point2 u
-> [(InterimText1 u, Point2 u)] -> BoundedGraphic u
mergeLines fn fallback_pt = step
where
step [(x,pt)] = fn x pt
step ((x,pt):ys) = fn x pt `oplus` step ys
step _ = fn empty_fallback fallback_pt
empty_fallback = InterimText1 (escapeString "") (hvec 0)
singleLRText :: (Ord u, FromPtSize u)
=> (Point2 u -> Point2 u) -> InterimText1 u
-> BoundedLocGraphic u
singleLRText dispF (InterimText1 esc av) =
glyphHeightRange >>= \(ymin, ymax) ->
promote1 $ \p0 -> let pt = dispF p0
w = advanceH av
ll = pt .+^ vvec ymin
ur = pt .+^ vec w ymax
bb = boundingBox ll ur
in (escapedline esc `at` pt) >>= \prim ->
return (bb, prim)
-- Point is baseline-left
--
drawLeftAligned1 :: (Ord u, FromPtSize u)
=> InterimText1 u -> Point2 u -> BoundedGraphic u
drawLeftAligned1 itext pt = singleLRText id itext `at` pt
-- Point is baseline-center
--
drawCenterAligned1 :: (Fractional u, Ord u, FromPtSize u)
=> InterimText1 u -> Point2 u -> BoundedGraphic u
drawCenterAligned1 itext pt =
let hw = 0.5 * advanceH (text1_advance itext)
in singleLRText (.-^ hvec hw) itext `at` pt
-- Point is baseline-right
--
drawRightAligned1 :: (Fractional u, Ord u, FromPtSize u)
=> InterimText1 u -> Point2 u -> BoundedGraphic u
drawRightAligned1 itext pt =
let w = advanceH (text1_advance itext)
in singleLRText (.-^ hvec w) itext `at` pt
-- This isn't worth the complexity to get to one traversal...
linesToInterims :: (FromPtSize u, Ord u)
=> String -> DrawingInfo (AdvanceVec u, [InterimText1 u])
linesToInterims = fmap post . mapM interimText1 . lines
where
post xs = let vmax = foldr fn (hvec 0) xs in (vmax,xs)
fn a vmax = avMaxWidth (text1_advance a) vmax
avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u
avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a
interimText1 :: FromPtSize u => String -> DrawingInfo (InterimText1 u)
interimText1 ss = let esc = escapeString ss in
postpro (mk esc) $ textVector esc
where
mk a b = InterimText1 { text1_escaped = a
, text1_advance = b }
textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u)
textVector esc = let cs = getEscapedText esc in
foldrM (\c v -> charVector c >>= \cv -> return (v ^+^ cv)) (vec 0 0) cs
charVector :: FromPtSize u => EscapedChar -> DrawingInfo (AdvanceVec u)
charVector (CharLiteral c) = unCF1 (ord c) avLookupTable
charVector (CharEscInt i) = unCF1 i avLookupTable
charVector (CharEscName s) = unCF1 ix avLookupTable
where
ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices
-- baseline_span is the vertical distance from one baseline to
-- the next it is not /gap_height/.
--
annotateStartPoints :: Fractional u
=> u -> u -> Point2 u -> [InterimText1 u]
-> [(InterimText1 u, Point2 u)]
annotateStartPoints _ _ _ [] = []
annotateStartPoints cap_height baseline_span (P2 x y) (z:rest) =
let y0 = if odd list_len then odd_start_y else even_start_y
p0 = P2 x y0
in (z,p0) : step (moveDown1 p0) rest
where
list_len = 1 + length rest
halfn = fromIntegral $ list_len `div` 2
center_to_bl = 0.5 * cap_height
half_gap_height = 0.5 * (baseline_span - cap_height)
odd_start_y = y - center_to_bl + halfn * baseline_span
even_start_y = y - half_gap_height - cap_height + halfn * baseline_span
moveDown1 = \pt -> pt .-^ vvec baseline_span
step _ [] = []
step pt (a:as) = (a,pt) : step (moveDown1 pt) as