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