[Haskell-cafe] Re: FRP for game programming / artifical life simulation

[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