8-queens using bitwise primops benchmark

plutus-benchmark/bitwise/bench/Main.hs

@@ -0,0 +1,26 @@
+module Main (main) where
+
+{-
+import Criterion.Main (bench, defaultMain)
+import PlutusBenchmark.Common (benchProgramCek, mkMostRecentEvalCtx)
+import PlutusBenchmark.NQueens (nqueens)
+import PlutusTx.Code (CompiledCode, getPlcNoAnn)
+import PlutusTx.TH (compile)
+-}
+
+main :: IO ()
+main = print "Pending"
+
+{- Currently not able to run, due to problems with writeBits compiling under PlutusTx
+
+main :: IO ()
+main = defaultMain [
+  bench "8-queens" . benchProgramCek mkMostRecentEvalCtx . getPlcNoAnn $ nqueensCompiled
+  ]
+
+-- Helpers
+
+nqueensCompiled :: CompiledCode [(Integer, Integer)]
+nqueensCompiled = $$(compile [||nqueens 8||])
+
+-}

plutus-benchmark/bitwise/src/PlutusBenchmark/NQueens.hs

@@ -0,0 +1,77 @@
+-- editorconfig-checker-disable-file
+{-# LANGUAGE MultiWayIf        #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module PlutusBenchmark.NQueens (nqueens) where
+
+import PlutusTx.Builtins (replicateByte)
+import PlutusTx.Prelude
+
+-- Based on Qiu, Zongyan (February 2002). "Bit-vector encoding of n-queen problem". ACM SIGPLAN Notices. 37 (2): 68–70
+-- For simplicity, this only accepts multiples of 8 for the dimension (so 8, 16,
+-- 24, etc): in all other cases it will return an empty list. Results are (row,
+-- column) pairs.
+{-# INLINE nqueens #-}
+nqueens :: Integer -> [(Integer, Integer)]
+nqueens dim
+  | dim < 8 = []
+  | dim `remainder` 8 /= 0 = []
+  | otherwise =
+      let down = replicateByte bytesNeeded 0x00
+          left = replicateByte bytesNeeded 0x00
+          right = replicateByte bytesNeeded 0x00
+       in go 0 0 down left right (replicateByte bytesNeeded 0xFF)
+  where
+    bytesNeeded :: Integer
+    bytesNeeded = dim `quotient` 8
+    go ::
+      Integer ->
+      Integer ->
+      BuiltinByteString ->
+      BuiltinByteString ->
+      BuiltinByteString ->
+      BuiltinByteString ->
+      [(Integer, Integer)]
+    go selectIx row down left right control
+      | selectIx == dim = []
+      | otherwise =
+          -- In the original writeup, 0 in a position meant 'occupied'. However,
+          -- this makes updates to the control vectors very annoying, because
+          -- now we have to 'shift in' 1 bits, which costs us an extra two
+          -- copies. We can reduce this by one by instead treating 0 as 'free'.
+          -- Ideally, we would eliminate one more redundant copy, but this
+          -- requires a select0 operation, which can't be implemented
+          -- efficiently. However, given that these copies are per recursive
+          -- call, we can save ourselves considerable effort by avoiding them.
+          let available = selectByteString selectIx control
+           in if
+                | available == (-1) -> []
+                | row == lastRow -> [(row, available)]
+                | otherwise ->
+                    let newDown = writeBit down available True
+                        newLeft = shiftByteString (writeBit left available True) 1
+                        newRight = shiftByteString (writeBit right available True) (-1)
+                        newRow = row + 1
+                        -- We 'hoist' the control vector as a parameter rather
+                        -- than recomputing it every time we modify selectIx.
+                        newControl = complementByteString . orByteString False newDown . orByteString False newLeft $ newRight
+                     in case go 0 newRow newDown newLeft newRight newControl of
+                          []   -> go (selectIx + 1) row down left right control
+                          next -> (row, available) : next
+    lastRow :: Integer
+    lastRow = dim - 1
+
+-- Helpers
+
+{-# INLINE selectByteString #-}
+selectByteString :: Integer -> BuiltinByteString -> Integer
+selectByteString which bs
+  | which <= 0 = findFirstSetBit bs
+  | otherwise = let i = selectByteString (which - 1) bs
+      in if i == (-1)
+         then (-1)
+         else i + 1 + findFirstSetBit (shiftByteString bs $ negate (i + 1))
+
+{-# INLINE writeBit #-}
+writeBit :: BuiltinByteString -> Integer -> Bool -> BuiltinByteString
+writeBit bs i b = writeBits bs [i] [b]

plutus-benchmark/bitwise/test/Main.hs

@@ -0,0 +1,12 @@
+module Main (main) where
+
+import PlutusBenchmark.NQueens (nqueens)
+import Test.Tasty (defaultMain, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
+
+main :: IO ()
+main = defaultMain . testGroup "nqueens" $ [
+  testCase "solves for 8 queens" $ assertEqual ""
+    [(0,0), (1,4), (2,7), (3,5), (4,2), (5,6), (6,1), (7,3)]
+    (nqueens 8)
+  ]

plutus-benchmark/plutus-benchmark.cabal

@@ -593,3 +593,35 @@ benchmark marlowe-agda-cek
     , plutus-benchmark-common
     , plutus-ledger-api        ^>=1.31
     , plutus-tx                ^>=1.31
+
+-------------------- bitwise-----------------------
+
+library bitwise-internal
+  import:          lang, ghc-version-support
+  hs-source-dirs:  bitwise/src
+  exposed-modules: PlutusBenchmark.NQueens
+  build-depends:   plutus-tx ^>=1.31
+
+test-suite bitwise-test
+  import:         lang, ghc-version-support
+  type:           exitcode-stdio-1.0
+  main-is:        Main.hs
+  hs-source-dirs: bitwise/test
+  build-depends:
+    , base              >=4.9 && <5
+    , bitwise-internal
+    , tasty
+    , tasty-hunit
+
+benchmark bitwise-bench
+  import:         lang, ghc-version-support
+  type:           exitcode-stdio-1.0
+  main-is:        Main.hs
+  hs-source-dirs: bitwise/bench
+  build-depends:  base >=4.9 && <5
+
+--    , bitwise-internal
+--    , criterion
+--    , plutus-benchmark-common
+--    , plutus-tx                ^>=1.30
+--    , plutus-tx-plugin         ^>=1.30