Change writeBits to take changelists as two separate lists (Intersect…

…MBO#6317)

* fix: types in defaultConstitution (IntersectMBO#6307)

More descriptive type names in the defaultConstitution

Co-authored-by: Nikolaos Bezirgiannis <329939+bezirg@users.noreply.github.com>

* Fix overflow bug in shiftByteString, rotateByteString, add tests to ensure it stays fixed (IntersectMBO#6309)

* Fix overflow bug in shiftByteString, add tests to ensure it stays fixed

* Fix similar issue in rotations

* Add shift wrapper for bounds checks

* Fix rotations similarly, note in docs

* Fix typo, note about fromIntegral

* Release 1.31.0.0 (IntersectMBO#6312)

* Modify writeBits to use two lists as arguments

* Fix writeBits in PlutusTx to match new API

* Fix goldens

---------

Co-authored-by: Romain Soulat <117812549+RSoulatIOHK@users.noreply.github.com>
Co-authored-by: Nikolaos Bezirgiannis <329939+bezirg@users.noreply.github.com>
Co-authored-by: Yura Lazarev <1009751+Unisay@users.noreply.github.com>

plutus-core/plutus-core/src/PlutusCore/Bitwise.hs

@@ -12,6 +12,7 @@ module PlutusCore.Bitwise (
   byteStringToIntegerWrapper,
   shiftByteStringWrapper,
   rotateByteStringWrapper,
+  writeBitsWrapper,
   -- * Implementation details
   IntegerToByteStringError (..),
   integerToByteStringMaximumOutputLength,
@@ -357,6 +358,12 @@ byteStringToInteger statedByteOrder input = case statedByteOrder of
 endiannessArgToByteOrder :: Bool -> ByteOrder
 endiannessArgToByteOrder b = if b then BigEndian else LittleEndian
 
+-- | Needed due to the complexities of passing lists of pairs as arguments.
+-- Effectively, we pass the second argument as required by CIP-122 in its
+-- \'unzipped\' form, truncating mismatches.
+writeBitsWrapper :: ByteString -> [Integer] -> [Bool] -> BuiltinResult ByteString
+writeBitsWrapper bs ixes = writeBits bs . zip ixes
+
 {- Note [Binary bitwise operation implementation and manual specialization]
 
    All of the 'binary' bitwise operations (namely `andByteString`,

plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs

@@ -1921,12 +1921,12 @@ instance uni ~ DefaultUni => ToBuiltinMeaning uni DefaultFun where
             (runCostingFunTwoArguments . unimplementedCostingFun)
 
     toBuiltinMeaning _semvar WriteBits =
-        let writeBitsDenotation :: BS.ByteString -> [(Integer, Bool)] -> BuiltinResult BS.ByteString
-            writeBitsDenotation = Bitwise.writeBits
+        let writeBitsDenotation :: BS.ByteString -> [Integer] -> [Bool] -> BuiltinResult BS.ByteString
+            writeBitsDenotation = Bitwise.writeBitsWrapper
             {-# INLINE writeBitsDenotation #-}
         in makeBuiltinMeaning
             writeBitsDenotation
-            (runCostingFunTwoArguments . unimplementedCostingFun)
+            (runCostingFunThreeArguments . unimplementedCostingFun)
 
     toBuiltinMeaning _semvar ReplicateByte =
         let replicateByteDenotation :: Int -> Word8 -> BuiltinResult BS.ByteString

plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/WriteBits.plc.golden

@@ -1 +1 @@
-bytestring -> list (pair integer bool) -> bytestring
+bytestring -> list integer -> list bool -> bytestring

plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs

@@ -65,7 +65,8 @@ getSet =
     b <- evaluateToHaskell lookupExp
     let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
           mkConstant @ByteString () bs,
-          mkConstant @[(Integer, Bool)] () [(i, b)]
+          mkConstant @[Integer] () [i],
+          mkConstant @[Bool] () [b]
           ]
     evaluatesToConstant bs lhs
 
@@ -79,7 +80,8 @@ setGet =
     b <- forAll Gen.bool
     let lhsInner = mkIterAppNoAnn (builtin () PLC.WriteBits) [
           mkConstant @ByteString () bs,
-          mkConstant @[(Integer, Bool)] () [(i, b)]
+          mkConstant @[Integer] () [i],
+          mkConstant @[Bool] () [b]
           ]
     let lhs = mkIterAppNoAnn (builtin () PLC.ReadBit) [
           lhsInner,
@@ -97,11 +99,13 @@ setSet =
     b2 <- forAll Gen.bool
     let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
           mkConstant @ByteString () bs,
-          mkConstant @[(Integer, Bool)] () [(i, b1), (i, b2)]
+          mkConstant @[Integer] () [i, i],
+          mkConstant @[Bool] () [b1, b2]
           ]
     let rhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
           mkConstant @ByteString () bs,
-          mkConstant @[(Integer, Bool)] () [(i, b2)]
+          mkConstant @[Integer] () [i],
+          mkConstant @[Bool] () [b2]
           ]
     evaluateTheSame lhs rhs
 
@@ -122,25 +126,29 @@ writeBitsHomomorphismLaws =
         bs <- forAllByteString 1 512
         let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
               mkConstant @ByteString () bs,
-              mkConstant @[(Integer, Bool)] () []
+              mkConstant @[Integer] () [],
+              mkConstant @[Bool] () []
               ]
         evaluatesToConstant bs lhs
       compositionProp :: Property
       compositionProp = property $ do
         bs <- forAllByteString 1 512
-        changelist1 <- forAllChangelistOf bs
-        changelist2 <- forAllChangelistOf bs
+        (ixes1, bits1) <- forAllChangelistsOf bs
+        (ixes2, bits2) <- forAllChangelistsOf bs
         let lhsInner = mkIterAppNoAnn (builtin () PLC.WriteBits) [
               mkConstant @ByteString () bs,
-              mkConstant @[(Integer, Bool)] () changelist1
+              mkConstant @[Integer] () ixes1,
+              mkConstant @[Bool] () bits1
               ]
         let lhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
               lhsInner,
-              mkConstant @[(Integer, Bool)] () changelist2
+              mkConstant @[Integer] () ixes2,
+              mkConstant @[Bool] () bits2
               ]
         let rhs = mkIterAppNoAnn (builtin () PLC.WriteBits) [
               mkConstant @ByteString () bs,
-              mkConstant @[(Integer, Bool)] () (changelist1 <> changelist2)
+              mkConstant @[Integer] () (ixes1 <> ixes2),
+              mkConstant @[Bool] () (bits1 <> bits2)
               ]
         evaluateTheSame lhs rhs
 
@@ -455,9 +463,12 @@ unitProp f isPadding unit = property $ do
 forAllIndexOf :: ByteString -> PropertyT IO Integer
 forAllIndexOf bs = forAll . Gen.integral . Range.linear 0 . fromIntegral $ BS.length bs * 8 - 1
 
-forAllChangelistOf :: ByteString -> PropertyT IO [(Integer, Bool)]
-forAllChangelistOf bs =
-  forAll . Gen.list (Range.linear 0 (8 * len - 1)) $ (,) <$> genIndex <*> Gen.bool
+forAllChangelistsOf :: ByteString -> PropertyT IO ([Integer], [Bool])
+forAllChangelistsOf bs = do
+  ourLen :: Int <- forAll . Gen.integral . Range.linear 0 $ 8 * len - 1
+  ixes <- forAll . Gen.list (Range.singleton ourLen) $ genIndex
+  bits <- forAll . Gen.list (Range.singleton ourLen) $ Gen.bool
+  pure (ixes, bits)
   where
     len :: Int
     len = BS.length bs

plutus-tx/src/PlutusTx/Builtins.hs

@@ -784,11 +784,28 @@ readBit ::
   Bool
 readBit bs i = fromOpaque (BI.readBit bs i)
 
--- | Given a 'BuiltinByteString' and a changelist of index-value pairs, set the _bit_ at each index
--- where the corresponding value is 'True', and clear the bit at each index where the corresponding
--- value is 'False'. Will error if any of the indexes are out-of-bounds: that is, if the index is
--- either negative, or equal to or greater than the total number of bits in the 'BuiltinByteString'
--- argument.
+-- | Given a 'BuiltinByteString', a list of indexes to change, and a list of values to change those
+-- indexes to, set the /bit/ at each of the specified index as follows:
+--
+-- * If the corresponding entry in the list of values is 'True', set that bit;
+-- * Otherwise, clear that bit.
+--
+-- Will error if any of the indexes are out-of-bounds: that is, if the index is either negative, or
+-- equal to or greater than the total number of bits in the 'BuiltinByteString' argument.
+--
+-- If the two list arguments have mismatched lengths, the longer argument will be truncated to match
+-- the length of the shorter one:
+--
+-- * @writeBits bs [0, 1, 4] [True]@ is the same as @writeBits bs [0] [True]@
+-- * @writeBits bs [0] [True, False, True]@ is the same as @writeBits bs [0] [True]@
+--
+-- = Note
+--
+-- This differs slightly from the description of the [corresponding operation in
+-- CIP-122](https://github.com/cardano-foundation/CIPs/tree/master/CIP-0122#writebits); instead of a
+-- single changelist argument comprised of pairs, we instead pass two lists, one for indexes to
+-- change, and one for the values to change those indexes to. Effectively, we are passing the
+-- changelist argument \'unzipped\'.
 --
 -- = See also
 --
@@ -799,9 +816,10 @@ readBit bs i = fromOpaque (BI.readBit bs i)
 {-# INLINEABLE writeBits #-}
 writeBits ::
   BuiltinByteString ->
-  BI.BuiltinList (BI.BuiltinPair BI.BuiltinInteger BI.BuiltinBool) ->
+  [Integer] ->
+  [Bool] ->
   BuiltinByteString
-writeBits = BI.writeBits
+writeBits bs ixes bits = BI.writeBits bs (toBuiltin ixes) (toBuiltin bits)
 
 -- | Given a length (first argument) and a byte (second argument), produce a 'BuiltinByteString' of
 -- that length, with that byte in every position. Will error if given a negative length, or a second

plutus-tx/src/PlutusTx/Builtins/Internal.hs

@@ -793,15 +793,15 @@ readBit (BuiltinByteString bs) i =
 {-# NOINLINE writeBits #-}
 writeBits ::
   BuiltinByteString ->
-  BuiltinList (BuiltinPair BuiltinInteger BuiltinBool) ->
+  BuiltinList BuiltinInteger ->
+  BuiltinList BuiltinBool ->
   BuiltinByteString
-writeBits (BuiltinByteString bs) (BuiltinList xs) =
-  let unwrapped = fmap (\(BuiltinPair (i, BuiltinBool b)) -> (i, b)) xs in
-    case Bitwise.writeBits bs unwrapped of
-      BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $
-        Haskell.error "writeBits errored."
-      BuiltinSuccess bs' -> BuiltinByteString bs'
-      BuiltinSuccessWithLogs logs bs' -> traceAll logs $ BuiltinByteString bs'
+writeBits (BuiltinByteString bs) (BuiltinList ixes) (BuiltinList bits) =
+  case Bitwise.writeBitsWrapper bs ixes (fmap (\(BuiltinBool b) -> b) bits) of
+    BuiltinFailure logs err -> traceAll (logs <> pure (display err)) $
+      Haskell.error "writeBits errored."
+    BuiltinSuccess bs' -> BuiltinByteString bs'
+    BuiltinSuccessWithLogs logs bs' -> traceAll logs $ BuiltinByteString bs'
 
 {-# NOINLINE replicateByte #-}
 replicateByte ::