{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.QuadTree.Draw
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Machinery for drawing cells.
--
--------------------------------------------------------------------------------
module Data.Geometry.QuadTree.Draw where

import           Data.Ext
import qualified Data.Foldable as F
import           Ipe.Attributes
import           Ipe.IpeOut
import           Ipe.Types
import           Data.Geometry.QuadTree
import           Data.Geometry.QuadTree.Cell
import qualified Data.Text as T
import           Data.Tree.Util (TreeNode(..))
--------------------------------------------------------------------------------

-- | Draw a quadTree cell as a Path
drawCell :: Fractional r => IpeOut (Cell r) Path r
drawCell :: IpeOut (Cell r) Path r
drawCell = Rectangle () r
-> Path r
   :+ Attributes
        (AttrMapSym1 r)
        '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
           'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
           'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
forall r p. Num r => IpeOut (Rectangle p r) Path r
ipeRectangle (Rectangle () r
 -> Path r
    :+ Attributes
         (AttrMapSym1 r)
         '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
            'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
            'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient])
-> (Cell r -> Rectangle () r)
-> Cell r
-> Path r
   :+ Attributes
        (AttrMapSym1 r)
        '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
           'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
           'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cell r -> Rectangle () r
forall r. Fractional r => Cell r -> Box 2 () r
toBox

-- | Draws an entire quadtree.
drawQuadTree :: (Fractional r, Ord r) => IpeOut (QuadTree v p r) Group r
drawQuadTree :: IpeOut (QuadTree v p r) Group r
drawQuadTree = IpeOut (p :+ Cell r) Path r -> IpeOut (QuadTree v p r) Group r
forall (i :: * -> *) r p v.
(ToObject i, Fractional r, Ord r) =>
IpeOut (p :+ Cell r) i r -> IpeOut (QuadTree v p r) Group r
drawQuadTreeWith (\(p
_ :+ Cell r
c) -> IpeOut (Cell r) Path r
forall r. Fractional r => IpeOut (Cell r) Path r
drawCell Cell r
c)

-- | Draw a quadtree with a given method for drawing the cells.
drawQuadTreeWith           :: (ToObject i, Fractional r, Ord r)
                           => IpeOut (p :+ Cell r) i r -> IpeOut (QuadTree v p r) Group r
drawQuadTreeWith :: IpeOut (p :+ Cell r) i r -> IpeOut (QuadTree v p r) Group r
drawQuadTreeWith IpeOut (p :+ Cell r) i r
drawCell' = NonEmpty (IpeObject r)
-> Group r
   :+ Attributes
        (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
forall (f :: * -> *) r.
Foldable f =>
IpeOut (f (IpeObject r)) Group r
ipeGroup (NonEmpty (IpeObject r)
 -> Group r
    :+ Attributes
         (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip])
-> (QuadTree v p r -> NonEmpty (IpeObject r))
-> QuadTree v p r
-> Group r
   :+ Attributes
        (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((p :+ Cell r) -> IpeObject r)
-> NonEmpty (p :+ Cell r) -> NonEmpty (IpeObject r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IpeObject' i r -> IpeObject r
forall (i :: * -> *) r. ToObject i => IpeObject' i r -> IpeObject r
iO (IpeObject' i r -> IpeObject r)
-> IpeOut (p :+ Cell r) i r -> (p :+ Cell r) -> IpeObject r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IpeOut (p :+ Cell r) i r
drawCell') (NonEmpty (p :+ Cell r) -> NonEmpty (IpeObject r))
-> (QuadTree v p r -> NonEmpty (p :+ Cell r))
-> QuadTree v p r
-> NonEmpty (IpeObject r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuadTree (v :+ Cell r) (p :+ Cell r) r -> NonEmpty (p :+ Cell r)
forall v p r. QuadTree v p r -> NonEmpty p
leaves (QuadTree (v :+ Cell r) (p :+ Cell r) r -> NonEmpty (p :+ Cell r))
-> (QuadTree v p r -> QuadTree (v :+ Cell r) (p :+ Cell r) r)
-> QuadTree v p r
-> NonEmpty (p :+ Cell r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuadTree v p r -> QuadTree (v :+ Cell r) (p :+ Cell r) r
forall r v p.
(Fractional r, Ord r) =>
QuadTree v p r -> QuadTree (v :+ Cell r) (p :+ Cell r) r
withCells

-- | Draw every cell of a level of the quadtree.
quadTreeLevels           :: forall i r v p. (ToObject i, Fractional r, Ord r
                                            )
                         => IpeOut (TreeNode v p :+ Cell r) i r -> IpeOut (QuadTree v p r) Group r
quadTreeLevels :: IpeOut (TreeNode v p :+ Cell r) i r
-> IpeOut (QuadTree v p r) Group r
quadTreeLevels IpeOut (TreeNode v p :+ Cell r) i r
drawCell' = \QuadTree v p r
qt -> let lvls :: NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
lvls = (NonEmpty (TreeNode (v :+ Cell r) (p :+ Cell r))
 -> NonEmpty (TreeNode v p :+ Cell r))
-> NonEmpty (NonEmpty (TreeNode (v :+ Cell r) (p :+ Cell r)))
-> NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TreeNode (v :+ Cell r) (p :+ Cell r) -> TreeNode v p :+ Cell r)
-> NonEmpty (TreeNode (v :+ Cell r) (p :+ Cell r))
-> NonEmpty (TreeNode v p :+ Cell r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TreeNode (v :+ Cell r) (p :+ Cell r) -> TreeNode v p :+ Cell r
forall v extra a.
TreeNode (v :+ extra) (a :+ extra) -> TreeNode v a :+ extra
flip') (NonEmpty (NonEmpty (TreeNode (v :+ Cell r) (p :+ Cell r)))
 -> NonEmpty (NonEmpty (TreeNode v p :+ Cell r)))
-> (QuadTree v p r
    -> NonEmpty (NonEmpty (TreeNode (v :+ Cell r) (p :+ Cell r))))
-> QuadTree v p r
-> NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuadTree (v :+ Cell r) (p :+ Cell r) r
-> NonEmpty (NonEmpty (TreeNode (v :+ Cell r) (p :+ Cell r)))
forall v p r. QuadTree v p r -> NonEmpty (NonEmpty (TreeNode v p))
perLevel (QuadTree (v :+ Cell r) (p :+ Cell r) r
 -> NonEmpty (NonEmpty (TreeNode (v :+ Cell r) (p :+ Cell r))))
-> (QuadTree v p r -> QuadTree (v :+ Cell r) (p :+ Cell r) r)
-> QuadTree v p r
-> NonEmpty (NonEmpty (TreeNode (v :+ Cell r) (p :+ Cell r)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QuadTree v p r -> QuadTree (v :+ Cell r) (p :+ Cell r) r
forall r v p.
(Fractional r, Ord r) =>
QuadTree v p r -> QuadTree (v :+ Cell r) (p :+ Cell r) r
withCells (QuadTree v p r -> NonEmpty (NonEmpty (TreeNode v p :+ Cell r)))
-> QuadTree v p r -> NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
forall a b. (a -> b) -> a -> b
$ QuadTree v p r
qt
                                  in [IpeObject r]
-> Group r
   :+ Attributes
        (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
forall (f :: * -> *) r.
Foldable f =>
IpeOut (f (IpeObject r)) Group r
ipeGroup ([IpeObject r]
 -> Group r
    :+ Attributes
         (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip])
-> (NonEmpty (NonEmpty (TreeNode v p :+ Cell r)) -> [IpeObject r])
-> NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
-> Group r
   :+ Attributes
        (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Group r
  :+ Attributes
       (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip])
 -> IpeObject r)
-> [Group r
    :+ Attributes
         (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]]
-> [IpeObject r]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Group r
 :+ Attributes
      (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip])
-> IpeObject r
forall (i :: * -> *) r. ToObject i => IpeObject' i r -> IpeObject r
iO ([Group r
  :+ Attributes
       (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]]
 -> [IpeObject r])
-> (NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
    -> [Group r
        :+ Attributes
             (AttrMapSym1 r)
             '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]])
-> NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
-> [IpeObject r]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
 -> NonEmpty (TreeNode v p :+ Cell r)
 -> Group r
    :+ Attributes
         (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip])
-> [Int]
-> [NonEmpty (TreeNode v p :+ Cell r)]
-> [Group r
    :+ Attributes
         (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int
-> NonEmpty (TreeNode v p :+ Cell r)
-> Group r
   :+ Attributes
        (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
drawLevel [Int
1..] ([NonEmpty (TreeNode v p :+ Cell r)]
 -> [Group r
     :+ Attributes
          (AttrMapSym1 r)
          '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]])
-> (NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
    -> [NonEmpty (TreeNode v p :+ Cell r)])
-> NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
-> [Group r
    :+ Attributes
         (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
-> [NonEmpty (TreeNode v p :+ Cell r)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
 -> Group r
    :+ Attributes
         (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip])
-> NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
-> Group r
   :+ Attributes
        (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
forall a b. (a -> b) -> a -> b
$ NonEmpty (NonEmpty (TreeNode v p :+ Cell r))
lvls
  where
    flip' :: TreeNode (v :+ extra) (a :+ extra) -> TreeNode v a :+ extra
flip' = \case
      InternalNode (v
v :+ extra
c) -> v -> TreeNode v a
forall v a. v -> TreeNode v a
InternalNode v
v TreeNode v a -> extra -> TreeNode v a :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
c
      LeafNode (a
l :+ extra
c)     -> a -> TreeNode v a
forall v a. a -> TreeNode v a
LeafNode a
l     TreeNode v a -> extra -> TreeNode v a :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
c

    -- drawLevel   :: Int -> IpeOut (NonEmpty (TreeNode v p :+ Cell r)) Group r
    drawLevel :: Int
-> NonEmpty (TreeNode v p :+ Cell r)
-> Group r
   :+ Attributes
        (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
drawLevel Int
i = NonEmpty (IpeObject r)
-> Group r
   :+ Attributes
        (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
forall (f :: * -> *) r.
Foldable f =>
IpeOut (f (IpeObject r)) Group r
ipeGroup (NonEmpty (IpeObject r)
 -> Group r
    :+ Attributes
         (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip])
-> (NonEmpty (TreeNode v p :+ Cell r) -> NonEmpty (IpeObject r))
-> NonEmpty (TreeNode v p :+ Cell r)
-> Group r
   :+ Attributes
        (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TreeNode v p :+ Cell r) -> IpeObject r)
-> NonEmpty (TreeNode v p :+ Cell r) -> NonEmpty (IpeObject r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\TreeNode v p :+ Cell r
n -> (Group r :+ Attributes (AttrMapSym1 r) (AttributesOf Group))
-> IpeObject r
forall (i :: * -> *) r. ToObject i => IpeObject' i r -> IpeObject r
iO ((Group r :+ Attributes (AttrMapSym1 r) (AttributesOf Group))
 -> IpeObject r)
-> (Group r :+ Attributes (AttrMapSym1 r) (AttributesOf Group))
-> IpeObject r
forall a b. (a -> b) -> a -> b
$ IpeOut [IpeObject r] Group r
forall (f :: * -> *) r.
Foldable f =>
IpeOut (f (IpeObject r)) Group r
ipeGroup [IpeObject' i r -> IpeObject r
forall (i :: * -> *) r. ToObject i => IpeObject' i r -> IpeObject r
iO (IpeObject' i r -> IpeObject r) -> IpeObject' i r -> IpeObject r
forall a b. (a -> b) -> a -> b
$ IpeOut (TreeNode v p :+ Cell r) i r
drawCell' TreeNode v p :+ Cell r
n] (Group r :+ Attributes (AttrMapSym1 r) (AttributesOf Group))
-> Attributes (AttrMapSym1 r) (AttributesOf Group)
-> Group r :+ Attributes (AttrMapSym1 r) (AttributesOf Group)
forall (i :: * -> *) r.
IpeObject' i r -> IpeAttributes i r -> IpeObject' i r
! SAttributeUniverse 'Layer
-> Apply (AttrMapSym1 r) 'Layer
-> Attributes
     (AttrMapSym1 r) '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Clip]
forall u (at :: u) (ats :: [u]) (proxy :: u -> *) (f :: u ~> *).
(at ∈ ats, RecApplicative ats) =>
proxy at -> Apply f at -> Attributes f ats
attr SAttributeUniverse 'Layer
SLayer (Int -> LayerName
layer Int
i))

    layer   :: Int -> LayerName
    layer :: Int -> LayerName
layer Int
i = Text -> LayerName
LayerName (Text -> LayerName) -> Text -> LayerName
forall a b. (a -> b) -> a -> b
$ Text
"level_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
i)