module Ipe.FromIpe.UnboundedConvexChain where

import           Control.Lens
import           Data.Foldable1
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Sequence as Seq
import           HGeometry.Ext
import           HGeometry.Point
import           HGeometry.PolyLine (PolyLine, polyLineFromPoints)
import           HGeometry.Polygon.Convex.Unbounded
import           HGeometry.Vector
import           Ipe.Attributes
import           Ipe.Path
import           Ipe.Types

-------------------------------------------------------------------------------

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Ipe.Attributes
-- >>> import Ipe.Color(IpeColor(..))
-- >>> import qualified HGeometry.PolyLine as PolyLine
-- >>> :{
-- let testPath :: Path Int
--     testPath = Path . fromSingleton  . PolyLineSegment
--              . PolyLine.polyLineFromPoints . NonEmpty.fromList
--              $ [ origin, Point2 10 10, Point2 200 100 ]
--     testPathAttrs :: IpeAttributes Path Int
--     testPathAttrs = attr SStroke (IpeColor "red")
--     testObject :: IpeObject Int
--     testObject = IpePath (testPath :+ testPathAttrs)
-- :}


-- | Renders an unbounded convex region as a Path
renderChain :: (Foldable1 nonEmpty, Point_ vertex 2 r, Num r)
            => UnboundedConvexRegionF r nonEmpty vertex :+ IpeAttributes Path r
            -> IpeObject' Path r
renderChain :: forall (nonEmpty :: * -> *) vertex r.
(Foldable1 nonEmpty, Point_ vertex 2 r, Num r) =>
(UnboundedConvexRegionF r nonEmpty vertex :+ IpeAttributes Path r)
-> IpeObject' Path r
renderChain (reg :: UnboundedConvexRegionF r nonEmpty vertex
reg@(Unbounded Vector 2 r
v nonEmpty vertex
pts Vector 2 r
w) :+ IpeAttributes Path r
ats) =
    (PolyLine (Point 2 r)
polyPolyLine (Point 2 r)
-> Getting (Path r) (PolyLine (Point 2 r)) (Path r) -> Path r
forall s a. s -> Getting a s a -> a
^.AReview (Path r) (PolyLine (Point 2 r))
-> Getter (PolyLine (Point 2 r)) (Path r)
forall t b. AReview t b -> Getter b t
re AReview (Path r) (PolyLine (Point 2 r))
forall r (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p (PolyLine (Point 2 r)) (f (PolyLine (Point 2 r)))
-> p (Path r) (f (Path r))
_asPolyLine) Path r
-> Attributes
     (AttrMapSym1 r)
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
        'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
        'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
-> Path r
   :+ Attributes
        (AttrMapSym1 r)
        '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
           'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
           'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
forall core extra. core -> extra -> core :+ extra
:+     SAttributeUniverse 'Arrow
-> Apply (AttrMapSym1 r) 'Arrow
-> Attributes
     (AttrMapSym1 r)
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
        'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
        'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
forall {u} (at :: u) (ats :: [u]) (proxy :: u -> *) (f :: u ~> *).
(at ∈ ats, RecApplicative ats) =>
proxy at -> Apply f at -> Attributes f ats
attr SAttributeUniverse 'Arrow
SArrow  Apply (AttrMapSym1 r) 'Arrow
IpeArrow r
forall r. IpeArrow r
normalArrow
                               Attributes
  (AttrMapSym1 r)
  '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
     'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
     'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
-> Attributes
     (AttrMapSym1 r)
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
        'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
        'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
-> Attributes
     (AttrMapSym1 r)
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
        'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
        'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
forall a. Semigroup a => a -> a -> a
<> SAttributeUniverse 'RArrow
-> Apply (AttrMapSym1 r) 'RArrow
-> Attributes
     (AttrMapSym1 r)
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
        'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
        'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
forall {u} (at :: u) (ats :: [u]) (proxy :: u -> *) (f :: u ~> *).
(at ∈ ats, RecApplicative ats) =>
proxy at -> Apply f at -> Attributes f ats
attr SAttributeUniverse 'RArrow
SRArrow Apply (AttrMapSym1 r) 'RArrow
IpeArrow r
forall r. IpeArrow r
normalArrow
                               Attributes
  (AttrMapSym1 r)
  '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
     'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
     'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
-> Attributes
     (AttrMapSym1 r)
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
        'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
        'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
-> Attributes
     (AttrMapSym1 r)
     '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
        'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
        'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
forall a. Semigroup a => a -> a -> a
<> Attributes
  (AttrMapSym1 r)
  '[ 'Layer, 'Matrix, 'Pin, 'Transformations, 'Stroke, 'Fill, 'Dash,
     'Pen, 'LineCap, 'LineJoin, 'FillRule, 'Arrow, 'RArrow,
     'StrokeOpacity, 'Opacity, 'Tiling, 'Gradient]
