From: Mart Lubbers Date: Tue, 22 Sep 2015 19:03:53 +0000 (+0200) Subject: working excpt map on tuple X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=2453111bc8911511f50aaebbcfa098a1f1f42239;p=ap2015.git working excpt map on tuple --- diff --git a/a3/mart/skeleton3a.icl b/a3/mart/skeleton3a.icl index 3b2c1fd..709c60c 100644 --- a/a3/mart/skeleton3a.icl +++ b/a3/mart/skeleton3a.icl @@ -1,28 +1,24 @@ module skeleton3a /* - Advanced Programming. - Skeleton for exercise 3.1 and 3.2. - To be used in a project with the environment Everything, - or StdEnv with an import of StdMaybe from StdLib + Advanced Programming. + Skeleton for exercise 3.1 and 3.2. + To be used in a project with the environment Everything, + or StdEnv with an import of StdMaybe from StdLib - Pieter Koopman, pieter@cs.ru.nl + Pieter Koopman, pieter@cs.ru.nl */ import StdEnv, StdMaybe /************* showing *******************/ -class show_0 a where show_0 :: a [String] -> [String] +class show_0 t where show_0 :: t [String] -> [String] -instance show_0 Int where show_0 i c = [IntTag :toString i:c] -instance show_0 Bool where show_0 b c = [BoolTag:toString b:c] -instance show_0 UNIT where show_0 unit c = [UNITTag:c] +instance show_0 Int where show_0 i c = [toString i:c] +instance show_0 Bool where show_0 b c = [toString b:c] -IntTag :== "Int" -BoolTag :== "Bool" -UNITTag :== "UNIT" -PAIRTag :== "PAIR" +instance show_0 UNIT where show_0 _ c = c show :: a -> [String] | show_0 a show a = show_0 a [] @@ -31,143 +27,230 @@ show a = show_0 a [] :: Result a :== Maybe (a,[String]) -class parse0 a :: [String] -> Result a +class parse0 t :: [String] -> Result t -instance parse0 Int -where - parse0 [IntTag,i:r] = Just (toInt i, r) +instance parse0 Int where + parse0 [i:r] = Just (toInt i, r) parse0 r = Nothing -instance parse0 Bool -where - parse0 [BoolTag,b:r] = Just (b=="True", r) - parse0 r = Nothing -instance parse0 UNIT -where - parse0 [UNITTag:r] = Just (UNIT, r) + +instance parse0 Bool where + parse0 [b:r] = Just (b == "True", r) parse0 r = Nothing +instance parse0 UNIT where + parse0 r = Just (UNIT, r) + /**************** Example Types and conversions *************************/ -:: T = C -:: Color = Red | Yellow | Blue -:: Tree a = Tip | Bin a (Tree a) (Tree a) +:: T = C +:: Color = Red | Yellow | Blue +:: Tree a = Tip | Bin a (Tree a) (Tree a) -// Binary sums and products (in generic prelude) -:: UNIT = UNIT -:: PAIR a b = PAIR a b -:: EITHER a b = LEFT a | RIGHT b -:: CONS a = CONS String a +// Binary sums and products (in generic prelude) +:: UNIT = UNIT +:: PAIR a b = PAIR a b +:: EITHER a b = LEFT a | RIGHT b +:: CONS a = CONS String a -// Generic type representations -:: TG :== CONS UNIT -:: ColorG :== EITHER (EITHER (CONS UNIT) (CONS UNIT)) (CONS UNIT) -:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a])) -:: TreeG a :== EITHER (CONS UNIT) (CONS (PAIR a (PAIR (Tree a) (Tree a)))) -:: TupG a b :== CONS (PAIR a b) +// Generic type representations +:: TG :== CONS UNIT +:: ColorG :== EITHER (EITHER (CONS UNIT) (CONS UNIT)) (CONS UNIT) +:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a])) +:: TreeG a :== EITHER (CONS UNIT) (CONS (PAIR a (PAIR (Tree a) (Tree a)))) +:: TupG a b :== CONS (PAIR a b) // Conversions -fromT :: T -> TG -fromT c = CONS "C" UNIT +fromT :: T -> TG +fromT c = CONS "C" UNIT -fromColor :: Color -> ColorG -fromColor Red = LEFT (LEFT (CONS "Red" UNIT)) -fromColor Yellow = LEFT (RIGHT (CONS "Yellow" UNIT)) -fromColor Blue = RIGHT (CONS "Blue" UNIT) +fromColor :: Color -> ColorG +fromColor Red = LEFT (LEFT (CONS "Red" UNIT)) +fromColor Yellow = LEFT (RIGHT (CONS "Yellow" UNIT)) +fromColor Blue = RIGHT (CONS "Blue" UNIT) -fromList :: [a] -> ListG a -fromList [] = LEFT (CONS "Nil" UNIT) -fromList [a:as] = RIGHT (CONS "Cons" (PAIR a as)) +fromList :: [a] -> ListG a +fromList [] = LEFT(CONS "Nil" UNIT) +fromList [a:as] = RIGHT (CONS "Cons" (PAIR a as)) -fromTree :: (Tree a) -> TreeG a -fromTree Tip = LEFT (CONS "Tip" UNIT) -fromTree (Bin a l r) = RIGHT (CONS "Bin" (PAIR a (PAIR l r))) +fromTree :: (Tree a) -> TreeG a +fromTree Tip = LEFT(CONS "Tip" UNIT) +fromTree (Bin a l r) = RIGHT (CONS "Bin" (PAIR a (PAIR l r))) -fromTup :: (a,b) -> TupG a b -fromTup (a,b) = CONS "Tuple2" (PAIR a b) +fromTup :: (a,b) -> TupG a b +fromTup (a,b) = CONS "Tuple2" (PAIR a b) -toT :: TG -> T -toT (CONS _ UNIT) = C +toT :: TG -> T +toT (CONS _ UNIT) = C -toColor :: ColorG -> Color -toColor (LEFT (LEFT (CONS _ UNIT))) = Red -toColor (LEFT (RIGHT (CONS _ UNIT))) = Yellow -toColor (RIGHT (CONS _ UNIT)) = Blue +toColor :: ColorG -> Color +toColor (LEFT (LEFT(CONS _ UNIT))) = Red +toColor (LEFT (RIGHT (CONS _ UNIT))) = Yellow +toColor (RIGHT (CONS _ UNIT)) = Blue -toList :: (ListG a) -> [a] -toList (LEFT (CONS s UNIT)) = [] -toList (RIGHT (CONS s (PAIR a as))) = [a:as] +toList :: (ListG a) -> [a] +toList (LEFT (CONS s UNIT)) = [] +toList (RIGHT (CONS s (PAIR a as))) = [a:as] -toTree :: (TreeG a) -> Tree a -toTree (LEFT (CONS s UNIT)) = Tip +toTree :: (TreeG a) -> Tree a +toTree (LEFT (CONS s UNIT))= Tip toTree (RIGHT (CONS s (PAIR a (PAIR l r)))) = Bin a l r -toTup :: (TupG a b) -> (a,b) -toTup (CONS s (PAIR a b)) = (a,b) +toTup :: (TupG a b) -> (a,b) +toTup (CONS s (PAIR a b)) = (a,b) /**************** to test if parse and show work properly *************************/ test :: t -> Bool | eq0, show_0, parse0 t -test x - = case parse0 (show x) of - Just (y,[]) = eq0 x y - _ = False +test x = case parse0 (show x) of + Just (y,[]) = eq0 x y + _ = False /**************** equality with a class for each kind *************************/ -class eq0 t :: t t -> Bool -class eq1 t :: (a a -> Bool) (t a) (t a) -> Bool +class eq0 t ::t t-> Bool +class eq1 t :: (a a -> Bool) (t a) (t a) -> Bool class eq2 t :: (a a -> Bool) (b b -> Bool) (t a b) (t a b) -> Bool -instance eq0 UNIT where eq0 _ _ = True -instance eq0 Int where eq0 n m = n == m +instance eq0 UNIT where eq0 _ _ = True +instance eq0 Int where eq0 n m = n == m -instance eq1 CONS where eq1 f (CONS s x) (CONS t y) = s == t && f x y +instance eq1 CONS where eq1 f (CONS s x) (CONS t y) = s == t && f x y -instance eq2 PAIR where eq2 f g (PAIR a b) (PAIR x y) = f a x && g b y -instance eq2 EITHER where eq2 f g (LEFT x) (LEFT y) = f x y - eq2 f g (RIGHT x) (RIGHT y) = g x y - eq2 f g _ _ = False +instance eq2 PAIR where eq2 f g (PAIR a b) (PAIR x y) = f a x && g b y +instance eq2 EITHER where + eq2 f g (LEFT x) (LEFT y)= f x y + eq2 f g (RIGHT x) (RIGHT y)= g x y + eq2 f g _ _ = False -instance eq0 [a] | eq0 a where eq0 l m = eq1 eq0 l m -instance eq1 [] where eq1 f l m = eq2 (eq1 eq0) (eq1 (eq2 f (eq1 f))) (fromList l) (fromList m) +instance eq0 [a] | eq0 a where eq0 l m = eq1 eq0 l m +instance eq1 [] where eq1 f l m = eq2 (eq1 eq0) (eq1 (eq2 f (eq1 f))) (fromList l) (fromList m) /**************** map *************************/ -class map0 t :: t -> t -class map1 t :: (a -> b) (t a) -> t b +class map0 t :: t -> t +class map1 t :: (a -> b) (t a) -> t b class map2 t :: (a -> b) (c -> d) (t a c) -> t b d -instance map0 Int where map0 i = i -instance map0 UNIT where map0 UNIT = UNIT +instance map0 Int where map0 i = i +instance map0 UNIT where map0 UNIT = UNIT -instance map1 CONS where map1 f (CONS n x) = CONS n (f x) +instance map1 CONS where map1 f (CONS n x) = CONS n (f x) -instance map2 PAIR where map2 f g (PAIR x y) = PAIR (f x) (g y) -instance map2 EITHER where map2 f g (LEFT x) = LEFT (f x) - map2 f g (RIGHT y) = RIGHT (g y) +instance map2 PAIR where map2 f g (PAIR x y) = PAIR (f x) (g y) +instance map2 EITHER where + map2 f g (LEFT x) = LEFT (f x) + map2 f g (RIGHT y)= RIGHT (g y) /**************** End Prelude *************************/ /**************** please add all new code below this line *************************/ - -instance eq0 Color where eq0 c1 c2 = False // TO BE IMPROVED -instance == Color where (==) c1 c2 = eq0 c1 c2 // just to use the well-known notation... -instance show_0 Color where show_0 _ c = c // TO BE IMPROVED -instance parse0 Color where parse0 _ = Nothing // TO BE IMPROVED - -instance map1 [] where map1 f l = map f l // TO BE IMPROVED, use generic version - -// some initial tests, please extend -Start - = [ and [ test i \\ i <- [-25 .. 25]] - , and [ c == toColor (fromColor c) \\ c <- [Red, Yellow, Blue]] - , and [ test c \\ c <- [Red,Yellow,Blue]] -// , test [1 .. 3] -// , test [(a,b) \\ a <- [1 .. 2], b <- [5 .. 7]] -// etc. - // maps - , map1 ((+) 1) [0 .. 5] == [1 .. 6] - ] - -aTree = Bin 2 Tip (Bin 4 Tip Tip) +//Show stuff +class show_1 t where show_1 :: (a [String] -> [String]) (t a) [String] -> [String] +class show_2 t where show_2 :: (a [String] -> [String]) (b [String] -> [String]) (t a b) [String] -> [String] + +instance show_1 CONS where + show_1 f (CONS s x) c = [s:f x c] +instance show_2 PAIR where + show_2 f1 f2 (PAIR x1 x2) c = f1 x1 (f2 x2 c) +instance show_2 EITHER where + show_2 f1 f2 (LEFT x1) c = f1 x1 c + show_2 f1 f2 (RIGHT x2) c = f2 x2 c + +instance show_0 Color where + show_0 x c = show_2 (show_2 (show_1 show_0) (show_1 show_0)) (show_1 show_0) (fromColor x) c + +instance show_1 Tree where + show_1 f x c = show_2 (show_1 show_0) (show_1 (show_2 f (show_2 (show_1 f) (show_1 f)))) (fromTree x) c +instance show_0 (Tree a) | show_0 a where + show_0 x c = show_1 show_0 x c + +instance show_1 [] where + show_1 f x c = show_2 (show_1 show_0) (show_1 (show_2 f (show_1 f))) (fromList x) c +instance show_0 [a] | show_0 a where + show_0 x c = show_1 show_0 x c + +instance show_0 (a, b) | show_0 a & show_0 b where + show_0 x c = show_1 (show_2 show_0 show_0) (fromTup x) c + +instance show_0 T where + show_0 x c = show_1 show_0 (fromT x) c + +//Parsing stuff +class parse1 t :: ([String] -> Result a) [String] -> Result (t a) +class parse2 t :: ([String] -> Result a) ([String] -> Result b) [String] -> Result (t a b) + +instance parse1 CONS where + parse1 f [s:r] = case f r of + Just (x, r) = Just (CONS s x, r) + _ = Nothing + parse1 _ _ = Nothing + +instance parse2 PAIR where + parse2 f1 f2 r = case f1 r of + Just (x1, r) = case f2 r of + Just (x2, r) = Just (PAIR x1 x2, r) + _ = Nothing + _ = Nothing + +instance parse2 EITHER where + parse2 f1 f2 r = case f2 r of + Just (x, r) = Just (RIGHT x, r) + _ = case f1 r of + Just (x, r) = Just (LEFT x, r) + _ = Nothing + +instance parse0 Color where + parse0 r = case parse2 (parse2 (parse1 parse0) (parse1 parse0)) (parse1 parse0) r of + Just (x, r) = Just (toColor x, r) + _ = Nothing + +instance parse1 Tree where + parse1 f r = case parse2 (parse1 parse0) (parse1 (parse2 f (parse2 (parse1 f) (parse1 f)))) r of + Just (x, r) = Just (toTree x, r) + _ = Nothing +instance parse0 (Tree a) | parse0 a where + parse0 r = parse1 parse0 r + +instance parse1 [] where + parse1 f r = case parse2 (parse1 parse0) (parse1 (parse2 f (parse1 f))) r of + Just (x, r) = Just (toList x, r) + _ = Nothing +instance parse0 [a] | parse0 a where + parse0 r = parse1 parse0 r + +instance parse0 (a, b) | parse0 a & parse0 b where + parse0 r = case parse1 (parse2 parse0 parse0) r of + Just (x, r) = Just (toTup x, r) + _ = Nothing + +instance parse0 T where + parse0 r = case parse1 parse0 r of + Just (x, r) = Just (toT x, r) + _ = Nothing + +instance eq0 Color where + eq0 c1 c2 = eq2 (eq2 (eq1 eq0) (eq1 eq0)) (eq1 eq0) (fromColor c1) (fromColor c2) +instance == Color where + (==) c1 c2 = eq0 c1 c2 + +instance map1 [] where + map1 f l = toList (map2 (map1 map0) (map1 (map2 f (map1 f))) (fromList l)) + +instance map1 Tree where + map1 f t = toTree (map2 (map1 map0) (map1 (map2 f (map2 (map1 f) (map1 f)))) (fromTree t)) + +//instance map2 (a, b) | map1 a & map1 a where +// map2 f1 f2 t = toTup (map1 (map2 f1 f2) (fromTup t)) + +Start = ( + map1 fac aTree, + map1 fac aList, + //map2 fac fac (aList, aTree), + map1 (\x.(x, fac x)) aList + ) + where + fac 1 = 1 + fac n = n * (fac (n-1)) + aTree = Bin 2 Tip (Bin 4 Tip Tip) + aList = [1..10] diff --git a/a3/mart/skeleton3a_wt.icl b/a3/mart/skeleton3a_wt.icl new file mode 100644 index 0000000..2e893ec --- /dev/null +++ b/a3/mart/skeleton3a_wt.icl @@ -0,0 +1,217 @@ +module skeleton3a + +/* + Advanced Programming. + Skeleton for exercise 3.1 and 3.2. + To be used in a project with the environment Everything, + or StdEnv with an import of StdMaybe from StdLib + + Pieter Koopman, pieter@cs.ru.nl +*/ + +import StdEnv, StdMaybe + +/************* showing *******************/ + +class show_0 t where show_0 :: t [String] -> [String] +class show_1 t where show_1 :: (a [String] -> [String]) (t a) [String] -> [String] +class show_2 t where show_2 :: (a [String] -> [String]) (b [String] -> [String]) (t a b) [String] -> [String] + +instance show_0 Int where show_0 i c = [IntTag :toString i:c] +instance show_0 Bool where show_0 b c = [BoolTag:toString b:c] + +instance show_0 UNIT where show_0 unit c = [UNITTag:c] +instance show_1 CONS where + show_1 f (CONS s x) c = [CONSTag,s:f x c] +instance show_2 PAIR where + show_2 f1 f2 (PAIR x1 x2) c = [PAIRTag:f1 x1 (f2 x2 c)] +instance show_2 EITHER where + show_2 f1 f2 (LEFT x1) c = [LEFTTag:f1 x1 c] + show_2 f1 f2 (RIGHT x2) c = [RIGHTTag:f2 x2 c] + +instance show_0 Color where + show_0 x c = show_2 (show_2 (show_1 show_0) (show_1 show_0)) (show_1 show_0) (fromColor x) c + +instance show_1 Tree where + show_1 f x c = show_2 (show_1 show_0) (show_1 (show_2 f (show_2 (show_1 f) (show_1 f)))) (fromTree x) c +instance show_0 (Tree a) | show_0 a where + show_0 x c = show_1 show_0 x c + +instance show_1 [] where + show_1 f x c = show_2 (show_1 show_0) (show_1 (show_2 f (show_1 f))) (fromList x) c +instance show_0 [a] | show_0 a where + show_0 x c = show_1 show_0 x c + +instance show_0 (a, b) | show_0 a & show_0 b where + show_0 x c = show_1 (show_2 show_0 show_0) (fromTup x) c + +instance show_0 T where + show_0 x c = show_1 show_0 (fromT x) c + +IntTag :== "Int" +BoolTag :== "Bool" +UNITTag :== "UNIT" +PAIRTag :== "PAIR" +LEFTTag :== "LEFT" +RIGHTTag :== "RIGHT" +CONSTag :== "CONS" + +show :: a -> [String] | show_0 a +show a = show_0 a [] + +/**************** parsing *************************/ + +:: Result a :== Maybe (a,[String]) + +class parse0 t :: [String] -> Result t +class parse1 t :: ([String] -> Result a) [String] -> Result (t a) +class parse2 t :: ([String] -> Result a) ([String] -> Result b) [String] -> Result (t a b) + +instance parse0 Int where + parse0 [IntTag,i:r] = Just (toInt i, r) + parse0 r = Nothing + +instance parse0 Bool where + parse0 [BoolTag,b:r] = Just (b == "True", r) + parse0 r = Nothing + +instance parse0 UNIT where + parse0 [UNITTag:r] = Just (UNIT, r) + parse0 r = Nothing + +instance parse1 CONS where + parse1 f [CONSTag,s:r] = case f r of + Just (x, r) = Just (CONS s x, r) + _ = Nothing + parse1 _ _ = Nothing + +instance parse2 PAIR where + parse2 f1 f2 [PAIRTag:r] = case f1 r of + Just (x1, r) = case f2 r of + Just (x2, r) = Just (PAIR x1 x2, r) + _ = Nothing + _ = Nothing + parse2 _ _ _ = Nothing + +instance parse2 EITHER where + parse2 f1 f2 [LEFTTag:r] = case f1 r of + Just (x, r) = Just (LEFT x, r) + _ = Nothing + parse2 f1 f2 [RIGHTTag:r] = case f2 r of + Just (x, r) = Just (RIGHT x, r) + _ = Nothing + +instance parse0 Color where + parse0 r = case parse2 (parse2 (parse1 parse0) (parse1 parse0)) (parse1 parse0) r of + Just (x, r) = Just (toColor x, r) + _ = Nothing + +instance parse1 Tree where + parse1 f r = case parse2 (parse1 parse0) (parse1 (parse2 f (parse2 (parse1 f) (parse1 f)))) r of + Just (x, r) = Just (toTree x, r) + _ = Nothing +instance parse0 (Tree a) | parse0 a where + parse0 r = parse1 parse0 r + +instance parse1 [] where + parse1 f r = case parse2 (parse1 parse0) (parse1 (parse2 f (parse1 f))) r of + Just (x, r) = Just (toList x, r) + _ = Nothing +instance parse0 [a] | parse0 a where + parse0 r = parse1 parse0 r + +instance parse0 (a, b) | parse0 a & parse0 b where + parse0 r = case parse1 (parse2 parse0 parse0) r of + Just (x, r) = Just (toTup x, r) + _ = Nothing + +instance parse0 T where + parse0 r = case parse1 parse0 r of + Just (x, r) = Just (toT x, r) + _ = Nothing + +/**************** Example Types and conversions *************************/ + +:: T = C +:: Color = Red | Yellow | Blue +:: Tree a = Tip | Bin a (Tree a) (Tree a) + +// Binary sums and products (in generic prelude) +:: UNIT = UNIT +:: PAIR a b = PAIR a b +:: EITHER a b = LEFT a | RIGHT b +:: CONS a = CONS String a + +// Generic type representations +:: TG :== CONS UNIT +:: ColorG :== EITHER (EITHER (CONS UNIT) (CONS UNIT)) (CONS UNIT) +:: ListG a :== EITHER (CONS UNIT) (CONS (PAIR a [a])) +:: TreeG a :== EITHER (CONS UNIT) (CONS (PAIR a (PAIR (Tree a) (Tree a)))) +:: TupG a b :== CONS (PAIR a b) + +// Conversions + +fromT :: T -> TG +fromT c = CONS "C" UNIT + +fromColor :: Color -> ColorG +fromColor Red = LEFT (LEFT (CONS "Red" UNIT)) +fromColor Yellow = LEFT (RIGHT (CONS "Yellow" UNIT)) +fromColor Blue = RIGHT (CONS "Blue" UNIT) + +fromList :: [a] -> ListG a +fromList [] = LEFT(CONS "Nil" UNIT) +fromList [a:as] = RIGHT (CONS "Cons" (PAIR a as)) + +fromTree :: (Tree a) -> TreeG a +fromTree Tip = LEFT(CONS "Tip" UNIT) +fromTree (Bin a l r) = RIGHT (CONS "Bin" (PAIR a (PAIR l r))) + +fromTup :: (a,b) -> TupG a b +fromTup (a,b) = CONS "Tuple2" (PAIR a b) + +toT :: TG -> T +toT (CONS _ UNIT) = C + +toColor :: ColorG -> Color +toColor (LEFT (LEFT(CONS _ UNIT))) = Red +toColor (LEFT (RIGHT (CONS _ UNIT))) = Yellow +toColor (RIGHT (CONS _ UNIT)) = Blue + +toList :: (ListG a) -> [a] +toList (LEFT (CONS s UNIT)) = [] +toList (RIGHT (CONS s (PAIR a as))) = [a:as] + +toTree :: (TreeG a) -> Tree a +toTree (LEFT (CONS s UNIT))= Tip +toTree (RIGHT (CONS s (PAIR a (PAIR l r)))) = Bin a l r + +toTup :: (TupG a b) -> (a,b) +toTup (CONS s (PAIR a b)) = (a,b) + +/**************** to test if parse and show work properly *************************/ + +test :: t -> Bool | eq0, show_0, parse0 t +test x = case parse0 (show x) of + Just (y,[]) = eq0 x y + _ = False + +/**************** equality with a class for each kind *************************/ + +class eq0 t ::t t-> Bool +class eq1 t :: (a a -> Bool) (t a) (t a) -> Bool +class eq2 t :: (a a -> Bool) (b b -> Bool) (t a b) (t a b) -> Bool + +instance eq0 UNIT where eq0 _ _ = True +instance eq0 Int where eq0 n m = n == m + +instance eq1 CONS where eq1 f (CONS s x) (CONS t y) = s == t && f x y + +instance eq2 PAIR where eq2 f g (PAIR a b) (PAIR x y) = f a x && g b y +instance eq2 EITHER where + eq2 f g (LEFT x) (LEFT y)= f x y + eq2 f g (RIGHT x) (RIGHT y)= g x y + eq2 f g _ _ = False + +instance eq0 [a] | eq0 a where eq0 l m = eq1 eq0 l m +instance eq1 [] where eq1 f l m = eq2 (eq1 eq0) (eq1 (eq2 f (eq1 f))) (fromList l) (fromList m)