Merge pull request #1 from dvdblk/feature/mg-haskell

Feature/mg haskell

.github/workflows/test-micrograd-ports.yaml

@@ -5,9 +5,10 @@ on:
     paths:
       - '.github/workflows/test-micrograd-ports.yaml'
       - 'micrograd-swift/**'
+      - 'micrograd-haskell/**'
 
 jobs:
-  build:
+  test-micrograd-swift:
     name: Test micrograd-swift
     runs-on: macos-latest
     steps:
@@ -18,3 +19,16 @@ jobs:
       - name: Run tests
         working-directory: micrograd-swift/MicrogradSwift
         run: swift test
+  test-micrograd-haskell:
+    name: Test micrograd-haskell
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v3
+      - uses: haskell/actions/setup@v2
+        with:
+          ghc-version: '9.2.7'
+          enable-stack: true
+          stack-version: 'latest'
+      - name: Run tests
+        working-directory: micrograd-haskell
+        run: stack test

.gitignore

@@ -0,0 +1,17 @@
+*.code-workspace
+
+# Created by https://www.gitignore.io/api/visualstudiocode
+# Edit at https://www.gitignore.io/?templates=visualstudiocode
+
+### VisualStudioCode ###
+.vscode/*      # Maybe .vscode/**/* instead - see comments
+!.vscode/settings.json
+!.vscode/tasks.json
+!.vscode/launch.json
+!.vscode/extensions.json
+
+### VisualStudioCode Patch ###
+# Ignore all local history of files
+**/.history
+
+# End of https://www.gitignore.io/api/visualstudiocode

.vscode/settings.json

@@ -0,0 +1,5 @@
+{
+    "haskell.formattingProvider": "ormolu",
+    "haskell.manageHLS": "GHCup",
+    "haskell.serverExecutablePath": ""
+}

micrograd-haskell/README.md

