From 05ffd999512958a5bd1a44e7bc053db5af549ca8 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Tue, 10 Feb 2015 10:07:28 +0100
Subject: [PATCH] week 2 almost finished
---
week2/mart/Makefile | 21 +++++++++
week2/mart/StdT.dcl | 18 ++++++++
week2/mart/StdT.icl | 38 +++++++++++++++++
week2/mart/StdTTest.icl | 45 +++++++++++++++++++
week2/mart/TupleOverloading.dcl | 25 +++++++++++
week2/mart/TupleOverloading.icl | 49 +++++++++++++++++++++
week2/mart/TupleOverloadingTest.icl | 64 ++++++++++++++++++++++++++++
week2/mart/VectorOverloading.dcl | 14 ++++++
week2/mart/VectorOverloading.icl | 22 ++++++++++
week2/mart/VectorOverloadingTest.icl | 62 +++++++++++++++++++++++++++
10 files changed, 358 insertions(+)
create mode 100644 week2/mart/Makefile
create mode 100644 week2/mart/StdT.dcl
create mode 100644 week2/mart/StdT.icl
create mode 100644 week2/mart/StdTTest.icl
create mode 100644 week2/mart/TupleOverloading.dcl
create mode 100644 week2/mart/TupleOverloading.icl
create mode 100644 week2/mart/TupleOverloadingTest.icl
create mode 100644 week2/mart/VectorOverloading.dcl
create mode 100644 week2/mart/VectorOverloading.icl
create mode 100644 week2/mart/VectorOverloadingTest.icl
diff --git a/week2/mart/Makefile b/week2/mart/Makefile
new file mode 100644
index 0000000..a35595b
--- /dev/null
+++ b/week2/mart/Makefile
@@ -0,0 +1,21 @@
+PATHS=-I ~/downloads/clean/lib/StdLib -I ~/downloads/clean/lib/MersenneTwister/ -I ~/downloads/usr/lib64/clean/Gast/ -I ~/downloads/clean/lib/Generics/
+FLAGS=-v
+
+all: tuple vector stdtime
+
+tuple: TupleOverloading.icl TupleOverloading.dcl
+ clm $(FLAGS) $(PATHS) TupleOverloadingTest -o TupleOverloadingTest
+
+vector: VectorOverloading.icl VectorOverloading.dcl
+ clm $(FLAGS) $(PATHS) VectorOverloadingTest -o VectorOverloadingTest
+
+stdtime: StdT.icl StdT.dcl
+ clm $(FLAGS) $(PATHS) StdTTest -o StdTTest
+
+testall:
+ ./StdTTest
+ ./TupleOverloadingTest
+ ./VectorOverloadingTest
+
+clean:
+ $(RM) -r Clean\ System\ Files a.out TupleOverloadingTest VectorOverloadingTest StdTTest
diff --git a/week2/mart/StdT.dcl b/week2/mart/StdT.dcl
new file mode 100644
index 0000000..f4f0d75
--- /dev/null
+++ b/week2/mart/StdT.dcl
@@ -0,0 +1,18 @@
+definition module StdT
+
+import StdOverloaded
+
+:: T
+
+instance == T
+instance < T
+
+instance zero T
+instance + T
+instance - T
+
+instance toInt T
+instance fromInt T
+
+instance toString T
+instance fromString T
diff --git a/week2/mart/StdT.icl b/week2/mart/StdT.icl
new file mode 100644
index 0000000..e49da8a
--- /dev/null
+++ b/week2/mart/StdT.icl
@@ -0,0 +1,38 @@
+implementation module StdT
+
+import StdEnv
+
+:: T = {m :: Int, s :: Int}
+
+instance == T where
+ == a b = a.m == b.m && a.s == b.s
+instance < T where
+ < a b = a.m < b.m || a.s < b.s
+
+instance zero T where
+ zero = {m=zero, s=zero}
+instance + T where
+ + a b = fromInt (toInt a + toInt b)
+instance - T where
+ - a b = fromInt (toInt a - toInt b)
+
+instance toInt T where
+ toInt a = a.m*60 + a.s
+instance fromInt T where
+ fromInt a
+ | a<0 = zero
+ | otherwise = {m=a/60, s=a rem 60}
+
+instance toString T where
+ toString {m=ms, s=0} = toString ms +++ ":00"
+ toString {m=ms, s=ss}
+ | ss < 10 = toString ms +++ ":0" +++ toString ss
+ | otherwise = toString ms +++ ":" +++ toString ss
+
+instance fromString T where
+ fromString a
+ | a.[size a - 3] == ':' = {m = toInt (a % (0, (size a) - 4)), s = toInt (a % ((size a) - 3, size a))}
+ | otherwise = zero
+
+Start :: T
+Start = fromString "12:34"
diff --git a/week2/mart/StdTTest.icl b/week2/mart/StdTTest.icl
new file mode 100644
index 0000000..6af64fc
--- /dev/null
+++ b/week2/mart/StdTTest.icl
@@ -0,0 +1,45 @@
+module StdTTest
+
+/* Test module StdTTest
+ Voor werken met Gast:
+ (*) gebruik Environment 'Gast'
+ (*) zet Project Options op 'Basic Values Only'
+*/
+
+import StdT
+import StdEnv
+import gast
+
+Start
+ = testn 1000
+ (\ i ->
+ gelijkheid_is_symmetrisch i /\
+ ordening_is_monotoon i /\
+ negatieve_tijd_bestaat_niet i /\
+ omzetten_naar_Int_is_consistent i /\
+ parse_print_is_consistent i /\
+ True
+ )
+
+t :: Int -> T
+t x = fromInt x
+
+gelijkheid_is_symmetrisch :: Int -> Property
+gelijkheid_is_symmetrisch i = name "gelijkheid_is_symmetrisch"
+ (t i == t i)
+
+ordening_is_monotoon :: Int -> Property
+ordening_is_monotoon i = name "ordening_is_monotoon"
+ ((i <= i+1) ==> t i <= t (i+1))
+
+negatieve_tijd_bestaat_niet :: Int -> Property
+negatieve_tijd_bestaat_niet i = name "negatieve_tijd_bestaat_niet"
+ ((i + 1 >= i) ==> t i - t (i+1) == zero)
+
+omzetten_naar_Int_is_consistent :: Int -> Property
+omzetten_naar_Int_is_consistent i = name "omzetten_naar_Int_is_consistent"
+ ((abs i >= 0) ==> toInt (t (abs i)) == abs i)
+
+parse_print_is_consistent :: Int -> Property
+parse_print_is_consistent i = name "parse_print_is_consistent"
+ (fromString (toString (t i)) == t i)
diff --git a/week2/mart/TupleOverloading.dcl b/week2/mart/TupleOverloading.dcl
new file mode 100644
index 0000000..6831948
--- /dev/null
+++ b/week2/mart/TupleOverloading.dcl
@@ -0,0 +1,25 @@
+definition module TupleOverloading
+
+import StdEnv
+
+instance + (a,b) | + a & + b
+instance + (a,b,c) | + a & + b & + c
+
+
+instance - (a,b) | - a & - b
+instance - (a,b,c) | - a & - b & - c
+
+instance * (a,b) | * a & * b
+instance * (a,b,c) | * a & * b & * c
+
+instance / (a,b) | / a & / b
+instance / (a,b,c) | / a & / b & / c
+
+instance zero (a,b) | zero a & zero b
+instance zero (a,b,c) | zero a & zero b & zero c
+
+instance one (a,b) | one a & one b
+instance one (a,b,c) | one a & one b & one c
+
+instance ~ (a,b) | ~ a & ~ b
+instance ~ (a,b,c) | ~ a & ~ b & ~ c
diff --git a/week2/mart/TupleOverloading.icl b/week2/mart/TupleOverloading.icl
new file mode 100644
index 0000000..2995fbd
--- /dev/null
+++ b/week2/mart/TupleOverloading.icl
@@ -0,0 +1,49 @@
+implementation module TupleOverloading
+
+import StdEnv
+
+instance + (a,b) | + a & + b where
+ + (a,b) (c,d) = (a+c,b+d)
+instance + (a,b,c) | + a & + b & + c where
+ + (a,b,c) (d,e,f) = (a+d,b+e,c+f)
+
+
+instance - (a,b) | - a & - b where
+ - (a,b) (c,d) = (a-c,b-d)
+instance - (a,b,c) | - a & - b & - c where
+ - (a,b,c) (d,e,f) = (a-d,b-e,c-f)
+
+instance * (a,b) | * a & * b where
+ * (a,b) (c,d) = (a*c,b*d)
+instance * (a,b,c) | * a & * b & * c where
+ * (a,b,c) (d,e,f) = (a*d,b*e,c*f)
+
+instance / (a,b) | / a & / b where
+ / (a,b) (c,d) = (a/c,b/d)
+instance / (a,b,c) | / a & / b & / c where
+ / (a,b,c) (d,e,f) = (a/d,b/e,c/f)
+
+instance zero (a,b) | zero a & zero b where
+ zero = (zero,zero)
+instance zero (a,b,c) | zero a & zero b & zero c where
+ zero = (zero,zero,zero)
+
+instance one (a,b) | one a & one b where
+ one = (one,one)
+instance one (a,b,c) | one a & one b & one c where
+ one = (one,one,one)
+
+instance ~ (a,b) | ~ a & ~ b where
+ ~ (a,b) = (~a,~b)
+instance ~ (a,b,c) | ~ a & ~ b & ~ c where
+ ~ (a,b,c) = (~a,~b,~c)
+
+Start = (test (1,2), test (1,2,3))
+
+test a = ( zero + a == a && a == a + zero
+ , a - zero == a && a == ~ (zero - a)
+ , one * a == a && a == a * one
+ , zero * a == zero && zero == a * zero
+ , a / one == a
+ , ~ (~ a) == a
+ )
diff --git a/week2/mart/TupleOverloadingTest.icl b/week2/mart/TupleOverloadingTest.icl
new file mode 100644
index 0000000..91417f7
--- /dev/null
+++ b/week2/mart/TupleOverloadingTest.icl
@@ -0,0 +1,64 @@
+module TupleOverloadingTest
+
+/* Test module VectorOverloading
+ Voor werken met Gast:
+ (*) gebruik Environment 'Gast'
+ (*) zet Project Options op 'Basic Values Only'
+*/
+
+import TupleOverloading
+import StdEnv
+import gast
+
+Start
+ = testn 1000
+ (\v ->
+ zero_is_neutral_for_addition v /\
+ zero_is_neutral_for_subtraction v /\
+ one_is_neutral_for_multiplication v /\
+ one_is_neutral_for_division v /\
+ negation_is_idempotent v /\
+ add_then_subtract_yields_identity v /\
+ subtract_then_add_yields_identity v /\
+ True
+ )
+
+:: Vector2 a :== (a,a)
+:: BaseType
+ :== Int
+// :== Real
+
+zero_is_neutral_for_addition :: (Vector2 BaseType) -> Property
+zero_is_neutral_for_addition a = name "zero_is_neutral_for_addition"
+ (zero + a == a && a == a + zero)
+
+zero_is_neutral_for_subtraction :: (Vector2 BaseType) -> Property
+zero_is_neutral_for_subtraction a = name "zero_is_neutral_for_subtraction"
+ (a - zero == a && a == ~ (zero - a))
+
+one_is_neutral_for_multiplication :: (Vector2 BaseType) -> Property
+one_is_neutral_for_multiplication a = name "one_is_neutral_for_multiplication"
+ (one * a == a && a == a * one)
+
+zero_is_zero_for_multiplication :: (Vector2 BaseType) -> Property
+zero_is_zero_for_multiplication a = name "zero_is_zero_for_multiplication"
+ (zero * a == zero && zero == a * zero)
+
+one_is_neutral_for_division :: (Vector2 BaseType) -> Property
+one_is_neutral_for_division a = name "one_is_neutral_for_division"
+ (a / one == a)
+
+negation_is_idempotent :: (Vector2 BaseType) -> Property
+negation_is_idempotent a = name "negation_is_idempotent"
+ (~ (~ a) == a)
+
+
+add_then_subtract_yields_identity :: (Vector2 BaseType) -> Property
+add_then_subtract_yields_identity a = name "add then subtract" ((a + a) - a == a)
+
+subtract_then_add_yields_identity :: (Vector2 BaseType) -> Property
+subtract_then_add_yields_identity a = name "subtract then add" ((zero - a - a) + a + a == zero)
+
+//derive genShow (,)
+//derive ggen (,)
+derive bimap []
diff --git a/week2/mart/VectorOverloading.dcl b/week2/mart/VectorOverloading.dcl
new file mode 100644
index 0000000..76f8520
--- /dev/null
+++ b/week2/mart/VectorOverloading.dcl
@@ -0,0 +1,14 @@
+definition module VectorOverloading
+
+import StdEnv
+
+:: Vector2 a = {x0 :: a, x1 :: a}
+
+instance == (Vector2 a) | == a
+instance zero (Vector2 a) | zero a
+instance one (Vector2 a) | one a
+instance ~ (Vector2 a) | ~ a
+instance + (Vector2 a) | + a
+instance - (Vector2 a) | - a
+instance * (Vector2 a) | * a
+instance / (Vector2 a) | / a
diff --git a/week2/mart/VectorOverloading.icl b/week2/mart/VectorOverloading.icl
new file mode 100644
index 0000000..74f6f69
--- /dev/null
+++ b/week2/mart/VectorOverloading.icl
@@ -0,0 +1,22 @@
+implementation module VectorOverloading
+
+import StdEnv
+
+:: Vector2 a = {x0 :: a, x1 :: a}
+
+instance == (Vector2 a) | == a where
+ == a b = a.x0 == b.x0 && a.x1 == b.x1
+instance zero (Vector2 a) | zero a where
+ zero = {x0=zero, x1=zero}
+instance one (Vector2 a) | one a where
+ one = {x0=one, x1=one}
+instance ~ (Vector2 a) | ~ a where
+ ~ a = {x0= ~a.x0, x1= ~a.x1}
+instance + (Vector2 a) | + a where
+ + a b = {x0=a.x0+b.x0, x1=a.x1+b.x1}
+instance - (Vector2 a) | - a where
+ - a b = {x0=a.x0-b.x0, x1=a.x1-b.x1}
+instance * (Vector2 a) | * a where
+ * a b = {x0=a.x0*b.x0, x1=a.x1*b.x1}
+instance / (Vector2 a) | / a where
+ / a b = {x0=a.x0/b.x0, x1=a.x1/b.x1}
diff --git a/week2/mart/VectorOverloadingTest.icl b/week2/mart/VectorOverloadingTest.icl
new file mode 100644
index 0000000..e5571bb
--- /dev/null
+++ b/week2/mart/VectorOverloadingTest.icl
@@ -0,0 +1,62 @@
+module VectorOverloadingTest
+
+/* Test module VectorOverloading
+ Voor werken met Gast:
+ (*) gebruik Environment 'Gast'
+ (*) zet Project Options op 'Basic Values Only'
+*/
+
+import VectorOverloading
+import StdEnv
+import gast
+
+Start
+ = testn 1000
+ (\v ->
+ zero_is_neutral_for_addition v /\
+ zero_is_neutral_for_subtraction v /\
+ one_is_neutral_for_multiplication v /\
+ one_is_neutral_for_division v /\
+ negation_is_idempotent v /\
+ add_then_subtract_yields_identity v /\
+ subtract_then_add_yields_identity v /\
+ True
+ )
+
+:: BaseType
+ :== Int
+// :== Real
+
+zero_is_neutral_for_addition :: (Vector2 BaseType) -> Property
+zero_is_neutral_for_addition a = name "zero_is_neutral_for_addition"
+ (zero + a == a && a == a + zero)
+
+zero_is_neutral_for_subtraction :: (Vector2 BaseType) -> Property
+zero_is_neutral_for_subtraction a = name "zero_is_neutral_for_subtraction"
+ (a - zero == a && a == ~ (zero - a))
+
+one_is_neutral_for_multiplication :: (Vector2 BaseType) -> Property
+one_is_neutral_for_multiplication a = name "one_is_neutral_for_multiplication"
+ (one * a == a && a == a * one)
+
+zero_is_zero_for_multiplication :: (Vector2 BaseType) -> Property
+zero_is_zero_for_multiplication a = name "zero_is_zero_for_multiplication"
+ (zero * a == zero && zero == a * zero)
+
+one_is_neutral_for_division :: (Vector2 BaseType) -> Property
+one_is_neutral_for_division a = name "one_is_neutral_for_division"
+ (a / one == a)
+
+negation_is_idempotent :: (Vector2 BaseType) -> Property
+negation_is_idempotent a = name "negation_is_idempotent"
+ (~ (~ a) == a)
+
+add_then_subtract_yields_identity :: (Vector2 BaseType) -> Property
+add_then_subtract_yields_identity a = name "add then subtract" ((a + a) - a == a)
+
+subtract_then_add_yields_identity :: (Vector2 BaseType) -> Property
+subtract_then_add_yields_identity a = name "subtract then add" ((zero - a - a) + a + a == zero)
+
+derive genShow Vector2
+derive ggen Vector2
+derive bimap []
--
2.20.1