Permalink
Browse files

some fixed point optimisations; Extended While implementation

git-svn-id: https://slps.svn.sourceforge.net/svnroot/slps@740 ab42f6e0-554d-0410-b580-99e487e6eeb2
  • Loading branch information...
grammarware committed Jan 18, 2010
1 parent b1ca5b8 commit 8111ebfc7d4ca8e2722707a6c999e37fdfc28407
@@ -0,0 +1,48 @@
module Evaluation where
import Syntax
import Data.Maybe
import Prelude hiding (lookup)
-- a frequently used pattern
match x1 x2 f1 f2 =
if x1 == x2
then f1
else f2
-- see slide 546
type Environment = [(Identifier, Location)]
type Store = [(Location, Int)]
type Location = Int
-- see slide 553
type PEnvironment = [(Procedure, Store -> Store)]
-- see slide 547
lookup :: Environment -> Store -> Identifier -> Maybe Int
lookup env sto = store2value sto . env2loc env
env2loc :: Environment -> Identifier -> Maybe Location
env2loc [] x = Nothing
env2loc ((x1,l):xls) x2 = match x1 x2 (Just l) (env2loc xls x2)
store2value :: Store -> Maybe Location -> Maybe Int
store2value _ Nothing = Nothing
store2value [] (Just l) = Nothing
store2value ((l1,v):lvs) (Just l2) = match l1 l2 (Just v) (store2value lvs (Just l2))
-- same old thing, with State replaced by Environment and Store, as slide 546 suggested
evala :: AExpression -> Environment -> Store -> Int
evala (Number n) _ _ = n
evala (Identifier x) env sto = Data.Maybe.fromMaybe (error "Undefined variable") (lookup env sto x)
evala (Add a1 a2) env sto = evala a1 env sto + evala a2 env sto
evala (Sub a1 a2) env sto = evala a1 env sto - evala a2 env sto
evala (Mul a1 a2) env sto = evala a1 env sto * evala a2 env sto
evalb :: BExpression -> Environment -> Store -> Bool
evalb BTrue _ _ = True
evalb BFalse _ _ = False
evalb (Equals a1 a2) env sto = evala a1 env sto == evala a2 env sto
evalb (LessThanOrEqual a1 a2) env sto = evala a1 env sto <= evala a2 env sto
evalb (Not b) env sto = not (evalb b env sto)
evalb (And b1 b2) env sto = evalb b1 env sto && evalb b2 env sto
@@ -0,0 +1,78 @@
module Execution where
import Syntax
import Evaluation
import Prelude hiding (lookup)
update :: Environment -> Store -> Identifier -> Int -> Store
update [] sto _ _ = sto
update ((x1,l):xls) sto x2 v = match x1 x2 (updateStore sto l v) (update xls sto x2 v)
updateStore :: Store -> Location -> Int -> Store
updateStore [] l v = []
updateStore ((l1,v1):lvs) l2 v2 = match l1 l2 ((l1,v2):lvs) ((l1,v1):updateStore lvs l2 v2)
-- Denotational semantics of Extended While, slides 545–554
exec :: Statement -> Environment -> PEnvironment -> (Store -> Store)
exec (Seq s1 s2) env penv = exec s2 env penv . exec s1 env penv
exec Skip _ _ = id
exec (IfThenElse b s1 s2) env penv = cond (evalb b env) (exec s1 env penv) (exec s2 env penv)
exec (While b s) env penv = fix f
where
f g = cond (evalb b env) (g . exec s env penv) id
exec (Call x) env penv = getProc penv x
exec (Assign x a) env penv = h
where
h sto = update env sto x (evala a env sto)
exec (Block dv dp s) env penv = h
where
h sto = exec s env' penv' sto'
where
(env', sto') = decVar dv (env, sto)
penv' = decProc dp env' penv
cond p g1 g2 sto | p sto = g1 sto
| otherwise = g2 sto
fix :: (t -> t) -> t
fix f = f (fix f)
-- slides 550, 551
decVar :: [VariableDeclaration] -> (Environment, Store) -> (Environment, Store)
decVar [] = id
decVar ((Var x a):dv) = h
where
h (env, sto) = decVar dv (modifyEnvironment env x l, modifyNext (modifySto sto l (evala a env sto)) l)
where
l = fst (head sto)
matchNmodify xys x y =
if null xys
then [(x,y)]
else match (fst (head xys)) x ((x,y):xys) (head xys:matchNmodify (tail xys) x y)
modifyEnvironment :: Environment -> Identifier -> Location -> Environment
modifyEnvironment [] x l = [(x,l)]
modifyEnvironment ((x1,l1):xls) x2 l2 = match x1 x2 ((x1,l2):xls) ((x1,l1):modifyEnvironment xls x2 l2)
modifySto :: Store -> Location -> Int -> Store
modifySto [] l v = [(l,v)]
modifySto ((l1,v1):lvs) l2 v2 = match l1 l2 ((l1,v2):lvs) ((l1,v1):modifySto lvs l2 v2)
modifyNext :: Store -> Location -> Store
modifyNext lvs l = (l+1,0):lvs
-- slides 552–554
decProc :: [ProcedureDeclaration] -> Environment -> PEnvironment -> PEnvironment
decProc [] env = id
decProc ((Proc p s):dp) env = h
where
h penv = decProc dp env (modifyPEnvironment penv p (fix (exec s env . modifyPEnvironment penv p)))
modifyPEnvironment :: PEnvironment -> Procedure -> (Store -> Store) -> PEnvironment
modifyPEnvironment [] p f = [(p,f)]
modifyPEnvironment ((p1,f1):pfs) p2 f2 = match p1 p2 ((p1,f2):pfs) ((p1,f1):modifyPEnvironment pfs p2 f2)
getProc :: Eq a => [(a,Store -> Store)] -> a -> (Store -> Store)
getProc [] a = id
getProc ((a1,b):abs) a2 = match a1 a2 b (getProc abs a2)
@@ -0,0 +1,9 @@
all:
runhaskell Test.hs
test:
ghci Test.hs
clean:
rm -f *~ *.hi *.o Test
@@ -0,0 +1,52 @@
module Syntax where
data Statement
= Seq Statement Statement
| Skip
| Assign Identifier AExpression
| IfThenElse BExpression Statement Statement
| While BExpression Statement
| Block [VariableDeclaration] [ProcedureDeclaration] Statement
| Call Procedure
data AExpression
= Number Int
| Identifier String
| Add AExpression AExpression
| Sub AExpression AExpression
| Mul AExpression AExpression
data BExpression
= BTrue
| BFalse
| Equals AExpression AExpression
| LessThanOrEqual AExpression AExpression
| Not BExpression
| And BExpression BExpression
data VariableDeclaration = Var Identifier AExpression
data ProcedureDeclaration = Proc Procedure Statement
type Procedure = String
type Identifier = String
myWhile =
Seq (Assign "y" (Number 2))
(Seq (Assign "x" (Add (Identifier "y") (Number 4)))
(Seq (IfThenElse (And (Equals (Identifier "y") (Number 2)) (Equals (Identifier "x") (Number 6)))
(Assign "z" (Identifier "y"))
(Assign "z" (Number 1000)))
(While (LessThanOrEqual (Identifier "x") (Number 10))
(Assign "x" (Add (Identifier "x") (Number 1))))))
mySkip = Seq Skip Skip
myBlock = Block
[Var "x" (Number 1)]
[]
(While (LessThanOrEqual (Identifier "x") (Number 10))
(Block
[Var "y" (Add (Identifier "x") (Number 1))]
[Proc "inc" (Assign "x" (Identifier "y"))]
(Call "inc")))
@@ -0,0 +1,7 @@
module Main where
import Syntax
import Execution
main =
print $ exec myBlock [] [] [(1,0)]
@@ -1,3 +1,8 @@
module Factorial where
import Maybe
---- Assignment
-- Explicitly recursive functorial function
fac x = if x == 0 then 1 else x * fac (x-1)
@@ -10,7 +15,7 @@ fac' = fix f
fix f = f (fix f)
-- Fixed point computation based on iteration
fac'' x = head (dropWhile (==Nothing) [ f'i n x | n <- [0..] ])
fac'' x = fromJust $ head $ dropWhile (==Nothing) [ f'i n x | n <- [0..] ]
where
f g x = if x == 0 then Just 1 else maybe Nothing (Just . (x*)) (g (x-1))
f'i 0 = const Nothing
@@ -19,6 +24,72 @@ fac'' x = head (dropWhile (==Nothing) [ f'i n x | n <- [0..] ])
-- Test functions
main =
do
print $ fac 5 -- prints 120
print $ fac' 5 -- ditto
print $ fac'' 5 -- prints Just 120
print $ fac 5 -- all variations print 120
print $ fac' 5
print $ fac'' 5
---- Solution
-- 1. Does fac’’ have any “pragmatic” advantage over fac’?
-- Not in this simple case. Possibly more control over fixed point computation.
-- 2. Why is it a good idea to use the Maybe constructor in fac''.
-- Becase "no answer" is an ideologically correct & anticipated answer.
-- 3. Why could we start from 1 rather than from 0 in fac''?
-- Apparent when we inline the head.
-- 4. How could fac’’ be optimized while still performing the same iteration?
-- The first way is to move the lower bound up:
fac''op1 x = fromJust $ head $ dropWhile (==Nothing) [ f'i n x | n <- [1..] ]
where
f g x = if x == 0 then Just 1 else maybe Nothing (Just . (x*)) (g (x-1))
f'i 0 = const Nothing
f'i n = f (f'i (n-1))
-- Or even farther:
fac''op2 x = fromJust $ head $ dropWhile (==Nothing) [ f'i n x | n <- [x..] ]
where
f g x = if x == 0 then Just 1 else maybe Nothing (Just . (x*)) (g (x-1))
f'i 0 = const Nothing
f'i n = f (f'i (n-1))
-- Starting from x+1, we don’t need dropWhile
fac''op3 x = fromJust $ head [ f'i n x | n <- [x+1..] ]
where
f g x = if x == 0 then Just 1 else maybe Nothing (Just . (x*)) (g (x-1))
f'i 0 = const Nothing
f'i n = f (f'i (n-1))
-- The second way is to move the upper bound:
fac''op4 x = fromJust $ head $ dropWhile (==Nothing) [ f'i n x | n <- [0..x+1] ]
where
f g x = if x == 0 then Just 1 else maybe Nothing (Just . (x*)) (g (x-1))
f'i 0 = const Nothing
f'i n = f (f'i (n-1))
-- Ultimately (incorrect assignment answer!), we can reduce the list to one element
-- fac''op5 x = fromJust $ head $ dropWhile (==Nothing) [ f'i (x+1) x ]
-- and then get rid of dropWhile:
-- fac''op5 x = fromJust $ head [ f'i (x+1) x ]
-- and head:
fac''op5 x = fromJust $ f'i (x+1) x
where
f g x = if x == 0 then Just 1 else maybe Nothing (Just . (x*)) (g (x-1))
f'i 0 = const Nothing
f'i n = f (f'i (n-1))
-- The third good optimisation would be to make it use the previously computed factorials:
-- Remember the straightforward definition of the factorial:
-- fac x = product [1..x]
-- which is, as we know:
-- fac x = foldl (*) 1 [1..x]
-- which in turn can be implemented as:
-- fac''' x = (foldl (\ f n -> f . (n*)) id [1..x]) 1
-- Let's reproduce it.
fac''' x = head $ dropWhile (==0) (map f [0..])
where
f l = fold l (\ f n -> f . (n*)) id [1..x] 1
fold 0 _ _ _ = const 0
fold _ _ z [] = z
fold n f z (x:xs) = fold (n-1) f (f z x) xs
-- Indeed, if we compute all factorials of numbers from 1 to 2000
-- with fac'' it takes 8 seconds,
-- with fac''' it takes 3 seconds
-- 5. Would it be safe to take the second element in fac'' rather than head?
-- Yes. First, second and all elements after that are equal.

0 comments on commit 8111ebf

Please sign in to comment.