path: root/Graphics/Glyph/Util.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}

module Graphics.Glyph.Util where

import Control.Exception
import Control.Monad
import Data.Angle
import Data.Array.MArray
import Data.Char
import Data.Either
import Data.Foldable as Fold
import Data.Maybe
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Graphics.Rendering.OpenGL

if' :: Bool -> a -> a -> a
if' True a _ = a
if' False _ a = a

(?) :: Bool -> a -> a -> a
(?) = if'

flipIf :: a -> a -> Bool -> a
flipIf a b c = if c then a else b

int :: (Integral a, Num b) => a -> b
int = fromIntegral

uncurry7 :: (a -> b -> c -> d -> e -> f -> g -> h) -> (a, b, c, d, e, f, g) -> h
uncurry7 func (a, b, c, d, e, f, g) = func a b c d e f g

uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g
uncurry6 func (a, b, c, d, e, f) = func a b c d e f

uncurry5 :: (a -> b -> c -> d -> e -> f) -> (a, b, c, d, e) -> f
uncurry5 func (a, b, c, d, e) = func a b c d e

uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
uncurry4 func (a, b, c, d) = func a b c d

uncurry3 :: (a -> b -> c -> e) -> (a, b, c) -> e
uncurry3 func (a, b, c) = func a b c

const2 :: a -> b -> c -> a
const2 = const . const

const3 :: a -> b -> c -> d -> a
const3 = const2 . const

const4 :: a -> b -> c -> d -> e -> a
const4 = const3 . const

gsin :: (Floating a) => a -> a
gsin = sine . Degrees

gcos :: (Floating a) => a -> a
gcos = cosine . Degrees

toEuclidian :: (Floating a) => (a, a, a) -> (a, a, a)
toEuclidian (r, th, ph) =
  ( - r * gsin th * gcos ph,
    r * gsin ph,
    r * gcos th * gcos ph
  )

mapT2 :: (a -> b) -> (a, a) -> (b, b)
mapT2 f (a, b) = (f a, f b)

mapT3 :: (a -> b) -> (a, a, a) -> (b, b, b)
mapT3 f (a, b, c) = (f a, f b, f c)

mapT4 :: (a -> b) -> (a, a, a, a) -> (b, b, b, b)
mapT4 f (a, b, c, d) = (f a, f b, f c, f d)

mapT5 :: (a -> b) -> (a, a, a, a, a) -> (b, b, b, b, b)
mapT5 f (a, b, c, d, e) = (f a, f b, f c, f d, f e)

mapT6 :: (a -> b) -> (a, a, a, a, a, a) -> (b, b, b, b, b, b)
mapT6 f (a, b, c, d, e, _f) = (f a, f b, f c, f d, f e, f _f)

mapT7 :: (a -> b) -> (a, a, a, a, a, a, a) -> (b, b, b, b, b, b, b)
mapT7 f (a, b, c, d, e, _f, g) = (f a, f b, f c, f d, f e, f _f, f g)

foldT2 :: (a -> b -> a) -> a -> (b, b) -> a
foldT2 f ini (x, y) = ini `f` x `f` y

foldT3 :: (a -> b -> a) -> a -> (b, b, b) -> a
foldT3 f ini (x, y, z) = ini `f` x `f` y `f` z

foldT4 :: (a -> b -> a) -> a -> (b, b, b, b) -> a
foldT4 f ini (x, y, z, w) = ini `f` x `f` y `f` z `f` w

foldT5 :: (a -> b -> a) -> a -> (b, b, b, b, b) -> a
foldT5 f ini (x, y, z, w, v) = ini `f` x `f` y `f` z `f` w `f` v

tup2Len :: (Real a, Floating b) => (a, a) -> b
tup2Len = sqrt . foldT2 (+) 0 . mapT2 ((** 2) . toFloating)

tup3Len :: (Real a, Floating b) => (a, a, a) -> b
tup3Len = sqrt . foldT3 (+) 0 . mapT3 ((** 2) . toFloating)

tup4Len :: (Real a, Floating b) => (a, a, a, a) -> b
tup4Len = sqrt . foldT4 (+) 0 . mapT4 ((** 2) . toFloating)

tup5Len :: (Real a, Floating b) => (a, a, a, a, a) -> b
tup5Len = sqrt . foldT5 (+) 0 . mapT5 ((** 2) . toFloating)

expand3 :: a -> (a, a, a)
expand3 t = (t, t, t)

