OpenNaSch.hs

import System.Random
import Control.Monad.Random

import qualified Data.Map.Lazy as Map
import Data.Map.Lazy (Map)
import Data.Maybe
import Data.Traversable as T

-- for the moment consider this a constant
max_speed = 2

data Headway = Headway Int | ClearHeadway

-- this is to fix what getRandom returns
getRandomDouble :: RandomGen g => Rand g Double
getRandomDouble = getRandom

data Vehicle = Vehicle Int
	deriving (Show)

getSpeed (Vehicle speed) = speed

newVehicle = Vehicle 0

updateSpeed (Vehicle speed) ClearHeadway = Vehicle safe_speed
	where
		safe_speed = min (speed + 1) max_speed

updateSpeed (Vehicle speed) (Headway h) = Vehicle safe_speed
	where
		safe_speed = min (speed + 1) $ min max_speed h

randomUpdateSpeed (Vehicle speed) ClearHeadway = do
	let safe_speed = min (speed + 1) max_speed
	x <- getRandomDouble
	let new_speed = if x < 0.5 then max (safe_speed - 1) 0 else safe_speed
	return (Vehicle new_speed)

randomUpdateSpeed (Vehicle speed) (Headway h) = do
	let safe_speed = min (speed + 1) $ min max_speed h
	x <- getRandomDouble
	let new_speed = if x < 0.5 then max (safe_speed - 1) 0 else safe_speed
	return (Vehicle new_speed)

type IntMap = Map Int
data Lane = Lane (IntMap Vehicle) (IntMap Int) Int
	deriving (Show)

newLane = Lane vehicles positions 0
	where
		vehicles = Map.singleton 0 newVehicle
		positions = Map.singleton 0 0

-- this doesn't check that canInsert lane returns true
pushVehicle (Lane vehicles positions first_vehicle) vehicle =
	Lane new_vehicles new_positions new_first_vehicle
	where
		new_vehicles = Map.insert new_first_vehicle vehicle vehicles
		new_positions = Map.insert new_first_vehicle 0 positions
		new_first_vehicle = first_vehicle - 1

headway (Lane _ _ _) 0 = ClearHeadway
headway (Lane _ positions _) i = Headway (x - y)
	where
		Just x = Map.lookup (i + 1) positions
		Just y = Map.lookup i positions

canInsert (Lane _ positions first_vehicle) = k /= 0
	where
		Just k = Map.lookup first_vehicle positions

originUpdate :: RandomGen g => Lane -> Rand g Lane
originUpdate lane = case canInsert lane of
	True -> do
		x <- getRandomDouble
		return $ if x > 0.5 then pushVehicle lane newVehicle else lane
	False -> return lane

bulkUpdate :: RandomGen g => Lane -> Rand g Lane
bulkUpdate lane@(Lane vehicles positions first_vehicle) = do
	new_vehicles <- Map.traverseWithKey (\i v -> randomUpdateSpeed v (headway lane i)) vehicles
	let update_position i p = p + (getSpeed $ fromJust $ Map.lookup i new_vehicles)
	let new_positions = Map.mapWithKey update_position positions
	return $ Lane new_vehicles new_positions first_vehicle

parallelUpdate:: RandomGen g => Lane -> Rand g Lane
parallelUpdate lane = do
	-- there should be a way to just write this as a composition right?
	l1 <- originUpdate lane
	l2 <- bulkUpdate l1
	return l2

iterateM :: Monad m => (a -> m a) -> a -> m [a]
iterateM f init = do
    x <- f init
    xs <- iterateM f x
    return (x:xs)

stream :: RandomGen g => Rand g [Lane]
stream = iterateM parallelUpdate newLane

compute n g = take n (map someAnalysisProcedure s)
  where s = evalRand stream g 

--
-- this is what is missing and I can't figure out
--
-- stream = iterate parallelUpdate newLane
-- compute n = take n $ map someAnalisysProcedure $ stream