Initial commit

LICENSE

@@ -0,0 +1,30 @@
+Copyright (c) 2020, Aiken Cairncross
+
+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 Aiken Cairncross 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.

bin/Clash.hs

@@ -0,0 +1,6 @@
+import Prelude
+import System.Environment (getArgs)
+import Clash.Main (defaultMain)
+
+main :: IO ()
+main = getArgs >>= defaultMain

cabal.project

@@ -0,0 +1,28 @@
+packages: .
+
+-- Add constraint to function passed to smap
+source-repository-package
+  type: git
+  location: https://github.com/acairncross/clash-compiler.git
+  tag: eb8027c5bcd01cb0d5f0d5ee28d4b69f5f7dd52b
+  subdir: clash-prelude
+
+-- Most recent parent of the smap fork
+source-repository-package
+  type: git
+  location: https://github.com/clash-lang/clash-compiler.git
+  tag: 1ccadf371bf5c3c19e16327b21370a56294edd11
+  subdir: clash-ghc
+
+source-repository-package
+  type: git
+  location: https://github.com/clash-lang/clash-compiler.git
+  tag: 1ccadf371bf5c3c19e16327b21370a56294edd11
+  subdir: clash-lib
+
+package clash-prelude
+  -- 'large-tuples' generates tuple instances for various classes up to the
+  -- GHC imposed maximum of 62 elements. This severely slows down compiling
+  -- Clash, and triggers Template Haskell bugs on Windows. Hence, we disable
+  -- it by default. This will be the default for Clash >=1.4.
+  flags: -large-tuples

euphrates.cabal

@@ -0,0 +1,67 @@
+cabal-version: 2.2
+name:          euphrates
+version:       0.0.0.0
+license:       BSD-3-Clause
+license-file:  LICENSE
+copyright:     Copyright (c) 2020, Aiken Cairncross
+maintainer:    [email protected]
+author:        Aiken Cairncross
+synopsis:      Maximum flow hardware accelerator
+description:
+  A Clash implementation of the push relabel algorithm for maximum flow.
+
+category:      Hardware
+
+source-repository head
+  type:     git
+  location: https://github.com/acairncross/euphrates.git
+
+library
+  exposed-modules:  Euphrates
+  hs-source-dirs:   src
+  default-language: Haskell2010
+  ghc-options:
+    -Wall
+    -fplugin GHC.TypeLits.Extra.Solver
+    -fplugin GHC.TypeLits.KnownNat.Solver
+    -fplugin GHC.TypeLits.Normalise
+    -fexpose-all-unfoldings
+    -fno-worker-wrapper
+
+  build-depends:
+    base <5,
+    clash-prelude,
+    ghc-typelits-extra,
+    ghc-typelits-knownnat,
+    ghc-typelits-natnormalise,
+
+executable clash
+  main-is:          bin/Clash.hs
+  default-language: Haskell2010
+  build-depends:
+    base <5,
+    clash-ghc
+
+  if !os(windows)
+    ghc-options: -dynamic
+
+test-suite test
+  type:             exitcode-stdio-1.0
+  main-is:          Main.hs
+  hs-source-dirs:   test
+  other-modules:
+    Euphrates.Hedgehog
+    Euphrates.Spec
+
+  default-language: Haskell2010
+  ghc-options:      -Wall
+  build-depends:
+    base <5,
+    clash-prelude,
+    euphrates,
+    fgl,
+    ghc-typelits-extra,
+    ghc-typelits-knownnat,
+    ghc-typelits-natnormalise,
+    hedgehog,
+    hspec,

src/Euphrates.hs

