Implement provisional printing of input options

meadow-client/src/MainFrame.purs

@@ -99,6 +99,7 @@ import Semantics
   , IdChoice(..)
   , IdInput(..)
   , IdOracle
+  , ErrorResult(..) 
   , MApplicationResult(..)
   , Person
   , State(..)
@@ -107,6 +108,7 @@ import Semantics
   , emptyState
   , peopleFromStateAndContract
   , readContract
+  , reduce
   , scoutPrimitives
   )
 import Servant.PureScript.Settings (SPSettings_)
@@ -334,6 +336,10 @@ simulateState state =
   case applyTransaction inps sigs bn st c mic of
     MSuccessfullyApplied {state: newState, contract: newContract} _ ->
             {state: newState, contract: newContract}
+    MCouldNotApply InvalidInput ->
+	    if inps == Nil
+	    then {state: st, contract: reduce state.blockNum state.state c}
+	    else {state: emptyState, contract: Null}
     MCouldNotApply _ -> {state: emptyState, contract: Null}
   where
     inps = Array.toUnfoldable (state.transaction.inputs)
@@ -466,6 +472,8 @@ evalF (ApplyTrasaction next) = pure next
 evalF (NextBlock next) = do
   modifying (_marloweState <<< _blockNum) (\x ->
     x + ((fromInt 1) :: BigInteger))
+  currentState <- use _marloweState
+  assign (_marloweState) $ updateState currentState
   pure next
 
 evalF (CompileMarlowe next) = do

meadow-client/src/Semantics.purs

@@ -1001,7 +1001,7 @@ reduceRec blockNum state env (Choice obs cont1 cont2) = reduceRec blockNum state
   then cont1
   else cont2)
 
-reduceRec blockNum state env c@(When obs timeout cont1 cont2) = if isExpired timeout blockNum
+reduceRec blockNum state env c@(When obs timeout cont1 cont2) = if isExpired blockNum timeout
   then go cont2
   else if evalObservation blockNum state obs
     then go cont1
@@ -1218,8 +1218,8 @@ fetchPrimitive idAction blockNum state (Commit idActionC idCommit person value _
               }
   else NoMatch
   where
-  notCurrentCommit = isCurrentCommit idCommit state
-  notExpiredCommit = isExpiredCommit idCommit state
+  notCurrentCommit = not (isCurrentCommit idCommit state)
+  notExpiredCommit = not (isExpiredCommit idCommit state)
   actualValue = evalValue blockNum state value
 
 fetchPrimitive idAction blockNum state (Pay idActionC idCommit person value _ continuation _) = if (idAction == idActionC)