IpeAttributes Path r
ats
  where
    poly :: PolyLine (Point 2 r)
poly = case UnboundedConvexRegionF r NonEmpty vertex
-> Either vertex (Vector 2 vertex)
forall r vertex.
UnboundedConvexRegionF r NonEmpty vertex
-> Either vertex (Vector 2 vertex)
extremalVertices ((nonEmpty vertex -> NonEmpty vertex)
-> UnboundedConvexRegionF r nonEmpty vertex
-> UnboundedConvexRegionF r NonEmpty vertex
forall (nonEmpty :: * -> *) vertex (nonEmpty' :: * -> *) vertex' r.
(nonEmpty vertex -> nonEmpty' vertex')
-> UnboundedConvexRegionF r nonEmpty vertex
-> UnboundedConvexRegionF r nonEmpty' vertex'
mapChain nonEmpty vertex -> NonEmpty vertex
forall a. nonEmpty a -> NonEmpty a
forall (t :: * -> *) a. Foldable1 t => t a -> NonEmpty a
toNonEmpty UnboundedConvexRegionF r nonEmpty vertex
reg) of
             Left vertex
p              -> vertex -> vertex -> PolyLine (Point 2 r)
f vertex
p vertex
p
             Right (Vector2 vertex
p vertex
q) -> vertex -> vertex -> PolyLine (Point 2 r)
f vertex
p vertex
q
    f :: vertex -> vertex -> PolyLine (Point 2 r)
f vertex
p vertex
q = NonEmpty (Point 2 r) -> PolyLine (Point 2 r)
forall polyLine point (f :: * -> *).
(ConstructablePolyLine_ polyLine point, Foldable1 f) =>
f point -> polyLine
forall (f :: * -> *).
Foldable1 f =>
f (Point 2 r) -> PolyLine (Point 2 r)
polyLineFromPoints (NonEmpty (Point 2 r) -> PolyLine (Point 2 r))
-> (NonEmpty vertex -> NonEmpty (Point 2 r))
-> NonEmpty vertex
-> PolyLine (Point 2 r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (vertex -> Point 2 r) -> NonEmpty vertex -> NonEmpty (Point 2 r)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (vertex -> Getting (Point 2 r) vertex (Point 2 r) -> Point 2 r
forall s a. s -> Getting a s a -> a
^.Getting (Point 2 r) vertex (Point 2 r)
forall point (d :: Nat) r.
Point_ point d r =>
Lens' point (Point d r)
Lens' vertex (Point 2 r)
asPoint)
          (NonEmpty vertex -> PolyLine (Point 2 r))
-> NonEmpty vertex -> PolyLine (Point 2 r)
forall a b. (a -> b) -> a -> b
$ vertex
p vertex -> Vector 2 r -> vertex
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> Vector d r -> point
.-^ Vector 2 r
v vertex -> NonEmpty vertex -> NonEmpty vertex
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.<| nonEmpty vertex -> NonEmpty vertex
forall a. nonEmpty a -> NonEmpty a
forall (t :: * -> *) a. Foldable1 t => t a -> NonEmpty a
toNonEmpty nonEmpty vertex
pts NonEmpty vertex -> NonEmpty vertex -> NonEmpty vertex
forall a. Semigroup a => a -> a -> a
<> vertex -> NonEmpty vertex
forall a. a -> NonEmpty a
NonEmpty.singleton (vertex
q vertex -> Vector 2 r -> vertex
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> Vector d r -> point
.+^ Vector 2 r
w)


-- | Convert to a polyline. Ignores all non-polyline parts
--
-- >>> testPath ^? _asPolyLine
-- Just (PolyLine [Point2 0 0,Point2 10 10,Point2 200 100])
_asPolyLine :: Prism' (Path r) (PolyLine (Point 2 r))
_asPolyLine :: forall r (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p (PolyLine (Point 2 r)) (f (PolyLine (Point 2 r)))
-> p (Path r) (f (Path r))
_asPolyLine = (PolyLine (Point 2 r) -> Path r)
-> (Path r -> Maybe (PolyLine (Point 2 r)))
-> Prism
     (Path r) (Path r) (PolyLine (Point 2 r)) (PolyLine (Point 2 r))
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' PolyLine (Point 2 r) -> Path r
forall {r}. PolyLine (Point 2 r) -> Path r
poly2path Path r -> Maybe (PolyLine (Point 2 r))
path2poly
  where
    poly2path :: PolyLine (Point 2 r) -> Path r
poly2path = Seq (PathSegment r) -> Path r
forall r. Seq (PathSegment r) -> Path r
Path (Seq (PathSegment r) -> Path r)
-> (PolyLine (Point 2 r) -> Seq (PathSegment r))
-> PolyLine (Point 2 r)
-> Path r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegment r -> Seq (PathSegment r)
forall a. a -> Seq a
fromSingleton  (PathSegment r -> Seq (PathSegment r))
-> (PolyLine (Point 2 r) -> PathSegment r)
-> PolyLine (Point 2 r)
-> Seq (PathSegment r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolyLine (Point 2 r) -> PathSegment r
forall r. PolyLine (Point 2 r) -> PathSegment r
PolyLineSegment
    path2poly :: Path r -> Maybe (PolyLine (Point 2 r))
path2poly = Getting
  (First (PolyLine (Point 2 r))) (Path r) (PolyLine (Point 2 r))
-> Path r -> Maybe (PolyLine (Point 2 r))
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((Seq (PathSegment r)
 -> Const (First (PolyLine (Point 2 r))) (Seq (PathSegment r)))
-> Path r -> Const (First (PolyLine (Point 2 r))) (Path r)
forall r r' (p :: * -> * -> *) (f :: * -> *).
(Profunctor p, Functor f) =>
p (Seq (PathSegment r)) (f (Seq (PathSegment r')))
-> p (Path r) (f (Path r'))
pathSegments((Seq (PathSegment r)
  -> Const (First (PolyLine (Point 2 r))) (Seq (PathSegment r)))
 -> Path r -> Const (First (PolyLine (Point 2 r))) (Path r))
-> ((PolyLine (Point 2 r)
     -> Const (First (PolyLine (Point 2 r))) (PolyLine (Point 2 r)))
    -> Seq (PathSegment r)
    -> Const (First (PolyLine (Point 2 r))) (Seq (PathSegment r)))
-> Getting
     (First (PolyLine (Point 2 r))) (Path r) (PolyLine (Point 2 r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PathSegment r
 -> Const (First (PolyLine (Point 2 r))) (PathSegment r))
-> Seq (PathSegment r)
-> Const (First (PolyLine (Point 2 r))) (Seq (PathSegment r))
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int (Seq (PathSegment r)) (PathSegment r)
folded((PathSegment r
  -> Const (First (PolyLine (Point 2 r))) (PathSegment r))
 -> Seq (PathSegment r)
 -> Const (First (PolyLine (Point 2 r))) (Seq (PathSegment r)))
-> ((PolyLine (Point 2 r)
     -> Const (First (PolyLine (Point 2 r))) (PolyLine (Point 2 r)))
    -> PathSegment r
    -> Const (First (PolyLine (Point 2 r))) (PathSegment r))
-> (PolyLine (Point 2 r)
    -> Const (First (PolyLine (Point 2 r))) (PolyLine (Point 2 r)))
-> Seq (PathSegment r)
-> Const (First (PolyLine (Point 2 r))) (Seq (PathSegment r))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PolyLine (Point 2 r)
 -> Const (First (PolyLine (Point 2 r))) (PolyLine (Point 2 r)))
-> PathSegment r
-> Const (First (PolyLine (Point 2 r))) (PathSegment r)
forall r (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p (PolyLine (Point 2 r)) (f (PolyLine (Point 2 r)))
-> p (PathSegment r) (f (PathSegment r))
_PolyLineSegment)
    -- TODO: Check that the path actually is a polyline, rather
    -- than ignoring everything that does not fit

-- | Helper to produce a singleton sequence
fromSingleton :: a -> Seq.Seq a
fromSingleton :: forall a. a -> Seq a
fromSingleton = a -> Seq a
forall a. a -> Seq a
Seq.singleton