Adaptive 0.1 → 0.22

raw patch · 14 files changed

+827/−506 lines, 14 filesdep +haskell98dep ~basesetup-changednew-component:exe:spreadsheetnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: haskell98

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Adaptive.cabal +16/−57
• ChangeLog +12/−0
• Control/Monad/Adaptive.hs +212/−0
• Control/Monad/Adaptive/CircularList.hs +72/−0
• Control/Monad/Adaptive/MonadUtil.hs +10/−0
• Control/Monad/Adaptive/OrderedList.hs +233/−0
• Control/Monad/Adaptive/PriorityQueue.hs +41/−0
• Control/Monad/Adaptive/Ref.hs +33/−0
• Data/Adaptive.hs +0/−287
• LICENSE +24/−160
• README +46/−0
• Setup.hs +0/−2
• Setup.lhs +4/−0
• spreadsheet.hs +124/−0

@@ -1,61 +1,20 @@--- Adaptive.cabal auto-generated by cabal init. For additional--- options, see--- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.--- The name of the package. Name:                Adaptive---- The package version. See the Haskell package versioning policy--- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for--- standards guiding when and how versions should be incremented.-Version:             0.1---- A short (one-line) description of the package.-Synopsis:            Adaptive precision floating-point arithmetic---- A longer description of the package.-Description:         Lazy arithmetic computed with as much precision as demanded ---- URL for the project homepage or repository.-Homepage:            http://github.com/HackerFoo/Adaptive---- The license under which the package is released.-License:             LGPL-3---- The file containing the license text.+Version:             0.22+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.+License:             BSD3 License-file:        LICENSE---- The package author(s).-Author:              Dustin DeWeese---- An email address to which users can send suggestions, bug reports,--- and patches.-Maintainer:          dustin.deweese@gmail.com---- A copyright notice.--- Copyright:           --Category:            Data--Build-type:          Simple---- Extra files to be distributed with the package, such as examples or--- a README.--- Extra-source-files:  ---- Constraint on the version of Cabal needed to build this package.-Cabal-version:       >=1.4+Author:              Magnus Carlsson+Maintainer:          Magnus Carlsson <magnus@galois.com>+Build-Depends:       base, haskell98+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+data-files:	     ChangeLog, README+build-type:	     Simple +Executable:          spreadsheet+Main-is:             spreadsheet.hs -Library-  -- Modules exported by the library.-  Exposed-modules:     Data.Adaptive-  -  -- Packages needed in order to build this package.-  Build-depends:       base >= 4 && < 5-  -  -- Modules not exported by this package.-  -- Other-modules:       -  -  -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.-  -- Build-tools:         -  

@@ -0,0 +1,12 @@+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.

@@ -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 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))

@@ -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)

@@ -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

@@ -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 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 ())

@@ -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 List(insert)+import 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 (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)

@@ -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

