{-# OPTIONS_GHC -Wno-orphans #-}

module Util where

import Control.Monad
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Tuple.Extra
import Graphics.SvgTree
import Linear

--TODO upstream to svg-tree, extra, linear etc.

infixl 5 <<$>>
(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
<<$>> :: (a -> b) -> f (g a) -> f (g b)
(<<$>>) = (g a -> g b) -> f (g a) -> f (g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((g a -> g b) -> f (g a) -> f (g b))
-> ((a -> b) -> g a -> g b) -> (a -> b) -> f (g a) -> f (g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

infixl 5 <<<$>>>
(<<<$>>>) :: (Functor f, Functor g, Functor h) => (a -> b) -> f (g (h a)) -> f (g (h b))
<<<$>>> :: (a -> b) -> f (g (h a)) -> f (g (h b))
(<<<$>>>) = (g (h a) -> g (h b)) -> f (g (h a)) -> f (g (h b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((g (h a) -> g (h b)) -> f (g (h a)) -> f (g (h b)))
-> ((a -> b) -> g (h a) -> g (h b))
-> (a -> b)
-> f (g (h a))
-> f (g (h b))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (h a -> h b) -> g (h a) -> g (h b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((h a -> h b) -> g (h a) -> g (h b))
-> ((a -> b) -> h a -> h b) -> (a -> b) -> g (h a) -> g (h b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> h a -> h b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

(++|) :: NonEmpty a -> [a] -> NonEmpty a
++| :: NonEmpty a -> [a] -> NonEmpty a
(++|) (a
x :| [a]
xs) [a]
ys = a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys

pairAdjacent :: [a] -> [(a, a)]
pairAdjacent :: [a] -> [(a, a)]
pairAdjacent [a]
xs = [a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [a]
xs ([a] -> [(a, a)]) -> [a] -> [(a, a)]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
forall a. [a] -> [a]
tail [a]
xs

classifyOn :: Ord b => (a -> b) -> [a] -> [(b, NonEmpty a)]
classifyOn :: (a -> b) -> [a] -> [(b, NonEmpty a)]
classifyOn a -> b
f = Map b (NonEmpty a) -> [(b, NonEmpty a)]
forall k a. Map k a -> [(k, a)]
Map.toList (Map b (NonEmpty a) -> [(b, NonEmpty a)])
-> ([a] -> Map b (NonEmpty a)) -> [a] -> [(b, NonEmpty a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty a -> NonEmpty a -> NonEmpty a)
-> [(b, NonEmpty a)] -> Map b (NonEmpty a)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith NonEmpty a -> NonEmpty a -> NonEmpty a
forall a. Semigroup a => a -> a -> a
(<>) ([(b, NonEmpty a)] -> Map b (NonEmpty a))
-> ([a] -> [(b, NonEmpty a)]) -> [a] -> Map b (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> (b, NonEmpty a)) -> [a] -> [(b, NonEmpty a)]
forall a b. (a -> b) -> [a] -> [b]
map (a -> b
f (a -> b) -> (a -> NonEmpty a) -> a -> (b, NonEmpty a)
forall a b c. (a -> b) -> (a -> c) -> a -> (b, c)
&&& a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure)

select :: [a] -> [(a, [a])]
select :: [a] -> [(a, [a])]
select [] = []
select (a
x : [a]
xs) = (a
x, [a]
xs) (a, [a]) -> [(a, [a])] -> [(a, [a])]
forall a. a -> [a] -> [a]
: ((a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:) ([a] -> [a]) -> [(a, [a])] -> [(a, [a])]
forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>> [a] -> [(a, [a])]
forall a. [a] -> [(a, [a])]
select [a]
xs)

{- | Rotate and reflect. Same coordinates in same order.

>>> equivalentCycles $ 1 :| [2,3,4]
[ 1 :| [2, 3, 4, 5]
, 5 :| [4, 3, 2, 1]
, 2 :| [3, 4, 5, 1]
, 1 :| [5, 4, 3, 2]
, 3 :| [4, 5, 1, 2]
, 2 :| [1, 5, 4, 3]
, 4 :| [5, 1, 2, 3]
, 3 :| [2, 1, 5, 4]
, 5 :| [1, 2, 3, 4]
, 4 :| [3, 2, 1, 5]
]
-}
equivalentCycles :: NonEmpty a -> [NonEmpty a]
equivalentCycles :: NonEmpty a -> [NonEmpty a]
equivalentCycles = (NonEmpty a -> [NonEmpty a]) -> [NonEmpty a] -> [NonEmpty a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap NonEmpty a -> [NonEmpty a]
forall a. NonEmpty a -> [NonEmpty a]
refls ([NonEmpty a] -> [NonEmpty a])
-> (NonEmpty a -> [NonEmpty a]) -> NonEmpty a -> [NonEmpty a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [NonEmpty a]
forall a. NonEmpty a -> [NonEmpty a]
rots
  where
    refls :: NonEmpty a -> [NonEmpty a]
refls NonEmpty a
xs = [NonEmpty a
xs, NonEmpty a -> NonEmpty a
forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty a
xs]
    rots :: NonEmpty a -> [NonEmpty a]
rots = [a] -> NonEmpty a -> [NonEmpty a]
forall a. [a] -> NonEmpty a -> [NonEmpty a]
go []
    go :: [a] -> NonEmpty a -> [NonEmpty a]
go [a]
ys = \case
        a
x :| [a]
xs -> (a
x a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
:| [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys) NonEmpty a -> [NonEmpty a] -> [NonEmpty a]
forall a. a -> [a] -> [a]
: [NonEmpty a]
-> (NonEmpty a -> [NonEmpty a])
-> Maybe (NonEmpty a)
-> [NonEmpty a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([a] -> NonEmpty a -> [NonEmpty a]
go ([a] -> NonEmpty a -> [NonEmpty a])
-> [a] -> NonEmpty a -> [NonEmpty a]
forall a b. (a -> b) -> a -> b
$ [a]
ys [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
x]) ([a] -> Maybe (NonEmpty a)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [a]
xs)

-- | Based on wikipedia: https://en.wikipedia.org/wiki/Line%E2%80%93line_intersection#Given_two_points_on_each_line
intersectLines :: (Eq a, Ord a, Fractional a, Show a) => (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
intersectLines :: (V2 a, V2 a) -> (V2 a, V2 a) -> Maybe (V2 a)
intersectLines (V2 a
x1 a
y1, V2 a
x2 a
y2) (V2 a
x3 a
y3, V2 a
x4 a
y4) = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ a
den a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 -- lines are not parallel or coincident
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0 Bool -> Bool -> Bool
&& a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1 -- intersection is on first line segment
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ a
u a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
0 Bool -> Bool -> Bool
&& a
u a -> a -> Bool
forall a. Ord a => a -> a -> Bool
<= a
1 -- intersection is on second line segment
    V2 a -> Maybe (V2 a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (V2 a -> Maybe (V2 a)) -> V2 a -> Maybe (V2 a)
forall a b. (a -> b) -> a -> b
$ a -> a -> V2 a
forall a. a -> a -> V2 a
V2 a
x a
y
  where
    dx12 :: a
dx12 = a
x1 a -> a -> a
forall a. Num a => a -> a -> a
- a
x2
    dx13 :: a
dx13 = a
x1 a -> a -> a
forall a. Num a => a -> a -> a
- a
x3
    dx34 :: a
dx34 = a
x3 a -> a -> a
forall a. Num a => a -> a -> a
- a
x4

    dy12 :: a
dy12 = a
y1 a -> a -> a
forall a. Num a => a -> a -> a
- a
y2
    dy13 :: a
dy13 = a
y1 a -> a -> a
forall a. Num a => a -> a -> a
- a
y3
    dy34 :: a
dy34 = a
y3 a -> a -> a
forall a. Num a => a -> a -> a
- a
y4

    den :: a
den = a
dx12 a -> a -> a
forall a. Num a => a -> a -> a
* a
dy34 a -> a -> a
forall a. Num a => a -> a -> a
- a
dy12 a -> a -> a
forall a. Num a => a -> a -> a
* a
dx34

    u :: a
u = (a
dy12 a -> a -> a
forall a. Num a => a -> a -> a
* a
dx13 a -> a -> a
forall a. Num a => a -> a -> a
- a
dx12 a -> a -> a
forall a. Num a => a -> a -> a
* a
dy13) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
den
    t :: a
t = (a
dx13 a -> a -> a
forall a. Num a => a -> a -> a
* a
dy34 a -> a -> a
forall a. Num a => a -> a -> a
- a
dy13 a -> a -> a
forall a. Num a => a -> a -> a
* a
dx34) a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
den

    x :: a
x = a
x1 a -> a -> a
forall a. Num a => a -> a -> a
- a
t a -> a -> a
forall a. Num a => a -> a -> a
* a
dx12
    y :: a
y = a
y1 a -> a -> a
forall a. Num a => a -> a -> a
- a
t a -> a -> a
forall a. Num a => a -> a -> a
* a
dy12

pathBranch :: TreeBranch -> Maybe Path
pathBranch :: TreeBranch -> Maybe Path
pathBranch = \case
    PathNode Path
p -> Path -> Maybe Path
forall a. a -> Maybe a
Just Path
p
    TreeBranch
_ -> Maybe Path
forall a. Maybe a
Nothing

deriving instance Ord Cap
deriving instance Ord DrawAttributes
deriving instance Ord ElementRef
deriving instance Ord FillRule
deriving instance Ord FontStyle
deriving instance Ord LineJoin
deriving instance Ord Number
deriving instance Ord TextAnchor
deriving instance Ord Texture
deriving instance Ord Transformation