From 42183873d8b1c58575006ca41888fb0af66eac91 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Mon, 8 Aug 2022 08:37:59 +0200 Subject: [PATCH] further implemented #12 & tested preliminary. Should(tm) work fine now. --- deps/dear-implot.hs | 2 +- src/Chart.hs | 90 +++++++++++++++++++++++++++++++-------------- src/Run.hs | 28 +++++++++----- src/Types.hs | 49 ++++++++++++++---------- 4 files changed, 111 insertions(+), 58 deletions(-) diff --git a/deps/dear-implot.hs b/deps/dear-implot.hs index f3d5b63..2b3810f 160000 --- a/deps/dear-implot.hs +++ b/deps/dear-implot.hs @@ -1 +1 @@ -Subproject commit f3d5b63b541d8048568f134403838213c77177e4 +Subproject commit 2b3810f7927a83c7cf95612497eaeceed56ca5e8 diff --git a/src/Chart.hs b/src/Chart.hs index cac3d2c..fdd799c 100644 --- a/src/Chart.hs +++ b/src/Chart.hs @@ -3,7 +3,13 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -module Chart (newChart, FillerException(..), getUpdatedChartCache, getChunkedDay) where +module Chart (newChart + , FillerException(..) + , getUpdatedChartCache + , getChunkedDay + , timePointToIndex + , indexToTimePoint + ) where import Import import Control.Concurrent (forkIO) @@ -40,19 +46,29 @@ newChart contract = do unless (sym `HM.member` hm) $ do today <- liftIO getCurrentDay :: RIO App Day (cacheErrors, cacheData) <- do - files <- liftIO $ listDirectory $ "cache" show con - res <- forM files $ \cacheFileName -> do - let fname = "cache" show con cacheFileName - ifM (liftIO $ doesFileExist fname) - (bimap (\err -> cacheFileName <> ": "<> err) ((readMaybe $ dropExtension cacheFileName) :: Maybe Day,) <$> liftIO (eitherDecodeFileStrict' fname)) - (return $ Left $ "cachefile "<>cacheFileName<>" not found.") - return $ partitionEithers res + 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 + ifM (liftIO $ doesFileExist fname) + (bimap (\err -> cacheFileName <> ": "<> err) ((readMaybe $ dropExtension cacheFileName) :: Maybe Day,) <$> liftIO (eitherDecodeFileStrict' fname)) + (return $ Left $ "cachefile "<>cacheFileName<>" not found.") + return $ partitionEithers res unless (null cacheErrors) $ forM_ cacheErrors $ \err -> logError (displayShow err) let (unknownDates, cacheData') = partition (isNothing . fst) cacheData 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 defChartCacheSettings emptyChartCacheData 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{..}) @@ -110,14 +126,14 @@ toCachePoint (t,as) = ChartPoint t m vol [OLHC o l h c] l = minimum as' h = maximum as' -getUpdatedChartCache :: MonadIO m => Chart -> Maybe ChartCacheSettings -> m (Maybe TimePoint, ChartCacheData) +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 + let cacheUpdateEnd = ((utcTimeToSeconds now + cRes) `div` cRes) * cRes cacheUpdateStart = cacheUpdateEnd - (cRes * cTicks) - ChartCacheData ccData ccRange ccFill = chartCache + ChartCacheData ccData ccAxis ccRange ccFill = chartCache chunks = case ccFill of Nothing -> [(cacheUpdateStart, cacheUpdateEnd)] Just (mi, ma) -> if @@ -131,32 +147,30 @@ getUpdatedChartCache Chart{..} chartCacheSettings' = do | otherwise -> [] | otherwise -> [] -- - chunk them with chunhChart - chunkedChart = L.concat $ for chunks $ \(start, end) -> chunkChart (min 0 start) end cRes chartData + 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 + 20) `div` 20 :: Int - iTo = (cacheUpdateEnd + cRes * interval) `div` (cRes * interval) + 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' :: (Int, Int) -> (Int, Int) -> TimePoint -> Int - timePointToIndex' (cRes', cTicks') (rFrom, rTo) (TimePoint p) = let result = (p - rFrom) `div` cRes in - 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 - timePointToIndex :: TimePoint -> Int - timePointToIndex = timePointToIndex' newRange (cRes, cTicks) - -- fold instead of map, so we can carry over cached calculatinos from element to element (for i.e. ema/sma) - (!foldedData,_,_) = foldl' folder ([], ChartPoint 0 0 0 [], mempty) chunkedChart + 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) + 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 @@ -203,10 +217,30 @@ getUpdatedChartCache Chart{..} chartCacheSettings' = do 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)) - return (Just $ TimePoint lUpdate, ChartCacheData (foldl' (.) id updates ccData) (Just newRange) Nothing) -- FIXME: fillData still missing + 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 diff --git a/src/Run.hs b/src/Run.hs index e07154d..c6a3579 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -4,24 +4,24 @@ 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 @@ -232,8 +232,16 @@ renderLoop = do withPlot "Test" $ do -- TODO: set axes -- let (x,y) = L.unzip $ (\ChartPoint{..} -> (fromIntegral timeOfDay,pointValue)) <$> chartCache - -- plotLine (T.unpack symbol) x y - return () + 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 () diff --git a/src/Types.hs b/src/Types.hs index 81d18e3..520ef2a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -36,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 @@ -44,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" @@ -68,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 @@ -80,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 @@ -115,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 @@ -132,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 newtype (Show, Eq) + deriving stock (Show) + deriving newtype (Eq) data IBSymbolSample = IBSymbolSample { _symbolId :: Int @@ -144,7 +148,7 @@ data IBSymbolSample = IBSymbolSample , _primaryExchange :: Text , _currency :: Text , _derivatives :: [Text] - } deriving (Show, Eq) + } deriving stock (Show, Eq) makeLenses ''IBAccountStrategy makeLenses ''IBAccountInfo @@ -155,7 +159,7 @@ data ChartSettings = ChartSettings , chartStart :: Maybe UTCTime , chartEnd :: Maybe UTCTime , chartStudySettings :: [ChartStudyType] - } deriving (Show, Eq) + } deriving stock (Show, Eq) defChartSettings :: ChartSettings defChartSettings = ChartSettings 60 Nothing Nothing [ChartStudyTypeDirect] @@ -163,7 +167,7 @@ defChartSettings = ChartSettings 60 Nothing Nothing [ChartStudyTypeDirect] updateChartStudySettings :: Chart -> [ChartStudyType] -> Chart updateChartStudySettings Chart{..} s = let chartSettings = chartSettings { chartStudySettings = [] } - chartCache = emptyChartCacheData + chartCache = emptyChartCacheData chartCacheSettings lastCacheUpdate = Nothing in Chart{..} @@ -171,6 +175,9 @@ updateChartStudySettings Chart{..} s = -- -- History and Resolution yield 1 day by default. Do not increase over 5000 as memery-consumption explodes! -- Think of it as timePlotted = candleWidth * numberOfCandles +-- +-- 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 @@ -189,18 +196,21 @@ newtype TimePoint = TimePoint Int data ChartStudies = SMA { window :: Int, value :: Float } | OLHC { olhc_open :: Float, olhc_low :: Float, olhc_high :: Float, olhc_close :: Float} | Volume { volume :: Float } - deriving (Show, Eq, Generic, FromJSON, ToJSON) + deriving stock (Show, Eq, Generic) + deriving anyclass (FromJSON, ToJSON) data ChartPoint = ChartPoint { timeOfDay :: TimePoint , pointValue :: Float , 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 @@ -212,13 +222,14 @@ data ChartStudyType = ChartStudyTypeDirect deriving anyclass (Hashable) data ChartCacheData = ChartCacheData - { chartCacheData :: HashMap ChartStudyType (VS.Vector Float) - , chartCacheCurrent :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today" - , chartCacheFilled :: Maybe (Int,Int) -- ^ in number of TimePoint, negative meaning "before today" + { 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 :: ChartCacheData -emptyChartCacheData = ChartCacheData mempty Nothing Nothing +emptyChartCacheData :: ChartCacheSettings -> ChartCacheData +emptyChartCacheData ChartCacheSettings{..} = ChartCacheData mempty (VS.replicate chartCacheHistory 0) Nothing Nothing data Chart = Chart { chartContractID :: Int @@ -230,7 +241,7 @@ data Chart = Chart , 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