{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Paths.PathBuilder -- Copyright : (c) Stephen Tetley 2011-2012 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Build relative paths monadically. -- -- \*\* WARNING \*\* this module is an experiment, and may -- change significantly or even be dropped from future revisions. -- -------------------------------------------------------------------------------- module Wumpus.Drawing.Paths.PathBuilder ( GenPathSpec , PathSpec , Vamp(..) , runGenPathSpec , execGenPathSpec , evalGenPathSpec , stripGenPathSpec , runPathSpec , runPathSpec_ , runPivot , penline , pencurve , breakPath , hpenline , vpenline , apenline , penlines , pathmoves , vamp , cycleSubPath , updatePen ) where import Wumpus.Drawing.Paths.Base import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space import Data.VectorSpace import Control.Applicative import Control.Monad import Data.Monoid import Prelude hiding ( null, cycle, lines ) -- -- TODO - possibly we need two drawing contexts one for the pen -- and one for the decoration trace. -- -- Alternatively PathSt should have a local DrawingContext for the -- pen. -- -- | Note - a path spec has an immutable start point like -- @LocDrawing@. -- -- Effectively a path is draw in a local coordinate system with -- @(0,0)@ as the origin. -- newtype GenPathSpec st u a = GenPathSpec { getGenPathSpec :: DrawingContext -> PathSt st -> (a, PathSt st, CatPrim) } type instance DUnit (GenPathSpec st u a) = u type instance UState (GenPathSpec st u a) = st type PathSpec u a = GenPathSpec () u a data PathSt st = PathSt { st_active_pen :: ActivePen , st_pen_ctx :: DrawingContext , st_cumulative_path :: AbsPath Double , st_user_state :: st } -- | Note - this formulation doesn\'t support monoidal append. -- -- Information gets lost for this one (we really would want to -- draw the left-hand-side): -- -- > PEN_DOWN _ _ `mappend` PEN_UP -- -- So it has to be part of the state not the writer. -- data ActivePen = PEN_UP | PEN_DOWN (AbsPath Double) zeroActivePen :: DPoint2 -> ActivePen zeroActivePen pt = PEN_DOWN (emptyPath pt) data Vamp u = Vamp { vamp_move :: Vec2 u , vamp_conn :: ConnectorGraphic u } type instance DUnit (Vamp u) = u -------------------------------------------------------------------------------- -- Instances -- Functor instance Functor (GenPathSpec st u) where fmap f ma = GenPathSpec $ \ctx s -> let (a,s1,w1) = getGenPathSpec ma ctx s in (f a,s1,w1) -- Applicative instance Applicative (GenPathSpec st u) where pure a = GenPathSpec $ \_ s -> (a, s, mempty) mf <*> ma = GenPathSpec $ \ctx s -> let (f,s1,w1) = getGenPathSpec mf ctx s (a,s2,w2) = getGenPathSpec ma ctx s1 in (f a, s2, w1 `mappend` w2) -- Monad instance Monad (GenPathSpec st u) where return a = GenPathSpec $ \_ s -> (a, s, mempty) ma >>= k = GenPathSpec $ \ctx s -> let (a,s1,w1) = getGenPathSpec ma ctx s (b,s2,w2) = (getGenPathSpec . k) a ctx s1 in (b, s2, w1 `mappend` w2) -- Monoid instance Monoid a => Monoid (GenPathSpec st u a) where mempty = GenPathSpec $ \_ s -> (mempty, s, mempty) ma `mappend` mb = GenPathSpec $ \ctx s -> let (a,s1,w1) = getGenPathSpec ma ctx s (b,s2,w2) = getGenPathSpec mb ctx s1 in (a `mappend` b, s2, w1 `mappend` w2) -- DrawingCtxM instance DrawingCtxM (GenPathSpec st u) where askDC = GenPathSpec $ \ctx s -> (ctx, s, mempty) asksDC f = GenPathSpec $ \ctx s -> (f ctx, s, mempty) localize upd ma = GenPathSpec $ \ctx s -> getGenPathSpec ma (upd ctx) s -- UserStateM instance UserStateM (GenPathSpec st u) where getState = GenPathSpec $ \_ s -> (st_user_state s, s, mempty) setState ust = GenPathSpec $ \_ s -> ((), s {st_user_state = ust} , mempty) updateState upd = GenPathSpec $ \_ s -> let ust = st_user_state s in ((), s {st_user_state = upd ust}, mempty) -- Note - all these need to peek at the cumulative path -- LocationM instance InterpretUnit u => LocationM (GenPathSpec st u) where location = locationImpl -- CursorM instance InterpretUnit u => CursorM (GenPathSpec st u) where moveby = movebyImpl -- InsertlM instance InterpretUnit u => InsertlM (GenPathSpec st u) where insertl = insertlImpl -------------------------------------------------------------------------------- -- Run functions runGenPathSpec :: InterpretUnit u => st -> PathMode -> GenPathSpec st u a -> LocImage u (a, st, AbsPath u) runGenPathSpec st mode ma = promoteLoc $ \pt -> askDC >>= \ctx -> let P2 dx dy = normalizeF (dc_font_size ctx) pt st_zero = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) st (a,s1,w1) = getGenPathSpec ma ctx st_zero dpath = translate dx dy $ st_cumulative_path s1 upath = dinterpF (dc_font_size ctx) dpath pctx = st_pen_ctx s1 (_,w2) = runImage pctx (renderActivePen mode $ st_active_pen s1) wfinal = cpmove (V2 dx dy) $ w1 `mappend` w2 in replaceAns (a, st_user_state s1, upath) $ primGraphic wfinal -- Note - eval and exec return the AbsPath this is as-per RWS -- which returns @w@ for execRWS (s,w) and evalRWS (a,w) -- evalGenPathSpec :: InterpretUnit u => st -> PathMode -> GenPathSpec st u a -> LocImage u (a, AbsPath u) evalGenPathSpec st mode ma = (\(a,_,w) -> (a,w)) <$> runGenPathSpec st mode ma execGenPathSpec :: InterpretUnit u => st -> PathMode -> GenPathSpec st u a -> LocImage u (st, AbsPath u) execGenPathSpec st mode ma = (\(_,s,w) -> (s,w)) <$> runGenPathSpec st mode ma stripGenPathSpec :: InterpretUnit u => st -> PathMode -> GenPathSpec st u a -> LocQuery u (a, st, AbsPath u) stripGenPathSpec st mode ma = stripLocImage $ runGenPathSpec st mode ma runPathSpec :: InterpretUnit u => PathMode -> PathSpec u a -> LocImage u (a, AbsPath u) runPathSpec mode ma = evalGenPathSpec () mode ma runPathSpec_ :: InterpretUnit u => PathMode -> PathSpec u a -> LocGraphic u runPathSpec_ mode ma = ignoreAns $ evalGenPathSpec () mode ma -- Monad run function nomenclature: -- -- > run - both -- > eval - answer (no state) -- > exec - state (no answer) -- -- Note RWS always returns the @w@. -- -- For Wumpus: -- -- > run - monadic answer, and the writer /construction/ -- > eval - just the monadic answer -- > exec - just the writer /construction/. -- -- In all case the CatPrim inside the LocImage may contain -- additional graphics. -- -- Client code can use @ignoreAns@ to generate a @LocGraphic@ -- from the @LocImage@. -- | Helper. -- renderActivePen :: PathMode -> ActivePen -> DGraphic renderActivePen _ PEN_UP = mempty renderActivePen mode (PEN_DOWN abs_path) = renderPath_ mode abs_path -- | Form a \"pivot path\" drawing from two path specifications. -- The start point of the drawing is the pivot formed by joining -- the paths. -- runPivot :: (Floating u, InterpretUnit u) => PathSpec u a -> PathSpec u a -> LocGraphic u runPivot ma mb = promoteLoc $ \pt -> askDC >>= \ctx -> let dpt = normalizeF (dc_font_size ctx) pt st_zero = PathSt (zeroActivePen zeroPt) ctx (emptyPath zeroPt) () (p1,s1,w1) = getGenPathSpec mz ctx st_zero dp1 = normalizeF (dc_font_size ctx) p1 v1 = pvec dpt dp1 pctx = st_pen_ctx s1 (_,w2) = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s1 wfinal = w1 `mappend` w2 in primGraphic $ cpmove (negateV v1) wfinal where mz = ma >> location >>= \pt -> mb >> return pt -------------------------------------------------------------------------------- -- operations locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u) locationImpl = GenPathSpec $ \ctx s -> let pt = tipR $ st_cumulative_path s upt = dinterpF (dc_font_size ctx) pt in (upt, s, mempty) -- | 'extendPaths' extends both the @cumulative_path@ and the -- @active_pen@. If the pen is up it, changes to a pendown. -- extendPaths :: DVec2 -> PathSt st -> PathSt st extendPaths v1 s@(PathSt { st_cumulative_path = cp , st_active_pen = pen} ) = s { st_cumulative_path = snocLine cp v1, st_active_pen = upd pen } where upd PEN_UP = let pt = tipR cp in PEN_DOWN $ line1 pt (pt .+^ v1) upd (PEN_DOWN absp) = PEN_DOWN $ snocLine absp v1 -- | Extend the path with a line, drawn by the pen. -- penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u () penline v1 = GenPathSpec $ \ctx s -> let sz = dc_font_size ctx dv1 = normalizeF sz v1 in ((), extendPaths dv1 s, mempty) -- | @extendPenC@ causes a pendown. -- extendPathsC :: DVec2 -> DVec2 -> DVec2 -> PathSt st -> PathSt st extendPathsC v1 v2 v3 s@(PathSt { st_cumulative_path = cp , st_active_pen = pen} ) = s { st_cumulative_path = snocCurve cp (v1,v2,v3), st_active_pen = upd pen } where upd PEN_UP = let p0 = tipR cp p1 = p0 .+^ v1 p2 = p1 .+^ v2 p3 = p2 .+^ v3 in PEN_DOWN $ curve1 p0 p1 p2 p3 upd (PEN_DOWN absp) = PEN_DOWN $ snocCurve absp (v1,v2,v3) -- | Extend the path with a curve, drawn by the pen. -- pencurve :: InterpretUnit u => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u () pencurve v1 v2 v3 = GenPathSpec $ \ctx s -> let sz = dc_font_size ctx dv1 = normalizeF sz v1 dv2 = normalizeF sz v2 dv3 = normalizeF sz v3 in ((), extendPathsC dv1 dv2 dv3 s, mempty) -- | @moveby@ causes a pen up. -- movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u () movebyImpl v1 = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) -> let sz = dc_font_size ctx dv1 = normalizeF sz v1 (_,w1) = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s cpath = snocLine (st_cumulative_path s) dv1 in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath }, w1) breakPath :: InterpretUnit u => GenPathSpec st u () breakPath = movebyImpl (V2 0 0) hpenline :: InterpretUnit u => u -> GenPathSpec st u () hpenline dx = penline (hvec dx) vpenline :: InterpretUnit u => u -> GenPathSpec st u () vpenline dy = penline (vvec dy) apenline :: (Floating u, InterpretUnit u) => Radian -> u -> GenPathSpec st u () apenline ang d = penline (avec ang d) penlines :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u () penlines = mapM_ penline pathmoves :: InterpretUnit u => [Vec2 u] -> GenPathSpec st u () pathmoves = mapM_ moveby insertlImpl :: InterpretUnit u => LocImage u a -> GenPathSpec st u a insertlImpl gf = GenPathSpec $ \ctx s -> let upt = dinterpF (dc_font_size ctx) (tipR $ st_cumulative_path s) (a,wcp) = runLocImage ctx upt gf in (a, s, wcp) vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u () vamp (Vamp v1 conn) = GenPathSpec $ \ctx s@(PathSt {st_pen_ctx = pctx}) -> let sz = dc_font_size ctx dv1 = normalizeF sz v1 (_,w1) = runImage pctx $ renderActivePen OSTROKE $ st_active_pen s upt = dinterpF sz (tipR $ st_cumulative_path s) (_,w2) = runConnectorImage ctx upt (upt .+^ v1) conn cpath = snocLine (st_cumulative_path s) dv1 in ((), s { st_active_pen = PEN_UP, st_cumulative_path = cpath } , w1 `mappend` w2) cycleSubPath :: DrawMode -> GenPathSpec st u () cycleSubPath mode = GenPathSpec $ \_ s@(PathSt {st_pen_ctx = pctx}) -> let (_,w1) = runImage pctx $ renderActivePen (fn mode) (st_active_pen s) in ((), s { st_active_pen = PEN_UP }, w1) where fn DRAW_STROKE = CSTROKE fn DRAW_FILL = CFILL fn DRAW_FILL_STROKE = CFILL_STROKE -- Design note -- -- Should pen changing be @local@ style vis the Reader monad or a -- state change with the State monad? -- -- Now switched to state change. -- -- | Note - updates the pen but doesn\'t draw, the final path -- will be drawing with the last updated context. -- updatePen :: DrawingContextF -> GenPathSpec st u () updatePen upd = GenPathSpec $ \_ s@(PathSt { st_pen_ctx = pctx}) -> ((), s { st_pen_ctx = upd pctx}, mempty )