diff --git a/demo/ArrowCircuit.hs b/demo/ArrowCircuit.hs --- a/demo/ArrowCircuit.hs +++ b/demo/ArrowCircuit.hs @@ -77,26 +77,23 @@ -- Note - need a variant of /bar/ that draws UDLR only. -connWith :: ( TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) - , Real u, Floating u, InterpretUnit u ) - => Connector u -> Anchor u -> Anchor u -> m () +connWith :: ( Real u, Floating u, InterpretUnit u ) + => Connector u -> Anchor u -> Anchor u -> TraceDrawing u () connWith con a0 a1 = localize double_point_size $ drawc a0 a1 (rightArrow tri45 con) -atext :: ( CenterAnchor (t u) - , Real u, Floating u, InterpretUnit u - , TraceM m, DrawingCtxM m, u ~ MonUnit (m ()), u ~ DUnit (t u) ) - => t u -> String -> m () +atext :: ( CenterAnchor (t u), u ~ DUnit (t u) + , Real u, Floating u, InterpretUnit u) + => t u -> String -> TraceDrawing u () atext ancr ss = - draw $ ccTextline ss `at` (center ancr) + draw $ textline ss CENTER `at` (center ancr) -ptext :: ( Real u, Floating u, InterpretUnit u - , TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) - => Point2 u -> String -> m () +ptext :: (Floating u, InterpretUnit u) + => Point2 u -> String -> TraceDrawing u () ptext pt ss = localize (font_attr times_italic 14) $ - draw $ ccTextline ss `at` pt + draw $ textline ss CENTER `at` pt -- Note - return type is a LocImage not a shape... diff --git a/demo/Arrowheads.hs b/demo/Arrowheads.hs --- a/demo/Arrowheads.hs +++ b/demo/Arrowheads.hs @@ -76,7 +76,7 @@ tableGraphic :: [(String, ArrowTip)] -> TraceDrawing Double () tableGraphic tips = - drawl start $ chain_ chn_alg (map makeArrowDrawing tips) + drawl start $ runChain_ (mapM makeArrowDrawing tips) chn_alg where chn_alg = tableDown 18 (180,24) start = P2 0 480 @@ -87,12 +87,15 @@ -makeArrowDrawing :: (String, ArrowTip) -> LocGraphic Double -makeArrowDrawing (name, utip) = aconn `mappend` lbl +-- Note - /null/ chain action needs a better type synonym name. +-- +makeArrowDrawing :: (String, ArrowTip) -> Chain Double (UNil Double) +makeArrowDrawing (name, utip) = cnext (aconn `mappend` lbl) where aconn = ignoreAns $ promoteLoc $ \pt -> connect pt (displace (hvec 60) pt) (uniformArrow utip connline) lbl = ignoreAns $ promoteLoc $ \pt -> textline name WW `at` (displace (hvec 66) pt) + diff --git a/demo/Automata.hs b/demo/Automata.hs --- a/demo/Automata.hs +++ b/demo/Automata.hs @@ -62,7 +62,7 @@ -- infixr 1 `mat` -mat :: LocImage u a -> Query u (Point2 u) -> Image u a +mat :: InterpretUnit u => LocImage u a -> Query u (Point2 u) -> Image u a mat img mq = zapQuery mq >>= \pt -> img `at` pt state :: String -> DLocImage DCircle @@ -106,8 +106,6 @@ v1 = pvec ctr p1 zradius = vlength v1 zincl = vdirection v1 - - diff --git a/demo/ClipPic.hs b/demo/ClipPic.hs --- a/demo/ClipPic.hs +++ b/demo/ClipPic.hs @@ -39,12 +39,16 @@ std_ctx = standardContext 14 +-- Note - currently the code is quite messy, path drawing needs +-- some convenience combinators. + clip_pic :: CtxPicture clip_pic = drawTracing $ localize (fill_colour medium_slate_blue) $ do - drawl (P2 0 320) $ closedRelPath FILL path01 - drawl (P2 112 320) $ localize (fill_colour powder_blue) $ closedRelPath FILL path02 - drawl (P2 384 416) $ closedRelPath FILL path03 - drawl (P2 328 512) $ closedRelPath FILL path04 + drawl (P2 0 320) $ (drawClosedPath FILL =<< zapLocQ (extrPathSpec path01)) + drawl (P2 112 320) $ localize (fill_colour powder_blue) $ + (drawClosedPath FILL =<< zapLocQ (extrPathSpec path02)) + drawl (P2 384 416) $ (drawClosedPath FILL =<< zapLocQ (extrPathSpec path03)) + drawl (P2 328 512) $ (drawClosedPath FILL =<< zapLocQ (extrPathSpec path04)) drawl (P2 0 0) $ clip1 drawl (P2 112 0) $ clip2 drawl (P2 384 96) $ clip3 @@ -55,21 +59,32 @@ background rgb = promoteLoc $ \_ -> ignoreAns $ localize (text_colour rgb) $ ihh `at` P2 0 288 where - ihh = chain (tableDown 18 (86,16)) (replicate 112 iheartHaskell) + ihh = runChain (mapM cnext $ replicate 112 iheartHaskell) + (tableDown 18 (86,16)) +-- | This is one for Wumpus-Basic - the set of combinators to +-- shift between Images and Queries needs sorting out +-- +zapLocQ :: InterpretUnit u => LocQuery u a-> LocImage u a +zapLocQ ma = promoteLoc $ \pt -> + askDC >>= \ctx -> + let a = runLocQuery ma ctx pt + in return a clip1 :: LocGraphic Double -clip1 = locClip path01 $ background black +clip1 = zapLocQ (extrPathSpec path01) >>= \a -> + ignoreAns $ locClip a (background black) clip2 :: LocGraphic Double -clip2 = locClip path02 $ background medium_violet_red +clip2 = zapLocQ (extrPathSpec path02) >>= \a -> + locClip a (background medium_violet_red) clip3 :: LocGraphic Double -clip3 = locClip path03 $ background black +clip3 = zapLocQ (extrPathSpec path03) >>= \a -> locClip a (background black) clip4 :: LocGraphic Double -clip4 = locClip path04 $ background black +clip4 = zapLocQ (extrPathSpec path04) >>= \a -> locClip a (background black) iheartHaskell :: LocGraphic Double @@ -79,32 +94,42 @@ dcTextlabel "&heart;" `at` (pt .+^ hvec 7) in body `mappend` heart +-- Note - this needs a more uniform name. In Wumpus an object +-- that produces a @UNil@ is called a __Graphic but that +-- convention seems misleading here. +-- +type UPathSpec u = PathSpec u (UNil u) -- zeroPt -path01 :: RelPath Double -path01 = evalPathSpec $ hline 80 - >> line (vec 112 160) - >> line (vec (-112) 160) - >> hline (-80) - >> line (vec 112 (-160)) - >> line (vec (-112) (-160)) - +path01 :: UPathSpec Double +path01 = do + hlineto 80 + lineto (vec 112 160) + lineto (vec (-112) 160) + hlineto (-80) + lineto (vec 112 (-160)) + lineto (vec (-112) (-160)) + ureturn + + -- (P2 112 0) -path02 :: RelPath Double -path02 = evalPathSpec $ hline 80 - >> line (vec 72 112) - >> line (vec 72 (-112)) - >> hline 80 - >> line (vec (-224) 320) - >> hline (-80) - >> line (vec 112 (-160)) - >> line (vec (-112) (-160)) +path02 :: UPathSpec Double +path02 = do + hlineto 80 + lineto (vec 72 112) + lineto (vec 72 (-112)) + hlineto 80 + lineto (vec (-224) 320) + hlineto (-80) + lineto (vec 112 (-160)) + lineto (vec (-112) (-160)) + ureturn -- (P2 384 96) -path03 :: RelPath Double -path03 = evalPathSpec $ hline 96 >> vline 56 >> hline (-136) +path03 :: UPathSpec Double +path03 = hlineto 96 >> vlineto 56 >> hlineto (-136) >> ureturn -- (P2 328 192) -path04 :: RelPath Double -path04 = evalPathSpec $ hline 152 >> vline 56 >> hline (-192) +path04 :: UPathSpec Double +path04 = hlineto 152 >> vlineto 56 >> hlineto (-192) >> ureturn diff --git a/demo/ColourCharts.hs b/demo/ColourCharts.hs --- a/demo/ColourCharts.hs +++ b/demo/ColourCharts.hs @@ -43,7 +43,7 @@ makeDrawing row_count xs = drawTracing $ tableGraphic row_count xs tableGraphic :: Int -> [(String,RGBi)] -> TraceDrawing Double () -tableGraphic row_count xs = draw $ (chain_ chn gs) `at` pt +tableGraphic row_count xs = draw $ (runChain (mapM cnext gs) chn) `at` pt where chn = tableDown row_count (152,11) pt = displace (vvec $ fromIntegral $ 11 * row_count) zeroPt diff --git a/demo/Connectors.hs b/demo/Connectors.hs --- a/demo/Connectors.hs +++ b/demo/Connectors.hs @@ -63,7 +63,7 @@ tableGraphic :: [(String, Connector Double)] -> TraceDrawing Double () tableGraphic conns = - draw $ chain_ chn_alg (map makeConnDrawing conns) `at` start + draw $ runChain (mapM (cnext . makeConnDrawing) conns) chn_alg `at` start where chn_alg = tableDown 8 (180,64) start = P2 0 520 diff --git a/demo/DotPic.hs b/demo/DotPic.hs --- a/demo/DotPic.hs +++ b/demo/DotPic.hs @@ -69,7 +69,7 @@ tableGraphic :: [(String, DotLocImage Double)] -> TraceDrawing Double () tableGraphic imgs = - draw $ chain_ chn_alg (map makeDotDrawing imgs) `at` pt + draw $ runChain_ (mapM (cnext . makeDotDrawing) imgs) chn_alg `at` pt where row_count = 18 chn_alg = tableDown row_count (180,36) @@ -82,9 +82,12 @@ makeDotDrawing (name,df) = drawing `mappend` moveStart (vec 86 14) lbl where - drawing = execPathSpec $ - updatePen path_style >> - insertl dot >> mapM (\v -> line v >> insertl dot) steps + drawing = execPathSpec $ localize path_style $ + insertl dot >> + mapM (\v -> lineto v >> insertl dot) steps >> + ureturn + + lbl = ignoreAns $ promoteLoc $ \pt -> textline name WW `at` pt diff --git a/demo/FeatureModel.hs b/demo/FeatureModel.hs --- a/demo/FeatureModel.hs +++ b/demo/FeatureModel.hs @@ -74,7 +74,7 @@ => u -> String -> Point2 u -> TraceDrawing u (Box u) makeBox w ss pt = do a <- drawi $ (strokedShape $ rectangle w 20) `at` pt - drawl (center a) $ ccTextline ss + drawl (center a) $ textline ss CENTER return a box :: (Real u, Floating u, InterpretUnit u, Tolerance u) diff --git a/demo/FontPic.hs b/demo/FontPic.hs --- a/demo/FontPic.hs +++ b/demo/FontPic.hs @@ -56,14 +56,14 @@ positions = [0, 12, 27, 49, 78, 122] -- Note - this chain might be worth putting in a library... -pointChain :: (Int -> DLocGraphic) -> DLocImage DPoint2 -pointChain fn = chain chn_alg $ map fn point_sizes +pointChain :: (Int -> DLocGraphic) -> DLocGraphic +pointChain fn = runChain_ (mapM (cnext . fn) point_sizes) chn_alg where - chn_alg = linearChain $ iterationScheme start step + chn_alg = ChainScheme start step start = \pt -> (pt,point_sizes) - step (pt,[]) = ((displace (vvec 50) pt, []), pt) - step (pt,(y:ys)) = ((displace (vvec $ fromIntegral $ 2 + y) pt, ys), pt) + step _ (pt,[]) = (pt, (displace (vvec 50) pt, [])) + step _ (pt,(y:ys)) = (pt, (displace (vvec $ fromIntegral $ 2 + y) pt, ys)) fontGraphic :: RGBi -> FontDef -> DLocGraphic fontGraphic rgb ft = ignoreAns $ pointChain mkGF @@ -77,7 +77,7 @@ fontDrawing :: [(RGBi,FontDef)] -> CtxPicture fontDrawing xs = drawTracing $ - draw $ chain_ chn_alg (map (uncurry fontGraphic) xs) `at` start + draw $ runChain_ (mapM (cnext . uncurry fontGraphic) xs) chn_alg `at` start where chn_alg = tableDown 4 (1,180) start = P2 0 (4*180) diff --git a/demo/LeftRightText.hs b/demo/LeftRightText.hs --- a/demo/LeftRightText.hs +++ b/demo/LeftRightText.hs @@ -117,22 +117,22 @@ cc_oneline :: BoundedLocGraphic Double -cc_oneline = ccTextline "Center-center..." +cc_oneline = textline "Center-center..." CENTER blank_text :: BoundedLocGraphic Double -blank_text = blcTextline "" +blank_text = textline "" BLC left_text :: BoundedLocGraphic Double -left_text = multiAlignLeft dummy_text CENTER +left_text = multilineText VALIGN_LEFT dummy_text CENTER right_text :: BoundedLocGraphic Double -right_text = multiAlignRight dummy_text CENTER +right_text = multilineText VALIGN_RIGHT dummy_text CENTER center_text :: BoundedLocGraphic Double -center_text = multiAlignCenter dummy_text CENTER +center_text = multilineText VALIGN_CENTER dummy_text CENTER dummy_text :: String dummy_text = unlines $ [ "The quick brown" diff --git a/demo/PetriNet.hs b/demo/PetriNet.hs --- a/demo/PetriNet.hs +++ b/demo/PetriNet.hs @@ -124,15 +124,15 @@ lblParensParens :: DLocGraphic lblParensParens = - ignoreAns $ localize (set_font helvetica) $ ccTextline "(),()" + ignoreAns $ localize (set_font helvetica) $ textline "(),()" CENTER lblParensParensParens :: DLocGraphic lblParensParensParens = - ignoreAns $ localize (set_font helvetica) $ ccTextline "(),(),()" + ignoreAns $ localize (set_font helvetica) $ textline "(),(),()" CENTER lblBold :: String -> DLocGraphic lblBold ss = - ignoreAns $ localize (set_font helvetica_bold) $ ccTextline ss + ignoreAns $ localize (set_font helvetica_bold) $ textline ss CENTER diff --git a/demo/SampleShapes.hs b/demo/SampleShapes.hs --- a/demo/SampleShapes.hs +++ b/demo/SampleShapes.hs @@ -156,7 +156,7 @@ where shape = strokedShape $ setDecoration textF sh textF = promoteLocTheta $ \pt _ -> - ignoreAns (multiAlignCenter name CENTER) `at` pt + ignoreAns (multilineText VALIGN_CENTER name CENTER) `at` pt deg10 = d2r (10::Double) deg110 = d2r (110::Double) @@ -177,7 +177,7 @@ where (rpos,fn) = go cpos msg = ignoreAns $ moveStart (fn 10) $ - multiAlignCenter ss rpos + multilineText VALIGN_CENTER ss rpos go NORTH = (SS, go_north) go NORTH_EAST = (SW, go_north_east) diff --git a/demo/SingleChar.hs b/demo/SingleChar.hs --- a/demo/SingleChar.hs +++ b/demo/SingleChar.hs @@ -62,7 +62,7 @@ draw $ redPlus `at` P2 200 0 where - fn addr obj = illustrateBoundedLocGraphic $ (runPosObject addr obj) + fn addr obj = illustrateBoundedLocGraphic $ runPosObjectBBox obj addr redPlus :: (Fractional u, InterpretUnit u) => LocGraphic u diff --git a/demo/Symbols.hs b/demo/Symbols.hs --- a/demo/Symbols.hs +++ b/demo/Symbols.hs @@ -31,13 +31,13 @@ symbols :: CtxPicture symbols = udrawTracing (0::Double) $ do localize (set_font symbol) $ fontDelta $ draw $ - chain_ chn_alg (map sdraw all_letters) `at` start - fontDelta $ draw $ chain chn_alg (map ldraw all_letters) `at` start + runChain_ (mapM sdraw all_letters) chn_alg `at` start + fontDelta $ draw $ runChain (mapM ldraw all_letters) chn_alg `at` start where chn_alg = tableDown 30 (100,20) start = P2 0 (30*20) - sdraw (s,_) = dcTextlabel s - ldraw (_,name) = moveStart (hvec 16) (dcTextlabel name) + sdraw (s,_) = cnext $ dcTextlabel s + ldraw (_,name) = cnext $ moveStart (hvec 16) (dcTextlabel name) all_letters :: [(String, String)] diff --git a/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs b/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs --- a/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs +++ b/src/Wumpus/Drawing/Basis/DrawingPrimitives.hs @@ -24,13 +24,19 @@ module Wumpus.Drawing.Basis.DrawingPrimitives ( + -- * Monoid mappend + (<>) -- * Lines - hline + , hline , vline , pivotLine + , oStraightLines + , cStraightLines + + -- * Rectangles , blRectangle , ctrRectangle @@ -52,6 +58,20 @@ import Data.AffineSpace -- package: vector-space +import Data.Monoid + +infixr 6 <> + + +-- | Alias for mappend in Monoid. +-- +-- > <> (infixr 6) +-- +(<>) :: Monoid a => a -> a -> a +(<>) = mappend + + + -------------------------------------------------------------------------------- -- Lines @@ -76,6 +96,17 @@ pivotLine :: (Floating u, InterpretUnit u) => u -> u -> Radian -> LocGraphic u pivotLine lu ru ang = promoteLoc $ \pt -> straightLine (pt .+^ avec (ang+pi) lu) (pt .+^ avec ang ru) + + +-- | Draw an open path formed from straight line segments. +-- +oStraightLines :: InterpretUnit u => [Point2 u] -> Graphic u +oStraightLines ps = zapQuery (vertexPP ps) >>= dcOpenPath + +-- | Draw an closed path formed from straight line segments. +-- +cStraightLines :: InterpretUnit u => DrawStyle -> [Point2 u] -> Graphic u +cStraightLines sty ps = zapQuery (vertexPP ps) >>= dcClosedPath sty -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Drawing/Basis/LocTrace.hs b/src/Wumpus/Drawing/Basis/LocTrace.hs --- a/src/Wumpus/Drawing/Basis/LocTrace.hs +++ b/src/Wumpus/Drawing/Basis/LocTrace.hs @@ -56,6 +56,19 @@ import Control.Monad import Data.Monoid +-- +-- Note - there are no instances of DrawingCtxM for LocTrace or +-- LocTraceT. +-- +-- The type is not directly compatible as we are collecting +-- LocGraphic in a triple, but also localize would change the +-- interpretation of the vector cursor if the font-size changes. +-- + + + + + -- | LocTrace is a writer state monad. -- -- The writer accumulates a LocGraphic the state is a cumulative @@ -216,22 +229,23 @@ -instance Num u => LocTraceM (LocTrace u) where + +instance InterpretUnit u => LocTraceM (LocTrace u) where insertl gf = LocTrace $ \v0 -> ((), v0, moveStart v0 gf) moveBy v = LocTrace $ \v0 -> ((), v0 ^+^ v, mempty) location = LocTrace $ \v0 -> (v0, v0, mempty) -instance Num u => LocForkTraceM (LocTrace u) where +instance InterpretUnit u => LocForkTraceM (LocTrace u) where reset = LocTrace $ \_ -> ((), V2 0 0, mempty) branch ma = LocTrace $ \v0 -> let (a,_,o) = getLocTrace ma v0 in (a,v0,o) -instance (Monad m, Num u) => LocTraceM (LocTraceT u m) where +instance (Monad m, InterpretUnit u) => LocTraceM (LocTraceT u m) where insertl gf = LocTraceT $ \v0 -> return ((), v0, moveStart v0 gf) moveBy v = LocTraceT $ \v0 -> return ((), v0 ^+^ v, mempty) location = LocTraceT $ \v0 -> return (v0, v0, mempty) -instance (LocTraceM m, Num u) => LocForkTraceM (LocTraceT u m) where +instance (LocTraceM m, InterpretUnit u) => LocForkTraceM (LocTraceT u m) where reset = LocTraceT $ \_ -> return ((), V2 0 0, mempty) branch ma = LocTraceT $ \v0 -> getLocTraceT ma v0 >>= \(a,_,o) -> return (a,v0,o) diff --git a/src/Wumpus/Drawing/Basis/RefTrace.hs b/src/Wumpus/Drawing/Basis/RefTrace.hs --- a/src/Wumpus/Drawing/Basis/RefTrace.hs +++ b/src/Wumpus/Drawing/Basis/RefTrace.hs @@ -37,9 +37,14 @@ , runRefTrace , runRefTraceT - , unaryLink - , binaryLink - , multiwayLink + , Lookup + , RefGraphic + , lookup + , unary + , binary + , multiway + , oneToMany + ) where @@ -58,6 +63,7 @@ import qualified Data.IntMap as IntMap import Data.Maybe import Data.Monoid +import Prelude hiding ( lookup ) @@ -78,36 +84,60 @@ newtype Ref = Ref { getRefUid :: Int } --- GRAPHIC or LOC_GRAPHIC? cf. connectors... --- --- TODO - make this an newtype and only export an arity family of --- constructors. --- --- Maybe we only support the arity2 (connector) and list (path) cases? --- --- type Elaboration u ans = IntMap.IntMap ans -> Graphic u +type Lookup u ans = IntMap.IntMap ans -> Query u (Maybe ans) +type RefGraphic u ans = IntMap.IntMap ans -> Graphic u -data LinkRef u ans = - Unary { refU :: Ref - , ancrU :: ans -> Point2 u - , drawU :: LocGraphic u - } - | Binary { refB1 :: Ref - , refB2 :: Ref - , ancrB1 :: ans -> Point2 u - , ancrB2 :: ans -> Point2 u - , drawB :: ConnectorGraphic u - } - | Multiway { refLs :: [Ref] - , ancrM :: ans -> Point2 u - , drawM :: [Point2 u] -> Graphic u - } +lookup :: Ref -> Lookup u ans +lookup ref = \im -> return $ IntMap.lookup (getRefUid ref) im + + +unary :: InterpretUnit u + => (ans -> Graphic u) + -> Ref + -> RefGraphic u ans +unary gf r1 = \im -> + zapQuery (lookup r1 im) >>= maybe mempty gf + + + +binary :: InterpretUnit u + => (ans -> ans -> Graphic u) + -> Ref -> Ref + -> RefGraphic u ans +binary gf r1 r2 = \im -> + zapQuery (both (lookup r1 im) (lookup r2 im)) >>= \(ma,mb) -> + case (ma,mb) of + (Just a, Just b) -> gf a b + _ -> mempty + + +multiway :: InterpretUnit u + => ([ans] -> Graphic u) + -> [Ref] + -> RefGraphic u ans +multiway gf rs = \im -> + zapQuery (fmap catMaybes $ mapM (\r -> lookup r im) rs) >>= gf + + +oneToMany :: InterpretUnit u + => (ans -> [ans] -> Graphic u) + -> Ref -> [Ref] + -> RefGraphic u ans +oneToMany gf r1 rs = \im -> + zapQuery (both (lookup r1 im) (allrefs im rs)) >>= \(ma,xs) -> + maybe mempty (\a -> gf a xs) ma + where + allrefs im = fmap catMaybes . mapM (\r -> lookup r im) + + + + data RefSt u z = RefSt { uid_count :: Int , current_tip :: Vec2 u , ref_acc :: LocImage u (IntMap.IntMap z) - , ref_links :: JL.JoinList (LinkRef u z) + , ref_links :: JL.JoinList (RefGraphic u z) } @@ -176,13 +206,13 @@ -- LocTraceM -instance Num u => LocTraceM (RefTrace u z) where +instance InterpretUnit u => LocTraceM (RefTrace u z) where insertl gf = RefTrace $ \s0 -> ((), insertSt gf s0) moveBy v = RefTrace $ \s0 -> ((), moveSt v s0) location = RefTrace $ \s0 -> (current_tip s0, s0) -instance (Monad m, Num u) => LocTraceM (RefTraceT u z m) where +instance (Monad m, InterpretUnit u) => LocTraceM (RefTraceT u z m) where insertl gf = RefTraceT $ \s0 -> return ((), insertSt gf s0) moveBy v = RefTraceT $ \s0 -> return ((), moveSt v s0) location = RefTraceT $ \s0 -> return (current_tip s0, s0) @@ -191,13 +221,14 @@ -- Run functions -runRefTrace :: Num u => RefTrace u ans a -> LocImage u a +runRefTrace :: InterpretUnit u => RefTrace u ans a -> LocImage u a runRefTrace mf = post $ getRefTrace mf zeroRefSt where post (a,st) = replaceAns a $ reconcileRefSt st -runRefTraceT :: (Monad m, Num u) => RefTraceT u ans m a -> m (LocImage u a) +runRefTraceT :: (Monad m, InterpretUnit u) + => RefTraceT u ans m a -> m (LocImage u a) runRefTraceT mf = liftM post $ getRefTraceT mf zeroRefSt where post (a,st) = replaceAns a $ reconcileRefSt st @@ -206,38 +237,22 @@ -- Note we have to drop the vector -reconcileRefSt :: RefSt u z -> LocGraphic u +reconcileRefSt :: InterpretUnit u => RefSt u z -> LocGraphic u reconcileRefSt st = - step (ref_acc st) (JL.toList $ ref_links st) + ignoreAns $ selaborate (ref_acc st) + (\a -> mconcat $ map (fn a) $ JL.toList $ ref_links st) where - step img xs = ignoreAns $ elaborate img (\a -> mconcat $ map (fn a) xs) - - fn im (Unary r1 ar1 gf) = - maybe mempty (\pt -> promoteLoc $ \_ -> applyLoc gf pt) (projectRef r1 ar1 im) - - fn im (Binary r1 r2 ar1 ar2 conn) = - case (projectRef r1 ar1 im, projectRef r2 ar2 im) of - (Just p1, Just p2) -> promoteLoc $ \_ -> applyConn conn p1 p2 - _ -> mempty - - - fn im (Multiway rs ar1 gf) = - let ps = catMaybes $ map (\a -> projectRef a ar1 im) rs - in promoteLoc $ \_ -> gf ps - + fn im g = promoteLoc $ \_ -> g im -projectRef :: Ref -> (ans -> Point2 u) -> IntMap.IntMap ans -> Maybe (Point2 u) -projectRef r ancr im = ancr <$> IntMap.lookup (getRefUid r) im - -- Note - probably this supports Tree which is not a Trace monad... class Monad m => RefTraceM (m :: * -> *) where type MonRef m :: * insertRef :: (MonRef m ~ a, MonUnit (m ()) ~ u) => LocImage u a -> m Ref - linkRef :: (MonRef m ~ a, MonUnit (m ()) ~ u) => LinkRef u a -> m () + linkRef :: (MonRef m ~ a, MonUnit (m ()) ~ u) => RefGraphic u a -> m () -instance Num u => RefTraceM (RefTrace u z) where +instance InterpretUnit u => RefTraceM (RefTrace u z) where type MonRef (RefTrace u z) = z insertRef img = RefTrace $ \s0 -> let (ix,s1) = incrementSt img s0 in (Ref ix, s1) @@ -245,21 +260,23 @@ linkRef fn = RefTrace $ \s0 -> ((), snocLink fn s0) + + moveSt :: Num u => Vec2 u -> RefStF u z moveSt v = (\s i -> s { current_tip = i ^+^ v }) <*> current_tip -insertSt :: Num u => LocImage u z2 -> RefStF u ans +insertSt :: InterpretUnit u => LocImage u z2 -> RefStF u ans insertSt gf = (\s ac v1 -> let g1 = ignoreAns $ moveStart v1 gf - in s { ref_acc = decorate ac g1 }) + in s { ref_acc = sdecorate ac g1 }) <*> ref_acc <*> current_tip -snocLink :: LinkRef u ans -> RefStF u ans +snocLink :: RefGraphic u ans -> RefStF u ans snocLink fn = (\s i -> s { ref_links = JL.snoc i fn }) <*> ref_links -incrementSt :: Num u +incrementSt :: InterpretUnit u => LocImage u ans -> RefSt u ans -> (Int, RefSt u ans) incrementSt img s0 = (uid_count s0, upd s0) where @@ -272,26 +289,4 @@ -unaryLink :: (ans -> Point2 u) -> LocGraphic u -> Ref -> LinkRef u ans -unaryLink f gf = \r1 -> Unary { refU = r1 - , ancrU = f - , drawU = gf - } -binaryLink :: (ans -> Point2 u) -> (ans -> Point2 u) - -> ConnectorGraphic u -> Ref -> Ref - -> LinkRef u ans -binaryLink f g conn = \r1 r2 -> Binary { refB1 = r1 - , refB2 = r2 - , ancrB1 = f - , ancrB2 = g - , drawB = conn - } - - -multiwayLink :: (ans -> Point2 u) -> ([Point2 u] -> Graphic u) -> [Ref] - -> LinkRef u ans -multiwayLink f gf = \rs -> Multiway { refLs = rs - , ancrM = f - , drawM = gf - } diff --git a/src/Wumpus/Drawing/Basis/TraceGraphic.hs b/src/Wumpus/Drawing/Basis/TraceGraphic.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Basis/TraceGraphic.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Basis.TraceGraphic --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Build multi-part Graphics with an accumulator (i.e. a Writer --- monad). --- --- Note - the run functions for the transformer and the plain --- monad are quite different. This is mandated by the need to --- single-thread the DrawingContext through the transformer. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Basis.TraceGraphic - ( - TraceGraphic - , TraceGraphicT - - , TraceGraphicM(..) - - , runTraceGraphic - , runTraceGraphicT - - , liftTraceGraphicT - - ) where - - -import Wumpus.Basic.Kernel -- package: wumpus-basic - -import Control.Applicative -import Data.Monoid - - - -newtype TraceGraphic u a = TraceGraphic { - getTraceGraphic :: DrawingContext -> (a, CatPrim) } - - -newtype TraceGraphicT u m a = TraceGraphicT { - getTraceGraphicT :: DrawingContext -> m (a, CatPrim) } - - -type instance MonUnit (TraceGraphic u a) = u -type instance MonUnit (TraceGraphicT u m a) = u - - --- Functor - -instance Functor (TraceGraphic u) where - fmap f ma = TraceGraphic $ \ctx -> let (a,w1) = getTraceGraphic ma ctx - in (f a,w1) - - -instance Monad m => Functor (TraceGraphicT u m) where - fmap f ma = TraceGraphicT $ \ctx -> getTraceGraphicT ma ctx >>= \(a,w1) -> - return (f a,w1) - - --- Applicative - -instance Applicative (TraceGraphic u) where - pure a = TraceGraphic $ \_ -> (a, mempty) - mf <*> ma = TraceGraphic $ \ctx -> - let (f,w1) = getTraceGraphic mf ctx - (a,w2) = getTraceGraphic ma ctx - in (f a,w1 `mappend` w2) - - -instance Monad m => Applicative (TraceGraphicT u m) where - pure a = TraceGraphicT $ \_ -> return (a, mempty) - mf <*> ma = TraceGraphicT $ \ctx -> - getTraceGraphicT mf ctx >>= \(f,w1) -> - getTraceGraphicT ma ctx >>= \(a,w2) -> - return (f a,w1 `mappend` w2) - - - --- Monad - -instance Monad (TraceGraphic u) where - return a = TraceGraphic $ \_ -> (a, mempty) - ma >>= k = TraceGraphic $ \ctx -> - let (a,w1) = getTraceGraphic ma ctx - (b,w2) = (getTraceGraphic . k) a ctx - in (b, w1 `mappend` w2) - - -instance Monad m => Monad (TraceGraphicT u m) where - return a = TraceGraphicT $ \_ -> return (a, mempty) - ma >>= k = TraceGraphicT $ \ctx -> - getTraceGraphicT ma ctx >>= \(a,w1) -> - (getTraceGraphicT . k) a ctx >>= \(b,w2) -> - return (b, w1 `mappend` w2) - - - --- DrawingCtxM - -instance DrawingCtxM (TraceGraphic u) where - askDC = TraceGraphic $ \ctx -> (ctx, mempty) - asksDC f = TraceGraphic $ \ctx -> (f ctx, mempty) - localize upd ma = TraceGraphic $ \ctx -> getTraceGraphic ma (upd ctx) - - - -instance Monad m => DrawingCtxM (TraceGraphicT u m) where - askDC = TraceGraphicT $ \ctx -> return (ctx, mempty) - asksDC f = TraceGraphicT $ \ctx -> return (f ctx, mempty) - localize upd ma = TraceGraphicT $ \ctx -> getTraceGraphicT ma (upd ctx) - - - --- TraceGraphicM - -class Monad m => TraceGraphicM m where - tellImage :: MonUnit (m ()) ~ u => Image u a -> m a - tellImage_ :: MonUnit (m ()) ~ u => Image u a -> m () - - tellImage_ ma = tellImage ma >> return () - - -instance TraceGraphicM (TraceGraphic u) where - tellImage img = TraceGraphic $ \ctx -> - let (PrimW o a) = runImage ctx img in (a,o) - - tellImage_ img = TraceGraphic $ \ctx -> - let (PrimW o _) = runImage ctx img in ((),o) - - -instance Monad m => TraceGraphicM (TraceGraphicT u m) where - tellImage img = TraceGraphicT $ \ctx -> - let (PrimW o a) = runImage ctx img in return (a,o) - - tellImage_ img = TraceGraphicT $ \ctx -> - let (PrimW o _) = runImage ctx img in return ((),o) - - -runTraceGraphic :: TraceGraphic u a -> Image u a -runTraceGraphic mf = askDC >>= \ctx -> let (a,o) = getTraceGraphic mf ctx - in replaceAns a $ primGraphic o - - --- | Note - this needs DrawingContext as an explicit parameter, --- and hence it returns a pair of @(a, HPrim u)@ rather than an --- Image. --- --- It is expected this will be wrapped in to form a specific --- TraceDrawing /draw/ function for the amalgamated monad. --- -runTraceGraphicT :: Monad m - => DrawingContext -> TraceGraphicT u m a -> m (a, HPrim u) -runTraceGraphicT ctx mf = - getTraceGraphicT mf ctx >>= \(a,o) -> return (a, singleH o) - - -liftTraceGraphicT :: Monad m => m a -> TraceGraphicT u m a -liftTraceGraphicT ma = TraceGraphicT $ \_ -> ma >>= \a -> return (a,mempty) - diff --git a/src/Wumpus/Drawing/Connectors/Arrowheads.hs b/src/Wumpus/Drawing/Connectors/Arrowheads.hs --- a/src/Wumpus/Drawing/Connectors/Arrowheads.hs +++ b/src/Wumpus/Drawing/Connectors/Arrowheads.hs @@ -59,6 +59,7 @@ ) where +import Wumpus.Drawing.Basis.DrawingPrimitives import Wumpus.Drawing.Connectors.Base import Wumpus.Drawing.Paths.Absolute @@ -83,24 +84,21 @@ filledTipPath :: PointGen -> LocThetaGraphic En -filledTipPath fn = +filledTipPath gen = localize fill_use_stroke_colour $ promoteLocTheta $ \pt theta -> - let vs = fn theta - in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcClosedPath FILL + cStraightLines FILL $ map (pt .+^) $ gen theta closedTipPath :: PointGen -> LocThetaGraphic En -closedTipPath fn = +closedTipPath gen = localize solid_stroke_tip $ promoteLocTheta $ \pt theta -> - let vs = fn theta - in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcClosedPath STROKE + cStraightLines STROKE $ map (pt .+^) $ gen theta openTipPath :: PointGen -> LocThetaGraphic En -openTipPath fn = +openTipPath gen = localize solid_stroke_tip $ promoteLocTheta $ \pt theta -> - let vs = fn theta - in zapQuery (vertexPP $ map (pt .+^) vs) >>= dcOpenPath + oStraightLines $ map (pt .+^) $ gen theta diff --git a/src/Wumpus/Drawing/Connectors/Base.hs b/src/Wumpus/Drawing/Connectors/Base.hs --- a/src/Wumpus/Drawing/Connectors/Base.hs +++ b/src/Wumpus/Drawing/Connectors/Base.hs @@ -134,7 +134,7 @@ mid_ang = tipDirectionL len full_path tip = applyLocTheta deco (tipL full_path) mid_ang in replaceAns full_path $ - decorate tip $ zapQuery (toPrimPath short_path) >>= dcOpenPath + sdecorate tip $ drawOpenPath short_path @@ -152,7 +152,7 @@ mid_ang = tipDirectionR len full_path tip = applyLocTheta deco (tipR full_path) mid_ang in replaceAns full_path $ - decorate tip $ zapQuery (toPrimPath short_path) >>= dcOpenPath + sdecorate tip $ drawOpenPath short_path @@ -173,8 +173,8 @@ tipl = applyLocTheta decol (tipL full_path) mid_angl tipr = applyLocTheta decor (tipR full_path) mid_angr in replaceAns full_path $ - decorate (tipl `mappend` tipr) $ - zapQuery (toPrimPath short_path) >>= dcOpenPath + sdecorate (tipl `mappend` tipr) $ drawOpenPath short_path + diff --git a/src/Wumpus/Drawing/Dots/AnchorDots.hs b/src/Wumpus/Drawing/Dots/AnchorDots.hs --- a/src/Wumpus/Drawing/Dots/AnchorDots.hs +++ b/src/Wumpus/Drawing/Dots/AnchorDots.hs @@ -65,7 +65,6 @@ import Wumpus.Drawing.Dots.SimpleDots ( MarkSize ) import qualified Wumpus.Drawing.Dots.SimpleDots as SD -import Wumpus.Drawing.Text.Base.RotTextZero import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel @@ -265,7 +264,8 @@ dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u -dotText ss = fmap bboxRectAnchor $ ccTextline ss +dotText ss = + fmap bboxRectAnchor $ runPosObjectBBox (posText ss) CENTER -- Note - maybe Wumpus-Basic should have a @swapAns@ function? @@ -334,8 +334,9 @@ dotTriangle = intoLocImage (triangleLDO 1) SD.dotTriangle -intoLocImage :: LocQuery u a -> LocImage u z -> LocImage u a -intoLocImage mq gf = promoteLoc $ \pt -> +intoLocImage :: InterpretUnit u + => LocQuery u a -> LocImage u z -> LocImage u a +intoLocImage ma gf = promoteLoc $ \pt -> askDC >>= \ctx -> - let ans = runLocQuery pt ctx mq + let ans = runLocQuery ma ctx pt in replaceAns ans $ applyLoc gf pt diff --git a/src/Wumpus/Drawing/Dots/SimpleDots.hs b/src/Wumpus/Drawing/Dots/SimpleDots.hs --- a/src/Wumpus/Drawing/Dots/SimpleDots.hs +++ b/src/Wumpus/Drawing/Dots/SimpleDots.hs @@ -42,7 +42,10 @@ , dotChar , dotText + , dotEscChar + , dotEscText + , dotHLine , dotVLine , dotX @@ -65,7 +68,6 @@ ) where -import Wumpus.Drawing.Text.Base.RotTextZero import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel @@ -143,8 +145,17 @@ dotText :: (Real u, Floating u, InterpretUnit u) => String -> LocGraphic u -dotText ss = ignoreAns $ ccTextline ss +dotText ss = ignoreAns $ runPosObject (posText ss) CENTER +dotEscChar :: (Real u, Floating u, InterpretUnit u) + => EscapedChar -> LocGraphic u +dotEscChar = dotEscText . wrapEscChar + +dotEscText :: (Real u, Floating u, InterpretUnit u) + => EscapedText -> LocGraphic u +dotEscText esc = ignoreAns $ runPosObject (posEscText esc) CENTER + +-- TODO - need Upright versions of dots... diff --git a/src/Wumpus/Drawing/Extras/Grids.hs b/src/Wumpus/Drawing/Extras/Grids.hs --- a/src/Wumpus/Drawing/Extras/Grids.hs +++ b/src/Wumpus/Drawing/Extras/Grids.hs @@ -197,7 +197,7 @@ -minorMajor :: Num u +minorMajor :: InterpretUnit u => Int -> Int -> Vec2 u -> LocGraphic u -> LocGraphic u -> LocGraphic u minorMajor count alt mv mnr mjr = execLocTrace (step count) diff --git a/src/Wumpus/Drawing/Paths/Base/AbsPath.hs b/src/Wumpus/Drawing/Paths/Base/AbsPath.hs --- a/src/Wumpus/Drawing/Paths/Base/AbsPath.hs +++ b/src/Wumpus/Drawing/Paths/Base/AbsPath.hs @@ -49,8 +49,10 @@ -- * Conversion , toPrimPath - , openAbsPath - , closedAbsPath + , drawOpenPath + , drawOpenPath_ + , drawClosedPath + , drawClosedPath_ -- * Shortening , shortenPath @@ -403,16 +405,26 @@ -openAbsPath :: InterpretUnit u - => AbsPath u -> Image u (AbsPath u) -openAbsPath rp = replaceAns rp $ +drawOpenPath :: InterpretUnit u + => AbsPath u -> Image u (AbsPath u) +drawOpenPath rp = replaceAns rp $ zapQuery (toPrimPath rp) >>= dcOpenPath -closedAbsPath :: InterpretUnit u - => DrawStyle -> AbsPath u -> Image u (AbsPath u) -closedAbsPath sty rp = replaceAns rp $ +drawOpenPath_ :: InterpretUnit u + => AbsPath u -> Graphic u +drawOpenPath_ rp = zapQuery (toPrimPath rp) >>= dcOpenPath + + +drawClosedPath :: InterpretUnit u + => DrawStyle -> AbsPath u -> Image u (AbsPath u) +drawClosedPath sty rp = replaceAns rp $ zapQuery (toPrimPath rp) >>= dcClosedPath sty + + +drawClosedPath_ :: InterpretUnit u + => DrawStyle -> AbsPath u -> Graphic u +drawClosedPath_ sty rp = zapQuery (toPrimPath rp) >>= dcClosedPath sty -- | Turn a Path into an ordinary PrimPath. diff --git a/src/Wumpus/Drawing/Paths/Base/PathBuilder.hs b/src/Wumpus/Drawing/Paths/Base/PathBuilder.hs --- a/src/Wumpus/Drawing/Paths/Base/PathBuilder.hs +++ b/src/Wumpus/Drawing/Paths/Base/PathBuilder.hs @@ -23,38 +23,33 @@ LocTraceM(..) -- re-export + , GenPathSpec , PathSpec - , PathSpecT + , Vamp(..) - , Vamp - , PathTerm(..) - , makeVamp + , runGenPathSpec , runPathSpec , execPathSpec , evalPathSpec - - , runPathSpecT - , execPathSpecT - , evalPathSpecT - - , execPivot - , execPivotT - - - , PathOpM(..) - + , extrPathSpec - -- * Derived operators - , pen_colour - , pen_width +-- , execPivot - , lines + , pathTip - , hline - , vline - , aline + , lineto + , curveto + , moveto + + , breakPath + , hlineto + , vlineto + , alineto + , vamp + , cycleSubPath + , localPen ) where @@ -68,7 +63,8 @@ import Wumpus.Core -- package: wumpus-core -import Data.VectorSpace -- package: vector-space +import Data.AffineSpace -- package: vector-space +-- import Data.VectorSpace import Control.Applicative import Control.Monad @@ -76,241 +72,210 @@ 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 instance MonUnit (GenPathSpec st u a) = u +type PathSpec u a = GenPathSpec () u a --- | The vector part of the @active_path@ is its start point. --- This allows cycled paths. --- -data BuildSt u = BuildSt - { cumulative_tip :: Vec2 u - , cumulative_path :: RelPath u - , current_incline :: Radian - , active_path :: ActivePath u - , pen_trace :: LocGraphic u - , ins_trace :: LocGraphic u - , pen_dc_modifier :: DrawingContextF +data PathSt st = PathSt + { st_active_pen :: ActivePen + , st_user_state :: st } - -- TODO - is incline worthwhile? - --- | The vector for @PEN_DOWN@ is the start-point not the current --- tip. +-- | Note - this formulation doesn\'t support monoidal append. -- --- Startpoint is needed for cycling a path. +-- 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 ActivePath u = PEN_UP - | PEN_DOWN (Vec2 u) (RelPath u) - +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 -type instance DUnit (BuildSt u) = u -type instance DUnit (ActivePath u) = u +data PathW = PathW + { w_rel_path :: RelPath Double + , w_trace :: CatPrim + } -newtype PathSpec u a = PathSpec { - getPathSpec :: BuildSt u -> (a, BuildSt u) } +instance Monoid PathW where + mempty = PathW mempty mempty + PathW a0 b0 `mappend` PathW a1 b1 = PathW (a0 `mappend` a1) (b0 `mappend` b1) -newtype PathSpecT u m a = PathSpecT { - getPathSpecT :: BuildSt u -> m (a, BuildSt u) } --- Note - splitting the state between BuildSt and the /path tip/ --- in LocTrace as actually detrimental to clarity of the code --- below. It would make some sense to add the tip and the insert --- trace to @BuildSt@ so everything is in one place. - - -type instance MonUnit (PathSpec u a) = u -type instance MonUnit (PathSpecT u m a) = u +data PathTerm = SUBPATH_OPEN | SUBPATH_CLOSED DrawStyle + deriving (Eq,Show) --- | Vamps... --- -data Vamp u = Vamp +data Vamp u = Vamp { vamp_move :: Vec2 u - , vamp_path :: RelPath u - , vamp_term :: PathTerm + , vamp_conn :: ConnectorGraphic u } - type instance DUnit (Vamp u) = u -data PathTerm = SUBPATH_OPEN | SUBPATH_CLOSED DrawStyle - deriving (Eq,Show) - - -makeVamp :: Vec2 u -> RelPath u -> PathTerm -> Vamp u -makeVamp v1 ph pe = Vamp { vamp_move = v1 - , vamp_path = ph - , vamp_term = pe - } - - -------------------------------------------------------------------------------- --- instances +-- Instances -- Functor -instance Functor (PathSpec u) where - fmap f mf = PathSpec $ \s0 -> let (a,s1) = getPathSpec mf s0 in (f a,s1) - -instance Monad m => Functor (PathSpecT u m) where - fmap f mf = PathSpecT $ \s0 -> - getPathSpecT mf s0 >>= \(a,s1) -> return (f a,s1) +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) -- Applicative - -instance Applicative (PathSpec u) where - pure a = PathSpec $ \s0 -> (a, s0) - mf <*> ma = PathSpec $ \s0 -> let (f,s1) = getPathSpec mf s0 - (a,s2) = getPathSpec ma s1 - in (f a, s2) -instance Monad m => Applicative (PathSpecT u m) where - pure a = PathSpecT $ \s0 -> return (a, s0) - mf <*> ma = PathSpecT $ \s0 -> - getPathSpecT mf s0 >>= \(f,s1) -> - getPathSpecT ma s1 >>= \(a,s2) -> - return (f a, s2) +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) -- Monad -instance Monad (PathSpec u) where - return a = PathSpec $ \s0 -> (a, s0) - ma >>= k = PathSpec $ \s0 -> - let (a,s1) = getPathSpec ma s0 in (getPathSpec . k) a s1 +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 Monad m => Monad (PathSpecT u m) where - return a = PathSpecT $ \s0 -> return (a, s0) - ma >>= k = PathSpecT $ \s0 -> - getPathSpecT ma s0 >>= \(a,s1) -> (getPathSpecT . k) a s1 - +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) --- | Make the initial build state. --- -zeroBuildSt :: InterpretUnit u => BuildSt u -zeroBuildSt = BuildSt { cumulative_tip = V2 0 0 - , cumulative_path = mempty - , current_incline = 0 - , active_path = PEN_UP - , pen_trace = mempty - , ins_trace = mempty - , pen_dc_modifier = id - } +-- DrawingCtxM +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 --- The /full/ versions throw away only parts of the @BuildSt@ . --- +-- UserStateM --- | Run a PathSpec - return a five-tuple. --- --- > (ans, path, end_vector, pen_trace, insert_trace) --- --- > ans - is the monadic answer, usually (). --- --- > path - is the relative path formed by all movements during --- > the build. This includes movement where the pen is _up_. --- --- > end_vector - is the cumulative displacement from the start --- > point. --- --- > pen_trace - is ... --- --- > insert_trace - --- -runPathSpec :: (Floating u, InterpretUnit u) - => PathSpec u a - -> (a, RelPath u, Vec2 u, LocGraphic u, LocGraphic u) -runPathSpec mf = - post $ getPathSpec mf zeroBuildSt - where - post (a,st) = let (ph,end,pen,ins) = postBuildSt st - in (a,ph,end,pen,ins) +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) --- | /Close/ the BuildSt, extracting the values. --- --- A partly drawn sub path will be added to the pen trace as an --- open sub path. + +-- | Note - location probably should return Point2 not Vec2 hence +-- this uses @cheat@ temporarily. -- -postBuildSt :: InterpretUnit u - => BuildSt u -> (RelPath u, Vec2 u, LocGraphic u, LocGraphic u) -postBuildSt s0 = step (penUp SUBPATH_OPEN s0) - where - step st = ( cumulative_path st - , cumulative_tip st - , pen_trace st - , ins_trace st ) +-- TODO - sort out LocTraceM class. +-- +instance InterpretUnit u => LocTraceM (GenPathSpec st u) where + moveBy = moveto + insertl = insertLocImage + location = cheat <$> pathTip + where cheat (P2 x y) = V2 x y + +runGenPathSpec :: InterpretUnit u + => GenPathSpec st u a -> st -> LocImage u (a, RelPath u) +runGenPathSpec ma st = 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 SUBPATH_OPEN $ st_active_pen s) ctx + wfinal = w_trace w `mappend` wcp + in replaceAns (a,upath) $ primGraphic wfinal --- | Run an 'PathSpec' - return the LocGraphic formed by the pen --- trace and the insert trace, /forget/ the outline of the path. --- --- Note - the insert trace is printed above the pen trace in the --- z-order. --- -execPathSpec :: (Floating u, InterpretUnit u) - => PathSpec u a -> LocGraphic u -execPathSpec mf = post $ runPathSpec mf - where - post (_,_,_,g1,g2) = g1 `mappend` g2 +runPathSpec :: InterpretUnit u + => PathSpec u a -> LocImage u (a, RelPath u) +runPathSpec ma = runGenPathSpec ma () +evalPathSpec :: InterpretUnit u + => PathSpec u a -> LocImage u (RelPath u) +evalPathSpec ma = snd <$> runPathSpec ma --- | Run an 'PathSpec' - return the outline of the path, /forget/ --- the the pen trace and the insert trace. --- -evalPathSpec :: (Floating u, InterpretUnit u) - => PathSpec u a -> RelPath u -evalPathSpec mf = post $ runPathSpec mf - where - post (_,ph,_,_,_) = ph +execPathSpec :: InterpretUnit u + => PathSpec u a -> LocImage u a +execPathSpec ma = fst <$> runPathSpec ma --- | Transformer version of 'runPathSpec' + + +extrPathSpec :: InterpretUnit u + => PathSpec u a -> LocQuery u (RelPath u) +extrPathSpec ma = extrLoc $ evalPathSpec ma + + +-- Monad run function nomenclature: -- -runPathSpecT :: (Monad m, Floating u, InterpretUnit u) - => PathSpecT u m a - -> m (a, RelPath u, Vec2 u, LocGraphic u, LocGraphic u) -runPathSpecT mf = - liftM post $ getPathSpecT mf zeroBuildSt - where - post (a,st) = let (ph,end,pen,ins) = postBuildSt st - in (a,ph,end,pen,ins) +-- > 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@. --- | Transformer version of 'execPathSpec' +-- | Helper. -- -execPathSpecT :: (Monad m, Floating u, InterpretUnit u) - => PathSpecT u m a -> m (LocGraphic u) -execPathSpecT mf = liftM post $ runPathSpecT mf - where - post (_,_,_,g1,g2) = g1 `mappend` g2 +drawActivePen :: PathTerm -> ActivePen -> DGraphic +drawActivePen _ PEN_UP = mempty +drawActivePen term (PEN_DOWN { ap_start_point = pt + , ap_rel_path = rp}) = case term of + SUBPATH_OPEN -> ignoreAns $ drawOpenPath rp `at` pt + SUBPATH_CLOSED styl -> ignoreAns $ drawClosedPath styl rp `at` pt --- | Transformer version of 'evalPathSpec'. --- -evalPathSpecT :: (Monad m, Floating u, InterpretUnit u) - => PathSpecT u m a -> m (RelPath u) -evalPathSpecT mf = liftM post $ runPathSpecT mf - where - post (_,ph,_,_,_) = ph +{- + -- | Form a \"pivot path\" drawing from two path specifications. -- The start point of the drawing is the pivot formed by joining -- the paths. @@ -321,256 +286,127 @@ where (v, _, _, pen, ins) = runPathSpec ( ma >> location >>= \ans -> mb >> return ans ) - --- | Transformer version of 'execPivot'. --- -execPivotT :: (Floating u, InterpretUnit u, Monad m) - => PathSpecT u m a -> PathSpecT u m a -> m (LocGraphic u) -execPivotT ma mb = - liftM post $ runPathSpecT ( ma >> location >>= \ans -> - mb >> return ans ) - where - post (v, _, _, pen, ins) = moveStart (negateV v) $ pen `mappend` ins - - +-} - -------------------------------------------------------------------------------- +-- operations --- BuildSt modifiers. -type BuildStF u = BuildSt u -> BuildSt u +pathTip :: InterpretUnit u => GenPathSpec st u (Point2 u) +pathTip = GenPathSpec $ \ctx pt s -> + let upt = dinterpF (dc_font_size ctx) pt + in (upt, pt, s, mempty) --- | Helper - extend the path with a line. --- --- This is an implicit PEN_DOWN if the active pen is UP. +-- | @extendPen@ causes a pendown. -- -extendPath :: Floating u - => Vec2 u -> BuildStF u -extendPath v1 = (\s v0 ph pa -> s { cumulative_tip = v0 ^+^ v1 - , cumulative_path = updP ph - , active_path = updA v0 pa }) - <*> cumulative_tip <*> cumulative_path <*> active_path - where - updP ph = snocLineTo ph v1 - updA tip PEN_UP = PEN_DOWN tip (line1 v1) - updA _ (PEN_DOWN v0 ph) = PEN_DOWN v0 (snocLineTo ph v1) +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) +lineto :: InterpretUnit u => Vec2 u -> GenPathSpec st u () +lineto 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) --- | Helper - extend the path with a curve. --- --- This is an implicit PEN_DOWN if the active pen is UP. --- -extendPathC :: (Floating u, Ord u, Tolerance u) - => Vec2 u -> Vec2 u -> Vec2 u -> BuildStF u -extendPathC c1 c2 c3 = - (\s v0 ph pa -> s { cumulative_tip = v0 ^+^ c1 ^+^ c2 ^+^ c3 - , cumulative_path = updP ph - , active_path = updA v0 pa }) - <*> cumulative_tip <*> cumulative_path <*> active_path - where - updP ph = snocCurveTo ph c1 c2 c3 - updA tip PEN_UP = PEN_DOWN tip (curve1 c1 c2 c2) - updA _ (PEN_DOWN v0 ph) = PEN_DOWN v0 (snocCurveTo ph c1 c2 c3) - --- | Helper - change the active_path to PEN_UP. --- --- This will implicitly log any partly drawn path. +-- | @extendPenC@ causes a pendown. -- -penUp :: InterpretUnit u => PathTerm -> BuildStF u -penUp term = - (\s pt pa upd -> s { active_path = PEN_UP - , pen_trace = pt `mappend` fn upd pa }) - <*> pen_trace <*> active_path <*> pen_dc_modifier - where - fn _ PEN_UP = mempty - fn upd (PEN_DOWN v0 pa) = subPathDraw upd v0 pa term +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) --- | Move the current tip. --- --- This is an implicit PEN_UP if the active pen is DOWN. --- -moveTip :: (Floating u, InterpretUnit u) - => Vec2 u -> BuildStF u -moveTip v1 = - (\s pa v0 cp -> let s1 = case pa of PEN_UP -> s; _ -> penUp SUBPATH_OPEN s - in s1 { cumulative_tip = v0 ^+^ v1 - , cumulative_path = snocLineTo cp v1 }) - <*> active_path <*> cumulative_tip <*> cumulative_path +curveto :: InterpretUnit u + => Vec2 u -> Vec2 u -> Vec2 u -> GenPathSpec st u () +curveto 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) --- | Cycle the current active path. --- -cycleAP :: (Floating u, InterpretUnit u) - => DrawStyle -> BuildStF u -cycleAP sty = - (\s pa vtip cp -> case pa of - PEN_UP -> s - PEN_DOWN v0 _ -> let s1 = penUp (SUBPATH_CLOSED sty) s - mv = v0 ^-^ vtip - in s1 { cumulative_tip = v0 - , cumulative_path = snocLineTo cp mv }) - <*> active_path <*> cumulative_tip <*> cumulative_path - - --- | Change the drawing props of the current pen. +-- | @moveto@ causes a pen up. -- --- This is an implicit PEN_UP if the active pen is DOWN. --- -changePen :: InterpretUnit u => DrawingContextF -> BuildStF u -changePen upd = - (\s pa df -> let s1 = case pa of PEN_UP -> s; _ -> penUp SUBPATH_OPEN s - in s1 { pen_dc_modifier = (upd . df) }) - <*> active_path <*> pen_dc_modifier - +moveto :: InterpretUnit u => Vec2 u -> GenPathSpec st u () +moveto v1 = GenPathSpec $ \ctx pt s -> + let sz = dc_font_size ctx + dv1 = normalizeF sz v1 + (_,wcp) = runImage (drawActivePen SUBPATH_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) -insertGf :: Num u => LocGraphic u -> BuildStF u -insertGf gf = - (\s ins v1 -> let g1 = moveStart v1 gf - in s { ins_trace = ins `mappend` g1 }) - <*> ins_trace <*> cumulative_tip - +breakPath :: InterpretUnit u => GenPathSpec st u () +breakPath = moveto (V2 0 0) +hlineto :: InterpretUnit u => u -> GenPathSpec st u () +hlineto dx = lineto (hvec dx) -appendVamp :: (Floating u, InterpretUnit u) - => Vamp u -> BuildStF u -appendVamp (Vamp { vamp_path = vph, vamp_term = term, vamp_move = mv }) = - next . penUp SUBPATH_OPEN - where - next = (\s v1 cp trc df -> let p1 = subPathDraw df v1 vph term - in s { cumulative_tip = v1 ^+^ mv - , cumulative_path = snocLineTo cp mv - , pen_trace = trc `mappend` p1 }) - <*> cumulative_tip <*> cumulative_path - <*> pen_trace <*> pen_dc_modifier - +vlineto :: InterpretUnit u => u -> GenPathSpec st u () +vlineto dy = lineto (vvec dy) -subPathDraw :: InterpretUnit u - => DrawingContextF -> Vec2 u -> RelPath u -> PathTerm - -> LocGraphic u -subPathDraw upd v0 subp term = promoteLoc $ \pt -> - zapQuery (toPrimPath (displace v0 pt) subp) >>= \pp -> localize upd (drawF pp) - where - drawF = case term of - SUBPATH_OPEN -> dcOpenPath - SUBPATH_CLOSED sty -> dcClosedPath sty +alineto :: (Floating u, InterpretUnit u) + => Radian -> u -> GenPathSpec st u () +alineto ang d = lineto (avec ang d) +insertLocImage :: InterpretUnit u + => LocImage u a -> GenPathSpec st u () +insertLocImage gf = GenPathSpec $ \ctx pt s -> + let upt = dinterpF (dc_font_size ctx) pt + (_,wcp) = runLocImage gf ctx upt + w1 = PathW { w_rel_path = mempty, w_trace = wcp } + in ((), pt, s, w1) --------------------------------------------------------------------------------- --- LocTraceM instances - --- Note - path building does not support forking (LocForkTraceM). - --- moveBy becomes a pen up - -instance (Floating u, InterpretUnit u) => - LocTraceM (PathSpec u) where - insertl a = PathSpec $ \s0 -> ((), insertGf a s0) - location = PathSpec $ \s0 -> (cumulative_tip s0, s0) - moveBy v = PathSpec $ \s0 -> ((), moveTip v s0) - - +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 SUBPATH_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) -instance (Monad m, Floating u, InterpretUnit u) => - LocTraceM (PathSpecT u m) where - insertl a = PathSpecT $ \s0 -> return ((), insertGf a s0) - location = PathSpecT $ \s0 -> return (cumulative_tip s0, s0) - moveBy v = PathSpecT $ \s0 -> return ((), moveTip v s0) - +cycleSubPath :: DrawStyle -> GenPathSpec st u () +cycleSubPath styl = GenPathSpec $ \ctx pt s -> + let gf = drawActivePen (SUBPATH_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) --------------------------------------------------------------------------------- +-- Design note +-- +-- Should pen changing be @local@ style vis the Reader monad or a +-- state change with the State monad? -- - - --- | @updatePen@ will draw any in-progress path as an open-stroked --- line before changing the pen properties. +-- @local@ is more idiomatic within the context of Wumpus (and +-- easier to implement), but @state change@ is probably more +-- natural for Path building. +-- +-- For the time being we go with local. -- -class Monad m => PathOpM m where - line :: u ~ MonUnit (m ()) => Vec2 u -> m () - curve :: u ~ MonUnit (m ()) => Vec2 u -> Vec2 u -> Vec2 u -> m () - updatePen :: DrawingContextF -> m () - cycleSubPath :: DrawStyle -> m () - vamp :: u ~ MonUnit (m ()) => Vamp u -> m () - -instance (Floating u, Ord u, Tolerance u, InterpretUnit u) => - PathOpM (PathSpec u) where - line v1 = PathSpec $ \s0 -> ((), extendPath v1 s0) - curve v1 v2 v3 = PathSpec $ \s0 -> ((), extendPathC v1 v2 v3 s0) - updatePen upd = PathSpec $ \s0 -> ((), changePen upd s0) - cycleSubPath sty = PathSpec $ \s0 -> ((), cycleAP sty s0) - vamp vp = PathSpec $ \s0 -> ((), appendVamp vp s0) - - - -instance (Monad m, Floating u, Ord u, Tolerance u, InterpretUnit u) => - PathOpM (PathSpecT u m) where - line v1 = PathSpecT $ \s0 -> return ((), extendPath v1 s0) - curve v1 v2 v3 = PathSpecT $ \s0 -> return ((), extendPathC v1 v2 v3 s0) - updatePen upd = PathSpecT $ \s0 -> return ((), changePen upd s0) - cycleSubPath sty = PathSpecT $ \s0 -> return ((), cycleAP sty s0) - vamp vp = PathSpecT $ \s0 -> return ((), appendVamp vp s0) - - - --------------------------------------------------------------------------------- --- operations - - - -{- - -setIncline :: Radian -> PathSpec u () -setIncline ang = sets_ upd - where - upd = (\s -> s { current_incline = ang }) - --} - --------------------------------------------------------------------------------- --- Derived operators - - - - -pen_colour :: PathOpM m - => RGBi -> m () -pen_colour rgb = updatePen (stroke_colour rgb) - -pen_width :: PathOpM m - => Double -> m () -pen_width d = updatePen (set_line_width d) - - -lines :: (PathOpM m, u ~ MonUnit (m ())) => [Vec2 u] -> m () -lines = mapM_ line - - --- --- Note - these names are not consistent with Displacement in --- Wumpus-Basic. --- - -hline :: (PathOpM m, Num u, u ~ MonUnit (m ())) => u -> m () -hline dx = line (hvec dx) - -vline :: (PathOpM m, Num u, u ~ MonUnit (m ())) => u -> m () -vline dy = line (vvec dy) - +localPen :: DrawingContextF -> GenPathSpec st u a -> GenPathSpec st u a +localPen upd ma = GenPathSpec $ \ctx pt s -> + let (_,wcp) = runImage (drawActivePen SUBPATH_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) -aline :: (PathOpM m, Floating u, u ~ MonUnit (m ())) => Radian -> u -> m () -aline ang d = line (avec ang d) diff --git a/src/Wumpus/Drawing/Paths/Base/RelPath.hs b/src/Wumpus/Drawing/Paths/Base/RelPath.hs --- a/src/Wumpus/Drawing/Paths/Base/RelPath.hs +++ b/src/Wumpus/Drawing/Paths/Base/RelPath.hs @@ -58,8 +58,10 @@ , toPrimPath , toAbsPath - , openRelPath - , closedRelPath + , drawOpenPath + , drawOpenPath_ + , drawClosedPath + , drawClosedPath_ ) where @@ -283,14 +285,16 @@ -- Conversion fromPathAlgVertices :: Floating u => PathAlg u -> (Vec2 u, RelPath u) -fromPathAlgVertices = bimap fn vertexPath . runPathAlgVec +fromPathAlgVertices = step . runPathAlgVec where - fn = maybe (V2 0 0) id + step (Nothing, xs) = (zeroVec, vertexPath xs) + step (Just v1, xs) = (v1, vertexPath xs) fromPathAlgCurves :: Floating u => PathAlg u -> (Vec2 u, RelPath u) -fromPathAlgCurves = bimap fn curvedPath . runPathAlgVec +fromPathAlgCurves = step . runPathAlgVec where - fn = maybe (V2 0 0) id + step (Nothing, xs) = (zeroVec, curvedPath xs) + step (Just v1, xs) = (v1, curvedPath xs) toPrimPath :: InterpretUnit u => Point2 u -> RelPath u -> Query u PrimPath @@ -336,14 +340,24 @@ -openRelPath :: InterpretUnit u - => RelPath u -> LocImage u (RelPath u) -openRelPath rp = replaceAns rp $ +drawOpenPath :: InterpretUnit u + => RelPath u -> LocImage u (RelPath u) +drawOpenPath rp = replaceAns rp $ promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcOpenPath +drawOpenPath_ :: InterpretUnit u + => RelPath u -> LocGraphic u +drawOpenPath_ rp = promoteLoc $ \start -> + zapQuery (toPrimPath start rp) >>= dcOpenPath -closedRelPath :: InterpretUnit u - => DrawStyle -> RelPath u -> LocImage u (RelPath u) -closedRelPath sty rp = replaceAns rp $ + +drawClosedPath :: InterpretUnit u + => DrawStyle -> RelPath u -> LocImage u (RelPath u) +drawClosedPath sty rp = replaceAns rp $ promoteLoc $ \start -> zapQuery (toPrimPath start rp) >>= dcClosedPath sty + +drawClosedPath_ :: InterpretUnit u + => DrawStyle -> RelPath u -> LocGraphic u +drawClosedPath_ sty rp = promoteLoc $ \start -> + zapQuery (toPrimPath start rp) >>= dcClosedPath sty diff --git a/src/Wumpus/Drawing/Paths/Vamps.hs b/src/Wumpus/Drawing/Paths/Vamps.hs --- a/src/Wumpus/Drawing/Paths/Vamps.hs +++ b/src/Wumpus/Drawing/Paths/Vamps.hs @@ -22,8 +22,8 @@ ) where -import Wumpus.Drawing.Paths.Base.PathBuilder -import Wumpus.Drawing.Paths.Base.RelPath +import Wumpus.Drawing.Paths.Base.PathBuilder ( Vamp(..) ) +import Wumpus.Drawing.Paths.Base.AbsPath import Wumpus.Basic.Kernel @@ -35,12 +35,18 @@ - -squareWE :: (Fractional u, Floating u) => u -> Vamp u -squareWE diam = makeVamp (hvec diam) rpath (SUBPATH_CLOSED STROKE) +-- Note - actual square TODO... +-- +squareWE :: (Real u, Floating u, Ord u, Tolerance u, InterpretUnit u) + => u -> Vamp u +squareWE diam = Vamp { vamp_move = hvec diam + , vamp_conn = conn } where - hdiam = 0.5 * diam - rpath = vertexPath [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ] + conn = promoteConn $ \p1 p2 -> + -- TODO ... + drawClosedPath_ STROKE $ vertexPath $ [ p1, p2 ] + -- vertexPath [ vvec hdiam, hvec diam, vvec (-diam), hvec (-diam) ] --- Drawing a cirle is probably best done with 90deg arcs. + +-- Drawing a cirle picks the half point on the vamp_move vector... diff --git a/src/Wumpus/Drawing/Shapes/Base.hs b/src/Wumpus/Drawing/Shapes/Base.hs --- a/src/Wumpus/Drawing/Shapes/Base.hs +++ b/src/Wumpus/Drawing/Shapes/Base.hs @@ -131,7 +131,7 @@ -- Probably Wumpus should calculate two paths instead. -- dblStrokedShape :: InterpretUnit u => Shape t u -> LocImage u (t u) -dblStrokedShape sh = decorate back fore +dblStrokedShape sh = sdecorate back fore where img = shapeToLoc (dcClosedPath STROKE) sh back = getLineWidth >>= \lw -> @@ -154,7 +154,7 @@ zapLocThetaQuery (shape_ans_fun sh) pt 0 >>= \a -> zapLocThetaQuery (shape_path_fun sh) pt 0 >>= \spath -> let g2 = atIncline (shape_decoration sh) pt 0 - in replaceAns a (decorate g2 $ zapQuery (toPrimPath spath) >>= drawF) + in replaceAns a (sdecorate g2 $ zapQuery (toPrimPath spath) >>= drawF) @@ -176,7 +176,7 @@ zapLocThetaQuery (shape_ans_fun sh) pt theta >>= \a -> zapLocThetaQuery (shape_path_fun sh) pt theta >>= \spath -> let g2 = atIncline (shape_decoration sh) pt theta - in replaceAns a $ decorate g2 (zapQuery (toPrimPath spath) >>= drawF) + in replaceAns a $ sdecorate g2 (zapQuery (toPrimPath spath) >>= drawF) diff --git a/src/Wumpus/Drawing/Text/Base/Common.hs b/src/Wumpus/Drawing/Text/Base/Common.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Text/Base/Common.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Text.Base.Common --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Helpers for working with measured / advance text. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Text.Base.Common - ( - posTextWithMargins - , advtext - , textVector - , textOrientationZero - - , charVector - , charOrientationZero - , hkernVector - , hkernOrientationZero - - ) where - - -import Wumpus.Basic.Kernel -- package: wumpus-basic - -import Wumpus.Core -- package: wumpus-core -import Wumpus.Core.Text.GlyphIndices - -import Data.VectorSpace -- package: vector-space - -import Control.Applicative -import Data.Char -import qualified Data.Map as Map -import Data.Maybe - - - -posTextWithMargins :: (Fractional u, InterpretUnit u) - => PosObject u -> (RectAddress -> LocImage u (BoundingBox u)) -posTextWithMargins obj = \raddr -> - textMargin >>= \(xsep,ysep) -> - let body = extendPosObject xsep xsep ysep ysep obj - in runPosObject raddr body - - --- | Single line text, returning its advance vector. --- -advtext :: InterpretUnit u => EscapedText -> LocImage u (Vec2 u) -advtext esc = textVector esc >>= body - where - body v = replaceAns v $ dcEscapedlabel esc - - -textVector :: (DrawingCtxM m, InterpretUnit u) - => EscapedText -> m (AdvanceVec u) -textVector esc = - cwLookupTable >>= \table -> - pointSize >>= \sz -> - let cs = destrEscapedText id esc - in return $ foldr (step sz table) (vec 0 0) cs - where - step sz table ch v = (v ^+^) $ charWidth sz table ch - -charVector :: (DrawingCtxM m, InterpretUnit u) - => EscapedChar -> m (AdvanceVec u) -charVector ch = - (\table sz -> charWidth sz table ch) <$> cwLookupTable <*> pointSize - --- | Build the Orientation of a single line of EscapedText. --- --- The locus of the Orientation is baseline left - margins are --- added. --- -textOrientationZero :: (DrawingCtxM m, InterpretUnit u ) - => EscapedText -> m (Orientation u) -textOrientationZero esc = textVector esc >>= bllOrientationZero - --- | Build the Orientation of an EscapedChar. --- --- The locus of the Orientation is baseline left - margins are --- added. --- -charOrientationZero :: (DrawingCtxM m, InterpretUnit u) - => EscapedChar -> m (Orientation u) -charOrientationZero ch = charVector ch >>= bllOrientationZero - - - --- NOTE - TextMargin should probably be added as a final step --- not during construction... - -bllOrientationZero :: (DrawingCtxM m, InterpretUnit u ) - => AdvanceVec u -> m (Orientation u) -bllOrientationZero (V2 w _) = - (\ymin ymaj -> Orientation 0 w ymin ymaj) - <$> fmap abs descender <*> capHeight - - - --- | 'hkernVector' : @ [kerning_char] -> AdvanceVec @ --- --- 'hkernvector' takes whatever length is paired with the --- EscapedChar for the init of the the list, for the last element --- it takes the charVector. --- -hkernVector :: (DrawingCtxM m, InterpretUnit u) - => [KernChar u] -> m (AdvanceVec u) -hkernVector = go 0 - where - go w [] = return $ V2 w 0 - go w [(dx,ch)] = fmap (addWidth $ w + dx) (charVector ch) - go w ((dx,_ ):xs) = go (w + dx) xs - - addWidth w (V2 x y) = V2 (w+x) y - - -- ERROR this not the right way to count... - - -hkernOrientationZero :: (DrawingCtxM m, InterpretUnit u ) - => [KernChar u] -> m (Orientation u) -hkernOrientationZero xs = hkernVector xs >>= bllOrientationZero - --- | This is outside the Drawing context as we don\'t want to get --- the @cwLookupTable@ for every char. --- -charWidth :: InterpretUnit u - => FontSize -> CharWidthLookup -> EscapedChar -> AdvanceVec u -charWidth sz fn (CharLiteral c) = fmap (dinterp sz) $ fn $ ord c -charWidth sz fn (CharEscInt i) = fmap (dinterp sz) $ fn i -charWidth sz fn (CharEscName s) = fmap (dinterp sz) $ fn ix - where - ix = fromMaybe (-1) $ Map.lookup s ps_glyph_indices - diff --git a/src/Wumpus/Drawing/Text/Base/DocTextZero.hs b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs --- a/src/Wumpus/Drawing/Text/Base/DocTextZero.hs +++ b/src/Wumpus/Drawing/Text/Base/DocTextZero.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -20,392 +21,226 @@ module Wumpus.Drawing.Text.Base.DocTextZero ( - Doc - , TextFrame - , render - , leftAlign - , centerAlign - , rightAlign + Doc + , DocGraphic + , runDoc + , (<+>) , blank , space , string , escaped - , int + , embedPosObject + + , bold + , italic + , boldItalic + + , monospace + , int , integer , float , ffloat - , (<>) - , (<+>) - , vcatl - , vcatc - , vcatr - - , lfill - , rfill - , centerfill - - , fontColour - , textSize - , bold - , italic - , boldItalic , strikethrough , underline , highlight ) where -import Wumpus.Drawing.Text.Base.Common import Wumpus.Basic.Kernel -- package: wumpus-basic import Wumpus.Core -- package: wumpus-core import Control.Applicative -import Data.Char ( ord ) +import Data.Monoid import Numeric --- | Space is the width of a space in the current font - it is --- filled in during interpretation. + +-- | Doc type. -- -data Doc u = Empty - | Space - | Text EscapedText - | Cat (Doc u) (Doc u) - | VCat VAlign (Doc u) (Doc u) - | Fill VAlign u (Doc u) - | DLocal DrawingContextF (Doc u) - | TLocal (TextContextF u) (Doc u) - | Mono (WidthQuery u) [EscapedChar] - | AElab (AElaborateF u) (Doc u) +newtype Doc u a = Doc { getDoc :: DocEnv -> PosObject u a } -type WidthQuery u = Query u (AdvanceVec u) +type instance DUnit (Doc u a) = u -type TextContextF u = TextContext u -> TextContext u +type DocGraphic u = Doc u (UNil u) -type AElaborateF u = Orientation u -> LocGraphic u +data DocEnv = DocEnv + { doc_alignment :: VAlign + , doc_font_family :: FontFamily + } +instance Functor (Doc u) where + fmap f ma = Doc $ \env -> fmap f $ getDoc ma env --- | TextFrame is the result Graphic made from rendering multiple --- lines of DocText. --- -type TextFrame u = RectAddress -> LocImage u (BoundingBox u) +instance Applicative (Doc u) where + pure a = Doc $ \_ -> pure a + mf <*> ma = Doc $ \env -> getDoc mf env <*> getDoc ma env --- NOTE - should the API use @em@ for fill, padding etc.? +instance Monad (Doc u) where + return a = Doc $ \_ -> return a + ma >>= k = Doc $ \env -> getDoc ma env >>= \a -> getDoc (k a) env -blank :: Doc u -blank = Empty -space :: Doc u -space = Space -string :: String -> Doc u -string = Text . escapeString +instance DrawingCtxM (Doc u) where + askDC = Doc $ \_ -> askDC + asksDC fn = Doc $ \_ -> asksDC fn + localize upd ma = Doc $ \env -> localize upd (getDoc ma env) -escaped :: EscapedText -> Doc u -escaped = Text +instance (Monoid a, InterpretUnit u) => Monoid (Doc u a) where + mempty = Doc $ \_ -> mempty + ma `mappend` mb = Doc $ \env -> getDoc ma env `hconcat` getDoc mb env -int :: InterpretUnit u => Int -> Doc u -int i = integer $ fromIntegral i - - -integer :: InterpretUnit u => Integer -> Doc u -integer i = Mono (charVector $ CharLiteral '0') (map CharLiteral $ show i) - --- | Specialized version of 'ffloat' - the answer is always --- rendered at \"full precision\". --- -float :: (RealFloat a, InterpretUnit u) => a -> Doc u -float = ffloat Nothing - - --- | This is equivalent to 'showFFloat' in the Numeric module. --- --- Like 'showFFloat', the answer is rendered to supplied --- precision. @Nothing@ indicated full precision. --- -ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> Doc u -ffloat mb d = Mono (charVector $ CharLiteral '0') xs +runDoc :: Doc u a -> VAlign -> FontFamily -> PosObject u a +runDoc ma va ff = getDoc ma env1 where - xs = (map CharLiteral $ ($ []) $ showFFloat mb d) + env1 = DocEnv { doc_alignment = va, doc_font_family = ff } +-------------------------------------------------------------------------------- +-- Get vcat vconcat... from the Concat class -infixr 6 <>, <+> +instance (Monoid a, Fractional u, InterpretUnit u) => Concat (Doc u a) where + hconcat = mappend + vconcat = vcatImpl +vcatImpl :: (Monoid a, Fractional u, InterpretUnit u) + => Doc u a -> Doc u a -> Doc u a +vcatImpl ma mb = Doc $ \env -> + let va = doc_alignment env + in textlineSpace >>= \sep -> + valignSpace va sep (getDoc ma env) (getDoc mb env) --- | Concatenate two DocTexts separated with no spacing. --- --- (infixr 6) --- -(<>) :: Doc u -> Doc u -> Doc u -a <> b = Cat a b - +-------------------------------------------------------------------------------- +-- Primitives +infixr 6 <+> + -- | Concatenate two Docs separated with a space. -- -- (infixr 6) -- -(<+>) :: Doc u -> Doc u -> Doc u -a <+> b = a <> space <> b +(<+>) :: InterpretUnit u => DocGraphic u -> DocGraphic u -> DocGraphic u +a <+> b = a `mappend` space `mappend` b -infixr 5 `vcatl`, `vcatc`, `vcatr` --- | Vertically concatenate - aligning left. --- --- (infixr 5) --- -vcatl :: Doc u -> Doc u -> Doc u -vcatl = VCat VLeft --- | Vertically concatenate - aligning center. --- --- (infixr 5) --- -vcatc :: Doc u -> Doc u -> Doc u -vcatc = VCat VCenter +blank :: InterpretUnit u => DocGraphic u +blank = Doc $ \_ -> posTextPrim (Left "") --- | Vertically concatenate - aligning right. --- --- (infixr 5) --- -vcatr :: Doc u -> Doc u -> Doc u -vcatr = VCat VRight +space :: InterpretUnit u => DocGraphic u +space = Doc $ \_ -> posCharPrim (Left ' ') -leftAlign :: [Doc u] -> Doc u -leftAlign = multiline vcatl -centerAlign :: [Doc u] -> Doc u -centerAlign = multiline vcatc +string :: InterpretUnit u => String -> DocGraphic u +string ss = Doc $ \_ -> posTextPrim (Left ss) -rightAlign :: [Doc u] -> Doc u -rightAlign = multiline vcatr -multiline :: (Doc u -> Doc u -> Doc u) -> [Doc u] -> Doc u -multiline _ [] = blank -multiline op (x:xs) = go x xs - where - go a [] = a - go a (b:bs) = go (a `op` b) bs +escaped :: InterpretUnit u => EscapedText -> DocGraphic u +escaped esc = Doc $ \_ -> posTextPrim (Right esc) +embedPosObject :: PosObject u a -> Doc u a +embedPosObject ma = Doc $ \_ -> ma -rfill :: u -> Doc u -> Doc u -rfill = Fill VLeft +-------------------------------------------------------------------------------- +-- Change font weight -lfill :: u -> Doc u -> Doc u -lfill = Fill VRight +bold :: Doc u a -> Doc u a +bold ma = Doc $ \env -> + localize (set_font $ boldWeight $ doc_font_family env) + (getDoc ma env) -centerfill :: u -> Doc u -> Doc u -centerfill = Fill VCenter +italic :: Doc u a -> Doc u a +italic ma = Doc $ \env -> + localize (set_font $ italicWeight $ doc_font_family env) + (getDoc ma env) +boldItalic :: Doc u a -> Doc u a +boldItalic ma = Doc $ \env -> + localize (set_font $ boldItalicWeight $ doc_font_family env) + (getDoc ma env) -fontColour :: RGBi -> Doc u -> Doc u -fontColour rgb = DLocal (text_colour rgb) +-------------------------------------------------------------------------------- +-- Monospace +monospace :: InterpretUnit u => EscapedChar -> EscapedText -> DocGraphic u +monospace ref_ch esc = Doc $ \_ -> + monospaceEscText (vector_x <$> escCharVector ref_ch) esc -textSize :: Int -> Doc u -> Doc u -textSize sz = DLocal (set_font_size sz) -bold :: Doc u -> Doc u -bold = TLocal (\s -> s { text_bold = True, text_italic = False }) - -italic :: Doc u -> Doc u -italic = TLocal (\s -> s { text_bold = False, text_italic = True }) - -boldItalic :: Doc u -> Doc u -boldItalic = TLocal (\s -> s { text_bold = True, text_italic = True }) - - -strikethrough :: Doc u -> Doc u -strikethrough = TLocal (\s -> s { text_strikethrough = True }) - -underline :: Doc u -> Doc u -underline = TLocal (\s -> s { text_underline = True }) - --- | Background fill. --- -highlight :: (Fractional u, InterpretUnit u) - => RGBi -> Doc u -> Doc u -highlight rgb = AElab (drawBackfill rgb) - - - -render :: (Real u, Floating u, InterpretUnit u) - => FontFamily -> Doc u -> (RectAddress -> LocImage u (BoundingBox u)) -render ff doc = \raddr -> localize (set_font $ regularWeight ff) $ - textlineSpace >>= \sep -> - let po = runEvalM (initTextCtx sep ff) (interpret doc) - in posTextWithMargins po raddr - - -data TextContext u = TextContext - { text_strikethrough :: Bool - , text_underline :: Bool - , text_sep :: u - , text_font_family :: FontFamily - , text_bold :: Bool - , text_italic :: Bool - } - - - -initTextCtx :: u -> FontFamily -> TextContext u -initTextCtx sep ff = TextContext - { text_strikethrough = False - , text_underline = False - , text_sep = sep - , text_font_family = ff - , text_bold = False - , text_italic = False - } - -newtype EvalM u a = EvalM { getEvalM :: TextContext u -> a } - - -instance Functor (EvalM u) where - fmap f mf = EvalM $ \ctx -> f $ getEvalM mf ctx +int :: InterpretUnit u => Int -> DocGraphic u +int i = integer $ fromIntegral i -instance Applicative (EvalM u) where - pure a = EvalM $ \_ -> a - mf <*> ma = EvalM $ \ctx -> - let f = getEvalM mf ctx - a = getEvalM ma ctx - in f a - -instance Monad (EvalM u) where - return a = EvalM $ \_ -> a - ma >>= k = EvalM $ \ctx -> - let a = getEvalM ma ctx - in (getEvalM . k) a ctx - -asks :: (TextContext u -> a) -> EvalM u a -asks f = EvalM $ \ctx -> f ctx - -lineSpace :: EvalM u u -lineSpace = asks text_sep - -local :: (TextContext u -> TextContext u) -> EvalM u a -> EvalM u a -local upd mf = EvalM $ \ctx -> getEvalM mf (upd ctx) - -runEvalM :: TextContext u -> EvalM u a -> a -runEvalM ctx mf = getEvalM mf ctx +integer :: InterpretUnit u => Integer -> DocGraphic u +integer i = monospace (CharLiteral '0') (escapeString $ show i) -interpret :: (Fractional u, Ord u, InterpretUnit u) - => Doc u -> EvalM u (PosObject u) -interpret Empty = interpEmpty -interpret Space = interpSpace -interpret (Text esc) = interpText esc -interpret (Cat a b) = hconcat <$> interpret a <*> interpret b -interpret (VCat va a b) = - valignSpace va <$> lineSpace <*> interpret a <*> interpret b - -interpret (Fill va w a) = ppad va w <$> interpret a -interpret (DLocal upd a) = localPosObject upd <$> interpret a -interpret (TLocal upd a) = local upd (interpret a) -interpret (Mono q1 xs) = interpMono q1 xs -interpret (AElab fn a) = decoPosObject fn ANTERIOR <$> interpret a - - +-------------------------------------------------------------------------------- -interpEmpty :: InterpretUnit u => EvalM u (PosObject u) -interpEmpty = - return $ makePosObject (pure $ Orientation 0 0 0 0) emptyLocImage - +-- | Specialized version of 'ffloat' - the answer is always +-- rendered at \"full precision\". +-- +float :: (RealFloat a, InterpretUnit u) => a -> DocGraphic u +float = ffloat Nothing --- | Note - the current way of seeding the LocGraphic with the --- DrawingContext looks dodgy (substantial copying). +-- | This is equivalent to 'showFFloat' in the Numeric module. -- --- Maybe EvalM should have a private, much smaller --- DrawingContext... +-- Like 'showFFloat', the answer is rendered to supplied +-- precision. @Nothing@ indicated full precision. -- -interpText :: (Fractional u, InterpretUnit u) - => EscapedText -> EvalM u (PosObject u) -interpText esc = interpretLeaf $ - makePosObject (textOrientationZero esc) (dcEscapedlabel esc) - +ffloat :: (RealFloat a, InterpretUnit u) => (Maybe Int) -> a -> DocGraphic u +ffloat mb d = + monospace (CharLiteral '0') $ escapeString $ ($ "") $ showFFloat mb d --- | Note - a space character is not draw in the output, instead --- 'space' advances the width vector by the width of a space in --- the current font. --- -interpSpace :: InterpretUnit u - => EvalM u (PosObject u) -interpSpace = return $ makePosObject qy1 emptyLocImage - where - qy1 = charOrientationZero $ CharEscInt $ ord ' ' -ppad :: (Fractional u, Ord u) - => VAlign -> u -> PosObject u -> PosObject u -ppad VLeft du = mapOrientation (padXMinor du) -ppad VCenter du = mapOrientation (padHEven $ 0.5 * du) -ppad VRight du = mapOrientation (padXMajor du) +-------------------------------------------------------------------------------- +-- Decorate -interpMono :: (Fractional u, InterpretUnit u) - => Query u (AdvanceVec u) -> [EscapedChar] - -> EvalM u (PosObject u) -interpMono avq chs = - interpretLeaf $ makePosObject (qChars >>= hkernOrientationZero) - (promoteLoc $ \pt -> - zapQuery qChars >>= \ks -> hkernLine ks `at` pt) - where - qChars = (\v1 -> monoSpace (advanceH v1) chs) <$> avq +strikethrough :: (Fractional u, InterpretUnit u) + => Doc u a -> Doc u a +strikethrough = decorateDoc SUPERIOR drawStrikethrough - +underline :: (Fractional u, InterpretUnit u) + => Doc u a -> Doc u a +underline = decorateDoc SUPERIOR drawUnderline +highlight :: (Fractional u, InterpretUnit u) + => RGBi -> Doc u a -> Doc u a +highlight rgb = decorateDoc ANTERIOR (drawBackfill rgb) + -interpretLeaf :: (Fractional u, InterpretUnit u) - => PosObject u -> EvalM u (PosObject u) -interpretLeaf po = - (\f1 f2 sty -> f1 $ f2 $ localPosObject sty po) - <$> (fmap (condE drawUnderline) $ asks text_underline) - <*> (fmap (condE drawStrikethrough) $ asks text_strikethrough) - <*> textstyle - where - condE f b = if b then decoPosObject f SUPERIOR else id -textstyle :: EvalM u DrawingContextF -textstyle = - fn <$> asks text_font_family <*> asks text_bold <*> asks text_italic - where - fn ff False False = set_font $ regularWeight ff - fn ff True False = set_font $ boldWeight ff - fn ff False True = set_font $ italicWeight ff - fn ff _ _ = set_font $ boldItalicWeight ff - --------------------------------------------------------------------------------- --- Helpers +decorateDoc :: InterpretUnit u + => ZDeco -> (Orientation u -> LocGraphic u) -> Doc u a -> Doc u a +decorateDoc zdec fn ma = Doc $ \env -> + decoratePosObject zdec fn $ getDoc ma env -monoSpace :: Num u => u -> [EscapedChar] -> [KernChar u] -monoSpace w1 (c:cs) = (0,c) : map (\ch -> (w1,ch)) cs -monoSpace _ [] = [] - -- API might be simple if we conditionally apply strikethrough on @@ -415,43 +250,44 @@ -- fromf font size as well... -- drawStrikethrough :: (Fractional u, InterpretUnit u) - => Orientation u -> LocGraphic u + => Orientation u -> LocGraphic u drawStrikethrough (Orientation xmin xmaj _ ymaj) = - linestyle $ moveStart (vec (-xmin) vpos) hline + linestyle $ moveStart (vec (-xmin) vpos) ln where vpos = 0.45 * ymaj - hline = locStraightLine (hvec $ xmin + xmaj) + ln = locStraightLine (hvec $ xmin + xmaj) drawUnderline :: (Fractional u, InterpretUnit u) => Orientation u -> LocGraphic u -drawUnderline (Orientation xmin xmaj ymin _) = - linestyle $ moveStart (vec (-xmin) vpos) hline +drawUnderline (Orientation xmin xmaj _ _) = + underlinePosition >>= \vpos -> + linestyle $ moveStart (vec (-xmin) vpos) ln where - vpos = negate $ 0.45 * ymin - hline = locStraightLine (hvec $ xmin + xmaj) + ln = locStraightLine (hvec $ xmin + xmaj) + +-- | This uses underline_thickness ... +-- linestyle :: LocGraphic u -> LocGraphic u linestyle mf = - pointSize >>= \sz -> - localize (stroke_use_text_colour . set_line_width (lim sz)) mf - where - lim i | i < 10 = 1.0 - | otherwise = (fromIntegral i) / 15.0 + underlineThickness >>= \sz -> + localize (stroke_use_text_colour . set_line_width sz) mf --- | Note - halving the TextMargin looks good. +-- | Note - quarter margin looks good. -- drawBackfill :: (Fractional u, InterpretUnit u) - => RGBi -> Orientation u -> LocGraphic u + => RGBi -> Orientation u -> LocGraphic u drawBackfill rgb (Orientation xmin xmaj ymin ymaj) = textMargin >>= \(dx,dy) -> - let hdx = 0.5 * dx - hdy = 0.5 * dy + let hdx = 0.25 * dx + hdy = 0.25 * dy in localize (fill_colour rgb) $ moveStart (mkVec hdx hdy) (mkRect hdx hdy) where mkVec dx dy = vec (negate $ xmin+dx) (negate $ ymin+dy) mkRect dx dy = let w = dx + xmin + xmaj + dx h = dy + ymin + ymaj + dy in dcRectangle FILL w h + diff --git a/src/Wumpus/Drawing/Text/Base/Label.hs b/src/Wumpus/Drawing/Text/Base/Label.hs --- a/src/Wumpus/Drawing/Text/Base/Label.hs +++ b/src/Wumpus/Drawing/Text/Base/Label.hs @@ -52,71 +52,71 @@ type BoundedLocRectGraphic u = RectAddress -> LocImage u (BoundingBox u) -locImageLabel :: Floating u +locImageLabel :: InterpretUnit u => (a -> Anchor u) -> RectAddress -> (RectAddress -> LocImage u (BoundingBox u)) -> LocImage u a -> LocImage u a locImageLabel fn rpos mklabel obj = promoteLoc $ \pt -> - elaborate (obj `at` pt) (\a -> ignoreAns $ mklabel rpos `at` fn a) + selaborate (obj `at` pt) (\a -> ignoreAns $ mklabel rpos `at` fn a) -label_center_of :: (Floating u, CenterAnchor a, u ~ DUnit a) +label_center_of :: (InterpretUnit u, CenterAnchor a, u ~ DUnit a) => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_center_of = locImageLabel center CENTER -label_left_of :: (Floating u, CardinalAnchor a, u ~ DUnit a) +label_left_of :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_left_of = locImageLabel west EE -label_right_of :: (Floating u, CardinalAnchor a, u ~ DUnit a) +label_right_of :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_right_of = locImageLabel east WW -label_above :: (Floating u, CardinalAnchor a, u ~ DUnit a) +label_above :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_above = locImageLabel north SS -label_below :: (Floating u, CardinalAnchor a, u ~ DUnit a) +label_below :: (InterpretUnit u, CardinalAnchor a, u ~ DUnit a) => BoundedLocRectGraphic u -> LocImage u a -> LocImage u a label_below = locImageLabel south NN -connectorPathLabel :: Floating u +connectorPathLabel :: InterpretUnit u => (AbsPath u -> Point2 u) -> RectAddress -> BoundedLocRectGraphic u -> Image u (AbsPath u) -> Image u (AbsPath u) connectorPathLabel fn rpos lbl img = - elaborate img (\a -> ignoreAns $ lbl rpos `at` (fn a)) + selaborate img (\a -> ignoreAns $ lbl rpos `at` (fn a)) -label_midway_of :: (Real u, Floating u) +label_midway_of :: (Real u, Floating u, InterpretUnit u) => RectAddress -> BoundedLocRectGraphic u -> Image u (AbsPath u) -> Image u (AbsPath u) label_midway_of = connectorPathLabel midway_ -label_atstart_of :: (Real u, Floating u) +label_atstart_of :: (Real u, Floating u, InterpretUnit u) => RectAddress -> BoundedLocRectGraphic u -> Image u (AbsPath u) -> Image u (AbsPath u) label_atstart_of = connectorPathLabel atstart_ -label_atend_of :: (Real u, Floating u) - => RectAddress - -> BoundedLocRectGraphic u - -> Image u (AbsPath u) -> Image u (AbsPath u) +label_atend_of :: (Real u, Floating u, InterpretUnit u) + => RectAddress + -> BoundedLocRectGraphic u + -> Image u (AbsPath u) -> Image u (AbsPath u) label_atend_of = connectorPathLabel atend_ diff --git a/src/Wumpus/Drawing/Text/Base/PosChar.hs b/src/Wumpus/Drawing/Text/Base/PosChar.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Text/Base/PosChar.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Text.Base.PosChar --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Drawing single a char as a PosImage. --- --------------------------------------------------------------------------------- - -module Wumpus.Drawing.Text.Base.PosChar - ( - LocRectChar - - , posChar - , posEscChar - - , charLabel - , escCharLabel - - ) where - -import Wumpus.Drawing.Text.Base.Common - -import Wumpus.Basic.Kernel -- package: wumpus-basic - -import Wumpus.Core -- package: wumpus-core - - -type PosChar u = PosObject u - -posChar :: InterpretUnit u => Char -> PosChar u -posChar = makePosChar . CharLiteral - -posEscChar :: InterpretUnit u => EscapedChar -> PosChar u -posEscChar = makePosChar - - - --- Note this type doesn\'t support concat... --- --- While it may be adequate, it does need another prefix. --- -type LocRectChar u = RectAddress -> LocImage u (BoundingBox u) - - - - -charLabel :: (Floating u, InterpretUnit u) => Char -> LocRectChar u -charLabel ch = escCharLabel $ CharLiteral ch - - -escCharLabel :: (Floating u, InterpretUnit u) - => EscapedChar -> LocRectChar u -escCharLabel esc = \raddr -> runPosObject raddr (makePosChar esc) - - -makePosChar :: InterpretUnit u - => EscapedChar -> PosObject u -makePosChar esc = makePosObject (charOrientationZero esc) (escText1 esc) - - -escText1 :: InterpretUnit u => EscapedChar -> LocGraphic u -escText1 ch = dcEscapedlabel $ wrapEscChar ch - - - diff --git a/src/Wumpus/Drawing/Text/Base/RotTextZero.hs b/src/Wumpus/Drawing/Text/Base/RotTextZero.hs deleted file mode 100644 --- a/src/Wumpus/Drawing/Text/Base/RotTextZero.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# 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 = RectAddress -> LocImage u (BoundingBox u) -type LocTextLine u = LocImage u (BoundingBox 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 = textline ss BLL - - -blcTextline :: (Floating u, InterpretUnit u) - => String -> LocTextLine u -blcTextline ss = textline ss BLC - -ccTextline :: (Floating u, InterpretUnit u) - => String -> LocTextLine u -ccTextline ss = 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 = \raddr -> - body >>= \ans -> posTextWithMargins ans raddr - where - body = (\dy -> alignColumnSep va dy docs) <$> textlineSpace - - -makeTextObject :: InterpretUnit u => String -> TextObject u -makeTextObject = makeEscTextObject . escapeString - - -makeEscTextObject :: InterpretUnit u => EscapedText -> TextObject u -makeEscTextObject esc = - makePosObject (textOrientationZero esc) (dcEscapedlabel 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) - - -rescTextline :: (Real u, Floating u, Ord u, InterpretUnit u) - => Radian -> EscapedText -> LocRectTextLine u -rescTextline ang esc = \raddr -> runPosObject raddr $ makePosObject ortt body - where - ortt = fmap (rotOrientation ang) $ textOrientationZero esc - body = incline (dcREscapedlabel esc) ang - - - --- | Rotate an Orientation about its locus. --- -rotOrientation :: (Real u, Floating u, Ord u) - => Radian -> Orientation u -> Orientation u -rotOrientation ang (Orientation { or_x_minor = xmin - , or_x_major = xmaj - , or_y_minor = ymin - , or_y_major = ymaj }) = - orthoOrientation bl br tl tr - where - bl = rotateAbout ang zeroPt $ P2 (-xmin) (-ymin) - br = rotateAbout ang zeroPt $ P2 xmaj (-ymin) - tr = rotateAbout ang zeroPt $ P2 xmaj ymaj - tl = rotateAbout ang zeroPt $ P2 (-xmin) ymaj - - -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 - } - - -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) - diff --git a/src/Wumpus/Drawing/Text/DirectionZero.hs b/src/Wumpus/Drawing/Text/DirectionZero.hs --- a/src/Wumpus/Drawing/Text/DirectionZero.hs +++ b/src/Wumpus/Drawing/Text/DirectionZero.hs @@ -17,11 +17,37 @@ module Wumpus.Drawing.Text.DirectionZero ( module Wumpus.Drawing.Text.Base.DocTextZero - , module Wumpus.Drawing.Text.Base.PosChar - , module Wumpus.Drawing.Text.Base.RotTextZero + , textline + , rtextline + , multilineText + ) where import Wumpus.Drawing.Text.Base.DocTextZero -import Wumpus.Drawing.Text.Base.PosChar -import Wumpus.Drawing.Text.Base.RotTextZero + +import Wumpus.Basic.Kernel -- package: wumpus-basic + +import Wumpus.Core -- package: wumpus-core + +-- | Note - this is likely to be moved... +-- +-- Also, reversed argument order would be more convenient as +-- RectAddress always short but String could be long. +-- +textline :: InterpretUnit u => String -> RectAddress -> BoundedLocGraphic u +textline ss addr = runPosObjectBBox (posText ss) addr + + +-- | Note - this is likely to be moved too... +-- +rtextline :: (Real u, Floating u, InterpretUnit u) + => Radian -> String -> RectAddress -> BoundedLocGraphic u +rtextline ang ss addr = runPosObjectBBox (rposText ang ss) addr + + +multilineText :: (Fractional u, InterpretUnit u) + => VAlign -> String -> RectAddress -> BoundedLocGraphic u +multilineText va ss addr = runPosObjectBBox (multilinePosText va ss) addr + + diff --git a/src/Wumpus/Drawing/VersionNumber.hs b/src/Wumpus/Drawing/VersionNumber.hs --- a/src/Wumpus/Drawing/VersionNumber.hs +++ b/src/Wumpus/Drawing/VersionNumber.hs @@ -23,7 +23,7 @@ -- | Version number -- --- > (0,4,0) +-- > (0,5,0) -- wumpus_drawing_version :: (Int,Int,Int) -wumpus_drawing_version = (0,4,0) +wumpus_drawing_version = (0,5,0) diff --git a/wumpus-drawing.cabal b/wumpus-drawing.cabal --- a/wumpus-drawing.cabal +++ b/wumpus-drawing.cabal @@ -1,5 +1,5 @@ name: wumpus-drawing -version: 0.4.0 +version: 0.5.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -38,6 +38,13 @@ . Changelog: . + v0.4.0 to v0.5.0 + . + * Re-implemented Text drawing. Some functionality moved to + Wumpus-Basic. + . + * Re-implemented monadic Path Builder. + . v0.3.0 to v0.4.0: . * Simplified Trapezium shape so it only produces isosceles @@ -82,12 +89,11 @@ containers >= 0.3 && <= 0.6, vector-space >= 0.6 && < 1.0, wumpus-core >= 0.51.0 && < 0.52.0, - wumpus-basic == 0.18.0 + wumpus-basic == 0.20.0 exposed-modules: Wumpus.Drawing.Basis.DrawingPrimitives, - Wumpus.Drawing.Basis.TraceGraphic, Wumpus.Drawing.Basis.LocTrace, Wumpus.Drawing.Basis.RefTrace, Wumpus.Drawing.Colour.SVGColours, @@ -123,11 +129,8 @@ Wumpus.Drawing.Shapes.Semicircle, Wumpus.Drawing.Shapes.Semiellipse, Wumpus.Drawing.Shapes.Triangle, - Wumpus.Drawing.Text.Base.Common, Wumpus.Drawing.Text.Base.DocTextZero, Wumpus.Drawing.Text.Base.Label, - Wumpus.Drawing.Text.Base.PosChar, - Wumpus.Drawing.Text.Base.RotTextZero, Wumpus.Drawing.Text.DirectionZero, Wumpus.Drawing.Text.StandardFontDefs, Wumpus.Drawing.VersionNumber