diff --git a/ephemeral.cabal b/ephemeral.cabal
new file mode 100644
--- /dev/null
+++ b/ephemeral.cabal
@@ -0,0 +1,80 @@
+cabal-version: 2.4
+name: ephemeral
+version: 0.0.1
+synopsis: See readme.md
+description: See readme.md for description.
+category: project
+author: Tony Day
+maintainer: tonyday567@gmail.com
+copyright: Tony Day (c) AfterTimes
+license: BSD-3-Clause
+homepage: https://github.com/tonyday567/ephemeral#readme
+bug-reports: https://github.com/tonyday567/ephemeral/issues
+build-type: Simple
+extra-doc-files: other/*.svg
+source-repository head
+ type: git
+ location: https://github.com/tonyday567/ephemeral
+library
+ exposed-modules:
+ Ephemeral.Chart
+ Ephemeral.Learn
+ Ephemeral.Market
+ Ephemeral.Shekel
+ hs-source-dirs:
+ src
+ default-extensions:
+ ghc-options:
+ -Wall
+ -Wcompat
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wredundant-constraints
+ -fwrite-ide-info
+ -hiedir=.hie
+
+ build-depends:
+ attoparsec >= 0.13 && < 0.14,
+ base >= 4.7 && < 5,
+ box >= 0.6 && < 0.7,
+ box-csv >= 0.0.1 && < 0.1,
+ chart-svg >= 0.2 && < 0.3,
+ concurrency >= 1.11,
+ lens >= 4.19.2 && < 5,
+ lucid,
+ moo,
+ mealy >= 0.0.2 && < 0.1,
+ mwc-probability >= 2.3.1 && < 2.4,
+ numhask >= 0.7.1 && < 0.8,
+ numhask-array >= 0.8 && < 0.9,
+ numhask-space >= 0.7.1 && < 0.8,
+ primitive,
+ profunctors >= 5.5,
+ random >= 1.2 && < 1.3,
+ text >= 1.2,
+ time >= 1.9 && < 1.10,
+ transformers >= 0.5,
+ unordered-containers,
+ microlens,
+ default-language: Haskell2010
+
+test-suite test
+ type: exitcode-stdio-1.0
+ main-is: test.hs
+ hs-source-dirs:
+ test
+ build-depends:
+ base >=4.7 && <5,
+ doctest,
+ numhask >= 0.7.1 && < 0.8,
+ ephemeral
+ default-language: Haskell2010
+ default-extensions:
+ ghc-options:
+ -Wall
+ -Wcompat
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wredundant-constraints
+ -fwrite-ide-info
+ -hiedir=.hie
diff --git a/other/allreturns.svg b/other/allreturns.svg
new file mode 100644
--- /dev/null
+++ b/other/allreturns.svg
@@ -0,0 +1,12043 @@
+
diff --git a/other/scratch.svg b/other/scratch.svg
new file mode 100644
--- /dev/null
+++ b/other/scratch.svg
@@ -0,0 +1,58 @@
+
diff --git a/other/shekeld.svg b/other/shekeld.svg
new file mode 100644
--- /dev/null
+++ b/other/shekeld.svg
@@ -0,0 +1,49 @@
+
diff --git a/other/shekelp.svg b/other/shekelp.svg
new file mode 100644
--- /dev/null
+++ b/other/shekelp.svg
@@ -0,0 +1,6 @@
+
diff --git a/other/surface.svg b/other/surface.svg
new file mode 100644
--- /dev/null
+++ b/other/surface.svg
@@ -0,0 +1,5 @@
+
diff --git a/src/Ephemeral/Chart.hs b/src/Ephemeral/Chart.hs
new file mode 100644
--- /dev/null
+++ b/src/Ephemeral/Chart.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- | chart combinators
+module Ephemeral.Chart
+ ( surface,
+ scratch,
+ ) where
+
+import NumHask.Prelude hiding (zero,one)
+import Chart
+import Control.Lens
+
+-- $setup
+--
+-- >>> :set -XOverloadedStrings
+-- >>> :set -XOverloadedLabels
+-- >>> import qualified NumHask.Prelude as P
+
+-- | default chart of a surface
+--
+-- > import Ephemeral.Shekel
+-- > writeChartSvg "other/surface.svg" $ surface 20 P.one shekel
+--
+-- 
+--
+surface ::
+ Int ->
+ Rect Double ->
+ (Point Double -> Double) ->
+ ChartSvg
+surface grain r f =
+ mempty &
+ #hudList .~ hs &
+ #chartList .~ cs &
+ #svgOptions .~ (defaultSvgOptions & #cssOptions .~ UseCssCrisp)
+ where
+ (cs, hs) = surfacefl f (SurfaceOptions defaultSurfaceStyle (Point grain grain) r)
+ (defaultSurfaceLegendOptions mempty)
+
+-- | testing
+scratch :: ChartSvg -> IO ()
+scratch cs = writeChartSvg "other/scratch.svg" cs
+
diff --git a/src/Ephemeral/Learn.hs b/src/Ephemeral/Learn.hs
new file mode 100644
--- /dev/null
+++ b/src/Ephemeral/Learn.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RebindableSyntax #-}
+
+{- |
+
+Functional machinery, rapid learning.
+
+-}
+
+module Ephemeral.Learn where
+
+import NumHask.Prelude hiding (evaluate)
+import Data.Profunctor
+
+{- |
+
+A computer program is said to learn from experience E with respect to some task T and some performance measure P, if its performance on T, as measured by P, improves with experience E. ~ Tom Mitchell
+
+-}
+
+-- | learning is to use experience to change the performance of a task.
+newtype Learn f e p =
+ Learn { change :: Foldable f => Experience f e -> Task e p -> Task e p }
+
+-- | An experience is an accumulation of e, the carrier of some underlying grammar.
+newtype Experience f e = Experience { set :: f e }
+
+-- | A task is a pure function that performance measures an experience singleton.
+--
+-- Both performance measures and experiences will need to remain flexible.
+--
+-- Which makes this type a unification point.
+newtype Task e p = Task { measure :: e -> p } deriving (Profunctor)
+
+-- | To progress, is to transduce a Task
+newtype Progress e p = Progress { step :: e -> Task e p -> Task e p}
+
+-- | to learn, is to make Progress (good, bad or ugly) from an Experience.
+learn :: Progress e p -> Learn f e p
+learn p = Learn $ \(Experience e) task -> foldr (step p) task e
+
+-- | to improve, given a way to change a task by experience, you need to choose the better performace way over an experience set.
+improve ::
+ (Ord (f p), Foldable f, Functor f) =>
+ Progress e p ->
+ Experience f e ->
+ Task e p ->
+ Task e p
+improve progress es task =
+ bool task task' (p' > p)
+ where
+ task' = change (learn progress) es task
+ p = measure task <$> set es
+ p' = measure task' <$> set es
+
+-- | This is a major categorization in machine learning.
+data LearningType a c =
+ Regression {fit :: (Ord a, Num a) => Params a} |
+ Classification { enumerate :: (Eq c) => Params c}
+
+{- |
+
+If we take a linear regression, with parameters of alpha and betas unified as (a:bs), gives a carrier e of ([a], a). We take an [a] (the dependent variables) and produce an a, our guess as to the independent variable. We then take the second element of the tuple and know it is the underlying true answer to our guess. The difference between our guess and the correct answer is our measure, with the closer to zero the better.
+
+-}
+newtype Params a = Params { act :: [a] } deriving (Eq, Show, Generic)
+
+-- | linear regression error
+error :: (Ring a) => Params a -> ([a], a) -> a
+error (Params bs) (es, y) = sum (zipWith (*) bs (one:es)) - y
+
+-- | errors over an Experience set
+errors :: (Functor f, Ring a) => Params a -> Experience f ([a],a) -> f a
+errors p (Experience es) = error p <$> es
+
+-- | population level (for parameters)
+newtype Population f a = Population { individuals :: f a } deriving (Generic)
+
+-- | The value of a population, for each experience.
+value :: (Traversable p, Traversable e, Applicative e, Ring a) =>
+ Population p (Params a) ->
+ Experience e ([a], a) ->
+ (e (p a) -> p a) ->
+ p a
+value (Population ps) (Experience es) f = f $ traverse (\p -> error p <$> es) ps
+
+-- | A heuristic is any approach to problem solving or *self-discovery* that employs a practical method, not guaranteed to be optimal, perfect, or rational.
+--
+-- populations evolve according to heuristics.
+--
+-- They are natural transformations, with a carrier phenotype.
+newtype Heuristic f g a = Heuristic { evolve :: Population f a -> Population g a }
+
+-- | cofunctor, like an average
+type Neighbourhood = Heuristic Identity
+
+-- | mutation is isomorphic to (->).
+type Mutation = Heuristic Identity Identity
+
+-- | crossover is foldable
+type Crossover f = Heuristic f Identity
+
+-- | an individual can also be a carrier of the algebra
+type Individual a = Population Identity a
+
+{-
+-- | climb a gradient by taking a fixed step, rejecting worse points.
+climbGradient :: Pop a Double -> (a -> Double) -> a -> Point Double
+climbGradient r f p = bool p p' (v' > fst bp)
+ where
+ bp :: (Double, Point Double)
+ bp = backprop f p
+ p' :: (Point Double)
+ p' = p + fmap (r*) (normp (snd bp))
+ v' = evalBP f p'
+
+-}
diff --git a/src/Ephemeral/Market.hs b/src/Ephemeral/Market.hs
new file mode 100644
--- /dev/null
+++ b/src/Ephemeral/Market.hs
@@ -0,0 +1,484 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
+-- | Daily stock market data for use in testing.
+module Ephemeral.Market
+ ( YahooData(..),
+ pYahoo,
+ yahooCsvConfig,
+ lret,
+ rtake,
+ MarketConfig(..),
+ defaultMarketConfig,
+ nAll,
+ defaultQuantiles,
+ quantileNames,
+ makeReturns,
+ signalize,
+ ) where
+
+import Box.Csv
+import Chart
+import Control.Category
+import NumHask.Prelude as P
+import Lens.Micro
+import qualified Data.Attoparsec.Text as A
+import Data.Time
+import Data.Mealy
+import Data.Mealy.Quantiles
+import qualified Control.Lens as L
+
+-- $setup
+--
+-- >>> :set -XOverloadedStrings
+-- >>> :set -XOverloadedLabels
+-- >>> import Chart.Various
+-- >>> rs <- makeReturns (MarketConfig 1000 0)
+--
+
+-- | yahoo csv data
+-- See: https://finance.yahoo.com/quote/%5EGSPC/history?period1=-631015200&period2=1497103200&interval=1d&filter=history&frequency=1d
+data YahooData
+ = YahooData
+ { yDate :: Day,
+ yOpen :: Double,
+ yHigh :: Double,
+ yLow :: Double,
+ yClose :: Double,
+ yAdjClose :: Double,
+ yVolume :: Double
+ }
+ deriving (Generic, Show)
+
+-- | Parser for a 'Day' in yahoo format.
+--
+-- >>> A.parseOnly pDay "2021-01-01"
+-- Right 2021-01-01
+pDay :: A.Parser Day
+pDay = do
+ y <- A.decimal
+ _ <- A.char '-'
+ m <- A.decimal
+ _ <- A.char '-'
+ d <- A.decimal
+ pure $ fromGregorian y m d
+
+-- | yahoo data format
+--
+-- >>> A.parseOnly (pYahoo ',') "1927-12-30,17.660000,17.660000,17.660000,17.660000,17.660000,0"
+-- Right (YahooData {yDate = 1927-12-30, yOpen = 17.66, yHigh = 17.66, yLow = 17.66, yClose = 17.66, yAdjClose = 17.66, yVolume = 0.0})
+pYahoo :: Char -> A.Parser YahooData
+pYahoo c = do
+ d <- pDay
+ _ <- A.char c
+ o <- A.double
+ _ <- A.char c
+ h <- A.double
+ _ <- A.char c
+ l <- A.double
+ _ <- A.char c
+ close <- A.double
+ _ <- A.char c
+ ac <- A.double
+ _ <- A.char c
+ v <- A.double
+ pure (YahooData d (realToFrac o) (realToFrac h) (realToFrac l) (realToFrac close) (realToFrac ac) (realToFrac v))
+
+-- | csv data is in other/data.csv
+yahooCsvConfig :: CsvConfig
+yahooCsvConfig = defaultCsvConfig & #name .~ "data" & #fsep .~ ',' & #dir .~ "./other"
+
+-- | Compute the log return from a price series.
+--
+-- Returns are geometric by nature, and using log(1+daily return) as the base unit of the time series leads to all sorts of benefits, not least of which is you can then add up the variates to get the cumulative return, without having to go through log and exp chicanery. Ditto for distributional assumptions.
+lret :: (ExpField a) => [a] -> [a]
+lret xs = drop 1 $ scan ((\x x' -> log (x/x')) <$> id <*> delay [P.zero]) xs
+
+-- | convert YahooData to a daily return series
+getdc :: [YahooData] -> [(Day, Double)]
+getdc xs = zip (drop 1 $ (L.view #yDate) <$> xs) (lret ((L.view #yClose) <$> xs))
+
+-- | reverse take
+--
+-- >>> rtake 3 [1..10]
+-- [8,9,10]
+rtake :: Int -> [a] -> [a]
+rtake n = reverse . take n . reverse
+
+-- | Create a tuple of the last n days returns.
+makeReturnSeries :: Int -> IO [(Day, Double)]
+makeReturnSeries n = do
+ r <- runCsv yahooCsvConfig pYahoo
+ pure $ rtake n $ getdc $ rights r
+ where
+-- |
+--
+-- >>> defaultMarketConfig
+-- MarketConfig {mN = 10000, mRunup = 2000}
+data MarketConfig = MarketConfig
+ { -- | number of (most recent) days
+ mN :: Int,
+ -- | runup length
+ mRunup :: Int
+ } deriving (Eq, Show, Generic)
+
+-- |
+defaultMarketConfig :: MarketConfig
+defaultMarketConfig = MarketConfig 10000 2000
+
+-- |
+--
+-- >>> quantileNames defaultQuantiles
+-- ["10th","20th","30th","40th","50th","60th","70th","80th","90th"]
+defaultQuantiles :: [Double]
+defaultQuantiles = (0.1 *) <$> [1 .. 9]
+
+-- |
+quantileNames :: [Double] -> [Text]
+quantileNames qs' = (<> "th") . comma (Just 0) . (100 *) <$> qs'
+
+-- | number of days plus runup
+--
+-- >>> nAll defaultMarketConfig
+-- 12000
+nAll :: MarketConfig -> Int
+nAll c = ((c ^. #mN) + (c ^. #mRunup))
+
+-- |
+--
+-- >>> rs <- makeReturns defaultMarketConfig
+-- >>> length rs
+-- 12000
+--
+-- >>> fixed (Just 5) $ sum (snd <$> rs) / (fromIntegral $ length rs)
+-- "0.00027"
+--
+-- >>> exp $ sum (snd <$> rs)
+-- 25.218060748460402
+--
+-- >>> writeChartSvg "other/allreturns.svg" $ ChartSvg defaultSvgOptions (defaultHudOptions & #hudAxes .~ tsAxes ((\x -> UTCTime x 0) . fst <$> rs)) [] (stdLineChart 0.002 [Colour 0.5 0.4 0.3 1] [scanl (+) 0 (snd <$> rs)])
+--
+-- 
+--
+makeReturns :: MarketConfig -> IO [(Day, Double)]
+makeReturns c = makeReturnSeries ((c ^. #mN) + (c ^. #mRunup))
+
+-- | Fold that converts a time series into a quantile estimate series, based on recent history
+--
+-- eg the 10 most recent returns
+--
+-- >>> fixed (Just 4) <$> rtake 10 (snd <$> rs)
+-- ["0.0330","-0.0161","-0.0451","0.0226","-0.0153","0.0680","-0.0016","0.0335","0.0144","-0.0102"]
+--
+-- and their quantiles
+--
+-- >>> quantileNames <$> rtake 10 $ scan (signalize 0.99 defaultQuantiles) (snd <$> rs)
+-- ["90th","10th","0th","90th","10th","90th","30th","90th","80th","10th"]
+--
+signalize :: Double -> [Double] -> Mealy Double Double
+signalize r qs' =
+ (\x -> fromIntegral x/fromIntegral (length qs' + 1)) <$> digitize r qs'
+
+
+
+
+
+
+
+{-
+Old market state guff
+
+-- | MarketState represents the current "state" of the market in quantile terms.
+--
+-- >>> defaultMarketState
+-- MarketState {masig = 0.9, qest = 0.9, params = [0.5,0.0,0.2,-0.5], qs = [0.8]}
+--
+-- Meaning:
+--
+-- - /masig = 0.9/: set moving average decay rate to 0.9 (= 10 day average)
+-- - /qest = 0.9/: set quantile estiamting on a 10 day decay rate
+-- - /qs = [0.8]/: two categories of signal; quantile of 0 to 0.8 or 0.8 to 1
+-- - /params = [0.5,0.0,0.2,-0.5]/:
+-- current quantile is 0 to 0.8 and average quantile is 0 to 0.8: trading signal is 0.5
+-- current quantile is 0 to 0.8 and average quantile is 0.8 to 1: trading signal is 0.0
+-- current quantile is 0.8 to 1 and average quantile is 0 to 0.8: trading signal is 0.2
+-- current quantile is 0.8 to 1 and average quantile is 0.8 to 1: trading signal is -0.5
+--
+data MarketState a = MarketState
+ { -- | rate of ma signal
+ masig :: a,
+ -- | rate of quantile estimation
+ qest :: a,
+ -- | parameters transduce a signal
+ params :: [a],
+ -- | quantile cuts (1 is the last cut that is baked in)
+ qs :: [a]
+ } deriving (Eq, Show, Generic)
+
+-- |
+defaultMarketState :: MarketState Double
+defaultMarketState = MarketState 0.9 0.9 [0.5,0,0.2,-0.5] [0.8]
+
+-- | Reasonable ranges for the 2-quantile case.
+rangeMS :: MarketState (Range Double)
+rangeMS = MarketState (Range 0.9 1) (Range 0.9 1) [one, one, one, one] [((+0.5) <$> one)]
+
+-- | convert from a MarketState to a list
+--
+-- >>> defaultMarketState == (toMS_ $ fromMS_ defaultMarketState)
+-- True
+--
+-- >>> fromMS_ defaultMarketState
+-- ((4,1),[0.9,0.9,0.5,0.0,0.2,-0.5,0.8])
+fromMS_ :: MarketState a -> ((Int, Int), [a])
+fromMS_ ms =
+ (((length (ms ^. #params), length (ms ^. #qs)),
+ [ (ms ^. #masig),
+ (ms ^. #qest)] <>
+ ((ms ^. #params)) <>
+ ((ms ^. #qs))))
+
+-- | convert from a list to a MarketState
+--
+-- >>> toMS_ ((4,1),[0.9,0.9,0.5,0.0,0.2,-0.5,0.8])
+-- MarketState {masig = 0.9, qest = 0.9, params = [0.5,0.0,0.2,-0.5], qs = [0.8]}
+toMS_ :: ((Int, Int), [a]) -> MarketState a
+toMS_ ((lp, lq), xs) =
+ MarketState
+ ((xs!!0))
+ ((xs!!1))
+ ((take lp $ drop 2 xs))
+ ((take lq $ drop (2+lp) xs))
+
+-- | normalise MarketState elements to being a signal (all values are in the range -0.5 to 0.5)
+--
+-- >>> scaleMS defaultMarketState
+-- MarketState {masig = -0.5, qest = -0.5, params = [0.5,0.0,0.19999999999999996,-0.5], qs = [0.30000000000000004]}
+scaleMS :: MarketState Double -> MarketState Double
+scaleMS ms =
+ ms &
+ #masig %~ project (rangeMS ^. #masig) one &
+ #qest %~ project (rangeMS ^. #qest) one &
+ #params %~ (\ps -> zipWith (\r p -> project r one p) (rangeMS ^. #params) ps) &
+ #qs %~ (\xs -> zipWith (\r p -> project r one p) (rangeMS ^. #qs) xs)
+
+-- | tweak a parameter indexed by the list version of a MarketState
+--
+-- >>> tweak1dMS 0 0.8 defaultMarketState
+-- MarketState {masig = 0.8, qest = 0.9, params = [0.5,0.0,0.2,-0.5], qs = [0.8]}
+tweak1dMS :: Int -> Double -> MarketState Double -> MarketState Double
+tweak1dMS n x ms = toMS_ $ ((lp,lq), (take n xs) <> [x] <> (drop (n+1) xs))
+ where
+ ((lp,lq), xs) = fromMS_ ms
+
+-- | tweak 2 parameters
+--
+-- >>> tweak2dMS (Point 0 1) (Point 0.8 0.8) defaultMarketState
+-- MarketState {masig = 0.8, qest = 0.8, params = [0.5,0.0,0.2,-0.5], qs = [0.8]}
+tweak2dMS :: Point Int -> Point Double -> MarketState Double -> MarketState Double
+tweak2dMS (Point x' y') (Point x y) ms = tweak1dMS y' y (tweak1dMS x' x ms)
+
+-- | take a point and look up 2 dim parameter signal
+--
+-- conversion from quantile to signal given a parameter set
+-- requires the last quantile cut to be 1
+applyp :: MarketState Double -> Point Double -> Double
+applyp ms (Point x y) = (ms ^. #params) List.!! cut
+ where
+ cutx = cutI qs' x
+ cuty = cutI qs' y
+ cut = cutx + length qs' * cuty
+ qs' = ms ^. #qs <> [1]
+
+-- | perfms takes the time series, and a MarketState, and outputs the accumulated return of applying the MarketState parameters to the series.
+--
+-- hinge for other measures of return series attributes
+perfms :: [Double] -> MarketState Double -> Double
+perfms xs ms = sum $ perf (applyp ms) (mealyp (ms ^. #masig) (ms ^. #qest) defaultQuantiles) xs
+
+-- | perf takes a function that produces a signal, a mealy fold, and a list of returns, and outputs a return series based on the signal.
+perf :: (a -> Double) -> Mealy Double a -> [Double] -> [Double]
+perf f m xs = scan ((\d x -> (f d * x)) <$> (m <<< delay [1]) <*> id) xs
+
+-- | A Fold that produces a Point representing the last return signal, and a moving average of that signal.
+--
+mealyp :: Double -> Double -> [Double] -> Mealy Double (Point Double)
+mealyp r r' qs' = Point <$> sig <*> (ma r <<< sig)
+ where
+ sig = signalize r' qs'
+
+-- | take a point, modify market state based on the indices, and measure performance
+perfp :: [Double] -> Point Int -> MarketState Double -> Point Double -> Double
+perfp xs i ms p = perfms xs (tweak2dMS i p ms)
+
+-- | Select a change in point and climb by taking a fixed step, rejecting worse points.
+climbP :: (Monad m, PrimMonad m) => Gen (PrimState m) -> Double -> (Point Double -> Double) -> Point Double -> m (Point Double)
+climbP g step f p = do
+ d <- uniformP g one
+ let p' = p + ((step *) <$> normp d)
+ pure $ bool p p' (f p' > f p)
+
+-- | surface chart over two dimensions
+--
+-- > xs <- fmap snd <$> makeReturnSeries 1000
+-- > scratch $ marketSurface xs (Point 0 1) 10 defaultMarketState
+marketSurface :: [Double] -> Point Int -> Int -> MarketState Double -> (HudOptions, [Hud Double], [Chart Double])
+marketSurface xs i@(Point ix' iy) grain ms =
+ surface_ grain
+ (Ranges ((snd $ fromMS_ rangeMS)!!ix') ((snd $ fromMS_ rangeMS)!!iy))
+ (perfp xs i ms)
+
+-- | Select a change in the MarketState list and climb by taking a fixed step, rejecting worse points.
+climbList :: (Monad m, PrimMonad m) => Gen (PrimState m) -> Double -> Int -> ([Double] -> Double) -> [Double] -> m [Double]
+climbList g step l f p = do
+ xs <- uniformList g l
+ let p' = zipWith (+) p ((step *) <$> normList xs)
+ pure $ bool p p' (f p' > f p)
+
+-- | Generate a random list of signals
+uniformList :: (PrimMonad m, Variate a, FromRational a, Subtractive a) => Gen (PrimState m) -> Int -> m [a]
+uniformList g l = replicateM l (uniformR (-0.5, 0.5) g)
+
+-- | climbing requires a distance metric
+distanceList :: ExpField a => [a] -> a
+distanceList xs = sqrt . sum $ (^ (2::Int)) <$> xs
+
+normList :: ExpField a => [a] -> [a]
+normList xs = fmap (/distanceList xs) xs
+
+initialPop :: (PrimMonad m, Variate a, FromRational a, Subtractive a) => Int -> m [[a]]
+initialPop n = do
+ g <- create
+ replicateM n (uniformList g 8)
+
+nextPop :: Gen (PrimState IO) -> [Double] -> StateT [[Double]] IO ()
+nextPop g xs = do
+ pop <- get
+ pop' <- lift $ sequence $ climbList g 0.01 7 (perfms xs . (\x -> toMS_ ((4,1), x))) <$> pop
+ put pop'
+
+
+chartMS :: [[Double]] -> [[[Chart Double]]]
+chartMS xss =
+ (\d2 ->
+ (\d1 -> ([Chart (GlyphA defaultGlyphStyle)
+ ((\xs -> PointXY $ selectDim xs (Point d1 d2)) <$> xss)])) <$>
+ [0..7]) <$>
+ [0..7]
+
+hudAndChart :: [Hud Double] -> [Chart Double] -> [Chart Double]
+hudAndChart hs cs = runHud (fixRect $ dataBox cs) hs cs
+
+stackedChart :: Double -> [[[Chart Double]]] -> [Chart Double]
+stackedChart gap css = vert gap rows
+ where
+ rows = (hori gap <$> css)
+
+{-
+stackedChart' :: Double -> HudOptions -> HudOptions -> [Text] -> [[[Chart Double]]] -> [Chart Double]
+stackedChart' gap rowho colho ts css = vert gap rows
+ where
+ rows = (hori gap <$> css')
+ css' = fmap
+ (\c ->
+ trimmings
+ (defaultHudOptions &
+ #hudAxes %~ fmap
+ (#abar .~ Nothing &
+ #adjust .~ Nothing &
+ #atick . #tick .~ Nothing), [], c)) <$>
+ css
+
+-}
+
+
+{-
+testChart :: IO ()
+testChart = do
+ pop <- initialPop 1
+ let cs = stackedChart $ chartMS pop
+ scratch $ (mempty, [], cs)
+
+-}
+
+selectDim :: [Double] -> Point Int -> Point Double
+selectDim xs (Point x y) = Point (xs!!x) (xs!!y)
+
+t1 :: Int -> Double -> IO ()
+t1 n gap = do
+ let cs = Chart (GlyphA defaultGlyphStyle) ((\x -> PointXY (Point (fromIntegral x) (fromIntegral x))) <$> [0..10::Int])
+ -- let cl = pixelLegendChart one (defaultPixelLegendOptions "title")
+ --let hs = legendHud defaultLegendOptions cl
+ let cs' = trimmings (scaleHudOptions (recip . fromIntegral $ n) defaultHudOptions, [], [cs])
+ let css' = replicate n (replicate n cs')
+ let css'' = stackedChart gap css'
+ scratch $ (mempty, [], css'')
+
+trimmings :: (HudOptions, [Hud Double], [Chart Double]) -> [Chart Double]
+trimmings (ho, hs, cs) = runHud datarect (hs<>hoh) (cs<>hoc)
+ where
+ datarect = fixRect $ styleBoxes cs
+ (hoh, hoc) = makeHud datarect ho
+
+-- | testing
+scratch' :: (HudOptions, [Hud Double], [Chart Double]) -> IO ()
+scratch' = writeFile "other/scratch.svg" . renderCharts . trimmings
+
+scaleHudOptions :: Double -> HudOptions -> HudOptions
+scaleHudOptions x ho =
+ ho &
+ (#hudCanvas %~ fmap (scaleRectStyle x)) &
+ (#hudTitles %~ fmap (scaleTitle x)) &
+ (#hudAxes %~ fmap (scaleAxis x)) &
+ (#hudLegend %~ fmap (first (scaleLegendOptions x) . second (fmap (first (scaleAnnotation x)))))
+
+scaleAxis :: Double -> AxisOptions -> AxisOptions
+scaleAxis x ao =
+ ao &
+ #abar %~ fmap (scaleBar x) &
+ -- #adjust %~ fmap (scaleAdjustments x) &
+ #atick %~ scaleTick x
+
+scaleTitle :: Double -> Title -> Title
+scaleTitle x t = t & ((#style %~ (#size %~ (*x)))) & (((#buff %~ (*x))))
+
+scaleRectStyle :: Double -> RectStyle -> RectStyle
+scaleRectStyle x rs = rs & (#borderSize %~ (*x))
+
+scaleBar :: Double -> Bar -> Bar
+scaleBar x b = b & (#rstyle %~ scaleRectStyle x) & (#wid %~ (*x)) & (#buff %~ (*x))
+
+scaleAdjustments :: Double -> Adjustments -> Adjustments
+scaleAdjustments x a = a & (#maxXRatio %~ (*x)) & (#maxYRatio %~ (*x)) & (#angledRatio %~ (*x))
+
+scaleTick :: Double -> Tick -> Tick
+scaleTick x t =
+ t &
+ (#gtick %~ fmap (first ((#size %~ (*x)) . (#borderSize %~ (*x))) . second (*x))) &
+ (#ttick %~ fmap (first (#size %~ (*x)) . second (*x))) &
+ (#ltick %~ fmap (first (#width %~ (*x)) . second (*x)))
+
+scaleLegendOptions :: Double -> LegendOptions -> LegendOptions
+scaleLegendOptions x lo =
+ lo &
+ #lscale %~ (*x)
+
+scaleAnnotation :: Double -> Annotation -> Annotation
+scaleAnnotation x (LineA ls) = LineA (ls & #width %~ (*x))
+scaleAnnotation x (TextA ts t) = TextA (ts & #size %~ (*x)) t
+scaleAnnotation x (GlyphA gs) = GlyphA (gs & #size %~ (*x) & #borderSize %~ (*x))
+scaleAnnotation x (RectA rs) = RectA (rs & #borderSize %~ (*x))
+scaleAnnotation _ BlankA = BlankA
+scaleAnnotation x (PixelA ps) = PixelA (ps & #pixelRectStyle . #borderSize %~ (*x))
+
+
+
+-}
+
diff --git a/src/Ephemeral/Shekel.hs b/src/Ephemeral/Shekel.hs
new file mode 100644
--- /dev/null
+++ b/src/Ephemeral/Shekel.hs
@@ -0,0 +1,117 @@
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# LANGUAGE NegativeLiterals #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+
+-- | Function with a tricky shape useful for testing.
+--
+-- See
+--
+module Ephemeral.Shekel
+ ( shekel,
+ shekelp,
+ ) where
+
+import NumHask.Prelude as P
+import NumHask.Space
+
+-- $setup
+--
+-- >>> :set -XOverloadedStrings
+-- >>> :set -XOverloadedLabels
+-- >>> import NumHask.Prelude as P
+
+-- underlying shekel function constants
+sa :: [[Double]]
+sa =
+ [ [9.681, 0.667, 4.783, 9.095, 3.517, 9.325, 6.544, 0.211, 5.122, 2.020],
+ [9.400, 2.041, 3.788, 7.931, 2.882, 2.672, 3.568, 1.284, 7.033, 7.374],
+ [8.025, 9.152, 5.114, 7.621, 4.564, 4.711, 2.996, 6.126, 0.734, 4.982],
+ [2.196, 0.415, 5.649, 6.979, 9.510, 9.166, 6.304, 6.054, 9.377, 1.426],
+ [8.074, 8.777, 3.467, 1.863, 6.708, 6.349, 4.534, 0.276, 7.633, 1.567],
+ [7.650, 5.658, 0.720, 2.764, 3.278, 5.283, 7.474, 6.274, 1.409, 8.208],
+ [1.256, 3.605, 8.623, 6.905, 0.584, 8.133, 6.071, 6.888, 4.187, 5.448],
+ [8.314, 2.261, 4.224, 1.781, 4.124, 0.932, 8.129, 8.658, 1.208, 5.762],
+ [0.226, 8.858, 1.420, 0.945, 1.622, 4.698, 6.228, 9.096, 0.972, 7.637],
+ [7.305, 2.228, 1.242, 5.928, 9.133, 1.826, 4.060, 5.204, 8.713, 8.247],
+ [0.652, 7.027, 0.508, 4.876, 8.807, 4.632, 5.808, 6.937, 3.291, 7.016],
+ [2.699, 3.516, 5.874, 4.119, 4.461, 7.496, 8.817, 0.690, 6.593, 9.789],
+ [8.327, 3.897, 2.017, 9.570, 9.825, 1.150, 1.395, 3.885, 6.354, 0.109],
+ [2.132, 7.006, 7.136, 2.641, 1.882, 5.943, 7.273, 7.691, 2.880, 0.564],
+ [4.707, 5.579, 4.080, 0.581, 9.698, 8.542, 8.077, 8.515, 9.231, 4.670],
+ [8.304, 7.559, 8.567, 0.322, 7.128, 8.392, 1.472, 8.524, 2.277, 7.826],
+ [8.632, 4.409, 4.832, 5.768, 7.050, 6.715, 1.711, 4.323, 4.405, 4.591],
+ [4.887, 9.112, 0.170, 8.967, 9.693, 9.867, 7.508, 7.770, 8.382, 6.740],
+ [2.440, 6.686, 4.299, 1.007, 7.008, 1.427, 9.398, 8.480, 9.950, 1.675],
+ [6.306, 8.583, 6.084, 1.138, 4.350, 3.134, 7.853, 6.061, 7.457, 2.258],
+ [0.652, 2.343, 1.370, 0.821, 1.310, 1.063, 0.689, 8.819, 8.833, 9.070],
+ [5.558, 1.272, 5.756, 9.857, 2.279, 2.764, 1.284, 1.677, 1.244, 1.234],
+ [3.352, 7.549, 9.817, 9.437, 8.687, 4.167, 2.570, 6.540, 0.228, 0.027],
+ [8.798, 0.880, 2.370, 0.168, 1.701, 3.680, 1.231, 2.390, 2.499, 0.064],
+ [1.460, 8.057, 1.336, 7.217, 7.914, 3.615, 9.981, 9.198, 5.292, 1.224],
+ [0.432, 8.645, 8.774, 0.249, 8.081, 7.461, 4.416, 0.652, 4.002, 4.644],
+ [0.679, 2.800, 5.523, 3.049, 2.968, 7.225, 6.730, 4.199, 9.614, 9.229],
+ [4.263, 1.074, 7.286, 5.599, 8.291, 5.200, 9.214, 8.272, 4.398, 4.506],
+ [9.496, 4.830, 3.150, 8.270, 5.079, 1.231, 5.731, 9.494, 1.883, 9.732],
+ [4.138, 2.562, 2.532, 9.661, 5.611, 5.500, 6.886, 2.341, 9.699, 6.500]
+ ]
+
+sc :: [Double]
+sc =
+ [ 0.806,
+ 0.517,
+ 0.1,
+ 0.908,
+ 0.965,
+ 0.669,
+ 0.524,
+ 0.902,
+ 0.531,
+ 0.876,
+ 0.462,
+ 0.491,
+ 0.463,
+ 0.714,
+ 0.352,
+ 0.869,
+ 0.813,
+ 0.811,
+ 0.828,
+ 0.964,
+ 0.789,
+ 0.360,
+ 0.369,
+ 0.992,
+ 0.332,
+ 0.817,
+ 0.632,
+ 0.883,
+ 0.608,
+ 0.326
+ ]
+
+sdiff :: [Double] -> [Double]
+sdiff xs = fmap ((sum . fmap (**2)) . zipWith (-) xs) sa
+
+sinv :: [Double] -> Double
+sinv xs = sum $ fmap (** -1) (zipWith (+) xs sc)
+
+-- | The shekel function applied to a list and roughly normalised to Range (-0.5) 0.5
+--
+-- >>> shekel [0.302, 0.412, 0.5]
+-- 0.614769661738902
+--
+shekel :: [Double] -> Double
+shekel = sinv . sdiff
+
+-- | The shekel function applied to a Point and roughly normalised to a Rect.unit
+--
+-- >>> shekelp (Point 0.302 0.412)
+-- 1.1945742676096427
+--
+shekelp :: Point Double -> Double
+shekelp (Point x y) = sinv . sdiff $ [x,y]
+
diff --git a/test/test.hs b/test/test.hs
new file mode 100644
--- /dev/null
+++ b/test/test.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -Wall #-}
+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
+
+module Main where
+
+import NumHask.Prelude
+import Test.DocTest
+
+main :: IO ()
+main =
+ doctest
+ [
+ "src/Ephemeral/Market.hs",
+ "src/Ephemeral/Shekel.hs",
+ "src/Ephemeral/Chart.hs"
+ ]