reference solution for assignment 10

git-svn-id: https://slps.svn.sourceforge.net/svnroot/slps@763 ab42f6e0-554d-0410-b580-99e487e6eeb2

topics/exercises/README.txt

@@ -22,10 +22,13 @@ b3       - folding over expressions for B in Haskell
 nb1      - abstract syntax for NB in Prolog
 nb2      - semantics and types for NB in Prolog
 nb3      - parsing and folding NB in Haskell
+nb4      - Expression Problem with NB in Haskell
 
 lambda1	 - lambda calculus abstract and concrete syntax in Prolog
-lambda2	 - lambda caclulus with Church numbers
+lambda2	 - lambda calculus with Church numbers
 lambda3  - lambda calculus abstract syntax, free variables, substitution, evaluation
 lambda4	 - untyped lambda calculus with alpha conversion & fixed point combinator
 lambda5  - typed lambda calculus with alpha conversion in Prolog
 lambda6  - typed lambda calculus with alpha conversion & fixed point operator
+
+shapes   - the Shapes Problem (object encoding) in Prolog

topics/exercises/nb4/Evaluation.hs

@@ -0,0 +1,40 @@
+module Evaluation where
+import Syntax
+
+data Result
+	= Bool Bool
+	| Num Int
+	| Neither
+	deriving Show
+
+class NB x => Evaluate x
+	where eval :: x -> Result
+
+instance Evaluate TrueB
+	where eval TrueB = Bool True
+
+instance Evaluate FalseB
+	where eval FalseB = Bool False
+
+instance (Evaluate c, Evaluate t, Evaluate e) => Evaluate (IfNB c t e)
+	where eval (IfNB c t e) = case (eval c) of
+		Bool x -> if x then eval t else eval e
+		_ -> Neither
+
+instance Evaluate ZeroN
+	where eval ZeroN = Num 0
+
+instance (Evaluate t) => Evaluate (SuccN t)
+	where eval (SuccN t) = case (eval t) of
+		Num x -> Num (x+1)
+		_ -> Neither
+
+instance (Evaluate t) => Evaluate (PredN t)
+	where eval (PredN t) = case (eval t) of
+		Num x -> Num (x-1)
+		_ -> Neither
+
+instance (Evaluate t) => Evaluate (IsZeroB t)
+	where eval (IsZeroB t) = case (eval t) of
+		Num x -> Bool (x==0)
+		_ -> Neither

topics/exercises/nb4/Makefile

@@ -0,0 +1,5 @@
+test:
+	runhaskell RunEval.hs
+
+clean:
+	rm -f *~

topics/exercises/nb4/RunEval.hs

@@ -0,0 +1,16 @@
+module RunEval where
+import Evaluation
+import Syntax
+import Data.Maybe
+
+
+main = do
+	print $ eval   TrueB
+	print $ eval   FalseB
+	print $ eval $ IsZeroB (PredN (PredN (SuccN (SuccN (PredN (SuccN ZeroN))))))
+	print $ eval $ SuccN (SuccN (PredN (SuccN ZeroN)))
+	print $ eval $ PredN (SuccN ZeroN)
+	print $ eval $ IfNB TrueB (SuccN ZeroN) (PredN ZeroN)
+	print $ eval $ IfNB TrueB TrueB FalseB
+	print $ eval $ IfNB (IsZeroB ZeroN) (SuccN (SuccN ZeroN)) (PredN ZeroN)
+	print $ eval $ IfNB ZeroN ZeroN ZeroN

topics/exercises/nb4/Syntax.hs

@@ -0,0 +1,25 @@
+module Syntax where
+
+data TrueB = TrueB
+	deriving Show
+data FalseB = FalseB
+	deriving Show
+data (NB b, NB n1, NB n2) => IfNB b n1 n2 = IfNB b n1 n2
+	deriving Show
+data ZeroN = ZeroN
+	deriving Show
+data (NB n) => SuccN n = SuccN n
+	deriving Show
+data (NB n) => PredN n = PredN n
+	deriving Show
+data (NB n) => IsZeroB n = IsZeroB n
+	deriving Show
+
+class NB x
+instance NB TrueB
+instance NB FalseB
+instance (NB c, NB t, NB e) => NB (IfNB c t e)
+instance NB ZeroN
+instance (NB t) => NB (SuccN t)
+instance (NB t) => NB (PredN t)
+instance (NB t) => NB (IsZeroB t)

topics/exercises/shapes/Makefile

@@ -0,0 +1,5 @@
+test:
+	swipl -s RunShapes.pro -t 'main'
+
+clean:
+	rm -rf *~

topics/exercises/shapes/RunShapes.pro

@@ -0,0 +1,14 @@
+:- ['Shapes.pro'].
+
+main :-
+	shape(1,2,S1),
+	circle(1,2,3,C1),
+	setradius(5,C1,C2),
+	rectangle(1,2,3,4,R1),
+	setheight(10,R1,R2),
+	setwidth(100,R2,R3),
+	boldcircle(1,2,3,10,B1),
+	setboldness(2,B1,B2),
+	movebyall(5,10,[S1,C2,R3,B2],TS2),
+	drawall(TS2),
+	nl.

topics/exercises/shapes/Shapes.pro

