flowsim-0.3.3: src/FilterSFF.hs

{-# Language DeriveDataTypeable #-}
module FilterSFF (main) where

-- import Debug.Trace
import System.IO

import System.Console.CmdArgs as C
import Version

import Generations.GenBase
import Generations.GS20
import Generations.Titanium
import Generations.Empirical

generations :: [(String,Generation)]
generations = [("GS20", gs20), ("Titanium",titanium),("EmpTitanium",tiEmp)]

data Opts = Opts { generation :: String
                 , output, inputs :: FilePath
                 , count :: Bool
                 }
          deriving (Data,Typeable,Show)

defopt :: Opts
defopt = Opts 
  { generation = "Titanium" &= help "454 generation" &= typ "GEN" &= C.name "G"
  , output = "filtered.sff" &= typFile
  , inputs = "" &= args &= typFile
  , count  = False &= help "count matches instead of filtering"
  } &= program "filtersff"
    &= summary ("filtersff "++version)
  
main :: IO ()
main = do
     opts <- cmdArgs defopt
     SFF h rs <- readSFF (inputs opts) 
     case lookup (generation opts) generations of 
             Just g -> if count opts 
                         then apply_count (disc_filters g) rs
                         else do
                           let f = apply_filter (disc_filters g)
                           n <- writeSFF' (output opts) (SFF h $ f rs)
                           putStrLn ("Wrote "++show n++" records to "++output opts)
             Nothing -> error ("Unknown generation: '"++generation opts++"'")

apply_filter :: [DiscardFilter] -> [ReadBlock] -> [ReadBlock]
apply_filter filters = filter (\r -> (and (apply1 filters r)))

apply_count ::  [DiscardFilter] -> [ReadBlock] -> IO ()
apply_count filters rbs = go (replicate (length filters) 0) rbs
  where go :: [Int] -> [ReadBlock] -> IO ()
        go counts (r:rs) = do
          let fs = apply1 filters r
          if and fs 
            then go counts rs
            else do
                 let c = add counts fs 
                 trace (show c)
                 go c rs
        go counts [] = trace (show counts++"\n")

{-
-- This leaks (well, retains) memory.  Laziness be damned.

apply_trace :: [DiscardFilter] -> [ReadBlock] -> [ReadBlock]
apply_trace filters = go (replicate (length filters) 0)
   where go counts (r:rs) = 
            let fs = apply1 filters r
            in if and fs then r : go counts rs
               else let c = add counts fs in trace ("Filtered: "++show c) $ go counts rs
         go _ [] = trace "\n" []
-}

trace :: String -> IO ()
trace msg = hPutStr stderr ("\r"++msg)

-- apply fs = filter (\r -> not (and $ apply1 fs r))

add :: [Int] -> [Bool] -> [Int]
add cs = zipWith (+) cs . map (fromEnum . not)

apply1 :: [DiscardFilter] -> ReadBlock -> [Bool]
apply1 filters r = map ($r) filters