{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Diagrams.Anchors
(
Anchor
, Anchored
, withAnchors
, noAnchors
, addAnchor
, deleteAnchor
, getAnchorOffset
, alignAnchor
, hasAnchor
, unanchor
, PositionalAnchor (..)
, rotateAnchors
, rotatePosAnchors
, anchorMany
, anchorMany_
, showAnchor
, showAnchor_)
where
import Diagrams.Names
import Diagrams.Core
import Diagrams.Path
import Diagrams.TwoD.Model
import qualified Control.Lens as Lens
import Control.Lens hiding (transform, (.>))
import Data.List (foldl')
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust, fromMaybe)
import qualified Data.Set as Set
import Data.Typeable (Typeable)
#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif
import Linear.Vector
import Linear.V2
import Linear.Affine
type Anchor = Name
data Anchored t =
Anchored
{ _currentAnchor :: Maybe Anchor
, _anchors :: Map Anchor (V t (N t))
, _anchoredObj :: t
}
makeLenses ''Anchored
type instance N (Anchored t) = N t
type instance V (Anchored t) = V t
instance (HasOrigin t, Additive (V t), Num (N t)) => HasOrigin (Anchored t) where
moveOriginTo p@(P v) =
(anchoredObj %~ moveOriginTo p) .
(anchors . traverse %~ (^-^ v))
instance (Transformable t) => Transformable (Anchored t) where
transform t =
(anchors . traverse %~ apply t) .
(anchoredObj %~ transform t)
instance (Additive (V t), Num (N t), HasOrigin t, Semigroup t) => Semigroup (Anchored t) where
o1 <> o2 =
let updateObj obj
| Just anchor <- obj^.currentAnchor
= moveOriginBy (getAnchorOffset anchor obj)
. deleteAnchor anchor
$ obj
| otherwise = obj
a1 <+> a2 = Anchored Nothing
((a1 ^. anchors) <> (a2 ^. anchors))
((a1 ^. anchoredObj) <> (a2 ^. anchoredObj))
in updateObj o1 <+> updateObj o2
instance (Additive (V t), Num (N t), HasOrigin t, Monoid' t) => Monoid (Anchored t) where
mempty = Anchored Nothing mempty mempty
mappend = (<>)
instance (Show (V t (N t)), Show t) => Show (Anchored t) where
showsPrec p anch =
showsPrec p (anch^.anchors) . (", " ++) . showsPrec p (anch^.anchoredObj)
addAnchor :: IsName anchor => anchor -> V t (N t) -> Anchored t -> Anchored t
addAnchor anchor val = anchors . Lens.at (toName anchor) .~ Just val
withAnchors :: IsName anchor => [(anchor, V t (N t))] -> t -> Anchored t
withAnchors = Anchored Nothing . Map.fromList . over (each . _1) toName
noAnchors :: t -> Anchored t
noAnchors = Anchored Nothing mempty
deleteAnchor :: IsName anchor => anchor -> Anchored t -> Anchored t
deleteAnchor anchor = anchors . Lens.at (toName anchor) .~ Nothing
getAnchorOffset :: (Num (N t), Additive (V t), IsName a) => a -> Anchored t -> V t (N t)
getAnchorOffset anchor = view $ anchors . Lens.at (toName anchor) . to (fromMaybe zero)
alignAnchor :: (IsName a) => a -> Anchored t -> Anchored t
alignAnchor anch = currentAnchor .~ Just (toName anch)
hasAnchor :: (IsName a) => a -> Anchored t -> Bool
hasAnchor anchor = view $ anchors . to (Map.member (toName anchor))
unanchor
:: Anchored t -> t
unanchor = view anchoredObj
data PositionalAnchor
= AnchorL
| AnchorTL
| AnchorT
| AnchorTR
| AnchorR
| AnchorBR
| AnchorB
| AnchorBL
deriving (Eq, Ord, Show, Typeable, Enum)
instance IsName PositionalAnchor where
rotateAnchors :: (IsName anchor) => [anchor] -> Int -> Anchored t -> Anchored t
rotateAnchors allAnchorsList n t =
let allAnchorsSet = Set.fromList . map toName $ allAnchorsList
allObjAnchors = t ^. anchors
presentAnchorsSet = Map.keysSet allObjAnchors `Set.intersection` allAnchorsSet
presentAnchorsList = filter ((`Set.member` presentAnchorsSet) . toName) allAnchorsList
rotateList k xs = drop k xs ++ take k xs
rotatedList = rotateList ((-n) `mod` length presentAnchorsList) presentAnchorsList
findOriginalPairing posAnch = fromJust $ Map.lookup (toName posAnch) allObjAnchors
originalOffsets = map findOriginalPairing presentAnchorsList
rotatedOffsets = zip (map toName rotatedList) originalOffsets
newObjAnchors = Map.fromList rotatedOffsets `Map.union` allObjAnchors
in t & anchors .~ newObjAnchors
rotatePosAnchors :: Int -> Anchored t -> Anchored t
rotatePosAnchors = rotateAnchors (enumFrom AnchorL)
instance Qualifiable t => Qualifiable (Anchored t) where
(.>>) name =
(currentAnchor . _Just %~ (name .>)) .
(anchors %~ Map.mapKeys (name .>)) .
(anchoredObj %~ (name .>>))
anchorMany
:: (Num (N t), Semigroup t, Additive (V t), HasOrigin t,
IsName anchor) =>
Anchored t -> [(anchor, anchor, Anchored t)] -> Anchored t
anchorMany = foldl' go
where
go base (thatAnch, thisAnch, obj)
= alignAnchor thatAnch base <> alignAnchor thisAnch obj
anchorMany_
:: (Num (N c), Semigroup c, Additive (V c), HasOrigin c,
IsName anchor) =>
Anchored c -> [(anchor, anchor, Anchored c)] -> c
anchorMany_ base = unanchor . anchorMany base
showAnchor
:: (RealFloat n, Typeable n, Monoid m, Semigroup m,
Renderable (Path V2 n) b, IsName a) =>
a -> Anchored (QDiagram b V2 n m) -> Anchored (QDiagram b V2 n m)
showAnchor anch = moveFromAnchor . over anchoredObj showOrigin . moveToAnchor
where
moveToAnchor t = t & anchoredObj %~ moveOriginBy ( getAnchorOffset anch t)
moveFromAnchor t = t & anchoredObj %~ moveOriginBy (-getAnchorOffset anch t)
showAnchor_
:: (RealFloat n, Typeable n, Monoid m, Semigroup m,
Renderable (Path V2 n) b, IsName a) =>
a -> Anchored (QDiagram b V2 n m) -> QDiagram b V2 n m
showAnchor_ anch = unanchor . showAnchor anch