Graphics/Glyph/ArrayGenerator.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45

{-# LANGUAGE UndecidableInstances #-}
module Graphics.Glyph.ArrayGenerator where

import qualified Data.Map as M

import Data.Array
import Data.Maybe

data ArrayTransaction ix val b = ArrayBuilderM_ (M.Map ix val) b

instance (Ord ix) => Functor (ArrayTransaction ix a) where
  fmap f bb = bb >>= (return . f)

instance (Ord ix) => Applicative (ArrayTransaction ix a) where
  (<*>) afn aa = do
     fn <- afn
     a <- aa
     return (fn a)

  pure = return

instance (Ord ix) => Monad (ArrayTransaction ix a) where
    return = ArrayBuilderM_ M.empty
    (ArrayBuilderM_ map1 val) >>= f = 
        ArrayBuilderM_ (map1 `M.union` map2) val2
        where (ArrayBuilderM_ map2 val2) = f val

class HasDefault a where
    theDefault :: a

instance (Num a) => HasDefault a where
    theDefault = 0
instance (HasDefault a, HasDefault b) => HasDefault (a,b) where
    theDefault = (theDefault,theDefault)
instance (HasDefault a, HasDefault b, HasDefault c) => HasDefault (a,b,c) where
    theDefault = (theDefault,theDefault,theDefault)

writeArray :: ix -> a -> ArrayTransaction ix a ()
writeArray index' val = ArrayBuilderM_ (M.singleton index' val) ()

buildArray :: (Ix ix) => (ix,ix) -> e -> ArrayTransaction ix e () -> Array ix e
buildArray bounds' def (ArrayBuilderM_ map' _) =
    listArray bounds' [maybeLookup map' bound | bound <- range bounds'] 
    where maybeLookup map_ key = fromMaybe def (M.lookup key map_)