module Graphics.Diagrams.Object where
import Graphics.Diagrams.Path
import Graphics.Diagrams.Point
import Graphics.Diagrams.Core
import Control.Monad
import Control.Lens (set,view)
data Anchor = Center | N | NW | W | SW | S | SE | E | NE | BaseW | Base | BaseE
deriving Show
type Box = Object
newtype Anchorage = Anchorage {fromAnchorage :: Anchor -> Point}
data Object = Object {objectOutline :: Path, objectAnchorage :: Anchorage}
class Anchored a where
anchors :: a -> Anchorage
infix 8 #
(#) :: Anchored a => a -> Anchor -> Point
(#) = fromAnchorage . anchors
instance Anchored Anchorage where
anchors = id
instance Anchored Object where
anchors = objectAnchorage
instance Anchored Point where
anchors p = Anchorage $ \_ -> p
hdist :: Anchored a => a -> a -> Expr
hdist x y = xpart (y # W x # E)
vdist :: Anchored a => a -> a -> Expr
vdist x y = ypart (y # S x # N)
extend :: Expr -> Anchorage -> Anchorage
extend e o = Anchorage $ \a -> o # a + shiftInDir a e
shiftInDir :: Anchor -> Expr -> Point
shiftInDir N d = 0 `Point` d
shiftInDir S d = 0 `Point` negate d
shiftInDir W d = negate d `Point` 0
shiftInDir BaseW d = negate d `Point` 0
shiftInDir E d = d `Point` 0
shiftInDir BaseE d = d `Point` 0
shiftInDir NW d = negate d `Point` d
shiftInDir SE d = d `Point` negate d
shiftInDir SW d = negate d `Point` negate d
shiftInDir NE d = d `Point` d
shiftInDir _ _ = 0 `Point` 0
mkLabel :: Monad m => lab -> Diagram lab m Anchorage
mkLabel texCode = extend 4 <$> labelBox texCode
labelObj :: Monad m => lab -> Diagram lab m Box
labelObj = rectangleShape <=< mkLabel
labelPt :: Monad m => lab -> Anchor -> Point -> Diagram lab m Box
labelPt labell anchor labeled = do
t <- labelObj labell
t # anchor .=. labeled
return t
point :: Monad m => Diagram lab m Point
point = do
[x,y] <- newVars (replicate 2 ContVar)
return $ Point x y
pointBox :: Monad m => Diagram lab m Anchorage
pointBox = anchors <$> point
box :: Monad m => Diagram lab m Anchorage
box = do
[n,s,e,w,base,midx,midy] <- newVars (replicate 7 ContVar)
n >== base
base >== s
w <== e
midx === avg [w,e]
midy === avg [n,s]
let pt = flip Point
return $ Anchorage $ \anch -> case anch of
NW -> pt n w
N -> pt n midx
NE -> pt n e
E -> pt midy e
SE -> pt s e
S -> pt s midx
SW -> pt s w
W -> pt midy w
Center -> pt midy midx
Base -> pt base midx
BaseE -> pt base e
BaseW -> pt base w
vrule :: Monad m => Diagram lab m Anchorage
vrule = do
o <- box
align xpart [o # W, o #Center, o#E]
return o
hrule :: Monad m => Diagram lab m Anchorage
hrule = do
o <- box
height o === 0
return o
height, width, ascent, descent :: Anchored a => a -> Expr
height o = ypart (o # N o # S)
width o = xpart (o # E o # W)
ascent o = ypart (o # N o # Base)
descent o = ypart (o # Base o # S)
fitsIn, fitsHorizontallyIn, fitsVerticallyIn :: (Monad m, Anchored a, Anchored b) => a -> b -> Diagram lab m ()
o `fitsVerticallyIn` o' = do
let dyN = ypart $ o' # N o # N
dyS = ypart $ o # S o' # S
minimize dyN
dyN >== 0
minimize dyS
dyS >== 0
o `fitsHorizontallyIn` o' = do
let dyW = xpart $ o # W o' # W
dyE = xpart $ o' # E o # E
minimize dyW
dyW >== 0
minimize dyE
dyE >== 0
a `fitsIn` b = do
a `fitsHorizontallyIn` b
a `fitsVerticallyIn` b
circleShape :: Monad m => Diagram lab m Object
circleShape = do
anch <- box
width anch === height anch
let radius = 0.5 *- width anch
let p = circle (anch # Center) radius
path p
return $ Object p anch
rectangleShape :: Monad m => Anchorage -> Diagram lab m Object
rectangleShape l = do
let p = polygon (map (l #) [NW,NE,SE,SW])
path p
return $ Object p l
traceAnchorage :: (Anchored a, Monad m) => Color -> a -> Diagram lab m ()
traceAnchorage c l = do
stroke c $ path $ polygon (map (l #) [NW,NE,SE,SW])
labelBox :: Monad m => lab -> Diagram lab m Anchorage
labelBox t = do
l <- box
BoxSpec wid h desc <- drawText (l # NW) t
width l === constant wid
descent l === constant desc
height l === constant (h + desc)
return l
data OVector = OVector { vectorOrigin, vectorMagnitude :: Point }
turn180 :: OVector -> OVector
turn180 (OVector p v) = OVector p (negate v)
data FList xs a where
NIL :: FList '[] a
(:%>) :: Functor t => t a -> FList fs a -> FList ('(:) t fs) a
infixr :%>
instance Functor (FList xs) where
fmap _ NIL = NIL
fmap f (x :%> xs) = fmap f x :%> fmap f xs
edge :: Monad m => Object -> Object -> Diagram lab m OVector
edge source target = do
let points@[a,b] = [source # Center,target # Center]
link = polyline points
targetArea = objectOutline target
sourceArea = objectOutline source
options <- view diaPathOptions
tracePath' <- view (diaBackend . tracePath)
freeze (link :%> sourceArea :%> targetArea :%> NIL) $ \(l' :%> sa' :%> ta' :%> NIL) -> do
tracePath' options $ (l' `cutAfter` ta') `cutBefore` sa'
return $ OVector (avg points) (rotate90 (ba))
(.<.) :: Monad m => Point -> Point -> Diagram lab m ()
Point x1 y1 .<. Point x2 y2 = do
x1 <== x2
y1 <== y2
insideBox :: Monad m => Anchored a => Point -> a -> Diagram lab m ()
insideBox p o = do
(o # SW) .<. p
p .<. (o # NE)
autoLabelObj :: Monad m => Box -> OVector -> Diagram lab m ()
autoLabelObj lab (OVector pt norm) = do
pt `insideBox` lab
minimize =<< orthoDist (lab#Center) (pt + norm)
autoLabel :: Monad m => lab -> OVector -> Diagram lab m ()
autoLabel lab i = do
o <- labelObj lab
autoLabelObj o i
labeledEdge :: Monad m => Object -> Object -> Box -> Diagram lab m ()
labeledEdge source target lab = autoLabelObj lab =<< edge source target
nodeDistance :: Expr
nodeDistance = 5
leftOf :: Monad m => Object -> Object -> Diagram lab m ()
a `leftOf` b = spread hdist nodeDistance [a,b]
topOf :: Monad m => Object -> Object -> Diagram lab m ()
a `topOf` b = spread vdist nodeDistance [b,a]
spread :: Monad m => (t -> t -> Expr) -> Expr -> [t] -> Diagram lab m ()
spread f d (x:y:xs) = do
f x y >== d
minimize $ f x y
spread f d (y:xs)
spread _ _ _ = return ()
node :: Monad m => lab -> Diagram lab m Object
node lab = do
l <- extend 4 <$> labelBox lab
c <- draw $ circleShape
l `fitsIn` c
l # Center .=. c # Center
return c
arrow :: Monad m => Object -> Object -> Diagram lab m OVector
arrow src trg = using (outline "black" . set endTip LatexTip) $ do
edge src trg
boundingBox :: (Monad m, Anchored a) => [a] -> Diagram lab m Object
boundingBox os = do
bx <- box
mapM_ (`fitsIn` bx) os
rectangleShape bx