Consolidation

src/Tokenomia/Common/Arbitrary/AssetClass.hs

@@ -0,0 +1,31 @@
+{-# OPTIONS_GHC -Wno-orphans              #-}
+
+module Tokenomia.Common.Arbitrary.AssetClass
+    () where
+
+import Plutus.V1.Ledger.Value
+    ( AssetClass(..)
+    , CurrencySymbol (..)
+    , TokenName (..)
+    )
+
+import Test.Tasty.QuickCheck
+    ( Arbitrary
+    , arbitrary
+    , shrink
+    )
+
+import Tokenomia.Common.Arbitrary.Builtins ()
+
+
+instance Arbitrary CurrencySymbol where
+    arbitrary = CurrencySymbol <$> arbitrary
+    shrink x  = CurrencySymbol <$> shrink (unCurrencySymbol x)
+
+instance Arbitrary TokenName where
+    arbitrary = TokenName <$> arbitrary
+    shrink x  = TokenName <$> shrink (unTokenName x)
+
+instance Arbitrary AssetClass where
+    arbitrary = AssetClass <$> arbitrary
+    shrink x  = AssetClass <$> shrink (unAssetClass x)

src/Tokenomia/Common/Arbitrary/Builtins.hs

@@ -0,0 +1,22 @@
+{-# OPTIONS_GHC -Wno-orphans              #-}
+
+module Tokenomia.Common.Arbitrary.Builtins
+    () where
+
+import PlutusTx.Builtins.Internal
+    ( BuiltinByteString(..) )
+
+import Test.QuickCheck.Instances.ByteString ()
+import Test.Tasty.QuickCheck
+    ( Arbitrary
+    , arbitrary
+    , resize
+    , shrink
+    )
+
+
+instance Arbitrary BuiltinByteString where
+    arbitrary = BuiltinByteString <$> resize 64 arbitrary
+    shrink x
+        |  x == mempty = mempty
+        |  otherwise   = pure mempty

src/Tokenomia/Common/Arbitrary/Modifiers.hs

@@ -0,0 +1,8 @@
+module Tokenomia.Common.Arbitrary.Modifiers
+    ( Restricted(..)
+    ) where
+
+
+newtype Restricted a
+    =   Restricted { getRestricted :: a }
+    deriving (Show, Eq )

src/Tokenomia/Common/Arbitrary/MultiAsset.hs

@@ -0,0 +1,50 @@
+{-# LANGUAGE FlexibleInstances            #-}
+{-# LANGUAGE ImportQualifiedPost          #-}
+{-# OPTIONS_GHC -Wno-orphans              #-}
+
+module Tokenomia.Common.Arbitrary.MultiAsset
+    ( Restricted(..)
+    ) where
+
+import Data.Functor.Syntax              ( (<$$>) )
+import Data.Set        qualified as Set ( toList )
+import Data.Map.Strict qualified as Map ( fromList )
+
+import Ledger.Value
+    ( AssetClass
+    )
+
+import Test.Tasty.QuickCheck
+    ( Arbitrary
+    , Gen
+    , arbitrary
+    , getPositive
+    , shrink
+    )
+
+import Tokenomia.Common.MultiAsset
+    ( MultiAsset(..)
+    , MultiAssetFormat(..)
+    )
+
+import Tokenomia.Common.Arbitrary.Modifiers  ( Restricted(..) )
+import Tokenomia.Common.Arbitrary.AssetClass ()
+
+
+instance Arbitrary MultiAsset where
+    arbitrary = MultiAsset <$> arbitrary
+    shrink x  = MultiAsset <$> shrink (unMultiAsset x)
+
+instance Arbitrary (Restricted MultiAsset) where
+    arbitrary = Restricted . MultiAsset . Map.fromList <$> gen
+      where
+        gen :: Gen [(AssetClass, Integer)]
+        gen =
+            zip
+                <$> (Set.toList  <$>  arbitrary)
+                <*> (getPositive <$$> arbitrary)
+    shrink x  = Restricted <$> shrink (getRestricted x)
+
+instance Arbitrary MultiAssetFormat where
+    arbitrary = MultiAssetFormat <$> arbitrary
+    shrink x  = MultiAssetFormat <$> shrink (unMultiAssetFormat x)

src/Tokenomia/Common/Arbitrary/Value.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE ImportQualifiedPost          #-}
+{-# LANGUAGE FlexibleInstances            #-}
+{-# LANGUAGE TypeApplications             #-}
+{-# OPTIONS_GHC -Wno-orphans              #-}
+
+module Tokenomia.Common.Arbitrary.Value
+    ( Restricted(..)
+    ) where
+
+import Data.Functor.Syntax          ( (<$$>) )
+import Data.Set qualified as Set    ( toList )
+
+import Plutus.V1.Ledger.Value
+    ( AssetClass(..)
+    , Value(..)
+    , assetClassValue
+    )
+
+import PlutusTx.AssocMap qualified as AssocMap
+    ( Map
+    , fromList
+    , toList
+    )
+
+import Tokenomia.Common.MultiAsset
+    ( MultiAsset(..)
+    , FromValue(..)
+    , ToValue(..)
+    )
+
+import Test.QuickCheck.Instances.ByteString ()
+import Test.Tasty.QuickCheck
+    ( Arbitrary
+    , Gen
+    , arbitrary
+    , getPositive
+    , shrink
+    )
+
+import Tokenomia.Common.Arbitrary.Modifiers  ( Restricted(..) )
+import Tokenomia.Common.Arbitrary.AssetClass ()
+import Tokenomia.Common.Arbitrary.MultiAsset ()
+
+
+instance (Arbitrary k, Arbitrary v) => Arbitrary (AssocMap.Map k v) where
+    arbitrary = AssocMap.fromList <$> arbitrary
+    shrink x  = AssocMap.fromList <$> shrink (AssocMap.toList x)
+
+instance Arbitrary Value where
+    arbitrary = Value <$> arbitrary
+    shrink x  = Value <$> shrink (getValue x)
+
+instance Arbitrary (Restricted Value) where
+    arbitrary =
+            Restricted . mconcat
+        <$> uncurry assetClassValue <$$> gen
+      where
+        gen :: Gen [(AssetClass, Integer)]
+        gen =
+            zip
+                <$> (Set.toList  <$>  arbitrary)
+                <*> (getPositive <$$> arbitrary)
+    shrink x  =
+            Restricted . toValue
+        <$> shrink (fromValue @MultiAsset $ getRestricted x)

src/Tokenomia/Common/Data/Function/Memoize.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE BangPatterns                 #-}
+
+module Tokenomia.Common.Data.Function.Memoize
+    ( memoize
+    ) where
+
+--
+-- The function `memoize` takes a function defined with explicit open recursion
+-- and return a memoized version. An open recursion happens when the recursive
+-- function does not call itself by name. Memoized results are stored in a tree
+-- for accessing them in sublinear time.
+--
+
+import Data.Function            ( fix )
+
+
+data Tree a = Tree (Tree a) a (Tree a)
+
+instance Functor Tree where
+    fmap f (Tree l a r) =
+        Tree (fmap f l) (f a) (fmap f r)
+
+naturals :: Tree Integer
+naturals = go 0 1
+  where
+    go !n !s =
+        let l = n + s
+            r = l + s
+            s' = s * 2
+        in
+            Tree (go l s') n (go r s')
+
+-- | Create the trie for the entire domain of a function
+trie :: (Integer -> a) -> Tree a
+trie f = fmap f naturals
+
+-- | Convert a trie to a function, i.e., access a field of the trie
+untrie :: Tree a -> Integer -> a
+untrie (Tree _ a _) 0 = a
+untrie (Tree l _ r) n =
+    case (n - 1) `divMod` 2 of
+        (q, 0) -> untrie l q
+        (q, _) -> untrie r q
+
+-- | Trie-based function memoizer
+memoizer :: (Integer -> a) -> Integer -> a
+memoizer = untrie . trie
+
+-- | Memoizing recursion. Use like `fix`.
+memoize :: ((Integer -> a) -> Integer -> a) -> Integer -> a
+memoize f = fix (memoizer . f)

src/Tokenomia/Common/Data/MonoTraversable/Instance.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE TypeFamilies                 #-}
+{-# LANGUAGE DerivingVia                  #-}
+
+module Tokenomia.Common.Data.MonoTraversable.Instance
+    ( Wrap(..)
+    ) where
+
+--
+-- This module provides default instance for MonoFunctor and MonoZip to derive
+-- with the via strategy. It is necessary to introduce the `Wrap` newtype
+-- because there is no instance of MonoZip for the Identity functor.
+--
+
+import Control.Lens             ( both )
+import Control.Lens.Setter      ( over )
+
+import Data.Functor.Identity    ( Identity(..) )
+
+import Data.MonoTraversable     ( MonoFunctor, Element )
+import Data.Containers          ( MonoZip, ozipWith, ozip, ounzip )
+
+
+type instance Element (Wrap a) = a
+
+newtype Wrap a
+    =   Wrap { unWrap :: a }
+    deriving ( MonoFunctor ) via Identity (Wrap a)
+
+instance (Monoid a) => MonoZip (Wrap a) where
+    ozipWith f a b = Wrap $ f (unWrap a) (unWrap b)
+    ozip a b = [(unWrap a, unWrap b)]
+    ounzip = over both (Wrap . mconcat) . unzip

src/Tokenomia/Common/Data/Sequence/IntegerPartitions.hs

@@ -0,0 +1,90 @@
+module Tokenomia.Common.Data.Sequence.IntegerPartitions
+    ( Partition(..)
+    , triangular
+    , fromCoordinates
+    , toCoordinates
+    , integerPartitions'
+    , integerPartitions
+    ) where
+
+--
+-- Functions related to integer partitions of n that do not contain 1 as a part.
+--
+-- This module provides both
+--     integerPartitions' — an exponential recursion
+-- and integerPartitions  — a slighter faster memoized implementation.
+--
+
+import Data.List.NonEmpty       ( NonEmpty((:|)), cons )
+
+import Tokenomia.Common.Data.Function.Memoize
+    ( memoize )
+
+
+newtype Partition a
+    =   Partition ( NonEmpty a )
+    deriving ( Show, Eq )
+
+triangular :: Integer -> Integer
+triangular n = n * (n + 1) `div` 2
+
+fromCoordinates :: (Integer, Integer) -> Integer
+fromCoordinates (n, k) = triangular n + k
+
+toCoordinates :: Integer -> (Integer, Integer)
+toCoordinates x =
+    let m :: Double
+        m = sqrt . fromIntegral $ 8 * x + 1
+        n = floor $ (m - 1) / 2
+        k = x - (triangular n - 1) - 1
+    in
+        (n, k)
+
+-- | Exponential recursion listing all integer partitions of n starting with k not containing 1
+integerPartitionsPrefixedBy' :: Integer -> Integer -> [Partition Integer]
+integerPartitionsPrefixedBy' n k
+    | k < 2      = []
+    | n < 2      = []
+    | n < k      = []
+    | n == k     = [singleton n]
+    | n == k + 1 = []
+    | otherwise  =
+        let m = min k (n - k)
+        in
+                prepend k
+            <$> concat [integerPartitionsPrefixedBy' (n - k) i | i <- [m, m - 1 .. 2]]
+
+-- | Wrapper listing all integer partitions of n not containing 1
+integerPartitions' :: Integer -> [Partition Integer]
+integerPartitions' n =
+    concat [integerPartitionsPrefixedBy' n k | k <- [n, n - 1 .. 2]]
+
+-- | Memoize with explicit open recursion integer partitions of n starting with k not containing 1
+integerPartitionsPrefixedBy :: Integer -> [Partition Integer]
+integerPartitionsPrefixedBy = memoize f
+  where
+    f :: (Integer -> [Partition Integer]) -> Integer -> [Partition Integer]
+    f rec x
+        | k < 2      = []
+        | n < 2      = []
+        | n < k      = []
+        | n == k     = [singleton n]
+        | n == k + 1 = []
+        | otherwise  =
+            let m = min k (n - k)
+            in
+                prepend k
+            <$> concat [rec $ fromCoordinates (n - k, i) | i <- [m, m - 1 .. 2]]
+      where
+        (n, k) = toCoordinates x
+
+-- | Wrapper for the memoized computation listing all integer partitions of n not containing 1
+integerPartitions :: Integer -> [Partition Integer]
+integerPartitions n =
+    concat [integerPartitionsPrefixedBy $ fromCoordinates (n, k) | k <- [n, n - 1 .. 2]]
+
+singleton :: a -> Partition a
+singleton a = Partition (a :| [])
+
+prepend :: a -> Partition a -> Partition a
+prepend x (Partition xs) = Partition (x `cons` xs)