expand4 :: a -> (a, a, a, a)
expand4 t = (t, t, t, t)

expand5 :: a -> (a, a, a, a, a)
expand5 t = (t, t, t, t, t)

expand6 :: a -> (a, a, a, a, a)
expand6 t = (t, t, t, t, t)

zipWithT2 :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
zipWithT2 fu (a, b) (d, e) = (fu a d, fu b e)

zipWithT3 :: (a -> b -> c) -> (a, a, a) -> (b, b, b) -> (c, c, c)
zipWithT3 fu (a, b, c) (d, e, f) = (fu a d, fu b e, fu c f)

zipWithT4 :: (a -> b -> c) -> (a, a, a, a) -> (b, b, b, b) -> (c, c, c, c)
zipWithT4 fu (a, b, c, d) (e, f, g, h) = (fu a e, fu b f, fu c g, fu d h)

zipWithT5 :: (a -> b -> c) -> (a, a, a, a, a) -> (b, b, b, b, b) -> (c, c, c, c, c)
zipWithT5 fu (a, b, c, d, i) (e, f, g, h, j) = (fu a e, fu b f, fu c g, fu d h, fu i j)

toFloating :: (Real a, Floating b) => a -> b
toFloating = fromRational . toRational

(!!%) :: [a] -> Int -> a
(!!%) lst idx = lst !! (idx `mod` length lst)

(++!) :: (Show a) => String -> a -> String
(++!) str = (str ++) . show

clamp :: (Ord a) => a -> (a, a) -> a
clamp var (low, high) = min (max var low) high

floatVertex :: (GLfloat, GLfloat, GLfloat) -> Vertex3 GLdouble
floatVertex tup = uncurry3 Vertex3 (mapT3 toFloating tup)

floatVector :: (GLfloat, GLfloat, GLfloat) -> Vector3 GLdouble
floatVector tup = uncurry3 Vector3 (mapT3 toFloating tup)

-- Maps a function across a list, except this function
-- can also be given a state variable like how foldl
-- works
mapWith :: (s -> a -> (b, s)) -> s -> [a] -> ([b], s)
mapWith func state (x : xs) =
  let (x', s') = func state x
   in let (l, s) = mapWith func s' xs in (x' : l, s)
mapWith _ s [] = ([], s)

{- Useful function that accepts two functions
 - and applies the third argument to both. Useful for
 - building up data flows with the same argument. Such
 - as:
 -
 - (bVertex3 >&> bNormal3) (0,0,1)
 - vs
 - bVertex3 (0,0,1) >> bNormal3 (0,0,1)
 -}
(>&>) :: (Monad m) => (a -> m b) -> (a -> m c) -> a -> m c
(>&>) f1 f2 a = f1 a >> f2 a

{- Instance where a monad can deconstruct
 - when the operation has failed -}
class (Monad m) => MonadHasFailure m where
  isFail :: m a -> Bool

instance MonadHasFailure Maybe where
  isFail = isNothing

instance MonadHasFailure [] where
  isFail = null

instance MonadHasFailure (Either a) where
  isFail (Left _) = True
  isFail _ = False

{- A way of chaining together commands such
 - that the first function in the chain that
 - returns a non-failing result is the one
 - that returns the result
 -
 - This is similar to the double pipe (||) operator
 - in imperative languages but with monads instead of
 - booleans.
 -}
(>|>) :: (MonadHasFailure m) => (a -> m c) -> (a -> m c) -> a -> m c
(>|>) f1 f2 a =
  let res = f1 a
   in isFail res ? f2 a $ res

(>||>) :: (MonadHasFailure m) => m a -> m a -> m a
(>||>) a b
  | isFail a = b
  | otherwise = a

whileM_ :: (Monad m) => (a -> Bool) -> m a -> a -> m a
whileM_ func routine start = do
  case func start of
    True -> routine >>= whileM_ func routine
    False -> return start

whileM :: (Monad m) => (a -> Bool) -> m a -> a -> m [a]
whileM bool routine' start' =
  whileM' bool routine' start' []
  where
    whileM' func routine start lst = do
      case func start of
        True -> do
          next <- routine
          whileM' func routine next (lst ++ [start])
        False -> return lst

untilM_ :: (Monad m) => (a -> Bool) -> m a -> m a
untilM_ func routine = do
  start <- routine
  if'
    (func start)
    (untilM_ func routine)
    (return start)

