Permalink
Browse files

reference solution for assignment 10

git-svn-id: https://slps.svn.sourceforge.net/svnroot/slps@763 ab42f6e0-554d-0410-b580-99e487e6eeb2
  • Loading branch information...
grammarware committed Feb 1, 2010
1 parent 5485077 commit d580ad2bcf287fc064b6eebc03815013be045a87
@@ -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
@@ -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
@@ -0,0 +1,5 @@
test:
runhaskell RunEval.hs
clean:
rm -f *~
@@ -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
@@ -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)
@@ -0,0 +1,5 @@
test:
swipl -s RunShapes.pro -t 'main'
clean:
rm -rf *~
@@ -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.
@@ -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).

0 comments on commit d580ad2

Please sign in to comment.