|
| 1 | +------------------------------------------------------------------------------- |
| 2 | +-- This file contains a Gofer implementation of the Haskell array datatype |
| 3 | +-- using new Gofer primitives added in Gofer 2.30. |
| 4 | +-- |
| 5 | +-- This file requires the standard, or cc prelude. |
| 6 | +-- You will not be able to use this file unless the version of Gofer that |
| 7 | +-- is installed on your machine has been compiled with the HASKELL_ARRAYS |
| 8 | +-- flag set to 1. |
| 9 | +-- |
| 10 | +-- Based on the standard prelude for Haskell 1.2. |
| 11 | +-- Mark P Jones, 1994 |
| 12 | +------------------------------------------------------------------------------- |
| 13 | + |
| 14 | +module PreludeArray( Array, Assoc((:=)), array, listArray, (!), bounds, |
| 15 | + indices, elems, assocs, accumArray, (//), accum, amap, |
| 16 | + ixmap |
| 17 | + ) where |
| 18 | + |
| 19 | +infixl 9 ! |
| 20 | +infixl 9 // |
| 21 | +infix 1 := |
| 22 | + |
| 23 | +-- Associations: Frankly, any pair type would do just as well ... ------------ |
| 24 | + |
| 25 | +data Assoc a b = a := b |
| 26 | + |
| 27 | +instance (Eq a, Eq b) => Eq (Assoc a b) where |
| 28 | + (x := y) == (u := v) = x==u && y==v |
| 29 | + |
| 30 | +instance (Ord a, Ord b) => Ord (Assoc a b) where |
| 31 | + (x := y) <= (u := v) = x<u || (x==u && y<=v) |
| 32 | + |
| 33 | +instance (Text a, Text b) => Text (Assoc a b) where |
| 34 | + showsPrec d (x := y) |
| 35 | + = if d > 1 then showChar '(' . s . showChar ')' |
| 36 | + else s |
| 37 | + where s = showsPrec 2 x . showString " := " . showsPrec 2 y |
| 38 | + |
| 39 | +-- Array primitives: ---------------------------------------------------------- |
| 40 | + |
| 41 | +array :: Ix a => (a,a) -> [Assoc a b] -> Array a b |
| 42 | +listArray :: Ix a => (a,a) -> [b] -> Array a b |
| 43 | +(!) :: Ix a => Array a b -> a -> b |
| 44 | +bounds :: Ix a => Array a b -> (a,a) |
| 45 | +indices :: Ix a => Array a b -> [a] |
| 46 | +elems :: Ix a => Array a b -> [b] |
| 47 | +assocs :: Ix a => Array a b -> [Assoc a b] |
| 48 | +accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [Assoc a c] -> Array a b |
| 49 | +(//) :: Ix a => Array a b -> [Assoc a b] -> Array a b |
| 50 | +accum :: Ix a => (b -> c -> b) -> Array a b -> [Assoc a c] -> Array a b |
| 51 | +amap :: Ix a => (b -> c) -> Array a b -> Array a c |
| 52 | +ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c |
| 53 | + |
| 54 | +instance (Ix a, Eq [Assoc a b]) => Eq (Array a b) where |
| 55 | + a == a' = assocs a == assocs a' |
| 56 | + |
| 57 | +instance (Ix a, Ord [Assoc a b]) => Ord (Array a b) where |
| 58 | + a <= a' = assocs a <= assocs a' |
| 59 | + |
| 60 | +instance (Ix a, Text (a,a), Text [Assoc a b]) => Text (Array a b) where |
| 61 | + showsPrec p a = if (p>9) then showChar '(' . s . showChar ')' else s |
| 62 | + where s = showString "array " . |
| 63 | + shows (bounds a) . |
| 64 | + showChar ' ' . |
| 65 | + shows (assocs a) |
| 66 | + |
| 67 | +-- Implementation: ------------------------------------------------------------ |
| 68 | + |
| 69 | +primitive primArray "primArray" |
| 70 | + :: (a -> Int) -> (a,a) -> [Assoc a b] -> Array a b |
| 71 | +primitive primUpdate "primUpdate" |
| 72 | + :: (a -> Int) -> Array a b -> [Assoc a b] -> Array a b |
| 73 | +primitive primAccum "primAccum" |
| 74 | + :: (a -> Int) -> (b -> c -> b) -> Array a b -> [Assoc a c] -> Array a b |
| 75 | +primitive primAccumArray "primAccumArray" |
| 76 | + :: (a -> Int) -> (b -> c -> b) -> b -> (a,a) -> [Assoc a c] -> Array a b |
| 77 | +primitive primBounds "primBounds" :: Array a b -> (a,a) |
| 78 | +primitive primElems "primElems" :: Array a b -> [b] |
| 79 | +primitive primSubscript "primSubscript" :: (a -> Int) -> Array a b -> a -> b |
| 80 | +primitive primAmap "primAmap" :: (b -> c) -> Array a b -> Array a c |
| 81 | + |
| 82 | +array bounds assocs = primArray (index bounds) bounds assocs |
| 83 | +listArray b vs = array b (zipWith (:=) (range b) vs) |
| 84 | +(!) a = primSubscript (index (bounds a)) a |
| 85 | +bounds = primBounds |
| 86 | +indices = range . bounds |
| 87 | +elems = primElems |
| 88 | +assocs a = zipWith (:=) (indices a) (elems a) |
| 89 | +accumArray f z b = primAccumArray (index b) f z b |
| 90 | +a // as = primUpdate (index (bounds a)) a as |
| 91 | +accum f a = primAccum (index (bounds a)) f a |
| 92 | +amap = primAmap |
| 93 | +ixmap b f a = array b [ i := (a ! f i) | i <- range b ] |
| 94 | + |
| 95 | +instance (Ix a, Ix b) => Ix (a,b) where |
| 96 | + range ((l,l'),(u,u')) |
| 97 | + = [ (i,i') | i <- range (l,u), i' <- range (l',u') ] |
| 98 | + index ((l,l'),(u,u')) (i,i') |
| 99 | + = index (l,u) i * rangeSize (l',u') + index (l',u') i' |
| 100 | + inRange ((l,l'),(u,u')) (i,i') |
| 101 | + = inRange (l,u) i && inRange (l',u') i' |
| 102 | + |
| 103 | +rangeSize :: (Ix a) => (a,a) -> Int |
| 104 | +rangeSize r@(l,u) = index r u + 1 |
| 105 | + |
| 106 | +------------------------------------------------------------------------------- |
0 commit comments