Exercise 2 of "Programming with arrows" by John Hughes.

SP.hs

module SP where

-- Exercise 2 of "Programming with arrows" by John Hughes.
-- http://www.cse.chalmers.se/~rjmh/afp-arrows.pdf

import Prelude hiding (id, (.))
import Control.Category
import Control.Arrow
import Data.List
import Test.QuickCheck
import Control.Monad

data SP a b = Put b (SP a b) | Get (a -> SP a b)

runSP :: SP a b -> [a] -> [b]
runSP (Put b s) as = b:runSP s as
runSP (Get k) (a:as) = runSP (k a) as
runSP (Get _) [] = []

compose :: SP b c -> SP a b -> SP a c
compose (Put a s) g = Put a (compose s g)
compose (Get k) (Put a s) = compose (k a) s
compose f (Get k) = Get (\a -> compose f (k a))

instance Category SP where
  id = arr id
  (.) = compose

instance Arrow SP where
  arr f = Get (\a -> Put (f a) (arr f))
  first = queued empty empty
    where queued :: Queue a -> Queue c -> SP a b -> SP (a, c) (b, c)
          queued qa qc (Put a s) =
            case pop qc of
              Just (c, qc') -> Put (a, c) (queued qa qc' s)
              Nothing -> Get (\(a', c) -> Put (a, c) (queued (push a' qa) qc s))
          queued qa qc (Get k) =
            case pop qa of
              Just (a, qa') -> queued qa' qc (k a)
              Nothing -> Get (\(a, c) -> queued qa (push c qc) (k a))

instance ArrowChoice SP where
  left (Put b s) = Put (Left b) (left s)
  left (Get k) = Get (\e -> case e of Right c -> Put (Right c) (left (Get k))
                                      Left a -> left (k a))

instance ArrowLoop SP where
  loop = loopQ empty
    where loopQ :: Queue c -> SP (a, c) (b, c) -> SP a b
          loopQ qc (Put (b, c) s) = Put b (loopQ (push c qc) s)
          loopQ qc (Get k) = Get (\a -> case pop qc of
                                     Just (c, qc') -> loopQ qc' (k (a, c))
                                     Nothing -> let (Put (b, c) s) = loopQ' (k (a, c)) in Put b (loopQ qc s))
          loopQ' :: SP (a, c) (b, c) -> SP (a, c) (b, c)
          loopQ' (Put (b, c) s) = Put (b, c) s
          loopQ' (Get k) = let (b, c) = undefined; s = undefined in Put (b, c) s

instance ArrowCircuit SP where
  delay a = Put a id

-- helper types
data Queue a = Queue { qOutput :: [a], qInput :: [a] }

empty :: Queue a
empty = Queue { qOutput = [], qInput = [] }

push :: a -> Queue a -> Queue a
push a q = q { qInput = i }
  where i = a:qInput q

pop :: Queue a -> Maybe (a, Queue a)
pop q = case (qOutput q, qInput q) of
          (a:o, _) -> Just (a, q { qOutput = o })
          ([], []) -> Nothing
          ([], i)  -> pop (q { qOutput = reverse i, qInput = [] })

-- tests
instance (CoArbitrary a, Arbitrary b) => Arbitrary (SP a b)  where
  arbitrary = oneof [liftM2 Put arbitrary arbitrary, liftM Get arbitrary]

instance (Show a, Show b) => Show (SP a b)  where
  show _ = error "SP a b: no show"

prop_SP_first :: SP Int Int -> [(Int,Int)] -> Bool
prop_SP_first f xs = x1 == x2
  where x1 = map snd xs
        x2 = map snd (runSP (first f) xs)

main :: IO ()
main = verboseCheck prop_SP_first


-- -- -- testing loop
-- `runSP loop_swap [1..10]` works
loop_swap :: SP a a
loop_swap = let swap (a, b) = (b, a) in loop (arr swap)

-- loop_bufid is just a "delayed id"
-- `runSP loop_bufid [1..10]` doesn't works :(
loop_bufid :: SP a a
loop_bufid = loop (Get (\a -> Get (\b -> Put a (Put b id))))


-- Appendix:
-- module Circuts where
class ArrowLoop a => ArrowCircuit a where
  delay :: b -> a b b
nor :: Arrow a => a (Bool,Bool) Bool
nor = arr (not.uncurry (||))
flipflop :: ArrowCircuit a => a (Bool,Bool) (Bool,Bool)
flipflop = loop (arr (\((a,b),~(c,d)) -> ((a,d),(b,c))) >>>
                 nor *** nor >>>
                 delay (False,True) >>>
                 arr id &&& arr id)
class Signal a where
  showSignal :: [a] -> String
instance Signal Bool where
  showSignal bs = concat top++"\n"++concat bot++"\n"
    where (top,bot) = unzip (zipWith sh (False:bs) bs)
          sh True True = ("__","  ")
          sh True False = ("  ","|_")
          sh False True = (" _","| ")
          sh False False = ("  ","__")
instance (Signal a,Signal b) => Signal (a,b) where
  showSignal xys = showSignal (map fst xys) ++
                   showSignal (map snd xys)
instance Signal a => Signal [a] where
  showSignal = concat . map showSignal . transpose
sig :: [(Int, a)] -> [a]
sig = concat . map (uncurry replicate)
flipflopInput :: [(Bool, Bool)]
flipflopInput = sig
                [(5,(False,False)),(2,(False,True)),(5,(False,False)),
                 (2,(True,False)),(5,(False,False)),(2,(True,True)),
                 (6,(False,False))]