module skeleton1
//Charlie Gerhardus (s000000)
//Mart Lubbers (s4109503)

import StdEnv

/**************** Prelude: *******************************/
//	Example types
:: Color	= Red | Yellow | Blue
:: Tree a	= Tip | Bin a (Tree a) (Tree a)         
:: Rose a	= Rose a [Rose a]

//	Binary sums and products (in generic prelude)
:: UNIT		= UNIT
:: PAIR   a b	= PAIR a b
:: EITHER a b	= LEFT a | RIGHT b

//	Generic type representations
:: RoseG a	:== PAIR a [Rose a]

// Conversions
fromRose :: (Rose a) -> RoseG a
fromRose (Rose a l)= PAIR a l

// Ordering
:: Ordering = Smaller | Equal | Bigger

class (><) infix 4 a :: !a !a -> Ordering

instance >< Int where		// Standard ordering for Int
	(><) x y
	| x < y		= Smaller
	| x > y		= Bigger
	| otherwise	= Equal

instance >< Char where		// Standard ordering for Char
	(><) x y
	| x < y		= Smaller
	| x > y		= Bigger
	| otherwise	= Equal

instance >< String where	// Standard lexicographical ordering
	(><) x y
	| x < y		= Smaller
	| x > y		= Bigger
	| otherwise	= Equal

instance >< Bool where		// False is smaller than True
	(><) False True  = Smaller
	(><) True  False = Bigger
	(><) _     _     = Equal

/**************** End Prelude *************************/
isEqual :: Ordering -> Bool
isEqual Equal = True
isEqual _ = False

// 1. Ordering by overloading
//instance >< Color where
//	(><) x y = (toInt x) >< (toInt y)
//		where
//			toInt Red = 3
//			toInt Yellow = 2
//			toInt Blue = 1

//instance >< (Tree a) | >< a where
//	(><) Tip Tip = Equal
//	(><) (Bin _ _ _) Tip = Bigger
//	(><) Tip (Bin _ _ _) = Smaller
//	(><) (Bin x ltx rtx) (Bin y lty rty)
//	| isEqual (x >< y)
//		| isEqual (ltx >< lty) = rtx >< rty
//		| otherwise = ltx >< lty
//	| otherwise = x >< y

instance >< [a] | >< a where
	(><) [] [] = Equal
	(><) [] _ = Smaller
	(><) _ [] = Bigger
	(><) [x:xs] [y:ys]
	| isEqual (x >< y) = xs >< ys
	| otherwise = x >< y

instance >< (Rose a) | >< a where
	(><) (Rose x xs) (Rose y ys)
	| isEqual (x >< y) = xs >< ys
	| otherwise = x >< y

//instance >< (a, b) | >< a & >< b where
//	(><) (xa, xb) (ya, yb)
//	| isEqual (xa >< ya) = xb >< yb
//	| otherwise = xa >< ya

//2. Generic representation
//2.1
:: ColorG	:== EITHER UNIT (EITHER UNIT UNIT)
:: ListG a	:== EITHER UNIT (PAIR a [a])
:: TupleG a b	:== PAIR a b
:: TreeG a	:== EITHER UNIT (PAIR a (PAIR (Tree a) (Tree a)))

//2.2
listToGen :: [a] -> ListG a
listToGen [] = LEFT UNIT
listToGen [x:xs] = RIGHT (PAIR x xs)

//2.3. 	EITHER (PAIR 1 (PAIR 2 3)) UNIT 
//	Nope, it will leave the xs to be so it will be: EITHER (PAIR 1 [2,3])
//2.4.	Yes, for Int and Char it works fine but for list and tuples you'll run
//	into problems.
//class toGen a :: a -> GenG a
//
//:: IntG :== EITHER UNIT (PAIR UNIT Int)
//:: CharG :== EITHER UNIT (PAIR UNIT Char)
//:: ListG a :== EITHER UNIT (PAIR a [a])
//:: GenG a :== EITHER IntG (EITHER CharG (ListG a))
//
//instance toGen Int where
//	toGen 0 = LEFT (LEFT UNIT)
//	toGen x = LEFT (RIGHT (PAIR UNIT (x-1)))
//
//instance toGen Char where
//	toGen x
//	| fromChar x == 0 = RIGHT (LEFT (LEFT UNIT))
//	| otherwise = RIGHT (LEFT (RIGHT (PAIR UNIT (x-(toChar 1)))))
//
//instance toGen [] where
//	toGen [] = RIGHT (RIGHT (LEFT UNIT))
//	toGen [x:xs] = RIGHT (RIGHT (RIGHT (PAIR (x xs))))

//3. Ordering via generic representation
//3.1
instance >< UNIT where
	(><) _ _ = Equal

instance >< (PAIR a b) | >< a & >< b where
	(><) (PAIR x1 y1) (PAIR x2 y2)
	| isEqual (x1 >< x2) = y1 >< y2
	| otherwise = x1 >< x2

instance >< (EITHER a b) | >< a & >< b where
	(><) (LEFT _) (RIGHT _) = Smaller
	(><) (RIGHT _) (LEFT _) = Bigger
	(><) (RIGHT x) (RIGHT y) = x >< y
	(><) (LEFT x) (LEFT y) = x >< y

instance >< Color where
	(><) a b = colorToGen a >< colorToGen b

instance >< (a, b) | >< a & >< b where
	(><) a b = tupleToGen a >< tupleToGen b

instance >< (Tree a) | >< a where
	(><) a b = treeToGen a >< treeToGen b

colorToGen :: Color -> ColorG
colorToGen Blue = LEFT UNIT
colorToGen Yellow = RIGHT (LEFT UNIT)
colorToGen Red = RIGHT (RIGHT UNIT)

tupleToGen :: (a, b) -> TupleG a b
tupleToGen (x, y) = PAIR x y

treeToGen :: (Tree a) -> TreeG a
treeToGen Tip = LEFT UNIT
treeToGen (Bin x xr xl) = RIGHT (PAIR x (PAIR xr xl))

//3.2.	Yes
//3.3.	Less defining and easier overloading
//3.4.	Overhead, the compiler has to translate on and on