added standard binary solver for circom

Author: martyall

Diff for: .github/workflows/ormolu.yml

@@ -0,0 +1,16 @@
+name: Ormolu CI
+
+on:
+  push:
+    branches: [main, master]
+  pull_request:
+    branches: [main, master]
+
+jobs:
+  ormolu:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v4
+      - uses: haskell-actions/run-ormolu@v15
+        with:
+            version: "0.7.2.0"

Diff for: circom-compat/src/Circuit/Solver/Circom.hs

@@ -15,6 +15,7 @@ module Circuit.Solver.Circom
     _setInputSignal,
     _getWitnessSize,
     _getWitness,
+    standardSolver,
   )
 where
 
@@ -30,7 +31,10 @@ import Data.Vector.Mutable qualified as MV
 import FNV (FNVHash (..), hashText, mkFNV)
 import Protolude
 import R1CS (Inputs (..), Witness (..), oneVar)
-import R1CS.Circom (FieldSize (..), integerFromLittleEndian, integerToLittleEndian, n32)
+import R1CS.Circom (CircomWitness, FieldSize (..), integerFromLittleEndian, integerToLittleEndian, n32, witnessToCircomWitness)
+import Text.PrettyPrint.Leijen.Text (Pretty (pretty), (<+>))
+
+-- WASM Solver
 
 data ProgramEnv f = ProgramEnv
   { peFieldSize :: FieldSize,
@@ -77,10 +81,8 @@ mkProgramState ProgramEnv {peFieldSize} = do
         psSharedRWMemory = sharedRWMemory
       }
 
--- | The arg is a bool representing 'sanityCheck'. We don't
--- need this at the moment
-_init :: Int -> IO ()
-_init = mempty
+_init :: ProgramEnv f -> IORef (ProgramState f) -> Int -> IO ()
+_init env st _ = writeBuffer env st 0
 
 _getNVars :: ProgramEnv f -> Int
 _getNVars = peWitnessSize
@@ -132,7 +134,12 @@ _setInputSignal env@(ProgramEnv {peCircuit, peInputsSize, peCircuitVars}) stRef
   writeIORef stRef $
     if IntMap.size newInputs == peInputsSize
       then
