module Wumpus.Drawing.Text.LRText
(
baseCenterLine
, baseLeftLine
, baseRightLine
, rbaseCenterLine
, rbaseLeftLine
, rbaseRightLine
, ctrCenterLine
, baseCenterEscChar
, multiAlignLeft
, multiAlignCenter
, multiAlignRight
, rmultiAlignLeft
, rmultiAlignCenter
, rmultiAlignRight
) where
import Wumpus.Basic.Kernel
import Wumpus.Core
import Wumpus.Core.Text.GlyphIndices
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
import Data.Char
import qualified Data.Map as Map
import Data.Maybe
data OnelineText u = OnelineText EscapedText (AdvanceVec u)
type LocThetaDrawOneline u = u -> OnelineText u -> LocThetaGraphic u
type BoundedLocThetaOneline u = u -> OnelineText u -> BoundedLocThetaGraphic u
drawLeftAligned :: Floating u => LocThetaDrawOneline u
drawLeftAligned max_width (OnelineText esc _) =
promoteR2 $ \baseline_ctr theta ->
let mv = displaceParallel ((0.5) * max_width) theta
in apply2R2 (rescapedline esc) (mv baseline_ctr) theta
drawCenterAligned :: Floating u => LocThetaDrawOneline u
drawCenterAligned _ (OnelineText esc av) =
promoteR2 $ \baseline_ctr theta ->
let mv = displaceParallel (negate $ 0.5 * advanceH av) theta
in apply2R2 (rescapedline esc) (mv baseline_ctr) theta
drawRightAligned :: Floating u => LocThetaDrawOneline u
drawRightAligned max_width (OnelineText esc av) =
promoteR2 $ \baseline_ctr theta ->
let mv = displaceParallel ((0.5 * max_width) advanceH av) theta
in apply2R2 (rescapedline esc) (mv baseline_ctr) theta
onelineBBox :: (Real u, Floating u, FromPtSize u)
=> OnelineText u -> LocThetaDrawingInfo u (BoundingBox u)
onelineBBox (OnelineText _ av) =
promoteR2 $ \baseline_ctr theta ->
glyphHeightRange >>= \(ymin, ymax) ->
getTextMargin >>= \(xsep, ysep) ->
let hw = 0.5 * advanceH av
btm_left = baseline_ctr .+^ vec (hw) ymin
top_right = baseline_ctr .+^ vec hw ymax
bbox = expandBB xsep ysep (BBox btm_left top_right)
in pure $ centerOrthoBBox theta bbox
where
expandBB xsep ysep (BBox (P2 x0 y0) (P2 x1 y1)) =
BBox (P2 (x0xsep) (y0ysep)) (P2 (x1+xsep) (y1+ysep))
makeMoveableLine :: (Real u, Floating u, FromPtSize u)
=> LocThetaDrawOneline u
-> BoundedLocThetaOneline u
makeMoveableLine drawF max_width oline =
intoLocThetaImage (onelineBBox oline) (drawF max_width oline)
onelineAlg :: (Real u, Floating u, FromPtSize u)
=> DisplaceFun u
-> LocThetaDrawOneline u
-> EscapedText
-> BoundedLocThetaGraphic u
onelineAlg ptMoveF drawF esc =
promoteR2 $ \pt theta ->
onelineEscText esc >>= \ans@(OnelineText _ av) ->
let max_width = advanceH av
move = ptMoveF max_width ans theta
in apply2R2 (makeMoveableLine drawF max_width ans) (move pt) theta
baseLeftLine :: (Real u, Floating u, FromPtSize u)
=> String -> BoundedLocGraphic u
baseLeftLine ss = rbaseLeftLine ss `rot` 0
baseCenterLine :: (Real u, Floating u, FromPtSize u)
=> String -> BoundedLocGraphic u
baseCenterLine ss = rbaseCenterLine ss `rot` 0
baseRightLine :: (Real u, Floating u, FromPtSize u)
=> String -> BoundedLocGraphic u
baseRightLine ss = rbaseRightLine ss `rot` 0
rbaseLeftLine :: (Real u, Floating u, FromPtSize u)
=> String -> BoundedLocThetaGraphic u
rbaseLeftLine ss =
onelineAlg leftToCenter drawLeftAligned (escapeString ss)
rbaseCenterLine :: (Real u, Floating u, FromPtSize u)
=> String -> BoundedLocThetaGraphic u
rbaseCenterLine ss =
onelineAlg centerToCenter drawCenterAligned (escapeString ss)
rbaseRightLine :: (Real u, Floating u, FromPtSize u)
=> String -> BoundedLocThetaGraphic u
rbaseRightLine ss =
onelineAlg rightToCenter drawRightAligned (escapeString ss)
ctrCenterLine :: (Real u, Floating u, FromPtSize u)
=> String -> BoundedLocGraphic u
ctrCenterLine ss =
glyphHeightRange >>= \(ymin, ymax) ->
let hh = 0.5 * ymax ymin in
moveStartPoint (displaceV $ negate $ hh abs ymin) $ baseCenterLine ss
baseCenterEscChar :: (Real u, Floating u, FromPtSize u)
=> EscapedChar -> BoundedLocGraphic u
baseCenterEscChar esc = body `rot` 0
where
body = onelineAlg centerToCenter drawCenterAligned (wrapEscChar esc)
type DisplaceFun u = u -> OnelineText u -> Radian -> PointDisplace u
centerToCenter :: DisplaceFun u
centerToCenter _ _ _ = id
leftToCenter :: Floating u => DisplaceFun u
leftToCenter max_width _ theta =
displaceParallel (0.5 * max_width) theta
rightToCenter :: Floating u => DisplaceFun u
rightToCenter max_width (OnelineText _ av) theta =
displaceParallel ((0.5 * max_width) advanceH av) theta
multiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u)
=> String
-> BoundedLocGraphic u
multiAlignLeft ss = rmultiAlignLeft ss `rot` 0
multiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u)
=> String
-> BoundedLocGraphic u
multiAlignCenter ss = rmultiAlignCenter ss `rot` 0
multiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u)
=> String
-> BoundedLocGraphic u
multiAlignRight ss = rmultiAlignRight ss `rot` 0
rmultiAlignLeft :: (Floating u, Real u, Ord u, FromPtSize u)
=> String
-> BoundedLocThetaGraphic u
rmultiAlignLeft = multilineTEXT (makeMoveableLine drawLeftAligned)
rmultiAlignCenter :: (Floating u, Real u, Ord u, FromPtSize u)
=> String
-> BoundedLocThetaGraphic u
rmultiAlignCenter = multilineTEXT (makeMoveableLine drawCenterAligned)
rmultiAlignRight :: (Floating u, Real u, Ord u, FromPtSize u)
=> String
-> BoundedLocThetaGraphic u
rmultiAlignRight = multilineTEXT (makeMoveableLine drawRightAligned)
multilineTEXT :: (Floating u, Ord u, FromPtSize u)
=> BoundedLocThetaOneline u
-> String
-> BoundedLocThetaGraphic u
multilineTEXT _ [] = lift1R2 emptyBoundedLocGraphic
multilineTEXT mf ss =
lift0R2 (linesToInterims ss) >>= \(max_av, itexts) ->
centralPoints (length itexts) >>= \pts ->
zipMultis (advanceH max_av) mf itexts pts
zipMultis :: (Ord u, FromPtSize u)
=> u
-> BoundedLocThetaOneline u
-> [OnelineText u] -> [Point2 u]
-> BoundedLocThetaGraphic u
zipMultis _ _ [] _ = lift1R2 $ emptyBoundedLocGraphic
zipMultis _ _ _ [] = lift1R2 $ emptyBoundedLocGraphic
zipMultis max_w mf (a:as) (b:bs) = step a b as bs
where
mkGraphic itext pt = promoteR2 $ \_ theta ->
apply2R2 (mf max_w itext) pt theta
step r s (r2:rs) (s2:ss) = liftA2 oplus (mkGraphic r s) (step r2 s2 rs ss)
step r s _ _ = mkGraphic r s
centralPoints :: Floating u => Int -> LocThetaDrawingInfo u [Point2 u]
centralPoints n | n < 2 = promoteR2 $ \ctr _ -> return [ctr]
| even n = body (n `div` 2) (0.5*)
| otherwise = body (n `div` 2) (0 *)
where
body halfn ana = promoteR2 $ \ctr theta ->
baselineSpacing >>= \h ->
let y0 = (h * fromIntegral halfn) + ana h
top = displacePerpendicular y0 theta ctr
in pure $ trailPoints n h theta top
trailPoints :: Floating u => Int -> u -> Radian -> Point2 u -> [Point2 u]
trailPoints n height theta top = take n $ iterate fn top
where
fn pt = displacePerpendicular (height) theta pt
linesToInterims :: (FromPtSize u, Ord u)
=> String -> DrawingInfo (AdvanceVec u, [OnelineText u])
linesToInterims = fmap post . mapM (onelineEscText . escapeString) . lines
where
post xs = let vmax = foldr fn (hvec 0) xs in (vmax,xs)
fn (OnelineText _ av) vmax = avMaxWidth av vmax
avMaxWidth :: Ord u => AdvanceVec u -> AdvanceVec u -> AdvanceVec u
avMaxWidth a@(V2 w1 _) b@(V2 w2 _) = if w2 > w1 then b else a
onelineEscText :: FromPtSize u => EscapedText -> DrawingInfo (OnelineText u)
onelineEscText esc = fmap (OnelineText esc) $ textVector esc
textVector :: FromPtSize u => EscapedText -> DrawingInfo (AdvanceVec u)
textVector esc =
cwLookupTable >>= \table ->
let cs = destrEscapedText id esc
in pure $ foldr (\c v -> v ^+^ (charWidth table c)) (vec 0 0) cs
charWidth :: FromPtSize u
=> CharWidthTable u -> EscapedChar -> AdvanceVec u
charWidth fn (CharLiteral c) = fn $ ord c
charWidth fn (CharEscInt i) = fn i
charWidth fn (CharEscName s) = fn ix
where
ix = fromMaybe (1) $ Map.lookup s ps_glyph_indices