15 changed files with 53 additions and 335 deletions
@ -1,102 +0,0 @@
@@ -1,102 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-} |
||||
|
||||
module ATrade.Backtest.Execution ( |
||||
mkExecutionAgent, |
||||
ExecutionAgent(..), |
||||
executePending, |
||||
executeStep |
||||
) where |
||||
|
||||
import qualified Data.Text as T |
||||
import qualified Data.Map as M |
||||
import qualified Data.List as L |
||||
import ATrade.Types |
||||
import ATrade.Strategy.Types |
||||
import ATrade.Strategy |
||||
import Control.Monad.State |
||||
import Control.Monad.Trans.Writer |
||||
import Data.Decimal |
||||
import Data.Time.Clock |
||||
import Data.Time.Calendar |
||||
|
||||
data Position = Position { |
||||
ticker :: T.Text, |
||||
balance :: Int } |
||||
|
||||
data ExecutionAgent = ExecutionAgent { |
||||
pendingOrders :: [Order], |
||||
cash :: Decimal, |
||||
currentTime :: UTCTime, |
||||
orderIdCounter :: Integer |
||||
} |
||||
|
||||
mkExecutionAgent startCash = ExecutionAgent { pendingOrders = [], |
||||
cash = startCash, |
||||
currentTime = UTCTime (fromGregorian 1970 1 1) 0, |
||||
orderIdCounter = 1 } |
||||
|
||||
executeAtPrice :: Order -> Decimal -> WriterT [Event] (State ExecutionAgent) () |
||||
executeAtPrice order price = do |
||||
when (orderState order == Unsubmitted) $ tell [OrderSubmitted order] |
||||
tell [OrderUpdate (orderId order) Executed] |
||||
timestamp <- gets currentTime |
||||
tell [NewTrade (mkTradeForOrder timestamp order price)] |
||||
|
||||
case orderOperation order of |
||||
Buy -> modify' (\agent -> agent { cash = cash agent - price * realFracToDecimal 10 (toRational $ orderQuantity order) }) |
||||
Sell -> modify' (\agent -> agent { cash = cash agent + price * realFracToDecimal 10 (toRational $ orderQuantity order) }) |
||||
|
||||
mkTradeForOrder timestamp order price = Trade { tradeOrderId = orderId order, |
||||
tradePrice = price, |
||||
tradeQuantity = orderQuantity order, |
||||
tradeVolume = price * realFracToDecimal 10 (toRational $ orderQuantity order), |
||||
tradeVolumeCurrency = "TEST_CURRENCY", |
||||
tradeOperation = orderOperation order, |
||||
tradeAccount = orderAccountId order, |
||||
tradeSecurity = orderSecurity order, |
||||
tradeTimestamp = timestamp, |
||||
tradeSignalId = orderSignalId order } |
||||
|
||||
|
||||
executePending :: Bars -> WriterT [Event] (State ExecutionAgent) () |
||||
executePending bars = do |
||||
orders <- gets pendingOrders |
||||
let (executedOrders, leftover) = L.partition shouldExecute orders |
||||
|
||||
mapM_ executeAtOrdersPrice executedOrders |
||||
modify' (\s -> s { pendingOrders = leftover } ) |
||||
where |
||||
executeAtOrdersPrice order = case orderPrice order of |
||||
Limit price -> executeAtPrice order price |
||||
_ -> return () -- TODO handle stops |
||||
|
||||
shouldExecute order = case M.lookup (orderSecurity order) bars of |
||||
Just (DataSeries ((ts, bar) : _)) -> case orderPrice order of |
||||
Limit price -> crosses bar price |
||||
_ -> False |
||||
Nothing -> False |
||||
|
||||
crosses bar price = (barClose bar > price && barOpen bar < price) || (barClose bar < price && barOpen bar > price) |
||||
|
||||
executeStep :: Bars -> [Order] -> WriterT [Event] (State ExecutionAgent) () |
||||
executeStep bars orders = do |
||||
-- Assign consecutive IDs |
||||
orders' <- mapM (\o -> do |
||||
id <- gets orderIdCounter |
||||
modify(\s -> s { orderIdCounter = id + 1 }) |
||||
return o { orderId = id }) orders |
||||
|
||||
let (executableNow, pending) = L.partition isExecutableNow orders' |
||||
mapM_ (executeOrderAtLastPrice bars) executableNow |
||||
modify' (\s -> s { pendingOrders = pending ++ pendingOrders s }) |
||||
|
||||
where |
||||
isExecutableNow order = case M.lookup (orderSecurity order) bars of |
||||
Just (DataSeries (x:xs)) -> case orderPrice order of |
||||
Limit price -> (orderOperation order == Buy && price >= (barClose . snd) x) || (orderOperation order == Sell && price <= (barClose . snd) x) |
||||
Market -> True |
||||
_ -> False |
||||
|
||||
executeOrderAtLastPrice bars order = case M.lookup (orderSecurity order) bars of |
||||
Just (DataSeries ((ts, bar) : _)) -> executeAtPrice order (barClose bar) |
||||
_ -> return () |
||||
@ -1,153 +0,0 @@
@@ -1,153 +0,0 @@
|
||||
{-# OPTIONS_GHC -Wno-type-defaults #-} |
||||
|
||||
module ATrade.Forums.Smartlab ( |
||||
NewsItem(..), |
||||
IndexItem(..), |
||||
getIndex, |
||||
getItem |
||||
) where |
||||
|
||||
import qualified Data.ByteString.Lazy as BL |
||||
import qualified Data.List as L |
||||
import Data.Maybe |
||||
import qualified Data.Text as T |
||||
import Data.Text.Encoding |
||||
import Data.Time.Calendar |
||||
import Data.Time.Clock |
||||
import Network.HTTP.Simple |
||||
import Safe |
||||
import Text.HTML.TagSoup |
||||
import Text.Parsec |
||||
import Text.Parsec.Text |
||||
import Text.StringLike |
||||
|
||||
import Debug.Trace |
||||
|
||||
data NewsItem = NewsItem { |
||||
niUrl :: !T.Text, |
||||
niHeader :: !T.Text, |
||||
niText :: !T.Text, |
||||
niAuthor :: !T.Text, |
||||
niPubTime :: !UTCTime |
||||
} deriving (Show, Eq) |
||||
|
||||
data IndexItem = IndexItem { |
||||
iiUrl :: !T.Text, |
||||
iiTitle :: !T.Text, |
||||
iiPubTime :: !UTCTime |
||||
} deriving (Show, Eq) |
||||
|
||||
monthNames :: [T.Text] |
||||
monthNames = fmap T.pack ["января", "февраля", "марта", "апреля", "мая", "июня", "июля", "августа", "сентября", "октября", "ноября", "декабря"] |
||||
|
||||
extractBetween :: StringLike str => String -> [Tag str] -> [Tag str] |
||||
extractBetween tagName = takeWhile (~/= closeTag) . dropWhile (~/= openTag) |
||||
where |
||||
openTag = "<" ++ tagName ++ ">" |
||||
closeTag = "</" ++ tagName ++ ">" |
||||
|
||||
matchClass :: T.Text -> T.Text -> Tag T.Text -> Bool |
||||
matchClass _ className (TagOpen _ attrs) = case L.lookup (T.pack "class") attrs of |
||||
Just klass -> className `L.elem` T.words klass |
||||
Nothing -> False |
||||
|
||||
matchClass _ _ _ = False |
||||
|
||||
parseTimestamp :: T.Text -> Maybe UTCTime |
||||
parseTimestamp text = case parse timestampParser "" text of |
||||
Left _ -> Nothing |
||||
Right val -> Just val |
||||
where |
||||
timestampParser :: Parser UTCTime |
||||
timestampParser = do |
||||
spaces |
||||
day <- read <$> many1 digit |
||||
spaces |
||||
monthName <- T.pack <$> many1 letter |
||||
case L.elemIndex monthName monthNames of |
||||
Nothing -> fail "Can't parse month" |
||||
Just month -> do |
||||
spaces |
||||
year <- fromIntegral . read <$> many1 digit |
||||
_ <- char ',' |
||||
spaces |
||||
hour <- fromIntegral . read <$> many1 digit |
||||
_ <- char ':' |
||||
minute <- fromIntegral . read <$> many1 digit |
||||
return $ UTCTime (fromGregorian year (month + 1) day) (hour * 3600 + minute * 60) |
||||
|
||||
getItem :: IndexItem -> IO (Maybe NewsItem) |
||||
getItem indexItem = do |
||||
rq <- parseRequest $ T.unpack (iiUrl indexItem) |
||||
resp <- httpLBS rq |
||||
if getResponseStatusCode resp == 200 |
||||
then return . parseItem . decodeUtf8 . BL.toStrict . getResponseBody $ resp |
||||
else return Nothing |
||||
where |
||||
parseItem rawHtml = case parseTimestamp timestamp of |
||||
Just itemPubtime -> Just NewsItem { |
||||
niUrl = iiUrl indexItem, |
||||
niHeader = itemHeader, |
||||
niText = itemText, |
||||
niAuthor = itemAuthor, |
||||
niPubTime = itemPubtime |
||||
} |
||||
Nothing -> Nothing |
||||
where |
||||
itemHeader = innerText . |
||||
extractBetween "span" . |
||||
extractBetween "h1" . |
||||
dropWhile (not . matchClass (T.pack "div") (T.pack "topic")) $ tags |
||||
|
||||
itemText = innerText . |
||||
extractBetween "div" . |
||||
dropWhile (not . matchClass (T.pack "div") (T.pack "content")) . |
||||
dropWhile (~/= "<div id=content_box>") $ tags |
||||
|
||||
itemAuthor = innerText . |
||||
extractBetween "li" . |
||||
dropWhile (not . matchClass (T.pack "li") (T.pack "author")) $ tags |
||||
|
||||
timestamp = traceShowId $ innerText . |
||||
extractBetween "li" . |
||||
dropWhile (not . matchClass (T.pack "li") (T.pack "date")) $ tags |
||||
|
||||
tags = parseTags rawHtml |
||||
|
||||
|
||||
getIndex :: T.Text -> Int -> IO ([IndexItem], Bool) |
||||
getIndex rootUrl pageNumber = do |
||||
rq <- parseRequest $ T.unpack $ makeUrl rootUrl pageNumber |
||||
resp <- httpLBS rq |
||||
return $ if getResponseStatusCode resp == 200 |
||||
then parseIndex . decodeUtf8 . BL.toStrict . getResponseBody $ resp |
||||
else ([], False) |
||||
where |
||||
parseIndex :: T.Text -> ([IndexItem], Bool) |
||||
parseIndex x = (mapMaybe parseIndexEntry $ partitions (matchClass (T.pack "div") (T.pack "topic")) $ parseTags x, hasNextPage $ parseTags x) |
||||
|
||||
parseIndexEntry :: [Tag T.Text] -> Maybe IndexItem |
||||
parseIndexEntry divTag = do |
||||
a <- headMay . dropWhile (~/= "<a>") $ divTag |
||||
let text = innerText . takeWhile (~/= "</a>") . dropWhile (~/= "<a>") $ divTag |
||||
case a of |
||||
TagOpen _ attr -> do |
||||
href <- L.lookup (T.pack "href") attr |
||||
ts <- parseTimestamp (innerText $ takeWhile (~/= "</li>") . dropWhile (not . matchClass (T.pack "li") (T.pack "date")) $ divTag) |
||||
Just IndexItem { iiUrl = href, |
||||
iiTitle = text, |
||||
iiPubTime = ts } |
||||
_ -> Nothing |
||||
|
||||
|
||||
makeUrl root pagenumber |
||||
| pagenumber == 0 || pagenumber == 1 = root |
||||
| otherwise = root `T.append` (T.pack "/page") `T.append` T.pack (show pagenumber) |
||||
|
||||
hasNextPage tags = if pageNumber <= 1 |
||||
then paginationLinksCount > 0 |
||||
else paginationLinksCount > 1 |
||||
where |
||||
paginationLinksCount = length . filter (~== "<a>") . extractBetween "p" . dropWhile (~/= "<div id=pagination>") $ tags |
||||
|
||||
|
||||
Loading…
Reference in new issue