emitter.hs

module Main where

import Control.Concurrent hiding (yield)
import Control.Concurrent.Chan
import Data.Char (chr)
import Data.Maybe
import Control.Monad
import Control.Monad.Random ( RandomGen, Rand, getRandomR, evalRandIO)
import Control.Monad.Trans.State.Strict (StateT, get, put, evalStateT)
import Data.List
import Data.Random.Normal
import Pipes
import Pipes.Concurrent
import System.IO
import Text.Printf


data UserEvent = Go
         | Stop
	       | Reset
	       | Quit
	       deriving (Show, Eq)

help = putStrLn "(g)o (s)top (r)eset (q)uit"

logger = putStrLn

instr :: String
instr = "EURUSD"

randSeed :: Int
randSeed = 123456

numPrices :: Int
numPrices = 1000

rndChar :: (RandomGen g) => Rand g Int
rndChar = getRandomR (65,90)

rndId :: Int -> IO String
rndId len = do
    vals <- evalRandIO (sequence (replicate len rndChar))
    return $ map chr vals

user :: IO UserEvent
user = loop
  where
    loop = do
    hSetBuffering stdin NoBuffering
    command <- getChar
    putStrLn ""
    case [command] of
	"q" -> return Quit
	"s" -> return Stop
	"g" -> return Go
	"r" -> return Reset
	_ -> do
	     help
	     loop

type Price = Double

dataStream :: Producer Price IO ()
dataStream = do
    sequence_ . intersperse (lift $ threadDelay (10^5)) $
	map (\p -> yield p) (stockPrice 100 (0.1) (0.1) (1/252))

stockPrice :: Double -> Double -> Double -> Double -> [Price]
stockPrice start drift sigma dt = price where
    stdNs = take numPrices $ mkNormals randSeed
    price = start : zipWith
	    (\p s ->
	      (p * (1 + ((drift * dt) + (sigma * (sqrt dt) * s))))) price stdNs

-- consumer of user input
handleUser :: UserEvent -> IO ()
handleUser msg = do
    case msg of
	Quit  -> mzero
	Go    -> run (for dataStream $ lift . print)
	Reset -> do
		 logger "undefined"
		 return ()
	Stop  -> do
		 logger "undefined"
		 return ()

quitCheck :: Pipe UserEvent UserEvent IO ()
quitCheck = do
    m <- await
    case m of
	Quit -> return ()
	_ -> yield m >> quitCheck

cloop :: (UserEvent -> IO ()) -> Consumer UserEvent IO ()
cloop h = loop
  where
    loop = do
	event <- await
	lift $ h event
	unless (event == Quit) loop

main :: IO ()
main = do
    (input,output) <- spawn Unbounded
    forkIO $ do
	run $ lift user >~ toInput input
	performGC
    run $ fromOutput output >->
	    cloop handleUser