queens

.stylish-haskell.yaml

@@ -11,7 +11,7 @@ steps:
       remove_redundant: false
 
   - trailing_whitespace: {}
-columns: 100
+columns: 99
 newline: native
 language_extensions:
   - DataKinds

plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Knights.hs

@@ -17,7 +17,7 @@ import PlutusBenchmark.NoFib.Knights.Queue
 
 import PlutusCore.Pretty qualified as PLC
 import PlutusTx qualified as Tx
-import PlutusTx.Prelude as Tx
+import PlutusTx.Prelude as Tx hiding ((*), (+), (-), (/=), (<), (<=), (==), (>), (>=))
 import Prelude qualified as Haskell
 
 {-# INLINABLE zipConst #-}
@@ -27,7 +27,7 @@ zipConst a (b:bs) = (a,b) : zipConst a bs
 
 {-# INLINABLE grow #-}
 grow :: (Integer,ChessSet) -> [(Integer,ChessSet)]
-grow (x,y) = zipConst (x+1) (descendents y)
+grow (x,y) = zipConst (x Haskell.+ 1) (descendents y)
 
 {-# INLINABLE isFinished #-}
 isFinished :: (Integer,ChessSet) -> Bool
@@ -36,23 +36,23 @@ isFinished (_,y) = tourFinished y
 {-# INLINABLE interval #-}
 interval :: Integer -> Integer -> [Integer]
 interval a b =
-    if a > b then []
-    else a:(interval (a+1) b)
+    if a Haskell.> b then []
+    else a:(interval (a Haskell.+ 1) b)
 
 
 {-# INLINABLE repl #-}
 repl :: Integer -> Integer -> [Integer]
 repl n a =
-    if n == 0 then []
-    else a:(repl (n-1) a)
+    if n Haskell.== 0 then []
+    else a:(repl (n Haskell.- 1) a)
 
 -- % Original version used infinite lists.
 {-# INLINABLE mkStarts #-}
 mkStarts :: Integer -> [(Integer, ChessSet)]
 mkStarts sze =
     let l = [startTour (x,y) sze | x <- interval 1 sze, y <- interval 1 sze]
         numStarts = Tx.length l  -- = sze*sze
-    in Tx.zip (repl numStarts (1-numStarts)) l
+    in Tx.zip (repl numStarts (1 Haskell.- numStarts)) l
 
 {-# INLINABLE root #-}
 root :: Integer -> Queue (Integer, ChessSet)
@@ -74,11 +74,11 @@ type Solution = (Integer, ChessSet)
 -- % Added a depth parameter to stop things getting out of hand in the strict world.
 depthSearch :: (Eq a) => Integer -> Queue a -> (a -> [a]) -> (a -> Bool) -> Queue a
 depthSearch depth q growFn finFn
-   | depth == 0             = []
+   | depth Haskell.== 0             = []
    | emptyQueue q           = []
    | finFn (inquireFront q) = (inquireFront q):
-                              (depthSearch (depth-1) (removeFront q) growFn finFn)
-   | otherwise              = depthSearch (depth-1)
+                              (depthSearch (depth Haskell.- 1) (removeFront q) growFn finFn)
+   | otherwise              = depthSearch (depth Haskell.- 1)
                                  (addAllFront (growFn (inquireFront q))
                                               (removeFront q))
                                  growFn

plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Prime.hs

@@ -26,12 +26,13 @@ import GHC.Generics
 
 import PlutusBenchmark.Common (Term, compiledCodeToTerm)
 
+import Prelude ((*), (+), (-), (<), (<=), (==), (>), (>=))
 import Prelude qualified as Haskell
 
 import PlutusCore.Pretty qualified as PLC
 import PlutusTx qualified as Tx
 import PlutusTx.Builtins (divideInteger, modInteger)
-import PlutusTx.Prelude as Tx hiding (even)
+import PlutusTx.Prelude as Tx hiding (even, (*), (+), (-), (/=), (<), (<=), (==), (>=))
 
 ---------------- Extras ----------------
 
@@ -84,7 +85,6 @@ powerMod a b m =
    @y@^3 &\geq & @x@, \mbox{ and}\\
    (@y@-1)^3 &<& @x@.
    \end{array}\]
-
    My implementation uses Newton's method.
 -}
 {-# INLINABLE cubeRoot #-}

plutus-benchmark/nofib/src/PlutusBenchmark/NoFib/Queens.hs

@@ -32,7 +32,7 @@ import PlutusBenchmark.Common (Term, compiledCodeToTerm)
 
 import PlutusCore.Pretty qualified as PLC
 import PlutusTx qualified as Tx
-import PlutusTx.Prelude as TxPrelude hiding (abs, sortBy)
+import PlutusTx.Prelude as TxPrelude hiding (abs, sortBy, (*), (+), (-), (<), (<=), (>), (>=))
 
 -----------------------------
 -- The main program
@@ -102,6 +102,9 @@ mkQueensCode sz alg =
               `Tx.unsafeApplyCode` Tx.liftCode sz
               `Tx.unsafeApplyCode` Tx.liftCode alg
 
+snooker :: Tx.CompiledCode [State]
+snooker = $$(Tx.compile [|| runQueens 4 Bt ||])
+
 mkQueensTerm :: Integer -> Algorithm -> Term
 mkQueensTerm sz alg = compiledCodeToTerm $ mkQueensCode sz alg
 
@@ -130,18 +133,18 @@ unindent d = map (dropWhile isSpace) $ (Haskell.lines . Haskell.show $ d)
 iterateN :: Integer -> (a -> a) -> a -> [a]
 iterateN k f x =
     if k == 0 then []
-    else x : iterateN (k-1) f (f x)
+    else x : iterateN (k Haskell.- 1) f (f x)
 
 -- % Replacement for [a..b]
 {-# INLINABLE interval #-}
 interval :: Integer -> Integer -> [Integer]
 interval a b =
-    if a > b then []
-    else a : (interval (a+1) b)
+    if a Haskell.> b then []
+    else a : (interval (a Haskell.+ 1) b)
 
 {-# INLINABLE abs #-}
 abs :: Integer -> Integer
-abs n = if n<0 then 0-n else n
+abs n = if n Haskell.< 0 then -n else n
 
 -- % Things needed for `union`
 
@@ -199,12 +202,13 @@ type Var = Integer
 type Value = Integer
 
 data Assign = Var := Value
-    deriving stock (Haskell.Show, Haskell.Eq, Haskell.Ord, Generic)
+    deriving stock (Haskell.Show, Generic)
     deriving anyclass (NFData)
-instance TxPrelude.Eq Assign
-    where (a := b) == (a' := b') = a==a' && b==b'
-instance TxPrelude.Ord Assign
-    where (a := b) < (a' := b') = (a<a') || (a==a' && b < b')
+instance Haskell.Eq Assign where
+    (a := b) == (a' := b') = a Haskell.== a' && b Haskell.== b'
+instance Haskell.Ord Assign where
+    (a := b) < (a' := b') = (a Haskell.< a') || (a Haskell.== a' && b Haskell.< b')
+    (a := b) <= (a' := b') = (a Haskell.< a') || (a Haskell.== a' && b Haskell.<= b')
 
 type Relation = Assign -> Assign -> Bool
 
@@ -233,12 +237,12 @@ complete CSP{vars=vars} s = maxLevel s == vars
 generate :: CSP -> [State]
 generate CSP{vals=vals,vars=vars} = g vars
   where g 0   = [[]]
-        g var = [ (var := val):st | val <- interval 1 vals, st <- g (var-1) ]
+        g var = [ (var := val):st | val <- interval 1 vals, st <- g (var Haskell.- 1) ]
 
 {-# INLINABLE inconsistencies #-}
 inconsistencies :: CSP -> State -> [(Var,Var)]
 inconsistencies CSP{rel=rel} as =
-  [ (level a, level b) | a <- as, b <- reverse as, a > b, not (rel a b) ]
+  [ (level a, level b) | a <- as, b <- reverse as, a Haskell.> b, not (rel a b) ]
 
 {-# INLINABLE consistent #-}
 consistent :: CSP -> State -> Bool
@@ -256,7 +260,7 @@ solver csp  = test csp candidates
 {-# INLINABLE queens #-}
 queens :: Integer -> CSP
 queens n = CSP {vars = n, vals = n, rel = safe}
-  where safe (i := m) (j := n) = (m /= n) && abs (i - j) /= abs (m - n)
+  where safe (i := m) (j := n) = (m /= n) && abs (i Haskell.- j) /= abs (m Haskell.- n)
 
 -------------------------------
 -- Figure 2.  Trees in Haskell.
@@ -303,7 +307,7 @@ initTree f a = Node a (map (initTree f) (f a))
 mkTree :: CSP -> Tree State
 mkTree CSP{vars=vars,vals=vals} = initTree next []
         -- Removed [1..vals]
-  where next ss = [ ((maxLevel ss + 1) := j):ss | maxLevel ss < vars, j <- vallist ]
+  where next ss = [ ((maxLevel ss Haskell.+ 1) := j):ss | maxLevel ss Haskell.< vars, j <- vallist ]
         vallist = interval 1 vals
 
 {-# INLINABLE earliestInconsistency #-}
@@ -392,8 +396,8 @@ btr seed csp = bt csp . hrandom seed
 
 {-# INLINABLE random2 #-}
 random2 :: Integer -> Integer
-random2 n = if test > 0 then test else test Haskell.+ 2147483647
-  where test = 16807 Haskell.* lo - 2836 Haskell.* hi
+random2 n = if test Haskell.> 0 then test else test Haskell.+ 2147483647
+  where test = 16807 Haskell.* lo Haskell.- 2836 Haskell.* hi
         hi   = n `Haskell.div` 127773
         lo   = n `Haskell.rem` 127773
 
@@ -447,7 +451,7 @@ lookupCache csp t = mapTree f t
   where f ([], tbl)      = (([], Unknown), tbl)
         f (s@(a:_), tbl) = ((s, cs), tbl)
              where cs = if tableEntry == Unknown then checkComplete csp s else tableEntry
-                   tableEntry = (head tbl)!!(value a-1)
+                   tableEntry = (head tbl)!!(value a Haskell.- 1)
 
 --------------------------------------------
 -- Figure 10. Conflict-directed backjumping.

plutus-benchmark/nofib/test/Spec.hs

@@ -65,7 +65,7 @@ testKnights = testGroup "knights"  -- Odd sizes call "error" because there are n
               , testCase "depth 100, 4x4" $ mkKnightsTest 100 4
               , testCase "depth 100, 6x6" $ mkKnightsTest 100 6
               , testCase "depth 100, 8x8" $ mkKnightsTest 100 8
-              , Tx.fitsInto "depth 10, 4x4 (size)" (Knights.mkKnightsCode 10 4) 3494
+              , Tx.fitsInto "depth 10, 4x4 (size)" (Knights.mkKnightsCode 10 4) 3482
               , runTestNested $ Tx.goldenBudget "knightsBudget" $ Knights.mkKnightsCode 10 4
               ]
 
@@ -85,6 +85,10 @@ testQueens = testGroup "queens"
                , testCase "Fc"    $ mkQueensTest 4 Queens.Fc
                , runTestNested    $
                   Tx.goldenBudget "queens4budget" $ Queens.mkQueensCode 4 Queens.Bt
+               , runTestNested    $
+                  Tx.goldenBudget "snooker" $ Queens.snooker
+            , runTestNested    $
+                  Tx.goldenPirReadable "snooker" $ Queens.snooker
                ]
              , testGroup "5x5"
                [ testCase "Bt"    $ mkQueensTest 5 Queens.Bt
@@ -95,7 +99,7 @@ testQueens = testGroup "queens"
                , runTestNested    $ Tx.goldenBudget "queens5budget" $
                   Queens.mkQueensCode 5 Queens.Bt
                ]
-             , Tx.fitsInto "Bt (size)" (Queens.mkQueensCode 5 Queens.Bt) 2852
+             , Tx.fitsInto "Bt (size)" (Queens.mkQueensCode 5 Queens.Bt) 2617
              ]
 
 ---------------- Primes ----------------

plutus-benchmark/nofib/test/knightsBudget.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 7378435298
-| mem: 27654740})
+({cpu: 7268656298
+| mem: 27177440})

plutus-benchmark/nofib/test/queens4budget.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 17033524305
-| mem: 67169742})
+({cpu: 14312670305
+| mem: 55339942})

plutus-benchmark/nofib/test/queens5budget.budget.golden

@@ -1,2 +1,2 @@
-({cpu: 236999646648
-| mem: 923154380})
+({cpu: 194195565648
+| mem: 737049680})

plutus-benchmark/nofib/test/snooker.budget.golden

@@ -0,0 +1,2 @@
+({cpu: 14310991305
+| mem: 55332642})

plutus-benchmark/nofib/test/snooker.budget.golden.patched

@@ -0,0 +1,2 @@
+({cpu: 16087787305
+| mem: 63057842})