[project @ 1996-07-25 21:02:03 by partain]
[nofib.git] / real / fluid / Min_degree.hs
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