module DNAEncoder where
  import qualified Data.Algorithms.KMP as KMP
  import qualified Data.List as  DL
  import qualified Control.Monad as CM

  data PLoc a = PLoc  {
    pattern :: [a],
    start :: Int
  } deriving (Show)

  data Valuable a = Valuable {
    value :: Int,
    item :: PLoc a
  } deriving (Show)

  findAll :: Eq a => [a] -> [a] -> [Int]
  findAll haystack needle =
    kmpTable `KMP.match` haystack
    where kmpTable = KMP.build needle

  find :: Eq a => [a] -> [a] -> Int
  find haystack needle = head result
    where result = findAll haystack needle

  pStop :: PLoc a -> Int
  pStop (PLoc p s) = s + length p

  pStart :: PLoc a -> Int
  pStart (PLoc _ s) = s

  vSorter :: Valuable a -> Valuable a -> Ordering
  vSorter (Valuable _ (PLoc _ s1)) (Valuable _ (PLoc _ s2)) = compare s1 s2

  expand2nd :: (a, [b]) -> [(a, b)]
  expand2nd (_, []) = []
  expand2nd (a, b:bs) = (a, b) : expand2nd (a, bs)

  unpack2 :: (a -> b -> c) -> (a, b) -> c
  unpack2 f (a, b) = f a b

  getFirstSatisfy :: (a -> Bool) -> [a] -> Maybe a
  getFirstSatisfy _ [] = Nothing
  getFirstSatisfy f (x:xs)
    | f x = Just x
    | otherwise = getFirstSatisfy f xs

  toDefault :: a -> Maybe a -> a
  toDefault defaultValue Nothing = defaultValue
  toDefault _ (Just x) = x

  vIs0 :: Eq a => Valuable a -> Bool
  vIs0 (Valuable v _) = v == 0

  svEnumerate :: Eq a => [Valuable a] -> (Maybe (Valuable a), Maybe (Valuable a))
  svEnumerate xs =
    let lefts = reverse $ takeWhile vIs0 xs
        rights = tail $ dropWhile vIs0 xs
        firstLeft = getFirstSatisfy vIs0 lefts
        firstRight = getFirstSatisfy vIs0 rights
    in (firstLeft, firstRight)

  main :: IO()
  main = do
    let
      dna = "TCTAACTTGCATCAGATCTGCTCGATCAGATCAA"
      includes = ["CTGC"]
      excludes = ["TGCAT", "TCAG"]
      iLocs = findAll dna `map` includes
      eLocs = findAll dna `map` excludes
      piLocs = includes `zip` iLocs
      peLocs = excludes `zip` eLocs
      epiLocs = CM.join $ map expand2nd piLocs
      epeLocs = CM.join $ map expand2nd peLocs
      pepiLocs = unpack2 PLoc `map` epiLocs
      pepeLocs = unpack2 PLoc `map` epeLocs
      vpepiLocs = Valuable 1 `map` pepiLocs
      vpepeLocs = Valuable 0 `map` pepeLocs
      vpepLocs = vpepiLocs ++ vpepeLocs
      svpepLocs = DL.sortBy vSorter vpepLocs
      (mleft, mright) = svEnumerate svpepLocs
      lDefault = toDefault $ Valuable 0 $ PLoc "" (-1)
      rDefault = toDefault $ Valuable 0 $ PLoc "" (length dna)
      left = lDefault mleft
      right = rDefault mright
      ldrop = start (item left) + 1
      rtake = pStop (item right) - (ldrop + 1)
      finalResult = take rtake $ drop ldrop dna
    print finalResult