Try fixing num

lear/lear.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: c9ad9c3f338b2f284bc1f96767ca03fed411eaa625857a27d5fcaed582cf3faf
+-- hash: 8eb0621afffd2e2e95e10d3257ee97be1690c0b6d09fe247de087cead7811255
 
 name:           lear
 version:        0.1.0.0
@@ -67,7 +67,9 @@ test-suite lear-test
     , distributive
     , generic-lens
     , ghc-typelits-natnormalise
+    , hedgehog >=1.0.2
     , hspec
+    , hspec-hedgehog
     , lear
     , lens
     , mtl

lear/package.yaml

@@ -38,6 +38,8 @@ tests:
     - lear
     - backprop
     - hspec
+    - hspec-hedgehog
+    - hedgehog >= 1.0.2
     - QuickCheck
 
 default-extensions:

lear/src/Lear/Internal/Type.hs

@@ -1,10 +1,12 @@
 module Lear.Internal.Type where
 
+import Control.Applicative
 import qualified Control.Category as C
 import Data.VectorSpace
   ( AdditiveGroup (..),
     VectorSpace (..),
   )
+import Debug.Trace
 import GHC.Generics (Generic)
 
 newtype Lear p a b
@@ -19,23 +21,23 @@ newtype Lear p a b
   deriving (Generic)
 
 liftOp ::
-  (Num a, Num b) =>
+  (Num a, Num p, Num b, Show a, Show p, Show b) =>
   (forall a. Num a => a -> a -> a) ->
   Lear p a b ->
   Lear p a b ->
   Lear p a b
 liftOp (?) (Lear x) (Lear y) = Lear $ \p a ->
-  let (bx, linx) = x p a
-      (by, liny) = y p a
-   in ( bx ? by,
+  let (bx, linx) = x (trace ("p=" ++ show p) p) (trace ("a=" ++ show a) a)
+      (by, liny) = y p (trace ("a=" ++ show a) a)
+   in ( (trace ("bx=" ++ show bx) bx) ? (trace ("by=" ++ show by) by),
         \b' ->
           let (fpx, ax) = linx b'
-              (fpy, ay) = liny b'
+              (fpy, ay) = liny (trace ("b'=" ++ show b') b')
            in -- Not sure about ax ? ay...
-              (fpx . fpy, ax ? ay)
+              (fpx . fpy, trace ("ax=" ++ show ax) ax - trace ("ay=" ++ show ay) ay)
       )
 
-instance (Num a, Num b) => Num (Lear p a b) where
+instance (Num a, Num p, Num b, Show p, Show b, Show a) => Num (Lear p a b) where
   fromInteger x = Lear $ \p a -> (fromInteger x, const (const p, a))
   (+) = liftOp (+)
   (-) = liftOp (-)

lear/test/Spec.hs

@@ -4,19 +4,23 @@ import Control.Category
 import Data.Bifunctor
 import Data.Functor.Foldable
 import Data.VectorSpace
+import GHC.Stack
+import qualified Hedgehog as H
+import qualified Hedgehog.Gen as H
+import qualified Hedgehog.Range as HR
 import Lear
 import Numeric.Backprop
 import Test.Hspec
-import Test.Hspec.QuickCheck
-import Test.QuickCheck
+import Test.Hspec.Hedgehog
 import Prelude hiding ((.))
 
 main :: IO ()
 main =
   hspec $ do
     runLearSpec
     learnOneSpec
-    atRateSpec
+
+-- atRateSpec
 
 runLearSpec :: Spec
 runLearSpec =
@@ -27,11 +31,19 @@ runLearSpec =
 learnOneSpec :: Spec
 learnOneSpec =
   describe "learnOne" $ do
-    prop "returns the input if correct" $ \(x, y) ->
-      (x /= 0) ==> learnOne linear x y (x * y) == (x, y)
-    prop "returns the two fixes if incorrect" $ \(x, y, z) ->
+    it "returns the input if correct" $ hedgehog $ do
+      x <- H.forAll $ H.filter (/= 0) $ H.float (HR.constant (-100) 100)
+      y <- H.forAll $ H.float (HR.constant (-100) 100)
+      learnOne linear x y (x * y) === (x, y)
+    it "returns the two fixes if incorrect" $ hedgehog $ do
+      x <- H.forAll $ H.filter (/= 0) $ H.float (HR.constant (-100) 100)
+      y <- H.forAll $ H.float (HR.constant (-100) 100)
+      z <- H.forAll $ H.float (HR.constant (-100) 100)
       let (x', y') = learnOne linear x y z
-       in (x /= 0) ==> x' * y ~~ z && x * y' ~~ z
+      x' * y ~=~ z
+      x * y' ~=~ z
+
+{-
 
 atRateSpec :: Spec
 atRateSpec =
@@ -43,16 +55,18 @@ atRateSpec =
         ==> let res = x * y
              in learnOne linear x y (res + z) ~~ learnOne (linear `atRate` 0.1) x y (res + z / 0.1)
 
+-}
+
 -- * Helpers
 
 -- | A linear function passing through the origin without noise.
 --
 -- This is solvable from one datapoint, which makes testing easier.
 linear :: Lear Float Float Float
-linear = backpropToLear $ \p x -> p * x
+-- linear = backpropToLear $ \p x -> p * x
+linear = param * input
 
 -- Change to this:
--- linear = param * input
 
 {-
 data P = P {weight :: Float, bias :: Float}
@@ -63,6 +77,11 @@ linear' = (param . look @"weight") * input + (param . look @"bias")
 
 -- ** Approximate Equality
 
+infix 4 ~=~
+
+(~=~) :: (HasCallStack, MonadTest m, Show a, ApproximateEq a) => a -> a -> m ()
+x ~=~ y = withFrozenCallStack $ diff x (~~) y
+
 infix 4 ~~
 
 class ApproximateEq a where

stack.yaml

@@ -5,3 +5,7 @@ packages:
 
 nix:
     enable: true
+
+extra-deps:
+- hspec-hedgehog-0.0.1.1@sha256:bbf992090eb2e3c1b8919150756bb4dc88c8c987992ee6f49ca9d3ec8cbddc96,1371
+- hedgehog-1.0.2@sha256:bc80f8df76a122c6c5d0bbf66efd53cca1c29691a53110628894802ba3f207e2,4582

stack.yaml.lock

@@ -3,7 +3,21 @@
 # For more information, please see the documentation at:
 #   https://docs.haskellstack.org/en/stable/lock_files
 
-packages: []
+packages:
+- completed:
+    hackage: hspec-hedgehog-0.0.1.1@sha256:bbf992090eb2e3c1b8919150756bb4dc88c8c987992ee6f49ca9d3ec8cbddc96,1371
+    pantry-tree:
+      size: 379
+      sha256: e3c8694eea1df1ad60a71be5153e828128c50f066429127811ecb404a9309598
+  original:
+    hackage: hspec-hedgehog-0.0.1.1@sha256:bbf992090eb2e3c1b8919150756bb4dc88c8c987992ee6f49ca9d3ec8cbddc96,1371
+- completed:
+    hackage: hedgehog-1.0.2@sha256:bc80f8df76a122c6c5d0bbf66efd53cca1c29691a53110628894802ba3f207e2,4582
+    pantry-tree:
+      size: 2549
+      sha256: 2129144cdfa14318a04c102eaf47ab751297ab62c1c97fa567e6abf21e4676e5
+  original:
+    hackage: hedgehog-1.0.2@sha256:bc80f8df76a122c6c5d0bbf66efd53cca1c29691a53110628894802ba3f207e2,4582
 snapshots:
 - completed:
     size: 524799