@@ -0,0 +1,134 @@
+% Object encoding: [M, T1, T2, ...]
+% M - shapedata(X,Y)
+% T - circledelta(R)
+% T - rectdelta(H,W)
+% T - boldcircledelta(W)
+% ...
+
+:- discontiguous(drawtail/1).
+
+last([E], E). last([_|T], E) :- last(T, E).
+
+isshape([shapedata(X,Y)|T]) :-
+	integer(X),
+	integer(Y),
+	shapetails(T).
+
+shapetails([]).
+shapetails([T|TS]) :-
+	shapetail(T),
+	shapetails(TS).
+
+shapetail(circledelta(R)) :-
+	integer(R).
+shapetail(rectdelta(H,W)) :-
+	integer(H),
+	integer(W).
+shapetail(boldcircledelta(W)) :-
+	integer(W).
+
+subclassname([]) :-
+	write('abstract shape').
+subclassname([circledelta(_)]) :-
+	write('circle').
+subclassname([boldcircledelta(_)]) :-
+	write('bold circle').
+subclassname([rectdelta(_,_)]) :-
+	write('rectangle').
+subclassname([_|SS]) :-
+	subclassname(SS).
+
+getx([shapedata(X,Y)|T],X) :-
+	isshape([shapedata(X,Y)|T]).
+gety([shapedata(X,Y)|T],Y) :-
+	isshape([shapedata(X,Y)|T]).
+setx(NX,[shapedata(X,Y)|T],[shapedata(NX,Y)|T]) :-
+	isshape([shapedata(X,Y)|T]),
+	isshape([shapedata(NX,Y)|T]).
+sety(NY,[shapedata(X,Y)|T],[shapedata(X,NY)|T]) :-
+	isshape([shapedata(X,Y)|T]),
+	isshape([shapedata(X,NY)|T]).
+moveto(NX,NY,S1,S3) :-
+	setx(NX,S1,S2),
+	sety(NY,S2,S3).
+moveby(DX,DY,S1,S3) :-
+	getx(S1,X),
+	gety(S1,Y),
+	NX is X + DX,
+	NY is Y + DY,
+	setx(NX,S1,S2),
+	sety(NY,S2,S3).
+% Can be implemented completely differently, this one just shows the (polymorphic) way, not the exact bits:
+draw([shapedata(X,Y)|T]) :-
+	isshape([shapedata(X,Y)|T]),
+	write('Drawing the '),
+	subclassname(T),
+	write(' at '),
+	write(X),
+	write(' × '),
+	write(Y),
+	drawtails(T),
+	write('.'),nl.
+drawtails([]).
+drawtails([T|TS]) :-
+	drawtail(T),
+	drawtails(TS).
+
+% circles
+iscircle(S) :- isshape(S), last(S,circledelta(_)).
+getradius([circledelta(R)|_],R).
+getradius([_|T],R) :- getradius([T],R).
+setradius(NR,[circledelta(_)|T],[circledelta(NR)|T]) :-	integer(NR).
+setradius(NR,[S|T1],[S|T2]) :- setradius(NR,T1,T2).
+drawtail(circledelta(R)) :- write(' of radius '), write(R).
+
+% rects
+isrect(S) :- isshape(S), last(S,rectdelta(_,_)).
+getheight([rectdelta(H,_)|_],H).
+getheight([_|T],R) :- getheight([T],R).
+setheight(NH,[rectdelta(_,W)|T],[rectdelta(NH,W)|T]) :- integer(NH).
+setheight(NH,[S|T1],[S|T2]) :- setheight(NH,T1,T2).
+getwidth([rectdelta(_,W)|_],W).
+getwidth([_|T],R) :- getwidth([T],R).
+setwidth(NW,[rectdelta(H,_)|T],[rectdelta(H,NW)|T]) :- integer(NW).
+setwidth(NW,[S|T1],[S|T2]) :- setwidth(NW,T1,T2).
+drawtail(rectdelta(H,W)) :-
+	write(' of size '),
+	write(H),
+	write(' × '),
+	write(W).
+
+% boldcircles
+isboldcircle(S) :- isshape(S), last(S,boldcircledelta(_)).
+getboldness([boldcircledelta(R)|_],R).
+getboldness([_|T],R) :- getboldness([T],R).
+setboldness(NR,[boldcircledelta(_)|T],[boldcircledelta(NR)|T]) :- integer(NR).
+setboldness(NR,[S|T1],[S|T2]) :- setboldness(NR,T1,T2).
+drawtail(boldcircledelta(W)) :-
+	write(' and width '),
+	write(W).
+
+drawall([]).
+drawall([S|SS]) :-
+	draw(S),
+	drawall(SS).
+movebyall(_,_,[],[]).
+movebyall(DX,DY,[S1|SS1],[S2|SS2]) :-
+	moveby(DX,DY,S1,S2),
+	movebyall(DX,DY,SS1,SS2).
+
+% constructors
+shape(X,Y,[shapedata(X,Y)]) :-
+	isshape([shapedata(X,Y)]).
+rectangle(X,Y,H,W,S2) :-
+	shape(X,Y,S1),
+	append(S1,[rectdelta(H,W)],S2),
+	isrect(S2).
+circle(X,Y,R,S2) :-
+	shape(X,Y,S1),
+	append(S1,[circledelta(R)],S2),
+	iscircle(S2).
+boldcircle(X,Y,R,W,S2) :-
+	circle(X,Y,R,S1),
+	append(S1,[boldcircledelta(W)],S2),
+	isboldcircle(S2).