module Goal.Geometry.Differential.GradientPursuit
(
cauchyLimit
, cauchySequence
, vanillaGradient
, gradientStep
, GradientPursuit (Classic,Momentum,Adam)
, gradientPursuitStep
, gradientSequence
, vanillaGradientSequence
, gradientCircuit
, vanillaGradientCircuit
, defaultMomentumPursuit
, defaultAdamPursuit
) where
import Goal.Core
import Goal.Geometry.Manifold
import Goal.Geometry.Vector
import Goal.Geometry.Differential
import qualified Goal.Core.Vector.Storable as S
cauchyLimit
:: (c # x -> c # x -> Double)
-> Double
-> [c # x]
-> c # x
{-# INLINE cauchyLimit #-}
cauchyLimit :: ((c # x) -> (c # x) -> Double) -> Double -> [c # x] -> c # x
cauchyLimit (c # x) -> (c # x) -> Double
f Double
eps [c # x]
ps = [c # x] -> c # x
forall a. [a] -> a
last ([c # x] -> c # x) -> [c # x] -> c # x
forall a b. (a -> b) -> a -> b
$ ((c # x) -> (c # x) -> Double) -> Double -> [c # x] -> [c # x]
forall c x.
((c # x) -> (c # x) -> Double) -> Double -> [c # x] -> [c # x]
cauchySequence (c # x) -> (c # x) -> Double
f Double
eps [c # x]
ps
cauchySequence
:: (c # x -> c # x -> Double)
-> Double
-> [c # x]
-> [c # x]
{-# INLINE cauchySequence #-}
cauchySequence :: ((c # x) -> (c # x) -> Double) -> Double -> [c # x] -> [c # x]
cauchySequence (c # x) -> (c # x) -> Double
f Double
eps [c # x]
ps =
let pps :: [(c # x, c # x)]
pps = ((c # x, c # x) -> Bool) -> [(c # x, c # x)] -> [(c # x, c # x)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (c # x, c # x) -> Bool
taker ([(c # x, c # x)] -> [(c # x, c # x)])
-> ([c # x] -> [(c # x, c # x)]) -> [c # x] -> [(c # x, c # x)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [c # x] -> [c # x] -> [(c # x, c # x)]
forall a b. [a] -> [b] -> [(a, b)]
zip [c # x]
ps ([c # x] -> [(c # x, c # x)]) -> [c # x] -> [(c # x, c # x)]
forall a b. (a -> b) -> a -> b
$ [c # x] -> [c # x]
forall a. [a] -> [a]
tail [c # x]
ps
in [c # x] -> c # x
forall a. [a] -> a
head [c # x]
ps (c # x) -> [c # x] -> [c # x]
forall a. a -> [a] -> [a]
: ((c # x, c # x) -> c # x) -> [(c # x, c # x)] -> [c # x]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (c # x, c # x) -> c # x
forall a b. (a, b) -> b
snd [(c # x, c # x)]
pps
where taker :: (c # x, c # x) -> Bool
taker (c # x
p1,c # x
p2) = Double
eps Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< (c # x) -> (c # x) -> Double
f c # x
p1 c # x
p2
vanillaGradient :: Manifold x => c #* x -> c # x
{-# INLINE vanillaGradient #-}
vanillaGradient :: (c #* x) -> c # x
vanillaGradient = (c #* x) -> c # x
forall x y c d. (Dimension x ~ Dimension y) => (c # x) -> Point d y
breakPoint
gradientStep
:: Manifold x
=> Double
-> c # x
-> c # x
-> c # x
{-# INLINE gradientStep #-}
gradientStep :: Double -> (c # x) -> (c # x) -> c # x
gradientStep Double
eps (Point Vector (Dimension x) Double
xs) c # x
pd =
Vector (Dimension x) Double -> c # x
forall c x. Vector (Dimension x) Double -> Point c x
Point (Vector (Dimension x) Double -> c # x)
-> Vector (Dimension x) Double -> c # x
forall a b. (a -> b) -> a -> b
$ Vector (Dimension x) Double
xs Vector (Dimension x) Double
-> Vector (Dimension x) Double -> Vector (Dimension x) Double
forall a. Num a => a -> a -> a
+ (c # x) -> Vector (Dimension x) Double
forall c x. Point c x -> Vector (Dimension x) Double
coordinates (Double
eps Double -> (c # x) -> c # x
forall c x. Double -> (c # x) -> c # x
.> c # x
pd)
data GradientPursuit
= Classic
| Momentum (Int -> Double)
| Adam Double Double Double
defaultMomentumPursuit :: Double -> GradientPursuit
{-# INLINE defaultMomentumPursuit #-}
defaultMomentumPursuit :: Double -> GradientPursuit
defaultMomentumPursuit Double
mxmu = (Int -> Double) -> GradientPursuit
Momentum Int -> Double
fmu
where fmu :: Int -> Double
fmu Int
k = Double -> Double -> Double
forall a. Ord a => a -> a -> a
min Double
mxmu (Double -> Double) -> Double -> Double
forall a b. (a -> b) -> a -> b
$ Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double
2Double -> Double -> Double
forall a. Floating a => a -> a -> a
**((Double -> Double
forall a. Num a => a -> a
negate Double
1 Double -> Double -> Double
forall a. Num a => a -> a -> a
-) (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double
forall a. Floating a => a -> a -> a
logBase Double
2 (Double -> Double) -> (Int -> Double) -> Int -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double) -> Int -> Double
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
k Int
250 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
defaultAdamPursuit :: GradientPursuit
{-# INLINE defaultAdamPursuit #-}
defaultAdamPursuit :: GradientPursuit
defaultAdamPursuit = Double -> Double -> Double -> GradientPursuit
Adam Double
0.9 Double
0.999 Double
1e-8
gradientPursuitStep
:: Manifold x
=> Double
-> GradientPursuit
-> Int
-> c # x
-> c # x
-> [c # x]
-> (c # x, [c # x])
{-# INLINE gradientPursuitStep #-}
gradientPursuitStep :: Double
-> GradientPursuit
-> Int
-> (c # x)
-> (c # x)
-> [c # x]
-> (c # x, [c # x])
gradientPursuitStep Double
eps GradientPursuit
Classic Int
_ c # x
cp c # x
dp [c # x]
_ = (Double -> (c # x) -> (c # x) -> c # x
forall x c. Manifold x => Double -> (c # x) -> (c # x) -> c # x
gradientStep Double
eps c # x
cp c # x
dp,[])
gradientPursuitStep Double
eps (Momentum Int -> Double
fmu) Int
k c # x
cp c # x
dp (c # x
v:[c # x]
_) =
let (c # x
p,c # x
v') = Double -> Double -> (c # x) -> (c # x) -> (c # x) -> (c # x, c # x)
forall x c.
Manifold x =>
Double -> Double -> (c # x) -> (c # x) -> (c # x) -> (c # x, c # x)
momentumStep Double
eps (Int -> Double
fmu Int
k) c # x
cp c # x
dp c # x
v
in (c # x
p,[c # x
v'])
gradientPursuitStep Double
eps (Adam Double
b1 Double
b2 Double
rg) Int
k c # x
cp c # x
dp (c # x
m:c # x
v:[c # x]
_) =
let (c # x
p,c # x
m',c # x
v') = Double
-> Double
-> Double
-> Double
-> Int
-> (c # x)
-> (c # x)
-> (c # x)
-> (c # x)
-> (c # x, c # x, c # x)
forall x c.
Manifold x =>
Double
-> Double
-> Double
-> Double
-> Int
-> (c # x)
-> (c # x)
-> (c # x)
-> (c # x)
-> (c # x, c # x, c # x)
adamStep Double
eps Double
b1 Double
b2 Double
rg Int
k c # x
cp c # x
dp c # x
m c # x
v
in (c # x
p,[c # x
m',c # x
v'])
gradientPursuitStep Double
_ GradientPursuit
_ Int
_ c # x
_ c # x
_ [c # x]
_ = [Char] -> (c # x, [c # x])
forall a. HasCallStack => [Char] -> a
error [Char]
"Momentum list length mismatch in gradientPursuitStep"
gradientSequence
:: Riemannian c x
=> (c # x -> c #* x)
-> Double
-> GradientPursuit
-> c # x
-> [c # x]
{-# INLINE gradientSequence #-}
gradientSequence :: ((c # x) -> c #* x)
-> Double -> GradientPursuit -> (c # x) -> [c # x]
gradientSequence (c # x) -> c #* x
f Double
eps GradientPursuit
gp c # x
p0 =
(c # x, ([c # x], Int)) -> c # x
forall a b. (a, b) -> a
fst ((c # x, ([c # x], Int)) -> c # x)
-> [(c # x, ([c # x], Int))] -> [c # x]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((c # x, ([c # x], Int)) -> (c # x, ([c # x], Int)))
-> (c # x, ([c # x], Int)) -> [(c # x, ([c # x], Int))]
forall a. (a -> a) -> a -> [a]
iterate (c # x, ([c # x], Int)) -> (c # x, ([c # x], Int))
iterator (c # x
p0,((c # x) -> [c # x]
forall a. a -> [a]
repeat c # x
0,Int
0))
where iterator :: (c # x, ([c # x], Int)) -> (c # x, ([c # x], Int))
iterator (c # x
p,([c # x]
vs,Int
k)) =
let dp :: c # x
dp = (c # x) -> (c #* x) -> c # x
forall c x. Riemannian c x => (c # x) -> (c #* x) -> c # x
sharp c # x
p ((c #* x) -> c # x) -> (c #* x) -> c # x
forall a b. (a -> b) -> a -> b
$ (c # x) -> c #* x
f c # x
p
(c # x
p',[c # x]
vs') = Double
-> GradientPursuit
-> Int
-> (c # x)
-> (c # x)
-> [c # x]
-> (c # x, [c # x])
forall x c.
Manifold x =>
Double
-> GradientPursuit
-> Int
-> (c # x)
-> (c # x)
-> [c # x]
-> (c # x, [c # x])
gradientPursuitStep Double
eps GradientPursuit
gp Int
k c # x
p c # x
dp [c # x]
vs
in (c # x
p',([c # x]
vs',Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
vanillaGradientSequence
:: Manifold x
=> (c # x -> c #* x)
-> Double
-> GradientPursuit
-> c # x
-> [c # x]
{-# INLINE vanillaGradientSequence #-}
vanillaGradientSequence :: ((c # x) -> c #* x)
-> Double -> GradientPursuit -> (c # x) -> [c # x]
vanillaGradientSequence (c # x) -> c #* x
f Double
eps GradientPursuit
gp c # x
p0 =
(c # x, ([c # x], Int)) -> c # x
forall a b. (a, b) -> a
fst ((c # x, ([c # x], Int)) -> c # x)
-> [(c # x, ([c # x], Int))] -> [c # x]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((c # x, ([c # x], Int)) -> (c # x, ([c # x], Int)))
-> (c # x, ([c # x], Int)) -> [(c # x, ([c # x], Int))]
forall a. (a -> a) -> a -> [a]
iterate (c # x, ([c # x], Int)) -> (c # x, ([c # x], Int))
iterator (c # x
p0,((c # x) -> [c # x]
forall a. a -> [a]
repeat c # x
0,Int
0))
where iterator :: (c # x, ([c # x], Int)) -> (c # x, ([c # x], Int))
iterator (c # x
p,([c # x]
vs,Int
k)) =
let dp :: c # x
dp = (c #* x) -> c # x
forall x c. Manifold x => (c #* x) -> c # x
vanillaGradient ((c #* x) -> c # x) -> (c #* x) -> c # x
forall a b. (a -> b) -> a -> b
$ (c # x) -> c #* x
f c # x
p
(c # x
p',[c # x]
vs') = Double
-> GradientPursuit
-> Int
-> (c # x)
-> (c # x)
-> [c # x]
-> (c # x, [c # x])
forall x c.
Manifold x =>
Double
-> GradientPursuit
-> Int
-> (c # x)
-> (c # x)
-> [c # x]
-> (c # x, [c # x])
gradientPursuitStep Double
eps GradientPursuit
gp Int
k c # x
p c # x
dp [c # x]
vs
in (c # x
p',([c # x]
vs',Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
gradientCircuit
:: (Monad m, Manifold x)
=> Double
-> GradientPursuit
-> Circuit m (c # x, c # x) (c # x)
{-# INLINE gradientCircuit #-}
gradientCircuit :: Double -> GradientPursuit -> Circuit m (c # x, c # x) (c # x)
gradientCircuit Double
eps GradientPursuit
gp = ([c # x], Int)
-> ((c # x, c # x) -> ([c # x], Int) -> m (c # x, ([c # x], Int)))
-> Circuit m (c # x, c # x) (c # x)
forall (m :: Type -> Type) acc a b.
Monad m =>
acc -> (a -> acc -> m (b, acc)) -> Circuit m a b
accumulateFunction ((c # x) -> [c # x]
forall a. a -> [a]
repeat c # x
0,Int
0) (((c # x, c # x) -> ([c # x], Int) -> m (c # x, ([c # x], Int)))
-> Circuit m (c # x, c # x) (c # x))
-> ((c # x, c # x) -> ([c # x], Int) -> m (c # x, ([c # x], Int)))
-> Circuit m (c # x, c # x) (c # x)
forall a b. (a -> b) -> a -> b
$ \(c # x
p,c # x
dp) ([c # x]
vs,Int
k) -> do
let (c # x
p',[c # x]
vs') = Double
-> GradientPursuit
-> Int
-> (c # x)
-> (c # x)
-> [c # x]
-> (c # x, [c # x])
forall x c.
Manifold x =>
Double
-> GradientPursuit
-> Int
-> (c # x)
-> (c # x)
-> [c # x]
-> (c # x, [c # x])
gradientPursuitStep Double
eps GradientPursuit
gp Int
k c # x
p c # x
dp [c # x]
vs
(c # x, ([c # x], Int)) -> m (c # x, ([c # x], Int))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (c # x
p',([c # x]
vs',Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1))
vanillaGradientCircuit
:: (Monad m, Manifold x)
=> Double
-> GradientPursuit
-> Circuit m (c # x, c #* x) (c # x)
{-# INLINE vanillaGradientCircuit #-}
vanillaGradientCircuit :: Double -> GradientPursuit -> Circuit m (c # x, c #* x) (c # x)
vanillaGradientCircuit Double
eps GradientPursuit
gp = Circuit m (c #* x) (c # x)
-> Circuit m (c # x, c #* x) (c # x, c # x)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (((c #* x) -> c # x) -> Circuit m (c #* x) (c # x)
forall (a :: Type -> Type -> Type) b c.
Arrow a =>
(b -> c) -> a b c
arr (c #* x) -> c # x
forall x c. Manifold x => (c #* x) -> c # x
vanillaGradient) Circuit m (c # x, c #* x) (c # x, c # x)
-> Circuit m (c # x, c # x) (c # x)
-> Circuit m (c # x, c #* x) (c # x)
forall k (cat :: k -> k -> Type) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Double -> GradientPursuit -> Circuit m (c # x, c # x) (c # x)
forall (m :: Type -> Type) x c.
(Monad m, Manifold x) =>
Double -> GradientPursuit -> Circuit m (c # x, c # x) (c # x)
gradientCircuit Double
eps GradientPursuit
gp
momentumStep
:: Manifold x
=> Double
-> Double
-> c # x
-> c # x
-> c # x
-> (c # x, c # x)
{-# INLINE momentumStep #-}
momentumStep :: Double -> Double -> (c # x) -> (c # x) -> (c # x) -> (c # x, c # x)
momentumStep Double
eps Double
mu c # x
p c # x
fd c # x
v =
let v' :: c # x
v' = Double
eps Double -> (c # x) -> c # x
forall c x. Double -> (c # x) -> c # x
.> c # x
fd (c # x) -> (c # x) -> c # x
forall a. Num a => a -> a -> a
+ Double
mu Double -> (c # x) -> c # x
forall c x. Double -> (c # x) -> c # x
.> c # x
v
in (Double -> (c # x) -> (c # x) -> c # x
forall x c. Manifold x => Double -> (c # x) -> (c # x) -> c # x
gradientStep Double
1 c # x
p c # x
v', c # x
v')
adamStep
:: Manifold x
=> Double
-> Double
-> Double
-> Double
-> Int
-> c # x
-> c # x
-> c # x
-> c # x
-> (c # x, c # x, c # x)
{-# INLINE adamStep #-}
adamStep :: Double
-> Double
-> Double
-> Double
-> Int
-> (c # x)
-> (c # x)
-> (c # x)
-> (c # x)
-> (c # x, c # x, c # x)
adamStep Double
eps Double
b1 Double
b2 Double
rg Int
k0 c # x
p c # x
fd c # x
m c # x
v =
let k :: Int
k = Int
k0Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1
fd' :: Vector (Dimension x) Double
fd' = (Double -> Double)
-> Vector (Dimension x) Double -> Vector (Dimension x) Double
forall a b (n :: Nat).
(Storable a, Storable b) =>
(a -> b) -> Vector n a -> Vector n b
S.map (Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
2 :: Int)) (Vector (Dimension x) Double -> Vector (Dimension x) Double)
-> Vector (Dimension x) Double -> Vector (Dimension x) Double
forall a b. (a -> b) -> a -> b
$ (c # x) -> Vector (Dimension x) Double
forall c x. Point c x -> Vector (Dimension x) Double
coordinates c # x
fd
m' :: c # x
m' = (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b1) Double -> (c # x) -> c # x
forall c x. Double -> (c # x) -> c # x
.> c # x
fd (c # x) -> (c # x) -> c # x
forall a. Num a => a -> a -> a
+ Double
b1 Double -> (c # x) -> c # x
forall c x. Double -> (c # x) -> c # x
.> c # x
m
v' :: c # x
v' = (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b2) Double -> (c # x) -> c # x
forall c x. Double -> (c # x) -> c # x
.> Vector (Dimension x) Double -> c # x
forall c x. Vector (Dimension x) Double -> Point c x
Point Vector (Dimension x) Double
fd' (c # x) -> (c # x) -> c # x
forall a. Num a => a -> a -> a
+ Double
b2 Double -> (c # x) -> c # x
forall c x. Double -> (c # x) -> c # x
.> c # x
v
mhat :: c # x
mhat = (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b1Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Int
k) Double -> (c # x) -> c # x
forall c x. Double -> (c # x) -> c # x
/> c # x
m'
vhat :: c # x
vhat = (Double
1Double -> Double -> Double
forall a. Num a => a -> a -> a
-Double
b2Double -> Int -> Double
forall a b. (Num a, Integral b) => a -> b -> a
^Int
k) Double -> (c # x) -> c # x
forall c x. Double -> (c # x) -> c # x
/> c # x
v'
fd'' :: Vector (Dimension x) Double
fd'' = (Double -> Double -> Double)
-> Vector (Dimension x) Double
-> Vector (Dimension x) Double
-> Vector (Dimension x) Double
forall a b c (n :: Nat).
(Storable a, Storable b, Storable c) =>
(a -> b -> c) -> Vector n a -> Vector n b -> Vector n c
S.zipWith Double -> Double -> Double
forall a. Fractional a => a -> a -> a
(/) ((c # x) -> Vector (Dimension x) Double
forall c x. Point c x -> Vector (Dimension x) Double
coordinates c # x
mhat) (Vector (Dimension x) Double -> Vector (Dimension x) Double)
-> (Vector (Dimension x) Double -> Vector (Dimension x) Double)
-> Vector (Dimension x) Double
-> Vector (Dimension x) Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double)
-> Vector (Dimension x) Double -> Vector (Dimension x) Double
forall a b (n :: Nat).
(Storable a, Storable b) =>
(a -> b) -> Vector n a -> Vector n b
S.map ((Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
rg) (Double -> Double) -> (Double -> Double) -> Double -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double
forall a. Floating a => a -> a
sqrt) (Vector (Dimension x) Double -> Vector (Dimension x) Double)
-> Vector (Dimension x) Double -> Vector (Dimension x) Double
forall a b. (a -> b) -> a -> b
$ (c # x) -> Vector (Dimension x) Double
forall c x. Point c x -> Vector (Dimension x) Double
coordinates c # x
vhat
in (Double -> (c # x) -> (c # x) -> c # x
forall x c. Manifold x => Double -> (c # x) -> (c # x) -> c # x
gradientStep Double
eps c # x
p ((c # x) -> c # x) -> (c # x) -> c # x
forall a b. (a -> b) -> a -> b
$ Vector (Dimension x) Double -> c # x
forall c x. Vector (Dimension x) Double -> Point c x
Point Vector (Dimension x) Double
fd'', c # x
m',c # x
v')