wumpus-drawing-0.3.0: src/Wumpus/Drawing/Text/Base/RotTextZero.hs
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Drawing.Text.Base.RotTextZero
-- Copyright : (c) Stephen Tetley 2011
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : unstable
-- Portability : GHC
--
-- Direction zero (left-to-right) measured text that supports
-- radial inclination. Caveat - rendering at any inclination other
-- than the horizontal may not look good in PostScript or SVG.
--
-- \*\* WARNING \*\* - the API for this module needs some polish.
--
--
--------------------------------------------------------------------------------
module Wumpus.Drawing.Text.Base.RotTextZero
(
LocRectTextLine
, LocTextLine
, TextObject
, textline
, bllTextline
, blcTextline
, ccTextline
, multiAlignLeft
, multiAlignCenter
, multiAlignRight
, rtextline
, rescTextline
) where
import Wumpus.Drawing.Text.Base.Common
import Wumpus.Basic.Kernel -- package: wumpus-basic
import Wumpus.Core -- package: wumpus-core
import Control.Applicative
type LocRectTextLine u = BoundedLocRectGraphic u
type LocTextLine u = BoundedLocGraphic u
type TextObject u = PosObject u
-- | Draw a single line of text.
--
textline :: (Fractional u, InterpretUnit u)
=> String -> LocRectTextLine u
textline ss = posTextWithMargins (makeTextObject ss)
bllTextline :: (Floating u, InterpretUnit u)
=> String -> LocTextLine u
bllTextline ss = startAddr (textline ss) BLL
blcTextline :: (Floating u, InterpretUnit u)
=> String -> LocTextLine u
blcTextline ss = startAddr (textline ss) BLC
ccTextline :: (Floating u, InterpretUnit u)
=> String -> LocTextLine u
ccTextline ss = startAddr (textline ss) CENTER
multiAlignLeft :: (Real u, Floating u, InterpretUnit u)
=> String -> LocRectTextLine u
multiAlignLeft ss =
renderMultiLine VLeft (map makeTextObject $ lines ss)
multiAlignCenter :: (Real u, Floating u, InterpretUnit u)
=> String -> LocRectTextLine u
multiAlignCenter ss =
renderMultiLine VCenter (map makeTextObject $ lines ss)
multiAlignRight :: (Real u, Floating u, InterpretUnit u)
=> String -> LocRectTextLine u
multiAlignRight ss =
renderMultiLine VRight (map makeTextObject $ lines ss)
renderMultiLine :: (Real u, Floating u, InterpretUnit u)
=> VAlign -> [TextObject u] -> LocRectTextLine u
renderMultiLine va docs = body >>= posTextWithMargins
where
body = (\dy -> alignColumnSep va dy $ reverse docs) <$> textlineSpace
makeTextObject :: InterpretUnit u => String -> TextObject u
makeTextObject = makeEscTextObject . escapeString
makeEscTextObject :: InterpretUnit u => EscapedText -> TextObject u
makeEscTextObject esc =
makePosObject (textOrientationZero esc) (escTextLine esc)
-- Note inclided text will (probably) have to construct with the
-- incline angle rather than apply it as part of the run function.
--
rtextline :: (Real u, Floating u, Ord u, InterpretUnit u)
=> Radian -> String -> LocRectTextLine u
rtextline ang ss = rescTextline ang (escapeString ss)
-- Is rotated text better with no margin?
rescTextline :: (Real u, Floating u, Ord u, InterpretUnit u)
=> Radian -> EscapedText -> LocRectTextLine u
rescTextline ang esc = runPosObjectR2 $ makePosObject ortt body
where
ortt = fmap (rotOrientation ang) $ textOrientationZero esc
body = incline (rescTextLine esc) ang
-- | Rotate an Orientation about its locus.
--
rotOrientation :: (Real u, Floating u, Ord u)
=> Radian -> Orientation u -> Orientation u
rotOrientation ang (Orientation xmin xmaj ymin ymaj) =
orthoOrientation bl br tl tr
where
bl = rotateCorner ang $ P2 (-xmin) (-ymin)
br = rotateCorner ang $ P2 xmaj (-ymaj)
tr = rotateCorner ang $ P2 xmaj ymaj
tl = rotateCorner ang $ P2 (-xmin) ymaj
-- | This is not necessarily correct...
--
orthoOrientation :: (Num u, Ord u)
=> Point2 u -> Point2 u -> Point2 u -> Point2 u
-> Orientation u
orthoOrientation (P2 x0 y0) (P2 x1 y1) (P2 x2 y2) (P2 x3 y3) =
Orientation { or_x_minor = abs $ min4 x0 x1 x2 x3
, or_x_major = max4 x0 x1 x2 x3
, or_y_minor = abs $ min4 y0 y1 y2 y3
, or_y_major = max4 y0 y1 y2 y3
}
rotateCorner :: (Real u, Floating u) => Radian -> Point2 u -> Point2 u
rotateCorner ang pt = displaceVec v2 zeroPt
where
v1 = pvec zeroPt pt
theta = vdirection v1
hyp = vlength v1
v2 = avec (ang+theta) hyp
min4 :: Ord u => u -> u -> u -> u -> u
min4 a b c d = min (min a b) (min c d)
max4 :: Ord u => u -> u -> u -> u -> u
max4 a b c d = max (max a b) (max c d)
{-
type RotText u = PosThetaImage BoundingBox u
-------------------
-- | One line of multiline text
--
data OnelineText u = OnelineText
{ text_content :: EscapedText
, oneline_adv :: AdvanceVec u
}
type OnelineGraphicF u = u -> OnelineText u -> LocThetaGraphic u
rotTextStart :: PosThetaImage u a -> RectPosition -> Radian -> LocImage u a
rotTextStart = startPosRot
textbox :: (Real u, Floating u, InterpretUnit u)
=> String -> PosImage BoundingBox u
textbox ss = multiAlignCenter ss `ptRot` 0
rtextbox :: (Real u, Floating u, InterpretUnit u)
=> String -> PosThetaImage BoundingBox u
rtextbox ss = multiAlignCenter ss
-- multi line text allows rotation
multiAlignLeft :: (Real u, Floating u, InterpretUnit u)
=> String -> PosThetaImage BoundingBox u
multiAlignLeft ss =
drawMultiline onelineALeft (map escapeString $ lines ss)
multiAlignCenter :: (Real u, Floating u, InterpretUnit u)
=> String -> PosThetaImage BoundingBox u
multiAlignCenter ss =
drawMultiline onelineACenter (map escapeString $ lines ss)
multiAlignRight :: (Real u, Floating u, InterpretUnit u)
=> String -> RotText u
multiAlignRight ss =
drawMultiline onelineARight (map escapeString $ lines ss)
textAlignLeft :: (Real u, Floating u, InterpretUnit u)
=> String -> LocImage BoundingBox u
textAlignLeft ss = startPosRot (multiAlignLeft ss) CENTER 0
textAlignCenter :: (Real u, Floating u, InterpretUnit u)
=> String -> LocImage BoundingBox u
textAlignCenter ss = startPosRot (multiAlignCenter ss) CENTER 0
textAlignRight :: (Real u, Floating u, InterpretUnit u)
=> String -> LocImage BoundingBox u
textAlignRight ss = startPosRot (multiAlignRight ss) CENTER 0
drawMultiline :: (Real u, Floating u, InterpretUnit u)
=> OnelineGraphicF u -> [EscapedText]
-> PosThetaImage BoundingBox u
drawMultiline _ [] = lift1R3 emptyBoundedLocGraphic
drawMultiline drawF xs = promoteR3 $ \start rpos ang ->
linesToInterims xs >>= \(max_w, ones) ->
borderedRotTextPos ang line_count max_w >>= \opos ->
let gf = multilineGraphic drawF max_w ang ones
bbf = orthoBB max_w line_count ang
img = intoLocImage bbf gf
posG = makePosImage opos img
in atStartPos posG start rpos
where
line_count = length xs
multilineGraphic :: (Floating u, InterpretUnit u)
=> OnelineGraphicF u
-> u
-> Radian
-> [OnelineText u]
-> LocGraphic u
multilineGraphic drawF max_w ang xs =
lift0R1 (centerSpineDisps (length xs) ang) >>= \(disp_top, disp_next) ->
let gs = map (\a -> rot (drawF max_w a) ang) xs
in ignoreAns $ moveStart disp_top $ chainDisplace disp_next gs
-- | Draw left-aligned text. Effictively this is:
--
-- > Leftwards for the half the max vector
-- >
-- > Down to the baseline from the center.
--
onelineALeft :: (Real u, Floating u, InterpretUnit u)
=> OnelineGraphicF u
onelineALeft width otext = promoteR2 $ \ctr theta ->
centerToBaseline >>= \down ->
let pt = move down theta ctr
in atRot (rescTextLine $ text_content otext) pt theta
where
vec1 = hvec $ negate $ 0.5 * width
move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang
-- | Draw center-aligned text. Effictively this is:
--
-- > Leftwards for the half the width vector
-- >
-- > Down to the baseline from the center.
--
-- The max_adv is ignored.
--
onelineACenter :: (Real u, Floating u, InterpretUnit u)
=> OnelineGraphicF u
onelineACenter _ otext = promoteR2 $ \ctr theta ->
centerToBaseline >>= \down ->
let pt = move down theta ctr
in atRot (rescTextLine $ text_content otext) pt theta
where
vec1 = negateV $ 0.5 *^ oneline_adv otext
move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang
-- | Draw right-aligned text. Effictively this is:
--
-- > Rightwards for the half the max width
-- >
-- > Leftwards for the width vector
-- >
-- > Down to the baseline from the center.
--
onelineARight :: (Real u, Floating u, InterpretUnit u)
=> OnelineGraphicF u
onelineARight max_w otext = promoteR2 $ \ctr theta ->
centerToBaseline >>= \down ->
let pt = move down theta ctr
in atRot (rescTextLine $ text_content otext) pt theta
where
vec1 = hvec (0.5 * max_w) ^-^ oneline_adv otext
move down = \ang -> thetaSouthwards down ang . displaceOrtho vec1 ang
-- Note - for multiline text, the bounding box (of one line) is
-- always the same size regardless of the alignment of the textlines.
--
-- | Its easy to find top-left and top-right, then bottom-left is
-- the vector from top-right to center added to the center.
-- Likewise bottom-right is the vector from top-left-to center
-- added to the center. Visually this construction forms a bow of
-- two triangles meeting at the (rectangle) center.
orthoBB :: (Real u, Floating u, InterpretUnit u)
=> u -> Int -> Radian -> LocQuery u (BoundingBox u)
orthoBB w line_count theta = promoteR1 $ \ctr ->
fmap (0.5*) verticalSpan >>= \hh1 ->
textMargin >>= \(xsep,ysep) ->
centerSpineDisps line_count theta >>= \(disp_top,_) ->
let top_ctr = disp_top ctr
hw = 0.5 * w
tr = displaceOrtho (V2 (hw+xsep) (hh1+ysep)) theta top_ctr
tl = displaceOrtho (V2 (negate $ hw+xsep) (hh1+ysep)) theta top_ctr
bl = ctr .+^ pvec tr ctr
br = ctr .+^ pvec tl ctr
in return $ traceBoundary [tr,tl,bl,br]
-- Note - displaceOrtho would be more convenient if it wasn\'t a
-- vector.
--------------------------------------------------------------------------------
-- This isn't worth the complexity to get down to one traversal...
-- | Turn the input list of lines of 'EscapedText' into
-- 'OnelineText' and return the result list twinned with the
-- largest width.
--
linesToInterims :: (InterpretUnit u, Ord u)
=> [EscapedText] -> Query (u, [OnelineText u])
linesToInterims = fmap post . mapM onelineEscText
where
post xs = let vmax = foldr fn 0 xs in (vmax,xs)
fn (OnelineText _ av) wmax = max (advanceH av) wmax
onelineEscText :: InterpretUnit u => EscapedText -> Query (OnelineText u)
onelineEscText esc = fmap (OnelineText esc) $ textVector esc
-}