svgone-0.2.0.0: src/Util.hs

{-# 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 = flip $ bool id

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

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

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

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

classifyOn :: Ord b => (a -> b) -> [a] -> [(b, NonEmpty a)]
classifyOn f = Map.toList . Map.fromListWith (<>) . map (f &&& pure)

select :: [a] -> [(a, [a])]
select [] = []
select (x : xs) = (x, xs) : ((x :) <<$>> select 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 = concatMap refls . rots
  where
    refls xs = [xs, NE.reverse xs]
    rots = go []
    go ys = \case
        x :| xs -> (x :| xs ++ ys) : maybe [] (go $ ys ++ [x]) (NE.nonEmpty 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 x1 y1, V2 x2 y2) (V2 x3 y3, V2 x4 y4) = do
    guard $ den /= 0 -- lines are not parallel or coincident
    guard $ t >= 0 && t <= 1 -- intersection is on first line segment
    guard $ u >= 0 && u <= 1 -- intersection is on second line segment
    pure $ V2 x y
  where
    dx12 = x1 - x2
    dx13 = x1 - x3
    dx34 = x3 - x4

    dy12 = y1 - y2
    dy13 = y1 - y3
    dy34 = y3 - y4

    den = dx12 * dy34 - dy12 * dx34

    u = (dy12 * dx13 - dx12 * dy13) / den
    t = (dx13 * dy34 - dy13 * dx34) / den

    x = x1 - t * dx12
    y = y1 - t * dy12

pathBranch :: TreeBranch -> Maybe Path
pathBranch = \case
    PathNode p -> Just p
    _ -> 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 = \case
    Num d -> nearZero d
    Px d -> nearZero d
    Em d -> nearZero d
    Percent d -> nearZero d
    Pc d -> nearZero d
    Mm d -> nearZero d
    Cm d -> nearZero d
    Point d -> nearZero d
    Inches d -> nearZero d