-        let wtns = solve peCircuitVars peCircuit newInputs
+        let wtns =
+              evalArithCircuit
+                (\w a -> IntMap.lookup (wireName w) a)
+                (\w a -> safeAssign (wireName w) a)
+                peCircuit
+                newInputs
          in st
               { psInputs = Inputs newInputs,
                 psWitness = Witness $ IntMap.insert oneVar 1 wtns
@@ -154,13 +161,44 @@ _getWitness env stRef i = do
    in writeBuffer env stRef wtn
 
 --------------------------------------------------------------------------------
+-- Standard Solver (to be used as native executable)
+
+standardSolver ::
+  forall f.
+  (PrimeField f) =>
+  CircuitVars Text ->
+  ArithCircuit f ->
+  Map Text f ->
+  CircomWitness f
+standardSolver vars circ inputs =
+  let initAssignments = assignInputs vars inputs
+      wtns =
+        evalArithCircuit
+          (\w a -> IntMap.lookup (wireName w) a)
+          (\w a -> safeAssign (wireName w) a)
+          circ
+          initAssignments
+   in witnessToCircomWitness $ Witness $ IntMap.insert oneVar 1 wtns
+
+--------------------------------------------------------------------------------
+
+{-# INLINE safeAssign #-}
+safeAssign :: (Eq f) => (Pretty f) => Int -> f -> IntMap f -> IntMap f
+safeAssign =
+  let f k new old =
+        if new == old
+          then new
+          else panic $ show $ "Assignment contradiction for var" <+> pretty k <> ":" <> pretty new <+> " /= " <+> pretty old
+   in IntMap.insertWithKey f
 
+{-# INLINE writeBuffer #-}
 writeBuffer :: ProgramEnv f -> IORef (ProgramState f) -> Integer -> IO ()
 writeBuffer (ProgramEnv {peFieldSize}) stRef x = do
   let chunks = integerToLittleEndian peFieldSize x
   forM_ [0 .. n32 peFieldSize - 1] $ \j ->
     _writeSharedRWMemory stRef j (chunks V.! j)
 
+{-# INLINE readBuffer #-}
 readBuffer :: ProgramEnv f -> IORef (ProgramState f) -> IO Integer
 readBuffer (ProgramEnv {peFieldSize}) stRef = do
   v <- V.generateM (n32 peFieldSize) $ \j ->

Diff for: language/src/Circuit/Language/Expr.hs

@@ -635,7 +635,7 @@ untypeBinOp BXors = UBXor
 
 --------------------------------------------------------------------------------
 
-reifyGraph ::  Expr i f ty -> Seq (Hash, Node i f)
+reifyGraph :: Expr i f ty -> Seq (Hash, Node i f)
 reifyGraph e =
   gbsEdges $ execState (buildGraph_ e) (GraphBuilderState mempty mempty)
 
@@ -645,7 +645,7 @@ data GraphBuilderState i f = GraphBuilderState
   }
 
 {-# SCC buildGraph_ #-}
-buildGraph_ :: forall i f ty.  Expr i f ty -> State (GraphBuilderState i f) Hash
+buildGraph_ :: forall i f ty. Expr i f ty -> State (GraphBuilderState i f) Hash
 buildGraph_ expr =
   getId expr <$ case expr of
     EVal h v ->
@@ -656,7 +656,7 @@ buildGraph_ expr =
       unlessM (hasBeenVisited h) $ do
         let n = NVar (rawWire v)
         markVisited h n
-    EUnOp h op e -> 
+    EUnOp h op e ->
       unlessM (hasBeenVisited h) $ do
         e' <- buildGraph_ e
         let n = NUnOp (untypeUnOp op) e'
@@ -674,7 +674,7 @@ buildGraph_ expr =
         f' <- buildGraph_ f
         let n = NIf b' t' f'
         markVisited h n
-    EEq h l r -> 
+    EEq h l r ->
       unlessM (hasBeenVisited h) $ do
         l' <- buildGraph_ l
         r' <- buildGraph_ r
@@ -685,7 +685,7 @@ buildGraph_ expr =
         i' <- buildGraph_ i
         let n = NSplit i' (fromIntegral $ natVal (Proxy @(NBits f)))
         markVisited h n
-    EJoin h i -> 
+    EJoin h i ->
       unlessM (hasBeenVisited h) $ do
         i' <- buildGraph_ i
         let n = NJoin i'
@@ -709,10 +709,10 @@ buildGraph_ expr =
   where
     hasBeenVisited h = gets $ Set.member h . gbsSharedNodes
     {-# INLINE hasBeenVisited #-}
-    markVisited h n = modify $ \s -> 
-      s 
-        { gbsSharedNodes = Set.insert h (gbsSharedNodes s)
-        , gbsEdges = gbsEdges s |> (h, n)
+    markVisited h n = modify $ \s ->
+      s
+        { gbsSharedNodes = Set.insert h (gbsSharedNodes s),
+          gbsEdges = gbsEdges s |> (h, n)
         }
     {-# INLINE markVisited #-}
 
@@ -738,7 +738,7 @@ evalGraph ::
   EvalM i f (V.Vector f)
 evalGraph lookupVar vars graph = case graph of
   Empty -> panic "empty graph"
-  ns :|> n -> traverse eval ns >> eval n
+  ns :|> n -> traverse_ eval ns >> eval n
   where
     eval (h, n) = evalNode lookupVar vars h n
 
@@ -759,15 +759,12 @@ evalNode lookupVar vars h node =
       Nothing -> throwError $ MissingVar i
     NUnOp op e -> do
       e' <- assertFromCache e
-      res <- case op of
-        UUNeg -> pure $ fmap Protolude.negate $ e'
-        UUNot -> pure $ fmap (\x -> 1 - x) $ e'
-        UURot n ->
-          pure $ V.fromList . rotateList n $ V.toList e'
-        UUShift n ->
-          pure $ V.fromList . shiftList 0 n $ V.toList e'
-        UUReverse ->
-          pure $ V.reverse e'
+      let res = case op of
+            UUNeg -> fmap Protolude.negate $ e'
+            UUNot -> fmap (\x -> 1 - x) $ e'
+            UURot n -> V.fromList . rotateList n $ V.toList e'
+            UUShift n -> V.fromList . shiftList 0 n $ V.toList e'
+            UUReverse -> V.reverse e'
       cachResult h res
     NBinOp op e1 e2 -> do
       e1' <- assertFromCache e1
@@ -837,4 +834,4 @@ evalNode lookupVar vars h node =
       case Map.lookup i m of
         Just ws -> pure ws
         Nothing -> throwError $ MissingFromCache i
-    {-# INLINE assertFromCache #-}
+    {-# INLINE assertFromCache #-}