{-# OPTIONS_GHC -farrows #-}

{---

   Some code from 1st half of Programming with Arrows by John Hughes.

---}

module ProgArrows where

import Control.Arrow
import ArrowComp
import Signal

newtype SF a b = SF {runSF:: [a] -> [b]}
instance Arrow SF where
    pure f = SF $ map f
    SF f >>> SF g = SF $ f >>> g
    first (SF f) = SF $ unzip >>> first f >>> uncurry zip
instance ArrowChoice SF where
    left (SF f) = SF $ \xs -> combine xs (f [y | Left y <- xs]) where
        combine (Left _ : xs) (z:zs) = Left z : combine xs zs
        combine (Right x : xs) zs = Right x : combine xs zs
        combine [] _ = []

listcase [] = Left ()
listcase (x:xs) = Right (x,xs)

mapA f = pure listcase >>> pure (const []) ||| (f *** mapA f >>> pure (uncurry (:)))

{-
untag x = case x of Left v -> v; Right v -> v
mirror v = case v of Left v -> Right v; Right v -> Left v
mapA' f = pure listcase >>> 
          left (pure (const [])) >>> 
          pure mirror >>> 
          left (first f >>> second (mapA' f) >>> pure (uncurry (:))) >>> 
          pure mirror >>> 
          pure untag
-}

delaysA :: (ArrowChoice a, ArrowCircuit a) => a [b] [b]
delaysA = pure listcase >>> pure (const []) ||| (pure id *** (delaysA >>> delay []) >>> pure (uncurry (:)))


edge :: SF Bool Bool
edge = pure id &&& delay False >>> pure detect where
    detect (a,b) = a && not b


instance ArrowLoop SF where
    loop (SF f) = SF $ \as -> 
        let (bs, cs) = unzip (f $ zip as $ stream cs) 
        in bs
      where stream ~(x:xs) = x:stream xs

{-
runSF (loop $ pure swap) [1,2,3]
let (_|_, (_|_ : cs)) = unzip (swap' (zip [1,2,3] (_|_ : cs))) 
let (_|_, (_|_ : cs)) = unzip ((_|_, 1) : swap' (zip [2,3] cs)) 
let (_|_, [_|_,_|_,_|_]) = unzip ((_|_, 1) : (_|_, 2) : (_|_, 3) : []) 
let (_|_, [_|_,_|_,_|_]) = ([_|_,_|_,_|_], [1,2,3])

let ([_|_,_|_,_|_], [1,2,3]) = unzip (swap' (zip [_|_,_|_,_|_] [1,2,3]))
let ([_|_,_|_,_|_], [1,2,3]) = ([1,2,3], [1,2,3])
let ([1,2,3], [1,2,3]) = ([1,2,3], [1,2,3])

let ([1,2,3], [1,2,3]) = unzip (swap' (zip [1,2,3] [1,2,3]))
-}


instance ArrowCircuit SF where
    delay x = SF $ init . (x :)

flipflop :: ArrowCircuit a => a (Bool, Bool) (Bool, Bool)
flipflop = loop $
    pure (\((reset, set), ~(c, d)) -> ((reset, d), (set, c))) >>>
    nor *** nor >>>
    delay (False, True) >>>
    pure id &&& pure id
  where
    nor = pure $ not . (uncurry (||))


testFF = do
    let (reset, set) = unzip testSig
    putStrLn "Input lines:"
    putStrLn $ showSig reset
    putStrLn $ showSig set
    let (q,q') = unzip $ runSF flipflop testSig
    putStrLn "\nOutput lines:"
    putStrLn $ showSig q
    putStrLn $ showSig q'


--
-- Examples using arrow syntax
--
filterA :: ArrowChoice a => a b Bool -> a [b] [b]
filterA p = proc xs -> case xs of
    [] -> returnA -< []
    x:xs -> do v <- p -< x
               xs' <- filterA p -< xs
               returnA -< if v then x:xs' else xs'

flipflop' :: ArrowCircuit a => a (Bool, Bool) (Bool, Bool)
flipflop' = proc (reset, set) -> do
    rec c <- delay False -< nor reset d
        d <- delay True -< nor set c
    returnA -< (c, d)
  where nor a b = not $ a || b