path: root/assignment-4/serialize4.icl

module serialize4

// Laurens Kuiper (s4467299)
// Camil Staps (s4498062)

// Output:
// Oke; True
// Oke; False
// Oke; 0
// Oke; 123
// Oke; -36
// Oke; (Cons 42 Nil)
// Oke; (Cons 0 (Cons 1 (Cons 2 (Cons 3 (Cons 4 Nil)))))
// Oke; (Cons (Cons True Nil) (Cons Nil Nil))
// Oke; (Cons (Cons (Cons 1 Nil) Nil) (Cons (Cons (Cons 2 Nil) (Cons (Cons 3 (Cons 4 Nil)) Nil)) (Cons (Cons Nil Nil) Nil)))
// Oke; (Cons (Cons True Nil) (Cons Nil Nil))
// Oke; (Bin Leaf True Leaf)
// Oke; (Cons (Bin (Bin Leaf (Cons 1 Nil) Leaf) (Cons 2 Nil) (Bin Leaf (Cons 3 Nil) (Bin Leaf (Cons 4 (Cons 5 Nil)) Leaf))) Nil)
// Oke; (Cons (Bin (Bin Leaf (Cons 1 Nil) Leaf) (Cons 2 Nil) (Bin Leaf (Cons 3 Nil) (Bin (Bin Leaf (Cons 4 (Cons 5 Nil)) Leaf) (Cons 6 (Cons 7 Nil)) (Bin Leaf (Cons 8 (Cons 9 Nil)) Leaf)))) Nil)
// Oke; Head
// Oke; Tail
// Oke; (7,True)
// Oke; (Head,(7,(Cons Tail Nil)))
// End of the tests.

import StdEnv, StdMaybe, monad

appFst :: (a -> c) (a, b) -> (c, b)
appFst f (x,y) = (f x, y)

/*
 * Pieter Koopman, pieter@cs.ru.nl
 * Advanced Programming, week 4, 2017
 *
 * import StdMaybe from Libraries/StdLib
 * use StdEnv or StdEnv 64
 * use Basic Values Only as conclose option for a nicer output.
 */

// ---

instance Functor Maybe
where
	fmap f (Just x) = Just (f x)
	fmap _ Nothing  = Nothing

instance Applicative Maybe
where
	pure x = Just x
	(<*>) (Just f) (Just x) = Just (f x)
	(<*>) _        _        = Nothing

:: State s a = S (s -> (Maybe a,s))

unS :: (State s a) -> s -> (Maybe a,s)
unS (S f) = f

instance Functor (State s)
where
	fmap f (S s) = S \st -> appFst (fmap f) (s st)