@@ -1,287 +0,0 @@-{-  -    This file is part of Adaptive.--    Adaptive is free software: you can redistribute it and/or modify-    it under the terms of the GNU Lesser General Public License as published by-    the Free Software Foundation, either version 3 of the License, or-    (at your option) any later version.--    Adaptive is distributed in the hope that it will be useful,-    but WITHOUT ANY WARRANTY; without even the implied warranty of-    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-    GNU Lesser General Public License for more details.--    You should have received a copy of the GNU Lesser General Public License-    along with Adaptive.  If not, see <http://www.gnu.org/licenses/>.--}--{-# LANGUAGE FlexibleInstances, BangPatterns, UnboxedTuples #-}-{-# OPTIONS_GHC -fno-excess-precision -fno-spec-constr #-}--- {-# OPTIONS_GHC -fglasgow-exts -fno-excess-precision -fno-spec-constr #-}--- use SSE to avoid the excess precision of the 387 FPU--- {-# OPTIONS_GHC -fvia-C -optc-O -optc-ffast-math -optc-mfpmath=sse -optc-msse #-}--- {-# OPTIONS_GHC -fllvm -optlc-mattr=+sse4a -optlc--disable-excess-fp-precision #-}---- | Based on Adaptive Precision Floating-Point Arithmetic and Fast Robust Geometric Predicates, Jonathan Richard Shewchuk, 1997-module Data.Adaptive (Adaptive(..), fromFloatingPoint, approx, approx', approxFast, splitter, epsilon) where--import Data.List-import Data.Bits-import Data.Ratio--type FloatT = Double----mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-mergeBy _ xs [] = xs-mergeBy _ [] ys = ys-mergeBy cmp (x:xs) (y:ys) = case cmp x y of-                              GT -> y : mergeBy cmp (x:xs) ys-                              _ -> x : mergeBy cmp xs (y:ys)--newtype Adaptive a = Adaptive [a]--instance (Show a, RealFloat a) => Show (Adaptive a) where-  showsPrec n x = showParen (n > 6 && x < 0) $ showsPrec 0 (approx x) . ('~':)--------------------------- approximate instances ---------------------------liftAdaptive1 f = fromFloatingPoint . f . approxFast-liftAdaptive2 f x y = fromFloatingPoint $ approxFast x `f` approxFast y--instance (RealFloat a, Real a) => Real (Adaptive a) where-  toRational = toRational . approxFast--instance (RealFloat a, Floating a) => Floating (Adaptive a) where-  pi = fromFloatingPoint pi-  exp = liftAdaptive1 exp-  sqrt = sqrtA-  log = liftAdaptive1 log-  (**) = liftAdaptive2 (**)-  logBase = liftAdaptive2 logBase-  sin = liftAdaptive1 sin-  tan = liftAdaptive1 tan-  cos = liftAdaptive1 cos-  asin = liftAdaptive1 asin-  atan = liftAdaptive1 atan-  acos = liftAdaptive1 acos-  sinh = liftAdaptive1 sinh-  tanh = liftAdaptive1 tanh-  cosh = liftAdaptive1 cosh-  asinh = liftAdaptive1 asinh-  atanh = liftAdaptive1 atanh-  acosh = liftAdaptive1 acosh--instance (RealFloat a) => RealFloat (Adaptive a) where-  floatRadix = floatRadix . approxFast-  floatDigits = floatDigits . approxFast-  floatRange = floatRange . approxFast-  decodeFloat = decodeFloat . approxFast-  encodeFloat s r = fromFloatingPoint (encodeFloat s r)-  exponent = exponent . approxFast-  significand = liftAdaptive1 significand-  scaleFloat x = liftAdaptive1 (scaleFloat x)-  isNaN = isNaN . approxFast-  isInfinite = isInfinite . approxFast-  isDenormalized = isDenormalized . approxFast-  isNegativeZero = isNegativeZero . approxFast-  isIEEE = isIEEE . approxFast-  atan2 = liftAdaptive2 atan2--instance (RealFloat a, RealFrac a) => RealFrac (Adaptive a) where-  properFraction x = (y, fromFloatingPoint x')-    where (y, x') = properFraction (approxFast x)-----------------------------------------------------------------------------instance (Num a, RealFloat a) => Eq (Adaptive a) where-  {-# SPECIALIZE instance Eq (Adaptive FloatT) #-}-  a == b | null x = True-         | otherwise = False-    where Adaptive x = a - b--instance (Num a, RealFloat a) => Ord (Adaptive a) where-  {-# SPECIALIZE instance Ord (Adaptive FloatT) #-}-  compare a b | null x = EQ-              | head x > 0 = GT-              | otherwise = LT-    where Adaptive x = a - b--instance (Num a, RealFloat a) => Num (Adaptive a) where-  {-# SPECIALIZE instance Num (Adaptive FloatT) #-}-  Adaptive x + Adaptive y = Adaptive . compress $ fastExpSum x y-  Adaptive x - Adaptive y = Adaptive x + Adaptive (map negate y)-  Adaptive x * Adaptive y = Adaptive $ expProd x y-  negate (Adaptive x) = Adaptive (map negate x)-  abs (Adaptive []) = Adaptive []-  abs (Adaptive x) | head x < 0 = Adaptive (map negate x)-                   | otherwise = Adaptive x-  signum (Adaptive []) = Adaptive []-  signum (Adaptive (x:_)) = Adaptive [signum x]-  fromInteger 0 = Adaptive []-  fromInteger x = Adaptive [fromInteger x]--instance (RealFloat a, Fractional a) => Fractional (Adaptive a) where-  {-# SPECIALIZE instance Fractional (Adaptive FloatT) #-}-  fromRational r = fromIntegral (numerator r) / fromIntegral (denominator r)-  a / b = Adaptive $ a `divA` b--{-# SPECIALIZE divA :: Adaptive FloatT -> Adaptive FloatT -> [FloatT] #-}-divA x y | d == 0 = []-         | e == 0 || abs e >= abs x = [d]-         | otherwise = d : divA e y-  where d = approxFast x / approxFast y-        e = x - fromFloatingPoint d * y---- | Use Babylonian method to calculate corrections to built in sqrt-{-# SPECIALIZE sqrtA :: Adaptive FloatT -> Adaptive FloatT #-}-sqrtA x = r + bab r-  where r = liftAdaptive1 sqrt x-        bab e | c == 0 = 0-              | otherwise = c + bab (e + c)-          where c = (x / e - e) / 2--{-# SPECIALIZE epsilon :: FloatT #-}-epsilon :: (RealFloat a) => a-epsilon = x-  where x = scaleFloat (- floatDigits x) 1--{-# SPECIALIZE splitter :: FloatT #-}-splitter :: (RealFloat a) => a-splitter = s-  where s = scaleFloat ((floatDigits s + 1) `shiftR` 1) 1 + 1---- {-# INLINE fromFloatingPoint #-}-{-# SPECIALIZE fromFloatingPoint :: FloatT -> Adaptive FloatT #-}-fromFloatingPoint :: (RealFloat a) => a -> Adaptive a-fromFloatingPoint 0 = Adaptive []-fromFloatingPoint x = Adaptive [x]--{-# INLINE approx #-}--- {-# SPECIALIZE approx :: Adaptive FloatT -> FloatT #-}-approx :: (RealFloat a, Ord a) => Adaptive a -> a-approx (Adaptive []) = 0-approx (Adaptive (x:xs)) = foldr (+) x . takeWhile ((> x*epsilon).abs) $ xs--{-# INLINE approx' #-}--- {-# SPECIALIZE approx' :: Adaptive FloatT -> FloatT #-}-approx' :: (Real a, RealFloat b) => Adaptive a -> b-approx' (Adaptive []) = 0-approx' (Adaptive (x:xs)) = foldr (+) x' .-                            takeWhile ((> x' * epsilon) . abs) .-                            map realToFrac $ xs-  where x' = realToFrac x---- {-# INLINE approxFast #-}-{-# SPECIALIZE approxFast :: Adaptive FloatT -> FloatT #-}-approxFast :: (Num a) => Adaptive a -> a-approxFast (Adaptive []) = 0-approxFast (Adaptive (x:_)) = x---- |a| >= [b]-{-# INLINE fastTwoSum #-}---{-# SPECIALIZE fastTwoSum :: FloatT -> FloatT -> (# FloatT, FloatT #) #-}-fastTwoSum :: (Num a) => a -> a -> (# a, a #)-fastTwoSum a b = (# x, y #)-  where x = a + b-        b' = x - a-        y = b - b'--{-# INLINE twoSum #-}---{-# SPECIALIZE twoSum :: FloatT -> FloatT -> (# FloatT, FloatT #) #-}-twoSum :: (Num a) => a -> a -> (# a, a #)-twoSum !a !b = (# x, y #)-  where !x = a + b-        !b' = x - a-        !a' = x - b'-        !br = b - b'-        !ar = a - a'-        !y = ar + br--{--{-# INLINE twoSum' #-}---{-# SPECIALIZE twoSum' :: FloatT -> FloatT -> (FloatT, FloatT) #-}-twoSum' :: (Num a) => a -> a -> (a, a)-twoSum' a b = (x, y)-  where x = a + b-        b' = x - a-        a' = x - b'-        br = b - b'-        ar = a - a'-        y = ar + br----{-# SPECIALIZE growExp :: FloatT -> [FloatT] -> [FloatT] #-}-growExp :: (Num a) => a -> [a] -> [a]-growExp b es = filter (/= 0) . uncurry (:) . mapAccumR twoSum' b $ es----{-# SPECIALIZE expSum :: [FloatT] -> [FloatT] -> [FloatT] #-}-expSum :: (Num a) => [a] -> [a] -> [a]-expSum = foldr growExp--}--{-# SPECIALIZE fastExpSum :: [FloatT] -> [FloatT] -> [FloatT] #-}-fastExpSum :: (RealFloat a) => [a] -> [a] -> [a]-fastExpSum [] x = x-fastExpSum x [] = x-fastExpSum e f = filter (/= 0) (q:hs)-  where g = mergeBy cmp e f-        cmp x y = compare (exponent y) (exponent x)-        (# q, hs #) = mapAccumR1 twoSum g----mapAccumR1 :: (t -> t -> (# t, a #)) -> [t] -> (# t, [a] #)-mapAccumR1 f [x] = (# x, [] #)-mapAccumR1 f (x:xs) = (# a', y:xs' #)-  where (# a, xs' #) = mapAccumR1 f xs-        (# a', y #) = f a x----{-# INLINE split #-}---{-# SPECIALIZE split :: FloatT -> (# FloatT, FloatT #) #-}---split :: (RealFloat a) => a -> (# a, a #)-split !a = (# ah, al #)-  where !c = splitter * a-        !ab = c - a-        !ah = c - ab-        !al = a - ah----{-# INLINE twoProd #-}---{-# SPECIALIZE twoProd :: FloatT -> FloatT -> (# FloatT, FloatT #) #-}---twoProd :: (RealFloat a) => a -> a -> (# a, a #)-twoProd !a !b = (# x, y #)-  where !x = a * b-        (# !ah, !al #) = split a-        (# !bh, !bl #) = split b-        !err = x - ah * bh - al * bh - ah * bl-        !y = al * bl - err----{-# INLINE scaleExp #-}---{-# SPECIALIZE scaleExp :: FloatT -> [FloatT] -> [FloatT] #-}---scaleExp :: (RealFloat a) => a -> [a] -> [a]-scaleExp _ [] = []-scaleExp b es = filter (/= 0) . (uncurry (:)) . foldr f (q0, [h0]) . init $ es-  where (# q0, h0 #) = twoProd (last es) b-        f e (q, h) = (q'', h2 : h1 : h)-          where (# th, tl #) = twoProd e b-                (# q', h1 #) = twoSum q tl-                (# q'', h2 #) = fastTwoSum th q'----{-# INLINE expProd #-}---{-# SPECIALIZE expProd :: [FloatT] -> [FloatT] -> [FloatT] #-}---expProd :: (RealFloat a) => [a] -> [a] -> [a]-expProd [] _ = []-expProd _ [] = []-expProd x [y] = scaleExp y x-expProd [x] y = scaleExp x y-expProd (x:xs) ys = foldl' f (scaleExp x ys) xs-  where f h e = fastExpSum h . scaleExp e $ ys----{-# SPECIALIZE compress :: [FloatT] -> [FloatT] #-}---compress :: (Num a) => [a] -> [a]-compress e = comp up . comp down $ e-  where comp _ [] = []-        comp _ [x] = [x]-        comp f (x:xs) = uncurry (:) . foldl' f (x, []) $ xs-        down (q, h) e | ql /= 0 = (ql, qu:h)-                      | otherwise = (qu, h)-          where (# qu, ql #) = fastTwoSum q e-        up (q, h) e | ql /= 0 = (qu, ql:h) -- error on pg. 28, line 14: Q should be q-                    | otherwise = (qu, h)-          where (# qu, ql #) = fastTwoSum e q

@@ -1,165 +1,29 @@-                  GNU LESSER GENERAL PUBLIC LICENSE-                       Version 3, 29 June 2007-- Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>- Everyone is permitted to copy and distribute verbatim copies- of this license document, but changing it is not allowed.---  This version of the GNU Lesser General Public License incorporates-the terms and conditions of version 3 of the GNU General Public-License, supplemented by the additional permissions listed below.--  0. Additional Definitions. --  As used herein, "this License" refers to version 3 of the GNU Lesser-General Public License, and the "GNU GPL" refers to version 3 of the GNU-General Public License.--  "The Library" refers to a covered work governed by this License,-other than an Application or a Combined Work as defined below.--  An "Application" is any work that makes use of an interface provided-by the Library, but which is not otherwise based on the Library.-Defining a subclass of a class defined by the Library is deemed a mode-of using an interface provided by the Library.--  A "Combined Work" is a work produced by combining or linking an-Application with the Library.  The particular version of the Library-with which the Combined Work was made is also called the "Linked-Version".--  The "Minimal Corresponding Source" for a Combined Work means the-Corresponding Source for the Combined Work, excluding any source code-for portions of the Combined Work that, considered in isolation, are-based on the Application, and not on the Linked Version.--  The "Corresponding Application Code" for a Combined Work means the-object code and/or source code for the Application, including any data-and utility programs needed for reproducing the Combined Work from the-Application, but excluding the System Libraries of the Combined Work.--  1. Exception to Section 3 of the GNU GPL.--  You may convey a covered work under sections 3 and 4 of this License-without being bound by section 3 of the GNU GPL.--  2. Conveying Modified Versions.--  If you modify a copy of the Library, and, in your modifications, a-facility refers to a function or data to be supplied by an Application-that uses the facility (other than as an argument passed when the-facility is invoked), then you may convey a copy of the modified-version:--   a) under this License, provided that you make a good faith effort to-   ensure that, in the event an Application does not supply the-   function or data, the facility still operates, and performs-   whatever part of its purpose remains meaningful, or--   b) under the GNU GPL, with none of the additional permissions of-   this License applicable to that copy.--  3. Object Code Incorporating Material from Library Header Files.--  The object code form of an Application may incorporate material from-a header file that is part of the Library.  You may convey such object-code under terms of your choice, provided that, if the incorporated-material is not limited to numerical parameters, data structure-layouts and accessors, or small macros, inline functions and templates-(ten or fewer lines in length), you do both of the following:--   a) Give prominent notice with each copy of the object code that the-   Library is used in it and that the Library and its use are-   covered by this License.--   b) Accompany the object code with a copy of the GNU GPL and this license-   document.--  4. Combined Works.--  You may convey a Combined Work under terms of your choice that,-taken together, effectively do not restrict modification of the-portions of the Library contained in the Combined Work and reverse-engineering for debugging such modifications, if you also do each of-the following:--   a) Give prominent notice with each copy of the Combined Work that-   the Library is used in it and that the Library and its use are-   covered by this License.--   b) Accompany the Combined Work with a copy of the GNU GPL and this license-   document.--   c) For a Combined Work that displays copyright notices during-   execution, include the copyright notice for the Library among-   these notices, as well as a reference directing the user to the-   copies of the GNU GPL and this license document.--   d) Do one of the following:--       0) Convey the Minimal Corresponding Source under the terms of this-       License, and the Corresponding Application Code in a form-       suitable for, and under terms that permit, the user to-       recombine or relink the Application with a modified version of-       the Linked Version to produce a modified Combined Work, in the-       manner specified by section 6 of the GNU GPL for conveying-       Corresponding Source.--       1) Use a suitable shared library mechanism for linking with the-       Library.  A suitable mechanism is one that (a) uses at run time-       a copy of the Library already present on the user's computer-       system, and (b) will operate properly with a modified version-       of the Library that is interface-compatible with the Linked-       Version. --   e) Provide Installation Information, but only if you would otherwise-   be required to provide such information under section 6 of the-   GNU GPL, and only to the extent that such information is-   necessary to install and execute a modified version of the-   Combined Work produced by recombining or relinking the-   Application with a modified version of the Linked Version. (If-   you use option 4d0, the Installation Information must accompany-   the Minimal Corresponding Source and Corresponding Application-   Code. If you use option 4d1, you must provide the Installation-   Information in the manner specified by section 6 of the GNU GPL-   for conveying Corresponding Source.)--  5. Combined Libraries.--  You may place library facilities that are a work based on the-Library side by side in a single library together with other library-facilities that are not Applications and are not covered by this-License, and convey such a combined library under terms of your-choice, if you do both of the following:--   a) Accompany the combined library with a copy of the same work based-   on the Library, uncombined with any other library facilities,-   conveyed under the terms of this License.+Copyright 2002-2008 Magnus Carlsson <magnus@galois.com>+All rights reserved. -   b) Give prominent notice with the combined library that part of it-   is a work based on the Library, and explaining where to find the-   accompanying uncombined form of the same work.+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met: -  6. Revised Versions of the GNU Lesser General Public License.+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer. -  The Free Software Foundation may publish revised and/or new versions-of the GNU Lesser General Public License from time to time. Such new-versions will be similar in spirit to the present version, but may-differ in detail to address new problems or concerns.+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. -  Each version is given a distinguishing version number. If the-Library as you received it specifies that a certain numbered version-of the GNU Lesser General Public License "or any later version"-applies to it, you have the option of following the terms and-conditions either of that published version or of any later version-published by the Free Software Foundation. If the Library as you-received it does not specify a version number of the GNU Lesser-General Public License, you may choose any version of the GNU Lesser-General Public License ever published by the Free Software Foundation.+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. -  If the Library as you received it specifies that a proxy can decide-whether future versions of the GNU Lesser General Public License shall-apply, that proxy's public statement of acceptance of any version is-permanent authorization for you to choose that version for the-Library.+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.

@@ -0,0 +1,46 @@+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

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain

@@ -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 Monad(ap,when)+import Data.IORef(IORef)+import System++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