summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPaoloGiarrusso <>2013-01-26 09:17:43 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-01-26 09:17:43 (GMT)
commit16723303a1c99525c22310bcdf3a691327a4a97b (patch)
tree4b55a77111e0ccfb525bc98552cbd82fca1e0d5c
version 0.23HEAD0.23master
-rw-r--r--Adaptive-Blaisorblade.cabal31
-rw-r--r--ChangeLog17
-rw-r--r--Control/Monad/Adaptive.hs212
-rw-r--r--Control/Monad/Adaptive/CircularList.hs72
-rw-r--r--Control/Monad/Adaptive/MonadUtil.hs10
-rw-r--r--Control/Monad/Adaptive/OrderedList.hs233
-rw-r--r--Control/Monad/Adaptive/PriorityQueue.hs41
-rw-r--r--Control/Monad/Adaptive/Ref.hs33
-rw-r--r--LICENSE29
-rw-r--r--README54
-rw-r--r--Setup.lhs4
-rw-r--r--spreadsheet.hs124
12 files changed, 860 insertions, 0 deletions
diff --git a/Adaptive-Blaisorblade.cabal b/Adaptive-Blaisorblade.cabal
new file mode 100644
index 0000000..048119e
--- /dev/null
+++ b/Adaptive-Blaisorblade.cabal
@@ -0,0 +1,31 @@
+Name: Adaptive-Blaisorblade
+Version: 0.23
+Synopsis: Library for incremental computing.
+Description: This is a Haskell (plus some extensions) implementation
+ of a library for incremental computing. It closely
+ follows the implementation in the nice POPL 2002 paper
+ "Adaptive Functional Programming", by Umut Acar,
+ Guy Blelloch and Bob Harper.
+ This is a small fork of the original library named
+ "Adaptive", with the same interface but small adaptations
+ to GHC 7.4.
+License: BSD3
+License-file: LICENSE
+Author: Magnus Carlsson
+Maintainer: none
+data-files: ChangeLog, README
+build-type: Simple
+Cabal-version: >= 1.6
+Category: Control
+
+Library
+ Build-Depends: base >= 4.5 && < 5
+ Exposed-modules: Control.Monad.Adaptive, Control.Monad.Adaptive.Ref,Control.Monad.Adaptive.PriorityQueue, Control.Monad.Adaptive.OrderedList, Control.Monad.Adaptive.CircularList, Control.Monad.Adaptive.MonadUtil
+
+--category:
+Executable spreadsheet
+ Main-is: spreadsheet.hs
+
+source-repository head
+ type: git
+ location: git://github.com/Blaisorblade/Haskell-Adaptive.git
diff --git a/ChangeLog b/ChangeLog
new file mode 100644
index 0000000..ddcb0e9
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,17 @@
+2013-01-26 <p.giarrusso@gmail.com>
+
+ * Version 0.23, adapted for ghc 7.4.
+ * Updated Cabal file with extra metadata.
+
+2008-07-14 <pj@csee.ltu.se>
+
+ * Version 0.22, adapted for Hugs 20060908 and ghc 6.8.2.
+
+2005-07-09 <magnus@cse.ogi.edu>
+
+ * Version 0.21, adapted for Hugs 20050308 and ghc 6.4, by
+ Andrew Pimlott <andrew@pimlott.net>.
+
+2002-03-18 <magnus@cse.ogi.edu>
+
+ * Version 0.2, public release.
diff --git a/Control/Monad/Adaptive.hs b/Control/Monad/Adaptive.hs
new file mode 100644
index 0000000..9551c78
--- /dev/null
+++ b/Control/Monad/Adaptive.hs
@@ -0,0 +1,212 @@
+-- -*- haskell-hugs-program-args: ("+." "-98") -*-
+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
+
+-- An monadic variant of the library from "Adaptive Functional
+-- Programming", by Acar, Blelloch and Harper (POPL 2002).
+
+-- Magnus Carlsson, magnus@cse.ogi.edu
+
+module Control.Monad.Adaptive
+ ( Adaptive
+ , Changeable
+ , Modifiable
+ , readMod
+ , InM(..)
+ , change
+ , propagate
+ , run
+ , inCh
+ , NewMod(..)
+ , newMod
+
+ ) where
+
+import Prelude
+import Control.Monad(ap,unless)
+import Control.Monad.Adaptive.MonadUtil
+import Control.Monad.Adaptive.Ref
+import qualified Control.Monad.Adaptive.OrderedList as OL
+import Control.Monad.Adaptive.OrderedList(OrderedList)
+import qualified Control.Monad.Adaptive.PriorityQueue as PQ
+import Control.Monad.Adaptive.PriorityQueue(PriorityQueue)
+
+-- Export:
+class InM m' where
+ inM :: Ref m r => m a -> m' m r a
+
+class (Monad (n m r), Ref m r) => NewMod n m r where
+ newModBy :: (a -> a -> Bool) -> Changeable m r a -> n m r (Modifiable m r a)
+
+
+newMod :: (Eq a, NewMod n m r) =>
+ Changeable m r a -> n m r (Modifiable m r a)
+change :: Ref m r => Modifiable m r a -> a -> Adaptive m r ()
+propagate :: Ref m r => Adaptive m r ()
+readMod :: Ref m r => Modifiable m r a -> Changeable m r a
+run :: Ref m r => Adaptive m r a -> m a
+inCh :: Ref m r => Changeable m r a -> Adaptive m r a
+
+-- Local:
+
+type ReComp m r = (Adaptive m r (), TimeStamp m r, TimeStamp m r)
+startTime (_,s,_) = s
+
+type TimeStamp m r = OL.Record m r ()
+
+newtype Adaptive m r a =
+ Ad ((r (PriorityQueue (ReComp m r)), r (TimeStamp m r)) ->
+ OrderedList m r () a)
+
+newtype Changeable m r a = Ch (K (Adaptive m r ()) a)
+type K b a = (a -> b) -> b
+
+newtype Modifiable m r a = Mo (r a, r (a -> Adaptive m r ()), r [ReComp m r])
+
+cont :: Ref m r =>
+ ((a -> Adaptive m r ()) -> Adaptive m r ()) -> Changeable m r a
+cont m = Ch m
+
+deCh (Ch m) = m
+deAd (Ad m) = m
+
+inAd :: Ref m r => Adaptive m r a -> Changeable m r a
+inAd m = Ch $ (m >>=)
+
+class InOL m' where
+ inOL :: Ref m r => OrderedList m r () b -> m' m r b
+
+instance InOL Adaptive where
+ inOL m = Ad $ const m
+
+instance InOL Changeable where
+ inOL m = inAd (inOL m)
+
+instance Ref m r => Ref (Changeable m r) r where
+ newRef v = inM $ newRef v
+ readRef x = inM $ readRef x
+ writeRef x v = inM $ writeRef x v
+
+instance Ref m r => Monad (Changeable m r) where
+ return a = Ch $ \k -> k a
+ Ch m >>= f = Ch $ \k -> m $ \a -> deCh (f a) k
+
+instance Ref m r => Functor (Changeable m r) where
+ fmap f m = m >>= return . f
+
+instance Ref m r => Ref (Adaptive m r) r where
+ newRef v = inM $ newRef v
+ readRef x = inM $ readRef x
+ writeRef x v = inM $ writeRef x v
+
+instance Ref m r => Monad (Adaptive m r) where
+ return a = Ad $ \e -> return a
+ Ad m >>= f = Ad $ \e -> m e >>= \a -> deAd (f a) e
+
+instance Ref m r => Functor (Adaptive m r) where
+ fmap f m = m >>= return . f
+
+readMod (Mo (r,chg,es)) = do
+ start <- inAd stepTime
+ cont $ \k -> do
+ let reader = do readRef r >>= k
+ now <- readCurrentTime
+ mapRef ((reader,start,now):) es
+ reader
+
+pqRef :: Ref m r => Adaptive m r (r (PriorityQueue (ReComp m r)))
+pqRef = Ad $ \ (pq,ct) -> return pq
+
+readPq :: Ref m r => Adaptive m r (PriorityQueue (ReComp m r))
+readPq = pqRef >>= readRef
+writePq a = pqRef >>= flip writeRef a
+
+ctRef :: Ref m r => Adaptive m r (r (TimeStamp m r))
+ctRef = Ad $ \ (pq,ct) -> return ct
+readCurrentTime :: Ref m r => Adaptive m r (TimeStamp m r)
+readCurrentTime = ctRef >>= readRef
+writeCurrentTime a = ctRef >>= flip writeRef a
+
+stepTime :: Ref m r => Adaptive m r (TimeStamp m r)
+stepTime = do
+ readCurrentTime >>= inOL . flip OL.insert () >>= writeCurrentTime
+ readCurrentTime
+
+instance InM Changeable where
+ inM m = Ch $ (inM m >>=)
+
+instance InM Adaptive where
+ inM m = Ad $ const (OL.inM m)
+
+change (Mo (r,changeR,es)) a = do
+ chg <- readRef changeR
+ chg a
+
+propagate = do
+ let prop = do
+ pq <- readPq
+ case PQ.min pq of
+ Nothing -> return ()
+ Just ((reader,start,stop),pq') -> do
+ writePq pq'
+ unlessM (inOL (OL.deleted start)) $ do
+ inOL (OL.spliceOut start stop)
+ writeCurrentTime start
+ reader
+ prop
+ now <- readCurrentTime
+ prop
+ writeCurrentTime now
+
+
+run m = OL.run $ do
+ pq <- newRef PQ.empty
+ ct <- OL.base >>= newRef
+ deAd m (pq,ct)
+
+inCh (Ch m) = do
+ x <- newRef (error "inCh")
+ m (writeRef x)
+ readRef x
+
+instance EqRef r => Eq (Modifiable m r a) where
+ (Mo (r1,_,_)) == (Mo (r2,_,_)) = eqRef r1 r2
+
+newMod = newModBy (==)
+
+instance Ref m r => NewMod Changeable m r where
+ newModBy c ch = inAd $ newModBy c ch
+
+insertPQ :: Ref m r =>
+ r [ReComp m r] -> Adaptive m r ()
+insertPQ esR = do
+ es <- readRef esR
+ pqR <- pqRef
+ readRef pqR >>= ins es >>= writeRef pqR
+ where
+ ins [] pq = return pq
+ ins (e:es) pq = PQ.insertM (\x y -> inOL $
+ OL.order (startTime x) (startTime y))
+ e pq >>= ins es
+
+instance Ref m r => NewMod Adaptive m r where
+ newModBy cmp c = do
+ m <- newRef (error "newMod")
+ changeR <- newRef (error "changeR")
+ es <- newRef []
+ let writeFirst v = do
+ writeRef m v
+ now <- stepTime
+ writeRef changeR (writeAgain now)
+ writeAgain t v = do
+ v' <- readRef m
+ unless (cmp v' v) $ do
+ writeRef m v
+ insertPQ es
+ writeRef es []
+ writeCurrentTime t
+ writeRef changeR writeFirst
+ inCh $ do
+ v <- c
+ write <- readRef changeR
+ inAd $ write v
+ return (Mo (m, changeR, es))
diff --git a/Control/Monad/Adaptive/CircularList.hs b/Control/Monad/Adaptive/CircularList.hs
new file mode 100644
index 0000000..4efa75d
--- /dev/null
+++ b/Control/Monad/Adaptive/CircularList.hs
@@ -0,0 +1,72 @@
+-- -*- haskell-hugs-program-args: ("+." "-98") -*-
+
+-- A monad of mutable circular lists.
+
+module Control.Monad.Adaptive.CircularList(
+ CircularList,
+ circularList,
+ val,
+ update,
+ next,
+ previous,
+ insert,
+ delete) where
+
+import Control.Monad.Adaptive.Ref
+
+-- Export:
+circularList :: Ref m r => a -> m (CircularList m r a)
+val :: Ref m r => CircularList m r a -> m a
+next :: Ref m r => CircularList m r a -> m (CircularList m r a)
+update :: Ref m r => CircularList m r a -> a -> m ()
+previous :: Ref m r => CircularList m r a -> m (CircularList m r a)
+insert :: Ref m r => CircularList m r a -> a -> m (CircularList m r a)
+delete :: Ref m r => CircularList m r a -> m ()
+
+-- Local:
+
+data CircularList m r a = CL (r (CircularList m r a,a,CircularList m r a))
+ | DummyCL (m a)
+
+deCL (CL l) = l
+
+circularList a = do
+ r <- newRef undefined
+ let l = CL r
+ writeRef r (l,a,l)
+ return l
+
+get :: Ref m r => CircularList m r a ->
+ m (CircularList m r a, a,CircularList m r a)
+get = readRef . deCL
+
+set :: Ref m r => CircularList m r a ->
+ (CircularList m r a, a,CircularList m r a) -> m ()
+set = writeRef . deCL
+
+update l a = do
+ (p,_,n) <- get l
+ set l (p,a,n)
+
+val l = (\ (p,a,n) -> a) `fmap` get l
+
+next l = (\ (p,a,n) -> n) `fmap` get l
+
+previous l = (\ (p,a,n) -> p) `fmap` get l
+
+insert l a = do
+ (p,b,n) <- get l
+ n' <- CL `fmap` newRef (l,a,n)
+ set l (p,b,n')
+ nl <- next n'
+ (_,nb,nn) <- get nl
+ set nl (n',nb,nn)
+ return n'
+
+
+delete l = do
+ (p,_,n) <- get l
+ (pp,a,_) <- get p
+ set p (pp,a,n)
+ (_,a',nn) <- get n
+ set n (p,a',nn)
diff --git a/Control/Monad/Adaptive/MonadUtil.hs b/Control/Monad/Adaptive/MonadUtil.hs
new file mode 100644
index 0000000..71c8afd
--- /dev/null
+++ b/Control/Monad/Adaptive/MonadUtil.hs
@@ -0,0 +1,10 @@
+module Control.Monad.Adaptive.MonadUtil where
+
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM b a c = do b' <- b; if b' then a else c
+
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM b a = ifM b a (return ())
+
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM b a = ifM b (return ()) a
diff --git a/Control/Monad/Adaptive/OrderedList.hs b/Control/Monad/Adaptive/OrderedList.hs
new file mode 100644
index 0000000..69a0a9a
--- /dev/null
+++ b/Control/Monad/Adaptive/OrderedList.hs
@@ -0,0 +1,233 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+-- A monad for manipulating ordered lists. Follows the implementation
+-- given in the appendix of O'Neill's and Burton's JFP paper, but
+-- doesn't impose any fixed limit of the number of elements.
+
+-- References:
+
+-- Dietz and Sleator: "Two algorithms for maintaining order in a
+-- list", in Proc. of 19th ACM Symposium of Theory of Computing, 1987.
+
+-- O'Neill and Burton: "A New Method For Functional Arrays", Journal
+-- of Functional Programming, vol7, no 5, September 1997.
+
+module Control.Monad.Adaptive.OrderedList(
+ Record,
+ OrderedList,
+ rval,
+ next,
+ order,
+ delete,
+ spliceOut,
+ deleted,
+ insert,
+ base,
+ run,
+ inM,
+ record
+ ) where
+
+import Control.Monad(ap,unless)
+import Control.Monad.Adaptive.MonadUtil
+import Control.Monad.Adaptive.Ref
+import Control.Monad.Adaptive.CircularList hiding (delete,insert,next,update)
+import qualified Control.Monad.Adaptive.CircularList as CircularList
+
+import System.IO.Unsafe(unsafePerformIO) -- for diagnostic
+
+-- Export:
+insert :: Ref m r => Record m r a -> a -> OrderedList m r a (Record m r a)
+next :: Ref m r => Record m r a -> OrderedList m r a (Record m r a)
+delete :: Ref m r => Record m r a -> OrderedList m r a ()
+spliceOut :: Ref m r => Record m r a -> Record m r a -> OrderedList m r a ()
+deleted :: Ref m r => Record m r a -> OrderedList m r a Bool
+order :: Ref m r => Record m r a -> Record m r a ->
+ OrderedList m r a Ordering
+rval :: Ref m r => Record m r a -> OrderedList m r a a
+run :: Ref m r => OrderedList m r a b -> m b
+inM :: Ref m r => m b -> OrderedList m r a b
+base :: Ref m r => OrderedList m r a (Record m r a)
+
+
+-- Local:
+
+newtype Record m r a = Record (CircularList m r (Bool,Integer,a))
+deR (Record r) = r
+
+data OrderedList m r a b = OL ((r Integer,r Integer,Record m r a) -> m b)
+deOL (OL f) = f
+
+run l = do
+ base <- Record `fmap` circularList (False,0,undefined)
+ s <- newRef 0
+ mr <- newRef m
+ deOL l (mr,s,base)
+ where
+ m = 2^16
+
+inM m = OL $ \e -> m
+
+instance Ref m r => Monad (OrderedList m r a) where
+ return a = inM (return a)
+ (OL m) >>= f = OL $ \e -> m e >>= \a -> deOL (f a) e
+
+instance Ref m r => Functor (OrderedList m r a) where
+ fmap f m = m >>= return . f
+
+instance Ref m r => Ref (OrderedList m r a) r where
+ newRef v = inM (newRef v)
+ readRef r = inM (readRef r)
+ writeRef r v = inM (writeRef r v)
+
+mop a o b = op2 o a b
+op2 f a b = op1 f a `ap` b
+op1 f a = return f `ap` a
+
+instance Eq (OrderedList m r a b) where { }
+instance Show (OrderedList m r a b) where { }
+
+instance (Ref m r, Num b) => Num (OrderedList m r a b) where
+ (+) = op2 (+)
+ (-) = op2 (-)
+ (*) = op2 (*)
+ negate = op1 negate
+ abs = op1 abs
+ signum = op1 signum
+ fromInteger = return . fromInteger
+-- fromInt = return . fromInt
+
+instance Ord (OrderedList m r a b) where { }
+instance (Ref m r, Real b) => Real (OrderedList m r a b) where { }
+instance Enum (OrderedList m r a b) where { }
+
+instance (Ref m r, Integral b) => Integral (OrderedList m r a b) where
+ rem = op2 rem
+ div = op2 div
+ mod = op2 mod
+
+base = OL $ \(m,n,b) -> return b
+
+bigM :: Ref m r => OrderedList m r a Integer
+bigM = OL $ \(m,n,b) -> readRef m
+
+size :: Ref m r => OrderedList m r a Integer
+size = OL $ \(m,n,b) -> readRef n
+
+adjsize :: Ref m r => Integer -> OrderedList m r a ()
+adjsize i = OL $ \(m,n,b) -> do s <- readRef n
+ writeRef n (s+i)
+
+setSize :: Ref m r => Integer -> OrderedList m r a ()
+setSize n' = OL $ \(m,n,b) -> writeRef n n'
+
+record :: Ref m r => Record m r a -> OrderedList m r a (Bool,Integer,a)
+record r = inM (val (deR r))
+
+rval r = (\ (d,i,a) -> a) `fmap` record r
+
+next r = Record `fmap` inM (CircularList.next (deR r))
+
+s x = next x
+
+-- label
+l :: Ref m r => Record m r a -> OrderedList m r a Integer
+l r = (\ (d,i,a) -> i) `fmap` record r
+
+-- gap
+g e f = (l f - l e) `mod` bigM
+
+deleted r = (\ (d,i,a) -> d) `fmap` record r
+
+lbase :: Ref m r => OrderedList m r a Integer
+lbase = base >>= l
+
+gstar :: Ref m r => Record m r a -> Record m r a -> OrderedList m r a Integer
+gstar e f = ifM (mop (l e) (==) (l f))
+ bigM
+ (g e f)
+
+order x y = do b <- base
+ return (compare) `ap` g b x `ap` g b y
+
+
+
+update :: Ref m r => ((Bool,Integer)->(Bool,Integer)) ->
+ Record m r a -> OrderedList m r a ()
+update f r = do
+ (d,i,a) <- record r
+ let (d',i') = f (d,i)
+ inM (CircularList.update (deR r) (d',i',a))
+
+delete r = unlessM (deleted r) $ do
+ ifM (mop lbase (==) (l r))
+ (error "OrderedList.delete on base element")
+ (do inM (CircularList.delete (deR r))
+ update (\ (_,i) -> (True,i)) r
+ adjsize (-1)
+ checkinvariant)
+
+spliceOut r s = next r >>= spl where
+ spl r = do
+ unlessM (mop lbase (==) (l r)) $
+ whenM ((==LT) `fmap` order r s)
+ (do r' <- next r
+ delete r
+ spl r')
+
+increaseBigM :: Ref m r => OrderedList m r a ()
+increaseBigM = do OL $ \(m,n,b) -> mapRef (*2) m
+
+insert r a = do
+ ifM (deleted r)
+ (error "insert: deleted") $ do
+ whenM (mop bigM (<=) (4*(size+1)*(size+1)))
+ increaseBigM
+ r' <- s r
+ d <- gstar r r'
+ unless (d > 1)
+ (renumber r)
+ li <- (l r + (gstar r r' `div` 2)) `mod` bigM
+ inM (CircularList.insert (deR r) (False,li,a))
+ adjsize 1
+ checkinvariant
+ next r
+
+renumber :: Ref m r => Record m r a -> OrderedList m r a ()
+renumber e = do
+ let getj j e0 ej = do
+ ifM (mop (g e0 ej) (>) (return (j * j)))
+ (return (j,ej)) $ do
+ ej' <- s ej
+ ifM (mop (l ej') (==) (l e))
+ (return (j,ej)) $ do
+ getj (j+1) e0 ej'
+ (j,sje) <- s e >>= getj 1 e
+ d <- gstar e sje
+ le <- l e
+ m <- bigM
+ let ren k ek | k == j = return ()
+ | otherwise = do
+ update (const (False,(le + ((k * d) `div` j)) `mod` m)) ek
+ s ek >>= ren (k+1)
+ s e >>= ren 1
+
+checkinvariant :: Ref m r => OrderedList m r a ()
+checkinvariant = return () -- prall >> base >>= inv
+ where inv r = do
+ r' <- s r
+ unlessM (mop lbase (==) (l r')) $ do
+ ifM (mop (order r r') (==) (return LT))
+ (inv r')
+ (error "invariant")
+
+
+prall :: Ref m r => OrderedList m r a ()
+prall = uprint "prall:" >> base >>= pr where
+ pr r = do
+ x <- l r
+ uprint (show x)
+ r' <- s r
+ unlessM (mop (base >>= order r') (==) (return EQ))
+ (pr r')
+
+uprint s = OL$ (\s' -> unsafePerformIO (putStrLn s) `seq` return ())
diff --git a/Control/Monad/Adaptive/PriorityQueue.hs b/Control/Monad/Adaptive/PriorityQueue.hs
new file mode 100644
index 0000000..77bdd2a
--- /dev/null
+++ b/Control/Monad/Adaptive/PriorityQueue.hs
@@ -0,0 +1,41 @@
+
+-- A naive priority queue implementation, with an insert operation
+-- that uses a monadic comparison operation.
+
+module Control.Monad.Adaptive.PriorityQueue(
+ PriorityQueue,
+ empty,
+ insert,
+ insertM,
+ min
+ ) where
+
+import Prelude hiding(min)
+
+import qualified Data.List(insert)
+import Control.Monad(ap)
+
+-- Export:
+empty :: PriorityQueue a
+insert :: Ord a => a -> PriorityQueue a -> PriorityQueue a
+insertM :: Monad m =>
+ (a -> a -> m Ordering) -> a -> PriorityQueue a -> m (PriorityQueue a)
+min :: PriorityQueue a -> Maybe (a, PriorityQueue a)
+
+-- Local
+
+newtype PriorityQueue a = PQ [a]
+
+empty = PQ []
+
+insert a (PQ l) = PQ (Data.List.insert a l)
+
+
+insertM cmp a (PQ l) = return PQ `ap` ins l
+ where ins [] = return [a]
+ ins (b:l) = do o <- cmp a b
+ case o of LT -> return (a:b:l)
+ _ -> return (b:) `ap` ins l
+
+min (PQ []) = Nothing
+min (PQ (x:xs)) = Just (x,PQ xs)
diff --git a/Control/Monad/Adaptive/Ref.hs b/Control/Monad/Adaptive/Ref.hs
new file mode 100644
index 0000000..90b3219
--- /dev/null
+++ b/Control/Monad/Adaptive/Ref.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
+-- A class for monads with mutable references
+
+module Control.Monad.Adaptive.Ref where
+
+import Control.Monad.ST
+import Data.IORef
+import Data.STRef
+
+class EqRef r where
+ eqRef :: r a -> r a -> Bool
+
+class (EqRef r, Functor m, Monad m) => Ref m r | m -> r where
+ newRef :: a -> m (r a)
+ readRef :: r a -> m a
+ writeRef :: r a -> a -> m ()
+
+instance EqRef (STRef s) where eqRef = (==)
+
+instance Ref (ST s) (STRef s) where
+ newRef = newSTRef
+ readRef = readSTRef
+ writeRef = writeSTRef
+
+instance EqRef IORef where eqRef = (==)
+
+instance Ref IO IORef where
+ newRef = newIORef
+ readRef = readIORef
+ writeRef = writeIORef
+
+mapRef :: Ref m r => (a -> a) -> r a -> m ()
+mapRef f r = readRef r >>= writeRef r . f
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..cba73bd
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,29 @@
+Copyright 2002-2008 Magnus Carlsson <magnus@galois.com>
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+ notice, this list of conditions and the following disclaimer in the
+ documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/README b/README
new file mode 100644
index 0000000..fb695dd
--- /dev/null
+++ b/README
@@ -0,0 +1,54 @@
+Adaptive version 0.23 2013-01-26
+================================
+
+This is a minor update to Adaptive version 0.22 to make it work with
+recent versions of GHC. Any problems with the result is my fault.
+
+Paolo G. Giarrusso, p.giarrusso@gmail.com
+
+Adaptive version 0.22 2008-07-14
+================================
+
+This is a minor update to Adaptive version 0.21 to make it work with
+recent versions of GHC and Hugs. Adaptive is now cabalized, and any
+problems with the packaging is my fault, not Magnus.
+
+Peter A. Jonsson, pj@csee.ltu.se
+
+
+Adaptive version 0.21 2005-07-09
+=================================
+
+This is a Haskell (plus some extensions) implementation of a library
+for incremental computing. It closely follows the implementation in
+the nice POPL 2002 paper "Adaptive Functional Programming", by Umut
+Acar, Guy Blelloch and Bob Harper. As of writing, their paper can be
+found at
+
+ http://ttic.uchicago.edu/~umut/papers/popl02.html
+
+However, this Haskell library provides a monadic interface, which
+doesn't need the "write" operation or the "destination" type. In
+addition, the monadic types enforce correct usage, which means that a
+modifiable variable must be defined before it can be used. This is
+achieved within Haskell's type system plus some popular extensions
+(multi-parameter classes and functional dependencies).
+
+The library is parameterised over any monad that has references (such
+as IO and ST). This means that it should be possible to put it on top
+of e.g. many GUI monads too.
+
+There is a small demo program of a classical incremental computation
+problem: a spreadsheet. Try it by typing
+
+ runhugs -98 spreadsheet.hs
+
+and type, say
+
+ c0 <Return> Cell c1 <Return> c1 <Return> Const 42 <Return>.
+
+This has been tested with the Hugs September 2006 version.
+
+Feedback is welcome!
+
+Magnus Carlsson, magnus@galois.com
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
index 0000000..6b32049
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,4 @@
+#! /usr/bin/env runhaskell
+
+> import Distribution.Simple
+> main = defaultMain
diff --git a/spreadsheet.hs b/spreadsheet.hs
new file mode 100644
index 0000000..a6991ec
--- /dev/null
+++ b/spreadsheet.hs
@@ -0,0 +1,124 @@
+-- -*- haskell-hugs-program-args: ("+." "-98") -*-
+{-# LANGUAGE FlexibleContexts #-}
+
+-- A demo program of the Adaptive library, implementing a simple
+-- spreadsheet. Requires a VT100-like terminal to work. Expressions
+-- have to be entered according to the Expr datatype.
+
+-- Magnus Carlsson, magnus@cse.ogi.edu
+
+import Control.Monad.Adaptive
+import Data.Char
+import Control.Monad.Adaptive.Ref
+import Control.Monad(ap,when)
+import Data.IORef(IORef)
+import System.Exit
+
+type InIO m a = m IO IORef a
+type IOMod a = InIO Modifiable a
+
+data CellRef = CR String (IOMod Integer) deriving Eq
+instance Show CellRef where show (CR s _) = s
+
+data Expr c = Const Integer | Add (Expr c) (Expr c) | Cell c
+ deriving (Eq,Read,Show)
+
+eval :: Expr CellRef -> InIO Changeable Integer
+eval (Const i) = return i
+eval (Add e1 e2) = return (+) `ap` eval e1 `ap` eval e2
+eval (Cell (CR _ n)) = readMod n
+
+memo ma = readMod =<< newMod ma
+
+instance Eq (a -> b) where a == b = False
+
+ap' mf ma = do
+ m <- newMod mf
+ a <- memo ma
+ f <- readMod m
+ return (f a)
+
+newCell :: NewMod m IO IORef =>
+ String -> InIO m (IOMod (Expr CellRef), CellRef)
+newCell s = do
+ c <- newMod (return (Const 0))
+ v <- newMod $ readMod c >>= eval
+ return (c,CR s v)
+
+newCell' n = do
+ let s = "c" ++ show n
+ inM $ prAt (n+2) 0 3 (s++": ")
+ a@(c,CR s v) <- newCell s
+ newMod $ readMod v >>= inM . prAt (n+2) 5 10 . show
+ newMod $ readMod c >>= inM . prAt (n+2) 15 40 . show
+ return (s,a)
+
+prAt l c w s = putStr (pos l c ++ replicate w ' ' ++ pos l c++s)
+esc = ("\ESC["++)
+pos l c = esc (show l++";"++show c++"H")
+clear = pos 0 0 ++ esc "J"
+cleareol = esc "K"
+
+readPrompt c s = do prAt 20 c 0 (s++"> "++ cleareol)
+ s <- getLine
+ when (s == "quit") $ exitWith ExitSuccess
+ return s
+
+msg s = prAt 19 0 0 (s ++ cleareol)
+
+prompt env = inM p where
+ p = do s <- readPrompt 0 "Cell"
+ case lookup s env of
+ Nothing -> do msg ("Cell " ++ show s ++ " not found")
+ p
+ Just (c,v) -> do let r = do s <- readPrompt 10 "Expr"
+ case reads s of
+ [(e,"")] -> msg "" >> return (c,e)
+ _ -> do msg "Syntax error"
+ r
+ r
+
+data CellName = CN String
+instance Read CellName where readsPrec _ s = [(CN $ takeWhile isAlphaNum s',
+ dropWhile isAlphaNum s')]
+ where s' = dropWhile isSpace s
+
+instance Show CellName where show (CN s) = s
+
+subst m env (Const i) = Const i
+subst m env (Add e1 e2) = Add (subst m env e1) (subst m env e2)
+subst m env (Cell (CN s)) = Cell $ case lookup s env of
+ Nothing -> m
+ Just (c,v) -> v
+
+main :: IO ()
+main = run $ do
+ inM $ putStr clear
+ env <- mapM newCell' [0..9]
+ m0 <- CR "?" `fmap` newMod (return 0)
+ let loop = do (c,e) <- prompt env
+ let e' = subst m0 env e
+ change c e'
+ propagate
+ loop
+ loop
+
+-- small non-interactive example
+
+newCellPr s = do
+ a@(c,CR s v) <- newCell s
+ newMod $ do e <- readMod c
+ x <- readMod v
+ inM $ putStrLn (s++" = "++show e ++ " = " ++ show x)
+ return a
+
+test = run $ do
+ [(c1,v1),(c2,v2)] <- mapM newCellPr ["c1","c2"]
+ change c1 (Const 10)
+ change c2 (Add (Cell v1) (Const 5))
+ inM (putStrLn "Propagate") >> propagate
+ change c1 (Add (Cell v2) (Const 4))
+ change c2 (Const 1)
+ inM (putStrLn "Propagate") >> propagate
+ change c2 (Const 2)
+ inM (putStrLn "Propagate") >> propagate