Commit 8ec770c0 authored by Job Cuppen's avatar Job Cuppen

ex 8.1.1

parent 03bb02c3
module ex1
/*
Definitions for assignment 8 in AFP 2019
Kind indexed gennerics
Pieter Koopman, pieter@cs.ru.nl
September 2019
Use StdEnv or iTask environment.
Use Basic Values Only as conclose option for a nicer output.
*/
import StdEnv, StdMaybe
class unitDecidable a where
isUnit :: a -> Bool
instance unitDecidable UNIT where
isUnit _ = True
instance unitDecidable a where
isUnit _ = False
// use this as serialize0 for kind *
class serialize0 a | unitDecidable a where
write0 :: a [String] -> [String]
read0 :: [String] -> Maybe (a,[String])
class serialize1 a where
write1 :: (x [String] -> [String]) (a x) [String] -> [String] | unitDecidable x
read1 :: ([String] -> Maybe (x, [String])) [String] -> Maybe ((a x),[String])
class serialize2 a where
write2 :: (x [String] -> [String]) (y [String] -> [String]) (a x y) [String] -> [String]
read2 :: ([String] -> Maybe (x, [String])) ([String] -> Maybe (y, [String])) [String] -> Maybe ((a x y),[String])
// ---
instance serialize0 Bool where
write0 b c = [toString b:c]
read0 list = foldl (match list) Nothing [True, False]
where
match [string: rest] r bool | toString bool == string
= Just (bool, rest)
= r
match _ r bool = r
instance serialize0 Int where
write0 i c = [toString i:c]
read0 list = foldl (match list) Nothing [True, False]
where
match [string: rest] r bool
# int = toInt string
| string == toString int
= Just (int, rest)
= r
match _ r bool = r
:: UNIT = UNIT
:: EITHER a b = LEFT a | RIGHT b
:: PAIR a b = PAIR a b
:: CONS a = CONS String a
instance serialize0 UNIT where
write0 _ c = c
read0 l = Just (UNIT, l)
instance serialize0 (EITHER a b) | serialize0 a & serialize0 b where
write0 (LEFT a) c = write0 a c
write0 (RIGHT b) c = write0 b c
read0 r = case read0 r of
Just (a, restA) -> Just (LEFT a, restA)
_ -> case read0 r of
Just (b, restB) -> Just (RIGHT b, restB)
_ -> Nothing
instance serialize2 EITHER where
write2 f g (LEFT a) c = f a c
write2 f g (RIGHT b) c = g b c
read2 f g r = case f r of
Just (a, restA) -> Just (LEFT a, restA)
_ -> case g r of
Just (b, restB) -> Just (RIGHT b, restB)
_ -> Nothing
instance serialize0 (PAIR a b) | serialize0 a & serialize0 b where
write0 (PAIR a b) c = write0 a (write0 b c)
read0 xs = case read0 xs of
Just (a, restA) -> case read0 restA of
Just(b, restB) -> Just (PAIR a b, restB)
_ -> Nothing
_ -> Nothing
instance serialize2 PAIR where
write2 f g (PAIR a b) c = f a (g b c)
read2 f g xs = case f xs of
Just (a, restA) -> case g restA of
Just(b, restB) -> Just (PAIR a b, restB)
_ -> Nothing
_ -> Nothing
instance serialize0 (CONS a) | serialize0 a where
write0 (CONS str a) c
| (isUnit a) = [str : write0 a c]
| otherwise = ["[":str:(write0 a ["]":c])]
read0 ["[":str:r] = case read0 r of
Just (a, ["]":r]) -> Just(CONS str a, r)
Just (a, r) -> Nothing
Nothing -> Nothing
read0 [str:r] = case read0 r of
Just (a, r) -> Just(CONS str a, r)
Nothing -> Nothing
read0 _ = Nothing
instance serialize1 CONS where
write1 f (CONS str a) c
| (isUnit a) = [str : f a c]
| otherwise = ["[":str:(f a ["]":c])]
read1 f ["[":str:r] = case f r of
Just (a, ["]":r]) -> Just(CONS str a, r)
Just (a, r) -> Nothing
Nothing -> Nothing
read1 f [str:r] = case f r of
Just (a, r) -> Just(CONS str a, r)
Nothing -> Nothing
read1 _ _ = Nothing
:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a]))
fromList :: [a] -> ListG a
fromList [] = LEFT (CONS NilString UNIT)
fromList [a:l] = RIGHT (CONS ConsString (PAIR a l))
toList :: (ListG a) -> [a]
toList (LEFT (CONS _ UNIT)) = []
toList (RIGHT (CONS _ (PAIR a l))) = [a:l]
instance serialize0 [a] | serialize0 a where
write0 l c = write0 (fromList l) c
read0 r = case read0 r of
Just (s,r) -> Just (toList s, r)
Nothing -> Nothing
NilString :== "Nil"
ConsString :== "Cons"
instance serialize1 [] where
write1 f l c = write2 (write1 write0) (write1 (write2 f (write1 f))) (fromList l) c
read1 f r = case read2 (read1 read0) (read1 (read2 f (read1 f))) r of
Just (s,r) -> Just (toList s, r)
Nothing -> Nothing
// ---
:: 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 serialize0 (Bin a) | serialize0 a where
write0 a c = write0 (fromBin a) c
read0 l = case read0 l of
Just (s,r) -> Just (toBin s,r)
Nothing -> Nothing
instance == (Bin a) | == a where
(==) Leaf Leaf = True
(==) (Bin l a r) (Bin k b s) = l == k && a == b && r == s
(==) _ _ = False
instance serialize1 Bin where
write1 f a c = write2 (write1 write0) (write1 (write2 (write1 f) (write2 f (write1 f)))) (fromBin a) c
read1 f l = case read2 (read1 read0) (read1 (read2 (read1 f) (read2 f (read1 f)))) l of
Just (s,r) -> Just (toBin s,r)
Nothing -> Nothing
// ---
:: 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 serialize0 Coin where
write0 c cont = write0 (fromCoin c) cont
read0 r = case read0 r of
Just (c, rest) -> Just(toCoin c, rest)
_ -> Nothing
/*
Define a special purpose version for this type that writes and reads
the value (7,True) as ["(","7",",","True",")"]
*/
instance serialize0 (a,b) | serialize0 a & serialize0 b where
write0 (a,b) c = ["(":write0 a [",":write0 b [")":c]]]
read0 ["(":r] = case read0 r of
Nothing -> Nothing
Just (a,[",":r]) -> case read0 r of
Nothing -> Nothing
Just(b,[")":r]) -> Just ((a,b),r)
_ -> Nothing
_ -> Nothing
read0 _ = Nothing
// ---
// output looks nice if compiled with "Basic Values Only" for console in project options
Start =
[test True
,test False
,test 0
,test 123
,test -36
,test [42]
,test [0..4]
,test [[True],[]]
,test [[[1]],[[2],[3,4]],[[]]]
,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] | serialize0, == a
test a =
(if (isJust r)
(if (fst jr == a)
(if (isEmpty (tl (snd jr)))
["Oke"]
["Not all input is consumed! ":snd jr])
["Wrong result: ":write0 (fst jr) []])
["read result is Nothing"]
) ++ [", write produces: ": s]
where
s = write0 a ["\n"]
r = read0 s
jr = fromJust r
module serialize8Start
module ex2
/*
Definitions for assignment 8 in AFP 2019
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment