wumpus-basic-0.21.0: src/Wumpus/Basic/Kernel/Objects/AdvObject.hs
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS -Wall #-}
--------------------------------------------------------------------------------
-- |
-- Module : Wumpus.Basic.Kernel.Objects.AdvObject
-- Copyright : (c) Stephen Tetley 2010-2011
-- License : BSD3
--
-- Maintainer : stephen.tetley@gmail.com
-- Stability : highly unstable
-- Portability : GHC
--
-- Extended Graphic object - an AdvanceGraphic is a Graphic
-- twinned with and advance vector.
--
--------------------------------------------------------------------------------
module Wumpus.Basic.Kernel.Objects.AdvObject
(
-- * Advance vector
AdvanceVec
, advanceH
, advanceV
-- * Advance-vector object and graphic
, AdvObject
, DAdvObject
, AdvGraphic
, DAdvGraphic
, runAdvObject
, makeAdvObject
, emptyAdvObject
, blankAdvObject
-- * Composition
, advance
, advances
, advspace
, evenspace
, advrepeat
, punctuate
, advfill
) where
import Wumpus.Basic.Kernel.Base.BaseDefs
import Wumpus.Basic.Kernel.Base.DrawingContext
import Wumpus.Basic.Kernel.Base.WrappedPrimitive
import Wumpus.Basic.Kernel.Objects.Basis
import Wumpus.Basic.Kernel.Objects.Image
import Wumpus.Basic.Kernel.Objects.LocImage
import Wumpus.Core -- package: wumpus-core
import Data.VectorSpace -- package: vector-space
import Control.Applicative
import Data.Monoid
--------------------------------------------------------------------------------
-- | Advance vectors provide an idiom for drawing consecutive
-- graphics. PostScript uses them to draw left-to-right text -
-- each character has an advance vector for the width and
-- as characters are drawn they successively displace the start
-- point for the next character with their advance vector.
--
-- Type alias for Vec2.
--
type AdvanceVec u = Vec2 u
-- | Extract the horizontal component of an advance vector.
--
-- For left-to-right latin text, the vertical component of an
-- advance vector is expected to be 0. Ingoring it seems
-- permissible when drawing text.
--
advanceH :: AdvanceVec u -> u
advanceH (V2 w _) = w
-- | Extract the verticall component of an advance vector.
--
advanceV :: AdvanceVec u -> u
advanceV (V2 _ h) = h
--------------------------------------------------------------------------------
-- AdvObject
-- | Internal newtype wrapper so we can have a monoid instance
-- with vector plus (^+^) for mappend.
--
newtype DAV = DAV { getDAV :: AdvanceVec Double }
instance Monoid DAV where
mempty = DAV $ V2 0 0
DAV v1 `mappend` DAV v2 = DAV $ v1 ^+^ v2
-- | /Advance vector/ graphic - this partially models the
-- PostScript @show@ command which moves the /current point/ by the
-- advance (width) vector as each character is drawn.
--
newtype AdvObject u a = AdvObject
{ getAdvObject :: DrawingContext -> DPoint2 -> (a, DAV, CatPrim) }
type instance DUnit (AdvObject u a) = u
type DAdvObject a = AdvObject Double a
type AdvGraphic u = AdvObject u (UNil u)
type DAdvGraphic = AdvGraphic Double
instance Functor (AdvObject u) where
fmap f mf = AdvObject $ \ctx pt ->
let (a,v1,w1) = getAdvObject mf ctx pt in (f a,v1,w1)
instance Applicative (AdvObject u) where
pure a = AdvObject $ \_ _ -> (a,mempty,mempty)
mf <*> ma = AdvObject $ \ctx pt ->
let (f,v1,w1) = getAdvObject mf ctx pt
(a,v2,w2) = getAdvObject ma ctx pt
in (f a, v1 `mappend` v2, w1 `mappend` w2)
instance Monad (AdvObject u) where
return a = AdvObject $ \_ _ -> (a,mempty,mempty)
mf >>= k = AdvObject $ \ctx pt ->
let (a,v1,w1) = getAdvObject mf ctx pt
(b,v2,w2) = getAdvObject (k a) ctx pt
in (b, v1 `mappend` v2, w1 `mappend` w2)
instance DrawingCtxM (AdvObject u) where
askDC = AdvObject $ \ctx _ -> (ctx, mempty, mempty)
asksDC fn = AdvObject $ \ctx _ -> (fn ctx, mempty, mempty)
localize upd ma = AdvObject $ \ctx pt -> getAdvObject ma (upd ctx) pt
instance (Monoid a, InterpretUnit u) => Monoid (AdvObject u a) where
mempty = AdvObject $ \_ _ -> (mempty, mempty, mempty)
ma `mappend` mb = AdvObject $ \ctx pt ->
let (a,v1,w1) = getAdvObject ma ctx pt
(b,v2,w2) = getAdvObject mb ctx pt
w2r = cpmove (getDAV v1) w2
in (a `mappend` b, v1 `mappend` v2, w1 `mappend` w2r)
-- | Running an AdvObject produces a LocImage.
--
runAdvObject :: InterpretUnit u
=> AdvObject u a -> LocImage u a
runAdvObject ma = promoteLoc $ \ot ->
askDC >>= \ctx ->
let dot = normalizeF (dc_font_size ctx) ot
(a,_,ca) = getAdvObject ma ctx dot
in replaceAns a $ primGraphic ca
--------------------------------------------------------------------------------
-- | 'makeAdvObject' : @ loc_context_function * image -> AdvObject @
--
-- Build an 'AdvObject' from a context function ('CF') that
-- generates the answer displacement vector and a 'LocGraphic'
-- that draws the 'AdvObject'.
--
makeAdvObject :: InterpretUnit u
=> Query u (Vec2 u) -> LocImage u a -> AdvObject u a
makeAdvObject ma gf = AdvObject $ \ctx pt ->
let v1 = runQuery ma ctx
dav1 = DAV $ normalizeF (dc_font_size ctx) v1
upt = dinterpF (dc_font_size ctx) pt
(a,w) = runLocImage gf ctx upt
in (a,dav1,w)
-- | 'emptyAdvObjectAU' : @ AdvObject @
--
-- Build an empty 'AdvObject'.
--
-- The 'emptyAdvObject' is treated as a /null primitive/ by
-- @Wumpus-Core@ and is not drawn, the answer vector generated is
-- the zero vector @(V2 0 0)@.
--
emptyAdvObject :: (Monoid a, InterpretUnit u) => AdvObject u a
emptyAdvObject = mempty
blankAdvObject :: (Monoid a, InterpretUnit u)
=> Vec2 u -> AdvObject u a
blankAdvObject v1 = AdvObject $ \ctx _ ->
let dav1 = DAV $ normalizeF (dc_font_size ctx) v1
in (mempty, dav1, mempty)
--------------------------------------------------------------------------------
-- Combining AdvObjects
-- Helper for list concatenation.
--
listcat :: (Monoid a, InterpretUnit u)
=> (AdvObject u a -> AdvObject u a -> AdvObject u a)
-> [AdvObject u a] -> AdvObject u a
listcat _ [] = mempty
listcat op (x:xs) = go x xs
where
go acc [] = acc
go acc (b:bs) = go (acc `op` b) bs
-- AdvObject does not have the same ability to be concatenated
-- as PosObject - all the advance vector says is \"where to go
-- next\". Nothing in the AdvObject tracks the boundary so we
-- cannot implement the Concat classes.
infixr 6 `advance`
-- | Draw the first AdvObject and use the advance vector to
-- displace the second AdvObject.
--
-- The final answer is the sum of both advance vectors.
--
advance :: (Monoid a, InterpretUnit u)
=> AdvObject u a -> AdvObject u a -> AdvObject u a
advance = mappend
-- | Concatenate the list of AdvObjects with 'advance'.
--
advances :: (Monoid a, InterpretUnit u)
=> [AdvObject u a] -> AdvObject u a
advances = mconcat
-- | Combine the AdvObjects using the answer vector of the
-- first object plus the separator to move the start of the second
-- object.
--
advspace :: (Monoid a, InterpretUnit u)
=> Vec2 u -> AdvObject u a -> AdvObject u a -> AdvObject u a
advspace sep a b = a `mappend` blank `mappend` b
where
blank = blankAdvObject sep
-- | List version of 'nextSpace'.
--
evenspace :: (Monoid a, InterpretUnit u)
=> Vec2 u -> [AdvObject u a] -> AdvObject u a
evenspace v = listcat (advspace v)
-- | Repeat the AdvObject @n@ times, moving each time with
-- 'advance'.
--
advrepeat :: (Monoid a, InterpretUnit u)
=> Int -> AdvObject u a -> AdvObject u a
advrepeat n = advances . replicate n
-- | Concatenate the list of AdvObjects, going next and adding
-- the separator at each step.
--
punctuate :: (Monoid a, InterpretUnit u)
=> AdvObject u a -> [AdvObject u a] -> AdvObject u a
punctuate sep = listcat (\a b -> a `advance` sep `advance` b)
-- | Render the supplied AdvObject, but swap the result advance
-- for the supplied vector. This function has behaviour analogue
-- to @fill@ in the @wl-pprint@ library.
--
advfill :: InterpretUnit u
=> Vec2 u -> AdvObject u a -> AdvObject u a
advfill sv mf = AdvObject $ \ctx pt ->
let (a,_,ca) = getAdvObject mf ctx pt
dav1 = DAV $ normalizeF (dc_font_size ctx) sv
in (a,dav1,ca)