SeqCP.hs

{-# LANGUAGE TupleSections #-}
module SeqCP where

import Data.Sequence
import Prelude hiding (drop, take, length, splitAt)
import Test.QuickCheck ((===), (==>), Property, Positive(..))

data CPs x y =
    Empty |
    SingleCP x (Seq y) |
    CPs (Seq x) (Seq y) !Int {- beginning column -} !Int {- last column -}
    deriving Show

createCPs :: Seq x -> Seq y -> CPs x y
createCPs xs ys = CPs xs ys 0 (length ys - 1)

lengthCPs :: CPs x y -> Int
lengthCPs Empty = 0
lengthCPs (SingleCP x ys) = length ys
lengthCPs (CPs xs ys fc lc) = (length xs - 1) * length ys - fc + lc + 1

-- Smart constructor
mkCPs :: Seq x -> Seq y -> Int -> Int -> CPs x y
mkCPs xs ys fc lc 
    | length xs == 0 || length ys == 0
    = Empty
    | length xs == 1 
    = SingleCP (xs `index` 0) (drop fc $ take (lc+1) $ ys)
    | otherwise
    = CPs xs ys fc lc

splitCPs:: Int -> CPs x y -> (CPs x y, CPs x y)
splitCPs n cps | n <= 0
    = ( Empty, cps )
splitCPs n (CPs xs ys fc lc) | length xs == 0 || length ys == 0
    = ( Empty, Empty )
splitCPs n cp | n >= lengthCPs cp
    = ( cp, Empty )
splitCPs n (SingleCP x ys)
    = ( SingleCP x ys1, SingleCP x ys2 )
  where (ys1, ys2) = splitAt n ys
splitCPs n (CPs xs ys fc lc)
    = ( mkCPs (take r_end xs)   ys fc      c_end
      , mkCPs (drop r_begin xs) ys c_begin lc
      )
  where
    -- Coordinates of the beginning of the second chunk
    r_begin = (n + fc) `div` length ys -- number of rows that do not go into the second chunk
    c_begin = (n + fc) `mod` length ys       

    -- Coordinates of the end of the first chunk
    r_end | c_begin == 0 = r_begin     -- cut nicely along rows, keep the other rows
          | otherwise    = r_begin + 1 -- we need to keep one row in both chunks
    c_end = (c_begin - 1) `mod` length ys

getSingletonCPs :: CPs x y -> (x, Seq y)
getSingletonCPs (SingleCP x ys) = (x, ys)

pairsCP :: CPs x y -> Seq (x,y)
pairsCP Empty
    = empty
pairsCP (SingleCP x ys)
    = fmap (x,) ys
pairsCP (CPs xs ys fc lc)
    = (fmap (xs `index` 0,) $ drop fc $ ys) >< pairsCP (mkCPs (drop 1 xs) ys 0 lc)


test_splitCPs :: [Int] -> [Char] -> Positive Int -> Positive Int -> Positive Int -> Property
test_splitCPs xs ys (Positive n) (Positive m) (Positive k)
    = n < length ys' ==>
      m < length ys' ==>
      (if length xs' == 1 then n < m else True) ==>
      pairsCP cp === (pairsCP cp1 >< pairsCP cp2)
  where
    xs' = fromList xs
    ys' = fromList ys
    cp = mkCPs xs' ys' n m
    (cp1, cp2) = splitCPs k cp