@@ -1276,8 +1276,8 @@ scoutPrimitivesAux blockNum state (Commit idActionC idCommit person value _ time
   then M.insert idActionC (Just (DCommit idCommit person actualValue timeout)) M.empty
   else M.empty 
   where
-  notCurrentCommit = isCurrentCommit idCommit state
-  notExpiredCommit = isExpiredCommit idCommit state
+  notCurrentCommit = not (isCurrentCommit idCommit state)
+  notExpiredCommit = not (isExpiredCommit idCommit state)
   actualValue = evalValue blockNum state value
 
 scoutPrimitivesAux blockNum state (Pay idActionC idCommit person value _ continuation _) =

meadow-client/src/Simulation.purs

@@ -3,7 +3,7 @@ module Simulation where
 import Data.BigInteger (BigInteger)
 import Semantics
 import Data.Map (Map)
-import Data.List (List)
+import Data.List (List(..), concatMap)
 import Data.Set (Set)
 import Data.Set as Set
 import API (RunResult(RunResult))
@@ -28,7 +28,7 @@ import Control.Monad.Eff (Eff)
 import Control.Monad.Eff.Class (liftEff)
 import Data.Either (Either(..))
 import Data.Eq ((==))
-import Data.Maybe (Maybe(Just), fromMaybe)
+import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Tuple (Tuple(..))
 import Halogen (HTML, action)
 import Halogen.Component (ParentHTML)
@@ -92,12 +92,14 @@ import Types
   ( ChildQuery
   , ChildSlot
   , FrontendState
+  , InputData
   , MarloweEditorSlot
       ( MarloweEditorSlot
       )
   , MarloweError
       ( MarloweError
       )
+  , OracleEntry
   , Query
       ( SetSignature
       , CompileMarlowe
@@ -204,13 +206,105 @@ inputComposerPane state = div [ classes [ col6
                                         ]
                               ] [ paneHeader "Input Composer"
                                 , div [ class_ $ ClassName "wallet"
-                                      ] [ card_ [ cardBody_ [ h3_ [ text ("Person " <> "3")
-                                                                  ]
-                                                            ]
+                                      ] [ card_ [ cardBody_ (inputComposer (state.marloweState.input))
                                                 ]
                                         ]
                                 ]
 
+inputComposer :: forall p. InputData -> Array (HTML p Query)
+inputComposer { inputs, choiceData, oracleData } =
+    Array.concat [ Array.concat (Array.fromFoldable (map (\x -> inputComposerPerson x inputs choiceData) people))
+                 , if (Map.isEmpty oracleData)
+		   then []
+                   else [ h3_ [ text ("Oracles") ] ]
+                 , Array.fromFoldable (map inputComposerOracle oracles)
+                 ]
+  where
+   ik = Set.fromFoldable (Map.keys inputs)
+   cdk = Set.fromFoldable (Map.keys choiceData)
+   people = Set.toUnfoldable (Set.union ik cdk) :: List Person
+   oracles = Map.toUnfoldable oracleData :: List (Tuple IdOracle OracleEntry)
+
+inputComposerPerson :: forall p. Person -> Map Person (List DetachedPrimitiveWIA)
+                       -> Map Person (Map BigInteger Choice)
+                       -> Array (HTML p Query)
+inputComposerPerson person inputs choices =
+  Array.concat
+  [ [ h3_ [ text ("Person " <> show person)
+          ] ]
+  , case Map.lookup person inputs of
+      Nothing -> []
+      Just x -> Array.fromFoldable
+	        do y <- x
+                   case y of
+                     DWAICommit idAction idCommit val tim ->
+                       pure (inputCommit person idAction idCommit val tim)
+                     DWAIPay idAction idCommit val ->
+                       pure (inputPay person idAction idCommit val)
+  , case Map.lookup person choices of
+      Nothing -> []
+      Just x -> do (Tuple idChoice choice) <- Map.toUnfoldable x
+                   pure (inputChoice person idChoice choice)
+  ]
+
+inputCommit :: forall p. Person -> IdAction -> IdCommit -> BigInteger -> Timeout
+                -> HTML p Query
+inputCommit person idAction idCommit val tim =
+  flexRow_ [ button [ class_ $ ClassName "composer-add-button"
+--                    , onClick <<< input_ <<< UpdatePerson $ promoteAction person idx
+                    ] [ text "+"
+                      ]
+           , spanText "Action "
+           , spanText (show idAction)
+           , spanText ": Commit "
+           , spanText (show val)
+           , spanText " ADA with id "
+           , spanText (show idCommit)
+           , spanText " to expire by "
+           , spanText (show tim)
+           ]
+
+inputPay :: forall p. Person -> IdAction -> IdCommit -> BigInteger -> HTML p Query
+inputPay person idAction idCommit val =
+  flexRow_ [ button [ class_ $ ClassName "composer-add-button"
+--                    , onClick <<< input_ <<< UpdatePerson $ promoteAction person idx
+                    ] [ text "+"
+                      ]
+           , spanText "Action "
+           , spanText (show idAction)
+           , spanText ": Claim "
+           , spanText (show val)
+           , spanText " ADA from commit "
+           , spanText (show idCommit)
+           ]
+
+inputChoice :: forall p. Person -> BigInteger -> BigInteger -> HTML p Query
+inputChoice person idChoice val =
+  flexRow_ [ button [ class_ $ ClassName "composer-add-button"
+--                    , onClick <<< input_ <<< UpdatePerson $ promoteAction person idx
+                    ] [ text "+"
+                      ]
+	   , spanText "Choice "
+           , spanText (show idChoice)
+           , spanText ": Choose value "
+           , spanText (show val)
+           ]
+
+inputComposerOracle :: forall p. Tuple IdOracle OracleEntry -> HTML p Query
+inputComposerOracle (Tuple idOracle {blockNumber, value}) =
+  flexRow_ [ button [ class_ $ ClassName "composer-add-button"
+--                    , onClick <<< input_ <<< UpdatePerson $ promoteAction person idx
+                    ] [ text "+"
+                      ]
+           , spanText "Oracle " 
+           , spanText (show idOracle)
+           , spanText ": Provide "
+           , spanText (show value)
+           , spanText " as the value for block "
+           , spanText (show blockNumber)
+           ]
+
+
 --updateSuggestedAction ::
 --  Person ->
 --  Int ->