Skip to content

Commit

Permalink
assignment 6 reference solution
Browse files Browse the repository at this point in the history 
git-svn-id: https://slps.svn.sourceforge.net/svnroot/slps@735 ab42f6e0-554d-0410-b580-99e487e6eeb2
  • Loading branch information
@grammarware
grammarware committed Dec 14, 2009
1 parent b9ce829 commit 3e1716f
Show file tree
Hide file tree
Showing 16 changed files with 953 additions and 0 deletions.
74 changes: 74 additions & 0 deletions topics/exercises/nb3/FoldNB.hs
View file
@@ -0,0 +1,74 @@
module FoldNB where

import NB

foldNB :: r -> r -> (r -> r -> r -> r) -> r -> (r -> r) -> (r -> r) -> (r -> r) -> (NB -> r)
-- TrueB FalseB IfNB ZeroN SuccN PredN IsZeroB
foldNB r _ _ _ _ _ _ TrueB = r
foldNB _ r _ _ _ _ _ FalseB = r
foldNB t f i z s p r (IfNB a b c) =
i (fold a) (fold b) (fold c)
where fold = foldNB t f i z s p r
foldNB _ _ _ r _ _ _ ZeroN = r
foldNB t f i z s p r (SuccN a) =
s (fold a)
where fold = foldNB t f i z s p r
foldNB t f i z s p r (PredN a) =
p (fold a)
where fold = foldNB t f i z s p r
foldNB t f i z s p r (IsZeroB a) =
r (fold a)
where fold = foldNB t f i z s p r

depth :: NB -> Int
depth = foldNB
1
1
(\ x y z -> 1 + (maximum [x, y, z]))
1
(+1)
(+1)
(+1)


countT :: NB -> Int
countT = foldNB
1
0
(\ x y z -> x + y + z)
0
(const 0)
(const 0)
(const 0)

maxN :: NB -> Int
maxN = foldNB
0
0
(\ x y z -> max y z)
0
(+1)
(\ x -> if x>1 then x-1 else 0)
(id)

eval :: NB -> Int
eval = foldNB
1
0
(\ x y z -> if x/=0 then y else z)
0
(+1)
(\ x -> if x>1 then x-1 else 0)
(\ x -> if x==0 then 1 else 0)

data Answer = Num Int | Bool2 Bool deriving Show

evalnb :: NB -> Answer
evalnb = foldNB
(Bool2 True)
(Bool2 False)
(\ (Bool2 x) y z -> if x then y else z)
(Num 0)
(\ (Num x) -> Num (x+1) )
(\ (Num x) -> if x>1 then (Num (x-1)) else Num 0)
(\ (Num x) -> if x==0 then Bool2 True else Bool2 False)
5 changes: 5 additions & 0 deletions topics/exercises/nb3/Makefile
View file
@@ -0,0 +1,5 @@
test:
ghci -ihutton:. Test.hs

clean:
rm -f *~ *.hi *.o
12 changes: 12 additions & 0 deletions topics/exercises/nb3/NB.hs
View file
@@ -0,0 +1,12 @@
module NB where

data NB
= TrueB
| FalseB
| IfNB NB NB NB
| ZeroN
| SuccN NB
| PredN NB
| IsZeroB NB
deriving Show

55 changes: 55 additions & 0 deletions topics/exercises/nb3/ParseNB.hs
View file
@@ -0,0 +1,55 @@
module ParseNB where

import NB
import Parsing

nb = true +++ false +++ cond +++ zero +++ succnb +++ prednb +++ iszero

true =
do
token (string "true")
return TrueB

false =
do
token (string "false")
return FalseB

cond =
do
token (string "if")
x <- nb
token (string "then")
y <- nb
token (string "else")
z <- nb
token (string "fi")
return (IfNB x y z)

zero =
do
token (string "0")
return ZeroN

succnb =
do
token (string "succ")
token (string "(")
x <- nb
token (string ")")
return (SuccN x)

prednb =
do
token (string "pred")
token (string "(")
x <- nb
token (string ")")
return (PredN x)

iszero =
do
token (string "is")
x <- nb
token (string "zero?")
return (IsZeroB x)
17 changes: 17 additions & 0 deletions topics/exercises/nb3/Test.hs
View file
@@ -0,0 +1,17 @@
module Main where

