module Wumpus.Drawing.Paths.Base.PathBuilder
(
GenPathSpec
, PathSpec
, Vamp(..)
, PathTerm(..)
, runGenPathSpec
, execGenPathSpec
, evalGenPathSpec
, stripGenPathSpec
, runPathSpec
, runPathSpec_
, runPivot
, penline
, pencurve
, breakPath
, hpenline
, vpenline
, apenline
, penlines
, pathmoves
, vamp
, cycleSubPath
, localPen
) where
import Wumpus.Drawing.Paths.Base.RelPath
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.AffineSpace
import Data.VectorSpace
import Control.Applicative
import Control.Monad
import Data.Monoid
import Prelude hiding ( null, cycle, lines )
newtype GenPathSpec st u a = GenPathSpec
{ getGenPathSpec :: DrawingContext -> DPoint2 -> PathSt st
-> (a, DPoint2, PathSt st, PathW) }
type instance DUnit (GenPathSpec st u a) = u
type instance UState (GenPathSpec st u) = st
type PathSpec u a = GenPathSpec () u a
data PathSt st = PathSt
{ st_active_pen :: ActivePen
, st_user_state :: st
}
data ActivePen = PEN_UP
| PEN_DOWN { ap_start_point :: Point2 Double
, ap_rel_path :: RelPath Double
}
zeroActivePath :: DPoint2 -> ActivePen
zeroActivePath pt = PEN_DOWN pt mempty
data PathW = PathW
{ w_rel_path :: RelPath Double
, w_trace :: CatPrim
}
instance Monoid PathW where
mempty = PathW mempty mempty
PathW a0 b0 `mappend` PathW a1 b1 = PathW (a0 `mappend` a1) (b0 `mappend` b1)
data PathTerm = PATH_OPEN | PATH_CLOSED DrawStyle
deriving (Eq,Show)
data Vamp u = Vamp
{ vamp_move :: Vec2 u
, vamp_conn :: ConnectorGraphic u
}
type instance DUnit (Vamp u) = u
instance Functor (GenPathSpec st u) where
fmap f ma = GenPathSpec $ \ctx pt s ->
let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s
in (f a,p1,s1,w1)
instance Applicative (GenPathSpec st u) where
pure a = GenPathSpec $ \_ pt s -> (a, pt, s, mempty)
mf <*> ma = GenPathSpec $ \ctx pt s ->
let (f,p1,s1,w1) = getGenPathSpec mf ctx pt s
(a,p2,s2,w2) = getGenPathSpec ma ctx p1 s1
in (f a, p2, s2, w1 `mappend` w2)
instance Monad (GenPathSpec st u) where
return a = GenPathSpec $ \_ pt s -> (a, pt, s, mempty)
ma >>= k = GenPathSpec $ \ctx pt s ->
let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s
(b,p2,s2,w2) = (getGenPathSpec . k) a ctx p1 s1
in (b, p2, s2, w1 `mappend` w2)
instance Monoid a => Monoid (GenPathSpec st u a) where
mempty = GenPathSpec $ \_ pt s -> (mempty, pt, s, mempty)
ma `mappend` mb = GenPathSpec $ \ctx pt s ->
let (a,p1,s1,w1) = getGenPathSpec ma ctx pt s
(b,p2,s2,w2) = getGenPathSpec mb ctx p1 s1
in (a `mappend` b, p2, s2, w1 `mappend` w2)
instance DrawingCtxM (GenPathSpec st u) where
askDC = GenPathSpec $ \ctx pt s -> (ctx, pt, s, mempty)
asksDC f = GenPathSpec $ \ctx pt s -> (f ctx, pt, s, mempty)
localize upd ma = GenPathSpec $ \ctx pt s ->
getGenPathSpec ma (upd ctx) pt s
instance UserStateM (GenPathSpec st u) where
getState = GenPathSpec $ \_ pt s ->
(st_user_state s, pt, s, mempty)
setState ust = GenPathSpec $ \_ pt s ->
((), pt, s {st_user_state = ust} , mempty)
updateState upd = GenPathSpec $ \_ pt s ->
let ust = st_user_state s
in ((), pt, s {st_user_state = upd ust}, mempty)
instance InterpretUnit u => LocationM (GenPathSpec st u) where
location = locationImpl
instance InterpretUnit u => CursorM (GenPathSpec st u) where
moveby = movebyImpl
instance InterpretUnit u => InsertlM (GenPathSpec st u) where
insertl = insertlImpl
runGenPathSpec :: InterpretUnit u
=> GenPathSpec st u a -> st -> PathTerm
-> LocImage u (a, st, RelPath u)
runGenPathSpec ma st term = promoteLoc $ \pt ->
askDC >>= \ctx ->
let dpt = normalizeF (dc_font_size ctx) pt
st_zero = PathSt (zeroActivePath dpt) st
(a,_,s,w) = getGenPathSpec ma ctx dpt st_zero
upath = dinterpF (dc_font_size ctx) $ w_rel_path w
(_,wcp) = runImage (drawActivePen term $ st_active_pen s) ctx
wfinal = w_trace w `mappend` wcp
in replaceAns (a, st_user_state s, upath) $ primGraphic wfinal
evalGenPathSpec :: InterpretUnit u
=> GenPathSpec st u a -> st -> PathTerm
-> LocImage u (a, RelPath u)
evalGenPathSpec ma st term =
(\(a,_,w) -> (a,w)) <$> runGenPathSpec ma st term
execGenPathSpec :: InterpretUnit u
=> GenPathSpec st u a -> st -> PathTerm
-> LocImage u (st, RelPath u)
execGenPathSpec ma st term =
(\(_,s,w) -> (s,w)) <$> runGenPathSpec ma st term
stripGenPathSpec :: InterpretUnit u
=> GenPathSpec st u a -> st -> PathTerm
-> LocQuery u (a, st, RelPath u)
stripGenPathSpec ma st term = stripLocImage $ runGenPathSpec ma st term
runPathSpec :: InterpretUnit u
=> PathSpec u a -> PathTerm -> LocImage u (a, RelPath u)
runPathSpec ma term = evalGenPathSpec ma () term
runPathSpec_ :: InterpretUnit u
=> PathSpec u a -> PathTerm -> LocGraphic u
runPathSpec_ ma term = ignoreAns $ evalGenPathSpec ma () term
drawActivePen :: PathTerm -> ActivePen -> DGraphic
drawActivePen _ PEN_UP = mempty
drawActivePen term (PEN_DOWN { ap_start_point = pt
, ap_rel_path = rp}) = case term of
PATH_OPEN -> ignoreAns $ drawOpenPath rp `at` pt
PATH_CLOSED styl -> ignoreAns $ drawClosedPath styl rp `at` pt
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 (zeroActivePath dpt) ()
(p1,_,s,w1) = getGenPathSpec mz ctx dpt st_zero
dp1 = normalizeF (dc_font_size ctx) p1
v1 = pvec dpt dp1
(_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx
wfinal = w_trace w1 `mappend` wcp
in primGraphic $ cpmove (negateV v1) wfinal
where
mz = ma >> location >>= \pt -> mb >> return pt
locationImpl :: InterpretUnit u => GenPathSpec st u (Point2 u)
locationImpl = GenPathSpec $ \ctx pt s ->
let upt = dinterpF (dc_font_size ctx) pt
in (upt, pt, s, mempty)
extendPen :: DPoint2 -> DVec2 -> ActivePen -> ActivePen
extendPen pt v PEN_UP = PEN_DOWN pt (line1 v)
extendPen _ v (PEN_DOWN p0 rp) = PEN_DOWN p0 (rp `snocLineTo` v)
penline :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()
penline v1 = GenPathSpec $ \ctx pt s ->
let sz = dc_font_size ctx
dv1 = normalizeF sz v1
pen = extendPen pt dv1 (st_active_pen s)
w1 = PathW { w_rel_path = line1 dv1, w_trace = mempty }
in ((), pt .+^ dv1, s { st_active_pen = pen }, w1)
extendPenC :: DPoint2 -> DVec2 -> DVec2 -> DVec2 -> ActivePen -> ActivePen
extendPenC pt v1 v2 v3 PEN_UP = PEN_DOWN pt (curve1 v1 v2 v3)
extendPenC _ v1 v2 v3 (PEN_DOWN p0 rp) = PEN_DOWN p0 (snocCurveTo rp v1 v2 v3)
pencurve :: InterpretUnit u
=> Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u ()
pencurve v1 v2 v3 = GenPathSpec $ \ctx pt s ->
let sz = dc_font_size ctx
dv1 = normalizeF sz v1
dv2 = normalizeF sz v2
dv3 = normalizeF sz v3
pen = extendPenC pt dv1 dv2 dv3 (st_active_pen s)
w1 = PathW { w_rel_path = line1 dv1, w_trace = mempty }
in ((), pt .+^ dv1, s { st_active_pen = pen }, w1)
movebyImpl :: InterpretUnit u => Vec2 u -> GenPathSpec st u ()
movebyImpl v1 = GenPathSpec $ \ctx pt s ->
let sz = dc_font_size ctx
dv1 = normalizeF sz v1
(_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx
w1 = PathW { w_rel_path = mempty, w_trace = wcp }
in ((), pt .+^ dv1, s { st_active_pen = PEN_UP }, 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 pt s ->
let upt = dinterpF (dc_font_size ctx) pt
(a,wcp) = runLocImage gf ctx upt
w1 = PathW { w_rel_path = mempty, w_trace = wcp }
in (a, pt, s, w1)
vamp :: InterpretUnit u => Vamp u -> GenPathSpec st u ()
vamp (Vamp v1 conn) = GenPathSpec $ \ctx pt s ->
let sz = dc_font_size ctx
dv1 = normalizeF sz v1
(_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx
upt = dinterpF sz pt
(_,ccp) = runConnectorImage conn ctx upt (upt .+^ v1)
w1 = PathW { w_rel_path = mempty, w_trace = wcp `mappend` ccp }
in ((), pt .+^ dv1, s { st_active_pen = PEN_UP }, w1)
cycleSubPath :: DrawStyle -> GenPathSpec st u ()
cycleSubPath styl = GenPathSpec $ \ctx pt s ->
let gf = drawActivePen (PATH_CLOSED styl) $ st_active_pen s
(_,wcp) = runImage gf ctx
w1 = PathW { w_rel_path = mempty, w_trace = wcp }
in ((), pt, s { st_active_pen = PEN_UP }, w1)
localPen :: DrawingContextF -> GenPathSpec st u a -> GenPathSpec st u a
localPen upd ma = GenPathSpec $ \ctx pt s ->
let (_,wcp) = runImage (drawActivePen PATH_OPEN $ st_active_pen s) ctx
(a,p1,s1,w1) = getGenPathSpec ma (upd ctx) pt s
w2 = let wcp2 = wcp `mappend` w_trace w1
in w1 { w_trace = wcp2 }
in (a, p1, s1 { st_active_pen = PEN_UP }, w2)