Haskell implementation of Quine-McCluskey Algorithm

quine-mcCluskey.hs

 import Data.Maybe
 import Data.List (nubBy, sort, isSuffixOf, group, inits, tails, find, intercalate)
 
 data Bit = F | T | X deriving (Show, Enum, Ord, Eq)
 
 type BitSet = [Bit]
 
 type Minterm = ([Integer], BitSet)
  
 type Table = [Minterm]
 safeHead::[a] -> Maybe a
 safeHead [] = Nothing
 safeHead (t:_) = Just t
 
 smallest::[[a]] -> [a]
 smallest [] = error "empty list"
 smallest a = reverse.fst $ smallest' $ map ((,) []) a
    where 
        smallest' a = case find cmp a of
                           Just l -> l
                           Nothing -> smallest' $ map helper a
                           
        cmp (_ , []) = True
        cmp _ = False
        helper (as, (b:bs)) = (b:as, bs)
 

 
 merge::Minterm -> Minterm -> Maybe Minterm
 merge (m1, b1) (m2, b2) = if isJust $ merge' b1 b2
                              then Just (m1++m2, fromJust $ merge' b1 b2)
                              else Nothing
    where 
        merge'::BitSet -> BitSet -> Maybe BitSet
        merge' [] [] = Nothing
        merge' (m:ms) (n:ns)
            | m == n             = fmap (m:) $ merge' ms ns
            | m /= n && ms == ns = fmap (X:) $ Just ms
            | otherwise          = Nothing
            
 --O(n²) 
 reduce:: Table -> Table
 reduce [] = []
 reduce t = clear $ (reduce $ reduce' t) ++ t
    where 
        reduce' [] = []
        reduce' (m:ts) = mapMaybe (merge m) ts ++ reduce' ts
        clear [] = []
        clear (t:ts) = t:(clear $ filter (t `notIn`) ts)
        notIn (t, _) (a, _) = not.and $ map (`elem` t) a
        
 -- o(n Log n)
 primeImplicant::Table -> Maybe Integer
 primeImplicant = fmap head . safeHead . filter ((1==).length) . group . sort . concat. map fst
        
 -- O(n⁴) if I compute correctly      
 minimalize:: Table -> [BitSet]
 minimalize [] = []
 minimalize t = case primeImplicant t of
                     Just p -> (snd $ term p t):(minimalize $ removeMinterms (fst $ term p t) t)
                     Nothing -> smallest $ map minimalize' $ zipWith (++) (inits t) (tail $ tails t)
    where
        term::Integer -> Table -> Minterm
        term m = head . filter (\(x, _) -> m `elem` x)
        removeMinterms ms = filter (not.null.fst) .map (\(x, b) -> (filter (not.(`elem` ms)) x , b))
        minimalize' t = (snd $ head t):(minimalize $ removeMinterms (fst $ head t) t)
        
 
 
 pretly::[BitSet] -> String
 pretly = intercalate " + " . map pretly' . sort
    where 
        pretly' bs = concat $ zipWith ($) (fmap apply bs) ['A'..]
        apply T b = b:""
        apply F b = b:"'"
        apply X b = ""
 
         
 table = [([2 ], [F,F,T,F]),
          ([4 ], [F,T,F,F]),
          ([6 ], [F,T,T,F]),
          ([8 ], [T,F,F,F]),
          ([9 ], [T,F,F,T]),
          ([10], [T,F,T,F]),
          ([12], [T,T,F,F]),
          ([13], [T,T,F,T]),
          ([15], [T,T,T,T])]
 
 main = do
     -- print $ reduce table
     -- print $ primeImplicant $ reduce table
     putStr "Input: "
     putStrLn $ pretly $ map snd table
     putStr "Result: "
     putStrLn $ pretly $ minimalize $ reduce table