Finish 4.2

1 files changed, 90 insertions, 60 deletions

diff --git a/assignment-4/serialize4.icl b/assignment-4/serialize4.icl
index 9abccbc..41a3c02 100644
--- a/assignment-4/serialize4.icl
+++ b/assignment-4/serialize4.icl
@@ -2,6 +2,9 @@ module serialize4
 
 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
@@ -13,46 +16,70 @@ import StdEnv, StdMaybe, monad
 
 // ---
 
+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 = fail
-instance Applicative (State s) where
-	pure a = fail
-	(<*>) f x = fail
-instance fail (State s) where
-	fail = S \s.(Nothing,s)
-instance Monad (State s) where
-	bind a f = fail
-instance OrMonad (State s) where
-	(<|>) f g = fail
+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 = Serialized
+:: Serialized :== [String]
 
 ser :: Serialized
-ser = Serialized
-
-toStrings :: Serialized -> [String]
-toStrings _ = ["to be done\n"]
+ser = []
 
 :: Serialize a :== State Serialized a
 
 wrt :: a -> Serialize String | toString a
-wrt a = fail
+wrt x = S \s -> let x` = toString x in (pure x`, [x`:s])
 
 rd :: Serialize String
-rd = fail
-
-match :: a -> Serialize a | toString a
-match a = fail
+rd = S \s -> case s of
+	[]     -> (Nothing, s)
+	[s:ss] -> (Just s, ss)
 
 pred :: (String->Bool) -> Serialize String
-pred f = fail
+pred f = rd >>= \x -> if (f x) (pure x) fail
+
+match :: a -> Serialize a | toString a
+match x = pred ((==) (toString x)) >>| pure x
 
 // ---
 
@@ -64,7 +91,7 @@ pred f = fail
 :: Write a :== a -> Serialize String
 :: Read a  :== Serialize a
 
-class serialize a | isUNIT a where
+class serialize a where
 	write :: a -> Serialize String
 	read  :: Serialize a
 
@@ -80,42 +107,42 @@ class serialize2 t where
   write2 :: (Write a) (Write b) (t a b) -> Serialize String
   read2  :: (Read  a) (Read  b) -> Serialize (t a b)
 
-class isUNIT a :: a -> Bool
-instance isUNIT UNIT where isUNIT _ = True
-instance isUNIT a    where isUNIT _ = False
-
 instance serialize Bool where
-	write b = fail
-	read = fail
+	write b = wrt b
+	read = match True <|> match False
 
 instance serialize Int where
-	write i = fail
-	read = fail
+	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 = fail
+	read = rd
 
 instance serialize UNIT where
-	write _ = fail
-	read = fail
+	write _ = pure ""
+	read = pure UNIT
 
 instance serializeCONS UNIT where
-	writeCons wa (CONS name a) = fail
-	readCons name ra = fail
+	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) = fail
-	readCons name ra =fail
+	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) = fail
-	write2 wa wb (RIGHT b) = fail
-	read2 ra rb = fail
+	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) = fail
-	read2 ra rb = fail
+	write2 wa wb (PAIR a b) = wb b >>| wrt " " >>| wa a
+	read2 ra rb = ra >>= \a -> match " " >>| rb >>= pure o PAIR a
 
 // ---
 
@@ -133,12 +160,12 @@ NilString :== "Nil"
 ConsString :== "Cons"
 
 instance serialize [a] | serialize a where
- write a = write1 write a
- read    = read1  read
+	write a = write1 write a
+	read    = read1  read
 
 instance serialize1 [] where
-	write1 writea l = fail
-	read1  reada = fail
+	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)
@@ -162,12 +189,12 @@ instance == (Bin a) | == a where
   (==) _ _ = False
 
 instance serialize (Bin a) | serialize a where
-	write b = fail
-	read = fail
+	write b = write1 write b
+	read = read1 read
 
 instance serialize1 Bin where
-	write1 writea b = fail
-	read1  reada    = fail
+	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
@@ -187,14 +214,14 @@ instance == Coin where
   (==) _    _    = False
 
 instance serialize Coin where
-	write c = fail
-	read    = fail
+	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) = fail
-	read = fail
+	write (a,b) = wrt ")" >>| write b >>| wrt "," >>| write a >>| wrt "("
+	read = match "(" >>| read >>= \a -> match "," >>| read >>= \b -> match ")" >>| pure (a,b)
 
 // ---
 
@@ -204,8 +231,6 @@ Start =
 	, test 0
 	, test 123
 	, test -36
-	, test Head
-	, test Tail
 	, test [42]
 	, test [0..4]
 	, test [[True],[]]
@@ -224,8 +249,13 @@ Start =
 test :: a -> [String] | serialize, == a
 test a = toStrings (snd ((unS t) ser))
 where
-	t = write a
+	t = (write a
 		>>| read
 		>>= \b. guard (a == b)
-		>>| write "Oke "
-		<|> write "Failure "
+		>>| write a
+		>>| write "Oke; ")
+		<|> write a >>| write "Failure: "
+		<|> write "Failure (no write)"
+
+	toStrings :: Serialized -> [String]
+	toStrings xs = xs ++ ["\n"]