import Parsing
import FoldNB
import ParseNB
import NB


main = do
print $ eval $ fst $ head $ parse nb "0"
print $ evalnb $ fst $ head $ parse nb "0"
print $ eval $ fst $ head $ parse nb "if true then false else if false then true else false fi fi"
print $ evalnb $ fst $ head $ parse nb "if true then false else if false then true else false fi fi"
print $ eval $ fst $ head $ parse nb "if is pred(succ(0)) zero? then true else false fi"
print $ evalnb $ fst $ head $ parse nb "if is pred(succ(0)) zero? then true else false fi"
print $ eval $ fst $ head $ parse nb "succ(succ(succ(pred(succ(0)))))"
print $ evalnb $ fst $ head $ parse nb "succ(succ(succ(pred(succ(0)))))"
126 changes: 126 additions & 0 deletions topics/exercises/nb3/hutton/Parsing.lhs
View file
@@ -0,0 +1,126 @@
Functional parsing library from chapter 8 of Programming in Haskell,
Graham Hutton, Cambridge University Press, 2007.


> module Parsing where
>
> import Char
> import Monad
>
> infixr 5 +++

The monad of parsers
--------------------

> newtype Parser a = P (String -> [(a,String)])
>
> instance Monad Parser where
> return v = P (\inp -> [(v,inp)])
> p >>= f = P (\inp -> case parse p inp of
> [] -> []
> [(v,out)] -> parse (f v) out)
>
> instance MonadPlus Parser where
> mzero = P (\inp -> [])
> p `mplus` q = P (\inp -> case parse p inp of
> [] -> parse q inp
> [(v,out)] -> [(v,out)])

Basic parsers
-------------

> failure :: Parser a
> failure = mzero
>
> item :: Parser Char
> item = P (\inp -> case inp of
> [] -> []
> (x:xs) -> [(x,xs)])
>
> parse :: Parser a -> String -> [(a,String)]
> parse (P p) inp = p inp

Choice
------

> (+++) :: Parser a -> Parser a -> Parser a
> p +++ q = p `mplus` q

Derived primitives
------------------

> sat :: (Char -> Bool) -> Parser Char
> sat p = do x <- item
> if p x then return x else failure
>
> digit :: Parser Char
> digit = sat isDigit
>
> lower :: Parser Char
> lower = sat isLower
>
> upper :: Parser Char
> upper = sat isUpper
>
> letter :: Parser Char
> letter = sat isAlpha
>
> alphanum :: Parser Char
> alphanum = sat isAlphaNum
>
> char :: Char -> Parser Char
> char x = sat (== x)
>
> string :: String -> Parser String
> string [] = return []
> string (x:xs) = do char x
> string xs
> return (x:xs)
>
> many :: Parser a -> Parser [a]
> many p = many1 p +++ return []
>
> many1 :: Parser a -> Parser [a]
> many1 p = do v <- p
> vs <- many p
> return (v:vs)
>
> ident :: Parser String
> ident = do x <- lower
> xs <- many alphanum
> return (x:xs)
>
> nat :: Parser Int
> nat = do xs <- many1 digit
> return (read xs)
>
> int :: Parser Int
> int = do char '-'
> n <- nat
> return (-n)
> +++ nat
>
> space :: Parser ()
> space = do many (sat isSpace)
> return ()

Ignoring spacing
----------------

> token :: Parser a -> Parser a
> token p = do space
> v <- p
> space
> return v
>
> identifier :: Parser String
> identifier = token ident
>
> natural :: Parser Int
> natural = token nat
>
> integer :: Parser Int
> integer = token int
>
> symbol :: String -> Parser String
> symbol xs = token (string xs)
7 changes: 7 additions & 0 deletions topics/exercises/nb3/hutton/README.txt
View file
@@ -0,0 +1,7 @@
These files were donwloaded from:
http://www.cs.nott.ac.uk/~gmh/book.html
The accompnay this book:
Programming in Haskell
Graham Hutton, University of Nottingham
Cambridge University Press, 2007

0 comments on commit 3e1716f

Please sign in to comment.