{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Paths.Base.AbsBuilder -- Copyright : (c) Stephen Tetley 2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Build absolute paths monadically. -- -- \*\* WARNING \*\* this module is an experiment, and may -- change significantly or even be dropped from future revisions. -- -------------------------------------------------------------------------------- module Wumpus.Drawing.Paths.Base.AbsBuilder ( AbsBuild , runAbsBuild , execAbsBuild , evalAbsBuild , tip , absline , abscurve , absmove , relline , relcurve , relmove , rellineParallel , rellinePerpendicular , relmoveParallel , relmovePerpendicular , ctrlcurve , insert , vamp , cycle , setIncline -- * Derived operators , pen_colour , pen_width , hline , vline , aline , hmove , vmove , amove , line_up , line_down , line_left , line_right , line_up_left , line_up_right , line_down_left , line_down_right , line_north , line_south , line_east , line_west , line_northeast , line_northwest , line_southeast , line_southwest , move_up , move_down , move_left , move_right , move_up_left , move_up_right , move_down_left , move_down_right , move_north , move_south , move_east , move_west , move_northeast , move_northwest , move_southeast , move_southwest ) where import Wumpus.Drawing.Paths.Base.AbsPath import qualified Wumpus.Drawing.Paths.Base.AbsPath as A import Wumpus.Drawing.Paths.Base.BuildCommon import qualified Wumpus.Drawing.Paths.Base.RelPath as R import Wumpus.Basic.Geometry ( half_pi ) -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space import Data.VectorSpace import Control.Applicative hiding ( empty ) import Data.Monoid import Prelude hiding ( log, cycle ) -- State monad building is quite good - it ameliorates the problem -- of joining to the end point of an empty path... data St u = St { current_point :: Point2 u , current_incline :: Radian , cumulative_path :: AbsPath u , active_path :: (Point2 u, AbsPath u) , pen_dc_modifier :: DrawingContextF } type instance DUnit (St u) = u type Log u = BuildLog (Graphic u) -- | Absolute Path builder monad. -- newtype AbsBuild u a = AbsBuild { getAbsBuild :: St u -> (a, St u, Log u) } type instance DUnit (AbsBuild u a) = u -------------------------------------------------------------------------------- -- instances instance Functor (AbsBuild u) where fmap f mf = AbsBuild $ \s0 -> let (a,s1,w1) = getAbsBuild mf s0 in (f a, s1, w1) instance Applicative (AbsBuild u) where pure a = AbsBuild $ \s0 -> (a,s0,mempty) mf <*> ma = AbsBuild $ \s0 -> let (f,s1,w1) = getAbsBuild mf s0 (a,s2,w2) = getAbsBuild ma s1 in (f a,s2,w1 `mappend` w2) instance Monad (AbsBuild u) where return a = AbsBuild $ \s0 -> (a,s0,mempty) m >>= k = AbsBuild $ \s0 -> let (a,s1,w1) = getAbsBuild m s0 (b,s2,w2) = (getAbsBuild . k) a s1 in (b, s2, w1 `mappend` w2) -- | The initial state is needs the start point. -- initSt :: Floating u => Point2 u -> St u initSt pt = St { current_point = pt , current_incline = 0 , cumulative_path = empty pt , active_path = (pt, empty pt) , pen_dc_modifier = id } -- run - (path,graphic) -- exec - graphic -- eval - path -- | Note - runAbsBuild drops the monadic answer and returns the -- constructed path and a trace of the inserts and sub-paths. -- runAbsBuild :: (Floating u, InterpretUnit u) => Point2 u -> AbsBuild u a -> (AbsPath u, Graphic u) runAbsBuild pt mf = post $ getAbsBuild mf (initSt pt) where post (_,st,log) = let sub_last = snd $ active_path st cf = pen_dc_modifier st log_last = logSubPath PATH_OPEN cf sub_last log2 = log `mappend` log_last empty_gfx = emptyLocGraphic `at` pt (pen,ins) = extractTrace empty_gfx log2 in (cumulative_path st, pen `oplus` ins) -- | Run an 'AbsBuild' - return the Graphic formed by the pen -- trace and the insert trace, /forget/ the outline of the path. -- execAbsBuild :: (Floating u, InterpretUnit u) => Point2 u -> AbsBuild u a -> Graphic u execAbsBuild pt mf = snd $ runAbsBuild pt mf -- | Run an 'AbsBuild' - return the outline of the path, /forget/ -- the Graphic formed by the pen trace and the insert trace. -- evalAbsBuild :: (Floating u, InterpretUnit u) => Point2 u -> AbsBuild u a -> AbsPath u evalAbsBuild pt mf = fst $ runAbsBuild pt mf logSubPath :: InterpretUnit u => PathEnd -> DrawingContextF -> AbsPath u -> Log u logSubPath spe upd subp | A.null subp = mempty | otherwise = pen1 (toPrimPath subp >>= localize upd . drawF) where drawF = if spe == PATH_OPEN then openStroke else closedStroke tellSubClosed :: InterpretUnit u => DrawingContextF -> AbsPath u -> AbsBuild u () tellSubClosed upd subp = AbsBuild $ \s0 -> ((), s0, logSubPath PATH_CLOSED upd subp) tellSubOpen :: InterpretUnit u => DrawingContextF -> AbsPath u -> AbsBuild u () tellSubOpen upd subp = AbsBuild $ \s0 -> ((), s0, logSubPath PATH_OPEN upd subp) tellInsert :: Graphic u -> AbsBuild u () tellInsert g1 = AbsBuild $ \s0 -> ((),s0, insert1 g1) sets_ :: (St u -> St u) -> AbsBuild u () sets_ f = AbsBuild $ \s0 -> ((), f s0, mempty) gets :: (St u -> a) -> AbsBuild u a gets f = AbsBuild $ \s0 -> (f s0, s0, mempty) -------------------------------------------------------------------------------- -- operations tip :: AbsBuild u (Point2 u) tip = gets current_point -- | Helper - extend the path. -- extendPath :: (Point2 u -> AbsPath u -> AbsPath u) -> Point2 u -> AbsBuild u () extendPath fn end_pt = sets_ upd where upd = (\s pt i j -> s { current_point = end_pt , cumulative_path = fn pt i , active_path = bimapR (fn pt) j }) <*> current_point <*> cumulative_path <*> active_path absline :: Floating u => Point2 u -> AbsBuild u () absline p1 = extendPath (\_ acc -> acc `snocLineTo` p1) p1 abscurve :: (Floating u, Ord u, Tolerance u) => Point2 u -> Point2 u -> Point2 u -> AbsBuild u () abscurve p1 p2 p3 = extendPath (\_ acc -> snocCurveTo acc p1 p2 p3) p3 -- | 'absmove' is a pen up. -- absmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => Point2 u -> AbsBuild u () absmove p1 = gets active_path >>= \(_,ans) -> gets pen_dc_modifier >>= \cf -> tellSubOpen cf ans >> sets_ upd where upd = (\s i -> s { current_point = p1 , cumulative_path = i `snocLineTo` p1 , active_path = (p1, empty p1) }) <*> cumulative_path relline :: Floating u => Vec2 u -> AbsBuild u () relline v1 = gets current_point >>= \pt -> absline (pt .+^ v1) relcurve :: (Floating u, Ord u, Tolerance u) => Vec2 u -> Vec2 u -> Vec2 u -> AbsBuild u () relcurve v1 v2 v3 = gets current_point >>= \pt -> abscurve (pt .+^ v1) (pt .+^ v1 ^+^ v2) (pt .+^ v1 ^+^ v2 ^+^ v3) relmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => Vec2 u -> AbsBuild u () relmove v1 = gets current_point >>= \pt -> absmove (pt .+^ v1) rellineParallel :: Floating u => u -> AbsBuild u () rellineParallel u = gets current_incline >>= \ang -> relline (avec ang u) rellinePerpendicular :: Floating u => u -> AbsBuild u () rellinePerpendicular u = gets current_incline >>= \ang -> relline (avec (fn ang) u) where fn = circularModulo . (+ half_pi) relmoveParallel :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () relmoveParallel u = gets current_incline >>= \ang -> relmove (avec ang u) relmovePerpendicular :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () relmovePerpendicular u = gets current_incline >>= \ang -> relmove (avec (fn ang) u) where fn = circularModulo . (+ half_pi) ctrlcurve :: (Floating u, Ord u, Tolerance u) => Radian -> Radian -> Point2 u -> AbsBuild u () ctrlcurve cin cout p1 = extendPath (\p0 acc -> acc `append` controlCurve p0 cin cout p1) p1 insert :: Num u => LocGraphic u -> AbsBuild u () insert gf = gets current_point >>= \pt -> tellInsert (gf `at` pt) penCtxUpdate :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => DrawingContextF -> AbsBuild u () penCtxUpdate cf = relmove (V2 0 0) >> sets_ upd where upd = (\s f -> s { pen_dc_modifier = cf . f }) <*> pen_dc_modifier -- Note - vamps should be a data type then we can have libraries -- of them. vamp :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => Vamp u -> AbsBuild u () vamp (Vamp vnext vstart upd relp path_end) = gets current_point >>= \p0 -> relmove vnext >> drawF upd (R.toAbsPath (p0 .+^ vstart) relp) where drawF = if path_end == PATH_OPEN then tellSubOpen else tellSubClosed cycle :: (Floating u, InterpretUnit u) => AbsBuild u () cycle = gets current_point >>= \pt -> gets pen_dc_modifier >>= \cf -> gets active_path >>= \(start,acc) -> tellSubClosed cf (acc `snocLineTo` start) >> sets_ (\s -> s { active_path = (pt, empty pt)}) setIncline :: Radian -> AbsBuild u () setIncline ang = sets_ upd where upd = (\s -> s { current_incline = ang }) -------------------------------------------------------------------------------- -- Derived operators pen_colour :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => RGBi -> AbsBuild u () pen_colour rgb = penCtxUpdate (stroke_colour rgb) pen_width :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => Double -> AbsBuild u () pen_width d = penCtxUpdate (set_line_width d) hline :: Floating u => u -> AbsBuild u () hline dx = relline (hvec dx) vline :: Floating u => u -> AbsBuild u () vline dy = relline (vvec dy) aline :: Floating u => u -> AbsBuild u () aline u = gets current_incline >>= \ang -> relline (avec ang u) hmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () hmove dx = relmove (hvec dx) vmove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () vmove dy = relmove (vvec dy) amove :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () amove u = gets current_incline >>= \ang -> relmove (avec ang u) line_up :: Floating u => u -> AbsBuild u () line_up u = relline (vvec u) line_down :: Floating u => u -> AbsBuild u () line_down u = relline (vvec $ negate u) line_left :: Floating u => u -> AbsBuild u () line_left u = relline (hvec $ negate u) line_right :: Floating u => u -> AbsBuild u () line_right u = relline (hvec u) -- | Diagonal lines line_up_left :: Floating u => u -> AbsBuild u () line_up_left u = relline (vec (-u) u) line_up_right :: Floating u => u -> AbsBuild u () line_up_right u = relline (vec u u) line_down_left :: Floating u => u -> AbsBuild u () line_down_left u = relline (vec (-u) (-u)) line_down_right :: Floating u => u -> AbsBuild u () line_down_right u = relline (vec u (-u)) -- Cardinal lines line_north :: Floating u => u -> AbsBuild u () line_north = vline line_south :: Floating u => u -> AbsBuild u () line_south = vline . negate line_east :: Floating u => u -> AbsBuild u () line_east = hline line_west :: Floating u => u -> AbsBuild u () line_west = hline . negate line_northeast :: Floating u => u -> AbsBuild u () line_northeast = relline . avec (0.25 * pi) line_northwest :: Floating u => u -> AbsBuild u () line_northwest = relline . avec (0.75 * pi) line_southeast :: Floating u => u -> AbsBuild u () line_southeast = relline . avec (1.75 * pi) line_southwest :: Floating u => u -> AbsBuild u () line_southwest = relline . avec (1.25 * pi) move_up :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_up u = relmove (vvec u) move_down :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_down u = relmove (vvec $ negate u) move_left :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_left u = relmove (hvec $ negate u) move_right :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_right u = relmove (hvec u) -- | Diagonal moves move_up_left :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_up_left u = relmove (vec (-u) u) move_up_right :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_up_right u = relmove (vec u u) move_down_left :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_down_left u = relmove (vec (-u) (-u)) move_down_right :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_down_right u = relmove (vec u (-u)) -- Cardinal moves move_north :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_north = vmove move_south :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_south = vmove . negate move_east :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_east = hmove move_west :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_west = hmove . negate move_northeast :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_northeast = relmove . avec (0.25 * pi) move_northwest :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_northwest = relmove . avec (0.75 * pi) move_southeast :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_southeast = relmove . avec (1.75 * pi) move_southwest :: (Floating u, Ord u, Tolerance u, InterpretUnit u) => u -> AbsBuild u () move_southwest = relmove . avec (1.25 * pi)