untilM :: (Monad m) => (a -> Bool) -> m a -> m [a]
untilM func' routine' =
  untilM' func' routine' []
  where
    untilM' func routine lst = do
      start <- routine
      if'
        (func start)
        (untilM' func routine (lst ++ [start]))
        (return lst)

dFold :: [a] -> b -> (a -> a -> b -> b) -> b
dFold (x1 : x2 : xs) next func = dFold (x2 : xs) (func x1 x2 next) func
dFold _ next _ = next

(!>>) :: a -> (a -> b) -> b
(!>>) a f = a `seq` f a

(!>>=) :: Monad m => m a -> (a -> m b) -> m b
(!>>=) a f = a !>> flip (>>=) f

{- Objective function composition. Useful to say
 - (drawArrays <..> numInstances) obj
 -}
(<..>) :: (b -> a -> c) -> (a -> b) -> a -> c
(<..>) f1 f2 a = f1 (f2 a) a

toHex :: (Integral a, Show a) => a -> String
toHex n
  | n == 0 = ""
  | otherwise =
    let (quot', rem') = n `divMod` 16
     in toHex quot' ++ [index' !! fromIntegral rem']
  where
    index' = "0123456789ABCDEFGHIJKlMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"

average :: (Fold.Foldable a, Real c, Fractional b) => a c -> b
average lst =
  let (sum', count) = Fold.foldl' (\(sum_, count_) x -> (sum_ + x, count_ + 1)) (0, 0) lst
   in realToFrac sum' / count

maybeDefault :: a -> Maybe a -> a
maybeDefault a b = fromJust $ b >||> Just a

maybeDefaultM :: (Monad m) => Maybe a -> (a -> m ()) -> m () -> m ()
maybeDefaultM Nothing _ a = a
maybeDefaultM (Just a) b _ = b a

data MonadPlusBuilder a b = MonadPlusBuilder a b

plusM :: a -> MonadPlusBuilder a ()
plusM a = MonadPlusBuilder a ()

runMonadPlusBuilder :: MonadPlusBuilder a b -> a
runMonadPlusBuilder (MonadPlusBuilder !a _) = a

instance (MonadPlus a) => Functor (MonadPlusBuilder (a b)) where
  fmap f b = b >>= return . f

instance (MonadPlus a) => Applicative (MonadPlusBuilder (a b)) where
  (<*>) afn aa = do
    fn <- afn
    fn <$> aa

  pure = return

instance (MonadPlus a) => Monad (MonadPlusBuilder (a b)) where
  return = MonadPlusBuilder mzero
  MonadPlusBuilder a1 _ >> MonadPlusBuilder a2 b = MonadPlusBuilder (a1 `mplus` a2) b
  builder@(MonadPlusBuilder _ b) >>= f = builder >> f b

untilM2 :: (Monad m) => (a -> m Bool) -> a -> (a -> m a) -> m a
untilM2 cond ini bod = do
  bool <- cond ini
  if bool
    then return ini
    else bod ini >>= \newini -> untilM2 cond newini bod

(<!>) :: (MArray a e IO, Ix i) => a i e -> i -> StateVar e
(<!>) arr idx =
  let setter = writeArray arr idx
      getter = readArray arr idx
   in makeStateVar getter setter

for :: [a] -> (a -> b) -> [b]
for = flip map

distribMaybe :: Maybe (a, b) -> (Maybe a, Maybe b)
distribMaybe Nothing = (Nothing, Nothing)
distribMaybe (Just (a, b)) = (Just a, Just b)

whenM :: IO Bool -> IO () -> IO ()
whenM b = (>>=) b . flip when

mix :: (Floating a) => a -> a -> a -> a
mix a b c = a * c + b * (1 - c)

fpart :: (RealFrac a) => a -> a
fpart x = x - (fromIntegral (floor x :: Int))

ifNaN :: (RealFloat a) => a -> a -> a
ifNaN reg def = if' (isNaN reg) def reg

everyN :: Int -> [a] -> [a]
everyN _ [] = []
everyN n (x : xs) = x : (everyN n $ drop n xs)

chunkList :: [a] -> [(a, a)]
chunkList l = zip [x | x <- everyN 1 l] [x | x <- everyN 1 (tail l)]

chunkList3 :: [a] -> [(a, a, a)]
chunkList3 l =
  zip3
    [x | x <- everyN 2 l]
    [x | x <- everyN 2 (tail l)]
    [x | x <- everyN 2 (tail $ tail l)]