home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / progs / prelude / PreludeArray.hs < prev    next >
Encoding:
Text File  |  1994-09-27  |  6.2 KB  |  213 lines  |  [TEXT/YHS2]
  1. module  PreludeArray ( Array, array, listArray, (!), bounds,
  2.              indices, elems, assocs, accumArray, (//), accum, amap,
  3.              ixmap
  4.            ) where
  5.  
  6. {-#Prelude#-}  -- Indicates definitions of compiler prelude symbols
  7.  
  8. -- This module uses some simple techniques with updatable vectors to
  9. -- avoid vector copying in loops where single threading is obvious.
  10. -- This is rather fragile and depends on the way the compiler handles
  11. -- strictness.
  12.  
  13. import PreludeBltinArray
  14. import PreludeArrayInternal
  15.  
  16. infixl 9  !
  17. infixl 9  //
  18.  
  19. data  (Ix a)    => Array a b = MkArray (a,a) {-#STRICT#-}
  20.                                        (Vector (Box b)) {-#STRICT#-}
  21.                        deriving ()
  22.  
  23. array        :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
  24. listArray    :: (Ix a) => (a,a) -> [b] -> Array a b
  25. (!)        :: (Ix a) => Array a b -> a -> b
  26. bounds        :: (Ix a) => Array a b -> (a,a)
  27. indices        :: (Ix a) => Array a b -> [a]
  28. elems        :: (Ix a) => Array a b -> [b]
  29. assocs        :: (Ix a) => Array a b -> [(a,b)]
  30. accumArray    :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]
  31.                  -> Array a b
  32. (//)        :: (Ix a) => Array a b -> [(a,b)] -> Array a b
  33. accum        :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]
  34.                  -> Array a b
  35. amap        :: (Ix a) => (b -> c) -> Array a b -> Array a c
  36. ixmap        :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c
  37.                  -> Array a c
  38.  
  39. -- Arrays are a datatype containing a bounds pair and a vector of values.
  40. -- Uninitialized array elements contain an error value.
  41.  
  42. -- Primitive vectors now contain only unboxed values.  This permits us to
  43. -- treat array indexing as an atomic operation without forcing the element
  44. -- being accessed.  The boxing and unboxing of array elements happens
  45. -- explicitly using these operations:
  46.  
  47. data Box a = MkBox a
  48. unBox (MkBox x) = x
  49. {-# unBox :: Inline #-}
  50.  
  51.  
  52. -- Array construction and update using index/value associations share
  53. -- the same helper function.
  54.  
  55. array b@(bmin, bmax) ivs =
  56.   let size = (index b bmax) + 1
  57.       v = primMakeVector size uninitializedArrayError
  58.   in (MkArray b (updateArrayIvs b v ivs))
  59. {-# array :: Inline #-}
  60.  
  61. a@(MkArray b v) // ivs =
  62.   let v' = primCopyVector v
  63.   in (MkArray b (updateArrayIvs b v' ivs))
  64. {-# (//) :: Inline #-}
  65.  
  66. updateArrayIvs b v ivs = 
  67.   let g (i,x) next =  strict1 (primVectorUpdate v (index b i) (MkBox x))
  68.                                  next
  69.   in foldr g v ivs
  70. {-# updateArrayIvs :: Inline #-}
  71.  
  72. uninitializedArrayError = 
  73.   MkBox (error "(!){PreludeArray}: uninitialized array element.")
  74.  
  75.  
  76. -- when mapping a list onto an array, be smart and don't do full index 
  77. -- computation
  78.  
  79. listArray b@(bmin, bmax) vs =
  80.   let size = (index b bmax) + 1
  81.       v = primMakeVector size uninitializedArrayError
  82.   in (MkArray b (updateArrayVs size v vs))
  83. {-# listArray :: Inline #-}
  84.  
  85. updateArrayVs size v vs =
  86.   let g x next j = if (j == size)
  87.                      then v
  88.              else strict1 (primVectorUpdate v j (MkBox x))
  89.                           (next (j + 1))
  90.   in foldr g (\ _ -> v) vs 0
  91. {-# updateArrayVs :: Inline #-}
  92.  
  93.  
  94. -- Array access
  95.  
  96. a@(MkArray b v) ! i = unBox (primVectorSel v (index b i))
  97. {-# (!) :: Inline #-}
  98.  
  99. bounds (MkArray b _)  = b
  100.  
  101. indices              = range . bounds
  102.  
  103.  
  104. -- Again, when mapping array elements into a list, be smart and don't do 
  105. -- the full index computation for every element.
  106.  
  107. elems a@(MkArray b@(bmin, bmax) v) =
  108.   build (\ c n -> 
  109.           let size = (index b bmax) + 1
  110.           g j  = if (j == size)
  111.                     then n
  112.             else c (unBox (primVectorSel v j)) (g (j + 1))
  113.           -- This strict1 is so size doesn't get inlined and recomputed
  114.       -- at every iteration.  It should also force the array argument
  115.       -- to be strict.
  116.           in strict1 size (g 0))
  117. {-# elems :: Inline #-}
  118.  
  119. assocs a@(MkArray b@(bmin, bmax) v) =
  120.   build (\ c n ->
  121.           let g i next j = let y = unBox (primVectorSel v j)
  122.                            in c (i,y) (next (j + 1))
  123.       in foldr g (\ _ -> n) (range b) 0)
  124. {-# assocs :: Inline #-}
  125.  
  126.  
  127. -- accum and accumArray share the same helper function.  The difference is
  128. -- that accum makes a copy of an existing array and accumArray creates
  129. -- a new one with all elements initialized to the given value.
  130.  
  131. accum f a@(MkArray b v) ivs =
  132.   let v' = primCopyVector v
  133.   in (MkArray b (accumArrayIvs f b v' ivs))
  134. {-# accum :: Inline #-}
  135.  
  136. accumArray f z b@(bmin, bmax) ivs =
  137.   let size = (index b bmax) + 1
  138.       v = primMakeVector size (MkBox z)
  139.   in (MkArray b (accumArrayIvs f b v ivs))
  140. {-# accumArray :: Inline #-}
  141.  
  142.  
  143. -- This is a bit tricky.  We need to force the access to the array element
  144. -- before the update, but not force the thunk that is the value of the
  145. -- array element unless f is strict.
  146.  
  147. accumArrayIvs f b v ivs =
  148.   let g (i,x) next = 
  149.         let j = index b i
  150.         y = primVectorSel v j
  151.     in strict1
  152.          y
  153.          (strict1 (primVectorUpdate v j (MkBox (f (unBox y) x)))
  154.                   next)
  155.   in foldr g v ivs
  156. {-# accumArrayIvs :: Inline #-}
  157.  
  158.  
  159. -- again, be smart and bypass full array indexing on array mapping
  160.  
  161. amap f a@(MkArray b@(bmin, bmax) v) =
  162.   let size = (index b bmax) + 1
  163.       v' = primMakeVector size uninitializedArrayError
  164.       g j = if (j == size)
  165.               then v'
  166.           else let y = primVectorSel v j
  167.                in strict1 (primVectorUpdate v' j (MkBox (f (unBox y))))
  168.                           (g (j + 1))
  169.   in (MkArray b (g 0))
  170. {-# amap :: Inline #-}
  171.  
  172.  
  173. -- can't bypass the index computation here since f needs it as an argument
  174.  
  175. ixmap b f a           = array b [(i,a ! f i) | i <- range b]
  176. {-# ixmap :: Inline #-}
  177.  
  178.  
  179. -- random other stuff
  180.  
  181. instance  (Ix a, Eq b)  => Eq (Array a b)  where
  182.     a == a'              =  assocs a == assocs a'
  183.  
  184. instance  (Ix a, Ord b) => Ord (Array a b)  where
  185.     a <=  a'              =  assocs a <=  assocs a'
  186.  
  187. instance  (Ix a, Text a, Text b) => Text (Array a b)  where
  188.     showsPrec p a = showParen (p > 9) (
  189.             showString "array " .
  190.             shows (bounds a) . showChar ' ' .
  191.             shows (assocs a)                  )
  192.  
  193.     readsPrec p = readParen (p > 9)
  194.        (\r -> [(array b as, u) | ("array",s) <- lex r,
  195.                      (b,t)       <- reads s,
  196.                      (as,u)      <- reads t   ]
  197.           ++
  198.           [(listArray b xs, u) | ("listArray",s) <- lex r,
  199.                      (b,t)           <- reads s,
  200.                      (xs,u)          <- reads t ])
  201.  
  202.  
  203.  
  204. module PreludeArrayInternal where
  205.  
  206. {-# Prelude #-}
  207.  
  208. -- These are internal data types
  209.  
  210. data Vector a = MkVector a
  211. data Delay a = MkDelay a
  212.  
  213.