{-# LANGUAGE DataKinds, KindSignatures, OverloadedStrings, EmptyDataDecls, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, GADTs, LambdaCase, RecordWildCards #-}
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)
import Algebra.Classes hiding (normalize)
import Prelude hiding (Num(..),(/))
data Anchor = Center | N | NW | W | SW | S | SE | E | NE | BaseW | Base | BaseE
deriving Show
type Box = Object
type Anchorage = Anchor -> Point
data Object = Object { objectName :: !String
, objectOutline :: !Path
, anchors :: !Anchorage}
infix 8 #
(#) :: Object -> Anchor -> Point
(#) = anchors
hdist :: Object -> Object -> Expr
hdist x y = xpart (y # W - x # E)
vdist :: Object -> Object -> Expr
vdist x y = ypart (y # S - x # N)
extend :: Expr -> Object -> Object
extend e Object{..} = Object{anchors = \a -> anchors a + shiftInDir a e,..}
shiftInDir :: Anchor -> Expr -> Point
shiftInDir N d = zero `Point` d
shiftInDir S d = zero `Point` negate d
shiftInDir W d = negate d `Point` zero
shiftInDir BaseW d = negate d `Point` zero
shiftInDir E d = d `Point` zero
shiftInDir BaseE d = d `Point` zero
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 _ _ = zero `Point` zero
label :: Monad m => String -> lab -> Diagram lab m Box
label name txt = do
l <- extend (constant 4) <$> rawLabel name txt
pathObject $ Object
name
(polygon (map (l #) [NW,NE,SE,SW]))
(anchors l)
pathObject :: Monad m => Object -> Diagram lab m Object
pathObject o@(Object _ p _) = path p >> return o
labelAt :: Monad m => String -> lab -> Anchor -> Point -> Diagram lab m Box
labelAt name labell anchor labeled = do
t <- label name labell
t # anchor .=. labeled
return t
point :: Monad m => String -> Diagram lab m Object
point name = do
x <- newVar (name++".x"); y <- newVar (name++".y")
return $ Object name EmptyPath (\_ -> Point x y)
box :: Monad m => String -> Diagram lab m Object
box objectName = do
let nv suff = newVar (objectName++"."++suff)
n <- nv "north" ; s <- nv "south"; e <- nv "east"; w <- nv "west"; base <- nv "base"; midx <- nv "midx"; midy <- nv "midy"
n >== base
base >== s
w <== e
midx === avg [w,e]
midy === avg [n,s]
let pt = flip Point
anchors 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
objectOutline = polygon (map anchors [NW,NE,SE,SW])
pathObject $ Object{..}
vrule :: Monad m => String -> Diagram lab m Object
vrule name = do
o <- box name
align xpart [o # W, o #Center, o#E]
return o
hrule :: Monad m => String -> Diagram lab m Object
hrule name = do
o <- box name
height o === zero
return o
height, width, ascent, descent :: Object -> 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)
sloppyFitsHorizontallyIn :: Monad m => Object -> Object -> Diagram lab m ()
o `sloppyFitsHorizontallyIn` o' = do
let dyW = xpart $ o # W - o' # W
dyE = xpart $ o' # E - o # E
dyW >== zero
dyE >== zero
fitsIn, fitsHorizontallyIn, fitsVerticallyIn
:: (Monad m) => Object -> Object -> Diagram lab m ()
o `fitsVerticallyIn` o' = do
let dyN = ypart $ o' # N - o # N
dyS = ypart $ o # S - o' # S
minimize dyN
dyN >== zero
minimize dyS
dyS >== zero
o `fitsHorizontallyIn` o' = do
let dyW = xpart $ o # W - o' # W
dyE = xpart $ o' # E - o # E
minimize dyW
dyW >== zero
minimize dyE
dyE >== zero
a `fitsIn` b = do
a `fitsHorizontallyIn` b
a `fitsVerticallyIn` b
circle :: Monad m => String -> Diagram lab m Object
circle name = do
bx <- noDraw (box name)
width bx === height bx
let radius = 0.5 *- width bx
p = circlePath (bx # Center) radius
pathObject $ Object name p (anchors bx)
traceBox :: (Monad m) => Color -> Object -> Diagram lab m ()
traceBox c l = do
stroke c $ path $ polygon (map (l #) [NW,NE,SE,SW])
rawLabel :: Monad m => String -> lab -> Diagram lab m Object
rawLabel name t = do
l <- noDraw (box name)
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 (b-a))
(.<.) :: Monad m => Point -> Point -> Diagram lab m ()
Point x1 y1 .<. Point x2 y2 = do
x1 <== x2
y1 <== y2
insideBox :: Monad m => Point -> Object -> 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 v) = do
tighten 10 $ pt `insideBox` lab
minimize (orthonorm (pt+v- lab#Center))
autoLabel :: Monad m => String -> lab -> OVector -> Diagram lab m Object
autoLabel name lab i = do
o <- label name lab
autoLabelObj o i
return o
labeledEdge :: Monad m => Object -> Object -> Box -> Diagram lab m ()
labeledEdge source target lab = autoLabelObj lab =<< edge source target
nodeDistance :: Expr
nodeDistance = constant 5
leftOf, topOf, rightOf :: Monad m => Object -> Object -> Diagram lab m ()
a `leftOf` b = spread hdist nodeDistance [a,b]
a `topOf` b = spread vdist nodeDistance [b,a]
rightOf = flip leftOf
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 => String -> lab -> Diagram lab m Object
node name lab = do
l <- noDraw $ label name lab
c <- circle name
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) => [Object] -> Diagram lab m Object
boundingBox os = do
bx <- box $ "boundingBox" ++ (show $ map objectName os)
mapM_ (`fitsIn` bx) os
return bx
noOverlap :: Monad m => Object -> Diagram lab m Object
noOverlap o = do
registerNonOverlap (o#SW) (o#NE)
return o