diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2020, Tony Day
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Tony Day nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/ephemeral.cabal b/ephemeral.cabal
--- a/ephemeral.cabal
+++ b/ephemeral.cabal
@@ -1,80 +1,51 @@
-cabal-version: 2.4
+cabal-version: 3.0
name: ephemeral
-version: 0.0.1
-synopsis: See readme.md
-description: See readme.md for description.
-category: project
+version: 0.0.2.0
+license: BSD-3-Clause
+license-file: LICENSE
+copyright: Tony Day (c) 2020
+category: machine learning
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
+synopsis: See readme.md
+description: See readme.md for description.
build-type: Simple
-extra-doc-files: other/*.svg
+tested-with:
+ , GHC == 9.10.1
+ , GHC == 9.6.5
+ , GHC == 9.8.2
+extra-doc-files:
+ readme.md
+
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
+ type: git
+ location: https://github.com/tonyday567/ephemeral
- 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
+common ghc-options-stanza
+ ghc-options:
+ -Wall
+ -Wcompat
+ -Widentities
+ -Wincomplete-record-updates
+ -Wincomplete-uni-patterns
+ -Wpartial-fields
+ -Wredundant-constraints
-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
+common ghc2021-stanza
+ default-language: GHC2021
+
+library
+ import: ghc-options-stanza
+ import: ghc2021-stanza
+ hs-source-dirs: src
+ build-depends:
+ , base >=4.7 && <5
+ , free >=5.2 && <5.3
+ , numhask >=0.11 && <0.13
+ , profunctors >=5.6.2 && <5.7
+ exposed-modules:
+ Ephemeral.Hughes
+ Ephemeral.Search
+ Ephemeral.Shekel
diff --git a/other/allreturns.svg b/other/allreturns.svg
deleted file mode 100644
--- a/other/allreturns.svg
+++ /dev/null
@@ -1,12043 +0,0 @@
-
diff --git a/other/scratch.svg b/other/scratch.svg
deleted file mode 100644
--- a/other/scratch.svg
+++ /dev/null
@@ -1,58 +0,0 @@
-
diff --git a/other/shekeld.svg b/other/shekeld.svg
deleted file mode 100644
--- a/other/shekeld.svg
+++ /dev/null
@@ -1,49 +0,0 @@
-
diff --git a/other/shekelp.svg b/other/shekelp.svg
deleted file mode 100644
--- a/other/shekelp.svg
+++ /dev/null
@@ -1,6 +0,0 @@
-
diff --git a/other/surface.svg b/other/surface.svg
deleted file mode 100644
--- a/other/surface.svg
+++ /dev/null
@@ -1,5 +0,0 @@
-
diff --git a/readme.md b/readme.md
new file mode 100644
--- /dev/null
+++ b/readme.md
@@ -0,0 +1,130 @@
+[](https://hackage.haskell.org/package/ephemeral)
+[](https://github.com/tonyday567/ephemeral/actions)
+
+Functional
+Machinery,
+Rapid
+Learning
+
+# What is Learning?
+
+> 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
+
+Here’s how I unpacked this into types:
+
+ -- | 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 }
+
+A common approach to newtypes is to label the unwrapping as a reversal
+of the newtype (such as \`unlearn\` or \`unLearn\`) but this misses an
+important naming opportunity: to use a Learn is to change.
+
+ -- | An experience is a set of e's
+ newtype Experience f e =
+ Experience { set :: f e }
+
+ -- | A task takes an e and measures
+ -- performance.
+ newtype Task e p =
+ Task { measure :: e -> p }
+ deriving (Profunctor)
+
+This could be thought of (and coded) as an ordinary function with type
+(e -> p). The advantage of using a newtype, however, is to highlight the
+two ways that a task can change:
+
+- changing the way a task is performed (the \`e\`).
+- changing the way a task is measured (the \`p\`).
+
+Acting on a learning, you can change the way a task is performed, such
+as changing parameters of a function, or change the way you view what
+performance is.
+
+To change the way a task is performed, taking experience into account,
+is to make progress. Progress is made one step at a time.
+
+ -- | To progress, is to transduce
+ -- a Task, via a carrier
+ newtype Progress e p =
+ Progress {
+ step :: e -> Task e p -> Task e p
+ }
+
+Putting these above types together in a useful way, to learn, is then to
+repeatedly apply a progressive step to a set of experiences.
+
+ -- | to learn, is to make Progress
+ -- from an Experience.
+ learn :: Progress e p -> Learn f e p
+ learn p =
+ Learn $
+ \(Experience e) task ->
+ foldr (step p) task e
+
+To \`machine learn\`, we change the way a \`machine\` does a task, based on
+learning, measuring whether performance improves, and adopt the new way
+to do a task if it does.
+
+ -- | to improve, given a way to change
+ -- a task by experience,
+ -- you need to choose the better
+ -- performance 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
+
+The constraints contained in the above code are mostly based on
+suggestions from ghc to get a compile, and I didn’t think about them
+much in drafting. Type constraints provide useful guide-rails for future
+development of these ideas.
+
+
+# Machine Learning in Haskell?
+
+In the above example of improving we are left with an \`Ord (f p)\`
+constraint - that the performance over an experience set is ordinal. If
+we narrow the constraint to a \`Num (f p)\`, in other words, assume that
+the size of the \`f p\` is meaningful, then we have wandered in to the
+traditional numerical methods domain, and can, for example, start to
+think about gradients to speed up our improvement.
+
+By insisting on useful and concrete names (aka types), Haskell supplies
+a constrained domain we can further explore. For example, are there
+machine learning examples that don’t fit the candidate types and
+constraints?
+
+Naming things is hard, and other ways of coding tend to avoid the task.
+Types bring me joy and I shall keep them, thank you very much, and
+continue to curate collections of them, for fun and profit. In this
+example, I now have as good a definition of machine learning as you’ll
+find out in the wild, and my progress on machine learning will be more
+comprehensive, faster and safer than bashing away in python.
+
+And yet, to a first degree, machine learning in Haskell does not exist,
+swamped by the easiness of dynamic types. If the promises being made by
+ML are to be eventually honoured, however, it may need less code bashing
+and better naming.
+
+
diff --git a/src/Ephemeral/Chart.hs b/src/Ephemeral/Chart.hs
deleted file mode 100644
--- a/src/Ephemeral/Chart.hs
+++ /dev/null
@@ -1,49 +0,0 @@
-{-# 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/Hughes.hs b/src/Ephemeral/Hughes.hs
new file mode 100644
--- /dev/null
+++ b/src/Ephemeral/Hughes.hs
@@ -0,0 +1,219 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RebindableSyntax #-}
+{-# OPTIONS_GHC -Wno-x-partial #-}
+
+module Ephemeral.Hughes where
+
+import Control.Comonad.Cofree
+import Data.Functor.Identity
+import NumHask.Prelude
+
+-- Cofree Identity
+type Free :: (Type -> Type) -> (Type -> Type)
+data Free f a = Pure a | Free (f (Free f a))
+
+-- https://www.reddit.com/r/haskell/comments/mf8588/deriving_via_free_and_cofree/
+-- Hopes <~> Free Maybe
+type Hopes :: Type -> Type
+data Hopes a = Confirmed a | Failed | Possible (Hopes a)
+
+-- type Cofree :: (Type -> Type) -> (Type -> Type)
+-- data Cofree f a = a :< f (Cofree f a)
+limit :: (Ord a, Subtractive a, Absolute a) => a -> Cofree Identity a -> a
+limit eps (x0 :< Identity xs0) = go x0 xs0
+ where
+ go x (x' :< Identity xs) = bool (go x' xs) x' (abs (x - x') < eps)
+
+-- limitf :: (Ord a, Num a) => a -> Cofree Identity a -> a
+limitf :: (Ord a, Subtractive a, Absolute a) => a -> Cofree Identity a -> a
+limitf eps = fix (\rec (x :< Identity xs@(x' :< _)) -> bool (rec xs) x' (abs (x - x') < eps))
+
+approach :: (Ord a, Subtractive a, Absolute a) => a -> (a -> a) -> a
+approach eps f = limit eps (coiter (Identity . f) one)
+
+approachf :: (Ord a, Subtractive a, Absolute a) => a -> (a -> a) -> a
+approachf eps f = limitf eps (coiter (Identity . f) one)
+
+sqrootStep :: (Additive a, Divisive a) => a -> a -> a
+sqrootStep a x = (x + a / x) / two
+
+sqroot'' :: (Ord a, Absolute a, Field a) => a -> a -> a
+sqroot'' eps a = approach eps (sqrootStep a)
+
+sqrootf :: (Ord a, Absolute a, Field a) => a -> a -> a
+sqrootf eps a = approachf eps (sqrootStep a)
+
+approach' :: (Ord a, Absolute a, Field a) => a -> (a -> a) -> a
+approach' eps f = limit_ eps (iterate f one)
+
+sqroot' :: (Ord a, Absolute a, Field a) => a -> a -> a
+sqroot' eps a = approach' eps (sqrootStep a)
+
+limit_ :: (Ord a, Absolute a, Field a) => a -> [a] -> a
+limit_ _ [] = error ("empty" :: String)
+limit_ eps (x0 : xs0) = go x0 xs0
+ where
+ go x [] = x
+ go x (x' : xs) = bool (go x' xs) x' (abs (x - x') < eps)
+
+limitm :: (Ord a, Absolute a, Field a) => a -> [a] -> a
+limitm _ [] = error ("empty" :: String)
+limitm eps (x0 : xs0) = go x0 xs0
+ where
+ go x [] = x
+ go x (x' : xs) = bool (go x' xs) x' (abs (x / x' - one) < eps)
+
+-- | sqroot limit_ test
+--
+-- >>> sqroot 0.0001 2
+-- 1.4142135623746899
+sqroot :: (Ord a, Absolute a, Field a) => a -> a -> a
+sqroot eps a = limit_ eps (iterate next one)
+ where
+ next x = (x + a / x) / two
+
+-- | Find the derivative of a function at a point.
+--
+-- >>> deriv 0.00001 (\x -> x * x) 3
+-- 6.000007629394531
+--
+-- >>> deriv 0.00001 (sqroot 0.00001) 2
+-- 0.35354799598098907
+deriv :: (Ord a, Absolute a, Field a) => a -> (a -> a) -> a -> a
+deriv eps f x =
+ limit_ eps (map slope (iterate (/ two) one))
+ where
+ slope h = (f (x + h) - f x) / h
+
+-- | Integrgrate a function over a range.
+--
+-- >>> integrate 0.00001 (sqroot 0.00001) 1 2
+-- 1.218945096090038
+-- >>> f x = x ** 1.5 / 1.5
+-- >>> f 2 - f 1
+-- 1.2189514164974602
+integrate :: (Ord a, Subtractive a, Absolute a, QuotientField a, Whole a ~ Int) => a -> (a -> a) -> a -> a -> a
+integrate eps f a b =
+ limit_ eps (map area (iterate (/ two) one))
+ where
+ area h = sum $ (h *) . f <$> take (floor $ (b - a) / h) (iterate (+ h) a)
+
+integrate' :: (Subtractive a, Absolute a, QuotientField a, Whole a ~ Int) => (a -> a) -> a -> a -> [a]
+integrate' f a b =
+ map area (iterate (/ two) one)
+ where
+ area h = sum $ (h *) . f <$> take (floor $ (b - a) / h) (iterate (+ h) a)
+
+-- | Hughes' improve idea
+--
+-- A + B * h^n
+-- A + B * (h/2)^n
+improve :: (Absolute a, Field a) => Int -> [a] -> [a]
+improve _ [] = []
+improve _ [x] = [x]
+improve n (a : b : rest) = (b * two ^ n - a) / (two ^ n - one) : improve n (b : rest)
+
+-- improveall :: (Fractional a, Num t) => t -> (Int -> [a] -> [a]) -> [Int -> [a] -> [a]]
+improveall :: (Absolute a, Field a) => Int -> [a] -> [[a]]
+improveall n s = s : improveall (n + 1) (improve n s)
+
+-- >>> limit_ 0.00000001 $ super (integrate' sin 0 4)
+-- 1.6536436208622662
+super :: (Absolute a, Field a) => [a] -> [a]
+super s = map head (improveall 1 s)
+
+-- | Newton-Raphson method for finding roots.
+newtonRaphson :: Double -> (Double -> Double) -> Double
+newtonRaphson guess f
+ | difference <= epsilon = newguess
+ | otherwise = newtonRaphson newguess f
+ where
+ newguess = guess - f guess / fprime guess
+ difference = abs (newguess - guess)
+ fprime = derivative f
+
+newtonRaphson2 :: Double -> (Double -> Double) -> (Double -> Double) -> Double
+newtonRaphson2 guess f fprime
+ | difference <= epsilon = newguess
+ | otherwise = newtonRaphson2 newguess f fprime
+ where
+ newguess = guess - f guess / fprime guess
+ difference = abs (newguess - guess)
+
+-- | Newton's method for finding optimization of functions.
+optimize :: (Double -> Double) -> Double -> Double
+optimize f guess = newtonRaphson guess g
+ where
+ g x = derivative2 f x / derivSecond f x
+
+-- | Numerical method for finding the square root.
+mysqrt :: Double -> Double -> Double
+mysqrt a x
+ | difference <= epsilon = newguess
+ | otherwise = mysqrt a newguess
+ where
+ newguess = (1 / 2) * (x + a / x)
+ difference = abs (newguess - x)
+
+-- | returns an approximation of the derivative
+-- using forward differences.
+derivative :: (Double -> Double) -> Double -> Double
+derivative f x = (f (x + epsilon) - f x) / epsilon
+
+-- | returns an approximation of the derivative using the symmetric
+-- difference quotient.
+derivative2 :: (Double -> Double) -> Double -> Double
+derivative2 f x = (f (x + epsilon) - f (x - epsilon)) / (2 * epsilon)
+
+-- finite central differences.
+derivative3 :: (Double -> Double) -> Double -> Double
+derivative3 f x = (d - 8 * c + 8 * b - a) / (12 * epsilon)
+ where
+ a = f (x + 2 * epsilon)
+ b = f (x + epsilon)
+ c = f (x - epsilon)
+ d = f (x - 2 * epsilon)
+
+-- | returns the second derivative of a function.
+derivSecond :: (Double -> Double) -> Double -> Double
+derivSecond f x = (f (x + epsilon) - 2 * f x + f (x - epsilon)) / epsilon ** 2
+
+deriv' :: (Double -> Double) -> Double -> Double
+deriv' f x = (f (x + dx) - f x) / dx
+ where
+ dx = epsilon * x
+
+-- root finding
+
+-- f (root f) = 0
+-- inverse f y = root (\x -> f x - y)
+-- extremum f = root (derivative f)
+-- https://hackage.haskell.org/package/math-functions-0.3.4.2/docs/Numeric-RootFinding.html#g:3
+
+-- bisection
+-- f a * f b < 0
+
+bisection ::
+ (Absolute a, Field a, Ord a, Epsilon a, Field b, Ord b) =>
+ (a -> b) ->
+ a ->
+ a ->
+ a
+bisection f a b = let av = (b + a) / two in bool (bool (bisection f av b) (bisection f a av) (f a * f av < zero)) av (b - a < epsilon)
+
+newton :: (Epsilon a, Absolute a, Field a, Ord a) => (a -> a) -> (a -> a) -> a -> a
+newton f f' guess =
+ let newGuess = guess - (f guess / f' guess)
+ err = abs (newGuess - guess)
+ in bool (newton f f' newGuess) newGuess (err < epsilon)
+
+towardRoot :: (Field a) => (a -> a) -> (a -> a) -> a -> a
+towardRoot f f' x = x - f x / f' x
+
+secant :: (Epsilon a, Absolute a, Field a, Ord a) => (a -> a) -> a -> a -> a
+secant f guess1 guess0 =
+ let newGuess = guess1 - f guess1 * (guess1 - guess0) / (f guess1 - f guess0)
+ err = abs (newGuess - guess1)
+ in if err < epsilon
+ then newGuess
+ else secant f newGuess guess1
diff --git a/src/Ephemeral/Learn.hs b/src/Ephemeral/Learn.hs
deleted file mode 100644
--- a/src/Ephemeral/Learn.hs
+++ /dev/null
@@ -1,123 +0,0 @@
-{-# 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
deleted file mode 100644
--- a/src/Ephemeral/Market.hs
+++ /dev/null
@@ -1,484 +0,0 @@
-{-# 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/Search.hs b/src/Ephemeral/Search.hs
new file mode 100644
--- /dev/null
+++ b/src/Ephemeral/Search.hs
@@ -0,0 +1,174 @@
+{-# OPTIONS_GHC -Wno-unused-binds #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
+-- | 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
+module Ephemeral.Search where
+
+import Data.Bool
+import Data.Functor.Identity
+import Data.Profunctor
+import GHC.Generics
+import Prelude
+
+-- | 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.
+--
+-- TODO: How would this hook into the nucleus of a profunctor memes?
+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}
+
+-- | population
+newtype Population f a = Population {individuals :: f a} deriving (Generic)
+
+-- | 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
+--
+-- isomorphic to a coalgebra (a -> g a)
+type Neighbourhood = Heuristic Identity
+
+-- | mutation is isomorphic to (->).
+type Mutation = Heuristic Identity Identity
+
+-- | foldable/an algebra
+--
+-- f a -> a
+type Crossover f = Heuristic f Identity
+
+-- | an individual can also be a carrier of the algebra
+type Individual a = Population Identity a
+
+-- | to learn, is to make Progress (good, bad or ugly) from an Experience.
+--
+-- In an online setting, processing streamed data, say, this is an update of the state of a Moore machine.
+--
+-- It doesn't allow for Mealy machine networks, where the Mealy's can fire independently of their inputs.
+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 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
+
+-- * sub-component as topologist
+
+--
+-- The whole problem with this setup is the `(>)` on the measured fitness value. It introduces an a priori: that the only thing worth knowing is which way is up, and that the only way forward is to proceed to the summit. There may be some trickiness needed to jump over local hills and find the ultimate high spot, but we will get there faster or more reliably than anyone else can. Finally, it tightly couples progress with computing the next value.
+--
+-- If we asked our sub-components, such as improve, to instead report on the topology and statistics of the space, then the usual learning processes (under the hood of every machine learning algorithm ever built) is actually a degenerate version, providing a summary consisting of the minimum or maximum value and where it's located.
+--
+-- IN this refactor, `next` would never know, as a sub-component, how many times it will be called. The first few suggestions might be random or grid-spaced if it's well-bounded. The next few would certainly try to extrapolate the results and search the highest and lowest gradient paths to see the local peaks and troughs. What then?
+--
+-- The AI solution, where a more topological approach is used, usually advocates a "shared fitness" approach where fitness for an individual is computed by also taking into account neighbouring results. K-means clustering is the iconic approach. With this reorientation, this appraoch can be seen as a clunky way to compensate for the API focus on the best individual and subsequent hinge point created for progress to use fitness as the sole criteria.
+--
+-- The shared fitness approach includes a rule of thumb that parameter space sections consisting of broad, high tableland shapes should be preferentially explored. This may be a natural outcome of this refactor.
+--
+-- An interesting design is where next is not supplied with any notion of distance for individual parameter elements and must make it's way by supplying it's own empirical notion of parameter distance. In this way, the statistics that it uses are topological as well. Associated to this is for next to form it's own ideas about the value of K in K-Means.
+--
+-- Bulk processing of populations using this structure seems more about the heuristic shortcuts in peoples minds than any formal feature of the problem domain. The API is simplified by generating just one suggestion at a time, and allowing bulk efficiencies to be explored above upstream.
+
+data Topology a p
+
+-- | generate the next parameter choice to be tested.
+next :: Topology a p -> a
+next = undefined
+
+-- | update the space summary
+--
+-- Is Topology really Task in disguise but a higher-kinded layer up?
+-- newtype Progress e p = Progress { step :: e -> Task e p -> Task e p}
+--
+-- Actual computation of the next suggestion is not guaranteed, so the fitness, p, is a Maybe to allow for the potential for delays in feeding the result of an individual test back, or if there is another process that rejects the suggestion.
+--
+-- as an alternative there could be a direct conversion to Topology, with Topology being monoidal.
+-- toTop :: (a, Maybe p) -> Topology a p
+--
+-- so update becomes `(<>) . toTop`
+update :: (a, Maybe p) -> Topology a p -> Topology a p
+update = undefined
+
+-- also useful would be to back out a point from the topology, if, for example, you were replacing a previous suggestion, with one that now included a fitness value.
+delete :: (a, Maybe p) -> Topology a p -> Topology a p
+delete = undefined
+
+-- Evaluation of good search to a single value potentially recovers the old notion of optimisation or maximisation, given the broader objective.
+searched :: Topology a p -> Double
+searched = undefined
+
+init :: Topology a p
+init = undefined
+
+{-
+
+A good example may be the degenerate case of exploring the surface of what turns out to be a sphere. Suggested candidate parameters should quickly find their way to near the surface and then fan out across it with a smooth denisity.
+
+-}
+
+-- * linear regression examples
+
+-- | This is a major categorization in machine learning, and probably a silly way if you were to start fromn scratch.
+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' :: (Num a) => Params a -> ([a], a) -> a
+error' (Params bs) (es, y) = sum (zipWith (*) bs (1 : es)) - y
+
+-- | errors over an Experience set
+errors :: (Functor f, Num a) => Params a -> Experience f ([a], a) -> f a
+errors p (Experience es) = error' p <$> es
+
+-- | The value of a population, for each experience.
+value ::
+ (Traversable p, Traversable e, Applicative e, Num 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
+
+-- * complex convergence
+
+--
+-- but this is tuned to the value-centric cycle approach.
+--
+data Dir = Up | Down deriving (Eq, Show)
+
+data Stops a b
+ = MaxIterations Int
+ | Converged a
+ | NotConverging
+ deriving (Eq, Show, Generic)
+
+defaultStops :: a -> [Stops a b]
+defaultStops eps = [MaxIterations 100, Converged eps, NotConverging]
diff --git a/src/Ephemeral/Shekel.hs b/src/Ephemeral/Shekel.hs
--- a/src/Ephemeral/Shekel.hs
+++ b/src/Ephemeral/Shekel.hs
@@ -1,28 +1,23 @@
-{-# LANGUAGE MonoLocalBinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RebindableSyntax #-}
-{-# LANGUAGE NegativeLiterals #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Function with a tricky shape useful for testing.
--
-- See
---
module Ephemeral.Shekel
( shekel,
shekelp,
- ) where
+ )
+where
-import NumHask.Prelude as P
-import NumHask.Space
+import Prelude
-- $setup
--
-- >>> :set -XOverloadedStrings
-- >>> :set -XOverloadedLabels
--- >>> import NumHask.Prelude as P
+-- >>> import Prelude
-- underlying shekel function constants
sa :: [[Double]]
@@ -94,24 +89,21 @@
]
sdiff :: [Double] -> [Double]
-sdiff xs = fmap ((sum . fmap (**2)) . zipWith (-) xs) sa
+sdiff xs = fmap ((sum . fmap (** 2)) . zipWith (-) xs) sa
sinv :: [Double] -> Double
-sinv xs = sum $ fmap (** -1) (zipWith (+) xs sc)
+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
---
+-- 0.6147696617389021
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)
+-- >>> shekelp (0.302, 0.412)
-- 1.1945742676096427
---
-shekelp :: Point Double -> Double
-shekelp (Point x y) = sinv . sdiff $ [x,y]
-
+shekelp :: (Double, Double) -> Double
+shekelp (x, y) = sinv . sdiff $ [x, y]
diff --git a/test/test.hs b/test/test.hs
deleted file mode 100644
--- a/test/test.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# 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"
- ]