diff options
Diffstat (limited to 'Graphics/Glyph/Util.hs')
| -rw-r--r-- | Graphics/Glyph/Util.hs | 265 |
1 files changed, 133 insertions, 132 deletions
diff --git a/Graphics/Glyph/Util.hs b/Graphics/Glyph/Util.hs index 90640a4..79fd5c6 100644 --- a/Graphics/Glyph/Util.hs +++ b/Graphics/Glyph/Util.hs @@ -3,21 +3,17 @@ module Graphics.Glyph.Util where +import Control.Exception +import Control.Monad import Data.Angle -import Graphics.Rendering.OpenGL -import Data.Maybe +import Data.Array.MArray import Data.Char import Data.Either - -import Control.Exception -import Control.Monad - import Data.Foldable as Fold - -import Foreign.Ptr +import Data.Maybe import Foreign.Marshal.Alloc - -import Data.Array.MArray +import Foreign.Ptr +import Graphics.Rendering.OpenGL if' :: Bool -> a -> a -> a if' True a _ = a @@ -30,31 +26,31 @@ flipIf :: a -> a -> Bool -> a flipIf a b c = if c then a else b int :: (Integral a, Num b) => a -> b -int = fromIntegral +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 +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 +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 +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 +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 +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 +const2 = const . const const3 :: a -> b -> c -> d -> a -const3 = const2.const +const3 = const2 . const const4 :: a -> b -> c -> d -> e -> a -const4 = const3.const +const4 = const3 . const gsin :: (Floating a) => a -> a gsin = sine . Degrees @@ -63,76 +59,76 @@ 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 - ) +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 :: (a -> b) -> (a, a) -> (b, b) mapT2 f (a, b) = (f a, f b) -mapT3 :: (a -> b) -> (a,a,a) -> (b,b,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 :: (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 :: (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 :: (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 :: (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 +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 +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 +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 +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) +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) +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) +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) +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) +expand3 :: a -> (a, a, a) +expand3 t = (t, t, t) -expand4 :: a -> (a,a,a,a) -expand4 t = (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) +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) +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 :: (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 :: (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 :: (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 :: (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 @@ -142,26 +138,25 @@ toFloating = fromRational . toRational (!!%) lst idx = lst !! (idx `mod` length lst) (++!) :: (Show a) => String -> a -> String -(++!) str = (str++) . show +(++!) str = (str ++) . show -clamp :: (Ord a) => a -> (a, a) -> a +clamp :: (Ord a) => a -> (a, a) -> a clamp var (low, high) = min (max var low) high -floatVertex :: (GLfloat,GLfloat,GLfloat) -> Vertex3 GLdouble +floatVertex :: (GLfloat, GLfloat, GLfloat) -> Vertex3 GLdouble floatVertex tup = uncurry3 Vertex3 (mapT3 toFloating tup) -floatVector :: (GLfloat,GLfloat,GLfloat) -> Vector3 GLdouble +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) +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 @@ -178,18 +173,17 @@ mapWith _ s [] = ([],s) {- Instance where a monad can deconstruct - when the operation has failed -} class (Monad m) => MonadHasFailure m where - isFail :: m a -> Bool + isFail :: m a -> Bool instance MonadHasFailure Maybe where - isFail = isNothing + isFail = isNothing instance MonadHasFailure [] where - isFail = null + isFail = null instance MonadHasFailure (Either a) where - isFail (Left _) = True - isFail _ = False - + isFail (Left _) = True + isFail _ = False {- A way of chaining together commands such - that the first function in the chain that @@ -202,49 +196,52 @@ instance MonadHasFailure (Either a) where -} (>|>) :: (MonadHasFailure m) => (a -> m c) -> (a -> m c) -> a -> m c (>|>) f1 f2 a = - let res = f1 a in - isFail res ? f2 a $ res + 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 + | 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 + 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 + 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) + 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) + 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 (x1 : x2 : xs) next func = dFold (x2 : xs) (func x1 x2 next) func dFold _ next _ = next (!>>) :: a -> (a -> b) -> b @@ -259,17 +256,19 @@ dFold _ next _ = next (<..>) :: (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" +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 + 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 @@ -278,7 +277,7 @@ 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 +data MonadPlusBuilder a b = MonadPlusBuilder a b plusM :: a -> MonadPlusBuilder a () plusM a = MonadPlusBuilder a () @@ -287,7 +286,7 @@ runMonadPlusBuilder :: MonadPlusBuilder a b -> a runMonadPlusBuilder (MonadPlusBuilder !a _) = a instance (MonadPlus a) => Functor (MonadPlusBuilder (a b)) where - fmap f b = b >>= return . f + fmap f b = b >>= return . f instance (MonadPlus a) => Applicative (MonadPlusBuilder (a b)) where (<*>) afn aa = do @@ -297,28 +296,29 @@ instance (MonadPlus a) => Applicative (MonadPlusBuilder (a b)) where 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 + 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 + 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 +(<!>) 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) +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 @@ -327,7 +327,7 @@ 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)) +fpart x = x - (fromIntegral (floor x :: Int)) ifNaN :: (RealFloat a) => a -> a -> a ifNaN reg def = if' (isNaN reg) def reg @@ -336,11 +336,12 @@ everyN :: Int -> [a] -> [a] everyN _ [] = [] everyN n (x : xs) = x : (everyN n $ drop n xs) -chunkList :: [a] -> [(a,a)] +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 +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)] |