@@ -1,3 +1,13 @@
 # micrograd-haskell
 
 A port of [micrograd](https://github.com/karpathy/micrograd) written in Haskell.
+
+## Building
+```
+$ stack build
+```
+
+## Testing
+```
+$ stack test
+```

micrograd-haskell/app/Main.hs

@@ -1,6 +1,4 @@
 module Main (main) where
 
-import Lib
-
 main :: IO ()
-main = someFunc
+main = putStrLn "temp"

micrograd-haskell/micrograd-haskell.cabal

@@ -9,9 +9,9 @@ version:        0.1.0.0
 description:    Please see the README on GitHub at <https://github.com/githubuser/micrograd-haskell#readme>
 homepage:       https://github.com/githubuser/micrograd-haskell#readme
 bug-reports:    https://github.com/githubuser/micrograd-haskell/issues
-author:         Author name here
-maintainer:     example@example.com
-copyright:      2023 Author name here
+author:         David Alexander Bielik
+maintainer:     github@dvdblk.com
+copyright:      2023 David Alexander Bielik
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple
@@ -25,14 +25,19 @@ source-repository head
 
 library
   exposed-modules:
-      Lib
+      EngineReverse
+      NN
   other-modules:
       Paths_micrograd_haskell
   hs-source-dirs:
       src
+  default-extensions:
+      ImportQualifiedPost
+      InstanceSigs
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints
   build-depends:
       base >=4.7 && <5
+    , containers
   default-language: Haskell2010
 
 executable micrograd-haskell-exe
@@ -41,21 +46,31 @@ executable micrograd-haskell-exe
       Paths_micrograd_haskell
   hs-source-dirs:
       app
+  default-extensions:
+      ImportQualifiedPost
+      InstanceSigs
   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
+    , containers
     , micrograd-haskell
   default-language: Haskell2010
 
 test-suite micrograd-haskell-test
   type: exitcode-stdio-1.0
   main-is: Spec.hs
   other-modules:
+      TestEngineReverse
       Paths_micrograd_haskell
   hs-source-dirs:
       test
-  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N
+  default-extensions:
+      ImportQualifiedPost
+      InstanceSigs
+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -Wtype-defaults
   build-depends:
-      base >=4.7 && <5
+      HUnit
+    , base >=4.7 && <5
+    , containers
     , micrograd-haskell
   default-language: Haskell2010

micrograd-haskell/package.yaml

@@ -2,9 +2,9 @@ name:                micrograd-haskell
 version:             0.1.0.0
 github:              "githubuser/micrograd-haskell"
 license:             BSD3
-author:              "Author name here"
-maintainer:          "example@example.com"
-copyright:           "2023 Author name here"
+author:              "David Alexander Bielik"
+maintainer:          "github@dvdblk.com"
+copyright:           "2023 David Alexander Bielik"
 
 extra-source-files:
 - README.md
@@ -21,6 +21,7 @@ description:         Please see the README on GitHub at <https://github.com/gith
 
 dependencies:
 - base >= 4.7 && < 5
+- containers
 
 ghc-options:
 - -Wall
@@ -36,6 +37,10 @@ ghc-options:
 library:
   source-dirs: src
 
+default-extensions:
+  - ImportQualifiedPost
+  - InstanceSigs
+
 executables:
   micrograd-haskell-exe:
     main:                Main.hs
@@ -55,5 +60,7 @@ tests:
     - -threaded
     - -rtsopts
     - -with-rtsopts=-N
+    - -Wtype-defaults
     dependencies:
     - micrograd-haskell
+    - HUnit

micrograd-haskell/src/EngineReverse.hs

@@ -0,0 +1,163 @@
+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
+
+{-# HLINT ignore "Use -" #-}
+module EngineReverse (
+  Value (..),
+  defaultValue,
+  valueInit,
+  changeValueOperation,
+  relu,
+  EngineReverse.tanh,
+  incrementGrad,
+  _backward,
+  backward
+)
+where
+
+import Data.Graph qualified as G
+
+data Value a = Value
+  { -- | Numerical data for this `Value`.
+    -- Need to use `_data` because 'data' is a reserved keyword
+    _data :: a
+    -- | Gradient of the `Value`
+  , grad :: a
+    -- | Operation that created this `Value`
+  , _op :: String
+    -- | List of previous values that created this `Value`
+  , _prev :: [Value a]
+  }
+  deriving (Show, Eq, Ord)
+
+-- | defaultValue creates a new `Value` with the given data and no gradient
+defaultValue :: Num a => a -> Value a
+defaultValue v = Value v 0 "" []
+
+-- | valueInit creates a new `Value` with the given data, operation, and ensures unique previous values.
+valueInit :: (Eq a, Num a) => a -> String -> [Value a] -> Value a
+valueInit v op [x, y] | x == y && op /= "**" = Value v 0 op [x]
+                      | otherwise = Value v 0 op [x, y]
+valueInit v op prev = Value v 0 op prev
+
+-- | changeValueOperation changes the operation of a `Value` to the given operation.
+-- It takes one argument of type 'String' and one argument of type `Value`.
+changeValueOperation :: String -> Value a -> Value a
+changeValueOperation op v = v{_op = op}
+
+instance (Num a, Ord a) => Num (Value a) where
+  (+) :: Value a -> Value a -> Value a
+  v1@(Value x _ _ _) + v2@(Value y _ _ _) = valueInit (x + y) "+" [v1, v2]
+  (*) :: Value a -> Value a -> Value a
+  v1@(Value x _ _ _) * v2@(Value y _ _ _) = valueInit (x * y) "*" [v1, v2]
+  (-) :: Value a -> Value a -> Value a
+  v1 - v2 = (changeValueOperation "-" . (v1 +) . negate) v2
+  negate :: Value a -> Value a
+  negate v = changeValueOperation "neg" $ defaultValue (-1) * v
+
+  -- | abs is not supported by OG micrograd
+  abs :: Value a -> Value a
+  abs v@(Value x _ _ _) = changeValueOperation "abs" $ if x >= 0 then v else negate v
+
+  -- | signum is not supported by OG micrograd
+  signum :: Value a -> Value a
+  signum v@(Value x _ _ _) = valueInit (signum x) "signum" [v]
+  fromInteger :: Integer -> Value a
+  fromInteger = defaultValue . fromInteger
+
+instance (Floating a, Ord a) => Fractional (Value a) where
+  (/) :: Value a -> Value a -> Value a
+  v1 / v2 = changeValueOperation "/" $ v1 * (v2 ** (-1))
+
+  -- | recip is not supported by OG micrograd
+  recip :: Value a -> Value a
+  recip v = changeValueOperation "recip" $ defaultValue 1 / v
+  fromRational :: Rational -> Value a
+  fromRational = defaultValue . fromRational
+
+instance (Floating a, Ord a) => Floating (Value a) where
+  (**) :: Value a -> Value a -> Value a
+  v1@(Value x _ _ _) ** v2@(Value y _ _ _) = valueInit (x ** y) "**" [v1, v2]
+
+  -- | Applies the exponential function to the given `Value`.
+  exp :: Value a -> Value a
+  exp v@(Value x _ _ _) = valueInit (Prelude.exp x) "exp" [v]
+
+  -- | functions which are not supported by OG micrograd
+  pi = undefined
+  log = undefined
+  sin = undefined
+  cos = undefined
+  asin = undefined
+  acos = undefined
+  atan = undefined
+  sinh = undefined
+  cosh = undefined
+  asinh = undefined
+  acosh = undefined
+  atanh = undefined
+
+-- | Applies the rectified linear unit function to the given `Value`.
+relu :: (Num a, Ord a) => Value a -> Value a
+relu v@(Value x _ _ _) = valueInit (max 0 x) "relu" [v]
+
+-- | Applies the hyperbolic tangent function to the given `Value`.
+tanh :: (Floating a, Ord a) => Value a -> Value a
+tanh v@(Value x _ _ _) = valueInit (Prelude.tanh x) "tanh" [v]
+
+-- | incrementGrad increments the gradient of a `Value` by the given amount.
+incrementGrad :: Num a => a -> Value a -> Value a
+incrementGrad x v@(Value _ g _ _) = v { grad = g + x }
+
+-- | _backward updates gradients of the children Values based on the operation
+_backward :: (Floating a, Ord a, Show a) => Value a -> Value a
+_backward v@(Value _ g "+" [v1, v2]) = v { _prev = [incrementGrad g v1, incrementGrad g v2] }
+_backward v@(Value _ g "*" [v1, v2]) = v { _prev = [incrementGrad (g * _data v2) v1, incrementGrad (g * _data v1) v2] }
+_backward v@(Value _ g "**" [v1, v2]) = v { _prev = [incrementGrad (_data v2 * _data v1 ** (_data v2 - 1) * g) v1, v2] }
+_backward v@(Value _ g "relu" [v1]) = v { _prev = [incrementGrad (g * if _data v1 > 0 then 1 else 0) v1] }
+_backward v@(Value _ g "exp" [v1]) = v { _prev = [incrementGrad (_data v1 * g) v1] }
+_backward v@(Value _ g "tanh" [v1]) = v { _prev = [incrementGrad ((1 - _data v1 ** 2) * g) v1] }
+-- workaround for duplicit values in required binary operations (+), (*)
+_backward v@(Value _ g "*" [v1]) = v { _prev = [incrementGrad (2 * g * _data v1) v1] }
+_backward v@(Value _ g "+" [v1]) = v { _prev = [incrementGrad (2 * g) v1] }
+_backward v@(Value _ _ op prev) = case (op, prev) of
+  -- redirect negation to multiplication by -1
+  ("neg", _) -> redirect "neg" "*" v
+  -- redirect subtraction to addition of negation
+  ("-", _) -> redirect "-" "+" v
+  -- redirect division to multiplication by reciprocal
+  ("/", _) -> redirect "/" "*" v
+  -- default case
+  ("", _) -> v
+  -- catch-all for unsupported operations
+  (_, _) -> error $ "Invalid operation (" ++ op ++ ") in _backward for prev: " ++ show prev
+  where
+    -- | redirect redirects a given operation to another operation and backpropagates the gradient.
+    redirect from to = changeValueOperation from . _backward . changeValueOperation to
+
+-- | prevToEdges converts a computation graph from a given `Value` to a list of edges.
+prevToEdges :: Value a -> [(Value a, Int, [Int])]
+prevToEdges = traverseComputationGraph 0
+  where traverseComputationGraph :: Int -> Value a -> [(Value a, Int, [Int])]
+        -- | If the Value has no previous Values, it is a leaf node and has no edges.
+        traverseComputationGraph i v@(Value _ _ _ []) = [(v, i, [])]
+        -- | If the Value has one previous Value, it has one edge.
+        traverseComputationGraph i v@(Value _ _ _ [v1]) = (v, i, [i + 1]) : traverseComputationGraph (i + 1) v1
+        -- | If the Value has two previous Values, it has two edges.
+        traverseComputationGraph i v@(Value _ _ _ [v1, v2]) = (v, i, [i + 1, i + 2]) : (traverseComputationGraph (i + 1) v1) ++ (traverseComputationGraph (i + 2) v2)
+        traverseComputationGraph _ _ = error "Invalid computation graph"
+
+reverseList :: [a] -> [a]
+reverseList = foldl (flip (:)) []
+
+-- | backward computes the gradient of every `Value` in the computation graph in a topological order.
+-- It also sets the gradient of the topmost node to 1.
+backward :: (Show a, Floating a, Ord a) => Value a -> Value a
+backward v = head . map ((\(val, _, _) -> _backward val) . vertexToNode) . reverseList . G.topSort $ graph
+  where topNode = v { grad = 1 }
+        (graph, vertexToNode, _) = G.graphFromEdges . prevToEdges $ topNode
+
+-- for debugging
+-- a = (defaultValue (3 :: Double) * defaultValue 4) * (defaultValue (-5) + defaultValue 16)
+-- bw v = map vertexToNode . reverseList . G.topSort $ graph
+--   where topNode = v { grad = 1 }
+--         (graph, vertexToNode, keyToVertex) = G.graphFromEdges . prevToEdges $ topNode

micrograd-haskell/src/NN.hs

@@ -0,0 +1,3 @@
+module NN (
+  )
+where

micrograd-haskell/stack.yaml

@@ -10,7 +10,7 @@
 #
 # resolver: lts-3.5
 # resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
+# resolver: ghc-9.2.7
 #
 # The location of a snapshot can be provided as a file or url. Stack assumes
 # a snapshot provided as a file might change, whereas a url resource does not.

micrograd-haskell/test/Spec.hs

@@ -1,2 +1,6 @@
-main :: IO ()
-main = putStrLn "Test suite not yet implemented"
+import TestEngineReverse (testsEngineReverse)
+
+import Test.HUnit
+
+main :: IO Counts
+main = do runTestTT testsEngineReverse