{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.PlaneGraph.IO where
import Control.Lens
import Control.Monad (forM_)
import Data.Aeson
import Data.Bifunctor
import qualified Data.ByteString as B
import Data.Geometry.Point
import qualified Data.List as List
import qualified Data.PlanarGraph.AdjRep as PGA
import qualified Data.PlanarGraph.IO as PGIO
import Data.PlaneGraph.Core
import Data.PlaneGraph.AdjRep
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as MV
import Data.Yaml (ParseException)
import Data.Yaml.Util
import Data.RealNumber.Rational
readPlaneGraph :: forall s v e f r. (FromJSON v, FromJSON e, FromJSON f, FromJSON r)
=> B.ByteString
-> Either ParseException (PlaneGraph s v e f r)
readPlaneGraph :: ByteString -> Either ParseException (PlaneGraph s v e f r)
readPlaneGraph = ByteString -> Either ParseException (PlaneGraph s v e f r)
forall a. FromJSON a => ByteString -> Either ParseException a
decodeYaml
writePlaneGraph :: (ToJSON v, ToJSON e, ToJSON f, ToJSON r)
=> PlaneGraph s v e f r -> B.ByteString
writePlaneGraph :: PlaneGraph s v e f r -> ByteString
writePlaneGraph = PlaneGraph s v e f r -> ByteString
forall a. ToJSON a => a -> ByteString
encodeYaml
instance (ToJSON v, ToJSON e, ToJSON f, ToJSON r) => ToJSON (PlaneGraph s v e f r) where
toEncoding :: PlaneGraph s v e f r -> Encoding
toEncoding = Gr (Vtx v e r) (Face f) -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Gr (Vtx v e r) (Face f) -> Encoding)
-> (PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f))
-> PlaneGraph s v e f r
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
forall k (s :: k) v e f r.
PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
toAdjRep
toJSON :: PlaneGraph s v e f r -> Value
toJSON = Gr (Vtx v e r) (Face f) -> Value
forall a. ToJSON a => a -> Value
toJSON (Gr (Vtx v e r) (Face f) -> Value)
-> (PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f))
-> PlaneGraph s v e f r
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
forall k (s :: k) v e f r.
PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
toAdjRep
instance (FromJSON v, FromJSON e, FromJSON f, FromJSON r)
=> FromJSON (PlaneGraph s v e f r) where
parseJSON :: Value -> Parser (PlaneGraph s v e f r)
parseJSON Value
v = forall k (s :: k) v e f r.
Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r
forall v e f r. Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r
fromAdjRep @s (Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r)
-> Parser (Gr (Vtx v e r) (Face f))
-> Parser (PlaneGraph s v e f r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser (Gr (Vtx v e r) (Face f))
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v
toAdjRep :: PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
toAdjRep :: PlaneGraph s v e f r -> Gr (Vtx v e r) (Face f)
toAdjRep = (Vtx (VertexData r v) e -> Vtx v e r)
-> Gr (Vtx (VertexData r v) e) (Face f) -> Gr (Vtx v e r) (Face f)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\(PGA.Vtx Int
v [(Int, e)]
aj (VertexData Point 2 r
p v
x)) -> Int -> Point 2 r -> [(Int, e)] -> v -> Vtx v e r
forall v e r. Int -> Point 2 r -> [(Int, e)] -> v -> Vtx v e r
Vtx Int
v Point 2 r
p [(Int, e)]
aj v
x) (Gr (Vtx (VertexData r v) e) (Face f) -> Gr (Vtx v e r) (Face f))
-> (PlaneGraph s v e f r -> Gr (Vtx (VertexData r v) e) (Face f))
-> PlaneGraph s v e f r
-> Gr (Vtx v e r) (Face f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlanarGraph s 'Primal (VertexData r v) e f
-> Gr (Vtx (VertexData r v) e) (Face f)
forall k (s :: k) (w :: World) v e f.
PlanarGraph s w v e f -> Gr (Vtx v e) (Face f)
PGIO.toAdjRep
(PlanarGraph s 'Primal (VertexData r v) e f
-> Gr (Vtx (VertexData r v) e) (Face f))
-> (PlaneGraph s v e f r
-> PlanarGraph s 'Primal (VertexData r v) e f)
-> PlaneGraph s v e f r
-> Gr (Vtx (VertexData r v) e) (Face f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
(PlanarGraph s 'Primal (VertexData r v) e f)
(PlaneGraph s v e f r)
(PlanarGraph s 'Primal (VertexData r v) e f)
-> PlaneGraph s v e f r
-> PlanarGraph s 'Primal (VertexData r v) e f
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
(PlanarGraph s 'Primal (VertexData r v) e f)
(PlaneGraph s v e f r)
(PlanarGraph s 'Primal (VertexData r v) e f)
forall k (s :: k) v e f r k2 (s2 :: k2) v2 e2 f2 r2.
Iso
(PlaneGraph s v e f r)
(PlaneGraph s2 v2 e2 f2 r2)
(PlanarGraph s 'Primal (VertexData r v) e f)
(PlanarGraph s2 'Primal (VertexData r2 v2) e2 f2)
graph
fromAdjRep :: forall s v e f r. Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r
fromAdjRep :: Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r
fromAdjRep = PlanarGraph s 'Primal (VertexData r v) e f -> PlaneGraph s v e f r
forall k (s :: k) v e f r.
PlanarGraph s 'Primal (VertexData r v) e f -> PlaneGraph s v e f r
PlaneGraph (PlanarGraph s 'Primal (VertexData r v) e f
-> PlaneGraph s v e f r)
-> (Gr (Vtx v e r) (Face f)
-> PlanarGraph s 'Primal (VertexData r v) e f)
-> Gr (Vtx v e r) (Face f)
-> PlaneGraph s v e f r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Gr (Vtx (VertexData r v) e) (Face f)
-> PlanarGraph s 'Primal (VertexData r v) e f
forall k (s :: k) v e f.
Gr (Vtx v e) (Face f) -> PlanarGraph s 'Primal v e f
PGIO.fromAdjRep
(Gr (Vtx (VertexData r v) e) (Face f)
-> PlanarGraph s 'Primal (VertexData r v) e f)
-> (Gr (Vtx v e r) (Face f)
-> Gr (Vtx (VertexData r v) e) (Face f))
-> Gr (Vtx v e r) (Face f)
-> PlanarGraph s 'Primal (VertexData r v) e f
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Vtx v e r -> Vtx (VertexData r v) e)
-> Gr (Vtx v e r) (Face f) -> Gr (Vtx (VertexData r v) e) (Face f)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\(Vtx Int
v Point 2 r
p [(Int, e)]
aj v
x) -> Int -> [(Int, e)] -> VertexData r v -> Vtx (VertexData r v) e
forall v e. Int -> [(Int, e)] -> v -> Vtx v e
PGA.Vtx Int
v [(Int, e)]
aj (VertexData r v -> Vtx (VertexData r v) e)
-> VertexData r v -> Vtx (VertexData r v) e
forall a b. (a -> b) -> a -> b
$ Point 2 r -> v -> VertexData r v
forall r v. Point 2 r -> v -> VertexData r v
VertexData Point 2 r
p v
x)
makeCCW :: (Num r, Ord r) => Gr (Vtx v e r) f -> Gr (Vtx v e r) f
makeCCW :: Gr (Vtx v e r) f -> Gr (Vtx v e r) f
makeCCW (Gr [Vtx v e r]
vs [f]
fs) = [Vtx v e r] -> [f] -> Gr (Vtx v e r) f
forall v f. [v] -> [f] -> Gr v f
Gr ((Vtx v e r -> Vtx v e r) -> [Vtx v e r] -> [Vtx v e r]
forall a b. (a -> b) -> [a] -> [b]
map Vtx v e r -> Vtx v e r
sort' [Vtx v e r]
vs) [f]
fs
where
location' :: Vector (Point 2 r)
location' = (forall s. ST s (MVector s (Point 2 r))) -> Vector (Point 2 r)
forall a. (forall s. ST s (MVector s a)) -> Vector a
V.create ((forall s. ST s (MVector s (Point 2 r))) -> Vector (Point 2 r))
-> (forall s. ST s (MVector s (Point 2 r))) -> Vector (Point 2 r)
forall a b. (a -> b) -> a -> b
$ do
MVector s (Point 2 r)
a <- Int -> ST s (MVector (PrimState (ST s)) (Point 2 r))
forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
MV.new ([Vtx v e r] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Vtx v e r]
vs)
[Vtx v e r] -> (Vtx v e r -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Vtx v e r]
vs ((Vtx v e r -> ST s ()) -> ST s ())
-> (Vtx v e r -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Vtx Int
i Point 2 r
p [(Int, e)]
_ v
_) ->
MVector (PrimState (ST s)) (Point 2 r)
-> Int -> Point 2 r -> ST s ()
forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
MV.write MVector s (Point 2 r)
MVector (PrimState (ST s)) (Point 2 r)
a Int
i Point 2 r
p
MVector s (Point 2 r) -> ST s (MVector s (Point 2 r))
forall (f :: * -> *) a. Applicative f => a -> f a
pure MVector s (Point 2 r)
a
sort' :: Vtx v e r -> Vtx v e r
sort' (Vtx Int
v Point 2 r
p [(Int, e)]
ajs v
x) = Int -> Point 2 r -> [(Int, e)] -> v -> Vtx v e r
forall v e r. Int -> Point 2 r -> [(Int, e)] -> v -> Vtx v e r
Vtx Int
v Point 2 r
p (((Int, e) -> (Int, e) -> Ordering) -> [(Int, e)] -> [(Int, e)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy (Point 2 r -> (Int, e) -> (Int, e) -> Ordering
around Point 2 r
p) [(Int, e)]
ajs) v
x
around :: Point 2 r -> (Int, e) -> (Int, e) -> Ordering
around Point 2 r
p (Int
a,e
_) (Int
b,e
_) = Point 2 r -> Point 2 r -> Point 2 r -> Ordering
forall r.
(Num r, Ord r) =>
Point 2 r -> Point 2 r -> Point 2 r -> Ordering
ccwCmpAround Point 2 r
p (Vector (Point 2 r)
location' Vector (Point 2 r) -> Int -> Point 2 r
forall a. Vector a -> Int -> a
V.! Int
a) (Vector (Point 2 r)
location' Vector (Point 2 r) -> Int -> Point 2 r
forall a. Vector a -> Int -> a
V.! Int
b)
data MyWorld
myPlaneGraph :: PlaneGraph MyWorld Int () String (RealNumber 5)
myPlaneGraph :: PlaneGraph MyWorld Int () String (RealNumber 5)
myPlaneGraph = Gr (Vtx Int () (RealNumber 5)) (Face String)
-> PlaneGraph MyWorld Int () String (RealNumber 5)
forall k (s :: k) v e f r.
Gr (Vtx v e r) (Face f) -> PlaneGraph s v e f r
fromAdjRep @MyWorld Gr (Vtx Int () (RealNumber 5)) (Face String)
myPlaneGraphAdjrep
myPlaneGraphAdjrep :: Gr (Vtx Int () (RealNumber 5)) (Face String)
myPlaneGraphAdjrep :: Gr (Vtx Int () (RealNumber 5)) (Face String)
myPlaneGraphAdjrep = [Vtx Int () (RealNumber 5)]
-> [Face String] -> Gr (Vtx Int () (RealNumber 5)) (Face String)
forall v f. [v] -> [f] -> Gr v f
Gr [ Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
0 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
0 RealNumber 5
0 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
9, Int -> (Int, ())
forall a. a -> (a, ())
e Int
5, Int -> (Int, ())
forall a. a -> (a, ())
e Int
1, Int -> (Int, ())
forall a. a -> (a, ())
e Int
2]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
1 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
4 RealNumber 5
4 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
0, Int -> (Int, ())
forall a. a -> (a, ())
e Int
5, Int -> (Int, ())
forall a. a -> (a, ())
e Int
12]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
2 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
3 RealNumber 5
7 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
0, Int -> (Int, ())
forall a. a -> (a, ())
e Int
3]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
3 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
0 RealNumber 5
5 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
4, Int -> (Int, ())
forall a. a -> (a, ())
e Int
2]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
4 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
3 RealNumber 5
8 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
3, Int -> (Int, ())
forall a. a -> (a, ())
e Int
13]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
5 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
8 RealNumber 5
1 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
0, Int -> (Int, ())
forall a. a -> (a, ())
e Int
6, Int -> (Int, ())
forall a. a -> (a, ())
e Int
8, Int -> (Int, ())
forall a. a -> (a, ())
e Int
1]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
6 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
6 (-RealNumber 5
1)) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
5, Int -> (Int, ())
forall a. a -> (a, ())
e Int
9]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
7 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
9 (-RealNumber 5
1)) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
8, Int -> (Int, ())
forall a. a -> (a, ())
e Int
11]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
8 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
12 RealNumber 5
1 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
7, Int -> (Int, ())
forall a. a -> (a, ())
e Int
12, Int -> (Int, ())
forall a. a -> (a, ())
e Int
5]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
9 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
8 (-RealNumber 5
5)) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
0, Int -> (Int, ())
forall a. a -> (a, ())
e Int
10, Int -> (Int, ())
forall a. a -> (a, ())
e Int
6]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
10 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
12 (-RealNumber 5
3)) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
9, Int -> (Int, ())
forall a. a -> (a, ())
e Int
11]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
11 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
14 (-RealNumber 5
1)) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
10, Int -> (Int, ())
forall a. a -> (a, ())
e Int
7]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
12 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
10 RealNumber 5
4 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
1, Int -> (Int, ())
forall a. a -> (a, ())
e Int
8, Int -> (Int, ())
forall a. a -> (a, ())
e Int
13, Int -> (Int, ())
forall a. a -> (a, ())
e Int
14]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
13 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
9 RealNumber 5
6 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
4, Int -> (Int, ())
forall a. a -> (a, ())
e Int
14, Int -> (Int, ())
forall a. a -> (a, ())
e Int
12]
, Int
-> Point 2 (RealNumber 5)
-> [(Int, ())]
-> Vtx Int () (RealNumber 5)
forall r e. Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
14 (RealNumber 5 -> RealNumber 5 -> Point 2 (RealNumber 5)
forall r. r -> r -> Point 2 r
Point2 RealNumber 5
8 RealNumber 5
5 ) [Int -> (Int, ())
forall a. a -> (a, ())
e Int
13, Int -> (Int, ())
forall a. a -> (a, ())
e Int
12]
]
[ (Int, Int) -> String -> Face String
forall f. (Int, Int) -> f -> Face f
Face (Int
0,Int
9) String
"OuterFace"
, (Int, Int) -> String -> Face String
forall f. (Int, Int) -> f -> Face f
Face (Int
0,Int
5) String
"A"
, (Int, Int) -> String -> Face String
forall f. (Int, Int) -> f -> Face f
Face (Int
0,Int
1) String
"B"
, (Int, Int) -> String -> Face String
forall f. (Int, Int) -> f -> Face f
Face (Int
0,Int
2) String
"C"
, (Int, Int) -> String -> Face String
forall f. (Int, Int) -> f -> Face f
Face (Int
14,Int
13) String
"D"
, (Int, Int) -> String -> Face String
forall f. (Int, Int) -> f -> Face f
Face (Int
1,Int
12) String
"E"
, (Int, Int) -> String -> Face String
forall f. (Int, Int) -> f -> Face f
Face (Int
5,Int
8) String
"F"
]
where
e :: a -> (a, ())
e a
i = (a
i,())
vtx :: Int -> Point 2 r -> [(Int, e)] -> Vtx Int e r
vtx Int
i Point 2 r
p [(Int, e)]
es = Int -> Point 2 r -> [(Int, e)] -> Int -> Vtx Int e r
forall v e r. Int -> Point 2 r -> [(Int, e)] -> v -> Vtx v e r
Vtx Int
i Point 2 r
p [(Int, e)]
es Int
i