recombinr.hs

-- The Problem:
-- I have four functions A, B, C, D of type Int -> [Int] which form a pipeline.  
-- I have a list of Int, and I want to pass each element of that list through the pipeline 
-- one at a time, and with each step collecting the results of the state of the pipeline
--
-- Example:
-- ---LIST-->--|-->-->--PIPELINE-->-->-->-->--|-->-->-->--RESULTS
-- [5,4,3,2,1], A[x] -> B[x] -> C[x] -> D[x]
--   [5,4,3,2], A[1] -> B[x] -> C[x] -> D[x] => let result1 = [A(1)] : []
--     [5,4,3], A[2] -> B[1] -> C[x] -> D[x] => let result2 = [A(2), B(1)] : result1
--       [5,4], A[3] -> B[2] -> C[1] -> D[x] => let result3 = [A(3), B(2), C(1)] : result2
--         [5], A[4] -> B[3] -> C[2] -> D[1] => let result4 = [A(4), B(3), C(2), D(1)] : result3
--          [], A[5] -> B[4] -> C[3] -> D[2] => let result5 = [A(5), B(4), C(3), D(2)] : result4
--          [], A[x] -> B[5] -> C[4] -> D[3] => let result6 = [B(5), C(4), D(3)] : result5
--          [], A[x] -> B[x] -> C[5] -> D[4] => let result7 = [C(5), D(4)] : result6
--          [], A[x] -> B[x] -> C[x] -> D[5] => let result8 = [D(5)] : result7
--          [], A[x] -> B[x] -> C[x] -> D[x] => let final = reverse(result8)
-- DONE, return final

module Main where

import Pipes ((>->), Pipe, Producer, Effect, runEffect, for, each, yield, await, discard)
import Pipes.Prelude (drain)
import Control.Monad ((>=>))
import Control.Monad.Writer (Writer, tell, execWriter)
import Control.Monad.Trans.Class (lift)
import Data.Monoid (Monoid, mappend, mempty)
import Data.Maybe (isJust)

chunkLength :: Int
chunkLength = 10

newtype BasePattern = BasePattern [Int] deriving (Show)
newtype Transformation = Transformation [Int] deriving (Show)

instance Monoid Transformation where
    mempty = Transformation []
    mappend (Transformation a) (Transformation b) = Transformation $ a ++ b

patternA = BasePattern [0,1,2,3,4]
patternB = BasePattern [0,2,4,6]
patternC = BasePattern [0,3,6]
patternD = BasePattern [0,4]

toTransformation :: BasePattern -> Transformation
toTransformation (BasePattern p) = Transformation $ do
    n <- [0..(chunkLength - 1)]
    x <- take (length p * chunkLength) p
    return $ (x + n) `mod` chunkLength

offsetTransformation :: Transformation -> Int -> Transformation
offsetTransformation (Transformation t) n = Transformation $ fmap (+ offset) t
    where offset = n * chunkLength

pipeWith :: (Int -> Transformation) -> Maybe Int -> Pipe (Maybe Int) (Maybe Int) (Writer [Transformation]) (Maybe Int)
pipeWith _ Nothing = yield Nothing >> return Nothing >> await
pipeWith f (Just a) = do
    mb <- await
    yield (Just a)
    if isJust mb then
        (lift . tell . return $ f a) >> return mb
    else
        return Nothing

toPipeSequence :: Transformation -> Pipe (Maybe Int) (Maybe Int) (Writer [Transformation]) (Maybe Int)
toPipeSequence transformation = do
    let applyOffset  = offsetTransformation transformation
        pipeSequence = foldr1 (>=>) (repeat $ pipeWith applyOffset)

    -- get the first number, and then hand it off to the pipe sequence
    await >>= pipeSequence

transformPipeline :: Pipe (Maybe Int) (Maybe Int) (Writer [Transformation]) ()
transformPipeline = foldr1 (>->) (fmap (toPipeSequence.toTransformation) [patternA, patternB, patternC, patternD]) >>= discard

pipeline :: Effect (Writer [Transformation]) ()
pipeline = spout >-> transformPipeline >-> drain

spout :: Monad m => Producer (Maybe Int) m ()
spout = for (each ns) yield
    where ns = [(Just x) | x <- [0..10]] ++ [Nothing]

main = let transformations = execWriter . runEffect $ pipeline in
       mapM_ (putStrLn . show) transformations