{-# OPTIONS -XNoMonomorphismRestriction #-}

module Main
where

import Control.Category
import Control.Arrow
import Prelude hiding (id, (.))

-- ------------------------------

newtype LA a b = LA { runLA :: a -> [b] }

instance Category LA where
 id             = LA $ (:[])
 LA g . LA f	= LA $ concatMap g . f

instance Arrow LA where
 arr f		= LA $ \ x -> [f x]

 LA f *** LA g	= LA $ \ (x1, x2) -> [ (y1, y2) | y1 <- f x1, y2 <- g x2]
 LA f &&& LA g	= LA $ \ x        -> [ (y1, y2) | y1 <- f x , y2 <- g x ]

 first  (LA f)	= LA $ \ (x1, x2) -> [ (y1, x2) | y1 <- f x1 ]
 second (LA g)	= LA $ \ (x1, x2) -> [ (x1, y2) | y2 <- g x2 ]

instance ArrowZero LA where
 zeroArrow		= LA $ const []


instance ArrowPlus LA where
 LA f <+> LA g	= LA $ \ x -> f x ++ g x


-- ------------------------------

f6	= arr (`div` 3) &&& arr (`mod` 3)
f7      = arr (* 2)     *** arr (+ 1)
f8      = f6 >>> f7
f9      = arr $ uncurry (+)
f10     = f6 >>> f7 >>> f9

f0	= LA $ \ x -> [x .. x + 10]

this    = arr id
none    = zeroArrow
db      = this <+> this

-- ------------------------------

t6  = runLA f6 $ 1
t8  = runLA (f6 >>> f7) $ 1
t10 = runLA (f6 >>> f7 >>> f9) $ 1
t11 = runLA (db >>> f6) $ 1

l6  = runLA (f0 >>> f6) $ 1
l8  = runLA (f0 >>> f6 >>> f7) $ 1
l10 = runLA (f0 >>> f6 >>> f7 >>> f9) $ 1
l11 = runLA (f0 >>> db >>> f6) $ 1
l12 = runLA (f0 >>> db >>> f6 >>> none) $ 1

-- ------------------------------