{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Diagrams.TwoD.Polygons(
PolyType(..)
, PolyOrientation(..)
, PolygonOpts(..), polyType, polyOrient, polyCenter
, polygon
, polyTrail
, polyPolarTrail
, polySidesTrail
, polyRegularTrail
, orient
, StarOpts(..)
, star
, GraphPart(..)
, orbits, mkGraph
) where
import Control.Lens (Lens', generateSignatures, lensRules,
makeLensesWith, view, (.~), (^.))
import Control.Monad (forM, liftM)
import Control.Monad.ST (ST, runST)
import Data.Array.ST (STUArray, newArray, readArray,
writeArray)
import Data.Default.Class
import Data.List (maximumBy, minimumBy)
import Data.Maybe (catMaybes)
import Data.Ord (comparing)
import Diagrams.Angle
import Diagrams.Core
import Diagrams.Located
import Diagrams.Path
import Diagrams.Points (centroid)
import Diagrams.Trail
import Diagrams.TrailLike
import Diagrams.TwoD.Types
import Diagrams.TwoD.Vector (leftTurn, unitX, unitY, unit_Y)
import Diagrams.Util (tau, ( # ))
import Linear.Affine
import Linear.Metric
import Linear.Vector
data PolyType n = PolyPolar [Angle n] [n]
| PolySides [Angle n] [n]
| PolyRegular Int n
data PolyOrientation n = NoOrient
| OrientH
| OrientV
| OrientTo (V2 n)
deriving (PolyOrientation n -> PolyOrientation n -> Bool
(PolyOrientation n -> PolyOrientation n -> Bool)
-> (PolyOrientation n -> PolyOrientation n -> Bool)
-> Eq (PolyOrientation n)
forall n. Eq n => PolyOrientation n -> PolyOrientation n -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PolyOrientation n -> PolyOrientation n -> Bool
$c/= :: forall n. Eq n => PolyOrientation n -> PolyOrientation n -> Bool
== :: PolyOrientation n -> PolyOrientation n -> Bool
$c== :: forall n. Eq n => PolyOrientation n -> PolyOrientation n -> Bool
Eq, Eq (PolyOrientation n)
Eq (PolyOrientation n) =>
(PolyOrientation n -> PolyOrientation n -> Ordering)
-> (PolyOrientation n -> PolyOrientation n -> Bool)
-> (PolyOrientation n -> PolyOrientation n -> Bool)
-> (PolyOrientation n -> PolyOrientation n -> Bool)
-> (PolyOrientation n -> PolyOrientation n -> Bool)
-> (PolyOrientation n -> PolyOrientation n -> PolyOrientation n)
-> (PolyOrientation n -> PolyOrientation n -> PolyOrientation n)
-> Ord (PolyOrientation n)
PolyOrientation n -> PolyOrientation n -> Bool
PolyOrientation n -> PolyOrientation n -> Ordering
PolyOrientation n -> PolyOrientation n -> PolyOrientation n
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall n. Ord n => Eq (PolyOrientation n)
forall n. Ord n => PolyOrientation n -> PolyOrientation n -> Bool
forall n.
Ord n =>
PolyOrientation n -> PolyOrientation n -> Ordering
forall n.
Ord n =>
PolyOrientation n -> PolyOrientation n -> PolyOrientation n
min :: PolyOrientation n -> PolyOrientation n -> PolyOrientation n
$cmin :: forall n.
Ord n =>
PolyOrientation n -> PolyOrientation n -> PolyOrientation n
max :: PolyOrientation n -> PolyOrientation n -> PolyOrientation n
$cmax :: forall n.
Ord n =>
PolyOrientation n -> PolyOrientation n -> PolyOrientation n
>= :: PolyOrientation n -> PolyOrientation n -> Bool
$c>= :: forall n. Ord n => PolyOrientation n -> PolyOrientation n -> Bool
> :: PolyOrientation n -> PolyOrientation n -> Bool
$c> :: forall n. Ord n => PolyOrientation n -> PolyOrientation n -> Bool
<= :: PolyOrientation n -> PolyOrientation n -> Bool
$c<= :: forall n. Ord n => PolyOrientation n -> PolyOrientation n -> Bool
< :: PolyOrientation n -> PolyOrientation n -> Bool
$c< :: forall n. Ord n => PolyOrientation n -> PolyOrientation n -> Bool
compare :: PolyOrientation n -> PolyOrientation n -> Ordering
$ccompare :: forall n.
Ord n =>
PolyOrientation n -> PolyOrientation n -> Ordering
$cp1Ord :: forall n. Ord n => Eq (PolyOrientation n)
Ord, Int -> PolyOrientation n -> ShowS
[PolyOrientation n] -> ShowS
PolyOrientation n -> String
(Int -> PolyOrientation n -> ShowS)
-> (PolyOrientation n -> String)
-> ([PolyOrientation n] -> ShowS)
-> Show (PolyOrientation n)
forall n. Show n => Int -> PolyOrientation n -> ShowS
forall n. Show n => [PolyOrientation n] -> ShowS
forall n. Show n => PolyOrientation n -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PolyOrientation n] -> ShowS
$cshowList :: forall n. Show n => [PolyOrientation n] -> ShowS
show :: PolyOrientation n -> String
$cshow :: forall n. Show n => PolyOrientation n -> String
showsPrec :: Int -> PolyOrientation n -> ShowS
$cshowsPrec :: forall n. Show n => Int -> PolyOrientation n -> ShowS
Show, ReadPrec [PolyOrientation n]
ReadPrec (PolyOrientation n)
Int -> ReadS (PolyOrientation n)
ReadS [PolyOrientation n]
(Int -> ReadS (PolyOrientation n))
-> ReadS [PolyOrientation n]
-> ReadPrec (PolyOrientation n)
-> ReadPrec [PolyOrientation n]
-> Read (PolyOrientation n)
forall n. Read n => ReadPrec [PolyOrientation n]
forall n. Read n => ReadPrec (PolyOrientation n)
forall n. Read n => Int -> ReadS (PolyOrientation n)
forall n. Read n => ReadS [PolyOrientation n]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PolyOrientation n]
$creadListPrec :: forall n. Read n => ReadPrec [PolyOrientation n]
readPrec :: ReadPrec (PolyOrientation n)
$creadPrec :: forall n. Read n => ReadPrec (PolyOrientation n)
readList :: ReadS [PolyOrientation n]
$creadList :: forall n. Read n => ReadS [PolyOrientation n]
readsPrec :: Int -> ReadS (PolyOrientation n)
$creadsPrec :: forall n. Read n => Int -> ReadS (PolyOrientation n)
Read)
data PolygonOpts n = PolygonOpts
{ PolygonOpts n -> PolyType n
_polyType :: PolyType n
, PolygonOpts n -> PolyOrientation n
_polyOrient :: PolyOrientation n
, PolygonOpts n -> Point V2 n
_polyCenter :: Point V2 n
}
makeLensesWith (generateSignatures .~ False $ lensRules) ''PolygonOpts
polyType :: Lens' (PolygonOpts n) (PolyType n)
polyOrient :: Lens' (PolygonOpts n) (PolyOrientation n)
polyCenter :: Lens' (PolygonOpts n) (Point V2 n)
instance Num n => Default (PolygonOpts n) where
def :: PolygonOpts n
def = PolyType n -> PolyOrientation n -> Point V2 n -> PolygonOpts n
forall n.
PolyType n -> PolyOrientation n -> Point V2 n -> PolygonOpts n
PolygonOpts (Int -> n -> PolyType n
forall n. Int -> n -> PolyType n
PolyRegular 5 1) PolyOrientation n
forall n. PolyOrientation n
OrientH Point V2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
polyTrail :: OrderedField n => PolygonOpts n -> Located (Trail V2 n)
polyTrail :: PolygonOpts n -> Located (Trail V2 n)
polyTrail po :: PolygonOpts n
po = Transformation
(V (Located (Trail V2 n))) (N (Located (Trail V2 n)))
-> Located (Trail V2 n) -> Located (Trail V2 n)
forall t. Transformable t => Transformation (V t) (N t) -> t -> t
transform Transformation
(V (Located (Trail V2 n))) (N (Located (Trail V2 n)))
Transformation V2 n
ori Located (Trail V2 n)
tr
where
tr :: Located (Trail V2 n)
tr = case PolygonOpts n
poPolygonOpts n
-> Getting (PolyType n) (PolygonOpts n) (PolyType n) -> PolyType n
forall s a. s -> Getting a s a -> a
^.Getting (PolyType n) (PolygonOpts n) (PolyType n)
forall n. Lens' (PolygonOpts n) (PolyType n)
polyType of
PolyPolar ans :: [Angle n]
ans szs :: [n]
szs -> [Angle n] -> [n] -> Located (Trail V2 n)
forall n.
OrderedField n =>
[Angle n] -> [n] -> Located (Trail V2 n)
polyPolarTrail [Angle n]
ans [n]
szs
PolySides ans :: [Angle n]
ans szs :: [n]
szs -> [Angle n] -> [n] -> Located (Trail V2 n)
forall n.
OrderedField n =>
[Angle n] -> [n] -> Located (Trail V2 n)
polySidesTrail [Angle n]
ans [n]
szs
PolyRegular n :: Int
n r :: n
r -> Int -> n -> Located (Trail V2 n)
forall n. OrderedField n => Int -> n -> Located (Trail V2 n)
polyRegularTrail Int
n n
r
ori :: Transformation V2 n
ori = case PolygonOpts n
poPolygonOpts n
-> Getting (PolyOrientation n) (PolygonOpts n) (PolyOrientation n)
-> PolyOrientation n
forall s a. s -> Getting a s a -> a
^.Getting (PolyOrientation n) (PolygonOpts n) (PolyOrientation n)
forall n. Lens' (PolygonOpts n) (PolyOrientation n)
polyOrient of
OrientH -> V2 n -> Located (Trail V2 n) -> Transformation V2 n
forall n.
OrderedField n =>
V2 n -> Located (Trail V2 n) -> Transformation V2 n
orient V2 n
forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unit_Y Located (Trail V2 n)
tr
OrientV -> V2 n -> Located (Trail V2 n) -> Transformation V2 n
forall n.
OrderedField n =>
V2 n -> Located (Trail V2 n) -> Transformation V2 n
orient V2 n
forall (v :: * -> *) n. (R1 v, Additive v, Num n) => v n
unitX Located (Trail V2 n)
tr
OrientTo v :: V2 n
v -> V2 n -> Located (Trail V2 n) -> Transformation V2 n
forall n.
OrderedField n =>
V2 n -> Located (Trail V2 n) -> Transformation V2 n
orient V2 n
v Located (Trail V2 n)
tr
NoOrient -> Transformation V2 n
forall a. Monoid a => a
mempty
polygon :: (InSpace V2 n t, TrailLike t) => PolygonOpts n -> t
polygon :: PolygonOpts n -> t
polygon = Located (Trail V2 n) -> t
forall t. TrailLike t => Located (Trail (V t) (N t)) -> t
trailLike (Located (Trail V2 n) -> t)
-> (PolygonOpts n -> Located (Trail V2 n)) -> PolygonOpts n -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolygonOpts n -> Located (Trail V2 n)
forall n. OrderedField n => PolygonOpts n -> Located (Trail V2 n)
polyTrail
polyPolarTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n)
polyPolarTrail :: [Angle n] -> [n] -> Located (Trail V2 n)
polyPolarTrail [] _ = Trail V2 n
forall (v :: * -> *) n. (Metric v, OrderedField n) => Trail v n
emptyTrail Trail V2 n
-> Point (V (Trail V2 n)) (N (Trail V2 n)) -> Located (Trail V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V (Trail V2 n)) (N (Trail V2 n))
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
polyPolarTrail _ [] = Trail V2 n
forall (v :: * -> *) n. (Metric v, OrderedField n) => Trail v n
emptyTrail Trail V2 n
-> Point (V (Trail V2 n)) (N (Trail V2 n)) -> Located (Trail V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V (Trail V2 n)) (N (Trail V2 n))
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin
polyPolarTrail ans :: [Angle n]
ans (r :: n
r:rs :: [n]
rs) = Trail V2 n
tr Trail V2 n
-> Point (V (Trail V2 n)) (N (Trail V2 n)) -> Located (Trail V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` Point (V (Trail V2 n)) (N (Trail V2 n))
P2 n
p1
where
p1 :: P2 n
p1 = (n, n) -> P2 n
forall n. (n, n) -> P2 n
p2 (1,0) P2 n -> (P2 n -> P2 n) -> P2 n
forall a b. a -> (a -> b) -> b
# n -> P2 n -> P2 n
forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
r
tr :: Trail V2 n
tr = Trail V2 n -> Trail V2 n
forall (v :: * -> *) n. Trail v n -> Trail v n
closeTrail (Trail V2 n -> Trail V2 n)
-> ([P2 n] -> Trail V2 n) -> [P2 n] -> Trail V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [P2 n] -> Trail V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[Point v n] -> Trail v n
trailFromVertices ([P2 n] -> Trail V2 n) -> [P2 n] -> Trail V2 n
forall a b. (a -> b) -> a -> b
$
(Angle n -> n -> P2 n) -> [Angle n] -> [n] -> [P2 n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
(\a :: Angle n
a l :: n
l -> Angle n -> P2 n -> P2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate Angle n
a (P2 n -> P2 n) -> (P2 n -> P2 n) -> P2 n -> P2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. n -> P2 n -> P2 n
forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale n
l (P2 n -> P2 n) -> P2 n -> P2 n
forall a b. (a -> b) -> a -> b
$ (n, n) -> P2 n
forall n. (n, n) -> P2 n
p2 (1,0))
((Angle n -> Angle n -> Angle n)
-> Angle n -> [Angle n] -> [Angle n]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Angle n -> Angle n -> Angle n
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
(^+^) Angle n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero [Angle n]
ans)
(n
rn -> [n] -> [n]
forall a. a -> [a] -> [a]
:[n]
rs)
polySidesTrail :: OrderedField n => [Angle n] -> [n] -> Located (Trail V2 n)
polySidesTrail :: [Angle n] -> [n] -> Located (Trail V2 n)
polySidesTrail ans :: [Angle n]
ans ls :: [n]
ls = Trail V2 n
tr Trail V2 n
-> Point (V (Trail V2 n)) (N (Trail V2 n)) -> Located (Trail V2 n)
forall a. a -> Point (V a) (N a) -> Located a
`at` ([Point V2 n] -> Point V2 n
forall (v :: * -> *) n.
(Additive v, Fractional n) =>
[Point v n] -> Point v n
centroid [Point V2 n]
ps Point V2 n -> (Point V2 n -> Point V2 n) -> Point V2 n
forall a b. a -> (a -> b) -> b
# n -> Point V2 n -> Point V2 n
forall (v :: * -> *) n a.
(InSpace v n a, Eq n, Fractional n, Transformable a) =>
n -> a -> a
scale (-1))
where
ans' :: [Angle n]
ans' = (Angle n -> Angle n -> Angle n)
-> Angle n -> [Angle n] -> [Angle n]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Angle n -> Angle n -> Angle n
forall (f :: * -> *) a. (Additive f, Num a) => f a -> f a -> f a
(^+^) Angle n
forall (f :: * -> *) a. (Additive f, Num a) => f a
zero [Angle n]
ans
offsets :: [V2 n]
offsets = (Angle n -> V2 n -> V2 n) -> [Angle n] -> [V2 n] -> [V2 n]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Angle n -> V2 n -> V2 n
forall n t.
(InSpace V2 n t, Transformable t, Floating n) =>
Angle n -> t -> t
rotate [Angle n]
ans' ((n -> V2 n) -> [n] -> [V2 n]
forall a b. (a -> b) -> [a] -> [b]
map (V2 n
forall (v :: * -> *) n. (R2 v, Additive v, Num n) => v n
unitY V2 n -> n -> V2 n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> a -> f a
^*) [n]
ls)
ps :: [Point V2 n]
ps = (Point V2 n -> V2 n -> Point V2 n)
-> Point V2 n -> [V2 n] -> [Point V2 n]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Point V2 n -> V2 n -> Point V2 n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
(.+^) Point V2 n
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin [V2 n]
offsets
tr :: Trail V2 n
tr = Trail V2 n -> Trail V2 n
forall (v :: * -> *) n. Trail v n -> Trail v n
closeTrail (Trail V2 n -> Trail V2 n)
-> ([V2 n] -> Trail V2 n) -> [V2 n] -> Trail V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [V2 n] -> Trail V2 n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
[v n] -> Trail v n
trailFromOffsets ([V2 n] -> Trail V2 n) -> [V2 n] -> Trail V2 n
forall a b. (a -> b) -> a -> b
$ [V2 n]
offsets
polyRegularTrail :: OrderedField n => Int -> n -> Located (Trail V2 n)
polyRegularTrail :: Int -> n -> Located (Trail V2 n)
polyRegularTrail n :: Int
n r :: n
r = [Angle n] -> [n] -> Located (Trail V2 n)
forall n.
OrderedField n =>
[Angle n] -> [n] -> Located (Trail V2 n)
polyPolarTrail
(Int -> Angle n -> [Angle n]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) (Angle n -> [Angle n]) -> Angle n -> [Angle n]
forall a b. (a -> b) -> a -> b
$ Angle n
forall v. Floating v => Angle v
fullTurn Angle n -> n -> Angle n
forall (f :: * -> *) a.
(Functor f, Fractional a) =>
f a -> a -> f a
^/ Int -> n
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
(n -> [n]
forall a. a -> [a]
repeat n
r)
orient :: OrderedField n => V2 n -> Located (Trail V2 n) -> Transformation V2 n
orient :: V2 n -> Located (Trail V2 n) -> Transformation V2 n
orient v :: V2 n
v = V2 n -> [Point V2 n] -> Transformation V2 n
forall n.
OrderedField n =>
V2 n -> [Point V2 n] -> Transformation V2 n
orientPoints V2 n
v ([Point V2 n] -> Transformation V2 n)
-> (Located (Trail V2 n) -> [Point V2 n])
-> Located (Trail V2 n)
-> Transformation V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (Trail V2 n) -> [Point V2 n]
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Located (Trail v n) -> [Point v n]
trailVertices
orientPoints :: OrderedField n => V2 n -> [Point V2 n] -> Transformation V2 n
orientPoints :: V2 n -> [Point V2 n] -> Transformation V2 n
orientPoints _ [] = Transformation V2 n
forall a. Monoid a => a
mempty
orientPoints _ [_] = Transformation V2 n
forall a. Monoid a => a
mempty
orientPoints v :: V2 n
v xs :: [Point V2 n]
xs = Angle n -> Transformation V2 n
forall n. Floating n => Angle n -> Transformation V2 n
rotation Angle n
a
where
(n1 :: Point V2 n
n1,x :: Point V2 n
x,n2 :: Point V2 n
n2) = ((Point V2 n, Point V2 n, Point V2 n)
-> (Point V2 n, Point V2 n, Point V2 n) -> Ordering)
-> [(Point V2 n, Point V2 n, Point V2 n)]
-> (Point V2 n, Point V2 n, Point V2 n)
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (((Point V2 n, Point V2 n, Point V2 n) -> n)
-> (Point V2 n, Point V2 n, Point V2 n)
-> (Point V2 n, Point V2 n, Point V2 n)
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (V2 n -> Point V2 n -> n
forall (f :: * -> *) a.
(Metric f, Floating a) =>
f a -> Point f a -> a
distAlong V2 n
v (Point V2 n -> n)
-> ((Point V2 n, Point V2 n, Point V2 n) -> Point V2 n)
-> (Point V2 n, Point V2 n, Point V2 n)
-> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point V2 n, Point V2 n, Point V2 n) -> Point V2 n
forall a b c. (a, b, c) -> b
sndOf3))
([Point V2 n]
-> [Point V2 n]
-> [Point V2 n]
-> [(Point V2 n, Point V2 n, Point V2 n)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 ([Point V2 n] -> [Point V2 n]
forall a. [a] -> [a]
tail ([Point V2 n] -> [Point V2 n]
forall a. [a] -> [a]
cycle [Point V2 n]
xs)) [Point V2 n]
xs ([Point V2 n] -> Point V2 n
forall a. [a] -> a
last [Point V2 n]
xs Point V2 n -> [Point V2 n] -> [Point V2 n]
forall a. a -> [a] -> [a]
: [Point V2 n] -> [Point V2 n]
forall a. [a] -> [a]
init [Point V2 n]
xs))
distAlong :: f a -> Point f a -> a
distAlong w :: f a
w ((Point f a -> Point f a -> Diff (Point f) a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point f a
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) -> Diff (Point f) a
p) = a -> a
forall a. Num a => a -> a
signum (f a
w f a -> f a -> a
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` f a
Diff (Point f) a
p) a -> a -> a
forall a. Num a => a -> a -> a
* f a -> a
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> a
norm (f a -> f a -> f a
forall (v :: * -> *) a.
(Metric v, Fractional a) =>
v a -> v a -> v a
project f a
w f a
Diff (Point f) a
p)
sndOf3 :: (a, b, c) -> b
sndOf3 (_,b :: b
b,_) = b
b
a :: Angle n
a = (Angle n -> Angle n -> Ordering) -> [Angle n] -> Angle n
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((Angle n -> n) -> Angle n -> Angle n -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Angle n -> n) -> Angle n -> Angle n -> Ordering)
-> (Angle n -> n) -> Angle n -> Angle n -> Ordering
forall a b. (a -> b) -> a -> b
$ n -> n
forall a. Num a => a -> a
abs (n -> n) -> (Angle n -> n) -> Angle n -> n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting n (Angle n) n -> Angle n -> n
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting n (Angle n) n
forall n. Iso' (Angle n) n
rad)
([Angle n] -> Angle n)
-> ([Point V2 n] -> [Angle n]) -> [Point V2 n] -> Angle n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point V2 n -> Angle n) -> [Point V2 n] -> [Angle n]
forall a b. (a -> b) -> [a] -> [b]
map (V2 n -> Angle n
angleFromNormal (V2 n -> Angle n) -> (Point V2 n -> V2 n) -> Point V2 n -> Angle n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Point V2 n -> Point V2 n -> Diff (Point V2) n
forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. Point V2 n
x)) ([Point V2 n] -> Angle n) -> [Point V2 n] -> Angle n
forall a b. (a -> b) -> a -> b
$ [Point V2 n
n1,Point V2 n
n2]
v' :: V2 n
v' = V2 n -> V2 n
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm V2 n
v
angleFromNormal :: V2 n -> Angle n
angleFromNormal o :: V2 n
o
| V2 n -> V2 n -> Bool
forall n. (Num n, Ord n) => V2 n -> V2 n -> Bool
leftTurn V2 n
o' V2 n
v' = Angle n
phi
| Bool
otherwise = Angle n -> Angle n
forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated Angle n
phi
where
o' :: V2 n
o' = V2 n -> V2 n
forall (f :: * -> *) a. (Metric f, Floating a) => f a -> f a
signorm V2 n
o
theta :: n
theta = n -> n
forall a. Floating a => a -> a
acos (V2 n
v' V2 n -> V2 n -> n
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` V2 n
o')
phi :: Angle n
phi
| n
theta n -> n -> Bool
forall a. Ord a => a -> a -> Bool
<= n
forall a. Floating a => a
taun -> n -> n
forall a. Fractional a => a -> a -> a
/4 = n
forall a. Floating a => a
taun -> n -> n
forall a. Fractional a => a -> a -> a
/4 n -> n -> n
forall a. Num a => a -> a -> a
- n
theta n -> AReview (Angle n) n -> Angle n
forall b a. b -> AReview a b -> a
@@ AReview (Angle n) n
forall n. Iso' (Angle n) n
rad
| Bool
otherwise = n
theta n -> n -> n
forall a. Num a => a -> a -> a
- n
forall a. Floating a => a
taun -> n -> n
forall a. Fractional a => a -> a -> a
/4 n -> AReview (Angle n) n -> Angle n
forall b a. b -> AReview a b -> a
@@ AReview (Angle n) n
forall n. Iso' (Angle n) n
rad
data GraphPart a = Cycle [a]
| Hair [a]
deriving (Int -> GraphPart a -> ShowS
[GraphPart a] -> ShowS
GraphPart a -> String
(Int -> GraphPart a -> ShowS)
-> (GraphPart a -> String)
-> ([GraphPart a] -> ShowS)
-> Show (GraphPart a)
forall a. Show a => Int -> GraphPart a -> ShowS
forall a. Show a => [GraphPart a] -> ShowS
forall a. Show a => GraphPart a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GraphPart a] -> ShowS
$cshowList :: forall a. Show a => [GraphPart a] -> ShowS
show :: GraphPart a -> String
$cshow :: forall a. Show a => GraphPart a -> String
showsPrec :: Int -> GraphPart a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> GraphPart a -> ShowS
Show, a -> GraphPart b -> GraphPart a
(a -> b) -> GraphPart a -> GraphPart b
(forall a b. (a -> b) -> GraphPart a -> GraphPart b)
-> (forall a b. a -> GraphPart b -> GraphPart a)
-> Functor GraphPart
forall a b. a -> GraphPart b -> GraphPart a
forall a b. (a -> b) -> GraphPart a -> GraphPart b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> GraphPart b -> GraphPart a
$c<$ :: forall a b. a -> GraphPart b -> GraphPart a
fmap :: (a -> b) -> GraphPart a -> GraphPart b
$cfmap :: forall a b. (a -> b) -> GraphPart a -> GraphPart b
Functor)
orbits :: (Int -> Int) -> Int -> [GraphPart Int]
orbits :: (Int -> Int) -> Int -> [GraphPart Int]
orbits f :: Int -> Int
f n :: Int
n = (forall s. ST s [GraphPart Int]) -> [GraphPart Int]
forall a. (forall s. ST s a) -> a
runST forall s. ST s [GraphPart Int]
genOrbits
where
f_n :: Int -> Int
f_n i :: Int
i = Int -> Int
f Int
i Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
n
genOrbits :: ST s [GraphPart Int]
genOrbits :: ST s [GraphPart Int]
genOrbits = (Int, Int) -> Bool -> ST s (STUArray s Int Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (0,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Bool
False ST s (STUArray s Int Bool)
-> (STUArray s Int Bool -> ST s [GraphPart Int])
-> ST s [GraphPart Int]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STUArray s Int Bool -> ST s [GraphPart Int]
forall s. STUArray s Int Bool -> ST s [GraphPart Int]
genOrbits'
genOrbits' :: STUArray s Int Bool -> ST s [GraphPart Int]
genOrbits' :: STUArray s Int Bool -> ST s [GraphPart Int]
genOrbits' marks :: STUArray s Int Bool
marks = ([Maybe [GraphPart Int]] -> [GraphPart Int])
-> ST s [Maybe [GraphPart Int]] -> ST s [GraphPart Int]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ([[GraphPart Int]] -> [GraphPart Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[GraphPart Int]] -> [GraphPart Int])
-> ([Maybe [GraphPart Int]] -> [[GraphPart Int]])
-> [Maybe [GraphPart Int]]
-> [GraphPart Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe [GraphPart Int]] -> [[GraphPart Int]]
forall a. [Maybe a] -> [a]
catMaybes) ([Int]
-> (Int -> ST s (Maybe [GraphPart Int]))
-> ST s [Maybe [GraphPart Int]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [0 .. Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-1] (STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int])
forall s.
STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int])
genPart STUArray s Int Bool
marks))
genPart :: STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int])
genPart :: STUArray s Int Bool -> Int -> ST s (Maybe [GraphPart Int])
genPart marks :: STUArray s Int Bool
marks i :: Int
i = do
[Int]
tr <- Int -> STUArray s Int Bool -> ST s [Int]
forall s. Int -> STUArray s Int Bool -> ST s [Int]
markRho Int
i STUArray s Int Bool
marks
case [Int]
tr of
[] -> Maybe [GraphPart Int] -> ST s (Maybe [GraphPart Int])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [GraphPart Int]
forall a. Maybe a
Nothing
_ -> Maybe [GraphPart Int] -> ST s (Maybe [GraphPart Int])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [GraphPart Int] -> ST s (Maybe [GraphPart Int]))
-> ([Int] -> Maybe [GraphPart Int])
-> [Int]
-> ST s (Maybe [GraphPart Int])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GraphPart Int] -> Maybe [GraphPart Int]
forall a. a -> Maybe a
Just ([GraphPart Int] -> Maybe [GraphPart Int])
-> ([Int] -> [GraphPart Int]) -> [Int] -> Maybe [GraphPart Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> [GraphPart Int]
splitParts ([Int] -> ST s (Maybe [GraphPart Int]))
-> [Int] -> ST s (Maybe [GraphPart Int])
forall a b. (a -> b) -> a -> b
$ [Int]
tr
markRho :: Int -> STUArray s Int Bool -> ST s [Int]
markRho :: Int -> STUArray s Int Bool -> ST s [Int]
markRho i :: Int
i marks :: STUArray s Int Bool
marks = do
Bool
isMarked <- STUArray s Int Bool -> Int -> ST s Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Bool
marks Int
i
if Bool
isMarked
then [Int] -> ST s [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return []
else STUArray s Int Bool -> Int -> Bool -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Bool
marks Int
i Bool
True ST s () -> ST s [Int] -> ST s [Int]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
([Int] -> [Int]) -> ST s [Int] -> ST s [Int]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Int
iInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) (Int -> STUArray s Int Bool -> ST s [Int]
forall s. Int -> STUArray s Int Bool -> ST s [Int]
markRho (Int -> Int
f_n Int
i) STUArray s Int Bool
marks)
splitParts :: [Int] -> [GraphPart Int]
splitParts :: [Int] -> [GraphPart Int]
splitParts tr :: [Int]
tr = [GraphPart Int]
hair [GraphPart Int] -> [GraphPart Int] -> [GraphPart Int]
forall a. [a] -> [a] -> [a]
++ [GraphPart Int]
cyc
where hair :: [GraphPart Int]
hair | Bool -> Bool
not ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
tl) = [[Int] -> GraphPart Int
forall a. [a] -> GraphPart a
Hair ([Int] -> GraphPart Int) -> [Int] -> GraphPart Int
forall a b. (a -> b) -> a -> b
$ [Int]
tl [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int -> Int
f_n ([Int] -> Int
forall a. [a] -> a
last [Int]
tl)]]
| Bool
otherwise = []
cyc :: [GraphPart Int]
cyc | Bool -> Bool
not ([Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
body) = [[Int] -> GraphPart Int
forall a. [a] -> GraphPart a
Cycle [Int]
body]
| Bool
otherwise = []
l :: Int
l = [Int] -> Int
forall a. [a] -> a
last [Int]
tr
(tl :: [Int]
tl, body :: [Int]
body) = (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Int
f_n Int
l) [Int]
tr
mkGraph :: (Int -> Int) -> [a] -> [GraphPart a]
mkGraph :: (Int -> Int) -> [a] -> [GraphPart a]
mkGraph f :: Int -> Int
f xs :: [a]
xs = ((GraphPart Int -> GraphPart a) -> [GraphPart Int] -> [GraphPart a]
forall a b. (a -> b) -> [a] -> [b]
map ((GraphPart Int -> GraphPart a)
-> [GraphPart Int] -> [GraphPart a])
-> ((Int -> a) -> GraphPart Int -> GraphPart a)
-> (Int -> a)
-> [GraphPart Int]
-> [GraphPart a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a) -> GraphPart Int -> GraphPart a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) ([a]
xs[a] -> Int -> a
forall a. [a] -> Int -> a
!!) ([GraphPart Int] -> [GraphPart a])
-> [GraphPart Int] -> [GraphPart a]
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> Int -> [GraphPart Int]
orbits Int -> Int
f ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs)
data StarOpts = StarFun (Int -> Int)
| StarSkip Int
star :: OrderedField n => StarOpts -> [Point V2 n] -> Path V2 n
star :: StarOpts -> [Point V2 n] -> Path V2 n
star sOpts :: StarOpts
sOpts vs :: [Point V2 n]
vs = [GraphPart (Point V2 n)] -> Path V2 n
graphToPath ([GraphPart (Point V2 n)] -> Path V2 n)
-> [GraphPart (Point V2 n)] -> Path V2 n
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> [Point V2 n] -> [GraphPart (Point V2 n)]
forall a. (Int -> Int) -> [a] -> [GraphPart a]
mkGraph Int -> Int
f [Point V2 n]
vs
where f :: Int -> Int
f = case StarOpts
sOpts of
StarFun g :: Int -> Int
g -> Int -> Int
g
StarSkip k :: Int
k -> (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
k)
graphToPath :: [GraphPart (Point V2 n)] -> Path V2 n
graphToPath = [Path V2 n] -> Path V2 n
forall a. Monoid a => [a] -> a
mconcat ([Path V2 n] -> Path V2 n)
-> ([GraphPart (Point V2 n)] -> [Path V2 n])
-> [GraphPart (Point V2 n)]
-> Path V2 n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GraphPart (Point V2 n) -> Path V2 n)
-> [GraphPart (Point V2 n)] -> [Path V2 n]
forall a b. (a -> b) -> [a] -> [b]
map GraphPart (Point V2 n) -> Path V2 n
forall (v :: * -> *) n.
(Metric v, Floating n, Ord n) =>
GraphPart (Point v n) -> Path v n
partToPath
partToPath :: GraphPart (Point v n) -> Path v n
partToPath (Cycle ps :: [Point v n]
ps) = Located (Trail v n) -> Path v n
forall (v :: * -> *) n.
(Metric v, OrderedField n) =>
Located (Trail v n) -> Path v n
pathFromLocTrail
(Located (Trail v n) -> Path v n)
-> ([Point v n] -> Located (Trail v n)) -> [Point v n] -> Path v n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Trail v n -> Trail v n)
-> Located (Trail v n) -> Located (Trail v n)
forall a b. SameSpace a b => (a -> b) -> Located a -> Located b
mapLoc Trail v n -> Trail v n
forall (v :: * -> *) n. Trail v n -> Trail v n
closeTrail
(Located (Trail v n) -> Located (Trail v n))
-> ([Point v n] -> Located (Trail v n))
-> [Point v n]
-> Located (Trail v n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point v n] -> Located (Trail v n)
forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices
([Point v n] -> Path v n) -> [Point v n] -> Path v n
forall a b. (a -> b) -> a -> b
$ [Point v n]
ps
partToPath (Hair ps :: [Point v n]
ps) = [Point (V (Path v n)) (N (Path v n))] -> Path v n
forall t. TrailLike t => [Point (V t) (N t)] -> t
fromVertices [Point v n]
[Point (V (Path v n)) (N (Path v n))]
ps