On Wed, 28 Apr 2010, Ben wrote:
thanks for the comments, i'll try to respond to them all. but to
start off with, let me mention that my ultimate goal is to have a way
of writing down causal and robust (restartable) computations which
happen on infinite streams of data "in a nice way" -- by which i mean
the declarative / whole-meal style ala Bird. loosely, these are
functions [a] -> [b] on infinite lists; the causal constraint just
means that the output at time (index) t only depends on the inputs for
times (indices) <= t.
the catch is the robust bit. by robust, i mean i need to be able to
suspend the computation, and restart it where it left off (the data
might be only sporadically or unreliably available, the computation
needs to be able to survive machine reboots.) unfortunately the
obvious way (to me) of writing down such suspendible computations is
to use explicit state-machines, e.g. to reify function computation as
data, and save that. this is unfortunately very piece-meal and
imperative.
Ben,
Do you want this?
{-# LANGUAGE TypeFamilies, Rank2Types, GeneralizedNewtypeDeriving #-}
module Hairball
(Operator(..),Hairball,Value,alpha,beta,Operation,apply,buildHairball) where
import Control.Monad
import Control.Monad.State
class Operator o where
type Domain o :: *
operation :: o -> Domain o -> Domain o -> (Domain o,o)
data Hairball o = Hairball {
hair_unique_supply :: Int,
hair_map :: [(Int,Int,Int,o)],
hair_output :: Int }
deriving (Read,Show)
data Value e = Value { address :: Int }
alpha :: Value e
alpha = Value 0
beta :: Value e
beta = Value 1
newtype Operation e o a = Operation { fromOperation :: State (Hairball o) a
} deriving (Monad,MonadFix)
apply :: o -> Value e -> Value e -> Operation e o (Value e)
apply op v1 v2 =
do hair <- Operation get
Operation $ put $ hair {
hair_unique_supply = succ $ hair_unique_supply hair,
hair_map = (hair_unique_supply hair,address v1,address
v2,op) : hair_map hair }
return $ Value $ hair_unique_supply hair
buildHairball :: (forall e. Operation e o (Value e)) -> Hairball o
buildHairball o = hair { hair_output = address v, hair_map = reverse $
hair_map hair }
where (v,hair) = runState (fromOperation o) (Hairball 2 [] $ error
"Hairball: impossible: output value undefined")
instance Operator o => Operator (Hairball o) where
type Domain (Hairball o) = Domain o
operation hair v1 v2 = (fst $ results !! hair_output hair, hair {
hair_map = drop 2 $ map snd results })
where results = (v1,undefined):(v2,undefined):flip map (hair_map
hair) (\(i,s1,s2,o) ->
let (r,o') = operation o (fst $ results !! s1)
(fst $ results !! s2)
in (r,(i,s1,s2,o')))
{-# LANGUAGE TypeFamilies, DoRec #-}
module Numeric () where
import Prelude hiding (subtract)
import Hairball
data Numeric n = Add | Subtract | Multiply | Delay n deriving (Read,Show)
instance (Num n) => Operator (Numeric n) where
type Domain (Numeric n) = n
operation Add x y = (x+y,Add)
operation Subtract x y = (x-y,Subtract)
operation Multiply x y = (x*y,Multiply)
operation (Delay x) x' _ = (x,Delay x')
type NumericOperation e n = Operation e (Numeric n)
type NumericHairball n = Hairball (Numeric n)
add :: Value e -> Value e -> NumericOperation e n (Value e)
add v1 v2 = apply Add v1 v2
subtract :: Value e -> Value e -> NumericOperation e n (Value e)
subtract v1 v2 = apply Subtract v1 v2
multiply :: Value e -> Value e -> NumericOperation e n (Value e)
multiply v1 v2 = apply Multiply v1 v2
delay :: n -> Value e -> NumericOperation e n (Value e)
delay initial_value v1 = apply (Delay initial_value) v1 alpha
integratorProgram :: String
integratorProgram = show $ buildHairball $
do rec prev_beta <- delay 0 beta
d_beta <- subtract beta prev_beta
add_alpha <- multiply alpha d_beta
prev_sum <- delay 0 sum
sum <- add prev_sum add_alpha
return sum
runNumericProgram :: (Read n,Show n,Num n) => String -> n -> n -> (n,String)
runNumericProgram program value time = (result,show hairball')
where hairball :: (Read n) => NumericHairball n
hairball = read program
(result,hairball') = operation hairball value time
numericStream :: (Read n,Show n,Num n) => [(n,n)] -> (n,String) ->
(n,String)
numericStream [] (n,s) = (n,s)
numericStream ((a,t):ats) (_,s) = numericStream ats $ runNumericProgram s a
t
