Commit 16971ef9 authored by Reg Huijben's avatar Reg Huijben

Start of week 8

parent 77af3e95
module genericMap
/*
Genric map definition for assignment 8 in AFP 2019
Pieter Koopman, pieter@cs.ru.nl
September 2019
Use StdEnv or iTask environment.
*/
import StdEnv, StdGeneric
generic gMap a b :: a -> b
gMap{|Int|} x = x
gMap{|Real|} x = x
gMap{|UNIT|} x = x
gMap{|PAIR|} f g (PAIR x y) = PAIR (f x) (g y)
gMap{|EITHER|} f g (LEFT x) = LEFT (f x)
gMap{|EITHER|} f g (RIGHT x) = RIGHT (g x)
gMap{|CONS|} f (CONS x) = CONS (f x)
gMap{|OBJECT|} f (OBJECT x) = OBJECT (f x)
:: Bin a = Leaf | Bin (Bin a) a (Bin a)
t = Bin (Bin Leaf 1 Leaf) 2 (Bin (Bin Leaf 3 Leaf) 4 Leaf)
l = [1..7]
Start = (l, t)
module serialize8Start
/*
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
import StdGeneric
// use this as serialize0 for kind *
//class serialize a | isUnit a where
// write :: a [String] -> [String]
// read :: [String] -> Maybe (a,[String])
generic write a :: a [String] -> [String]
generic read a :: [String] -> Maybe (a,[String])
class serialize a | read{|*|}, write{|*|} a
//write :: a [String] -> [String]
//write a c = write{|*|} a
//instance serialize Bool where
derive read Bool
derive write Bool
write{|Bool|} b c = [toString b:c]
write{|UNIT|} b c = []
write{|PAIR|} f g b c = []
write{|EITHER|} f g b c = []
write{|CONS|} f b c = []
write{|FIELD|} f b c = []
write{|OBJECT|} f b c = []
read{|Bool|} r = Nothing
read{|UNIT|} r = Nothing
read{|PAIR|} f g r = Nothing
read{|EITHER|} f g r = Nothing
read{|CONS|} f r = Nothing
read{|FIELD|} f r = Nothing
read{|OBJECT|} f r = Nothing
//write{|*|} b c = []
//read{|*|} r = Nothing
//instance where
// write{|*|} a [String] -> [String]
// read{|*|} [String] -> Maybe (a,[String])
// ---
//derive serialize Bool
instance serialize Bool where
write b c = []
/*instance serialize Bool where
write b c = [toString b:c]
read 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 serialize Int where
write i c = [toString i:c]
read 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
// ---
/*
class isUnit a where
isUnit :: a -> Bool
instance isUnit UNIT where
isUnit a = True
instance isUnit a where
isUnit a = False
instance serialize UNIT where
write u c = c
read r = Just (UNIT,r)
instance serialize (PAIR a b) | serialize a & serialize b where
write (PAIR a b) c = (write a (write b c))
read r = case read r of
Nothing -> Nothing
Just (a,r) -> case read r of
Nothing -> Nothing
Just (b,r) -> Just (PAIR a b, r)
instance serialize (EITHER a b) | serialize a & serialize b where
write (LEFT a) c = write a c
write (RIGHT b) c = write b c
read r = case read r of // try to parse the left side...
Just (a,r) -> Just (LEFT a ,r)
Nothing -> case read r of // if that fails, try to parse the right side
Just (a,r) -> Just (RIGHT a ,r)
Nothing -> Nothing
// Don't flip left and right though, that makes reading using the 'unit without parentheses' not work
instance serialize (CONS a) | serialize a where
// Cheekily using the fact that a written unit is an empty list
//write (CONS s a) c = let written = write a [] in
// if (length (written) == 0)
// [s: written++c] // unit without parentheses
// ["(":s: (written ++ [")":c])] // else with parentheses
write (CONS a) c = if (isUnit a)
(write a c) // unit without parentheses
["(": (write a [")":c])] // else with parentheses
read ["(":s:r] = case read r of
Just (a,[")":r]) -> Just(CONS a, r)
_ -> Nothing
read [s:r] = case read r of
Just (a,r) -> Just (CONS a, r)
Nothing -> Nothing
read _ = Nothing
*/
// ------------
:: 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 // to be improved
write a s = s
read s = 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 == (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 // to be improved
write b s = s
read l = Nothing
*/
// ---
:: Coin = Head | Tail
:: CoinG :== EITHER (CONS UNIT) (CONS UNIT)
fromCoin :: Coin -> CoinG
fromCoin Head = LEFT (CONS UNIT)
fromCoin Tail = RIGHT (CONS 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 s = s
read l = Nothing
*/
/*
Define a special purpose version for this type that writes and reads
the value (7,True) as ["(","7",",","True",")"]
*/
:: TupleG a b :== CONS (PAIR a b)
fromTup :: (a,b) -> (TupleG a b)
fromTup (a,b) = CONS (PAIR a b)
toTup :: (TupleG a b) -> (a,b)
toTup (CONS (PAIR a b)) = (a,b)
/*
instance serialize (a,b) | serialize a & serialize b where
write (a,b) c = ["(":(write a [ ",":(write b [")":c])])] //write (fromTup (a,b)) c
read ["(":r] = case read r of
Just (a,[",":r]) -> case read r of
Just(b,[")":r]) -> Just ((a,b),r)
_ -> Nothing
_ -> Nothing
//read _ = Nothing
*/
// ---
Start = write True
// 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 (7,True)
,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] | serialize, == 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: ":write (fst jr) []])
["read result is Nothing"]
) ++ [", write produces: ": s]
where
s = write a ["\n"]
r = read s
jr = fromJust r
*/
\ No newline at end of file
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