1 {- 2 This is a substitute for module PreludeArray oriented 3 to sparse arrays. Arrays are constructed using binary 4 radix tries. Signatures of functions are kept as close as 5 possible to their standard counterparts (index type is 6 restricted to Int). 7 8 This module also includes some extra functions 9 specifically for sparse array operations. 10 11 XZ, 19/2/92 12 -} 13 14 module S_Array ( 15 S_array, -- counterpart of Array 16 s_array, -- counterparts of array 17 s_def_array, -- new 18 s_listArray, -- counterparts of listArray 19 s_def_listArray, -- new 20 (!^), -- counterpart of (!) 21 s_bounds, -- counterpart of bounds 22 s_indices, -- counterpart of indices 23 s_elems, -- counterpart of elems 24 s_assocs, -- counterpart of assocs 25 s_accumArray, -- counterpart of accumArray 26 (//^), -- counterpart of (//) 27 s_accum, -- counterpart of accum 28 s_amap, -- counterpart of amap 29 s_ixmap, -- counterpart of ixmap 30 sparse_assocs {-, -- new 31 Norm.. partain: NOT YET ************** -} 32 ) 33 where 34 35 import Norm 36 37 import Array--1.3 38 import Ix--1.3 39 import List -- 1.3 40 41 infixl 9 !^ 42 infixl 9 //^ 43 infix 4 :^: 44 45 type Assoc a b = (a,b) 46 47 {- 48 definitions of data types 49 -} 50 51 -- data type of index 52 type Ix_type = Int 53 54 -- data type of default value 55 --1.3:data Maybe a = 56 -- Nothing | Just a 57 -- deriving (Eq) 58 59 -- data type of radix trie 60 data Bin_Trie a = 61 Null | Leaf a | (Bin_Trie a) :^: (Bin_Trie a) 62 deriving () 63 -- data type of sparse array 64 data S_array a = 65 Mk_t_Array (Ix_type,Ix_type) Ix_type (Maybe a) (Bin_Trie a) 66 deriving () 67 68 {- 69 function signatures 70 -} 71 72 s_array :: (Ix_type,Ix_type) -> [Assoc Ix_type a] -> S_array a 73 s_def_array :: (Eq a) => 74 (Ix_type,Ix_type) -> a -> [Assoc Ix_type a] -> S_array a 75 s_listArray :: (Ix_type,Ix_type) -> [a] -> S_array a 76 s_def_listArray :: (Eq a) => 77 (Ix_type,Ix_type) -> a -> [a] -> S_array a 78 (!^) :: S_array a -> Ix_type -> a 79 s_bounds :: S_array a -> (Ix_type,Ix_type) 80 s_indices :: S_array a -> [Ix_type] 81 s_elems :: S_array a -> [a] 82 s_assocs :: S_array a -> [Assoc Ix_type a] 83 sparse_assocs :: S_array a -> [Assoc Ix_type a] 84 s_accumArray :: (Eq a) => 85 (a->b->a) -> a -> (Ix_type,Ix_type) -> [Assoc Ix_type b] -> S_array a 86 (//^) :: (Eq a) => 87 S_array a -> [Assoc Ix_type a] -> S_array a 88 s_accum :: (Eq a) => 89 (a->b->a) -> S_array a -> [Assoc Ix_type b] -> S_array a 90 --hbc doesn't like: s_amap :: (b->a) -> S_array b -> S_array a 91 s_ixmap :: 92 (Ix_type,Ix_type) -> (Ix_type->Ix_type) -> S_array a -> S_array a 93 94 {- 95 declarations of exported functions 96 -} 97 98 s_array b@(b1,_) asocs = 99 if check_as b asocs -- check if indices are within bounds 100 then -- ok 101 -- do construction 102 -- radix trie is generated from [Assoc Ix_type a] by gen_trie 103 -- default value is set to Nothing 104 Mk_t_Array b sz Nothing 105 (gen_trie sz (convt_as b1 asocs)) 106 else err_out 107 where 108 sz = size b 109 110 -- new function, refer s_array for comments 111 s_def_array b@(b1,_) def_v asocs = 112 if check_as b asocs 113 then 114 -- default value is set to (Just dev_v) 115 Mk_t_Array b sz (Just def_v) 116 (gen_trie sz (convt_as b1 new_as)) 117 else err_out 118 where 119 sz = size b 120 -- remove trivial associations 121 new_as = 122 filter (\(i,v)->v/=def_v) asocs 123 124 s_listArray b vs = 125 -- default value is set to Nothing 126 Mk_t_Array b (size b) Nothing 127 -- radix trie is generated from [a] by gen_trie_from_list 128 (gen_trie_from_list (height b) 129 (map Leaf (take (b_size b) vs))) 130 131 -- new function 132 s_def_listArray b def_v vs = 133 -- default value is set to (Just dev_v) 134 Mk_t_Array b (size b) (Just def_v) 135 -- radix trie is generated from [a] by gen_trie_from_list 136 (gen_trie_from_list (height b) (map convt (take (b_size b) vs))) 137 where 138 -- remove trivial values 139 convt = \x -> 140 if (x == def_v) 141 then Null 142 else Leaf x 143 144 (!^) a@(Mk_t_Array b@(b1,_) sz default_v b_trie) i = 145 if inRange b i -- check index 146 then get_v_from_trie (find_leaf b_trie sz (i-b1)) default_v 147 else err_out 148 149 s_bounds (Mk_t_Array b _ _ _) = b 150 151 s_indices = range.s_bounds 152 153 s_elems (Mk_t_Array b sz default_v b_trie) = 154 -- flatten a radix trie 155 flatten (b_size b) sz b_trie 156 where 157 def_v = get_just_v default_v 158 flatten n s (t1 :^: t2) = l1 ++ l2 159 where 160 l1 = flatten (min s' n) s' t1 161 l2 = flatten (max 0 (n-s')) s' t2 162 s' = s `div` 2 163 flatten n _ Null = [ def_v | i <- range (1,n) ] 164 flatten _ _ (Leaf v) = [v] 165 166 s_assocs a = 167 zipWith (\x y->(x,y)) (s_indices a) (s_elems a) 168 169 -- new function for obtaining non-trivial associations 170 sparse_assocs (Mk_t_Array (b1,_) sz _ b_trie) = 171 flatten_sparse b1 sz b_trie 172 where 173 flatten_sparse n s (br1:^:br2) = 174 (flatten_sparse n s' br1) ++ (flatten_sparse (n+s') s' br2) 175 where s' = s `div` 2 176 flatten_sparse _ _ Null = [] 177 flatten_sparse n _ (Leaf v) = [(n,v)] 178 179 (//^) (Mk_t_Array b@(b1,_) sz default_v b_trie) asocs = 180 if check_as b asocs 181 then 182 if undefinedd default_v -- check if default is defined 183 then 184 -- not defined, directly update 185 Mk_t_Array b sz default_v 186 (do_update b_trie sz (convt_as b1 asocs)) 187 else 188 -- defined, convert trivials (to Null) than update 189 Mk_t_Array b sz default_v 190 (do_update b_trie sz (map_as b1 (map convt asocs))) 191 else err_out 192 where 193 def_v = get_just_v default_v 194 -- conversion function 195 convt = \(i,v) -> 196 if ( v==def_v ) 197 then (i,Null) 198 else (i,Leaf v) 199 -- trie update function 200 do_update br _ [] = br 201 do_update br s as = 202 case br of 203 (br1 :^: br2) -> 204 fork (do_update br1 s' as1) (do_update br2 s' (map_as s' as2)) 205 where 206 s' = s `div` 2 207 (as1,as2) = partition (\(i,_)->(i<s')) as 208 Null -> gen_trie s as 209 (Leaf _) -> 210 case as of 211 [(_,v)] -> v 212 _ -> err_multi 213 214 s_accum f (Mk_t_Array b@(b1,_) sz default_v b_trie) asocs = 215 if check_as b asocs 216 then 217 Mk_t_Array b sz default_v 218 (do_accum b_trie sz (map_as b1 asocs)) 219 else err_out 220 where 221 defed = not (undefinedd default_v) 222 def_v = get_just_v default_v 223 -- generate a radix trie, slightly different from gen_trie 224 gen_a_trie _ [] = Null 225 gen_a_trie 1 as = gen_leaf def_v as 226 gen_a_trie s as = 227 fork (gen_a_trie s' as1) (gen_a_trie s' (map_as s' as2)) 228 where 229 s' = s `div` 2 230 (as1,as2) = partition (\(i,_)->(i<s')) as 231 -- generate a leaf with accumulated value 232 gen_leaf v as = 233 if defed && (x == def_v) 234 then Null 235 else Leaf x 236 where x = foldl f v (map (\(_,v')->v') as) 237 -- update radix trie with accumulated values 238 do_accum br _ [] = br 239 do_accum br s as = 240 case br of 241 (br1 :^: br2) -> 242 fork (do_accum br1 s' as1) (do_accum br2 s' (map_as s' as2)) 243 where 244 s' = s `div` 2 245 (as1,as2) = partition (\(i,_)->(i<s')) as 246 Null -> gen_a_trie s as 247 (Leaf v) -> gen_leaf v as 248 249 s_accumArray f z b = 250 s_accum f (Mk_t_Array b (size b) (Just z) Null) 251 252 s_amap f (Mk_t_Array b sz default_v b_trie) = 253 Mk_t_Array b sz new_def_v (do_replace b_trie) 254 where 255 -- modify default value if necessary 256 new_def_v = 257 if undefinedd default_v 258 then default_v 259 else Just ((f.get_just_v) default_v) 260 -- function for replacing leaves with new values 261 do_replace br = 262 case br of 263 (br1 :^: br2) -> 264 fork (do_replace br1) (do_replace br2) 265 Null -> br 266 (Leaf v) -> Leaf (f v) 267 268 s_ixmap b f (Mk_t_Array (b1,_) sz default_v b_trie) = 269 Mk_t_Array b (size b) default_v 270 (gen_trie_from_list (height b) 271 (map (find_leaf b_trie sz) 272 (map (\i->(f i)-b1) (range b)))) 273 274 {- 275 declarations of internal functions 276 -} 277 278 -- error functions 279 280 err_out = error "s_array: index out of range!" 281 err_undefed = error "s_array: value not defined!" 282 err_multi = error "s_array: multiple value definitions!" 283 284 -- functions operating on [Assoc Ix_type a] 285 286 convt_as :: 287 Ix_type -> [Assoc Ix_type a] -> [Assoc Ix_type (Bin_Trie a)] 288 convt_as = \s -> map (\ (i,v) -> ((i-s),Leaf v)) 289 290 map_as :: Ix_type -> [Assoc Ix_type a] -> [Assoc Ix_type a] 291 map_as = \s -> map (\ (i,v)->((i-s),v)) 292 293 check_as :: (Ix_type,Ix_type) -> [Assoc Ix_type a] -> Bool 294 check_as = \b asocs -> and (map (\(i , _) -> inRange b i) asocs) 295 296 -- functions for generating radix tries 297 298 -- generate a trie from [Assoc Ix_type (Bin_Trie a)] 299 gen_trie :: Ix_type -> [Assoc Ix_type (Bin_Trie a)] -> Bin_Trie a 300 gen_trie _ [] = Null 301 gen_trie 1 [(_,v)] = v 302 gen_trie 1 _ = err_multi 303 gen_trie s as = 304 fork (gen_trie s' as1) (gen_trie s' (map_as s' as2)) 305 where 306 s' = s `div` 2 307 (as1,as2) = partition (\(i,_)->(i<s')) as 308 309 -- generate a trie from [(Bin_Trie a)] 310 gen_trie_from_list :: Ix_type -> [Bin_Trie a] -> Bin_Trie a 311 gen_trie_from_list _ [] = Null 312 gen_trie_from_list 0 [t] = t 313 gen_trie_from_list n sub_ts = 314 gen_trie_from_list (n-1) (groop sub_ts ) 315 316 -- group subtries 317 groop :: [Bin_Trie a] -> [Bin_Trie a] 318 groop (t1:t2:rest) = (fork t1 t2) : (groop rest) 319 groop [t] = [fork t Null] 320 groop _ = [] 321 322 -- generate a fork 323 fork :: Bin_Trie a -> Bin_Trie a -> Bin_Trie a 324 fork Null Null = Null 325 fork br1 br2 = br1 :^: br2 326 327 -- testing functions 328 329 -- test if a trie is empty 330 empty_trie :: Bin_Trie a -> Bool 331 empty_trie Null = True 332 empty_trie _ = False 333 334 -- test if a default value is defined 335 undefinedd :: Maybe a -> Bool 336 undefinedd Nothing = True 337 undefinedd _ = False 338 339 -- value retrieve functions 340 341 -- locate a leaf ( or a Null node ) 342 find_leaf :: Bin_Trie a -> Ix_type -> Ix_type -> Bin_Trie a 343 find_leaf = \t s k -> 344 case t of 345 (t1 :^: t2) -> 346 find_leaf t' s' (if k<s' then k else (k-s')) 347 where 348 s' = s `div` 2 349 t' = if k<s' then t1 else t2 350 _ -> t 351 352 get_just_v :: (Maybe a) -> a 353 get_just_v (Just v) = v 354 get_just_v _ = err_undefed 355 356 get_leaf_v :: (Bin_Trie a) -> a 357 get_leaf_v (Leaf v) = v 358 get_leaf_v _ = err_undefed 359 360 get_v_from_trie :: (Bin_Trie a) -> (Maybe a) -> a 361 get_v_from_trie (Leaf v) _ = v 362 get_v_from_trie _ (Just v) = v 363 get_v_from_trie _ _ = err_undefed 364 365 -- functions for calculating sizes 366 367 height :: (Ix_type,Ix_type) -> Ix_type 368 height = \b@(b1,b2) -> 369 if b1<=b2 370 then ceiling (logBase 2 (fromIntegral (b_size b))) 371 --partain: could use: then ceiling ((logBase (2::Float) ((fromIntegral (b_size b))::Float)) ::Float) 372 else 0 373 374 size :: (Ix_type,Ix_type) -> Ix_type 375 size = \b@(b1,b2) -> 376 if b1<=b2 377 then (2::Ix_type)^(height b) 378 else 0 379 380 b_size :: (Ix_type,Ix_type) -> Ix_type 381 b_size = \(b1,b2) -> 382 if b1<=b2 383 then b2-b1+1 384 else 0 385 386 {- 387 definitions of (==) on S_array 388 -} 389 390 instance (Eq a) => Eq (S_array a) where 391 (Mk_t_Array b1 sz d1 b_trie1) == (Mk_t_Array b2 _ d2 b_trie2) = 392 b1 == b2 && eq_trie leaf_no sz b_trie1 b_trie2 393 where 394 leaf_no = b_size b1 395 eq_def = d1 == d2 396 397 -- partain: added sig 398 eq_trie :: (Eq b) => Ix_type -> Ix_type -> Bin_Trie b -> Bin_Trie b -> Bool 399 eq_trie 0 _ _ _ = True 400 eq_trie l s (lb1:^:rb1) (lb2:^:rb2) = 401 eq_trie (min s' l) s' lb1 lb2 && 402 eq_trie (max 0 (l-s')) s' rb1 rb2 403 where 404 s' = s `div` 2 405 eq_trie _ _ Null Null = eq_def 406 eq_trie _ _ (Leaf x) (Leaf y) = x == y 407 eq_trie _ _ _ _ = False 408 409 {- 410 definitions for class Text 411 -} 412 413 instance (Show a) => 414 Show (S_array a) where 415 showsPrec p a = 416 showParen (p>9) ( 417 showString "array " . 418 shows (s_bounds a) . showChar ' ' . 419 shows (s_assocs a)) 420 instance (Read a) => 421 Read (S_array a) where 422 readsPrec p = 423 readParen (p>9) 424 (\r -> 425 [ (s_array b as, u) | 426 ("array", s) <- lex r, 427 (b,t)<- reads s, 428 (as,u) <- reads t 429 ] 430 ++ 431 [ (s_listArray b xs, u) | 432 ("listArray",s) <- lex r, 433 (b,t) <- reads s, 434 (xs,u) <- reads t 435 ] 436 ) 437 438 instance (Show a) => 439 Show (Bin_Trie a) where 440 showsPrec p t = 441 case t of 442 Null -> showString "Null" 443 (Leaf m) -> 444 showParen (p>9) 445 (showString "Leaf " . showsPrec 10 m) 446 (u:^:v) -> 447 showParen (p>4) 448 (showsPrec 5 u . showString " :^: " . showsPrec 5 v) 449 450 instance (Normal a) => Normal (Bin_Trie a) where 451 normal (b1 :^: b2) = normal b1 `andAnd` normal b2 452 normal (Leaf v) = normal v 453 normal Null = True 454 455 instance (Normal a) => Normal (Maybe a) where 456 normal (Just v) = normal v 457 normal Nothing = True 458 459 instance (Normal a) => Normal (S_array a) where 460 normal a@(Mk_t_Array b s def_v b_trie) 461 | normal b `andAnd` normal s `andAnd` normal def_v `andAnd` normal b_trie = True