Compare commits
2 Commits
fcf8c26137
...
42183873d8
Author | SHA1 | Date | |
---|---|---|---|
42183873d8 | |||
16b4eb83e1 |
2
deps/dear-implot.hs
vendored
2
deps/dear-implot.hs
vendored
@ -1 +1 @@
|
||||
Subproject commit f3d5b63b541d8048568f134403838213c77177e4
|
||||
Subproject commit 2b3810f7927a83c7cf95612497eaeceed56ca5e8
|
@ -78,7 +78,18 @@ library
|
||||
TypeSynonymInstances
|
||||
ViewPatterns
|
||||
DuplicateRecordFields
|
||||
ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -static -dynamic-too
|
||||
ghc-options:
|
||||
-Wall
|
||||
-Wcompat
|
||||
-Widentities
|
||||
-Wincomplete-record-updates
|
||||
-Wincomplete-uni-patterns
|
||||
-Wpartial-fields
|
||||
-Wredundant-constraints
|
||||
-Wderiving-defaults
|
||||
-Wmissing-deriving-strategies
|
||||
-static
|
||||
-dynamic-too
|
||||
-- include-dirs:
|
||||
-- deps/dear-implot.hs/implot
|
||||
-- deps/dear-imgui.hs/imgui
|
||||
@ -109,6 +120,7 @@ library
|
||||
, time
|
||||
, type-iso
|
||||
, unordered-containers
|
||||
, vector
|
||||
default-language: Haskell2010
|
||||
|
||||
executable ibhelper-exe
|
||||
|
@ -37,11 +37,11 @@ appFiller app = runRIO app $ withRunInIO $ \run -> do
|
||||
$ unless (L.null as)
|
||||
$ switchAccountTo $ L.head as
|
||||
(Msg_IB_IN (IB_NextValidID i)) -> atomically $ modifyTVar' (nextValidID currentAppData) (const (Just i))
|
||||
(Msg_IB_IN (IB_ErrorMsg i c m)) -> debugMsg "IB_ErrorMsg not implemented"
|
||||
(Msg_IB_IN (IB_ErrorMsg _i _c _m)) -> debugMsg "IB_ErrorMsg not implemented"
|
||||
(Msg_IB_IN (IB_AccountValue k v c n)) -> do
|
||||
let action = HM.update (\ai -> Just $ ai & accountInfo . accountProperties %~ HM.alter (\old -> Just $ (v,c):filter ((/=c) . snd) (fromMaybe [] old)) k) n
|
||||
atomically $ modifyTVar' (Types.accounts currentAppData) action
|
||||
(Msg_IB_IN (IB_AccountUpdateTime t)) -> debugMsg "IB_AccountUpdateTime not implemented"
|
||||
(Msg_IB_IN (IB_AccountUpdateTime _t)) -> debugMsg "IB_AccountUpdateTime not implemented"
|
||||
-- (Msg_IB_IN (IB_AccountUpdateTime t)) -> do
|
||||
-- let action = HM.update (\ai -> Just $ ai & accountInfo . accountLastUpdate %~ const t) n
|
||||
-- atomically $ modifyTVar' (Types.accounts currentAppData) action
|
||||
@ -72,8 +72,8 @@ handleTickPrice IB_TickPrice{..} = do
|
||||
chartVar <- (HM.!s) <$> liftIO (readTVarIO charts)
|
||||
case tickType of
|
||||
IBTickType_Last_Price -> do
|
||||
t <- utctDayTime <$> liftIO getCurrentTime
|
||||
let cp = ChartPoint (TimePoint $ fromInteger. (`div` 1000000000000) . diffTimeToPicoseconds $ t) price size []
|
||||
t <- utcTimeToSeconds <$> liftIO getCurrentTime
|
||||
let cp = ChartPoint (TimePoint t) price (fromIntegral size) []
|
||||
liftIO $ atomically $ modifyTVar chartVar (\c@Chart{..} -> c { chartData = chartData |> cp, chartDirty = True})
|
||||
_ -> return ()
|
||||
handleTickPrice _ = error "impossible"
|
||||
|
201
src/Chart.hs
201
src/Chart.hs
@ -3,32 +3,39 @@
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
module Chart (newChart, FillerException(..), getUpdatedChartCache) where
|
||||
module Chart (newChart
|
||||
, FillerException(..)
|
||||
, getUpdatedChartCache
|
||||
, getChunkedDay
|
||||
, timePointToIndex
|
||||
, indexToTimePoint
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Data.Aeson (eitherDecodeFileStrict')
|
||||
import RIO.List
|
||||
import RIO.List.Partial
|
||||
import RIO.FilePath
|
||||
import Data.Time.Calendar (Day(..))
|
||||
import Data.FingerTree (FingerTree)
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Monad.Extra (ifM)
|
||||
import qualified RIO.ByteString as BS
|
||||
-- import Control.Exception
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.FingerTree as FT
|
||||
import qualified Data.Text as T
|
||||
import Data.Aeson (eitherDecodeFileStrict')
|
||||
import Data.FingerTree (FingerTree)
|
||||
import Data.Time.Calendar (Day(..))
|
||||
import Data.Time.Clock
|
||||
import Data.Maybe (fromJust)
|
||||
import RIO.FilePath
|
||||
import RIO.List
|
||||
import RIO.List.Partial
|
||||
|
||||
import qualified Debug.Trace as D
|
||||
import qualified Data.FingerTree as FT
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import qualified Data.List as L
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector.Storable as VS
|
||||
|
||||
--import qualified Debug.Trace as D
|
||||
|
||||
data FillerException = QuitFiller
|
||||
deriving Show
|
||||
deriving stock Show
|
||||
|
||||
instance Exception FillerException
|
||||
|
||||
--deriving via Integer instance Hashable Day
|
||||
|
||||
newChart :: IBContract -> RIO App ()
|
||||
newChart contract = do
|
||||
app <- ask
|
||||
@ -39,6 +46,8 @@ newChart contract = do
|
||||
unless (sym `HM.member` hm) $ do
|
||||
today <- liftIO getCurrentDay :: RIO App Day
|
||||
(cacheErrors, cacheData) <- do
|
||||
ifM (fmap not $ liftIO $ doesDirectoryExist $ "cache" </> show con)
|
||||
(return $ (["no data-chache found for " <> show con], [])) $ do
|
||||
files <- liftIO $ listDirectory $ "cache" </> show con
|
||||
res <- forM files $ \cacheFileName -> do
|
||||
let fname = "cache" </> show con </> cacheFileName
|
||||
@ -51,7 +60,15 @@ newChart contract = do
|
||||
unless (null unknownDates) $ logError $ display $ T.pack $ show (length unknownDates) <> " files had no parsable Date."
|
||||
let cacheData'' :: HashMap Day (FingerTree TimePoint ChartPoint) = HM.fromList $ bimap (fromMaybe today) FT.fromList <$> cacheData'
|
||||
logError $ displayShow $ HM.keys cacheData''
|
||||
c <- liftIO $ newTVarIO $ Chart con (fromMaybe FT.empty $ cacheData'' HM.!? today) (HM.delete today cacheData'') undefined defChartSettings [] Nothing False
|
||||
c <- liftIO $ newTVarIO $ Chart con
|
||||
(fromMaybe FT.empty $ cacheData'' HM.!? today)
|
||||
(HM.delete today cacheData'')
|
||||
undefined
|
||||
defChartSettings
|
||||
defChartCacheSettings
|
||||
(emptyChartCacheData defChartCacheSettings)
|
||||
Nothing
|
||||
False
|
||||
tid <- liftIO $ forkIO $ fillChart app contract c
|
||||
liftIO $ atomically $ do
|
||||
modifyTVar' c (\Chart{..} -> let fillerThread = tid in Chart{..})
|
||||
@ -67,7 +84,7 @@ fillChart app contract cVar = runRIO app $ do
|
||||
let cancelSubscription = liftIO $ atomically $ do
|
||||
modifyTVar tickerMapVar (HM.delete tickerId)
|
||||
-- TODO: send cancel-request
|
||||
let sendQ = twsConnectionSend $ twsConnectionRefs $ appRefs $ app
|
||||
let sendQ = twsConnectionSend . twsConnectionRefs . appRefs $ app
|
||||
liftIO $ atomically $ do
|
||||
modifyTVar tickerMapVar (HM.insert tickerId sym)
|
||||
writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestMktData tickerId contract "233" False False
|
||||
@ -76,18 +93,14 @@ fillChart app contract cVar = runRIO app $ do
|
||||
-- chart dirty? set clean & begin work
|
||||
c <- liftIO (readTVarIO cVar)
|
||||
when (chartDirty c) $ do
|
||||
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartDirty = False })
|
||||
let (lUpdate, cachePoints) = getUpdatedChartCache c Nothing
|
||||
liftIO $ atomically $ modifyTVar cVar (\c -> c { chartCache = cachePoints, lastCacheUpdate = lUpdate })
|
||||
liftIO $ atomically $ modifyTVar cVar (\c' -> c' { chartDirty = False })
|
||||
(lUpdate, cachePoints) <- getUpdatedChartCache c Nothing
|
||||
liftIO $ atomically $ modifyTVar cVar (\c' -> c' { chartCache = cachePoints, lastCacheUpdate = lUpdate })
|
||||
return ()
|
||||
threadDelay 1000000 -- sleep 5 seconds
|
||||
|
||||
getUpdatedChartCache :: Chart -> Maybe ChartSettings -> (Maybe TimePoint, [ChartPoint])
|
||||
getUpdatedChartCache Chart{..} chartSettings' = (lUpdate, takeWhile (\ChartPoint{..} -> (\(TimePoint x) -> x < cacheUpdateStart) timeOfDay) chartCache <> map toCachePoint chunkedChart)
|
||||
where (TimePoint cacheUpdateStart) = fromMaybe (TimePoint 0) Nothing -- TODO: lastCacheUpdate
|
||||
cacheUpdateEnd = 86400
|
||||
chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])]
|
||||
chunkChart from until range tree = go from range interval
|
||||
chunkChart :: Int -> Int -> Int -> FingerTree TimePoint ChartPoint -> [(TimePoint,[ChartPoint])]
|
||||
chunkChart from until range tree = go from range interval
|
||||
where
|
||||
lastItem = case FT.viewr interval of
|
||||
FT.EmptyR -> until
|
||||
@ -99,17 +112,135 @@ getUpdatedChartCache Chart{..} chartSettings' = (lUpdate, takeWhile (\ChartPoint
|
||||
| f+i >= lastItem = [(TimePoint (f+i), toList t)]
|
||||
| otherwise = let (a, b) = FT.split (\(TimePoint x) -> x > f+i) t
|
||||
in (TimePoint (f+i),toList a) : go (f+i) i b
|
||||
chunkedChart = chunkChart cacheUpdateStart cacheUpdateEnd (chartResolution $ fromMaybe chartSettings chartSettings') chartData
|
||||
lUpdate = fmap fst . lastMaybe $ chunkedChart
|
||||
toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
|
||||
toCachePoint (t,[]) = ChartPoint t (-1) 0 []
|
||||
toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
|
||||
|
||||
toCachePoint :: (TimePoint,[ChartPoint]) -> ChartPoint
|
||||
toCachePoint (t,[]) = ChartPoint t (-1) 0 []
|
||||
toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c]
|
||||
where
|
||||
vol = sum $ volume <$> as
|
||||
vol = sum $ pointVolume <$> as
|
||||
as' = pointValue <$> as
|
||||
ms' = sum $ (\x -> pointValue x * fromIntegral (volume x)) <$> as
|
||||
m = ms' / fromIntegral vol
|
||||
ms' = sum $ (\x -> pointValue x * pointVolume x) <$> as
|
||||
m = ms' / vol
|
||||
o = head as'
|
||||
c = last as'
|
||||
l = minimum as'
|
||||
h = maximum as'
|
||||
|
||||
getUpdatedChartCache :: Chart -> Maybe ChartCacheSettings -> RIO App (Maybe TimePoint, ChartCacheData)
|
||||
getUpdatedChartCache Chart{..} chartCacheSettings' = do
|
||||
let ChartCacheSettings cRes cTicks = fromMaybe chartCacheSettings chartCacheSettings'
|
||||
now <- liftIO getCurrentTime
|
||||
-- - recalculate cacheUpdateStart & cacheUpdateEnd
|
||||
let cacheUpdateEnd = ((utcTimeToSeconds now + cRes) `div` cRes) * cRes
|
||||
cacheUpdateStart = cacheUpdateEnd - (cRes * cTicks)
|
||||
ChartCacheData ccData ccAxis ccRange ccFill = chartCache
|
||||
chunks = case ccFill of
|
||||
Nothing -> [(cacheUpdateStart, cacheUpdateEnd)]
|
||||
Just (mi, ma) -> if
|
||||
-- Interval mi-ma already updated. get remaining intervals
|
||||
-- mi ma cUS cUE
|
||||
| ma < cacheUpdateStart -> [(cacheUpdateStart, cacheUpdateEnd)]
|
||||
-- mi? cUS mi? ma cUE -> [ma,cUE] + rest
|
||||
| ma < cacheUpdateEnd -> [(ma,cacheUpdateEnd)] <> if
|
||||
-- cUS mi ma
|
||||
| mi > cacheUpdateStart -> [(cacheUpdateStart, mi)]
|
||||
| otherwise -> []
|
||||
| otherwise -> []
|
||||
-- - chunk them with chunhChart
|
||||
chunkedChart = L.filter (not . null . snd) $ L.concat $ for chunks $ \(start, end) -> chunkChart (min 0 start) end cRes chartData
|
||||
lUpdate = cacheUpdateEnd - cRes
|
||||
-- - calculate Range and need for shift
|
||||
shiftNeccessary = case ccRange of
|
||||
Nothing -> False
|
||||
Just (_,ma) -> cacheUpdateEnd > ma
|
||||
(newRange, shiftInterval) = if not shiftNeccessary && isJust ccRange then (fromJust ccRange, 0) else
|
||||
let interval = cTicks `div` 20 :: Int
|
||||
iTo = ((cacheUpdateEnd + cRes * interval) `div` (cRes * interval)) * (cRes * interval)
|
||||
iFrom = iTo - 20 * (cRes * interval)
|
||||
in ((iFrom,iTo), interval)
|
||||
ccAxis' = if not shiftNeccessary && isJust ccRange then ccAxis
|
||||
else VS.enumFromStepN (fromIntegral $ fst newRange) (fromIntegral cRes) cTicks
|
||||
logDebug $ displayShow ("now, updateEnd, lUpdate" :: Text, utcTimeToSeconds now, cacheUpdateEnd, lUpdate)
|
||||
-- create data for updates
|
||||
let timePointToIndex' :: TimePoint -> Int
|
||||
timePointToIndex' = timePointToIndex (Just $ ChartCacheSettings cRes cTicks) newRange
|
||||
let indexToTimePoint' :: Int -> TimePoint
|
||||
indexToTimePoint' = indexToTimePoint (Just $ ChartCacheSettings cRes cTicks) newRange
|
||||
-- fold instead of map, so we can carry over cached calculatinos from element to element (for i.e. ema/sma)
|
||||
let (!foldedData,_,_) = foldl' folder ([], ChartPoint 0 0 0 [], mempty) chunkedChart
|
||||
folder :: ([(Int, ChartPoint)], ChartPoint, HM.HashMap Int [Float]) -> (TimePoint, [ChartPoint]) -> ([(Int, ChartPoint)], ChartPoint, HM.HashMap Int [Float])
|
||||
folder old (_,[]) = old
|
||||
folder (acc, lastPoint, smaMap) (tp,cdata) = ((timePointToIndex' tp, cp):acc, cp, foldl' (.) id smaUpdates smaMap)
|
||||
where
|
||||
cp = ChartPoint tp m vol studies
|
||||
(studies, smaUpdates) = unzip $ catMaybes $ (chartStudySettings chartSettings :: [ChartStudyType]) <&> \case
|
||||
ChartStudyTypeOpen -> Just (OLHC o l h c, id)
|
||||
ChartStudyTypeHigh -> Nothing
|
||||
ChartStudyTypeLow -> Nothing
|
||||
ChartStudyTypeClose -> Nothing
|
||||
ChartStudyTypeDirect -> Nothing
|
||||
ChartStudyTypeSMA w -> Nothing --TODO: fixme #13, do the calculation & use data inside smaMap and return (SMA x y, smaUpdate)
|
||||
ChartStudyTypeVolume -> Just (Volume vol, id)
|
||||
vol = sum $ pointVolume <$> cdata
|
||||
as' = pointValue <$> cdata
|
||||
ms' = sum $ (\x -> pointValue x * pointVolume x) <$> cdata
|
||||
m = ms' / vol
|
||||
o = head as'
|
||||
c = last as'
|
||||
l = minimum as'
|
||||
h = maximum as'
|
||||
-- plan the actual work
|
||||
updates = chartStudySettings chartSettings <&> \cs ->
|
||||
-- check if thing is in hashmap
|
||||
let vec = case ccData HM.!? cs of
|
||||
Nothing -> VS.replicate cTicks 0
|
||||
Just a -> a
|
||||
-- shift if neccessary
|
||||
vec' = if shiftNeccessary && cs `HM.member` ccData then
|
||||
-- TODO: unsafeSlice && unsafeUpdate_ - see #16
|
||||
let sliceLength = VS.length vec - shiftInterval
|
||||
in VS.update_ vec (VS.enumFromN 0 sliceLength) (VS.slice shiftInterval sliceLength vec)
|
||||
else
|
||||
vec
|
||||
-- NOW:
|
||||
-- newRange is (rangeFrom, rangeTo) in seconds with 0 being last midnight
|
||||
-- vec' has that range mapped to indices [0,cTicks-1] with every cRes being one time-slice
|
||||
-- everything in the chunkedChart-list has to be inserted if in range using the same time-notation like the range
|
||||
-- (hint: chunkedChart is (time, [data]), with time being the point at the end of each contained interval)
|
||||
findOLHC as = fromJust $ find (\case OLHC{} -> True; _ -> False) as
|
||||
findVolume as = fromJust $ find (\case Volume{} -> True; _ -> False) as
|
||||
in case cs of
|
||||
ChartStudyTypeDirect -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ x _ _) -> (i,x)) <$> foldedData))
|
||||
ChartStudyTypeOpen -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_open $ findOLHC s)) <$> foldedData))
|
||||
ChartStudyTypeLow -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_low $ findOLHC s)) <$> foldedData))
|
||||
ChartStudyTypeHigh -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_high $ findOLHC s)) <$> foldedData))
|
||||
ChartStudyTypeClose -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,olhc_close $ findOLHC s)) <$> foldedData))
|
||||
ChartStudyTypeSMA x -> id --TODO: implement #13
|
||||
ChartStudyTypeVolume -> HM.insert cs (vec' VS.// ((\(i, ChartPoint _ _ _ s) -> (i,volume $ findVolume s)) <$> foldedData))
|
||||
let ccData' = foldl' (.) id updates ccData
|
||||
-- logInfo $ displayShow chartCache
|
||||
-- logInfo $ displayShow (cacheUpdateStart, cacheUpdateEnd)
|
||||
-- logInfo $ displayShow (newRange, chunkedChart)
|
||||
let ma = timePointToIndex' $ TimePoint lUpdate
|
||||
mi = fromMaybe ma $ fst <$> ccFill
|
||||
return (Just $ TimePoint lUpdate, ChartCacheData ccData' ccAxis' (Just newRange) (Just $ (mi, timePointToIndex' $ TimePoint lUpdate)))
|
||||
|
||||
getChunkedDay :: Chart -> Maybe Int -> (Maybe TimePoint, [ChartPoint])
|
||||
getChunkedDay Chart{..} chunkResolution = (lUpdate, toCachePoint <$> chunkedData)
|
||||
where
|
||||
chunkedData = chunkChart 0 86400 (fromMaybe (chartCacheResolution chartCacheSettings) chunkResolution) chartData
|
||||
lUpdate = fmap fst . lastMaybe $ chunkedData
|
||||
|
||||
indexToTimePoint :: Maybe ChartCacheSettings -> (Int, Int) -> Int -> TimePoint
|
||||
indexToTimePoint ccs (rFrom, rTo) i = TimePoint $ rFrom + i*cRes
|
||||
where
|
||||
ChartCacheSettings cRes _ = fromMaybe defChartCacheSettings ccs
|
||||
|
||||
timePointToIndex :: Maybe ChartCacheSettings -> (Int, Int) -> TimePoint -> Int
|
||||
timePointToIndex ccs (rFrom, rTo) (TimePoint p) = if
|
||||
| p < rFrom || p > rTo -> error $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show p <> " out of range."
|
||||
| result < 0 || result >= cTicks -> error $ "timePointToIndex " <> show ((cRes, cTicks),(rFrom, rTo),TimePoint p) <> ": " <> show result <> " is invalid index"
|
||||
| otherwise -> result
|
||||
where
|
||||
ChartCacheSettings cRes cTicks = fromMaybe defChartCacheSettings ccs
|
||||
result = (p - rFrom) `div` cRes
|
||||
|
@ -44,7 +44,8 @@ toBS (IBBool False) = "0"--BS.pack [0,0,0,0] -- bool == 32-bit int in IB
|
||||
|
||||
newtype IBGenericMessage = IBGenericMessage
|
||||
{ fields :: [IBTypes]
|
||||
} deriving (Show, Eq)
|
||||
} deriving stock (Show)
|
||||
deriving newtype (Eq)
|
||||
|
||||
instance Binary IBGenericMessage where
|
||||
put (IBGenericMessage f) = do
|
||||
|
@ -10,6 +10,7 @@ module Import
|
||||
, ppShow'
|
||||
, getCurrentDay
|
||||
, switchAccountTo
|
||||
, utcTimeToSeconds
|
||||
) where
|
||||
|
||||
import RIO
|
||||
@ -44,3 +45,6 @@ switchAccountTo a = do
|
||||
liftIO $ atomically $ writeTQueue sendQ $ Msg_IB_OUT $ IB_RequestAccountData True a
|
||||
-- finally change
|
||||
liftIO $ atomically $ modifyTVar' (currentAccount refs') (const $ Just a)
|
||||
|
||||
utcTimeToSeconds :: UTCTime -> Int
|
||||
utcTimeToSeconds = fromInteger . (`div` ((10 :: Integer)^(12 :: Integer))) . diffTimeToPicoseconds . utctDayTime
|
||||
|
41
src/Run.hs
41
src/Run.hs
@ -4,27 +4,26 @@
|
||||
module Run (run) where
|
||||
|
||||
import Import
|
||||
import Chart
|
||||
import Types
|
||||
import Chart
|
||||
import Control.Concurrent
|
||||
import Data.Aeson (encodeFile)
|
||||
import Data.Bits
|
||||
import Data.FingerTree (ViewL(..), ViewR(..), viewl, viewr, split, FingerTree)
|
||||
import DearImGui
|
||||
import DearImGui.Plot
|
||||
import DearImGui.OpenGL3
|
||||
import DearImGui.SDL
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Time.Clock
|
||||
import Data.Tuple.Extra
|
||||
import DearImGui
|
||||
import DearImGui.OpenGL3
|
||||
import DearImGui.Plot
|
||||
import DearImGui.SDL
|
||||
import Graphics.GL
|
||||
import SDL
|
||||
--import Data.StateVar
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.List as L
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
--import qualified Data.FingerTree as FT
|
||||
import qualified Data.Vector.Storable as VS
|
||||
|
||||
import IBClient.Connection
|
||||
import Import (Chart(chartContractID))
|
||||
|
||||
run :: RIO App ()
|
||||
run = do
|
||||
@ -52,13 +51,13 @@ shutdownApp = do
|
||||
-- save cached data
|
||||
liftIO $ unlessM (doesDirectoryExist "cache") $ createDirectory "cache"
|
||||
charts <- liftIO . readTVarIO . appCharts $ refs
|
||||
forM_ (HM.toList charts) $ \(symbol,tc) -> do
|
||||
forM_ (HM.toList charts) $ \(_symbol,tc) -> do
|
||||
c@Chart{..} <- liftIO . readTVarIO $ tc
|
||||
today <- liftIO $ utctDay <$> getCurrentTime
|
||||
liftIO $ unlessM (doesDirectoryExist $ "cache/" <> show chartContractID) $ createDirectory $ "cache/" <> show chartContractID
|
||||
let (_, chartData') = getUpdatedChartCache c (Just $ ChartSettings 5 Nothing Nothing)
|
||||
let (_, chartData') = getChunkedDay c (Just 5)
|
||||
newData = HM.toList
|
||||
. fmap (filter (\ChartPoint{..} -> 0 /= volume))
|
||||
. fmap (filter (\ChartPoint{..} -> 0 /= pointVolume))
|
||||
. HM.alter (Just . maybe chartData' (<>chartData')) today
|
||||
. fmap toList
|
||||
$ chartHistData
|
||||
@ -165,7 +164,7 @@ renderLoop = do
|
||||
tableSetupColumn "AVG"
|
||||
tableSetupColumn "Market Value"
|
||||
tableHeadersRow
|
||||
forM_ ((accs HM.! aid) ^.. accountPortfolio . traverse) $ \(IBPortfolioValue c p mp mv ac up rp) ->
|
||||
forM_ ((accs HM.! aid) ^.. accountPortfolio . traverse) $ \(IBPortfolioValue c p mp mv _ac up rp) ->
|
||||
do
|
||||
tableNextRow
|
||||
tableNextColumn $ text $ localSymbol c
|
||||
@ -203,7 +202,7 @@ renderLoop = do
|
||||
when mustSort $ liftIO $ pPrint sortSpecs
|
||||
tableHeadersRow
|
||||
lResult <- readTVarIO $ symbolLookupResults data'
|
||||
forM_ lResult $ \contract@IBSymbolSample{..} -> do
|
||||
forM_ lResult $ \IBSymbolSample{..} -> do
|
||||
let popupName = fromString $ "SymbolAction"<>show _symbolId
|
||||
withPopup popupName $ \isPopupOpen -> do
|
||||
when isPopupOpen $ do
|
||||
@ -232,9 +231,17 @@ renderLoop = do
|
||||
(_ :> ChartPoint{..}) -> text $ fromString $ "Last: " <> show pointValue <> "\nTime: " <> show timeOfDay
|
||||
withPlot "Test" $ do
|
||||
-- TODO: set axes
|
||||
let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache
|
||||
plotLine (T.unpack symbol) x y
|
||||
return ()
|
||||
-- let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache
|
||||
setupAxisLimits (both fromIntegral $ fromMaybe (0,86400) $ chartCacheCurrent chartCache) (-100,2500) Nothing
|
||||
let ChartCacheSettings _ cTicks = chartCacheSettings
|
||||
(f, t) = fromMaybe (0, cTicks) $ chartCacheFilledTo chartCache
|
||||
direct = chartCacheData chartCache HM.!? ChartStudyTypeDirect
|
||||
x = chartCacheAxis chartCache
|
||||
-- t-f == 0 means there is still 1 point in it. VS.slice takes number of points as second argument. Add 1!
|
||||
-- dataSlice = VS.slice f (t-f+1)
|
||||
dataSliceLine = if t-f < 1 then VS.slice (max 0 $ f-1) 2 else VS.slice f (t-f+1) -- need at least 2 points to make a line... duh!
|
||||
when (isJust direct) $ do
|
||||
plotLine (T.unpack symbol) (dataSliceLine x) (dataSliceLine $ fromJust direct)
|
||||
return ()
|
||||
|
||||
|
||||
|
94
src/Types.hs
94
src/Types.hs
@ -24,6 +24,7 @@ import RIO
|
||||
import RIO.Process
|
||||
import Lens.Micro.TH
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector.Storable as VS
|
||||
|
||||
import IBClient.Types
|
||||
|
||||
@ -35,7 +36,8 @@ data Options = Options
|
||||
data WindowParams = WindowParams
|
||||
{ _windowWidth :: Int
|
||||
, _windowHeight :: Int
|
||||
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||
} deriving stock (Show, Generic)
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
instance Default WindowParams where
|
||||
def = WindowParams 1024 768
|
||||
@ -43,7 +45,8 @@ instance Default WindowParams where
|
||||
data TWSConnection = TWSConnection
|
||||
{ _host :: Text
|
||||
, _port :: Text
|
||||
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||
} deriving stock (Show, Generic)
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
instance Default TWSConnection where
|
||||
def = TWSConnection "127.0.0.1" "7497"
|
||||
@ -67,7 +70,8 @@ data Settings = Settings
|
||||
{ _windowParams :: WindowParams
|
||||
, _twsConnection :: TWSConnection
|
||||
, _logLevel :: LogLevel
|
||||
} deriving (Show, Generic, FromJSON, ToJSON)
|
||||
} deriving stock (Show, Generic)
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
makeLenses ''WindowParams
|
||||
makeLenses ''TWSConnection
|
||||
@ -79,7 +83,7 @@ instance Default Settings where
|
||||
data TWSConnectionStatus = TWSDisconnected
|
||||
| TWSConnecting
|
||||
| TWSConnected
|
||||
deriving (Show, Eq, Enum, Bounded)
|
||||
deriving stock (Show, Eq, Enum, Bounded)
|
||||
|
||||
data TWSConnectionRefs = TWSConnectionRefs
|
||||
{ twsConnectionRefsHost :: TVar Text
|
||||
@ -114,14 +118,14 @@ data IBAccount = IBAccount
|
||||
{ _accountInfo :: IBAccountInfo
|
||||
, _accountPortfolio :: [IBPortfolioValue]
|
||||
, _accountStrategies :: [IBAccountStrategy]
|
||||
} deriving (Show, Eq)
|
||||
} deriving stock (Show, Eq)
|
||||
|
||||
|
||||
data IBAccountInfo = IBAccountInfo
|
||||
{ _accountName :: Text
|
||||
, _accountProperties :: HashMap Text [(Text, Text)] -- (value, currency)
|
||||
, _accountLastUpdate :: Text
|
||||
} deriving (Show, Eq)
|
||||
} deriving stock (Show, Eq)
|
||||
|
||||
data IBPortfolioValue = IBPortfolioValue
|
||||
{ _contract :: IBContract
|
||||
@ -131,10 +135,11 @@ data IBPortfolioValue = IBPortfolioValue
|
||||
, _averageCost :: Float
|
||||
, _unrealizedPNL :: Float
|
||||
, _realizedPNL :: Float
|
||||
} deriving (Show, Eq)
|
||||
} deriving stock (Show, Eq)
|
||||
|
||||
newtype IBAccountStrategy = IBAccountStrategy [Int] -- Int -> contract-id for this strategy
|
||||
deriving (Show, Eq)
|
||||
deriving stock (Show)
|
||||
deriving newtype (Eq)
|
||||
|
||||
data IBSymbolSample = IBSymbolSample
|
||||
{ _symbolId :: Int
|
||||
@ -143,7 +148,7 @@ data IBSymbolSample = IBSymbolSample
|
||||
, _primaryExchange :: Text
|
||||
, _currency :: Text
|
||||
, _derivatives :: [Text]
|
||||
} deriving (Show, Eq)
|
||||
} deriving stock (Show, Eq)
|
||||
|
||||
makeLenses ''IBAccountStrategy
|
||||
makeLenses ''IBAccountInfo
|
||||
@ -153,53 +158,90 @@ data ChartSettings = ChartSettings
|
||||
{ chartResolution :: Int
|
||||
, chartStart :: Maybe UTCTime
|
||||
, chartEnd :: Maybe UTCTime
|
||||
} deriving (Show, Eq)
|
||||
, chartStudySettings :: [ChartStudyType]
|
||||
} deriving stock (Show, Eq)
|
||||
|
||||
defChartSettings :: ChartSettings
|
||||
defChartSettings = ChartSettings 60 Nothing Nothing
|
||||
defChartSettings = ChartSettings 60 Nothing Nothing [ChartStudyTypeDirect]
|
||||
|
||||
-- data TimeWindow = TimeWindow
|
||||
-- { begin :: Int
|
||||
-- , end :: Int
|
||||
-- } deriving (Show, Eq)
|
||||
updateChartStudySettings :: Chart -> [ChartStudyType] -> Chart
|
||||
updateChartStudySettings Chart{..} s =
|
||||
let chartSettings = chartSettings { chartStudySettings = [] }
|
||||
chartCache = emptyChartCacheData chartCacheSettings
|
||||
lastCacheUpdate = Nothing
|
||||
in Chart{..}
|
||||
|
||||
-- | Settings for Chart-cache.
|
||||
--
|
||||
-- instance Semigroup TimeWindow where
|
||||
-- (TimeWindow a b) <> (TimeWindow x y) = TimeWindow (min a x) (max b y)
|
||||
-- History and Resolution yield 1 day by default. Do not increase over 5000 as memery-consumption explodes!
|
||||
-- Think of it as timePlotted = candleWidth * numberOfCandles
|
||||
--
|
||||
-- instance Monoid TimeWindow where
|
||||
-- mempty = TimeWindow 0 86400
|
||||
-- chartCacheHistory should be a multiple of 20 as there often is 5% buffer in various caches and this
|
||||
-- fills the caches more optimally
|
||||
data ChartCacheSettings = ChartCacheSettings
|
||||
{ chartCacheResolution :: Int
|
||||
, chartCacheHistory :: Int
|
||||
} deriving stock (Show, Eq)
|
||||
|
||||
defChartCacheSettings :: ChartCacheSettings
|
||||
defChartCacheSettings = ChartCacheSettings 60 1440
|
||||
|
||||
-- TODO: TimePointFloat? or only 1 entry per second?
|
||||
|
||||
newtype TimePoint = TimePoint Int
|
||||
deriving (Eq, Generic)
|
||||
deriving newtype (Show, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON)
|
||||
deriving stock (Generic)
|
||||
deriving newtype (Show, Eq, Enum, Real, Ord, Num, Integral, FromJSON, ToJSON)
|
||||
deriving (Semigroup, Monoid) via (Max Int)
|
||||
|
||||
data ChartStudies = SMA { window :: Int, value :: Float }
|
||||
| OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float}
|
||||
deriving (Show, Eq, Generic, FromJSON, ToJSON)
|
||||
| Volume { volume :: Float }
|
||||
deriving stock (Show, Eq, Generic)
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
data ChartPoint = ChartPoint
|
||||
{ timeOfDay :: TimePoint
|
||||
, pointValue :: Float
|
||||
, volume :: Int
|
||||
, pointVolume :: Float
|
||||
, pointExtra :: [ChartStudies]
|
||||
} deriving (Show, Eq, Generic, FromJSON, ToJSON)
|
||||
} deriving stock (Show, Eq, Generic)
|
||||
deriving anyclass (FromJSON, ToJSON)
|
||||
|
||||
instance Measured TimePoint ChartPoint where
|
||||
measure = timeOfDay
|
||||
|
||||
-- | Tick-based data
|
||||
data ChartStudyType = ChartStudyTypeDirect
|
||||
| ChartStudyTypeSMA Int
|
||||
| ChartStudyTypeOpen
|
||||
| ChartStudyTypeLow
|
||||
| ChartStudyTypeHigh
|
||||
| ChartStudyTypeClose
|
||||
| ChartStudyTypeVolume
|
||||
deriving stock (Show, Eq, Generic)
|
||||
deriving anyclass (Hashable)
|
||||
|
||||
data ChartCacheData = ChartCacheData
|
||||
{ chartCacheData :: HashMap ChartStudyType (VS.Vector Float)
|
||||
, chartCacheAxis :: VS.Vector Float
|
||||
, chartCacheCurrent :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today"
|
||||
, chartCacheFilledTo :: Maybe (Int,Int) -- ^ in index into the vectors given range of "Current"
|
||||
} deriving stock (Show, Eq)
|
||||
|
||||
emptyChartCacheData :: ChartCacheSettings -> ChartCacheData
|
||||
emptyChartCacheData ChartCacheSettings{..} = ChartCacheData mempty (VS.replicate chartCacheHistory 0) Nothing Nothing
|
||||
|
||||
data Chart = Chart
|
||||
{ chartContractID :: Int
|
||||
, chartData :: FingerTree TimePoint ChartPoint -- ^ raw data (time & sale)
|
||||
, chartHistData :: HashMap Day (FingerTree TimePoint ChartPoint) -- ^ raw data (time & sale)
|
||||
, fillerThread :: ThreadId
|
||||
, chartSettings :: ChartSettings
|
||||
, chartCache :: [ChartPoint] -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings'
|
||||
, chartCacheSettings :: ChartCacheSettings
|
||||
, chartCache :: ChartCacheData -- ^ cache for drawing with all pointExtra filled out and sampled according to 'chartSettings'
|
||||
, lastCacheUpdate :: Maybe TimePoint
|
||||
, chartDirty :: Bool
|
||||
} deriving (Show, Eq)
|
||||
} deriving stock (Show, Eq)
|
||||
|
||||
newtype InjetiveGettable a b = InjetiveGettable
|
||||
{ gettable :: TVar a
|
||||
|
Loading…
Reference in New Issue
Block a user