1 {- 2 New implementation of minimum degree ordering (more 3 efficient). 4 Algorithm from Duff86. 5 6 XZ, 19/2/92 7 -} 8 9 module Min_degree (min_degree) where 10 11 import Defs 12 import S_Array -- not needed w/ proper module handling 13 import Norm -- ditto 14 import List(nub,partition)--1.3 15 16 -- minimum degree ordering 17 -- the entry lists in old_rows must be in assending order 18 min_degree :: (My_Array Int [Int]) -> [Int] 19 min_degree old_rows = find_min init_counts [] [] [] 20 where 21 -- initial row degree counts 22 init_counts = 23 s_accumArray (++) ([]::[Int]) (s_bounds old_rows) 24 (map (\(x,y)->(length y,[x])) (s_assocs old_rows)) 25 -- find rows with minimum degrees (recursive) 26 find_min counts cliques pro res = 27 if remaining == [] 28 then res 29 else find_min new_counts new_cliques processed new_pivots 30 where 31 -- updated result 32 new_pivots = res ++ [pivot_i] 33 -- processed rows 34 processed = mg_line pro [pivot_i] 35 -- updated row counts 36 new_counts = 37 s_accumArray mg_line ([]::[Int]) (s_bounds counts) 38 ((map (\(i,js)->(i,rm_list chgd js)) (sparse_assocs counts)) ++ updt) 39 where 40 chgd = mg_lines ([pivot_i]:[ js | (_, js) <- updt ]) 41 updt = count_update new_cols [] 42 -- counts of remaining rows 43 remaining = sparse_assocs counts 44 (_, (pivot_i:_)) = head remaining 45 -- (List of) cliques with the processed column removed. 46 -- Also, whole clique is removed if there is less 47 -- 2 entries in it. 48 rmed = do_rm cliques [] 49 -- the function does the removal 50 do_rm (cli:clis) rmd = 51 do_rm clis 52 ( 53 if (l2 == []) || (head l2) /= pivot_i 54 then cli:rmd 55 else 56 case r of 57 (r1:r2:_) -> r:rmd 58 _ -> rmd 59 ) 60 where 61 r = l1 ++ (tail l2) 62 (l1,l2) = partition ((<) pivot_i) cli 63 do_rm _ res = res 64 -- new cliques 65 new_cliques = nub (new_cols:rmed) 66 -- new clique 67 new_cols = remove pivot_i (get_cols pivot_i cliques) 68 where 69 remove x = filter ((/=) x) -- old haskell 1.0 function 70 -- the function which updates the row counts 71 count_update (r:rs) res = 72 count_update rs 73 (((length (get_cols r (new_cols:cliques)))-1,[r]):res) 74 count_update _ res = res 75 -- find nonzero entries 76 get_cols = \i cli -> 77 rm_list pro (mg_lines ((old_rows!^i):(filter (elem i) cli))) 78 79 -- the following functions assum lists are in assending order 80 81 -- check if two lists have something in common 82 inter_sec x@(x1:xs) y@(y1:ys) 83 | x1 == y1 = True 84 | x1 < y1 = inter_sec xs y 85 | otherwise = inter_sec x ys 86 inter_sec _ _ = False 87 88 -- remove entries in the 1st list from the 2nd list 89 rm_list x@(x1:xs) y@(y1:ys) 90 | x1 == y1 = rm_list xs ys 91 | x1 < y1 = rm_list xs y 92 | otherwise = y1:rm_list x ys 93 rm_list _ y = y 94 95 -- morge two lists 96 mg_line x@(x1:xs) y@(y1:ys) 97 | x1 == y1 = x1:mg_line xs ys 98 | x1 < y1 = x1:mg_line xs y 99 | otherwise = y1:mg_line x ys 100 mg_line x y = x ++ y 101 102 -- merge many lists 103 mg_lines :: Ord a => [[a]] -> [a] 104 105 mg_lines = foldl1 mg_line