module Problem1 where
import qualified Prelude as P
import Prelude(Functor, (.), id, (++), Eq, (==), Bool(..), 
               Show, showsPrec, shows)
import Data.Monoid(Monoid, mempty, mappend)
import Test.QuickCheck

-- Problem 1a)
newtype DList a = DL { unDL :: [a] -> [a] }

append :: DList a -> DList a -> DList a
append (DL xs) (DL ys) = DL (xs . ys)

cons :: a -> DList a -> DList a
cons x (DL xs) = DL ((x:) . xs)

empty :: DList a
empty = DL id

foldr :: (a -> b -> b) -> b -> DList a -> b
foldr f z xs = P.foldr f z (toList xs)

fromList :: [a] -> DList a
fromList xs = DL (xs ++)

map :: (a -> b) -> DList a -> DList b
map f = foldr (cons . f) empty

toList :: DList a -> [a]
toList (DL xs) = xs []
-- Alternatively: toList xs = unDL xs []

instance Functor DList where
  fmap = map

instance Monoid (DList a) where
  mempty = empty
  mappend = append

instance Eq a => Eq (DList a) where
  xs == ys   =   toList xs == toList ys

----------------
-- Problem 1b)

{-
Functor laws:
       fmap id == id
  fmap (f . g) == fmap f . fmap g

Monoid laws:  
  mappend mempty m == m
  mappend m mempty == m
  mappend (mappend m_1 m_2) m_3 == mappend m_1 (mappend m_2 m_3)

-}

-- Polymorphic properties:
prop_fmap_id :: P.Eq a => DList a -> Bool
prop_fmap_id xs  =  map id xs == id xs

prop_fmap_comp :: Eq c => (b->c) -> (a->b) -> DList a -> Bool
prop_fmap_comp f g =  map (f . g) === map f . map g

infix 4 ===
(===) :: (Eq a) => (t -> a) -> (t -> a) -> t -> Bool
f === g = \x -> f x == g x

prop_monoid_1 :: (Monoid a, Eq a) => a -> Bool
prop_monoid_1 m =  mappend mempty m == m

prop_monoid_2 :: (Monoid a, Eq a) => a -> Bool
prop_monoid_2 m =  mappend m mempty == m

prop_monoid_3 :: (Monoid a, Eq a) => a -> a -> a -> Bool
prop_monoid_3 m1 m2 m3 =  mappend (mappend m1 m2) m3 == mappend m1 (mappend m2 m3)

-- Monomorphic versions for quickCheck
type B = Bool -- could be some other non-trivial type (not ())

test_id   = quickCheck (prop_fmap_id   :: DList Bool -> Bool)
test_comp = quickCheck (prop_fmap_comp :: (B->B)->(B->B) -> DList B -> Bool)
test_mon1 = quickCheck (prop_monoid_1  :: DList B -> Bool)
test_mon2 = quickCheck (prop_monoid_2  :: DList B -> Bool)
test_mon3 = quickCheck (prop_monoid_3  :: DList B -> DList B -> DList B -> Bool)


instance Show a => Show (DList a) where -- not required on the exam
  showsPrec p xs = showsPrec p (toList xs)
    
instance (P.Bounded a, P.Enum a, Show a, Show b) => Show (a->b) where
  showsPrec p f = showsPrec p (P.map (\x-> (x,f x)) [P.minBound .. P.maxBound])

instance Arbitrary a => Arbitrary (DList a) where
  arbitrary = P.fmap fromList arbitrary

main = do 
  test_id   
  test_comp 
  test_mon1 
  test_mon2
  test_mon3 

----------------------------------------------------------------
-- Problem 1 extras: attempting to "prove" some properties by equality
-- reasoning. Not part of the exam question and unfinished.

functor_law_1 =        
  [ map id
  , foldr (cons . id) empty
  , foldr cons empty
  , -- foldr_cons_empty_lemma
    id
  ]

-- foldr cons empty xs == xs
foldr_cons_empty_lemma_e =
  [ foldr cons empty empty
  , P.foldr cons empty (toList empty)
  , P.foldr cons empty (toList (DL id))
  , P.foldr cons empty (id [])
  , P.foldr cons empty []
  , empty
  ]
foldr_cons_empty_lemma_c x xs =
  [ foldr cons empty (cons x xs)
  , foldr cons empty (DL ((x:) . unDL xs))
  , P.foldr cons empty (toList (DL ((x:) . unDL xs)))
  , P.foldr cons empty (((x:) . unDL xs) [])
  , P.foldr cons empty (x : unDL xs [])
  , cons x (P.foldr cons empty (unDL xs []))
  , cons x (P.foldr cons empty (toList xs))
  -- lemma P.foldr cons empty (toList xs)
  ]

-- P.foldr cons empty (toList xs) == xs
lemma2 xs = 
  [ P.foldr cons empty (toList xs)
  , xs
  ]