diff --git a/plutus-core/plutus-core/src/PlutusCore/Bitwise.hs b/plutus-core/plutus-core/src/PlutusCore/Bitwise.hs index 46acc7dd3ec..45b74070bf7 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Bitwise.hs +++ b/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`, diff --git a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs b/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs index 065ea86fdfd..1159348db60 100644 --- a/plutus-core/plutus-core/src/PlutusCore/Default/Builtins.hs +++ b/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 diff --git a/plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/WriteBits.plc.golden b/plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/WriteBits.plc.golden index ab0f9ecb22e..7dc57625d05 100644 --- a/plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/WriteBits.plc.golden +++ b/plutus-core/plutus-core/test/TypeSynthesis/Golden/DefaultFun/WriteBits.plc.golden @@ -1 +1 @@ -bytestring -> list (pair integer bool) -> bytestring \ No newline at end of file +bytestring -> list integer -> list bool -> bytestring \ No newline at end of file diff --git a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs b/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs index cce4f034f9d..ab9883c3094 100644 --- a/plutus-core/untyped-plutus-core/test/Evaluation/Builtins/Laws.hs +++ b/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 diff --git a/plutus-tx/src/PlutusTx/Builtins.hs b/plutus-tx/src/PlutusTx/Builtins.hs index fdbe67fe750..7cf6e133235 100644 --- a/plutus-tx/src/PlutusTx/Builtins.hs +++ b/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 diff --git a/plutus-tx/src/PlutusTx/Builtins/Internal.hs b/plutus-tx/src/PlutusTx/Builtins/Internal.hs index 6fa2c5d9cd3..8ce3b5f74ed 100644 --- a/plutus-tx/src/PlutusTx/Builtins/Internal.hs +++ b/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 ::