{-# OPTIONS_GHC -Wno-orphans #-}

module Util where

import Control.Monad
import Data.Bool
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.

applyWhen :: Bool -> (a -> a) -> a -> a
applyWhen :: forall a. Bool -> (a -> a) -> a -> a
applyWhen = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Bool -> a
bool forall a. a -> a
id

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

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

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

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

select :: [a] -> [(a, [a])]
select :: forall a. [a] -> [(a, [a])]
select [] = []
select (a
x : [a]
xs) = (a
x, [a]
xs) forall a. a -> [a] -> [a]
: ((a
x forall a. a -> [a] -> [a]
:) forall (f :: * -> *) (g :: * -> *) a b.
(Functor f, Functor g) =>
(a -> b) -> f (g a) -> f (g b)
<<$>> 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 :: forall a. NonEmpty a -> [NonEmpty a]
equivalentCycles = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. NonEmpty a -> [NonEmpty a]
refls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [NonEmpty a]
rots
  where
    refls :: NonEmpty a -> [NonEmpty a]
refls NonEmpty a
xs = [NonEmpty a
xs, forall a. NonEmpty a -> NonEmpty a
NE.reverse NonEmpty a
xs]
    rots :: NonEmpty a -> [NonEmpty a]
rots = forall {a}. [a] -> NonEmpty a -> [NonEmpty a]
go []
    go :: [a] -> NonEmpty a -> [NonEmpty a]
go [a]
ys = \case
        a
x :| [a]
xs -> (a
x forall a. a -> [a] -> NonEmpty a
:| [a]
xs forall a. [a] -> [a] -> [a]
++ [a]
ys) forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([a] -> NonEmpty a -> [NonEmpty a]
go forall a b. (a -> b) -> a -> b
$ [a]
ys forall a. [a] -> [a] -> [a]
++ [a
x]) (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 :: forall a.
(Eq a, Ord a, Fractional a, Show a) =>
(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
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ a
den forall a. Eq a => a -> a -> Bool
/= a
0 -- lines are not parallel or coincident
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ a
t forall a. Ord a => a -> a -> Bool
>= a
0 Bool -> Bool -> Bool
&& a
t forall a. Ord a => a -> a -> Bool
<= a
1 -- intersection is on first line segment
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ a
u forall a. Ord a => a -> a -> Bool
>= a
0 Bool -> Bool -> Bool
&& a
u forall a. Ord a => a -> a -> Bool
<= a
1 -- intersection is on second line segment
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> V2 a
V2 a
x a
y
  where
    dx12 :: a
dx12 = a
x1 forall a. Num a => a -> a -> a
- a
x2
    dx13 :: a
dx13 = a
x1 forall a. Num a => a -> a -> a
- a
x3
    dx34 :: a
dx34 = a
x3 forall a. Num a => a -> a -> a
- a
x4

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

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

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

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

pathBranch :: TreeBranch -> Maybe Path
pathBranch :: TreeBranch -> Maybe Path
pathBranch = \case
    PathNode Path
p -> forall a. a -> Maybe a
Just Path
p
    TreeBranch
_ -> 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

nearZeroNumber :: Number -> Bool
nearZeroNumber :: Number -> Bool
nearZeroNumber = \case
    Num Double
d -> forall a. Epsilon a => a -> Bool
nearZero Double
d
    Px Double
d -> forall a. Epsilon a => a -> Bool
nearZero Double
d
    Em Double
d -> forall a. Epsilon a => a -> Bool
nearZero Double
d
    Percent Double
d -> forall a. Epsilon a => a -> Bool
nearZero Double
d
    Pc Double
d -> forall a. Epsilon a => a -> Bool
nearZero Double
d
    Mm Double
d -> forall a. Epsilon a => a -> Bool
nearZero Double
d
    Cm Double
d -> forall a. Epsilon a => a -> Bool
nearZero Double
d
    Point Double
d -> forall a. Epsilon a => a -> Bool
nearZero Double
d
    Inches Double
d -> forall a. Epsilon a => a -> Bool
nearZero Double
d