diff --git a/demo/AltUnits.hs b/demo/AltUnits.hs new file mode 100644 --- /dev/null +++ b/demo/AltUnits.hs @@ -0,0 +1,77 @@ +{-# OPTIONS -Wall #-} + + +module AltUnits where + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core + +import System.Directory + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + let pic1 = runCtxPictureU std_attr drawing01 + writeEPS "./out/alt_units01.eps" pic1 + writeSVG "./out/alt_units01.svg" pic1 + + +std_attr :: DrawingContext +std_attr = (stroke_colour firebrick . fill_colour linen) $ standardContext 12 + + +drawing01 :: CtxPicture +drawing01 = drawTracing $ combined + + +mf1 :: TraceDrawing Double () +mf1 = do + draw $ dblLocGraphic `at` P2 12 0 + +mf2 :: TraceDrawing Em () +mf2 = do + draw $ emLocGraphic `at` P2 1 0 + +combined :: TraceDrawing Double () +combined = do + draw $ dblLocGraphic `at` P2 12 108 + drawl (P2 12 72) $ uconvLocImageF emLocGraphic + draw $ uconvImageF $ emLocGraphic `at` P2 1 3 + drawl (P2 12 0) $ uconvLocImageF $ pushR1 (hyperlink haskell_org) enLocGraphic + +dblLocGraphic :: LocGraphic Double +dblLocGraphic = rect1 `oplus` rect2 + where + rect1 = borderedRectangle 36 24 + rect2 = moveStart (displaceH 36) $ borderedRectangle 60 24 + + + +emLocGraphic :: LocGraphic Em +emLocGraphic = localize swap_colours $ rect1 `oplus` rect2 + where + rect1 = borderedRectangle 3 2 + rect2 = moveStart (displaceH 3) $ borderedRectangle 5 2 + + +enLocGraphic :: LocGraphic En +enLocGraphic = localize (fill_colour lemon_chiffon) $ rect1 `oplus` rect2 + where + rect1 = borderedRectangle 6 4 + rect2 = moveStart (displaceH 6) $ borderedRectangle 10 4 + + +haskell_org :: XLink +haskell_org = xlinkhref "http://www.haskell.org" + +firebrick :: RGBi +firebrick = RGBi 0xb2 0x22 0x22 + +lemon_chiffon :: RGBi +lemon_chiffon = RGBi 0xff 0xfa 0xcd + +linen :: RGBi +linen = RGBi 0xfa 0xf0 0xe6 + + diff --git a/demo/FontDeltaPic.hs b/demo/FontDeltaPic.hs --- a/demo/FontDeltaPic.hs +++ b/demo/FontDeltaPic.hs @@ -16,8 +16,7 @@ main :: IO () main = do createDirectoryIfMissing True "./out/" - putStrLn $ "Note - the SVG optimization that should be used here" - putStrLn $ "has bit-rotted and is not currently in use.." + putStrLn $ "Check the generated SVG to verify the font attrs are grouped..." -- let pic1 = runCtxPictureU std_attr drawing01 writeEPS "./out/font_delta01.eps" pic1 @@ -28,23 +27,23 @@ std_attr = standardContext 24 -drawing01 :: DCtxPicture +drawing01 :: CtxPicture drawing01 = drawTracing $ mf -mf :: (Floating u, FromPtSize u) => TraceDrawing u () -mf = do +mf :: TraceDrawing Double () +mf = fontDelta $ do draw $ line1 `at` (P2 0 100) draw $ line2 `at` (P2 0 75) draw $ line3 `at` (P2 0 50) draw $ line4 `at` (P2 0 25) draw $ line5 `at` (P2 0 0) where - line1 = textline "All the lines of this drawing" - line2 = textline "should be grouped within a SVG" - line3 = textline "g-element, from where they" - line4 = textline "inherit the font-family and" - line5 = textline "font-size attributes." + line1 = plainTextLine "All the lines of this drawing" + line2 = plainTextLine "should be grouped within a SVG" + line3 = plainTextLine "g-element, from where they" + line4 = plainTextLine "inherit the font-family and" + line5 = plainTextLine "font-size attributes." diff --git a/demo/SimpleAdvGraphic.hs b/demo/SimpleAdvGraphic.hs --- a/demo/SimpleAdvGraphic.hs +++ b/demo/SimpleAdvGraphic.hs @@ -7,6 +7,7 @@ import Wumpus.Core -- package: wumpus-core +import Control.Applicative import System.Directory main :: IO () @@ -21,31 +22,46 @@ std_attr = standardContext 24 -drawing01 :: DCtxPicture -drawing01 = drawTracing $ mf +drawing01 :: CtxPicture +drawing01 = drawTracing mf -mf :: (Floating u, FromPtSize u) => TraceDrawing u () + +-- Although TraceDrawing can be fully unit polymorphic, it seems +-- always best to specialize as we are stating concrete values +-- (and they will be in some unit). +-- + +mf :: TraceDrawing Double () mf = do - drawi_ $ advspace (hvec 10) [text01, text02, text01] `at` P2 0 120 - drawi_ $ advconcat [text01, text02, text01] `at` P2 0 80 - drawi_ $ (miniDisk `advcat` text01 `advcat` miniDisk) `at` P2 0 40 - drawi_ $ (miniDisk `advcat` text02 `advcat` miniDisk) `at` P2 0 0 + drawl (P2 0 120) $ + runAdvObjectR1 $ evenspace (hvec 10) [text01, text02, text01] + drawl (P2 0 80) $ + runAdvObjectR1 $ advances [text01, text02, text01] + drawl (P2 0 40) $ + runAdvObjectR1 (miniDisk `advance` text01 `advance` miniDisk) + + drawl (P2 0 0) $ + runAdvObjectR1 (miniDisk `advance` text02 `advance` miniDisk) + + -- Normally, text calculate the advance vector from the font -- metrics... -- -text01 :: Num u => AdvGraphic u -text01 = replaceAns (hvec 84) $ textline "text01" +text01 :: AdvObject Double +text01 = makeAdvObject (pure $ hvec 84) $ plainTextLine "text01" -text02 :: Num u => AdvGraphic u -text02 = replaceAns (hvec 210) $ textline "text number two" +text02 :: AdvObject Double +text02 = makeAdvObject (pure $ hvec 210) $ plainTextLine "text number two" -miniDisk :: Num u => AdvGraphic u -miniDisk = replaceAns (V2 0 0) $ localize (fillColour sienna) $ filledDisk 3 +miniDisk :: AdvObject Double +miniDisk = makeAdvObject (pure $ V2 0 0) disk1 + where + disk1 = localize (fill_colour sienna) $ filledDisk 3 sienna :: RGBi diff --git a/demo/SimplePosImage.hs b/demo/SimplePosImage.hs deleted file mode 100644 --- a/demo/SimplePosImage.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# OPTIONS -Wall #-} - - -module SimplePosImage where - -import Wumpus.Basic.Kernel - -import Wumpus.Core -- package: wumpus-core -import Wumpus.Core.Colour ( red ) - -import System.Directory - -main :: IO () -main = do - createDirectoryIfMissing True "./out/" - let pic1 = runCtxPictureU std_attr drawing01 - writeEPS "./out/simple_pos_image01.eps" pic1 - writeSVG "./out/simple_pos_image01.svg" pic1 - - -std_attr :: DrawingContext -std_attr = standardContext 24 - - -drawing01 :: DCtxPicture -drawing01 = drawTracing $ localize (fillColour red) $ mf - - -mf :: (Floating u, FromPtSize u) => TraceDrawing u () -mf = do - draw $ testDrawMinor NN `at` (P2 0 300) - draw $ testDrawMinor SS `at` (P2 75 300) - draw $ testDrawMinor EE `at` (P2 150 300) - draw $ testDrawMinor WW `at` (P2 225 300) - draw $ testDrawMinor NE `at` (P2 0 225) - draw $ testDrawMinor SE `at` (P2 75 225) - draw $ testDrawMinor SW `at` (P2 150 225) - draw $ testDrawMinor NW `at` (P2 225 225) - draw $ testDrawMinor CENTER `at` (P2 0 150) - draw $ testDrawBl CENTER `at` (P2 225 150) - draw $ testDrawBl NN `at` (P2 0 75) - draw $ testDrawBl SS `at` (P2 75 75) - draw $ testDrawBl EE `at` (P2 150 75) - draw $ testDrawBl WW `at` (P2 225 75) - draw $ testDrawBl NE `at` (P2 0 0) - draw $ testDrawBl SE `at` (P2 75 0) - draw $ testDrawBl SW `at` (P2 150 0) - draw $ testDrawBl NW `at` (P2 225 0) - - -testDrawBl :: Floating u => RectPosition -> LocGraphic u -testDrawBl rpos = filledDisk 2 `oplus` (rectBl `startPos` rpos) - -rectBl :: Floating u => PosGraphic u -rectBl = makePosImage opos (mkRectBl w h) - where - w = 40 - h = 20 - opos = ObjectPos { op_x_minor = 0 - , op_x_major = w - , op_y_minor = 0 - , op_y_major = h } - - --- start-point - bottom left -mkRectBl :: Floating u => u -> u -> LocGraphic u -mkRectBl w h = promoteR1 $ \bl -> - let br = displaceH w bl - tr = displaceV h br - tl = displaceV h bl - in closedStroke $ vertexPath [bl, br, tr, tl] - - - -testDrawMinor :: Floating u => RectPosition -> LocGraphic u -testDrawMinor rpos = filledDisk 2 `oplus` (rectMinor `startPos` rpos) - -rectMinor :: Floating u => PosGraphic u -rectMinor = makePosImage opos (mkRectMinor m w h) - where - m = 10 - w = 40 - h = 20 - opos = ObjectPos { op_x_minor = m - , op_x_major = (w-m) - , op_y_minor = m - , op_y_major = (h-m) } - - --- start-point - +10 +10 -mkRectMinor :: Floating u => u -> u -> u -> LocGraphic u -mkRectMinor m w h = promoteR1 $ \pt -> - let bl = displaceVec (vec (-m) (-m)) pt - br = displaceH w bl - tr = displaceV h br - tl = displaceV h bl - in closedStroke $ vertexPath [bl, br, tr, tl] - diff --git a/demo/SimplePosObject.hs b/demo/SimplePosObject.hs new file mode 100644 --- /dev/null +++ b/demo/SimplePosObject.hs @@ -0,0 +1,108 @@ +{-# OPTIONS -Wall #-} + + +module SimplePosObject where + +import Wumpus.Basic.Kernel + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Colour ( red ) + +import System.Directory + + + +main :: IO () +main = do + createDirectoryIfMissing True "./out/" + let pic1 = runCtxPictureU std_ctx drawing01 + writeEPS "./out/simple_pos_object01.eps" pic1 + writeSVG "./out/simple_pos_object01.svg" pic1 + + +std_ctx :: DrawingContext +std_ctx = standardContext 24 + + +drawing01 :: CtxPicture +drawing01 = drawTracing $ localize (fill_colour red) $ mf + + +mf :: TraceDrawing Double () +mf = do + draw $ testDrawMinor NN `at` (P2 0 400) + draw $ testDrawMinor SS `at` (P2 75 400) + draw $ testDrawMinor EE `at` (P2 150 400) + draw $ testDrawMinor WW `at` (P2 225 400) + draw $ testDrawMinor NE `at` (P2 0 325) + draw $ testDrawMinor SE `at` (P2 75 325) + draw $ testDrawMinor SW `at` (P2 150 325) + draw $ testDrawMinor NW `at` (P2 225 325) + draw $ testDrawMinor CENTER `at` (P2 0 250) + draw $ testDrawMinor BLL `at` (P2 75 250) + draw $ testDrawMinor BLC `at` (P2 150 250) + draw $ testDrawMinor BLR `at` (P2 225 250) + + + draw $ testDrawBl NN `at` (P2 0 150) + draw $ testDrawBl SS `at` (P2 75 150) + draw $ testDrawBl EE `at` (P2 150 150) + draw $ testDrawBl WW `at` (P2 225 150) + draw $ testDrawBl NE `at` (P2 0 75) + draw $ testDrawBl SE `at` (P2 75 75) + draw $ testDrawBl SW `at` (P2 150 75) + draw $ testDrawBl NW `at` (P2 225 75) + draw $ testDrawBl CENTER `at` (P2 0 0) + draw $ testDrawBl BLL `at` (P2 75 0) + draw $ testDrawBl BLC `at` (P2 150 0) + draw $ testDrawBl BLR `at` (P2 225 0) + + +testDrawBl :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u +testDrawBl rpos = + filledDisk 2 `oplus` (pushR1 ignoreAns $ rectBl `startAddr` rpos) + +rectBl :: (Fractional u, InterpretUnit u) => BoundedLocRectGraphic u +rectBl = runPosObjectR2 $ makePosObject (return ortt) (mkRectBl w h) + where + w = 40 + h = 30 + ortt = Orientation { or_x_minor = 0 + , or_x_major = w + , or_y_minor = 0 + , or_y_major = h } + + +-- start-point - bottom left +mkRectBl :: InterpretUnit u => u -> u -> LocGraphic u +mkRectBl w h = strokedRectangle w h + + + +testDrawMinor :: (Floating u, InterpretUnit u) => RectAddress -> LocGraphic u +testDrawMinor rpos = + filledDisk 2 `oplus` (pushR1 ignoreAns $ rectMinor `startAddr` rpos) + + +rectMinor :: (Fractional u, InterpretUnit u) => BoundedLocRectGraphic u +rectMinor = + runPosObjectR2 $ makePosObject (return ortt) (mkRectMinor m w h) + where + m = 10 + w = 40 + h = 30 + ortt = Orientation { or_x_minor = m + , or_x_major = (w-m) + , or_y_minor = m + , or_y_major = (h-m) } + + +-- start-point - +10 +10 +mkRectMinor :: InterpretUnit u => u -> u -> u -> LocGraphic u +mkRectMinor m w h = promoteR1 $ \pt -> + let bl = displaceVec (vec (-m) (-m)) pt + br = displaceH w bl + tr = displaceV h br + tl = displaceV h bl + in vertexPP [bl, br, tr, tl] >>= closedStroke + diff --git a/src/Wumpus/Basic/Geometry.hs b/src/Wumpus/Basic/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Geometry.hs @@ -0,0 +1,31 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Import shim for @Wumpus.Basic.Geometry@ modules. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Geometry + ( + module Wumpus.Basic.Geometry.Base + , module Wumpus.Basic.Geometry.Intersection + , module Wumpus.Basic.Geometry.Paths + , module Wumpus.Basic.Geometry.Quadrant + + ) where + + +import Wumpus.Basic.Geometry.Base +import Wumpus.Basic.Geometry.Intersection +import Wumpus.Basic.Geometry.Paths +import Wumpus.Basic.Geometry.Quadrant diff --git a/src/Wumpus/Basic/Geometry/Base.hs b/src/Wumpus/Basic/Geometry/Base.hs --- a/src/Wumpus/Basic/Geometry/Base.hs +++ b/src/Wumpus/Basic/Geometry/Base.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -19,7 +18,8 @@ ( -- * constants - half_pi + quarter_pi + , half_pi , two_pi -- * 2x2 Matrix @@ -75,13 +75,18 @@ -half_pi :: Floating u => u -half_pi = 0.5*pi -two_pi :: Floating u => u -two_pi = 2*pi +quarter_pi :: Floating u => u +quarter_pi = 0.25 * pi +half_pi :: Floating u => u +half_pi = 0.5 * pi + +two_pi :: Floating u => u +two_pi = 2.0 * pi + + -------------------------------------------------------------------------------- -- 2x2 matrix @@ -99,9 +104,7 @@ type DMatrix2'2 = Matrix2'2 Double -type instance DUnit (Matrix2'2 u) = u - instance Functor Matrix2'2 where fmap f (M2'2 a b c d) = M2'2 (f a) (f b) (f c) (f d) @@ -166,7 +169,6 @@ type DLineEquation = LineEquation Double -type instance DUnit (LineEquation u) = u -- | 'lineEquation' : @ point1 * point2 -> LineEquation @ -- @@ -230,7 +232,6 @@ type DLineSegment = LineSegment Double -type instance DUnit (LineSegment u) = u @@ -276,7 +277,6 @@ type DBezierCurve = BezierCurve Double -type instance DUnit (BezierCurve u) = u @@ -291,9 +291,9 @@ -- The result is found through repeated subdivision so the -- calculation is potentially costly. -- -bezierLength :: (Floating u, Ord u, FromPtSize u) +bezierLength :: (Floating u, Ord u, Tolerance u) => BezierCurve u -> u -bezierLength = gravesenLength (fromPtSize 0.1) +bezierLength = gravesenLength length_tolerance @@ -408,7 +408,7 @@ -- > ang should be in the range 0 < ang <= 90deg. -- bezierMinorArc :: Floating u - => Radian -> u -> Radian -> Point2 u -> BezierCurve u + => Radian -> u -> Radian -> Point2 u -> BezierCurve u bezierMinorArc ang radius theta pt = BezierCurve p0 c1 c2 p3 where kfactor = fromRadian $ ang / (0.5*pi) diff --git a/src/Wumpus/Basic/Geometry/Intersection.hs b/src/Wumpus/Basic/Geometry/Intersection.hs --- a/src/Wumpus/Basic/Geometry/Intersection.hs +++ b/src/Wumpus/Basic/Geometry/Intersection.hs @@ -20,16 +20,13 @@ module Wumpus.Basic.Geometry.Intersection ( - LineSegment - , interLineLine + interLineLine , interLinesegLineseg , interLinesegLine , interCurveLine , findIntersect , makePlane - , rectangleLineSegments - , polygonLineSegments ) @@ -85,7 +82,7 @@ -- An answer of @Nothing@ indicates that the line segments -- coincide, or that there is no intersection. -- -interLinesegLineseg :: (Fractional u, Ord u, FromPtSize u) +interLinesegLineseg :: (Fractional u, Ord u, Tolerance u) => LineSegment u -> LineSegment u -> Maybe (Point2 u) interLinesegLineseg a@(LineSegment p q) b@(LineSegment s t) = interLineLine (p,q) (s,t) >>= segcheck @@ -101,7 +98,7 @@ -- An answer of @Nothing@ indicates that the the line and line -- segment coincide, or that there is no intersection. -- -interLinesegLine :: (Fractional u, Ord u, FromPtSize u) +interLinesegLine :: (Fractional u, Ord u, Tolerance u) => LineSegment u -> (Point2 u, Point2 u) -> Maybe (Point2 u) interLinesegLine a@(LineSegment p q) line = interLineLine (p,q) line >>= segcheck @@ -117,30 +114,28 @@ -- Note - this function is to be used \*after\* an intersection -- has been found. Hence it is not export. -- -withinPoints :: (Ord u, FromPtSize u) => Point2 u -> LineSegment u -> Bool +withinPoints :: (Ord u, Fractional u, Tolerance u) + => Point2 u -> LineSegment u -> Bool withinPoints (P2 x y) (LineSegment (P2 x0 y0) (P2 x1 y1)) = between x (ordpair x0 x1) && between y (ordpair y0 y1) where ordpair a b = (min a b, max a b) between a (s,t) = (s `tGT` a) && (a `tGT` t) - tGT a b = a < b || abs (a-b) < tolerance --- | Note - its important to use tolerance for the @withPoints@ --- function. --- -tolerance :: FromPtSize u => u -tolerance = fromPtSize 0.01 - +pve :: (Fractional u, Ord u, Tolerance u) => u -> Bool +pve a = a > eq_tolerance +nve :: (Fractional u, Ord u, Tolerance u) => u -> Bool +nve a = a < (negate eq_tolerance) -------------------------------------------------------------------------------- -- intersection of line and Bezier curve -interCurveLine :: (Floating u , Ord u, FromPtSize u) +interCurveLine :: (Floating u , Ord u, Tolerance u) => BezierCurve u -> (Point2 u, Point2 u) -> Maybe (Point2 u) interCurveLine c0 (p,q) = step c0 where @@ -159,16 +154,13 @@ -- as it saves performing a subdivision. But make the return type -- a bit involved. -- -cut :: (Floating u , Ord u, FromPtSize u) +cut :: (Floating u , Ord u, Tolerance u) => BezierCurve u -> LineEquation u -> Either (Point2 u) Bool cut (BezierCurve p0 p1 p2 p3) line = if d0 `tEQ` 0 then Left p0 else if d3 `tEQ` 0 then Left p3 else let ds = [d0,d1,d2,d3] in Right $ not $ all pve ds || all nve ds where - tEQ = \a b -> abs (a-b) < tolerance - pve = \a -> a > tolerance - nve = \a -> a < (negate tolerance) d0 = pointLineDistance p0 line d1 = pointLineDistance p1 line d2 = pointLineDistance p2 line @@ -190,9 +182,9 @@ -- at angle @theta@ and the supplied line segments, if there -- is one. -- -findIntersect :: (Floating u, Real u, Ord u, FromPtSize u) - => Point2 u -> Radian -> [LineSegment u] - -> Maybe (Point2 u) +findIntersect :: (Floating u, Real u, Ord u, Tolerance u) + => Point2 u -> Radian -> [LineSegment u] + -> Maybe (Point2 u) findIntersect radial_ogin ang = step where plane = makePlane radial_ogin ang diff --git a/src/Wumpus/Basic/Geometry/Paths.hs b/src/Wumpus/Basic/Geometry/Paths.hs --- a/src/Wumpus/Basic/Geometry/Paths.hs +++ b/src/Wumpus/Basic/Geometry/Paths.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -18,7 +19,24 @@ module Wumpus.Basic.Geometry.Paths ( - LocCoordPath + + PathAlg + , runPathAlgPoint + , runPathAlgVec + , pathStartIsStart + , pathStartIsLocus + , pathIterateLocus + + , rectanglePathAlg + , blRectanglePathAlg + + , diamondPathAlg + , polygonPathAlg + + , arcPathAlg + , circlePathAlg + + , LocCoordPath , coordinatePrimPath , rectangleCoordPath @@ -31,14 +49,202 @@ ) where +import Wumpus.Basic.Geometry.Base +import Wumpus.Basic.Kernel + import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space - +import Data.VectorSpace import Data.List ( unfoldr ) +data PathAlgScheme = START_IS_START | START_IS_LOCUS + deriving (Enum,Eq,Ord,Show) + + +-- | A vector chain building a path. +-- +-- The vectors are relative to the predecessor, so the +-- rendering of a 'PathAlg' iterates the start point. +-- +-- A polygon PathAlg should have steps for all sides of the +-- polygon with the end point generated by the last vector +-- coinciding with thet start point. +-- +data PathAlg u = PathAlg { path_alg_scheme :: PathAlgScheme + , path_alg_steps :: [Vec2 u] + } + + +type instance DUnit (PathAlg u) = u + +runPathAlgPoint :: Num u => Point2 u -> PathAlg u -> [Point2 u] +runPathAlgPoint _ (PathAlg _ []) = [] +runPathAlgPoint p0 (PathAlg scm (v0:xs)) + | scm == START_IS_START = p0 : step (p0 .+^ v0) xs + | otherwise = step (p0 .+^ v0) xs + where + step pt [] = [pt] + step pt (v:vs) = pt : step (pt .+^ v) vs + + +runPathAlgVec :: PathAlg u -> (Maybe (Vec2 u), [Vec2 u]) +runPathAlgVec (PathAlg START_IS_LOCUS (v:vs)) = (Just v, vs) +runPathAlgVec (PathAlg _ vs) = (Nothing, vs) + + + +-- TO CLARIFY - should all four side paths of a rectangle be +-- generated, or three sides with the implication that close forms +-- the fourth? +-- + +pathStartIsStart :: [Vec2 u] -> PathAlg u +pathStartIsStart vs = PathAlg { path_alg_scheme = START_IS_START + , path_alg_steps = vs } + + + +pathStartIsLocus :: [Vec2 u] -> PathAlg u +pathStartIsLocus vs = PathAlg { path_alg_scheme = START_IS_LOCUS + , path_alg_steps = vs } + +-- | Note this creates a path very the first vector represents a +-- @moveto@, then the subsequence vectors represent @linetos@. +-- +pathIterateLocus :: Num u => [Vec2 u] -> PathAlg u +pathIterateLocus [] = pathStartIsLocus [] +pathIterateLocus (v0:xs) = pathStartIsLocus $ v0 : step v0 xs + where + step v1 [] = [v0 ^-^ v1] + step v1 (v2:vs) = (v2 ^-^ v1) : step v2 vs + + + + +-- | Supplied point is /center/, the genearated points are +-- counter-clockwise so [ bl, br, tr, tl ] . +-- +rectanglePathAlg :: Fractional u => u -> u -> PathAlg u +rectanglePathAlg w h = pathStartIsLocus [ vbl, vbr, vtr, vtl ] + where + vbl = vec (negate $ 0.5*w) (negate $ 0.5*h) + vbr = hvec w + vtr = vvec h + vtl = hvec (-w) + +-- | Supplied point is /bottom-left/, subsequent points are +-- counter-clockwise so [ bl, br, tr, tl ] . +-- +blRectanglePathAlg :: Num u => u -> u -> PathAlg u +blRectanglePathAlg w h = pathStartIsStart [ vbr, vtr, vtl, vbl ] + where + vbr = hvec w + vtr = vvec h + vtl = hvec (-w) + vbl = vvec (-h) + + + + +-- | 'diamondPathAlg' : @ half_width * half_height -> PathAlg @ +-- +diamondPathAlg :: Num u => u -> u -> PathAlg u +diamondPathAlg hw hh = pathIterateLocus [ vs,ve,vn,vw ] + where + vs = vvec (-hh) + ve = hvec hw + vn = vvec hh + vw = hvec (-hw) + + +-- | 'polygonPathAlg' : @ num_points * radius -> PathAlg @ +-- +polygonPathAlg :: Floating u => Int -> u -> PathAlg u +polygonPathAlg n radius = pathIterateLocus $ unfoldr phi (0,top) + where + top = 0.5*pi + theta = (2*pi) / fromIntegral n + + phi (i,ang) | i < n = Just (avec ang radius, (i+1,ang+theta)) + | otherwise = Nothing + + +arcPathAlg :: Floating u => u -> Radian -> Radian -> PathAlg u +arcPathAlg r ang1 ang2 = pathStartIsLocus $ step1 $ arcdiv ang1 ang2 + where + step1 [] = [] + step1 ((a,b):xs) = let (v0,v1,v2,v3) = minorArcQuadVec r a b + in v0 : v1: v2: v3 : step xs + + step [] = [] + step ((a,b):xs) = let (_,v1,v2,v3) = minorArcQuadVec r a b + in v1: v2: v3 : step xs + + + +-- | Helper - generate four vectors building a minor (<90 deg) +-- arc. +-- +-- The first vec is from center - for cumulative arcs this should +-- only taken once. +-- +minorArcQuadVec :: Floating u + => u -> Radian -> Radian -> (Vec2 u, Vec2 u, Vec2 u, Vec2 u) +minorArcQuadVec r ang1 ang2 = (v0, v1, v2, v3) + where + (p1,p2,p3,p4) = bezierArc r ang1 ang2 zeroPt + v0 = pvec zeroPt p1 + v1 = pvec p1 p2 + v2 = pvec p2 p3 + v3 = pvec p3 p4 + + +circlePathAlg :: (Fractional u, Floating u) + => u -> PathAlg u +circlePathAlg r = pathStartIsLocus vs + where + vs = hvec r : diff (flip pvec) (bezierCircle r zeroPt) + + + + +-- | Helper - diff +-- +-- Note diff relies on the pointlist cycling the endpoint +-- +-- > [p0, ..., p0] +-- +-- This is how Wumpus-Core generates Bezier circles. +-- +diff :: (a -> a -> b) -> [a] -> [b] +diff _ [] = [] +diff op (x:xs) = step x xs + where + step _ [] = [] + step a (b:bs) = b `op` a : step b bs + +-- | Helper - divide an arc into quadrants plus remainder. +-- +arcdiv :: Radian -> Radian -> [(Radian,Radian)] +arcdiv ang1 ang2 | ang1 > ang2 = step ang1 (ang2 + 2 * pi) + | otherwise = step ang1 ang2 + where + step a1 a2 | a1 == a2 = [] + step a1 a2 | a2 - a1 > half_pi = norm (a1,a1+half_pi) : step (a1+half_pi) a2 + | otherwise = [(a1,a2)] + + norm (a,b) = (circularModulo a, circularModulo b) + + + +-- arcs - wedges - circles... + +--------------------------------------------------------------------------- +-- OLD ... + -- | A functional type from /initial point/ to point list. -- type LocCoordPath u = Point2 u -> [Point2 u] @@ -51,17 +257,16 @@ -- The Path data type will also need a similar function... -- -coordinatePrimPath :: Num u => Point2 u -> LocCoordPath u -> PrimPath u -coordinatePrimPath pt fn = go (fn pt) - where - go ps@(_:_) = vertexPath ps - go [] = emptyPath pt -- fallback +-- | Relative unit version of 'coordinatePrimPathAU'. +-- +coordinatePrimPath :: InterpretUnit u + => LocCoordPath u -> Point2 u -> Query PrimPath +coordinatePrimPath fn pt = vertexPP $ fn pt --- NOTE - These functions need changing to generate LocCoordPaths... -- | Supplied point is /bottom-left/, subsequenct points are --- counter-clockise so [ bl, br, tr, tl ] . +-- counter-clockwise so [ bl, br, tr, tl ] . -- rectangleCoordPath :: Num u => u -> u -> LocCoordPath u rectangleCoordPath w h bl = [ bl, br, tr, tl ] diff --git a/src/Wumpus/Basic/Kernel.hs b/src/Wumpus/Basic/Kernel.hs --- a/src/Wumpus/Basic/Kernel.hs +++ b/src/Wumpus/Basic/Kernel.hs @@ -17,43 +17,54 @@ module Wumpus.Basic.Kernel ( - module Wumpus.Basic.Kernel.Base.Anchors - , module Wumpus.Basic.Kernel.Base.BaseDefs + module Wumpus.Basic.Kernel.Base.BaseDefs , module Wumpus.Basic.Kernel.Base.ContextFun , module Wumpus.Basic.Kernel.Base.DrawingContext - , module Wumpus.Basic.Kernel.Base.GlyphMetrics + , module Wumpus.Basic.Kernel.Base.FontSupport , module Wumpus.Basic.Kernel.Base.QueryDC - , module Wumpus.Basic.Kernel.Base.ScalingContext + , module Wumpus.Basic.Kernel.Base.Units , module Wumpus.Basic.Kernel.Base.UpdateDC , module Wumpus.Basic.Kernel.Base.WrappedPrimitive - , module Wumpus.Basic.Kernel.Objects.AdvanceGraphic - , module Wumpus.Basic.Kernel.Objects.BaseObjects + , module Wumpus.Basic.Kernel.Objects.AdvObject + , module Wumpus.Basic.Kernel.Objects.Anchors + , module Wumpus.Basic.Kernel.Objects.Basis , module Wumpus.Basic.Kernel.Objects.Bounded + , module Wumpus.Basic.Kernel.Objects.Chain + , module Wumpus.Basic.Kernel.Objects.Concat , module Wumpus.Basic.Kernel.Objects.Connector , module Wumpus.Basic.Kernel.Objects.CtxPicture , module Wumpus.Basic.Kernel.Objects.Displacement , module Wumpus.Basic.Kernel.Objects.DrawingPrimitives - , module Wumpus.Basic.Kernel.Objects.Graphic - , module Wumpus.Basic.Kernel.Objects.PosImage + , module Wumpus.Basic.Kernel.Objects.Image + , module Wumpus.Basic.Kernel.Objects.LocImage + , module Wumpus.Basic.Kernel.Objects.LocThetaImage + , module Wumpus.Basic.Kernel.Objects.Orientation + , module Wumpus.Basic.Kernel.Objects.PosObject , module Wumpus.Basic.Kernel.Objects.TraceDrawing + ) where -import Wumpus.Basic.Kernel.Base.Anchors import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext -import Wumpus.Basic.Kernel.Base.GlyphMetrics +import Wumpus.Basic.Kernel.Base.FontSupport import Wumpus.Basic.Kernel.Base.QueryDC -import Wumpus.Basic.Kernel.Base.ScalingContext +import Wumpus.Basic.Kernel.Base.Units import Wumpus.Basic.Kernel.Base.UpdateDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive -import Wumpus.Basic.Kernel.Objects.AdvanceGraphic -import Wumpus.Basic.Kernel.Objects.BaseObjects +import Wumpus.Basic.Kernel.Objects.AdvObject +import Wumpus.Basic.Kernel.Objects.Anchors +import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.Bounded +import Wumpus.Basic.Kernel.Objects.Chain +import Wumpus.Basic.Kernel.Objects.Concat import Wumpus.Basic.Kernel.Objects.Connector import Wumpus.Basic.Kernel.Objects.CtxPicture import Wumpus.Basic.Kernel.Objects.Displacement import Wumpus.Basic.Kernel.Objects.DrawingPrimitives -import Wumpus.Basic.Kernel.Objects.Graphic -import Wumpus.Basic.Kernel.Objects.PosImage +import Wumpus.Basic.Kernel.Objects.Image +import Wumpus.Basic.Kernel.Objects.LocImage +import Wumpus.Basic.Kernel.Objects.LocThetaImage +import Wumpus.Basic.Kernel.Objects.Orientation +import Wumpus.Basic.Kernel.Objects.PosObject import Wumpus.Basic.Kernel.Objects.TraceDrawing diff --git a/src/Wumpus/Basic/Kernel/Base/Anchors.hs b/src/Wumpus/Basic/Kernel/Base/Anchors.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Base/Anchors.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Kernel.Base.Anchors --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Anchor points on shapes, bounding boxes, etc. --- --- Anchors are addressable positions, an examplary use is taking --- anchors on node shapes to get the start and end points for --- connectors in a network (graph) diagram. --- --- \*\* WARNING \*\* - The API here needs some thought as to a --- good balance of the type classes - in a nutshell \"are corners --- better than cardinals\". Originally I tried to follow how I --- understand the TikZ anchors to work, but this is perhaps not --- ideal for dividing into type-classes. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Kernel.Base.Anchors - ( - - -- * Anchors - CenterAnchor(..) - , ApexAnchor(..) - , CardinalAnchor(..) - , CardinalAnchor2(..) - , RadialAnchor(..) - , TopCornerAnchor(..) - , BottomCornerAnchor(..) - , SideMidpointAnchor(..) - - - -- * Extended anchor points - , projectAnchor - - , radialConnectorPoints - - ) where - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - - --- | Center of an object. --- -class CenterAnchor t where - center :: DUnit t ~ u => t -> Point2 u - - --- | Apex of an object. --- -class ApexAnchor t where - apex :: DUnit t ~ u => t -> Point2 u - - --- | Cardinal (compass) positions on an object. --- --- Note - in TikZ cardinal anchors are not necessarily at the --- equivalent radial position, for instance reactangle north-east --- is the top-right corner whether or not this is incident at --- 45deg. --- --- Wumpus generally follows the TikZ convention. --- -class CardinalAnchor t where - north :: DUnit t ~ u => t -> Point2 u - south :: DUnit t ~ u => t -> Point2 u - east :: DUnit t ~ u => t -> Point2 u - west :: DUnit t ~ u => t -> Point2 u - --- --- Note - a design change is probably in order where the cardinals --- should /always/ represent their true cardinal position. --- --- If this change is made, it is worthwhile having cardinals as --- classes (rather than making them derived operations on --- RadialAnchor) as classes allow for more efficient --- implementations usually by trigonometry. --- - - --- | Secondary group of cardinal (compass) positions on an object. --- --- It seems possible that for some objects defining the primary --- compass points (north, south,...) will be straight-forward --- whereas defining the secondary compass points may be --- problematic, hence the compass points are split into two --- classes. --- -class CardinalAnchor2 t where - northeast :: DUnit t ~ u => t -> Point2 u - southeast :: DUnit t ~ u => t -> Point2 u - southwest :: DUnit t ~ u => t -> Point2 u - northwest :: DUnit t ~ u => t -> Point2 u - - --- | Anchor on a border that can be addressed by an angle. --- --- The angle is counter-clockwise from the right-horizontal, i.e. --- 0 is /east/. --- -class RadialAnchor t where - radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u - - --- | Anchors at the top left and right corners of a shape. --- --- For some shapes (Rectangle) the TikZ convention appears to be --- have cardinals as the corner anchors, but this doesn\'t seem --- to be uniform. Wumpus will need to reconsider anchors at some --- point... --- -class TopCornerAnchor t where - topLeftCorner :: DUnit t ~ u => t -> Point2 u - topRightCorner :: DUnit t ~ u => t -> Point2 u - - --- | Anchors at the bottom left and right corners of a shape. --- -class BottomCornerAnchor t where - bottomLeftCorner :: DUnit t ~ u => t -> Point2 u - bottomRightCorner :: DUnit t ~ u => t -> Point2 u - - --- | Anchors in the center of a side. --- --- Sides are addressable by index. Following TikZ, side 1 is --- expected to be the top of the shape. If the shape has an apex --- instead of a side then side 1 is expected to be the first side --- left of the apex. --- --- Implementations are also expected to modulo the side number, --- rather than throw an out-of-bounds error. --- -class SideMidpointAnchor t where - sideMidpoint :: DUnit t ~ u => Int -> t -> Point2 u - - - --------------------------------------------------------------------------------- - --- | 'projectAnchor' : @ extract_func * dist * object -> Point @ --- --- Derive a anchor by projecting a line from the center of an --- object through the intermediate anchor (produced by the --- extraction function). The final answer point is located along --- the projected line at the supplied distance @dist@. --- --- E.g. take the north of a rectangle and project it 10 units --- further on: --- --- > projectAnchor north 10 my_rect --- --- If the distance is zero the answer with be whatever point the --- the extraction function produces. --- --- If the distance is negative the answer will be along the --- projection line, between the center and the intermediate anchor. --- --- If the distance is positive the anchor will be extend outwards --- from the intermediate anchor. --- -projectAnchor :: (Real u, Floating u, u ~ DUnit t, CenterAnchor t) - => (t -> Point2 u) -> u -> t -> Point2 u -projectAnchor f d a = p1 .+^ (avec ang d) - where - p1 = f a - v = pvec (center a) p1 - ang = vdirection v - - - --------------------------------------------------------------------------------- - --- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @ --- --- Find the radial connectors points for objects @a@ and @b@ along --- the line joining their centers. --- -radialConnectorPoints :: ( Real u, Floating u - , CenterAnchor t1, RadialAnchor t1 - , CenterAnchor t2, RadialAnchor t2 - , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) - => t1 -> t2 -> (Point2 u, Point2 u) -radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b) - where - theta = vdirection $ pvec (center a) (center b) - - --------------------------------------------------------------------------------- --- Instances - -instance Fractional u => CenterAnchor (BoundingBox u) where - center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y - where - x = xl+0.5*(xr-xl) - y = ylo+0.5*(yhi-ylo) - - -instance Fractional u => CardinalAnchor (BoundingBox u) where - north (BBox (P2 xl _ ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi - south (BBox (P2 xl ylo) (P2 xr _ )) = P2 (xl+0.5*(xr-xl)) ylo - east (BBox (P2 _ ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo)) - west (BBox (P2 xl ylo) (P2 _ yhi)) = P2 xl (ylo+0.5*(yhi-ylo)) - - -instance Fractional u => CardinalAnchor2 (BoundingBox u) where - northeast (BBox _ ur) = ur - southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo - southwest (BBox ll _) = ll - northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi - diff --git a/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs --- a/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +++ b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs @@ -1,13 +1,10 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernal.Base.BaseDefs --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -21,16 +18,35 @@ module Wumpus.Basic.Kernel.Base.BaseDefs ( + + MonUnit -- * A semigroup class - OPlus(..) + , OPlus(..) , oconcat + , altconcat + -- * A bifunctor class , Bimap(..) , replaceL , replaceR + -- * Unit phantom type + , UNil(..) + + -- * Non-contextual unit conversion. + , ScalarUnit(..) + + -- * Unit interpretation with respect to the current Point size + , InterpretUnit(..) + , dinterpF + , normalizeF + , uconvert1 + , uconvertF + , intraMapPoint + , intraMapFunctor + -- * Alignment , HAlign(..) , VAlign(..) @@ -43,18 +59,29 @@ , advanceH , advanceV - - -- * Monadic drawing - , MonUnit - - , PointSupplyM(..) - ) where import Wumpus.Core -- package: wumpus-core import Data.VectorSpace -- package: vector-space +import Control.Applicative +import Data.Monoid + + + + + +-- | Type family to access the unit parameter of a TraceDrawing +-- or a promoted TraceDrawingT transformer. +-- +type family MonUnit m :: * + + + + + + infixr 6 `oplus` -- | A Semigroup class. @@ -66,6 +93,17 @@ class OPlus t where oplus :: t -> t -> t +-- | 'oconcat' : @ list_head * [rest] -> Ans @ +-- +-- Semigroup version of @mconcat@ from the module @Data.Monoid@. +-- +-- As a semigroup cannot build a zero value, /concat/ cannot +-- handle the empty list. So to make 'oconcat' a safe function +-- the input list is already destructured by one cons cell. +-- +-- Effectively this means that client code must handle the +-- empty list case, before calling 'oconcat'. +-- oconcat :: OPlus t => t -> [t] -> t oconcat t = step t where @@ -74,16 +112,35 @@ +-- | 'altconcat' : @ alternative * [list] -> Ans@ +-- +-- 'altconcat' uses 'oplus' to create a summary value from a list +-- of values. +-- +-- When supplied the empty list 'altconcat' returns the supplied +-- /alternative/ value. If the list is inhabited, the alternative +-- value is discarded. +-- +-- This contrasts to 'oconcat' where the single value represents +-- the head of an already destructured list. +-- +altconcat :: OPlus a => a -> [a] -> a +altconcat _ (x:xs) = oconcat x xs +altconcat alt [] = alt + + instance OPlus () where _ `oplus` _ = () -instance OPlus (UNil u) where - _ `oplus` _ = uNil +instance OPlus a => OPlus (Const a b) where + Const a0 `oplus` Const a1 = Const $ a0 `oplus` a1 + + instance Ord u => OPlus (BoundingBox u) where oplus = boundaryUnion -instance OPlus (Primitive u) where +instance OPlus Primitive where a `oplus` b = primGroup [a,b] instance (OPlus a, OPlus b) => OPlus (a,b) where @@ -144,7 +201,129 @@ -------------------------------------------------------------------------------- +-- Simple objects wrapped with unit phatom type + +-- | The empty data type - i.e. @()@ - wrapped with a phantom unit +-- parameter. +-- +data UNil u = UNil deriving (Eq,Ord,Read,Show) + +type instance DUnit (UNil u) = u + +instance Functor UNil where + fmap _ UNil= UNil + + +instance Monoid (UNil u) where + mempty = UNil + _ `mappend` _ = UNil + +instance OPlus (UNil u) where + _ `oplus` _ = UNil + + + + +instance Rotate (UNil u) where + rotate _ = id + +instance RotateAbout (UNil u) where + rotateAbout _ _ = id + +instance Scale (UNil u) where + scale _ _ = id + +instance Translate (UNil u) where + translate _ _ = id + +-------------------------------------------------------------------------------- +-- Non-contextual units + +class ScalarUnit a where + fromPsPoint :: Double -> a + toPsPoint :: a -> Double + +instance ScalarUnit Double where + fromPsPoint = id + toPsPoint = id + + + +-------------------------------------------------------------------------------- +-- Interpreting units + +-- Units may or may not depend on current font size +-- + +class Num u => InterpretUnit u where + normalize :: FontSize -> u -> Double + dinterp :: FontSize -> Double -> u + +instance InterpretUnit Double where + normalize _ = id + dinterp _ = id + +instance InterpretUnit AfmUnit where + normalize sz = afmValue sz + dinterp sz = afmUnit sz + + +-- | 'dinterp' an object that gives access to its unit at the +-- functor position. +-- +dinterpF :: (Functor t, InterpretUnit u) => FontSize -> t Double -> t u +dinterpF sz = fmap (dinterp sz) + + +-- | 'normalize' an object that gives access to its unit at the +-- functor position. +-- +normalizeF :: (Functor t, InterpretUnit u) => FontSize -> t u -> t Double +normalizeF sz = fmap (normalize sz) + + +-- | Convert a scalar value from one unit to another. +-- +uconvert1 :: (InterpretUnit u, InterpretUnit u1) => FontSize -> u -> u1 +uconvert1 sz = dinterp sz . normalize sz + +-- | Unit convert an object that gives access to its unit at the +-- Functor position. +-- +-- In practive this will be \*all\* Image answers. +-- +uconvertF :: (Functor t, InterpretUnit u, InterpretUnit u1) + => FontSize -> t u -> t u1 +uconvertF sz = fmap (uconvert1 sz) + + + +-- Helper for defining Affine instances. This function allows +-- scaling etc to be applied on a Point coerced to a Double then +-- converted back to the original unit. Thus transformations can +-- work in contextual units. +-- +intraMapPoint :: InterpretUnit u + => FontSize -> (DPoint2 -> DPoint2) -> Point2 u -> Point2 u +intraMapPoint sz fn (P2 x y) = + let P2 x' y' = fn $ P2 (normalize sz x) (normalize sz y) + in P2 (dinterp sz x') (dinterp sz y') + + + +-- Helper for defining Affine instances. This function allows +-- scaling etc to be applied on a Point coerced to a Double then +-- converted back to the original unit. Thus transformations can +-- work in contextual units. +-- +intraMapFunctor :: (Functor f, InterpretUnit u) + => FontSize -> (f Double -> f Double) -> f u -> f u +intraMapFunctor sz fn ma = dinterpF sz $ fn $ normalizeF sz ma + + +-------------------------------------------------------------------------------- + -- Alignment -- | Horizontal alignment - align to the top, center or bottom. @@ -195,22 +374,3 @@ advanceV (V2 _ h) = h - - --------------------------------------------------------------------------------- --- Monadic drawing - --- | DUnit is always for fully saturated type constructors, so --- (seemingly) an equivalent type family is needed for monads. - -type family MonUnit m :: * - - --- | A monad that supplies points, e.g. a turtle monad. --- --- \*\* WARNING \*\* - the idea behind this class is somewhat --- half-baked. It may be revised or even dropped in subsequent --- versions of Wumpus-Basic. --- -class Monad m => PointSupplyM (m :: * -> *) where - position :: MonUnit m ~ u => m (Point2 u) diff --git a/src/Wumpus/Basic/Kernel/Base/ContextFun.hs b/src/Wumpus/Basic/Kernel/Base/ContextFun.hs --- a/src/Wumpus/Basic/Kernel/Base/ContextFun.hs +++ b/src/Wumpus/Basic/Kernel/Base/ContextFun.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Base.ContextFun --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -18,57 +20,42 @@ module Wumpus.Basic.Kernel.Base.ContextFun ( - -- * /Context functional/ types + -- * /Context functional/ type CF - , CF1 - , CF2 - , LocCF - , LocThetaCF - , ConnectorCF - , DLocCF - , DLocThetaCF - , DConnectorCF + -- * Alias + , Query + -- * Run function + , runCF + -- * Construction + , consCF - -- * Run functions - , runCF - , runCF1 - , runCF2 + , domMap1 + , domMap2 - -- * Lift functions - , lift0R1 - , lift0R2 - , lift1R2 - , promoteR1 , promoteR2 + , pushR0 + , pushR1 + , pushR2 , apply1R1 - , apply2R2 , apply1R2 + , apply2R2 - -- * Extractors - , drawingCtx - , queryCtx - , locCtx - , locPoint - , locThetaCtx - , locThetaPoint - , locThetaAng - , connCtx - , connStart - , connEnd + , lift0R1 + , lift0R2 + , lift1R2 - -- * Combinators - , at - , rot - , atRot - , connect - , chain1 + , uconvR0 + , uconvR1 + , uconvR2a + , uconvR2ab + , drawingCtx ) where @@ -85,6 +72,9 @@ -------------------------------------------------------------------------------- -- +-- NOTE - 31.03.11 - is there an advantage to adding a phantom +-- unit param to the CF functions? + -- | Most drawing operations in Wumpus-Basic have an implicit -- /graphics state/ the 'DrawingContext', so the most primitive -- building block is a function from the DrawingContext to some @@ -95,121 +85,46 @@ -- -- > CF :: DrawingContext -> a -- -newtype CF a = CF { unCF :: DrawingContext -> a } +newtype CF a = CF { getCF :: DrawingContext -> a } +type instance DUnit (CF a) = DUnit a --- | Variation of 'CF' with one parametric /static argument/. --- --- The static argument is commonly a point representing the start --- point / origin of a drawing. --- --- > CF1 :: DrawingContext -> r1 -> a --- -newtype CF1 r1 a = CF1 { unCF1 :: DrawingContext -> r1 -> a } --- | Variation of 'CF' with two parametric /static arguments/. --- --- The first argument is commonly a point representing the start --- point / origin of a drawing. The second argument might --- typically be the angle of displacement (for drawing arrowheads) --- or an end point (for drawing connectors between two points). +-- | Alias for 'CF'. Wumpus considers Context functions that +-- don\'t produce graphics to be /queries/. -- --- > CF2 :: DrawingContext -> r1 -> r2 -> a +-- > Query :: DrawingContext -> a -- -newtype CF2 r1 r2 a = CF2 { unCF2 :: DrawingContext -> r1 -> r2 -> a } - +-- 'Query' has no unit type parameter. +-- +type Query a = CF a --- | Type specialized verison of 'CF1' where the /static argument/ --- is the /start point/. --- --- > LocCF :: DrawingContext -> Point2 u -> a --- -type LocCF u a = CF1 (Point2 u) a --- | Type specialized verison of 'CF2' where the /static arguments/ --- are the /start point/ and the /angle of displacement/. --- --- > LocThetaCF :: DrawingContext -> Point2 u -> Radian -> a --- -type LocThetaCF u a = CF2 (Point2 u) Radian a --- | Type specialized verison of 'CF2' where the /static arguments/ --- are the /start point/ and the /end point/. --- --- > ConnectorCF :: DrawingContext -> Point2 u -> Point2 u -> a --- -type ConnectorCF u a = CF2 (Point2 u) (Point2 u) a - - --- | Alias of 'LocCF' where the unit type is specialized to --- @Double@. --- -type DLocCF a = LocCF Double a - - --- | Alias of 'LocThetaCF' where the unit type is specialized to --- @Double@. --- -type DLocThetaCF a = LocThetaCF Double a - --- | Alias of 'ConnectorCF' where the unit type is specialized to --- @Double@. --- -type DConnectorCF a = ConnectorCF Double a - - - -------------------------------------------------------------------------------- -- CF instances -- OPlus instance OPlus a => OPlus (CF a) where - fa `oplus` fb = CF $ \ctx -> unCF fa ctx `oplus` unCF fb ctx - -instance OPlus a => OPlus (CF1 r1 a) where - fa `oplus` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `oplus` unCF1 fb ctx r1 - -instance OPlus a => OPlus (CF2 r1 r2 a) where - fa `oplus` fb = CF2 $ \ctx r1 r2 -> - unCF2 fa ctx r1 r2 `oplus` unCF2 fb ctx r1 r2 + fa `oplus` fb = CF $ \ctx -> getCF fa ctx `oplus` getCF fb ctx -- Monoid --- Nothing is stopping monoid instances, though in practice there --- might be few useful types (more in Semgigroup / OPlus)... - instance Monoid a => Monoid (CF a) where mempty = CF $ \_ -> mempty - fa `mappend` fb = CF $ \ctx -> unCF fa ctx `mappend` unCF fb ctx - -instance Monoid a => Monoid (CF1 r1 a) where - mempty = CF1 $ \_ _ -> mempty - fa `mappend` fb = CF1 $ \ctx r1 -> unCF1 fa ctx r1 `mappend` unCF1 fb ctx r1 - -instance Monoid a => Monoid (CF2 r1 r2 a) where - mempty = CF2 $ \_ _ _ -> mempty - fa `mappend` fb = CF2 $ \ctx r1 r2 -> - unCF2 fa ctx r1 r2 `mappend` unCF2 fb ctx r1 r2 - + fa `mappend` fb = CF $ \ctx -> getCF fa ctx `mappend` getCF fb ctx -- Functor instance Functor CF where - fmap f ma = CF $ \ctx -> f $ unCF ma ctx - - -instance Functor (CF1 r1) where - fmap f ma = CF1 $ \ctx r1 -> f $ unCF1 ma ctx r1 - -instance Functor (CF2 r1 r2) where - fmap f ma = CF2 $ \ctx r1 r2 -> f $ unCF2 ma ctx r1 r2 + fmap f ma = CF $ \ctx -> f $ getCF ma ctx @@ -217,69 +132,46 @@ instance Applicative CF where pure a = CF $ \_ -> a - mf <*> ma = CF $ \ctx -> let f = unCF mf ctx - a = unCF ma ctx + mf <*> ma = CF $ \ctx -> let f = getCF mf ctx + a = getCF ma ctx in f a -instance Applicative (CF1 r1) where - pure a = CF1 $ \_ _ -> a - mf <*> ma = CF1 $ \ctx r1 -> let f = unCF1 mf ctx r1 - a = unCF1 ma ctx r1 - in f a - -instance Applicative (CF2 r1 r2) where - pure a = CF2 $ \_ _ _ -> a - mf <*> ma = CF2 $ \ctx r1 r2 -> let f = unCF2 mf ctx r1 r2 - a = unCF2 ma ctx r1 r2 - in f a - - - - -- Monad instance Monad CF where return a = CF $ \_ -> a - ma >>= k = CF $ \ctx -> let a = unCF ma ctx in (unCF . k) a ctx - -instance Monad (CF1 r1) where - return a = CF1 $ \_ _ -> a - ma >>= k = CF1 $ \ctx r1 -> let a = unCF1 ma ctx r1 in (unCF1 . k) a ctx r1 - -instance Monad (CF2 r1 r2) where - return a = CF2 $ \_ _ _ -> a - ma >>= k = CF2 $ \ctx r1 r2 -> - let a = unCF2 ma ctx r1 r2 in (unCF2 . k) a ctx r1 r2 - + ma >>= k = CF $ \ctx -> let a = getCF ma ctx in (getCF . k) a ctx -- DrawingCtxM instance DrawingCtxM CF where askDC = CF $ \ctx -> ctx - localize upd df = CF $ \ctx -> unCF df (upd ctx) + localize upd df = CF $ \ctx -> getCF df (upd ctx) -instance DrawingCtxM (CF1 r1) where - askDC = CF1 $ \ctx _ -> ctx - localize upd df = CF1 $ \ctx r1 -> unCF1 df (upd ctx) r1 +-------------------------------------------------------------------------------- +-- Affine instances -instance DrawingCtxM (CF2 r1 r2) where - askDC = CF2 $ \ctx _ _ -> ctx - localize upd df = CF2 $ \ctx r1 r2 -> unCF2 df (upd ctx) r1 r2 --- Note - there is nothing determining a DUnit for the CF types, --- so it seems appropriate not to define affine instances. --- --- However affine instances can be made for the Image type in --- Objects.BaseObjects. --- +instance Rotate a => Rotate (CF a) where + rotate ang = fmap (rotate ang) +instance RotateAbout a => RotateAbout (CF a) where + rotateAbout ang pt = fmap (rotateAbout ang pt) +instance Scale a => Scale (CF a) where + scale sx sy = fmap (scale sx sy) + +instance Translate a => Translate (CF a) where + translate dx dy = fmap (translate dx dy) + + + -------------------------------------------------------------------------------- -- Run functions @@ -287,264 +179,127 @@ -- /DrawingContext/. -- runCF :: DrawingContext -> CF a -> a -runCF ctx df = unCF df ctx +runCF ctx cf = getCF cf ctx --- | Run a /CF1/ (context function) with the supplied --- /DrawingContext/ and static argument. --- -runCF1 :: DrawingContext -> r1 -> CF1 r1 a -> a -runCF1 ctx r1 df = unCF1 df ctx r1 - --- | Run a /CF1/ (context function) with the supplied --- /DrawingContext/ and two static arguments. +-- | Construction function. -- -runCF2 :: DrawingContext -> r1 -> r2 -> CF2 r1 r2 a -> a -runCF2 ctx r1 r2 df = unCF2 df ctx r1 r2 +consCF :: (DrawingContext -> a) -> CF a +consCF fn = CF $ \ctx -> fn ctx --------------------------------------------------------------------------------- --- lift functions --- | Lift a zero-arity context function 'CF' to an arity one --- context function 'CF1'. --- -lift0R1 :: CF a -> CF1 r1 a -lift0R1 mf = CF1 $ \ctx _ -> unCF mf ctx +domMap1 :: (r1 -> r1) -> CF (r1 -> a) -> CF (r1 -> a) +domMap1 f ma = CF $ \ctx -> + (\r1 -> let f1 = getCF ma ctx in f1 (f r1)) --- | Lift a zero-arity context function 'CF' to an arity two --- context function 'CF2'. --- -lift0R2 :: CF a -> CF2 r1 r2 a -lift0R2 mf = CF2 $ \ctx _ _ -> unCF mf ctx +domMap2 :: (r1 -> r1) -> (r2 -> r2) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a) +domMap2 f g ma = CF $ \ctx -> + (\r1 r2 -> let f1 = getCF ma ctx in f1 (f r1) (g r2)) --- | Lift an arity one context function 'CF1' to an arity two --- context function 'CF2'. --- -lift1R2 :: CF1 r1 a -> CF2 r1 r2 a -lift1R2 mf = CF2 $ \ctx r1 _ -> unCF1 mf ctx r1 +promoteR1 :: (r1 -> CF a) -> CF (r1 -> a) +promoteR1 mf = CF $ \ctx r1 -> getCF (mf r1) ctx --- | Promote a function @from one argument to a Context Function@ --- to an arity one @Context Function@. --- --- The type signature is as explanatory as a description: --- --- > promoteR1 :: (r1 -> CF a) -> CF1 r1 a --- -promoteR1 :: (r1 -> CF a) -> CF1 r1 a -promoteR1 mf = CF1 $ \ctx r1 -> unCF (mf r1) ctx +promoteR2 :: (r1 -> r2 -> CF a) -> CF (r1 -> r2 -> a) +promoteR2 mf = CF $ \ctx r1 r2 -> getCF (mf r1 r2) ctx --- | Promote a function @from two arguments to a Context Function@ --- to an arity two @Context Function@. +-- | Apply the value transformer to the answer of the context +-- function. Figuratively /push it right/ so it works on the +-- answer. -- --- The type signature is as explanatory as a description: +-- > pushR0 = fmap -- --- > promoteR2 :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a --- -promoteR2 :: (r1 -> r2 -> CF a) -> CF2 r1 r2 a -promoteR2 mf = CF2 $ \ctx r1 r2 -> unCF (mf r1 r2) ctx - +pushR0 :: (a -> a1) -> CF a -> CF a1 +pushR0 = fmap --- | Apply an arity-one Context Function to a single argument, --- downcasting it by one level, making an arity-zero Context --- function. --- --- The type signature is as explanatory as a description: --- --- > apply1R1 :: CF1 r1 a -> r1 -> CF a +-- | Apply the value transformer to the answer of the context +-- function. Figuratively /push it right/ so it works on the +-- answer. -- -apply1R1 :: CF1 r1 a -> r1 -> CF a -apply1R1 mf r1 = CF $ \ctx -> unCF1 mf ctx r1 - - --- | Apply an arity-two Context Function to two arguments, --- downcasting it by two levels, making an arity-zero Context --- function. --- --- The type signature is as explanatory as a description: +-- > pushR1 = fmap . fmap -- --- > apply2R2 :: CF2 r1 r2 a -> r1 -> r2 -> CF a --- -apply2R2 :: CF2 r1 r2 a -> r1 -> r2 -> CF a -apply2R2 mf r1 r2 = CF $ \ctx -> unCF2 mf ctx r1 r2 +pushR1 :: (a -> a1) -> CF (r1 -> a) -> CF (r1 -> a1) +pushR1 = fmap . fmap --- | Apply an arity-two Context Function to one argument, --- downcasting it by one level, making an arity-one Context --- function. --- --- The type signature is as explanatory as a description: +-- | Apply the value transformer to the answer of the context +-- function. Figuratively /push it right/ so it works on the +-- answer. -- --- > apply1R2 :: CF2 r1 r2 a -> r2 -> CF1 r1 a +-- > pushR2 = fmap . fmap . fmap -- -apply1R2 :: CF2 r1 r2 a -> r2 -> CF1 r1 a -apply1R2 mf r2 = CF1 $ \ctx r1 -> unCF2 mf ctx r1 r2 +pushR2 :: (a -> a1) -> CF (r1 -> r2 -> a) -> CF (r1 -> r2 -> a1) +pushR2 = fmap . fmap . fmap --------------------------------------------------------------------------------- --- extractors --- | Extract the drawing context from a CtxFun. --- --- > (ctx -> ctx) --- -drawingCtx :: CF DrawingContext -drawingCtx = CF $ \ctx -> ctx --- | Apply the projection function to the drawing context. --- --- > (ctx -> a) -> (ctx -> a) --- -queryCtx :: (DrawingContext -> a) -> CF a -queryCtx f = CF $ \ctx -> f ctx +apply1R1 :: CF (r1 -> a) -> r1 -> CF a +apply1R1 mf r1 = CF $ \ctx -> getCF mf ctx r1 --- | Extract the drawing context from a LocCF. --- --- > (ctx -> pt -> ctx) --- -locCtx :: LocCF u DrawingContext -locCtx = CF1 $ \ctx _ -> ctx +apply1R2 :: CF (r1 -> r2 -> a) -> r2 -> CF (r1 -> a) +apply1R2 mf r2 = CF $ \ctx r1 -> getCF mf ctx r1 r2 --- | Extract the /start/ point from a LocCF. --- --- > (ctx -> pt -> pt) --- -locPoint :: LocCF u (Point2 u) -locPoint = CF1 $ \_ pt -> pt +apply2R2 :: CF (r1 -> r2 -> a) -> r1 -> r2 -> CF a +apply2R2 mf r1 r2 = CF $ \ctx -> getCF mf ctx r1 r2 --- | Extract the drawing context from a LocThetaCF. --- --- > (ctx -> pt -> ang -> ctx) --- -locThetaCtx :: LocThetaCF u DrawingContext -locThetaCtx = CF2 $ \ctx _ _ -> ctx +lift0R1 :: CF a -> CF (r1 -> a) +lift0R1 mf = CF $ \ctx _ -> getCF mf ctx --- | Extract the /start/ point from a LocThetaCF. --- --- > (ctx -> pt -> ang -> pt) --- -locThetaPoint :: LocThetaCF u (Point2 u) -locThetaPoint = CF2 $ \_ pt _ -> pt +lift0R2 :: CF a -> CF (r1 -> r2 -> a) +lift0R2 mf = CF $ \ctx _ _ -> getCF mf ctx --- | Extract the angle from a LocThetaCF. --- --- > (ctx -> pt -> ang -> ang) --- -locThetaAng :: LocThetaCF u Radian -locThetaAng = CF2 $ \_ _ ang -> ang +lift1R2 :: CF (r1 -> a) -> CF (r1 -> r2 -> a) +lift1R2 mf = CF $ \ctx r1 _ -> getCF mf ctx r1 --- | Extract the drawing context from a ConnectorCF. --- --- > (ctx -> pt1 -> pt2 -> ctx) --- -connCtx :: ConnectorCF u DrawingContext -connCtx = CF2 $ \ctx _ _ -> ctx --- | Extract the start point from a ConnectorCF. --- --- > (ctx -> pt1 -> pt2 -> pt1) --- -connStart :: ConnectorCF u (Point2 u) -connStart = CF2 $ \_ pt _ -> pt --- | Extract the end point from a ConnectorCF. --- --- > (ctx -> pt1 -> pt2 -> pt2) --- -connEnd :: ConnectorCF u (Point2 u) -connEnd = CF2 $ \_ _ pt -> pt +uconvR0 :: (FontSize -> ans -> ans1) -> CF ans -> CF ans1 +uconvR0 post df = CF $ \ctx -> + let sz = dc_font_size ctx + in post sz $ getCF df ctx +uconvR1 :: (Functor t, InterpretUnit u, InterpretUnit u1) + => (FontSize -> ans -> ans1) + -> CF (t u -> ans) -> CF (t u1 -> ans1) +uconvR1 post df = CF $ \ctx r1 -> + let sz = dc_font_size ctx + in post sz $ getCF df ctx (uconvertF sz r1) --------------------------------------------------------------------------------- --- Combinators +uconvR2a :: (Functor t, InterpretUnit u, InterpretUnit u1) + => (FontSize -> ans -> ans1) + -> CF (t u -> r2 -> ans) -> CF (t u1 -> r2 -> ans1) +uconvR2a post df = CF $ \ctx r1 r2 -> + let sz = dc_font_size ctx + in post sz $ getCF df ctx (uconvertF sz r1) r2 -infixr 1 `at` - - --- | Downcast a 'LocCF' function by applying it to the supplied --- point, making an arity-zero Context Function. --- --- Remember a 'LocCF' function is a 'CF1' context function where --- the /static argument/ is specialized to a start point. --- -at :: LocCF u a -> Point2 u -> CF a -at = apply1R1 - - -infixr 1 `rot` - - --- | Downcast a 'LocThetaCF' function by applying it to the --- supplied angle, making an arity-one Context Function (a --- 'LocCF'). --- - -rot :: LocThetaCF u a -> Radian -> LocCF u a -rot = apply1R2 - - --- | Downcast a 'LocThetaCF' function by applying it to the --- supplied point and angle, making an arity-zero Context --- Function (a 'CF'). --- -atRot :: LocThetaCF u a -> Point2 u -> Radian -> CF a -atRot = apply2R2 - - --- | Downcast a 'ConnectorCF' function by applying it to the --- start and end point, making an arity-zero Context Function --- (a 'CF'). --- -connect :: ConnectorCF u a -> Point2 u -> Point2 u -> CF a -connect = apply2R2 +uconvR2ab :: (Functor t1, Functor t2, InterpretUnit u, InterpretUnit u1) + => (FontSize -> ans -> ans1) + -> CF (t1 u -> t2 u -> ans) -> CF (t1 u1 -> t2 u1 -> ans1) +uconvR2ab post df = CF $ \ctx r1 r2 -> + let sz = dc_font_size ctx + in post sz $ getCF df ctx (uconvertF sz r1) (uconvertF sz r2) -infixr 6 `chain1` - --- | /Chaining/ combinator - the /answer/ of the --- first Context Function is feed to the second Context Function. --- --- This contrasts with the usual idiom in @Wumpus-Basic@ where --- composite graphics are built by applying both functions to the --- same initial /static argument/. --- --- Desciption: --- --- Evaluate the first Context Function with the drawing context --- and the /initial state/ @st0@. The result of the evaluation is --- a new /state/ @st1@ and and answer @a1@. --- --- Evaluate the second Context Function with the drawing context --- and the new state @st1@, producing a new state @s2@ and an --- answer @a2@. --- --- Return the result of combining the answers with --- @op :: (ans -> ans -> ans)@ and the second state @s2@. --- --- @ (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) -> (ctx -> s1 -> (w,s1)) @ +-- | Extract the drawing context from a CtxFun. -- --- This models chaining start points together, which is the model --- PostScript uses for text output when successively calling the --- @show@ operator. +-- > (ctx -> ctx) -- -chain1 :: OPlus w - => CF1 s1 (s1,w) -> CF1 s1 (s1,w) -> CF1 s1 (s1,w) -chain1 f g = CF1 $ \ctx s -> let (s1,a1) = unCF1 f ctx s - (s2,a2) = unCF1 g ctx s1 - in (s2, a1 `oplus` a2) +drawingCtx :: Query DrawingContext +drawingCtx = CF $ \ctx -> ctx diff --git a/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs b/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs --- a/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs +++ b/src/Wumpus/Basic/Kernel/Base/DrawingContext.hs @@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Base.DrawingContext --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley @@ -24,22 +24,24 @@ module Wumpus.Basic.Kernel.Base.DrawingContext ( - -- * Drawing context + -- * Drawing context types DrawingContext(..) - , DrawingContextF + , DrawingContextF , TextMargin(..) + , ConnectorProps(..) + -- * Construction , standardContext , metricsContext + , addFontTables - , default_drawing_context + , reset_drawing_properties + , reset_drawing_metrics -- * DrawingCtxM (reader) monad , DrawingCtxM(..) - , asksDC - -- * Glyph metrics , withFontMetrics @@ -47,13 +49,15 @@ ) where -import Wumpus.Basic.Kernel.Base.GlyphMetrics +import Wumpus.Basic.Kernel.Base.FontSupport +import Wumpus.Basic.Kernel.Base.Units import Wumpus.Core -- package: wumpus-core import Wumpus.Core.Text.StandardEncoding import Control.Applicative import Data.Maybe +import Data.Monoid -- | 'DrawingContext' - the \"graphics state\" of Wumpus-Basic. -- DrawingContext is operated on within a Reader monad rather than @@ -61,29 +65,31 @@ -- operation (called @localize@ in Wumpus), rather than permanent -- until overridden as per @set@ of a State monad. -- --- Note - @round_corner_factor@ is only accounted for by some --- graphic objects (certain Path objects and Shapes in --- Wumpus-Drawing for instance). There many be many objects that --- ignore it and are drawn only with angular corners. --- --- Also note - in contrast to most other drawing objects in --- Wumpus, none of the measurement values are parameteric - --- usually notated with the type variable @u@ in Wumpus. This is --- so Wumpus can (potentially) support different units e.g. --- centimeters rather than just Doubles (represening printers --- points), though adding support for other units has a very low --- priority. --- +-- Note - in contrast to most other drawing objects in Wumpus, +-- none of the types of measurement values are parameteric +-- (usually notated with the type variable @u@ in Wumpus). Types +-- are either 'Double' representing PostScript points or Em - a +-- contextual size that is interpreted according to the current +-- font size. +-- +-- It is easier to specialize all the measurement types and +-- within the 'DrawingContext' and add parametricity to the +-- /getters/ and /setters/ instead. +-- data DrawingContext = DrawingContext - { glyph_tables :: GlyphMetrics - , fallback_metrics :: MetricsOps - , stroke_props :: StrokeAttr - , font_props :: FontAttr - , stroke_colour :: RGBi -- also text colour... - , fill_colour :: RGBi - , line_spacing_factor :: Double - , round_corner_factor :: Double - , text_margin :: TextMargin + { dc_font_metrics_table :: FontTable + , dc_font_load_log :: FontLoadLog + , dc_fallback_metrics :: FontMetrics + , dc_font_face :: FontFace + , dc_font_size :: !FontSize + , dc_snap_grid_factors :: (Double,Double) + , dc_stroke_props :: StrokeAttr + , dc_stroke_colour :: RGBi + , dc_fill_colour :: RGBi + , dc_text_colour :: RGBi + , dc_line_spacing_factor :: Double + , dc_text_margin :: TextMargin + , dc_connector_props :: ConnectorProps } -- TODO - what parts of the Drawing Context should be strict? @@ -93,43 +99,240 @@ -- type DrawingContextF = DrawingContext -> DrawingContext --- | The unit of Margin is always Double representing Points, e.g. --- 1.0 is 1 Point. Margins are not scaled relative to the current --- font size. +-- | The text margin is measured in 'Em' so it is relative to the +-- current font size. -- --- The default value is 2 point. +-- The default value is 0.5. -- data TextMargin = TextMargin - { text_margin_x :: !Double - , text_margin_y :: !Double + { text_margin_x :: !Em + , text_margin_y :: !Em } +-- | ConnectorProps control the drawing of connectors in +-- Wumpus-Drawing. +-- +-- > conn_src_space :: Em +-- > conn_dst_space :: Em +-- +-- Source and destination spacers - these add spacing between the +-- respective connector points and the tips of the drawn connector. +-- +-- > conn_src_offset :: Em +-- > conn_dst_offset :: Em +-- +-- Source and destination offsets - these offset the drawing of +-- the connector perpendicular to the direction of line formed +-- between the connector points (a positive offset is drawn above, +-- a negative offset below). The main use of offsets is to draw +-- parallel line connectors. +-- +-- > conn_arc_ang :: Radian +-- +-- Control the /bend/ of an arc connector. +-- +-- > conn_src_arm :: Em +-- > conn_dst_arm :: Em +-- +-- Control the /arm/ length of a jointed connector - arms are the +-- initial segments of the connector. +-- +-- > conn_loop_size :: Em +-- +-- Control the /height/ of a loop connector. +-- +-- > conn_box_halfsize :: Em +-- +-- Control the size of a connector box. Connector boxes are +-- drawn with the exterior lines projected out from the connector +-- points a halfsize above and below. +-- +data ConnectorProps = ConnectorProps + { dc_conn_src_space :: !Em + , dc_conn_dst_space :: !Em + , dc_conn_src_offset :: !Em + , dc_conn_dst_offset :: !Em + , dc_conn_arc_ang :: !Radian + , dc_conn_src_arm :: !Em + , dc_conn_dst_arm :: !Em + , dc_conn_loop_size :: !Em + , dc_conn_box_halfsize :: !Em + } + + +-- | 'standardContext' : @ font_size -> DrawingContext @ +-- +-- Create a 'DrawingContext'. +-- +-- Note - @font_size@ is used for sizing more than just text +-- labels. Arrowheads, plot marks and other elements have their +-- metrics derived from the font size. +-- +-- No real font metrics are present in the 'DrawingContext' +-- created by 'standardContext'. Static, hard-coded fallback +-- metrics derived from the @Courier@ font are available but +-- these metrics might not accurately correspond to the +-- @Courier@ available to the the final renderer (GhostScript, +-- an SVG viewer, etc.). +-- +-- Use this constructor for drawings that make primitive use of +-- text. +-- +-- > font_metrics_table: empty +-- > font_load_log: empty +-- > fallback_metrics: monospace_metrics +-- > font_face: Courier +-- > font_size: @supplied_font_size@ +-- > stroke_props: line_width 1, no dash_pattern, cap-butt, join-miter. +-- > stroke_colour: black +-- > fill_colour: light_gray +-- > text_colour: black +-- > line_spacing_factor: 0.2 +-- > round_corner_factor: 0 +-- > text_margin: (0.5 em, 0.5 em) +-- +-- > conn_src_sep: 0 +-- > conn_dst_sep: 0 +-- > conn_src_offset: 0 +-- > conn_dst_offset: 0 +-- > conn_arc_ang: pi / 12 +-- > conn_src_arm: 1 +-- > conn_dst_arm: 1 +-- > conn_loop_size: 2 +-- +-- standardContext :: FontSize -> DrawingContext standardContext sz = - DrawingContext { glyph_tables = emptyGlyphMetrics - , fallback_metrics = monospace_metrics - , stroke_props = default_stroke_attr - , font_props = FontAttr sz wumpus_courier - , stroke_colour = wumpus_black - , fill_colour = wumpus_light_gray - , line_spacing_factor = 1.2 - , round_corner_factor = 0 - , text_margin = standardTextMargin + DrawingContext { dc_font_metrics_table = emptyFontTable + , dc_font_load_log = mempty + , dc_fallback_metrics = monospace_metrics + , dc_font_face = wumpus_courier + , dc_font_size = sz + , dc_stroke_props = default_stroke_attr + , dc_snap_grid_factors = (50.0, 50.0) + , dc_stroke_colour = wumpus_black + , dc_fill_colour = wumpus_light_gray + , dc_text_colour = wumpus_black + , dc_line_spacing_factor = default_line_spacing + , dc_text_margin = default_text_margin + , dc_connector_props = default_connector_props } -standardTextMargin :: TextMargin -standardTextMargin = TextMargin { text_margin_x = 2.0, text_margin_y = 2.0 } --- out-of-date - should be adding loaded fonts, not replacing the --- GlyphMetrics Map wholesale. +-- | 'metricsContext' : @ font_size * font_metrics -> DrawingContext @ -- -metricsContext :: FontSize -> GlyphMetrics -> DrawingContext -metricsContext sz bgm = - let env = standardContext sz in env { glyph_tables = bgm } +-- Create a 'DrawingContext' with font metrics loaded from the +-- file system. +-- +-- Note - @font_size@ is used for sizing more than just text +-- labels. Arrowheads, plot marks and other elements have their +-- metrics derived from the font size. +-- +-- Use this constructor for drawings that make use of the text +-- objects provided by @Wumpus-Drawing@ (DocText and RotText). +-- +metricsContext :: FontSize -> FontLoadResult -> DrawingContext +metricsContext sz res = + let env = standardContext sz + in env { dc_font_metrics_table = loaded_font_table res + , dc_font_load_log = loader_errors res + } + +-- | 'addFontTables' : @ font_load_result -> DrawinContextUpdate @ +-- +-- Add the font metrics from the FontLoadResult, if a font with +-- the same name alreay exists in the 'DrawingContext' it will be +-- replaced. Error and warning messages in the @font_load_result@ +-- will be appended to the 'font_load_log'. +-- +addFontTables :: FontLoadResult -> DrawingContextF +addFontTables (FontLoadResult table msgs) = + (\s i j -> s { dc_font_metrics_table = i `mappend` table + , dc_font_load_log = j `mappend` msgs }) + <*> dc_font_metrics_table <*> dc_font_load_log + + + +-- | 'reset_drawing_properties' : @ DrawingContextF @ +-- +-- Reset the drawing properties in the 'DrawingContext' to their +-- default values. This changes the following fields: +-- +-- > stroke_props: line_width 1, no dash_pattern, cap-butt, join-miter. +-- > stroke_colour: black +-- > fill_colour: light_gray +-- > text_colour: black +-- > line_spacing_factor: 0.2 +-- > round_corner_factor: 0 +-- > text_margin: (0.5 em, 0.5 em) +-- +reset_drawing_properties :: DrawingContextF +reset_drawing_properties dcxt = + dcxt { dc_stroke_props = default_stroke_attr + , dc_stroke_colour = wumpus_black + , dc_fill_colour = wumpus_light_gray + , dc_text_colour = wumpus_black + , dc_line_spacing_factor = default_line_spacing + , dc_text_margin = default_text_margin + , dc_connector_props = default_connector_props + } + +-- Ideally @reset_drawing_properties@ would be in the UpdateDC +-- module, but that would mean exporting @default_line_spacing@ +-- etc. +-- + + + +-- | 'reset_drawing_metrics' : @ DrawingContextF @ +-- +-- Reset the drawing metrics in the 'DrawingContext' to their +-- default values. This is a more limited version of +-- 'reset_drawing_properties' and changes the following fields: +-- +-- > stroke_props: line_width 1, no dash_pattern, cap-butt, join-miter. +-- > line_spacing_factor: 0.2 +-- > round_corner_factor: 0 +-- > text_margin: (0.5 em, 0.5 em) +-- +reset_drawing_metrics :: DrawingContextF +reset_drawing_metrics dcxt = + dcxt { dc_stroke_props = default_stroke_attr + , dc_line_spacing_factor = default_line_spacing + , dc_text_margin = default_text_margin + } + + + +-- Helpers - not exported + +default_text_margin :: TextMargin +default_text_margin = TextMargin { text_margin_x = 0.5, text_margin_y = 0.5 } + + +-- Arc angle is 15deg - quite shallow. +-- +default_connector_props :: ConnectorProps +default_connector_props = + ConnectorProps { dc_conn_src_space = 0 + , dc_conn_dst_space = 0 + , dc_conn_src_offset = 0 + , dc_conn_dst_offset = 0 + , dc_conn_arc_ang = pi / 12 + , dc_conn_src_arm = 1 + , dc_conn_dst_arm = 1 + , dc_conn_loop_size = 2 + , dc_conn_box_halfsize = 2 + } + + +default_line_spacing :: Double +default_line_spacing = 0.2 + wumpus_black :: RGBi wumpus_black = RGBi 0 0 0 @@ -144,26 +347,27 @@ FontFace "Courier" "Courier New" SVG_REGULAR standard_encoding - -default_drawing_context :: DrawingContext -default_drawing_context = - standardContext (font_size wumpus_default_font) - - - -------------------------------------------------------------------------------- - -class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where - askDC :: m DrawingContext - localize :: (DrawingContext -> DrawingContext) -> m a -> m a - - --- | Project a value out of a context. +-- | 'DrawingCtxM' is equivalent to the to the @MonadReader@ +-- class, but the environment type is fixed to 'DrawingContext'. -- -asksDC :: DrawingCtxM m => (DrawingContext -> a) -> m a -asksDC f = askDC >>= (return . f) +-- To avoid name clashes with @mtl@ this scheme is used: +-- +-- > askDC = ask +-- > asksDC = asks +-- > localize = local +-- +-- Note, because the derived operation 'query' (aka @asks@) is +-- expected to be used more often than queryCtx (aka @ask@) it +-- gets the more convenient name. +-- +class (Applicative m, Monad m) => DrawingCtxM (m :: * -> *) where + askDC :: m DrawingContext + asksDC :: (DrawingContext -> a) -> m a + localize :: (DrawingContext -> DrawingContext) -> m a -> m a + asksDC f = f <$> askDC -------------------------------------------------------------------------------- @@ -173,13 +377,15 @@ -withFontMetrics :: (MetricsOps -> PtSize -> u) -> DrawingContext -> u -withFontMetrics fn ctx@(DrawingContext { font_props = font_stats }) = - fn metric_set point_sz +withFontMetrics :: (FontMetrics -> FontSize -> u) -> DrawingContext -> u +withFontMetrics fn ctx@(DrawingContext { dc_font_face = fface + , dc_font_size = ftsize }) = + fn metric_set ftsize where - ps_name = ps_font_name $ font_face font_stats - point_sz = fromIntegral $ font_size font_stats - metric_set = fromMaybe (fallback_metrics ctx) $ - lookupFont ps_name (glyph_tables ctx) + ps_name = ps_font_name fface + metric_set = fromMaybe (dc_fallback_metrics ctx) $ + lookupFont ps_name (dc_font_metrics_table ctx) + + diff --git a/src/Wumpus/Basic/Kernel/Base/FontSupport.hs b/src/Wumpus/Basic/Kernel/Base/FontSupport.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/FontSupport.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.FontSupport +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Data types representing font metrics. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.FontSupport + ( + + FontName + , CodePoint + , FontDef(..) + , FontFamily(..) + , regularWeight + , boldWeight + , italicWeight + , boldItalicWeight + + , CharWidthLookup + + , FontMetrics(..) + + , FontTable + , emptyFontTable + , lookupFont + , insertFont + + , FontLoadMsg + , FontLoadLog + , fontLoadMsg + + , FontLoadResult(..) + , printLoadErrors + + , monospace_metrics + + + ) where + +import Wumpus.Basic.Utils.HList + +import Wumpus.Core -- package: wumpus-core + +import qualified Data.Map as Map +import Data.Monoid + + + +type FontName = String + +-- | A Unicode code-point. +-- +type CodePoint = Int + +-- | FontDef wraps @FontFace@ from Wumpus-Core with file name +-- information for the font loaders. +-- +data FontDef = FontDef + { font_def_face :: FontFace + , gs_file_name :: String + , afm_file_name :: String + } + deriving (Eq,Ord,Show) + + + +-- | A family group of FontDefs (regular, bold, italic and +-- bold-italic). +-- +-- It is convenient for some higher-level text objects in Wumpus +-- (particularly @Doc@ in Wumpus-Drawing) to treat a font and its +-- standard weights as the same entity. This allows @Doc@ API to +-- provide a @bold@ operation to simply change to the the bold +-- weight of the current family, rather than use the primitive +-- @set_font@ operation to change to an explicitly named font. +-- +-- +data FontFamily = FontFamily + { ff_regular :: FontDef + , ff_bold :: Maybe FontDef + , ff_italic :: Maybe FontDef + , ff_bold_italic :: Maybe FontDef + } + +-- | Extract the regular weight 'FontDef' from a 'FontFamily'. +-- +regularWeight :: FontFamily -> FontDef +regularWeight = ff_regular + + +-- | Extract the bold weight 'FontDef' from a 'FontFamily'. +-- +-- Note - this falls back to the regular weight if the font family +-- has no bold weight. To get the bold weight or @Nothing@ if it +-- is not present use the record selector @ff_bold@. +-- +boldWeight :: FontFamily -> FontDef +boldWeight s = maybe (ff_regular s) id $ ff_bold s + + +-- | Extract the @italic@ weight 'FontDef' from a 'FontFamily'. +-- +-- Note - this falls back to the regular weight if the font family +-- has no italic weight. To get the italic weight or @Nothing@ if +-- it is not present use the record selector @ff_italic@. +-- +italicWeight :: FontFamily -> FontDef +italicWeight s = maybe (ff_regular s) id $ ff_italic s + + +-- | Extract the @bold-italic@ weight 'FontDef' from a +-- 'FontFamily'. +-- +-- Note - this falls back to the regular weight if the font family +-- has no bold-italic weight. To get the bold-italic weight or +-- @Nothing@ if it is not present use the record selector +-- @ff_bold_italic@. +-- +boldItalicWeight :: FontFamily -> FontDef +boldItalicWeight s = maybe (ff_regular s) id $ ff_bold_italic s + + + +-- | A lookup function from code point to /width vector/. +-- +-- The unit is always stored as a Double representing PostScript +-- points. +-- +-- Note - in PostScript terminology a width vector is not obliged +-- to be left-to-right (writing direction 0). It could be +-- top-to-bottom (writing direction 1). +-- +type CharWidthLookup = CodePoint -> Vec2 Double + + + +-- | 'FontMetrics' store a subset of the properties available in +-- a font file - enough to calculate accurate bounding boxes and +-- positions for text. +-- +-- > Bounding box representing the maximum glyph area. +-- > Width vectors for each character. +-- > Cap height +-- > Descender depth. +-- +-- Because Wumpus always needs font metrics respective to the +-- current point size, the actual fields are all functions. +-- +data FontMetrics = FontMetrics + { get_bounding_box :: FontSize -> BoundingBox Double + , get_cw_table :: FontSize -> CharWidthLookup + , get_cap_height :: FontSize -> Double + , get_descender :: FontSize -> Double + } + + +-- | A map between a font name and the respective FontMetrics. +-- +newtype FontTable = FontTable { + getFontTable :: Map.Map FontName FontMetrics } + + + +instance Monoid FontTable where + mempty = emptyFontTable + a `mappend` b = FontTable $ getFontTable a `mappend` getFontTable b + + +emptyFontTable :: FontTable +emptyFontTable = FontTable $ Map.empty + + +-- | 'FontLoadMsg' - type synonym for String. +-- +type FontLoadMsg = String + +-- | 'FontLoadLog' is a Hughes list of Strings, so it supports +-- efficient append. +-- +newtype FontLoadLog = FontLoadLog { getFontLoadLog :: H FontLoadMsg } + + +instance Monoid FontLoadLog where + mempty = FontLoadLog $ emptyH + a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b + + +fontLoadMsg :: String -> FontLoadLog +fontLoadMsg = FontLoadLog . wrapH + + +-- Need a synonym for @FontLoading@... +data FontLoadResult = FontLoadResult + { loaded_font_table :: FontTable + , loader_errors :: FontLoadLog + } + + +-- | Print the loader errors from the 'FontLoadResult' to std-out. +-- +printLoadErrors :: FontLoadResult -> IO () +printLoadErrors = mapM_ putStrLn . toListH . getFontLoadLog . loader_errors + +-------------------------------------------------------------------------------- + + +-- | 'lookupFont' : @ name * font_table -> Maybe FontMetrics @ +-- +-- Lookup a font in the font_table. +-- +lookupFont :: FontName -> FontTable -> Maybe FontMetrics +lookupFont name = Map.lookup name . getFontTable + +-- | 'insertFont' : @ name * font_metrics * font_table -> FontTable @ +-- +-- Insert a named font into the font_table. +-- +insertFont :: FontName -> FontMetrics -> FontTable -> FontTable +insertFont name ops = + FontTable . Map.insert name ops . getFontTable + +-- | This ignores the Char code lookup and just returns the +-- default advance vector. +-- +monospace_metrics :: FontMetrics +monospace_metrics = FontMetrics + { get_bounding_box = \sz -> BBox (lowerLeft sz) (upperRight sz) + , get_cw_table = \sz _ -> hvec (upscale sz width_vec) + , get_cap_height = \sz -> upscale sz cap_height + , get_descender = \sz -> upscale sz descender + } + where + llx = (-23) / 1000 + lly = (-250) / 1000 + urx = 715 / 1000 + ury = 805 / 1000 + width_vec = 600 / 1000 + cap_height = 562 / 1000 + descender = (-157) / 1000 + + upscale sz d = d * fromIntegral sz + lowerLeft sz = P2 (upscale sz llx) (upscale sz lly) + upperRight sz = P2 (upscale sz urx) (upscale sz ury) + + diff --git a/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs b/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Base/GlyphMetrics.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Kernel.Base.GlyphMetrics --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Data types representing glyph metrics loaded from font files. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Kernel.Base.GlyphMetrics - ( - - FontName - , CodePoint - , CharWidthTable - , MetricsOps(..) - , FontMetricsOps(..) - - , GlyphMetrics - , emptyGlyphMetrics - , lookupFont - , insertFont - - , monospace_metrics - - - ) where - -import Wumpus.Core -- package: wumpus-core - -import qualified Data.Map as Map -import Data.Monoid - - - -type FontName = String - --- | A Unicode code-point. --- -type CodePoint = Int - --- | A lookup from code point to /width vector/. --- --- Note - in PostScript terminology a width vector is not obliged --- to be left-to-right (writing direction 0). It could be --- top-to-bottom (writing direction 1). --- -type CharWidthTable u = CodePoint -> Vec2 u - - - --- | Operations on the metrics set of a font. --- --- The is the internal representation used by Wumpus-Basic after --- parsing the font file. --- -data MetricsOps = MetricsOps - { get_bounding_box :: forall u. FromPtSize u => PtSize -> BoundingBox u - , get_cw_table :: forall u. FromPtSize u => PtSize -> CharWidthTable u - , get_cap_height :: forall u. FromPtSize u => PtSize -> u - , get_descender :: forall u. FromPtSize u => PtSize -> u - } - --- | 'MetricsOps' for a particular named font. --- -data FontMetricsOps = FontMetricsOps FontName MetricsOps - - --- | A map between a font name and MetricsOps. --- -newtype GlyphMetrics = GlyphMetrics { - getGlyphMetrics :: Map.Map FontName MetricsOps } - -instance Monoid GlyphMetrics where - mempty = emptyGlyphMetrics - a `mappend` b = GlyphMetrics $ getGlyphMetrics a `mappend` getGlyphMetrics b - - -emptyGlyphMetrics :: GlyphMetrics -emptyGlyphMetrics = GlyphMetrics $ Map.empty - -lookupFont :: FontName -> GlyphMetrics -> Maybe MetricsOps -lookupFont name = Map.lookup name . getGlyphMetrics - -insertFont :: FontMetricsOps -> GlyphMetrics -> GlyphMetrics -insertFont (FontMetricsOps name ops) = - GlyphMetrics . Map.insert name ops . getGlyphMetrics - --- | This ignores the Char code lookup and just returns the --- default advance vector. --- -monospace_metrics :: MetricsOps -monospace_metrics = MetricsOps - { get_bounding_box = \sz -> BBox (lowerLeft sz) (upperRight sz) - , get_cw_table = \sz _ -> hvec (upscale sz width_vec) - , get_cap_height = \sz -> upscale sz cap_height - , get_descender = \sz -> upscale sz descender - } - where - llx = (-23) / 1000 - lly = (-250) / 1000 - urx = 715 / 1000 - ury = 805 / 1000 - width_vec = 600 / 1000 - cap_height = 562 / 1000 - descender = (-157) / 1000 - - upscale sz d = fromPtSize $ sz * d - lowerLeft sz = P2 (upscale sz llx) (upscale sz lly) - upperRight sz = P2 (upscale sz urx) (upscale sz ury) - - diff --git a/src/Wumpus/Basic/Kernel/Base/QueryDC.hs b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs --- a/src/Wumpus/Basic/Kernel/Base/QueryDC.hs +++ b/src/Wumpus/Basic/Kernel/Base/QueryDC.hs @@ -21,55 +21,61 @@ module Wumpus.Basic.Kernel.Base.QueryDC ( - - textAttr - , withTextAttr + normalizeCtx + , normalizeCtxF + , dinterpCtx + , dinterpCtxF - , strokeAttr - , withStrokeAttr + , uconvertCtx1 + , uconvertCtxF - , fillAttr - , withFillAttr + , pointSize + , strokeAttr + , fillAttr , borderedAttr - , withBorderedAttr + , textAttr - , getRoundCornerSize - , getTextMargin + , position + , snapmove + , textMargin + , getLineWidth , getFontAttr , getFontSize , getFontFace + , getTextColour + , markHeight , markHalfHeight - , baselineSpacing + , textlineSpace -- * Glyph metrics , glyphBoundingBox - , glyphCapHeight - , glyphDescender - , glyphVerticalSpan + , capHeight + , descender + , verticalSpan + , cwLookupTable - -- * Default monospace metrics - , monoFontPointSize - , monoCharWidth - , monoTextWidth - , monoTextLength - , monoCapHeight - , monoLowerxHeight - , monoDescenderDepth - , monoAscenderHeight - , monoTextDimensions - , monoMultiLineHeight - , monoDefaultPadding - , monoVecToCenter + -- * Connector props + , connectorSrcSpace + , connectorDstSpace + , connectorSrcOffset + , connectorDstOffset + , connectorArcAngle + , connectorSrcArm + , connectorDstArm + , connectorLoopSize + , connectorBoxHalfSize + ) where +import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.DrawingContext -import Wumpus.Basic.Kernel.Base.GlyphMetrics +import Wumpus.Basic.Kernel.Base.FontSupport import Wumpus.Core -- package: wumpus-core import qualified Wumpus.Core.FontSize as FS @@ -77,225 +83,231 @@ import Control.Applicative -textAttr :: DrawingCtxM m => m (RGBi,FontAttr) -textAttr = (,) <$> asksDC stroke_colour <*> asksDC font_props --- | Because @textAttr@ is so commonly used here is a functional --- version that avoids tupling. --- -withTextAttr :: DrawingCtxM m => (RGBi -> FontAttr -> a) -> m a -withTextAttr fn = fn <$> asksDC stroke_colour <*> asksDC font_props +normalizeCtx :: (DrawingCtxM m, InterpretUnit u) => u -> m Double +normalizeCtx u = (\sz -> normalize sz u) <$> pointSize -strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr) -strokeAttr = (,) <$> asksDC stroke_colour <*> asksDC stroke_props +normalizeCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u) + => t u -> m (t Double) +normalizeCtxF t = (\sz -> fmap (normalize sz) t) <$> pointSize -withStrokeAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> a) -> m a -withStrokeAttr fn = fn <$> asksDC stroke_colour <*> asksDC stroke_props +dinterpCtx :: (DrawingCtxM m, InterpretUnit u) => Double -> m u +dinterpCtx u = (\sz -> dinterp sz u) <$> pointSize +dinterpCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u) => t Double -> m (t u) +dinterpCtxF u = (\sz -> fmap (dinterp sz) u) <$> pointSize +uconvertCtx1 :: (DrawingCtxM m, InterpretUnit u, InterpretUnit u1) + => u -> m u1 +uconvertCtx1 t = (\sz -> uconvert1 sz t) <$> pointSize + +uconvertCtxF :: (DrawingCtxM m, Functor t, InterpretUnit u, InterpretUnit u1) + => t u -> m (t u1) +uconvertCtxF t = (\sz -> uconvertF sz t) <$> pointSize + + +pointSize :: DrawingCtxM m => m FontSize +pointSize = asksDC dc_font_size + +strokeAttr :: DrawingCtxM m => m (RGBi, StrokeAttr) +strokeAttr = (,) <$> asksDC dc_stroke_colour <*> asksDC dc_stroke_props + fillAttr :: DrawingCtxM m => m RGBi -fillAttr = asksDC fill_colour +fillAttr = asksDC dc_fill_colour -withFillAttr :: DrawingCtxM m => (RGBi -> a) -> m a -withFillAttr fn = fn <$> asksDC fill_colour borderedAttr :: DrawingCtxM m => m (RGBi, StrokeAttr, RGBi) -borderedAttr = (,,) <$> asksDC fill_colour <*> asksDC stroke_props - <*> asksDC stroke_colour +borderedAttr = (,,) <$> asksDC dc_fill_colour + <*> asksDC dc_stroke_props + <*> asksDC dc_stroke_colour -withBorderedAttr :: DrawingCtxM m => (RGBi -> StrokeAttr -> RGBi -> a) -> m a -withBorderedAttr fn = - fn <$> asksDC fill_colour <*> asksDC stroke_props - <*> asksDC stroke_colour +textAttr :: DrawingCtxM m => m (RGBi,FontAttr) +textAttr = + (\a b c -> (a, FontAttr b c)) + <$> asksDC dc_text_colour <*> asksDC dc_font_size <*> asksDC dc_font_face --- | Size of the round corner factor. + + + +-- | Get the Point corresponding the grid coordinates scaled by +-- the snap-grid scaling factors. -- -getRoundCornerSize :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u -getRoundCornerSize = (\factor -> (realToFrac factor) * fromPtSize 1) - <$> asksDC round_corner_factor +position :: (DrawingCtxM m, Fractional u) => (Int, Int) -> m (Point2 u) +position (x,y) = post <$> asksDC dc_snap_grid_factors + where + post (sx,sy) = P2 (realToFrac $ sx * fromIntegral x) + (realToFrac $ sy * fromIntegral y) + +-- | Scale a vector coordinate by the snap-grid scaling factors. +-- +-- Absolute units. +-- +snapmove :: (DrawingCtxM m, Fractional u) => (Int,Int) -> m (Vec2 u) +snapmove (x,y) = post <$> asksDC dc_snap_grid_factors + where + post (sx,sy) = V2 (realToFrac $ sx * fromIntegral x) + (realToFrac $ sy * fromIntegral y) + + + -- | Get the (x,y) margin around text. -- -- Note - not all text operations in Wumpus are drawn with text -- margin. -- -getTextMargin :: (DrawingCtxM m, Fractional u, FromPtSize u) => m (u,u) -getTextMargin = (\(TextMargin xsep ysep) -> (fn xsep, fn ysep)) - <$> asksDC text_margin +textMargin :: (DrawingCtxM m, InterpretUnit u) => m (u,u) +textMargin = post <$> asksDC dc_font_size <*> asksDC dc_text_margin where - fn d = (realToFrac d) * fromPtSize 1 + post sz (TextMargin xem yem) = (uconvert1 sz xem, uconvert1 sz yem) + + getLineWidth :: DrawingCtxM m => m Double -getLineWidth = line_width <$> asksDC stroke_props +getLineWidth = line_width <$> asksDC dc_stroke_props getFontAttr :: DrawingCtxM m => m FontAttr -getFontAttr = asksDC font_props +getFontAttr = FontAttr <$> asksDC dc_font_size <*> asksDC dc_font_face -getFontSize :: DrawingCtxM m => m Int -getFontSize = font_size <$> asksDC font_props -getFontFace :: DrawingCtxM m => m FontFace -getFontFace = font_face <$> asksDC font_props +getFontSize :: DrawingCtxM m => m Int +getFontSize = asksDC dc_font_size +getFontFace :: DrawingCtxM m => m FontFace +getFontFace = asksDC dc_font_face +getTextColour :: DrawingCtxM m => m RGBi +getTextColour = asksDC dc_text_colour --- | Vertical distance between baselines of consecutive text --- lines. --- -baselineSpacing :: (DrawingCtxM m, Fractional u) => m u -baselineSpacing = - (\sz factor -> realToFrac $ factor * fromIntegral sz) - <$> asksDC (font_size . font_props) <*> asksDC line_spacing_factor - -- | The /mark/ height is the height of a lowercase letter in the --- current font. +-- Courier font at the current point size. -- -- Arrowheads, dots etc. should generally be drawn at the mark -- height. -- -markHeight :: (DrawingCtxM m, FromPtSize u) => m u -markHeight = (fromPtSize . FS.xcharHeight . font_size) <$> asksDC font_props +markHeight :: (DrawingCtxM m, InterpretUnit u) => m u +markHeight = post <$> asksDC dc_font_size + where + post sz = dinterp sz (FS.xcharHeight sz) -markHalfHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u + +markHalfHeight :: (Fractional u, DrawingCtxM m, InterpretUnit u) => m u markHalfHeight = (0.5*) <$> markHeight --- Note - there are probably enough functions that use just --- markHeight to merit a withMarkHeight function. +-- | Vertical distance between descender of a line and the +-- cap-height of the line below. +-- +textlineSpace :: (DrawingCtxM m, Fractional u, InterpretUnit u) => m u +textlineSpace = + post <$> asksDC dc_font_size <*> asksDC dc_line_spacing_factor + where + post sz factor = dinterp sz ((fromIntegral sz) * (realToFrac factor)) -------------------------------------------------------------------------------- -glyphQuery :: DrawingCtxM m => (MetricsOps -> PtSize -> u) -> m u + +glyphQuery :: DrawingCtxM m => (FontMetrics -> FontSize -> a) -> m a glyphQuery fn = (\ctx -> withFontMetrics fn ctx) <$> askDC + + -- | Get the font bounding box - this is the maximum boundary of -- the glyphs in the font. The span of the height is expected to -- be bigger than the cap_height plus descender depth. -- -glyphBoundingBox :: (FromPtSize u, DrawingCtxM m) => m (BoundingBox u) -glyphBoundingBox = glyphQuery get_bounding_box +glyphBoundingBox :: (DrawingCtxM m, InterpretUnit u) => m (BoundingBox u) +glyphBoundingBox = + uconvertF <$> asksDC dc_font_size <*> glyphQuery get_bounding_box +-- | Height of a capital letter. +-- +capHeight :: (DrawingCtxM m, InterpretUnit u) => m u +capHeight = dinterp <$> asksDC dc_font_size <*> glyphQuery get_cap_height -glyphCapHeight :: (FromPtSize u, DrawingCtxM m) => m u -glyphCapHeight = glyphQuery get_cap_height - -- | Note - descender is expected to be negative. -- -glyphDescender :: (FromPtSize u, DrawingCtxM m) => m u -glyphDescender = glyphQuery get_descender +descender :: (DrawingCtxM m, InterpretUnit u) => m u +descender = dinterp <$> asksDC dc_font_size <*> glyphQuery get_descender + -- | This is the distance from cap_height to descender. -- -glyphVerticalSpan :: (FromPtSize u, DrawingCtxM m) => m u -glyphVerticalSpan = - (\ch dd -> ch - dd) <$> glyphCapHeight <*> glyphDescender +verticalSpan :: (DrawingCtxM m, InterpretUnit u) => m u +verticalSpan = + (\ch dd -> ch - dd) <$> capHeight <*> descender -cwLookupTable :: (FromPtSize u, DrawingCtxM m) => m (CharWidthTable u) -cwLookupTable = glyphQuery get_cw_table +-- | Note the CharWidthLookup is not parameteric on units. +-- +-- /CharWidth/ is always Double representing PostScript points. +-- Client code must convert this value accordingly. +-- +cwLookupTable :: DrawingCtxM m => m CharWidthLookup +cwLookupTable = glyphQuery get_cw_table -------------------------------------------------------------------------------- +-- Connector props -withFontSize :: DrawingCtxM m => (FontSize -> u) -> m u -withFontSize fn = (fn . font_size) <$> asksDC font_props +-- helper +connectorAsks :: DrawingCtxM m => (ConnectorProps -> a) -> m a +connectorAsks f = f <$> asksDC dc_connector_props --- NOTE - textHeight in Wumpus-Core should be renamed as it is --- (probably) more indiactive of Cap height than /font point size/ --- -monoFontPointSize :: (DrawingCtxM m, FromPtSize u) => m u -monoFontPointSize = withFontSize (fromPtSize . fromIntegral) +connectorSrcSpace :: (DrawingCtxM m, InterpretUnit u) => m u +connectorSrcSpace = (\sz u -> uconvert1 sz u) + <$> pointSize <*> connectorAsks dc_conn_src_space -monoCharWidth :: (DrawingCtxM m, FromPtSize u) => m u -monoCharWidth = withFontSize (fromPtSize . FS.charWidth) +connectorDstSpace :: (DrawingCtxM m, InterpretUnit u) => m u +connectorDstSpace = (\sz u -> uconvert1 sz u) + <$> pointSize <*> connectorAsks dc_conn_dst_space -monoTextWidth :: (DrawingCtxM m, FromPtSize u) => Int -> m u -monoTextWidth n = withFontSize $ \sz -> fromPtSize $ FS.textWidth sz n +connectorSrcOffset :: (DrawingCtxM m, InterpretUnit u) => m u +connectorSrcOffset = (\sz u -> uconvert1 sz u) + <$> pointSize <*> connectorAsks dc_conn_src_offset -monoTextLength :: (DrawingCtxM m, FromPtSize u) => String -> m u -monoTextLength ss = monoTextWidth $ charCount ss +connectorDstOffset :: (DrawingCtxM m, InterpretUnit u) => m u +connectorDstOffset = (\sz u -> uconvert1 sz u) + <$> pointSize <*> connectorAsks dc_conn_dst_offset -monoCapHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoCapHeight = withFontSize (fromPtSize . FS.capHeight) - -monoTotalCharHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoTotalCharHeight = withFontSize (fromPtSize . FS.totalCharHeight) - +connectorArcAngle :: DrawingCtxM m => m Radian +connectorArcAngle = connectorAsks dc_conn_arc_ang --- | Height of a lower case \'x\' in Courier. --- --- \'x\' has no ascenders or descenders. --- -monoLowerxHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoLowerxHeight = withFontSize (fromPtSize . FS.xcharHeight) - -monoDescenderDepth :: (DrawingCtxM m, FromPtSize u) => m u -monoDescenderDepth = withFontSize (fromPtSize . FS.descenderDepth) - -monoAscenderHeight :: (DrawingCtxM m, FromPtSize u) => m u -monoAscenderHeight = withFontSize (fromPtSize . FS.ascenderHeight) +connectorSrcArm :: (DrawingCtxM m, InterpretUnit u) => m u +connectorSrcArm = (\sz u -> uconvert1 sz u) + <$> pointSize <*> connectorAsks dc_conn_src_arm --- | Query the dimensions of the text using the current font size --- but using metrics derived from Courier. --- --- Note - the width will generally be a over-estimate for --- non-monospaced fonts. --- -monoTextDimensions :: (DrawingCtxM m, Num u, Ord u, FromPtSize u) - => String -> m (u,u) -monoTextDimensions ss = - (\sz -> post $ textBounds sz zeroPt ss) - <$> asksDC (font_size . font_props) - where - post bb = (boundaryWidth bb, boundaryHeight bb) +connectorDstArm :: (DrawingCtxM m, InterpretUnit u) => m u +connectorDstArm = (\sz u -> uconvert1 sz u) + <$> pointSize <*> connectorAsks dc_conn_dst_arm --- | The heigth of @n@ lines of text, which is --- @n lines + n-1 line spacers@ --- -monoMultiLineHeight :: (DrawingCtxM m, Fractional u, FromPtSize u) - => Int -> m u -monoMultiLineHeight n | n < 0 = pure 0 -monoMultiLineHeight n = - (\h lsf -> h + (fromIntegral $ n-1) * (h * realToFrac lsf)) - <$> monoTotalCharHeight <*> asksDC line_spacing_factor - - -- Note as the height calculation has changed in Wumpus-Core this - -- no longer quite works... - - -{-# DEPRECATED monoDefaultPadding "Needs a rethink" #-} - --- | The default padding is half of the /char width/. --- -monoDefaultPadding :: (DrawingCtxM m, Fractional u, FromPtSize u) => m u -monoDefaultPadding = (0.5*) <$> monoCharWidth - +connectorLoopSize :: (DrawingCtxM m, InterpretUnit u) => m u +connectorLoopSize = (\sz u -> uconvert1 sz u) + <$> pointSize <*> connectorAsks dc_conn_loop_size --- | Vector from baseline left to center --- -monoVecToCenter :: (DrawingCtxM m, Fractional u, Ord u, FromPtSize u) - => String -> m (Vec2 u) -monoVecToCenter ss = (\(w,h) dy -> vec (0.5*w) (0.5*h - dy)) - <$> monoTextDimensions ss <*> monoDescenderDepth +connectorBoxHalfSize :: (DrawingCtxM m, InterpretUnit u) => m u +connectorBoxHalfSize = + (\sz u -> uconvert1 sz u) + <$> pointSize <*> connectorAsks dc_conn_box_halfsize diff --git a/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs b/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Base/ScalingContext.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Kernel.Base.ScalingContext --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : unstable --- Portability : GHC --- --- Scaling in X and Y --- --- \*\* WARNING \*\* - half baked. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Kernel.Base.ScalingContext - ( - - ScalingContext(..) - - , scaleX - , scaleY - , scalePt - , scaleVec - - , unitX - , unitY - - , uniformScaling - , coordinateScaling - - ) where - - -import Wumpus.Core -- package: wumpus-core - - - --- | ScalingContext is a dictionary of two functions for scaling --- in X and Y. --- -data ScalingContext ux uy u = ScalingContext - { scale_in_x :: ux -> u - , scale_in_y :: uy -> u - } - - -scaleX :: ScalingContext ux uy u -> ux -> u -scaleX ctx ux = (scale_in_x ctx) ux - -scaleY :: ScalingContext ux uy u -> uy -> u -scaleY ctx uy = (scale_in_y ctx) uy - - -scalePt :: ScalingContext ux uy u -> ux -> uy -> Point2 u -scalePt ctx ux uy = P2 (scale_in_x ctx ux) (scale_in_y ctx uy) - -scaleVec :: ScalingContext ux uy u -> ux -> uy -> Vec2 u -scaleVec ctx ux uy = V2 (scale_in_x ctx ux) (scale_in_y ctx uy) - - -unitX :: Num ux => ScalingContext ux uy u -> u -unitX ctx = scaleX ctx 1 - -unitY :: Num uy => ScalingContext ux uy u -> u -unitY ctx = scaleY ctx 1 - - - - --------------------------------------------------------------------------------- --- constructors for scaling context - - --- | Build a ScalingContext where both X and Y are scaled by the --- same uniform step. --- --- The dimensions (types) of the ScalingContext are unified - the --- output type and the input types are all the same. --- -uniformScaling :: Num u => u -> ScalingContext u u u -uniformScaling u = ScalingContext - { scale_in_x = (\x -> u*x) - , scale_in_y = (\y -> u*y) - } - - - --- | Build a ScalingContext for scaling Int coordinates. --- --- The scaling factors in X and Y can be different sizes. ---- -coordinateScaling :: Num u => u -> u -> ScalingContext Int Int u -coordinateScaling sx sy = ScalingContext - { scale_in_x = (\x -> sx * fromIntegral x) - , scale_in_y = (\y -> sy * fromIntegral y) - } - - - diff --git a/src/Wumpus/Basic/Kernel/Base/Units.hs b/src/Wumpus/Basic/Kernel/Base/Units.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Base/Units.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Base.Units +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Units @cm@, @pica@ and \"contextual\" units - @em@, @en@. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Base.Units + ( + + + -- * Centimeter + Centimeter + , cm + , dcm + + -- * Pica + , Pica + , pica + , dpica + + -- * Em + , Em + + -- * En + , En + + ) where + + +import Wumpus.Basic.Kernel.Base.BaseDefs + +import Wumpus.Core -- package: wumpus-core + + +-------------------------------------------------------------------------------- + +-- | Wrapped Double representing Centimeter. +-- +newtype Centimeter = Centimeter { getCentimeter :: Double } + deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) + + +instance Show Centimeter where + showsPrec p d = showsPrec p (getCentimeter d) + +-- | Cast a value in Centimeters to some Fractional type. +-- +-- Note - this casting should only be used for non-contextual +-- units such as Double. +-- +cm :: Fractional u => Centimeter -> u +cm = realToFrac . (28.45275619 *) . getCentimeter + +-- | Convert Double to Centimer. +-- +dcm :: Double -> Centimeter +dcm = Centimeter . (0.03514598 *) + +instance ScalarUnit Centimeter where + fromPsPoint = dcm + toPsPoint = cm + +instance InterpretUnit Centimeter where + normalize _ = cm + dinterp _ = dcm + + +-- | Wrapped Double /Pica/ unit type. +-- +-- Pica is 12 Points. +-- +newtype Pica = Pica { getPica :: Double } + deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) + + +instance Show Pica where + showsPrec p d = showsPrec p (getPica d) + + +-- | Cast a value in Pica to some Fractional type. +-- +-- Note - this casting should only be used for non-contextual +-- units such as Double. +-- +pica :: Fractional u => Pica -> u +pica = realToFrac . (* 12.0) . getPica + +-- | Convert a Double to a Pica. +-- +dpica :: Double -> Pica +dpica = Pica . (\x -> x / 12.0) + + +instance Tolerance Pica where + eq_tolerance = 0.001 + length_tolerance = 0.01 + + +instance ScalarUnit Pica where + fromPsPoint = dpica + toPsPoint = pica + +instance InterpretUnit Pica where + normalize _ = pica + dinterp _ = dpica + + + +-------------------------------------------------------------------------------- +-- Contextual units + +-- | Wrapped Double representing an Em. +-- +newtype Em = Em { getEm :: Double } + deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) + +instance Show Em where + showsPrec p d = showsPrec p (getEm d) + + + +instance InterpretUnit Em where + normalize sz a = fromIntegral sz * realToFrac a + dinterp sz d = realToFrac d / fromIntegral sz + +instance Tolerance Centimeter where + eq_tolerance = 0.001 + length_tolerance = 0.01 + + +-- | Wrapped Double representing an En. +-- +newtype En = En { getEn :: Double } + deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) + +instance Show En where + showsPrec p d = showsPrec p (getEn d) + + +instance InterpretUnit En where + normalize sz a = (realToFrac a) * 0.5 * fromIntegral sz + dinterp sz d = 2 * (realToFrac d) / (fromIntegral sz) + + + +instance Tolerance Em where + eq_tolerance = 0.001 + length_tolerance = 0.01 + +instance Tolerance En where + eq_tolerance = 0.001 + length_tolerance = 0.01 diff --git a/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs b/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs --- a/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs +++ b/src/Wumpus/Basic/Kernel/Base/UpdateDC.hs @@ -3,263 +3,640 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Base.UpdateDC --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- --- Customize drawing attributes --- --- \*\* WARNING \*\* - this module needs systematic naming --- schemes both for update functions (primaryColour, ...) and --- for synthesized selectors (e.g. lowerxHeight). The current --- names will change. +-- Customize drawing attributes. The functions here are +-- @DrawingContext@ modifiers to be run within a the scope of a +-- @localize@ block (cf. @local@ of the Reader monad). -- +-- By convention, underscore-separated names are used for +-- DrawingContext modifiers in this module. This is because the +-- modifiers defined here are expected to be used mostly as static +-- \"properties\" resembling constants in drawings. -- -------------------------------------------------------------------------------- module Wumpus.Basic.Kernel.Base.UpdateDC ( - -- * Modifiers - - roundCornerFactor - , textMargin + -- * Modifiers + snap_grid_factors -- ** Line widths - , lineWidth - , thick - , ultrathick - , thin + , set_line_width + , line_default + , line_thin + , line_thick + , line_ultra_thick + -- ** Line caps - , capButt - , capRound - , capSquare + , cap_default + , cap_butt + , cap_round + , cap_square -- ** Line joins - , joinMiter - , joinRound - , joinBevel + , join_default + , join_miter + , join_round + , join_bevel -- ** Dash Pattern - , dashPattern - , unit_dash_pattern - , phase - , dphase - , doublegaps - , doubledashes + , set_dash_pattern + , solid_line + , dotted_line + , packed_dotted + , loose_dotted + + , dashed_line + , packed_dashed + , loose_dashed + -- * Font properties - , fontAttr - , fontSize - , fontFace + , font_attr + , set_font + , set_font_size + -- * Font / mark drawing size - , scalesize - , doublesize - , halfsize + , scale_point_size + , double_point_size + , half_point_size + + , text_margin + , text_margin_none + , text_margin_tight + , text_margin_default + , text_margin_loose + + -- * Colour - , swapColours - , bothStrokeColour - , bothFillColour - , strokeColour - , fillColour + , stroke_colour + , fill_colour + , text_colour + , single_colour + , swap_colours + , fill_use_stroke_colour + , stroke_use_fill_colour - + , fill_use_text_colour + , stroke_use_text_colour + + , text_use_stroke_colour + , text_use_fill_colour + + -- * Connector Props + , source_space + , dest_space + , source_offset + , dest_offset + , uniform_conn_space + , conn_arc_angle + , source_arm_len + , dest_arm_len + , uniform_arm_len + , conn_loop_size + , conn_box_halfsize + ) where +import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Base.FontSupport +import Wumpus.Basic.Kernel.Base.Units import Wumpus.Core -- package: wumpus-core import Control.Applicative -import Data.Ratio -------------------------------------------------------------------------------- +-- helpers updateStrokeProps :: (StrokeAttr -> StrokeAttr) -> DrawingContextF -updateStrokeProps fn = (\s i -> s { stroke_props = fn i }) <*> stroke_props - -updateFontProps :: (FontAttr -> FontAttr) -> DrawingContextF -updateFontProps fn = (\s i -> s { font_props = fn i }) <*> font_props +updateStrokeProps fn = + (\s i -> s { dc_stroke_props = fn i }) <*> dc_stroke_props +withFontSize :: (FontSize -> DrawingContextF) -> DrawingContextF +withFontSize fn = (\s i -> fn i s) <*> dc_font_size -------------------------------------------------------------------------------- -roundCornerFactor :: Double -> DrawingContextF -roundCornerFactor d = (\s -> s { round_corner_factor = d }) --- | 'textMargin' : @ xsep * ysep -> DrawingContextF @ + +-- | 'snap_grid_factors' : @ x_unit * y_unit -> DrawingContextF @ +-- +-- Set the @snap grid factors@ - a snap grid is an alternative +-- coordinate space, it can be convenient for drawing +-- \"box and arrow\" diagrams. -- -textMargin :: Double -> Double -> DrawingContextF -textMargin xsep ysep = (\s -> s { text_margin = TextMargin xsep ysep }) +snap_grid_factors :: Double -> Double -> DrawingContextF +snap_grid_factors xu yu = \s -> s { dc_snap_grid_factors = (xu, yu) } -------------------------------------------------------------------------------- -- line widths --- Note - some care might be needed if we ever define other unit --- types... -lineWidth :: Double -> DrawingContextF -lineWidth d = updateStrokeProps (\s -> s { line_width = d }) +-- | set_line_width : @ width_in_points -> DrawingContextF @ +-- +-- Set the line_width to the supplied point size. +-- +-- Initially the line width is 1.0. +-- +-- /Constant/ variations of the function maybe be more +-- convenient: +-- +-- > line_default, line_thin, line_thick, line_ultra_thick +-- +set_line_width :: Double -> DrawingContextF +set_line_width d = updateStrokeProps (\s -> s { line_width = d }) --- std_line_width :: Double --- std_line_width = 1.0 +-- | Set the line_width to @default@ - 1.0. +-- +line_default :: DrawingContextF +line_default = set_line_width 1.0 -thick_line :: Double -thick_line = 2.0 -ultra_thick_line :: Double -ultra_thick_line = 4.0 - -thin_line :: Double -thin_line = 0.5 +-- | Set the line_width to @thin@ - 0.5. +-- +line_thin :: DrawingContextF +line_thin = set_line_width 0.5 --- | Set the line width to a /thick/. +-- | Set the line_width to @thick@ - 2.0. -- --- Note this context update is /oblivious/ - operationally the --- line width is set to exactly @2.0@. +line_thick :: DrawingContextF +line_thick = set_line_width 2.0 + +-- | Set the line_width to @ultra_thick@ - 4.0. -- -thick :: DrawingContextF -thick = lineWidth thick_line +line_ultra_thick :: DrawingContextF +line_ultra_thick = set_line_width 4.0 -ultrathick :: DrawingContextF -ultrathick = lineWidth ultra_thick_line -thin :: DrawingContextF -thin = lineWidth thin_line +-- +-- All options share the prefix so the enumeration is obvious... +-- -------------------------------------------------------------------------------- +-- Line props setLineCap :: LineCap -> DrawingContextF setLineCap d = updateStrokeProps (\s -> s { line_cap = d }) +setLineJoin :: LineJoin -> DrawingContextF +setLineJoin d = updateStrokeProps (\s -> s { line_join = d }) -capButt :: DrawingContextF -capButt = setLineCap CapButt -capRound :: DrawingContextF -capRound = setLineCap CapRound +-- | Set the line_cap to the default which is @butt@. +-- +-- This is a synonym for 'cap_butt'. +-- +cap_default :: DrawingContextF +cap_default = cap_butt -capSquare :: DrawingContextF -capSquare = setLineCap CapSquare +-- | Set the line_cap to @butt@. +-- +-- Butt squares of the stroke at the end point. +-- +-- This is the default. +-- +cap_butt :: DrawingContextF +cap_butt = setLineCap CapButt +-- | Set the line_cap to @round@. +-- +-- This rounds the end of the stroke and the visually the +-- rounding slightly extends the length of the line. +-- +cap_round :: DrawingContextF +cap_round = setLineCap CapRound -setLineJoin :: LineJoin -> DrawingContextF -setLineJoin d = updateStrokeProps (\s -> s { line_join = d }) +-- | Set the line_cap to @square@. +-- +-- This squares off the end of the stroke, visually extending +-- the stroke by half the line width. +-- +cap_square :: DrawingContextF +cap_square = setLineCap CapSquare -joinMiter :: DrawingContextF -joinMiter = setLineJoin JoinMiter -joinRound :: DrawingContextF -joinRound = setLineJoin JoinRound -joinBevel :: DrawingContextF -joinBevel = setLineJoin JoinBevel +-- | Set the line_join to the default which is @miter@. +-- +-- This is a synonym for 'join_miter'. +-- +join_default :: DrawingContextF +join_default = join_miter +-- | Set the line_join to @miter@. +-- +-- This extends the joining line segments to form a sharp miter. +-- +-- This is the default. +-- +join_miter :: DrawingContextF +join_miter = setLineJoin JoinMiter + + +-- | Set the line_join to @round@. +-- +-- This rounds off the corner of the joined line segments. +-- +join_round :: DrawingContextF +join_round = setLineJoin JoinRound + + +-- | Set the line_join to @round@. +-- +-- This bevels off the corner of the joined line segments with a +-- notch. +-- +join_bevel :: DrawingContextF +join_bevel = setLineJoin JoinBevel + + -------------------------------------------------------------------------------- -dashPattern :: DashPattern -> DrawingContextF -dashPattern d = updateStrokeProps (\s -> s { dash_pattern = d }) + +-- | Set the dash pattern. +-- +-- Initially the dash pattern is 'Solid'. +-- +set_dash_pattern :: DashPattern -> DrawingContextF +set_dash_pattern d = updateStrokeProps (\s -> s { dash_pattern = d }) -unit_dash_pattern :: DashPattern -unit_dash_pattern = Dash 0 [(1,1)] --- oblivious -phase :: Int -> DashPattern -> DashPattern -phase _ Solid = Solid -phase i (Dash _ xs) = Dash i xs +-- | Set the dash_pattern to @solid@ - i.e. no dash pattern. +-- +-- This is the default. +-- +solid_line :: DrawingContextF +solid_line = set_dash_pattern Solid --- non-oblivious -dphase :: Int -> DashPattern -> DashPattern -dphase _ Solid = Solid -dphase d (Dash i xs) = Dash (i+d) xs +-- | Set the dash pattern to draw a dotted line. +-- +-- A dot is actually a square - side length is equal to the line +-- width. +-- +-- The spacing between dots is 2 times the dot width. +-- +dotted_line :: DrawingContextF +dotted_line = set_dash_pattern $ Dash 0 [(1,2)] -doublegaps :: DashPattern -> DashPattern -doublegaps Solid = Solid -doublegaps (Dash i xs) = Dash i (map fn xs) - where - fn (a,b) = (a,2*b) +-- | Set the dash pattern to draw a tightly packed dotted line. +-- +-- A dot is actually a square - side length is equal to the line +-- width. +-- +-- The spacing between dots is equal to the dot width. +-- +packed_dotted :: DrawingContextF +packed_dotted = set_dash_pattern $ Dash 0 [(1,1)] -doubledashes :: DashPattern -> DashPattern -doubledashes Solid = Solid -doubledashes (Dash i xs) = Dash i (map fn xs) - where - fn (a,b) = (a*2,b) +-- | Set the dash pattern to draw a loosely dotted line. +-- +-- A dot is actually a square - side length is equal to the line +-- width. +-- +-- The spacing between dots is 4 times the dot width. +-- +loose_dotted :: DrawingContextF +loose_dotted = set_dash_pattern $ Dash 0 [(1,4)] --------------------------------------------------------------------------------- -fontAttr :: FontFace -> Int -> DrawingContextF -fontAttr ff sz = (\s -> s { font_props = FontAttr sz ff }) -fontFace :: FontFace -> DrawingContextF -fontFace ff = updateFontProps (\(FontAttr sz _) -> FontAttr sz ff) +-- | Set the dash pattern to draw a dashed line. +-- +-- The dash length is 3 times the line width, the spacing is 2 +-- times the line width. +-- +dashed_line :: DrawingContextF +dashed_line = set_dash_pattern $ Dash 0 [(3,2)] -fontSize :: Int -> DrawingContextF -fontSize sz = updateFontProps (\(FontAttr _ ff) -> FontAttr sz ff) +-- | Set the dash pattern to draw a tightly packed, dashed line. +-- +-- The dash length is 3 times the line width, the spacing is +-- equal to the line width. +-- +packed_dashed :: DrawingContextF +packed_dashed = set_dash_pattern $ Dash 0 [(3,1)] + +-- | Set the dash pattern to draw a loosely dashed line. +-- +-- The dash length is 3 times the line width, the spacing is 4 +-- times the line width. +-- +loose_dashed :: DrawingContextF +loose_dashed = set_dash_pattern $ Dash 0 [(3,4)] + + + -------------------------------------------------------------------------------- -scalesize :: Ratio Int -> DrawingContextF -scalesize r = let (n,d) = (numerator r, denominator r) - in (\s sz -> fontSize (n * sz `div` d) s) - <*> (font_size . font_props) +-- | Set the font attributes, point size and font face. +-- +font_attr :: FontDef -> Int -> DrawingContextF +font_attr ft sz = \s -> s { dc_font_size = sz + , dc_font_face = font_def_face ft } --- | Set the font size to double the current size, note the font --- size also controls the size of dots, arrowsheads etc. +-- | Set the font face. +-- +set_font :: FontDef -> DrawingContextF +set_font ft = \s -> s { dc_font_face = font_def_face ft } + + +-- | Set the point size. +-- +-- This controls the drawing size of both +-- text labels and marks (e.g. dots and arrowheads). +-- +set_font_size :: Int -> DrawingContextF +set_font_size sz = \s -> s { dc_font_size = sz } + + +-- | Scale the current point size by the supplied ratio. -- -doublesize :: DrawingContextF -doublesize = scalesize 2 +-- Note - as fonts can only be drawn at integral sizes this +-- operation is not exact - for instance scaling 15pt by (1%2) +-- results in 7pt. +-- +scale_point_size :: Double -> DrawingContextF +scale_point_size a = (\s sz -> set_font_size (floor $ a * fromIntegral sz) s) + <*> dc_font_size +-- | Set the point size (font and mark size) to double the current +-- size. +-- +double_point_size :: DrawingContextF +double_point_size = scale_point_size 2 --- | Set the font size to half the current size, note the font + +-- | Set the point size to half the current size, note the point -- size also controls the size of dots, arrowsheads etc. -- --- As fontsize is an integer this is not exact - half size of --- 15pt type is 7pt. +-- Note - as fonts can only be drawn at integral sizes this +-- operation is not exact - half size of 15pt type is 7pt. -- -halfsize :: DrawingContextF -halfsize = scalesize (1%2) +half_point_size :: DrawingContextF +half_point_size = scale_point_size 0.5 +-- | 'text_margin' : @ x_sep * y_sep -> DrawingContextF @ +-- +-- NOTE - ideally this would use Em or En rather thn Double... +-- +text_margin :: Em -> Em -> DrawingContextF +text_margin xsep ysep = \s -> + s { dc_text_margin = TextMargin xsep ysep } + + +-- | Set the text margin to (0,0). +-- +-- This produces a tight box around the text vertically measured +-- to the cap-height and descender. Therefore some characters may +-- extend outside the margin (e.g. accented capitals like +-- A-grave). +-- +text_margin_none :: DrawingContextF +text_margin_none = text_margin 0 0 + + + +-- | Set the text margin to (0.25 em, 0.25 em). +-- +text_margin_tight :: DrawingContextF +text_margin_tight = text_margin 0.25 0.25 + +-- | Set the text margin to (0.5 em, 0.5 em). +-- +text_margin_default :: DrawingContextF +text_margin_default = text_margin 0.5 0.5 + +-- | Set the text margin to (1.0 em, 1.0 em). +-- +text_margin_loose :: DrawingContextF +text_margin_loose = text_margin 1.0 1.0 + + -------------------------------------------------------------------------------- -swapColours :: DrawingContextF -swapColours = - (\s a b -> s { stroke_colour = b, fill_colour = a }) - <*> stroke_colour <*> fill_colour +-- | Set the stroke colour. +-- +stroke_colour :: RGBi -> DrawingContextF +stroke_colour rgb = \s -> s { dc_stroke_colour = rgb } -bothStrokeColour :: DrawingContextF -bothStrokeColour = (\s a -> s { fill_colour = a }) <*> stroke_colour -bothFillColour :: DrawingContextF -bothFillColour = (\s a -> s { stroke_colour = a }) <*> fill_colour +-- | Set the fill colour. +-- +fill_colour :: RGBi -> DrawingContextF +fill_colour rgb = \s -> s { dc_fill_colour = rgb } +-- | Set the text colour. +-- +text_colour :: RGBi -> DrawingContextF +text_colour rgb = (\s -> s { dc_text_colour = rgb}) -strokeColour :: RGBi -> DrawingContextF -strokeColour rgb = \s -> s { stroke_colour = rgb } -fillColour :: RGBi -> DrawingContextF -fillColour rgb = \s -> s { fill_colour = rgb } +-- | Set the stroke, fill and text colours to a single colour. +-- +single_colour :: RGBi -> DrawingContextF +single_colour rgb = stroke_colour rgb . fill_colour rgb . text_colour rgb +-- | Swap the stroke colour and fill colours. +-- +swap_colours :: DrawingContextF +swap_colours = + (\s a b -> s { dc_stroke_colour = b, dc_fill_colour = a }) + <*> dc_stroke_colour <*> dc_fill_colour + +-- | Set the fill colour to use the current stroke colour. +-- +fill_use_stroke_colour :: DrawingContextF +fill_use_stroke_colour = + (\s a -> s { dc_fill_colour = a }) <*> dc_stroke_colour + + +-- | Set the stroke colour to use the current fill colour. +-- +stroke_use_fill_colour :: DrawingContextF +stroke_use_fill_colour = + (\s a -> s { dc_stroke_colour = a }) <*> dc_fill_colour + + +-- | Set the fill colour to use the current text colour. +-- +fill_use_text_colour :: DrawingContextF +fill_use_text_colour = + (\s a -> s { dc_fill_colour = a }) <*> dc_text_colour + + +-- | Set the stroke colour to use the current fill colour. +-- +stroke_use_text_colour :: DrawingContextF +stroke_use_text_colour = + (\s a -> s { dc_stroke_colour = a }) <*> dc_text_colour + + + +-- | Set the text colour to use the current stroke colour. +-- +text_use_stroke_colour :: DrawingContextF +text_use_stroke_colour = + (\s a -> s { dc_text_colour = a }) <*> dc_stroke_colour + + +-- | Set the text colour to use the current fill colour. +-- +text_use_fill_colour :: DrawingContextF +text_use_fill_colour = + (\s a -> s { dc_text_colour = a }) <*> dc_fill_colour + + + +-------------------------------------------------------------------------------- +-- Connector props + +-- helper +connectorUpd :: (ConnectorProps -> ConnectorProps) -> DrawingContextF +connectorUpd f = + (\s a -> s { dc_connector_props = f a }) <*> dc_connector_props + +-- | Normalize to zero if negative. +-- +normZero :: (Num u, Ord u) => u -> u +normZero u = if u < 0 then 0 else u + +-- | Set the connector source spacing. +-- +-- The spacing is used as a projection along the line formed +-- between connector points making the connection /looser/ if +-- required. +-- +-- The default value is 0. Negative values are not allowed, they +-- are normalized to 0. +-- +source_space :: (Ord u, InterpretUnit u) => u -> DrawingContextF +source_space u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_src_space = uconvert1 sz $ normZero u }) + + +-- | Set the connector destination spacing. +-- +-- The spacing is used as a projection along the line formed +-- between connector points making the connection /looser/ if +-- required. +-- +-- The default value is 0. Negative values are not allowed, they +-- are normalized to 0. +-- +dest_space :: (Ord u, InterpretUnit u) => u -> DrawingContextF +dest_space u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_dst_space = uconvert1 sz $ normZero u }) + + + +-- | Set the connector source and destination spacings to the +-- same length. +-- +uniform_conn_space :: (Ord u, InterpretUnit u) => u -> DrawingContextF +uniform_conn_space u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_src_space = uconvert1 sz $ normZero u + , dc_conn_dst_space = uconvert1 sz $ normZero u }) + + + +-- | Set the connector source offset. +-- +-- The offset is used to shift the start point /upwards/ +-- perpendicular to its true origin (negative values are +-- downwards). This can be used to draw a connector with two +-- parallel lines, for example. +-- +-- Upwards and downwards in this description are dependent on the +-- direction of the line, of course. Generally the documentations +-- consider lines are left-to-right unless specifically noted. +-- +source_offset :: (Ord u, InterpretUnit u) => u -> DrawingContextF +source_offset u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_src_offset = uconvert1 sz u }) + + +-- | Set the connector destination offset. +-- +-- See 'source_offset' for an explanation. +-- +dest_offset :: (Ord u, InterpretUnit u) => u -> DrawingContextF +dest_offset u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_dst_offset = uconvert1 sz u }) + + +-- | Set the connector arc angle. +-- +conn_arc_angle :: Radian -> DrawingContextF +conn_arc_angle ang = + connectorUpd (\s -> s { dc_conn_arc_ang = ang }) + + +-- | Set the connector source arm length. +-- +source_arm_len :: InterpretUnit u => u -> DrawingContextF +source_arm_len u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_src_arm = uconvert1 sz u }) + + + + +-- | Set the connector destination arm length. +-- +dest_arm_len :: InterpretUnit u => u -> DrawingContextF +dest_arm_len u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_dst_arm = uconvert1 sz u }) + + + + +-- | Set the connector source and destination arms to the same +-- length. +-- +uniform_arm_len :: InterpretUnit u => u -> DrawingContextF +uniform_arm_len u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_src_arm = uconvert1 sz u + , dc_conn_dst_arm = uconvert1 sz u }) + + +-- | Set the connector loop size. +-- +conn_loop_size :: InterpretUnit u => u -> DrawingContextF +conn_loop_size u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_loop_size = uconvert1 sz u }) + +-- | Set the connector box halfsize. +-- +conn_box_halfsize :: InterpretUnit u => u -> DrawingContextF +conn_box_halfsize u = withFontSize $ \sz -> + connectorUpd (\s -> s { dc_conn_box_halfsize = uconvert1 sz u }) diff --git a/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs b/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs --- a/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs +++ b/src/Wumpus/Basic/Kernel/Base/WrappedPrimitive.hs @@ -1,39 +1,36 @@ {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Base.WrappedPrimitive --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com -- Stability : highly unstable -- Portability : GHC -- --- Two /warpped/ versions of the Primitive type from Wumpus-Core. +-- Wrapped versions of the @Primitive@ type from Wumpus-Core. -- -------------------------------------------------------------------------------- module Wumpus.Basic.Kernel.Base.WrappedPrimitive ( + + -- * Primitives - HPrim + CatPrim + , prim1 + , cpmap + + , HPrim , hprimToList , singleH - -- * Collect primitives (writer monad) - , TraceM(..) - , PrimGraphic - , getPrimGraphic - , primGraphic - , metamorphPrim - , collectH ) where @@ -47,24 +44,57 @@ --- As of version 0.36.0, Wumpus-Core supports grouping primitives --- together (a common operation in vector drawing editors). --- --- For Wumpus-Basic this means e.g. a line with arrowheads can --- still be a primitive. --- --- Still, we wrap Primitive as a newtype... +-- | CatPrim could probably manage happily just being a +-- Primitive, but it is wrapped as a newtype... -- +data CatPrim = CZero + | Cat1 Primitive -newtype PrimGraphic u = PrimGraphic { getPrimGraphic :: Primitive u } - deriving (Eq,Show) +type instance DUnit CatPrim = Double +instance OPlus CatPrim where + CZero `oplus` b = b + a `oplus` CZero = a + Cat1 a `oplus` Cat1 b = Cat1 $ a `primCat` b -type instance DUnit (PrimGraphic u) = u +instance Monoid CatPrim where + mempty = CZero + CZero `mappend` b = b + a `mappend` CZero = a + Cat1 a `mappend` Cat1 b = Cat1 $ a `primCat` b + -------------------------------------------------------------------------------- + +instance Rotate CatPrim where + rotate _ CZero = CZero + rotate ang (Cat1 a) = Cat1 $ rotate ang a + +instance RotateAbout CatPrim where + rotateAbout _ _ CZero = CZero + rotateAbout ang pt (Cat1 a) = Cat1 $ rotateAbout ang pt a + +instance Scale CatPrim where + scale _ _ CZero = CZero + scale sx sy (Cat1 a) = Cat1 $ scale sx sy a + +instance Translate CatPrim where + translate _ _ CZero = CZero + translate dx dy (Cat1 a) = Cat1 $ translate dx dy a + + +-------------------------------------------------------------------------------- + +prim1 :: Primitive -> CatPrim +prim1 = Cat1 + +cpmap :: (Primitive -> Primitive) -> CatPrim -> CatPrim +cpmap _ CZero = CZero +cpmap f (Cat1 a) = Cat1 $ f a + +-------------------------------------------------------------------------------- -- Lists of primitives... -- | Graphics objects, even simple ones (line, arrow, dot) might @@ -81,8 +111,13 @@ -- representation, and a Hughes list which supports -- efficient concatenation is wise. -- -newtype HPrim u = HPrim { getHPrim :: H (Primitive u) } +-- NOTE - currently HPrim has a phantom unit @u@, this is so +-- trace drawings can have a unit type, but this may change as +-- perhaps trace drawings don\'t benefit from having units. +-- +newtype HPrim u = HPrim { getHPrim :: H Primitive } + -- Note - only a Monoid instance for HPrim - they cannot be -- shown, fmapped etc. @@ -91,59 +126,16 @@ ha `mappend` hb = HPrim $ getHPrim ha `appendH` getHPrim hb -hprimToList :: HPrim u -> [Primitive u] +hprimToList :: HPrim u -> [Primitive] hprimToList = toListH . getHPrim -singleH :: Primitive u -> HPrim u -singleH = HPrim . wrapH - - --------------------------------------------------------------------------------- - --- | Collect elementary graphics as part of a larger drawing. --- --- TraceM works much like a writer monad. --- -class TraceM (m :: * -> *) where - trace :: MonUnit m ~ u => HPrim u -> m () +singleH :: CatPrim -> HPrim u +singleH CZero = HPrim emptyH +singleH (Cat1 a) = HPrim $ wrapH a --------------------------------------------------------------------------------- --- instances - -instance OPlus (PrimGraphic u) where - oplus a b = PrimGraphic $ getPrimGraphic a `oplus` getPrimGraphic b - - --- Affine transformations - -instance (Real u, Floating u) => Rotate (PrimGraphic u) where - rotate ang = PrimGraphic . rotate ang . getPrimGraphic - - -instance (Real u, Floating u) => RotateAbout (PrimGraphic u) where - rotateAbout ang pt = PrimGraphic . rotateAbout ang pt . getPrimGraphic - - -instance Num u => Scale (PrimGraphic u) where - scale sx sy = PrimGraphic . scale sx sy . getPrimGraphic - - -instance Num u => Translate (PrimGraphic u) where - translate dx dy = PrimGraphic . translate dx dy . getPrimGraphic - --------------------------------------------------------------------------------- - -primGraphic :: Primitive u -> PrimGraphic u -primGraphic = PrimGraphic - -metamorphPrim :: (Primitive u -> Primitive u) -> PrimGraphic u -> PrimGraphic u -metamorphPrim f = primGraphic . f . getPrimGraphic - -collectH :: PrimGraphic u -> HPrim u -collectH = singleH . getPrimGraphic diff --git a/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs b/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/AdvObject.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.AdvObject +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Extended Graphic object - an AdvanceGraphic is a Graphic +-- twinned with and advance vector. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.AdvObject + ( + + -- * Advance-vector object and graphic + AdvObject + , DAdvObject + + , AdvGraphic + , DAdvGraphic + + , makeAdvObject + , emptyAdvObject + + , runAdvObjectR0 + , runAdvObjectR1 + + + -- * Composition + , advance + , advances + , advspace + , evenspace + + , advrepeat + , punctuate + , advfill + + ) where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Objects.Basis +import Wumpus.Basic.Kernel.Objects.Displacement +import Wumpus.Basic.Kernel.Objects.Image +import Wumpus.Basic.Kernel.Objects.LocImage + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative +import Data.Monoid + + + +type AdvDraw u = Point2 u -> GraphicAns u + + +-- | /Advance vector/ graphic - this partially models the +-- PostScript @show@ command which moves the /current point/ by the +-- advance (width) vector as each character is drawn. +-- +newtype AdvObject u = AdvObject { getAdvObject :: CF (Vec2 u, AdvDraw u) } + +type instance DUnit (AdvObject u) = u + +type DAdvObject = AdvObject Double + + +type AdvGraphic u = LocImage u (Vec2 u) +type DAdvGraphic = AdvGraphic Double + + +-------------------------------------------------------------------------------- + +instance (InterpretUnit u) => Monoid (AdvObject u) where + mempty = emptyAdvObject + mappend = advplus + + +-- | 'makeAdvObject' : @ loc_context_function * graphic -> AdvObject @ +-- +-- Build an 'AdvObject' from a context function ('CF') that +-- generates the answer displacement vector and a 'LocGraphic' +-- that draws the 'AdvObject'. +-- +makeAdvObject :: Query (Vec2 u) -> LocGraphic u -> AdvObject u +makeAdvObject qvec gf = AdvObject body + where + body = drawingCtx >>= \ctx -> + let v1 = runCF ctx qvec + pf = runCF ctx gf + in return (v1,pf) + + + +-- | 'emptyAdvObjectAU' : @ AdvObject @ +-- +-- Build an empty 'AdvObject'. +-- +-- The 'emptyAdvObject' is treated as a /null primitive/ by +-- @Wumpus-Core@ and is not drawn, the answer vector generated is +-- the zero vector @(V2 0 0)@. +-- +emptyAdvObject :: InterpretUnit u => AdvObject u +emptyAdvObject = makeAdvObject (pure $ V2 0 0) emptyLocGraphic + + + +runAdvObjectR0 :: Point2 u -> AdvObject u -> Image u (Vec2 u) +runAdvObjectR0 pt (AdvObject mf) = + (\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf + + +runAdvObjectR1 :: AdvObject u -> AdvGraphic u +runAdvObjectR1 (AdvObject mf) = promoteR1 $ \pt -> + (\(v1,pf) -> replaceAns v1 $ pf pt) <$> mf + + +-------------------------------------------------------------------------------- +-- Combining AdvObjects + + + +-- | Primitive combination. +-- +-- Move second object by the advance vector of the first. Sum +-- both advance vecots. +-- +advplus :: Num u => AdvObject u -> AdvObject u -> AdvObject u +advplus a b = AdvObject body + where + body = drawingCtx >>= \ctx -> + let (v0,pf0) = runCF ctx (getAdvObject a) + (v1,pf1) = runCF ctx (getAdvObject b) + pf = \pt -> pf0 pt `oplus` pf1 (pt .+^ v0) + in return (v0 ^+^ v1, pf) + +-- Helper for list concatenation. +-- +listcat :: InterpretUnit u + => (AdvObject u -> AdvObject u -> AdvObject u) + -> [AdvObject u] -> AdvObject u +listcat _ [] = emptyAdvObject +listcat op (x:xs) = go x xs + where + go acc [] = acc + go acc (b:bs) = go (acc `op` b) bs + + + +-- AdvObject does not have the same ability to be concatenated +-- as PosObject - all the advance vector says is \"where to go +-- next\". Nothing in the AdvObject tracks the boundary so we +-- cannot implement the Concat classes. + +infixr 6 `advance` + + +-- | Draw the first AdvObject and use the advance vector to +-- displace the second AdvObject. +-- +-- The final answer is the sum of both advance vectors. +-- +advance :: Num u => AdvObject u -> AdvObject u -> AdvObject u +advance = advplus + + +-- | Concatenate the list of AdvObjects with 'advance'. +-- +advances :: InterpretUnit u => [AdvObject u] -> AdvObject u +advances = listcat advance + + +-- | Combine the AdvObjects using the answer vector of the +-- first object plus the separator to move the start of the second +-- object. +-- +advspace :: Num u => Vec2 u -> AdvObject u -> AdvObject u -> AdvObject u +advspace sep a b = AdvObject body + where + body = drawingCtx >>= \ctx -> + let (v0,pf0) = runCF ctx (getAdvObject a) + (v1,pf1) = runCF ctx (getAdvObject b) + pf = \pt -> pf0 pt `oplus` pf1 (displaceVec (sep ^+^ v0) pt) + in return (v0 ^+^ sep ^+^ v1, pf) + +-- | List version of 'nextSpace'. +-- +evenspace :: InterpretUnit u => Vec2 u -> [AdvObject u] -> AdvObject u +evenspace v = listcat (advspace v) + + + +-- | Repeat the AdvObject @n@ times, moving each time with +-- 'advance'. +-- +advrepeat :: InterpretUnit u => Int -> AdvObject u -> AdvObject u +advrepeat n = advances . replicate n + + +-- | Concatenate the list of AdvObjects, going next and adding +-- the separator at each step. +-- +punctuate :: InterpretUnit u => AdvObject u -> [AdvObject u] -> AdvObject u +punctuate sep = listcat (\a b -> a `advance` sep `advance` b) + + + +-- | Render the supplied AdvObject, but swap the result advance +-- for the supplied vector. This function has behaviour analogue +-- to @fill@ in the @wl-pprint@ library. +-- +advfill :: Num u => Vec2 u -> AdvObject u -> AdvObject u +advfill sv a = AdvObject body + where + body = drawingCtx >>= \ctx -> + let (_,pf) = runCF ctx (getAdvObject a) in return (sv, pf) + + + diff --git a/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs b/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Objects/AdvanceGraphic.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Kernel.Objects.AdvanceGraphic --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- Extended Graphic object - an AdvanceGraphic is a Graphic --- twinned with and advance vector. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Kernel.Objects.AdvanceGraphic - ( - - -- * Advance-vector graphic - AdvGraphic - , DAdvGraphic - - - , intoAdvGraphic - , emptyAdvGraphic - - - -- * Composition - , advcat - , advsep - , advconcat - , advspace - , advpunctuate - , advfill - - ) where - -import Wumpus.Basic.Kernel.Base.BaseDefs -import Wumpus.Basic.Kernel.Base.ContextFun -import Wumpus.Basic.Kernel.Objects.BaseObjects -import Wumpus.Basic.Kernel.Objects.Graphic - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space -import Data.VectorSpace - - - --- | /Advance vector/ graphic - this partially models the --- PostScript @show@ command which moves the /current point/ by the --- advance (width) vector as each character is drawn. --- -type AdvGraphic u = LocImage u (Vec2 u) - -type DAdvGraphic = AdvGraphic Double - - - --------------------------------------------------------------------------------- - - - - --- | 'intoAdvGraphic' : @ loc_context_function * graphic -> Image @ --- --- Build an 'AdvGraphic' from a context function ('CF') that --- generates the answer displacement vector and a 'LocGraphic' --- that draws the 'AdvGraphic'. --- -intoAdvGraphic :: LocCF u (Vec2 u) - -> LocGraphic u - -> AdvGraphic u -intoAdvGraphic = intoLocImage - - --- | 'emptyAdvGraphic' : @ AdvGraphic @ --- --- Build an empty 'AdvGraphic'. --- --- The 'emptyAdvGraphic' is treated as a /null primitive/ by --- @Wumpus-Core@ and is not drawn, the answer vetor generated is --- the empty vector @(V2 0 0)@. --- -emptyAdvGraphic :: Num u => AdvGraphic u -emptyAdvGraphic = replaceAns (V2 0 0) $ emptyLocGraphic - - - --- runAdvGraphic :: DrawingContext -> Point2 u -> AdvGraphic u --- -> (Point2 u, PrimGraphic u) --- runAdvGraphic ctx pt df = runCF1 ctx pt df - - - --------------------------------------------------------------------------------- --- composition - --- Note there are opportunities for extra composition operators --- like the /picture language/... - - --- Naming convention - binary functions are favoured for shorter names. - -infixr 6 `advcat` -infixr 5 `advsep` - --- | Concatenate the two AdvGraphics. --- -advcat :: Num u => AdvGraphic u -> AdvGraphic u -> AdvGraphic u -advcat af ag = promoteR1 $ \start -> - (af `at` start) >>= \(v1,prim1) -> - (ag `at` start .+^ v1) >>= \(v2,prim2) -> - return (v1 ^+^ v2, prim1 `oplus` prim2) - - --- | Concatenate the two AdvGraphics spacing them by the supplied --- vector. --- -advsep :: Num u => Vec2 u -> AdvGraphic u -> AdvGraphic u -> AdvGraphic u -advsep sv af ag = promoteR1 $ \start -> - (af `at` start) >>= \(v1,prim1) -> - (ag `at` start .+^ sv ^+^ v1) >>= \(v2,prim2) -> - return (v1 ^+^ sv ^+^ v2, prim1 `oplus` prim2) - - --- | Concatenate the list of AdvGraphic with 'advcat'. --- -advconcat :: Num u => [AdvGraphic u] -> AdvGraphic u -advconcat [] = emptyAdvGraphic -advconcat (x:xs) = step x xs - where - step a (b:bs) = step (a `advcat` b) bs - step a [] = a - - --- | Concatenate the list of AdvGraphic with 'advsep'. --- -advspace :: Num u => Vec2 u -> [AdvGraphic u] -> AdvGraphic u -advspace _ [] = emptyAdvGraphic -advspace sv (x:xs) = step x xs - where - step a (b:bs) = step (advsep sv a b) bs - step a [] = a - - --- | Concatenate the list of AdvGraphic with 'advsep'. --- -advpunctuate :: Num u => AdvGraphic u -> [AdvGraphic u] -> AdvGraphic u -advpunctuate _ [] = emptyAdvGraphic -advpunctuate sep (x:xs) = step x xs - where - step a (b:bs) = step (a `advcat` sep `advcat` b) bs - step a [] = a - - --- | Render the supplied AdvGraphic, but swap the result advance --- for the supplied vector. This function has behaviour analogue --- to @fill@ in the @wl-pprint@ library. --- -advfill :: Num u => Vec2 u -> AdvGraphic u -> AdvGraphic u -advfill sv = replaceAns sv diff --git a/src/Wumpus/Basic/Kernel/Objects/Anchors.hs b/src/Wumpus/Basic/Kernel/Objects/Anchors.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Anchors.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Anchors +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Anchor points on shapes, bounding boxes, etc. +-- +-- Anchors are addressable positions, an examplary use is taking +-- anchors on node shapes to get the start and end points for +-- connectors in a network (graph) diagram. +-- +-- \*\* WARNING \*\* - The API here needs some thought as to a +-- good balance of the type classes - in a nutshell \"are corners +-- better than cardinals\". Originally I tried to follow how I +-- understand the TikZ anchors to work, but this is perhaps not +-- ideal for dividing into type-classes. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Anchors + ( + + -- * Anchors + Anchor + + -- * Anchor classes + , CenterAnchor(..) + , ApexAnchor(..) + , CardinalAnchor(..) + , CardinalAnchor2(..) + , RadialAnchor(..) + , TopCornerAnchor(..) + , BottomCornerAnchor(..) + , SideMidpointAnchor(..) + + + -- * Extended anchor points + , projectAnchor + + , radialConnectorPoints + + ) where + + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space + + +-- | Note an Anchor is just a Point2. +-- +type Anchor u = Point2 u + + +-- | Center of an object. +-- +class CenterAnchor a where + center :: u ~ DUnit a => a -> Anchor u + + +-- | Apex of an object. +-- +class ApexAnchor a where + apex :: u ~ DUnit a => a -> Anchor u + + +-- | Cardinal (compass) positions on an object. +-- +-- Cardinal anchors should be at their equivalent radial position. +-- However, some shapes may not be able to easily define radial +-- positions or may be able to provide more efficient definitions +-- for the cardinal anchors. Hence the redundancy seems justified. +-- +class CardinalAnchor a where + north :: u ~ DUnit a => a -> Anchor u + south :: u ~ DUnit a => a -> Anchor u + east :: u ~ DUnit a => a -> Anchor u + west :: u ~ DUnit a => a -> Anchor u + +-- +-- Note - a design change is probably in order where the cardinals +-- should /always/ represent their true cardinal position. +-- +-- If this change is made, it is worthwhile having cardinals as +-- classes (rather than making them derived operations on +-- RadialAnchor) as classes allow for more efficient +-- implementations usually by trigonometry. +-- + + +-- | Secondary group of cardinal (compass) positions on an object +-- for the diagonal positions. +-- +-- It seems possible that for some objects defining the primary +-- compass points (north, south,...) will be straight-forward +-- whereas defining the secondary compass points may be +-- problematic, hence the compass points are split into two +-- classes. +-- +class CardinalAnchor2 a where + northeast :: u ~ DUnit a => a -> Anchor u + southeast :: u ~ DUnit a => a -> Anchor u + southwest :: u ~ DUnit a => a -> Anchor u + northwest :: u ~ DUnit a => a -> Anchor u + + +-- | Anchor on a border that can be addressed by an angle. +-- +-- The angle is counter-clockwise from the right-horizontal, i.e. +-- 0 is /east/. +-- +class RadialAnchor a where + radialAnchor :: Radian -> u ~ DUnit a => a -> Anchor u + + +-- | Anchors at the top left and right corners of a shape. +-- +-- For some shapes (Rectangle) the TikZ convention appears to be +-- have cardinals as the corner anchors, but this doesn\'t seem +-- to be uniform. Wumpus will need to reconsider anchors at some +-- point... +-- +class TopCornerAnchor a where + topLeftCorner :: u ~ DUnit a => a -> Anchor u + topRightCorner :: u ~ DUnit a => a -> Anchor u + + +-- | Anchors at the bottom left and right corners of a shape. +-- +class BottomCornerAnchor a where + bottomLeftCorner :: u ~ DUnit a => a -> Anchor u + bottomRightCorner :: u ~ DUnit a => a -> Anchor u + + +-- | Anchors in the center of a side. +-- +-- Sides are addressable by index. Following TikZ, side 1 is +-- expected to be the top of the shape. If the shape has an apex +-- instead of a side then side 1 is expected to be the first side +-- left of the apex. +-- +-- Implementations are also expected to modulo the side number, +-- rather than throw an out-of-bounds error. +-- +class SideMidpointAnchor a where + sideMidpoint :: Int -> u ~ DUnit a => a -> Anchor u + + + +-------------------------------------------------------------------------------- + +-- | 'projectAnchor' : @ extract_func * dist * object -> Point @ +-- +-- Derive a anchor by projecting a line from the center of an +-- object through the intermediate anchor (produced by the +-- extraction function). The final answer point is located along +-- the projected line at the supplied distance @dist@. +-- +-- E.g. take the north of a rectangle and project it 10 units +-- further on: +-- +-- > projectAnchor north 10 my_rect +-- +-- If the distance is zero the answer with be whatever point the +-- the extraction function produces. +-- +-- If the distance is negative the answer will be along the +-- projection line, between the center and the intermediate anchor. +-- +-- If the distance is positive the anchor will be extend outwards +-- from the intermediate anchor. +-- +projectAnchor :: (Real u, Floating u, CenterAnchor a, u ~ DUnit a) + => (a -> Anchor u) -> u -> a -> Anchor u +projectAnchor fn d a = p1 .+^ (avec (vdirection v) d) + where + p1 = fn a + v = pvec (center a) p1 + + + +-------------------------------------------------------------------------------- + +-- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @ +-- +-- Find the radial connectors points for objects @a@ and @b@ along +-- the line joining their centers. +-- +radialConnectorPoints :: ( Real u, Floating u + , CenterAnchor a, RadialAnchor a + , CenterAnchor b, RadialAnchor b + , u ~ DUnit a, u ~ DUnit b) + => a -> b -> (Point2 u, Point2 u) +radialConnectorPoints a b = (radialAnchor ang a, radialAnchor (ang+pi) b) + where + ang = vdirection $ pvec (center a) (center b) + + + +-------------------------------------------------------------------------------- +-- Instances + +instance Fractional u => CenterAnchor (BoundingBox u) where + center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y + where + x = xl+0.5*(xr-xl) + y = ylo+0.5*(yhi-ylo) + + +instance Fractional u => CardinalAnchor (BoundingBox u) where + north (BBox (P2 xl _ ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi + south (BBox (P2 xl ylo) (P2 xr _ )) = P2 (xl+0.5*(xr-xl)) ylo + east (BBox (P2 _ ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo)) + west (BBox (P2 xl ylo) (P2 _ yhi)) = P2 xl (ylo+0.5*(yhi-ylo)) + + +instance Fractional u => CardinalAnchor2 (BoundingBox u) where + northeast (BBox _ ur) = ur + southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo + southwest (BBox ll _) = ll + northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi + diff --git a/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs b/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Objects/BaseObjects.hs +++ /dev/null @@ -1,186 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Kernel.Objects.BaseObjects --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- Aliases for ContextFun types. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Kernel.Objects.BaseObjects - ( - - -- * Drawing info - DrawingInfo - , LocDrawingInfo - , LocThetaDrawingInfo - - - - -- * Drawing objects - , ImageAns - , GraphicAns - - , Image - , LocImage - , LocThetaImage - - , DImage - , DLocImage - , DLocThetaImage - - ) where - -import Wumpus.Basic.Kernel.Base.ContextFun -import Wumpus.Basic.Kernel.Base.WrappedPrimitive - -import Wumpus.Core -- package: wumpus-core - --------------------------------------------------------------------------------- --- DrawingInfo - --- | A query on the DrawingContext. --- --- Alias for 'CF'. --- -type DrawingInfo a = CF a - - --- | A query on the DrawingContext respective to the supplied --- point. --- --- Alias for 'LocCF'. --- -type LocDrawingInfo u a = LocCF u a - - --- | A query on the DrawingContext respective to the supplied --- point and angle. --- --- Alias for 'LocCF'. --- -type LocThetaDrawingInfo u a = LocThetaCF u a - - - - --------------------------------------------------------------------------------- --- Image - - --- | An Image always returns a pair of some polymorphic answer @a@ --- and a PrimGraphic. --- --- Note a PrimGraphic cannot be empty. --- -type ImageAns u a = (a, PrimGraphic u) - - -type GraphicAns u = ImageAns u (UNil u) - - --- | Draw a PrimGraphic repsective to the 'DrawingContext' and --- return some answer @a@. --- -type Image u a = CF (ImageAns u a) - - --- | Draw a PrimGraphic respective to the 'DrawingContext' and --- the supplied point, return some answer @a@. --- -type LocImage u a = LocCF u (ImageAns u a) - - --- | Draw a PrimGraphic respective to the 'DrawingContext' and --- the supplied point and angle. --- -type LocThetaImage u a = LocThetaCF u (ImageAns u a) - - - -type DImage a = Image Double a -type DLocImage a = LocImage Double a -type DLocThetaImage a = LocThetaImage Double a - - -type instance DUnit (Image u a) = u -- GuardEq (DUnit a) (DUnit (PrimGraphic u)) - -type instance DUnit (LocImage u a) = u -- GuardEq (DUnit a) (DUnit (PrimGraphic u)) - -type instance DUnit (LocThetaImage u a) = u - - - --------------------------------------------------------------------------------- --- Affine instances - --- Note - it seems better to have these instances for Image (even --- though Image is a type synonym) rather than more general --- instances on a CF. --- --- There is nothing determining a DUnit for the CF types. --- --- The downside is these instances are effectively orphan --- instances. --- - -instance (Real u, Floating u, Rotate a, DUnit a ~ u) => - Rotate (Image u a) where - rotate ang = fmap (rotate ang) - - -instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => - RotateAbout (Image u a) where - rotateAbout ang pt = fmap (rotateAbout ang pt) - - -instance (Num u, Scale a, DUnit a ~ u) => Scale (Image u a) where - scale sx sy = fmap (scale sx sy) - - -instance (Num u, Translate a, DUnit a ~ u) => Translate (Image u a) where - translate dx dy = fmap (translate dx dy) - - --- \*\* WARNING \*\* - I am not sure having affine instances for --- LocImage makes sense... --- --- Particularly, what is a rotateAbout on a function from Point to --- Graphic? Is it just a post-transformation, or should the start --- point be transformed as well. --- - -instance (Real u, Floating u, Rotate a, DUnit a ~ u) => - Rotate (LocImage u a) where - rotate ang = fmap (rotate ang) - -instance (Real u, Floating u, RotateAbout a, DUnit a ~ u) => - RotateAbout (LocImage u a) where - rotateAbout ang pt = fmap (rotateAbout ang pt) - - -instance (Num u, Scale a, DUnit a ~ u) => Scale (LocImage u a) where - scale sx sy = fmap (scale sx sy) - - -instance (Num u, Translate a, DUnit a ~ u) => Translate (LocImage u a) where - translate dx dy = fmap (translate dx dy) - --------------------------------------------------------------------------------- - - - - - - - - diff --git a/src/Wumpus/Basic/Kernel/Objects/Basis.hs b/src/Wumpus/Basic/Kernel/Objects/Basis.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Basis.hs @@ -0,0 +1,564 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Basis +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Common types and operations. +-- +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Basis + ( + + LocQuery + , LocThetaQuery + , ConnectorQuery + + , GraphicAns + , ImageAns(..) + + , graphicAns + , mapAns + , replaceAns + , ignoreAns + , answer + , hyperlink + , clipObject + + , szconvAnsF + , szconvAnsZ + + + , at + , incline + , atIncline + , connect + + , replaceAnsR0 + , replaceAnsR1 + , replaceAnsR2 + + , decorateR0 + , decorateR1 + , decorateR2 + + , elaborateR0 + , elaborateR1 + , elaborateR2 + + + ) where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.WrappedPrimitive + +import Wumpus.Core -- package: wumpus-core + + +import Control.Applicative +import Data.Monoid + + +type LocQuery u a = CF (Point2 u -> a) +type LocThetaQuery u a = CF (Point2 u -> Radian -> a) +type ConnectorQuery u a = CF (Point2 u -> Point2 u -> a) + + +-- Design note - GraphicAns needs a unit for consistency even +-- though it is never scrutinized. +-- + + +data ImageAns u a = Ans CatPrim a + +type GraphicAns u = ImageAns u (UNil u) + + + +type instance DUnit (ImageAns u a) = u + + +-------------------------------------------------------------------------------- +-- OPlus and monoid + + +instance OPlus a => OPlus (ImageAns u a) where + Ans cp0 a `oplus` Ans cp1 b = Ans (cp0 `oplus` cp1) (a `oplus` b) + + +instance Monoid a => Monoid (ImageAns u a) where + mempty = Ans mempty mempty + Ans cp0 a `mappend` Ans cp1 b = Ans (cp0 `mappend` cp1) (a `mappend` b) + + +-------------------------------------------------------------------------------- +-- Affine instances + +-- +-- Design Note +-- +-- Translate and RotateAbout require the unit to be /scalar/ +-- e.g. Double, Centimeter, Pica. +-- +-- This is annoying and a limitation, but an alternative would +-- need access to current-font-size which cannot be a pure +-- function. +-- + +instance Rotate a => Rotate (ImageAns u a) where + rotate ang (Ans cp a) = Ans (rotate ang cp) (rotate ang a) + + +instance (RotateAbout a, ScalarUnit u, u ~ DUnit a) => + RotateAbout (ImageAns u a) where + rotateAbout ang pt@(P2 x y) (Ans cp a) = + Ans (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) cp) + (rotateAbout ang pt a) + + + +instance Scale a => Scale (ImageAns u a) where + scale sx sy (Ans cp a) = Ans (scale sx sy cp) (scale sx sy a) + + +instance (Translate a, ScalarUnit u, u ~ DUnit a) => + Translate (ImageAns u a) where + translate dx dy (Ans cp a) = + Ans (translate (toPsPoint dx) (toPsPoint dy) cp) (translate dx dy a) + + +-------------------------------------------------------------------------------- + + + +-- | Map the answer produced by a graphic object. +-- +-- Note - the new answer must share the same unit type as the +-- initial answer, although it does not need to have the same +-- wrapper type. +-- +mapAns :: (a -> a1) -> ImageAns u a -> ImageAns u a1 +mapAns f (Ans cp a) = Ans cp (f a) + + + +-- | Replace the answer produced by a graphic object. +-- +-- Note - the new answer must share the same unit type as the +-- initial answer, although it does not need to have the same +-- wrapper type. +-- +replaceAns :: ans -> ImageAns u a -> ImageAns u ans +replaceAns ans (Ans prim _) = Ans prim ans + + +-- | Turn an imageAns into a GraphicAns by ignoring the +-- result. +-- +-- Usually this function will be used with one of the @push@ +-- family of combinators. +-- +-- > LocImage-to-LocGraphic = pushR1 ignoreAns +-- +ignoreAns :: ImageAns u a -> GraphicAns u +ignoreAns(Ans prim _) = Ans prim UNil + + + +graphicAns :: CatPrim -> GraphicAns u +graphicAns prim = Ans prim UNil + +-- | Extractor for the answer part of an image. +-- +answer :: ImageAns u a -> a +answer (Ans _ a) = a + + +-- | Note - maybe this requires an arity family instead? +-- +hyperlink :: XLink -> ImageAns u a -> ImageAns u a +hyperlink hypl (Ans prim a) = Ans (cpmap (xlinkPrim hypl) prim) a + + +-- | Clip a graphic object. +-- +-- Note - maybe this requires an arity family instead? +-- +clipObject :: PrimPath -> ImageAns t u -> ImageAns t u +clipObject pp (Ans prim a) = Ans (cpmap (clip pp) prim) a + + +-------------------------------------------------------------------------------- +-- Helpers for unit conversion... + + + +szconvAnsF :: (Functor t, InterpretUnit u, InterpretUnit u1) + => FontSize -> ImageAns u (t u) -> ImageAns u1 (t u1) +szconvAnsF sz (Ans prim a) = Ans prim (uconvertF sz a) + +szconvAnsZ :: FontSize -> ImageAns u a -> ImageAns u1 a +szconvAnsZ _ (Ans prim a) = Ans prim a + + + +infixr 1 `at` + + +-- | Downcast a 'LocCF' function by applying it to the supplied +-- point, making an arity-zero Context Function. +-- +-- Remember a 'LocCF' function is a 'CF1' context function where +-- the /static argument/ is specialized to a start point. +-- +at :: LocQuery u a -> Point2 u -> CF a +at = apply1R1 + + + +infixr 1 `incline` + + +-- | Downcast a 'LocThetaQuery' function by applying it to the +-- supplied angle, making an arity-one Context Function (a +-- 'LocCF'). +-- +incline :: LocThetaQuery u a -> Radian -> LocQuery u a +incline = apply1R2 + + +-- | Downcast a LocThetaQuery function by applying it to the +-- supplied point and angle, making an arity-zero Context Function +-- (a CF). +-- +atIncline :: LocThetaQuery u a -> Point2 u -> Radian -> CF a +atIncline = apply2R2 + + +-- | Downcast a 'ConnectorQuery' function by applying it to the +-- start and end point, making an arity-zero Context Function +-- (a 'CF'). +-- +connect :: ConnectorQuery u a -> Point2 u -> Point2 u -> CF a +connect = apply2R2 + + + +-- | Replace the ans - arity 0. +-- +replaceAnsR0 :: ans -> CF (ImageAns u a) -> CF (ImageAns u ans) +replaceAnsR0 ans = fmap (replaceAns ans) + + +-- | Replace the ans - arity 1. +-- +replaceAnsR1 :: ans -> CF (r1 -> ImageAns u a) -> CF (r1 -> ImageAns u ans) +replaceAnsR1 ans = fmap $ fmap (replaceAns ans) + + +-- | Replace the ans - arity 2. +-- +replaceAnsR2 :: ans + -> CF (r1 -> r2 -> ImageAns u a) + -> CF (r1 -> r2 -> ImageAns u ans) +replaceAnsR2 ans = fmap $ fmap $ fmap (replaceAns ans) + + +-- | Decorate an Image by superimposing a Graphic. +-- +-- Note - this function has a very general type signature and +-- supports various graphic types: +-- +decorateR0 :: CF (ImageAns u a) -> CF (GraphicAns u) -> CF (ImageAns u a) +decorateR0 img gf = op <$> img <*> gf + where + op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a + + +decorateR1 :: CF (r1 -> ImageAns u a) + -> CF (r1 -> GraphicAns u) + -> CF (r1 -> ImageAns u a) +decorateR1 img gf = promoteR1 $ \r1 -> + op <$> apply1R1 img r1 <*> apply1R1 gf r1 + where + op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a + + +decorateR2 :: CF (r1 -> r2 -> ImageAns u a) + -> CF (r1 -> r2 -> GraphicAns u) + -> CF (r1 -> r2 -> ImageAns u a) +decorateR2 img gf = promoteR2 $ \r1 r2 -> + op <$> apply2R2 img r1 r2 <*> apply2R2 gf r1 r2 + where + op (Ans cp a) (Ans cp1 _) = Ans (cp `oplus` cp1) a + + +-- | Decorate an Image by superimposing a Graphic. +-- +-- Note - this function has a very general type signature and +-- supports various graphic types: +-- +elaborateR0 :: CF (ImageAns u a) -> (a -> CF (GraphicAns u)) -> CF (ImageAns u a) +elaborateR0 img gf = + img >>= \(Ans p1 a) -> + gf a >>= \(Ans p2 _) -> + return $ Ans (p1 `oplus` p2) a + + + + +-- | Decorate an Image by superimposing a Graphic. +-- +-- Note - this function has a very general type signature and +-- supports various graphic types: +-- +elaborateR1 :: CF (r1 -> ImageAns u a) + -> (a -> CF (r1 -> GraphicAns u)) + -> CF (r1 -> ImageAns u a) +elaborateR1 img gf = promoteR1 $ \r1 -> + apply1R1 img r1 >>= \(Ans p1 a) -> + apply1R1 (gf a) r1 >>= \(Ans p2 _) -> + return $ Ans (p1 `oplus` p2) a + + + +elaborateR2 :: CF (r1 -> r2 -> ImageAns u a) + -> (a -> CF (r1 -> r2 -> GraphicAns u)) + -> CF (r1 -> r2 -> ImageAns u a) +elaborateR2 img gf = promoteR2 $ \r1 r2 -> + apply2R2 img r1 r2 >>= \(Ans p1 a) -> + apply2R2 (gf a) r1 r2 >>= \(Ans p2 _) -> + return $ Ans (p1 `oplus` p2) a + + + + +{- + +-- Not exported - thanks to Max Bollingbroke. +-- +type family GuardEqAns a b :: * +type instance GuardEqAns a a = a + +-- | An Image always returns a pair of some polymorphic answer @a@ +-- and a PrimGraphic. +-- +data ImageAns t u = Ans (t u) CatPrim + +type instance DUnit (ImageAns t u) = GuardEqAns u (DUnit (t u)) + +type GraphicAns u = ImageAns UNil u + + +instance Functor t => Functor (ImageAns t) where + fmap f (Ans a prim) = Ans (fmap f a) prim + +instance OPlus (t u) => OPlus (ImageAns t u) where + Ans a p1 `oplus` Ans b p2 = Ans (a `oplus` b) (p1 `oplus` p2) + + +-------------------------------------------------------------------------------- +-- Affine instances + +-- +-- Design Note +-- +-- Translate and RotateAbout require the unit to be /scalar/ +-- e.g. Double, Centimeter, Pica. +-- +-- This is annoying and a limitation, but an alternative would +-- need access to current-font-size which cannot be a pure +-- function. +-- + +instance Rotate (t u) => Rotate (ImageAns t u) where + rotate ang (Ans a p) = Ans (rotate ang a) (rotate ang p) + + +instance (RotateAbout (t u), ScalarUnit u, u ~ DUnit (t u)) => + RotateAbout (ImageAns t u) where + rotateAbout ang pt@(P2 x y) (Ans a p) = + Ans (rotateAbout ang pt a) + (rotateAbout ang (P2 (toPsPoint x) (toPsPoint y)) p) + + +instance Scale (t u) => Scale (ImageAns t u) where + scale sx sy (Ans a p) = Ans (scale sx sy a) (scale sx sy p) + + +instance (Translate (t u), ScalarUnit u, u ~ DUnit (t u)) => + Translate (ImageAns t u) where + translate dx dy (Ans a p) = + Ans (translate dx dy a) (translate (toPsPoint dx) (toPsPoint dy) p) + + +-------------------------------------------------------------------------------- + + +-- | Ignore the answer produced by an Image (or LocImage, etc.) +-- and form a Graphic instead. +-- +ignoreAns :: Functor f + => cf (ImageAns t u) -> cf (GraphicAns u) +ignoreAns = fmap (\(Ans _ prim) -> Ans UNil prim) + + + +-- | Replace the answer produced by a graphic object. +-- +-- Note - the new answer must share the same unit type as the +-- initial answer, although it does not need to have the same +-- wrapper type. +-- +replaceAns :: Functor cf + => t1 u -> cf (ImageAns t u) -> cf (ImageAns t1 u) +replaceAns ans = fmap (\(Ans _ prim) -> Ans ans prim) + + +-- | Map the answer produced by a graphic object. +-- +-- Note - the new answer must share the same unit type as the +-- initial answer, although it does not need to have the same +-- wrapper type. +-- +mapAns :: Functor cf + => (t u -> t1 u) -> cf (ImageAns t u) -> cf (ImageAns t1 u) +mapAns f = fmap (trafoImageAns f id) + + + +-- | Transform both the answer produced by a graphic object and +-- transform the primitive drawing. +-- +-- Note - the new answer must share the same unit type as the +-- initial answer, although it does not need to have the same +-- wrapper type. Also this function is specifically exposed to +-- enable affine transofrmations - it is not expected to be +-- generally useful. +-- +trafoImageAns :: (t u -> t1 u) -> (CatPrim -> CatPrim) + -> ImageAns t u -> ImageAns t1 u +trafoImageAns f g (Ans a prim) = Ans (f a) (g prim) + + +-- | Decorate an Image by superimposing a Graphic. +-- +-- Note - this function has a very general type signature and +-- supports various graphic types: +-- +-- > decorate :: Image u a -> Graphic u -> Image u a +-- > decorate :: LocImage u a -> LocGraphic u -> LocImage u a +-- > decorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a +-- +decorate :: Monad cf + => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) +decorate img gf = combind const img (const gf) + + +-- | Ante-decorate - version of 'decorate' where the decoration is +-- drawn behind the Image. +-- +adecorate :: Monad cf + => cf (ImageAns t u) -> cf (GraphicAns u) -> cf (ImageAns t u) +adecorate img gf = acombind const img (const gf) + + +-- | Version of 'elaborate' where the decorating Graphic has access +-- to the result produced by the Image. +-- +-- Again, this function has a very general type signature and +-- supports various graphic types: +-- +-- > elaborate :: Image u a -> Graphic u -> Image u a +-- > elaborate :: LocImage u a -> LocGraphic u -> LocImage u a +-- > elaborate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a +-- +elaborate :: Monad cf + => cf (ImageAns t u) + -> (t u -> cf (GraphicAns u)) + -> cf (ImageAns t u) +elaborate img gf = combind const img gf + +-- | Ante-elaborate - version of 'elaborate' where the decoration +-- is drawn behind the Image. +-- +aelaborate :: Monad cf + => cf (ImageAns t u) -> (t u -> cf (GraphicAns u)) -> cf (ImageAns t u) +aelaborate img gf = acombind const img gf + + +-- | Hyperlink a graphic object. +-- +-- This function has a very general type signature and supports +-- various graphic types: +-- +-- > hyperlink :: XLink -> Graphic u -> Graphic u +-- > hyperlink :: XLink -> Image u a -> Image u a +-- > hyperlink :: XLink -> LocImage u a -> LocImage u a +-- > hyperlink :: XLink -> LocThetaImage u a -> LocThetaImage u a +-- +hyperlink :: Functor cf + => XLink -> cf (ImageAns t u) -> cf (ImageAns t u) +hyperlink hypl = + fmap (\(Ans a prim) -> Ans a (cpmap (xlinkPrim hypl) prim)) + + +-- | Clip a graphic object. +-- +clipObject :: Functor cf + => PrimPath -> cf (ImageAns t u) -> cf (ImageAns t u) +clipObject pp = + fmap (\(Ans a prim) -> Ans a (cpmap (clip pp) prim)) + + + + +-- | This is a very general monadic combiner. +-- +-- The first argument is a pure combiner cf. @liftM2@, @liftA2@ +-- +-- The second argument is an Image to be evaluated. +-- +-- The third argument, uses the ouput from the first Image to +-- build a second Image. +-- +-- The function concatenates the CatPrims formed by both Images +-- and uses the pure combiner to build an answer from the +-- intermediate answers. +-- +-- NOTE - note useful with CF representation change. +-- +combind :: Monad cf + => (t1 u -> t2 u -> t3 u) + -> cf (ImageAns t1 u) + -> (t1 u -> cf (ImageAns t2 u)) + -> cf (ImageAns t3 u) +combind op gf fn = gf >>= \(Ans a p1) -> + fn a >>= \(Ans b p2) -> + return $ Ans (a `op` b) (p1 `oplus` p2) + + +-- | Version of combind where the drawing order is flipped. +-- +acombind :: Monad cf + => (t1 u -> t2 u -> t3 u) + -> cf (ImageAns t1 u) + -> (t1 u -> cf (ImageAns t2 u)) + -> cf (ImageAns t3 u) +acombind op gf fn = gf >>= \(Ans a p1) -> + fn a >>= \(Ans b p2) -> + return $ Ans (a `op` b) (p2 `oplus` p1) + +-} diff --git a/src/Wumpus/Basic/Kernel/Objects/Bounded.hs b/src/Wumpus/Basic/Kernel/Objects/Bounded.hs --- a/src/Wumpus/Basic/Kernel/Objects/Bounded.hs +++ b/src/Wumpus/Basic/Kernel/Objects/Bounded.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Objects.Bounded --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -14,6 +14,8 @@ -- -- Bounded meaning they are actually Images that return the -- bounding box of the Graphic. +-- +-- These abojects are type synonyms. -- -------------------------------------------------------------------------------- @@ -29,10 +31,12 @@ , BoundedLocThetaGraphic , DBoundedLocThetaGraphic + , emptyBoundedLocGraphic , emptyBoundedLocThetaGraphic , centerOrthoBBox + , illustrateBoundedGraphic , illustrateBoundedLocGraphic , illustrateBoundedLocThetaGraphic @@ -45,13 +49,14 @@ import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext import Wumpus.Basic.Kernel.Base.UpdateDC -import Wumpus.Basic.Kernel.Objects.BaseObjects +import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Basic.Kernel.Objects.DrawingPrimitives -import Wumpus.Basic.Kernel.Objects.Graphic +import Wumpus.Basic.Kernel.Objects.Image +import Wumpus.Basic.Kernel.Objects.LocImage +import Wumpus.Basic.Kernel.Objects.LocThetaImage import Wumpus.Core -- package: wumpus-core -import Control.Applicative -------------------------------------------------------------------------------- @@ -84,6 +89,9 @@ + + + -- | 'centerOrthoBBox' : @ theta * bbox -> BBox @ -- -- Rotate a bounding box by @theta@ about its center. Take the @@ -93,15 +101,13 @@ -- so the dimensions as well as the positions may change under -- rotation. -- -centerOrthoBBox :: (Real u, Floating u) + +centerOrthoBBox :: (Real u, Floating u, Ord u) => Radian -> BoundingBox u -> BoundingBox u -centerOrthoBBox theta bb = - traceBoundary $ map (rotateAbout theta ctr) ps +centerOrthoBBox theta bb = traceBoundary $ map (rotateAbout theta ctr) ps where - ps = boundaryCornerList bb ctr = boundaryCenter bb - - + ps = boundaryCornerList bb -- | 'emptyBoundedLocGraphic' : @ BoundedLocGraphic @ @@ -113,12 +119,14 @@ -- the minimum bounding box with both the bottom-left and -- upper-right corners at the implicit start point. -- -emptyBoundedLocGraphic :: Num u => BoundedLocGraphic u +emptyBoundedLocGraphic :: InterpretUnit u => BoundedLocGraphic u emptyBoundedLocGraphic = intoLocImage fn emptyLocGraphic where - fn = promoteR1 $ \pt -> pure (BBox pt pt) + fn = promoteR1 $ \pt -> return $ BBox pt pt + + -- | 'emptyBoundedLocThetaGraphic' : @ BoundedLocThetaGraphic @ -- -- Build an empty 'BoundedLocThetaGraphic'. @@ -129,40 +137,68 @@ -- upper-right corners at the implicit start point (the implicit -- inclination can be ignored). -- -emptyBoundedLocThetaGraphic :: Num u => BoundedLocThetaGraphic u -emptyBoundedLocThetaGraphic = lift1R2 emptyBoundedLocGraphic +emptyBoundedLocThetaGraphic :: InterpretUnit u => BoundedLocThetaGraphic u +emptyBoundedLocThetaGraphic = intoLocThetaImage fn emptyLocThetaGraphic + where + fn = promoteR2 $ \pt _ -> return $ BBox pt pt + +-- +-- NOTE - CONCATENATION +-- +-- Because there is no tangible relation between the start point +-- and answer BoundingBox, LocBoundedGraphic supports exactly the +-- same concatenation as LocImage. +-- +-- PosImage and AdvGraphic are the objects that support more +-- sophisticated concatenation. +-- + + + -------------------------------------------------------------------------------- -- --- This is a common pattern so needs a name... -illustrateBoundedGraphic :: Fractional u => BoundedGraphic u -> BoundedGraphic u -illustrateBoundedGraphic mf = - mf >>= \(bb,g1) -> bbrectangle bb >>= \(_,g0) -> return (bb, g0 `oplus` g1) +-- | Draw a BoundedGraphic, illustrating the bounding box. +-- +illustrateBoundedGraphic :: InterpretUnit u + => BoundedGraphic u -> BoundedGraphic u +illustrateBoundedGraphic gf = elaborateR0 gf bbrectangle -illustrateBoundedLocGraphic :: Fractional u + +-- | Draw a BoundedLocGraphic, illustrating the bounding box. +-- +illustrateBoundedLocGraphic :: InterpretUnit u => BoundedLocGraphic u -> BoundedLocGraphic u -illustrateBoundedLocGraphic mf = - promoteR1 $ \pt -> illustrateBoundedGraphic $ apply1R1 mf pt +illustrateBoundedLocGraphic gf = elaborateR1 gf fn + where + fn bb = lift0R1 (bbrectangle bb) -illustrateBoundedLocThetaGraphic :: Fractional u - => BoundedLocThetaGraphic u -> BoundedLocThetaGraphic u -illustrateBoundedLocThetaGraphic mf = - promoteR2 $ \pt theta-> illustrateBoundedGraphic $ apply2R2 mf pt theta --- -bbrectangle :: Fractional u => BoundingBox u -> Graphic u +-- | Draw a BoundedLocThetaGraphic, illustrating the bounding box. +-- +illustrateBoundedLocThetaGraphic :: InterpretUnit u + => BoundedLocThetaGraphic u + -> BoundedLocThetaGraphic u +illustrateBoundedLocThetaGraphic gf = elaborateR2 gf fn + where + fn bb = lift0R2 (bbrectangle bb) + + + + +bbrectangle :: InterpretUnit u => BoundingBox u -> Graphic u bbrectangle (BBox p1@(P2 llx lly) p2@(P2 urx ury)) | llx == urx && lly == ury = emptyLocGraphic `at` p1 | otherwise = localize drawing_props $ rect1 `oplus` cross where - drawing_props = capRound . dashPattern (Dash 0 [(1,2)]) + drawing_props = cap_round . dotted_line rect1 = strokedRectangle (urx-llx) (ury-lly) `at` p1 - cross = straightLineGraphic p1 p2 - `oplus` straightLineGraphic (P2 llx ury) (P2 urx lly) + cross = straightLine p1 p2 + `oplus` straightLine (P2 llx ury) (P2 urx lly) diff --git a/src/Wumpus/Basic/Kernel/Objects/Chain.hs b/src/Wumpus/Basic/Kernel/Objects/Chain.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Chain.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Chain +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Chaining moveable LocGraphics. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Chain + ( + ChainAlg + , IterationScheme + + , chain + , chain_ + + , linear + , prefix + , iterationScheme + + , chainIterate + , chainH + , chainV + + , tableRight + , tableDown + + , radialChain + + ) where + + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Objects.Basis +import Wumpus.Basic.Kernel.Objects.Displacement +import Wumpus.Basic.Kernel.Objects.LocImage +import Wumpus.Basic.Kernel.Objects.Image +import Wumpus.Basic.Utils.HList + +import Wumpus.Core -- package: wumpus-core + + + +-- In TikZ chains are finite node list and iterated (infite) points + + +-- | Chain algorithm. +-- +-- @Linear@ simply iterates points. +-- +-- @Prefix@ runs the left chain @n@ times then runs the right +-- chain from the end point of the left chain. +-- +data ChainAlg u = L1 (IterationScheme u) + | PX Int (ChainAlg u) (ChainAlg u) + + + + +type instance DUnit (ChainAlg u) = u + + + +data IterationScheme u = forall st. Scheme + { scheme_start :: Point2 u -> st + , scheme_step :: st -> (st, Point2 u) + } + +type instance DUnit (IterationScheme u) = u + + + + +-- | Note the tail of of result list is infinite. +-- +-- As any prefixes will be generated fully. This potentially +-- produces a /space bubble/ where a long prefix has to be +-- generated without the streaming of lazy evaluation. However, +-- chains that are long enough to cause this problem will be +-- problematic for a PostScript or SVG renderer. +-- +-- In short - don'\t make long chains. +-- +interpChainAlg :: ChainAlg u -> Point2 u -> [Point2 u] +interpChainAlg ch start = go start ch + where + go pt (L1 (Scheme mk run)) = let st = mk pt in runInf run st + go pt (PX n chl chr) = let (af,end) = takeAndLast n (go pt chl) + in prefixListH af $ go end chr + + +runInf :: (st -> (st,Point2 u)) -> st -> [Point2 u] +runInf fn = \st -> go (fn st) + where + go (st,a) = a : go (fn st) + + + + +-- | Take n elements - also return the last of element in the +-- tuple so it can be accessed without a second traversal. +-- +-- Note @(n > 0)@ +-- +takeAndLast :: Int -> [a] -> (H a,a) +takeAndLast _ [] = error "takeAndLast - empty list (unreachable?)" +takeAndLast n (a:as) = go (wrapH a,a) (n-1) as + where + go (af,_) i (x:xs) | i > 0 = go (af `snocH` x, x) (i-1) xs + go acc _ _ = acc + + + +-- | Returns the end point... +-- +chain :: InterpretUnit u + => ChainAlg u -> [LocImage u a] -> LocImage u (Point2 u) +chain _ [] = promoteR1 $ \pt -> + fmap (replaceAns pt) $ emptyLocGraphic `at` pt + +chain alg fs = promoteR1 $ \pt -> + let ps = interpChainAlg alg pt in go1 fs pt ps + where + go1 (gf:gs) _ (p:ps) = go (graphic_ $ gf `at` p) gs p ps + go1 _ p0 _ = fmap (replaceAns p0) $ emptyLocGraphic `at` p0 + + go acc (gf:gs) _ (p:ps) = let g1 = graphic_ $ gf `at` p + in go (acc `oplus` g1) gs p ps + go acc _ p0 _ = fmap (replaceAns p0) acc + + +-- | Returns no answer, just a 'LocGraphic'. +chain_ :: InterpretUnit u => ChainAlg u -> [LocImage u a] -> LocGraphic u +chain_ alg xs = locGraphic_ $ chain alg xs + + +linear :: IterationScheme u -> ChainAlg u +linear = L1 + +prefix :: Int -> ChainAlg u -> ChainAlg u -> ChainAlg u +prefix n c1 c2 | n < 1 = c2 + | otherwise = PX n c1 c2 + + +iterationScheme :: (Point2 u -> st) + -> (st -> (st, Point2 u)) + -> IterationScheme u +iterationScheme start stepper = Scheme start stepper + + + + +chainIterate :: (Point2 u -> Point2 u) -> ChainAlg u +chainIterate fn = L1 $ Scheme { scheme_start = id + , scheme_step = \pt -> (fn pt, pt) + } + + +chainH :: Num u => u -> ChainAlg u +chainH = L1 . scHorizontal + +scHorizontal :: Num u => u -> IterationScheme u +scHorizontal dx = Scheme { scheme_start = id + , scheme_step = \pt -> (displaceH dx pt, pt) + } + + + +chainV :: Num u => u -> ChainAlg u +chainV = L1 . scVertical + +scVertical :: Num u => u -> IterationScheme u +scVertical dy = Scheme { scheme_start = id + , scheme_step = \pt -> (displaceV dy pt, pt) + } + + +tableRight :: Num u => Int -> (u,u) -> ChainAlg u +tableRight num_cols (col_width,row_height) = + L1 $ scStepper downF num_cols rightF + where + downF = displaceV $ negate row_height + rightF = displaceH col_width + +tableDown :: Num u => Int -> (u,u) -> ChainAlg u +tableDown num_rows (col_width,row_height) = + L1 $ scStepper rightF num_rows downF + where + downF = displaceV $ negate row_height + rightF = displaceH col_width + + +-- | Outer and inner steppers. +-- +scStepper :: PointDisplace u -> Int -> PointDisplace u -> IterationScheme u +scStepper outF n innF = Scheme start step + where + start pt = (pt,pt,0) + step (ogin,pt,i) | i < n = ((ogin, innF pt, i+1), pt) + | otherwise = let o1 = outF ogin + in ((o1, innF o1,1), o1) + + + + +radialChain :: Floating u => u -> Radian -> Radian -> ChainAlg u +radialChain radius start step = L1 $ scCircular radius start step + + +scCircular :: Floating u => u -> Radian -> Radian -> IterationScheme u +scCircular radius angstart angseg = Scheme start step + where + start pt = (pt,angstart) + step (ogin,ang) = ((ogin,ang + angseg), displaceVec (avec ang radius) ogin) + + diff --git a/src/Wumpus/Basic/Kernel/Objects/Concat.hs b/src/Wumpus/Basic/Kernel/Objects/Concat.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Concat.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Concat +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Classes for concatenation. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Concat + ( + + ZConcat(..) + , cat + , Concat(..) + , hcat + , vcat + + , CatSpace(..) + , hsep + , vsep + + , Align(..) + , alignRow + , alignColumn + + , AlignSpace(..) + , alignRowSep + , alignColumnSep + + + ) where + +import Wumpus.Basic.Kernel.Base.BaseDefs + +import Wumpus.Core -- package: wumpus-core + +import Data.Monoid + +infixr 6 `superior`, `anterior` + +-- | Minimal defintion is 'superior', 'anterior' is usually +-- @flip superior@. +-- +-- > `superior` (infixr 6) +-- +-- > `anterior` (infixr 6) +-- +-- +class ZConcat o where + anterior :: o -> o -> o + superior :: o -> o -> o + + anterior = flip superior + + +cat :: (Monoid o, ZConcat o) => [o] -> o +cat [] = mempty +cat (x:xs) = go x xs + where + go acc [] = acc + go acc (a:as) = go (acc `superior` a) as + + + +infixr 6 `hconcat` +infixr 5 `vconcat` + + +-- | Concatenation with /movement/ - the second object is moved +-- next to the first. +-- +-- > hconcat is equivalent to @(<>)@ in WL-PPrint. +-- > (infixr 6) +-- +-- > vconcat is equivalent to @(<$>)@ in WL_PPrint. +-- > (infixr 5) +-- +class Concat o where + hconcat :: o -> o -> o + vconcat :: o -> o -> o + +-- | Horizontally concatenate a list of objects. +-- +-- Note - the first argument is an /alternative/ - this is drawn +-- if the list is empty, otherwise it is not drawn. +-- +hcat :: (Monoid o, Concat o) => [o] -> o +hcat [] = mempty +hcat (x:xs) = go x xs + where + go acc [] = acc + go acc (a:as) = go (acc `hconcat` a) as + + +-- | Vertically concatenate a list of objects. +-- +-- Note - the first argument is an /alternative/ - this is drawn +-- if the list is empty, otherwise it is not drawn. +-- +vcat :: (Monoid o, Concat o) => [o] -> o +vcat [] = mempty +vcat (x:xs) = go x xs + where + go acc [] = acc + go acc (a:as) = go (acc `vconcat` a) as + + +class CatSpace o where + hspace :: u ~ DUnit o => u -> o -> o -> o + vspace :: u ~ DUnit o => u -> o -> o -> o + +hsep :: (Monoid o, CatSpace o, u ~ DUnit o) => u -> [o] -> o +hsep _ [] = mempty +hsep dx (x:xs) = go x xs + where + op = hspace dx + go acc [] = acc + go acc (a:as) = go (acc `op` a) as + + +vsep :: (Monoid o, CatSpace o, u ~ DUnit o) => u -> [o] -> o +vsep _ [] = mempty +vsep dx (x:xs) = go x xs + where + op = vspace dx + go acc [] = acc + go acc (a:as) = go (acc `op` a) as + + +class Align o where + halign :: HAlign -> o -> o -> o + valign :: VAlign -> o -> o -> o + + +alignRow :: (Monoid o, Align o) => HAlign -> [o] -> o +alignRow _ [] = mempty +alignRow ha (x:xs) = go x xs + where + op = halign ha + go acc [] = acc + go acc (a:as) = go (acc `op` a) as + + +alignColumn :: (Monoid o, Align o) => VAlign -> [o] -> o +alignColumn _ [] = mempty +alignColumn va (x:xs) = go x xs + where + op = valign va + go acc [] = acc + go acc (a:as) = go (acc `op` a) as + + + +class AlignSpace o where + halignSpace :: u ~ DUnit o => HAlign -> u -> o -> o -> o + valignSpace :: u ~ DUnit o => VAlign -> u -> o -> o -> o + + + +alignRowSep :: (Monoid o, AlignSpace o, u ~ DUnit o) + => HAlign -> u -> [o] -> o +alignRowSep _ _ [] = mempty +alignRowSep ha dx (x:xs) = go x xs + where + op = halignSpace ha dx + go acc [] = acc + go acc (a:as) = go (acc `op` a) as + + +alignColumnSep :: (Monoid o, AlignSpace o, u ~ DUnit o) + => VAlign -> u -> [o] -> o +alignColumnSep _ _ [] = mempty +alignColumnSep va dx (x:xs) = go x xs + where + op = valignSpace va dx + go acc [] = acc + go acc (a:as) = go (acc `op` a) as + + diff --git a/src/Wumpus/Basic/Kernel/Objects/Connector.hs b/src/Wumpus/Basic/Kernel/Objects/Connector.hs --- a/src/Wumpus/Basic/Kernel/Objects/Connector.hs +++ b/src/Wumpus/Basic/Kernel/Objects/Connector.hs @@ -1,99 +1,95 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Objects.Connector --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com -- Stability : highly unstable -- Portability : GHC -- --- Graphic and Image types representing connectors - connectors --- have two implicit points - start and end. +-- ConnImage and ConnGraphic types - these are functional types +-- from the DrawingContext plus start point and end point to a +-- graphic /primitive/. -- -------------------------------------------------------------------------------- module Wumpus.Basic.Kernel.Objects.Connector - ( + ( + ConnectorImage + , ConnectorGraphic - -- * Connector Graphic - ConnectorGraphic - , DConnectorGraphic + , DConnectorImage + , DConnectorGraphic + , intoConnectorImage + , connectorGraphic_ - -- * Connector Image - , ConnectorImage - , DConnectorImage + , emptyConnectorGraphic - , intoConnectorImage - , emptyConnectorGraphic + , uconvConnectorImageF + , uconvConnectorImageZ - ) where + ) + where + import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.ContextFun -import Wumpus.Basic.Kernel.Objects.BaseObjects -import Wumpus.Basic.Kernel.Objects.Graphic +import Wumpus.Basic.Kernel.Objects.Basis +import Wumpus.Basic.Kernel.Objects.LocImage --- import Wumpus.Core -- package: wumpus-core import Control.Applicative --------------------------------------------------------------------------------- --- Connector Graphic - --- | ConnectorGraphic is a connector drawn between two points --- contructing a Graphic. --- -type ConnectorGraphic u = ConnectorCF u (GraphicAns u) - --- | Alias of 'ConnectorGraphic' where the unit type is --- specialized to Double. +-- | ConnectorImage - function from DrawingContext and start and +-- end points to a polymorphic /answer/ and a graphic /primitive/. -- -type DConnectorGraphic = ConnectorGraphic Double - - +type ConnectorImage u a = ConnectorQuery u (ImageAns u a) --------------------------------------------------------------------------------- --- Connector Image +-- | ConnectorGraphic - function from DrawingContext and start and +-- end points to a graphic /primitive/. +-- +type ConnectorGraphic u = ConnectorQuery u (GraphicAns u) --- | ConnectorImage is a connector drawn between two points --- constructing an Image. --- --- Usually the answer type of a ConnectorImage will be a Path --- (defined in Wumpus-Drawing) so the points at @midway@, --- @atstart@ etc. or the end directions and tangents can be taken --- on it. +-- | Type specialized version of 'ConnectorImage'. -- -type ConnectorImage u a = ConnectorCF u (ImageAns u a) - +type DConnectorImage a = ConnectorImage Double a --- | Alias of 'ConnectorImage' where the unit type is --- specialized to Double. +-- | Type specialized version of 'ConnectorGraphic'. -- -type DConnectorImage a = ConnectorImage Double a +type DConnectorGraphic = ConnectorGraphic Double --- | 'intoConnectorImage' : @ conn_context_function * conn_graphic -> LocImage @ +-- | 'intoConnectorImage' : @ conn_query * conn_graphic -> LocImage @ -- -- /Connector/ version of 'intoImage'. -- -- The 'ConnectorImage' is built as a function from an implicit -- start and end points to the answer. -- -intoConnectorImage :: ConnectorCF u a -> ConnectorGraphic u +intoConnectorImage :: ConnectorQuery u a + -> ConnectorGraphic u -> ConnectorImage u a -intoConnectorImage = liftA2 (\a (_,b) -> (a,b)) +intoConnectorImage qf ma = + promoteR2 $ \a b -> replaceAns <$> apply2R2 qf a b <*> apply2R2 ma a b +-- | /Downcast/ an 'ConnectorImage' to a 'ConnectorGraphic'. +-- +-- This means forgetting the answer of the Image, replacing it +-- with @()@. +-- +connectorGraphic_ :: ConnectorImage u a -> ConnectorGraphic u +connectorGraphic_ = (fmap . fmap . fmap) ignoreAns + + -- | 'emptyConnectorGraphic' : @ ConnectorGraphic @ -- -- Build an empty 'ConnectorGraphic'. @@ -103,10 +99,41 @@ -- bounding box around the rectangular hull of the start and end -- points. -- -emptyConnectorGraphic :: Num u => ConnectorGraphic u +emptyConnectorGraphic :: InterpretUnit u => ConnectorGraphic u emptyConnectorGraphic = promoteR2 $ \start end -> let a = emptyLocGraphic `at` start b = emptyLocGraphic `at` end in a `oplus` b + + + +-- | Use this to convert 'ConnectorGraphic' or 'ConnectorImage' +-- with Functor answer. +-- +uconvConnectorImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) + => ConnectorImage u (t u) -> ConnectorImage u1 (t u1) +uconvConnectorImageF = uconvR2ab szconvAnsF + + + +-- | Use this to convert 'ConnectorImage' with unit-less answer. +-- +uconvConnectorImageZ :: (InterpretUnit u, InterpretUnit u1) + => ConnectorImage u a -> ConnectorImage u1 a +uconvConnectorImageZ = uconvR2ab szconvAnsZ + + +-------------------------------------------------------------------------------- + + +-- +-- Design note - potentially there are no useful combining +-- operators on Connectors (!). +-- +-- Division - i.e. splitting a path at points between the start +-- and end - seems a more obvious operation on connector paths +-- than combination. See the ConnectorPath operations in +-- Wumpus-Drawing for some examples. +-- diff --git a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs --- a/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs +++ b/src/Wumpus/Basic/Kernel/Objects/CtxPicture.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- @@ -31,50 +32,25 @@ ( CtxPicture - , DCtxPicture , runCtxPicture , runCtxPictureU , drawTracing + , udrawTracing - , clipCtxPicture , mapCtxPicture -- * Composition - , cxpBeneath - , cxpUniteCenter - , cxpRight - , cxpDown + , uniteCenter - , cxpCenteredAt - - - , cxpRow - , cxpColumn - - - , cxpRightSep - , cxpDownSep - , cxpRowSep - , cxpColumnSep - - -- * Compose with alignment - , cxpAlignH - , cxpAlignV - , cxpAlignSepH - , cxpAlignSepV - , cxpAlignRow - , cxpAlignColumn - , cxpAlignRowSep - , cxpAlignColumnSep - + , centeredAt ) where -import Wumpus.Basic.Kernel.Base.Anchors import Wumpus.Basic.Kernel.Base.BaseDefs -import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Objects.Anchors +import Wumpus.Basic.Kernel.Objects.Concat import Wumpus.Basic.Kernel.Objects.TraceDrawing import Wumpus.Core -- package: wumpus-core @@ -82,45 +58,45 @@ import Data.AdditiveGroup -- package: vector-space import Data.AffineSpace -import Control.Applicative -import Data.List ( foldl' ) +import Data.Monoid --- Note - PosGraphic should take priority for the good names. --- | A /Contextual Picture/. +-- | A /Contextual/ Picture. -- +-- > CtxPicture = DrawingContext -> Maybe Picture +-- -- This type corresponds to the 'Picture' type in Wumpus-Core, but -- it is embedded with a 'DrawingContext' (for font properties, --- fill colour etc.). So it is a function --- /from DrawingContext to Picture/. --- --- Internally the result is actually a (Maybe Picture) and not a --- Picture, this is a trick to promote the extraction from --- possibly empty drawings (created by TraceDrawing) to the --- top-level of the type hierarchy where client code can deal --- with empty drawings explicitly (empty Pictures cannot be --- rendered by Wumpus-Core). +-- fill colour etc.). The DrawingContext is embedded so that font +-- metrics - loaded in @IO@ can be passed into the pure world of +-- 'TraceDrawing'. -- --- > a `oplus` b +-- Internally a /context picture/ is a function from +-- 'DrawingContext' to @(Maybe Picture)@. The @Maybe@ represents +-- that it is possible to construct empty Pictures, even though +-- @Wumpus-Core@ cannot render them. Just as the DrawingContext +-- pushes font-metrics from the IO to the pure world, the Maybe +-- lifts the problem of unrenderable Pictures into the API where +-- client code must deal with it explicitly. -- --- The 'OPlus' (semigroup) instance for 'CtxPicture' draws picture --- a in front of picture b in the z-order, neither picture is --- moved. (Usually the picture composition operators in this --- module move the second picture aligning it somehow with the --- first). +-- (In practice, it is very unlikely a program will create empty +-- pictures and @runCtxPictureU@ can be used without worry). +-- +-- +-- Note - pictures are fixed to the unit @Double@ (representing +-- PostScript points). Pictures are intentionally unsophisticated, +-- any fine grained control of units should be delegated to the +-- elements that build the picture (Graphics, LocGraphics, etc.). -- -newtype CtxPicture u = CtxPicture { getCtxPicture :: CF (Maybe (Picture u)) } +newtype CtxPicture = CtxPicture { + getCtxPicture :: DrawingContext -> Maybe Picture } --- | Version of CtxPicture specialized to Double for the unit type. --- -type DCtxPicture = CtxPicture Double +type instance DUnit CtxPicture = Double -type instance DUnit (CtxPicture u) = u - -- | 'runCtxPicture' : @ drawing_ctx * ctx_picture -> Maybe Picture @ -- -- Run a 'CtxPicture' with the supplied 'DrawingContext' @@ -131,9 +107,10 @@ -- result is wrapped within a Maybe. This delegates reponsibility -- for handling empty pictures to client code. -- -runCtxPicture :: DrawingContext -> CtxPicture u -> Maybe (Picture u) -runCtxPicture ctx drw = runCF ctx (getCtxPicture drw) +runCtxPicture :: DrawingContext -> CtxPicture -> Maybe Picture +runCtxPicture ctx drw = getCtxPicture drw ctx + -- | 'runCtxPictureU' : @ drawing_ctx * ctx_picture -> Picture @ -- -- /Unsafe/ version of 'runCtxPicture'. @@ -141,7 +118,7 @@ -- This function throws a runtime error when supplied with an -- empty CtxPicture. -- -runCtxPictureU :: DrawingContext -> CtxPicture u -> Picture u +runCtxPictureU :: DrawingContext -> CtxPicture -> Picture runCtxPictureU ctx df = maybe fk id $ runCtxPicture ctx df where fk = error "runCtxPictureU - empty CtxPicture." @@ -151,139 +128,76 @@ -- -- Transform a 'TraceDrawing' into a 'CtxPicture'. -- -drawTracing :: (Real u, Floating u, FromPtSize u) - => TraceDrawing u a -> CtxPicture u -drawTracing mf = CtxPicture $ - drawingCtx >>= \ctx -> return (liftToPictureMb $ execTraceDrawing ctx mf) - +drawTracing :: TraceDrawing u a -> CtxPicture +drawTracing mf = + CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx mf --- Note - cannot get an answer from a TraceDrawing with this --- CtxPicture type. There is nowhere to put the answer in the type. +-- | 'udrawTracing' : @ scalar_unit_value * trace_drawing -> CtxPicture @ -- --- If the type was extended: +-- Variant of 'drawTracing' with a phantom first argument - the +-- phantom identifies the unit type of the 'TraceDrawing'. It is +-- not scurtinized at the value level. -- --- > newtype CtxPicture u a = CtxPicture { getCtxPicture :: CF (a, Maybe (Picture u))) } -- --- It would make things difficult for the drawing composition --- operators. @a@ could be monoidial but are there any types of --- a where this would be useful (rather than just making things --- more complicated)? --- +udrawTracing :: u -> TraceDrawing u a -> CtxPicture +udrawTracing _ mf = + CtxPicture $ \ctx -> liftToPictureMb $ execTraceDrawing ctx mf --- | 'clipCtxPicture' : @ path * ctx_picture -> CtxPicture @ --- --- Clip a picture with a path. --- -clipCtxPicture :: (Num u, Ord u) => PrimPath u -> CtxPicture u -> CtxPicture u -clipCtxPicture cpath = mapCtxPicture (clip cpath) --- Note - it seems preferable to clip a smaller type in the --- hierarchy than CtxPicture. But which one Graphic, TraceDrawing? --- ... --- + -- | 'mapCtxPicture' : @ trafo * ctx_picture -> CtxPicture @ -- -- Apply a picture transformation function to the 'Picture' -- warpped in a 'CtxPicture'. -- -mapCtxPicture :: (Picture u -> Picture u) -> CtxPicture u -> CtxPicture u -mapCtxPicture pf = CtxPicture . fmap (fmap pf) . getCtxPicture +mapCtxPicture :: (Picture -> Picture) -> CtxPicture -> CtxPicture +mapCtxPicture pf pic1 = CtxPicture $ \ctx -> fmap pf $ getCtxPicture pic1 ctx -------------------------------------------------------------------------------- - - +-- Affine instances -instance (Real u, Floating u) => Rotate (CtxPicture u) where - rotate ang = mapCtxPicture (rotate ang) +instance Rotate CtxPicture where + rotate ang = mapCtxPicture (rotate ang) -instance (Real u, Floating u) => RotateAbout (CtxPicture u) where - rotateAbout r pt = mapCtxPicture (rotateAbout r pt) +instance RotateAbout CtxPicture where + rotateAbout ang pt = mapCtxPicture (rotateAbout ang pt) -instance (Num u, Ord u) => Scale (CtxPicture u) where - scale sx sy = mapCtxPicture (scale sx sy) +instance Scale CtxPicture where + scale sx sy = mapCtxPicture (scale sx sy) -instance (Num u, Ord u) => Translate (CtxPicture u) where - translate dx dy = mapCtxPicture (translate dx dy) +instance Translate CtxPicture where + translate dx dy = mapCtxPicture (translate dx dy) -------------------------------------------------------------------------------- - - --------------------------------------------------------------------------------- --- Extract anchors - -boundaryExtr :: (BoundingBox u -> a) -> Picture u -> a -boundaryExtr f = f . boundary - --- Operations on bounds - --- | The center of a picture. --- -boundaryCtr :: Fractional u => Picture u -> Point2 u -boundaryCtr = boundaryExtr center - - - --- | Extract the mid point of the top edge. --- -boundaryN :: Fractional u => Picture u -> Point2 u -boundaryN = boundaryExtr north - --- | Extract the mid point of the bottom edge. --- -boundaryS :: Fractional u => Picture u -> Point2 u -boundaryS = boundaryExtr south - --- | Extract the mid point of the left edge. --- -boundaryE :: Fractional u => Picture u -> Point2 u -boundaryE = boundaryExtr east +-- Monoid --- | Extract the mid point of the right edge. --- -boundaryW :: Fractional u => Picture u -> Point2 u -boundaryW = boundaryExtr west +instance Monoid CtxPicture where + mempty = CtxPicture $ \_ -> Nothing + mappend = moveSnd $ \_ _ -> V2 0 0 --- | Extract the top-left corner. --- -boundaryNW :: Fractional u => Picture u -> Point2 u -boundaryNW = boundaryExtr northwest - --- | Extract the top-right corner. --- -boundaryNE :: Picture u -> Point2 u -boundaryNE = boundaryExtr ur_corner - --- | Extract the bottom-left corner. --- -boundarySW :: Picture u -> Point2 u -boundarySW = boundaryExtr ll_corner - --- | Extract the bottom-right corner. --- -boundarySE :: Fractional u => Picture u -> Point2 u -boundarySE = boundaryExtr southeast +-------------------------------------------------------------------------------- +-- Extract /planes/. -boundaryLeftEdge :: Picture u -> u -boundaryLeftEdge = boundaryExtr (point_x . ll_corner) +leftEdge :: BoundingBox Double -> Double +leftEdge = point_x . ll_corner -boundaryRightEdge :: Picture u -> u -boundaryRightEdge = boundaryExtr (point_x . ur_corner) +rightEdge :: BoundingBox Double -> Double +rightEdge = point_x . ur_corner -boundaryBottomEdge :: Picture u -> u -boundaryBottomEdge = boundaryExtr (point_y . ll_corner) +bottomEdge :: BoundingBox Double -> Double +bottomEdge = point_y . ll_corner -boundaryTopEdge :: Picture u -> u -boundaryTopEdge = boundaryExtr (point_y . ur_corner) - +topEdge :: BoundingBox Double -> Double +topEdge = point_y . ur_corner @@ -302,14 +216,12 @@ -- ambiguous as when used as binary operators). -- -cxpConcat :: (Picture u -> Picture u -> Picture u) - -> CtxPicture u -> CtxPicture u -> CtxPicture u -cxpConcat op a b = CtxPicture $ mbpostcomb op (getCtxPicture a) (getCtxPicture b) - -mbpostcomb :: (a -> a -> a) -> CF (Maybe a) -> CF (Maybe a) -> CF (Maybe a) -mbpostcomb op = liftA2 fn +combineP2 :: (Picture -> Picture -> Picture) + -> CtxPicture -> CtxPicture -> CtxPicture +combineP2 op mf mg = + CtxPicture $ \ctx -> fn (getCtxPicture mf ctx) (getCtxPicture mg ctx) where fn (Just a) (Just b) = Just $ a `op` b fn a Nothing = a @@ -327,95 +239,81 @@ -- --- Picture /mega-combiner/ - moves only the second argument aka the --- right picture. --- -megaCombR :: (Num u, Ord u) - => (Picture u -> a) -> (Picture u -> a) - -> (a -> a -> Picture u -> Picture u) - -> CtxPicture u -> CtxPicture u - -> CtxPicture u -megaCombR qL qR trafoR = cxpConcat fn +moveSnd :: (DBoundingBox -> DBoundingBox -> DVec2) + -> CtxPicture -> CtxPicture + -> CtxPicture +moveSnd mkV = combineP2 fn where - fn pic1 pic2 = let a = qL pic1 - b = qR pic2 - p2 = trafoR a b pic2 - in pic1 `picOver` p2 + fn pl pr = let v1 = mkV (boundary pl) (boundary pr) + in pl `picOver` (picMoveBy pr v1) + + + -- | > a `oplus` b -- -- Place \'drawing\' a over b. The idea of @over@ here is in -- terms z-ordering, nither picture a or b are actually moved. -- -instance (Num u, Ord u) => OPlus (CtxPicture u) where - oplus = cxpConcat picOver +instance OPlus CtxPicture where + oplus = moveSnd $ \_ _ -> V2 0 0 --- | 'cxpBeneath' : @ ctx_picture1 * ctx_picture2 -> CtxPicture @ --- --- > a `cxpBeneath` b --- --- Similarly @beneath@ draws the first picture behind the second --- picture in the z-order, neither picture is moved. --- -cxpBeneath :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u -cxpBeneath = flip oplus +instance ZConcat CtxPicture where + superior = oplus + anterior = flip oplus -------------------------------------------------------------------------------- -- Composition -infixr 5 `cxpDown` -infixr 6 `cxpRight`, `cxpUniteCenter` +infixr 6 `uniteCenter` + -- | Draw @a@, move @b@ so its center is at the same center as -- @a@, @b@ is drawn over underneath in the zorder. -- -- > a `cxpUniteCenter` b -- -cxpUniteCenter :: (Fractional u, Ord u) - => CtxPicture u -> CtxPicture u -> CtxPicture u -cxpUniteCenter = megaCombR boundaryCtr boundaryCtr moveFun - where - moveFun p1 p2 pic = let v = p1 .-. p2 in pic `picMoveBy` v - +uniteCenter :: CtxPicture -> CtxPicture -> CtxPicture +uniteCenter = moveSnd $ \a b -> center a .-. center b -- -- Are combinator names less ambiguous if they name direction -- rather than position? -- +instance Concat CtxPicture where + hconcat = cxpRight + vconcat = cxpBelow + + -- | > a `cxpRight` b -- -- Horizontal composition - position picture @b@ to the right of -- picture @a@. -- -cxpRight :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u -cxpRight = megaCombR boundaryRightEdge boundaryLeftEdge moveFun - where - moveFun a b pic = pic `picMoveBy` hvec (a - b) - +cxpRight :: CtxPicture -> CtxPicture -> CtxPicture +cxpRight = moveSnd $ \a b -> hvec $ rightEdge a - leftEdge b --- | > a `cxpDown` b +-- | > a `cxpBelow` b -- -- Vertical composition - position picture @b@ /down/ from picture -- @a@. -- -cxpDown :: (Num u, Ord u) => CtxPicture u -> CtxPicture u -> CtxPicture u -cxpDown = megaCombR boundaryBottomEdge boundaryTopEdge moveFun - where - moveFun a b drw = drw `picMoveBy` vvec (a - b) +cxpBelow :: CtxPicture -> CtxPicture -> CtxPicture +cxpBelow = moveSnd $ \a b -> vvec $ bottomEdge a - topEdge b -- | Center the picture at the supplied point. -- -cxpCenteredAt :: (Fractional u, Ord u) => CtxPicture u -> Point2 u -> CtxPicture u -cxpCenteredAt d (P2 x y) = mapCtxPicture fn d +centeredAt :: CtxPicture -> DPoint2 -> CtxPicture +centeredAt pic (P2 x y) = mapCtxPicture fn pic where fn p = let bb = boundary p dx = x - (boundaryWidth bb * 0.5) @@ -424,37 +322,12 @@ --- | 'cxpRow' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @ --- --- Make a row of pictures concatenating them horizontally. --- --- Note - this function is in /destructor form/. As Wumpus cannot --- make a Picture from an empty list of Pictures, --- /destructor form/ decomposes the list into the @head@ and the --- @rest@ in the function signature, rather than take a possibly --- empty list and have to throw an error. --- -cxpRow :: (Real u, Floating u, FromPtSize u) - => CtxPicture u -> [CtxPicture u] -> CtxPicture u -cxpRow = foldl' cxpRight - --- | 'cxpColumn' : @ ctx_picture1 * [ctx_picture] -> CtxPicture @ --- --- Make a column of pictures concatenating them vertically. --- --- Note - this function is in /destructor form/. --- -cxpColumn :: (Real u, Floating u, FromPtSize u) - => CtxPicture u -> [CtxPicture u] -> CtxPicture u -cxpColumn = foldl' cxpDown - - - - -------------------------------------------------------------------------------- - +instance CatSpace CtxPicture where + hspace = cxpRightSep + vspace = cxpDownSep -- | > cxpRightSep n a b @@ -462,12 +335,8 @@ -- Horizontal composition - move @b@, placing it to the right -- of @a@ with a horizontal gap of @n@ separating the pictures. -- -cxpRightSep :: (Num u, Ord u) => u -> CtxPicture u -> CtxPicture u -> CtxPicture u -cxpRightSep n = megaCombR boundaryRightEdge boundaryLeftEdge moveFun - where - moveFun a b pic = pic `picMoveBy` hvec (n + a - b) - - +cxpRightSep :: Double -> CtxPicture -> CtxPicture -> CtxPicture +cxpRightSep n = moveSnd $ \a b -> hvec $ n + (rightEdge a - leftEdge b) @@ -476,58 +345,27 @@ -- Vertical composition - move @b@, placing it below @a@ with a -- vertical gap of @n@ separating the pictures. -- -cxpDownSep :: (Num u, Ord u) - => u -> CtxPicture u -> CtxPicture u -> CtxPicture u -cxpDownSep n = megaCombR boundaryBottomEdge boundaryTopEdge moveFun - where - moveFun a b pic = pic `picMoveBy` vvec (a - b - n) - - - --- | > picRowSep n x xs --- --- Concatenate the list of pictures @xs@ horizontally with --- @hspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units. --- -cxpRowSep :: (Real u, Floating u, FromPtSize u) - => u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u -cxpRowSep n = foldl' (cxpRightSep n) - - - --- | > vsepPic n xs --- --- Concatenate the list of pictures @xs@ vertically with --- @vspace@ starting at @x@. The pictures are interspersed with --- spaces of @n@ units. --- -cxpColumnSep :: (Real u, Floating u, FromPtSize u) - => u -> CtxPicture u -> [CtxPicture u] -> CtxPicture u -cxpColumnSep n = foldl' (cxpDownSep n) +cxpDownSep :: Double -> CtxPicture -> CtxPicture -> CtxPicture +cxpDownSep n = moveSnd $ \a b -> vvec $ bottomEdge a - (topEdge b + n) -------------------------------------------------------------------------------- -- Aligning pictures -alignMove :: (Num u, Ord u) => Point2 u -> Point2 u -> Picture u -> Picture u -alignMove p1 p2 pic = pic `picMoveBy` (p1 .-. p2) - --- Note - these don\'t conform to the naming convention, but using --- /Right/ in the names would be confusing with alignment. - +instance Align CtxPicture where + halign = cxpAlignH + valign = cxpAlignV -- | > cxpAlignH align a b -- -- Horizontal composition - move @b@, placing it to the right -- of @a@ and align it with the top, center or bottom of @a@. -- -cxpAlignH :: (Fractional u, Ord u) - => HAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u -cxpAlignH HTop = megaCombR boundaryNE boundaryNW alignMove -cxpAlignH HCenter = megaCombR boundaryE boundaryW alignMove -cxpAlignH HBottom = megaCombR boundarySE boundarySW alignMove +cxpAlignH :: HAlign -> CtxPicture -> CtxPicture -> CtxPicture +cxpAlignH HTop = moveSnd $ \a b -> northeast a .-. northwest b +cxpAlignH HCenter = moveSnd $ \a b -> east a .-. west b +cxpAlignH HBottom = moveSnd $ \a b -> southeast a .-. southwest b -- | > cxpAlignV align a b @@ -535,81 +373,41 @@ -- Vertical composition - move @b@, placing it below @a@ -- and align it with the left, center or right of @a@. -- -cxpAlignV :: (Fractional u, Ord u) - => VAlign -> CtxPicture u -> CtxPicture u -> CtxPicture u -cxpAlignV VLeft = megaCombR boundarySW boundaryNW alignMove -cxpAlignV VCenter = megaCombR boundaryS boundaryN alignMove -cxpAlignV VRight = megaCombR boundarySE boundaryNE alignMove +cxpAlignV :: VAlign -> CtxPicture -> CtxPicture -> CtxPicture +cxpAlignV VLeft = moveSnd $ \a b -> southwest a .-. northwest b +cxpAlignV VCenter = moveSnd $ \a b -> south a .-. north b +cxpAlignV VRight = moveSnd $ \a b -> southeast a .-. northeast b -alignMove2 :: (Num u, Ord u) - => Vec2 u -> Point2 u -> Point2 u -> Picture u -> Picture u -alignMove2 v p1 p2 pic = pic `picMoveBy` (v ^+^ (p1 .-. p2)) - - +instance AlignSpace CtxPicture where + halignSpace = cxpAlignSpaceH + valignSpace = cxpAlignSpaceV --- | > cxpAlignSepH align sep a b +-- | > cxpAlignSpaceH align sep a b -- -- Spacing version of 'cxpAlignH' - move @b@ to the right of @a@ -- separated by @sep@ units, align @b@ according to @align@. -- -cxpAlignSepH :: (Fractional u, Ord u) - => HAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u -cxpAlignSepH align dx = go align +cxpAlignSpaceH :: HAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture +cxpAlignSpaceH align dx = go align where - go HTop = megaCombR boundaryNE boundaryNW (alignMove2 (hvec dx)) - go HCenter = megaCombR boundaryE boundaryW (alignMove2 (hvec dx)) - go HBottom = megaCombR boundarySE boundarySW (alignMove2 (hvec dx)) + mv f g = moveSnd $ \a b -> hvec dx ^+^ (f a .-. g b) + go HTop = mv northeast northwest + go HCenter = mv east west + go HBottom = mv southeast southwest --- | > cxpAlignSepV align sep a b +-- | > cxpAlignSpaceV align sep a b -- -- Spacing version of alignV - move @b@ below @a@ -- separated by @sep@ units, align @b@ according to @align@. -- -cxpAlignSepV :: (Fractional u, Ord u) - => VAlign -> u -> CtxPicture u -> CtxPicture u -> CtxPicture u -cxpAlignSepV align dy = go align +cxpAlignSpaceV :: VAlign -> Double -> CtxPicture -> CtxPicture -> CtxPicture +cxpAlignSpaceV align dy = go align where - go VLeft = megaCombR boundarySW boundaryNW (alignMove2 $ vvec (-dy)) - go VCenter = megaCombR boundaryS boundaryN (alignMove2 $ vvec (-dy)) - go VRight = megaCombR boundarySE boundaryNE (alignMove2 $ vvec (-dy)) - - --- | Variant of 'cxpRow' that aligns the pictures as well as --- concatenating them. --- -cxpAlignRow :: (Real u, Floating u, FromPtSize u) - => HAlign -> CtxPicture u-> [CtxPicture u] -> CtxPicture u -cxpAlignRow ha = foldl' (cxpAlignH ha) - - - --- | Variant of 'cxpColumn' that aligns the pictures as well as --- concatenating them. --- -cxpAlignColumn :: (Real u, Floating u, FromPtSize u) - => VAlign -> CtxPicture u -> [CtxPicture u] -> CtxPicture u -cxpAlignColumn va = foldl' (cxpAlignV va) - - --- | Variant of 'cxpRow' that aligns the pictures as well as --- concatenating and spacing them. --- -cxpAlignRowSep :: (Real u, Floating u, FromPtSize u) - => HAlign -> u -> CtxPicture u -> [CtxPicture u] - -> CtxPicture u -cxpAlignRowSep ha n = foldl' (cxpAlignSepH ha n) - - --- | Variant of 'cxpColumn' that aligns the pictures as well as --- concatenating and spacing them. --- -cxpAlignColumnSep :: (Real u, Floating u, FromPtSize u) - => VAlign -> u -> CtxPicture u -> [CtxPicture u] - -> CtxPicture u -cxpAlignColumnSep va n = foldl' (cxpAlignSepV va n) - - + mv f g = moveSnd $ \a b -> vvec (-dy) ^+^ (f a .-. g b) + go VLeft = mv southwest northwest + go VCenter = mv south north + go VRight = mv southeast northeast diff --git a/src/Wumpus/Basic/Kernel/Objects/Displacement.hs b/src/Wumpus/Basic/Kernel/Objects/Displacement.hs --- a/src/Wumpus/Basic/Kernel/Objects/Displacement.hs +++ b/src/Wumpus/Basic/Kernel/Objects/Displacement.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Objects.Displacement --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -17,8 +19,6 @@ module Wumpus.Basic.Kernel.Objects.Displacement ( - - -- * Moving points and angles PointDisplace , ThetaDisplace , ThetaPointDisplace @@ -27,42 +27,65 @@ , moveStart , moveStartTheta , moveStartThetaPoint - , moveStartThetaAngle + , moveStartThetaIncl , displace , displaceVec , displaceH , displaceV - , northwards - , southwards - , eastwards - , westwards + , disp_up + , disp_down + , disp_left + , disp_right - , northeastwards - , northwestwards - , southeastwards - , southwestwards + , disp_up_left + , disp_up_right + , disp_down_left + , disp_down_right + + , disp_north + , disp_south + , disp_east + , disp_west + , disp_northeast + , disp_northwest + , disp_southeast + , disp_southwest + + , displaceParallel , displacePerpendicular , displaceOrtho - , thetaNorthwards - , thetaSouthwards - , thetaEastwards - , thetaWestwards + , adisp_north + , adisp_south + , adisp_east + , adisp_west - , thetaNortheastwards - , thetaNorthwestwards - , thetaSoutheastwards - , thetaSouthwestwards + , adisp_northeast + , adisp_northwest + , adisp_southeast + , adisp_southwest + , centerRelative + , left_of + , right_of + , above_left_of + , above_right_of + , below_left_of + , below_right_of + ) where +import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.QueryDC +import Wumpus.Basic.Kernel.Objects.Anchors +import Wumpus.Basic.Kernel.Objects.Basis import Wumpus.Core -- package: wumpus-core @@ -70,8 +93,6 @@ --------------------------------------------------------------------------------- --- Displacing points -- | 'PointDisplace' is a type representing functions -- @from Point to Point@. @@ -83,6 +104,8 @@ type PointDisplace u = Point2 u -> Point2 u + + -- | 'ThetaDisplace' is a type representing functions -- @from Radian to Radian@. -- @@ -100,39 +123,44 @@ -- with an implicit angle representing the direction of the line -- at the arrow tip. -- -type ThetaPointDisplace u = Radian -> PointDisplace u +type ThetaPointDisplace u = Radian -> Point2 u -> Point2 u +-------------------------------------------------------------------------------- +-- Displacing points and inclination --- | Move the start-point of a 'LocCF' with the supplied + + +-- | Move the start-point of a 'LocQuery' with the supplied -- displacement function. -- -moveStart :: PointDisplace u -> LocCF u a -> LocCF u a -moveStart f ma = promoteR1 $ \pt -> apply1R1 ma (f pt) +moveStart :: PointDisplace u -> LocQuery u a -> LocQuery u a +moveStart f ma = domMap1 f ma --- | Move the start-point of a 'LocThetaCF' with the supplied +-- | Move the start-point of a 'LocThetaQuery' with the supplied -- displacement function. -- -moveStartTheta :: ThetaPointDisplace u -> LocThetaCF u a -> LocThetaCF u a -moveStartTheta f ma = promoteR2 $ \pt theta -> let p2 = f theta pt - in apply2R2 ma p2 theta +moveStartTheta :: ThetaPointDisplace u + -> LocThetaQuery u a -> LocThetaQuery u a +moveStartTheta f cf = consCF $ \ctx -> + (\pt ang -> let f1 = runCF ctx cf in f1 (f ang pt) ang) -- | Move the start-point of a 'LocThetaCF' with the supplied -- displacement function. -- -moveStartThetaPoint :: PointDisplace u -> LocThetaCF u a -> LocThetaCF u a -moveStartThetaPoint f ma = promoteR2 $ \pt theta -> apply2R2 ma (f pt) theta +moveStartThetaPoint :: PointDisplace u + -> LocThetaQuery u a -> LocThetaQuery u a +moveStartThetaPoint f = domMap2 f id -- | Change the inclination of a 'LocThetaCF' with the supplied -- displacement function. -- -moveStartThetaAngle :: ThetaDisplace -> LocThetaCF u a -> LocThetaCF u a -moveStartThetaAngle f ma = promoteR2 $ \pt theta -> apply2R2 ma pt (f theta) - +moveStartThetaIncl :: ThetaDisplace -> LocThetaQuery u a -> LocThetaQuery u a +moveStartThetaIncl f = domMap2 id f -------------------------------------------------------------------------------- @@ -173,36 +201,71 @@ displaceV dy (P2 x y) = P2 x (y+dy) --- Cardinal displacement +disp_up :: Num u => u -> PointDisplace u +disp_up = displaceV -northwards :: Num u => u -> PointDisplace u -northwards = displaceV +disp_down :: Num u => u -> PointDisplace u +disp_down = displaceV . negate +disp_left :: Num u => u -> PointDisplace u +disp_left = displaceH . negate -southwards :: Num u => u -> PointDisplace u -southwards = displaceV . negate +disp_right :: Num u => u -> PointDisplace u +disp_right = displaceH -eastwards :: Num u => u -> PointDisplace u -eastwards = displaceH -westwards :: Num u => u -> PointDisplace u -westwards = displaceH . negate +-- diagonals - these are different to cardinals which have the +-- hypotenuese as the dist. +-- -northeastwards :: Floating u => u -> PointDisplace u -northeastwards = displaceVec . avec (0.25 * pi) +disp_up_left :: Num u => u -> PointDisplace u +disp_up_left u = displaceVec (V2 (-u) u) -northwestwards :: Floating u => u -> PointDisplace u -northwestwards = displaceVec . avec (0.75 * pi) +disp_up_right :: Num u => u -> PointDisplace u +disp_up_right u = displaceVec (V2 u u) -southeastwards :: Floating u => u -> PointDisplace u -southeastwards = displaceVec . avec (1.75 * pi) +disp_down_left :: Num u => u -> PointDisplace u +disp_down_left u = displaceVec (V2 (-u) (-u)) -southwestwards :: Floating u => u -> PointDisplace u -southwestwards = displaceVec . avec (1.25 * pi) +disp_down_right :: Num u => u -> PointDisplace u +disp_down_right u = displaceVec (V2 u (-u)) + + + + + +-- Cardinal displacement + +disp_north :: Num u => u -> PointDisplace u +disp_north = displaceV + + +disp_south :: Num u => u -> PointDisplace u +disp_south = displaceV . negate + +disp_east :: Num u => u -> PointDisplace u +disp_east = displaceH + +disp_west :: Num u => u -> PointDisplace u +disp_west = displaceH . negate + +disp_northeast :: Floating u => u -> PointDisplace u +disp_northeast = displaceVec . avec (0.25 * pi) + +disp_northwest :: Floating u => u -> PointDisplace u +disp_northwest = displaceVec . avec (0.75 * pi) + +disp_southeast :: Floating u => u -> PointDisplace u +disp_southeast = displaceVec . avec (1.75 * pi) + +disp_southwest :: Floating u => u -> PointDisplace u +disp_southwest = displaceVec . avec (1.25 * pi) + + -------------------------------------------------------------------------------- -- ThetaPointDisplace functions @@ -241,37 +304,104 @@ displaceParallel x theta . displacePerpendicular y theta -thetaNorthwards :: Floating u => u -> ThetaPointDisplace u -thetaNorthwards = displacePerpendicular +adisp_north :: Floating u => u -> ThetaPointDisplace u +adisp_north = displacePerpendicular -thetaSouthwards :: Floating u => u -> ThetaPointDisplace u -thetaSouthwards = displacePerpendicular . negate +adisp_south :: Floating u => u -> ThetaPointDisplace u +adisp_south = displacePerpendicular . negate -thetaEastwards :: Floating u => u -> ThetaPointDisplace u -thetaEastwards = displaceParallel +adisp_east :: Floating u => u -> ThetaPointDisplace u +adisp_east = displaceParallel -thetaWestwards :: Floating u => u -> ThetaPointDisplace u -thetaWestwards = displaceParallel . negate +adisp_west :: Floating u => u -> ThetaPointDisplace u +adisp_west = displaceParallel . negate -thetaNortheastwards :: Floating u => u -> ThetaPointDisplace u -thetaNortheastwards d = - \theta pt -> pt .+^ avec (circularModulo $ theta + (0.25*pi)) d +adisp_northeast :: Floating u => u -> ThetaPointDisplace u +adisp_northeast d = \ang pt -> pt .+^ avec (ang + (0.25*pi)) d -thetaNorthwestwards :: Floating u => u -> ThetaPointDisplace u -thetaNorthwestwards d = - \theta pt -> pt .+^ avec (circularModulo $ theta + (0.75*pi)) d +adisp_northwest :: Floating u => u -> ThetaPointDisplace u +adisp_northwest d = \ang pt -> pt .+^ avec (ang + (0.75*pi)) d -thetaSoutheastwards :: Floating u => u -> ThetaPointDisplace u -thetaSoutheastwards d = - \theta pt -> pt .+^ avec (circularModulo $ theta + (1.75*pi)) d +adisp_southeast :: Floating u => u -> ThetaPointDisplace u +adisp_southeast d = \ang pt -> pt .+^ avec (ang + (1.75*pi)) d -thetaSouthwestwards :: Floating u => u -> ThetaPointDisplace u -thetaSouthwestwards d = - \theta pt -> pt .+^ avec (circularModulo $ theta + (1.25*pi)) d +adisp_southwest :: Floating u => u -> ThetaPointDisplace u +adisp_southwest d = \ang pt -> pt .+^ avec (ang + (1.25*pi)) d + + + +-------------------------------------------------------------------------------- + +-- | Absolute units. +-- +centerRelative :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => (Int,Int) -> a -> Query (Anchor u) +centerRelative coord a = snapmove coord >>= \v -> return $ center a .+^ v + +-- TODO - These are really for Anchors. +-- +-- Should the have a separate module or be rolled into the same +-- module as the classes? +-- + +-- | Value is 1 snap unit right. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +right_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query (Anchor u) +right_of = centerRelative (1,0) + +-- | Value is 1 snap move left. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +left_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query (Anchor u) +left_of = centerRelative ((-1),0) + +-- | Value is 1 snap move up, 1 snap move right. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +above_right_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query (Anchor u) +above_right_of = centerRelative (1,1) + +-- | Value is 1 snap move below, 1 snap move right. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +below_right_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query (Anchor u) +below_right_of = centerRelative (1, (-1)) + +-- | Value is 1 snap move up, 1 snap move left. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +above_left_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query (Anchor u) +above_left_of = centerRelative ((-1),1) + +-- | Value is 1 snap move down, 1 snap move left. +-- +-- This function should be considered obsolete, pending a +-- re-think. +-- +below_left_of :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) + => a -> Query (Anchor u) +below_left_of = centerRelative ((-1),(-1)) + diff --git a/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs b/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs --- a/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs +++ b/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Objects.DrawingPrimitives --- Copyright : (c) Stephen Tetley 2010-2011 +-- Copyright : (c) Stephen Tetley 2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -22,28 +20,34 @@ module Wumpus.Basic.Kernel.Objects.DrawingPrimitives ( - -- * Paths - locPath - , emptyLocPath + -- * Prim Paths + locPP + + , emptyLocPP + , vertexPP + , curvePP + , openStroke , closedStroke , filledPath , borderedPath -- * Text - , textline - , rtextline - , escapedline - , rescapedline + , plainTextLine + , rplainTextLine + , escTextLine + , rescTextLine - , hkernline - , vkernline + , KernChar + , hkernLine + , vkernLine -- * Lines , straightLine - , straightLineGraphic - , curveGraphic + , locStraightLine + , curvedLine + , straightConnector -- * Circles , strokedCircle @@ -55,7 +59,6 @@ , rstrokedEllipse , filledEllipse , rfilledEllipse - , borderedEllipse , rborderedEllipse @@ -75,55 +78,111 @@ ) where +import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive -import Wumpus.Basic.Kernel.Objects.Graphic +import Wumpus.Basic.Kernel.Objects.Basis +import Wumpus.Basic.Kernel.Objects.Connector +import Wumpus.Basic.Kernel.Objects.Image +import Wumpus.Basic.Kernel.Objects.LocImage +import Wumpus.Basic.Kernel.Objects.LocThetaImage import Wumpus.Core -- package: wumpus-core -import Data.AffineSpace -- package: vector-space - import Control.Applicative +-- Helpers --- Helper --- -graphicAns :: Primitive u -> (UNil u, PrimGraphic u) -graphicAns p = (uNil, primGraphic p) +norm2 :: InterpretUnit u => u -> u -> Query (Double,Double) +norm2 a b = (,) <$> normalizeCtx a <*> normalizeCtx b +makeGraphic :: Query a -> (a -> Primitive) -> Graphic u +makeGraphic qy fn = qy >>= \a -> return $ graphicAns $ prim1 $ fn a + + +makeLocGraphic :: InterpretUnit u + => Query a -> (a -> DPoint2 -> Primitive) -> LocGraphic u +makeLocGraphic qy fn = promoteR1 $ \pt -> + normalizeCtxF pt >>= \dpt -> + qy >>= \a -> return $ graphicAns $ prim1 $ fn a dpt + +makeLocThetaGraphic :: InterpretUnit u + => Query a -> (a -> DPoint2 -> Radian -> Primitive) + -> LocThetaGraphic u +makeLocThetaGraphic qy fn = promoteR2 $ \pt ang -> + normalizeCtxF pt >>= \dpt -> + qy >>= \a -> return $ graphicAns $ prim1 $ fn a dpt ang + + + -------------------------------------------------------------------------------- -- Paths --- | 'locPath' : @ [next_vector] -> (Point2 ~> PrimPath) @ +-- Note - naming convention, the PP suffix is to avoid confusion +-- with the Path data type in Wumpus-Drawing. These paths are +-- considered more /internal/. -- --- Create a path 'LocCF' - i.e. a functional type + +-- | 'locPP' : @ [next_vector] -> LocQuery PrimPath @ +-- +-- Create a path 'LocQuery' - i.e. a functional type -- /from Point to PrimPath/. -- -- This is the analogue to 'vectorPath' in @Wumpus-Core@, but the -- result is produced /within/ the 'DrawingContext'. -- -locPath :: Num u => [Vec2 u] -> LocCF u (PrimPath u) -locPath vs = promoteR1 $ \pt -> pure $ vectorPath pt vs +locPP :: InterpretUnit u => [Vec2 u] -> LocQuery u PrimPath +locPP vs = promoteR1 $ \ pt -> + vectorPrimPath <$> normalizeCtxF pt <*> mapM normalizeCtxF vs --- | 'emptyLocPath' : @ (Point ~> PrimPath) @ + + +-- | 'emptyLocPP' : @ (Point ~> PrimPath) @ -- --- Create an empty path 'LocCF' - i.e. a functional type +-- Create an empty path 'LocQuery' - i.e. a functional type -- /from Point to PrimPath/. -- -- This is the analogue to 'emptyPath' in @Wumpus-Core@, but the -- result is produced /within/ the 'DrawingContext'. -- -emptyLocPath :: Num u => LocCF u (PrimPath u) -emptyLocPath = locPath [] +emptyLocPP :: InterpretUnit u => LocQuery u PrimPath +emptyLocPP = locPP [] +-- | 'vertexPP' : @ (Point ~> PrimPath) @ -- +-- Create a PrimPath made of straight line segments joining the +-- supplied points. +-- +-- This is the analogue to 'vertexPrimPath' in @Wumpus-Core@, but +-- it is polymorphic on unit. +-- +vertexPP :: InterpretUnit u => [Point2 u] -> Query PrimPath +vertexPP xs = vertexPrimPath <$> mapM normalizeCtxF xs + + + +-- | 'curvePP' : @ (Point ~> PrimPath) @ +-- +-- Create a path made of curve segments joining the +-- supplied points. +-- +-- This is the analogue to 'curvedPrimPath' in @Wumpus-Core@, but +-- it is polymorphic on unit. +-- +curvePP :: InterpretUnit u => [Point2 u] -> Query PrimPath +curvePP xs = curvedPrimPath <$> mapM normalizeCtxF xs + + +-------------------------------------------------------------------------------- + +-- -- Drawing paths (stroke, fill, bordered)... -- @@ -133,20 +192,20 @@ -- drawing properties (colour, line width, etc.) are taken from -- the implicit 'DrawingContext'. -- -openStroke :: Num u => PrimPath u -> Graphic u -openStroke pp = - withStrokeAttr $ \rgb attr -> graphicAns $ ostroke rgb attr pp +openStroke :: PrimPath -> Graphic u +openStroke pp = makeGraphic strokeAttr (\(rgb,attr) -> ostroke rgb attr pp) + -- | 'closedStroke' : @ path -> Graphic @ -- -- This is the analogue to 'cstroke' in @Wumpus-core@, but the -- drawing properties (colour, line width, etc.) are taken from -- the implicit 'DrawingContext'. -- -closedStroke :: Num u => PrimPath u -> Graphic u +closedStroke :: PrimPath -> Graphic u closedStroke pp = - withStrokeAttr $ \rgb attr -> graphicAns $ cstroke rgb attr pp + makeGraphic strokeAttr (\(rgb,attr) -> cstroke rgb attr pp) -- | 'filledPath' : @ path -> Graphic @ @@ -155,8 +214,8 @@ -- fill colour is taken from the implicit 'DrawingContext'. -- -- -filledPath :: Num u => PrimPath u -> Graphic u -filledPath pp = withFillAttr $ \rgb -> graphicAns $ fill rgb pp +filledPath :: PrimPath -> Graphic u +filledPath pp = makeGraphic fillAttr (\rgb -> fill rgb pp) -- | 'borderedPath' : @ path -> Graphic @ @@ -166,17 +225,17 @@ -- etc.) are taken from the implicit 'DrawingContext'. -- -- -borderedPath :: Num u => PrimPath u -> Graphic u +borderedPath :: PrimPath -> Graphic u borderedPath pp = - withBorderedAttr $ \frgb attr srgb -> - graphicAns $ fillStroke frgb attr srgb pp + makeGraphic borderedAttr + (\(frgb,attr,srgb) -> fillStroke frgb attr srgb pp) -------------------------------------------------------------------------------- -- Text --- | 'textline' : @ string -> LocGraphic @ +-- | 'plainTextLine' : @ string -> LocGraphic @ -- -- Create a text 'LocGraphic' - i.e. a functional type -- /from Point to Graphic/. @@ -187,15 +246,16 @@ -- text properties (font family, font size, colour) are taken from -- the implicit 'DrawingContext'. -- -textline :: Num u => String -> LocGraphic u -textline ss = - promoteR1 $ \pt -> - withTextAttr $ \rgb attr -> graphicAns (textlabel rgb attr ss pt) +plainTextLine :: InterpretUnit u => String -> LocGraphic u +plainTextLine ss = + makeLocGraphic textAttr + (\(rgb,attr) pt -> textlabel rgb attr ss pt) --- | 'rtextline' : @ string -> LocThetaGraphic @ + +-- | 'rplainTextLine' : @ string -> LocThetaGraphic @ -- -- Create a text 'LocThetaGraphic' - i.e. a functional type -- /from Point and Angle to Graphic/. @@ -208,14 +268,13 @@ -- -- This is the analogue to 'rtextlabel' in @Wumpus-core@. -- -rtextline :: Num u => String -> LocThetaGraphic u -rtextline ss = - promoteR2 $ \pt theta -> - withTextAttr $ \rgb attr -> graphicAns (rtextlabel rgb attr ss theta pt) - +rplainTextLine :: InterpretUnit u => String -> LocThetaGraphic u +rplainTextLine ss = + makeLocThetaGraphic textAttr + (\(rgb,attr) pt ang -> rtextlabel rgb attr ss ang pt) --- | 'escapedline' : @ escaped_text -> LocGraphic @ +-- | 'escTextline' : @ escaped_text -> LocGraphic @ -- -- Create a text 'LocGraphic' - i.e. a functional type -- /from Point to Graphic/. @@ -226,14 +285,14 @@ -- the text properties (font family, font size, colour) are taken -- from the implicit 'DrawingContext'. -- -escapedline :: Num u => EscapedText -> LocGraphic u -escapedline ss = - promoteR1 $ \pt -> - withTextAttr $ \rgb attr -> graphicAns (escapedlabel rgb attr ss pt) +escTextLine :: InterpretUnit u => EscapedText -> LocGraphic u +escTextLine esc = + makeLocGraphic textAttr + (\(rgb,attr) pt -> escapedlabel rgb attr esc pt) --- | 'rescapedline' : @ escaped_text -> LocThetaGraphic @ +-- | 'rescTextLine' : @ escaped_text -> LocThetaGraphic @ -- -- Create a text 'LocThetaGraphic' - i.e. a functional type -- /from Point and Angle to Graphic/. @@ -248,15 +307,25 @@ -- the text properties (font family, font size, colour) are taken -- from the implicit 'DrawingContext'. -- -rescapedline :: Num u => EscapedText -> LocThetaGraphic u -rescapedline ss = - promoteR2 $ \pt theta -> - withTextAttr $ \rgb attr -> graphicAns (rescapedlabel rgb attr ss theta pt) +rescTextLine :: InterpretUnit u => EscapedText -> LocThetaGraphic u +rescTextLine esc = + makeLocThetaGraphic textAttr + (\(rgb,attr) pt ang -> rescapedlabel rgb attr esc ang pt) +-- | Unit parametric version of KerningChar from Wumpus-Core. +-- +type KernChar u = (u,EscapedChar) --- | 'hkernline' : @ [kern_char] -> LocGraphic @ +uconvKernChar :: InterpretUnit u => [KernChar u] -> Query [KerningChar] +uconvKernChar = mapM mf + where + mf (u,ch) = (\u1 -> (u1,ch)) <$> normalizeCtx u + + + +-- | 'hkernLine' : @ [kern_char] -> LocGraphic @ -- -- Create a horizontally kerned text 'LocGraphic' - i.e. a -- functional type /from Point to Graphic/. @@ -267,13 +336,15 @@ -- the text properties (font family, font size, colour) are taken -- from the implicit 'DrawingContext'. -- -hkernline :: Num u => [KerningChar u] -> LocGraphic u -hkernline xs = - promoteR1 $ \pt -> - withTextAttr $ \rgb attr -> graphicAns (hkernlabel rgb attr xs pt) +hkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u +hkernLine ks = uconvKernChar ks >>= body + where + body ans = makeLocGraphic textAttr + (\(rgb,attr) pt -> hkernlabel rgb attr ans pt) --- | 'vkernline' : @ [kern_char] -> LocGraphic @ + +-- | 'vkernLine' : @ [kern_char] -> LocGraphic @ -- -- Create a vertically kerned text 'LocGraphic' - i.e. a -- functional type /from Point to Graphic/. @@ -284,18 +355,28 @@ -- the text properties (font family, font size, colour) are taken -- from the implicit 'DrawingContext'. -- -vkernline :: Num u => [KerningChar u] -> LocGraphic u -vkernline xs = - promoteR1 $ \pt -> - withTextAttr $ \rgb attr -> graphicAns (vkernlabel rgb attr xs pt) - - - +vkernLine :: InterpretUnit u => [KernChar u] -> LocGraphic u +vkernLine ks = uconvKernChar ks >>= body + where + body ans = makeLocGraphic textAttr + (\(rgb,attr) pt -> vkernlabel rgb attr ans pt) -------------------------------------------------------------------------------- -- Lines --- | 'straightLine' : @ vec_to -> LocGraphic @ +-- | 'straightLine' : @ start_point * end_point -> LocGraphic @ +-- +-- Create a straight line 'Graphic', the start and end point +-- are supplied explicitly. +-- +-- The line properties (colour, pen thickness, etc.) are taken +-- from the implicit 'DrawingContext'. +-- +straightLine :: InterpretUnit u => Point2 u -> Point2 u -> Graphic u +straightLine p1 p2 = vertexPP [p1,p2] >>= openStroke + + +-- | 'locStraightLine' : @ vec_to -> LocGraphic @ -- -- Create a stright line 'LocGraphic' - i.e. a functional type -- /from Point to Graphic/. @@ -307,42 +388,55 @@ -- The line properties (colour, pen thickness, etc.) are taken -- from the implicit 'DrawingContext'. -- -straightLine :: Fractional u => Vec2 u -> LocGraphic u -straightLine v = mf >>= (lift0R1 . openStroke) - where - mf = promoteR1 $ \pt -> pure $ primPath pt [lineTo $ pt .+^ v] +locStraightLine :: InterpretUnit u => Vec2 u -> LocGraphic u +locStraightLine v = promoteR1 $ \pt -> + apply1R1 (locPP [v]) pt >>= openStroke - --- | 'straightLineGraphic' : @ start_point * end_point -> LocGraphic @ + + +-- | 'curveLine' : @ start_point * control_point1 * +-- control_point2 * end_point -> Graphic @ -- --- Create a straight line 'Graphic', the start and end point --- are supplied explicitly. +-- Create a Bezier curve 'Graphic', all control points are +-- supplied explicitly. -- -- The line properties (colour, pen thickness, etc.) are taken -- from the implicit 'DrawingContext'. -- -straightLineGraphic :: Fractional u => Point2 u -> Point2 u -> Graphic u -straightLineGraphic p1 p2 = openStroke $ primPath p1 [lineTo p2] +curvedLine :: InterpretUnit u + => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u +curvedLine p0 p1 p2 p3 = curvePP [p0,p1,p2,p3] >>= openStroke --- | 'curveGraphic' : @ start_point * control_point1 * --- control_point2 * end_point -> Graphic @ + +-- | 'straightConnector' : @ start_point * end_point -> Connector @ -- --- Create a Bezier curve 'Graphic', all control points are --- supplied explicitly. +-- Create a straight line 'Graphic', the start and end point +-- are supplied implicitly. -- -- The line properties (colour, pen thickness, etc.) are taken -- from the implicit 'DrawingContext'. -- -curveGraphic :: Fractional u - => Point2 u -> Point2 u -> Point2 u -> Point2 u -> Graphic u -curveGraphic sp cp1 cp2 ep = openStroke $ primPath sp [curveTo cp1 cp2 ep] +straightConnector :: InterpretUnit u => ConnectorGraphic u +straightConnector = promoteR2 $ \p0 p1 -> vertexPP [p0,p1] >>= openStroke + -------------------------------------------------------------------------------- -- Circles +-- | Helper for circle drawing. +-- +circlePath :: InterpretUnit u + => u -> LocQuery u PrimPath +circlePath r = promoteR1 $ \pt -> + (\dr dpt -> curvedPrimPath $ bezierCircle dr dpt) + <$> normalizeCtx r <*> normalizeCtxF pt + + + + -- | 'strokedCircle' : @ radius -> LocGraphic @ -- -- Create a stroked circle 'LocGraphic' - the implicit point is @@ -351,11 +445,13 @@ -- The line properties (colour, pen thickness, etc.) are taken -- from the implicit 'DrawingContext'. -- -strokedCircle :: Floating u => u -> LocGraphic u -strokedCircle r = promoteR1 (closedStroke . curvedPath . bezierCircle r) +strokedCircle :: InterpretUnit u => u -> LocGraphic u +strokedCircle r = promoteR1 $ \pt -> + apply1R1 (circlePath r) pt >>= openStroke + -- | 'filledCircle' : @ radius -> LocGraphic @ -- -- Create a filled circle 'LocGraphic' - the implicit point is @@ -363,8 +459,9 @@ -- -- The fill colour is taken from the implicit 'DrawingContext'. -- -filledCircle :: Floating u => u -> LocGraphic u -filledCircle r = promoteR1 (filledPath . curvedPath . bezierCircle r) +filledCircle :: InterpretUnit u => u -> LocGraphic u +filledCircle r = promoteR1 $ \pt -> + apply1R1 (circlePath r) pt >>= filledPath @@ -376,15 +473,35 @@ -- The background fill colour and the outline stroke properties -- are taken from the implicit 'DrawingContext'. -- -borderedCircle :: Floating u => u -> LocGraphic u -borderedCircle r = promoteR1 (borderedPath . curvedPath . bezierCircle r) +borderedCircle :: InterpretUnit u => u -> LocGraphic u +borderedCircle r = promoteR1 $ \pt -> + apply1R1 (circlePath r) pt >>= borderedPath -------------------------------------------------------------------------------- -- Ellipses +-- | Helper for ellipse drawing. +-- +ellipsePath :: InterpretUnit u + => u -> u -> LocQuery u PrimPath +ellipsePath rx ry = promoteR1 $ \pt -> + (\drx dry dpt -> curvedPrimPath $ bezierEllipse drx dry dpt) + <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt + +-- | Helper for ellipse drawing. +-- +rellipsePath :: InterpretUnit u + => u -> u -> LocThetaQuery u PrimPath +rellipsePath rx ry = promoteR2 $ \pt ang -> + (\drx dry dpt -> curvedPrimPath $ rbezierEllipse drx dry ang dpt) + <$> normalizeCtx rx <*> normalizeCtx ry <*> normalizeCtxF pt + + + + -- | 'strokedEllipse' : @ x_radius * y_radius -> LocGraphic @ -- -- Create a stroked ellipse 'LocGraphic' - the implicit point is @@ -393,9 +510,9 @@ -- The line properties (colour, pen thickness, etc.) are taken -- from the implicit 'DrawingContext'. -- -strokedEllipse :: Floating u => u -> u -> LocGraphic u -strokedEllipse rx ry = - promoteR1 (closedStroke . curvedPath . bezierEllipse rx ry) +strokedEllipse :: InterpretUnit u => u -> u -> LocGraphic u +strokedEllipse rx ry = promoteR1 $ \pt -> + apply1R1 (ellipsePath rx ry) pt >>= closedStroke @@ -408,12 +525,14 @@ -- The line properties (colour, pen thickness, etc.) are taken -- from the implicit 'DrawingContext'. -- -rstrokedEllipse :: (Real u, Floating u) => u -> u -> LocThetaGraphic u -rstrokedEllipse hw hh = - promoteR2 $ \ pt theta -> - closedStroke $ curvedPath $ rbezierEllipse hw hh theta pt +rstrokedEllipse :: InterpretUnit u + => u -> u -> LocThetaGraphic u +rstrokedEllipse rx ry = promoteR2 $ \pt ang -> + apply2R2 (rellipsePath rx ry) pt ang >>= closedStroke + + -- | 'filledEllipse' : @ x_radius * y_radius -> LocGraphic @ -- -- Create a filled ellipse 'LocGraphic' - the implicit point is @@ -421,9 +540,9 @@ -- -- The fill colour is taken from the implicit 'DrawingContext'. -- -filledEllipse :: Floating u => u -> u -> LocGraphic u -filledEllipse hw hh = - promoteR1 (filledPath . curvedPath . bezierEllipse hw hh) +filledEllipse :: InterpretUnit u => u -> u -> LocGraphic u +filledEllipse rx ry = promoteR1 $ \pt -> + apply1R1 (ellipsePath rx ry) pt >>= filledPath -- | 'rfilledEllipse' : @ x_radius * y_radius -> LocGraphic @ @@ -434,10 +553,9 @@ -- -- The fill colour is taken from the implicit 'DrawingContext'. -- -rfilledEllipse :: (Real u, Floating u) => u -> u -> LocThetaGraphic u -rfilledEllipse hw hh = - promoteR2 $ \ pt theta -> - filledPath $ curvedPath $ rbezierEllipse hw hh theta pt +rfilledEllipse :: InterpretUnit u => u -> u -> LocThetaGraphic u +rfilledEllipse rx ry = promoteR2 $ \pt ang -> + apply2R2 (rellipsePath rx ry) pt ang >>= filledPath @@ -449,9 +567,9 @@ -- The background fill colour and the outline stroke properties -- are taken from the implicit 'DrawingContext'. -- -borderedEllipse :: Floating u => u -> u -> LocGraphic u -borderedEllipse hw hh = - promoteR1 (borderedPath . curvedPath . bezierEllipse hw hh) +borderedEllipse :: InterpretUnit u => u -> u -> LocGraphic u +borderedEllipse rx ry = promoteR1 $ \pt -> + apply1R1 (ellipsePath rx ry) pt >>= borderedPath @@ -464,29 +582,23 @@ -- The background fill colour and the outline stroke properties -- are taken from the implicit 'DrawingContext'. -- -rborderedEllipse :: (Real u, Floating u) => u -> u -> LocThetaGraphic u -rborderedEllipse hw hh = - promoteR2 $ \ pt theta -> - borderedPath $ curvedPath $ rbezierEllipse hw hh theta pt +rborderedEllipse :: InterpretUnit u + => u -> u -> LocThetaGraphic u +rborderedEllipse rx ry = promoteR2 $ \pt ang -> + apply2R2 (rellipsePath rx ry) pt ang >>= borderedPath --- Note - clipping needs a picture as well as a path, so there is --- no analogous @clippedPath@ function. +-- Note - clipping to do... -------------------------------------------------------------------------------- -- Rectangles - - -- | Supplied point is /bottom-left/. -- -rectanglePath :: Num u => u -> u -> Point2 u -> PrimPath u -rectanglePath w h bl = primPath bl [ lineTo br, lineTo tr, lineTo tl ] - where - br = bl .+^ hvec w - tr = br .+^ vvec h - tl = bl .+^ vvec h +rectanglePath :: InterpretUnit u + => u -> u -> LocQuery u PrimPath +rectanglePath w h = locPP [hvec w, vvec h, hvec (-w)] -- | 'strokedRectangle' : @ width * height -> LocGraphic @ @@ -497,8 +609,9 @@ -- The line properties (colour, pen thickness, etc.) are taken -- from the implicit 'DrawingContext'. -- -strokedRectangle :: Fractional u => u -> u -> LocGraphic u -strokedRectangle w h = promoteR1 (closedStroke . rectanglePath w h) +strokedRectangle :: InterpretUnit u => u -> u -> LocGraphic u +strokedRectangle w h = promoteR1 $ \pt -> + apply1R1 (rectanglePath w h) pt >>= closedStroke -- | 'filledRectangle' : @ width * height -> LocGraphic @ @@ -508,8 +621,9 @@ -- -- The fill colour is taken from the implicit 'DrawingContext'. -- -filledRectangle :: Fractional u => u -> u -> LocGraphic u -filledRectangle w h = promoteR1 (filledPath . rectanglePath w h) +filledRectangle :: InterpretUnit u => u -> u -> LocGraphic u +filledRectangle w h = promoteR1 $ \pt -> + apply1R1 (rectanglePath w h) pt >>= filledPath -- | 'borderedRectangle' : @ width * height -> LocGraphic @ @@ -520,13 +634,12 @@ -- The background fill colour and the outline stroke properties -- are taken from the implicit 'DrawingContext'. -- -borderedRectangle :: Fractional u => u -> u -> LocGraphic u -borderedRectangle w h = promoteR1 (borderedPath . rectanglePath w h) - +borderedRectangle :: InterpretUnit u => u -> u -> LocGraphic u +borderedRectangle w h = promoteR1 $ \pt -> + apply1R1 (rectanglePath w h) pt >>= borderedPath --------------------------------------------------------------------------- - -- | 'strokedDisk' : @ radius -> LocGraphic @ -- -- Create a stroked circle 'LocGraphic' - the implicit point is @@ -544,10 +657,16 @@ -- The line properties (colour, pen thickness, etc.) are taken -- from the implicit 'DrawingContext'. -- -strokedDisk :: Num u => u -> LocGraphic u -strokedDisk r = strokedEllipseDisk r r +strokedDisk :: InterpretUnit u => u -> LocGraphic u +strokedDisk radius = + normalizeCtx radius >>= body + where + body r = makeLocGraphic strokeAttr + (\(rgb,attr) pt -> strokeEllipse rgb attr r r pt) + + -- | 'filledDisk' : @ radius -> LocGraphic @ -- -- Create a filled circle 'LocGraphic' - the implicit point is @@ -560,8 +679,11 @@ -- -- The fill colour is taken from the implicit 'DrawingContext'. -- -filledDisk :: Num u => u -> LocGraphic u -filledDisk r = filledEllipseDisk r r +filledDisk :: InterpretUnit u => u -> LocGraphic u +filledDisk radius = + normalizeCtx radius >>= body + where + body r = makeLocGraphic fillAttr (\rgb pt -> fillEllipse rgb r r pt) -- | 'borderedDisk' : @ radius -> LocGraphic @ @@ -581,8 +703,12 @@ -- The background fill colour and the outline stroke properties -- are taken from the implicit 'DrawingContext'. -- -borderedDisk :: Num u => u -> LocGraphic u -borderedDisk r = borderedEllipseDisk r r +borderedDisk :: InterpretUnit u => u -> LocGraphic u +borderedDisk radius = + normalizeCtx radius >>= body + where + body r = makeLocGraphic borderedAttr + (\(frgb,attr,srgb) pt -> fillStrokeEllipse frgb attr srgb r r pt) -- | 'strokedEllipseDisk' : @ x_radius * y_radius -> LocGraphic @ @@ -602,13 +728,14 @@ -- The line properties (colour, pen thickness, etc.) are taken -- from the implicit 'DrawingContext'. -- -strokedEllipseDisk :: Num u => u -> u -> LocGraphic u -strokedEllipseDisk rx ry = - promoteR1 $ \ pt -> - withStrokeAttr $ \rgb attr -> - graphicAns (strokeEllipse rgb attr rx ry pt) +strokedEllipseDisk :: InterpretUnit u => u -> u -> LocGraphic u +strokedEllipseDisk rx ry = norm2 rx ry >>= body + where + body (drx,dry) = makeLocGraphic strokeAttr + (\(rgb,attr) pt -> strokeEllipse rgb attr drx dry pt) + -- | 'filledEllipseDisk' : @ x_radius * y_radius -> LocGraphic @ -- -- Create a filled ellipse 'LocGraphic' - the implicit point is @@ -621,10 +748,11 @@ -- -- The fill colour is taken from the implicit 'DrawingContext'. -- -filledEllipseDisk :: Num u => u -> u -> LocGraphic u -filledEllipseDisk rx ry = - promoteR1 $ \pt -> - withFillAttr $ \rgb -> graphicAns (fillEllipse rgb rx ry pt) +filledEllipseDisk :: InterpretUnit u => u -> u -> LocGraphic u +filledEllipseDisk rx ry = norm2 rx ry >>= body + where + body (drx,dry) = makeLocGraphic fillAttr + (\rgb pt -> fillEllipse rgb drx dry pt) -- | 'borderedEllipseDisk' : @ x_radius * y_radius -> LocGraphic @ @@ -644,8 +772,10 @@ -- The background fill colour and the outline stroke properties -- are taken from the implicit 'DrawingContext'. -- -borderedEllipseDisk :: Num u => u -> u -> LocGraphic u -borderedEllipseDisk rx ry = - promoteR1 $ \pt -> - withBorderedAttr $ \frgb attr srgb -> - graphicAns (fillStrokeEllipse frgb attr srgb rx ry pt) +borderedEllipseDisk :: InterpretUnit u => u -> u -> LocGraphic u +borderedEllipseDisk rx ry = norm2 rx ry >>= body + where + body (drx,dry) = makeLocGraphic borderedAttr + (\(frgb,attr,srgb) pt -> + fillStrokeEllipse frgb attr srgb drx dry pt) + diff --git a/src/Wumpus/Basic/Kernel/Objects/Graphic.hs b/src/Wumpus/Basic/Kernel/Objects/Graphic.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Objects/Graphic.hs +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Kernel.Objects.Graphic --- Copyright : (c) Stephen Tetley 2010-2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- Graphic type - this is largely equivalent to Primitive in --- Wumpus-Core, but drawing attributes are implicitly supplied --- by the DrawingContext. --- --- API in @Wumpus.Core@, but here they exploit the implicit --- @DrawingContext@. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Kernel.Objects.Graphic - ( - - Graphic - , DGraphic - - - -- * LocGraphic - , LocGraphic - , DLocGraphic - - - , LocThetaGraphic - , DLocThetaGraphic - - -- * Functions - , safeconcat - , ignoreAns - , replaceAns - , mapAns - - , intoImage - , intoLocImage - , intoLocThetaImage - - , emptyLocGraphic - , emptyLocThetaGraphic - - , decorate - , sdecorate - , adecorate - - , hyperlink - - ) where - -import Wumpus.Basic.Kernel.Base.BaseDefs -import Wumpus.Basic.Kernel.Base.ContextFun -import Wumpus.Basic.Kernel.Base.WrappedPrimitive -import Wumpus.Basic.Kernel.Objects.BaseObjects - -import Wumpus.Core -- package: wumpus-core - - -import Control.Applicative - --------------------------------------------------------------------------------- --- Graphic - --- | Simple drawing - produce a primitive, access the DrawingContext --- as required, e.g for fill colour, stroke colur, line width, etc. --- -type Graphic u = Image u (UNil u) - --- | Alias of 'Graphic' where the unit type is specialized to --- Double. --- -type DGraphic = Graphic Double - - --- | /Originated/ drawing - produce a primitive respective to the --- supplied start-point, access the DrawingContext as required. --- -type LocGraphic u = LocImage u (UNil u) - --- | Alias of 'LocGraphic' where the unit type is specialized to --- Double. --- -type DLocGraphic = LocGraphic Double - - - - --- | /Originated/ drawing - produce a primitive respective to the --- supplied start-point, access the DrawingContext as required. --- -type LocThetaGraphic u = LocThetaImage u (UNil u) - - --- | Alias of 'LocThetaGraphic' where the unit type is specialized --- to Double. --- -type DLocThetaGraphic = LocThetaGraphic Double - - --------------------------------------------------------------------------------- --- Functions - - --- | 'safeconcat' : @ alternative * [image] -> Image@ --- --- 'safeconcat' produces a composite 'Image' from a list of --- @Image@\'s. If the list is empty the alternative @Image@ is --- used. --- --- This contrasts to 'oconcat' - when used for @Image@\'s, --- @oconcat@ has the same type signature as @safeconcat@ but --- @oconcat@ considers its arguments to be an already destructured --- list: --- --- > oconcat (head::Image) (rest::[Image]) --- -safeconcat :: OPlus a => Image u a -> [Image u a] -> Image u a -safeconcat _ (x:xs) = oconcat x xs -safeconcat alt [] = alt - - --- | Ignore the answer produced by an 'Image', a 'LocImage' etc. --- --- Use this function to turn an 'Image' into a 'Graphic', a --- 'LocImage into a 'LocGraphic'. --- -ignoreAns :: Functor f => f (a,b) -> f (UNil u, b) -ignoreAns = fmap (replaceL uNil) - - --- | Replace the answer produced by an 'Image', a 'LocImage' etc. --- -replaceAns :: Functor f => z -> f (a,b) -> f (z, b) -replaceAns = fmap . replaceL - - --- | Apply the supplied function to the answer produced by an --- 'Image', a 'LocImage' etc. --- -mapAns :: Functor f => (a -> z) -> f (a,b) -> f (z,b) -mapAns f = fmap (\(a,b) -> (f a ,b)) - - --- | 'intoImage' : @ context_function * graphic -> Image @ --- --- Build an 'Image' from a context function ('CF') that generates --- the answer and a 'Graphic' that draws the 'Image'. --- -intoImage :: CF a -> Graphic u -> Image u a -intoImage = liftA2 (\a (_,b) -> (a,b)) - - --- | 'intoLocImage' : @ loc_context_function * loc_graphic -> LocImage @ --- --- /Loc/ version of 'intoImage'. --- --- The 'LocImage' is built as a function from an implicit start --- point to the answer. --- -intoLocImage :: LocCF u a -> LocGraphic u -> LocImage u a -intoLocImage = liftA2 (\a (_,b) -> (a,b)) - --- | 'intoLocThetaImage' : @ loc_theta_cf * loc_theta_graphic -> LocThetaImage @ --- --- /LocTheta/ version of 'intoImage'. --- --- The 'LocThetaImage' is built as a function from an implicit --- start point and angle of inclination to the answer. --- -intoLocThetaImage :: LocThetaCF u a -> LocThetaGraphic u -> LocThetaImage u a -intoLocThetaImage = liftA2 (\a (_,b) -> (a,b)) - - - --- | 'emptyLocGraphic' : @ LocGraphic @ --- --- Build an empty 'LocGraphic' (i.e. a function --- /from Point to Graphic/). This is a path with a start point --- but no path segments. --- --- The 'emptyLocGraphic' is treated as a /null primitive/ by --- @Wumpus-Core@ and is not drawn, although it does generate a --- minimum bounding box at the implicit start point. --- -emptyLocGraphic :: Num u => LocGraphic u -emptyLocGraphic = promoteR1 $ \pt -> - return $ (uNil, primGraphic $ zostroke $ emptyPath pt) - - - --- | 'emptyLocThetaGraphic' : @ LocThetaGraphic @ --- --- Build an empty 'LocThetaGraphic' (i.e. a function --- /from Point and Inclination to Graphic/). --- --- The 'emptyLocThetaGraphic' is treated as a /null primitive/ by --- @Wumpus-Core@ and is not drawn, although it does generate a --- minimum bounding box at the implicit start point. --- -emptyLocThetaGraphic :: Num u => LocThetaGraphic u -emptyLocThetaGraphic = lift1R2 emptyLocGraphic - - - - --- | Decorate an Image by superimposing a Graphic. --- --- Note - this function has a very general type signature and --- supports various graphic types: --- --- > decorate :: Image u a -> Graphic u -> Image u a --- > decorate :: LocImage u a -> LocGraphic u -> LocImage u a --- > decorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a --- -decorate :: Monad m - => m (ImageAns u a) -> m (ImageAns u zz) -> m (ImageAns u a) -decorate img gf = - img >>= \(a,g1) -> gf >>= \(_,g2) -> return (a, g1 `oplus` g2) - - - --- | /Anterior decorate/ - decorate an Image by superimposing it --- on a Graphic. --- --- Note - here the Graphic has access to the result produced by the --- the Image unlike 'decorate'. --- --- Again, this function has a very general type signature and --- supports various graphic types: --- --- > adecorate :: Image u a -> Graphic u -> Image u a --- > adecorate :: LocImage u a -> LocGraphic u -> LocImage u a --- > adecorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a --- -adecorate :: Monad m - => m (ImageAns u a) -> (a -> m (ImageAns u zz)) -> m (ImageAns u a) -adecorate img f = - img >>= \(a,g1) -> f a >>= \(_,g0) -> return (a, g0 `oplus` g1) - - --- | /Superior decorate/ - decorate an image by superimposing a --- graphic on top of it. --- --- Note, here the Graphic has access to the result produced by the --- the Image unlike 'decorate'. --- --- Again, this function has a very general type signature and --- supports various graphic types: --- --- > sdecorate :: Image u a -> Graphic u -> Image u a --- > sdecorate :: LocImage u a -> LocGraphic u -> LocImage u a --- > sdecorate :: LocThetaImage u a -> LocThetaGraphic u -> LocTheteImage u a --- -sdecorate :: Monad m - => m (ImageAns u a) -> (a -> m (ImageAns u zz)) -> m (ImageAns u a) -sdecorate img f = - img >>= \(a,g1) -> f a >>= \(_,g2) -> return (a, g1 `oplus` g2) - - --- | Hyperlink a graphic object. --- --- This function has a very general type signature and supports --- various graphic types: --- --- > hyperlink :: XLink -> Graphic u -> Graphic u --- > hyperlink :: XLink -> Image u a -> Image u a --- > hyperlink :: XLink -> LocImage u a -> LocImage u a --- > hyperlink :: XLink -> LocThetaImage u a -> LocThetaImage u a --- -hyperlink :: Functor m => XLink -> m (ImageAns u a) -> m (ImageAns u a) -hyperlink hypl = - fmap (\(a,prim) -> (a, metamorphPrim (xlink hypl) prim)) - diff --git a/src/Wumpus/Basic/Kernel/Objects/Image.hs b/src/Wumpus/Basic/Kernel/Objects/Image.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Image.hs @@ -0,0 +1,105 @@ +{-# OPTIONS -Wall #-} + + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Image +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Image and Graphic types - these are functional types from the +-- DrawingContext to a graphic /primitive/. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Image + ( + Graphic + , Image + + , DImage + , DGraphic + + , intoImage + , graphic_ + + , uconvImageF + , uconvImageZ + + ) + + where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Objects.Basis + +import Control.Applicative + + +-- | Image - function from the DrawingContext to a polymorphic +-- /answer/ and a graphic /primitive/. +-- +-- The answer is expected to be a Functor. +-- +type Image u a = CF (ImageAns u a) + + + +-- | Graphic - function from the DrawingContext to a graphic +-- /primitive/. +-- +type Graphic u = CF (GraphicAns u) + + + +-- | Type specialized version of 'Image'. +-- +type DImage a = Image Double a + + +-- | Type specialized version of 'Graphic'. +-- +type DGraphic = Graphic Double + + +-- | 'intoImage' : @ query * graphic -> Image @ +-- +-- Build an 'Image' from a context function ('CF') that generates +-- the answer and a 'Graphic' that draws the 'Image'. +-- +intoImage :: Query a -> Graphic u -> Image u a +intoImage qf ma = replaceAns <$> qf <*> ma + + +-- | /Downcast/ an 'Image' to a 'Graphic'. +-- +-- This means forgetting the answer of the Image, replacing it +-- with @()@. +-- +graphic_ :: Image u a -> Graphic u +graphic_ = fmap ignoreAns + + + + + +-- | Use this to convert 'Graphic' or 'Image' with Functor answer. +-- +uconvImageF :: (Functor t, InterpretUnit u, InterpretUnit u1) + => Image u (t u) -> Image u1 (t u1) +uconvImageF = uconvR0 szconvAnsF + + +uconvImageZ :: (InterpretUnit u, InterpretUnit u1) + => Image u a -> Image u1 a +uconvImageZ = uconvR0 szconvAnsZ + + + +-------------------------------------------------------------------------------- + diff --git a/src/Wumpus/Basic/Kernel/Objects/LocImage.hs b/src/Wumpus/Basic/Kernel/Objects/LocImage.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/LocImage.hs @@ -0,0 +1,199 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.LocImage +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- LocImage and LocGraphic types - these are functional types from the +-- DrawingContext and start point to a graphic /primitive/. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.LocImage + ( + LocGraphic + , LocImage + + , DLocImage + , DLocGraphic + + , intoLocImage + , locGraphic_ + + , emptyLocGraphic + + , uconvLocImageF + , uconvLocImageZ + + -- * Composing LocImages + , distrib + , distribH + , distribV + + , duplicate + , duplicateH + , duplicateV + + + ) + + where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.QueryDC +import Wumpus.Basic.Kernel.Base.WrappedPrimitive +import Wumpus.Basic.Kernel.Objects.Basis +import Wumpus.Basic.Kernel.Objects.Displacement + + +import Wumpus.Core -- package: wumpus-core + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative +import Data.Monoid + + +-- | Graphic - function from DrawingContext and start point to a +-- polymorphic /answer/ and a graphic /primitive/. +-- +-- The answer is expected to be a Functor. +-- +type LocImage u a = LocQuery u (ImageAns u a) + + + + +-- | LocGraphic - function from DrawingContext and start point to +-- a graphic /primitive/. +-- +type LocGraphic u = LocQuery u (GraphicAns u) + + +-- | Type specialized version of 'LocImage'. +-- +type DLocImage a = LocImage Double a + +-- | Type specialized version of 'LocGraphic'. +-- +type DLocGraphic = LocGraphic Double + + + + + + +-- | 'intoLocImage' : @ loc_query * loc_graphic -> LocImage @ +-- +-- /Loc/ version of 'intoImage'. +-- +-- The 'LocImage' is built as a function from an implicit start +-- point to the answer. +-- +intoLocImage :: LocQuery u a -> LocGraphic u -> LocImage u a +intoLocImage ma gf = promoteR1 $ \pt -> + replaceAns <$> apply1R1 ma pt <*> apply1R1 gf pt + + +-- | /Downcast/ an 'LocImage' to a 'LocGraphic'. +-- +-- This means forgetting the answer of the LocImage, replacing it +-- with @()@. +-- +locGraphic_ :: LocImage u a -> LocGraphic u +locGraphic_ = (fmap . fmap) ignoreAns + + +-- | 'emptyLocGraphic' : @ LocGraphic @ +-- +-- Build an empty 'LocGraphic' (i.e. a function +-- /from Point to Graphic/). This is a path with a start point +-- but no path segments. +-- +-- The 'emptyLocGraphic' is treated as a /null primitive/ by +-- @Wumpus-Core@ and is not drawn, although it does generate a +-- minimum bounding box at the implicit start point. +-- +emptyLocGraphic :: InterpretUnit u => LocGraphic u +emptyLocGraphic = promoteR1 $ \pt -> + uconvertCtxF pt >>= \dpt -> + return $ graphicAns $ prim1 $ zostroke $ emptyPrimPath dpt + + + + + +-- | Use this to convert 'LocGraphic' or 'LocImage' with Functor +-- answer. +-- +uconvLocImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) + => LocImage u (t u) -> LocImage u1 (t u1) +uconvLocImageF = uconvR1 szconvAnsF + + + +-- | Use this to convert 'LocImage' with unit-less answer. +-- +uconvLocImageZ :: (InterpretUnit u, InterpretUnit u1) + => LocImage u a -> LocImage u1 a +uconvLocImageZ = uconvR1 szconvAnsZ + + + +-------------------------------------------------------------------------------- +-- Combining LocImages + +-- LocImages have no concept of /border/ or /next/, so they can +-- only be combined by manipulating the start point of successive +-- drawings. + +-- 'oplus' gives super-imposition - Locimages are drawn at the same +-- start point. + + + +distrib :: (Monoid a, InterpretUnit u) + => Vec2 u -> [LocImage u a] -> LocImage u a +distrib _ [] = pushR1 (replaceAns mempty) $ emptyLocGraphic +distrib v1 (x:xs) = promoteR1 $ \pt -> + go (x `at` pt) (pt .+^ v1) xs + where + go acc _ [] = acc + go acc pt (a:as) = go (acc `mappend` apply1R1 a pt) (pt .+^ v1) as + +distribH :: (Monoid a, InterpretUnit u) + => u -> [LocImage u a] -> LocImage u a +distribH dx = distrib (hvec dx) + +distribV :: (Monoid a, InterpretUnit u) + => u -> [LocImage u a] -> LocImage u a +distribV dy = distrib (hvec dy) + + + +-- | This is analogue to @replicate@ in the Prelude. +-- +duplicate :: (Monoid a, InterpretUnit u) + => Int -> Vec2 u -> LocImage u a -> LocImage u a +duplicate n _ _ | n < 1 = pushR1 (replaceAns mempty) $ emptyLocGraphic +duplicate n v img = go img v (n-1) + where + go acc _ i | i < 1 = acc + go acc va i = let img1 = moveStart (displaceVec va) img + in go (acc `mappend` img1) (va ^+^ v) (i-1) + +duplicateH :: (Monoid a, InterpretUnit u) + => Int -> u -> LocImage u a -> LocImage u a +duplicateH n dx = duplicate n (hvec dx) + +duplicateV :: (Monoid a, InterpretUnit u) + => Int -> u -> LocImage u a -> LocImage u a +duplicateV n dy = duplicate n (vvec dy) diff --git a/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs b/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/LocThetaImage.hs @@ -0,0 +1,367 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.LocThetaImage +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- LocThetaImage and LocThetaGraphic types - these are functional +-- types from the DrawingContext, start point and angle of +-- inclination to a graphic /primitive/. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.LocThetaImage + ( + LocThetaGraphic + , LocThetaImage + + , DLocThetaGraphic + , DLocThetaImage + + , intoLocThetaImage + , locThetaGraphic_ + + , emptyLocThetaGraphic + + , uconvLocThetaImageF + , uconvLocThetaImageZ + + + ) + + where + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Objects.Basis +-- import Wumpus.Basic.Kernel.Objects.Displacement +import Wumpus.Basic.Kernel.Objects.LocImage + +-- import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + +-- | 'LocThetaImage' - function from DrawingContext, start point +-- and inclination to a polymorphic /answer/ and a graphic +-- /primitive/ (ImageAns). +-- +-- The answer is expected to be a Functor. +-- +type LocThetaImage u a = LocThetaQuery u (ImageAns u a) + + +-- | LocThetaGraphic - function from DrawingContext, start point +-- and inclination to a graphic /primitive/ (GraphicAns). +-- +type LocThetaGraphic u = LocThetaQuery u (GraphicAns u) + + +-- | Type specialized version of 'LocThetaImage'. +-- +type DLocThetaImage a = LocThetaImage Double a + +-- | Type specialized version of 'LocThetaGraphic'. +-- +type DLocThetaGraphic = LocThetaGraphic Double + + + + +-- | 'intoLocThetaImage' : @ loc_theta_query * loc_theta_graphic -> LocThetaImage @ +-- +-- /LocTheta/ version of 'intoImage'. +-- +-- The 'LocThetaImage' is built as a function from an implicit +-- start point and angle of inclination to the answer. +-- +intoLocThetaImage :: LocThetaQuery u a + -> LocThetaGraphic u + -> LocThetaImage u a +intoLocThetaImage qf ma = + promoteR2 $ \a b -> replaceAns <$> apply2R2 qf a b <*> apply2R2 ma a b + + + +-- | /Downcast/ an 'LocThetaImage' to a 'LocThetaGraphic'. +-- +-- This means forgetting the answer of the Image, replacing it +-- with @()@. +-- +locThetaGraphic_ :: LocThetaImage u a -> LocThetaGraphic u +locThetaGraphic_ = (fmap . fmap . fmap) ignoreAns + + +-- | 'emptyLocThetaGraphic' : @ LocThetaGraphic @ +-- +-- Build an empty 'LocThetaGraphic' (i.e. a function +-- /from Point and Inclination to Graphic/). +-- +-- The 'emptyLocThetaGraphic' is treated as a /null primitive/ by +-- @Wumpus-Core@ and is not drawn, although it does generate a +-- minimum bounding box at the implicit start point. +-- +emptyLocThetaGraphic :: InterpretUnit u => LocThetaGraphic u +emptyLocThetaGraphic = lift1R2 emptyLocGraphic + + + + +-- | Use this to convert 'LocThetaGraphic' or 'LocThetaImage' +-- with Functor answer. +-- +uconvLocThetaImageF :: (InterpretUnit u, InterpretUnit u1, Functor t) + => LocThetaImage u (t u) -> LocThetaImage u1 (t u1) +uconvLocThetaImageF = uconvR2a szconvAnsF + + + +-- | Use this to convert 'LocThetaImage' with unit-less answer. +-- +uconvLocThetaImageZ :: (InterpretUnit u, InterpretUnit u1) + => LocThetaImage u a -> LocThetaImage u1 a +uconvLocThetaImageZ = uconvR2a szconvAnsZ + + + + +-------------------------------------------------------------------------------- +-- Combining LocThetaImages + +{- + +infixr 6 `catLTI` +infixr 5 `sepLTI` + +-- | Concatenate two LocThetaImages. The start point is /shared/. +-- +-- This is just @oplus@. +-- +catLTI :: OPlus (t u) + => LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u +catLTI = oplus + + + +-- | Concatenate two LocThetaImages, the second LocThetaImage is +-- displaced /orthonormally/ from the the start point by the +-- supplied vector (separator). +-- +-- Here, /orthonormally/ means that the x-component of the vector +-- displaces the second LocThetaImage in parallel to the angle +-- of inclination, the y-component of the vector displaces +-- perpendicular to the incliantion. +-- +-- Note - the separator is exactly a displacement of the start +-- point, LocImages have no notion of border so this function +-- can only be used to concatenate to objects side by side if +-- there boundaries are known beforehand. +-- +-- Consider a PosThetaImage if you need more sophisticated arrangement. +-- +sepLTI :: (Floating u, OPlus (t u)) + => Vec2 u -> LocThetaImage t u -> LocThetaImage t u + -> LocThetaImage t u +sepLTI v g1 g2 = g1 `oplus` moveStartTheta (displaceOrtho v) g2 + + + +-- | Concatenate two LocThetaImages, the second LocImage is +-- displaced parallel to the inclination by the supplied distance. +-- +-- Note - this is exactly a start point displacement. See the +-- caveat for 'sepLTI'. +-- +paraSepLTI :: (Floating u, OPlus (t u)) + => u -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u +paraSepLTI u = sepLTI (hvec u) + + + +-- | Concatenate two LocThetaImages, the second LocThetaImage is +-- displaced perpendicular to the inclination by the supplied +-- distance. +-- +-- Note - this is exactly a start point displacement. See the +-- caveat for 'sepLTI'. +-- +perpSepLTI :: (Floating u, OPlus (t u)) + => u -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u +perpSepLTI u = sepLTI (vvec u) + + +-- | Repeatedly draw a LocThetaImage, moving the start point each time +-- /orthonormally/ by the supplied vector. +-- +-- Note - the first LocThetaImage argument is the /empty/ alternative +-- this is drawn if the repeat count is less than 1. +-- +repeatLTI :: (Floating u, OPlus (t u)) + => LocThetaImage t u -> Int -> Vec2 u -> LocThetaImage t u + -> LocThetaImage t u +repeatLTI alt i _ _ | i < 1 = alt +repeatLTI _ i v gf = promoteR2 $ \start ang -> body start ang + where + body start ang = go (i-1) (drawF start) (moveF start) + where + drawF pt = atIncline gf pt ang + moveF pt = displaceOrtho v ang pt + go n acc pt | n < 1 = acc + | otherwise = go (n-1) (acc `oplus` drawF pt) (moveF pt) + + + +-- | Repeatedly draw a LocThetaImage, moving parallel to the +-- inclination each time by the supplied distance. +-- +-- Note - this draws the alternative LocThetaImage if the repeat count +-- is less than 1. +-- +paraRepeatLTI :: (Floating u, OPlus (t u)) + => LocThetaImage t u -> Int -> u -> LocThetaImage t u + -> LocThetaImage t u +paraRepeatLTI alt i u = repeatLTI alt i (hvec u) + + + +-- | Repeatedly draw a LocThetaImage, moving perpendicular to the +-- inclination each time by the supplied distance. +-- +-- Note - this draws the alternative LocThetaImage if the repeat count +-- is less than 1. +-- +perpRepeatLTI :: (Floating u, OPlus (t u)) + => LocThetaImage t u -> Int -> u -> LocThetaImage t u -> LocThetaImage t u +perpRepeatLTI alt i u = repeatLTI alt i (vvec u) + + + +-- | Concatenate a list of LocThetaImages, spacing them by moving +-- the start point /orthonormally/ each time by the supplied +-- vector. +-- +-- Note - this draws the /empty/ alternative if the list is empty. +-- +spaceLTI :: (Floating u, OPlus (t u)) + => LocThetaImage t u -> Vec2 u -> [LocThetaImage t u] + -> LocThetaImage t u +spaceLTI alt _ [] = alt +spaceLTI _ v (g:gs) = promoteR2 $ \start ang -> body start ang + where + body start ang = go (drawF g start) (moveF start) gs + where + drawF gf pt = atIncline gf pt ang + moveF pt = displaceOrtho v ang pt + go acc _ [] = acc + go acc pt (f:fs) = go (acc `oplus` drawF f pt) (moveF pt) fs + + + +-- | Concatenate a list of LocThetaImages, spacing them by moving +-- the start point parallel to the inclination each time by the +-- supplied distance. +-- +-- Note - this draws the /empty/ alternative if the list is empty. +-- +paraSpaceLTI :: (Floating u, OPlus (t u)) + => LocThetaImage t u -> u -> [LocThetaImage t u] + -> LocThetaImage t u +paraSpaceLTI alt u = spaceLTI alt (hvec u) + + +-- | Concatenate a list of LocThetaImages, spacing them by moving +-- the start point perpendicular to the inclination each time by +-- the supplied distance. +-- +-- Note - this draws the /empty/ alternative if the list is empty. +-- +perpSpaceLTI :: (Floating u, OPlus (t u)) + => LocThetaImage t u -> u -> [LocThetaImage t u] + -> LocThetaImage t u +perpSpaceLTI alt u = spaceLTI alt (vvec u) + + +-- | Enclose l r x +-- +-- Note - the @left@ LocThetaImage is drawn at the start point, the +-- LocThetaImage @x@ is concatenated with 'sepLTI' then the right +-- LocThetaImage is concatenated with 'sepLi'. +-- +encloseLTI :: (Floating u, OPlus (t u)) + => Vec2 u + -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u + -> LocThetaImage t u +encloseLTI v lft rht obj = lft `op` obj `op` rht + where + op = sepLTI v + + + +-- | Parallel version of 'encloseLTI'. +-- +-- Note - the @left@ LocThetaImage is drawn at the start point, the +-- LocThetaImage @x@ is concatenated with 'sepLTI' then the right +-- LocThetaImage is concatenated with 'sepLTI'. +-- +paraEncloseLTI :: (Floating u, OPlus (t u)) + => u + -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u + -> LocThetaImage t u +paraEncloseLTI u = encloseLTI (hvec u) + + + +-- | Perpendicular version of 'encloseLTI'. +-- +-- Note - the @left@ LocThetaImage is drawn at the start point, the +-- LocThetaImage @x@ is concatenated with 'sepLTI' then the right +-- LocThetaImage is concatenated with 'sepLTI'. +-- +perpEncloseLTI :: (Floating u, OPlus (t u)) + => u + -> LocThetaImage t u -> LocThetaImage t u -> LocThetaImage t u + -> LocThetaImage t u +perpEncloseLTI u = encloseLTI (vvec u) + + + +-- | Concatenate a list of LocThetaImages, punctuating with the +-- separator. +-- +-- Note - this draws the /empty/ alternative if the list is empty. +-- +punctuateLTI :: (Floating u, OPlus (t u)) + => LocThetaImage t u -> Vec2 u + -> LocThetaImage t u -> [LocThetaImage t u] + -> LocThetaImage t u +punctuateLTI alt _ _ [] = alt +punctuateLTI _ v sep (g:gs) = go g gs + where + go acc [] = acc + go acc (f:fs) = go (encloseLTI v acc f sep) fs + + +-- | Parallel version of 'punctuateLTI' +-- +paraPunctuateLTI :: (Floating u, OPlus (t u)) + => LocThetaImage t u -> u + -> LocThetaImage t u -> [LocThetaImage t u] + -> LocThetaImage t u +paraPunctuateLTI alt u = punctuateLTI alt (hvec u) + + +-- | Perpendicular version of 'punctuateLTI' +-- +perpPunctuateLTI :: (Floating u, OPlus (t u)) + => LocThetaImage t u -> u + -> LocThetaImage t u -> [LocThetaImage t u] + -> LocThetaImage t u +perpPunctuateLTI alt u = punctuateLTI alt (vvec u) + +-} diff --git a/src/Wumpus/Basic/Kernel/Objects/Orientation.hs b/src/Wumpus/Basic/Kernel/Objects/Orientation.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/Orientation.hs @@ -0,0 +1,500 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.Orientation +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Graphic objects RectAddress and Orientation to model +-- rectangular positioning. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.Orientation + ( + + + -- * Components + RectAddress(..) + , Orientation(..) + + , orientationStart + , orientationBounds + + , extendOrientation + , extendOLeft + , extendORight + , extendODown + , extendOUp + + , padHEven + , padXMinor + , padXMajor + , padVEven + , padYMajor + , padYMinor + + , spineRight + , spineBelow + + , halignBottomO + , halignCenterO + , halignTopO + , valignLeftO + , valignCenterO + , valignRightO + + , spinemoveH + , spinemoveV + , binmoveHBottom + , binmoveHCenter + , binmoveHTop + , binmoveVLeft + , binmoveVCenter + , binmoveVRight + + ) where + + +import Wumpus.Basic.Kernel.Base.BaseDefs + +import Wumpus.Core -- package: wumpus-core + +import Data.Monoid + +-- | Datatype enumerating the addressable positions of a rectangle +-- that can be derived for a 'PosObject'. +-- +data RectAddress = CENTER + | NN | SS | EE | WW | NE | NW | SE | SW + | BLL | BLC | BLR + deriving (Enum,Eq,Ord,Show) + + + + +-- | Utility datatype representing orientation within a +-- rectangular /frame/. RectPos is useful for graphics such as +-- text where the start point is not necessarily at the center +-- (or bottom left). +-- +-- > x_minor is the horizontal distance from the left to the start point +-- > +-- > x_major is the horizontal distance from the start point to the right +-- > +-- > y_minor is the vertical distance from the bottom to the start point +-- > +-- > y_major is the vertical distance from the start point to the top +-- +-- Values should be not be negative! +-- +-- +data Orientation u = Orientation + { or_x_minor :: !u + , or_x_major :: !u + , or_y_minor :: !u + , or_y_major :: !u + } + deriving (Eq,Ord,Show) + + + + +-------------------------------------------------------------------------------- + +instance Functor Orientation where + fmap f (Orientation xmin xmaj ymin ymaj) = + Orientation (f xmin) (f xmaj) (f ymin) (f ymaj) + +instance (Fractional u, Ord u) => OPlus (Orientation u) where + oplus = concatOrientation + + +instance (Fractional u, Ord u) => Monoid (Orientation u) where + mempty = Orientation 0 0 0 0 + mappend = concatOrientation + +-- | Concatenation here essentially turns both Orientation objects +-- into /center-form/ then finds the maximum rectangle. +-- +concatOrientation :: (Fractional u, Ord u) + => Orientation u -> Orientation u -> Orientation u +concatOrientation op0 op1 = Orientation hw hw hh hh + where + (hw0,hh0) = halfDists op0 + (hw1,hh1) = halfDists op1 + hw = max hw0 hw1 + hh = max hh0 hh1 + + + + +-- | Find the half-width and half-height of an Orientation. +-- +-- Essentially this is /center-form/ of an Orientation, but +-- in /center-form/ there is duplication: +-- +-- > xminor == xmajor +-- > yminor == ymajor +-- +-- So instead, the result type is just a pair. +-- +halfDists :: Fractional u => Orientation u -> (u,u) +{-# INLINE halfDists #-} +halfDists (Orientation xmin xmaj ymin ymaj) = + (0.5 * (xmin+xmaj), 0.5 * (ymin+ymaj)) + + + + + +-- | The vector from a 'RectAddress' to the start point. +-- +orientationStart :: Fractional u => RectAddress -> Orientation u -> Vec2 u +orientationStart rpos (Orientation xmin xmaj ymin ymaj) = go rpos + where + w = xmin + xmaj + h = ymin + ymaj + hw = 0.5 * w + hh = 0.5 * h + + -- CENTER, NN, SS, EE, WW all go to bottomleft then add back + -- the minors. + + go CENTER = V2 ((-hw) + xmin) ((-hh) + ymin) + go NN = V2 ((-hw) + xmin) ((-h) + ymin) + go SS = V2 ((-hw) + xmin) ymin + go EE = V2 ((-w) + xmin) ((-hh) + ymin) + go WW = V2 xmin ((-hh) + ymin) + go NE = V2 (-xmaj) (-ymaj) + go SE = V2 (-xmaj) ymin + go SW = V2 xmin ymin + go NW = V2 xmin (-ymaj) + go BLL = V2 xmin 0 + go BLC = V2 ((-hw) + xmin) 0 + go BLR = V2 ((-w) + xmin) 0 + + +-- | Calculate the bounding box formed by locating the 'Orientation' +-- at the supplied point. +-- +orientationBounds :: Num u + => Orientation u -> Point2 u -> BoundingBox u +orientationBounds (Orientation xmin xmaj ymin ymaj) (P2 x y) = BBox llc urc + where + llc = P2 (x-xmin) (y-ymin) + urc = P2 (x+xmaj) (y+ymaj) + + +-------------------------------------------------------------------------------- +-- Extending an arm of the orientation + +extendOrientation :: Num u + => u -> u -> u -> u -> Orientation u -> Orientation u +extendOrientation dxl dxr dyd dyu (Orientation xmin xmaj ymin ymaj) = + Orientation (xmin+dxl) (xmaj+dxr) (ymin+dyd) (ymaj+dyu) + +extendOLeft :: Num u => u -> Orientation u -> Orientation u +extendOLeft u (Orientation xmin xmaj ymin ymaj) = + Orientation (u+xmin) xmaj ymin ymaj + + +extendORight :: Num u => u -> Orientation u -> Orientation u +extendORight u (Orientation xmin xmaj ymin ymaj) = + Orientation xmin (u+xmaj) ymin ymaj + +extendODown :: Num u => u -> Orientation u -> Orientation u +extendODown u (Orientation xmin xmaj ymin ymaj) = + Orientation xmin xmaj (u+ymin) ymaj + +extendOUp :: Num u => u -> Orientation u -> Orientation u +extendOUp u (Orientation xmin xmaj ymin ymaj) = + Orientation xmin xmaj ymin (u+ymaj) + + +-------------------------------------------------------------------------------- + +padHEven :: (Fractional u, Ord u) + => u -> Orientation u -> Orientation u +padHEven w ortt@(Orientation xmin xmaj _ _) = + if w > ow then ortt { or_x_minor = xmin + hdx + , or_x_major = xmaj + hdx } + else ortt + where + ow = xmin + xmaj + hdx = 0.5 * (w - ow) + + +padXMinor :: (Num u, Ord u) + => u -> Orientation u -> Orientation u +padXMinor w ortt@(Orientation xmin xmaj _ _) = + if w > ow then ortt { or_x_minor = xmin + dx } else ortt + where + ow = xmin + xmaj + dx = w - ow + +padXMajor :: (Num u, Ord u) + => u -> Orientation u -> Orientation u +padXMajor w ortt@(Orientation xmin xmaj _ _) = + if w > ow then ortt { or_x_major = xmaj + dx } else ortt + where + ow = xmin + xmaj + dx = w - ow + +padVEven :: (Fractional u, Ord u) + => u -> Orientation u -> Orientation u +padVEven h ortt@(Orientation _ _ ymin ymaj) = + if h > oh then ortt { or_y_minor = ymin + hdy + , or_y_major = ymaj + hdy } + else ortt + where + oh = ymin + ymaj + hdy = 0.5 * (h - oh) + +padYMinor :: (Num u, Ord u) + => u -> Orientation u -> Orientation u +padYMinor h ortt@(Orientation _ _ ymin ymaj) = + if h > oh then ortt { or_y_minor = ymin + dy } else ortt + where + oh = ymin + ymaj + dy = h - oh + + +padYMajor :: (Num u, Ord u) + => u -> Orientation u -> Orientation u +padYMajor h ortt@(Orientation _ _ ymin ymaj) = + if h > oh then ortt { or_y_major = ymaj + dy } else ortt + where + oh = ymin + ymaj + dy = h - oh + + +-------------------------------------------------------------------------------- +-- Combining Orientation + +-- Note - there are lots of concatenations (due to alignment) +-- we need a consistent name scheme... + + +-- | Second Orientation is moved /to the right/ of the first along +-- the /spine/ i.e the baseline. +-- +spineRight :: (Num u, Ord u) + => Orientation u -> Orientation u -> Orientation u +spineRight (Orientation xmin0 xmaj0 ymin0 ymaj0) + (Orientation xmin1 xmaj1 ymin1 ymaj1) = + Orientation { or_x_minor = xmin0 + , or_x_major = xmaj0 + xmin1 + xmaj1 + , or_y_minor = max ymin0 ymin1 + , or_y_major = max ymaj0 ymaj1 + } + + +-- | Second Orientation is moved /below/ the first along the spine +-- i.e. the vertical point between the left minor and right major +-- (not the same as the horizontal center). +-- +spineBelow :: (Num u, Ord u) + => Orientation u -> Orientation u -> Orientation u +spineBelow (Orientation xmin0 xmaj0 ymin0 ymaj0) + (Orientation xmin1 xmaj1 ymin1 ymaj1) = + Orientation { or_x_minor = max xmin0 xmin1 + , or_x_major = max xmaj0 xmaj1 + , or_y_minor = ymin0 + ymaj1 + ymin1 + , or_y_major = ymaj0 + } + + +-- | xmin and xmaj same as left. +-- +halignBottomO :: (Num u, Ord u) + => Orientation u -> Orientation u -> Orientation u +halignBottomO (Orientation xmin0 xmaj0 ymin0 ymaj0) + (Orientation xmin1 xmaj1 ymin1 ymaj1) = + let hr = ymin1 + ymaj1 + in Orientation { or_x_minor = xmin0 + , or_x_major = xmaj0 + xmin1 + xmaj1 + , or_y_minor = ymin0 + , or_y_major = max ymaj0 (hr - ymin0) + } + + + + + +-- | xmin same as left. +-- +halignCenterO :: (Fractional u, Ord u) + => Orientation u -> Orientation u -> Orientation u +halignCenterO (Orientation xmin0 xmaj0 ymin0 ymaj0) + (Orientation xmin1 xmaj1 ymin1 ymaj1) = + let hl = ymin0 + ymaj0 + hr = ymin1 + ymaj1 + half_diff = 0.5 * (hr - hl) + in Orientation + { or_x_minor = xmin0 + , or_x_major = xmaj0 + xmin1 + xmaj1 + , or_y_minor = if hl >= hr then ymin0 else (ymin0 + half_diff) + , or_y_major = if hl >= hr then ymaj0 else (ymaj0 + half_diff) + } + + + +-- | xmin and ymaj same as left. +-- +halignTopO :: (Num u, Ord u) + => Orientation u -> Orientation u -> Orientation u +halignTopO (Orientation xmin0 xmaj0 ymin0 ymaj0) + (Orientation xmin1 xmaj1 ymin1 ymaj1) = + let hr = ymin1 + ymaj1 + in Orientation { or_x_minor = xmin0 + , or_x_major = xmaj0 + xmin1 + xmaj1 + , or_y_minor = max ymin0 (hr - ymaj0) + , or_y_major = ymaj0 + } + +-- | Align second below - xmin and ymaj are same as left. +-- +valignLeftO :: (Fractional u, Ord u) + => Orientation u -> Orientation u -> Orientation u +valignLeftO (Orientation xmin0 xmaj0 ymin0 ymaj0) + (Orientation xmin1 xmaj1 ymin1 ymaj1) = + let wr = xmin1 + xmaj1 + in Orientation { or_x_minor = xmin0 + , or_x_major = max xmaj0 (wr - xmin0) + , or_y_minor = ymin0 + ymin1 + ymaj1 + , or_y_major = ymaj0 + } + + + +-- | Align second below - ymaj same as left. +-- +valignCenterO :: (Fractional u, Ord u) + => Orientation u -> Orientation u -> Orientation u +valignCenterO (Orientation xmin0 xmaj0 ymin0 ymaj0) + (Orientation xmin1 xmaj1 ymin1 ymaj1) = + let wl = xmin0 + xmaj0 + wr = xmin1 + xmaj1 + half_diff = 0.5 * (wr - wl) + in Orientation + { or_x_minor = if wl >= wr then xmin0 else (xmin0 + half_diff) + , or_x_major = if wl >= wr then xmaj0 else (xmaj0 + half_diff) + , or_y_minor = ymin0 + ymin1 + ymaj1 + , or_y_major = ymaj0 + } + + +-- | Align second below - xmaj and ymaj are same as left. +-- +valignRightO :: (Fractional u, Ord u) + => Orientation u -> Orientation u -> Orientation u +valignRightO (Orientation xmin0 xmaj0 ymin0 ymaj0) + (Orientation xmin1 xmaj1 ymin1 ymaj1) = + let wr = xmin1 + xmaj1 + in Orientation { or_x_minor = max xmin0 (wr - xmaj0) + , or_x_major = xmaj0 + , or_y_minor = ymin0 + ymin1 + ymaj1 + , or_y_major = ymaj0 + } + + +-------------------------------------------------------------------------------- +-- Binary start pos displacement + +upDown :: Num u => u -> u -> u +{-# INLINE upDown #-} +upDown u d = u - d + +downUp :: Num u => u -> u -> u +{-# INLINE downUp #-} +downUp d u = negate d + u + +-- | Move second right. +-- +spinemoveH :: Num u => Orientation u -> Orientation u -> Vec2 u +spinemoveH op0 op1 = V2 hdist 0 + where + hdist = or_x_major op0 + or_x_minor op1 + +-- | Move second below. +-- +spinemoveV :: Num u => Orientation u -> Orientation u -> Vec2 u +spinemoveV op0 op1 = V2 0 (negate vdist) + where + vdist = or_y_minor op0 + or_y_major op1 + + + +binmoveHBottom :: Num u => Orientation u -> Orientation u -> Vec2 u +binmoveHBottom op0 op1 = V2 hdist vdist + where + hdist = or_x_major op0 + or_x_minor op1 + vdist = downUp (or_y_minor op0) (or_y_minor op1) + + +binmoveHCenter :: (Fractional u, Ord u) + => Orientation u -> Orientation u -> Vec2 u +binmoveHCenter (Orientation _ xmaj0 ymin0 ymaj0) + (Orientation xmin1 _ ymin1 ymaj1) = + V2 hdist vdist + where + h0 = ymin0 + ymaj0 + h1 = ymin1 + ymaj1 + half_diff = abs $ 0.5 * (h1 - h0) + hdist = xmaj0 + xmin1 + vdist = if h0 >= h1 then downUp ymin0 (half_diff + ymin1) + else upDown (ymaj0 + half_diff) ymaj1 + + + +binmoveHTop :: Num u => Orientation u -> Orientation u -> Vec2 u +binmoveHTop op0 op1 = V2 hdist vdist + where + hdist = or_x_major op0 + or_x_minor op1 + vdist = upDown (or_y_major op0) (or_y_major op1) + + +leftRight :: Num u => u -> u -> u +{-# INLINE leftRight #-} +leftRight l r = negate l + r + + +rightLeft :: Num u => u -> u -> u +{-# INLINE rightLeft #-} +rightLeft r l = r - l + + +binmoveVLeft :: Num u => Orientation u -> Orientation u -> Vec2 u +binmoveVLeft op0 op1 = V2 hdist vdist + where + hdist = leftRight (or_x_minor op0) (or_x_minor op1) + vdist = negate $ or_y_minor op0 + or_y_major op1 + + +binmoveVCenter :: (Fractional u, Ord u) + => Orientation u -> Orientation u -> Vec2 u +binmoveVCenter (Orientation xmin0 xmaj0 ymin0 _) + (Orientation xmin1 xmaj1 _ ymaj1) = + V2 hdist vdist + where + w0 = xmin0 + xmaj0 + w1 = xmin1 + xmaj1 + half_diff = abs $ 0.5 * (w1 - w0) + hdist = if w0 >= w1 then leftRight xmin0 (half_diff + xmin1) + else rightLeft (xmaj0 + half_diff) xmaj1 + vdist = negate $ ymin0 + ymaj1 + + + +binmoveVRight :: Num u => Orientation u -> Orientation u -> Vec2 u +binmoveVRight op0 op1 = V2 hdist vdist + where + hdist = rightLeft (or_x_major op0) (or_x_major op1) + vdist = negate $ or_y_minor op0 + or_y_major op1 + diff --git a/src/Wumpus/Basic/Kernel/Objects/PosImage.hs b/src/Wumpus/Basic/Kernel/Objects/PosImage.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Kernel/Objects/PosImage.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Kernel.Objects.PosImage --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : stephen.tetley@gmail.com --- Stability : highly unstable --- Portability : GHC --- --- Extended Graphic object - a rectangular /positionable/ Image. --- --- This graphic object has a more flexible API for positioning --- than other graphic objects. Rather than a LocGraphic which --- supports a single method of positioning at some start-point, --- a @PosGraphic@ can be drawn at its center or locations on its --- outer rectangle. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.Kernel.Objects.PosImage - ( - - RectPosition(..) - , ObjectPos(..) - - -- * Positionable image - - , PosImage - , DPosImage - - , PosGraphic - , DPosGraphic - - , makePosImage - - , startPos - , atStartPos - - , objectPosBounds - - ) where - - -import Wumpus.Basic.Kernel.Base.BaseDefs -import Wumpus.Basic.Kernel.Base.ContextFun -import Wumpus.Basic.Kernel.Objects.BaseObjects -import Wumpus.Basic.Kernel.Objects.Displacement - -import Wumpus.Core -- package: wumpus-core - -import Data.AffineSpace -- package: vector-space - --- | Datatype enumerating positions within a rectangle that can be --- derived for a 'PosGraphic'. --- -data RectPosition = CENTER | NN | SS | EE | WW | NE | NW | SE | SW - deriving (Enum,Eq,Ord,Show) - - --- | Utility datatype representing orientation within a --- rectangular /frame/. ObjectPos is useful for graphics such as --- text where the start point is not necessarily at the center --- (or bottom left). --- --- > x_minor is the horizontal distance from the left to the start point --- > --- > x_major is the horizontal distance from the start point to the right --- > --- > y_minor is the vertical distance from the bottom to the start point --- > --- > y_major is the vertical distance from the start point to the top --- --- Values should be not be negative! --- --- -data ObjectPos u = ObjectPos - { op_x_minor :: !u - , op_x_major :: !u - , op_y_minor :: !u - , op_y_major :: !u - } - deriving (Eq,Ord,Show) - - - -type instance DUnit (ObjectPos u) = u - - - --- | A positionable Image. --- -type PosImage u a = CF2 (Point2 u) RectPosition (ImageAns u a) - --- | Version of PosImage specialized to Double for the unit type. --- -type DPosImage a = PosImage Double a - - - --- | A positionable Graphic. --- -type PosGraphic u = PosImage u (UNil u) - --- | Version of PosGraphic specialized to Double for the unit type. --- -type DPosGraphic = PosGraphic Double - - - - - - --------------------------------------------------------------------------------- - - -instance (Fractional u, Ord u) => OPlus (ObjectPos u) where - oplus = concatObjectPos - - --- | Concatenation here essentially turns both ObjectPos objects --- into /center-form/ then finds the maximum rectangle. --- -concatObjectPos :: (Fractional u, Ord u) - => ObjectPos u -> ObjectPos u -> ObjectPos u -concatObjectPos op0 op1 = ObjectPos hw hw hh hh - where - (hw0,hh0) = halfDists op0 - (hw1,hh1) = halfDists op1 - hw = max hw0 hw1 - hh = max hh0 hh1 - - - --------------------------------------------------------------------------------- - - --- | Find the half-width and half-height of an ObjectPos. --- --- Essentially this is /center-form/ of an ObjectPos, but --- in /center-form/ there is duplication: --- --- > xminor == xmajor --- > yminor == ymajor --- --- So instead, the result type is just a pair. --- -halfDists :: Fractional u => ObjectPos u -> (u,u) -halfDists (ObjectPos xmin xmaj ymin ymaj) = - (0.5 * (xmin+xmaj), 0.5 * (ymin+ymaj)) - - --- | 'makePosImage' : @ object_pos * loc_graphic -> PosGraphic @ --- --- Create a 'PosImage' from an 'ObjectPos' describing how it --- is orientated within a border rectangle and a 'LocImage' that --- draws it. --- -makePosImage :: Fractional u - => ObjectPos u -> LocImage u a -> PosImage u a -makePosImage opos gf = promoteR2 $ \start rpos -> - let v1 = startVector rpos opos in gf `at` displaceVec v1 start - - - -infixr 1 `startPos` - --- | 'startPos' : @ pos_image * rect_pos -> LocImage @ --- --- /Downcast/ a 'PosImage' to a 'LocImage' by supplying it --- with a 'RectPosition' (start position). --- -startPos :: Floating u - => PosImage u a -> RectPosition -> LocImage u a -startPos = apply1R2 - --- | 'atStartPos' : @ pos_image * start_point * rect_pos -> LocImage @ --- --- /Downcast/ a 'PosGraphic' to an 'Image' by supplying it --- with an initial point and a 'RectPosition' (start position). --- -atStartPos :: Floating u - => PosImage u a -> Point2 u -> RectPosition -> Image u a -atStartPos = apply2R2 - --- | The vector from some Rectangle position to the start point. --- -startVector :: Fractional u => RectPosition -> ObjectPos u -> Vec2 u -startVector rpos (ObjectPos xminor xmajor yminor ymajor) = go rpos - where - w = xminor + xmajor - h = yminor + ymajor - hw = 0.5 * w - hh = 0.5 * h - - -- CENTER, NN, SS, EE, WW all go to bottomleft then add back - -- the minors. - - go CENTER = V2 ((-hw) + xminor) ((-hh) + yminor) - go NN = V2 ((-hw) + xminor) ((-h) + yminor) - go SS = V2 ((-hw) + xminor) yminor - go EE = V2 ((-w) + xminor) ((-hh) + yminor) - go WW = V2 xminor ((-hh) + yminor) - go NE = V2 (-xmajor) (-ymajor) - go SE = V2 (-xmajor) yminor - go SW = V2 xminor yminor - go NW = V2 xminor (-ymajor) - - - --- | Calculate the bounding box formed by locating the 'ObjectPos' --- at the supplied point. --- -objectPosBounds :: Fractional u - => Point2 u -> RectPosition -> ObjectPos u -> BoundingBox u -objectPosBounds (P2 x y) pos (ObjectPos xmin xmaj ymin ymaj) = go pos - where - w = xmin + xmaj - h = ymin + ymaj - hw = 0.5 * w - hh = 0.5 * h - bbox = \bl -> BBox bl (bl .+^ vec w h) - - go CENTER = bbox $ P2 (x-hw) (y-hh) - go NN = bbox $ P2 (x-hw) (y-h) - go SS = bbox $ P2 (x-hw) y - go EE = bbox $ P2 (x-w) (y-hh) - go WW = bbox $ P2 x (y-hh) - go NE = bbox $ P2 (x-w) (y-h) - go SE = bbox $ P2 (x-w) y - go SW = bbox $ P2 x y - go NW = bbox $ P2 x (y-h) - - diff --git a/src/Wumpus/Basic/Kernel/Objects/PosObject.hs b/src/Wumpus/Basic/Kernel/Objects/PosObject.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/Kernel/Objects/PosObject.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.Kernel.Objects.PosObject +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Extended Graphic object - a rectangular /positionable/ Image. +-- +-- This graphic object has a more flexible API for positioning +-- than other graphic objects. Rather than a LocGraphic which +-- supports a single method of positioning at some start-point, +-- a @PosGraphic@ can be drawn at its center or locations on its +-- outer rectangle. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.Kernel.Objects.PosObject + ( + + -- * Positionable image + + PosObject + , DPosObject + + , LocRectQuery + , BoundedLocRectGraphic + + -- * Operations + + , makePosObject + , makeBindPosObject + , emptyPosObject + , runPosObjectR0 + , runPosObjectR1 + , runPosObjectR2 + + + , localizePO + , elaboratePO + , aelaboratePO + + , startAddr + , atStartAddr + + , extendPosObject + + , padHorizontalPO + , padLeftPO + , padRightPO + , padVerticalPO + , padUpPO + , padDownPO + + , illustratePosObject + + + ) where + + +import Wumpus.Basic.Kernel.Base.BaseDefs +import Wumpus.Basic.Kernel.Base.ContextFun +import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Base.QueryDC +import Wumpus.Basic.Kernel.Base.UpdateDC +import Wumpus.Basic.Kernel.Objects.Basis +import Wumpus.Basic.Kernel.Objects.Bounded +import Wumpus.Basic.Kernel.Objects.Concat +import Wumpus.Basic.Kernel.Objects.DrawingPrimitives +import Wumpus.Basic.Kernel.Objects.Displacement +import Wumpus.Basic.Kernel.Objects.LocImage +import Wumpus.Basic.Kernel.Objects.Orientation + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Colour ( red, blue ) + +import Data.AffineSpace -- package: vector-space +import Data.VectorSpace + +import Control.Applicative +import Data.Monoid + + +-- | Helper for PosObject - a LocImage that is /pre-applied/ to +-- the DrawingContext. +-- +-- This is somewhat contrived, but the orientation and the result +-- graphic from a PosImage have to be generated within the same +-- DrawingContext. +-- +type PosDraw u = Point2 u -> GraphicAns u + + +-- | A positionable \"Object\" that is drawn as a +-- 'BoundedLocGraphic'. +-- +newtype PosObject u = PosObject + { getPosObject :: CF (Orientation u, PosDraw u) } + +type instance DUnit (PosObject u) = u + +-- | Version of PosObject specialized to Double for the unit type. +-- +type DPosObject = PosObject Double + + + + +type LocRectQuery u a = CF (Point2 u -> RectAddress -> a) + +type BoundedLocRectGraphic u = LocRectQuery u (ImageAns u (BoundingBox u)) + +-------------------------------------------------------------------------------- + + +instance (Fractional u, Ord u) => OPlus (PosObject u) where + oplus = poconcat + +instance (Fractional u, Ord u, InterpretUnit u) => Monoid (PosObject u) where + mempty = pozero + mappend = poconcat + + +pozero :: InterpretUnit u => PosObject u +pozero = PosObject body + where + body = drawingCtx >>= \ctx -> + let pf = \pt -> runCF ctx (apply1R1 emptyLocGraphic pt) + in return (Orientation 0 0 0 0, pf) + +poconcat :: (Fractional u, Ord u) => PosObject u -> PosObject u -> PosObject u +poconcat a b = PosObject body + where + body = drawingCtx >>= \ctx -> + let (o0,pf0) = runCF ctx (getPosObject a) + (o1,pf1) = runCF ctx (getPosObject b) + pf = \pt -> pf0 pt `oplus` pf1 pt + in return (o0 `oplus` o1, pf) + + +-- | 'makePosObject' : @ object_pos * loc_image -> PosObject @ +-- +-- Create a 'PosObject' from an 'Orientation' describing how it +-- is orientated within a border rectangle and a 'LocImage' that +-- draws it. +-- +-- This is the /primary/ constructor for PosObjects. Because the +-- PosObject type is considered as a specialized object it does +-- not have the range of functions of LocImage or LocThetaImage. +-- +makePosObject :: Query (Orientation u) -> LocGraphic u -> PosObject u +makePosObject qortt gf = PosObject body + where + body = drawingCtx >>= \ctx -> + let ortt = runCF ctx qortt + pf = runCF ctx gf + in return (ortt,pf) + + +-- | This is a bit of a hack to overcome that the newtype +-- wrapper around PosObject stops monadic bind operating +-- with the internal CF function. +-- +makeBindPosObject :: Query a + -> (a -> Query (Orientation u)) -> (a -> LocGraphic u) + -> PosObject u +makeBindPosObject qy mkO mkG = PosObject body + where + body = drawingCtx >>= \ctx -> + let a = runCF ctx qy + ortt = runCF ctx (mkO a) + pf = runCF ctx (mkG a) + in return (ortt,pf) + + + +-- | 'emptyPosObject' : @ PosObject @ +-- +-- Build an empty 'PosGraphicObject'. +-- +emptyPosObject :: InterpretUnit u => PosObject u +emptyPosObject = + makePosObject (pure $ Orientation 0 0 0 0) emptyLocGraphic + + +-- | Run a PosObject forming an Image (an /arity zero/ answer). +-- +runPosObjectR0 :: Fractional u + => Point2 u -> RectAddress -> PosObject u -> BoundedGraphic u +runPosObjectR0 pt addr (PosObject mf) = + mf >>= \(ortt,ptf) -> let sv = orientationStart addr ortt + bb = orientationBounds ortt (displaceVec sv pt) + in pure $ replaceAns bb $ ptf $ displaceVec sv pt + + + +-- | Version of 'runPosObject' that produces a +-- 'BoundedLocGraphic'. +-- +-- The 'PosObject' is run with only rect-address as an explicit +-- argument (start-point is implicit). The corresponding answer is +-- an /arity one/ Graphic that needs drawing with the start-point. +-- +runPosObjectR1 :: Fractional u + => RectAddress -> PosObject u -> BoundedLocGraphic u +runPosObjectR1 addr obj = promoteR1 $ \start -> runPosObjectR0 start addr obj + + +-- | Version of 'runPosObject' that produces a +-- 'BoundedLocRectGraphic'. +-- +-- The 'PosObject' is run with no explicit arguments (rect-address +-- or start-point) so the corresponding answer is an /arity two/ +-- Graphic that needs drawing with the start-point and +-- rect-address. +-- +runPosObjectR2 :: Fractional u + => PosObject u -> BoundedLocRectGraphic u +runPosObjectR2 obj = promoteR2 $ \start addr -> runPosObjectR0 start addr obj + + + +-- | Run a DrawingContext update within a 'PosObject'. +-- +localizePO :: DrawingContextF -> PosObject u -> PosObject u +localizePO upd = PosObject . localize upd . getPosObject + + +-- | 'decorate' -like functionality. +-- +elaboratePO :: (Orientation u -> LocGraphic u) -> PosObject u -> PosObject u +elaboratePO fn po = PosObject body + where + body = drawingCtx >>= \ctx -> + let (ortt,ptf) = runCF ctx (getPosObject po) + deco = runCF ctx (fn ortt) + in return (ortt, ptf `oplus` deco) + +-- | ante-eloborate +-- +aelaboratePO :: (Orientation u -> LocGraphic u) -> PosObject u -> PosObject u +aelaboratePO fn po = PosObject body + where + body = drawingCtx >>= \ctx -> + let (ortt,ptf) = runCF ctx (getPosObject po) + deco = runCF ctx (fn ortt) + in return (ortt, deco `oplus` ptf) + + + + + +infixr 1 `startAddr` + +-- | 'startAddr' : @ bounded_loc_rect * rect_pos -> BoundedlocGraphic @ +-- +-- /Downcast/ a 'BoundedLocRectGraphic' to a 'BoundedLocGraphic' +-- by supplying it with a 'RectAddress' (start address on the +-- rectangle frame). +-- +startAddr :: Floating u + => BoundedLocRectGraphic u -> RectAddress -> BoundedLocGraphic u +startAddr = apply1R2 + + + +-- | 'atStartAddr' : @ bounded_loc_rect * start_point * rect_pos +-- -> BoundedGraphic @ +-- +-- /Downcast/ a 'BoundedLocRectGraphic' to a 'BoundedGraphic' by +-- supplying it with an initial point and a 'RectAddress' (start +-- address on the rectangle frame). +-- +atStartAddr :: Floating u + => BoundedLocRectGraphic u -> Point2 u -> RectAddress + -> BoundedGraphic u +atStartAddr = apply2R2 + + + +-- | Extend the orientation. +-- +extendPosObject :: Num u + => u -> u -> u -> u -> PosObject u -> PosObject u +extendPosObject x0 x1 y0 y1 po = PosObject body + where + body = drawingCtx >>= \ctx -> + let (o0,pf0) = runCF ctx (getPosObject po) + ortt = extendOrientation x0 x1 y0 y1 o0 + in return (ortt,pf0) + + +-------------------------------------------------------------------------------- +-- Padding + +padHorizontalPO :: (Fractional u, Ord u) => u -> PosObject u -> PosObject u +padHorizontalPO w = genPad (padHEven w) + +padLeftPO :: (Num u, Ord u) => u -> PosObject u -> PosObject u +padLeftPO w = genPad (padXMinor w) + +padRightPO :: (Num u, Ord u) => u -> PosObject u -> PosObject u +padRightPO w = genPad (padXMajor w) + + +padVerticalPO :: (Fractional u, Ord u) => u -> PosObject u -> PosObject u +padVerticalPO w = genPad (padVEven w) + +padUpPO :: (Num u, Ord u) => u -> PosObject u -> PosObject u +padUpPO h = genPad (padYMajor h) + +padDownPO :: (Num u, Ord u) => u -> PosObject u -> PosObject u +padDownPO h = genPad (padYMinor h) + + +genPad :: (Orientation u -> Orientation u) -> PosObject u -> PosObject u +genPad fn po = PosObject body + where + body = drawingCtx >>= \ctx -> + let (o0,pf0) = runCF ctx (getPosObject po) + ortt = fn o0 + in return (ortt,pf0) + + +-------------------------------------------------------------------------------- + + +-- | Illustrate a 'PosObject' by super-imposing its 'Orientation'. +-- +-- This turns the 'PosObject' into a 'LocImage' drawn at the locus +-- of the PosObject. +-- +illustratePosObject :: InterpretUnit u + => PosObject u -> LocGraphic u +illustratePosObject (PosObject mf) = promoteR1 $ \pt -> + mf >>= \(ortt,ptf) -> + decorateR0 (pure $ ptf pt) (illustrateOrientation ortt `at` pt) + + +illustrateOrientation :: InterpretUnit u + => Orientation u -> LocGraphic u +illustrateOrientation (Orientation xmin xmaj ymin ymaj) = promoteR1 $ \pt -> + dinterpCtx 3 >>= \radius -> + let upd = localize (fill_colour blue . dotted_line) + bl = pt .-^ V2 xmin ymin + dot = localize (fill_colour red) $ filledDisk radius `at` pt + hln = upd $ locStraightLine (hvec $ xmin+xmaj) `at` pt .-^ hvec xmin + vln = upd $ locStraightLine (vvec $ ymin+ymaj) `at` pt .-^ vvec ymin + bdr = upd $ strokedRectangle (xmin+xmaj) (ymin+ymaj) `at` bl + in bdr `oplus` hln `oplus` vln `oplus` dot + + +-------------------------------------------------------------------------------- +-- Combining PosObject + + +instance (Fractional u, Ord u) => ZConcat (PosObject u) where + superior = oplus + anterior = flip oplus + + +instance (Num u, Ord u) => Concat (PosObject u) where + hconcat = genMoveAlign spinemoveH spineRight + vconcat = genMoveAlign spinemoveV spineBelow + +instance (Num u, Ord u) => CatSpace (PosObject u) where + hspace = genMoveSepH spinemoveH spineRight + vspace = genMoveSepV spinemoveV spineBelow + + + +instance (Fractional u, Ord u) => Align (PosObject u) where + halign HTop = genMoveAlign binmoveHTop halignTopO + halign HCenter = genMoveAlign binmoveHCenter halignCenterO + halign HBottom = genMoveAlign binmoveHBottom halignBottomO + + valign VLeft = genMoveAlign binmoveVLeft valignLeftO + valign VCenter = genMoveAlign binmoveVCenter valignCenterO + valign VRight = genMoveAlign binmoveVRight valignRightO + + + +genMoveAlign :: (Num u) + => (Orientation u -> Orientation u -> Vec2 u) + -> (Orientation u -> Orientation u -> Orientation u) + -> PosObject u -> PosObject u -> PosObject u +genMoveAlign mkV mkO po0 po1 = PosObject body + where + body = drawingCtx >>= \ctx -> + let (ortt0,pf0) = runCF ctx (getPosObject po0) + (ortt1,pf1) = runCF ctx (getPosObject po1) + v1 = mkV ortt0 ortt1 + ortt = mkO ortt0 ortt1 + pf = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1) + in return (ortt,pf) + + +-------------------------------------------------------------------------------- +-- Sep + +instance (Fractional u, Ord u) => AlignSpace (PosObject u) where + halignSpace HTop = genMoveSepH binmoveHTop halignTopO + halignSpace HCenter = genMoveSepH binmoveHCenter halignCenterO + halignSpace HBottom = genMoveSepH binmoveHBottom halignBottomO + + valignSpace VLeft = genMoveSepV binmoveVLeft valignLeftO + valignSpace VCenter = genMoveSepV binmoveVCenter valignCenterO + valignSpace VRight = genMoveSepV binmoveVRight valignRightO + + +genMoveSepH :: (Num u) + => (Orientation u -> Orientation u -> Vec2 u) + -> (Orientation u -> Orientation u -> Orientation u) + -> u + -> PosObject u -> PosObject u -> PosObject u +genMoveSepH mkV mkO sep po0 po1 = PosObject body + where + body = drawingCtx >>= \ctx -> + let (ortt0,pf0) = runCF ctx (getPosObject po0) + (ortt1,pf1) = runCF ctx (getPosObject po1) + v1 = hvec sep ^+^ mkV ortt0 ortt1 + ortt = extendORight sep $ mkO ortt0 ortt1 + pf = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1) + in return (ortt,pf) + + +genMoveSepV :: (Num u) + => (Orientation u -> Orientation u -> Vec2 u) + -> (Orientation u -> Orientation u -> Orientation u) + -> u + -> PosObject u -> PosObject u -> PosObject u +genMoveSepV mkV mkO sep po0 po1 = PosObject body + where + body = drawingCtx >>= \ctx -> + let (ortt0,pf0) = runCF ctx (getPosObject po0) + (ortt1,pf1) = runCF ctx (getPosObject po1) + v1 = vvec (-sep) ^+^ mkV ortt0 ortt1 + ortt = extendODown sep $ mkO ortt0 ortt1 + pf = \pt -> pf0 pt `oplus` (pf1 $ pt .+^ v1) + in return (ortt,pf) diff --git a/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs b/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs --- a/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs +++ b/src/Wumpus/Basic/Kernel/Objects/TraceDrawing.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -7,7 +6,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Objects.TraceDrawing --- Copyright : (c) Stephen Tetley 2010 +-- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : stephen.tetley@gmail.com @@ -23,7 +22,10 @@ module Wumpus.Basic.Kernel.Objects.TraceDrawing ( - TraceDrawing + -- * Collect primitives (writer monad) + TraceM(..) + + , TraceDrawing , DTraceDrawing , TraceDrawingT , DTraceDrawingT @@ -40,16 +42,20 @@ , mbPictureU - , query + , evalQuery + , draw - , xdraw , drawi - , drawi_ - , xdrawi - , xdrawi_ + , drawl + , drawli + , drawc + , drawci , node , nodei + + , drawrc + , drawrci ) where @@ -57,9 +63,13 @@ import Wumpus.Basic.Kernel.Base.BaseDefs import Wumpus.Basic.Kernel.Base.ContextFun import Wumpus.Basic.Kernel.Base.DrawingContext +import Wumpus.Basic.Kernel.Base.QueryDC import Wumpus.Basic.Kernel.Base.WrappedPrimitive -import Wumpus.Basic.Kernel.Objects.BaseObjects -import Wumpus.Basic.Kernel.Objects.Graphic +import Wumpus.Basic.Kernel.Objects.Anchors +import Wumpus.Basic.Kernel.Objects.Basis +import Wumpus.Basic.Kernel.Objects.Connector +import Wumpus.Basic.Kernel.Objects.Image +import Wumpus.Basic.Kernel.Objects.LocImage import Wumpus.Core -- package: wumpus-core @@ -68,7 +78,18 @@ import Data.Monoid +-------------------------------------------------------------------------------- + + +-- | Collect elementary graphics as part of a larger drawing. +-- +-- TraceM works much like a writer monad. +-- +class TraceM (m :: * -> *) where + trace :: MonUnit (m ()) ~ u => HPrim u -> m () + fontDelta :: m a -> m a + -- Note - TraceDrawing run \once\ - it is supplied with the starting -- environment (DrawingContext) and returns a Picture. -- @@ -84,17 +105,15 @@ newtype TraceDrawingT u m a = TraceDrawingT { getTraceDrawingT :: DrawingContext -> m (a, HPrim u) } +type instance MonUnit (TraceDrawing u a) = u +type instance MonUnit (TraceDrawingT u m a) = u + type DTraceDrawing a = TraceDrawing Double a type DTraceDrawingT m a = TraceDrawingT Double m a -type instance MonUnit (TraceDrawing u) = u -type instance MonUnit (TraceDrawingT u m) = u - - - -- Functor instance Functor (TraceDrawing u) where @@ -157,25 +176,42 @@ -- the drawing model would be valuable. -- -instance TraceM (TraceDrawing u) where +instance TraceM (TraceDrawing u) where trace a = TraceDrawing $ \_ -> ((), a) + fontDelta = fontDeltaMon +fontDeltaMon :: TraceDrawing u a -> TraceDrawing u a +fontDeltaMon mf = TraceDrawing $ \ctx -> + let (_,font_attrs) = runCF ctx textAttr + (a,hf) = runTraceDrawing ctx mf + prim = fontDeltaContext font_attrs $ primGroup $ hprimToList hf + in (a, singleH $ prim1 $ prim) instance Monad m => TraceM (TraceDrawingT u m) where trace a = TraceDrawingT $ \_ -> return ((), a) + fontDelta = fontDeltaTrans +fontDeltaTrans :: Monad m => TraceDrawingT u m a -> TraceDrawingT u m a +fontDeltaTrans mf = TraceDrawingT $ \ctx -> + let (_,font_props) = runCF ctx textAttr + in runTraceDrawingT ctx mf >>= \(a,hf) -> + let prim = fontDeltaContext font_props $ primGroup $ hprimToList hf + in return (a, singleH $ prim1 $ prim) + -- DrawingCtxM instance DrawingCtxM (TraceDrawing u) where askDC = TraceDrawing $ \ctx -> (ctx, mempty) + asksDC f = TraceDrawing $ \ctx -> (f ctx, mempty) localize upd ma = TraceDrawing $ \ctx -> getTraceDrawing ma (upd ctx) instance Monad m => DrawingCtxM (TraceDrawingT u m) where - askDC = TraceDrawingT $ \ctx -> return (ctx,mempty) + askDC = TraceDrawingT $ \ctx -> return (ctx, mempty) + asksDC f = TraceDrawingT $ \ctx -> return (f ctx, mempty) localize upd ma = TraceDrawingT $ \ctx -> getTraceDrawingT ma (upd ctx) @@ -231,7 +267,7 @@ -- -- If the HPrim is empty, a run-time error is thrown. -- -liftToPictureU :: (Real u, Floating u, FromPtSize u) => HPrim u -> Picture u +liftToPictureU :: HPrim u -> Picture liftToPictureU hf = let prims = hprimToList hf in if null prims then errK else frame prims where @@ -241,8 +277,7 @@ -- -- If the HPrim is empty, then @Nothing@ is returned. -- -liftToPictureMb :: (Real u, Floating u, FromPtSize u) - => HPrim u -> Maybe (Picture u) +liftToPictureMb :: HPrim u -> Maybe Picture liftToPictureMb hf = let prims = hprimToList hf in if null prims then Nothing else Just (frame prims) @@ -259,8 +294,7 @@ -- -- If the supplied value is @Nothing@ a run-time error is thrown. -- -mbPictureU :: (Real u, Floating u, FromPtSize u) - => Maybe (Picture u) -> Picture u +mbPictureU :: Maybe Picture -> Picture mbPictureU Nothing = error "mbPictureU - empty picture." mbPictureU (Just a) = a @@ -268,25 +302,29 @@ -- a very simple way to run graphics without concern for return -- type or initial drawing context. + + -------------------------------------------------------------------------------- -query :: DrawingCtxM m => CF a -> m a -query df = askDC >>= \ctx -> return $ runCF ctx df +evalQuery :: DrawingCtxM m => Query a -> m a +evalQuery df = askDC >>= \ctx -> return $ runCF ctx df + + -- | Draw a Graphic taking the drawing style from the -- /drawing context/. -- --- This operation is analogeous to @tell@ in a Writer monad. +-- This function is the /forgetful/ version of 'drawi'. +-- Commonly, it is used to draw 'Graphic' objects which +-- have no /answer/. -- -draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Graphic u -> m () -draw gf = askDC >>= \ctx -> trace (collectH $ snd $ runCF ctx gf) +draw :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) + => Image u a -> m () +draw gf = askDC >>= \ctx -> + let Ans o _ = runCF ctx gf + in trace (singleH o) >> return () --- | Hyperlink version of 'draw'. --- -xdraw :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) - => XLink -> Graphic u -> m () -xdraw xl gf = draw (hyperlink xl gf) @@ -296,43 +334,142 @@ -- The graphic representation of the Image is drawn in the Trace -- monad, and the result is returned. -- -drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit m) => Image u a -> m a +drawi :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) + => Image u a -> m a drawi img = askDC >>= \ctx -> - let (a,o) = runCF ctx img in trace (collectH o) >> return a + let Ans o a = runCF ctx img + in trace (singleH o) >> return a --- | Forgetful 'drawi'. + +-- | Draw a LocImage at the supplied Anchor taking the drawing +-- style from the /drawing context/. -- -drawi_ :: (TraceM m, DrawingCtxM m, MonUnit m ~ u) => Image u a -> m () -drawi_ img = drawi img >> return () +-- This function is the /forgetful/ version of 'drawli'. +-- Commonly, it is used to draw 'LocGraphic' objects which +-- have no /answer/. +-- +drawl :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) + => Anchor u -> LocImage u a -> m () +drawl ancr img = drawli ancr img >> return () --- | Hyperlink version of 'drawi'. + +-- | Draw a LocImage at the supplied Point taking the drawing +-- style from the /drawing context/. -- -xdrawi :: (TraceM m, DrawingCtxM m, MonUnit m ~ u) - => XLink -> Image u a -> m a -xdrawi xl img = drawi (hyperlink xl img) +-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned. +-- +drawli :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) + => Anchor u -> LocImage u a -> m a +drawli pt img = askDC >>= \ctx -> + let Ans o a = runCF ctx img pt + in trace (singleH o) >> return a --- | Forgetful 'xdrawi'. + +-- Design note - having @drawlti@ for LocThetaImage does not seem +-- compelling (at the moment). The thinking is that LocTheta +-- objects should be downcast to Loc objects before drawing. -- -xdrawi_ :: (TraceM m, DrawingCtxM m, MonUnit m ~ u) - => XLink -> Image u a -> m () -xdrawi_ xl img = xdrawi xl img >> return () +-- Connectors however are be different. +-- +-- PosImages would seem to be the same as LocThetaImages. +-- +-- | Draw a ConnectorGraphic with the supplied Anchors taking the +-- drawing style from the /drawing context/. +-- +-- This function is the /forgetful/ version of 'drawci'. +-- Commonly, it is used to draw 'ConnectorGraphic' objects which +-- have no /answer/. +-- +drawc :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) + => Anchor u -> Anchor u -> ConnectorImage u a -> m () +drawc an0 an1 img = drawci an0 an1 img >> return () -node :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u) - => LocGraphic u -> m () -node gf = askDC >>= \ctx -> - position >>= \pt -> - let (_,prim) = runCF1 ctx pt gf in trace (collectH prim) +-- | Draw a ConnectorImage with the supplied Points taking the +-- drawing style from the /drawing context/. +-- +-- The graphic representation of the Image is drawn in the Trace +-- monad, and the result is returned. +-- +drawci :: (TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) + => Anchor u -> Anchor u -> ConnectorImage u a -> m a +drawci p0 p1 img = drawi (connect img p0 p1) -nodei :: (TraceM m, DrawingCtxM m, PointSupplyM m, MonUnit m ~ u) - => LocImage u a -> m a -nodei imgL = askDC >>= \ctx -> - position >>= \pt -> - let (a,o) = runCF ctx (apply1R1 imgL pt) - in trace (collectH o) >> return a + + + + + + + +-- | Draw the object with the supplied grid coordinate. The +-- actual position is scaled according to the +-- @snap_grid_factors@ in the /drawing context/. +-- +-- This function is the /forgetful/ version of 'nodei'. +-- Commonly, it is used to draw 'LocGraphic' objects which +-- have no /answer/. +-- +node :: (Fractional u, TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) + => (Int,Int) -> LocImage u a -> m () +node coord gf = nodei coord gf >> return () + + +-- | Draw the object with the supplied grid coordinate. The +-- actual position is scaled according to the +-- @snap_grid_factors@ in the /drawing context/. +-- +nodei :: (Fractional u, TraceM m, DrawingCtxM m, u ~ MonUnit (m ()) ) + => (Int,Int) -> LocImage u a -> m a +nodei coord gf = askDC >>= \ctx -> + position coord >>= \pt -> + let Ans o a = runCF ctx gf pt + in trace (singleH o) >> return a + + + + + + + + +-- | Draw a connector between two objects. The projection of the +-- connector line is drawn on the line from center to center of +-- the objects, the actual start and end points of the drawn line +-- are the radial points on the objects borders that cross the +-- projected line. +-- +-- This function is the /forgetful/ version of 'drawrci'. +-- Commonly, it is used to draw 'LocGraphic' objects which +-- have no /answer/. +-- +drawrc :: ( Real u, Floating u, DrawingCtxM m, TraceM m + , CenterAnchor a, RadialAnchor a + , CenterAnchor b, RadialAnchor b + , u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b + ) + => a -> b -> ConnectorImage u ans -> m () +drawrc a b gf = drawrci a b gf >> return () + + +-- | Draw a connector between two objects. The projection of the +-- connector line is drawn on the line from center to center of +-- the objects, the actual start and end points of the drawn line +-- are the radial points on the objects borders that cross the +-- projected line. +-- +drawrci :: ( Real u, Floating u, DrawingCtxM m, TraceM m + , CenterAnchor a, RadialAnchor a + , CenterAnchor b, RadialAnchor b + , u ~ MonUnit (m ()), u ~ DUnit a, u ~ DUnit b + ) + => a -> b -> ConnectorImage u ans -> m ans +drawrci a b img = + let (p0,p1) = radialConnectorPoints a b in drawi (connect img p0 p1) diff --git a/src/Wumpus/Basic/System/FontLoader.hs b/src/Wumpus/Basic/System/FontLoader.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader.hs @@ -0,0 +1,141 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader +-- Copyright : (c) Stephen Tetley 2011 +-- License : BSD3 +-- +-- Maintainer : stephen.tetley@gmail.com +-- Stability : highly unstable +-- Portability : GHC +-- +-- Top level module for font loading... +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader + ( + FontLoader + , afmLoaderByEnv + , gsLoaderByEnv + , simpleFontLoader + + , default_font_loader_help + + ) where + +import Wumpus.Basic.Kernel.Base.FontSupport +import Wumpus.Basic.System.FontLoader.AfmTopLevel +import Wumpus.Basic.System.FontLoader.GSTopLevel + +import Control.Monad +import System.Environment +import System.IO.Error + + + + +-- | A FontLoader is an action from a list of fonts to a +-- 'FontLoadResult' returned in @IO@. +-- +-- Fonts are supplied in a list of @Either FontDef FontFamily@, +-- this is a little cumbersome but it allows the loader to load +-- individual fonts and \/ or a whole families with a single API +-- call. +-- +type FontLoader = [Either FontDef FontFamily] -> IO FontLoadResult + + + + + +-- | Environment variable pointing to the GhostScript font +-- directory. +-- +-- > WUMPUS_GS_FONT_DIR +-- +wumpus_gs_font_dir :: String +wumpus_gs_font_dir = "WUMPUS_GS_FONT_DIR" + + +-- | Environment variable pointing to the diretory containing +-- the Adobe Font Metrics files. +-- +-- > WUMPUS_AFM_FONT_DIR +-- +wumpus_afm_font_dir :: String +wumpus_afm_font_dir = "WUMPUS_AFM_FONT_DIR" + + + +afmLoaderByEnv :: IO (Maybe FontLoader) +afmLoaderByEnv = do + mb <- envLookup wumpus_afm_font_dir + case mb of + Nothing -> return Nothing + Just path -> return $ Just (\xs -> loadAfmFontMetrics path $ fontList xs) + + +gsLoaderByEnv :: IO (Maybe FontLoader) +gsLoaderByEnv = do + mb <- envLookup wumpus_gs_font_dir + case mb of + Nothing -> return Nothing + Just path -> return $ Just (\xs -> loadGSFontMetrics path $ fontList xs) + + +-- | Tries to find the GhostScript metrics first... +-- +-- Runs the IO action on the loader if it finds one. +-- +-- Either of one of the environment variables +-- @WUMPUS_AFM_FONT_DIR@ or @WUMPUS_GS_FONT_DIR@ must be defined +-- and point to their respective directory. +-- +simpleFontLoader :: (FontLoader -> IO a) -> IO (Maybe a) +simpleFontLoader mf = + gsLoaderByEnv >>= maybe fk1 sk + where + fk1 = afmLoaderByEnv >>= maybe fk2 sk + fk2 = putStrLn default_font_loader_help >> return Nothing + sk loader = mf loader >>= return . Just + + +envLookup :: String -> IO (Maybe String) +envLookup name = liftM fn $ try $ getEnv name + where + fn (Left _) = Nothing + fn (Right a) = Just a + + + +fontList :: [Either FontDef FontFamily] -> [FontDef] +fontList = foldr fn [] + where + fn (Left a) acc = a:acc + fn (Right b) acc = let f1 = maybe id (\a -> (a:)) $ ff_bold b + f2 = maybe id (\a -> (a:)) $ ff_italic b + f3 = maybe id (\a -> (a:)) $ ff_bold_italic b + in ff_regular b : (f1 $ f2 $ f3 acc) + + +default_font_loader_help :: String +default_font_loader_help = unlines $ + [ "This example uses glyph metrics loaded at runtime." + , "It can use either the metrics files supplied with GhostScript," + , "or the AFM v4.1 metrics for the Core 14 fonts available from" + , "Adobe's website." + , "" + , "To use GhostScripts font metrics set the environemt variable" + , wumpus_gs_font_dir ++ " to point to the GhostScript fonts" + , "directory (e.g. /usr/share/ghostscript/fonts)." + , "" + , "To use the Adode Core 14 font metrics download the archive from" + , "the Adobe website and set the environment variable " + , wumpus_afm_font_dir ++ " to point to it." + , "" + , "If you have both environment variables set, the GhostScript loader" + , "will be used." + ] + diff --git a/src/Wumpus/Basic/System/FontLoader/Afm.hs b/src/Wumpus/Basic/System/FontLoader/Afm.hs deleted file mode 100644 --- a/src/Wumpus/Basic/System/FontLoader/Afm.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.System.FontLoader.Afm --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Font loader / import shim for the Adobe \"Core 14\" glyph --- metrics. --- --- Use this loader if you have the Adode glyph metrics set --- (AFM v4.1). This metrics set is avaiable from the Adobe --- website. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.System.FontLoader.Afm - ( - loadAfmMetrics - - ) where - -import Wumpus.Basic.Kernel -import Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser -import Wumpus.Basic.System.FontLoader.Base.Datatypes -import Wumpus.Basic.System.FontLoader.Base.FontLoadMonad - - -import Wumpus.Core -- package: wumpus-core - -import Control.Monad -import Data.Monoid - --- The file names of the Afm fonts match there PostScript names, --- the only difference is the addition of a @.afm@ extension. --- - --- | 'loadAfmMetrics' : --- @ path_to_afm_fonts * [font_name] -> IO (metrics, messages) @ --- --- Load the supplied list of fonts. --- --- Note - if a font fails to load a message is written to the --- log and monospaced /fallback metrics/ are used. --- -loadAfmMetrics :: FilePath -> [FontName] -> IO (GlyphMetrics, [String]) -loadAfmMetrics font_dir_path ns = - liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ns - where - mkFun = afmLoadFontCalcs font_dir_path - - post (Left err,ss) = (mempty, ss ++ [err]) -- unreachable... - post (Right xs,ss) = (foldr insertFont mempty xs, ss) - - - - -afmLoadFontCalcs :: FilePath -> FontName -> FontLoadIO FontMetricsOps -afmLoadFontCalcs font_dir_path name = do - logLoadMsg $ "Loading " ++ name - path <- checkFontPath font_dir_path (name ++ ".afm") - ans <- runParserFLIO path afmV4Dot1Parser - props <- buildAfmFontProps afm_mono_defaults_4_1 ans - return $ FontMetricsOps name (buildMetricsOps afmUnitScale props) - - - --- | These are values extracted from Courier in the core 14 fonts. --- -afm_mono_defaults_4_1 :: MonospaceDefaults AfmUnit -afm_mono_defaults_4_1 = - MonospaceDefaults { default_letter_bbox = bbox - , default_cap_height = 562 - , default_descender = (-157) - , default_char_width = V2 600 0 - } - where - bbox = BBox (P2 (-23) (-250)) (P2 715 805) diff --git a/src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs b/src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/AfmParserBase.hs @@ -0,0 +1,214 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.AfmParserBase +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Common parsers for AFM files. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.AfmParserBase + ( + + afmFileParser + , runQuery + , textQuery + + , getFontBBox + , getEncodingScheme + , getCapHeight + + , charBBox + , metric + , keyStringPair + , versionNumber + , startCharMetrics + + , keyName + , newlineOrEOF + , name + , name1 + , semi + , uptoNewline + , number + , cint + , hexInt + , octInt + + , lexeme + , symbol + , integer + , int + , double + + ) where + +import Wumpus.Basic.System.FontLoader.Datatypes + +import Wumpus.Basic.Utils.ParserCombinators +import qualified Wumpus.Basic.Utils.TokenParsers as P + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + +import Data.Char +import qualified Data.Map as Map + + +afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile +afmFileParser pgm = do + info <- (versionNumber *> globalInfo) + cms <- (startCharMetrics *> many pgm) + return $ AfmFile + { afm_encoding = getEncodingScheme info + , afm_letter_bbox = getFontBBox info + , afm_cap_height = getCapHeight info + , afm_descender = getDescender info + , afm_glyph_metrics = cms + } + +globalInfo :: CharParser GlobalInfo +globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) + <$> manyTill keyStringPair (peek startCharMetrics) + + + +runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a +runQuery field_name p table = + Map.lookup field_name table >>= extr . runParser p + where + extr (Okay a _) = Just a + extr _ = Nothing + +textQuery :: String -> GlobalInfo -> Maybe String +textQuery = Map.lookup + + +-- | Strictly speaking a fontBBox is measured in integer units. +-- +getFontBBox :: GlobalInfo -> Maybe AfmBoundingBox +getFontBBox = runQuery "FontBBox" fontBBox + +getEncodingScheme :: GlobalInfo -> Maybe String +getEncodingScheme = textQuery "EncodingScheme" + +getCapHeight :: GlobalInfo -> Maybe AfmUnit +getCapHeight = runQuery "CapHeight" number + +getDescender :: GlobalInfo -> Maybe AfmUnit +getDescender = runQuery "Descender" number + + +charBBox :: CharParser AfmBoundingBox +charBBox = symbol "B" *> fontBBox <* semi + +fontBBox :: CharParser AfmBoundingBox +fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury)) + <$> number <*> number <*> number <*> number + + + +metric :: String -> a -> CharParser a -> CharParser a +metric iden dfault p = option dfault go + where + go = symbol iden *> p <* semi + + + +keyStringPair :: CharParser (AfmKey,String) +keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF + "key-value line" + +versionNumber :: CharParser String +versionNumber = + symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF + "StartFontMetrics" + + +startCharMetrics :: CharParser Int +startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF + "StartCharMetrics failed" + + + +-------------------------------------------------------------------------------- + + +keyName :: CharParser AfmKey +keyName = lexeme (many1 $ satisfy isAlphaNum) + + +newlineOrEOF :: CharParser () +newlineOrEOF = skipOne (lexeme newline) <|> eof + + +uptoNewline :: CharParser String +uptoNewline = many1 (noneOf ['\n']) + + +name :: CharParser String +name = lexeme $ many (noneOf ";\n") + +name1 :: CharParser String +name1 = lexeme $ many (noneOf "; \t\n") + + + +semi :: CharParser Char +semi = lexeme $ char ';' + + + + +number :: CharParser AfmUnit +number = liftA realToFrac double + + +cint :: CharParser Int +cint = hexInt <|> octInt <|> int + + +hexInt :: CharParser Int +hexInt = lexeme $ between (char '<') (char '>') P.hexBase + + +octInt :: CharParser Int +octInt = lexeme $ char '\\' *> P.octBase + + + +-------------------------------------------------------------------------------- + +-- no newline in whitespace + + +lp :: P.LexemeParser +lp = P.commentLineLexemeParser "Comment" [' ', '\t'] + + +lexeme :: CharParser a -> CharParser a +lexeme = P.lexeme lp + +symbol :: String -> CharParser String +symbol = lexeme . string + +-- whiteSpace :: CharParser () +-- whiteSpace = P.whiteSpace lp + + +integer :: CharParser Integer +integer = lexeme P.integer + +int :: CharParser Int +int = fromIntegral <$> integer + +double :: CharParser Double +double = lexeme P.double diff --git a/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs b/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/AfmTopLevel.hs @@ -0,0 +1,111 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.AfmTopLevel +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Top-level AFM V4.1 font loader. +-- +-- Use this module to build a font loader if you want to work with +-- the Adobe metrics sets, but find the @simpleFontLoader@ in +-- @Wumpus.Basic.System.FontLoader@ too inflexible. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.AfmTopLevel + ( + + loadAfmFontMetrics + + , loadAfmFont1 + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser +import Wumpus.Basic.System.FontLoader.Datatypes +import Wumpus.Basic.System.FontLoader.FontLoadMonad + + +import Wumpus.Core -- package: wumpus-core + +import Control.Monad +import Data.Monoid + +-- The file names of the Afm fonts match there PostScript names, +-- the only difference is the addition of a @.afm@ extension. +-- + +-- | 'loadAfmFontMetrics' : +-- @ path_to_afm_fonts * [font_name] -> IO FontLoadResult @ +-- +-- Load the supplied list of fonts. +-- +-- Note - if a font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used. +-- +loadAfmFontMetrics :: FilePath -> [FontDef] -> IO FontLoadResult +loadAfmFontMetrics font_dir_path ds = + liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ds + where + mkFun = afmLoadFontMetrics font_dir_path + + post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs + in FontLoadResult mempty errs + post (Right xs,msgs) = let body = foldr fn mempty xs + in FontLoadResult body msgs + + fn (name,metrics) table = insertFont name metrics table + + +-- TODO - need a one font version... + + +-- | 'loadAfmFont1' : +-- @ path_to_afm_fonts * font_def -> IO FontLoadResult @ +-- +-- Load a single AFM font. +-- +-- Note - if the font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used. +-- +loadAfmFont1 :: FilePath -> FontDef -> IO FontLoadResult +loadAfmFont1 font_dir_path font_def = + liftM post $ runFontLoadIO $ afmLoadFontMetrics font_dir_path font_def + where + post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs + in FontLoadResult mempty errs + post (Right (a,b),msgs) = let body = insertFont a b mempty + in FontLoadResult body msgs + + + +afmLoadFontMetrics :: FilePath -> FontDef -> FontLoadIO (FontName,FontMetrics) +afmLoadFontMetrics font_dir_path font_def = do + tellLoadMsg $ "Loading " ++ afm_file + path <- checkFontPath font_dir_path afm_file + ans <- runParserFLIO path afmV4Dot1Parser + props <- buildAfmFontProps afm_mono_defaults_4_1 ans + return (name, buildMetricsOps afmValue props) + where + afm_file = afm_file_name font_def + name = ps_font_name $ font_def_face font_def + + +-- | These are values extracted from Courier in the core 14 fonts. +-- +afm_mono_defaults_4_1 :: MonospaceDefaults AfmUnit +afm_mono_defaults_4_1 = + MonospaceDefaults { default_letter_bbox = bbox + , default_cap_height = 562 + , default_descender = (-157) + , default_char_width = V2 600 0 + } + where + bbox = BBox (P2 (-23) (-250)) (P2 715 805) diff --git a/src/Wumpus/Basic/System/FontLoader/AfmV2Parser.hs b/src/Wumpus/Basic/System/FontLoader/AfmV2Parser.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/AfmV2Parser.hs @@ -0,0 +1,65 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.AfmV2Parser +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- AFM file parser for Version 2.0. +-- +-- Note - AFM Version 2.0 used by GhostScript and Version 3.0+ +-- have numerous differences. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.AfmV2Parser + ( + afmV2Parser + + ) where + +import Wumpus.Basic.System.FontLoader.AfmParserBase +import Wumpus.Basic.System.FontLoader.Datatypes +import Wumpus.Basic.Utils.ParserCombinators + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + + + +-------------------------------------------------------------------------------- +-- parser + + +afmV2Parser :: CharParser AfmFile +afmV2Parser = afmFileParser charMetricsV2 + + +charMetricsV2 :: CharParser AfmGlyphMetrics +charMetricsV2 = AfmGlyphMetrics <$> + metric "C" (-1) cint + <*> widthVector + <*> metric "N" "" name1 + <* charBBox + <* many (symbol "L" *> ligature_body <* semi) + <* newlineOrEOF + where + ligature_body = ((,) <$> name <*> name) + +widthVector :: CharParser (Vec2 AfmUnit) +widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) + <|> (symbol "W" *> (vec <$> number <*> number) <* semi) + + +-------------------------------------------------------------------------------- + + + + diff --git a/src/Wumpus/Basic/System/FontLoader/AfmV4Dot1Parser.hs b/src/Wumpus/Basic/System/FontLoader/AfmV4Dot1Parser.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/AfmV4Dot1Parser.hs @@ -0,0 +1,63 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- AFM file parser for Version 4.1. +-- +-- Adobe distributes font metrics for the /Core 14/ fonts as +-- AFM Version 4.1 files. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser + ( + + afmV4Dot1Parser + ) where + +import Wumpus.Basic.System.FontLoader.AfmParserBase +import Wumpus.Basic.System.FontLoader.Datatypes +import Wumpus.Basic.Utils.ParserCombinators + +import Wumpus.Core -- package: wumpus-core + +import Control.Applicative + + +afmV4Dot1Parser :: CharParser AfmFile +afmV4Dot1Parser = afmFileParser charMetricsV4Dot1 + + +charMetricsV4Dot1 :: CharParser AfmGlyphMetrics +charMetricsV4Dot1 = AfmGlyphMetrics <$> + characterCode + <*> widthVector + <*> metric "N" "" name1 + <* charBBox + <* many (symbol "L" *> ligature_body <* semi) + <* newlineOrEOF + where + ligature_body = ((,) <$> name <*> name) + + +-- Note - there are many variants for width vectors in in 4.1. +-- Wumpus needs some thought about what to do for them, it also +-- needs some facility to tell how successful the parse has been. + +widthVector :: CharParser (Vec2 AfmUnit) +widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) + <|> (symbol "W" *> (vec <$> number <*> number) <* semi) + + +-- V4.1 allows C int or CH \ +-- +characterCode :: CharParser Int +characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs deleted file mode 100644 --- a/src/Wumpus/Basic/System/FontLoader/Base/AfmParserBase.hs +++ /dev/null @@ -1,214 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.System.FontLoader.Base.AfmParserBase --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Common parsers for AFM files. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.System.FontLoader.Base.AfmParserBase - ( - - afmFileParser - , runQuery - , textQuery - - , getFontBBox - , getEncodingScheme - , getCapHeight - - , charBBox - , metric - , keyStringPair - , versionNumber - , startCharMetrics - - , keyName - , newlineOrEOF - , name - , name1 - , semi - , uptoNewline - , number - , cint - , hexInt - , octInt - - , lexeme - , symbol - , integer - , int - , double - - ) where - -import Wumpus.Basic.System.FontLoader.Base.Datatypes - -import Wumpus.Basic.Utils.ParserCombinators -import qualified Wumpus.Basic.Utils.TokenParsers as P - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - -import Data.Char -import qualified Data.Map as Map - - -afmFileParser :: CharParser AfmGlyphMetrics -> CharParser AfmFile -afmFileParser pgm = do - info <- (versionNumber *> globalInfo) - cms <- (startCharMetrics *> many pgm) - return $ AfmFile - { afm_encoding = getEncodingScheme info - , afm_letter_bbox = getFontBBox info - , afm_cap_height = getCapHeight info - , afm_descender = getDescender info - , afm_glyph_metrics = cms - } - -globalInfo :: CharParser GlobalInfo -globalInfo = (foldr (\(k,v) a -> Map.insert k v a) Map.empty) - <$> manyTill keyStringPair (peek startCharMetrics) - - - -runQuery :: String -> CharParser a -> GlobalInfo -> Maybe a -runQuery field_name p table = - Map.lookup field_name table >>= extr . runParser p - where - extr (Okay a _) = Just a - extr _ = Nothing - -textQuery :: String -> GlobalInfo -> Maybe String -textQuery = Map.lookup - - --- | Strictly speaking a fontBBox is measured in integer units. --- -getFontBBox :: GlobalInfo -> Maybe AfmBoundingBox -getFontBBox = runQuery "FontBBox" fontBBox - -getEncodingScheme :: GlobalInfo -> Maybe String -getEncodingScheme = textQuery "EncodingScheme" - -getCapHeight :: GlobalInfo -> Maybe AfmUnit -getCapHeight = runQuery "CapHeight" number - -getDescender :: GlobalInfo -> Maybe AfmUnit -getDescender = runQuery "Descender" number - - -charBBox :: CharParser AfmBoundingBox -charBBox = symbol "B" *> fontBBox <* semi - -fontBBox :: CharParser AfmBoundingBox -fontBBox = (\llx lly urx ury -> boundingBox (P2 llx lly) (P2 urx ury)) - <$> number <*> number <*> number <*> number - - - -metric :: String -> a -> CharParser a -> CharParser a -metric iden dfault p = option dfault go - where - go = symbol iden *> p <* semi - - - -keyStringPair :: CharParser (AfmKey,String) -keyStringPair = (,) <$> keyName <*> uptoNewline <* newlineOrEOF - "key-value line" - -versionNumber :: CharParser String -versionNumber = - symbol "StartFontMetrics" *> many1 (digit <|> char '.') <* newlineOrEOF - "StartFontMetrics" - - -startCharMetrics :: CharParser Int -startCharMetrics = symbol "StartCharMetrics" *> int <* newlineOrEOF - "StartCharMetrics failed" - - - --------------------------------------------------------------------------------- - - -keyName :: CharParser AfmKey -keyName = lexeme (many1 $ satisfy isAlphaNum) - - -newlineOrEOF :: CharParser () -newlineOrEOF = skipOne (lexeme newline) <|> eof - - -uptoNewline :: CharParser String -uptoNewline = many1 (noneOf ['\n']) - - -name :: CharParser String -name = lexeme $ many (noneOf ";\n") - -name1 :: CharParser String -name1 = lexeme $ many (noneOf "; \t\n") - - - -semi :: CharParser Char -semi = lexeme $ char ';' - - - - -number :: CharParser AfmUnit -number = liftA realToFrac double - - -cint :: CharParser Int -cint = hexInt <|> octInt <|> int - - -hexInt :: CharParser Int -hexInt = lexeme $ between (char '<') (char '>') P.hexBase - - -octInt :: CharParser Int -octInt = lexeme $ char '\\' *> P.octBase - - - --------------------------------------------------------------------------------- - --- no newline in whitespace - - -lp :: P.LexemeParser -lp = P.commentLineLexemeParser "Comment" [' ', '\t'] - - -lexeme :: CharParser a -> CharParser a -lexeme = P.lexeme lp - -symbol :: String -> CharParser String -symbol = lexeme . string - --- whiteSpace :: CharParser () --- whiteSpace = P.whiteSpace lp - - -integer :: CharParser Integer -integer = lexeme P.integer - -int :: CharParser Int -int = fromIntegral <$> integer - -double :: CharParser Double -double = lexeme P.double diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs deleted file mode 100644 --- a/src/Wumpus/Basic/System/FontLoader/Base/AfmV2Parser.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.System.FontLoader.Internal.AfmV2Parser --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- AFM file parser for Version 2.0. --- --- Note - AFM Version 2.0 used by GhostScript and Version 3.0+ --- have numerous differences. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.System.FontLoader.Base.AfmV2Parser - ( - afmV2Parser - - ) where - -import Wumpus.Basic.System.FontLoader.Base.AfmParserBase -import Wumpus.Basic.System.FontLoader.Base.Datatypes -import Wumpus.Basic.Utils.ParserCombinators - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - - - - --------------------------------------------------------------------------------- --- parser - - -afmV2Parser :: CharParser AfmFile -afmV2Parser = afmFileParser charMetricsV2 - - -charMetricsV2 :: CharParser AfmGlyphMetrics -charMetricsV2 = AfmGlyphMetrics <$> - metric "C" (-1) cint - <*> widthVector - <*> metric "N" "" name1 - <* charBBox - <* many (symbol "L" *> ligature_body <* semi) - <* newlineOrEOF - where - ligature_body = ((,) <$> name <*> name) - -widthVector :: CharParser (Vec2 AfmUnit) -widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) - <|> (symbol "W" *> (vec <$> number <*> number) <* semi) - - --------------------------------------------------------------------------------- - - - - diff --git a/src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs b/src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs deleted file mode 100644 --- a/src/Wumpus/Basic/System/FontLoader/Base/AfmV4Dot1Parser.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- AFM file parser for Version 4.1. --- --- Adobe distributes font metrics for the /Core 14/ fonts as --- AFM Version 4.1 files. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser - ( - - afmV4Dot1Parser - ) where - -import Wumpus.Basic.System.FontLoader.Base.AfmParserBase -import Wumpus.Basic.System.FontLoader.Base.Datatypes -import Wumpus.Basic.Utils.ParserCombinators - -import Wumpus.Core -- package: wumpus-core - -import Control.Applicative - - -afmV4Dot1Parser :: CharParser AfmFile -afmV4Dot1Parser = afmFileParser charMetricsV4Dot1 - - -charMetricsV4Dot1 :: CharParser AfmGlyphMetrics -charMetricsV4Dot1 = AfmGlyphMetrics <$> - characterCode - <*> widthVector - <*> metric "N" "" name1 - <* charBBox - <* many (symbol "L" *> ligature_body <* semi) - <* newlineOrEOF - where - ligature_body = ((,) <$> name <*> name) - - --- Note - there are many variants for width vectors in in 4.1. --- Wumpus needs some thought about what to do for them, it also --- needs some facility to tell how successful the parse has been. - -widthVector :: CharParser (Vec2 AfmUnit) -widthVector = (symbol "WX" *> ((\w -> vec w 0) <$> number) <* semi) - <|> (symbol "W" *> (vec <$> number <*> number) <* semi) - - --- V4.1 allows C int or CH \ --- -characterCode :: CharParser Int -characterCode = metric "CH" (-1) hexInt <|> metric "C" (-1) cint diff --git a/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs b/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs deleted file mode 100644 --- a/src/Wumpus/Basic/System/FontLoader/Base/Datatypes.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.System.FontLoader.Base.Datatypes --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Datatypes --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.System.FontLoader.Base.Datatypes - ( - - -- * Afm Unit - AfmUnit - , afmValue - , afmUnitScale - - -- * Glyph metrics - - , PSCharCode - , PSEncodingScheme - , AfmBoundingBox - - , AfmKey - , GlobalInfo - , AfmFile(..) - , AfmGlyphMetrics(..) - - , MonospaceDefaults(..) - - , FontProps(..) - , buildMetricsOps - - ) where - - -import Wumpus.Basic.Kernel.Base.GlyphMetrics - -import Wumpus.Core -- package: wumpus-core - -import qualified Data.IntMap as IM -import qualified Data.Map as M - - - --- | Wrapped Double representing 1\/1000 of the scale factor --- (Point size) of a font. AFM files encode all measurements --- as these units. --- -newtype AfmUnit = AfmUnit { getAfmUnit :: Double } - deriving (Eq,Ord,Num,Floating,Fractional,Real,RealFrac,RealFloat) - -instance Show AfmUnit where - showsPrec p d = showsPrec p (getAfmUnit d) - - --- | Compute the size of a measurement in Afm units scaled by the --- point size of the font. --- -afmValue :: FromPtSize u => AfmUnit -> PtSize -> u -afmValue u pt = fromPtSize $ (realToFrac $ getAfmUnit u) * (pt / 1000) - -afmUnitScale :: AfmUnit -> PtSize -afmUnitScale u = (realToFrac $ getAfmUnit u / 1000) - - --------------------------------------------------------------------------------- - --- | Afm files index glyphs by /PostScript character code/. This --- is not the same as Unicode, ASCII... --- --- It is expected to be determined by @EncodingScheme@ in the --- Global Font Information Section. --- -type PSCharCode = Int - -type PSEncodingScheme = String - -type AfmBoundingBox = BoundingBox AfmUnit - -type AfmKey = String -type GlobalInfo = M.Map AfmKey String - - - --- | Wumpus needs a very small subset of AFM files, common to both --- version 2.0 and version 4.1. --- --- Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1 --- --- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus --- uses cap height in calculations, glyph metrics must be build --- with an arbitrary value if it is not present. --- --- Encoding Scheme is optional in AFM files. --- -data AfmFile = AfmFile - { afm_encoding :: Maybe String - , afm_letter_bbox :: Maybe AfmBoundingBox - , afm_cap_height :: Maybe AfmUnit - , afm_descender :: Maybe AfmUnit - , afm_glyph_metrics :: [AfmGlyphMetrics] - } - deriving (Show) - --- Note - for AfmFile BBox is a required field for version 4.1, --- but it appears to be optional for version 2.0. --- - - -data AfmGlyphMetrics = AfmGlyphMetrics - { afm_char_code :: !PSCharCode - , afm_width_vector :: !(Vec2 AfmUnit) - , afm_char_name :: !String - } - deriving (Eq,Show) - - --- | Monospace defaults are used if the font loader fails to --- extract the necessary fields. --- --- The values are taken from the font correpsonding to Courier --- in the distributed font files. --- -data MonospaceDefaults cu = MonospaceDefaults - { default_letter_bbox :: BoundingBox cu - , default_cap_height :: cu - , default_descender :: cu - , default_char_width :: Vec2 cu - } - deriving (Eq,Show) - - - --- | The metrics read from a font file by a font loader. --- --- NOTE - FontProps is parametric on @cu@ - /Character Unit/ and --- not on the usual @u@. A typical character unit is 'AfmUnit', --- the unit of measurement for AFM files (1000th of a point). --- --- The is the initial representation used by Wumpus-Basic as an --- syntax tree when loading font files. --- -data FontProps cu = FontProps - { fp_bounding_box :: BoundingBox cu - , fp_default_adv_vec :: Vec2 cu - , fp_adv_vecs :: IM.IntMap (Vec2 cu) - , fp_cap_height :: cu - , fp_descender :: cu - } - - --- | Build a MetricsOps function table, from a character unit --- scaling function and FontProps read from a file. --- -buildMetricsOps :: (cu -> PtSize) -> FontProps cu -> MetricsOps -buildMetricsOps fn font@(FontProps { fp_bounding_box = BBox ll ur - , fp_default_adv_vec = V2 vx vy }) = - MetricsOps - { get_bounding_box = \sz -> BBox (scalePt sz ll) (scalePt sz ur) - , get_cw_table = \sz i -> - maybe (defaultAV sz) (scaleVec sz) $ IM.lookup i (fp_adv_vecs font) - , get_cap_height = \sz -> upscale sz (fn $ fp_cap_height font) - , get_descender = \sz -> upscale sz (fn $ fp_descender font) - } - where - upscale sz d = fromPtSize $ sz * d - - defaultAV sz = V2 (upscale sz $ fn vx) (upscale sz $ fn vy) - scalePt sz (P2 cx cy) = P2 (upscale sz $ fn cx) (upscale sz $ fn cy) - scaleVec sz (V2 cx cy) = V2 (upscale sz $ fn cx) (upscale sz $ fn cy) - - - diff --git a/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs b/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs deleted file mode 100644 --- a/src/Wumpus/Basic/System/FontLoader/Base/FontLoadMonad.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.System.FontLoader.Base.FontLoadMonad --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Font load monad handling IO (file system access), failure and --- logging. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.System.FontLoader.Base.FontLoadMonad - ( - FontLoadErr - , FontLoadIO - , runFontLoadIO - , evalFontLoadIO - , loadError - , logLoadMsg - , promoteIO - , promoteEither - , runParserFLIO - - , sequenceAll - - -- * Font loading - - , buildAfmFontProps - , checkFontPath - - ) where - -import Wumpus.Basic.System.FontLoader.Base.Datatypes -import Wumpus.Basic.Utils.HList -import Wumpus.Basic.Utils.ParserCombinators - - -import Wumpus.Core -- package: wumpus-core -import Wumpus.Core.Text.GlyphIndices - - -import Control.Monad -import qualified Data.IntMap as IntMap -import qualified Data.Map as Map -import Data.Monoid -import System.Directory -import System.FilePath - - - --------------------------------------------------------------------------------- --- FontLoadIO monad - IO plus Error - - - -type FontLoadErr = String - -newtype FontLoadLog = FontLoadLog { getFontLoadLog :: H String } - - -instance Monoid FontLoadLog where - mempty = FontLoadLog $ emptyH - a `mappend` b = FontLoadLog $ getFontLoadLog a `appendH` getFontLoadLog b - - - -newtype FontLoadIO a = FontLoadIO { - getFontLoadIO :: IO (Either FontLoadErr a, FontLoadLog ) } - -instance Functor FontLoadIO where - fmap f ma = FontLoadIO $ getFontLoadIO ma >>= \(a,w) -> return (fmap f a, w) - -instance Monad FontLoadIO where - return a = FontLoadIO $ return (Right a, mempty) - m >>= k = FontLoadIO $ getFontLoadIO m >>= fn - where - fn (Left err, w) = return (Left err, w) - fn (Right a, w1) = getFontLoadIO (k a) >>= \(b,w2) -> - return (b, w1 `mappend` w2) - -runFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a,[String]) -runFontLoadIO ma = liftM post $ getFontLoadIO ma - where - post (ans,w) = (ans, toListH $ getFontLoadLog w) - - -evalFontLoadIO :: FontLoadIO a -> IO (Either FontLoadErr a) -evalFontLoadIO ma = liftM post $ getFontLoadIO ma - where - post (ans,_) = ans - - -loadError :: FontLoadErr -> FontLoadIO a -loadError msg = FontLoadIO $ return (Left msg, mempty) - -logLoadMsg :: String -> FontLoadIO () -logLoadMsg msg = FontLoadIO $ return (Right (), message1 msg ) - - -message1 :: String -> FontLoadLog -message1 = FontLoadLog . wrapH - - --- | aka liftIO -promoteIO :: IO a -> FontLoadIO a -promoteIO ma = FontLoadIO $ ma >>= \a -> return (Right a, mempty) - -promoteEither :: Either FontLoadErr a -> FontLoadIO a -promoteEither = either loadError return - -runParserFLIO :: FilePath -> Parser Char a -> FontLoadIO a -runParserFLIO filepath p = - promoteIO (readFile filepath) >>= promoteEither . runParserEither p - - --- | The standard monadic @sequence@ would finish on first fail --- for the FontLoadIO monad. As we want to be able to sequence --- the loading of a list of fonts, this is not really the --- behaviour we want for Wumpus. Instead we prefer to use fallback --- metrics and produce an inaccurate drawing on a font load error --- rather than fail and produce no drawing. --- -sequenceAll :: [FontLoadIO a] -> FontLoadIO [a] -sequenceAll = FontLoadIO . step - where - step [] = return (Right [], mempty) - step (m:ms) = liftM2 cons (getFontLoadIO m) (step ms) - -cons :: (Either FontLoadErr a, FontLoadLog) - -> (Either FontLoadErr [a], FontLoadLog) - -> (Either FontLoadErr [a], FontLoadLog) -cons (Right a, w1) (Right as, w2) = - (Right $ a:as, w1 `mappend` w2) - -cons (Right a, w1) (Left e2, w2) = - (Right [a], w1 `mappend` w2 `mappend` message1 e2) - -cons (Left e1, w1) (Right as, w2) = - (Right as, w1 `mappend` message1 e1 `mappend` w2) - -cons (Left e1, w1) (Left e2, w2) = - (Right [], w1 `mappend` message1 e1 `mappend` w2 `mappend` message1 e2) - - - --------------------------------------------------------------------------------- - - --- | Afm files do not have a default advance vec so use the --- monospace default. --- --- Afm files hopefully have @CapHeight@ and @FontBBox@ properties --- in the header. Use the monospace default only if they are --- missing. --- -buildAfmFontProps :: MonospaceDefaults AfmUnit - -> AfmFile - -> FontLoadIO (FontProps AfmUnit) -buildAfmFontProps defaults afm = do - cap_height <- extractCapHeight defaults afm - desc_depth <- extractDescender defaults afm - bbox <- extractFontBBox defaults afm - return $ FontProps - { fp_bounding_box = bbox - , fp_default_adv_vec = default_char_width defaults - , fp_adv_vecs = char_widths - , fp_cap_height = cap_height - , fp_descender = desc_depth - } - where - char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm - - fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of - Nothing -> table - Just i -> IntMap.insert i v table - - -extractCapHeight :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit -extractCapHeight defaults afm = maybe errk return $ afm_cap_height afm - where - errk = logLoadMsg "WARNING - Could not extract CapHeight" >> - return (default_cap_height defaults) - - - -extractDescender :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit -extractDescender defaults afm = maybe errk return $ afm_descender afm - where - errk = logLoadMsg "WARNING - Could not extract Descender" >> - return (default_descender defaults) - - -extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile - -> FontLoadIO (BoundingBox AfmUnit) -extractFontBBox defaults afm = maybe errk return $ afm_letter_bbox afm - where - errk = logLoadMsg "WARNING - Could not extract CapHeight" >> - return (default_letter_bbox defaults) - - - -checkFontPath :: FilePath -> FilePath -> FontLoadIO FilePath -checkFontPath path_root font_file_name = - let full_path = normalise (path_root font_file_name) - in do { check <- promoteIO (doesFileExist full_path) - ; if check then return full_path - else loadError $ "Could not resolve path: " ++ full_path - } diff --git a/src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs b/src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs deleted file mode 100644 --- a/src/Wumpus/Basic/System/FontLoader/Base/GSFontMap.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.System.FontLoader.Base.GSFontMap --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- GhostScript Font map. --- --- GhostScript aliases the /Core 14/ PostScript fonts to fonts --- it can freely distribute. This module provides aliases to --- Wumpus so the font loader can find the equivalent GhostScript --- files to the Core 14 set. --- --- The data in this file matches GhostScript 8.63. Other versions --- of GhostScript may need different aliases. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.System.FontLoader.Base.GSFontMap - ( - - GSFontMap(..) - , gsMetricsFile - , gsFontAlias - , gsVersionNumber - , ghostscript_fontmap_8_54 - - ) where - - -import Data.Map ( Map ) -import qualified Data.Map as Map - - --- | GhostScript version that the aliases were derived from. --- --- ghostscript_version :: String --- ghostscript_version = "gs8.54" - - --- | A map from standard /Adode PostScript/ font name to the --- equivalent GhostScript font and AFM file name. --- --- It is expected that all GhostScript AFM files will be located --- in the same directory. --- -data GSFontMap = GSFontMap - { ghostscript_version :: String - , ghostscript_fontmap :: Map String (String, FilePath) - } - - --- | Get the @.afm@ metrics file. --- --- Note this return only the file name and not the path to it. --- The full path must be resolved in client code. --- -gsMetricsFile :: GSFontMap -> String -> Maybe FilePath -gsMetricsFile mp name = fmap snd $ Map.lookup name (ghostscript_fontmap mp) - --- | Get the GhostScript font name alias. --- -gsFontAlias :: GSFontMap -> String -> Maybe String -gsFontAlias mp name = fmap fst $ Map.lookup name (ghostscript_fontmap mp) - - --- | Get the GhostScript version number that the FontMap --- represents. --- -gsVersionNumber :: GSFontMap -> String -gsVersionNumber = ghostscript_version - - --- | Map from PostScript font name to the corresponding --- GhostScript name and file. --- --- Naming is correct for GhostSCript version 8.54. --- -ghostscript_fontmap_8_54 :: GSFontMap -ghostscript_fontmap_8_54 = GSFontMap "8.54" body - where - body = Map.fromList $ - [ ("Courier", ("NimbusMonL-Regu", "n022003l.afm")) - , ("Courier-Oblique", ("NimbusMonL-ReguObli", "n022023l.afm")) - , ("Courier-Bold", ("NimbusMonL-Bold", "n022004l.afm")) - , ("Courier-BoldOblique", ("NimbusMonL-BoldObli", "n022024l.afm")) - - , ("Helvetica", ("NimbusSanL-Regu", "n019003l.afm")) - , ("Helvetica-Oblique", ("NimbusSanL-ReguItal", "n019023l.afm")) - , ("Helvetica-Bold", ("NimbusSanL-Bold", "n019004l.afm")) - , ("Helvetica-BoldOblique", ("NimbusSanL-BoldItal", "n019024l.afm")) - - , ("Times-Roman", ("NimbusRomNo9L-Regu", "n021003l.afm")) - , ("Times-Italic", ("NimbusRomNo9L-ReguItal", "n021023l.afm")) - , ("Times-Bold", ("NimbusRomNo9L-Medi", "n021004l.afm")) - , ("Times-BoldItalic", ("NimbusRomNo9L-MediItal", "n021024l.afm")) - - , ("Symbol", ("StandardSymL", "s050000l.afm")) - - , ("ZapfDingbats", ("Dingbats", "d050000l.afm")) - ] - diff --git a/src/Wumpus/Basic/System/FontLoader/Datatypes.hs b/src/Wumpus/Basic/System/FontLoader/Datatypes.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/Datatypes.hs @@ -0,0 +1,158 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.Datatypes +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Datatypes +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.Datatypes + ( + + -- * Glyph metrics + + PSCharCode + , PSEncodingScheme + , AfmBoundingBox + + , AfmKey + , GlobalInfo + , AfmFile(..) + , AfmGlyphMetrics(..) + + , MonospaceDefaults(..) + + , FontProps(..) + , buildMetricsOps + + ) where + + +import Wumpus.Basic.Kernel.Base.FontSupport + +import Wumpus.Core -- package: wumpus-core + +import qualified Data.IntMap as IM +import qualified Data.Map as M + + + + + + + + +-------------------------------------------------------------------------------- + +-- | Afm files index glyphs by /PostScript character code/. This +-- is not the same as Unicode, ASCII... +-- +-- It is expected to be determined by @EncodingScheme@ in the +-- Global Font Information Section. +-- +type PSCharCode = Int + +type PSEncodingScheme = String + +type AfmBoundingBox = BoundingBox AfmUnit + +type AfmKey = String +type GlobalInfo = M.Map AfmKey String + + + +-- | Wumpus needs a very small subset of AFM files, common to both +-- version 2.0 and version 4.1. +-- +-- Note - Bounding Box is mandatory for AFM versions 3.0 and 4.1 +-- +-- Cap Height is optional in AFM versions 3.0 and 4.1. As Wumpus +-- uses cap height in calculations, glyph metrics must be build +-- with an arbitrary value if it is not present. +-- +-- Encoding Scheme is optional in AFM files. +-- +data AfmFile = AfmFile + { afm_encoding :: Maybe String + , afm_letter_bbox :: Maybe AfmBoundingBox + , afm_cap_height :: Maybe AfmUnit + , afm_descender :: Maybe AfmUnit + , afm_glyph_metrics :: [AfmGlyphMetrics] + } + deriving (Show) + +-- Note - for AfmFile BBox is a required field for version 4.1, +-- but it appears to be optional for version 2.0. +-- + + +data AfmGlyphMetrics = AfmGlyphMetrics + { afm_char_code :: !PSCharCode + , afm_width_vector :: !(Vec2 AfmUnit) + , afm_char_name :: !String + } + deriving (Eq,Show) + + +-- | Monospace defaults are used if the font loader fails to +-- extract the necessary fields. +-- +-- The values are taken from the font correpsonding to Courier +-- in the distributed font files. +-- +data MonospaceDefaults cu = MonospaceDefaults + { default_letter_bbox :: BoundingBox cu + , default_cap_height :: cu + , default_descender :: cu + , default_char_width :: Vec2 cu + } + deriving (Eq,Show) + + + +-- | The metrics read from a font file by a font loader. +-- +-- NOTE - FontProps is parametric on @cu@ - /Character Unit/ and +-- not on the usual @u@. A typical character unit is 'AfmUnit', +-- the unit of measurement for AFM files (1000th of a point). +-- +-- The is the initial representation used by Wumpus-Basic as an +-- syntax tree when loading font files. +-- +data FontProps cu = FontProps + { fp_bounding_box :: BoundingBox cu + , fp_default_adv_vec :: Vec2 cu + , fp_adv_vecs :: IM.IntMap (Vec2 cu) + , fp_cap_height :: cu + , fp_descender :: cu + } + + +-- | Build a MetricsOps function table, from a character unit +-- scaling function and FontProps read from a file. +-- +buildMetricsOps :: (FontSize -> cu -> Double) -> FontProps cu -> FontMetrics +buildMetricsOps fn font@(FontProps { fp_bounding_box = BBox ll ur + , fp_default_adv_vec = V2 vx vy }) = + FontMetrics + { get_bounding_box = \sz -> BBox (scalePt sz ll) (scalePt sz ur) + , get_cw_table = \sz i -> + maybe (defaultAV sz) (scaleVec sz) $ IM.lookup i (fp_adv_vecs font) + , get_cap_height = \sz -> fn sz (fp_cap_height font) + , get_descender = \sz -> fn sz (fp_descender font) + } + where + defaultAV sz = V2 (fn sz vx) (fn sz vy) + scalePt sz (P2 cx cy) = P2 (fn sz cx) (fn sz cy) + scaleVec sz (V2 cx cy) = V2 (fn sz cx) (fn sz cy) + + + diff --git a/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs b/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/FontLoadMonad.hs @@ -0,0 +1,200 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.FontLoadMonad +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Font load monad handling IO (file system access), failure and +-- logging. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.FontLoadMonad + ( + FontLoadIO + , runFontLoadIO + , evalFontLoadIO + , loadError + , tellLoadMsg + , promoteIO + , promoteEither + , runParserFLIO + + , sequenceAll + + -- * Font loading + + , buildAfmFontProps + , checkFontPath + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.Datatypes +import Wumpus.Basic.Utils.ParserCombinators + + +import Wumpus.Core -- package: wumpus-core +import Wumpus.Core.Text.GlyphIndices + + +import Control.Monad +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import Data.Monoid +import System.Directory +import System.FilePath + + + +-------------------------------------------------------------------------------- +-- FontLoadIO monad - IO plus Error + + + +newtype FontLoadIO a = FontLoadIO { + getFontLoadIO :: IO (Either FontLoadMsg a, FontLoadLog ) } + +instance Functor FontLoadIO where + fmap f ma = FontLoadIO $ getFontLoadIO ma >>= \(a,w) -> return (fmap f a, w) + +instance Monad FontLoadIO where + return a = FontLoadIO $ return (Right a, mempty) + m >>= k = FontLoadIO $ getFontLoadIO m >>= fn + where + fn (Left err, w) = return (Left err, w) + fn (Right a, w1) = getFontLoadIO (k a) >>= \(b,w2) -> + return (b, w1 `mappend` w2) + +runFontLoadIO :: FontLoadIO a -> IO (Either FontLoadMsg a, FontLoadLog) +runFontLoadIO ma = getFontLoadIO ma + + +evalFontLoadIO :: FontLoadIO a -> IO (Either FontLoadMsg a) +evalFontLoadIO ma = liftM post $ getFontLoadIO ma + where + post (ans,_) = ans + + +loadError :: FontLoadMsg -> FontLoadIO a +loadError msg = FontLoadIO $ return (Left msg, mempty) + +tellLoadMsg :: String -> FontLoadIO () +tellLoadMsg msg = FontLoadIO $ return (Right (), fontLoadMsg msg ) + + + +-- | Promote an @IO@ action into the the @FontLoadIO@ monad. +-- +-- This function is equivalent to @liftIO@. +-- +promoteIO :: IO a -> FontLoadIO a +promoteIO ma = FontLoadIO $ ma >>= \a -> return (Right a, mempty) + +promoteEither :: Either FontLoadMsg a -> FontLoadIO a +promoteEither = either loadError return + +runParserFLIO :: FilePath -> Parser Char a -> FontLoadIO a +runParserFLIO filepath p = + promoteIO (readFile filepath) >>= promoteEither . runParserEither p + + +-- | The standard monadic @sequence@ would finish on first fail +-- for the FontLoadIO monad. As we want to be able to sequence +-- the loading of a list of fonts, this is not really the +-- behaviour we want for Wumpus. Instead we prefer to use fallback +-- metrics and produce an inaccurate drawing on a font load error +-- rather than fail and produce no drawing. +-- +sequenceAll :: [FontLoadIO a] -> FontLoadIO [a] +sequenceAll = FontLoadIO . step + where + step [] = return (Right [], mempty) + step (m:ms) = liftM2 cons (getFontLoadIO m) (step ms) + +cons :: (Either FontLoadMsg a, FontLoadLog) + -> (Either FontLoadMsg [a], FontLoadLog) + -> (Either FontLoadMsg [a], FontLoadLog) +cons (Right a, w1) (Right as, w2) = + (Right $ a:as, w1 `mappend` w2) + +cons (Right a, w1) (Left e2, w2) = + (Right [a], w1 `mappend` w2 `mappend` fontLoadMsg e2) + +cons (Left e1, w1) (Right as, w2) = + (Right as, w1 `mappend` fontLoadMsg e1 `mappend` w2) + +cons (Left e1, w1) (Left e2, w2) = + (Right [], w1 `mappend` fontLoadMsg e1 `mappend` w2 `mappend` fontLoadMsg e2) + + + +-------------------------------------------------------------------------------- + + +-- | Afm files do not have a default advance vec so use the +-- monospace default. +-- +-- Afm files hopefully have @CapHeight@ and @FontBBox@ properties +-- in the header. Use the monospace default only if they are +-- missing. +-- +buildAfmFontProps :: MonospaceDefaults AfmUnit + -> AfmFile + -> FontLoadIO (FontProps AfmUnit) +buildAfmFontProps defaults afm = do + cap_height <- extractCapHeight defaults afm + desc_depth <- extractDescender defaults afm + bbox <- extractFontBBox defaults afm + return $ FontProps + { fp_bounding_box = bbox + , fp_default_adv_vec = default_char_width defaults + , fp_adv_vecs = char_widths + , fp_cap_height = cap_height + , fp_descender = desc_depth + } + where + char_widths = foldr fn IntMap.empty $ afm_glyph_metrics afm + + fn (AfmGlyphMetrics _ v ss) table = case Map.lookup ss ps_glyph_indices of + Nothing -> table + Just i -> IntMap.insert i v table + + +extractCapHeight :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit +extractCapHeight defaults afm = maybe errk return $ afm_cap_height afm + where + errk = tellLoadMsg "WARNING - Could not extract CapHeight" >> + return (default_cap_height defaults) + + + +extractDescender :: MonospaceDefaults AfmUnit -> AfmFile -> FontLoadIO AfmUnit +extractDescender defaults afm = maybe errk return $ afm_descender afm + where + errk = tellLoadMsg "WARNING - Could not extract Descender" >> + return (default_descender defaults) + + +extractFontBBox :: MonospaceDefaults AfmUnit -> AfmFile + -> FontLoadIO (BoundingBox AfmUnit) +extractFontBBox defaults afm = maybe errk return $ afm_letter_bbox afm + where + errk = tellLoadMsg "WARNING - Could not extract CapHeight" >> + return (default_letter_bbox defaults) + + + +checkFontPath :: FilePath -> FilePath -> FontLoadIO FilePath +checkFontPath path_root font_file_name = + let full_path = normalise (path_root font_file_name) + in do { check <- promoteIO (doesFileExist full_path) + ; if check then return full_path + else loadError $ "Could not resolve path: " ++ full_path + } diff --git a/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs b/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs new file mode 100644 --- /dev/null +++ b/src/Wumpus/Basic/System/FontLoader/GSTopLevel.hs @@ -0,0 +1,108 @@ +{-# OPTIONS -Wall #-} + +-------------------------------------------------------------------------------- +-- | +-- Module : Wumpus.Basic.System.FontLoader.GSTopLevel +-- Copyright : (c) Stephen Tetley 2010-2011 +-- License : BSD3 +-- +-- Maintainer : Stephen Tetley +-- Stability : highly unstable +-- Portability : GHC +-- +-- Top-level GhostScript font loader. +-- +-- Use this module to build a font loader if you want to work with +-- GhostScript, but find the @simpleFontLoader@ in +-- @Wumpus.Basic.System.FontLoader@ too inflexible. +-- +-------------------------------------------------------------------------------- + +module Wumpus.Basic.System.FontLoader.GSTopLevel + ( + + loadGSFontMetrics + + , loadGSFont1 + + ) where + +import Wumpus.Basic.Kernel +import Wumpus.Basic.System.FontLoader.AfmV2Parser +import Wumpus.Basic.System.FontLoader.Datatypes +import Wumpus.Basic.System.FontLoader.FontLoadMonad + +import Wumpus.Core -- package: wumpus-core + +import Control.Monad +import Data.Monoid + + +-- | 'loadGSFontMetrics' : +-- @ path_to_gs_fonts * [font_name] -> IO FontLoadResult @ +-- +-- Load the supplied list of fonts. +-- +-- Note - if a font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used. +-- +loadGSFontMetrics :: FilePath -> [FontDef] -> IO FontLoadResult +loadGSFontMetrics font_dir_path ds = + liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ds + where + mkFun = gsLoadFontMetrics font_dir_path + + post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs + in FontLoadResult mempty errs + post (Right xs,msgs) = let body = foldr fn mempty xs + in FontLoadResult body msgs + + fn (name,metrics) table = insertFont name metrics table + + +-- | 'loadGSFont1' : +-- @ path_to_gs_fonts * font_name -> IO FontLoadResult @ +-- +-- Load a single GhostScript font. +-- +-- Note - if the font fails to load a message is written to the +-- log and monospaced /fallback metrics/ are used. +-- +loadGSFont1 :: FilePath -> FontDef -> IO FontLoadResult +loadGSFont1 font_dir_path font_def = + liftM post $ runFontLoadIO $ gsLoadFontMetrics font_dir_path font_def + where + post (Left err,msgs) = let errs = fontLoadMsg err `mappend` msgs + in FontLoadResult mempty errs + post (Right (a,b),msgs) = let body = insertFont a b mempty + in FontLoadResult body msgs + + + +gsLoadFontMetrics :: FilePath -> FontDef + -> FontLoadIO (FontName,FontMetrics) +gsLoadFontMetrics font_dir_path font_def = do + tellLoadMsg $ "Loading " ++ gs_file + path <- checkFontPath font_dir_path gs_file + ans <- runParserFLIO path afmV2Parser + props <- buildAfmFontProps ghostscript_mono_defaults_8_54 ans + return (name, buildMetricsOps afmValue props) + where + gs_file = gs_file_name font_def + name = ps_font_name $ font_def_face font_def + + + +-- | These are values extracted from the file @n022003l.afm@ +-- which is the font @NimbusMonL-Regu@, GhostScript\'s eqivalent +-- font for the core 14 font Courier. +-- +ghostscript_mono_defaults_8_54 :: MonospaceDefaults AfmUnit +ghostscript_mono_defaults_8_54 = + MonospaceDefaults { default_letter_bbox = bbox + , default_cap_height = 563 + , default_descender = (-186) + , default_char_width = V2 600 0 + } + where + bbox = BBox (P2 (-46) (-273)) (P2 650 820) diff --git a/src/Wumpus/Basic/System/FontLoader/GhostScript.hs b/src/Wumpus/Basic/System/FontLoader/GhostScript.hs deleted file mode 100644 --- a/src/Wumpus/Basic/System/FontLoader/GhostScript.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.System.FontLoader.GhostScript --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- Stability : highly unstable --- Portability : GHC --- --- Font loader / import shim for GhostScript glyph metrics. --- --- Use this loader if you have GhostScript installed and you want --- to use the (AFM v2.0) metrics that are distributed with --- GhostScript. --- --------------------------------------------------------------------------------- - -module Wumpus.Basic.System.FontLoader.GhostScript - ( - - loadGSMetrics - - ) where - -import Wumpus.Basic.Kernel -import Wumpus.Basic.System.FontLoader.Base.AfmV2Parser -import Wumpus.Basic.System.FontLoader.Base.Datatypes -import Wumpus.Basic.System.FontLoader.Base.FontLoadMonad -import Wumpus.Basic.System.FontLoader.Base.GSFontMap - -import Wumpus.Core -- package: wumpus-core - -import Control.Monad -import Data.Monoid - - --- | 'loadGSMetrics' : --- @ path_to_gs_fonts * [font_name] -> IO (metrics, messages) @ --- --- Load the supplied list of fonts. --- --- Note - if a font fails to load a message is written to the --- log and monospaced /fallback metrics/ are used. --- -loadGSMetrics :: FilePath -> [FontName] -> IO (GlyphMetrics, [String]) -loadGSMetrics font_dir_path ns = - liftM post $ runFontLoadIO $ sequenceAll $ map mkFun ns - where - mkFun = gsLoadFontCalcs font_dir_path ghostscript_fontmap_8_54 - - post (Left err,ss) = (mempty, ss ++ [err]) -- unreachable... - post (Right xs,ss) = (foldr insertFont mempty xs, ss) - - -gsLoadFontCalcs :: FilePath -> GSFontMap -> FontName - -> FontLoadIO FontMetricsOps -gsLoadFontCalcs font_dir_path fm name = do - logLoadMsg $ "Loading " ++ name - font_file <- resolveFontFile fm name - path <- checkFontPath font_dir_path font_file - ans <- runParserFLIO path afmV2Parser - props <- buildAfmFontProps ghostscript_mono_defaults_8_54 ans - return $ FontMetricsOps name (buildMetricsOps afmUnitScale props) - - -resolveFontFile :: GSFontMap -> FontName -> FontLoadIO FilePath -resolveFontFile fm name = maybe errk return $ gsMetricsFile fm name - where - errk = loadError $ "Could note resolve GhostScript alias for " ++ name - - --- | These are values extracted from the file @n022003l.afm@ --- which is the font @NimbusMonL-Regu@, GhostScript\'s eqivalent --- font for the core 14 font Courier. --- -ghostscript_mono_defaults_8_54 :: MonospaceDefaults AfmUnit -ghostscript_mono_defaults_8_54 = - MonospaceDefaults { default_letter_bbox = bbox - , default_cap_height = 563 - , default_descender = (-186) - , default_char_width = V2 600 0 - } - where - bbox = BBox (P2 (-46) (-273)) (P2 650 820) diff --git a/src/Wumpus/Basic/Utils/HList.hs b/src/Wumpus/Basic/Utils/HList.hs --- a/src/Wumpus/Basic/Utils/HList.hs +++ b/src/Wumpus/Basic/Utils/HList.hs @@ -29,6 +29,7 @@ , concatH , toListH + , prefixListH , fromListH @@ -79,6 +80,9 @@ toListH :: H a -> [a] toListH = ($ []) + +prefixListH :: H a -> [a] -> [a] +prefixListH hf xs = hf $ xs fromListH :: [a] -> H a fromListH xs = (xs++) diff --git a/src/Wumpus/Basic/Utils/JoinList.hs b/src/Wumpus/Basic/Utils/JoinList.hs --- a/src/Wumpus/Basic/Utils/JoinList.hs +++ b/src/Wumpus/Basic/Utils/JoinList.hs @@ -135,7 +135,7 @@ -- | Convert a join list to a regular list. -- toList :: JoinList a -> [a] -toList = joinfoldl (flip (:)) [] +toList = joinfoldr (:) [] diff --git a/src/Wumpus/Basic/VersionNumber.hs b/src/Wumpus/Basic/VersionNumber.hs --- a/src/Wumpus/Basic/VersionNumber.hs +++ b/src/Wumpus/Basic/VersionNumber.hs @@ -23,7 +23,7 @@ -- | Version number -- --- > (0,16,0) +-- > (0,17,0) -- wumpus_basic_version :: (Int,Int,Int) -wumpus_basic_version = (0,16,0) +wumpus_basic_version = (0,17,0) diff --git a/wumpus-basic.cabal b/wumpus-basic.cabal --- a/wumpus-basic.cabal +++ b/wumpus-basic.cabal @@ -1,5 +1,5 @@ name: wumpus-basic -version: 0.16.0 +version: 0.17.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -29,7 +29,34 @@ . . Changelog: + . + v0.16.0 to v0.17.0: . + * Changed representation of ContextFuns - context funs are no + longer an arity family of newtypes. The new representation + is simpler, but some of the opportunities for overloading + have been lost. + . + * Substantial round of renaming for the @DrawingContext@ types + an query and update functions. + . + * Re-worked the font metrics and font loader modules. The new + names should be more systematic. Removed the need for the + GhostScript font modules to match PostScript names to + GhostScript font files. + . + * Superceded the PointSupplyM class by adding snapping grid + scaling to the DrawingContext. + . + * Removed @ScalingContext@ module. + . + * Made text colour a distinct property in the DrawingContext. + Text is now drawn with the text colour rather than the stroke + colour. + . + * Added FontLoadLog to the DrawingContext - this allows access + to the errors recorded during font loading. + . v0.15.0 to v0.16.0: . * Moved the Geometry modules from Wumpus-Drawing into @@ -43,6 +70,8 @@ * Added @PosImage@ object - this is a rectangle-framed object that can be drawn from any of its corners or its center. . + * Added @CF3@, an arity three /ContextFunction/. + . * Added @Displacement@ module. This defines the @PointDisplace@ type and provides a library of @PointDisplace@ functions. Note - some of the new functions have taken names previously @@ -85,9 +114,10 @@ extra-source-files: CHANGES, LICENSE, + demo/AltUnits.hs, demo/FontDeltaPic.hs, demo/SimpleAdvGraphic.hs, - demo/SimplePosImage.hs + demo/SimplePosObject.hs library hs-source-dirs: src @@ -96,42 +126,48 @@ directory >= 1.0 && < 2.0, filepath >= 1.1 && < 2.0, vector-space >= 0.6 && < 1.0, - wumpus-core >= 0.43.0 && < 0.44.0 + wumpus-core >= 0.50.0 && < 0.51.0 exposed-modules: + Wumpus.Basic.Geometry, Wumpus.Basic.Geometry.Base, Wumpus.Basic.Geometry.Intersection, Wumpus.Basic.Geometry.Paths, Wumpus.Basic.Geometry.Quadrant, Wumpus.Basic.Kernel, - Wumpus.Basic.Kernel.Base.Anchors, Wumpus.Basic.Kernel.Base.BaseDefs, Wumpus.Basic.Kernel.Base.ContextFun, Wumpus.Basic.Kernel.Base.DrawingContext, - Wumpus.Basic.Kernel.Base.GlyphMetrics, + Wumpus.Basic.Kernel.Base.FontSupport, Wumpus.Basic.Kernel.Base.QueryDC, - Wumpus.Basic.Kernel.Base.ScalingContext, + Wumpus.Basic.Kernel.Base.Units, Wumpus.Basic.Kernel.Base.UpdateDC, Wumpus.Basic.Kernel.Base.WrappedPrimitive, - Wumpus.Basic.Kernel.Objects.AdvanceGraphic, - Wumpus.Basic.Kernel.Objects.BaseObjects, + Wumpus.Basic.Kernel.Objects.AdvObject, + Wumpus.Basic.Kernel.Objects.Anchors, + Wumpus.Basic.Kernel.Objects.Basis, Wumpus.Basic.Kernel.Objects.Bounded, + Wumpus.Basic.Kernel.Objects.Chain, + Wumpus.Basic.Kernel.Objects.Concat, Wumpus.Basic.Kernel.Objects.Connector, Wumpus.Basic.Kernel.Objects.CtxPicture, Wumpus.Basic.Kernel.Objects.Displacement, Wumpus.Basic.Kernel.Objects.DrawingPrimitives, - Wumpus.Basic.Kernel.Objects.Graphic, - Wumpus.Basic.Kernel.Objects.PosImage, + Wumpus.Basic.Kernel.Objects.Image, + Wumpus.Basic.Kernel.Objects.LocImage, + Wumpus.Basic.Kernel.Objects.LocThetaImage, + Wumpus.Basic.Kernel.Objects.Orientation, + Wumpus.Basic.Kernel.Objects.PosObject, Wumpus.Basic.Kernel.Objects.TraceDrawing, - Wumpus.Basic.System.FontLoader.Afm, - Wumpus.Basic.System.FontLoader.GhostScript, - Wumpus.Basic.System.FontLoader.Base.AfmParserBase, - Wumpus.Basic.System.FontLoader.Base.AfmV2Parser, - Wumpus.Basic.System.FontLoader.Base.AfmV4Dot1Parser, - Wumpus.Basic.System.FontLoader.Base.Datatypes, - Wumpus.Basic.System.FontLoader.Base.FontLoadMonad, - Wumpus.Basic.System.FontLoader.Base.GSFontMap, + Wumpus.Basic.System.FontLoader, + Wumpus.Basic.System.FontLoader.AfmParserBase, + Wumpus.Basic.System.FontLoader.AfmTopLevel, + Wumpus.Basic.System.FontLoader.AfmV2Parser, + Wumpus.Basic.System.FontLoader.AfmV4Dot1Parser, + Wumpus.Basic.System.FontLoader.Datatypes, + Wumpus.Basic.System.FontLoader.FontLoadMonad, + Wumpus.Basic.System.FontLoader.GSTopLevel, Wumpus.Basic.Utils.HList, Wumpus.Basic.Utils.FormatCombinators, Wumpus.Basic.Utils.JoinList,