instance Applicative (State s)
where
	pure x = S \s -> (pure x,s)
	(<*>) (S f) (S x) = S \st ->
		let (f`,st`) = f st; (x`,st``) = x st` in (f` <*> x`, st``)

instance fail (State s)
where
	fail = S \s -> (Nothing,s)

instance Monad (State s)
where
	bind (S x) f = S \st -> case x st of
		(Just x, st) -> unS (f x) st
		(Nothing,st) -> (Nothing,st)

instance OrMonad (State s)
where
	(<|>) (S f) (S g) = S \s -> case f s of
		r=:(Just _,_) -> r
		_             -> g s

// ---

:: Serialized :== [String]

ser :: Serialized
ser = []

:: Serialize a :== State Serialized a

wrt :: a -> Serialize String | toString a
wrt x = S \s -> let x` = toString x in (pure x`, [x`:s])

rd :: Serialize String
rd = S \s -> case s of
	[]     -> (Nothing, s)
	[s:ss] -> (Just s, ss)

pred :: (String->Bool) -> Serialize String
pred f = rd >>= \x -> if (f x) (pure x) fail

match :: a -> Serialize a | toString a
match x = pred ((==) (toString x)) >>| pure x

// ---

:: UNIT     = UNIT
:: EITHER a b = LEFT a | RIGHT b
:: PAIR   a b = PAIR a b
:: CONS   a   = CONS String a

:: Write a :== a -> Serialize String
:: Read a  :== Serialize a

class serialize a where
	write :: a -> Serialize String
	read  :: Serialize a

class serialize1 t where
	write1 :: (Write a) (t a) -> Serialize String
	read1  :: (Read  a) -> Serialize (t a)

class serializeCONS a where
	writeCons :: (Write a) (CONS a) -> Serialize String
	readCons  :: String (Read a) -> Serialize (CONS a)

class serialize2 t where
  write2 :: (Write a) (Write b) (t a b) -> Serialize String
  read2  :: (Read  a) (Read  b) -> Serialize (t a b)

instance serialize Bool where
	write b = wrt b
	read = match True <|> match False

instance serialize Int where
	write i = wrt i
	read = rd >>= safeToInt
	where
		safeToInt :: String -> m Int | fail, Applicative m
		safeToInt "0" = pure 0
		safeToInt s   = case toInt s of 0 -> fail; n -> pure n

instance serialize String where
	write s = wrt s
	read = rd

instance serialize UNIT where
	write _ = pure ""
	read = pure UNIT

instance serializeCONS UNIT where
	writeCons wa (CONS name a) = wrt name
	readCons name ra = match name >>| pure (CONS name UNIT)

instance serializeCONS a where
	writeCons wa (CONS name a) = wrt ")" >>| wa a >>| write " " >>| wrt name >>| wrt "("
	readCons name ra = match "(" >>| match name >>| match " " >>| ra >>= \a -> match ")" >>| pure (CONS name a)

instance serialize2 EITHER where
	write2 wa wb (LEFT  a) = wa a
	write2 wa wb (RIGHT b) = wb b
	read2 ra rb = LEFT <$> ra <|> RIGHT <$> rb

instance serialize2 PAIR where
	write2 wa wb (PAIR a b) = wb b >>| wrt " " >>| wa a
	read2 ra rb = ra >>= \a -> match " " >>| rb >>= pure o PAIR a

// ---

:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a]))

fromList :: [a] -> ListG a
fromList []  = LEFT  (CONS NilString  UNIT)
fromList [a:x] = RIGHT (CONS ConsString (PAIR a x))

toList :: (ListG a) -> [a]
toList (LEFT  (CONS NilString  UNIT)) = []
toList (RIGHT (CONS ConsString (PAIR a x))) = [a:x]

NilString :== "Nil"
ConsString :== "Cons"

instance serialize [a] | serialize a where
	write a = write1 write a
	read    = read1  read

instance serialize1 [] where
	write1 writea l = write2 (writeCons write) (writeCons (write2 writea (write1 writea))) (fromList l)
	read1  reada = toList <$> read2 (readCons NilString read) (readCons ConsString (read2 reada (read1 reada)))
// ---

:: Bin a = Leaf | Bin (Bin a) a (Bin a)

:: BinG a :== EITHER (CONS UNIT) (CONS (PAIR (Bin a) (PAIR a (Bin a))))

fromBin :: (Bin a) -> BinG a
fromBin Leaf = LEFT (CONS LeafString UNIT)
fromBin (Bin l a r) = RIGHT (CONS BinString (PAIR l (PAIR a r)))

toBin :: (BinG a) -> Bin a
toBin (LEFT (CONS _ UNIT)) = Leaf
toBin (RIGHT (CONS _ (PAIR l (PAIR a r)))) = Bin l a r

LeafString :== "Leaf"
BinString :== "Bin"

instance == (Bin a) | == a where
  (==) Leaf Leaf = True
  (==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s
  (==) _ _ = False

instance serialize (Bin a) | serialize a where
	write b = write1 write b
	read = read1 read

instance serialize1 Bin where
	write1 writea b = write2 (writeCons write) (writeCons (write2 (write1 writea) (write2 writea (write1 writea)))) (fromBin b)
	read1  reada    = toBin <$> read2 (readCons LeafString read) (readCons BinString (read2 (read1 reada) (read2 reada (read1 reada))))
// ---

:: Coin = Head | Tail
:: CoinG :== EITHER (CONS UNIT) (CONS UNIT)

fromCoin :: Coin -> CoinG
fromCoin Head = LEFT (CONS "Head" UNIT)
fromCoin Tail = RIGHT (CONS "Tail" UNIT)

toCoin :: CoinG -> Coin
toCoin (LEFT (CONS _ UNIT)) = Head
toCoin (RIGHT (CONS _ UNIT)) = Tail

instance == Coin where
  (==) Head Head = True
  (==) Tail Tail = True
  (==) _    _    = False

instance serialize Coin where
	write c = write2 (writeCons write) (writeCons write) (fromCoin c)
	read    = toCoin <$> read2 (readCons "Head" read) (readCons "Tail" read)

// ---

instance serialize (a,b) | serialize a & serialize b where
	write (a,b) = wrt ")" >>| write b >>| wrt "," >>| write a >>| wrt "("
	read = match "(" >>| read >>= \a -> match "," >>| read >>= \b -> match ")" >>| pure (a,b)

// ---

Start =
	[ test True
	, test False
	, test 0
	, test 123
	, test -36
	, test [42]
	, test [0..4]
	, test [[True],[]]
	, test [[[1]],[[2],[3,4]],[[]]]
	, test [[True],[]]
	, test (Bin Leaf True Leaf)
	, test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin Leaf [4,5] Leaf))]
	, test [Bin (Bin Leaf [1] Leaf) [2] (Bin Leaf [3] (Bin (Bin Leaf [4,5] Leaf) [6,7] (Bin Leaf [8,9] Leaf)))]
	, test Head
	, test Tail
	, test (7,True)
	, test (Head,(7,[Tail]))
	, ["End of the tests.\n"]
	]

test :: a -> [String] | serialize, == a
test a = toStrings (snd ((unS t) ser))
where
	t = (write a
		>>| read
		>>= \b. guard (a == b)
		>>| write a
		>>| write "Oke; ")
		<|> write a >>| write "Failure: "
		<|> write "Failure (no write)"

	toStrings :: Serialized -> [String]
	toStrings xs = xs ++ ["\n"]