1 module Stuff
    2 
    3 ( bind
    4 , fixpoint
    5 , sethull
    6 , zippy
    7 , lookupset
    8 , invert
    9 , packs
   10 , insts
   11 , collectFM
   12 
   13 , exists
   14 , the
   15 
   16 , inits
   17 , tails
   18 , intersperse
   19 
   20 , partition
   21 )
   22 
   23 where
   24 
   25 import Set
   26 import FiniteMap
   27 
   28 -- hbc complains
   29 
   30 {- # SPECIALIZE instance Eq (Set Int) #-}
   31 {- # SPECIALIZE instance Ord (Set Int) #-}
   32 
   33 {- # SPECIALIZE instance Eq (Set (Int, Int)) #-}
   34 {- # SPECIALIZE instance Ord (Set (Int, Int)) #-}
   35 
   36 
   37 exists (Just _) = True
   38 exists Nothing = False
   39 
   40 the (Just x) = x
   41 the _ = error "the"
   42 
   43 
   44 
   45 bind :: Ord b => Set a -> (a -> Set b) -> Set b
   46 -- looks familiar? could be a monad, eh?
   47 s `bind` f = unionManySets (map f (setToList s))
   48 
   49 fixpoint :: Eq a => (a -> a) -> a -> a
   50 fixpoint f x = 
   51     let y = f x
   52     in  if x == y then x else fixpoint f y
   53 
   54 zippy :: [a] -> [b] -> [(a,b)]
   55 -- checks that args have equal length
   56 zippy [] [] = []
   57 zippy (x : xs) (y : ys) = (x,y) : zippy xs ys
   58 zippy _ _ = error "zippy: unequal lengths"
   59 
   60 sethull :: Ord a => (a -> Set a) -> Set a -> Set a
   61 sethull f init = sh emptySet init 
   62     where
   63         sh known unknown | isEmptySet unknown = known
   64         sh known unknown = 
   65             let        xs = unknown `bind` f
   66                 uk = known `unionSet` unknown
   67                 ys = xs `minusSet` uk
   68             in sh uk ys
   69 
   70 -- returns empty set as default
   71 lookupset m x = lookupWithDefaultFM m emptySet x
   72 
   73 
   74 
   75 -- inits xs returns the list of initial segments of xs, shortest first.
   76 -- e.g., inits "abc" == ["","a","ab","abc"]
   77 inits                  :: [a] -> [[a]]
   78 inits []                = [[]]
   79 inits (x:xs)            = [[]] ++ map (x:) (inits xs)
   80 
   81 -- tails xs returns the list of all final segments of xs, longest first.
   82 -- e.g., tails "abc" == ["abc", "bc", "c",""]
   83 tails                  :: [a] -> [[a]]
   84 tails []                = [[]]
   85 tails xxs@(_:xs)        = xxs : tails xs
   86 
   87 
   88 
   89 
   90 invert :: (Ord a, Ord b) => FiniteMap a (Set b) -> FiniteMap b (Set a)
   91 invert fab = 
   92     addListToFM_C unionSet emptyFM 
   93         [(y,unitSet x)|(x,ys) <- fmToList fab, y <- setToList ys]
   94 
   95 
   96 partition :: (a -> Bool) -> [a] -> ([a], [a])
   97 partition p [] = ([], [])
   98 partition p (x : xs) = 
   99     let (as, bs) = partition p xs
  100     in  if p x then (x : as, bs) else (as, x : bs)
  101 
  102 
  103 
  104 packs :: Int -> Int -> [a] -> [a] -> [[a]]
  105 -- packs n m xs ys = all list of length n 
  106 -- whose elements are in xs ++ ys
  107 -- with at least m from ys
  108 packs 0 _ _ _   = [[]]
  109 packs n m xs ys = [ h : t | n > m, t <- packs (n - 1) m       xs ys, h <- xs ]
  110                ++ [ h : t |        t <- packs (n - 1) (m - 1) xs ys, h <- ys ]
  111 
  112 insts :: Ord a => [Set a] -> Set [a]
  113 -- all instances of a given list whose elements are sets
  114 insts []       = unitSet []
  115 insts (x : xs) = insts xs `bind` \ t -> mapSet (\ h -> h : t) x
  116 
  117 -- intersperse sep inserts sep between the elements of its list argument.
  118 -- e.g. intersperse ',' "abcde" == "a,b,c,d,e"
  119 intersperse            :: a -> [a] -> [a]
  120 intersperse sep []      = []
  121 intersperse sep [x]     = [x]
  122 intersperse sep (x:xs)  = x : sep : intersperse sep xs
  123 
  124 
  125 collectFM :: Ord a => [a] -> FiniteMap a Int
  126 -- collect elements, count them
  127 -- duplicates get same number
  128 -- but beware: numbers are not used contiguously
  129 collectFM xs = addListToFM_C
  130         (\ x old -> old)       -- already there, don't overwrite
  131         emptyFM
  132         (zip xs [0..])         -- count them
  133 
  134