Skip to content

Commit

Permalink
Playground: Adding an experimental new transaction visualisation.
Browse files Browse the repository at this point in the history
  • Loading branch information
@krisajenkins
krisajenkins committed Mar 18, 2019
1 parent ee7cc83 commit 84a8453
Show file tree
Hide file tree
Showing 14 changed files with 887 additions and 376 deletions.
259 changes: 231 additions & 28 deletions plutus-playground-client/src/Chain.purs
View file
Expand Up @@ -7,14 +7,21 @@ module Chain
import Bootstrap (empty, nbsp)
import Color (Color, rgb, white)
import Control.Monad.Aff.Class (class MonadAff)
import Data.Array (mapWithIndex)
import Data.Array as Array
import Data.Foldable (traverse_)
import Data.Generic (gShow)
import Data.Generic (class Generic, gShow)
import Data.Int as Int
import Data.Lens (to, toListOf, traversed)
import Data.Maybe (Maybe(Nothing))
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Newtype (unwrap)
import Data.Tuple.Nested ((/\))
import Data.Set (Set)
import Data.Set as Set
import Data.String as String
import Data.Tuple (Tuple(Tuple), fst, snd)
import Data.Tuple.Nested (tuple3, (/\))
import ECharts.Commands (addItem, addLink, axisLine, axisType, backgroundColor, bar, bottom, buildItems, buildLinks, color, colorSource, colors, formatterString, itemStyle, items, label, left, lineStyle, name, nameGap, nameLocationMiddle, nameRotate, normal, right, sankey, series, sourceName, splitLine, targetName, textStyle, tooltip, top, trigger, value, xAxis, yAxis) as E
import ECharts.Extras (focusNodeAdjacencyAllEdges, orientVertical, positionBottom)
import ECharts.Monad (CommandsT, DSL) as E
Expand All @@ -23,30 +30,60 @@ import ECharts.Types.Phantom (I)
import Halogen (HTML)
import Halogen.Component (ParentHTML)
import Halogen.ECharts (EChartsEffects, echarts)
import Halogen.HTML (ClassName(ClassName), br_, div, div_, h2_, slot', text)
import Halogen.HTML (ClassName(ClassName), br_, div, div_, h2, h2_, h3, slot', strong_, table, tbody_, td, text, th, thead_, tr_)
import Halogen.HTML.Events (input)
import Halogen.HTML.Properties (class_)
import Halogen.HTML.Properties (class_, classes, colSpan)
import Ledger.Ada.TH (Ada(..))
import Ledger.Interval (Slot(..))
import Ledger.Types (TxIdOf(..))
import Ledger.Types (DataScript(..), PubKey(PubKey), RedeemerScript(..), Signature(Signature), Tx(Tx), TxIdOf(TxIdOf), TxInOf(TxInOf), TxInType(..), TxOutOf(TxOutOf), TxOutRefOf(TxOutRefOf), TxOutType(..))
import Ledger.Value.TH (CurrencySymbol(..), Value(..))
import Partial.Unsafe (unsafePartial)
import Playground.API (EvaluationResult(EvaluationResult), SimulatorWallet)
import Prelude (class Monad, Unit, discard, show, unit, ($), (<$>), (<<<), (<>))
import Types (BalancesChartSlot(BalancesChartSlot), ChildQuery, ChildSlot, MockchainChartSlot(MockchainChartSlot), Query(HandleBalancesChartMessage, HandleMockchainChartMessage), _ada, _simulatorWalletBalance, _simulatorWalletWallet, _walletId, cpBalancesChart, cpMockchainChart)
import Prelude (class Eq, class Monad, class Ord, class Semigroup, class Show, Unit, discard, map, show, unit, (#), ($), (+), (<#>), (<$>), (<*>), (<<<), (<>), (==))
import Types (BalancesChartSlot(BalancesChartSlot), ChildQuery, ChildSlot, MockchainChartSlot(MockchainChartSlot), Query(HandleBalancesChartMessage, HandleMockchainChartMessage), Blockchain, _ada, _simulatorWalletBalance, _simulatorWalletWallet, _walletId, cpBalancesChart, cpMockchainChart)
import Wallet.Emulator.Types (EmulatorEvent(..), Wallet(..))
import Wallet.Graph (FlowGraph(FlowGraph), FlowLink(FlowLink), TxRef(TxRef))

type SlotId = Int
type StepId = Int
type Hash = String

data Column
= ForgeIx
| FeeIx
| OwnerIx Int Hash
| ScriptIx String Hash

derive instance genericColumn :: Generic Column
derive instance eqColumn :: Eq Column
derive instance ordColumn :: Ord Column

instance showColumn :: Show Column where
show FeeIx = "Fee"
show ForgeIx = "Forge"
show (OwnerIx owner hash) = show owner <> "-" <> String.take 7 hash
show (ScriptIx owner hash) = owner <> "-" <> String.take 7 hash

type Row = Tuple SlotId StepId

type BalanceMap =
Map (Tuple Column Row) Balance

evaluationPane::
forall m aff.
MonadAff (EChartsEffects aff) m
=> EvaluationResult
-> ParentHTML Query ChildQuery ChildSlot m
evaluationPane (EvaluationResult {emulatorLog}) =
evaluationPane e@(EvaluationResult {emulatorLog, resultBlockchain}) =
div_
[ div_
[ h2_ [ text "Chain" ]
, slot' cpMockchainChart MockchainChartSlot
[ blockchainExploration resultBlockchain
, br_
, div_
[ h2_ [ text "Final Balances" ]
, slot' cpBalancesChart BalancesChartSlot
(echarts Nothing)
({width: 930, height: 600} /\ unit)
(input HandleMockchainChartMessage)
({width: 930, height: 300} /\ unit)
(input HandleBalancesChartMessage)
]
, br_
, div_
Expand All @@ -60,11 +97,11 @@ evaluationPane (EvaluationResult {emulatorLog}) =
]
, br_
, div_
[ h2_ [ text "Final Balances" ]
, slot' cpBalancesChart BalancesChartSlot
[ h2_ [ text "Chain" ]
, slot' cpMockchainChart MockchainChartSlot
(echarts Nothing)
({width: 930, height: 300} /\ unit)
(input HandleBalancesChartMessage)
({width: 930, height: 600} /\ unit)
(input HandleMockchainChartMessage)
]
]

Expand Down Expand Up @@ -99,9 +136,6 @@ emulatorEventPane (WalletInfo (Wallet walletId) info) =

------------------------------------------------------------

offWhite :: Color
offWhite = rgb 188 188 193

lightPurple :: Color
lightPurple = rgb 163 128 188

Expand All @@ -111,13 +145,6 @@ lightBlue = rgb 88 119 182
fadedBlue :: Color
fadedBlue = rgb 35 39 64

softPalette :: Array Color
softPalette =
[ rgb 55 68 106
, rgb 54 93 72
, rgb 94 50 62
]

hardPalette :: Array Color
hardPalette =
[ rgb 210 112 240
Expand All @@ -127,6 +154,7 @@ hardPalette =
, rgb 163 128 188
, rgb 112 156 240
]

------------------------------------------------------------

-- | Remember here that the Blockchain is latest-block *first*.
Expand Down Expand Up @@ -206,3 +234,178 @@ balancesChartOptions wallets = do
E.axisLine $ E.lineStyle $ E.color lightBlue
E.splitLine $ E.lineStyle $ E.color lightBlue
formatWalletId id = "Wallet #" <> show id

------------------------------------------------------------

data Balance
= AdaBalance Ada
| CurrencyBalance (Array (Tuple CurrencySymbol Int))
| Remainder

-- | TODO this is not even close to right.
instance semigroupBalance :: Partial => Semigroup Balance where
append Remainder Remainder = Remainder
append (CurrencyBalance x) (CurrencyBalance y) = CurrencyBalance (x <> y)
append (AdaBalance (Ada {getAda: x})) (AdaBalance (Ada {getAda: y})) = AdaBalance (Ada { getAda: x + y })

blockchainExploration :: forall p i. Blockchain -> HTML p i
blockchainExploration blockchain =
div_ [ h2_ [ text "Blockchain" ]
, blockchainTable
]
where
blockchainTable =
table [ classes [ ClassName "table"
, ClassName "balance-map"
]
]
[ thead_
[ tr_ $ columns
# Set.map (tuple3 <$> columnHeading <*> matchCount <*> columnClass)
# Set.toUnfoldable
<#> \(heading /\ count /\ cssClass /\ _) -> th [ colSpan count ]
[ h2 [ class_ cssClass ]
[ text heading ]
]
, tr_ $ columns
# Set.toUnfoldable
<#> \column -> th []
[ h3 [ class_ $ columnClass column ]
[ text $ columnSubheading column ]
]
]
, tbody_ $ Array.reverse (Set.toUnfoldable rows) <#>
(\row -> tr_ $ columns
# Set.toUnfoldable
# Array.sortWith columnHeading
<#> \column ->
let mBalance = Map.lookup (Tuple column row) balanceMap
in td
[ class_ $ columnClass column ]
[ maybe nbsp balanceView mBalance ]
)
]

balanceMap = toBalanceMap blockchain

columnHeading FeeIx = "Fee"
columnHeading ForgeIx = "Forge"
columnHeading (OwnerIx owner hash) = "Wallet #" <> show owner
columnHeading (ScriptIx owner hash) = "Script #" <> owner

columnSubheading FeeIx = ""
columnSubheading ForgeIx = ""
columnSubheading (OwnerIx owner hash) = "Tx/" <> String.take 10 hash <> "..."
columnSubheading (ScriptIx owner hash) = "Tx/" <> String.take 10 hash <> "..."

matchCount :: Column -> Int
matchCount owner = Array.length $ Array.filter (isOwner owner) $ Set.toUnfoldable columns

isOwner :: Column -> Column -> Boolean
isOwner FeeIx FeeIx = true
isOwner ForgeIx ForgeIx = true
isOwner (OwnerIx owner1 _) (OwnerIx owner2 _) = owner1 == owner2
isOwner (ScriptIx owner1 _) (ScriptIx owner2 _) = owner1 == owner2
isOwner _ _ = false

columnClass :: Column -> ClassName
columnClass ForgeIx = ClassName "forge"
columnClass FeeIx = ClassName "fee"
columnClass (OwnerIx _ _) = ClassName "owner"
columnClass (ScriptIx _ _) = ClassName "script"

columns :: Set Column
columns = Set.fromFoldable $ map fst $ Map.keys $ balanceMap

rows :: Set Row
rows = Set.fromFoldable $ map snd $ Map.keys $ balanceMap

toBalanceMap :: Blockchain -> Map (Tuple Column (Tuple Int Int)) Balance
toBalanceMap =
Map.fromFoldableWith (unsafePartial (<>))
<<< Array.concat
<<< Array.concat
<<< mapWithIndex (\slotId -> mapWithIndex
(\stepId tx ->
let row = Tuple slotId stepId
in [ forgeTransactions row tx
, feeTransactions row tx
]
<> inputTransactions row tx
<> outputTransactions row tx
))
where
forgeTransactions :: Row -> Tuple (TxIdOf String) Tx -> Tuple (Tuple Column Row) Balance
forgeTransactions row (Tuple _ (Tx {txForge: (Value { getValue: value})})) =
Tuple (Tuple ForgeIx row) (CurrencyBalance value)

feeTransactions :: Row -> Tuple (TxIdOf String) Tx -> Tuple (Tuple Column Row) Balance
feeTransactions row (Tuple _ (Tx {txFee: ada})) =
Tuple (Tuple FeeIx row) (AdaBalance ada)

inputTransactions :: Row -> Tuple (TxIdOf String) Tx -> Array (Tuple (Tuple Column Row) Balance)
inputTransactions row (Tuple _ (Tx {txInputs})) =
fromTxIn <$> txInputs
where
fromTxIn :: TxInOf String -> Tuple (Tuple Column Row) Balance
fromTxIn (TxInOf { txInRef: (TxOutRefOf {txOutRefId: (TxIdOf {getTxId: hash})})
, txInType: (ConsumePublicKeyAddress (Signature { getSignature: owner }))
})
= Tuple (Tuple (OwnerIx owner hash) row) Remainder
fromTxIn (TxInOf { txInRef: (TxOutRefOf {txOutRefId: (TxIdOf {getTxId: hash})})
, txInType: (ConsumeScriptAddress _ (RedeemerScript { getRedeemer: owner }))
})
= Tuple (Tuple (ScriptIx owner hash) row) Remainder

outputTransactions :: Row -> Tuple (TxIdOf String) Tx -> Array (Tuple (Tuple Column Row) Balance)
outputTransactions row (Tuple (TxIdOf {getTxId: hash}) (Tx {txOutputs})) =
fromTxOut <$> txOutputs
where
fromTxOut :: TxOutOf String -> Tuple (Tuple Column Row) Balance
fromTxOut (TxOutOf { txOutType: (PayToPubKey (PubKey { getPubKey: owner }))
, txOutValue: (Value { getValue: currencyBalances })
})
= Tuple (Tuple (OwnerIx owner hash) row) (CurrencyBalance currencyBalances)
fromTxOut (TxOutOf { txOutType: (PayToScript (DataScript { getDataScript: owner }))
, txOutValue: (Value { getValue: currencyBalances })
})
= Tuple (Tuple (ScriptIx owner hash) row) (CurrencyBalance currencyBalances)

balanceClassname :: ClassName
balanceClassname = ClassName "balance"

balanceView :: forall p i. Balance -> HTML p i
balanceView (AdaBalance (Ada {getAda: ada})) =
div [ classes [ balanceClassname
, if ada == 0
then ClassName "balance-no-ada"
else ClassName "balance-ada"
]
]
[ amountView "ADA" ada ]

balanceView (CurrencyBalance currencyBalances) =
div [ classes [ balanceClassname
, if Array.null currencyBalances
then ClassName "balance-no-currencies"
else ClassName "balance-currencies"
]
]
(map valueView currencyBalances)

balanceView Remainder =
div [ classes [ balanceClassname
, ClassName "balance-remainder"
]
]
[]

valueView :: forall p i. Tuple CurrencySymbol Int -> HTML p i
valueView (Tuple (CurrencySymbol sym) balance) =
amountView (show sym) balance

amountView :: forall p i. String -> Int -> HTML p i
amountView name balance =
div_ [ strong_ [ text name ]
, text $ ": " <> show balance
]
2 changes: 2 additions & 0 deletions plutus-playground-client/src/Icons.purs
View file
Expand Up @@ -13,6 +13,7 @@ data Icon
| Plus
| Trash
| Spinner
| SignIn

icon :: forall p i. Icon -> HTML p i
icon iconType =
Expand All @@ -29,3 +30,4 @@ iconClass Github = ClassName "fa-github"
iconClass Plus = ClassName "fa-plus"
iconClass Trash = ClassName "fa-trash"
iconClass Spinner = ClassName "fa-spinner fa-pulse"
iconClass SignIn = ClassName "fa-sign-in"
4 changes: 2 additions & 2 deletions plutus-playground-client/src/Types.purs
View file
Expand Up @@ -32,7 +32,7 @@ import Halogen.Component.ChildPath (ChildPath, cp1, cp2, cp3)
import Halogen.ECharts (EChartsMessage, EChartsQuery)
import Language.Haskell.Interpreter (CompilationError)
import Ledger.Ada.TH (Ada, _Ada)
import Ledger.Types (Tx)
import Ledger.Types (Tx, TxIdOf)
import Matryoshka (class Corecursive, class Recursive, Algebra, cata)
import Network.RemoteData (RemoteData)
import Playground.API (CompilationResult, EvaluationResult, FunctionSchema, SimpleArgumentSchema(..), SimulatorWallet, _FunctionSchema, _SimulatorWallet)
Expand Down Expand Up @@ -213,7 +213,7 @@ cpBalancesChart = cp3

-----------------------------------------------------------

type Blockchain = Array (Array Tx)
type Blockchain = Array (Array (Tuple (TxIdOf String) Tx))
type Signatures = Array (FunctionSchema SimpleArgumentSchema)
type Simulation =
{ signatures :: Signatures
Expand Down

0 comments on commit 84a8453

Please sign in to comment.