Lane --
Thanks for the suggestion, I'll take a closer look shortly. At the
moment I have to confess to not exactly understanding what your code
is doing, it's a little "hairy" for me? Right now I'm going to focus
on what Felipe has given me, it fits in nicely with the arrow
framework, which I'm excited about.
Thanks all for your help. I'm sure I'll have more questions soon enough!
Best, B
On Thu, Apr 29, 2010 at 10:06 AM, Christopher Lane Hinson
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