@@ -0,0 +1,178 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Euphrates (node, network, excessesToFlowValue, runNetwork) where
+
+import Clash.Prelude
+import Data.Function (on)
+import Data.Maybe (isNothing, fromJust)
+import qualified Prelude as P
+
+-- Ordering on a extended with positive infinity.
+compareWithInf :: Ord a => Maybe a -> Maybe a -> Ordering
+compareWithInf (Just x) (Just y) = compare x y
+compareWithInf (Just _) Nothing = LT
+compareWithInf Nothing (Just _) = GT
+compareWithInf Nothing Nothing = EQ
+
+minBy :: (a -> a -> Ordering) -> a -> a -> a
+minBy cmp x y = case cmp x y of
+  GT -> y
+  _  -> x
+
+-- Functions from Clash.Prelude with more convenient constraints
+at' :: forall n m a. m + 1 <= n => SNat m -> Vec n a -> a
+at' = leToPlus @(m+1) @n at 
+
+init' :: forall n a. 1 <= n => Vec n a -> Vec (n-1) a
+init' = leToPlus @1 @n init
+
+last' :: forall n a. 1 <= n => Vec n a -> a
+last' = leToPlus @1 @n last
+
+-- | Note: If there is a residual (self-)edge from u to u, then relabelling might
+-- only relabel to h(u) + 1
+node
+  :: forall n u a
+   . 1 <= n
+  => u + 1 <= n
+  => KnownNat n
+  => Real a
+  => SNat u
+  -- ^ Self
+  -> Vec n a
+  -- ^ Capacities
+  -> a
+  -- ^ Excess
+  -> Vec n a
+  -- ^ Heights
+  -> Vec n a
+  -- ^ Flows
+  -> (a, Vec n a)
+  -- ^ (Height', Flow update)
+node u cs e hs fs =
+  let -- Residual capacities
+      rcs = zipWith (-) cs fs
+
+      -- Height of each residual graph neighbor (infinite height if not a
+      -- residual graph neighbor)
+      hsM = zipWith (\h rc -> if rc > 0 then Just h else Nothing) hs rcs 
+
+      -- Neighbor with smallest height
+      (v, hvM) =
+        fold @(n-1) (minBy (compareWithInf `on` snd)) (zip indicesI hsM)
+
+      -- Height of self
+      hu = at' u hs
+
+  in case compareSNat u d0 of
+    SNatLE -> (hu, repeat 0) -- u == 0 (self == source)
+    SNatGT -> case compareSNat (SNat @n) (succSNat u) of
+      SNatLE -> (hu, repeat 0) -- n == u+1 (self == sink)
+      SNatGT -> case hvM of
+        Just hv | e > 0 ->
+          if hu > hv
+            then -- push
+              let d = min e (rcs !! v)
+              in (hu, replace v d (repeat 0))
+            else -- relabel
+              (hv+1, repeat 0)
+        _ -> -- No excess or no outgoing residual edges
+          (hu, repeat 0)
+{-# NOINLINE node #-}
+
+network
+  :: forall dom n a
+   . 2 <= n
+  => Real a
+  => NFDataX a
+  => SNat n
+  -> Vec n (Vec n a)
+  -- ^ Capacities
+  -> (HiddenClockResetEnable dom
+    => (Signal dom (Vec n (Vec n a)), Signal dom (Vec n a)))
+  -- ^ (Flows, Excesses)
+network n@SNat css =
+  let nodes :: HiddenClockResetEnable dom => Signal dom (Vec n (a, Vec n a))
+      nodes = bundle $
+        smap @n
+          (\u () ->
+            liftA3 (node @n u (at' u css)) (at' u <$> es) hs (at' u <$> fss))
+          (replicate n ())
+
+      -- Heights'
+      hs' :: HiddenClockResetEnable dom => Signal dom (Vec n a)
+      -- Flow updates/deltas
+      fssD :: HiddenClockResetEnable dom => Signal dom (Vec n (Vec n a))
+      (hs', fssD) =
+        let (<^$^>) = fmap . map
+        in (fst <^$^> nodes, snd <^$^> nodes)
+
+      -- Initially all heights set to 0 except source set to n
+      hs0 :: Vec n a
+      hs0 = replace (0 :: Int) (snatToNum n) (replicate n 0)
+
+      -- Heights
+      hs :: HiddenClockResetEnable dom => Signal dom (Vec n a)
+      hs = register hs0 hs'
+
+      -- Initially all flows set to 0 except outgoing edges from the source
+      -- are saturated
+      fss0 :: Vec n (Vec n a)
+      fss0 =
+        let cs = at' d0 css
+        in zipWith (\c fs -> replace (0 :: Int) (negate c) fs) cs
+          $ replace (0 :: Int) cs
+          $ replicate n
+          $ replicate n 0
+
+      fss :: HiddenClockResetEnable dom => Signal dom (Vec n (Vec n a))
+      fss =
+        let -- The equal and opposite flow update to fssD
+            fssDT :: Signal dom (Vec n (Vec n a))
+            fssDT = (map . map $ negate) . transpose <$> fssD
+
+            -- Addition lifted over Signal and two layers of Vec
+            (^+^) = liftA2 . zipWith . zipWith $ (+)
+
+        in register fss0 (fss ^+^ fssD ^+^ fssDT)
+
+      -- Excesses
+      es :: HiddenClockResetEnable dom => Signal dom (Vec n a)
+      es = (fmap . map) (negate . sum) fss
+
+  in (fss, es)
+{-# NOINLINE network #-}
+
+-- | Given node excesses, return 'Just' the flow value if there is in fact a
+-- a flow, and return 'Nothing' otherwise (e.g. if there is a pre-flow).
+excessesToFlowValue
+  :: KnownNat n
+  => 2 <= n
+  => Num a
+  => Ord a
+  => Vec n a
+  -> Maybe a
+excessesToFlowValue es =
+  if P.any (> 0) (init' es) then Nothing else Just (last' es)
+
+-- | Compute a `network`'s flow value.
+runNetwork
+  :: forall dom n a
+   . KnownDomain dom
+  => KnownNat n
+  => 2 <= n
+  => NFDataX a
+  => Num a
+  => Ord a
+  => (HiddenClockResetEnable dom
+    => (Signal dom (Vec n (Vec n a)), Signal dom (Vec n a)))
+  -> a
+runNetwork nw =
+  let samples = sample $ fmap excessesToFlowValue $ snd $ nw
+  in fromJust . P.head . P.dropWhile isNothing $ samples

test/Euphrates/Hedgehog.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Euphrates.Hedgehog where
+
+import Clash.Prelude
+import Data.Graph.Inductive.Query.MaxFlow (maxFlow)
+import Euphrates
+import Hedgehog
+import qualified Data.Graph.Inductive as G
+import qualified Hedgehog.Gen as Gen
+import qualified Hedgehog.Range as Range
+import qualified Prelude as P
+
+-- A random flow network with integer capacities from 0 to 100 (no "self"
+-- capacities)
+flowNetwork :: MonadGen m => 1 <= n => SNat n -> m (Vec n (Vec n Int))
+flowNetwork n@SNat = removeSelfEdges matrix
+  where
+    removeSelfEdges mat = zipWith (\i cs -> replace i 0 cs) (indices n) <$> mat
+    matrix = sequence $ replicate n row
+    row = sequence $ replicate n (Gen.int (Range.constant 0 100))
+
+-- Convert a graph represented as a matrix to an FGL graph
+matrixToGraph :: SNat n -> Vec n (Vec n Int) -> G.Gr () Int
+matrixToGraph n css = G.mkGraph
+  (P.zip [0..snatToNum n - 1] (P.repeat ()))
+  [ (i, j, c)
+  | (i, cs) <- P.zip [0..] . toList $ P.zip [0..] . toList <$> css
+  , (j, c) <- cs
+  , c /= 0
+  ]
+
+-- Max flows should never be negative
+prop_non_negative :: Property
+prop_non_negative = property $ do
+  css <- forAll (flowNetwork d4)
+  assert (runNetwork @System (network d4 css) >= 0)
+
+-- Use FGL as a reference implementation
+prop_matches_fgl :: Property
+prop_matches_fgl = property $ do
+  css <- forAll (flowNetwork d8)
+  runNetwork @System (network d8 css) === maxFlow (matrixToGraph d8 css) 0 7