From 04ef674d06bf586f75189ed3ec7aad4e9d202d14 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 18 Jun 2024 16:21:49 +0300 Subject: [PATCH 1/6] First prototype of optimised Data Value union Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 162 ++++++++++++++++++ plutus-tx/src/PlutusTx/Data/AssocMap.hs | 3 + 2 files changed, 165 insertions(+) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index e94bc03a213..840383f40da 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -339,6 +339,168 @@ unionWith f ls rs = These a b -> f a b in Value (Map.map (Map.map unThese) combined) +unionVal' + :: (Integer -> Integer -> Integer) + -> Value + -> Value + -> Value +unionVal' + f + (Map.toBuiltinList . getValue -> ls) + (Map.toBuiltinList . getValue -> rs) + = + Value . Map.unsafeFromBuiltinList $ res ls rs + where + goLeft + :: BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + goLeft leftMap = + B.matchList + leftMap + (\() -> Map.nil) + (\hd tl -> + let curSymb = BI.fst hd + leftTokens = BI.snd hd + leftTokensMap = BI.unsafeDataAsMap leftTokens + in + case Map.lookup' curSymb rs of + Just rightTokens -> + let rightTokensMap = BI.unsafeDataAsMap rightTokens + pt lTs = + B.matchList + lTs + (\() -> Map.nil) + (\hd' tl' -> + let tok = BI.fst hd' + leftAmt = BI.snd hd' + in + case Map.lookup' tok rightTokensMap of + Just rightAmt -> + BI.mkCons + (BI.mkPairData + tok + ( PlutusTx.toBuiltinData + $ f + (PlutusTx.unsafeFromBuiltinData leftAmt) + (PlutusTx.unsafeFromBuiltinData rightAmt) + ) + ) + (pt tl') + Nothing -> + BI.mkCons + (BI.mkPairData + tok + ( PlutusTx.toBuiltinData + $ f (PlutusTx.unsafeFromBuiltinData leftAmt) 0 + ) + ) + (pt tl') + ) + in + BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt leftTokensMap)) (goLeft tl) + Nothing -> + let pt lTs = + B.matchList + lTs + (\() -> Map.nil) + (\hd' tl' -> + let tok = BI.fst hd' + leftAmt = BI.snd hd' + in + BI.mkCons + (BI.mkPairData + tok + ( PlutusTx.toBuiltinData + $ f (PlutusTx.unsafeFromBuiltinData leftAmt) 0 + ) + ) + (pt tl') + ) + in + BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt leftTokensMap)) (goLeft tl) + ) + + goRight + :: BuiltinList (BuiltinPair BuiltinData BuiltinData) + -> BuiltinList (BuiltinPair BuiltinData BuiltinData) + goRight rightMap = + B.matchList + rightMap + (\() -> Map.nil) + (\hd tl -> + let curSymb = BI.fst hd + rightTokens = BI.snd hd + rightTokensMap = BI.unsafeDataAsMap rightTokens + in + case Map.lookup' curSymb ls of + Just leftTokens -> + let leftTokensMap = BI.unsafeDataAsMap leftTokens + pt lTs = + B.matchList + lTs + (\() -> Map.nil) + (\hd' tl' -> + let tok = BI.fst hd' + rightAmt = BI.snd hd' + in + case Map.lookup' tok leftTokensMap of + Just leftAmt -> + BI.mkCons + (BI.mkPairData + tok + ( PlutusTx.toBuiltinData + $ f + (PlutusTx.unsafeFromBuiltinData leftAmt) + (PlutusTx.unsafeFromBuiltinData rightAmt) + ) + ) + (pt tl') + Nothing -> + BI.mkCons + (BI.mkPairData + tok + ( PlutusTx.toBuiltinData + $ f 0 (PlutusTx.unsafeFromBuiltinData rightAmt) + ) + ) + (pt tl') + ) + in + BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt rightTokensMap)) (goRight tl) + Nothing -> + let pt lTs = + B.matchList + lTs + (\() -> Map.nil) + (\hd' tl' -> + let tok = BI.fst hd' + rightAmt = BI.snd hd' + in + BI.mkCons + (BI.mkPairData + tok + ( PlutusTx.toBuiltinData + $ f 0 (PlutusTx.unsafeFromBuiltinData rightAmt) + ) + ) + (pt tl') + ) + in + BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt rightTokensMap)) (goRight tl) + ) + + safeAppend xs1 xs2 = + B.matchList + xs1 + (\() -> xs2) + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + in Map.insert' k v (safeAppend tl xs2) + ) + + res l r = goLeft l `safeAppend` goRight r + {-# INLINABLE flattenValue #-} -- | Convert a 'Value' to a simple list, keeping only the non-zero amounts. -- Note that the result isn't sorted, meaning @v1 == v2@ doesn't generally imply diff --git a/plutus-tx/src/PlutusTx/Data/AssocMap.hs b/plutus-tx/src/PlutusTx/Data/AssocMap.hs index 5fded4753d9..fe218ff330b 100644 --- a/plutus-tx/src/PlutusTx/Data/AssocMap.hs +++ b/plutus-tx/src/PlutusTx/Data/AssocMap.hs @@ -8,8 +8,10 @@ module PlutusTx.Data.AssocMap ( Map, lookup, + lookup', member, insert, + insert', delete, singleton, empty, @@ -28,6 +30,7 @@ module PlutusTx.Data.AssocMap ( map, mapThese, foldr, + nil, ) where import PlutusTx.Builtins qualified as P From 3aa44086816f3e9558d3b6b210ba5516a464d7fe Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Wed, 19 Jun 2024 16:52:11 +0300 Subject: [PATCH 2/6] Partial fix Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 29 ++++++------------- 1 file changed, 9 insertions(+), 20 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 840383f40da..ce77b8cde7c 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -330,26 +330,20 @@ unionVal (Value l) (Value r) = -- | Combine two 'Value' maps with the argument function. -- Assumes the well-definedness of the two maps. unionWith :: (Integer -> Integer -> Integer) -> Value -> Value -> Value -unionWith f ls rs = - let - combined = unionVal ls rs - unThese k' = case k' of - This a -> f a 0 - That b -> f 0 b - These a b -> f a b - in Value (Map.map (Map.map unThese) combined) - -unionVal' - :: (Integer -> Integer -> Integer) - -> Value +unionWith f v1 = Value . unionWith' f v1 + +unionWith' + :: (PlutusTx.ToData a) + => (Integer -> Integer -> a) -> Value -> Value -unionVal' + -> Map.Map CurrencySymbol (Map.Map TokenName a) +unionWith' f (Map.toBuiltinList . getValue -> ls) (Map.toBuiltinList . getValue -> rs) = - Value . Map.unsafeFromBuiltinList $ res ls rs + Map.unsafeFromBuiltinList $ res ls rs where goLeft :: BuiltinList (BuiltinPair BuiltinData BuiltinData) @@ -540,12 +534,7 @@ checkPred f l r = -- supplying 0 where a key is only present in one of them. checkBinRel :: (Integer -> Integer -> Bool) -> Value -> Value -> Bool checkBinRel f l r = - let - unThese k' = case k' of - This a -> f a 0 - That b -> f 0 b - These a b -> f a b - in checkPred unThese l r + Map.all (Map.all id) (unionWith' f l r) {-# INLINABLE geq #-} -- | Check whether one 'Value' is greater than or equal to another. See 'Value' for an explanation From 65569c7fa98f5ab37a41faf66da4103eac5232c7 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Thu, 20 Jun 2024 12:34:32 +0300 Subject: [PATCH 3/6] Fix unionWith algorithm Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 19 +- .../Spec/Data/Budget/9.6/geq1.budget.golden | 4 +- .../Spec/Data/Budget/9.6/geq2.budget.golden | 4 +- .../Spec/Data/Budget/9.6/geq3.budget.golden | 4 +- .../Spec/Data/Budget/9.6/geq4.budget.golden | 4 +- .../Spec/Data/Budget/9.6/geq5.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt.pir.golden | 758 +++++++++--------- .../Spec/Data/Budget/9.6/gt1.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt2.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt3.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt4.budget.golden | 4 +- .../Spec/Data/Budget/9.6/gt5.budget.golden | 4 +- 12 files changed, 410 insertions(+), 407 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index ce77b8cde7c..618d1c62600 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -483,6 +483,16 @@ unionWith' BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt rightTokensMap)) (goRight tl) ) + safeAppendInner xs1 xs2 = + B.matchList + xs1 + (\() -> xs2) + ( \hd tl -> + let k = BI.fst hd + v = BI.snd hd + in Map.insert' k v (safeAppendInner tl xs2) + ) + safeAppend xs1 xs2 = B.matchList xs1 @@ -490,7 +500,14 @@ unionWith' ( \hd tl -> let k = BI.fst hd v = BI.snd hd - in Map.insert' k v (safeAppend tl xs2) + in + case Map.lookup' k xs2 of + Just v' -> + let vNew = + BI.mkMap + $ safeAppendInner (BI.unsafeDataAsMap v) (BI.unsafeDataAsMap v') + in Map.insert' k vNew (safeAppend tl xs2) + Nothing -> Map.insert' k v (safeAppend tl xs2) ) res l r = goLeft l `safeAppend` goRight r diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden index 889d817f475..f19b3dd603c 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq1.budget.golden @@ -1,2 +1,2 @@ -({cpu: 614011320 -| mem: 1839010}) \ No newline at end of file +({cpu: 590056416 +| mem: 1659138}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden index 1c96be260f1..88d182ecb2f 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq2.budget.golden @@ -1,2 +1,2 @@ -({cpu: 649267269 -| mem: 1959530}) \ No newline at end of file +({cpu: 619254539 +| mem: 1751842}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden index 0cb8213faf4..52217550b73 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq3.budget.golden @@ -1,2 +1,2 @@ -({cpu: 677953814 -| mem: 2051216}) \ No newline at end of file +({cpu: 659950439 +| mem: 1870296}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden index 7cc3dfba486..54075cbc3d9 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 589398915 -| mem: 1735702}) \ No newline at end of file +({cpu: 576299094 +| mem: 1596676}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden index 9d0dcbff6db..797065d2fbe 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/geq5.budget.golden @@ -1,2 +1,2 @@ -({cpu: 636471807 -| mem: 1904018}) \ No newline at end of file +({cpu: 612184202 +| mem: 1722320}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden index 76ed91318bb..1949080145b 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt.pir.golden @@ -1,165 +1,111 @@ let - !`$fToDataInteger_$ctoBuiltinData` : integer -> data - = \(i : integer) -> iData i - data (These :: * -> * -> *) a b | These_match where - That : b -> These a b - These : a -> b -> These a b - This : a -> These a b - !`$fToDataThese_$ctoBuiltinData` : - all a b. (\a -> a -> data) a -> (\a -> a -> data) b -> These a b -> data - = /\a b -> - \(`$dToData` : (\a -> a -> data) a) - (`$dToData` : (\a -> a -> data) b) - (ds : These a b) -> - These_match - {a} - {b} - ds - {data} - (\(arg : b) -> constrData 1 (mkCons {data} (`$dToData` arg) [])) - (\(arg : a) (arg : b) -> - constrData - 2 - (mkCons - {data} - (`$dToData` arg) - (mkCons {data} (`$dToData` arg) []))) - (\(arg : a) -> constrData 0 (mkCons {data} (`$dToData` arg) [])) - ~`$dToData` : These integer integer -> data - = `$fToDataThese_$ctoBuiltinData` - {integer} - {integer} - `$fToDataInteger_$ctoBuiltinData` - `$fToDataInteger_$ctoBuiltinData` data Bool | Bool_match where True : Bool False : Bool !f : integer -> integer -> Bool = \(x : integer) (y : integer) -> ifThenElse {Bool} (lessThanInteger x y) False True - !`$fUnsafeFromDataThese_$cunsafeFromBuiltinData` : - all a b. (\a -> data -> a) a -> (\a -> data -> a) b -> data -> These a b - = /\a b -> - \(`$dUnsafeFromData` : (\a -> data -> a) a) - (`$dUnsafeFromData` : (\a -> data -> a) b) - (d : data) -> - let - !tup : pair integer (list data) = unConstrData d - !index : integer = fstPair {integer} {list data} tup - !args : list data = sndPair {integer} {list data} tup - in - ifThenElse - {all dead. These a b} - (equalsInteger 0 index) - (/\dead -> This {a} {b} (`$dUnsafeFromData` (headList {data} args))) - (/\dead -> - ifThenElse - {all dead. These a b} - (equalsInteger 1 index) - (/\dead -> - That {a} {b} (`$dUnsafeFromData` (headList {data} args))) - (/\dead -> - ifThenElse - {all dead. These a b} - (equalsInteger 2 index) - (/\dead -> - These - {a} - {b} - (`$dUnsafeFromData` (headList {data} args)) - (`$dUnsafeFromData` - (headList {data} (tailList {data} args)))) - (/\dead -> error {These a b}) - {all dead. dead}) - {all dead. dead}) - {all dead. dead} - !`$fToDataMap_$ctoBuiltinData` : - all k a. (\k a -> list (pair data data)) k a -> data - = /\k a -> \(ds : (\k a -> list (pair data data)) k a) -> mapData ds + !`$dToData` : (\a -> a -> data) Bool + = \(ds : Bool) -> + Bool_match + ds + {all dead. data} + (/\dead -> Constr 1 []) + (/\dead -> Constr 0 []) + {all dead. dead} data Unit | Unit_match where Unit : Unit - !map : - all k a b. - (\a -> data -> a) a -> - (\a -> a -> data) b -> - (a -> b) -> - (\k a -> list (pair data data)) k a -> - (\k a -> list (pair data data)) k b - = /\k a b -> - \(`$dUnsafeFromData` : (\a -> data -> a) a) - (`$dToData` : (\a -> a -> data) b) - (f : a -> b) -> - letrec - !go : list (pair data data) -> list (pair data data) - = \(xs : list (pair data data)) -> - chooseList - {pair data data} - {Unit -> list (pair data data)} - xs - (\(ds : Unit) -> []) - (\(ds : Unit) -> - let - !hd : pair data data = headList {pair data data} xs - !tl : list (pair data data) - = tailList {pair data data} xs - !v : data = sndPair {data} {data} hd - in - mkCons - {pair data data} - (mkPairData - (fstPair {data} {data} hd) - (`$dToData` (f (`$dUnsafeFromData` v)))) - (go tl)) - Unit - in - \(ds : (\k a -> list (pair data data)) k a) -> go ds + !`$fAdditiveGroupValue` : Unit -> list (pair data data) = \(ds : Unit) -> [] in letrec - !safeAppend : - list (pair data data) -> list (pair data data) -> list (pair data data) - = \(xs : list (pair data data)) (xs : list (pair data data)) -> + !pt : list (pair data data) -> list (pair data data) + = \(lTs : list (pair data data)) -> + let + ~hd' : pair data data = headList {pair data data} lTs + in chooseList {pair data data} {Unit -> list (pair data data)} - xs - (\(ds : Unit) -> xs) + lTs + `$fAdditiveGroupValue` (\(ds : Unit) -> - let - !hd : pair data data = headList {pair data data} xs - !tl : list (pair data data) = tailList {pair data data} xs - !v : data = sndPair {data} {data} hd - !k : data = fstPair {data} {data} hd - in - letrec - !go : list (pair data data) -> list (pair data data) - = \(xs : list (pair data data)) -> - chooseList - {pair data data} - {Unit -> list (pair data data)} - xs - (\(ds : Unit) -> - mkCons {pair data data} (mkPairData k v) []) - (\(ds : Unit) -> - let - !hd : pair data data = headList {pair data data} xs - !tl : list (pair data data) - = tailList {pair data data} xs - in - ifThenElse - {all dead. list (pair data data)} - (equalsData k (fstPair {data} {data} hd)) - (/\dead -> - mkCons {pair data data} (mkPairData k v) tl) - (/\dead -> mkCons {pair data data} hd (go tl)) - {all dead. dead}) - Unit - in - let - !eta : list (pair data data) = safeAppend tl xs - in - go eta) + mkCons + {pair data data} + (mkPairData + (fstPair {data} {data} hd') + (`$dToData` (f 0 (unIData (sndPair {data} {data} hd'))))) + (pt (tailList {pair data data} lTs))) + Unit +in +letrec + !pt : list (pair data data) -> list (pair data data) + = \(lTs : list (pair data data)) -> + let + ~hd' : pair data data = headList {pair data data} lTs + in + chooseList + {pair data data} + {Unit -> list (pair data data)} + lTs + `$fAdditiveGroupValue` + (\(ds : Unit) -> + mkCons + {pair data data} + (mkPairData + (fstPair {data} {data} hd') + (`$dToData` (f (unIData (sndPair {data} {data} hd')) 0))) + (pt (tailList {pair data data} lTs))) Unit in +let + !insert' : data -> data -> list (pair data data) -> list (pair data data) + = \(k : data) (a : data) -> + letrec + !go : list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> mkCons {pair data data} (mkPairData k a) []) + (\(ds : Unit) -> + let + !hd : pair data data = headList {pair data data} xs + !tl : list (pair data data) + = tailList {pair data data} xs + in + ifThenElse + {all dead. list (pair data data)} + (equalsData k (fstPair {data} {data} hd)) + (/\dead -> mkCons {pair data data} (mkPairData k a) tl) + (/\dead -> mkCons {pair data data} hd (go tl)) + {all dead. dead}) + Unit + in + \(eta : list (pair data data)) -> go eta +in +letrec + !`$fAdditiveGroupValue_safeAppendInner` : + list (pair data data) -> list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + let + ~hd : pair data data = headList {pair data data} xs + in + \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> xs) + (\(ds : Unit) -> + insert' + (fstPair {data} {data} hd) + (sndPair {data} {data} hd) + (`$fAdditiveGroupValue_safeAppendInner` + (tailList {pair data data} xs) + xs)) + Unit +in let data (Maybe :: * -> *) a | Maybe_match where Just : a -> Maybe a @@ -192,127 +138,46 @@ let Unit in \(m : list (pair data data)) -> go m - !union : - all k a b. - (\a -> data -> a) a -> - (\a -> data -> a) b -> - (\a -> a -> data) a -> - (\a -> a -> data) b -> - (\k a -> list (pair data data)) k a -> - (\k a -> list (pair data data)) k b -> - (\k a -> list (pair data data)) k (These a b) - = /\k a b -> - \(`$dUnsafeFromData` : (\a -> data -> a) a) - (`$dUnsafeFromData` : (\a -> data -> a) b) - (`$dToData` : (\a -> a -> data) a) - (`$dToData` : (\a -> a -> data) b) - (ds : (\k a -> list (pair data data)) k a) -> - letrec - !goRight : list (pair data data) -> list (pair data data) - = \(xs : list (pair data data)) -> - chooseList - {pair data data} - {Unit -> list (pair data data)} - xs - (\(ds : Unit) -> []) - (\(ds : Unit) -> - let - !hd : pair data data = headList {pair data data} xs - !tl : list (pair data data) - = tailList {pair data data} xs - !v : data = sndPair {data} {data} hd - !k : data = fstPair {data} {data} hd - in - Maybe_match - {data} - (lookup' k ds) - {all dead. list (pair data data)} - (\(r : data) -> - /\dead -> - mkCons - {pair data data} - (mkPairData - k - (`$fToDataThese_$ctoBuiltinData` - {a} - {b} - `$dToData` - `$dToData` - (These - {a} - {b} - (`$dUnsafeFromData` v) - (`$dUnsafeFromData` r)))) - (goRight tl)) - (/\dead -> - mkCons - {pair data data} - (mkPairData - k - (`$fToDataThese_$ctoBuiltinData` - {a} - {b} - `$dToData` - `$dToData` - (That {a} {b} (`$dUnsafeFromData` v)))) - (goRight tl)) - {all dead. dead}) - Unit - in - \(ds : (\k a -> list (pair data data)) k b) -> - letrec - !goLeft : list (pair data data) -> list (pair data data) - = \(xs : list (pair data data)) -> - chooseList - {pair data data} - {Unit -> list (pair data data)} - xs - (\(ds : Unit) -> []) - (\(ds : Unit) -> - let - !hd : pair data data = headList {pair data data} xs - !tl : list (pair data data) - = tailList {pair data data} xs - !v : data = sndPair {data} {data} hd - !k : data = fstPair {data} {data} hd - in - Maybe_match - {data} - (lookup' k ds) - {all dead. list (pair data data)} - (\(r : data) -> - /\dead -> - mkCons - {pair data data} - (mkPairData - k - (`$fToDataThese_$ctoBuiltinData` - {a} - {b} - `$dToData` - `$dToData` - (These - {a} - {b} - (`$dUnsafeFromData` v) - (`$dUnsafeFromData` r)))) - (goLeft tl)) - (/\dead -> - mkCons - {pair data data} - (mkPairData - k - (`$fToDataThese_$ctoBuiltinData` - {a} - {b} - `$dToData` - `$dToData` - (This {a} {b} (`$dUnsafeFromData` v)))) - (goLeft tl)) - {all dead. dead}) - Unit - in - safeAppend (goLeft ds) (goRight ds) +in +letrec + !`$fAdditiveGroupValue_safeAppend` : + list (pair data data) -> list (pair data data) -> list (pair data data) + = \(xs : list (pair data data)) -> + let + ~hd : pair data data = headList {pair data data} xs + ~k : data = fstPair {data} {data} hd + in + \(xs : list (pair data data)) -> + chooseList + {pair data data} + {Unit -> list (pair data data)} + xs + (\(ds : Unit) -> xs) + (\(ds : Unit) -> + Maybe_match + {data} + (lookup' k xs) + {all dead. list (pair data data)} + (\(v' : data) -> + /\dead -> + insert' + k + (mapData + (`$fAdditiveGroupValue_safeAppendInner` + (unMapData (sndPair {data} {data} hd)) + (unMapData v'))) + (`$fAdditiveGroupValue_safeAppend` + (tailList {pair data data} xs) + xs)) + (/\dead -> + insert' + k + (sndPair {data} {data} hd) + (`$fAdditiveGroupValue_safeAppend` + (tailList {pair data data} xs) + xs)) + {all dead. dead}) + Unit in letrec !rev : all a. list a -> list a -> list a @@ -515,127 +380,248 @@ let goBoth eta eta in \(l : - (\k a -> list (pair data data)) - bytestring - ((\k a -> list (pair data data)) bytestring integer)) - (r : (\k a -> list (pair data data)) bytestring ((\k a -> list (pair data data)) bytestring integer)) -> - Bool_match - (all - {bytestring} - {(\k a -> list (pair data data)) bytestring (These integer integer)} - (\(eta : data) -> unMapData eta) - (all - {bytestring} - {These integer integer} - (`$fUnsafeFromDataThese_$cunsafeFromBuiltinData` - {integer} - {integer} - unIData - unIData) - (\(k' : These integer integer) -> - These_match - {integer} - {integer} - k' - {Bool} - (\(b : integer) -> f 0 b) - (\(a : integer) (b : integer) -> f a b) - (\(a : integer) -> f a 0))) - (map - {bytestring} - {These - ((\k a -> list (pair data data)) bytestring integer) - ((\k a -> list (pair data data)) bytestring integer)} - {(\k a -> list (pair data data)) bytestring (These integer integer)} - (`$fUnsafeFromDataThese_$cunsafeFromBuiltinData` - {(\k a -> list (pair data data)) bytestring integer} - {(\k a -> list (pair data data)) bytestring integer} - (\(eta : data) -> unMapData eta) - (\(eta : data) -> unMapData eta)) - (`$fToDataMap_$ctoBuiltinData` {bytestring} {These integer integer}) - (\(k : - These - ((\k a -> list (pair data data)) bytestring integer) - ((\k a -> list (pair data data)) bytestring integer)) -> - These_match - {(\k a -> list (pair data data)) bytestring integer} - {(\k a -> list (pair data data)) bytestring integer} - k - {(\k a -> list (pair data data)) - bytestring - (These integer integer)} - (\(b : (\k a -> list (pair data data)) bytestring integer) -> - map - {bytestring} - {integer} - {These integer integer} - unIData - `$dToData` - (\(ds : integer) -> That {integer} {integer} ds) - b) - (\(a : (\k a -> list (pair data data)) bytestring integer) - (b : (\k a -> list (pair data data)) bytestring integer) -> - union - {bytestring} - {integer} - {integer} - unIData - unIData - `$fToDataInteger_$ctoBuiltinData` - `$fToDataInteger_$ctoBuiltinData` - a - b) - (\(a : (\k a -> list (pair data data)) bytestring integer) -> - map - {bytestring} - {integer} - {These integer integer} - unIData - `$dToData` - (\(ds : integer) -> This {integer} {integer} ds) - a)) - (union - {bytestring} - {(\k a -> list (pair data data)) bytestring integer} - {(\k a -> list (pair data data)) bytestring integer} - (\(eta : data) -> unMapData eta) - (\(eta : data) -> unMapData eta) - (`$fToDataMap_$ctoBuiltinData` {bytestring} {integer}) - (`$fToDataMap_$ctoBuiltinData` {bytestring} {integer}) - l - r))) - {all dead. Bool} - (/\dead -> - Bool_match - (unordEqWith - (\(v : data) -> - all - {bytestring} - {integer} - unIData - (\(v : integer) -> - ifThenElse {Bool} (equalsInteger 0 v) True False) - (unMapData v)) - (\(v : data) (v : data) -> - unordEqWith - (\(v : data) -> - ifThenElse {Bool} (equalsInteger 0 (unIData v)) True False) - (\(v : data) (v : data) -> + letrec + !goRight : list (pair data data) -> list (pair data data) + = \(rightMap : list (pair data data)) -> + let + ~hd : pair data data = headList {pair data data} rightMap + ~curSymb : data = fstPair {data} {data} hd + in + chooseList + {pair data data} + {Unit -> list (pair data data)} + rightMap + `$fAdditiveGroupValue` + (\(ds : Unit) -> + Maybe_match + {data} + (lookup' curSymb l) + {all dead. list (pair data data)} + (\(leftTokens : data) -> + letrec + !pt : list (pair data data) -> list (pair data data) + = \(lTs : list (pair data data)) -> + let + ~hd' : pair data data + = headList {pair data data} lTs + ~tok : data = fstPair {data} {data} hd' + in + chooseList + {pair data data} + {Unit -> list (pair data data)} + lTs + `$fAdditiveGroupValue` + (\(ds : Unit) -> + Maybe_match + {data} + (lookup' tok (unMapData leftTokens)) + {all dead. list (pair data data)} + (\(leftAmt : data) -> + /\dead -> + mkCons + {pair data data} + (mkPairData + tok + (`$dToData` + (f + (unIData leftAmt) + (unIData + (sndPair + {data} + {data} + hd'))))) + (pt (tailList {pair data data} lTs))) + (/\dead -> + mkCons + {pair data data} + (mkPairData + tok + (`$dToData` + (f + 0 + (unIData + (sndPair + {data} + {data} + hd'))))) + (pt (tailList {pair data data} lTs))) + {all dead. dead}) + Unit + in + /\dead -> + mkCons + {pair data data} + (mkPairData + curSymb + (mapData + (pt (unMapData (sndPair {data} {data} hd))))) + (goRight (tailList {pair data data} rightMap))) + (/\dead -> + mkCons + {pair data data} + (mkPairData + curSymb + (mapData (pt (unMapData (sndPair {data} {data} hd))))) + (goRight (tailList {pair data data} rightMap))) + {all dead. dead}) + Unit + in + \(r : + (\k a -> list (pair data data)) + bytestring + ((\k a -> list (pair data data)) bytestring integer)) -> + letrec + !goLeft : list (pair data data) -> list (pair data data) + = \(leftMap : list (pair data data)) -> + let + ~hd : pair data data = headList {pair data data} leftMap + ~curSymb : data = fstPair {data} {data} hd + in + chooseList + {pair data data} + {Unit -> list (pair data data)} + leftMap + `$fAdditiveGroupValue` + (\(ds : Unit) -> + Maybe_match + {data} + (lookup' curSymb r) + {all dead. list (pair data data)} + (\(rightTokens : data) -> + letrec + !pt : list (pair data data) -> list (pair data data) + = \(lTs : list (pair data data)) -> + let + ~hd' : pair data data + = headList {pair data data} lTs + ~tok : data = fstPair {data} {data} hd' + in + chooseList + {pair data data} + {Unit -> list (pair data data)} + lTs + `$fAdditiveGroupValue` + (\(ds : Unit) -> + Maybe_match + {data} + (lookup' tok (unMapData rightTokens)) + {all dead. list (pair data data)} + (\(rightAmt : data) -> + /\dead -> + mkCons + {pair data data} + (mkPairData + tok + (`$dToData` + (f + (unIData + (sndPair + {data} + {data} + hd')) + (unIData rightAmt)))) + (pt + (tailList {pair data data} lTs))) + (/\dead -> + mkCons + {pair data data} + (mkPairData + tok + (`$dToData` + (f + (unIData + (sndPair + {data} + {data} + hd')) + 0))) + (pt (tailList {pair data data} lTs))) + {all dead. dead}) + Unit + in + /\dead -> + mkCons + {pair data data} + (mkPairData + curSymb + (mapData + (pt (unMapData (sndPair {data} {data} hd))))) + (goLeft (tailList {pair data data} leftMap))) + (/\dead -> + mkCons + {pair data data} + (mkPairData + curSymb + (mapData + (pt (unMapData (sndPair {data} {data} hd))))) + (goLeft (tailList {pair data data} leftMap))) + {all dead. dead}) + Unit + in + Bool_match + (all + {bytestring} + {(\k a -> list (pair data data)) bytestring Bool} + (\(eta : data) -> unMapData eta) + (all + {bytestring} + {Bool} + (\(d : data) -> + let + !tup : pair integer (list data) = unConstrData d + !index : integer = fstPair {integer} {list data} tup + !args : list data = sndPair {integer} {list data} tup + in + ifThenElse + {all dead. Bool} + (equalsInteger 0 index) + (/\dead -> False) + (/\dead -> ifThenElse - {Bool} - (equalsInteger (unIData v) (unIData v)) - True - False) - (unMapData v) - (unMapData v)) - l - r) - {all dead. Bool} - (/\dead -> False) - (/\dead -> True) - {all dead. dead}) - (/\dead -> False) - {all dead. dead} \ No newline at end of file + {all dead. Bool} + (equalsInteger 1 index) + (/\dead -> True) + (/\dead -> error {Bool}) + {all dead. dead}) + {all dead. dead}) + (\(x : Bool) -> x)) + (`$fAdditiveGroupValue_safeAppend` (goLeft l) (goRight r))) + {all dead. Bool} + (/\dead -> + Bool_match + (unordEqWith + (\(v : data) -> + all + {bytestring} + {integer} + unIData + (\(v : integer) -> + ifThenElse {Bool} (equalsInteger 0 v) True False) + (unMapData v)) + (\(v : data) (v : data) -> + unordEqWith + (\(v : data) -> + ifThenElse + {Bool} + (equalsInteger 0 (unIData v)) + True + False) + (\(v : data) (v : data) -> + ifThenElse + {Bool} + (equalsInteger (unIData v) (unIData v)) + True + False) + (unMapData v) + (unMapData v)) + l + r) + {all dead. Bool} + (/\dead -> False) + (/\dead -> True) + {all dead. dead}) + (/\dead -> False) + {all dead. dead} \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden index 52164d0cda0..f1b75aa94ae 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt1.budget.golden @@ -1,2 +1,2 @@ -({cpu: 712873128 -| mem: 2153344}) \ No newline at end of file +({cpu: 688918224 +| mem: 1973472}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden index 4a622ce09d2..e38a4e6611a 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt2.budget.golden @@ -1,2 +1,2 @@ -({cpu: 649619269 -| mem: 1961730}) \ No newline at end of file +({cpu: 619654539 +| mem: 1754342}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden index d5400a80dde..9f846f06207 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt3.budget.golden @@ -1,2 +1,2 @@ -({cpu: 780012969 -| mem: 2379272}) \ No newline at end of file +({cpu: 762009594 +| mem: 2198352}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden index bc2ff4d0de3..4310940f5d9 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt4.budget.golden @@ -1,2 +1,2 @@ -({cpu: 589750915 -| mem: 1737902}) \ No newline at end of file +({cpu: 576699094 +| mem: 1599176}) \ No newline at end of file diff --git a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden index 61a0f8642f2..ddc914e994a 100644 --- a/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden +++ b/plutus-ledger-api/test-plugin/Spec/Data/Budget/9.6/gt5.budget.golden @@ -1,2 +1,2 @@ -({cpu: 683168148 -| mem: 2056794}) \ No newline at end of file +({cpu: 658880543 +| mem: 1875096}) \ No newline at end of file From 37abbea4c0e9ac1892281bfdae3b02b1bb7ec91c Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 21 Jun 2024 12:39:28 +0300 Subject: [PATCH 4/6] Temp Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 48 +++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 618d1c62600..1bd348a8d6f 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -332,6 +332,54 @@ unionVal (Value l) (Value r) = unionWith :: (Integer -> Integer -> Integer) -> Value -> Value -> Value unionWith f v1 = Value . unionWith' f v1 +mergeSort + :: (Integer -> Integer -> Integer) + -> [(Bool, CurrencySymbol, TokenName, Integer)] + -> [(Bool, CurrencySymbol, TokenName, Integer)] +mergeSort f l = mergeAll (sequences l) + where + cmp (_, a1, b1, _) (_, a2, b2, _) = (a1, b1) `Ord.compare` (a2, b2) + + sequences (a:b:xs) + | a `cmp` b == GT = descending b [a] xs + | otherwise = ascending b (a:) xs + sequences xs = [xs] + + descending a as (b:bs) + | a `cmp` b == GT = descending b (a:as) bs + descending a as bs = (a:as): sequences bs + + ascending a as (b:bs) + | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs + ascending a as bs = let x = as [a] + in x : sequences bs + + mergeAll [x] = x + mergeAll xs = mergeAll (mergePairs xs) + + mergePairs (a:b:xs) = let x = merge a b + in x : mergePairs xs + mergePairs xs = (fmap . fmap) (\(flag, c, t, v) -> if flag then (flag, c, t, f v 0) else (flag, c, t, f 0 v)) xs + + merge as@(a@(flaga, ca, ta, va):as') bs@(b@(flagb, cb, tb, vb):bs') + | a `cmp` b == LT = + case flaga of + True -> (flaga, ca, ta, f va 0) : merge as' bs + False -> (flaga, ca, ta, f 0 va) : merge as' bs + | a `cmp` b == EQ = + case (flaga, flagb) of + (True, False) -> (flaga, ca, ta, f va vb) : merge as' bs + (False, True) -> (flaga, ca, ta, f vb va) : merge as' bs + | otherwise = + case flagb of + True -> (flagb, cb, tb, f vb 0) : merge as bs' + False -> (flagb, cb, tb, f 0 vb) : merge as bs' + merge [] bs = fmap (\(flag, c, t, v) -> if flag then (flag, c, t, f v 0) else (flag, c, t, f 0 v)) bs + merge as [] = fmap (\(flag, c, t, v) -> if flag then (flag, c, t, f v 0) else (flag, c, t, f 0 v)) as + + + + unionWith' :: (PlutusTx.ToData a) => (Integer -> Integer -> a) From d3a8e9af6f2d65f6234a9e88621bd1ac67c8e0fc Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Fri, 21 Jun 2024 14:56:42 +0300 Subject: [PATCH 5/6] WIP algorithm based on merge sort Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 92 ++++++++++++++----- 1 file changed, 67 insertions(+), 25 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index 1bd348a8d6f..ce4780df133 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -314,23 +314,68 @@ assetClassValue (AssetClass (c, t)) i = singleton c t i assetClassValueOf :: Value -> AssetClass -> Integer assetClassValueOf v (AssetClass (c, t)) = valueOf v c t -{-# INLINABLE unionVal #-} --- | Combine two 'Value' maps, assumes the well-definedness of the two maps. -unionVal :: Value -> Value -> Map.Map CurrencySymbol (Map.Map TokenName (These Integer Integer)) -unionVal (Value l) (Value r) = - let - combined = Map.union l r - unThese k = case k of - This a -> Map.map This a - That b -> Map.map That b - These a b -> Map.union a b - in Map.map unThese combined - {-# INLINABLE unionWith #-} -- | Combine two 'Value' maps with the argument function. -- Assumes the well-definedness of the two maps. unionWith :: (Integer -> Integer -> Integer) -> Value -> Value -> Value -unionWith f v1 = Value . unionWith' f v1 +unionWith f v1 v2 = -- Value . unionWith' f v1 + let v1' = toMergeList True v1 + v2' = toMergeList False v2 + merged = mergeSort f (v1' ++ v2') + in fromMergeList merged + +toMergeList :: Bool -> Value -> [(Bool, CurrencySymbol, TokenName, Integer)] +toMergeList flag (Map.toBuiltinList . getValue -> m) = + go m + where + go l = + B.matchList + l + (\() -> []) + (\hd tl -> + let c = unsafeFromBuiltinData . BI.fst $ hd + innerL = BI.unsafeDataAsMap . BI.snd $ hd + flattenInner l' = + B.matchList + l' + (\() -> []) + (\hd' tl' -> + let t = unsafeFromBuiltinData . BI.fst $ hd' + v = unsafeFromBuiltinData . BI.snd $ hd' + in + (flag, c, t, v) : flattenInner tl' + ) + in + flattenInner innerL ++ go tl + ) + +-- pre-condition: the merge list is sorted and indexed by c and t +fromMergeList :: [(Bool, CurrencySymbol, TokenName, Integer)] -> Value +fromMergeList = foldr go (Value Map.empty) + where + go :: (Bool, CurrencySymbol, TokenName, Integer) -> Value -> Value + go (_, c1, t1, v1) (B.uncons . Map.toBuiltinList . getValue -> Nothing) = + Value $ Map.singleton c1 (Map.singleton t1 v1) + go (_, c1, t1, v1) (B.uncons . Map.toBuiltinList . getValue -> Just (p, rest)) = + let c2 = unsafeFromBuiltinData . BI.fst $ p + l = BI.unsafeDataAsMap . BI.snd $ p + t1B = PlutusTx.toBuiltinData t1 + v1B = PlutusTx.toBuiltinData v1 + c1B = PlutusTx.toBuiltinData c1 + in + if c1 == c2 + then + Value + $ Map.unsafeFromBuiltinList + $ BI.mkCons (BI.mkPairData c1B (BI.mkMap $ BI.mkCons (BI.mkPairData t1B v1B) l)) rest + else + Value + $ Map.unsafeFromBuiltinList + $ BI.mkCons + (BI.mkPairData c1B (BI.mkMap $ BI.mkCons (BI.mkPairData t1B v1B) Map.nil)) + (BI.mkCons p rest) + +{-# INLINABLE mergeSort #-} mergeSort :: (Integer -> Integer -> Integer) @@ -583,23 +628,20 @@ flattenValue v = goOuter [] (Map.toList $ getValue v) isZero :: Value -> Bool isZero (Value xs) = Map.all (Map.all (\i -> 0 == i)) xs -{-# INLINABLE checkPred #-} --- | Checks whether a predicate holds for all the values in a 'Value' --- union. Assumes the well-definedness of the two underlying 'Map's. -checkPred :: (These Integer Integer -> Bool) -> Value -> Value -> Bool -checkPred f l r = - let - inner :: Map.Map TokenName (These Integer Integer) -> Bool - inner = Map.all f - in - Map.all inner (unionVal l r) - {-# INLINABLE checkBinRel #-} -- | Check whether a binary relation holds for value pairs of two 'Value' maps, -- supplying 0 where a key is only present in one of them. checkBinRel :: (Integer -> Integer -> Bool) -> Value -> Value -> Bool checkBinRel f l r = - Map.all (Map.all id) (unionWith' f l r) + let l' = toMergeList True l + r' = toMergeList False r + f' i1 i2 = + if f i1 i2 + then 1 + else 0 + merged = mergeSort f' (l' ++ r') + in all (\(_, _, _, v) -> v == 1) merged + {-# INLINABLE geq #-} -- | Check whether one 'Value' is greater than or equal to another. See 'Value' for an explanation From 8fe3d5fdf10aa5e2aa60014f5ca510a368b7ad85 Mon Sep 17 00:00:00 2001 From: Ana Pantilie Date: Tue, 25 Jun 2024 10:42:52 +0300 Subject: [PATCH 6/6] Temp Signed-off-by: Ana Pantilie --- .../src/PlutusLedgerApi/V1/Data/Value.hs | 523 ++++++++++-------- 1 file changed, 283 insertions(+), 240 deletions(-) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index ce4780df133..26d4a3c5d3a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -319,12 +319,12 @@ assetClassValueOf v (AssetClass (c, t)) = valueOf v c t -- Assumes the well-definedness of the two maps. unionWith :: (Integer -> Integer -> Integer) -> Value -> Value -> Value unionWith f v1 v2 = -- Value . unionWith' f v1 - let v1' = toMergeList True v1 - v2' = toMergeList False v2 - merged = mergeSort f (v1' ++ v2') + let v1' = toMergeList FromLeft v1 + v2' = toMergeList FromRight v2 + merged = processMerge f $ mergeSort (v1' ++ v2') in fromMergeList merged -toMergeList :: Bool -> Value -> [(Bool, CurrencySymbol, TokenName, Integer)] +toMergeList :: MergeFlag -> Value -> [(MergeFlag, CurrencySymbol, TokenName, Integer)] toMergeList flag (Map.toBuiltinList . getValue -> m) = go m where @@ -350,10 +350,10 @@ toMergeList flag (Map.toBuiltinList . getValue -> m) = ) -- pre-condition: the merge list is sorted and indexed by c and t -fromMergeList :: [(Bool, CurrencySymbol, TokenName, Integer)] -> Value +fromMergeList :: [(MergeFlag, CurrencySymbol, TokenName, Integer)] -> Value fromMergeList = foldr go (Value Map.empty) where - go :: (Bool, CurrencySymbol, TokenName, Integer) -> Value -> Value + go :: (MergeFlag, CurrencySymbol, TokenName, Integer) -> Value -> Value go (_, c1, t1, v1) (B.uncons . Map.toBuiltinList . getValue -> Nothing) = Value $ Map.singleton c1 (Map.singleton t1 v1) go (_, c1, t1, v1) (B.uncons . Map.toBuiltinList . getValue -> Just (p, rest)) = @@ -375,235 +375,282 @@ fromMergeList = foldr go (Value Map.empty) (BI.mkPairData c1B (BI.mkMap $ BI.mkCons (BI.mkPairData t1B v1B) Map.nil)) (BI.mkCons p rest) -{-# INLINABLE mergeSort #-} -mergeSort - :: (Integer -> Integer -> Integer) - -> [(Bool, CurrencySymbol, TokenName, Integer)] - -> [(Bool, CurrencySymbol, TokenName, Integer)] -mergeSort f l = mergeAll (sequences l) - where - cmp (_, a1, b1, _) (_, a2, b2, _) = (a1, b1) `Ord.compare` (a2, b2) - - sequences (a:b:xs) - | a `cmp` b == GT = descending b [a] xs - | otherwise = ascending b (a:) xs - sequences xs = [xs] - - descending a as (b:bs) - | a `cmp` b == GT = descending b (a:as) bs - descending a as bs = (a:as): sequences bs - - ascending a as (b:bs) - | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs - ascending a as bs = let x = as [a] - in x : sequences bs - - mergeAll [x] = x - mergeAll xs = mergeAll (mergePairs xs) - - mergePairs (a:b:xs) = let x = merge a b - in x : mergePairs xs - mergePairs xs = (fmap . fmap) (\(flag, c, t, v) -> if flag then (flag, c, t, f v 0) else (flag, c, t, f 0 v)) xs - - merge as@(a@(flaga, ca, ta, va):as') bs@(b@(flagb, cb, tb, vb):bs') - | a `cmp` b == LT = - case flaga of - True -> (flaga, ca, ta, f va 0) : merge as' bs - False -> (flaga, ca, ta, f 0 va) : merge as' bs - | a `cmp` b == EQ = - case (flaga, flagb) of - (True, False) -> (flaga, ca, ta, f va vb) : merge as' bs - (False, True) -> (flaga, ca, ta, f vb va) : merge as' bs - | otherwise = - case flagb of - True -> (flagb, cb, tb, f vb 0) : merge as bs' - False -> (flagb, cb, tb, f 0 vb) : merge as bs' - merge [] bs = fmap (\(flag, c, t, v) -> if flag then (flag, c, t, f v 0) else (flag, c, t, f 0 v)) bs - merge as [] = fmap (\(flag, c, t, v) -> if flag then (flag, c, t, f v 0) else (flag, c, t, f 0 v)) as - - - - -unionWith' - :: (PlutusTx.ToData a) - => (Integer -> Integer -> a) - -> Value - -> Value - -> Map.Map CurrencySymbol (Map.Map TokenName a) -unionWith' - f - (Map.toBuiltinList . getValue -> ls) - (Map.toBuiltinList . getValue -> rs) - = - Map.unsafeFromBuiltinList $ res ls rs - where - goLeft - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - goLeft leftMap = - B.matchList - leftMap - (\() -> Map.nil) - (\hd tl -> - let curSymb = BI.fst hd - leftTokens = BI.snd hd - leftTokensMap = BI.unsafeDataAsMap leftTokens - in - case Map.lookup' curSymb rs of - Just rightTokens -> - let rightTokensMap = BI.unsafeDataAsMap rightTokens - pt lTs = - B.matchList - lTs - (\() -> Map.nil) - (\hd' tl' -> - let tok = BI.fst hd' - leftAmt = BI.snd hd' - in - case Map.lookup' tok rightTokensMap of - Just rightAmt -> - BI.mkCons - (BI.mkPairData - tok - ( PlutusTx.toBuiltinData - $ f - (PlutusTx.unsafeFromBuiltinData leftAmt) - (PlutusTx.unsafeFromBuiltinData rightAmt) - ) - ) - (pt tl') - Nothing -> - BI.mkCons - (BI.mkPairData - tok - ( PlutusTx.toBuiltinData - $ f (PlutusTx.unsafeFromBuiltinData leftAmt) 0 - ) - ) - (pt tl') - ) - in - BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt leftTokensMap)) (goLeft tl) - Nothing -> - let pt lTs = - B.matchList - lTs - (\() -> Map.nil) - (\hd' tl' -> - let tok = BI.fst hd' - leftAmt = BI.snd hd' - in - BI.mkCons - (BI.mkPairData - tok - ( PlutusTx.toBuiltinData - $ f (PlutusTx.unsafeFromBuiltinData leftAmt) 0 - ) - ) - (pt tl') - ) - in - BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt leftTokensMap)) (goLeft tl) - ) +data MergeFlag = FromLeft | FromRight | Merged + +instance PlutusTx.Show MergeFlag where + {-# INLINABLE show #-} + show FromLeft = "FromLeft" + show FromRight = "FromRight" + show Merged = "Merged" - goRight - :: BuiltinList (BuiltinPair BuiltinData BuiltinData) - -> BuiltinList (BuiltinPair BuiltinData BuiltinData) - goRight rightMap = - B.matchList - rightMap - (\() -> Map.nil) - (\hd tl -> - let curSymb = BI.fst hd - rightTokens = BI.snd hd - rightTokensMap = BI.unsafeDataAsMap rightTokens - in - case Map.lookup' curSymb ls of - Just leftTokens -> - let leftTokensMap = BI.unsafeDataAsMap leftTokens - pt lTs = - B.matchList - lTs - (\() -> Map.nil) - (\hd' tl' -> - let tok = BI.fst hd' - rightAmt = BI.snd hd' - in - case Map.lookup' tok leftTokensMap of - Just leftAmt -> - BI.mkCons - (BI.mkPairData - tok - ( PlutusTx.toBuiltinData - $ f - (PlutusTx.unsafeFromBuiltinData leftAmt) - (PlutusTx.unsafeFromBuiltinData rightAmt) - ) - ) - (pt tl') - Nothing -> - BI.mkCons - (BI.mkPairData - tok - ( PlutusTx.toBuiltinData - $ f 0 (PlutusTx.unsafeFromBuiltinData rightAmt) - ) - ) - (pt tl') - ) - in - BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt rightTokensMap)) (goRight tl) - Nothing -> - let pt lTs = - B.matchList - lTs - (\() -> Map.nil) - (\hd' tl' -> - let tok = BI.fst hd' - rightAmt = BI.snd hd' - in - BI.mkCons - (BI.mkPairData - tok - ( PlutusTx.toBuiltinData - $ f 0 (PlutusTx.unsafeFromBuiltinData rightAmt) - ) - ) - (pt tl') - ) - in - BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt rightTokensMap)) (goRight tl) - ) - safeAppendInner xs1 xs2 = - B.matchList - xs1 - (\() -> xs2) - ( \hd tl -> - let k = BI.fst hd - v = BI.snd hd - in Map.insert' k v (safeAppendInner tl xs2) - ) - - safeAppend xs1 xs2 = - B.matchList - xs1 - (\() -> xs2) - ( \hd tl -> - let k = BI.fst hd - v = BI.snd hd - in - case Map.lookup' k xs2 of - Just v' -> - let vNew = - BI.mkMap - $ safeAppendInner (BI.unsafeDataAsMap v) (BI.unsafeDataAsMap v') - in Map.insert' k vNew (safeAppend tl xs2) - Nothing -> Map.insert' k v (safeAppend tl xs2) - ) - - res l r = goLeft l `safeAppend` goRight r +-- TODO: whenever the two elems are equal, merge them with f; the last pass above will take care of the others +-- we only know that there aren't any other equal elems _after_ mergeSort has run +{-# INLINABLE mergeSort #-} +mergeSort :: [(MergeFlag, CurrencySymbol, TokenName, Integer)] -> [(MergeFlag, CurrencySymbol, TokenName, Integer)] +mergeSort = + PlutusTx.sortBy (\(_, a1, b1, _) (_, a2, b2, _) -> (a1, b1) `Ord.compare` (a2, b2)) + +{-# INLINABLE processMerge #-} +processMerge :: (Integer -> Integer -> a) -> [(MergeFlag, CurrencySymbol, TokenName, Integer)] -> [(MergeFlag, CurrencySymbol, TokenName, a)] +processMerge f [] = [] +processMerge f [x@(flag, c, t, v)] = + case flag of + FromLeft -> [(Merged, c, t, f v 0)] + FromRight -> [(Merged, c, t, f 0 v)] +processMerge f (x1@(flag1, c1, t1, v1) : x2@(flag2, c2, t2, v2) : xs) = + if (c1 == c2) PlutusTx.&& (t1 == t2) + then + (Merged, c1, t1, f v1 v2) : processMerge f xs + else + case flag1 of + FromLeft -> (Merged, c1, t1, f v1 0) : processMerge f (x2 : xs) + FromRight -> (Merged, c1, t1, f 0 v1) : processMerge f (x2 : xs) + +-- mergeSort +-- :: (Integer -> Integer -> Integer) +-- -> [(MergeFlag, CurrencySymbol, TokenName, Integer)] +-- -> [(MergeFlag, CurrencySymbol, TokenName, Integer)] +-- mergeSort f l = mergeAll (sequences l) +-- where +-- cmp (_, a1, b1, _) (_, a2, b2, _) = (a1, b1) `Ord.compare` (a2, b2) +-- +-- sequences (a:b:xs) +-- | a `cmp` b == GT = descending b [a] xs +-- | otherwise = ascending b (a:) xs +-- sequences xs = [xs] +-- +-- descending a as (b:bs) +-- | a `cmp` b == GT = descending b (a:as) bs +-- descending a as bs = (a:as): sequences bs +-- +-- ascending a as (b:bs) +-- | a `cmp` b /= GT = ascending b (\ys -> as (a:ys)) bs +-- ascending a as bs = let x = as [a] +-- in x : sequences bs +-- +-- mergeAll [x] = x +-- mergeAll xs = mergeAll (mergePairs xs) +-- +-- mergePairs (a:b:xs) = let x = merge a b +-- in x : mergePairs xs +-- mergePairs xs = xs +-- +-- merge as@(a@(flaga, ca, ta, va):as') bs@(b@(flagb, cb, tb, vb):bs') +-- | a `cmp` b == LT = a : merge as' bs +-- -- case flaga of +-- -- FromLeft -> (Merged, ca, ta, f va 0) : merge as' bs +-- -- FromRight -> (Merged, ca, ta, f 0 va) : merge as' bs +-- -- Merged -> a : merge as' bs +-- | a `cmp` b == EQ = +-- case (flaga, flagb) of +-- (FromLeft, FromRight) -> (Merged, ca, ta, f va vb) : merge as' bs +-- (FromRight, FromLeft) -> (Merged, ca, ta, f vb va) : merge as' bs +-- | otherwise = b : merge as bs' +-- -- case flagb of +-- -- FromLeft -> (Merged, cb, tb, f vb 0) : merge as bs' +-- -- FromRight -> (Merged, cb, tb, f 0 vb) : merge as bs' +-- -- Merged -> b : merge as bs' +-- merge [] bs = +-- fmap (\o@(flag, c, t, v) -> +-- case flag of +-- FromLeft -> (Merged, c, t, f v 0) +-- FromRight -> (Merged, c, t, f 0 v) +-- Merged -> o +-- ) +-- bs +-- merge as [] = +-- fmap (\o@(flag, c, t, v) -> +-- case flag of +-- FromLeft -> (Merged, c, t, f v 0) +-- FromRight -> (Merged, c, t, f 0 v) +-- Merged -> o +-- ) +-- as +-- +-- +-- +-- +-- unionWith' +-- :: (PlutusTx.ToData a) +-- => (Integer -> Integer -> a) +-- -> Value +-- -> Value +-- -> Map.Map CurrencySymbol (Map.Map TokenName a) +-- unionWith' +-- f +-- (Map.toBuiltinList . getValue -> ls) +-- (Map.toBuiltinList . getValue -> rs) +-- = +-- Map.unsafeFromBuiltinList $ res ls rs +-- where +-- goLeft +-- :: BuiltinList (BuiltinPair BuiltinData BuiltinData) +-- -> BuiltinList (BuiltinPair BuiltinData BuiltinData) +-- goLeft leftMap = +-- B.matchList +-- leftMap +-- (\() -> Map.nil) +-- (\hd tl -> +-- let curSymb = BI.fst hd +-- leftTokens = BI.snd hd +-- leftTokensMap = BI.unsafeDataAsMap leftTokens +-- in +-- case Map.lookup' curSymb rs of +-- Just rightTokens -> +-- let rightTokensMap = BI.unsafeDataAsMap rightTokens +-- pt lTs = +-- B.matchList +-- lTs +-- (\() -> Map.nil) +-- (\hd' tl' -> +-- let tok = BI.fst hd' +-- leftAmt = BI.snd hd' +-- in +-- case Map.lookup' tok rightTokensMap of +-- Just rightAmt -> +-- BI.mkCons +-- (BI.mkPairData +-- tok +-- ( PlutusTx.toBuiltinData +-- $ f +-- (PlutusTx.unsafeFromBuiltinData leftAmt) +-- (PlutusTx.unsafeFromBuiltinData rightAmt) +-- ) +-- ) +-- (pt tl') +-- Nothing -> +-- BI.mkCons +-- (BI.mkPairData +-- tok +-- ( PlutusTx.toBuiltinData +-- $ f (PlutusTx.unsafeFromBuiltinData leftAmt) 0 +-- ) +-- ) +-- (pt tl') +-- ) +-- in +-- BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt leftTokensMap)) (goLeft tl) +-- Nothing -> +-- let pt lTs = +-- B.matchList +-- lTs +-- (\() -> Map.nil) +-- (\hd' tl' -> +-- let tok = BI.fst hd' +-- leftAmt = BI.snd hd' +-- in +-- BI.mkCons +-- (BI.mkPairData +-- tok +-- ( PlutusTx.toBuiltinData +-- $ f (PlutusTx.unsafeFromBuiltinData leftAmt) 0 +-- ) +-- ) +-- (pt tl') +-- ) +-- in +-- BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt leftTokensMap)) (goLeft tl) +-- ) +-- +-- goRight +-- :: BuiltinList (BuiltinPair BuiltinData BuiltinData) +-- -> BuiltinList (BuiltinPair BuiltinData BuiltinData) +-- goRight rightMap = +-- B.matchList +-- rightMap +-- (\() -> Map.nil) +-- (\hd tl -> +-- let curSymb = BI.fst hd +-- rightTokens = BI.snd hd +-- rightTokensMap = BI.unsafeDataAsMap rightTokens +-- in +-- case Map.lookup' curSymb ls of +-- Just leftTokens -> +-- let leftTokensMap = BI.unsafeDataAsMap leftTokens +-- pt lTs = +-- B.matchList +-- lTs +-- (\() -> Map.nil) +-- (\hd' tl' -> +-- let tok = BI.fst hd' +-- rightAmt = BI.snd hd' +-- in +-- case Map.lookup' tok leftTokensMap of +-- Just leftAmt -> +-- BI.mkCons +-- (BI.mkPairData +-- tok +-- ( PlutusTx.toBuiltinData +-- $ f +-- (PlutusTx.unsafeFromBuiltinData leftAmt) +-- (PlutusTx.unsafeFromBuiltinData rightAmt) +-- ) +-- ) +-- (pt tl') +-- Nothing -> +-- BI.mkCons +-- (BI.mkPairData +-- tok +-- ( PlutusTx.toBuiltinData +-- $ f 0 (PlutusTx.unsafeFromBuiltinData rightAmt) +-- ) +-- ) +-- (pt tl') +-- ) +-- in +-- BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt rightTokensMap)) (goRight tl) +-- Nothing -> +-- let pt lTs = +-- B.matchList +-- lTs +-- (\() -> Map.nil) +-- (\hd' tl' -> +-- let tok = BI.fst hd' +-- rightAmt = BI.snd hd' +-- in +-- BI.mkCons +-- (BI.mkPairData +-- tok +-- ( PlutusTx.toBuiltinData +-- $ f 0 (PlutusTx.unsafeFromBuiltinData rightAmt) +-- ) +-- ) +-- (pt tl') +-- ) +-- in +-- BI.mkCons (BI.mkPairData curSymb (BI.mkMap $ pt rightTokensMap)) (goRight tl) +-- ) +-- +-- safeAppendInner xs1 xs2 = +-- B.matchList +-- xs1 +-- (\() -> xs2) +-- ( \hd tl -> +-- let k = BI.fst hd +-- v = BI.snd hd +-- in Map.insert' k v (safeAppendInner tl xs2) +-- ) +-- +-- safeAppend xs1 xs2 = +-- B.matchList +-- xs1 +-- (\() -> xs2) +-- ( \hd tl -> +-- let k = BI.fst hd +-- v = BI.snd hd +-- in +-- case Map.lookup' k xs2 of +-- Just v' -> +-- let vNew = +-- BI.mkMap +-- $ safeAppendInner (BI.unsafeDataAsMap v) (BI.unsafeDataAsMap v') +-- in Map.insert' k vNew (safeAppend tl xs2) +-- Nothing -> Map.insert' k v (safeAppend tl xs2) +-- ) +-- +-- res l r = goLeft l `safeAppend` goRight r {-# INLINABLE flattenValue #-} -- | Convert a 'Value' to a simple list, keeping only the non-zero amounts. @@ -633,14 +680,10 @@ isZero (Value xs) = Map.all (Map.all (\i -> 0 == i)) xs -- supplying 0 where a key is only present in one of them. checkBinRel :: (Integer -> Integer -> Bool) -> Value -> Value -> Bool checkBinRel f l r = - let l' = toMergeList True l - r' = toMergeList False r - f' i1 i2 = - if f i1 i2 - then 1 - else 0 - merged = mergeSort f' (l' ++ r') - in all (\(_, _, _, v) -> v == 1) merged + let l' = toMergeList FromLeft l + r' = toMergeList FromRight r + merged = processMerge f $ mergeSort (l' ++ r') + in all (\(_, _, _, v) -> v) merged {-# INLINABLE geq #-}