From 8d35a66b22b870693ae8717816189d65163e21d5 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 4 Feb 2025 18:05:16 +0100 Subject: [PATCH 001/256] added config for illegal petrinet MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Möglicherweise weitere Parameter hinzufügen --- src/Modelling/PetriNet/Types.hs | 48 +++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 262ea714e..a9ddd5bfe 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -31,8 +31,10 @@ module Modelling.PetriNet.Types ( DrawSettings (..), FindConcurrencyConfig (..), FindConflictConfig (..), + FindMistakeConfig (..), GraphConfig (..), InvalidPetriNetException (..), + MistakeConfig(..), Net (..), Node (..), Petri (..), @@ -56,6 +58,7 @@ module Modelling.PetriNet.Types ( defaultChangeConfig, defaultFindConcurrencyConfig, defaultFindConflictConfig, + defaultFindMistakeConfig, defaultGraphConfig, defaultPickConcurrencyConfig, defaultPickConflictConfig, @@ -882,6 +885,51 @@ defaultPickConcurrencyConfig = PickConcurrencyConfig , alloyConfig = defaultAlloyConfig } +data FindMistakeConfig = FindMistakeConfig + { basicConfig :: BasicConfig + , advConfig :: AdvConfig + , changeConfig :: ChangeConfig + , graphConfig :: GraphConfig + , printSolution :: Bool + , alloyConfig :: AlloyConfig + , mistakeConfig :: MistakeConfig + } deriving (Generic, Read, Show) + +defaultFindMistakeConfig :: FindMistakeConfig +defaultFindMistakeConfig = FindMistakeConfig + { basicConfig = defaultBasicConfig { atLeastActive = 3 } + , advConfig = defaultAdvConfig{ presenceOfSourceTransitions = Nothing } + , changeConfig = defaultChangeConfig + , graphConfig = defaultGraphConfig { hidePlaceNames = True } + , printSolution = False + , alloyConfig = defaultAlloyConfig + , mistakeConfig = defaultMistakeConfig + } + +data MistakeConfig = MistakeConfig + { mistakes :: Int + , negativeTokenCost :: Bool + , negativeTokenCostNum :: Int + -- ^ negative cost of tokens + corresponding number of mistakes (can be zero) + , tranToTran :: Bool + , tranToTranNum :: Int + -- ^ connection between transition and transition + corresponding number of mistakes (can be zero) + , placetoPlace :: Bool + , placetoPlaceNum :: Int + -- ^ connection between places and places + corresponding number of mistakes (can be zero) + } deriving (Generic, Read, Show) + +defaultMistakeConfig :: MistakeConfig +defaultMistakeConfig = MistakeConfig + { mistakes = 3 + , negativeTokenCost = True + , negativeTokenCostNum = 1 + , tranToTran = True + , tranToTranNum = 2 + , placetoPlace = False + , placetoPlaceNum = 0 + } + data DrawSettings = DrawSettings { withPlaceNames :: Bool, withSvgHighlighting :: Bool, From 3b9fd683cfc9c645e0fdf394e83d7ac9a0113594 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 4 Feb 2025 18:06:17 +0100 Subject: [PATCH 002/256] added base file for illegal petrinet MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit isLegalPetriNet als Prädikat hinzugefügt. Bis jetzt noch statisch. --- modelling-tasks.cabal | 1 + src/Modelling/PetriNet/Mistake.hs | 395 ++++++++++++++++++++++++++++++ 2 files changed, 396 insertions(+) create mode 100644 src/Modelling/PetriNet/Mistake.hs diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index 4410289b5..d22508c80 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -100,6 +100,7 @@ library Modelling.CdOd.Phrasing Modelling.CdOd.Phrasing.English Modelling.CdOd.Phrasing.German + Modelling.PetriNet.Mistake Modelling.PetriNet.Reach.Draw Modelling.PetriNet.Reach.Roll Paths_modelling_tasks diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs new file mode 100644 index 000000000..81d04eebc --- /dev/null +++ b/src/Modelling/PetriNet/Mistake.hs @@ -0,0 +1,395 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# Language DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# Language QuasiQuotes #-} + +module Modelling.PetriNet.Mistake ( + checkFindMistakeConfig, + defaultFindMistakeInstance, + findMistake, + findMistakeEvaluation, + findMistakeGenerate, + findMistakeSolution, + findMistakeSyntax, + findMistakeTask, + parseConcurrency, + petriNetFindMist, + simpleFindMistakeTask, + ) where + +import qualified Modelling.PetriNet.Find as F (showSolution) +import qualified Modelling.PetriNet.Types as Find ( + FindMistakeConfig (..), + ) + +import qualified Data.Map as M ( + empty, + fromList, + ) + +import Capabilities.Alloy (MonadAlloy) +import Capabilities.Cache (MonadCache) +import Capabilities.Diagrams (MonadDiagrams) +import Capabilities.Graphviz (MonadGraphviz) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Debug.Trace (trace) +import Modelling.Auxiliary.Common ( + Object, + oneOf, + parseWith, + ) +import Modelling.Auxiliary.Output ( + hoveringInformation, + ) +import Modelling.PetriNet.Alloy ( + compAdvConstraints, + compBasicConstraints, + compChange, + defaultConstraints, + moduleHelpers, + modulePetriAdditions, + modulePetriConcepts, + modulePetriConstraints, + modulePetriSignatureMistake, + petriScopeBitWidth, + petriScopeMaxSeq, + signatures, + skolemVariable, + taskInstance, + unscopedSingleSig, + ) +import Modelling.PetriNet.Diagram ( + renderWith, + ) +import Modelling.PetriNet.Find ( + FindInstance (..), + checkConfigForFind, + findInitial, + findTaskInstance, + toFindEvaluation, + toFindSyntax, + ) +import Modelling.PetriNet.Parser ( + asSingleton, + ) +import Modelling.PetriNet.Reach.Type ( + Transition (Transition), + parseTransitionPrec, + ) +import Modelling.PetriNet.Types ( + AdvConfig, + BasicConfig (..), + ChangeConfig, + Concurrent (Concurrent), + DrawSettings (..), + FindMistakeConfig (..), + GraphConfig (..), + Net (..), + PetriLike (PetriLike, allNodes), + SimpleNode (..), + SimplePetriNet, + transitionPairShow, + ) + +import Control.Monad.Catch (MonadThrow) +import Control.OutputCapable.Blocks ( + ArticleToUse (DefiniteArticle), + GenericOutputCapable (..), + LangM', + LangM, + OutputCapable, + Rated, + ($=<<), + english, + german, + printSolutionAndAssert, + translate, + translations, + unLangM, + ) +import Control.Monad.Random ( + RandT, + RandomGen, + evalRandT, + mkStdGen, + ) +import Control.Monad.Trans (MonadTrans (lift)) +import Data.Bifunctor (Bifunctor (bimap)) +import Data.Either (isLeft) +import Data.GraphViz.Commands (GraphvizCommand (Circo, Fdp)) +import Data.String.Interpolate (i, iii) +import Language.Alloy.Call ( + AlloyInstance, + ) + +simpleFindMistakeTask + :: ( + MonadCache m, + MonadDiagrams m, + MonadGraphviz m, + MonadThrow m, + OutputCapable m + ) + => FilePath + -> FindInstance SimplePetriNet (Concurrent Transition) + -> LangM m +simpleFindMistakeTask = findMistakeTask + +findMistakeTask + :: ( + MonadCache m, + MonadDiagrams m, + MonadGraphviz m, + MonadThrow m, + Net p n, + OutputCapable m + ) + => FilePath + -> FindInstance (p n String) (Concurrent Transition) + -> LangM m +findMistakeTask path task = do + paragraph $ translate $ do + english "Consider the following Petri net:" + german "Betrachten Sie folgendes Petrinetz:" + image + $=<< renderWith path "concurrent" (net task) (drawFindWith task) + paragraph $ translate $ do + english [iii| + Which pair of transitions is concurrently activated + under the initial marking? + |] + german [iii| + Welches Paar von Transitionen ist unter der Startmarkierung + nebenläufig aktiviert? + |] + paragraph $ do + translate $ do + english [iii| + State your answer by giving a pair + of concurrently activated transitions. + #{" "}|] + german [iii| + Geben Sie Ihre Antwort durch Angabe eines Paars + von nebenläufig aktivierten Transitionen an. + #{" "}|] + translate $ do + english [i|Stating |] + german [i|Die Angabe von |] + let ts = transitionPairShow findInitial + code $ show ts + translate $ do + let (t1, t2) = bimap show show ts + english [iii| + #{" "}as answer would indicate that transitions #{t1} and #{t2} + are concurrently activated under the initial marking. + #{" "}|] + german [iii| + #{" "}als Antwort würde bedeuten, dass Transitionen #{t1} und #{t2} + unter der Startmarkierung nebenläufig aktiviert sind. + #{" "}|] + translate $ do + english "The order of transitions within the pair does not matter here." + german [iii| + Die Reihenfolge der Transitionen innerhalb + des Paars spielt hierbei keine Rolle. + |] + pure () + paragraph hoveringInformation + pure () + +findMistakeSyntax + :: OutputCapable m + => FindInstance net (Concurrent Transition) + -> (Transition, Transition) + -> LangM' m () +findMistakeSyntax = toFindSyntax False . numberOfTransitions + +findMistakeEvaluation + :: (Monad m, OutputCapable m) + => FindInstance net (Concurrent Transition) + -> (Transition, Transition) + -> Rated m +findMistakeEvaluation task x = do + let what = translations $ do + english "are concurrently activated" + german "sind nebenläufig aktiviert" + uncurry (printSolutionAndAssert DefiniteArticle) + $=<< unLangM $ toFindEvaluation what withSol concur x + where + concur = findMistakeSolution task + withSol = F.showSolution task + +findMistakeSolution :: FindInstance net (Concurrent a) -> (a, a) +findMistakeSolution task = concur + where + Concurrent concur = toFind task + +findMistakeGenerate + :: (MonadAlloy m, MonadThrow m, MonadIO m, Net p n) + => FindMistakeConfig + -> Int + -> Int + -> m (FindInstance (p n String) (Concurrent Transition)) +findMistakeGenerate config segment seed = flip evalRandT (mkStdGen seed) $ do + let alloyFile = petriNetFindMist config + let fileName = "output.als" + liftIO $ writeFile fileName alloyFile + (d, c) <- trace "findMistake successful" <$> findMistake config segment + gl <- oneOf $ graphLayouts gc + c' <- lift $ traverse + (parseWith parseTransitionPrec) + c + return $ FindInstance { + drawFindWith = DrawSettings { + withPlaceNames = not $ hidePlaceNames gc, + withSvgHighlighting = True, + withTransitionNames = not $ hideTransitionNames gc, + with1Weights = not $ hideWeight1 gc, + withGraphvizCommand = gl + }, + toFind = c', + net = d, + numberOfPlaces = places bc, + numberOfTransitions = transitions bc, + showSolution = Find.printSolution config + } + where + bc = Find.basicConfig config + gc = Find.graphConfig config + +findMistake + :: (MonadAlloy m, MonadThrow m, Net p n, RandomGen g) + => FindMistakeConfig + -> Int + -> RandT g m (p n String, Concurrent String) +findMistake = taskInstance + findTaskInstance + petriNetFindMist + parseConcurrency + Find.alloyConfig + +petriNetFindMist :: FindMistakeConfig -> String +petriNetFindMist FindMistakeConfig{ + basicConfig, + advConfig, + changeConfig + } = petriNetMistakeAlloy basicConfig changeConfig $ Right advConfig + +{-| +Generate code for Mistake PetriNet tasks +-} +petriNetMistakeAlloy + :: BasicConfig + -> ChangeConfig + -> Either Bool AdvConfig + -- ^ Right for find task; Left for pick task + -> String +petriNetMistakeAlloy basicC changeC specific + = [i|module PetriNetConcur + +#{modulePetriSignatureMistake} +#{either (const sigs) (const modulePetriAdditions) specific} +#{moduleHelpers} +#{modulePetriConcepts} +#{modulePetriConstraints} + +pred #{mistakePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions, #{t1}, #{t2} : Transitions] { + \#Places = #{places basicC} + \#Transitions = #{transitions basicC} + #{compBasicConstraints activated basicC} + #{compChange changeC} + #{sourceTransitionConstraints} + #{compConstraints} + + not (all w : Nodes.flow[Nodes] | w > 0) + Places.flow.Int in Transitions + not (Transitions.flow.Int in Places) +} + +pred isLegalPetriNet[] { + all w : Nodes.flow[Nodes] | w > 0 + not (Places.flow.Int in Transitions) + not (Transitions.flow.Int in Places) +} + +run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int +|] + where + activated = "activatedTrans" + activatedDefault = "defaultActiveTrans" + compConstraints = either + (const $ defaultConstraints activatedDefault basicC) + compAdvConstraints + specific + sourceTransitionConstraints + | Left True <- specific = [i| + no t : givenTransitions | no givenPlaces.flow[t] + no t : Transitions | sourceTransitions[t]|] + | otherwise = "" + defaultActiveTrans + | isLeft specific = [i|#{activatedDefault} : set givenTransitions,|] + | otherwise = "" + sigs = signatures "given" (places basicC) (transitions basicC) + t1 = transition1 + t2 = transition2 + +mistakePredicateName :: String +mistakePredicateName = "showMistake" + +concurrencyTransition1 :: String +concurrencyTransition1 = skolemVariable mistakePredicateName transition1 + +concurrencyTransition2 :: String +concurrencyTransition2 = skolemVariable mistakePredicateName transition2 + +transition1 :: String +transition1 = "transition1" + +transition2 :: String +transition2 = "transition2" + +{-| +Parses the concurrency Skolem variables for singleton of transitions and returns +both as tuple. +It throws an error instead if unexpected behaviour occurs. +-} +parseConcurrency :: MonadThrow m => AlloyInstance -> m (Concurrent Object) +parseConcurrency inst = do + t1 <- unscopedSingleSig inst concurrencyTransition1 "" + t2 <- unscopedSingleSig inst concurrencyTransition2 "" + Concurrent <$> ((,) <$> asSingleton t1 <*> asSingleton t2) + +checkFindMistakeConfig :: FindMistakeConfig -> Maybe String +checkFindMistakeConfig FindMistakeConfig { + basicConfig, + changeConfig, + graphConfig + } + = checkConfigForFind basicConfig changeConfig graphConfig + +defaultFindMistakeInstance :: FindInstance SimplePetriNet (Concurrent Transition) +defaultFindMistakeInstance = FindInstance { + drawFindWith = DrawSettings { + withPlaceNames = False, + withSvgHighlighting = True, + withTransitionNames = True, + with1Weights = False, + withGraphvizCommand = Circo + }, + toFind = Concurrent (Transition 1,Transition 3), + net = PetriLike { + allNodes = M.fromList [ + ("s1",SimplePlace {initial = 2, flowOut = M.fromList [("t1",1),("t2",2),("t3",1),("s2",-3)]}), + ("s2",SimplePlace {initial = 1, flowOut = M.empty}), + ("s3",SimplePlace {initial = 1, flowOut = M.fromList [("t3",1)]}), + ("s4",SimplePlace {initial = 0, flowOut = M.empty}), + ("t1",SimpleTransition {flowOut = M.fromList [("s3",1)]}), + ("t2",SimpleTransition {flowOut = M.fromList [("s2",1),("s4",2)]}), + ("t3",SimpleTransition {flowOut = M.fromList [("s2",2)]}) + ] + }, + numberOfPlaces = 4, + numberOfTransitions = 3, + showSolution = False + } From 53dc12396b9db67e49a3db20a28920019f9018a0 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 4 Feb 2025 18:06:59 +0100 Subject: [PATCH 003/256] added new PetriSignatureMistake Neue Datei angelegt, in der "isLegalPetriNet" kein Fakt ist --- alloy/petri/PetriSignatureMistake.als | 40 +++++++++++++++++++++++++++ src/Modelling/PetriNet/Alloy.hs | 4 +++ 2 files changed, 44 insertions(+) create mode 100644 alloy/petri/PetriSignatureMistake.als diff --git a/alloy/petri/PetriSignatureMistake.als b/alloy/petri/PetriSignatureMistake.als new file mode 100644 index 000000000..317e4188e --- /dev/null +++ b/alloy/petri/PetriSignatureMistake.als @@ -0,0 +1,40 @@ +module PetriSignatureMistake + +abstract sig Nodes +{ + flow : Nodes -> lone Int, + defaultFlow : Nodes -> lone Int, + flowChange : Nodes -> lone (Int - 0) +} +{ + all w : defaultFlow[Nodes] | w > 0 + all n : Nodes | let theFlow = plus[defaultFlow[n], flowChange[n]] | theFlow = 0 implies no flow[n] else flow[n] = theFlow +} + +abstract sig Places extends Nodes +{ + defaultTokens : one Int, + tokenChange : lone (Int - 0), + tokens : one Int +} +{ + defaultTokens >= 0 + tokens = plus[defaultTokens, tokenChange] + tokens >= 0 + defaultFlow.Int in Transitions +} + +abstract sig Transitions extends Nodes +{ +} +{ + defaultFlow.Int in Places +} + +//set default places and transitions +abstract sig givenPlaces extends Places{} +abstract sig givenTransitions extends Transitions{} + +fun givenNodes : set Nodes { + givenPlaces + givenTransitions +} diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 377bad163..356c8120e 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -18,6 +18,7 @@ module Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, + modulePetriSignatureMistake, petriScopeBitWidth, petriScopeMaxSeq, signatures, @@ -77,6 +78,9 @@ petriScopeMaxSeq BasicConfig{places,transitions} = places+transitions modulePetriSignature :: String modulePetriSignature = removeLines 2 $(embedStringFile "alloy/petri/PetriSignature.als") +modulePetriSignatureMistake :: String +modulePetriSignatureMistake = removeLines 2 $(embedStringFile "alloy/petri/PetriSignatureMistake.als") + modulePetriAdditions :: String modulePetriAdditions = removeLines 11 $(embedStringFile "alloy/petri/PetriAdditions.als") From 9711119202d1dc491f895942a9d763bf4c8a4d3f Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 7 Feb 2025 09:39:44 +0100 Subject: [PATCH 004/256] updated config --- src/Modelling/PetriNet/Types.hs | 30 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 16 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index a9ddd5bfe..33b189189 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -907,27 +907,25 @@ defaultFindMistakeConfig = FindMistakeConfig } data MistakeConfig = MistakeConfig - { mistakes :: Int - , negativeTokenCost :: Bool + { negativeTokenCost :: Bool , negativeTokenCostNum :: Int - -- ^ negative cost of tokens + corresponding number of mistakes (can be zero) - , tranToTran :: Bool - , tranToTranNum :: Int - -- ^ connection between transition and transition + corresponding number of mistakes (can be zero) - , placetoPlace :: Bool - , placetoPlaceNum :: Int - -- ^ connection between places and places + corresponding number of mistakes (can be zero) + -- ^ negative cost of tokens + corresponding number of mistakes + , transitionToIllegal :: Bool + , transitionToIllegalNum :: Int + -- ^ transition connects to something illegal + corresponding number of mistakes + , placeToIllegal :: Bool + , placeToIllegalNum :: Int + -- ^ place connects to something illegal + corresponding number of mistakes } deriving (Generic, Read, Show) defaultMistakeConfig :: MistakeConfig defaultMistakeConfig = MistakeConfig - { mistakes = 3 - , negativeTokenCost = True - , negativeTokenCostNum = 1 - , tranToTran = True - , tranToTranNum = 2 - , placetoPlace = False - , placetoPlaceNum = 0 + { negativeTokenCost = True + , negativeTokenCostNum = 2 + , transitionToIllegal = False + , transitionToIllegalNum = 1 + , placeToIllegal = False + , placeToIllegalNum = 2 } data DrawSettings = DrawSettings { From b5ba3a5556379a5d38b90066aab027f81f1c9666 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 7 Feb 2025 09:45:34 +0100 Subject: [PATCH 005/256] updated MistakeGenerate to be dynamic output is dependant on given config --- src/Modelling/PetriNet/Alloy.hs | 29 ++++++++++++++++++++++++++++ src/Modelling/PetriNet/Mistake.hs | 32 ++++++++++++------------------- 2 files changed, 41 insertions(+), 20 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 356c8120e..53942f287 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -13,6 +13,7 @@ module Modelling.PetriNet.Alloy ( connected, defaultConstraints, isolated, + mistakeIsLegal, moduleHelpers, modulePetriAdditions, modulePetriConcepts, @@ -38,6 +39,7 @@ import Modelling.PetriNet.Types ( AlloyConfig, BasicConfig (..), ChangeConfig (..), + MistakeConfig (..) ) import qualified Modelling.PetriNet.Types as T ( @@ -192,6 +194,33 @@ compChange ChangeConfig maxTokenChangePerPlace[#{maxTokenChangePerPlace}] |] +mistakeIsLegal :: MistakeConfig -> String +mistakeIsLegal MistakeConfig + { negativeTokenCost, negativeTokenCostNum + , transitionToIllegal, transitionToIllegalNum + , placeToIllegal, placeToIllegalNum + } = [i| + #{mistakeNegative negativeTokenCost negativeTokenCostNum} + #{mistakeTransition transitionToIllegal transitionToIllegalNum} + #{mistakePlace placeToIllegal placeToIllegalNum} +|] + where + mistakeNegative :: Bool -> Int -> String + mistakeNegative True num = [i|some w : Nodes.flow[Nodes] | w < 0 && #{num} < (#{countIllegalNegative})|] + mistakeNegative False _ = "all w : Nodes.flow[Nodes] | w > 0" + + mistakeTransition :: Bool -> Int -> String + mistakeTransition True num = [i|some t : Transitions | t.flow.Int in Places && #{num} < (#{countIllegalTransition})|] + mistakeTransition False _ = "Transitions.flow.Int in Places" + + mistakePlace :: Bool -> Int -> String + mistakePlace True num = [i|some p : Places | some p.flow.Int in Transitions && #{num} < (#{countIllegalPlace})|] + mistakePlace False _ = "Places.flow.Int in Transitions" + + countIllegalNegative = "let cn = {w : Nodes.flow[Nodes] | w < 0} | #cn" + countIllegalTransition = "let cit = {t : Transitions | some t.flow.Int in Places} | #cit" + countIllegalPlace = "let cip = {p : Places | some p.flow.Int in Transitions} | #cip" + {-| Generates signatures of the given kind, number of places and transitions. -} diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 81d04eebc..e06df5f54 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -47,6 +47,7 @@ import Modelling.PetriNet.Alloy ( compBasicConstraints, compChange, defaultConstraints, + mistakeIsLegal, moduleHelpers, modulePetriAdditions, modulePetriConcepts, @@ -85,6 +86,7 @@ import Modelling.PetriNet.Types ( DrawSettings (..), FindMistakeConfig (..), GraphConfig (..), + MistakeConfig (..), Net (..), PetriLike (PetriLike, allNodes), SimpleNode (..), @@ -117,7 +119,7 @@ import Control.Monad.Random ( import Control.Monad.Trans (MonadTrans (lift)) import Data.Bifunctor (Bifunctor (bimap)) import Data.Either (isLeft) -import Data.GraphViz.Commands (GraphvizCommand (Circo, Fdp)) +import Data.GraphViz.Commands (GraphvizCommand (Circo)) import Data.String.Interpolate (i, iii) import Language.Alloy.Call ( AlloyInstance, @@ -263,18 +265,15 @@ findMistake => FindMistakeConfig -> Int -> RandT g m (p n String, Concurrent String) -findMistake = taskInstance - findTaskInstance - petriNetFindMist - parseConcurrency - Find.alloyConfig +findMistake = taskInstance findTaskInstance petriNetFindMist parseConcurrency Find.alloyConfig petriNetFindMist :: FindMistakeConfig -> String petriNetFindMist FindMistakeConfig{ basicConfig, advConfig, - changeConfig - } = petriNetMistakeAlloy basicConfig changeConfig $ Right advConfig + changeConfig, + mistakeConfig + } = petriNetMistakeAlloy basicConfig changeConfig (Right advConfig) mistakeConfig {-| Generate code for Mistake PetriNet tasks @@ -284,9 +283,10 @@ petriNetMistakeAlloy -> ChangeConfig -> Either Bool AdvConfig -- ^ Right for find task; Left for pick task + -> MistakeConfig -> String -petriNetMistakeAlloy basicC changeC specific - = [i|module PetriNetConcur +petriNetMistakeAlloy basicC changeC specific mistakeC + = [i|module PetriNetMist #{modulePetriSignatureMistake} #{either (const sigs) (const modulePetriAdditions) specific} @@ -301,16 +301,8 @@ pred #{mistakePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions #{compChange changeC} #{sourceTransitionConstraints} #{compConstraints} + #{mistakeIsLegal mistakeC} - not (all w : Nodes.flow[Nodes] | w > 0) - Places.flow.Int in Transitions - not (Transitions.flow.Int in Places) -} - -pred isLegalPetriNet[] { - all w : Nodes.flow[Nodes] | w > 0 - not (Places.flow.Int in Transitions) - not (Transitions.flow.Int in Places) } run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int @@ -322,7 +314,7 @@ run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petr (const $ defaultConstraints activatedDefault basicC) compAdvConstraints specific - sourceTransitionConstraints + sourceTransitionConstraints | Left True <- specific = [i| no t : givenTransitions | no givenPlaces.flow[t] no t : Transitions | sourceTransitions[t]|] From 494f82af16896b263146c5a0a8e20f2c86b767df Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 9 Feb 2025 20:43:22 +0100 Subject: [PATCH 006/256] fix spelling --- src/Modelling/PetriNet/Alloy.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 53942f287..87fc2561f 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -217,9 +217,9 @@ mistakeIsLegal MistakeConfig mistakePlace True num = [i|some p : Places | some p.flow.Int in Transitions && #{num} < (#{countIllegalPlace})|] mistakePlace False _ = "Places.flow.Int in Transitions" - countIllegalNegative = "let cn = {w : Nodes.flow[Nodes] | w < 0} | #cn" - countIllegalTransition = "let cit = {t : Transitions | some t.flow.Int in Places} | #cit" - countIllegalPlace = "let cip = {p : Places | some p.flow.Int in Transitions} | #cip" + countIllegalNegative = "let countIllegalNegative = {w : Nodes.flow[Nodes] | w < 0} | #countIllegalNegative" + countIllegalTransition = "let countIllegalTransition = {t : Transitions | some t.flow.Int in Places} | #countIllegalTransition" + countIllegalPlace = "let countIllegalPlace = {p : Places | some p.flow.Int in Transitions} | #countIllegalPlace" {-| Generates signatures of the given kind, number of places and transitions. From f0bcf3e28f6b0fec9e78edbed5986b341b591092 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 14 Feb 2025 14:13:06 +0100 Subject: [PATCH 007/256] changed isLegalPetriNet from fact to pred --- alloy/petri/PetriSignature.als | 2 +- alloy/petri/PetriSignatureMistake.als | 40 --------------------------- src/Modelling/PetriNet/Concurrency.hs | 1 + src/Modelling/PetriNet/Conflict.hs | 1 + src/Modelling/PetriNet/MatchToMath.hs | 2 ++ 5 files changed, 5 insertions(+), 41 deletions(-) delete mode 100644 alloy/petri/PetriSignatureMistake.als diff --git a/alloy/petri/PetriSignature.als b/alloy/petri/PetriSignature.als index 4277bb5f3..dc64daeb5 100644 --- a/alloy/petri/PetriSignature.als +++ b/alloy/petri/PetriSignature.als @@ -31,7 +31,7 @@ abstract sig Transitions extends Nodes defaultFlow.Int in Places } -fact isLegalPetriNet { +pred isLegalPetriNet { all w : Nodes.flow[Nodes] | w > 0 Places.flow.Int in Transitions Transitions.flow.Int in Places diff --git a/alloy/petri/PetriSignatureMistake.als b/alloy/petri/PetriSignatureMistake.als deleted file mode 100644 index 317e4188e..000000000 --- a/alloy/petri/PetriSignatureMistake.als +++ /dev/null @@ -1,40 +0,0 @@ -module PetriSignatureMistake - -abstract sig Nodes -{ - flow : Nodes -> lone Int, - defaultFlow : Nodes -> lone Int, - flowChange : Nodes -> lone (Int - 0) -} -{ - all w : defaultFlow[Nodes] | w > 0 - all n : Nodes | let theFlow = plus[defaultFlow[n], flowChange[n]] | theFlow = 0 implies no flow[n] else flow[n] = theFlow -} - -abstract sig Places extends Nodes -{ - defaultTokens : one Int, - tokenChange : lone (Int - 0), - tokens : one Int -} -{ - defaultTokens >= 0 - tokens = plus[defaultTokens, tokenChange] - tokens >= 0 - defaultFlow.Int in Transitions -} - -abstract sig Transitions extends Nodes -{ -} -{ - defaultFlow.Int in Places -} - -//set default places and transitions -abstract sig givenPlaces extends Places{} -abstract sig givenTransitions extends Transitions{} - -fun givenNodes : set Nodes { - givenPlaces + givenTransitions -} diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index 89e7c4229..da81ca34a 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -432,6 +432,7 @@ pred #{concurrencyPredicateName}[#{defaultActiveTrans}#{activated} : set Transit all disj u,v : Transitions | concurrent[u + v] implies #{t1} + #{t2} = u + v #{compConstraints} + isLegalPetriNet } run #{concurrencyPredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index 6997b42c7..b6b7061b7 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -506,6 +506,7 @@ pred #{conflictPredicateName}[#{p} : some Places,#{defaultActiveTrans}#{activate #{conflictDistractor "" ""} #{conflictDistractor "given" "default"} #{compConstraints} + isLegalPetriNet } run #{conflictPredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 06078ac85..156036265 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -561,6 +561,7 @@ pred showNets[#{activated} : set Transitions] { \#Transitions = #{transitions} #{compBasicConstraints activated basicC} #{compAdvConstraints advConfig} + isLegalPetriNet } run showNets for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] @@ -589,6 +590,7 @@ pred showFalseNets[#{activated} : set Transitions]{ #{compBasicConstraints activated basicConfig} #{compAdvConstraints advConfig} #{compChange changeConfig} + isLegalPetriNet } run showFalseNets for exactly #{petriScopeMaxSeq basicConfig} Nodes, #{petriScopeBitWidth basicConfig} Int From d946afa59c7b5cd102a784c231819cbe6e9bd2d2 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 14 Feb 2025 14:15:18 +0100 Subject: [PATCH 008/256] change old config --- src/Modelling/PetriNet/Types.hs | 37 ++++++++++++++------------------- 1 file changed, 16 insertions(+), 21 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 33b189189..230d6c286 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -31,7 +31,7 @@ module Modelling.PetriNet.Types ( DrawSettings (..), FindConcurrencyConfig (..), FindConflictConfig (..), - FindMistakeConfig (..), + PickMistakeConfig (..), GraphConfig (..), InvalidPetriNetException (..), MistakeConfig(..), @@ -58,7 +58,7 @@ module Modelling.PetriNet.Types ( defaultChangeConfig, defaultFindConcurrencyConfig, defaultFindConflictConfig, - defaultFindMistakeConfig, + defaultPickMistakeConfig, defaultGraphConfig, defaultPickConcurrencyConfig, defaultPickConflictConfig, @@ -885,47 +885,42 @@ defaultPickConcurrencyConfig = PickConcurrencyConfig , alloyConfig = defaultAlloyConfig } -data FindMistakeConfig = FindMistakeConfig +data PickMistakeConfig = PickMistakeConfig { basicConfig :: BasicConfig - , advConfig :: AdvConfig , changeConfig :: ChangeConfig , graphConfig :: GraphConfig + , mistakeConfig :: MistakeConfig , printSolution :: Bool + , prohibitSourceTransitions :: Bool + , prohibitSinkTransitions :: Bool + , useDifferentGraphLayouts :: Bool , alloyConfig :: AlloyConfig - , mistakeConfig :: MistakeConfig } deriving (Generic, Read, Show) -defaultFindMistakeConfig :: FindMistakeConfig -defaultFindMistakeConfig = FindMistakeConfig - { basicConfig = defaultBasicConfig { atLeastActive = 3 } - , advConfig = defaultAdvConfig{ presenceOfSourceTransitions = Nothing } +defaultPickMistakeConfig :: PickMistakeConfig +defaultPickMistakeConfig = PickMistakeConfig + { basicConfig = defaultBasicConfig , changeConfig = defaultChangeConfig - , graphConfig = defaultGraphConfig { hidePlaceNames = True } + , graphConfig = defaultGraphConfig { hidePlaceNames = True, hideTransitionNames = True } , printSolution = False + , prohibitSourceTransitions = True + , prohibitSinkTransitions = True + , useDifferentGraphLayouts = False , alloyConfig = defaultAlloyConfig , mistakeConfig = defaultMistakeConfig } data MistakeConfig = MistakeConfig { negativeTokenCost :: Bool - , negativeTokenCostNum :: Int - -- ^ negative cost of tokens + corresponding number of mistakes , transitionToIllegal :: Bool - , transitionToIllegalNum :: Int - -- ^ transition connects to something illegal + corresponding number of mistakes , placeToIllegal :: Bool - , placeToIllegalNum :: Int - -- ^ place connects to something illegal + corresponding number of mistakes } deriving (Generic, Read, Show) defaultMistakeConfig :: MistakeConfig defaultMistakeConfig = MistakeConfig { negativeTokenCost = True - , negativeTokenCostNum = 2 - , transitionToIllegal = False - , transitionToIllegalNum = 1 - , placeToIllegal = False - , placeToIllegalNum = 2 + , transitionToIllegal = True + , placeToIllegal = True } data DrawSettings = DrawSettings { From c8c4eca7ecbfce045015814412b2b11a89c7785a Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 14 Feb 2025 14:16:39 +0100 Subject: [PATCH 009/256] change code to reflect new config --- src/Modelling/PetriNet/Alloy.hs | 45 ++++++++++++++------------------- 1 file changed, 19 insertions(+), 26 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 87fc2561f..bc3cf9d45 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -13,13 +13,12 @@ module Modelling.PetriNet.Alloy ( connected, defaultConstraints, isolated, - mistakeIsLegal, + mistakeConstraints, moduleHelpers, modulePetriAdditions, modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - modulePetriSignatureMistake, petriScopeBitWidth, petriScopeMaxSeq, signatures, @@ -80,9 +79,6 @@ petriScopeMaxSeq BasicConfig{places,transitions} = places+transitions modulePetriSignature :: String modulePetriSignature = removeLines 2 $(embedStringFile "alloy/petri/PetriSignature.als") -modulePetriSignatureMistake :: String -modulePetriSignatureMistake = removeLines 2 $(embedStringFile "alloy/petri/PetriSignatureMistake.als") - modulePetriAdditions :: String modulePetriAdditions = removeLines 11 $(embedStringFile "alloy/petri/PetriAdditions.als") @@ -194,32 +190,29 @@ compChange ChangeConfig maxTokenChangePerPlace[#{maxTokenChangePerPlace}] |] -mistakeIsLegal :: MistakeConfig -> String -mistakeIsLegal MistakeConfig - { negativeTokenCost, negativeTokenCostNum - , transitionToIllegal, transitionToIllegalNum - , placeToIllegal, placeToIllegalNum +mistakeConstraints :: MistakeConfig -> String +mistakeConstraints MistakeConfig + { negativeTokenCost, transitionToIllegal, placeToIllegal } = [i| - #{mistakeNegative negativeTokenCost negativeTokenCostNum} - #{mistakeTransition transitionToIllegal transitionToIllegalNum} - #{mistakePlace placeToIllegal placeToIllegalNum} + #{mistakeNegative negativeTokenCost} + #{mistakeTransition transitionToIllegal} + #{mistakePlace placeToIllegal} + no n : Nodes | selfLoop[n] + no t : Transitions | sinkTransitions[t] + no t : Transitions | sourceTransitions[t] |] where - mistakeNegative :: Bool -> Int -> String - mistakeNegative True num = [i|some w : Nodes.flow[Nodes] | w < 0 && #{num} < (#{countIllegalNegative})|] - mistakeNegative False _ = "all w : Nodes.flow[Nodes] | w > 0" - - mistakeTransition :: Bool -> Int -> String - mistakeTransition True num = [i|some t : Transitions | t.flow.Int in Places && #{num} < (#{countIllegalTransition})|] - mistakeTransition False _ = "Transitions.flow.Int in Places" + mistakeNegative = \case + True -> "not(all w : Nodes.flow[Nodes] | w > 0)" + False -> "all w : Nodes.flow[Nodes] | w > 0" - mistakePlace :: Bool -> Int -> String - mistakePlace True num = [i|some p : Places | some p.flow.Int in Transitions && #{num} < (#{countIllegalPlace})|] - mistakePlace False _ = "Places.flow.Int in Transitions" + mistakeTransition = \case + True -> "not(Transitions.flow.Int in Places)" + False -> "Transitions.flow.Int in Places" - countIllegalNegative = "let countIllegalNegative = {w : Nodes.flow[Nodes] | w < 0} | #countIllegalNegative" - countIllegalTransition = "let countIllegalTransition = {t : Transitions | some t.flow.Int in Places} | #countIllegalTransition" - countIllegalPlace = "let countIllegalPlace = {p : Places | some p.flow.Int in Transitions} | #countIllegalPlace" + mistakePlace = \case + True -> "not(Places.flow.Int in Transitions)" + False -> "Places.flow.Int in Transitions" {-| Generates signatures of the given kind, number of places and transitions. From 2dbf7467874804d5de891a3331eb1e04c608e3c0 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 14 Feb 2025 14:28:19 +0100 Subject: [PATCH 010/256] add new Mistake file MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Ein paar "Concurrency" Zeilen müssen erstmal noch im Code bleiben. Gerade bei parseMistake habe ich noch Probleme den Code umzuändern. --- src/Modelling/PetriNet/Mistake.hs | 362 +++++++++++------------------- 1 file changed, 136 insertions(+), 226 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index e06df5f54..1332786b4 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -5,22 +5,16 @@ {-# Language QuasiQuotes #-} module Modelling.PetriNet.Mistake ( - checkFindMistakeConfig, - defaultFindMistakeInstance, - findMistake, - findMistakeEvaluation, - findMistakeGenerate, - findMistakeSolution, - findMistakeSyntax, - findMistakeTask, - parseConcurrency, - petriNetFindMist, - simpleFindMistakeTask, + defaultPickMistakeInstance, + parseMistake, + petriNetPickMist, + pickMistake, + pickMistakeGenerate, + pickMistakeTask, ) where -import qualified Modelling.PetriNet.Find as F (showSolution) -import qualified Modelling.PetriNet.Types as Find ( - FindMistakeConfig (..), +import qualified Modelling.PetriNet.Types as Pick ( + PickMistakeConfig (..), ) import qualified Data.Map as M ( @@ -32,113 +26,81 @@ import Capabilities.Alloy (MonadAlloy) import Capabilities.Cache (MonadCache) import Capabilities.Diagrams (MonadDiagrams) import Capabilities.Graphviz (MonadGraphviz) -import Control.Monad.IO.Class (MonadIO, liftIO) -import Debug.Trace (trace) -import Modelling.Auxiliary.Common ( - Object, - oneOf, - parseWith, - ) +import Modelling.Auxiliary.Common (Object) import Modelling.Auxiliary.Output ( hoveringInformation, ) import Modelling.PetriNet.Alloy ( - compAdvConstraints, compBasicConstraints, compChange, defaultConstraints, - mistakeIsLegal, + mistakeConstraints, moduleHelpers, - modulePetriAdditions, modulePetriConcepts, modulePetriConstraints, - modulePetriSignatureMistake, + modulePetriSignature, petriScopeBitWidth, petriScopeMaxSeq, - signatures, skolemVariable, taskInstance, unscopedSingleSig, ) -import Modelling.PetriNet.Diagram ( - renderWith, - ) -import Modelling.PetriNet.Find ( - FindInstance (..), - checkConfigForFind, - findInitial, - findTaskInstance, - toFindEvaluation, - toFindSyntax, - ) import Modelling.PetriNet.Parser ( asSingleton, ) -import Modelling.PetriNet.Reach.Type ( - Transition (Transition), - parseTransitionPrec, +import Modelling.PetriNet.Pick ( + PickInstance (..), + pickGenerate, + pickTaskInstance, + renderPick, + wrongInstances, ) import Modelling.PetriNet.Types ( - AdvConfig, BasicConfig (..), ChangeConfig, Concurrent (Concurrent), DrawSettings (..), - FindMistakeConfig (..), - GraphConfig (..), - MistakeConfig (..), + MistakeConfig, Net (..), PetriLike (PetriLike, allNodes), + PickMistakeConfig (..), SimpleNode (..), SimplePetriNet, - transitionPairShow, ) import Control.Monad.Catch (MonadThrow) import Control.OutputCapable.Blocks ( - ArticleToUse (DefiniteArticle), GenericOutputCapable (..), - LangM', LangM, OutputCapable, - Rated, ($=<<), english, german, - printSolutionAndAssert, translate, - translations, - unLangM, ) import Control.Monad.Random ( RandT, RandomGen, - evalRandT, - mkStdGen, ) -import Control.Monad.Trans (MonadTrans (lift)) -import Data.Bifunctor (Bifunctor (bimap)) -import Data.Either (isLeft) -import Data.GraphViz.Commands (GraphvizCommand (Circo)) +import Data.GraphViz.Commands (GraphvizCommand (Fdp)) import Data.String.Interpolate (i, iii) import Language.Alloy.Call ( AlloyInstance, ) -simpleFindMistakeTask - :: ( - MonadCache m, - MonadDiagrams m, - MonadGraphviz m, - MonadThrow m, - OutputCapable m - ) - => FilePath - -> FindInstance SimplePetriNet (Concurrent Transition) - -> LangM m -simpleFindMistakeTask = findMistakeTask +pickMistakeGenerate + :: (MonadAlloy m, MonadThrow m, Net p n) + => PickMistakeConfig + -> Int + -> Int + -> m (PickInstance (p n String)) +pickMistakeGenerate = pickGenerate pickMistake gc ud ws + where + gc = Pick.graphConfig + ud = Pick.useDifferentGraphLayouts + ws = Pick.printSolution -findMistakeTask +pickMistakeTask :: ( MonadCache m, MonadDiagrams m, @@ -148,148 +110,87 @@ findMistakeTask OutputCapable m ) => FilePath - -> FindInstance (p n String) (Concurrent Transition) + -> PickInstance (p n String) -> LangM m -findMistakeTask path task = do - paragraph $ translate $ do - english "Consider the following Petri net:" - german "Betrachten Sie folgendes Petrinetz:" - image - $=<< renderWith path "concurrent" (net task) (drawFindWith task) +pickMistakeTask path task = do paragraph $ translate $ do english [iii| - Which pair of transitions is concurrently activated - under the initial marking? + Which of the following Petri nets is "illegal" meaning it violates fundamental constraints? |] german [iii| - Welches Paar von Transitionen ist unter der Startmarkierung - nebenläufig aktiviert? + Welches dieser Petri-Netze ist "illegal", das heißt, es verletzt grundlegende Bedingungen? |] + images show snd + $=<< renderPick path "mistake" task + paragraph $ translate $ do + english [iii| + State your answer by giving the number of the Petri net + that is incorrect. + #{" "}|] + german [iii| + Geben Sie Ihre Antwort durch Angabe der Nummer des Petrinetzes an, + das inkorrekt ist. + #{" "}|] + let plural = wrongInstances task > 1 paragraph $ do - translate $ do - english [iii| - State your answer by giving a pair - of concurrently activated transitions. - #{" "}|] - german [iii| - Geben Sie Ihre Antwort durch Angabe eines Paars - von nebenläufig aktivierten Transitionen an. - #{" "}|] translate $ do english [i|Stating |] german [i|Die Angabe von |] - let ts = transitionPairShow findInitial - code $ show ts + code "1" translate $ do - let (t1, t2) = bimap show show ts english [iii| - #{" "}as answer would indicate that transitions #{t1} and #{t2} - are concurrently activated under the initial marking. - #{" "}|] - german [iii| - #{" "}als Antwort würde bedeuten, dass Transitionen #{t1} und #{t2} - unter der Startmarkierung nebenläufig aktiviert sind. - #{" "}|] - translate $ do - english "The order of transitions within the pair does not matter here." - german [iii| - Die Reihenfolge der Transitionen innerhalb - des Paars spielt hierbei keine Rolle. + #{" "}as answer would indicate that Petri net 1 is "illegal" (and the other Petri + #{if plural then "nets are valid" else "net is valid"}). |] + german $ [iii| + #{" "}als Antwort würde bedeuten, dass Petri-Netz 1 + "illegal" ist, während + #{" "} + |] + ++ (if plural + then "die anderen Petri-Netze gültig sind" + else "das andere Petri-Netz gültig ist") pure () paragraph hoveringInformation pure () -findMistakeSyntax - :: OutputCapable m - => FindInstance net (Concurrent Transition) - -> (Transition, Transition) - -> LangM' m () -findMistakeSyntax = toFindSyntax False . numberOfTransitions - -findMistakeEvaluation - :: (Monad m, OutputCapable m) - => FindInstance net (Concurrent Transition) - -> (Transition, Transition) - -> Rated m -findMistakeEvaluation task x = do - let what = translations $ do - english "are concurrently activated" - german "sind nebenläufig aktiviert" - uncurry (printSolutionAndAssert DefiniteArticle) - $=<< unLangM $ toFindEvaluation what withSol concur x - where - concur = findMistakeSolution task - withSol = F.showSolution task - -findMistakeSolution :: FindInstance net (Concurrent a) -> (a, a) -findMistakeSolution task = concur - where - Concurrent concur = toFind task - -findMistakeGenerate - :: (MonadAlloy m, MonadThrow m, MonadIO m, Net p n) - => FindMistakeConfig - -> Int - -> Int - -> m (FindInstance (p n String) (Concurrent Transition)) -findMistakeGenerate config segment seed = flip evalRandT (mkStdGen seed) $ do - let alloyFile = petriNetFindMist config - let fileName = "output.als" - liftIO $ writeFile fileName alloyFile - (d, c) <- trace "findMistake successful" <$> findMistake config segment - gl <- oneOf $ graphLayouts gc - c' <- lift $ traverse - (parseWith parseTransitionPrec) - c - return $ FindInstance { - drawFindWith = DrawSettings { - withPlaceNames = not $ hidePlaceNames gc, - withSvgHighlighting = True, - withTransitionNames = not $ hideTransitionNames gc, - with1Weights = not $ hideWeight1 gc, - withGraphvizCommand = gl - }, - toFind = c', - net = d, - numberOfPlaces = places bc, - numberOfTransitions = transitions bc, - showSolution = Find.printSolution config - } - where - bc = Find.basicConfig config - gc = Find.graphConfig config - -findMistake +pickMistake :: (MonadAlloy m, MonadThrow m, Net p n, RandomGen g) - => FindMistakeConfig + => PickMistakeConfig -> Int - -> RandT g m (p n String, Concurrent String) -findMistake = taskInstance findTaskInstance petriNetFindMist parseConcurrency Find.alloyConfig + -> RandT + g + m + [(p n String, Maybe (Concurrent String))] +pickMistake = taskInstance + pickTaskInstance + petriNetPickMist + parseMistake + Pick.alloyConfig -petriNetFindMist :: FindMistakeConfig -> String -petriNetFindMist FindMistakeConfig{ +petriNetPickMist :: PickMistakeConfig -> String +petriNetPickMist PickMistakeConfig{ basicConfig, - advConfig, changeConfig, mistakeConfig - } = petriNetMistakeAlloy basicConfig changeConfig (Right advConfig) mistakeConfig + } = + petriNetMistakeAlloy + basicConfig + changeConfig + mistakeConfig {-| -Generate code for Mistake PetriNet tasks +Generate code for PetriNet mistake tasks -} petriNetMistakeAlloy :: BasicConfig -> ChangeConfig - -> Either Bool AdvConfig - -- ^ Right for find task; Left for pick task -> MistakeConfig -> String -petriNetMistakeAlloy basicC changeC specific mistakeC - = [i|module PetriNetMist +petriNetMistakeAlloy basicC changeC mistakeC + = [i|module PetriNetMistake -#{modulePetriSignatureMistake} -#{either (const sigs) (const modulePetriAdditions) specific} +#{modulePetriSignature} #{moduleHelpers} #{modulePetriConcepts} #{modulePetriConstraints} @@ -300,9 +201,9 @@ pred #{mistakePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions #{compBasicConstraints activated basicC} #{compChange changeC} #{sourceTransitionConstraints} + #{sinkTransitionConstraints} #{compConstraints} - #{mistakeIsLegal mistakeC} - + #{mistakeConstraints mistakeC} } run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int @@ -310,19 +211,15 @@ run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petr where activated = "activatedTrans" activatedDefault = "defaultActiveTrans" - compConstraints = either - (const $ defaultConstraints activatedDefault basicC) - compAdvConstraints - specific - sourceTransitionConstraints - | Left True <- specific = [i| + sourceTransitionConstraints :: String + sourceTransitionConstraints = [i| no t : givenTransitions | no givenPlaces.flow[t] no t : Transitions | sourceTransitions[t]|] - | otherwise = "" - defaultActiveTrans - | isLeft specific = [i|#{activatedDefault} : set givenTransitions,|] - | otherwise = "" - sigs = signatures "given" (places basicC) (transitions basicC) + sinkTransitionConstraints :: String + sinkTransitionConstraints = "no t : Transitions | sinkTransitions[t]" + defaultActiveTrans :: String + defaultActiveTrans = [i|#{activatedDefault} : set givenTransitions,|] + compConstraints = defaultConstraints activatedDefault basicC t1 = transition1 t2 = transition2 @@ -346,42 +243,55 @@ Parses the concurrency Skolem variables for singleton of transitions and returns both as tuple. It throws an error instead if unexpected behaviour occurs. -} -parseConcurrency :: MonadThrow m => AlloyInstance -> m (Concurrent Object) -parseConcurrency inst = do +parseMistake :: MonadThrow m => AlloyInstance -> m (Concurrent Object) +parseMistake inst = do t1 <- unscopedSingleSig inst concurrencyTransition1 "" t2 <- unscopedSingleSig inst concurrencyTransition2 "" Concurrent <$> ((,) <$> asSingleton t1 <*> asSingleton t2) -checkFindMistakeConfig :: FindMistakeConfig -> Maybe String -checkFindMistakeConfig FindMistakeConfig { - basicConfig, - changeConfig, - graphConfig - } - = checkConfigForFind basicConfig changeConfig graphConfig - -defaultFindMistakeInstance :: FindInstance SimplePetriNet (Concurrent Transition) -defaultFindMistakeInstance = FindInstance { - drawFindWith = DrawSettings { - withPlaceNames = False, - withSvgHighlighting = True, - withTransitionNames = True, - with1Weights = False, - withGraphvizCommand = Circo - }, - toFind = Concurrent (Transition 1,Transition 3), - net = PetriLike { - allNodes = M.fromList [ - ("s1",SimplePlace {initial = 2, flowOut = M.fromList [("t1",1),("t2",2),("t3",1),("s2",-3)]}), - ("s2",SimplePlace {initial = 1, flowOut = M.empty}), - ("s3",SimplePlace {initial = 1, flowOut = M.fromList [("t3",1)]}), - ("s4",SimplePlace {initial = 0, flowOut = M.empty}), - ("t1",SimpleTransition {flowOut = M.fromList [("s3",1)]}), - ("t2",SimpleTransition {flowOut = M.fromList [("s2",1),("s4",2)]}), - ("t3",SimpleTransition {flowOut = M.fromList [("s2",2)]}) - ] - }, - numberOfPlaces = 4, - numberOfTransitions = 3, +defaultPickMistakeInstance :: PickInstance SimplePetriNet +defaultPickMistakeInstance = PickInstance { + nets = M.fromList [ + (1,(False,( + PetriLike { + allNodes = M.fromList [ + ("s1",SimplePlace {initial = 1, flowOut = M.fromList [("t1",2),("t2",1),("t3",1)]}), + ("s2",SimplePlace {initial = 0, flowOut = M.empty}), + ("s3",SimplePlace {initial = 0, flowOut = M.fromList [("t1",1)]}), + ("s4",SimplePlace {initial = 1, flowOut = M.empty}), + ("t1",SimpleTransition {flowOut = M.fromList [("s1",1),("s4",1)]}), + ("t2",SimpleTransition {flowOut = M.fromList [("s4",1)]}), + ("t3",SimpleTransition {flowOut = M.fromList [("s2",1),("s3",1)]}) + ] + }, + DrawSettings { + withPlaceNames = False, + withSvgHighlighting = True, + withTransitionNames = False, + with1Weights = False, + withGraphvizCommand = Fdp + } + ))), + (2,(True,( + PetriLike { + allNodes = M.fromList [ + ("s1",SimplePlace {initial = 2, flowOut = M.fromList [("t1",2),("t2",1),("s2",1)]}), + ("s2",SimplePlace {initial = 0, flowOut = M.empty}), + ("s3",SimplePlace {initial = 0, flowOut = M.fromList [("t1",1)]}), + ("s4",SimplePlace {initial = 2, flowOut = M.fromList [("t2",-2)]}), + ("t1",SimpleTransition {flowOut = M.fromList [("s1",1),("s4",1)]}), + ("t2",SimpleTransition {flowOut = M.fromList [("s1",1),("s4",1)]}), + ("t3",SimpleTransition {flowOut = M.fromList [("s2",1),("s3",-1)]}) + ] + }, + DrawSettings { + withPlaceNames = False, + withSvgHighlighting = True, + withTransitionNames = False, + with1Weights = False, + withGraphvizCommand = Fdp + } + ))) + ], showSolution = False } From af7793a0056df113718708829762374c97ea0245 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 19 Feb 2025 16:15:39 +0100 Subject: [PATCH 011/256] updated isLegalPetriNet call Jetzt kann selber beim Erstellen des Codes festgelegt werden, ob legale oder illegale Petrinetze benutzt werden sollen. Durch compBasicConstraints --- src/Modelling/PetriNet/Alloy.hs | 35 ++++++++++++--------------- src/Modelling/PetriNet/Concurrency.hs | 5 ++-- src/Modelling/PetriNet/Conflict.hs | 3 +-- src/Modelling/PetriNet/MatchToMath.hs | 6 ++--- src/Modelling/PetriNet/Mistake.hs | 2 +- 5 files changed, 23 insertions(+), 28 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index bc3cf9d45..778c3d979 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -99,12 +99,14 @@ A set of constraints enforcing settings of 'BasicConfig'. (Besides 'defaultConstraints') -} compBasicConstraints - :: String + :: Bool + -- ^ 'True' for legal petri nets, `False` for illegal petri nets. + -> String -- ^ The name of the Alloy variable for the set of activated Transitions. -> BasicConfig -- ^ the configuration to enforce. -> String -compBasicConstraints = enforceConstraints False +compBasicConstraints mistake = enforceConstraints mistake False {-| A set of constraints enforcing settings of 'BasicConfig' for the net under @@ -116,17 +118,19 @@ defaultConstraints -> BasicConfig -- ^ the configuration to enforce. -> String -defaultConstraints = enforceConstraints True +defaultConstraints = enforceConstraints False True enforceConstraints :: Bool + -- ^ 'True' for legal petri nets, `False` for illegal petri nets. + -> Bool -- ^ If to generate constraints under default conditions. -> String -- ^ The name of the Alloy variable for the set of activated Transitions. -> BasicConfig -- ^ the configuration to enforce. -> String -enforceConstraints underDefault activated BasicConfig { +enforceConstraints mistake underDefault activated BasicConfig { atLeastActive, isConnected, flowOverall, @@ -143,7 +147,8 @@ enforceConstraints underDefault activated BasicConfig { \##{activated} >= #{atLeastActive} theActivated#{upperFirst which}Transitions[#{activated}] #{connected (prepend "graphIsConnected") isConnected} - #{isolated (prepend "noIsolatedNodes") isConnected}|] + #{isolated (prepend "noIsolatedNodes") isConnected} + #{if mistake then "isLegalPetriNet" else ""}|] where (given, prepend, which) | underDefault = (("given" ++), (which ++) . upperFirst, "default") @@ -194,25 +199,17 @@ mistakeConstraints :: MistakeConfig -> String mistakeConstraints MistakeConfig { negativeTokenCost, transitionToIllegal, placeToIllegal } = [i| - #{mistakeNegative negativeTokenCost} - #{mistakeTransition transitionToIllegal} - #{mistakePlace placeToIllegal} + #{mistakeControl negativeTokenCost "all w : Nodes.flow[Nodes] | w > 0"} + #{mistakeControl transitionToIllegal "Transitions.flow.Int in Places"} + #{mistakeControl placeToIllegal "Places.flow.Int in Transitions"} no n : Nodes | selfLoop[n] no t : Transitions | sinkTransitions[t] no t : Transitions | sourceTransitions[t] |] where - mistakeNegative = \case - True -> "not(all w : Nodes.flow[Nodes] | w > 0)" - False -> "all w : Nodes.flow[Nodes] | w > 0" - - mistakeTransition = \case - True -> "not(Transitions.flow.Int in Places)" - False -> "Transitions.flow.Int in Places" - - mistakePlace = \case - True -> "not(Places.flow.Int in Transitions)" - False -> "Places.flow.Int in Transitions" + mistakeControl :: Bool -> String -> String + mistakeControl True string = "not(" ++ string ++ ")" + mistakeControl False string = string {-| Generates signatures of the given kind, number of places and transitions. diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index da81ca34a..4df386bf6 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# Language QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} module Modelling.PetriNet.Concurrency ( checkFindConcurrencyConfig, @@ -212,6 +213,7 @@ findConcurrencyTask path task = do Die Reihenfolge der Transitionen innerhalb des Paars spielt hierbei keine Rolle. |] + pure () paragraph hoveringInformation pure () @@ -424,7 +426,7 @@ petriNetConcurrencyAlloy basicC changeC specific pred #{concurrencyPredicateName}[#{defaultActiveTrans}#{activated} : set Transitions, #{t1}, #{t2} : Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} - #{compBasicConstraints activated basicC} + #{compBasicConstraints True activated basicC} #{compChange changeC} #{sourceTransitionConstraints} no disj x,y : givenTransitions | concurrentDefault[x + y] @@ -432,7 +434,6 @@ pred #{concurrencyPredicateName}[#{defaultActiveTrans}#{activated} : set Transit all disj u,v : Transitions | concurrent[u + v] implies #{t1} + #{t2} = u + v #{compConstraints} - isLegalPetriNet } run #{concurrencyPredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index b6b7061b7..fbef98fbe 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -492,7 +492,7 @@ petriNetConflictAlloy basicC changeC conflictC uniqueConflictP specific pred #{conflictPredicateName}[#{p} : some Places,#{defaultActiveTrans}#{activated} : set Transitions, #{t1}, #{t2} : Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} - #{compBasicConstraints activated basicC} + #{compBasicConstraints True activated basicC} #{compChange changeC} #{multiplePlaces uniqueConflictP} #{sourceTransitionConstraints} @@ -506,7 +506,6 @@ pred #{conflictPredicateName}[#{p} : some Places,#{defaultActiveTrans}#{activate #{conflictDistractor "" ""} #{conflictDistractor "given" "default"} #{compConstraints} - isLegalPetriNet } run #{conflictPredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 156036265..2799f9f28 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -559,9 +559,8 @@ fact{ pred showNets[#{activated} : set Transitions] { \#Places = #{places} \#Transitions = #{transitions} - #{compBasicConstraints activated basicC} + #{compBasicConstraints True activated basicC} #{compAdvConstraints advConfig} - isLegalPetriNet } run showNets for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] @@ -587,10 +586,9 @@ fact{ } pred showFalseNets[#{activated} : set Transitions]{ - #{compBasicConstraints activated basicConfig} + #{compBasicConstraints True activated basicConfig} #{compAdvConstraints advConfig} #{compChange changeConfig} - isLegalPetriNet } run showFalseNets for exactly #{petriScopeMaxSeq basicConfig} Nodes, #{petriScopeBitWidth basicConfig} Int diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 1332786b4..4c19c5fe8 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -198,7 +198,7 @@ petriNetMistakeAlloy basicC changeC mistakeC pred #{mistakePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions, #{t1}, #{t2} : Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} - #{compBasicConstraints activated basicC} + #{compBasicConstraints False activated basicC} #{compChange changeC} #{sourceTransitionConstraints} #{sinkTransitionConstraints} From 2a35b2c7a770d9a4aa5e237a3adf7989b134daff Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 19 Feb 2025 16:22:43 +0100 Subject: [PATCH 012/256] removed config constraints --- src/Modelling/PetriNet/Types.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 230d6c286..3be7ca4d0 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -891,8 +891,6 @@ data PickMistakeConfig = PickMistakeConfig , graphConfig :: GraphConfig , mistakeConfig :: MistakeConfig , printSolution :: Bool - , prohibitSourceTransitions :: Bool - , prohibitSinkTransitions :: Bool , useDifferentGraphLayouts :: Bool , alloyConfig :: AlloyConfig } deriving (Generic, Read, Show) @@ -903,8 +901,6 @@ defaultPickMistakeConfig = PickMistakeConfig , changeConfig = defaultChangeConfig , graphConfig = defaultGraphConfig { hidePlaceNames = True, hideTransitionNames = True } , printSolution = False - , prohibitSourceTransitions = True - , prohibitSinkTransitions = True , useDifferentGraphLayouts = False , alloyConfig = defaultAlloyConfig , mistakeConfig = defaultMistakeConfig From e0abfd3bbe7f111f1d079c182fb8a5136ff70fb2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Wed, 19 Feb 2025 19:39:34 +0100 Subject: [PATCH 013/256] clarify conditions for a predicate --- alloy/petri/PetriConcepts.als | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/alloy/petri/PetriConcepts.als b/alloy/petri/PetriConcepts.als index 430960987..be9486c2a 100644 --- a/alloy/petri/PetriConcepts.als +++ b/alloy/petri/PetriConcepts.als @@ -39,7 +39,7 @@ pred concurrentDefault[ts : set givenTransitions]{ all p : givenPlaces | p.defaultTokens >= (sum t : ts | p.defaultFlow[t]) } -//check if there is a loop between two nodes +//check if there is a loop between two nodes (in legal Petri nets; otherwise has slightly different meaning) pred selfLoop[n : Nodes]{ n in n.flow.Int.flow.Int } From 6bbea45142208c29aea7ab1f8b90e54d390aa9a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 20 Feb 2025 09:45:12 +0100 Subject: [PATCH 014/256] optimize constraint about active transitions to only appear when 'atLeastActive' set to positive value --- src/Modelling/PetriNet/Alloy.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 778c3d979..60ca4be33 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -144,8 +144,7 @@ enforceConstraints mistake underDefault activated BasicConfig { all w : #{nodes}.#{flow}[#{nodes}] | w =< #{maxFlowPerEdge} let theFlow = (sum f, t : #{nodes} | f.#{flow}[t]) | #{fst flowOverall} =< theFlow and theFlow =< #{snd flowOverall} - \##{activated} >= #{atLeastActive} - theActivated#{upperFirst which}Transitions[#{activated}] + #{activatedConstraint} #{connected (prepend "graphIsConnected") isConnected} #{isolated (prepend "noIsolatedNodes") isConnected} #{if mistake then "isLegalPetriNet" else ""}|] @@ -157,6 +156,11 @@ enforceConstraints mistake underDefault activated BasicConfig { nodes = given "Nodes" places = given "Places" tokens = prepend "tokens" + activatedConstraint + | atLeastActive > 0 = [i| + \##{activated} >= #{atLeastActive} + theActivated#{upperFirst which}Transitions[#{activated}]|] + | otherwise = "" connected :: String -> Maybe Bool -> String connected p = maybe "" $ \c -> (if c then "" else "not ") ++ p From 60e0abc723f49bc08c1679d09b8bacf963e15ce3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 20 Feb 2025 09:46:36 +0100 Subject: [PATCH 015/256] move isLegalPetriNet to compBasicConstraints - in defaultConstraints, the first argument for enforceConstraints was anyway always False --- src/Modelling/PetriNet/Alloy.hs | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 60ca4be33..fe20016ae 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -106,7 +106,9 @@ compBasicConstraints -> BasicConfig -- ^ the configuration to enforce. -> String -compBasicConstraints mistake = enforceConstraints mistake False +compBasicConstraints mistake activated basicConfig = [i| + #{enforceConstraints False activated basicConfig} + #{if mistake then "isLegalPetriNet" else ""}|] {-| A set of constraints enforcing settings of 'BasicConfig' for the net under @@ -118,19 +120,17 @@ defaultConstraints -> BasicConfig -- ^ the configuration to enforce. -> String -defaultConstraints = enforceConstraints False True +defaultConstraints = enforceConstraints True enforceConstraints :: Bool - -- ^ 'True' for legal petri nets, `False` for illegal petri nets. - -> Bool -- ^ If to generate constraints under default conditions. -> String -- ^ The name of the Alloy variable for the set of activated Transitions. -> BasicConfig -- ^ the configuration to enforce. -> String -enforceConstraints mistake underDefault activated BasicConfig { +enforceConstraints underDefault activated BasicConfig { atLeastActive, isConnected, flowOverall, @@ -146,8 +146,7 @@ enforceConstraints mistake underDefault activated BasicConfig { #{fst flowOverall} =< theFlow and theFlow =< #{snd flowOverall} #{activatedConstraint} #{connected (prepend "graphIsConnected") isConnected} - #{isolated (prepend "noIsolatedNodes") isConnected} - #{if mistake then "isLegalPetriNet" else ""}|] + #{isolated (prepend "noIsolatedNodes") isConnected}|] where (given, prepend, which) | underDefault = (("given" ++), (which ++) . upperFirst, "default") From f4216ce88a4a6a11e2a70252531bf79d63331236 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 20 Feb 2025 10:01:41 +0100 Subject: [PATCH 016/256] circumvent hlint parsing quirk --- src/Modelling/PetriNet/Alloy.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index fe20016ae..22d8f97cb 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -155,11 +155,12 @@ enforceConstraints underDefault activated BasicConfig { nodes = given "Nodes" places = given "Places" tokens = prepend "tokens" - activatedConstraint - | atLeastActive > 0 = [i| + activatedConstraint = + if atLeastActive <= 0 + then "" + else [i| \##{activated} >= #{atLeastActive} theActivated#{upperFirst which}Transitions[#{activated}]|] - | otherwise = "" connected :: String -> Maybe Bool -> String connected p = maybe "" $ \c -> (if c then "" else "not ") ++ p From 679993dad714f17b26be97580dd742c242e0c4ad Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 20 Feb 2025 22:41:16 +0100 Subject: [PATCH 017/256] added app for illegal petrinets --- app/mistake.hs | 113 ++++++++++++++++++++++++++++++ src/Modelling/PetriNet/Mistake.hs | 30 ++++++++ 2 files changed, 143 insertions(+) create mode 100644 app/mistake.hs diff --git a/app/mistake.hs b/app/mistake.hs new file mode 100644 index 000000000..29f757f4b --- /dev/null +++ b/app/mistake.hs @@ -0,0 +1,113 @@ +{-# Language DuplicateRecordFields #-} + +module Main (main) where + +import qualified Modelling.PetriNet.Types as Pick ( + PickMistakeConfig (..), + ) + +import Capabilities.Alloy.IO () +import Capabilities.Cache.IO () +import Capabilities.Diagrams.IO () +import Capabilities.Graphviz.IO () +import Common ( + forceErrors, + instanceInput, + withLang, + ) +import Modelling.PetriNet.Mistake ( + checkPickMistakeConfig, + pickMistakeGenerate, + simplePickMistakeTask, + ) +import Modelling.PetriNet.Types ( + BasicConfig (..), + ChangeConfig (..), + MistakeConfig (..), + PickMistakeConfig (..), + defaultPickMistakeConfig, + ) + +import Control.OutputCapable.Blocks (Language (English)) +import Control.Monad.Trans.Class (lift) +import Data.Char (toLower) +import Data.Maybe (isNothing) +import System.IO ( + BufferMode (NoBuffering), hSetBuffering, stdout, + ) +import Text.Pretty.Simple (pPrint) +import Text.Read (readMaybe) + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + putStrLn "Generating instance for picking the Net with mistakes" + i <- instanceInput + if i >= 0 + then mainPick i + else print "There is no negative index" + +mainPick :: Int -> IO () +mainPick i = forceErrors $ do + lift $ pPrint defaultPickMistakeConfig + (pls, trns, tknChange, flwChange, negTokCost, transToTr, placeToPl) <- lift userInput + let config = defaultPickMistakeConfig { + Pick.basicConfig = (Pick.basicConfig defaultPickMistakeConfig) { + places = pls, + transitions = trns + }, + Pick.changeConfig = (Pick.changeConfig defaultPickMistakeConfig) { + tokenChangeOverall = tknChange, + flowChangeOverall = flwChange + }, + Pick.mistakeConfig = (Pick.mistakeConfig defaultPickMistakeConfig) { + negativeTokenCost = negTokCost, + transitionToTransition = transToTr, + placeToPlace = placeToPl + } + } :: PickMistakeConfig + let c = checkPickMistakeConfig config + if isNothing c + then do + t <- pickMistakeGenerate config 0 i + lift . (`withLang` English) $ simplePickMistakeTask "tmp/" t + lift $ print t + else + lift $ print c + +boolInput :: IO Bool +boolInput = do + input <- getLine + case map toLower input of + "true" -> return True + "false" -> return False + _ -> do + putStrLn "Invalid input" + boolInput + +intInput :: IO Int +intInput = do + input <- getLine + case readMaybe input of + Just n -> return n + Nothing -> do + putStrLn "Invalid input" + intInput + +userInput :: IO (Int, Int, Int, Int, Bool, Bool, Bool) +userInput = do + putStr "Number of Places: " + pls <- intInput + putStr "Number of Transitions: " + trns <- intInput + putStr "TokenChange Overall: " + tknCh <- intInput + putStr "FlowChange Overall: " + flwCh <- intInput + putStr "Negative Token Cost (True/False): " + negTokCost <- boolInput + putStr "Transition to Transition (True/False): " + transToTr <- boolInput + putStr "Places to Places (True/False): " + placeToPl <- boolInput + return (pls, trns, tknCh, flwCh, negTokCost, transToTr, placeToPl) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 4c19c5fe8..e5c96b40d 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -5,12 +5,14 @@ {-# Language QuasiQuotes #-} module Modelling.PetriNet.Mistake ( + checkPickMistakeConfig, defaultPickMistakeInstance, parseMistake, petriNetPickMist, pickMistake, pickMistakeGenerate, pickMistakeTask, + simplePickMistakeTask, ) where import qualified Modelling.PetriNet.Types as Pick ( @@ -50,9 +52,11 @@ import Modelling.PetriNet.Parser ( ) import Modelling.PetriNet.Pick ( PickInstance (..), + checkConfigForPick, pickGenerate, pickTaskInstance, renderPick, + wrong, wrongInstances, ) import Modelling.PetriNet.Types ( @@ -100,6 +104,18 @@ pickMistakeGenerate = pickGenerate pickMistake gc ud ws ud = Pick.useDifferentGraphLayouts ws = Pick.printSolution +simplePickMistakeTask + :: (MonadCache m, + MonadDiagrams m, + MonadGraphviz m, + MonadThrow m, + OutputCapable m + ) + => FilePath + -> PickInstance SimplePetriNet + -> LangM m +simplePickMistakeTask = pickMistakeTask + pickMistakeTask :: ( MonadCache m, @@ -249,6 +265,20 @@ parseMistake inst = do t2 <- unscopedSingleSig inst concurrencyTransition2 "" Concurrent <$> ((,) <$> asSingleton t1 <*> asSingleton t2) +checkPickMistakeConfig :: PickMistakeConfig -> Maybe String +checkPickMistakeConfig PickMistakeConfig { + basicConfig, + changeConfig, + graphConfig, + useDifferentGraphLayouts + } + = checkConfigForPick + useDifferentGraphLayouts + wrong + basicConfig + changeConfig + graphConfig + defaultPickMistakeInstance :: PickInstance SimplePetriNet defaultPickMistakeInstance = PickInstance { nets = M.fromList [ From b3bf1a385235ef47388ef78809882bc9c5ec3b2f Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 20 Feb 2025 22:50:59 +0100 Subject: [PATCH 018/256] changed >1 mistakes not being required in petrinet --- src/Modelling/PetriNet/Alloy.hs | 29 +++++++++++++++++------------ 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 22d8f97cb..fc0009428 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -201,19 +201,24 @@ compChange ChangeConfig mistakeConstraints :: MistakeConfig -> String mistakeConstraints MistakeConfig - { negativeTokenCost, transitionToIllegal, placeToIllegal - } = [i| - #{mistakeControl negativeTokenCost "all w : Nodes.flow[Nodes] | w > 0"} - #{mistakeControl transitionToIllegal "Transitions.flow.Int in Places"} - #{mistakeControl placeToIllegal "Places.flow.Int in Transitions"} - no n : Nodes | selfLoop[n] - no t : Transitions | sinkTransitions[t] - no t : Transitions | sourceTransitions[t] -|] + { negativeTokenCost, transitionToTransition, placeToPlace + } = unlines [trueInput, falseInput] where - mistakeControl :: Bool -> String -> String - mistakeControl True string = "not(" ++ string ++ ")" - mistakeControl False string = string + input :: [(Bool, String)] + input = [(negativeTokenCost, "all w : Nodes.flow[Nodes] | w > 0"), + (transitionToTransition, "Transitions.flow.Int in Places"), + (placeToPlace, "Places.flow.Int in Transitions")] + + trueMistakes = [string | (True, string) <- input] + falseMistakes = [string | (False, string) <- input] + + trueInput = intercalate " or " (map (\x -> "not(" ++ x ++ ")") trueMistakes) + + falseInput :: String + falseInput = unlines (map (" " ++) falseMistakes) + + + {-| Generates signatures of the given kind, number of places and transitions. From 9ea7fe7ec094e32c5cc4a19dde74fcbb20360e11 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 20 Feb 2025 22:51:46 +0100 Subject: [PATCH 019/256] fixed spelling --- src/Modelling/PetriNet/Alloy.hs | 4 ++-- src/Modelling/PetriNet/Types.hs | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index fc0009428..33243890e 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -106,9 +106,9 @@ compBasicConstraints -> BasicConfig -- ^ the configuration to enforce. -> String -compBasicConstraints mistake activated basicConfig = [i| +compBasicConstraints legal activated basicConfig = [i| #{enforceConstraints False activated basicConfig} - #{if mistake then "isLegalPetriNet" else ""}|] + #{if legal then "isLegalPetriNet" else ""}|] {-| A set of constraints enforcing settings of 'BasicConfig' for the net under diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 3be7ca4d0..9c7826a3a 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -908,15 +908,15 @@ defaultPickMistakeConfig = PickMistakeConfig data MistakeConfig = MistakeConfig { negativeTokenCost :: Bool - , transitionToIllegal :: Bool - , placeToIllegal :: Bool + , transitionToTransition :: Bool + , placeToPlace :: Bool } deriving (Generic, Read, Show) defaultMistakeConfig :: MistakeConfig defaultMistakeConfig = MistakeConfig { negativeTokenCost = True - , transitionToIllegal = True - , placeToIllegal = True + , transitionToTransition = True + , placeToPlace = False } data DrawSettings = DrawSettings { From e93425dadad563cdbbdd1038a27c9e3c1beaca78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 21 Feb 2025 14:24:52 +0100 Subject: [PATCH 020/256] add "app" to package.yaml --- app/package.yaml | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/app/package.yaml b/app/package.yaml index cbdbf64fd..cf5e62872 100644 --- a/app/package.yaml +++ b/app/package.yaml @@ -156,6 +156,19 @@ executables: - pretty-simple other-modules: - Common + mistake: + main: mistake.hs + source-dirs: + - . + - common + dependencies: + - bytestring + - digest + - modelling-tasks + - output-blocks + - pretty-simple + other-modules: + - Common repair-incorrect: main: repair-incorrect.hs source-dirs: From 9b3ca728e48db86c9a8b77157d9e83ea519fb960 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 21 Feb 2025 14:58:11 +0100 Subject: [PATCH 021/256] package business --- app/modelling-tasks-apps.cabal | 26 ++++++++++++++++++++++++++ modelling-tasks.cabal | 2 +- package.yaml | 1 + 3 files changed, 28 insertions(+), 1 deletion(-) diff --git a/app/modelling-tasks-apps.cabal b/app/modelling-tasks-apps.cabal index b6f1720f8..ae99bad0b 100644 --- a/app/modelling-tasks-apps.cabal +++ b/app/modelling-tasks-apps.cabal @@ -305,6 +305,32 @@ executable matchToMath , transformers default-language: Haskell2010 +executable mistake + main-is: mistake.hs + other-modules: + Common + hs-source-dirs: + ./ + common + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints -Werror -Wwarn=incomplete-uni-patterns -Wwarn=orphans + build-tools: + alex + , happy + build-depends: + MonadRandom + , base + , bytestring + , containers + , diagrams-lib + , diagrams-svg + , digest + , modelling-tasks + , mtl + , output-blocks + , pretty-simple + , transformers + default-language: Haskell2010 + executable repair-incorrect main-is: repair-incorrect.hs other-modules: diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index d22508c80..82c35bbfd 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -88,6 +88,7 @@ library Modelling.PetriNet.Conflict Modelling.PetriNet.ConflictPlaces Modelling.PetriNet.Find + Modelling.PetriNet.Mistake Modelling.PetriNet.Pick Modelling.PetriNet.Reach.Deadlock Modelling.PetriNet.Reach.Property @@ -100,7 +101,6 @@ library Modelling.CdOd.Phrasing Modelling.CdOd.Phrasing.English Modelling.CdOd.Phrasing.German - Modelling.PetriNet.Mistake Modelling.PetriNet.Reach.Draw Modelling.PetriNet.Reach.Roll Paths_modelling_tasks diff --git a/package.yaml b/package.yaml index e97c7333b..ffef60bf6 100644 --- a/package.yaml +++ b/package.yaml @@ -134,6 +134,7 @@ library: - Modelling.PetriNet.Conflict - Modelling.PetriNet.ConflictPlaces - Modelling.PetriNet.Find + - Modelling.PetriNet.Mistake - Modelling.PetriNet.Pick - Modelling.PetriNet.Reach.Deadlock - Modelling.PetriNet.Reach.Property From d2e4fcf0f411cbdc82b520494b1b369597d4bd59 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 23 Feb 2025 22:46:58 +0100 Subject: [PATCH 022/256] changed name of config (clarity) --- app/mistake.hs | 30 +++++++++++++-------------- src/Modelling/PetriNet/Alloy.hs | 24 ++++++++++------------ src/Modelling/PetriNet/Mistake.hs | 26 +++++++++++------------ src/Modelling/PetriNet/Types.hs | 34 +++++++++++++++---------------- 4 files changed, 56 insertions(+), 58 deletions(-) diff --git a/app/mistake.hs b/app/mistake.hs index 29f757f4b..c42f857de 100644 --- a/app/mistake.hs +++ b/app/mistake.hs @@ -3,7 +3,7 @@ module Main (main) where import qualified Modelling.PetriNet.Types as Pick ( - PickMistakeConfig (..), + PickPossibleMistakeConfig (..), ) import Capabilities.Alloy.IO () @@ -16,16 +16,16 @@ import Common ( withLang, ) import Modelling.PetriNet.Mistake ( - checkPickMistakeConfig, + checkPickPossibleMistakeConfig, pickMistakeGenerate, simplePickMistakeTask, ) import Modelling.PetriNet.Types ( BasicConfig (..), ChangeConfig (..), - MistakeConfig (..), - PickMistakeConfig (..), - defaultPickMistakeConfig, + PossibleMistakeConfig (..), + PickPossibleMistakeConfig (..), + defaultPickPossibleMistakeConfig, ) import Control.OutputCapable.Blocks (Language (English)) @@ -49,24 +49,24 @@ main = do mainPick :: Int -> IO () mainPick i = forceErrors $ do - lift $ pPrint defaultPickMistakeConfig + lift $ pPrint defaultPickPossibleMistakeConfig (pls, trns, tknChange, flwChange, negTokCost, transToTr, placeToPl) <- lift userInput - let config = defaultPickMistakeConfig { - Pick.basicConfig = (Pick.basicConfig defaultPickMistakeConfig) { + let config = defaultPickPossibleMistakeConfig { + Pick.basicConfig = (Pick.basicConfig defaultPickPossibleMistakeConfig) { places = pls, transitions = trns }, - Pick.changeConfig = (Pick.changeConfig defaultPickMistakeConfig) { + Pick.changeConfig = (Pick.changeConfig defaultPickPossibleMistakeConfig) { tokenChangeOverall = tknChange, flowChangeOverall = flwChange }, - Pick.mistakeConfig = (Pick.mistakeConfig defaultPickMistakeConfig) { - negativeTokenCost = negTokCost, - transitionToTransition = transToTr, - placeToPlace = placeToPl + Pick.possibleMistakeConfig = (Pick.possibleMistakeConfig defaultPickPossibleMistakeConfig) { + canHaveNegativeTokenCost = negTokCost, + canHaveTransitionToTransition = transToTr, + canHavePlaceToPlace = placeToPl } - } :: PickMistakeConfig - let c = checkPickMistakeConfig config + } :: PickPossibleMistakeConfig + let c = checkPickPossibleMistakeConfig config if isNothing c then do t <- pickMistakeGenerate config 0 i diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 33243890e..6aa5a3780 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -38,7 +38,7 @@ import Modelling.PetriNet.Types ( AlloyConfig, BasicConfig (..), ChangeConfig (..), - MistakeConfig (..) + PossibleMistakeConfig (..) ) import qualified Modelling.PetriNet.Types as T ( @@ -55,7 +55,7 @@ import Control.Monad.Random ( ) import Data.Composition ((.:)) import Data.FileEmbed (embedStringFile) -import Data.List (intercalate) +import Data.List (intercalate, partition) import Data.Set (Set) import Data.String.Interpolate (i) import Language.Alloy.Call ( @@ -199,23 +199,21 @@ compChange ChangeConfig maxTokenChangePerPlace[#{maxTokenChangePerPlace}] |] -mistakeConstraints :: MistakeConfig -> String -mistakeConstraints MistakeConfig - { negativeTokenCost, transitionToTransition, placeToPlace +mistakeConstraints :: PossibleMistakeConfig -> String +mistakeConstraints PossibleMistakeConfig + { canHaveNegativeTokenCost, canHaveTransitionToTransition, canHavePlaceToPlace } = unlines [trueInput, falseInput] where input :: [(Bool, String)] - input = [(negativeTokenCost, "all w : Nodes.flow[Nodes] | w > 0"), - (transitionToTransition, "Transitions.flow.Int in Places"), - (placeToPlace, "Places.flow.Int in Transitions")] + input = [(canHaveNegativeTokenCost, "all w : Nodes.flow[Nodes] | w > 0"), + (canHaveTransitionToTransition, "Transitions.flow.Int in Places"), + (canHavePlaceToPlace, "Places.flow.Int in Transitions")] + (trueMistakes, falseMistakes) = partition fst input - trueMistakes = [string | (True, string) <- input] - falseMistakes = [string | (False, string) <- input] - - trueInput = intercalate " or " (map (\x -> "not(" ++ x ++ ")") trueMistakes) + trueInput = intercalate " or " (map (\(_,x) -> "not(" ++ x ++ ")") trueMistakes) falseInput :: String - falseInput = unlines (map (" " ++) falseMistakes) + falseInput = unlines (map(\(_,x) -> " " ++ x) falseMistakes) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index e5c96b40d..460ef98fc 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -5,7 +5,7 @@ {-# Language QuasiQuotes #-} module Modelling.PetriNet.Mistake ( - checkPickMistakeConfig, + checkPickPossibleMistakeConfig, defaultPickMistakeInstance, parseMistake, petriNetPickMist, @@ -16,7 +16,7 @@ module Modelling.PetriNet.Mistake ( ) where import qualified Modelling.PetriNet.Types as Pick ( - PickMistakeConfig (..), + PickPossibleMistakeConfig (..), ) import qualified Data.Map as M ( @@ -64,10 +64,10 @@ import Modelling.PetriNet.Types ( ChangeConfig, Concurrent (Concurrent), DrawSettings (..), - MistakeConfig, + PossibleMistakeConfig, Net (..), PetriLike (PetriLike, allNodes), - PickMistakeConfig (..), + PickPossibleMistakeConfig (..), SimpleNode (..), SimplePetriNet, ) @@ -94,7 +94,7 @@ import Language.Alloy.Call ( pickMistakeGenerate :: (MonadAlloy m, MonadThrow m, Net p n) - => PickMistakeConfig + => PickPossibleMistakeConfig -> Int -> Int -> m (PickInstance (p n String)) @@ -172,7 +172,7 @@ pickMistakeTask path task = do pickMistake :: (MonadAlloy m, MonadThrow m, Net p n, RandomGen g) - => PickMistakeConfig + => PickPossibleMistakeConfig -> Int -> RandT g @@ -184,16 +184,16 @@ pickMistake = taskInstance parseMistake Pick.alloyConfig -petriNetPickMist :: PickMistakeConfig -> String -petriNetPickMist PickMistakeConfig{ +petriNetPickMist :: PickPossibleMistakeConfig -> String +petriNetPickMist PickPossibleMistakeConfig{ basicConfig, changeConfig, - mistakeConfig + possibleMistakeConfig } = petriNetMistakeAlloy basicConfig changeConfig - mistakeConfig + possibleMistakeConfig {-| Generate code for PetriNet mistake tasks @@ -201,7 +201,7 @@ Generate code for PetriNet mistake tasks petriNetMistakeAlloy :: BasicConfig -> ChangeConfig - -> MistakeConfig + -> PossibleMistakeConfig -> String petriNetMistakeAlloy basicC changeC mistakeC = [i|module PetriNetMistake @@ -265,8 +265,8 @@ parseMistake inst = do t2 <- unscopedSingleSig inst concurrencyTransition2 "" Concurrent <$> ((,) <$> asSingleton t1 <*> asSingleton t2) -checkPickMistakeConfig :: PickMistakeConfig -> Maybe String -checkPickMistakeConfig PickMistakeConfig { +checkPickPossibleMistakeConfig :: PickPossibleMistakeConfig -> Maybe String +checkPickPossibleMistakeConfig PickPossibleMistakeConfig { basicConfig, changeConfig, graphConfig, diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 9c7826a3a..4ee94447d 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -31,10 +31,10 @@ module Modelling.PetriNet.Types ( DrawSettings (..), FindConcurrencyConfig (..), FindConflictConfig (..), - PickMistakeConfig (..), + PickPossibleMistakeConfig (..), GraphConfig (..), InvalidPetriNetException (..), - MistakeConfig(..), + PossibleMistakeConfig(..), Net (..), Node (..), Petri (..), @@ -58,7 +58,7 @@ module Modelling.PetriNet.Types ( defaultChangeConfig, defaultFindConcurrencyConfig, defaultFindConflictConfig, - defaultPickMistakeConfig, + defaultPickPossibleMistakeConfig, defaultGraphConfig, defaultPickConcurrencyConfig, defaultPickConflictConfig, @@ -885,38 +885,38 @@ defaultPickConcurrencyConfig = PickConcurrencyConfig , alloyConfig = defaultAlloyConfig } -data PickMistakeConfig = PickMistakeConfig +data PickPossibleMistakeConfig = PickPossibleMistakeConfig { basicConfig :: BasicConfig , changeConfig :: ChangeConfig , graphConfig :: GraphConfig - , mistakeConfig :: MistakeConfig + , possibleMistakeConfig :: PossibleMistakeConfig , printSolution :: Bool , useDifferentGraphLayouts :: Bool , alloyConfig :: AlloyConfig } deriving (Generic, Read, Show) -defaultPickMistakeConfig :: PickMistakeConfig -defaultPickMistakeConfig = PickMistakeConfig +defaultPickPossibleMistakeConfig :: PickPossibleMistakeConfig +defaultPickPossibleMistakeConfig = PickPossibleMistakeConfig { basicConfig = defaultBasicConfig , changeConfig = defaultChangeConfig , graphConfig = defaultGraphConfig { hidePlaceNames = True, hideTransitionNames = True } , printSolution = False , useDifferentGraphLayouts = False , alloyConfig = defaultAlloyConfig - , mistakeConfig = defaultMistakeConfig + , possibleMistakeConfig = defaultPossibleMistakeConfig } -data MistakeConfig = MistakeConfig - { negativeTokenCost :: Bool - , transitionToTransition :: Bool - , placeToPlace :: Bool +data PossibleMistakeConfig = PossibleMistakeConfig + { canHaveNegativeTokenCost :: Bool + , canHaveTransitionToTransition :: Bool + , canHavePlaceToPlace :: Bool } deriving (Generic, Read, Show) -defaultMistakeConfig :: MistakeConfig -defaultMistakeConfig = MistakeConfig - { negativeTokenCost = True - , transitionToTransition = True - , placeToPlace = False +defaultPossibleMistakeConfig :: PossibleMistakeConfig +defaultPossibleMistakeConfig = PossibleMistakeConfig + { canHaveNegativeTokenCost = True + , canHaveTransitionToTransition = True + , canHavePlaceToPlace = False } data DrawSettings = DrawSettings { From 59e4b5c3f6bdcc3a83fff38ec4af8a99d9eba1b8 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 23 Feb 2025 22:49:43 +0100 Subject: [PATCH 023/256] changed parseConcurrency MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Für Pick wird hier kein parsen gebraucht --- src/Modelling/PetriNet/Mistake.hs | 47 +++++-------------------------- 1 file changed, 7 insertions(+), 40 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 460ef98fc..26f3ba4a3 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -7,7 +7,6 @@ module Modelling.PetriNet.Mistake ( checkPickPossibleMistakeConfig, defaultPickMistakeInstance, - parseMistake, petriNetPickMist, pickMistake, pickMistakeGenerate, @@ -28,7 +27,6 @@ import Capabilities.Alloy (MonadAlloy) import Capabilities.Cache (MonadCache) import Capabilities.Diagrams (MonadDiagrams) import Capabilities.Graphviz (MonadGraphviz) -import Modelling.Auxiliary.Common (Object) import Modelling.Auxiliary.Output ( hoveringInformation, ) @@ -43,12 +41,7 @@ import Modelling.PetriNet.Alloy ( modulePetriSignature, petriScopeBitWidth, petriScopeMaxSeq, - skolemVariable, taskInstance, - unscopedSingleSig, - ) -import Modelling.PetriNet.Parser ( - asSingleton, ) import Modelling.PetriNet.Pick ( PickInstance (..), @@ -62,7 +55,6 @@ import Modelling.PetriNet.Pick ( import Modelling.PetriNet.Types ( BasicConfig (..), ChangeConfig, - Concurrent (Concurrent), DrawSettings (..), PossibleMistakeConfig, Net (..), @@ -87,10 +79,8 @@ import Control.Monad.Random ( RandomGen, ) import Data.GraphViz.Commands (GraphvizCommand (Fdp)) +import Data.Maybe (listToMaybe) import Data.String.Interpolate (i, iii) -import Language.Alloy.Call ( - AlloyInstance, - ) pickMistakeGenerate :: (MonadAlloy m, MonadThrow m, Net p n) @@ -177,11 +167,13 @@ pickMistake -> RandT g m - [(p n String, Maybe (Concurrent String))] + [(p n String, Maybe String)] pickMistake = taskInstance - pickTaskInstance + (\parse inst -> do + results <- pickTaskInstance parse inst + return $ map (\(net, mistakes) -> (net, mistakes >>= listToMaybe)) results) petriNetPickMist - parseMistake + (\_ -> return []) Pick.alloyConfig petriNetPickMist :: PickPossibleMistakeConfig -> String @@ -211,7 +203,7 @@ petriNetMistakeAlloy basicC changeC mistakeC #{modulePetriConcepts} #{modulePetriConstraints} -pred #{mistakePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions, #{t1}, #{t2} : Transitions] { +pred #{mistakePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} #{compBasicConstraints False activated basicC} @@ -236,35 +228,10 @@ run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petr defaultActiveTrans :: String defaultActiveTrans = [i|#{activatedDefault} : set givenTransitions,|] compConstraints = defaultConstraints activatedDefault basicC - t1 = transition1 - t2 = transition2 mistakePredicateName :: String mistakePredicateName = "showMistake" -concurrencyTransition1 :: String -concurrencyTransition1 = skolemVariable mistakePredicateName transition1 - -concurrencyTransition2 :: String -concurrencyTransition2 = skolemVariable mistakePredicateName transition2 - -transition1 :: String -transition1 = "transition1" - -transition2 :: String -transition2 = "transition2" - -{-| -Parses the concurrency Skolem variables for singleton of transitions and returns -both as tuple. -It throws an error instead if unexpected behaviour occurs. --} -parseMistake :: MonadThrow m => AlloyInstance -> m (Concurrent Object) -parseMistake inst = do - t1 <- unscopedSingleSig inst concurrencyTransition1 "" - t2 <- unscopedSingleSig inst concurrencyTransition2 "" - Concurrent <$> ((,) <$> asSingleton t1 <*> asSingleton t2) - checkPickPossibleMistakeConfig :: PickPossibleMistakeConfig -> Maybe String checkPickPossibleMistakeConfig PickPossibleMistakeConfig { basicConfig, From d98921f7c70d291dbfd3ea258ba5824a99782ddc Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 23 Feb 2025 22:50:21 +0100 Subject: [PATCH 024/256] changed defaultPickMistakeConfig Beinhaltet nur zwei Fehler --- src/Modelling/PetriNet/Mistake.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 26f3ba4a3..dc3f8824d 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -252,13 +252,13 @@ defaultPickMistakeInstance = PickInstance { (1,(False,( PetriLike { allNodes = M.fromList [ - ("s1",SimplePlace {initial = 1, flowOut = M.fromList [("t1",2),("t2",1),("t3",1)]}), + ("s1",SimplePlace {initial = 3, flowOut = M.fromList [("t1",1),("t3",2)]}), ("s2",SimplePlace {initial = 0, flowOut = M.empty}), - ("s3",SimplePlace {initial = 0, flowOut = M.fromList [("t1",1)]}), - ("s4",SimplePlace {initial = 1, flowOut = M.empty}), - ("t1",SimpleTransition {flowOut = M.fromList [("s1",1),("s4",1)]}), - ("t2",SimpleTransition {flowOut = M.fromList [("s4",1)]}), - ("t3",SimpleTransition {flowOut = M.fromList [("s2",1),("s3",1)]}) + ("s3",SimplePlace {initial = 1, flowOut = M.fromList [("t2",1)]}), + ("s4",SimplePlace {initial = 1, flowOut = M.fromList [("t2",1)]}), + ("t1",SimpleTransition {flowOut = M.fromList [("s2",1),("s3",1)]}), + ("t2",SimpleTransition {flowOut = M.fromList [("s1",1)]}), + ("t3",SimpleTransition {flowOut = M.fromList [("s4",2)]}) ] }, DrawSettings { @@ -272,13 +272,13 @@ defaultPickMistakeInstance = PickInstance { (2,(True,( PetriLike { allNodes = M.fromList [ - ("s1",SimplePlace {initial = 2, flowOut = M.fromList [("t1",2),("t2",1),("s2",1)]}), + ("s1",SimplePlace {initial = 3, flowOut = M.fromList [("t1",-1),("t3",2)]}), ("s2",SimplePlace {initial = 0, flowOut = M.empty}), - ("s3",SimplePlace {initial = 0, flowOut = M.fromList [("t1",1)]}), - ("s4",SimplePlace {initial = 2, flowOut = M.fromList [("t2",-2)]}), - ("t1",SimpleTransition {flowOut = M.fromList [("s1",1),("s4",1)]}), - ("t2",SimpleTransition {flowOut = M.fromList [("s1",1),("s4",1)]}), - ("t3",SimpleTransition {flowOut = M.fromList [("s2",1),("s3",-1)]}) + ("s3",SimplePlace {initial = 1, flowOut = M.fromList [("t2",1)]}), + ("s4",SimplePlace {initial = 1, flowOut = M.fromList [("t2",1)]}), + ("t1",SimpleTransition {flowOut = M.fromList [("s2",1),("s3",1)]}), + ("t2",SimpleTransition {flowOut = M.fromList [("t1",1)]}), + ("t3",SimpleTransition {flowOut = M.fromList [("s4",2)]}) ] }, DrawSettings { From 0dfd9ebd8ed7bb9dd08cba7137a2ee612478081d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 24 Feb 2025 08:43:44 +0100 Subject: [PATCH 025/256] made app a bit more convenient to use - simply hitting Enter several times leads to use of the default config - (also simplified the code somewhat) --- app/mistake.hs | 52 +++++++++++++++++++++++++------------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/app/mistake.hs b/app/mistake.hs index c42f857de..3024e4fdf 100644 --- a/app/mistake.hs +++ b/app/mistake.hs @@ -1,11 +1,8 @@ {-# Language DuplicateRecordFields #-} +{-# Language RecordWildCards #-} module Main (main) where -import qualified Modelling.PetriNet.Types as Pick ( - PickPossibleMistakeConfig (..), - ) - import Capabilities.Alloy.IO () import Capabilities.Cache.IO () import Capabilities.Diagrams.IO () @@ -49,18 +46,19 @@ main = do mainPick :: Int -> IO () mainPick i = forceErrors $ do - lift $ pPrint defaultPickPossibleMistakeConfig - (pls, trns, tknChange, flwChange, negTokCost, transToTr, placeToPl) <- lift userInput - let config = defaultPickPossibleMistakeConfig { - Pick.basicConfig = (Pick.basicConfig defaultPickPossibleMistakeConfig) { + let theConfig@PickPossibleMistakeConfig{..} = defaultPickPossibleMistakeConfig + lift $ pPrint theConfig + (pls, trns, tknChange, flwChange, negTokCost, transToTr, placeToPl) <- lift $ userInput theConfig + let config = theConfig { + basicConfig = basicConfig { places = pls, transitions = trns }, - Pick.changeConfig = (Pick.changeConfig defaultPickPossibleMistakeConfig) { + changeConfig = changeConfig { tokenChangeOverall = tknChange, flowChangeOverall = flwChange }, - Pick.possibleMistakeConfig = (Pick.possibleMistakeConfig defaultPickPossibleMistakeConfig) { + possibleMistakeConfig = possibleMistakeConfig { canHaveNegativeTokenCost = negTokCost, canHaveTransitionToTransition = transToTr, canHavePlaceToPlace = placeToPl @@ -75,39 +73,41 @@ mainPick i = forceErrors $ do else lift $ print c -boolInput :: IO Bool -boolInput = do +boolInput :: Bool -> IO Bool +boolInput d = do input <- getLine case map toLower input of + "" -> return d "true" -> return True "false" -> return False _ -> do putStrLn "Invalid input" - boolInput + boolInput d -intInput :: IO Int -intInput = do +intInput :: Int -> IO Int +intInput d = do input <- getLine - case readMaybe input of + if null input then return d + else case readMaybe input of Just n -> return n Nothing -> do putStrLn "Invalid input" - intInput + intInput d -userInput :: IO (Int, Int, Int, Int, Bool, Bool, Bool) -userInput = do +userInput :: PickPossibleMistakeConfig -> IO (Int, Int, Int, Int, Bool, Bool, Bool) +userInput PickPossibleMistakeConfig{basicConfig = BasicConfig{..}, changeConfig = ChangeConfig{..}, possibleMistakeConfig = PossibleMistakeConfig{..}} = do putStr "Number of Places: " - pls <- intInput + pls <- intInput places putStr "Number of Transitions: " - trns <- intInput + trns <- intInput transitions putStr "TokenChange Overall: " - tknCh <- intInput + tknCh <- intInput tokenChangeOverall putStr "FlowChange Overall: " - flwCh <- intInput + flwCh <- intInput flowChangeOverall putStr "Negative Token Cost (True/False): " - negTokCost <- boolInput + negTokCost <- boolInput canHaveNegativeTokenCost putStr "Transition to Transition (True/False): " - transToTr <- boolInput + transToTr <- boolInput canHaveTransitionToTransition putStr "Places to Places (True/False): " - placeToPl <- boolInput + placeToPl <- boolInput canHavePlaceToPlace return (pls, trns, tknCh, flwCh, negTokCost, transToTr, placeToPl) From d595fd713ce46102ff4c0827ad0ad2c0fd42f37b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 24 Feb 2025 08:47:04 +0100 Subject: [PATCH 026/256] make behavior of function agree with what its documentation claims --- src/Modelling/PetriNet/Alloy.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 6aa5a3780..0c1db15ef 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -108,7 +108,7 @@ compBasicConstraints -> String compBasicConstraints legal activated basicConfig = [i| #{enforceConstraints False activated basicConfig} - #{if legal then "isLegalPetriNet" else ""}|] + #{if legal then "isLegalPetriNet" else "not isLegalPetriNet"}|] {-| A set of constraints enforcing settings of 'BasicConfig' for the net under From b351aeb7f35f07a826d20027fffa92dc53881c00 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 24 Feb 2025 08:57:36 +0100 Subject: [PATCH 027/256] remove unwarranted language extension - introduced in af7793a0056df113718708829762374c97ea0245 --- src/Modelling/PetriNet/Concurrency.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index 4df386bf6..f24e69825 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# Language QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} module Modelling.PetriNet.Concurrency ( checkFindConcurrencyConfig, From a841fc5f143b4b5f3fae6db479f339cc53562c56 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 24 Feb 2025 09:29:52 +0100 Subject: [PATCH 028/256] reflect that there isn't anything to parse "in addition" during PickMistakeTask - i.e., nothing like specific transitions to point to, as in Concurrency/Conflict tasks --- src/Modelling/PetriNet/Mistake.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index dc3f8824d..f02692fdf 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -79,7 +79,7 @@ import Control.Monad.Random ( RandomGen, ) import Data.GraphViz.Commands (GraphvizCommand (Fdp)) -import Data.Maybe (listToMaybe) +import Data.Functor.Const (Const(..)) import Data.String.Interpolate (i, iii) pickMistakeGenerate @@ -167,13 +167,11 @@ pickMistake -> RandT g m - [(p n String, Maybe String)] + [(p n String, Maybe (Const () String))] pickMistake = taskInstance - (\parse inst -> do - results <- pickTaskInstance parse inst - return $ map (\(net, mistakes) -> (net, mistakes >>= listToMaybe)) results) + pickTaskInstance petriNetPickMist - (\_ -> return []) + (\_ -> return (Const ())) Pick.alloyConfig petriNetPickMist :: PickPossibleMistakeConfig -> String From de95091b280fb3b7e1cdc772ead0468f45611762 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 24 Feb 2025 23:10:38 +0100 Subject: [PATCH 029/256] reverted change on some names --- app/mistake.hs | 4 ++-- src/Modelling/PetriNet/Mistake.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/app/mistake.hs b/app/mistake.hs index 3024e4fdf..d9c76b133 100644 --- a/app/mistake.hs +++ b/app/mistake.hs @@ -13,7 +13,7 @@ import Common ( withLang, ) import Modelling.PetriNet.Mistake ( - checkPickPossibleMistakeConfig, + checkPickMistakeConfig, pickMistakeGenerate, simplePickMistakeTask, ) @@ -64,7 +64,7 @@ mainPick i = forceErrors $ do canHavePlaceToPlace = placeToPl } } :: PickPossibleMistakeConfig - let c = checkPickPossibleMistakeConfig config + let c = checkPickMistakeConfig config if isNothing c then do t <- pickMistakeGenerate config 0 i diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index f02692fdf..375bf41bf 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -5,7 +5,7 @@ {-# Language QuasiQuotes #-} module Modelling.PetriNet.Mistake ( - checkPickPossibleMistakeConfig, + checkPickMistakeConfig, defaultPickMistakeInstance, petriNetPickMist, pickMistake, @@ -230,8 +230,8 @@ run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petr mistakePredicateName :: String mistakePredicateName = "showMistake" -checkPickPossibleMistakeConfig :: PickPossibleMistakeConfig -> Maybe String -checkPickPossibleMistakeConfig PickPossibleMistakeConfig { +checkPickMistakeConfig :: PickPossibleMistakeConfig -> Maybe String +checkPickMistakeConfig PickPossibleMistakeConfig { basicConfig, changeConfig, graphConfig, From b40d570d4e15944fbf82c79f7917bd1e31d2642d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 24 Feb 2025 23:12:51 +0100 Subject: [PATCH 030/256] removed code from generated alloy code changed enforceConstraints for petrinets that don't use activated transitions --- src/Modelling/PetriNet/Alloy.hs | 7 ++++--- src/Modelling/PetriNet/Mistake.hs | 18 +++--------------- 2 files changed, 7 insertions(+), 18 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 0c1db15ef..939ab054b 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -144,7 +144,7 @@ enforceConstraints underDefault activated BasicConfig { all w : #{nodes}.#{flow}[#{nodes}] | w =< #{maxFlowPerEdge} let theFlow = (sum f, t : #{nodes} | f.#{flow}[t]) | #{fst flowOverall} =< theFlow and theFlow =< #{snd flowOverall} - #{activatedConstraint} + #{activatedConstraint activated} #{connected (prepend "graphIsConnected") isConnected} #{isolated (prepend "noIsolatedNodes") isConnected}|] where @@ -155,8 +155,9 @@ enforceConstraints underDefault activated BasicConfig { nodes = given "Nodes" places = given "Places" tokens = prepend "tokens" - activatedConstraint = - if atLeastActive <= 0 + activatedConstraint :: String -> String + activatedConstraint string = + if atLeastActive <= 0 || null string then "" else [i| \##{activated} >= #{atLeastActive} diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 375bf41bf..e11e502ca 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -201,13 +201,11 @@ petriNetMistakeAlloy basicC changeC mistakeC #{modulePetriConcepts} #{modulePetriConstraints} -pred #{mistakePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions] { +pred #{mistakePredicateName} { \#Places = #{places basicC} \#Transitions = #{transitions basicC} - #{compBasicConstraints False activated basicC} + #{compBasicConstraints False "" basicC} #{compChange changeC} - #{sourceTransitionConstraints} - #{sinkTransitionConstraints} #{compConstraints} #{mistakeConstraints mistakeC} } @@ -215,17 +213,7 @@ pred #{mistakePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] where - activated = "activatedTrans" - activatedDefault = "defaultActiveTrans" - sourceTransitionConstraints :: String - sourceTransitionConstraints = [i| - no t : givenTransitions | no givenPlaces.flow[t] - no t : Transitions | sourceTransitions[t]|] - sinkTransitionConstraints :: String - sinkTransitionConstraints = "no t : Transitions | sinkTransitions[t]" - defaultActiveTrans :: String - defaultActiveTrans = [i|#{activatedDefault} : set givenTransitions,|] - compConstraints = defaultConstraints activatedDefault basicC + compConstraints = defaultConstraints "" basicC mistakePredicateName :: String mistakePredicateName = "showMistake" From ad1e52687beaec52cfc1391971e620a26ba5cc9c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 25 Feb 2025 09:41:18 +0100 Subject: [PATCH 031/256] bake more strictly into the code that "activatedness" is not of concern in Mistake tasks --- src/Modelling/PetriNet/Alloy.hs | 7 +++---- src/Modelling/PetriNet/Mistake.hs | 4 ++-- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 939ab054b..0c1db15ef 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -144,7 +144,7 @@ enforceConstraints underDefault activated BasicConfig { all w : #{nodes}.#{flow}[#{nodes}] | w =< #{maxFlowPerEdge} let theFlow = (sum f, t : #{nodes} | f.#{flow}[t]) | #{fst flowOverall} =< theFlow and theFlow =< #{snd flowOverall} - #{activatedConstraint activated} + #{activatedConstraint} #{connected (prepend "graphIsConnected") isConnected} #{isolated (prepend "noIsolatedNodes") isConnected}|] where @@ -155,9 +155,8 @@ enforceConstraints underDefault activated BasicConfig { nodes = given "Nodes" places = given "Places" tokens = prepend "tokens" - activatedConstraint :: String -> String - activatedConstraint string = - if atLeastActive <= 0 || null string + activatedConstraint = + if atLeastActive <= 0 then "" else [i| \##{activated} >= #{atLeastActive} diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index e11e502ca..d36c441ce 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -204,7 +204,7 @@ petriNetMistakeAlloy basicC changeC mistakeC pred #{mistakePredicateName} { \#Places = #{places basicC} \#Transitions = #{transitions basicC} - #{compBasicConstraints False "" basicC} + #{compBasicConstraints False undefined basicC} #{compChange changeC} #{compConstraints} #{mistakeConstraints mistakeC} @@ -213,7 +213,7 @@ pred #{mistakePredicateName} { run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] where - compConstraints = defaultConstraints "" basicC + compConstraints = defaultConstraints undefined basicC mistakePredicateName :: String mistakePredicateName = "showMistake" From 386b9fa7d7a383cd94e08a0f7b25d97b00bc5cc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 25 Feb 2025 09:42:48 +0100 Subject: [PATCH 032/256] cosmetic change of order of constraints --- src/Modelling/PetriNet/Mistake.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index d36c441ce..6ebd067d6 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -205,15 +205,13 @@ pred #{mistakePredicateName} { \#Places = #{places basicC} \#Transitions = #{transitions basicC} #{compBasicConstraints False undefined basicC} - #{compChange changeC} - #{compConstraints} #{mistakeConstraints mistakeC} + #{compChange changeC} + #{defaultConstraints undefined basicC} } run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] - where - compConstraints = defaultConstraints undefined basicC mistakePredicateName :: String mistakePredicateName = "showMistake" From d50325fb469bc9a64d0eb7ff26e22e5ca037ef4e Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 26 Feb 2025 21:39:13 +0100 Subject: [PATCH 033/256] remove not(...) statements from alloy code and move to mistake --- src/Modelling/PetriNet/Alloy.hs | 23 +---------------------- src/Modelling/PetriNet/Mistake.hs | 22 ++++++++++++++++++++-- 2 files changed, 21 insertions(+), 24 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 0c1db15ef..d716e88c9 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -13,7 +13,6 @@ module Modelling.PetriNet.Alloy ( connected, defaultConstraints, isolated, - mistakeConstraints, moduleHelpers, modulePetriAdditions, modulePetriConcepts, @@ -38,7 +37,6 @@ import Modelling.PetriNet.Types ( AlloyConfig, BasicConfig (..), ChangeConfig (..), - PossibleMistakeConfig (..) ) import qualified Modelling.PetriNet.Types as T ( @@ -55,7 +53,7 @@ import Control.Monad.Random ( ) import Data.Composition ((.:)) import Data.FileEmbed (embedStringFile) -import Data.List (intercalate, partition) +import Data.List (intercalate) import Data.Set (Set) import Data.String.Interpolate (i) import Language.Alloy.Call ( @@ -199,25 +197,6 @@ compChange ChangeConfig maxTokenChangePerPlace[#{maxTokenChangePerPlace}] |] -mistakeConstraints :: PossibleMistakeConfig -> String -mistakeConstraints PossibleMistakeConfig - { canHaveNegativeTokenCost, canHaveTransitionToTransition, canHavePlaceToPlace - } = unlines [trueInput, falseInput] - where - input :: [(Bool, String)] - input = [(canHaveNegativeTokenCost, "all w : Nodes.flow[Nodes] | w > 0"), - (canHaveTransitionToTransition, "Transitions.flow.Int in Places"), - (canHavePlaceToPlace, "Places.flow.Int in Transitions")] - (trueMistakes, falseMistakes) = partition fst input - - trueInput = intercalate " or " (map (\(_,x) -> "not(" ++ x ++ ")") trueMistakes) - - falseInput :: String - falseInput = unlines (map(\(_,x) -> " " ++ x) falseMistakes) - - - - {-| Generates signatures of the given kind, number of places and transitions. -} diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 6ebd067d6..82b2d1a10 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -7,6 +7,7 @@ module Modelling.PetriNet.Mistake ( checkPickMistakeConfig, defaultPickMistakeInstance, + mistakeConstraints, petriNetPickMist, pickMistake, pickMistakeGenerate, @@ -216,8 +217,25 @@ run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petr mistakePredicateName :: String mistakePredicateName = "showMistake" -checkPickMistakeConfig :: PickPossibleMistakeConfig -> Maybe String -checkPickMistakeConfig PickPossibleMistakeConfig { +mistakeConstraints :: MistakeConfig -> String +mistakeConstraints MistakeConfig + { canHaveNegativeTokenCost, canHaveTransitionToTransition, canHavePlaceToPlace + } = falseInput + where + input :: [(Bool, String)] + input = [(canHaveNegativeTokenCost, "all w : Nodes.flow[Nodes] | w > 0"), + (canHaveTransitionToTransition, "Transitions.flow.Int in Places"), + (canHavePlaceToPlace, "Places.flow.Int in Transitions")] + falseMistakes = map snd (filter (not . fst) input) + + falseInput :: String + falseInput = + case falseMistakes of + [] -> "" + (x:xs) -> unlines (x : map (" " ++) xs) + +checkPickMistakeConfig :: PickMistakeConfig -> Maybe String +checkPickMistakeConfig PickMistakeConfig { basicConfig, changeConfig, graphConfig, From 2bd57ca69dcdd6f7fefca844c45cfc39b279ae96 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 26 Feb 2025 21:42:00 +0100 Subject: [PATCH 034/256] removed all "possible" from mistake names --- app/mistake.hs | 16 ++++++++-------- src/Modelling/PetriNet/Mistake.hs | 23 +++++++++++------------ src/Modelling/PetriNet/Types.hs | 26 +++++++++++++------------- 3 files changed, 32 insertions(+), 33 deletions(-) diff --git a/app/mistake.hs b/app/mistake.hs index d9c76b133..9c5c10c4c 100644 --- a/app/mistake.hs +++ b/app/mistake.hs @@ -20,9 +20,9 @@ import Modelling.PetriNet.Mistake ( import Modelling.PetriNet.Types ( BasicConfig (..), ChangeConfig (..), - PossibleMistakeConfig (..), - PickPossibleMistakeConfig (..), - defaultPickPossibleMistakeConfig, + MistakeConfig (..), + PickMistakeConfig (..), + defaultPickMistakeConfig, ) import Control.OutputCapable.Blocks (Language (English)) @@ -46,7 +46,7 @@ main = do mainPick :: Int -> IO () mainPick i = forceErrors $ do - let theConfig@PickPossibleMistakeConfig{..} = defaultPickPossibleMistakeConfig + let theConfig@PickMistakeConfig{..} = defaultPickMistakeConfig lift $ pPrint theConfig (pls, trns, tknChange, flwChange, negTokCost, transToTr, placeToPl) <- lift $ userInput theConfig let config = theConfig { @@ -58,12 +58,12 @@ mainPick i = forceErrors $ do tokenChangeOverall = tknChange, flowChangeOverall = flwChange }, - possibleMistakeConfig = possibleMistakeConfig { + mistakeConfig = mistakeConfig { canHaveNegativeTokenCost = negTokCost, canHaveTransitionToTransition = transToTr, canHavePlaceToPlace = placeToPl } - } :: PickPossibleMistakeConfig + } :: PickMistakeConfig let c = checkPickMistakeConfig config if isNothing c then do @@ -94,8 +94,8 @@ intInput d = do putStrLn "Invalid input" intInput d -userInput :: PickPossibleMistakeConfig -> IO (Int, Int, Int, Int, Bool, Bool, Bool) -userInput PickPossibleMistakeConfig{basicConfig = BasicConfig{..}, changeConfig = ChangeConfig{..}, possibleMistakeConfig = PossibleMistakeConfig{..}} = do +userInput :: PickMistakeConfig -> IO (Int, Int, Int, Int, Bool, Bool, Bool) +userInput PickMistakeConfig{basicConfig = BasicConfig{..}, changeConfig = ChangeConfig{..}, mistakeConfig = MistakeConfig{..}} = do putStr "Number of Places: " pls <- intInput places putStr "Number of Transitions: " diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 82b2d1a10..c5ff5330b 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -16,7 +16,7 @@ module Modelling.PetriNet.Mistake ( ) where import qualified Modelling.PetriNet.Types as Pick ( - PickPossibleMistakeConfig (..), + PickMistakeConfig (..), ) import qualified Data.Map as M ( @@ -35,7 +35,6 @@ import Modelling.PetriNet.Alloy ( compBasicConstraints, compChange, defaultConstraints, - mistakeConstraints, moduleHelpers, modulePetriConcepts, modulePetriConstraints, @@ -57,10 +56,10 @@ import Modelling.PetriNet.Types ( BasicConfig (..), ChangeConfig, DrawSettings (..), - PossibleMistakeConfig, + MistakeConfig (..), Net (..), PetriLike (PetriLike, allNodes), - PickPossibleMistakeConfig (..), + PickMistakeConfig (..), SimpleNode (..), SimplePetriNet, ) @@ -85,7 +84,7 @@ import Data.String.Interpolate (i, iii) pickMistakeGenerate :: (MonadAlloy m, MonadThrow m, Net p n) - => PickPossibleMistakeConfig + => PickMistakeConfig -> Int -> Int -> m (PickInstance (p n String)) @@ -135,7 +134,7 @@ pickMistakeTask path task = do that is incorrect. #{" "}|] german [iii| - Geben Sie Ihre Antwort durch Angabe der Nummer des Petrinetzes an, + Geben Sie Ihre Antwort durch Angabe der Nummer des Petri-Netzes an, das inkorrekt ist. #{" "}|] let plural = wrongInstances task > 1 @@ -163,7 +162,7 @@ pickMistakeTask path task = do pickMistake :: (MonadAlloy m, MonadThrow m, Net p n, RandomGen g) - => PickPossibleMistakeConfig + => PickMistakeConfig -> Int -> RandT g @@ -175,16 +174,16 @@ pickMistake = taskInstance (\_ -> return (Const ())) Pick.alloyConfig -petriNetPickMist :: PickPossibleMistakeConfig -> String -petriNetPickMist PickPossibleMistakeConfig{ +petriNetPickMist :: PickMistakeConfig -> String +petriNetPickMist PickMistakeConfig{ basicConfig, changeConfig, - possibleMistakeConfig + mistakeConfig } = petriNetMistakeAlloy basicConfig changeConfig - possibleMistakeConfig + mistakeConfig {-| Generate code for PetriNet mistake tasks @@ -192,7 +191,7 @@ Generate code for PetriNet mistake tasks petriNetMistakeAlloy :: BasicConfig -> ChangeConfig - -> PossibleMistakeConfig + -> MistakeConfig -> String petriNetMistakeAlloy basicC changeC mistakeC = [i|module PetriNetMistake diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 4ee94447d..a063fa3a4 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -31,10 +31,10 @@ module Modelling.PetriNet.Types ( DrawSettings (..), FindConcurrencyConfig (..), FindConflictConfig (..), - PickPossibleMistakeConfig (..), + PickMistakeConfig (..), GraphConfig (..), InvalidPetriNetException (..), - PossibleMistakeConfig(..), + MistakeConfig(..), Net (..), Node (..), Petri (..), @@ -58,7 +58,7 @@ module Modelling.PetriNet.Types ( defaultChangeConfig, defaultFindConcurrencyConfig, defaultFindConflictConfig, - defaultPickPossibleMistakeConfig, + defaultPickMistakeConfig, defaultGraphConfig, defaultPickConcurrencyConfig, defaultPickConflictConfig, @@ -885,38 +885,38 @@ defaultPickConcurrencyConfig = PickConcurrencyConfig , alloyConfig = defaultAlloyConfig } -data PickPossibleMistakeConfig = PickPossibleMistakeConfig +data PickMistakeConfig = PickMistakeConfig { basicConfig :: BasicConfig , changeConfig :: ChangeConfig + , mistakeConfig :: MistakeConfig , graphConfig :: GraphConfig - , possibleMistakeConfig :: PossibleMistakeConfig , printSolution :: Bool , useDifferentGraphLayouts :: Bool , alloyConfig :: AlloyConfig } deriving (Generic, Read, Show) -defaultPickPossibleMistakeConfig :: PickPossibleMistakeConfig -defaultPickPossibleMistakeConfig = PickPossibleMistakeConfig - { basicConfig = defaultBasicConfig +defaultPickMistakeConfig :: PickMistakeConfig +defaultPickMistakeConfig = PickMistakeConfig + { basicConfig = defaultBasicConfig { atLeastActive = 0 } , changeConfig = defaultChangeConfig , graphConfig = defaultGraphConfig { hidePlaceNames = True, hideTransitionNames = True } , printSolution = False , useDifferentGraphLayouts = False , alloyConfig = defaultAlloyConfig - , possibleMistakeConfig = defaultPossibleMistakeConfig + , mistakeConfig = defaultMistakeConfig } -data PossibleMistakeConfig = PossibleMistakeConfig +data MistakeConfig = MistakeConfig { canHaveNegativeTokenCost :: Bool , canHaveTransitionToTransition :: Bool , canHavePlaceToPlace :: Bool } deriving (Generic, Read, Show) -defaultPossibleMistakeConfig :: PossibleMistakeConfig -defaultPossibleMistakeConfig = PossibleMistakeConfig +defaultMistakeConfig :: MistakeConfig +defaultMistakeConfig = MistakeConfig { canHaveNegativeTokenCost = True , canHaveTransitionToTransition = True - , canHavePlaceToPlace = False + , canHavePlaceToPlace = True } data DrawSettings = DrawSettings { From 25c805d62399471d3e518309514a70ec48f86262 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 27 Feb 2025 19:05:36 +0100 Subject: [PATCH 035/256] added checkMistakeConfig --- src/Modelling/PetriNet/Mistake.hs | 45 ++++++++++++++++++++++++++----- 1 file changed, 39 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index c5ff5330b..76ab9d582 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -54,7 +54,7 @@ import Modelling.PetriNet.Pick ( ) import Modelling.PetriNet.Types ( BasicConfig (..), - ChangeConfig, + ChangeConfig (..), DrawSettings (..), MistakeConfig (..), Net (..), @@ -64,6 +64,7 @@ import Modelling.PetriNet.Types ( SimplePetriNet, ) +import Control.Applicative ((<|>)) import Control.Monad.Catch (MonadThrow) import Control.OutputCapable.Blocks ( GenericOutputCapable (..), @@ -124,7 +125,7 @@ pickMistakeTask path task = do Which of the following Petri nets is "illegal" meaning it violates fundamental constraints? |] german [iii| - Welches dieser Petri-Netze ist "illegal", das heißt, es verletzt grundlegende Bedingungen? + Welches dieser Petrinetze ist "illegal", das heißt, es verletzt grundlegende Bedingungen? |] images show snd $=<< renderPick path "mistake" task @@ -134,7 +135,7 @@ pickMistakeTask path task = do that is incorrect. #{" "}|] german [iii| - Geben Sie Ihre Antwort durch Angabe der Nummer des Petri-Netzes an, + Geben Sie Ihre Antwort durch Angabe der Nummer des Petrinetzes an, das inkorrekt ist. #{" "}|] let plural = wrongInstances task > 1 @@ -149,13 +150,13 @@ pickMistakeTask path task = do #{if plural then "nets are valid" else "net is valid"}). |] german $ [iii| - #{" "}als Antwort würde bedeuten, dass Petri-Netz 1 + #{" "}als Antwort würde bedeuten, dass Petrinetz 1 "illegal" ist, während #{" "} |] ++ (if plural - then "die anderen Petri-Netze gültig sind" - else "das andere Petri-Netz gültig ist") + then "die anderen Petrinetze gültig sind" + else "das andere Petrinetz gültig ist") pure () paragraph hoveringInformation pure () @@ -237,6 +238,7 @@ checkPickMistakeConfig :: PickMistakeConfig -> Maybe String checkPickMistakeConfig PickMistakeConfig { basicConfig, changeConfig, + mistakeConfig, graphConfig, useDifferentGraphLayouts } @@ -246,6 +248,37 @@ checkPickMistakeConfig PickMistakeConfig { basicConfig changeConfig graphConfig + <|> checkMistakeConfig basicConfig changeConfig mistakeConfig + +checkMistakeConfig :: BasicConfig -> ChangeConfig -> MistakeConfig -> Maybe String +checkMistakeConfig BasicConfig { + places, + transitions, + atLeastActive + } + ChangeConfig { + flowChangeOverall, + maxFlowChangePerEdge + } + MistakeConfig { + canHaveNegativeTokenCost, + canHaveTransitionToTransition, + canHavePlaceToPlace + } + | not (canHaveNegativeTokenCost || canHaveTransitionToTransition || canHavePlaceToPlace) + = Just "At least one mistake must be enabled" + | atLeastActive /= 0 + = Just "atLeastActive has to be 0" + | canHaveTransitionToTransition && transitions < 2 + = Just "At least two transitions are required for transition mistakes" + | canHavePlaceToPlace && places < 2 + = Just "At least two places are required for place mistakes" + | (canHaveTransitionToTransition || canHavePlaceToPlace) && flowChangeOverall < 2 + = Just "flowChangeOverall must be at least 2 for mistakes" + | (canHaveTransitionToTransition || canHavePlaceToPlace) && maxFlowChangePerEdge < 1 + = Just "maxFlowChangePerEdge must be at least 1 for mistakes" + | otherwise + = Nothing defaultPickMistakeInstance :: PickInstance SimplePetriNet defaultPickMistakeInstance = PickInstance { From aa836bc5551df2900e5d6a67134b985635e8c107 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 27 Feb 2025 20:46:39 +0100 Subject: [PATCH 036/256] updated checkMistakeConfig --- src/Modelling/PetriNet/Mistake.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 76ab9d582..d61c8c80f 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -273,9 +273,11 @@ checkMistakeConfig BasicConfig { = Just "At least two transitions are required for transition mistakes" | canHavePlaceToPlace && places < 2 = Just "At least two places are required for place mistakes" - | (canHaveTransitionToTransition || canHavePlaceToPlace) && flowChangeOverall < 2 - = Just "flowChangeOverall must be at least 2 for mistakes" - | (canHaveTransitionToTransition || canHavePlaceToPlace) && maxFlowChangePerEdge < 1 + | (canHaveTransitionToTransition || canHavePlaceToPlace) && flowChangeOverall < 1 + = Just "flowChangeOverall must be at least 1 for mistakes" + | (canHaveTransitionToTransition && canHaveTransitionToTransition && canHavePlaceToPlace) && flowChangeOverall < 2 + = Just "flowChangeOverall must be greater than 1 for all mistakes" + | maxFlowChangePerEdge < 1 = Just "maxFlowChangePerEdge must be at least 1 for mistakes" | otherwise = Nothing From 97f7eb02018c3888382264c4467cfb31089d5f9d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 28 Feb 2025 09:39:14 +0100 Subject: [PATCH 037/256] wording --- src/Modelling/PetriNet/Mistake.hs | 38 +++++++++++++++---------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index d61c8c80f..6511faf91 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -122,21 +122,21 @@ pickMistakeTask pickMistakeTask path task = do paragraph $ translate $ do english [iii| - Which of the following Petri nets is "illegal" meaning it violates fundamental constraints? + Which of the following Petri net candidates is not correctly formed? |] german [iii| - Welches dieser Petrinetze ist "illegal", das heißt, es verletzt grundlegende Bedingungen? + Welcher der folgenden Petrinetzkandidaten ist nicht korrekt geformt? |] images show snd $=<< renderPick path "mistake" task paragraph $ translate $ do english [iii| - State your answer by giving the number of the Petri net - that is incorrect. + State your answer by giving the number of the Petri net candidate + that is syntactically incorrect. #{" "}|] german [iii| - Geben Sie Ihre Antwort durch Angabe der Nummer des Petrinetzes an, - das inkorrekt ist. + Geben Sie Ihre Antwort durch Angabe der Nummer des Petrinetzkandidaten an, + der syntaktisch inkorrekt ist. #{" "}|] let plural = wrongInstances task > 1 paragraph $ do @@ -146,17 +146,17 @@ pickMistakeTask path task = do code "1" translate $ do english [iii| - #{" "}as answer would indicate that Petri net 1 is "illegal" (and the other Petri - #{if plural then "nets are valid" else "net is valid"}). + #{" "}as answer would indicate that Petri net candidate 1 is incorrect (and the other + #{if plural then "ones are" else "one is"} at least syntactically correct). |] german $ [iii| - #{" "}als Antwort würde bedeuten, dass Petrinetz 1 - "illegal" ist, während + #{" "}als Antwort würde bedeuten, dass Petrinetzkandidat 1 + inkorrekt ist, während #{" "} |] ++ (if plural - then "die anderen Petrinetze gültig sind" - else "das andere Petrinetz gültig ist") + then "die anderen zumindest syntaktisch korrekt sind." + else "der andere zumindest syntaktisch korrekt ist.") pure () paragraph hoveringInformation pure () @@ -266,19 +266,19 @@ checkMistakeConfig BasicConfig { canHavePlaceToPlace } | not (canHaveNegativeTokenCost || canHaveTransitionToTransition || canHavePlaceToPlace) - = Just "At least one mistake must be enabled" + = Just "At least one mistake must be enabled." | atLeastActive /= 0 - = Just "atLeastActive has to be 0" + = Just "atLeastActive has to be 0 in this task type." | canHaveTransitionToTransition && transitions < 2 - = Just "At least two transitions are required for transition mistakes" + = Just "At least two transitions are required for transition mistakes." | canHavePlaceToPlace && places < 2 - = Just "At least two places are required for place mistakes" + = Just "At least two places are required for place mistakes." | (canHaveTransitionToTransition || canHavePlaceToPlace) && flowChangeOverall < 1 - = Just "flowChangeOverall must be at least 1 for mistakes" + = Just "flowChangeOverall must be at least 1 for mistakes." | (canHaveTransitionToTransition && canHaveTransitionToTransition && canHavePlaceToPlace) && flowChangeOverall < 2 - = Just "flowChangeOverall must be greater than 1 for all mistakes" + = Just "flowChangeOverall must be greater than 1 for all mistakes." | maxFlowChangePerEdge < 1 - = Just "maxFlowChangePerEdge must be at least 1 for mistakes" + = Just "maxFlowChangePerEdge must be at least 1 for mistakes to appear." | otherwise = Nothing From cf0ab96f5832f5a5dd1c026a76f09daed15b0bf8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 28 Feb 2025 09:55:55 +0100 Subject: [PATCH 038/256] code comment for clarity --- src/Modelling/PetriNet/Mistake.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 6511faf91..09d3a92ca 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -49,8 +49,8 @@ import Modelling.PetriNet.Pick ( pickGenerate, pickTaskInstance, renderPick, - wrong, - wrongInstances, + wrong, -- note that "wrong" in the context of the current module means + wrongInstances, -- "not having been infused with a mistake" ) import Modelling.PetriNet.Types ( BasicConfig (..), From 0f1eeb681f3b6399974992a6be5033598a5eeed2 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 2 Mar 2025 16:51:15 +0100 Subject: [PATCH 039/256] added MistakeSpec + added new type Mistake for parsing --- src/Modelling/PetriNet/Mistake.hs | 71 +++++++++++++++++-- src/Modelling/PetriNet/Types.hs | 6 +- test/Modelling/PetriNet/MistakeSpec.hs | 97 ++++++++++++++++++++++++++ 3 files changed, 166 insertions(+), 8 deletions(-) create mode 100644 test/Modelling/PetriNet/MistakeSpec.hs diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 09d3a92ca..78b21d616 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -5,9 +5,11 @@ {-# Language QuasiQuotes #-} module Modelling.PetriNet.Mistake ( + checkMistakeConfig, checkPickMistakeConfig, defaultPickMistakeInstance, mistakeConstraints, + parseMistake, petriNetPickMist, pickMistake, pickMistakeGenerate, @@ -28,6 +30,9 @@ import Capabilities.Alloy (MonadAlloy) import Capabilities.Cache (MonadCache) import Capabilities.Diagrams (MonadDiagrams) import Capabilities.Graphviz (MonadGraphviz) +import Modelling.Auxiliary.Common ( + Object + ) import Modelling.Auxiliary.Output ( hoveringInformation, ) @@ -41,7 +46,12 @@ import Modelling.PetriNet.Alloy ( modulePetriSignature, petriScopeBitWidth, petriScopeMaxSeq, + skolemVariable, taskInstance, + unscopedSingleSig, + ) +import Modelling.PetriNet.Parser ( + asSingleton, ) import Modelling.PetriNet.Pick ( PickInstance (..), @@ -57,6 +67,7 @@ import Modelling.PetriNet.Types ( ChangeConfig (..), DrawSettings (..), MistakeConfig (..), + Mistakes (Mistakes), Net (..), PetriLike (PetriLike, allNodes), PickMistakeConfig (..), @@ -80,8 +91,10 @@ import Control.Monad.Random ( RandomGen, ) import Data.GraphViz.Commands (GraphvizCommand (Fdp)) -import Data.Functor.Const (Const(..)) import Data.String.Interpolate (i, iii) +import Language.Alloy.Call ( + AlloyInstance, + ) pickMistakeGenerate :: (MonadAlloy m, MonadThrow m, Net p n) @@ -161,6 +174,7 @@ pickMistakeTask path task = do paragraph hoveringInformation pure () + pickMistake :: (MonadAlloy m, MonadThrow m, Net p n, RandomGen g) => PickMistakeConfig @@ -168,13 +182,14 @@ pickMistake -> RandT g m - [(p n String, Maybe (Const () String))] + [(p n String, Maybe (Mistakes String))] pickMistake = taskInstance pickTaskInstance petriNetPickMist - (\_ -> return (Const ())) + parseMistake Pick.alloyConfig + petriNetPickMist :: PickMistakeConfig -> String petriNetPickMist PickMistakeConfig{ basicConfig, @@ -186,6 +201,14 @@ petriNetPickMist PickMistakeConfig{ changeConfig mistakeConfig +parseMistake :: MonadThrow m => AlloyInstance -> m (Mistakes Object) +parseMistake inst = do + t1 <- unscopedSingleSig inst mistakeTransition1 "" + t2 <- unscopedSingleSig inst mistakeTransition2 "" + p1 <- unscopedSingleSig inst mistakePlace1 "" + p2 <- unscopedSingleSig inst mistakePlace2 "" + Mistakes <$> ((,,,) <$> asSingleton t1 <*> asSingleton t2 <*> asSingleton p1 <*> asSingleton p2) + {-| Generate code for PetriNet mistake tasks -} @@ -202,21 +225,57 @@ petriNetMistakeAlloy basicC changeC mistakeC #{modulePetriConcepts} #{modulePetriConstraints} -pred #{mistakePredicateName} { +pred #{mistakePredicateName} [#{t1}, #{t2} : Transitions, #{p1}, #{p2} : Places] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} #{compBasicConstraints False undefined basicC} #{mistakeConstraints mistakeC} #{compChange changeC} #{defaultConstraints undefined basicC} + + disj[#{t1}, #{t2}] + disj[#{p1}, #{p2}] + + some n1, n2 : Nodes | n1.flow[n2] < 0 + or some t1, t2 : Transitions | (some t1.flow[t2]) + or some p1, p2 : Places | (some p1.flow[p2]) } run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] + where + t1 = transition1 + t2 = transition2 + p1 = place1 + p2 = place2 mistakePredicateName :: String mistakePredicateName = "showMistake" +mistakeTransition1 :: String +mistakeTransition1 = skolemVariable mistakePredicateName transition1 + +mistakeTransition2 :: String +mistakeTransition2 = skolemVariable mistakePredicateName transition2 + +mistakePlace1 :: String +mistakePlace1 = skolemVariable mistakePredicateName place1 + +mistakePlace2 :: String +mistakePlace2 = skolemVariable mistakePredicateName place2 + +transition1 :: String +transition1 = "transition1" + +transition2 :: String +transition2 = "transition2" + +place1 :: String +place1 = "place1" + +place2 :: String +place2 = "place2" + mistakeConstraints :: MistakeConfig -> String mistakeConstraints MistakeConfig { canHaveNegativeTokenCost, canHaveTransitionToTransition, canHavePlaceToPlace @@ -273,10 +332,8 @@ checkMistakeConfig BasicConfig { = Just "At least two transitions are required for transition mistakes." | canHavePlaceToPlace && places < 2 = Just "At least two places are required for place mistakes." - | (canHaveTransitionToTransition || canHavePlaceToPlace) && flowChangeOverall < 1 + | flowChangeOverall < 1 = Just "flowChangeOverall must be at least 1 for mistakes." - | (canHaveTransitionToTransition && canHaveTransitionToTransition && canHavePlaceToPlace) && flowChangeOverall < 2 - = Just "flowChangeOverall must be greater than 1 for all mistakes." | maxFlowChangePerEdge < 1 = Just "maxFlowChangePerEdge must be at least 1 for mistakes to appear." | otherwise diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index a063fa3a4..6206c9b8e 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -35,6 +35,7 @@ module Modelling.PetriNet.Types ( GraphConfig (..), InvalidPetriNetException (..), MistakeConfig(..), + Mistakes (..), Net (..), Node (..), Petri (..), @@ -229,6 +230,9 @@ instance Bitraversable PetriConflict where newtype Concurrent a = Concurrent (a, a) deriving (Foldable, Functor, Generic, Read, Show, Traversable) +newtype Mistakes a = Mistakes (a, a, a, a) + deriving (Foldable, Functor, Generic, Read, Show, Traversable) + class Show (n String) => PetriNode n where initialTokens :: n a -> Int @@ -882,7 +886,7 @@ defaultPickConcurrencyConfig = PickConcurrencyConfig , printSolution = False , prohibitSourceTransitions = False , useDifferentGraphLayouts = False - , alloyConfig = defaultAlloyConfig + , alloyConfig = defaultAlloyConfig { timeout = Just 60000000 } } data PickMistakeConfig = PickMistakeConfig diff --git a/test/Modelling/PetriNet/MistakeSpec.hs b/test/Modelling/PetriNet/MistakeSpec.hs new file mode 100644 index 000000000..d8c444fad --- /dev/null +++ b/test/Modelling/PetriNet/MistakeSpec.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} +module Modelling.PetriNet.MistakeSpec where + +import qualified Modelling.PetriNet.Types as Pick ( + PickMistakeConfig (..), + ) + +import Modelling.PetriNet.Mistake ( + checkMistakeConfig, + checkPickMistakeConfig, + petriNetPickMist, + parseMistake, + pickMistake, + ) + +import Modelling.PetriNet.Pick ( + pickTaskInstance, + ) +import Modelling.PetriNet.Types ( + BasicConfig, + ChangeConfig, + MistakeConfig (..), + Mistakes (Mistakes), + PickMistakeConfig (..), + SimplePetriLike, + defaultPickMistakeConfig, + ) + +import Modelling.PetriNet.TestCommon ( + alloyTestConfig, + checkConfigs, + defaultConfigTaskGeneration, + firstInstanceConfig, + testTaskGeneration, + validConfigsForPick, + validGraphConfig, + ) +import Settings (configDepth, needsTuning) + +import Control.Lens.Lens ((??)) +import Data.Maybe (isNothing) +import Test.Hspec + +spec :: Spec +spec = do + describe "validPickMistakeConfigs" $ + checkConfigs checkPickMistakeConfig pickConfigs + describe "pickMistake" $ do + defaultConfigTaskGeneration + (pickMistake defaultPickMistakeConfig { + Pick.alloyConfig = firstInstanceConfig + } 0) + 0 + $ checkPickMistakeInstance @(SimplePetriLike _) + needsTuning $ + testPickMistakeConfig pickConfigs + where + pickConfigs = validPickMistakeConfigs validPicks + validPicks = validConfigsForPick 0 configDepth + +checkPickMistakeInstance :: [(a, Maybe (Mistakes String))] -> Bool +checkPickMistakeInstance = f . fmap snd + where + f [Just x, Nothing] = isValidMistake x + f _ = False + +testPickMistakeConfig :: [PickMistakeConfig] -> Spec +testPickMistakeConfig = testTaskGeneration + petriNetPickMist + (pickTaskInstance parseMistake) + $ checkPickMistakeInstance @(SimplePetriLike _) + +validMistakeConfigs :: BasicConfig -> ChangeConfig -> [MistakeConfig] +validMistakeConfigs bc ch = filter (isNothing.checkMistakeConfig bc ch) $ do + negative <- [False, True] + transitionToTransition <- [False, True] + placeToPlace <- [False, True] + [MistakeConfig negative transitionToTransition placeToPlace] + +validPickMistakeConfigs + :: [(BasicConfig, ChangeConfig)] + -> [PickMistakeConfig] +validPickMistakeConfigs cs = do + (bc, ch) <- cs + PickMistakeConfig bc ch + <$> validMistakeConfigs bc ch + <*> pure validGraphConfig + <*> pure False + ?? False + ?? alloyTestConfig + +isValidMistake :: Mistakes String -> Bool +isValidMistake m@(Mistakes (t1, t2, p1, p2)) + | ('t':x) <- t1, ('t':y) <- t2, x /= y = True + | ('p':x) <- p1, ('p':y) <- p2, x /= y = True + | otherwise = error $ show m From fd9e3be7b8539ea552e9c5ba4d33fbaf28d5710e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 3 Mar 2025 09:43:57 +0100 Subject: [PATCH 040/256] fix CI complaint --- modelling-tasks.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index 82c35bbfd..2653e88ea 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -190,6 +190,7 @@ test-suite modelling-tasks-test Modelling.PetriNet.ConflictSpec Modelling.PetriNet.DiagramSpec Modelling.PetriNet.MatchToMathSpec + Modelling.PetriNet.MistakeSpec Modelling.PetriNet.Reach.DeadlockSpec Modelling.PetriNet.Reach.ReachSpec Modelling.PetriNet.TestCommon From 922ca9b5198308e93ffc290e94ed02337fdd8594 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 3 Mar 2025 09:45:43 +0100 Subject: [PATCH 041/256] remove superfluous check if flowChangeOverall >= 1, checkChangeConfig already prevents maxFlowChangePerEdge < 1 --- src/Modelling/PetriNet/Mistake.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 78b21d616..576f9cb70 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -316,8 +316,7 @@ checkMistakeConfig BasicConfig { atLeastActive } ChangeConfig { - flowChangeOverall, - maxFlowChangePerEdge + flowChangeOverall } MistakeConfig { canHaveNegativeTokenCost, @@ -334,8 +333,6 @@ checkMistakeConfig BasicConfig { = Just "At least two places are required for place mistakes." | flowChangeOverall < 1 = Just "flowChangeOverall must be at least 1 for mistakes." - | maxFlowChangePerEdge < 1 - = Just "maxFlowChangePerEdge must be at least 1 for mistakes to appear." | otherwise = Nothing From a6f81ff4b0dd9dc3753b43b7c8e6cdd3fbafde1a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 3 Mar 2025 09:48:50 +0100 Subject: [PATCH 042/256] add config checker test on defaultPickMistakeConfig --- test/Modelling/PetriNet/MistakeSpec.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/Modelling/PetriNet/MistakeSpec.hs b/test/Modelling/PetriNet/MistakeSpec.hs index d8c444fad..d2637555b 100644 --- a/test/Modelling/PetriNet/MistakeSpec.hs +++ b/test/Modelling/PetriNet/MistakeSpec.hs @@ -44,6 +44,8 @@ import Test.Hspec spec :: Spec spec = do + describe "defaultPickMistakeConfig" $ + checkConfigs checkPickMistakeConfig [defaultPickMistakeConfig] describe "validPickMistakeConfigs" $ checkConfigs checkPickMistakeConfig pickConfigs describe "pickMistake" $ do From f8f38ab7a7ff99c35ae868cd246bb25e4d370995 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 3 Mar 2025 09:51:50 +0100 Subject: [PATCH 043/256] no parsing/checking of nodes from PickMistake task - partially reverts 0f1eeb681f3b6399974992a6be5033598a5eeed2 - the test code was only checking that the generated net has two different places and two different transitions (with no connection to actual mistakes infused) - see also https://fmidue.slack.com/archives/C084TAWR2AH/p1740648911453929 --- src/Modelling/PetriNet/Mistake.hs | 64 ++------------------------ src/Modelling/PetriNet/Types.hs | 4 -- test/Modelling/PetriNet/MistakeSpec.hs | 22 +++------ 3 files changed, 11 insertions(+), 79 deletions(-) diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 576f9cb70..33b57fe86 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -9,7 +9,6 @@ module Modelling.PetriNet.Mistake ( checkPickMistakeConfig, defaultPickMistakeInstance, mistakeConstraints, - parseMistake, petriNetPickMist, pickMistake, pickMistakeGenerate, @@ -30,9 +29,6 @@ import Capabilities.Alloy (MonadAlloy) import Capabilities.Cache (MonadCache) import Capabilities.Diagrams (MonadDiagrams) import Capabilities.Graphviz (MonadGraphviz) -import Modelling.Auxiliary.Common ( - Object - ) import Modelling.Auxiliary.Output ( hoveringInformation, ) @@ -46,12 +42,7 @@ import Modelling.PetriNet.Alloy ( modulePetriSignature, petriScopeBitWidth, petriScopeMaxSeq, - skolemVariable, taskInstance, - unscopedSingleSig, - ) -import Modelling.PetriNet.Parser ( - asSingleton, ) import Modelling.PetriNet.Pick ( PickInstance (..), @@ -67,7 +58,6 @@ import Modelling.PetriNet.Types ( ChangeConfig (..), DrawSettings (..), MistakeConfig (..), - Mistakes (Mistakes), Net (..), PetriLike (PetriLike, allNodes), PickMistakeConfig (..), @@ -91,10 +81,8 @@ import Control.Monad.Random ( RandomGen, ) import Data.GraphViz.Commands (GraphvizCommand (Fdp)) +import Data.Functor.Const (Const(..)) import Data.String.Interpolate (i, iii) -import Language.Alloy.Call ( - AlloyInstance, - ) pickMistakeGenerate :: (MonadAlloy m, MonadThrow m, Net p n) @@ -182,11 +170,11 @@ pickMistake -> RandT g m - [(p n String, Maybe (Mistakes String))] + [(p n String, Maybe (Const () String))] pickMistake = taskInstance pickTaskInstance petriNetPickMist - parseMistake + (\_ -> return (Const ())) Pick.alloyConfig @@ -201,14 +189,6 @@ petriNetPickMist PickMistakeConfig{ changeConfig mistakeConfig -parseMistake :: MonadThrow m => AlloyInstance -> m (Mistakes Object) -parseMistake inst = do - t1 <- unscopedSingleSig inst mistakeTransition1 "" - t2 <- unscopedSingleSig inst mistakeTransition2 "" - p1 <- unscopedSingleSig inst mistakePlace1 "" - p2 <- unscopedSingleSig inst mistakePlace2 "" - Mistakes <$> ((,,,) <$> asSingleton t1 <*> asSingleton t2 <*> asSingleton p1 <*> asSingleton p2) - {-| Generate code for PetriNet mistake tasks -} @@ -225,57 +205,21 @@ petriNetMistakeAlloy basicC changeC mistakeC #{modulePetriConcepts} #{modulePetriConstraints} -pred #{mistakePredicateName} [#{t1}, #{t2} : Transitions, #{p1}, #{p2} : Places] { +pred #{mistakePredicateName} { \#Places = #{places basicC} \#Transitions = #{transitions basicC} #{compBasicConstraints False undefined basicC} #{mistakeConstraints mistakeC} #{compChange changeC} #{defaultConstraints undefined basicC} - - disj[#{t1}, #{t2}] - disj[#{p1}, #{p2}] - - some n1, n2 : Nodes | n1.flow[n2] < 0 - or some t1, t2 : Transitions | (some t1.flow[t2]) - or some p1, p2 : Places | (some p1.flow[p2]) } run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] - where - t1 = transition1 - t2 = transition2 - p1 = place1 - p2 = place2 mistakePredicateName :: String mistakePredicateName = "showMistake" -mistakeTransition1 :: String -mistakeTransition1 = skolemVariable mistakePredicateName transition1 - -mistakeTransition2 :: String -mistakeTransition2 = skolemVariable mistakePredicateName transition2 - -mistakePlace1 :: String -mistakePlace1 = skolemVariable mistakePredicateName place1 - -mistakePlace2 :: String -mistakePlace2 = skolemVariable mistakePredicateName place2 - -transition1 :: String -transition1 = "transition1" - -transition2 :: String -transition2 = "transition2" - -place1 :: String -place1 = "place1" - -place2 :: String -place2 = "place2" - mistakeConstraints :: MistakeConfig -> String mistakeConstraints MistakeConfig { canHaveNegativeTokenCost, canHaveTransitionToTransition, canHavePlaceToPlace diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 6206c9b8e..f7893e40e 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -35,7 +35,6 @@ module Modelling.PetriNet.Types ( GraphConfig (..), InvalidPetriNetException (..), MistakeConfig(..), - Mistakes (..), Net (..), Node (..), Petri (..), @@ -230,9 +229,6 @@ instance Bitraversable PetriConflict where newtype Concurrent a = Concurrent (a, a) deriving (Foldable, Functor, Generic, Read, Show, Traversable) -newtype Mistakes a = Mistakes (a, a, a, a) - deriving (Foldable, Functor, Generic, Read, Show, Traversable) - class Show (n String) => PetriNode n where initialTokens :: n a -> Int diff --git a/test/Modelling/PetriNet/MistakeSpec.hs b/test/Modelling/PetriNet/MistakeSpec.hs index d2637555b..680c3107f 100644 --- a/test/Modelling/PetriNet/MistakeSpec.hs +++ b/test/Modelling/PetriNet/MistakeSpec.hs @@ -10,7 +10,6 @@ import Modelling.PetriNet.Mistake ( checkMistakeConfig, checkPickMistakeConfig, petriNetPickMist, - parseMistake, pickMistake, ) @@ -21,7 +20,6 @@ import Modelling.PetriNet.Types ( BasicConfig, ChangeConfig, MistakeConfig (..), - Mistakes (Mistakes), PickMistakeConfig (..), SimplePetriLike, defaultPickMistakeConfig, @@ -36,9 +34,10 @@ import Modelling.PetriNet.TestCommon ( validConfigsForPick, validGraphConfig, ) -import Settings (configDepth, needsTuning) +import Settings (configDepth) import Control.Lens.Lens ((??)) +import Data.Functor.Const (Const(..)) import Data.Maybe (isNothing) import Test.Hspec @@ -55,22 +54,21 @@ spec = do } 0) 0 $ checkPickMistakeInstance @(SimplePetriLike _) - needsTuning $ - testPickMistakeConfig pickConfigs + testPickMistakeConfig pickConfigs where pickConfigs = validPickMistakeConfigs validPicks validPicks = validConfigsForPick 0 configDepth -checkPickMistakeInstance :: [(a, Maybe (Mistakes String))] -> Bool +checkPickMistakeInstance :: [(a, Maybe (Const () String))] -> Bool checkPickMistakeInstance = f . fmap snd where - f [Just x, Nothing] = isValidMistake x - f _ = False + f [Just (Const ()), Nothing] = True + f _ = False testPickMistakeConfig :: [PickMistakeConfig] -> Spec testPickMistakeConfig = testTaskGeneration petriNetPickMist - (pickTaskInstance parseMistake) + (pickTaskInstance (const (return (Const ())))) $ checkPickMistakeInstance @(SimplePetriLike _) validMistakeConfigs :: BasicConfig -> ChangeConfig -> [MistakeConfig] @@ -91,9 +89,3 @@ validPickMistakeConfigs cs = do <*> pure False ?? False ?? alloyTestConfig - -isValidMistake :: Mistakes String -> Bool -isValidMistake m@(Mistakes (t1, t2, p1, p2)) - | ('t':x) <- t1, ('t':y) <- t2, x /= y = True - | ('p':x) <- p1, ('p':y) <- p2, x /= y = True - | otherwise = error $ show m From ce1a7b7303d8bc5a8c37f4a7a3c3df38cce305d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 3 Mar 2025 09:52:07 +0100 Subject: [PATCH 044/256] code cosmetics --- test/Modelling/PetriNet/MistakeSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Modelling/PetriNet/MistakeSpec.hs b/test/Modelling/PetriNet/MistakeSpec.hs index 680c3107f..42bc4882e 100644 --- a/test/Modelling/PetriNet/MistakeSpec.hs +++ b/test/Modelling/PetriNet/MistakeSpec.hs @@ -72,7 +72,7 @@ testPickMistakeConfig = testTaskGeneration $ checkPickMistakeInstance @(SimplePetriLike _) validMistakeConfigs :: BasicConfig -> ChangeConfig -> [MistakeConfig] -validMistakeConfigs bc ch = filter (isNothing.checkMistakeConfig bc ch) $ do +validMistakeConfigs bc ch = filter (isNothing . checkMistakeConfig bc ch) $ do negative <- [False, True] transitionToTransition <- [False, True] placeToPlace <- [False, True] From d115bb970f0fd46c9272bedc4f4e45234c202805 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 3 Mar 2025 10:30:41 +0100 Subject: [PATCH 045/256] rename canHaveNegativeTokenCost to canHaveNegativeWeight naming it "token cost" doesn't make much sense on an arrow from a transition to a place (where it isn't "costing" tokens, instead providing new tokens) --- app/mistake.hs | 4 ++-- src/Modelling/PetriNet/Mistake.hs | 8 ++++---- src/Modelling/PetriNet/Types.hs | 4 ++-- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/app/mistake.hs b/app/mistake.hs index 9c5c10c4c..7a2d91ee5 100644 --- a/app/mistake.hs +++ b/app/mistake.hs @@ -59,7 +59,7 @@ mainPick i = forceErrors $ do flowChangeOverall = flwChange }, mistakeConfig = mistakeConfig { - canHaveNegativeTokenCost = negTokCost, + canHaveNegativeWeight = negTokCost, canHaveTransitionToTransition = transToTr, canHavePlaceToPlace = placeToPl } @@ -105,7 +105,7 @@ userInput PickMistakeConfig{basicConfig = BasicConfig{..}, changeConfig = Change putStr "FlowChange Overall: " flwCh <- intInput flowChangeOverall putStr "Negative Token Cost (True/False): " - negTokCost <- boolInput canHaveNegativeTokenCost + negTokCost <- boolInput canHaveNegativeWeight putStr "Transition to Transition (True/False): " transToTr <- boolInput canHaveTransitionToTransition putStr "Places to Places (True/False): " diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/Mistake.hs index 33b57fe86..e4e96ae7e 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/Mistake.hs @@ -222,11 +222,11 @@ mistakePredicateName = "showMistake" mistakeConstraints :: MistakeConfig -> String mistakeConstraints MistakeConfig - { canHaveNegativeTokenCost, canHaveTransitionToTransition, canHavePlaceToPlace + { canHaveNegativeWeight, canHaveTransitionToTransition, canHavePlaceToPlace } = falseInput where input :: [(Bool, String)] - input = [(canHaveNegativeTokenCost, "all w : Nodes.flow[Nodes] | w > 0"), + input = [(canHaveNegativeWeight, "all w : Nodes.flow[Nodes] | w > 0"), (canHaveTransitionToTransition, "Transitions.flow.Int in Places"), (canHavePlaceToPlace, "Places.flow.Int in Transitions")] falseMistakes = map snd (filter (not . fst) input) @@ -263,11 +263,11 @@ checkMistakeConfig BasicConfig { flowChangeOverall } MistakeConfig { - canHaveNegativeTokenCost, + canHaveNegativeWeight, canHaveTransitionToTransition, canHavePlaceToPlace } - | not (canHaveNegativeTokenCost || canHaveTransitionToTransition || canHavePlaceToPlace) + | not (canHaveNegativeWeight || canHaveTransitionToTransition || canHavePlaceToPlace) = Just "At least one mistake must be enabled." | atLeastActive /= 0 = Just "atLeastActive has to be 0 in this task type." diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index f7893e40e..39e751c94 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -907,14 +907,14 @@ defaultPickMistakeConfig = PickMistakeConfig } data MistakeConfig = MistakeConfig - { canHaveNegativeTokenCost :: Bool + { canHaveNegativeWeight :: Bool , canHaveTransitionToTransition :: Bool , canHavePlaceToPlace :: Bool } deriving (Generic, Read, Show) defaultMistakeConfig :: MistakeConfig defaultMistakeConfig = MistakeConfig - { canHaveNegativeTokenCost = True + { canHaveNegativeWeight = True , canHaveTransitionToTransition = True , canHavePlaceToPlace = True } From 160bc2386723f4a60107a5e369be39899cee5bbe Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 6 Mar 2025 11:15:21 +0100 Subject: [PATCH 046/256] added new task type activeTransition --- modelling-tasks.cabal | 1 + src/Modelling/PetriNet/ActiveTransition.hs | 393 +++++++++++++++++++++ 2 files changed, 394 insertions(+) create mode 100644 src/Modelling/PetriNet/ActiveTransition.hs diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index 2653e88ea..5b4024c93 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -101,6 +101,7 @@ library Modelling.CdOd.Phrasing Modelling.CdOd.Phrasing.English Modelling.CdOd.Phrasing.German + Modelling.PetriNet.ActiveTransition Modelling.PetriNet.Reach.Draw Modelling.PetriNet.Reach.Roll Paths_modelling_tasks diff --git a/src/Modelling/PetriNet/ActiveTransition.hs b/src/Modelling/PetriNet/ActiveTransition.hs new file mode 100644 index 000000000..35498c2a6 --- /dev/null +++ b/src/Modelling/PetriNet/ActiveTransition.hs @@ -0,0 +1,393 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE LambdaCase #-} + +module Modelling.PetriNet.ActiveTransition ( + checkActiveTransitionConfig, + checkFindActiveTransitionConfig, + defaultFindActiveTransitionInstance, + findActiveTransition, + findActiveTransitionEvaluation, + findActiveTransitionGenerate, + findActiveTransitionSolution, + findActiveTransitionTask, + parseActiveTransition, + petriNetFindActive, + simpleFindActiveTransitionTask, + ) where + +import qualified Modelling.PetriNet.Find as F (showSolution) +import qualified Modelling.PetriNet.Types as Find ( + FindActiveTransitionConfig (..), + ) +import qualified Data.Map as M ( + empty, + fromList, + ) +import qualified Data.Set as Set ( + toList, + ) + +import Capabilities.Alloy (MonadAlloy) +import Capabilities.Cache (MonadCache) +import Capabilities.Diagrams (MonadDiagrams) +import Capabilities.Graphviz (MonadGraphviz) +import Modelling.Auxiliary.Common ( + Object, + oneOf, + parseWith, + ) +import Modelling.Auxiliary.Output ( + hoveringInformation, + ) +import Modelling.PetriNet.Alloy ( + compAdvConstraints, + compBasicConstraints, + compChange, + defaultConstraints, + moduleHelpers, + modulePetriAdditions, + modulePetriConcepts, + modulePetriConstraints, + modulePetriSignature, + petriScopeBitWidth, + petriScopeMaxSeq, + signatures, + skolemVariable, + taskInstance, + unscopedSingleSig, + ) +import Modelling.PetriNet.Diagram ( + renderWith, + ) +import Modelling.PetriNet.Find ( + FindInstance (..), + checkConfigForFind, + findInitialList, + findTaskInstance, + toFindEvaluationList, + ) +import Modelling.PetriNet.Reach.Type ( + Transition (Transition), + parseTransitionPrec, + ) +import Modelling.PetriNet.Types ( + ActiveTransition (ActiveTransition), + AdvConfig, + BasicConfig (..), + ChangeConfig (..), + ActiveTransitionConfig (..), + DrawSettings (..), + FindActiveTransitionConfig (..), + GraphConfig (..), + Net, + PetriLike (PetriLike, allNodes), + SimpleNode (..), + SimplePetriNet, + transitionListShow, + ) + +import Control.Applicative ((<|>)) +import Control.Monad.Catch (MonadThrow) +import Control.OutputCapable.Blocks ( + ArticleToUse (DefiniteArticle), + GenericOutputCapable (..), + LangM, + OutputCapable, + Rated, + ($=<<), + english, + german, + printSolutionAndAssert, + translate, + translations, + unLangM + ) +import Control.Monad.Random ( + RandT, + RandomGen, + evalRandT, + mkStdGen + ) +import Control.Monad.Trans (MonadTrans (lift)) +import Data.Either (isLeft) +import Data.GraphViz.Commands (GraphvizCommand (Circo)) +import Data.String.Interpolate (i, iii) +import Language.Alloy.Call ( + AlloyInstance + ) + +findActiveTransitionGenerate + :: (MonadAlloy m, MonadThrow m, Net p n) + => FindActiveTransitionConfig + -> Int + -> Int + -> m (FindInstance (p n String) (ActiveTransition Transition)) +findActiveTransitionGenerate config segment seed = flip evalRandT (mkStdGen seed) $ do + (d, c) <- findActiveTransition config segment + gl <- oneOf $ graphLayouts gc + c' <- lift $ traverse + (parseWith parseTransitionPrec) + c + return $ FindInstance { + drawFindWith = DrawSettings { + withPlaceNames = not $ hidePlaceNames gc, + withSvgHighlighting = True, + withTransitionNames = not $ hideTransitionNames gc, + with1Weights = not $ hideWeight1 gc, + withGraphvizCommand = gl + }, + toFind = c', + net = d, + numberOfPlaces = places bc, + numberOfTransitions = transitions bc, + showSolution = Find.printSolution config + } + where + bc = Find.basicConfig config + gc = Find.graphConfig config + +simpleFindActiveTransitionTask + :: ( + MonadCache m, + MonadDiagrams m, + MonadGraphviz m, + MonadThrow m, + OutputCapable m + ) + => FilePath + -> FindInstance SimplePetriNet (ActiveTransition Transition) + -> LangM m +simpleFindActiveTransitionTask = findActiveTransitionTask + +findActiveTransitionTask + :: ( + MonadCache m, + MonadDiagrams m, + MonadGraphviz m, + MonadThrow m, + Net p n, + OutputCapable m + ) + => FilePath + -> FindInstance (p n String) (ActiveTransition Transition) + -> LangM m +findActiveTransitionTask path task = do + paragraph $ translate $ do + english "Consider the following Petri net:" + german "Betrachten Sie folgendes Petrinetz:" + image + $=<< renderWith path "activeTransition" (net task) (drawFindWith task) + paragraph $ translate $ do + english [iii| + Which transitions are activated + under the initial marking? + |] + german [iii| + Welche Transitionen sind unter der Startmarkierung aktiviert? + |] + paragraph $ do + translate $ do + english [iii| + State your answer by giving a list of activated transitions. + #{" "}|] + german [iii| + Geben Sie Ihre Antwort durch Angabe einer Liste + von aktivierten Transitionen an. + #{" "}|] + translate $ do + english [i|Stating |] + german [i|Die Angabe von |] + let ts = transitionListShow findInitialList + code $ show ts + translate $ do + let ta = map show findInitialList + english [iii| + #{" "}as answer would indicate that transitions #{ta} + are activated under the initial marking. + #{" "}|] + german [iii| + #{" "}als Antwort würde bedeuten, dass Transitionen #{ta} + unter der Startmarkierung aktiviert sind. + #{" "}|] + translate $ do + english "The order of transitions within the pair does not matter here." + german [iii| + Die Reihenfolge der Transitionen innerhalb + des Paars spielt hierbei keine Rolle. + |] + + pure () + paragraph hoveringInformation + pure () + +findActiveTransitionEvaluation + :: (Monad m, OutputCapable m) + => FindInstance net (ActiveTransition Transition) + -> [Transition] + -> Rated m +findActiveTransitionEvaluation task x = do + let what = translations $ do + english "are activated" + german "sind aktiviert" + uncurry (printSolutionAndAssert DefiniteArticle) + $=<< unLangM $ toFindEvaluationList what withSol active x + where + active = findActiveTransitionSolution task + withSol = F.showSolution task + +findActiveTransitionSolution :: FindInstance net (ActiveTransition a) -> [a] +findActiveTransitionSolution task = active + where + ActiveTransition active = toFind task + +findActiveTransition + :: (MonadAlloy m, MonadThrow m, Net p n, RandomGen g) + => FindActiveTransitionConfig + -> Int + -> RandT + g + m + (p n String, ActiveTransition String) +findActiveTransition = taskInstance + findTaskInstance + petriNetFindActive + parseActiveTransition + Find.alloyConfig + +petriNetFindActive :: FindActiveTransitionConfig -> String +petriNetFindActive FindActiveTransitionConfig { + basicConfig, + advConfig, + changeConfig, + activeTransitionConfig + } + = petriNetActiveTransitionAlloy + basicConfig + changeConfig + activeTransitionConfig + $ Right advConfig + +parseActiveTransition :: MonadThrow m => AlloyInstance -> m (ActiveTransition Object) +parseActiveTransition inst = do + t <- unscopedSingleSig inst activeTransition1 "" + pure $ ActiveTransition (Set.toList t) + +petriNetActiveTransitionAlloy + :: BasicConfig + -> ChangeConfig + -> ActiveTransitionConfig + -> Either Bool AdvConfig + -- ^ Right for find task; Left for pick task + -> String +petriNetActiveTransitionAlloy basicC changeC activeC specific + = [i|module PetriNetActiveTransition + +#{modulePetriSignature} +#{either (const sigs) (const modulePetriAdditions) specific} +#{moduleHelpers} +#{modulePetriConcepts} +#{modulePetriConstraints} + +pred #{activePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions] { + \#Places = #{places basicC} + \#Transitions = #{transitions basicC} + #{compBasicConstraints True activated basicC} + #{compChange changeC} + #{sourceTransitionConstraints} + #{compConstraints} + + no t : givenTransitions | activatedDefault[t] + #{maxActivatedTrans activeC} +} + +run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int +|] + where + activated = "activatedTrans" + activatedDefault = "defaultActiveTrans" + compConstraints = either + (const $ defaultConstraints activatedDefault basicC) + compAdvConstraints + specific + sourceTransitionConstraints + | Left True <- specific = [i| + no t : givenTransitions | no givenPlaces.flow[t] + no t : Transitions | sourceTransitions[t]|] + | otherwise = "" + defaultActiveTrans + | isLeft specific = [i|#{activatedDefault} : set givenTransitions,|] + | otherwise = "" + maxActivatedTrans :: ActiveTransitionConfig -> String + maxActivatedTrans ActiveTransitionConfig {atMostActive} + = "#" ++ [i|#{activated} <= #{atMostActive}|] + + sigs = signatures "given" (places basicC) (transitions basicC) + +activePredicateName :: String +activePredicateName = "showActiveTransition" + +activeTransition1 :: String +activeTransition1 = skolemVariable activePredicateName transition1 + +transition1 :: String +transition1 = "activatedTrans" + +checkFindActiveTransitionConfig :: FindActiveTransitionConfig -> Maybe String +checkFindActiveTransitionConfig FindActiveTransitionConfig { + basicConfig, + changeConfig, + activeTransitionConfig, + graphConfig + } + = checkConfigForFind basicConfig changeConfig graphConfig + <|> checkActiveTransitionConfig basicConfig changeConfig activeTransitionConfig + +checkActiveTransitionConfig :: BasicConfig -> ChangeConfig -> ActiveTransitionConfig -> Maybe String +checkActiveTransitionConfig BasicConfig { + transitions, + atLeastActive + } + ChangeConfig { + + } + ActiveTransitionConfig { + atMostActive + } + | atLeastActive >= atMostActive + = Just "atLeastActive must be less than atMostActive." + | transitions <= atLeastActive + = Just "There must be at least as many transitions as atLeastActive." + | transitions <= atMostActive + = Just "There must be at least as many transitions as atMostActive." + | otherwise + = Nothing + +defaultFindActiveTransitionInstance :: FindInstance SimplePetriNet (ActiveTransition Transition) +defaultFindActiveTransitionInstance = FindInstance { + drawFindWith = DrawSettings { + withPlaceNames = False, + withSvgHighlighting = True, + withTransitionNames = True, + with1Weights = False, + withGraphvizCommand = Circo + }, + toFind = ActiveTransition [Transition 1, Transition 2], + net = PetriLike { + allNodes = M.fromList [ + ("s1",SimplePlace {initial = 2, flowOut = M.fromList [("t1",1),("t2",1)]}), + ("s2",SimplePlace {initial = 0, flowOut = M.empty}), + ("s3",SimplePlace {initial = 0, flowOut = M.empty}), + ("s4",SimplePlace {initial = 1, flowOut = M.fromList [("t1",1),("t3",2)]}), + ("t1",SimpleTransition {flowOut = M.fromList [("s2",2),("s3",2)]}), + ("t2",SimpleTransition {flowOut = M.fromList [("s3",1)]}), + ("t3",SimpleTransition {flowOut = M.fromList [("s3",1)]}) + ] + }, + numberOfPlaces = 4, + numberOfTransitions = 3, + showSolution = False + } From 364018194eefac4f46cd2af4265235c2edbca956 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 6 Mar 2025 11:20:32 +0100 Subject: [PATCH 047/256] added new functions for a list instead of a tuple --- src/Modelling/PetriNet/Concurrency.hs | 8 ++--- src/Modelling/PetriNet/Conflict.hs | 8 ++--- src/Modelling/PetriNet/ConflictPlaces.hs | 4 +-- src/Modelling/PetriNet/Find.hs | 41 ++++++++++++++++++++---- 4 files changed, 45 insertions(+), 16 deletions(-) diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index f24e69825..784546c2b 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -73,9 +73,9 @@ import Modelling.PetriNet.Diagram ( import Modelling.PetriNet.Find ( FindInstance (..), checkConfigForFind, - findInitial, + findInitialTuple, findTaskInstance, - toFindEvaluation, + toFindEvaluationTuple, toFindSyntax, ) import Modelling.PetriNet.Parser ( @@ -194,7 +194,7 @@ findConcurrencyTask path task = do translate $ do english [i|Stating |] german [i|Die Angabe von |] - let ts = transitionPairShow findInitial + let ts = transitionPairShow findInitialTuple code $ show ts translate $ do let (t1, t2) = bimap show show ts @@ -234,7 +234,7 @@ findConcurrencyEvaluation task x = do english "are concurrently activated" german "sind nebenläufig aktiviert" uncurry (printSolutionAndAssert DefiniteArticle) - $=<< unLangM $ toFindEvaluation what withSol concur x + $=<< unLangM $ toFindEvaluationTuple what withSol concur x where concur = findConcurrencySolution task withSol = F.showSolution task diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index fbef98fbe..a4a162deb 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -82,10 +82,10 @@ import Modelling.PetriNet.Diagram ( import Modelling.PetriNet.Find ( FindInstance (..), checkConfigForFind, - findInitial, + findInitialTuple, findTaskInstance, lToFind, - toFindEvaluation, + toFindEvaluationTuple, toFindSyntax, ) import Modelling.PetriNet.Parser ( @@ -213,7 +213,7 @@ findConflictTask path task = do translate $ do english [i|Stating |] german [i|Die Angabe von |] - let ts = transitionPairShow findInitial + let ts = transitionPairShow findInitialTuple code $ show ts translate $ do let (t1, t2) = bimap show show ts @@ -260,7 +260,7 @@ findConflictPlacesEvaluation -> ConflictPlaces -> Rated m findConflictPlacesEvaluation task (conflict, ps) = - toFindEvaluation what withSol conf conflict $>>= \(ms, res) -> do + toFindEvaluationTuple what withSol conf conflict $>>= \(ms, res) -> do recoverFrom $ unless (null inducing || res == 0) $ do for_ ps' $ \x -> assert (x `elem` inducing) $ translate $ do let x' = show $ ShowPlace x diff --git a/src/Modelling/PetriNet/ConflictPlaces.hs b/src/Modelling/PetriNet/ConflictPlaces.hs index 5bcb805bb..6f5656a09 100644 --- a/src/Modelling/PetriNet/ConflictPlaces.hs +++ b/src/Modelling/PetriNet/ConflictPlaces.hs @@ -34,7 +34,7 @@ import Modelling.PetriNet.Find ( FindInstance (..), checkConfigForFind, drawFindWith, - findInitial, + findInitialTuple, ) import Modelling.PetriNet.Diagram ( renderWith, @@ -153,7 +153,7 @@ Die Reihenfolge von Stellen innerhalb der Auflistung der den Konflikt verursache pure () conflictInitial :: ConflictPlaces -conflictInitial = (findInitial, [Place 0, Place 1]) +conflictInitial = (findInitialTuple, [Place 0, Place 1]) findConflictPlacesSyntax :: OutputCapable m diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 9154bae87..9869d805f 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -12,10 +12,12 @@ module Modelling.PetriNet.Find ( FindInstance (..), checkFindBasicConfig, checkConfigForFind, - findInitial, + findInitialList, + findInitialTuple, findTaskInstance, lToFind, - toFindEvaluation, + toFindEvaluationList, + toFindEvaluationTuple, toFindSyntax, ) where @@ -62,6 +64,7 @@ import Control.Monad.Random ( RandomGen, ) import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.List (sort) import Data.Map (Map) import Language.Alloy.Call ( AlloyInstance, @@ -80,8 +83,11 @@ data FindInstance n a = FindInstance { makeLensesFor [("toFind", "lToFind")] ''FindInstance -findInitial :: (Transition, Transition) -findInitial = (Transition 0, Transition 1) +findInitialTuple :: (Transition, Transition) +findInitialTuple = (Transition 0, Transition 1) + +findInitialList :: [Transition] +findInitialList = [Transition 0, Transition 1] toFindSyntax :: OutputCapable m @@ -112,14 +118,14 @@ findTaskInstance f inst = do t' <- lift $ (`BM.lookup` mapping) `mapM` t return (pl', t') -toFindEvaluation +toFindEvaluationTuple :: (Num a, OutputCapable m) => Map Language String -> Bool -> (Transition, Transition) -> (Transition, Transition) -> LangM' m (Maybe String, a) -toFindEvaluation what withSol (ft, st) (fi, si) = do +toFindEvaluationTuple what withSol (ft, st) (fi, si) = do let correct = ft == fi && st == si || ft == si && st == fi points = if correct then 1 else 0 maybeSolutionString = @@ -133,6 +139,29 @@ toFindEvaluation what withSol (ft, st) (fi, si) = do where assert = continueOrAbort withSol +toFindEvaluationList + :: (Num a, OutputCapable m) + => Map Language String + -> Bool + -> [Transition] + -> [Transition] + -> LangM' m (Maybe String, a) +toFindEvaluationList what withSol correctTransitions inputTransitions = do + let correct = (sortCorrect correctTransitions == sortCorrect inputTransitions) + points = if correct then 1 else 0 + maybeSolutionString = + if withSol + then Just $ show $ transitionListShow (correctTransitions) + else Nothing + assert correct $ translate $ do + english $ "The given transitions " ++ localise English what ++ "?" + german $ "Die angegebenen Transitionen " ++ localise German what ++ "?" + pure (maybeSolutionString, points) + where + assert = continueOrAbort withSol + sortCorrect :: Ord a => [a] -> [a] + sortCorrect = sort + checkFindBasicConfig :: BasicConfig -> Maybe String checkFindBasicConfig BasicConfig { atLeastActive } | atLeastActive < 2 From 99fd73edbcc236306facdcbd5fe2bec1491bb4e8 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 6 Mar 2025 11:21:57 +0100 Subject: [PATCH 048/256] added new type config --- src/Modelling/PetriNet/Find.hs | 1 + src/Modelling/PetriNet/Types.hs | 44 ++++++++++++++++++++++++++++++++- 2 files changed, 44 insertions(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 9869d805f..704f31adf 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -43,6 +43,7 @@ import Modelling.PetriNet.Types ( checkBasicConfig, checkChangeConfig, shuffleNames, + transitionListShow, transitionPairShow, ) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 39e751c94..e61c3c729 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -19,6 +19,8 @@ The 'Modelling.PetriNet.Types' module defines basic type class instances and functions to work on and transform Petri net representations. -} module Modelling.PetriNet.Types ( + ActiveTransition (ActiveTransition), + ActiveTransitionConfig (..), AdvConfig (..), AlloyConfig (..), BasicConfig (..), @@ -29,6 +31,7 @@ module Modelling.PetriNet.Types ( ConflictConfig (..), Drawable, DrawSettings (..), + FindActiveTransitionConfig (..), FindConcurrencyConfig (..), FindConflictConfig (..), PickMistakeConfig (..), @@ -56,6 +59,7 @@ module Modelling.PetriNet.Types ( defaultAlloyConfig, defaultBasicConfig, defaultChangeConfig, + defaultFindActiveTransitionConfig, defaultFindConcurrencyConfig, defaultFindConflictConfig, defaultPickMistakeConfig, @@ -93,6 +97,7 @@ module Modelling.PetriNet.Types ( randomDrawSettings, shuffleNames, transformNet, + transitionListShow, transitionNames, transitionPairShow, ) where @@ -229,6 +234,9 @@ instance Bitraversable PetriConflict where newtype Concurrent a = Concurrent (a, a) deriving (Foldable, Functor, Generic, Read, Show, Traversable) +newtype ActiveTransition a = ActiveTransition [a] + deriving (Functor, Foldable, Traversable, Generic, Read, Show) + class Show (n String) => PetriNode n where initialTokens :: n a -> Int @@ -857,7 +865,7 @@ data FindConcurrencyConfig = FindConcurrencyConfig defaultFindConcurrencyConfig :: FindConcurrencyConfig defaultFindConcurrencyConfig = FindConcurrencyConfig { basicConfig = defaultBasicConfig { atLeastActive = 3 } - , advConfig = defaultAdvConfig{ presenceOfSourceTransitions = Nothing } + , advConfig = defaultAdvConfig { presenceOfSourceTransitions = Nothing } , changeConfig = defaultChangeConfig , graphConfig = defaultGraphConfig { hidePlaceNames = True } , printSolution = False @@ -919,6 +927,37 @@ defaultMistakeConfig = MistakeConfig , canHavePlaceToPlace = True } +data FindActiveTransitionConfig = FindActiveTransitionConfig + { basicConfig :: BasicConfig + , advConfig :: AdvConfig + , changeConfig :: ChangeConfig + , activeTransitionConfig :: ActiveTransitionConfig + , graphConfig :: GraphConfig + , printSolution :: Bool + , alloyConfig :: AlloyConfig + } deriving (Generic, Read, Show) + + +defaultFindActiveTransitionConfig :: FindActiveTransitionConfig +defaultFindActiveTransitionConfig = FindActiveTransitionConfig + { basicConfig = defaultBasicConfig { atLeastActive = 0 } + , advConfig = defaultAdvConfig + , changeConfig = defaultChangeConfig + , activeTransitionConfig = defaultActiveTransitionConfig { atMostActive = 3 } + , graphConfig = defaultGraphConfig { hidePlaceNames = True } + , printSolution = True + , alloyConfig = defaultAlloyConfig + } + +data ActiveTransitionConfig = ActiveTransitionConfig + { atMostActive :: Int + } deriving (Generic, Read, Show) + +defaultActiveTransitionConfig :: ActiveTransitionConfig +defaultActiveTransitionConfig = ActiveTransitionConfig + { atMostActive = 2 + } + data DrawSettings = DrawSettings { withPlaceNames :: Bool, withSvgHighlighting :: Bool, @@ -966,6 +1005,9 @@ transitionPairShow -> (ShowTransition, ShowTransition) transitionPairShow = bimap ShowTransition ShowTransition +transitionListShow :: [Petri.Transition] -> [ShowTransition] +transitionListShow = map ShowTransition + checkBasicConfig :: BasicConfig -> Maybe String checkBasicConfig BasicConfig{ atLeastActive, From cf02a34cad1551cf4fe16348c7bff42df40bed06 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 6 Mar 2025 23:10:51 +0100 Subject: [PATCH 049/256] added app for findActivatedTransitions --- app/findActivatedTransitions.hs | 86 +++++++++++++++++++++++++++++++++ app/package.yaml | 13 +++++ 2 files changed, 99 insertions(+) create mode 100644 app/findActivatedTransitions.hs diff --git a/app/findActivatedTransitions.hs b/app/findActivatedTransitions.hs new file mode 100644 index 000000000..d579ef838 --- /dev/null +++ b/app/findActivatedTransitions.hs @@ -0,0 +1,86 @@ +{-# Language DuplicateRecordFields #-} +{-# Language RecordWildCards #-} + +module Main (main) where + + +import qualified Modelling.PetriNet.Types as Find ( + FindActivatedTransitionsConfig (..), + ) + +import Capabilities.Alloy.IO () +import Capabilities.Cache.IO () +import Capabilities.Diagrams.IO () +import Capabilities.Graphviz.IO () +import Common ( + forceErrors, + instanceInput, + withLang, + ) +import Modelling.PetriNet.FindActivatedTransitions ( + checkFindActivatedTransitionsConfig, + findActivatedTransitionsGenerate, + simpleFindActivatedTransitionsTask, + ) +import Modelling.PetriNet.Types ( + BasicConfig(..), + ChangeConfig(..), + FindActivatedTransitionsConfig(..), + defaultFindActivatedTransitionsConfig, + ) + +import Control.OutputCapable.Blocks (Language (English)) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Maybe (isNothing) +import System.IO ( + BufferMode (NoBuffering), hSetBuffering, stdout, + ) +import Text.Pretty.Simple (pPrint) + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + putStr "Generating instance for finding active transition(s) in a net" + i <- instanceInput + if i >= 0 + then mainFind i + else print "There is no negative index" + +mainFind :: Int -> IO () +mainFind i = forceErrors $ do + pPrint defaultFindActivatedTransitionsConfig + (pls, trns, tknChange, flwChange, atMost) <- lift userInput + let config = defaultFindActivatedTransitionsConfig { + Find.basicConfig = (Find.basicConfig defaultFindActivatedTransitionsConfig) { + places = pls, + transitions = trns + }, + Find.changeConfig = (Find.changeConfig defaultFindActivatedTransitionsConfig) { + tokenChangeOverall = tknChange, + flowChangeOverall = flwChange + }, + Find.atMostActive = atMost + } :: FindActivatedTransitionsConfig + let c = checkFindActivatedTransitionsConfig config + if isNothing c + then do + t <- findActivatedTransitionsGenerate config 0 i + lift . (`withLang` English) $ simpleFindActivatedTransitionsTask "" t + lift $ print t + else + lift $ print c + +userInput :: IO (Int, Int, Int, Int, Int) +userInput = do + putStr "Number of Places: " + pls <- getLine + putStr "Number of Transitions: " + trns <- getLine + putStr "TokenChange Overall: " + tknCh <- getLine + putStr "FlowChange Overall: " + flwCh <- getLine + putStr "AtMostActive Transitions: " + atMost <- getLine + return (read pls, read trns, read tknCh, read flwCh, read atMost) + diff --git a/app/package.yaml b/app/package.yaml index cf5e62872..abbbb6a14 100644 --- a/app/package.yaml +++ b/app/package.yaml @@ -100,6 +100,19 @@ executables: - criterion-measurement - modelling-tasks - string-interpolate + findActivatedTransitions: + main: findActivatedTransitions.hs + source-dirs: + - . + - common + dependencies: + - bytestring + - digest + - modelling-tasks + - output-blocks + - pretty-simple + other-modules: + - Common findAuxiliaryPetriNodesTaskDemo: main: findAuxiliaryPetriNodesTaskDemo.hs source-dirs: From 5e4ddc405f5130fa8a87c62040a00da38e923bb2 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 6 Mar 2025 23:14:21 +0100 Subject: [PATCH 050/256] changes name of task type --- ...nsition.hs => FindActivatedTransitions.hs} | 158 ++++++++---------- src/Modelling/PetriNet/Types.hs | 14 +- 2 files changed, 80 insertions(+), 92 deletions(-) rename src/Modelling/PetriNet/{ActiveTransition.hs => FindActivatedTransitions.hs} (70%) diff --git a/src/Modelling/PetriNet/ActiveTransition.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs similarity index 70% rename from src/Modelling/PetriNet/ActiveTransition.hs rename to src/Modelling/PetriNet/FindActivatedTransitions.hs index 35498c2a6..dd79032c6 100644 --- a/src/Modelling/PetriNet/ActiveTransition.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -5,23 +5,23 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE LambdaCase #-} -module Modelling.PetriNet.ActiveTransition ( +module Modelling.PetriNet.FindActivatedTransitions ( checkActiveTransitionConfig, - checkFindActiveTransitionConfig, - defaultFindActiveTransitionInstance, - findActiveTransition, - findActiveTransitionEvaluation, - findActiveTransitionGenerate, - findActiveTransitionSolution, - findActiveTransitionTask, + checkFindActivatedTransitionsConfig, + defaultFindActivatedTransitionsInstance, + findActivatedTransitions, + findActivatedTransitionsEvaluation, + findActivatedTransitionsGenerate, + findActivatedTransitionsSolution, + findActivatedTransitionsTask, parseActiveTransition, petriNetFindActive, - simpleFindActiveTransitionTask, + simpleFindActivatedTransitionsTask, ) where import qualified Modelling.PetriNet.Find as F (showSolution) import qualified Modelling.PetriNet.Types as Find ( - FindActiveTransitionConfig (..), + FindActivatedTransitionsConfig (..), ) import qualified Data.Map as M ( empty, @@ -47,7 +47,6 @@ import Modelling.PetriNet.Alloy ( compAdvConstraints, compBasicConstraints, compChange, - defaultConstraints, moduleHelpers, modulePetriAdditions, modulePetriConcepts, @@ -55,7 +54,6 @@ import Modelling.PetriNet.Alloy ( modulePetriSignature, petriScopeBitWidth, petriScopeMaxSeq, - signatures, skolemVariable, taskInstance, unscopedSingleSig, @@ -79,9 +77,8 @@ import Modelling.PetriNet.Types ( AdvConfig, BasicConfig (..), ChangeConfig (..), - ActiveTransitionConfig (..), DrawSettings (..), - FindActiveTransitionConfig (..), + FindActivatedTransitionsConfig (..), GraphConfig (..), Net, PetriLike (PetriLike, allNodes), @@ -113,21 +110,20 @@ import Control.Monad.Random ( mkStdGen ) import Control.Monad.Trans (MonadTrans (lift)) -import Data.Either (isLeft) import Data.GraphViz.Commands (GraphvizCommand (Circo)) import Data.String.Interpolate (i, iii) import Language.Alloy.Call ( AlloyInstance ) -findActiveTransitionGenerate +findActivatedTransitionsGenerate :: (MonadAlloy m, MonadThrow m, Net p n) - => FindActiveTransitionConfig + => FindActivatedTransitionsConfig -> Int -> Int -> m (FindInstance (p n String) (ActiveTransition Transition)) -findActiveTransitionGenerate config segment seed = flip evalRandT (mkStdGen seed) $ do - (d, c) <- findActiveTransition config segment +findActivatedTransitionsGenerate config segment seed = flip evalRandT (mkStdGen seed) $ do + (d, c) <- findActivatedTransitions config segment gl <- oneOf $ graphLayouts gc c' <- lift $ traverse (parseWith parseTransitionPrec) @@ -150,7 +146,7 @@ findActiveTransitionGenerate config segment seed = flip evalRandT (mkStdGen seed bc = Find.basicConfig config gc = Find.graphConfig config -simpleFindActiveTransitionTask +simpleFindActivatedTransitionsTask :: ( MonadCache m, MonadDiagrams m, @@ -161,9 +157,9 @@ simpleFindActiveTransitionTask => FilePath -> FindInstance SimplePetriNet (ActiveTransition Transition) -> LangM m -simpleFindActiveTransitionTask = findActiveTransitionTask +simpleFindActivatedTransitionsTask = findActivatedTransitionsTask -findActiveTransitionTask +findActivatedTransitionsTask :: ( MonadCache m, MonadDiagrams m, @@ -175,7 +171,7 @@ findActiveTransitionTask => FilePath -> FindInstance (p n String) (ActiveTransition Transition) -> LangM m -findActiveTransitionTask path task = do +findActivatedTransitionsTask path task = do paragraph $ translate $ do english "Consider the following Petri net:" german "Betrachten Sie folgendes Petrinetz:" @@ -224,52 +220,52 @@ findActiveTransitionTask path task = do paragraph hoveringInformation pure () -findActiveTransitionEvaluation +findActivatedTransitionsEvaluation :: (Monad m, OutputCapable m) => FindInstance net (ActiveTransition Transition) -> [Transition] -> Rated m -findActiveTransitionEvaluation task x = do +findActivatedTransitionsEvaluation task x = do let what = translations $ do english "are activated" german "sind aktiviert" uncurry (printSolutionAndAssert DefiniteArticle) $=<< unLangM $ toFindEvaluationList what withSol active x where - active = findActiveTransitionSolution task + active = findActivatedTransitionsSolution task withSol = F.showSolution task -findActiveTransitionSolution :: FindInstance net (ActiveTransition a) -> [a] -findActiveTransitionSolution task = active +findActivatedTransitionsSolution :: FindInstance net (ActiveTransition a) -> [a] +findActivatedTransitionsSolution task = active where ActiveTransition active = toFind task -findActiveTransition +findActivatedTransitions :: (MonadAlloy m, MonadThrow m, Net p n, RandomGen g) - => FindActiveTransitionConfig + => FindActivatedTransitionsConfig -> Int -> RandT g m (p n String, ActiveTransition String) -findActiveTransition = taskInstance +findActivatedTransitions = taskInstance findTaskInstance petriNetFindActive parseActiveTransition Find.alloyConfig -petriNetFindActive :: FindActiveTransitionConfig -> String -petriNetFindActive FindActiveTransitionConfig { +petriNetFindActive :: FindActivatedTransitionsConfig -> String +petriNetFindActive FindActivatedTransitionsConfig { basicConfig, advConfig, changeConfig, - activeTransitionConfig + atMostActive } = petriNetActiveTransitionAlloy basicConfig changeConfig - activeTransitionConfig - $ Right advConfig + atMostActive + advConfig parseActiveTransition :: MonadThrow m => AlloyInstance -> m (ActiveTransition Object) parseActiveTransition inst = do @@ -279,53 +275,38 @@ parseActiveTransition inst = do petriNetActiveTransitionAlloy :: BasicConfig -> ChangeConfig - -> ActiveTransitionConfig - -> Either Bool AdvConfig + -> Maybe Int + -> AdvConfig -- ^ Right for find task; Left for pick task -> String -petriNetActiveTransitionAlloy basicC changeC activeC specific +petriNetActiveTransitionAlloy basicC changeC atMost specific = [i|module PetriNetActiveTransition #{modulePetriSignature} -#{either (const sigs) (const modulePetriAdditions) specific} +#{const modulePetriAdditions specific} #{moduleHelpers} #{modulePetriConcepts} #{modulePetriConstraints} -pred #{activePredicateName}[#{defaultActiveTrans}#{activated} : set Transitions] { +pred #{activePredicateName}[#{activated} : set Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} #{compBasicConstraints True activated basicC} #{compChange changeC} - #{sourceTransitionConstraints} - #{compConstraints} + #{compAdvConstraints specific} no t : givenTransitions | activatedDefault[t] - #{maxActivatedTrans activeC} + theActivatedTransitions[activatedTrans] + #{maxActivatedTrans atMost} } run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] where activated = "activatedTrans" - activatedDefault = "defaultActiveTrans" - compConstraints = either - (const $ defaultConstraints activatedDefault basicC) - compAdvConstraints - specific - sourceTransitionConstraints - | Left True <- specific = [i| - no t : givenTransitions | no givenPlaces.flow[t] - no t : Transitions | sourceTransitions[t]|] - | otherwise = "" - defaultActiveTrans - | isLeft specific = [i|#{activatedDefault} : set givenTransitions,|] - | otherwise = "" - maxActivatedTrans :: ActiveTransitionConfig -> String - maxActivatedTrans ActiveTransitionConfig {atMostActive} - = "#" ++ [i|#{activated} <= #{atMostActive}|] - - sigs = signatures "given" (places basicC) (transitions basicC) + maxActivatedTrans :: Maybe Int -> String + maxActivatedTrans Nothing = "" + maxActivatedTrans (Just maxValue) = "#" ++ [i|#{activated} <= #{maxValue}|] activePredicateName :: String activePredicateName = "showActiveTransition" @@ -336,38 +317,45 @@ activeTransition1 = skolemVariable activePredicateName transition1 transition1 :: String transition1 = "activatedTrans" -checkFindActiveTransitionConfig :: FindActiveTransitionConfig -> Maybe String -checkFindActiveTransitionConfig FindActiveTransitionConfig { +checkFindActivatedTransitionsConfig :: FindActivatedTransitionsConfig -> Maybe String +checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { basicConfig, changeConfig, - activeTransitionConfig, + atMostActive, graphConfig } = checkConfigForFind basicConfig changeConfig graphConfig - <|> checkActiveTransitionConfig basicConfig changeConfig activeTransitionConfig + <|> checkActiveTransitionConfig basicConfig atMostActive -checkActiveTransitionConfig :: BasicConfig -> ChangeConfig -> ActiveTransitionConfig -> Maybe String +checkActiveTransitionConfig :: BasicConfig -> Maybe Int -> Maybe String checkActiveTransitionConfig BasicConfig { - transitions, - atLeastActive - } - ChangeConfig { - - } - ActiveTransitionConfig { - atMostActive + atLeastActive, + maxFlowPerEdge, + maxTokensPerPlace, + places, + tokensOverall, + transitions } - | atLeastActive >= atMostActive - = Just "atLeastActive must be less than atMostActive." - | transitions <= atLeastActive - = Just "There must be at least as many transitions as atLeastActive." - | transitions <= atMostActive - = Just "There must be at least as many transitions as atMostActive." - | otherwise - = Nothing + atMostActive + | transitions <= atLeastActive = + Just "There must be at least as many transitions as atLeastActive." + | maxTokensPerPlace = 0 && atLeastActive > 0 = + Just "There must be at least one token per place for an activated transition." + | tokensOverall >= 0 && atLeastActive > tokensOverall = + Just "There must be at least as many tokens as atLeastActive." + | otherwise = + case atMostActive of + Just atMost + | atMost >= 0 + -> Just "atMostActive must be non-negative." + | atLeastActive >= atMost + -> Just "atLeastActive must be less than atMostActive." + | transitions <= atMost + -> Just "There must be at least as many transitions as atMostActive." + _ -> Nothing -defaultFindActiveTransitionInstance :: FindInstance SimplePetriNet (ActiveTransition Transition) -defaultFindActiveTransitionInstance = FindInstance { +defaultFindActivatedTransitionsInstance :: FindInstance SimplePetriNet (ActiveTransition Transition) +defaultFindActivatedTransitionsInstance = FindInstance { drawFindWith = DrawSettings { withPlaceNames = False, withSvgHighlighting = True, diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index e61c3c729..b2434fbef 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -31,7 +31,7 @@ module Modelling.PetriNet.Types ( ConflictConfig (..), Drawable, DrawSettings (..), - FindActiveTransitionConfig (..), + FindActivatedTransitionsConfig (..), FindConcurrencyConfig (..), FindConflictConfig (..), PickMistakeConfig (..), @@ -59,7 +59,7 @@ module Modelling.PetriNet.Types ( defaultAlloyConfig, defaultBasicConfig, defaultChangeConfig, - defaultFindActiveTransitionConfig, + defaultFindActivatedTransitionsConfig, defaultFindConcurrencyConfig, defaultFindConflictConfig, defaultPickMistakeConfig, @@ -927,7 +927,7 @@ defaultMistakeConfig = MistakeConfig , canHavePlaceToPlace = True } -data FindActiveTransitionConfig = FindActiveTransitionConfig +data FindActivatedTransitionsConfig = FindActivatedTransitionsConfig { basicConfig :: BasicConfig , advConfig :: AdvConfig , changeConfig :: ChangeConfig @@ -938,14 +938,14 @@ data FindActiveTransitionConfig = FindActiveTransitionConfig } deriving (Generic, Read, Show) -defaultFindActiveTransitionConfig :: FindActiveTransitionConfig -defaultFindActiveTransitionConfig = FindActiveTransitionConfig - { basicConfig = defaultBasicConfig { atLeastActive = 0 } +defaultFindActivatedTransitionsConfig :: FindActivatedTransitionsConfig +defaultFindActivatedTransitionsConfig = FindActivatedTransitionsConfig + { basicConfig = defaultBasicConfig { atLeastActive = 1 } , advConfig = defaultAdvConfig , changeConfig = defaultChangeConfig , activeTransitionConfig = defaultActiveTransitionConfig { atMostActive = 3 } , graphConfig = defaultGraphConfig { hidePlaceNames = True } - , printSolution = True + , printSolution = False , alloyConfig = defaultAlloyConfig } From d6d6aa81de5f04289f8efbf97aea3209b6ca9b11 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 6 Mar 2025 23:16:03 +0100 Subject: [PATCH 051/256] move atMostActive to FindActivatedTransitionsConfig --- src/Modelling/PetriNet/Types.hs | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index b2434fbef..734a2c9d6 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -20,7 +20,6 @@ functions to work on and transform Petri net representations. -} module Modelling.PetriNet.Types ( ActiveTransition (ActiveTransition), - ActiveTransitionConfig (..), AdvConfig (..), AlloyConfig (..), BasicConfig (..), @@ -931,7 +930,7 @@ data FindActivatedTransitionsConfig = FindActivatedTransitionsConfig { basicConfig :: BasicConfig , advConfig :: AdvConfig , changeConfig :: ChangeConfig - , activeTransitionConfig :: ActiveTransitionConfig + , atMostActive :: Maybe Int , graphConfig :: GraphConfig , printSolution :: Bool , alloyConfig :: AlloyConfig @@ -943,21 +942,12 @@ defaultFindActivatedTransitionsConfig = FindActivatedTransitionsConfig { basicConfig = defaultBasicConfig { atLeastActive = 1 } , advConfig = defaultAdvConfig , changeConfig = defaultChangeConfig - , activeTransitionConfig = defaultActiveTransitionConfig { atMostActive = 3 } + , atMostActive = Just 3 , graphConfig = defaultGraphConfig { hidePlaceNames = True } , printSolution = False , alloyConfig = defaultAlloyConfig } -data ActiveTransitionConfig = ActiveTransitionConfig - { atMostActive :: Int - } deriving (Generic, Read, Show) - -defaultActiveTransitionConfig :: ActiveTransitionConfig -defaultActiveTransitionConfig = ActiveTransitionConfig - { atMostActive = 2 - } - data DrawSettings = DrawSettings { withPlaceNames :: Bool, withSvgHighlighting :: Bool, From 0594e2d5faaaac73b02166e2bf3cdcff82e2b173 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 6 Mar 2025 23:17:10 +0100 Subject: [PATCH 052/256] fixed super linter --- src/Modelling/PetriNet/Find.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 704f31adf..6def1073f 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -148,11 +148,11 @@ toFindEvaluationList -> [Transition] -> LangM' m (Maybe String, a) toFindEvaluationList what withSol correctTransitions inputTransitions = do - let correct = (sortCorrect correctTransitions == sortCorrect inputTransitions) + let correct = sortCorrect correctTransitions == sortCorrect inputTransitions points = if correct then 1 else 0 maybeSolutionString = if withSol - then Just $ show $ transitionListShow (correctTransitions) + then Just $ show $ transitionListShow correctTransitions else Nothing assert correct $ translate $ do english $ "The given transitions " ++ localise English what ++ "?" From 0c4a0a16406ee8d30d08bdcd79e7bd79396126ab Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 6 Mar 2025 23:35:59 +0100 Subject: [PATCH 053/256] fixed mistakes in checks --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index dd79032c6..fb793bd1b 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -330,19 +330,17 @@ checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { checkActiveTransitionConfig :: BasicConfig -> Maybe Int -> Maybe String checkActiveTransitionConfig BasicConfig { atLeastActive, - maxFlowPerEdge, maxTokensPerPlace, - places, tokensOverall, transitions } atMostActive - | transitions <= atLeastActive = - Just "There must be at least as many transitions as atLeastActive." - | maxTokensPerPlace = 0 && atLeastActive > 0 = - Just "There must be at least one token per place for an activated transition." - | tokensOverall >= 0 && atLeastActive > tokensOverall = - Just "There must be at least as many tokens as atLeastActive." + | transitions <= atLeastActive + = Just "There must be at least as many transitions as atLeastActive." + | maxTokensPerPlace == 0 && atLeastActive > 0 + = Just "There must be at least one token per place for an activated transition." + | fst tokensOverall >= 0 && atLeastActive > snd tokensOverall + = Just "There must be at least as many tokens as atLeastActive." | otherwise = case atMostActive of Just atMost From d2ebb922507bf75fc7d18b0ea505d9fa2eca7082 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 7 Mar 2025 23:05:53 +0100 Subject: [PATCH 054/256] renamed Mistake to PickMistake --- app/modelling-tasks-apps.cabal | 4 ++-- app/package.yaml | 4 ++-- app/{mistake.hs => pickMistake.hs} | 2 +- modelling-tasks.cabal | 4 ++-- package.yaml | 2 +- .../PetriNet/{Mistake.hs => PickMistake.hs} | 22 +++++++++---------- src/Modelling/PetriNet/Types.hs | 4 ++-- .../{MistakeSpec.hs => PickMistakeSpec.hs} | 4 ++-- 8 files changed, 23 insertions(+), 23 deletions(-) rename app/{mistake.hs => pickMistake.hs} (98%) rename src/Modelling/PetriNet/{Mistake.hs => PickMistake.hs} (95%) rename test/Modelling/PetriNet/{MistakeSpec.hs => PickMistakeSpec.hs} (96%) diff --git a/app/modelling-tasks-apps.cabal b/app/modelling-tasks-apps.cabal index ae99bad0b..69687b9b8 100644 --- a/app/modelling-tasks-apps.cabal +++ b/app/modelling-tasks-apps.cabal @@ -305,8 +305,8 @@ executable matchToMath , transformers default-language: Haskell2010 -executable mistake - main-is: mistake.hs +executable pickMistake + main-is: pickMistake.hs other-modules: Common hs-source-dirs: diff --git a/app/package.yaml b/app/package.yaml index abbbb6a14..4100f1c49 100644 --- a/app/package.yaml +++ b/app/package.yaml @@ -169,8 +169,8 @@ executables: - pretty-simple other-modules: - Common - mistake: - main: mistake.hs + pickMistake: + main: pickMistake.hs source-dirs: - . - common diff --git a/app/mistake.hs b/app/pickMistake.hs similarity index 98% rename from app/mistake.hs rename to app/pickMistake.hs index 7a2d91ee5..a1ee814cd 100644 --- a/app/mistake.hs +++ b/app/pickMistake.hs @@ -12,7 +12,7 @@ import Common ( instanceInput, withLang, ) -import Modelling.PetriNet.Mistake ( +import Modelling.PetriNet.PickMistake ( checkPickMistakeConfig, pickMistakeGenerate, simplePickMistakeTask, diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index 5b4024c93..cad2491d1 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -88,8 +88,8 @@ library Modelling.PetriNet.Conflict Modelling.PetriNet.ConflictPlaces Modelling.PetriNet.Find - Modelling.PetriNet.Mistake Modelling.PetriNet.Pick + Modelling.PetriNet.PickMistake Modelling.PetriNet.Reach.Deadlock Modelling.PetriNet.Reach.Property Modelling.PetriNet.Reach.Reach @@ -191,7 +191,7 @@ test-suite modelling-tasks-test Modelling.PetriNet.ConflictSpec Modelling.PetriNet.DiagramSpec Modelling.PetriNet.MatchToMathSpec - Modelling.PetriNet.MistakeSpec + Modelling.PetriNet.PickMistakeSpec Modelling.PetriNet.Reach.DeadlockSpec Modelling.PetriNet.Reach.ReachSpec Modelling.PetriNet.TestCommon diff --git a/package.yaml b/package.yaml index ffef60bf6..e685e6b2b 100644 --- a/package.yaml +++ b/package.yaml @@ -134,8 +134,8 @@ library: - Modelling.PetriNet.Conflict - Modelling.PetriNet.ConflictPlaces - Modelling.PetriNet.Find - - Modelling.PetriNet.Mistake - Modelling.PetriNet.Pick + - Modelling.PetriNet.PickMistake - Modelling.PetriNet.Reach.Deadlock - Modelling.PetriNet.Reach.Property - Modelling.PetriNet.Reach.Reach diff --git a/src/Modelling/PetriNet/Mistake.hs b/src/Modelling/PetriNet/PickMistake.hs similarity index 95% rename from src/Modelling/PetriNet/Mistake.hs rename to src/Modelling/PetriNet/PickMistake.hs index e4e96ae7e..ad5d476e1 100644 --- a/src/Modelling/PetriNet/Mistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -4,11 +4,11 @@ {-# LANGUAGE NamedFieldPuns #-} {-# Language QuasiQuotes #-} -module Modelling.PetriNet.Mistake ( +module Modelling.PetriNet.PickMistake ( checkMistakeConfig, checkPickMistakeConfig, defaultPickMistakeInstance, - mistakeConstraints, + pickMistakeConstraints, petriNetPickMist, pickMistake, pickMistakeGenerate, @@ -129,7 +129,7 @@ pickMistakeTask path task = do Welcher der folgenden Petrinetzkandidaten ist nicht korrekt geformt? |] images show snd - $=<< renderPick path "mistake" task + $=<< renderPick path "pickMistake" task paragraph $ translate $ do english [iii| State your answer by giving the number of the Petri net candidate @@ -184,7 +184,7 @@ petriNetPickMist PickMistakeConfig{ changeConfig, mistakeConfig } = - petriNetMistakeAlloy + petriNetPickMistakeAlloy basicConfig changeConfig mistakeConfig @@ -192,13 +192,13 @@ petriNetPickMist PickMistakeConfig{ {-| Generate code for PetriNet mistake tasks -} -petriNetMistakeAlloy +petriNetPickMistakeAlloy :: BasicConfig -> ChangeConfig -> MistakeConfig -> String -petriNetMistakeAlloy basicC changeC mistakeC - = [i|module PetriNetMistake +petriNetPickMistakeAlloy basicC changeC mistakeC + = [i|module PetriNetPickMistake #{modulePetriSignature} #{moduleHelpers} @@ -208,8 +208,8 @@ petriNetMistakeAlloy basicC changeC mistakeC pred #{mistakePredicateName} { \#Places = #{places basicC} \#Transitions = #{transitions basicC} - #{compBasicConstraints False undefined basicC} - #{mistakeConstraints mistakeC} + #{compBasicConstraints False Nothing undefined basicC} + #{pickMistakeConstraints mistakeC} #{compChange changeC} #{defaultConstraints undefined basicC} } @@ -220,8 +220,8 @@ run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petr mistakePredicateName :: String mistakePredicateName = "showMistake" -mistakeConstraints :: MistakeConfig -> String -mistakeConstraints MistakeConfig +pickMistakeConstraints :: MistakeConfig -> String +pickMistakeConstraints MistakeConfig { canHaveNegativeWeight, canHaveTransitionToTransition, canHavePlaceToPlace } = falseInput where diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 734a2c9d6..a6420bb8b 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -33,10 +33,9 @@ module Modelling.PetriNet.Types ( FindActivatedTransitionsConfig (..), FindConcurrencyConfig (..), FindConflictConfig (..), - PickMistakeConfig (..), GraphConfig (..), InvalidPetriNetException (..), - MistakeConfig(..), + MistakeConfig (..), Net (..), Node (..), Petri (..), @@ -48,6 +47,7 @@ module Modelling.PetriNet.Types ( PetriNode (..), PickConcurrencyConfig (..), PickConflictConfig (..), + PickMistakeConfig (..), SimpleNode (..), SimplePetriLike, SimplePetriNet, diff --git a/test/Modelling/PetriNet/MistakeSpec.hs b/test/Modelling/PetriNet/PickMistakeSpec.hs similarity index 96% rename from test/Modelling/PetriNet/MistakeSpec.hs rename to test/Modelling/PetriNet/PickMistakeSpec.hs index 42bc4882e..95384c67e 100644 --- a/test/Modelling/PetriNet/MistakeSpec.hs +++ b/test/Modelling/PetriNet/PickMistakeSpec.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TypeApplications #-} -module Modelling.PetriNet.MistakeSpec where +module Modelling.PetriNet.PickMistakeSpec where import qualified Modelling.PetriNet.Types as Pick ( PickMistakeConfig (..), ) -import Modelling.PetriNet.Mistake ( +import Modelling.PetriNet.PickMistake ( checkMistakeConfig, checkPickMistakeConfig, petriNetPickMist, From 07e28a123fe35cc50f20a32531811eab659a2253 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 7 Mar 2025 23:08:24 +0100 Subject: [PATCH 055/256] renamed ActiveTransition to FindActivatedTransitions --- app/modelling-tasks-apps.cabal | 26 ++++++++ modelling-tasks.cabal | 2 +- package.yaml | 1 + .../PetriNet/FindActivatedTransitions.hs | 63 +++++++++---------- src/Modelling/PetriNet/Types.hs | 4 +- 5 files changed, 61 insertions(+), 35 deletions(-) diff --git a/app/modelling-tasks-apps.cabal b/app/modelling-tasks-apps.cabal index 69687b9b8..0db5e0989 100644 --- a/app/modelling-tasks-apps.cabal +++ b/app/modelling-tasks-apps.cabal @@ -184,6 +184,32 @@ executable evalTimeToGenerate , transformers default-language: Haskell2010 +executable findActivatedTransitions + main-is: findActivatedTransitions.hs + other-modules: + Common + hs-source-dirs: + ./ + common + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints -Werror -Wwarn=incomplete-uni-patterns -Wwarn=orphans + build-tools: + alex + , happy + build-depends: + MonadRandom + , base + , bytestring + , containers + , diagrams-lib + , diagrams-svg + , digest + , modelling-tasks + , mtl + , output-blocks + , pretty-simple + , transformers + default-language: Haskell2010 + executable findAuxiliaryPetriNodesTaskDemo main-is: findAuxiliaryPetriNodesTaskDemo.hs other-modules: diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index cad2491d1..0110a126a 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -88,6 +88,7 @@ library Modelling.PetriNet.Conflict Modelling.PetriNet.ConflictPlaces Modelling.PetriNet.Find + Modelling.PetriNet.FindActivatedTransitions Modelling.PetriNet.Pick Modelling.PetriNet.PickMistake Modelling.PetriNet.Reach.Deadlock @@ -101,7 +102,6 @@ library Modelling.CdOd.Phrasing Modelling.CdOd.Phrasing.English Modelling.CdOd.Phrasing.German - Modelling.PetriNet.ActiveTransition Modelling.PetriNet.Reach.Draw Modelling.PetriNet.Reach.Roll Paths_modelling_tasks diff --git a/package.yaml b/package.yaml index e685e6b2b..0f71d7436 100644 --- a/package.yaml +++ b/package.yaml @@ -134,6 +134,7 @@ library: - Modelling.PetriNet.Conflict - Modelling.PetriNet.ConflictPlaces - Modelling.PetriNet.Find + - Modelling.PetriNet.FindActivatedTransitions - Modelling.PetriNet.Pick - Modelling.PetriNet.PickMistake - Modelling.PetriNet.Reach.Deadlock diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index fb793bd1b..7981d3590 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -6,7 +6,7 @@ {-# LANGUAGE LambdaCase #-} module Modelling.PetriNet.FindActivatedTransitions ( - checkActiveTransitionConfig, + checkActivatedTransitionsConfig, checkFindActivatedTransitionsConfig, defaultFindActivatedTransitionsInstance, findActivatedTransitions, @@ -14,8 +14,8 @@ module Modelling.PetriNet.FindActivatedTransitions ( findActivatedTransitionsGenerate, findActivatedTransitionsSolution, findActivatedTransitionsTask, - parseActiveTransition, - petriNetFindActive, + parseActivatedTransitions, + petriNetFindActivated, simpleFindActivatedTransitionsTask, ) where @@ -73,7 +73,7 @@ import Modelling.PetriNet.Reach.Type ( parseTransitionPrec, ) import Modelling.PetriNet.Types ( - ActiveTransition (ActiveTransition), + ActivatedTransitions (ActivatedTransitions), AdvConfig, BasicConfig (..), ChangeConfig (..), @@ -121,7 +121,7 @@ findActivatedTransitionsGenerate => FindActivatedTransitionsConfig -> Int -> Int - -> m (FindInstance (p n String) (ActiveTransition Transition)) + -> m (FindInstance (p n String) (ActivatedTransitions Transition)) findActivatedTransitionsGenerate config segment seed = flip evalRandT (mkStdGen seed) $ do (d, c) <- findActivatedTransitions config segment gl <- oneOf $ graphLayouts gc @@ -155,7 +155,7 @@ simpleFindActivatedTransitionsTask OutputCapable m ) => FilePath - -> FindInstance SimplePetriNet (ActiveTransition Transition) + -> FindInstance SimplePetriNet (ActivatedTransitions Transition) -> LangM m simpleFindActivatedTransitionsTask = findActivatedTransitionsTask @@ -169,14 +169,14 @@ findActivatedTransitionsTask OutputCapable m ) => FilePath - -> FindInstance (p n String) (ActiveTransition Transition) + -> FindInstance (p n String) (ActivatedTransitions Transition) -> LangM m findActivatedTransitionsTask path task = do paragraph $ translate $ do english "Consider the following Petri net:" german "Betrachten Sie folgendes Petrinetz:" image - $=<< renderWith path "activeTransition" (net task) (drawFindWith task) + $=<< renderWith path "activatedTransition" (net task) (drawFindWith task) paragraph $ translate $ do english [iii| Which transitions are activated @@ -222,7 +222,7 @@ findActivatedTransitionsTask path task = do findActivatedTransitionsEvaluation :: (Monad m, OutputCapable m) - => FindInstance net (ActiveTransition Transition) + => FindInstance net (ActivatedTransitions Transition) -> [Transition] -> Rated m findActivatedTransitionsEvaluation task x = do @@ -235,10 +235,10 @@ findActivatedTransitionsEvaluation task x = do active = findActivatedTransitionsSolution task withSol = F.showSolution task -findActivatedTransitionsSolution :: FindInstance net (ActiveTransition a) -> [a] +findActivatedTransitionsSolution :: FindInstance net (ActivatedTransitions a) -> [a] findActivatedTransitionsSolution task = active where - ActiveTransition active = toFind task + ActivatedTransitions active = toFind task findActivatedTransitions :: (MonadAlloy m, MonadThrow m, Net p n, RandomGen g) @@ -247,40 +247,39 @@ findActivatedTransitions -> RandT g m - (p n String, ActiveTransition String) + (p n String, ActivatedTransitions String) findActivatedTransitions = taskInstance findTaskInstance - petriNetFindActive - parseActiveTransition + petriNetFindActivated + parseActivatedTransitions Find.alloyConfig -petriNetFindActive :: FindActivatedTransitionsConfig -> String -petriNetFindActive FindActivatedTransitionsConfig { +petriNetFindActivated :: FindActivatedTransitionsConfig -> String +petriNetFindActivated FindActivatedTransitionsConfig { basicConfig, advConfig, changeConfig, atMostActive } - = petriNetActiveTransitionAlloy + = petriNetActivatedTransitionsAlloy basicConfig changeConfig atMostActive advConfig -parseActiveTransition :: MonadThrow m => AlloyInstance -> m (ActiveTransition Object) -parseActiveTransition inst = do - t <- unscopedSingleSig inst activeTransition1 "" - pure $ ActiveTransition (Set.toList t) +parseActivatedTransitions :: MonadThrow m => AlloyInstance -> m (ActivatedTransitions Object) +parseActivatedTransitions inst = do + t <- unscopedSingleSig inst activatedTransitions1 "" + pure $ ActivatedTransitions (Set.toList t) -petriNetActiveTransitionAlloy +petriNetActivatedTransitionsAlloy :: BasicConfig -> ChangeConfig -> Maybe Int -> AdvConfig - -- ^ Right for find task; Left for pick task -> String -petriNetActiveTransitionAlloy basicC changeC atMost specific - = [i|module PetriNetActiveTransition +petriNetActivatedTransitionsAlloy basicC changeC atMost advConfig + = [i|module PetriNetFindActivatedTransitions #{modulePetriSignature} #{const modulePetriAdditions specific} @@ -311,8 +310,8 @@ run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petri activePredicateName :: String activePredicateName = "showActiveTransition" -activeTransition1 :: String -activeTransition1 = skolemVariable activePredicateName transition1 +activatedTransitions1 :: String +activatedTransitions1 = skolemVariable activePredicateName transition1 transition1 :: String transition1 = "activatedTrans" @@ -325,10 +324,10 @@ checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { graphConfig } = checkConfigForFind basicConfig changeConfig graphConfig - <|> checkActiveTransitionConfig basicConfig atMostActive + <|> checkActivatedTransitionsConfig basicConfig atMostActive -checkActiveTransitionConfig :: BasicConfig -> Maybe Int -> Maybe String -checkActiveTransitionConfig BasicConfig { +checkActivatedTransitionsConfig :: BasicConfig -> Maybe Int -> Maybe String +checkActivatedTransitionsConfig BasicConfig { atLeastActive, maxTokensPerPlace, tokensOverall, @@ -352,7 +351,7 @@ checkActiveTransitionConfig BasicConfig { -> Just "There must be at least as many transitions as atMostActive." _ -> Nothing -defaultFindActivatedTransitionsInstance :: FindInstance SimplePetriNet (ActiveTransition Transition) +defaultFindActivatedTransitionsInstance :: FindInstance SimplePetriNet (ActivatedTransitions Transition) defaultFindActivatedTransitionsInstance = FindInstance { drawFindWith = DrawSettings { withPlaceNames = False, @@ -361,7 +360,7 @@ defaultFindActivatedTransitionsInstance = FindInstance { with1Weights = False, withGraphvizCommand = Circo }, - toFind = ActiveTransition [Transition 1, Transition 2], + toFind = ActivatedTransitions [Transition 1, Transition 2], net = PetriLike { allNodes = M.fromList [ ("s1",SimplePlace {initial = 2, flowOut = M.fromList [("t1",1),("t2",1)]}), diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index a6420bb8b..5116f5f96 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -19,7 +19,7 @@ The 'Modelling.PetriNet.Types' module defines basic type class instances and functions to work on and transform Petri net representations. -} module Modelling.PetriNet.Types ( - ActiveTransition (ActiveTransition), + ActivatedTransitions (ActivatedTransitions), AdvConfig (..), AlloyConfig (..), BasicConfig (..), @@ -233,7 +233,7 @@ instance Bitraversable PetriConflict where newtype Concurrent a = Concurrent (a, a) deriving (Foldable, Functor, Generic, Read, Show, Traversable) -newtype ActiveTransition a = ActiveTransition [a] +newtype ActivatedTransitions a = ActivatedTransitions [a] deriving (Functor, Foldable, Traversable, Generic, Read, Show) class Show (n String) => PetriNode n where From c638d75d3a81ccd51b4fb17da98e684c25c3a0b6 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 7 Mar 2025 23:10:23 +0100 Subject: [PATCH 056/256] enforceConstraints now also uses atMostActive --- src/Modelling/PetriNet/Alloy.hs | 14 +++++++++----- src/Modelling/PetriNet/Concurrency.hs | 2 +- src/Modelling/PetriNet/Conflict.hs | 2 +- src/Modelling/PetriNet/FindActivatedTransitions.hs | 2 +- 4 files changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index d716e88c9..daf029e90 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -99,13 +99,15 @@ A set of constraints enforcing settings of 'BasicConfig'. compBasicConstraints :: Bool -- ^ 'True' for legal petri nets, `False` for illegal petri nets. + -> Maybe Int + -- ^ Whether or not to enforce a maximum number of activated transitions. -> String -- ^ The name of the Alloy variable for the set of activated Transitions. -> BasicConfig -- ^ the configuration to enforce. -> String -compBasicConstraints legal activated basicConfig = [i| - #{enforceConstraints False activated basicConfig} +compBasicConstraints legal atMostActive activated basicConfig = [i| + #{enforceConstraints False atMostActive activated basicConfig} #{if legal then "isLegalPetriNet" else "not isLegalPetriNet"}|] {-| @@ -118,17 +120,19 @@ defaultConstraints -> BasicConfig -- ^ the configuration to enforce. -> String -defaultConstraints = enforceConstraints True +defaultConstraints = enforceConstraints True Nothing enforceConstraints :: Bool -- ^ If to generate constraints under default conditions. + -> Maybe Int + -- ^ Whether or not to enforce a maximum number of activated transitions. -> String -- ^ The name of the Alloy variable for the set of activated Transitions. -> BasicConfig -- ^ the configuration to enforce. -> String -enforceConstraints underDefault activated BasicConfig { +enforceConstraints underDefault atMostActive activated BasicConfig { atLeastActive, isConnected, flowOverall, @@ -154,7 +158,7 @@ enforceConstraints underDefault activated BasicConfig { places = given "Places" tokens = prepend "tokens" activatedConstraint = - if atLeastActive <= 0 + if atLeastActive <= 0 && atMostActive == Nothing then "" else [i| \##{activated} >= #{atLeastActive} diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index 784546c2b..bfc18e970 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -425,7 +425,7 @@ petriNetConcurrencyAlloy basicC changeC specific pred #{concurrencyPredicateName}[#{defaultActiveTrans}#{activated} : set Transitions, #{t1}, #{t2} : Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} - #{compBasicConstraints True activated basicC} + #{compBasicConstraints True Nothing activated basicC} #{compChange changeC} #{sourceTransitionConstraints} no disj x,y : givenTransitions | concurrentDefault[x + y] diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index a4a162deb..9e99bd30d 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -492,7 +492,7 @@ petriNetConflictAlloy basicC changeC conflictC uniqueConflictP specific pred #{conflictPredicateName}[#{p} : some Places,#{defaultActiveTrans}#{activated} : set Transitions, #{t1}, #{t2} : Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} - #{compBasicConstraints True activated basicC} + #{compBasicConstraints True Nothing activated basicC} #{compChange changeC} #{multiplePlaces uniqueConflictP} #{sourceTransitionConstraints} diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 7981d3590..2a4df8198 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -290,7 +290,7 @@ petriNetActivatedTransitionsAlloy basicC changeC atMost advConfig pred #{activePredicateName}[#{activated} : set Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} - #{compBasicConstraints True activated basicC} + #{compBasicConstraints True atMost activated basicC} #{compChange changeC} #{compAdvConstraints specific} From f18c777521abe23e2c8d6aca2117e0ef0c85b8e3 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 7 Mar 2025 23:16:24 +0100 Subject: [PATCH 057/256] added findActivatedTransitionsSyntax + used code from ConflictPlaces --- .../PetriNet/FindActivatedTransitions.hs | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 2a4df8198..159b44427 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -13,6 +13,7 @@ module Modelling.PetriNet.FindActivatedTransitions ( findActivatedTransitionsEvaluation, findActivatedTransitionsGenerate, findActivatedTransitionsSolution, + findActivatedTransitionsSyntax, findActivatedTransitionsTask, parseActivatedTransitions, petriNetFindActivated, @@ -69,6 +70,7 @@ import Modelling.PetriNet.Find ( toFindEvaluationList, ) import Modelling.PetriNet.Reach.Type ( + ShowTransition (ShowTransition), Transition (Transition), parseTransitionPrec, ) @@ -92,10 +94,12 @@ import Control.Monad.Catch (MonadThrow) import Control.OutputCapable.Blocks ( ArticleToUse (DefiniteArticle), GenericOutputCapable (..), + LangM', LangM, OutputCapable, Rated, ($=<<), + continueOrAbort, english, german, printSolutionAndAssert, @@ -110,6 +114,7 @@ import Control.Monad.Random ( mkStdGen ) import Control.Monad.Trans (MonadTrans (lift)) +import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) import Data.String.Interpolate (i, iii) import Language.Alloy.Call ( @@ -220,6 +225,22 @@ findActivatedTransitionsTask path task = do paragraph hoveringInformation pure () +findActivatedTransitionsSyntax + :: OutputCapable m + => FindInstance net (ActivatedTransitions Transition) + -> [Transition] + -> LangM' m () +findActivatedTransitionsSyntax task transitions = do + for_ transitions assertTransition + pure () + where + assert = continueOrAbort False + assertTransition t = assert (isValidTransition t) $ translate $ do + let t' = show $ ShowTransition t + english $ t' ++ " is a transition of the given Petri net?" + german $ t' ++ " ist eine Transition des gegebenen Petrinetzes?" + isValidTransition (Transition x) = x >= 1 && x <= numberOfTransitions task + findActivatedTransitionsEvaluation :: (Monad m, OutputCapable m) => FindInstance net (ActivatedTransitions Transition) From 9cb5b69b719f5e94a03b2047fb611088e098bf4e Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 7 Mar 2025 23:18:18 +0100 Subject: [PATCH 058/256] implemented commit comments --- app/findActivatedTransitions.hs | 4 +-- .../PetriNet/FindActivatedTransitions.hs | 25 ++++++------------- 2 files changed, 10 insertions(+), 19 deletions(-) diff --git a/app/findActivatedTransitions.hs b/app/findActivatedTransitions.hs index d579ef838..3c6d9e7ce 100644 --- a/app/findActivatedTransitions.hs +++ b/app/findActivatedTransitions.hs @@ -40,7 +40,7 @@ import Text.Pretty.Simple (pPrint) main :: IO () main = do hSetBuffering stdout NoBuffering - putStr "Generating instance for finding active transition(s) in a net" + putStrLn "Generating instance for finding activated transition(s) in a net" i <- instanceInput if i >= 0 then mainFind i @@ -59,7 +59,7 @@ mainFind i = forceErrors $ do tokenChangeOverall = tknChange, flowChangeOverall = flwChange }, - Find.atMostActive = atMost + Find.atMostActive = Just atMost } :: FindActivatedTransitionsConfig let c = checkFindActivatedTransitionsConfig config if isNothing c diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 159b44427..249d25be1 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -303,7 +303,7 @@ petriNetActivatedTransitionsAlloy basicC changeC atMost advConfig = [i|module PetriNetFindActivatedTransitions #{modulePetriSignature} -#{const modulePetriAdditions specific} +#{const modulePetriAdditions advConfig} #{moduleHelpers} #{modulePetriConcepts} #{modulePetriConstraints} @@ -313,10 +313,10 @@ pred #{activePredicateName}[#{activated} : set Transitions] { \#Transitions = #{transitions basicC} #{compBasicConstraints True atMost activated basicC} #{compChange changeC} - #{compAdvConstraints specific} + #{compAdvConstraints advConfig} no t : givenTransitions | activatedDefault[t] - theActivatedTransitions[activatedTrans] + theActivatedTransitions[#{activated}] #{maxActivatedTrans atMost} } @@ -350,25 +350,16 @@ checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { checkActivatedTransitionsConfig :: BasicConfig -> Maybe Int -> Maybe String checkActivatedTransitionsConfig BasicConfig { atLeastActive, - maxTokensPerPlace, - tokensOverall, transitions } - atMostActive - | transitions <= atLeastActive - = Just "There must be at least as many transitions as atLeastActive." - | maxTokensPerPlace == 0 && atLeastActive > 0 - = Just "There must be at least one token per place for an activated transition." - | fst tokensOverall >= 0 && atLeastActive > snd tokensOverall - = Just "There must be at least as many tokens as atLeastActive." - | otherwise = + atMostActive = case atMostActive of Just atMost - | atMost >= 0 + | atMost <= 0 -> Just "atMostActive must be non-negative." - | atLeastActive >= atMost - -> Just "atLeastActive must be less than atMostActive." - | transitions <= atMost + | atLeastActive > atMost + -> Just "atLeastActive must not be greater than atMostActive." + | transitions < atMost -> Just "There must be at least as many transitions as atMostActive." _ -> Nothing From c9402d259c7ea6184be9ccb05eab124e0b59bbc6 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 7 Mar 2025 23:19:02 +0100 Subject: [PATCH 059/256] had to change enforceConstraints also here --- src/Modelling/PetriNet/MatchToMath.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 2799f9f28..fcccfde50 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -559,7 +559,7 @@ fact{ pred showNets[#{activated} : set Transitions] { \#Places = #{places} \#Transitions = #{transitions} - #{compBasicConstraints True activated basicC} + #{compBasicConstraints True Nothing activated basicC} #{compAdvConstraints advConfig} } run showNets for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int @@ -586,7 +586,7 @@ fact{ } pred showFalseNets[#{activated} : set Transitions]{ - #{compBasicConstraints True activated basicConfig} + #{compBasicConstraints True Nothing activated basicConfig} #{compAdvConstraints advConfig} #{compChange changeConfig} } From 035fcbbf47f74870788073e768a1666ff3f027f9 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 7 Mar 2025 23:26:20 +0100 Subject: [PATCH 060/256] fixed hlint error --- app/findActivatedTransitions.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/app/findActivatedTransitions.hs b/app/findActivatedTransitions.hs index 3c6d9e7ce..38b0aa94d 100644 --- a/app/findActivatedTransitions.hs +++ b/app/findActivatedTransitions.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DisambiguateRecordFields #-} {-# Language DuplicateRecordFields #-} {-# Language RecordWildCards #-} From 81c6e0620b3704046d86308c8080d7fb81ce9c7b Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sat, 8 Mar 2025 22:19:55 +0100 Subject: [PATCH 061/256] updated app for findActivatedTransitions --- app/findActivatedTransitions.hs | 59 ++++++++++++++++++++------------- 1 file changed, 36 insertions(+), 23 deletions(-) diff --git a/app/findActivatedTransitions.hs b/app/findActivatedTransitions.hs index 38b0aa94d..3e52edd53 100644 --- a/app/findActivatedTransitions.hs +++ b/app/findActivatedTransitions.hs @@ -1,14 +1,8 @@ -{-# LANGUAGE DisambiguateRecordFields #-} {-# Language DuplicateRecordFields #-} {-# Language RecordWildCards #-} module Main (main) where - -import qualified Modelling.PetriNet.Types as Find ( - FindActivatedTransitionsConfig (..), - ) - import Capabilities.Alloy.IO () import Capabilities.Cache.IO () import Capabilities.Diagrams.IO () @@ -37,6 +31,7 @@ import System.IO ( BufferMode (NoBuffering), hSetBuffering, stdout, ) import Text.Pretty.Simple (pPrint) +import Text.Read (readMaybe) main :: IO () main = do @@ -49,39 +44,57 @@ main = do mainFind :: Int -> IO () mainFind i = forceErrors $ do - pPrint defaultFindActivatedTransitionsConfig - (pls, trns, tknChange, flwChange, atMost) <- lift userInput - let config = defaultFindActivatedTransitionsConfig { - Find.basicConfig = (Find.basicConfig defaultFindActivatedTransitionsConfig) { + let theConfig@FindActivatedTransitionsConfig{..} = defaultFindActivatedTransitionsConfig + lift $ pPrint theConfig + (pls, trns, tknChange, flwChange, atMost) <- lift $ userInput theConfig + let config = theConfig { + basicConfig = basicConfig { places = pls, transitions = trns }, - Find.changeConfig = (Find.changeConfig defaultFindActivatedTransitionsConfig) { + changeConfig = changeConfig { tokenChangeOverall = tknChange, flowChangeOverall = flwChange }, - Find.atMostActive = Just atMost + atMostActive = atMost } :: FindActivatedTransitionsConfig let c = checkFindActivatedTransitionsConfig config if isNothing c then do t <- findActivatedTransitionsGenerate config 0 i - lift . (`withLang` English) $ simpleFindActivatedTransitionsTask "" t + lift . (`withLang` English) $ simpleFindActivatedTransitionsTask "tmp/" t lift $ print t else lift $ print c -userInput :: IO (Int, Int, Int, Int, Int) -userInput = do +intInput :: Int -> IO Int +intInput d = do + input <- getLine + if null input then return d + else case readMaybe input of + Just n -> return n + Nothing -> do + putStrLn "Invalid input" + intInput d + +maybeIntInput :: Maybe Int -> IO (Maybe Int) +maybeIntInput d = do + input <- getLine + if null input then return d + else case readMaybe input of + Just n -> return (Just n) + Nothing -> return Nothing + +userInput :: FindActivatedTransitionsConfig -> IO (Int, Int, Int, Int, Maybe Int) +userInput FindActivatedTransitionsConfig{basicConfig = BasicConfig{..}, changeConfig = ChangeConfig{..}, atMostActive = atMostActiveValue}= do putStr "Number of Places: " - pls <- getLine + pls <- intInput places putStr "Number of Transitions: " - trns <- getLine + trns <- intInput transitions putStr "TokenChange Overall: " - tknCh <- getLine + tknCh <- intInput tokenChangeOverall putStr "FlowChange Overall: " - flwCh <- getLine - putStr "AtMostActive Transitions: " - atMost <- getLine - return (read pls, read trns, read tknCh, read flwCh, read atMost) - + flwCh <- intInput flowChangeOverall + putStr "AtMostActive Transitions (Input anything other than a number for 'irrelevance'): " + atMost <- maybeIntInput atMostActiveValue + return (pls, trns, tknCh, flwCh, atMost) From 060c96858c791639952b7d38313c4b2a046cddff Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sat, 8 Mar 2025 22:53:39 +0100 Subject: [PATCH 062/256] reduced duplicate code in toFindEvaluationlist and -tuple --- src/Modelling/PetriNet/Find.hs | 44 ++++++++++++++++++++-------------- 1 file changed, 26 insertions(+), 18 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 6def1073f..760b1686b 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -16,6 +16,7 @@ module Modelling.PetriNet.Find ( findInitialTuple, findTaskInstance, lToFind, + toFindEvaluation, toFindEvaluationList, toFindEvaluationTuple, toFindSyntax, @@ -119,19 +120,21 @@ findTaskInstance f inst = do t' <- lift $ (`BM.lookup` mapping) `mapM` t return (pl', t') -toFindEvaluationTuple +toFindEvaluation :: (Num a, OutputCapable m) => Map Language String -> Bool - -> (Transition, Transition) - -> (Transition, Transition) + -> (b -> b -> Bool) + -> (b -> String) + -> b + -> b -> LangM' m (Maybe String, a) -toFindEvaluationTuple what withSol (ft, st) (fi, si) = do - let correct = ft == fi && st == si || ft == si && st == fi +toFindEvaluation what withSol isCorrect format correctValue inputValue = do + let correct = isCorrect correctValue inputValue points = if correct then 1 else 0 maybeSolutionString = if withSol - then Just $ show $ transitionPairShow (ft, st) + then Just $ format correctValue else Nothing assert correct $ translate $ do english $ "The given transitions " ++ localise English what ++ "?" @@ -140,6 +143,20 @@ toFindEvaluationTuple what withSol (ft, st) (fi, si) = do where assert = continueOrAbort withSol +toFindEvaluationTuple + :: (Num a, OutputCapable m) + => Map Language String + -> Bool + -> (Transition, Transition) + -> (Transition, Transition) + -> LangM' m (Maybe String, a) +toFindEvaluationTuple what withSol = + toFindEvaluation what withSol pairEquals formatPair + where + pairEquals (ft, st) (fi, si) = + (ft == fi && st == si) || (ft == si && st == fi) + formatPair pair = show (transitionPairShow pair) + toFindEvaluationList :: (Num a, OutputCapable m) => Map Language String @@ -147,19 +164,10 @@ toFindEvaluationList -> [Transition] -> [Transition] -> LangM' m (Maybe String, a) -toFindEvaluationList what withSol correctTransitions inputTransitions = do - let correct = sortCorrect correctTransitions == sortCorrect inputTransitions - points = if correct then 1 else 0 - maybeSolutionString = - if withSol - then Just $ show $ transitionListShow correctTransitions - else Nothing - assert correct $ translate $ do - english $ "The given transitions " ++ localise English what ++ "?" - german $ "Die angegebenen Transitionen " ++ localise German what ++ "?" - pure (maybeSolutionString, points) +toFindEvaluationList what withSol = + toFindEvaluation what withSol (==) formatList . sortCorrect where - assert = continueOrAbort withSol + formatList transitions = show (transitionListShow transitions) sortCorrect :: Ord a => [a] -> [a] sortCorrect = sort From d88fe0ada930457012f3801490dd58f4081e6436 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 9 Mar 2025 00:08:36 +0100 Subject: [PATCH 063/256] ActivatedTransitions does not work with checkBasicConfig --- src/Modelling/PetriNet/Find.hs | 1 + src/Modelling/PetriNet/FindActivatedTransitions.hs | 8 ++++++-- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 760b1686b..6029a14c8 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -16,6 +16,7 @@ module Modelling.PetriNet.Find ( findInitialTuple, findTaskInstance, lToFind, + prohibitHideTransitionNames, toFindEvaluation, toFindEvaluationList, toFindEvaluationTuple, diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 249d25be1..b4da58dbc 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -64,9 +64,9 @@ import Modelling.PetriNet.Diagram ( ) import Modelling.PetriNet.Find ( FindInstance (..), - checkConfigForFind, findInitialList, findTaskInstance, + prohibitHideTransitionNames, toFindEvaluationList, ) import Modelling.PetriNet.Reach.Type ( @@ -86,6 +86,8 @@ import Modelling.PetriNet.Types ( PetriLike (PetriLike, allNodes), SimpleNode (..), SimplePetriNet, + checkBasicConfig, + checkChangeConfig, transitionListShow, ) @@ -344,7 +346,9 @@ checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { atMostActive, graphConfig } - = checkConfigForFind basicConfig changeConfig graphConfig + = prohibitHideTransitionNames graphConfig + <|> checkBasicConfig basicConfig + <|> checkChangeConfig basicConfig changeConfig <|> checkActivatedTransitionsConfig basicConfig atMostActive checkActivatedTransitionsConfig :: BasicConfig -> Maybe Int -> Maybe String From ec48f73591177d1996ebe32df84ee7eacf91b905 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 9 Mar 2025 20:25:40 +0100 Subject: [PATCH 064/256] added atMostActive to enforceConstraints --- src/Modelling/PetriNet/Alloy.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index daf029e90..2e42f8ec3 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -157,12 +157,15 @@ enforceConstraints underDefault atMostActive activated BasicConfig { nodes = given "Nodes" places = given "Places" tokens = prepend "tokens" - activatedConstraint = - if atLeastActive <= 0 && atMostActive == Nothing - then "" - else [i| - \##{activated} >= #{atLeastActive} - theActivated#{upperFirst which}Transitions[#{activated}]|] + activatedConstraint = unlines [ + if atLeastActive <= 0 + then "" + else [i|\##{activated} >= #{atLeastActive}|], + case atMostActive of + Just 0 -> [i|\##{activated} <= 0 + theActivated#{upperFirst which}Transitions[#{activated}]|] + Just atMost -> [i|\##{activated} <= #{atMost}|] + Nothing -> ""] connected :: String -> Maybe Bool -> String connected p = maybe "" $ \c -> (if c then "" else "not ") ++ p From ec985078754659067edfc14bda630919a2f24fdc Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 9 Mar 2025 21:23:09 +0100 Subject: [PATCH 065/256] added testing for ActivatedTransitions (amended by jvoigtlaender to remove a stray `needsTuning`-call) --- modelling-tasks.cabal | 1 + .../PetriNet/FindActivatedTransitionsSpec.hs | 93 +++++++++++++++++++ 2 files changed, 94 insertions(+) create mode 100644 test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index 0110a126a..ab8bbed78 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -190,6 +190,7 @@ test-suite modelling-tasks-test Modelling.PetriNet.ConcurrencySpec Modelling.PetriNet.ConflictSpec Modelling.PetriNet.DiagramSpec + Modelling.PetriNet.FindActivatedTransitionsSpec Modelling.PetriNet.MatchToMathSpec Modelling.PetriNet.PickMistakeSpec Modelling.PetriNet.Reach.DeadlockSpec diff --git a/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs new file mode 100644 index 000000000..820c72917 --- /dev/null +++ b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE TypeApplications #-} +module Modelling.PetriNet.FindActivatedTransitionsSpec where + +import qualified Modelling.PetriNet.Types as Find ( + FindActivatedTransitionsConfig (alloyConfig), + ) + +import Modelling.PetriNet.FindActivatedTransitions ( + checkActivatedTransitionsConfig, + checkFindActivatedTransitionsConfig, + findActivatedTransitions, + parseActivatedTransitions, + petriNetFindActivated, + ) + +import Modelling.PetriNet.Find ( + findTaskInstance, + ) +import Modelling.PetriNet.Types ( + ActivatedTransitions (..), + AdvConfig (AdvConfig), + BasicConfig, + ChangeConfig, + FindActivatedTransitionsConfig (FindActivatedTransitionsConfig), + SimplePetriLike, + defaultFindActivatedTransitionsConfig, + ) + +import Modelling.PetriNet.TestCommon ( + alloyTestConfig, + checkConfigs, + defaultConfigTaskGeneration, + firstInstanceConfig, + testTaskGeneration, + validAdvConfigs, + validConfigsForFind, + validGraphConfig, + ) +import Settings (configDepth) + +import Data.Maybe (isNothing) +import Test.Hspec + +spec :: Spec +spec = do + describe "defaultFindActivatedTransitionsConfig" $ + checkConfigs checkFindActivatedTransitionsConfig [defaultFindActivatedTransitionsConfig] + describe "validFindActivatedTransitionsConfig" $ + checkConfigs checkFindActivatedTransitionsConfig findConfigs' + describe "findActivatedTransitions" $ do + defaultConfigTaskGeneration + (findActivatedTransitions defaultFindActivatedTransitionsConfig { + Find.alloyConfig = firstInstanceConfig + } 0) + 0 + $ checkFindActivatedTransitionsInstance @(SimplePetriLike _) + testFindActivatedTransitionsConfig findConfigs + where + findConfigs' = validFindActivatedTransitionsConfig + validFinds + (AdvConfig Nothing Nothing Nothing) + findConfigs = validAdvConfigs >>= validFindActivatedTransitionsConfig validFinds + validFinds = validConfigsForFind 0 configDepth + +checkFindActivatedTransitionsInstance :: (a, ActivatedTransitions String) -> Bool +checkFindActivatedTransitionsInstance = isValidActivatedTransitions . snd + +testFindActivatedTransitionsConfig :: [FindActivatedTransitionsConfig] -> Spec +testFindActivatedTransitionsConfig = testTaskGeneration + petriNetFindActivated + (findTaskInstance parseActivatedTransitions) + $ checkFindActivatedTransitionsInstance @(SimplePetriLike _) + +validFindActivatedTransitionsConfig + :: [(BasicConfig, ChangeConfig)] + -> AdvConfig + -> [FindActivatedTransitionsConfig] +validFindActivatedTransitionsConfig cs advancedConfig = do + (bc, ch) <- cs + FindActivatedTransitionsConfig bc advancedConfig ch + <$> validActivatedTransitionsConfigs bc + <*> pure validGraphConfig + <*> pure False + <*> pure alloyTestConfig + +validActivatedTransitionsConfigs :: BasicConfig -> [Maybe Int] +validActivatedTransitionsConfigs bc = filter (isNothing . checkActivatedTransitionsConfig bc) $ do + atMost <- [Nothing] ++ [Just n | n <- [0..10]] + return atMost + +isValidActivatedTransitions :: ActivatedTransitions String -> Bool +isValidActivatedTransitions _ = True From 23bf730c4685d65f54b0736e57720b4bcc68697e Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 9 Mar 2025 23:26:03 +0100 Subject: [PATCH 066/256] moved activatedTransitions constraints to enforceConstraints --- src/Modelling/PetriNet/Alloy.hs | 7 ++++--- src/Modelling/PetriNet/FindActivatedTransitions.hs | 6 ------ 2 files changed, 4 insertions(+), 9 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 2e42f8ec3..446041e37 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -162,9 +162,10 @@ enforceConstraints underDefault atMostActive activated BasicConfig { then "" else [i|\##{activated} >= #{atLeastActive}|], case atMostActive of - Just 0 -> [i|\##{activated} <= 0 - theActivated#{upperFirst which}Transitions[#{activated}]|] - Just atMost -> [i|\##{activated} <= #{atMost}|] + Just 0 -> [i| + \##{activated} <= 0 + theActivated#{upperFirst which}Transitions[#{activated}]|] + Just atMost -> [i| \##{activated} <= #{atMost}|] Nothing -> ""] connected :: String -> Maybe Bool -> String diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index b4da58dbc..cbd7c3ca0 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -317,18 +317,12 @@ pred #{activePredicateName}[#{activated} : set Transitions] { #{compChange changeC} #{compAdvConstraints advConfig} - no t : givenTransitions | activatedDefault[t] - theActivatedTransitions[#{activated}] - #{maxActivatedTrans atMost} } run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] where activated = "activatedTrans" - maxActivatedTrans :: Maybe Int -> String - maxActivatedTrans Nothing = "" - maxActivatedTrans (Just maxValue) = "#" ++ [i|#{activated} <= #{maxValue}|] activePredicateName :: String activePredicateName = "showActiveTransition" From ab692e911ffbeb2185ee9b30b90c524a6f2247da Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 9 Mar 2025 23:26:10 +0100 Subject: [PATCH 067/256] corrected code --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index cbd7c3ca0..ba4fcaecb 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -292,7 +292,7 @@ petriNetFindActivated FindActivatedTransitionsConfig { parseActivatedTransitions :: MonadThrow m => AlloyInstance -> m (ActivatedTransitions Object) parseActivatedTransitions inst = do - t <- unscopedSingleSig inst activatedTransitions1 "" + t <- unscopedSingleSig inst activatedTransitions "" pure $ ActivatedTransitions (Set.toList t) petriNetActivatedTransitionsAlloy @@ -327,11 +327,11 @@ run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petri activePredicateName :: String activePredicateName = "showActiveTransition" -activatedTransitions1 :: String -activatedTransitions1 = skolemVariable activePredicateName transition1 +activatedTransitions :: String +activatedTransitions = skolemVariable activePredicateName transition -transition1 :: String -transition1 = "activatedTrans" +transition :: String +transition = "activatedTrans" checkFindActivatedTransitionsConfig :: FindActivatedTransitionsConfig -> Maybe String checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { @@ -353,7 +353,7 @@ checkActivatedTransitionsConfig BasicConfig { atMostActive = case atMostActive of Just atMost - | atMost <= 0 + | atMost < 0 -> Just "atMostActive must be non-negative." | atLeastActive > atMost -> Just "atLeastActive must not be greater than atMostActive." From a6443322698e543c1e95802319799ab1c5287435 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 10 Mar 2025 19:38:04 +0100 Subject: [PATCH 068/256] added max bounds for config check --- test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs index 820c72917..b90b12dc8 100644 --- a/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs +++ b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeApplications #-} + module Modelling.PetriNet.FindActivatedTransitionsSpec where import qualified Modelling.PetriNet.Types as Find ( @@ -20,7 +22,7 @@ import Modelling.PetriNet.Find ( import Modelling.PetriNet.Types ( ActivatedTransitions (..), AdvConfig (AdvConfig), - BasicConfig, + BasicConfig (..), ChangeConfig, FindActivatedTransitionsConfig (FindActivatedTransitionsConfig), SimplePetriLike, @@ -85,9 +87,8 @@ validFindActivatedTransitionsConfig cs advancedConfig = do <*> pure alloyTestConfig validActivatedTransitionsConfigs :: BasicConfig -> [Maybe Int] -validActivatedTransitionsConfigs bc = filter (isNothing . checkActivatedTransitionsConfig bc) $ do - atMost <- [Nothing] ++ [Just n | n <- [0..10]] - return atMost +validActivatedTransitionsConfigs bc@BasicConfig{ transitions } = filter (isNothing . checkActivatedTransitionsConfig bc) $ + Nothing : [Just n | n <- [0..transitions]] isValidActivatedTransitions :: ActivatedTransitions String -> Bool isValidActivatedTransitions _ = True From dc2e0df541251298152d9c07fcfc964a61276235 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 10 Mar 2025 19:38:33 +0100 Subject: [PATCH 069/256] changed how input is read for app --- app/findActivatedTransitions.hs | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/app/findActivatedTransitions.hs b/app/findActivatedTransitions.hs index 3e52edd53..6e252dd84 100644 --- a/app/findActivatedTransitions.hs +++ b/app/findActivatedTransitions.hs @@ -26,6 +26,8 @@ import Modelling.PetriNet.Types ( import Control.OutputCapable.Blocks (Language (English)) import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Char (toLower) +import Data.List (stripPrefix) import Data.Maybe (isNothing) import System.IO ( BufferMode (NoBuffering), hSetBuffering, stdout, @@ -80,10 +82,19 @@ intInput d = do maybeIntInput :: Maybe Int -> IO (Maybe Int) maybeIntInput d = do input <- getLine - if null input then return d - else case readMaybe input of - Just n -> return (Just n) - Nothing -> return Nothing + let lowerInput = map toLower input + case lowerInput of + "" -> return d + "nothing" -> return Nothing + _ -> case stripPrefix "just " lowerInput of + Just num -> case readMaybe num of + Just n -> return (Just n) + Nothing -> invalid + Nothing -> invalid + where + invalid = do + putStrLn "Invalid input" + maybeIntInput d userInput :: FindActivatedTransitionsConfig -> IO (Int, Int, Int, Int, Maybe Int) userInput FindActivatedTransitionsConfig{basicConfig = BasicConfig{..}, changeConfig = ChangeConfig{..}, atMostActive = atMostActiveValue}= do @@ -95,6 +106,6 @@ userInput FindActivatedTransitionsConfig{basicConfig = BasicConfig{..}, changeCo tknCh <- intInput tokenChangeOverall putStr "FlowChange Overall: " flwCh <- intInput flowChangeOverall - putStr "AtMostActive Transitions (Input anything other than a number for 'irrelevance'): " + putStr "AtMostActive Transitions (Just Int/Nothing): " atMost <- maybeIntInput atMostActiveValue return (pls, trns, tknCh, flwCh, atMost) From 2d16b8ed4014ed94b5f7bfa80e982ef3a06a532d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 10 Mar 2025 20:15:31 +0100 Subject: [PATCH 070/256] toFindEvaluation now compares both sorted lists + reverted removal of line --- src/Modelling/PetriNet/Find.hs | 4 +--- src/Modelling/PetriNet/FindActivatedTransitions.hs | 1 + 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 6029a14c8..21f108081 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -166,11 +166,9 @@ toFindEvaluationList -> [Transition] -> LangM' m (Maybe String, a) toFindEvaluationList what withSol = - toFindEvaluation what withSol (==) formatList . sortCorrect + toFindEvaluation what withSol (\x y -> sort x == sort y) formatList where formatList transitions = show (transitionListShow transitions) - sortCorrect :: Ord a => [a] -> [a] - sortCorrect = sort checkFindBasicConfig :: BasicConfig -> Maybe String checkFindBasicConfig BasicConfig { atLeastActive } diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index ba4fcaecb..eefb9e3d4 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -317,6 +317,7 @@ pred #{activePredicateName}[#{activated} : set Transitions] { #{compChange changeC} #{compAdvConstraints advConfig} + no t : givenTransitions | activatedDefault[t] } run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int From 04d332a6ef9854a545163df40b13fb632e678f46 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 10 Mar 2025 20:24:32 +0100 Subject: [PATCH 071/256] corrected changes in enforceConstraints --- src/Modelling/PetriNet/Alloy.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 446041e37..d23fd2818 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -158,15 +158,17 @@ enforceConstraints underDefault atMostActive activated BasicConfig { places = given "Places" tokens = prepend "tokens" activatedConstraint = unlines [ - if atLeastActive <= 0 + if atLeastActive == 0 then "" else [i|\##{activated} >= #{atLeastActive}|], + if atLeastActive == 0 && atMostActive == Nothing + then "" + else [i| theActivated#{upperFirst which}Transitions[#{activated}]|], case atMostActive of - Just 0 -> [i| - \##{activated} <= 0 - theActivated#{upperFirst which}Transitions[#{activated}]|] + Just 0 -> [i| \##{activated} = 0|] Just atMost -> [i| \##{activated} <= #{atMost}|] - Nothing -> ""] + Nothing -> "" + ] connected :: String -> Maybe Bool -> String connected p = maybe "" $ \c -> (if c then "" else "not ") ++ p From d89d85e078be84ede1012683bc7ab8a2f192c7b8 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 11 Mar 2025 12:45:36 +0100 Subject: [PATCH 072/256] removed commas from enforceConstraints + hopefully fixed hlint --- src/Modelling/PetriNet/Alloy.hs | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index d23fd2818..a45039609 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -157,18 +157,17 @@ enforceConstraints underDefault atMostActive activated BasicConfig { nodes = given "Nodes" places = given "Places" tokens = prepend "tokens" - activatedConstraint = unlines [ - if atLeastActive == 0 - then "" - else [i|\##{activated} >= #{atLeastActive}|], - if atLeastActive == 0 && atMostActive == Nothing - then "" - else [i| theActivated#{upperFirst which}Transitions[#{activated}]|], - case atMostActive of - Just 0 -> [i| \##{activated} = 0|] - Just atMost -> [i| \##{activated} <= #{atMost}|] - Nothing -> "" - ] + activatedConstraint = unlines $ + (if atLeastActive == 0 + then [] + else [[i|\##{activated} >= #{atLeastActive}|]]) + ++ (if atLeastActive == 0 && atMostActive == Nothing + then [] + else [[i| theActivated#{upperFirst which}Transitions[#{activated}]|]]) + ++ (case atMostActive of + Just 0 -> [[i| \##{activated} = 0|]] + Just atMost -> [[i| \##{activated} <= #{atMost}|]] + Nothing -> []) connected :: String -> Maybe Bool -> String connected p = maybe "" $ \c -> (if c then "" else "not ") ++ p From d70ba18fcf12a37e5aa0c6c90ca86a37792699ac Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 11 Mar 2025 13:59:34 +0100 Subject: [PATCH 073/256] simplified code for enforceConstraints --- app/findActivatedTransitions.hs | 20 ++++++-------------- 1 file changed, 6 insertions(+), 14 deletions(-) diff --git a/app/findActivatedTransitions.hs b/app/findActivatedTransitions.hs index 6e252dd84..8f55c6f0a 100644 --- a/app/findActivatedTransitions.hs +++ b/app/findActivatedTransitions.hs @@ -26,8 +26,6 @@ import Modelling.PetriNet.Types ( import Control.OutputCapable.Blocks (Language (English)) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Data.Char (toLower) -import Data.List (stripPrefix) import Data.Maybe (isNothing) import System.IO ( BufferMode (NoBuffering), hSetBuffering, stdout, @@ -82,22 +80,16 @@ intInput d = do maybeIntInput :: Maybe Int -> IO (Maybe Int) maybeIntInput d = do input <- getLine - let lowerInput = map toLower input - case lowerInput of - "" -> return d - "nothing" -> return Nothing - _ -> case stripPrefix "just " lowerInput of - Just num -> case readMaybe num of - Just n -> return (Just n) - Nothing -> invalid - Nothing -> invalid - where - invalid = do + if null input then return d + else if input == "Nothing" then return Nothing + else case readMaybe input of + Just n -> return n + Nothing -> do putStrLn "Invalid input" maybeIntInput d userInput :: FindActivatedTransitionsConfig -> IO (Int, Int, Int, Int, Maybe Int) -userInput FindActivatedTransitionsConfig{basicConfig = BasicConfig{..}, changeConfig = ChangeConfig{..}, atMostActive = atMostActiveValue}= do +userInput FindActivatedTransitionsConfig{basicConfig = BasicConfig{..}, changeConfig = ChangeConfig{..}, atMostActive = atMostActiveValue} = do putStr "Number of Places: " pls <- intInput places putStr "Number of Transitions: " From a97db33dda403c8254cb6254b959eab531ea753f Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 11 Mar 2025 16:55:29 +0100 Subject: [PATCH 074/256] combine both ...input functions --- app/findActivatedTransitions.hs | 27 ++++++++------------------- 1 file changed, 8 insertions(+), 19 deletions(-) diff --git a/app/findActivatedTransitions.hs b/app/findActivatedTransitions.hs index 8f55c6f0a..4354d0c1b 100644 --- a/app/findActivatedTransitions.hs +++ b/app/findActivatedTransitions.hs @@ -67,37 +67,26 @@ mainFind i = forceErrors $ do else lift $ print c -intInput :: Int -> IO Int -intInput d = do +validateInput :: Read a => a -> IO a +validateInput d = do input <- getLine if null input then return d else case readMaybe input of Just n -> return n Nothing -> do putStrLn "Invalid input" - intInput d - -maybeIntInput :: Maybe Int -> IO (Maybe Int) -maybeIntInput d = do - input <- getLine - if null input then return d - else if input == "Nothing" then return Nothing - else case readMaybe input of - Just n -> return n - Nothing -> do - putStrLn "Invalid input" - maybeIntInput d + validateInput d userInput :: FindActivatedTransitionsConfig -> IO (Int, Int, Int, Int, Maybe Int) userInput FindActivatedTransitionsConfig{basicConfig = BasicConfig{..}, changeConfig = ChangeConfig{..}, atMostActive = atMostActiveValue} = do putStr "Number of Places: " - pls <- intInput places + pls <- validateInput places putStr "Number of Transitions: " - trns <- intInput transitions + trns <- validateInput transitions putStr "TokenChange Overall: " - tknCh <- intInput tokenChangeOverall + tknCh <- validateInput tokenChangeOverall putStr "FlowChange Overall: " - flwCh <- intInput flowChangeOverall + flwCh <- validateInput flowChangeOverall putStr "AtMostActive Transitions (Just Int/Nothing): " - atMost <- maybeIntInput atMostActiveValue + atMost <- validateInput atMostActiveValue return (pls, trns, tknCh, flwCh, atMost) From d0e21f129cd78831a8c2ad4d6973f73d0e6e9063 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 11 Mar 2025 17:57:49 +0100 Subject: [PATCH 075/256] minor tweaks --- src/Modelling/PetriNet/Alloy.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index a45039609..2ddc7f91c 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -164,10 +164,10 @@ enforceConstraints underDefault atMostActive activated BasicConfig { ++ (if atLeastActive == 0 && atMostActive == Nothing then [] else [[i| theActivated#{upperFirst which}Transitions[#{activated}]|]]) - ++ (case atMostActive of - Just 0 -> [[i| \##{activated} = 0|]] - Just atMost -> [[i| \##{activated} <= #{atMost}|]] - Nothing -> []) + ++ case atMostActive of + Just 0 -> [[i| no #{activated}|]] + Just atMost -> [[i| \##{activated} =< #{atMost}|]] + Nothing -> [] connected :: String -> Maybe Bool -> String connected p = maybe "" $ \c -> (if c then "" else "not ") ++ p From 9498e58f47b2cce00e3283b612cbb74e2e2cd90e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 11 Mar 2025 18:17:10 +0100 Subject: [PATCH 076/256] small code tweaks --- src/Modelling/PetriNet/Find.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 21f108081..87ad4b89c 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -152,11 +152,10 @@ toFindEvaluationTuple -> (Transition, Transition) -> LangM' m (Maybe String, a) toFindEvaluationTuple what withSol = - toFindEvaluation what withSol pairEquals formatPair + toFindEvaluation what withSol pairEquals (show . transitionPairShow) where pairEquals (ft, st) (fi, si) = (ft == fi && st == si) || (ft == si && st == fi) - formatPair pair = show (transitionPairShow pair) toFindEvaluationList :: (Num a, OutputCapable m) @@ -166,9 +165,7 @@ toFindEvaluationList -> [Transition] -> LangM' m (Maybe String, a) toFindEvaluationList what withSol = - toFindEvaluation what withSol (\x y -> sort x == sort y) formatList - where - formatList transitions = show (transitionListShow transitions) + toFindEvaluation what withSol (\x y -> sort x == sort y) (show . transitionListShow) checkFindBasicConfig :: BasicConfig -> Maybe String checkFindBasicConfig BasicConfig { atLeastActive } From 6511ace85e0b9b3411aef9ebde72f6862f93a5f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 11 Mar 2025 19:10:55 +0100 Subject: [PATCH 077/256] address hlint comment elsewhere --- src/Modelling/CdOd/Types.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Modelling/CdOd/Types.hs b/src/Modelling/CdOd/Types.hs index d707aed70..1de92ad6f 100644 --- a/src/Modelling/CdOd/Types.hs +++ b/src/Modelling/CdOd/Types.hs @@ -729,10 +729,10 @@ checkClassConfigWithProperties | Just False == y = 0 | otherwise = x plusOne x = if x /= 0 then x + 1 else x - minNonInheritances = (+ selfRelationshipsAmount) . plusOne $ sum [ - 1 `forMaybe` hasDoubleRelationships, - 1 `forMaybe` hasReverseRelationships - ] + minNonInheritances = (+ selfRelationshipsAmount) . plusOne $ ( + (1 `forMaybe` hasDoubleRelationships) + + (1 `forMaybe` hasReverseRelationships) + ) minInheritances = (+ selfInheritancesAmount) . plusOne $ sum [ 1 `for` hasReverseInheritances, 1 `forMaybe` hasMultipleInheritances, From 342ace5dd1d9ffadf5e564aad484a71846b67ec7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 11 Mar 2025 19:17:17 +0100 Subject: [PATCH 078/256] simplify code --- src/Modelling/PetriNet/Alloy.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 2ddc7f91c..a9459f82d 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -158,9 +158,7 @@ enforceConstraints underDefault atMostActive activated BasicConfig { places = given "Places" tokens = prepend "tokens" activatedConstraint = unlines $ - (if atLeastActive == 0 - then [] - else [[i|\##{activated} >= #{atLeastActive}|]]) + [ [i|\##{activated} >= #{atLeastActive}|] | atLeastActive > 0 ] ++ (if atLeastActive == 0 && atMostActive == Nothing then [] else [[i| theActivated#{upperFirst which}Transitions[#{activated}]|]]) From 218505efefab9ce7d334612c25e28258e1e8f2d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 11 Mar 2025 19:23:41 +0100 Subject: [PATCH 079/256] simplify more code --- src/Modelling/PetriNet/Alloy.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index a9459f82d..cb8ce1c83 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -159,9 +159,8 @@ enforceConstraints underDefault atMostActive activated BasicConfig { tokens = prepend "tokens" activatedConstraint = unlines $ [ [i|\##{activated} >= #{atLeastActive}|] | atLeastActive > 0 ] - ++ (if atLeastActive == 0 && atMostActive == Nothing - then [] - else [[i| theActivated#{upperFirst which}Transitions[#{activated}]|]]) + ++ + [ [i| theActivated#{upperFirst which}Transitions[#{activated}]|] | atLeastActive > 0 || atMostActive /= Nothing ] ++ case atMostActive of Just 0 -> [[i| no #{activated}|]] Just atMost -> [[i| \##{activated} =< #{atMost}|]] From 91ab6868a0d0fc3c62ef5e54af5080f3ed0ba4fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 11 Mar 2025 19:33:35 +0100 Subject: [PATCH 080/256] use isJust --- src/Modelling/PetriNet/Alloy.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index cb8ce1c83..a4c25f004 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -54,6 +54,7 @@ import Control.Monad.Random ( import Data.Composition ((.:)) import Data.FileEmbed (embedStringFile) import Data.List (intercalate) +import Data.Maybe (isJust) import Data.Set (Set) import Data.String.Interpolate (i) import Language.Alloy.Call ( @@ -160,7 +161,7 @@ enforceConstraints underDefault atMostActive activated BasicConfig { activatedConstraint = unlines $ [ [i|\##{activated} >= #{atLeastActive}|] | atLeastActive > 0 ] ++ - [ [i| theActivated#{upperFirst which}Transitions[#{activated}]|] | atLeastActive > 0 || atMostActive /= Nothing ] + [ [i| theActivated#{upperFirst which}Transitions[#{activated}]|] | atLeastActive > 0 || isJust atMostActive ] ++ case atMostActive of Just 0 -> [[i| no #{activated}|]] Just atMost -> [[i| \##{activated} =< #{atMost}|]] From 632956a02f574f3d98183cd9afc05f619789f928 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 11 Mar 2025 19:57:37 +0100 Subject: [PATCH 081/256] inline singular name (that should have been plural, but that would likely conflict with a field accessor) --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index eefb9e3d4..2889f140b 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -329,10 +329,7 @@ activePredicateName :: String activePredicateName = "showActiveTransition" activatedTransitions :: String -activatedTransitions = skolemVariable activePredicateName transition - -transition :: String -transition = "activatedTrans" +activatedTransitions = skolemVariable activePredicateName "activatedTrans" checkFindActivatedTransitionsConfig :: FindActivatedTransitionsConfig -> Maybe String checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { From 14624da7b5903e282ecb51bdca4c96935bafca91 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 11 Mar 2025 22:34:53 +0100 Subject: [PATCH 082/256] added case for 0/Nothing (atLeast/atMost) to alloy code --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 2889f140b..e21f2da8d 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -118,6 +118,7 @@ import Control.Monad.Random ( import Control.Monad.Trans (MonadTrans (lift)) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) +import Data.Maybe (isNothing) import Data.String.Interpolate (i, iii) import Language.Alloy.Call ( AlloyInstance @@ -317,6 +318,7 @@ pred #{activePredicateName}[#{activated} : set Transitions] { #{compChange changeC} #{compAdvConstraints advConfig} + #{activatedConstraints basicC atMost} no t : givenTransitions | activatedDefault[t] } @@ -324,6 +326,12 @@ run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petri |] where activated = "activatedTrans" + activatedConstraints :: BasicConfig -> Maybe Int -> String + activatedConstraints BasicConfig{ atLeastActive } atMostActive + | atLeastActive == 0 && isNothing atMostActive + = [i|theActivatedTransitions[#{activated}]|] + | otherwise + = "" activePredicateName :: String activePredicateName = "showActiveTransition" From 76c793a1b32e8cfed711d7181aaa2a59be01815e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Wed, 12 Mar 2025 08:52:21 +0100 Subject: [PATCH 083/256] skolem variables only when really needed --- src/Modelling/PetriNet/Concurrency.hs | 7 +++++-- src/Modelling/PetriNet/Conflict.hs | 7 +++++-- src/Modelling/PetriNet/MatchToMath.hs | 12 ++++++++---- 3 files changed, 18 insertions(+), 8 deletions(-) diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index bfc18e970..c8da0a832 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -422,7 +422,7 @@ petriNetConcurrencyAlloy basicC changeC specific #{modulePetriConcepts} #{modulePetriConstraints} -pred #{concurrencyPredicateName}[#{defaultActiveTrans}#{activated} : set Transitions, #{t1}, #{t2} : Transitions] { +pred #{concurrencyPredicateName}[#{skolemSets}#{t1}, #{t2} : Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} #{compBasicConstraints True Nothing activated basicC} @@ -450,11 +450,14 @@ run #{concurrencyPredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{ no t : Transitions | sourceTransitions[t]|] | otherwise = "" defaultActiveTrans - | isLeft specific = [i|#{activatedDefault} : set givenTransitions,|] + | isLeft specific = [i|#{activatedDefault} : set givenTransitions, |] | otherwise = "" sigs = signatures "given" (places basicC) (transitions basicC) t1 = transition1 t2 = transition2 + skolemSets + | atLeastActive basicC > 0 = [i|#{defaultActiveTrans}#{activated} : set Transitions, |] + | otherwise = "" concurrencyPredicateName :: String concurrencyPredicateName = "showConcurrency" diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index 9e99bd30d..aab2c2e1c 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -489,7 +489,7 @@ petriNetConflictAlloy basicC changeC conflictC uniqueConflictP specific #{modulePetriConcepts} #{modulePetriConstraints} -pred #{conflictPredicateName}[#{p} : some Places,#{defaultActiveTrans}#{activated} : set Transitions, #{t1}, #{t2} : Transitions] { +pred #{conflictPredicateName}[#{p} : some Places, #{skolemSets}#{t1}, #{t2} : Transitions] { \#Places = #{places basicC} \#Transitions = #{transitions basicC} #{compBasicConstraints True Nothing activated basicC} @@ -552,7 +552,7 @@ run #{conflictPredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{pet let ps = common#{upperFirst which}Preconditions[t1, t2] | \#ps > 1 and all p : ps | p.#{tokens} >= p.#{flow}[t1] and p.#{tokens} >= p.#{flow}[t2]|] defaultActiveTrans - | isLeft specific = [i|#{activatedDefault} : set givenTransitions,|] + | isLeft specific = [i|#{activatedDefault} : set givenTransitions, |] | otherwise = "" multiplePlaces unique | unique == Just True @@ -565,6 +565,9 @@ run #{conflictPredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{pet sigs = signatures "given" (places basicC) (transitions basicC) t1 = transition1 t2 = transition2 + skolemSets + | atLeastActive basicC > 0 = [i|#{defaultActiveTrans}#{activated} : set Transitions, |] + | otherwise = "" conflictPredicateName :: String conflictPredicateName = "showConflict" diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index fcccfde50..cb8c717e0 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -556,7 +556,7 @@ fact{ no givenTransitions } -pred showNets[#{activated} : set Transitions] { +pred showNets[#{skolemSet}] { \#Places = #{places} \#Transitions = #{transitions} #{compBasicConstraints True Nothing activated basicC} @@ -565,7 +565,9 @@ pred showNets[#{activated} : set Transitions] { run showNets for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] where - activated = "activatedTrans" + (skolemSet, activated) + | atLeastActive basicC > 0 = ([i|#{activated} : set Transitions|], "activatedTrans") + | otherwise = ("", undefined) renderFalse :: Net p n => p n String -> MathConfig -> String renderFalse @@ -585,7 +587,7 @@ fact{ #{defaultFlow} } -pred showFalseNets[#{activated} : set Transitions]{ +pred showFalseNets[#{skolemSet}]{ #{compBasicConstraints True Nothing activated basicConfig} #{compAdvConstraints advConfig} #{compChange changeConfig} @@ -596,7 +598,6 @@ run showFalseNets for exactly #{petriScopeMaxSeq basicConfig} Nodes, #{petriScop where allNodes = nodes net (ps, ts) = M.partition isPlaceNode allNodes - activated = "activatedTrans" places = unlines [extendLine p "givenPlaces" | p <- M.keys ps] transitions = unlines [extendLine t "givenTransitions" | t <- M.keys ts] initialMark = M.foldrWithKey (\k -> (++) . tokenLine k) "" $ initialTokens <$> ps @@ -617,6 +618,9 @@ run showFalseNets for exactly #{petriScopeMaxSeq basicConfig} Nodes, #{petriScop |] flowLine from to (Just f) = [i| #{from}.defaultFlow[#{to}] = #{f} |] + (skolemSet, activated) + | atLeastActive basicConfig > 0 = ([i|#{activated} : set Transitions|], "activatedTrans") + | otherwise = ("", undefined) defaultGraphToMathInstance :: GraphToMathInstance defaultGraphToMathInstance = MatchInstance { From 42ba52a5cf09718e58e6cf3950d79401d7ed1224 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Wed, 12 Mar 2025 08:53:48 +0100 Subject: [PATCH 084/256] tweaks for readability/documentation --- .../PetriNet/FindActivatedTransitions.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index e21f2da8d..b1aaf5356 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -318,26 +318,29 @@ pred #{activePredicateName}[#{activated} : set Transitions] { #{compChange changeC} #{compAdvConstraints advConfig} - #{activatedConstraints basicC atMost} + #{activatedConstraint basicC atMost} no t : givenTransitions | activatedDefault[t] } run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] where - activated = "activatedTrans" - activatedConstraints :: BasicConfig -> Maybe Int -> String - activatedConstraints BasicConfig{ atLeastActive } atMostActive + activated = skolemName + activatedConstraint :: BasicConfig -> Maybe Int -> String + activatedConstraint BasicConfig{ atLeastActive } atMostActive | atLeastActive == 0 && isNothing atMostActive = [i|theActivatedTransitions[#{activated}]|] | otherwise - = "" + = "" -- because in all other cases already compBasicConstraints emits that constraint activePredicateName :: String activePredicateName = "showActiveTransition" activatedTransitions :: String -activatedTransitions = skolemVariable activePredicateName "activatedTrans" +activatedTransitions = skolemVariable activePredicateName skolemName + +skolemName :: String +skolemName = "activatedTrans" checkFindActivatedTransitionsConfig :: FindActivatedTransitionsConfig -> Maybe String checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { From 5aac6561289cf0b778a2c50597951f9995d04083 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 16 Mar 2025 23:53:22 +0100 Subject: [PATCH 085/256] added new check for FindActivatedTransitions --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index b1aaf5356..97b45bb21 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -364,6 +364,8 @@ checkActivatedTransitionsConfig BasicConfig { Just atMost | atMost < 0 -> Just "atMostActive must be non-negative." + | atMost == transitions + -> Just "When atMostActive equals the total number of transitions, it is redundant. Rather use atMostActive = 'Nothing' instead." | atLeastActive > atMost -> Just "atLeastActive must not be greater than atMostActive." | transitions < atMost From 896748206957eccb1426ba77640b1a82cac3d7de Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 17 Mar 2025 22:00:40 +0100 Subject: [PATCH 086/256] added check to FindActivatedTransitions -one case where noInstanceAvailable when atMostActive = Nothing, but instance found when atMostActive = Just 2, which should not happen --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 97b45bb21..657e56646 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -330,6 +330,8 @@ run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petri activatedConstraint BasicConfig{ atLeastActive } atMostActive | atLeastActive == 0 && isNothing atMostActive = [i|theActivatedTransitions[#{activated}]|] + -- | atMost == Nothing + -- = [i|\##{activated} =< #{transitions}|] | otherwise = "" -- because in all other cases already compBasicConstraints emits that constraint From 7eab20d974820bfd7dcfbef795ea18d5c675de3a Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 17 Mar 2025 22:06:05 +0100 Subject: [PATCH 087/256] fixed comment --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 657e56646..4c880fd70 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -330,8 +330,8 @@ run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petri activatedConstraint BasicConfig{ atLeastActive } atMostActive | atLeastActive == 0 && isNothing atMostActive = [i|theActivatedTransitions[#{activated}]|] - -- | atMost == Nothing - -- = [i|\##{activated} =< #{transitions}|] + | atMost == Nothing + = [i|\##{activated} =< #{transitions}|] | otherwise = "" -- because in all other cases already compBasicConstraints emits that constraint From 8d8bf59e6a32d3672d75081c13983d08c95e50b2 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 17 Mar 2025 22:16:51 +0100 Subject: [PATCH 088/256] fixed mistakes --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 4c880fd70..4ec6885e3 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -327,10 +327,10 @@ run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petri where activated = skolemName activatedConstraint :: BasicConfig -> Maybe Int -> String - activatedConstraint BasicConfig{ atLeastActive } atMostActive + activatedConstraint BasicConfig{ transitions, atLeastActive } atMostActive | atLeastActive == 0 && isNothing atMostActive = [i|theActivatedTransitions[#{activated}]|] - | atMost == Nothing + | isNothing atMostActive = [i|\##{activated} =< #{transitions}|] | otherwise = "" -- because in all other cases already compBasicConstraints emits that constraint From f73922d160c21a4b9e4cc1e8ebc274d4d4287aa4 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 17 Mar 2025 22:28:58 +0100 Subject: [PATCH 089/256] isolated check in FindActivatedTransitions --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 4ec6885e3..f5c95867d 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -319,6 +319,7 @@ pred #{activePredicateName}[#{activated} : set Transitions] { #{compAdvConstraints advConfig} #{activatedConstraint basicC atMost} + #{extraAtMostActive basicC atMost} no t : givenTransitions | activatedDefault[t] } @@ -327,13 +328,17 @@ run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petri where activated = skolemName activatedConstraint :: BasicConfig -> Maybe Int -> String - activatedConstraint BasicConfig{ transitions, atLeastActive } atMostActive + activatedConstraint BasicConfig{ atLeastActive } atMostActive | atLeastActive == 0 && isNothing atMostActive = [i|theActivatedTransitions[#{activated}]|] + | otherwise + = "" -- because in all other cases already compBasicConstraints emits that constraint + extraAtMostActive :: BasicConfig -> Maybe Int -> String + extraAtMostActive BasicConfig{ transitions } atMostActive | isNothing atMostActive = [i|\##{activated} =< #{transitions}|] | otherwise - = "" -- because in all other cases already compBasicConstraints emits that constraint + = "" activePredicateName :: String activePredicateName = "showActiveTransition" From f79943c8dafac64748b5392aeeaa662ee2784cef Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 18 Mar 2025 23:41:31 +0100 Subject: [PATCH 090/256] fixed defaultFindActivatedTransitionsConfig after new check --- src/Modelling/PetriNet/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 5116f5f96..b826e68dd 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -942,7 +942,7 @@ defaultFindActivatedTransitionsConfig = FindActivatedTransitionsConfig { basicConfig = defaultBasicConfig { atLeastActive = 1 } , advConfig = defaultAdvConfig , changeConfig = defaultChangeConfig - , atMostActive = Just 3 + , atMostActive = Nothing , graphConfig = defaultGraphConfig { hidePlaceNames = True } , printSolution = False , alloyConfig = defaultAlloyConfig From 9a54a81c2d47f7b50f3ca544856905cd433fe376 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 19 Mar 2025 19:27:21 +0100 Subject: [PATCH 091/256] added check to prohibit "Patchwork" as a renderer MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Ich habe den check als neue Funktion geschrieben. Dadurch kann er, falls nötig, schnell entfernt werden --- src/Modelling/PetriNet/Find.hs | 9 +++++++++ src/Modelling/PetriNet/FindActivatedTransitions.hs | 2 ++ src/Modelling/PetriNet/Reach/Deadlock.hs | 2 +- src/Modelling/PetriNet/Reach/Reach.hs | 2 +- src/Modelling/PetriNet/Types.hs | 3 ++- 5 files changed, 15 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 87ad4b89c..bb814bc69 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -17,6 +17,7 @@ module Modelling.PetriNet.Find ( findTaskInstance, lToFind, prohibitHideTransitionNames, + prohibitPatchworkRenderer, toFindEvaluation, toFindEvaluationList, toFindEvaluationTuple, @@ -179,6 +180,7 @@ checkConfigForFind basic change graph = <|> prohibitHideTransitionNames graph <|> checkBasicConfig basic <|> checkChangeConfig basic change + <|> prohibitPatchworkRenderer graph prohibitHideTransitionNames :: GraphConfig -> Maybe String prohibitHideTransitionNames gc @@ -186,3 +188,10 @@ prohibitHideTransitionNames gc = Just "Transition names are required for this task type" | otherwise = Nothing + +prohibitPatchworkRenderer :: GraphConfig -> Maybe String +prohibitPatchworkRenderer gc + | any ((== "Patchwork") . show) (graphLayouts gc) + = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." + | otherwise + = Nothing diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index f5c95867d..89976ce01 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -67,6 +67,7 @@ import Modelling.PetriNet.Find ( findInitialList, findTaskInstance, prohibitHideTransitionNames, + prohibitPatchworkRenderer, toFindEvaluationList, ) import Modelling.PetriNet.Reach.Type ( @@ -360,6 +361,7 @@ checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { <|> checkBasicConfig basicConfig <|> checkChangeConfig basicConfig changeConfig <|> checkActivatedTransitionsConfig basicConfig atMostActive + <|> prohibitPatchworkRenderer graphConfig checkActivatedTransitionsConfig :: BasicConfig -> Maybe Int -> Maybe String checkActivatedTransitionsConfig BasicConfig { diff --git a/src/Modelling/PetriNet/Reach/Deadlock.hs b/src/Modelling/PetriNet/Reach/Deadlock.hs index 4bec66a2b..79d73c0d2 100644 --- a/src/Modelling/PetriNet/Reach/Deadlock.hs +++ b/src/Modelling/PetriNet/Reach/Deadlock.hs @@ -209,7 +209,7 @@ defaultDeadlockConfig = numPlaces = 4, numTransitions = 4, Modelling.PetriNet.Reach.Deadlock.capacity = Unbounded, - drawCommands = [Dot, Neato, TwoPi, Circo, Fdp, Sfdp, Osage, Patchwork], + drawCommands = [Dot, Neato, TwoPi, Circo, Fdp, Sfdp, Osage], maxTransitionLength = 10, minTransitionLength = 8, postconditionsRange = (0, Nothing), diff --git a/src/Modelling/PetriNet/Reach/Reach.hs b/src/Modelling/PetriNet/Reach/Reach.hs index 5efb8f658..f0684c8c1 100644 --- a/src/Modelling/PetriNet/Reach/Reach.hs +++ b/src/Modelling/PetriNet/Reach/Reach.hs @@ -346,7 +346,7 @@ defaultReachConfig = ReachConfig { numPlaces = 4, numTransitions = 4, Modelling.PetriNet.Reach.Reach.capacity = Unbounded, - drawCommands = [Dot, Neato, TwoPi, Circo, Fdp, Sfdp, Osage, Patchwork], + drawCommands = [Dot, Neato, TwoPi, Circo, Fdp, Sfdp, Osage], maxTransitionLength = 8, minTransitionLength = 6, postconditionsRange = (0, Nothing), diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index b826e68dd..c11caf403 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -741,7 +741,7 @@ data GraphConfig = GraphConfig { defaultGraphConfig :: GraphConfig defaultGraphConfig = GraphConfig { - graphLayouts = [Dot, Neato, TwoPi, Circo, Fdp, Sfdp, Osage, Patchwork], + graphLayouts = [Dot, Neato, TwoPi, Circo, Fdp, Sfdp, Osage], hidePlaceNames = False, hideTransitionNames = False, hideWeight1 = True @@ -1094,5 +1094,6 @@ checkGraphLayouts useDifferent wrongInstances gc = Just "At least one graph layout needs to be provided." | useDifferent && length (graphLayouts gc) <= wrongInstances = Just "The parameter 'graphLayout' has to contain more entries than the number of 'wrongInstances' if 'useDifferentGraphLayouts' is set." + | any ((== "Patchwork") . show) (graphLayouts gc) | otherwise = Nothing From 281e1211462b47e12faf7002123f4825040dc0c4 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 19 Mar 2025 21:15:10 +0100 Subject: [PATCH 092/256] added error message to check --- src/Modelling/PetriNet/Types.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index c11caf403..b0b4cfa01 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1095,5 +1095,6 @@ checkGraphLayouts useDifferent wrongInstances gc | useDifferent && length (graphLayouts gc) <= wrongInstances = Just "The parameter 'graphLayout' has to contain more entries than the number of 'wrongInstances' if 'useDifferentGraphLayouts' is set." | any ((== "Patchwork") . show) (graphLayouts gc) + = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise = Nothing From 3d8dd6348bd6019e2a07d8c368fad74df0d8dda0 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 19 Mar 2025 23:08:54 +0100 Subject: [PATCH 093/256] simplified Patchwork check --- src/Modelling/PetriNet/Find.hs | 3 ++- src/Modelling/PetriNet/Types.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index bb814bc69..ae74f2d2c 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -68,6 +68,7 @@ import Control.Monad.Random ( RandomGen, ) import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.GraphViz.Attributes.Complete (GraphvizCommand (..)) import Data.List (sort) import Data.Map (Map) import Language.Alloy.Call ( @@ -191,7 +192,7 @@ prohibitHideTransitionNames gc prohibitPatchworkRenderer :: GraphConfig -> Maybe String prohibitPatchworkRenderer gc - | any ((== "Patchwork") . show) (graphLayouts gc) + | any (== Patchwork) (graphLayouts gc) = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise = Nothing diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index b0b4cfa01..6820f6970 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1094,7 +1094,7 @@ checkGraphLayouts useDifferent wrongInstances gc = Just "At least one graph layout needs to be provided." | useDifferent && length (graphLayouts gc) <= wrongInstances = Just "The parameter 'graphLayout' has to contain more entries than the number of 'wrongInstances' if 'useDifferentGraphLayouts' is set." - | any ((== "Patchwork") . show) (graphLayouts gc) + | any (== Patchwork) (graphLayouts gc) = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise = Nothing From a27778817869712251122183c3e8d92b5d2cfd2d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 19 Mar 2025 23:09:26 +0100 Subject: [PATCH 094/256] prohibited self loops of transitions --- src/Modelling/PetriNet/PickMistake.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index ad5d476e1..a4b648d89 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -212,10 +212,19 @@ pred #{mistakePredicateName} { #{pickMistakeConstraints mistakeC} #{compChange changeC} #{defaultConstraints undefined basicC} + + #{prohibitTransitionSelfLoop mistakeC} } run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] + where + prohibitTransitionSelfLoop :: MistakeConfig -> String + prohibitTransitionSelfLoop MistakeConfig{ canHaveTransitionToTransition } + | canHaveTransitionToTransition + = [i|all t : Transitions | no t.flow[t]|] + | otherwise + = "" mistakePredicateName :: String mistakePredicateName = "showMistake" From 659779f0f8c91c987ba47a0824fe925aca5b5c69 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 19 Mar 2025 23:36:28 +0100 Subject: [PATCH 095/256] fixed hlint --- src/Modelling/PetriNet/Find.hs | 2 +- src/Modelling/PetriNet/Types.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index ae74f2d2c..8acf9b74c 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -192,7 +192,7 @@ prohibitHideTransitionNames gc prohibitPatchworkRenderer :: GraphConfig -> Maybe String prohibitPatchworkRenderer gc - | any (== Patchwork) (graphLayouts gc) + | elem Patchwork (graphLayouts gc) = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise = Nothing diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 6820f6970..0eb354653 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1094,7 +1094,7 @@ checkGraphLayouts useDifferent wrongInstances gc = Just "At least one graph layout needs to be provided." | useDifferent && length (graphLayouts gc) <= wrongInstances = Just "The parameter 'graphLayout' has to contain more entries than the number of 'wrongInstances' if 'useDifferentGraphLayouts' is set." - | any (== Patchwork) (graphLayouts gc) + | elem Patchwork (graphLayouts gc) = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise = Nothing From 484f50c14bff0965790f55f2f8ce95d90af1ee0b Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 19 Mar 2025 23:40:29 +0100 Subject: [PATCH 096/256] used infix --- src/Modelling/PetriNet/Find.hs | 2 +- src/Modelling/PetriNet/Types.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 8acf9b74c..278481014 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -192,7 +192,7 @@ prohibitHideTransitionNames gc prohibitPatchworkRenderer :: GraphConfig -> Maybe String prohibitPatchworkRenderer gc - | elem Patchwork (graphLayouts gc) + | Patchwork `elem` (graphLayouts gc) = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise = Nothing diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 0eb354653..b10350200 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1094,7 +1094,7 @@ checkGraphLayouts useDifferent wrongInstances gc = Just "At least one graph layout needs to be provided." | useDifferent && length (graphLayouts gc) <= wrongInstances = Just "The parameter 'graphLayout' has to contain more entries than the number of 'wrongInstances' if 'useDifferentGraphLayouts' is set." - | elem Patchwork (graphLayouts gc) + | Patchwork `elem` (graphLayouts gc) = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise = Nothing From c39e9a0a58036e63edea55e2108e0b2e3af70c58 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 19 Mar 2025 23:42:50 +0100 Subject: [PATCH 097/256] removed brackets --- src/Modelling/PetriNet/Find.hs | 2 +- src/Modelling/PetriNet/Types.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 278481014..88c609701 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -192,7 +192,7 @@ prohibitHideTransitionNames gc prohibitPatchworkRenderer :: GraphConfig -> Maybe String prohibitPatchworkRenderer gc - | Patchwork `elem` (graphLayouts gc) + | Patchwork `elem` graphLayouts gc = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise = Nothing diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index b10350200..1c36874b1 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1094,7 +1094,7 @@ checkGraphLayouts useDifferent wrongInstances gc = Just "At least one graph layout needs to be provided." | useDifferent && length (graphLayouts gc) <= wrongInstances = Just "The parameter 'graphLayout' has to contain more entries than the number of 'wrongInstances' if 'useDifferentGraphLayouts' is set." - | Patchwork `elem` (graphLayouts gc) + | Patchwork `elem` graphLayouts gc = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise = Nothing From 405b8f62a7bf10965bea6b2818d3e9467a342135 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 20 Mar 2025 22:05:39 +0100 Subject: [PATCH 098/256] also prohibit place self loops --- src/Modelling/PetriNet/PickMistake.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index a4b648d89..7c9ef4fe7 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -213,16 +213,16 @@ pred #{mistakePredicateName} { #{compChange changeC} #{defaultConstraints undefined basicC} - #{prohibitTransitionSelfLoop mistakeC} + #{prohibitSelfLoops mistakeC} } run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int |] where - prohibitTransitionSelfLoop :: MistakeConfig -> String - prohibitTransitionSelfLoop MistakeConfig{ canHaveTransitionToTransition } - | canHaveTransitionToTransition - = [i|all t : Transitions | no t.flow[t]|] + prohibitSelfLoops :: MistakeConfig -> String + prohibitSelfLoops MistakeConfig{ canHaveTransitionToTransition, canHavePlaceToPlace } + | canHaveTransitionToTransition || canHavePlaceToPlace + = [i|all n : Nodes | no n.flow[n]|] | otherwise = "" From 58c8960dc25c5477c947bd296927a15854a72009 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 21 Mar 2025 11:01:57 +0100 Subject: [PATCH 099/256] cleanup --- app/findActivatedTransitions.hs | 2 +- app/pickMistake.hs | 38 +++++++------------ .../PetriNet/FindActivatedTransitions.hs | 4 +- src/Modelling/PetriNet/PickMistake.hs | 2 - .../PetriNet/FindActivatedTransitionsSpec.hs | 2 +- 5 files changed, 16 insertions(+), 32 deletions(-) diff --git a/app/findActivatedTransitions.hs b/app/findActivatedTransitions.hs index 4354d0c1b..7981b4e1d 100644 --- a/app/findActivatedTransitions.hs +++ b/app/findActivatedTransitions.hs @@ -25,7 +25,7 @@ import Modelling.PetriNet.Types ( ) import Control.OutputCapable.Blocks (Language (English)) -import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Trans.Class (lift) import Data.Maybe (isNothing) import System.IO ( BufferMode (NoBuffering), hSetBuffering, stdout, diff --git a/app/pickMistake.hs b/app/pickMistake.hs index a1ee814cd..6f929a857 100644 --- a/app/pickMistake.hs +++ b/app/pickMistake.hs @@ -27,7 +27,6 @@ import Modelling.PetriNet.Types ( import Control.OutputCapable.Blocks (Language (English)) import Control.Monad.Trans.Class (lift) -import Data.Char (toLower) import Data.Maybe (isNothing) import System.IO ( BufferMode (NoBuffering), hSetBuffering, stdout, @@ -48,7 +47,7 @@ mainPick :: Int -> IO () mainPick i = forceErrors $ do let theConfig@PickMistakeConfig{..} = defaultPickMistakeConfig lift $ pPrint theConfig - (pls, trns, tknChange, flwChange, negTokCost, transToTr, placeToPl) <- lift $ userInput theConfig + (pls, trns, tknChange, flwChange, negWeight, transToTr, placeToPl) <- lift $ userInput theConfig let config = theConfig { basicConfig = basicConfig { places = pls, @@ -59,7 +58,7 @@ mainPick i = forceErrors $ do flowChangeOverall = flwChange }, mistakeConfig = mistakeConfig { - canHaveNegativeWeight = negTokCost, + canHaveNegativeWeight = negWeight, canHaveTransitionToTransition = transToTr, canHavePlaceToPlace = placeToPl } @@ -73,41 +72,30 @@ mainPick i = forceErrors $ do else lift $ print c -boolInput :: Bool -> IO Bool -boolInput d = do - input <- getLine - case map toLower input of - "" -> return d - "true" -> return True - "false" -> return False - _ -> do - putStrLn "Invalid input" - boolInput d - -intInput :: Int -> IO Int -intInput d = do +validateInput :: Read a => a -> IO a +validateInput d = do input <- getLine if null input then return d else case readMaybe input of Just n -> return n Nothing -> do putStrLn "Invalid input" - intInput d + validateInput d userInput :: PickMistakeConfig -> IO (Int, Int, Int, Int, Bool, Bool, Bool) userInput PickMistakeConfig{basicConfig = BasicConfig{..}, changeConfig = ChangeConfig{..}, mistakeConfig = MistakeConfig{..}} = do putStr "Number of Places: " - pls <- intInput places + pls <- validateInput places putStr "Number of Transitions: " - trns <- intInput transitions + trns <- validateInput transitions putStr "TokenChange Overall: " - tknCh <- intInput tokenChangeOverall + tknCh <- validateInput tokenChangeOverall putStr "FlowChange Overall: " - flwCh <- intInput flowChangeOverall + flwCh <- validateInput flowChangeOverall putStr "Negative Token Cost (True/False): " - negTokCost <- boolInput canHaveNegativeWeight + negWeight <- validateInput canHaveNegativeWeight putStr "Transition to Transition (True/False): " - transToTr <- boolInput canHaveTransitionToTransition + transToTr <- validateInput canHaveTransitionToTransition putStr "Places to Places (True/False): " - placeToPl <- boolInput canHavePlaceToPlace - return (pls, trns, tknCh, flwCh, negTokCost, transToTr, placeToPl) + placeToPl <- validateInput canHavePlaceToPlace + return (pls, trns, tknCh, flwCh, negWeight, transToTr, placeToPl) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 89976ce01..ff6cfe3ec 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE LambdaCase #-} module Modelling.PetriNet.FindActivatedTransitions ( checkActivatedTransitionsConfig, @@ -185,7 +184,7 @@ findActivatedTransitionsTask path task = do english "Consider the following Petri net:" german "Betrachten Sie folgendes Petrinetz:" image - $=<< renderWith path "activatedTransition" (net task) (drawFindWith task) + $=<< renderWith path "activatedTransitions" (net task) (drawFindWith task) paragraph $ translate $ do english [iii| Which transitions are activated @@ -318,7 +317,6 @@ pred #{activePredicateName}[#{activated} : set Transitions] { #{compBasicConstraints True atMost activated basicC} #{compChange changeC} #{compAdvConstraints advConfig} - #{activatedConstraint basicC atMost} #{extraAtMostActive basicC atMost} no t : givenTransitions | activatedDefault[t] diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index 7c9ef4fe7..a96cdc571 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -8,7 +8,6 @@ module Modelling.PetriNet.PickMistake ( checkMistakeConfig, checkPickMistakeConfig, defaultPickMistakeInstance, - pickMistakeConstraints, petriNetPickMist, pickMistake, pickMistakeGenerate, @@ -212,7 +211,6 @@ pred #{mistakePredicateName} { #{pickMistakeConstraints mistakeC} #{compChange changeC} #{defaultConstraints undefined basicC} - #{prohibitSelfLoops mistakeC} } diff --git a/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs index b90b12dc8..8c6c3e03c 100644 --- a/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs +++ b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs @@ -88,7 +88,7 @@ validFindActivatedTransitionsConfig cs advancedConfig = do validActivatedTransitionsConfigs :: BasicConfig -> [Maybe Int] validActivatedTransitionsConfigs bc@BasicConfig{ transitions } = filter (isNothing . checkActivatedTransitionsConfig bc) $ - Nothing : [Just n | n <- [0..transitions]] + Nothing : [Just n | n <- [0 .. transitions - 1]] isValidActivatedTransitions :: ActivatedTransitions String -> Bool isValidActivatedTransitions _ = True From 4900f36cc30dd8973b8e74dd9673293987d88e69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 21 Mar 2025 11:04:35 +0100 Subject: [PATCH 100/256] renames --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 8 ++++---- src/Modelling/PetriNet/PickMistake.hs | 8 ++++---- .../PetriNet/FindActivatedTransitionsSpec.hs | 14 +++++++------- test/Modelling/PetriNet/PickMistakeSpec.hs | 4 ++-- 4 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index ff6cfe3ec..bf3fed836 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -15,7 +15,7 @@ module Modelling.PetriNet.FindActivatedTransitions ( findActivatedTransitionsSyntax, findActivatedTransitionsTask, parseActivatedTransitions, - petriNetFindActivated, + petriNetFindActivatedTransitions, simpleFindActivatedTransitionsTask, ) where @@ -274,12 +274,12 @@ findActivatedTransitions (p n String, ActivatedTransitions String) findActivatedTransitions = taskInstance findTaskInstance - petriNetFindActivated + petriNetFindActivatedTransitions parseActivatedTransitions Find.alloyConfig -petriNetFindActivated :: FindActivatedTransitionsConfig -> String -petriNetFindActivated FindActivatedTransitionsConfig { +petriNetFindActivatedTransitions :: FindActivatedTransitionsConfig -> String +petriNetFindActivatedTransitions FindActivatedTransitionsConfig { basicConfig, advConfig, changeConfig, diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index a96cdc571..fe7db72e7 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -8,7 +8,7 @@ module Modelling.PetriNet.PickMistake ( checkMistakeConfig, checkPickMistakeConfig, defaultPickMistakeInstance, - petriNetPickMist, + petriNetPickMistake, pickMistake, pickMistakeGenerate, pickMistakeTask, @@ -172,13 +172,13 @@ pickMistake [(p n String, Maybe (Const () String))] pickMistake = taskInstance pickTaskInstance - petriNetPickMist + petriNetPickMistake (\_ -> return (Const ())) Pick.alloyConfig -petriNetPickMist :: PickMistakeConfig -> String -petriNetPickMist PickMistakeConfig{ +petriNetPickMistake :: PickMistakeConfig -> String +petriNetPickMistake PickMistakeConfig{ basicConfig, changeConfig, mistakeConfig diff --git a/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs index 8c6c3e03c..5bf0a80d4 100644 --- a/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs +++ b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs @@ -13,7 +13,7 @@ import Modelling.PetriNet.FindActivatedTransitions ( checkFindActivatedTransitionsConfig, findActivatedTransitions, parseActivatedTransitions, - petriNetFindActivated, + petriNetFindActivatedTransitions, ) import Modelling.PetriNet.Find ( @@ -48,7 +48,7 @@ spec :: Spec spec = do describe "defaultFindActivatedTransitionsConfig" $ checkConfigs checkFindActivatedTransitionsConfig [defaultFindActivatedTransitionsConfig] - describe "validFindActivatedTransitionsConfig" $ + describe "validFindActivatedTransitionsConfigs" $ checkConfigs checkFindActivatedTransitionsConfig findConfigs' describe "findActivatedTransitions" $ do defaultConfigTaskGeneration @@ -59,10 +59,10 @@ spec = do $ checkFindActivatedTransitionsInstance @(SimplePetriLike _) testFindActivatedTransitionsConfig findConfigs where - findConfigs' = validFindActivatedTransitionsConfig + findConfigs' = validFindActivatedTransitionsConfigs validFinds (AdvConfig Nothing Nothing Nothing) - findConfigs = validAdvConfigs >>= validFindActivatedTransitionsConfig validFinds + findConfigs = validAdvConfigs >>= validFindActivatedTransitionsConfigs validFinds validFinds = validConfigsForFind 0 configDepth checkFindActivatedTransitionsInstance :: (a, ActivatedTransitions String) -> Bool @@ -70,15 +70,15 @@ checkFindActivatedTransitionsInstance = isValidActivatedTransitions . snd testFindActivatedTransitionsConfig :: [FindActivatedTransitionsConfig] -> Spec testFindActivatedTransitionsConfig = testTaskGeneration - petriNetFindActivated + petriNetFindActivatedTransitions (findTaskInstance parseActivatedTransitions) $ checkFindActivatedTransitionsInstance @(SimplePetriLike _) -validFindActivatedTransitionsConfig +validFindActivatedTransitionsConfigs :: [(BasicConfig, ChangeConfig)] -> AdvConfig -> [FindActivatedTransitionsConfig] -validFindActivatedTransitionsConfig cs advancedConfig = do +validFindActivatedTransitionsConfigs cs advancedConfig = do (bc, ch) <- cs FindActivatedTransitionsConfig bc advancedConfig ch <$> validActivatedTransitionsConfigs bc diff --git a/test/Modelling/PetriNet/PickMistakeSpec.hs b/test/Modelling/PetriNet/PickMistakeSpec.hs index 95384c67e..a0d7f940c 100644 --- a/test/Modelling/PetriNet/PickMistakeSpec.hs +++ b/test/Modelling/PetriNet/PickMistakeSpec.hs @@ -9,7 +9,7 @@ import qualified Modelling.PetriNet.Types as Pick ( import Modelling.PetriNet.PickMistake ( checkMistakeConfig, checkPickMistakeConfig, - petriNetPickMist, + petriNetPickMistake, pickMistake, ) @@ -67,7 +67,7 @@ checkPickMistakeInstance = f . fmap snd testPickMistakeConfig :: [PickMistakeConfig] -> Spec testPickMistakeConfig = testTaskGeneration - petriNetPickMist + petriNetPickMistake (pickTaskInstance (const (return (Const ())))) $ checkPickMistakeInstance @(SimplePetriLike _) From a5991dd4e8932e725b950f0baeda82d4819c4e7f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 21 Mar 2025 11:10:09 +0100 Subject: [PATCH 101/256] fix task description --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index bf3fed836..f112d9e2c 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -208,20 +208,20 @@ findActivatedTransitionsTask path task = do let ts = transitionListShow findInitialList code $ show ts translate $ do - let ta = map show findInitialList + let ta = map show ts english [iii| - #{" "}as answer would indicate that transitions #{ta} + #{" "}as answer would indicate that exactly the transitions #{ta} are activated under the initial marking. #{" "}|] german [iii| - #{" "}als Antwort würde bedeuten, dass Transitionen #{ta} + #{" "}als Antwort würde bedeuten, dass genau die Transitionen #{ta} unter der Startmarkierung aktiviert sind. #{" "}|] translate $ do - english "The order of transitions within the pair does not matter here." + english "The order of transitions within the list does not matter here." german [iii| Die Reihenfolge der Transitionen innerhalb - des Paars spielt hierbei keine Rolle. + der Liste spielt hierbei keine Rolle. |] pure () From 24ef11e68506a0ee69d3128e2529f20d5087e840 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 21 Mar 2025 11:11:21 +0100 Subject: [PATCH 102/256] refine direct selfloop constraining --- src/Modelling/PetriNet/PickMistake.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index fe7db72e7..4317f7060 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -219,8 +219,12 @@ run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petr where prohibitSelfLoops :: MistakeConfig -> String prohibitSelfLoops MistakeConfig{ canHaveTransitionToTransition, canHavePlaceToPlace } - | canHaveTransitionToTransition || canHavePlaceToPlace + | canHaveTransitionToTransition && canHavePlaceToPlace = [i|all n : Nodes | no n.flow[n]|] + | canHaveTransitionToTransition + = [i|all n : Transition | no n.flow[n]|] + | canHavePlaceToPlace + = [i|all n : Place | no n.flow[n]|] | otherwise = "" From 5f40a190a82e394570a0cf932d2301efa2f9343c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 21 Mar 2025 11:12:08 +0100 Subject: [PATCH 103/256] not hiding place names by default --- src/Modelling/PetriNet/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 1c36874b1..61bc8d5f3 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -943,7 +943,7 @@ defaultFindActivatedTransitionsConfig = FindActivatedTransitionsConfig , advConfig = defaultAdvConfig , changeConfig = defaultChangeConfig , atMostActive = Nothing - , graphConfig = defaultGraphConfig { hidePlaceNames = True } + , graphConfig = defaultGraphConfig , printSolution = False , alloyConfig = defaultAlloyConfig } From 0e78b11dffc51a5a3d927792a31645744053d551 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 21 Mar 2025 11:28:29 +0100 Subject: [PATCH 104/256] typos --- src/Modelling/PetriNet/PickMistake.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index 4317f7060..26d46c70c 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -222,9 +222,9 @@ run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petr | canHaveTransitionToTransition && canHavePlaceToPlace = [i|all n : Nodes | no n.flow[n]|] | canHaveTransitionToTransition - = [i|all n : Transition | no n.flow[n]|] + = [i|all n : Transitions | no n.flow[n]|] | canHavePlaceToPlace - = [i|all n : Place | no n.flow[n]|] + = [i|all n : Places | no n.flow[n]|] | otherwise = "" From f78eda56675a273246682558509a195763d7c1f4 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 21 Mar 2025 14:56:05 +0100 Subject: [PATCH 105/256] added advConfig checks --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index f112d9e2c..bbcedfc34 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -76,7 +76,7 @@ import Modelling.PetriNet.Reach.Type ( ) import Modelling.PetriNet.Types ( ActivatedTransitions (ActivatedTransitions), - AdvConfig, + AdvConfig (..), BasicConfig (..), ChangeConfig (..), DrawSettings (..), @@ -351,16 +351,27 @@ skolemName = "activatedTrans" checkFindActivatedTransitionsConfig :: FindActivatedTransitionsConfig -> Maybe String checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { basicConfig, + advConfig, changeConfig, atMostActive, graphConfig } = prohibitHideTransitionNames graphConfig <|> checkBasicConfig basicConfig + <|> checkAdvConfig basicConfig advConfig atMostActive <|> checkChangeConfig basicConfig changeConfig <|> checkActivatedTransitionsConfig basicConfig atMostActive <|> prohibitPatchworkRenderer graphConfig +checkAdvConfig :: BasicConfig -> AdvConfig -> Maybe Int -> Maybe String +checkAdvConfig BasicConfig{ atLeastActive } AdvConfig{ presenceOfSourceTransitions } atMostActive + | presenceOfSourceTransitions == Just True && atLeastActive == 0 + = Just "atLeastActive has to be at least 1 for source transitions." + | isNothing presenceOfSourceTransitions && atMostActive == Just 0 + = Just "When atMostActive = 'Just 0', use presenceOfSourceTransitions = 'Just False' instead." + | otherwise + = Nothing + checkActivatedTransitionsConfig :: BasicConfig -> Maybe Int -> Maybe String checkActivatedTransitionsConfig BasicConfig { atLeastActive, From a0443192de43e16ed7cd4be058548c4bc754a53d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 21 Mar 2025 15:57:02 +0100 Subject: [PATCH 106/256] removed extraAtMostActive --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index bbcedfc34..4ceedb657 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -318,7 +318,6 @@ pred #{activePredicateName}[#{activated} : set Transitions] { #{compChange changeC} #{compAdvConstraints advConfig} #{activatedConstraint basicC atMost} - #{extraAtMostActive basicC atMost} no t : givenTransitions | activatedDefault[t] } @@ -332,12 +331,6 @@ run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petri = [i|theActivatedTransitions[#{activated}]|] | otherwise = "" -- because in all other cases already compBasicConstraints emits that constraint - extraAtMostActive :: BasicConfig -> Maybe Int -> String - extraAtMostActive BasicConfig{ transitions } atMostActive - | isNothing atMostActive - = [i|\##{activated} =< #{transitions}|] - | otherwise - = "" activePredicateName :: String activePredicateName = "showActiveTransition" From 5ad88327f82c26154bfa82a5c69b27bc1c29e99f Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 21 Mar 2025 15:58:02 +0100 Subject: [PATCH 107/256] updated test for activatedTransitions --- test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs index 5bf0a80d4..5f9cedac5 100644 --- a/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs +++ b/test/Modelling/PetriNet/FindActivatedTransitionsSpec.hs @@ -41,6 +41,8 @@ import Modelling.PetriNet.TestCommon ( ) import Settings (configDepth) +import Data.Char (isDigit) +import Data.List (nub) import Data.Maybe (isNothing) import Test.Hspec @@ -91,4 +93,9 @@ validActivatedTransitionsConfigs bc@BasicConfig{ transitions } = filter (isNothi Nothing : [Just n | n <- [0 .. transitions - 1]] isValidActivatedTransitions :: ActivatedTransitions String -> Bool -isValidActivatedTransitions _ = True +isValidActivatedTransitions a@(ActivatedTransitions ts) + | length ts == length (nub ts) && all isNumber ts = True + | otherwise = error $ show a + where + isNumber ('t':x) = all isDigit x + isNumber _ = False From b2e8becb605475723e1ef538a72c83aa136c9843 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 24 Mar 2025 17:26:26 +0100 Subject: [PATCH 108/256] limited values for petriScopeBitWidth to 15 --- src/Modelling/PetriNet/Types.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 61bc8d5f3..2ddc07c7c 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1042,6 +1042,8 @@ checkBasicConfig BasicConfig{ = Just "The maximum 'flowOverall' is set unreasonably high, given the other parameters." | transitions + places > 1 + fst flowOverall = Just "The number of transitions and places exceeds the minimum 'flowOverall' too much to create a connected net." + | maximum [snd flowOverall, snd tokensOverall, places, transitions] > 15 + = Just "'places', 'transitions' and the maximum 'flowOverall' and 'tokensOverall' should not be greater than 15." | otherwise = Nothing From e701177193fa408128e6ca980b63f36b56e441fc Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 24 Mar 2025 23:25:40 +0100 Subject: [PATCH 109/256] move petriScopeBitWidth to PetriNet/Types --- src/Modelling/PetriNet/Alloy.hs | 9 --------- src/Modelling/PetriNet/Concurrency.hs | 2 +- src/Modelling/PetriNet/Conflict.hs | 2 +- src/Modelling/PetriNet/FindActivatedTransitions.hs | 2 +- src/Modelling/PetriNet/MatchToMath.hs | 2 +- src/Modelling/PetriNet/PickMistake.hs | 2 +- src/Modelling/PetriNet/Types.hs | 9 +++++++++ test/Modelling/PetriNet/AlloySpec.hs | 1 + 8 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index a4c25f004..45ee9c56c 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -18,7 +18,6 @@ module Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeBitWidth, petriScopeMaxSeq, signatures, skolemVariable, @@ -64,14 +63,6 @@ import Language.Alloy.Call ( unscoped, ) -petriScopeBitWidth :: BasicConfig -> Int -petriScopeBitWidth BasicConfig - { flowOverall, places, tokensOverall, transitions } = - floor - (2 + ((logBase :: Double -> Double -> Double) 2.0 . fromIntegral) - (maximum [snd flowOverall, snd tokensOverall, places, transitions]) - ) - petriScopeMaxSeq :: BasicConfig -> Int petriScopeMaxSeq BasicConfig{places,transitions} = places+transitions diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index c8da0a832..da094f221 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -60,7 +60,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeBitWidth, petriScopeMaxSeq, signatures, skolemVariable, @@ -107,6 +106,7 @@ import Modelling.PetriNet.Types ( PickConcurrencyConfig (..), SimpleNode (..), SimplePetriNet, + petriScopeBitWidth, transitionPairShow, ) diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index aab2c2e1c..b4a12e67b 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -69,7 +69,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeBitWidth, petriScopeMaxSeq, signatures, skolemVariable, @@ -125,6 +124,7 @@ import Modelling.PetriNet.Types ( SimpleNode (..), SimplePetriNet, lConflictPlaces, + petriScopeBitWidth, transitionPairShow, ) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 4ceedb657..8ff8cb91d 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -52,7 +52,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeBitWidth, petriScopeMaxSeq, skolemVariable, taskInstance, @@ -88,6 +87,7 @@ import Modelling.PetriNet.Types ( SimplePetriNet, checkBasicConfig, checkChangeConfig, + petriScopeBitWidth, transitionListShow, ) diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index cb8c717e0..64d3b3f08 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -56,7 +56,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeBitWidth, petriScopeMaxSeq, signatures, taskInstance, @@ -94,6 +93,7 @@ import Modelling.PetriNet.Types ( isPlaceNode, manyRandomDrawSettings, mapChange, + petriScopeBitWidth, randomDrawSettings, shuffleNames, ) diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index 26d46c70c..197cca90a 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -39,7 +39,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeBitWidth, petriScopeMaxSeq, taskInstance, ) @@ -62,6 +61,7 @@ import Modelling.PetriNet.Types ( PickMistakeConfig (..), SimpleNode (..), SimplePetriNet, + petriScopeBitWidth, ) import Control.Applicative ((<|>)) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 2ddc07c7c..a1369ed5a 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -92,6 +92,7 @@ module Modelling.PetriNet.Types ( mapChange, maybeInitial, petriLikeToPetri, + petriScopeBitWidth, placeNames, randomDrawSettings, shuffleNames, @@ -998,6 +999,14 @@ transitionPairShow = bimap ShowTransition ShowTransition transitionListShow :: [Petri.Transition] -> [ShowTransition] transitionListShow = map ShowTransition +petriScopeBitWidth :: BasicConfig -> Int +petriScopeBitWidth BasicConfig + { flowOverall, places, tokensOverall, transitions } = + floor + (2 + ((logBase :: Double -> Double -> Double) 2.0 . fromIntegral) + (maximum [snd flowOverall, snd tokensOverall, places, transitions]) + ) + checkBasicConfig :: BasicConfig -> Maybe String checkBasicConfig BasicConfig{ atLeastActive, diff --git a/test/Modelling/PetriNet/AlloySpec.hs b/test/Modelling/PetriNet/AlloySpec.hs index 2c2896b2d..eddf5f75c 100644 --- a/test/Modelling/PetriNet/AlloySpec.hs +++ b/test/Modelling/PetriNet/AlloySpec.hs @@ -3,6 +3,7 @@ module Modelling.PetriNet.AlloySpec where import Modelling.PetriNet.Alloy import Modelling.PetriNet.Types ( defaultBasicConfig, + petriScopeBitWidth, ) import Test.Hspec From 6b8c122a18ce49c449782535ef083fd095b5f758 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 24 Mar 2025 23:27:05 +0100 Subject: [PATCH 110/256] updated old parts of thesis --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 8ff8cb91d..928da0987 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -333,7 +333,7 @@ run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petri = "" -- because in all other cases already compBasicConstraints emits that constraint activePredicateName :: String -activePredicateName = "showActiveTransition" +activePredicateName = "showActivatedTransitions" activatedTransitions :: String activatedTransitions = skolemVariable activePredicateName skolemName From 07e2f55717125769ce5c4f933554f2017e4d27c6 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 24 Mar 2025 23:28:58 +0100 Subject: [PATCH 111/256] changed check for petriScopeBitWidth --- src/Modelling/PetriNet/Types.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index a1369ed5a..352ad923d 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1008,7 +1008,7 @@ petriScopeBitWidth BasicConfig ) checkBasicConfig :: BasicConfig -> Maybe String -checkBasicConfig BasicConfig{ +checkBasicConfig basicC@BasicConfig{ atLeastActive, flowOverall, maxFlowPerEdge, @@ -1051,8 +1051,8 @@ checkBasicConfig BasicConfig{ = Just "The maximum 'flowOverall' is set unreasonably high, given the other parameters." | transitions + places > 1 + fst flowOverall = Just "The number of transitions and places exceeds the minimum 'flowOverall' too much to create a connected net." - | maximum [snd flowOverall, snd tokensOverall, places, transitions] > 15 - = Just "'places', 'transitions' and the maximum 'flowOverall' and 'tokensOverall' should not be greater than 15." + | petriScopeBitWidth basicC > 5 + = Just "'places', 'transitions' and the maximum 'flowOverall' and 'tokensOverall' should not be set too high." | otherwise = Nothing From 0bad9a253483dda123aab2be6d4b0d560f0eb126 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 25 Mar 2025 09:23:29 +0100 Subject: [PATCH 112/256] refactor config checkers --- src/Modelling/PetriNet/Concurrency.hs | 6 +++++- src/Modelling/PetriNet/Conflict.hs | 5 ++++- src/Modelling/PetriNet/ConflictPlaces.hs | 2 ++ src/Modelling/PetriNet/Find.hs | 19 +++++-------------- .../PetriNet/FindActivatedTransitions.hs | 10 ++-------- src/Modelling/PetriNet/MatchToMath.hs | 2 ++ src/Modelling/PetriNet/Pick.hs | 2 ++ src/Modelling/PetriNet/Types.hs | 6 ++++++ 8 files changed, 28 insertions(+), 24 deletions(-) diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index da094f221..af60fcbed 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -72,6 +72,7 @@ import Modelling.PetriNet.Diagram ( import Modelling.PetriNet.Find ( FindInstance (..), checkConfigForFind, + checkFindTwoActive, findInitialTuple, findTaskInstance, toFindEvaluationTuple, @@ -110,6 +111,7 @@ import Modelling.PetriNet.Types ( transitionPairShow, ) +import Control.Applicative (Alternative ((<|>))) import Control.Monad.Catch (MonadThrow) import Control.OutputCapable.Blocks ( ArticleToUse (DefiniteArticle), @@ -491,7 +493,9 @@ checkFindConcurrencyConfig FindConcurrencyConfig { changeConfig, graphConfig } - = checkConfigForFind basicConfig changeConfig graphConfig + = + checkFindTwoActive basicConfig + <|> checkConfigForFind basicConfig changeConfig graphConfig checkPickConcurrencyConfig :: PickConcurrencyConfig -> Maybe String checkPickConcurrencyConfig PickConcurrencyConfig { diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index b4a12e67b..743946cdd 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -81,6 +81,7 @@ import Modelling.PetriNet.Diagram ( import Modelling.PetriNet.Find ( FindInstance (..), checkConfigForFind, + checkFindTwoActive, findInitialTuple, findTaskInstance, lToFind, @@ -649,7 +650,9 @@ checkFindConflictConfig FindConflictConfig { conflictConfig, graphConfig } - = checkConfigForFind basicConfig changeConfig graphConfig + = + checkFindTwoActive basicConfig + <|> checkConfigForFind basicConfig changeConfig graphConfig <|> checkConflictConfig basicConfig conflictConfig checkPickConflictConfig :: PickConflictConfig -> Maybe String diff --git a/src/Modelling/PetriNet/ConflictPlaces.hs b/src/Modelling/PetriNet/ConflictPlaces.hs index 6f5656a09..59df2d59f 100644 --- a/src/Modelling/PetriNet/ConflictPlaces.hs +++ b/src/Modelling/PetriNet/ConflictPlaces.hs @@ -33,6 +33,7 @@ import Modelling.PetriNet.Conflict ( import Modelling.PetriNet.Find ( FindInstance (..), checkConfigForFind, + checkFindTwoActive, drawFindWith, findInitialTuple, ) @@ -213,6 +214,7 @@ checkFindConflictPlacesConfig FindConflictConfig { graphConfig } = prohibitHidePlaceNames graphConfig + <|> checkFindTwoActive basicConfig <|> checkConfigForFind basicConfig changeConfig graphConfig <|> checkConflictConfig basicConfig conflictConfig diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 88c609701..8ece5b3a4 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -10,14 +10,13 @@ module Modelling.PetriNet.Find ( FindInstance (..), - checkFindBasicConfig, + checkFindTwoActive, checkConfigForFind, findInitialList, findInitialTuple, findTaskInstance, lToFind, prohibitHideTransitionNames, - prohibitPatchworkRenderer, toFindEvaluation, toFindEvaluationList, toFindEvaluationTuple, @@ -45,6 +44,7 @@ import Modelling.PetriNet.Types ( Net (..), checkBasicConfig, checkChangeConfig, + prohibitPatchworkRenderer, shuffleNames, transitionListShow, transitionPairShow, @@ -68,7 +68,6 @@ import Control.Monad.Random ( RandomGen, ) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Data.GraphViz.Attributes.Complete (GraphvizCommand (..)) import Data.List (sort) import Data.Map (Map) import Language.Alloy.Call ( @@ -169,16 +168,15 @@ toFindEvaluationList toFindEvaluationList what withSol = toFindEvaluation what withSol (\x y -> sort x == sort y) (show . transitionListShow) -checkFindBasicConfig :: BasicConfig -> Maybe String -checkFindBasicConfig BasicConfig { atLeastActive } +checkFindTwoActive :: BasicConfig -> Maybe String +checkFindTwoActive BasicConfig { atLeastActive } | atLeastActive < 2 = Just "The parameter 'atLeastActive' must be at least 2 to create the task." | otherwise = Nothing checkConfigForFind :: BasicConfig -> ChangeConfig -> GraphConfig -> Maybe String checkConfigForFind basic change graph = - checkFindBasicConfig basic - <|> prohibitHideTransitionNames graph + prohibitHideTransitionNames graph <|> checkBasicConfig basic <|> checkChangeConfig basic change <|> prohibitPatchworkRenderer graph @@ -189,10 +187,3 @@ prohibitHideTransitionNames gc = Just "Transition names are required for this task type" | otherwise = Nothing - -prohibitPatchworkRenderer :: GraphConfig -> Maybe String -prohibitPatchworkRenderer gc - | Patchwork `elem` graphLayouts gc - = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." - | otherwise - = Nothing diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 928da0987..1b47737c7 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -62,10 +62,9 @@ import Modelling.PetriNet.Diagram ( ) import Modelling.PetriNet.Find ( FindInstance (..), + checkConfigForFind, findInitialList, findTaskInstance, - prohibitHideTransitionNames, - prohibitPatchworkRenderer, toFindEvaluationList, ) import Modelling.PetriNet.Reach.Type ( @@ -85,8 +84,6 @@ import Modelling.PetriNet.Types ( PetriLike (PetriLike, allNodes), SimpleNode (..), SimplePetriNet, - checkBasicConfig, - checkChangeConfig, petriScopeBitWidth, transitionListShow, ) @@ -349,12 +346,9 @@ checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { atMostActive, graphConfig } - = prohibitHideTransitionNames graphConfig - <|> checkBasicConfig basicConfig + = checkConfigForFind basicConfig changeConfig graphConfig <|> checkAdvConfig basicConfig advConfig atMostActive - <|> checkChangeConfig basicConfig changeConfig <|> checkActivatedTransitionsConfig basicConfig atMostActive - <|> prohibitPatchworkRenderer graphConfig checkAdvConfig :: BasicConfig -> AdvConfig -> Maybe Int -> Maybe String checkAdvConfig BasicConfig{ atLeastActive } AdvConfig{ presenceOfSourceTransitions } atMostActive diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 64d3b3f08..912cd499b 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -94,6 +94,7 @@ import Modelling.PetriNet.Types ( manyRandomDrawSettings, mapChange, petriScopeBitWidth, + prohibitPatchworkRenderer, randomDrawSettings, shuffleNames, ) @@ -514,6 +515,7 @@ checkMathConfig c@MathConfig { <|> checkChangeConfig basicConfig changeConfig <|> checkConfig c <|> checkGraphLayouts useDifferentGraphLayouts wrongInstances graphConfig + <|> prohibitPatchworkRenderer graphConfig prohibitHideNames :: GraphConfig -> Maybe String prohibitHideNames gc diff --git a/src/Modelling/PetriNet/Pick.hs b/src/Modelling/PetriNet/Pick.hs index 6f86af94c..c24fc53d5 100644 --- a/src/Modelling/PetriNet/Pick.hs +++ b/src/Modelling/PetriNet/Pick.hs @@ -45,6 +45,7 @@ import Modelling.PetriNet.Types ( checkGraphLayouts, manyRandomDrawSettings, placeNames, + prohibitPatchworkRenderer, randomDrawSettings, transitionNames, ) @@ -193,3 +194,4 @@ checkConfigForPick useDifferent numWrongInstances basic change graph = checkBasicConfig basic <|> checkChangeConfig basic change <|> checkGraphLayouts useDifferent numWrongInstances graph + <|> prohibitPatchworkRenderer graph diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 352ad923d..e6cddac5a 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -94,6 +94,7 @@ module Modelling.PetriNet.Types ( petriLikeToPetri, petriScopeBitWidth, placeNames, + prohibitPatchworkRenderer, randomDrawSettings, shuffleNames, transformNet, @@ -1105,6 +1106,11 @@ checkGraphLayouts useDifferent wrongInstances gc = Just "At least one graph layout needs to be provided." | useDifferent && length (graphLayouts gc) <= wrongInstances = Just "The parameter 'graphLayout' has to contain more entries than the number of 'wrongInstances' if 'useDifferentGraphLayouts' is set." + | otherwise + = Nothing + +prohibitPatchworkRenderer :: GraphConfig -> Maybe String +prohibitPatchworkRenderer gc | Patchwork `elem` graphLayouts gc = Just "Do not use 'Patchwork' as a GraphViz Renderer as it does not work properly." | otherwise From e6589bc51d9d2fe5d8cd1e2ffafbc2b6670e6b51 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 25 Mar 2025 09:46:50 +0100 Subject: [PATCH 113/256] outlawing presenceOfSourceTransitions == Just True && atLeastActive == 0 also in checkMathConfig --- src/Modelling/PetriNet/FindActivatedTransitions.hs | 13 +++++++------ src/Modelling/PetriNet/MatchToMath.hs | 3 +++ src/Modelling/PetriNet/Types.hs | 8 ++++++++ 3 files changed, 18 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 1b47737c7..25edeb297 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -84,6 +84,7 @@ import Modelling.PetriNet.Types ( PetriLike (PetriLike, allNodes), SimpleNode (..), SimplePetriNet, + checkActivatedSourceConfig, petriScopeBitWidth, transitionListShow, ) @@ -347,15 +348,15 @@ checkFindActivatedTransitionsConfig FindActivatedTransitionsConfig { graphConfig } = checkConfigForFind basicConfig changeConfig graphConfig - <|> checkAdvConfig basicConfig advConfig atMostActive + <|> checkActivatedSourceConfig basicConfig advConfig + <|> checkAdvConfig advConfig atMostActive <|> checkActivatedTransitionsConfig basicConfig atMostActive -checkAdvConfig :: BasicConfig -> AdvConfig -> Maybe Int -> Maybe String -checkAdvConfig BasicConfig{ atLeastActive } AdvConfig{ presenceOfSourceTransitions } atMostActive - | presenceOfSourceTransitions == Just True && atLeastActive == 0 - = Just "atLeastActive has to be at least 1 for source transitions." +checkAdvConfig :: AdvConfig -> Maybe Int -> Maybe String +checkAdvConfig AdvConfig{ presenceOfSourceTransitions } atMostActive | isNothing presenceOfSourceTransitions && atMostActive == Just 0 - = Just "When atMostActive = 'Just 0', use presenceOfSourceTransitions = 'Just False' instead." + -- no check for Just True necessary since already handled by checkActivatedSourceConfig + = Just "When atMostActive = 'Just 0', use presenceOfSourceTransitions = 'Just False'." | otherwise = Nothing diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 912cd499b..5bdae19fb 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -81,6 +81,7 @@ import Modelling.PetriNet.Types ( PetriNode (..), SimpleNode (..), SimplePetriLike, + checkActivatedSourceConfig, checkBasicConfig, checkChangeConfig, checkGraphLayouts, @@ -506,12 +507,14 @@ checkGraphToMathConfig c@MathConfig { checkMathConfig :: MathConfig -> Maybe String checkMathConfig c@MathConfig { basicConfig, + advConfig, changeConfig, graphConfig, useDifferentGraphLayouts, wrongInstances } = checkBasicConfig basicConfig <|> prohibitHideNames graphConfig + <|> checkActivatedSourceConfig basicConfig advConfig <|> checkChangeConfig basicConfig changeConfig <|> checkConfig c <|> checkGraphLayouts useDifferentGraphLayouts wrongInstances graphConfig diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index e6cddac5a..c4b39a373 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -51,6 +51,7 @@ module Modelling.PetriNet.Types ( SimpleNode (..), SimplePetriLike, SimplePetriNet, + checkActivatedSourceConfig, checkBasicConfig, checkChangeConfig, checkGraphLayouts, @@ -1057,6 +1058,13 @@ checkBasicConfig basicC@BasicConfig{ | otherwise = Nothing +checkActivatedSourceConfig :: BasicConfig -> AdvConfig -> Maybe String +checkActivatedSourceConfig BasicConfig{ atLeastActive } AdvConfig{ presenceOfSourceTransitions } + | presenceOfSourceTransitions == Just True && atLeastActive == 0 + = Just "atLeastActive has to be at least 1 for source transitions to exist." + | otherwise + = Nothing + checkChangeConfig :: BasicConfig -> ChangeConfig -> Maybe String checkChangeConfig BasicConfig { From 4372bfa7525ae033790f667173b3ea4c2f97bd6e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 25 Mar 2025 10:40:00 +0100 Subject: [PATCH 114/256] more explicit scope setting for Places and Transitions (instead of abstractly Nodes) --- src/Modelling/PetriNet/Alloy.hs | 4 ---- src/Modelling/PetriNet/Concurrency.hs | 5 +---- src/Modelling/PetriNet/Conflict.hs | 5 +---- .../PetriNet/FindActivatedTransitions.hs | 5 +---- src/Modelling/PetriNet/MatchToMath.hs | 15 ++++++--------- src/Modelling/PetriNet/PickMistake.hs | 5 +---- test/Modelling/PetriNet/AlloySpec.hs | 5 ----- 7 files changed, 10 insertions(+), 34 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 45ee9c56c..a997749f4 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -18,7 +18,6 @@ module Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeMaxSeq, signatures, skolemVariable, taskInstance, @@ -63,9 +62,6 @@ import Language.Alloy.Call ( unscoped, ) -petriScopeMaxSeq :: BasicConfig -> Int -petriScopeMaxSeq BasicConfig{places,transitions} = places+transitions - modulePetriSignature :: String modulePetriSignature = removeLines 2 $(embedStringFile "alloy/petri/PetriSignature.als") diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index af60fcbed..b9bf080f7 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -60,7 +60,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeMaxSeq, signatures, skolemVariable, taskInstance, @@ -425,8 +424,6 @@ petriNetConcurrencyAlloy basicC changeC specific #{modulePetriConstraints} pred #{concurrencyPredicateName}[#{skolemSets}#{t1}, #{t2} : Transitions] { - \#Places = #{places basicC} - \#Transitions = #{transitions basicC} #{compBasicConstraints True Nothing activated basicC} #{compChange changeC} #{sourceTransitionConstraints} @@ -437,7 +434,7 @@ pred #{concurrencyPredicateName}[#{skolemSets}#{t1}, #{t2} : Transitions] { #{compConstraints} } -run #{concurrencyPredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int +run #{concurrencyPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int |] where activated = "activatedTrans" diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index 743946cdd..308e77a46 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -69,7 +69,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeMaxSeq, signatures, skolemVariable, taskInstance, @@ -491,8 +490,6 @@ petriNetConflictAlloy basicC changeC conflictC uniqueConflictP specific #{modulePetriConstraints} pred #{conflictPredicateName}[#{p} : some Places, #{skolemSets}#{t1}, #{t2} : Transitions] { - \#Places = #{places basicC} - \#Transitions = #{transitions basicC} #{compBasicConstraints True Nothing activated basicC} #{compChange changeC} #{multiplePlaces uniqueConflictP} @@ -509,7 +506,7 @@ pred #{conflictPredicateName}[#{p} : some Places, #{skolemSets}#{t1}, #{t2} : Tr #{compConstraints} } -run #{conflictPredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int +run #{conflictPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int |] where activated = "activatedTrans" diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 25edeb297..193a3fb45 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -52,7 +52,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeMaxSeq, skolemVariable, taskInstance, unscopedSingleSig, @@ -310,8 +309,6 @@ petriNetActivatedTransitionsAlloy basicC changeC atMost advConfig #{modulePetriConstraints} pred #{activePredicateName}[#{activated} : set Transitions] { - \#Places = #{places basicC} - \#Transitions = #{transitions basicC} #{compBasicConstraints True atMost activated basicC} #{compChange changeC} #{compAdvConstraints advConfig} @@ -319,7 +316,7 @@ pred #{activePredicateName}[#{activated} : set Transitions] { no t : givenTransitions | activatedDefault[t] } -run #{activePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int +run #{activePredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int |] where activated = skolemName diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 5bdae19fb..1adfa93ea 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -56,7 +56,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeMaxSeq, signatures, taskInstance, ) @@ -562,12 +561,10 @@ fact{ } pred showNets[#{skolemSet}] { - \#Places = #{places} - \#Transitions = #{transitions} #{compBasicConstraints True Nothing activated basicC} #{compAdvConstraints advConfig} } -run showNets for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int +run showNets for exactly #{places} Places, exactly #{transitions} Transitions, #{petriScopeBitWidth basicC} Int |] where (skolemSet, activated) @@ -584,8 +581,8 @@ renderFalse #{modulePetriConcepts} #{modulePetriConstraints} -#{places} -#{transitions} +#{thePlaces} +#{theTransitions} fact{ #{initialMark} @@ -598,13 +595,13 @@ pred showFalseNets[#{skolemSet}]{ #{compChange changeConfig} } -run showFalseNets for exactly #{petriScopeMaxSeq basicConfig} Nodes, #{petriScopeBitWidth basicConfig} Int +run showFalseNets for exactly #{places basicConfig} Places, exactly #{transitions basicConfig} Transitions, #{petriScopeBitWidth basicConfig} Int |] where allNodes = nodes net (ps, ts) = M.partition isPlaceNode allNodes - places = unlines [extendLine p "givenPlaces" | p <- M.keys ps] - transitions = unlines [extendLine t "givenTransitions" | t <- M.keys ts] + thePlaces = unlines [extendLine p "givenPlaces" | p <- M.keys ps] + theTransitions = unlines [extendLine t "givenTransitions" | t <- M.keys ts] initialMark = M.foldrWithKey (\k -> (++) . tokenLine k) "" $ initialTokens <$> ps defaultFlow = M.foldrWithKey (\k _ -> (printFlow k ++)) "" allNodes printFlow :: String -> String diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index 197cca90a..c48fb9257 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -39,7 +39,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, - petriScopeMaxSeq, taskInstance, ) import Modelling.PetriNet.Pick ( @@ -205,8 +204,6 @@ petriNetPickMistakeAlloy basicC changeC mistakeC #{modulePetriConstraints} pred #{mistakePredicateName} { - \#Places = #{places basicC} - \#Transitions = #{transitions basicC} #{compBasicConstraints False Nothing undefined basicC} #{pickMistakeConstraints mistakeC} #{compChange changeC} @@ -214,7 +211,7 @@ pred #{mistakePredicateName} { #{prohibitSelfLoops mistakeC} } -run #{mistakePredicateName} for exactly #{petriScopeMaxSeq basicC} Nodes, #{petriScopeBitWidth basicC} Int +run #{mistakePredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int |] where prohibitSelfLoops :: MistakeConfig -> String diff --git a/test/Modelling/PetriNet/AlloySpec.hs b/test/Modelling/PetriNet/AlloySpec.hs index eddf5f75c..4a8e38de6 100644 --- a/test/Modelling/PetriNet/AlloySpec.hs +++ b/test/Modelling/PetriNet/AlloySpec.hs @@ -1,6 +1,5 @@ module Modelling.PetriNet.AlloySpec where -import Modelling.PetriNet.Alloy import Modelling.PetriNet.Types ( defaultBasicConfig, petriScopeBitWidth, @@ -14,7 +13,3 @@ spec = do context "computes the needed bit width for generating Petri nets with Alloy" $ it "taking some values out of the user's input" $ petriScopeBitWidth defaultBasicConfig `shouldSatisfy` (< 7) - describe "petriScopeMaxSeq" $ - context "computes the maximal needed space for generating Petri nets with Alloy" $ - it "taking some values out of the user's input" $ - petriScopeMaxSeq defaultBasicConfig `shouldSatisfy` (< 10) From fad2c93470b949f00c3736bbb5c8d2fd72d77d50 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 25 Mar 2025 23:54:08 +0100 Subject: [PATCH 115/256] added config for Capacity --- src/Modelling/PetriNet/Types.hs | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index c4b39a373..b5e0ee2f4 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -23,6 +23,7 @@ module Modelling.PetriNet.Types ( AdvConfig (..), AlloyConfig (..), BasicConfig (..), + CapacityConfig (..), Change, ChangeConfig (..), Concurrent (..), @@ -58,6 +59,7 @@ module Modelling.PetriNet.Types ( defaultAdvConfig, defaultAlloyConfig, defaultBasicConfig, + defaultCapacityConfig, defaultChangeConfig, defaultFindActivatedTransitionsConfig, defaultFindConcurrencyConfig, @@ -950,6 +952,28 @@ defaultFindActivatedTransitionsConfig = FindActivatedTransitionsConfig , printSolution = False , alloyConfig = defaultAlloyConfig } +-} + +data CapacityConfig = CapacityConfig + { basicConfig :: BasicConfig + , advConfig :: AdvConfig + , maxCapacity :: Int + , graphConfig :: GraphConfig + , printSolution :: Bool + , useDifferentGraphLayouts :: Bool + , alloyConfig :: AlloyConfig + } deriving (Generic, Read, Show) + +defaultCapacityConfig :: CapacityConfig +defaultCapacityConfig = CapacityConfig + { basicConfig = defaultBasicConfig { places = 2, transitions = 2, atLeastActive = 1 } + , advConfig = defaultAdvConfig + , maxCapacity = 8 + , graphConfig = defaultGraphConfig { hidePlaceNames = False, hideTransitionNames = False } + , printSolution = True + , useDifferentGraphLayouts = False + , alloyConfig = defaultAlloyConfig + } data DrawSettings = DrawSettings { withPlaceNames :: Bool, From 3d798b44c050e6293cd092dbbdd5f41f8ad5bf20 Mon Sep 17 00:00:00 2001 From: Marcellus Siegburg Date: Wed, 26 Mar 2025 19:36:27 +0100 Subject: [PATCH 116/256] limit bitwidth on compile time (#313) --- .github/workflows/haskell.yml | 12 ++++++++---- README.md | 14 ++++++++++++++ modelling-tasks.cabal | 1 + src/Capabilities/Alloy.hs | 9 +++++++++ src/Configuration.hs | 3 +++ src/Modelling/PetriNet/Types.hs | 3 ++- 6 files changed, 37 insertions(+), 5 deletions(-) create mode 100644 src/Configuration.hs diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index dd0ecf692..0d32facb7 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -78,7 +78,8 @@ jobs: run: | set -ex # shellcheck disable=SC2086 - stack --no-terminal --install-ghc $ARGS test --stack-yaml=stack-apps.yaml --bench --only-dependencies + stack --no-terminal --install-ghc $ARGS test --stack-yaml=stack-apps.yaml \ + --ghc-options="-DMAX_BIT_WIDTH=7" --bench --only-dependencies set +ex env: ARGS: ${{ matrix.plan.resolver }} @@ -87,7 +88,8 @@ jobs: - name: Install dependencies on windows shell: powershell run: | - stack --no-terminal --install-ghc ${env:ARGS} test --stack-yaml=stack-apps.yaml --bench --only-dependencies + stack --no-terminal --install-ghc ${env:ARGS} test --stack-yaml=stack-apps.yaml \ + --ghc-options="-DMAX_BIT_WIDTH=7" --bench --only-dependencies env: ARGS: ${{ matrix.plan.resolver }} if: contains(matrix.os, 'windows') @@ -97,7 +99,8 @@ jobs: run: | set -ex # shellcheck disable=SC2086 - stack --no-terminal $ARGS test --stack-yaml=stack-apps.yaml --coverage --bench --no-run-benchmarks --haddock --no-haddock-deps --test-arguments="--maximum-generated-tests=50" + stack --no-terminal $ARGS test --stack-yaml=stack-apps.yaml \ + --ghc-options="-DMAX_BIT_WIDTH=7" --coverage --bench --no-run-benchmarks --haddock --no-haddock-deps --test-arguments="--maximum-generated-tests=50" set +ex env: ARGS: ${{ matrix.plan.resolver }} @@ -107,7 +110,8 @@ jobs: id: test-windows shell: powershell run: | - stack --no-terminal ${env:ARGS} test --stack-yaml=stack-apps.yaml --coverage --bench --no-run-benchmarks --haddock --no-haddock-deps --test-arguments="--maximum-generated-tests=50" + stack --no-terminal ${env:ARGS} test --stack-yaml=stack-apps.yaml \ + --ghc-options="-DMAX_BIT_WIDTH=7" --coverage --bench --no-run-benchmarks --haddock --no-haddock-deps --test-arguments="--maximum-generated-tests=50" env: ARGS: ${{ matrix.plan.resolver }} if: contains(matrix.os, 'windows') diff --git a/README.md b/README.md index 7b2da192d..f7290baf6 100644 --- a/README.md +++ b/README.md @@ -9,6 +9,20 @@ The diagram types covered are * Object diagram (UML) * Petri net +## Configuration + +You may limit the maximal bit width by adding a limit (here 5) to your stack +command like `stack build --ghc-options="-DMAX_BIT_WIDTH=5"` or by amending your +`stack.yaml` like: + +``` haskell +ghc-options: + modelling-tasks: -DMAX_BIT_WIDTH=5 +``` + +This configuration is then used in order to reject configurations that do not +adhere to this limit. + ## Compatibility On Windows, you may have to use `SAT4J` instead of `MiniSat`. diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index ab8bbed78..64a099e8c 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -98,6 +98,7 @@ library Modelling.PetriNet.Reach.Type Modelling.Types other-modules: + Configuration Modelling.Auxiliary.Diagrams Modelling.CdOd.Phrasing Modelling.CdOd.Phrasing.English diff --git a/src/Capabilities/Alloy.hs b/src/Capabilities/Alloy.hs index b431fe87d..b2dc11d79 100644 --- a/src/Capabilities/Alloy.hs +++ b/src/Capabilities/Alloy.hs @@ -4,6 +4,7 @@ module Capabilities.Alloy ( MonadAlloy (..), getInstances, + maxBitWidth, ) where import Control.Monad.Trans.Class (MonadTrans (lift)) @@ -45,3 +46,11 @@ getInstances maybeMaxInstances maybeTimeout = getInstancesWith #endif timeout = maybeTimeout } + +maxBitWidth :: Maybe Int +maxBitWidth = +#ifdef MAX_BIT_WIDTH + Just MAX_BIT_WIDTH +#else + Nothing +#endif diff --git a/src/Configuration.hs b/src/Configuration.hs new file mode 100644 index 000000000..aa0fe49a0 --- /dev/null +++ b/src/Configuration.hs @@ -0,0 +1,3 @@ +-- | + +module Configuration where diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index b5e0ee2f4..950638ffb 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -127,6 +127,7 @@ import qualified Data.Map.Lazy as M ( ) import qualified Data.Set as S (empty, union) +import Capabilities.Alloy (maxBitWidth) import Modelling.Auxiliary.Common (lensRulesL, oneOf) import Modelling.PetriNet.Reach.Type (Place, ShowTransition (ShowTransition)) @@ -1077,7 +1078,7 @@ checkBasicConfig basicC@BasicConfig{ = Just "The maximum 'flowOverall' is set unreasonably high, given the other parameters." | transitions + places > 1 + fst flowOverall = Just "The number of transitions and places exceeds the minimum 'flowOverall' too much to create a connected net." - | petriScopeBitWidth basicC > 5 + | Just maxValue <- maxBitWidth, petriScopeBitWidth basicC > maxValue = Just "'places', 'transitions' and the maximum 'flowOverall' and 'tokensOverall' should not be set too high." | otherwise = Nothing From adb922477855fffd2fa5ec13a4e078cf5d825627 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Wed, 26 Mar 2025 20:25:30 +0100 Subject: [PATCH 117/256] make code compile --- src/Modelling/PetriNet/Types.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 950638ffb..607c9455d 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -953,7 +953,6 @@ defaultFindActivatedTransitionsConfig = FindActivatedTransitionsConfig , printSolution = False , alloyConfig = defaultAlloyConfig } --} data CapacityConfig = CapacityConfig { basicConfig :: BasicConfig From dc15d2a6c623687748f52e3ca22043efae9c6178 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 31 Mar 2025 00:16:00 +0200 Subject: [PATCH 118/256] added new task type "capacity" --- modelling-tasks.cabal | 1 + src/Modelling/PetriNet/Capacity.hs | 327 +++++++++++++++++++++++++++++ 2 files changed, 328 insertions(+) create mode 100644 src/Modelling/PetriNet/Capacity.hs diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index 64a099e8c..920488d3d 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -103,6 +103,7 @@ library Modelling.CdOd.Phrasing Modelling.CdOd.Phrasing.English Modelling.CdOd.Phrasing.German + Modelling.PetriNet.Capacity Modelling.PetriNet.Reach.Draw Modelling.PetriNet.Reach.Roll Paths_modelling_tasks diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs new file mode 100644 index 000000000..f4efa676f --- /dev/null +++ b/src/Modelling/PetriNet/Capacity.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} + +module Modelling.PetriNet.Capacity ( + capacityGenerate, + capacityTask, + findCapacity, + petriNetFindCapacity, + petriNetPickCapacity, + parseCapacity, + pickCapacity, + ) where + +import qualified Modelling.PetriNet.Types as Find ( + AlloyConfig (maxInstances, timeout), + CapacityConfig (..), + ) +import qualified Modelling.PetriNet.Types as Pick ( + CapacityConfig (..), + ) +import qualified Data.Map as M ( + empty, + fromList, + ) +import qualified Data.Set as Set ( + toList, + ) + +import Capabilities.Alloy (MonadAlloy, getInstances) +import Capabilities.Cache (MonadCache) +import Capabilities.Diagrams (MonadDiagrams) +import Capabilities.Graphviz (MonadGraphviz) +import Modelling.Auxiliary.Common ( + Object, + oneOf, + parseWith, + ) +import Modelling.Auxiliary.Output ( + hoveringInformation, + ) +import Modelling.PetriNet.Alloy ( + compAdvConstraints, + defaultConstraints, + moduleHelpers, + modulePetriAdditions, + modulePetriConcepts, + modulePetriConstraints, + modulePetriSignature, + randomInSegment, + skolemVariable, + taskInstance, + unscopedSingleSig, + ) +import Modelling.PetriNet.Diagram ( + getDefaultNet, + renderWith, + ) +import Modelling.PetriNet.Find ( + FindInstance (..), + findTaskInstance, + ) +import Modelling.PetriNet.Reach.Type ( + Transition (Transition), + parseTransitionPrec, + ) +import Modelling.PetriNet.Types ( + ActivatedTransitions (ActivatedTransitions), + AdvConfig (..), + AlloyConfig (..), + BasicConfig (..), + Capacity (Capacity), + CapacityConfig (..), + Drawable, + DrawSettings (..), + GraphConfig (..), + Net (..), + PetriLike (PetriLike, allNodes), + SimpleNode (..), + CapacityNode (..), + SimplePetriNet, + petriScopeBitWidth, + transitionListShow, + transitionNames, + placeNames, + randomDrawSettings, + manyRandomDrawSettings, + ) + +import Control.Monad.Catch (MonadThrow) +import Control.OutputCapable.Blocks ( + ArticleToUse (DefiniteArticle), + GenericOutputCapable (..), + LangM', + LangM, + OutputCapable, + Rated, + ($=<<), + continueOrAbort, + english, + german, + printSolutionAndAssert, + translate, + translations, + unLangM + ) +import Control.Monad.Random ( + RandT, + RandomGen, + evalRandT, + mkStdGen + ) +import Control.Monad.Trans (MonadTrans (lift)) +import Data.GraphViz.Commands (GraphvizCommand (Circo)) +import Data.String.Interpolate (i, iii) +import Language.Alloy.Call ( + AlloyInstance + ) + +import GHC.Generics (Generic) +import Control.Monad.IO.Class (liftIO, MonadIO) + + +data CapacityInstance = CapacityInstance { + drawWith :: !DrawSettings, + toFind :: !(ActivatedTransitions Transition), + originalNet :: !(PetriLike CapacityNode String), + transformedNet :: !(PetriLike SimpleNode String), + numberOfPlaces :: !Int, + numberOfTransitions :: !Int, + showSolution :: !Bool + } + deriving (Generic, Read, Show) + +capacityGenerate + :: (MonadAlloy m, MonadThrow m, MonadIO m) + => CapacityConfig + -> Int + -> Int + -> m CapacityInstance +capacityGenerate config seed segment = + flip evalRandT (mkStdGen seed) $ do + gl <- oneOf $ graphLayouts gc + + tn <- pickCapacity petriNetPickCapacity Pick.alloyConfig config segment + + (net, condition) <- findCapacity config segment + condition' <- lift $ traverse (parseWith parseTransitionPrec) condition + liftIO $ print net + liftIO $ print condition + liftIO $ print tn + return $ CapacityInstance + { drawWith = DrawSettings + { withPlaceNames = not $ hidePlaceNames gc + , withSvgHighlighting = True + , withTransitionNames = not $ hideTransitionNames gc + , with1Weights = not $ hideWeight1 gc + , withGraphvizCommand = gl + } + , toFind = condition' + , originalNet = tn + , transformedNet = net + , numberOfPlaces = places bc + , numberOfTransitions = transitions bc + , showSolution = Find.printSolution config + } + where + bc = Find.basicConfig config + gc = Pick.graphConfig config + +capacityTask + :: ( + MonadCache m, + MonadDiagrams m, + MonadGraphviz m, + MonadThrow m, + OutputCapable m + ) + => FilePath + -> CapacityInstance + -> LangM m +capacityTask path task = do + image + $=<< renderWith path "capacity" (originalNet task) (drawWith task) + paragraph $ translate $ do + english [iii| + State your answer by giving the number of the Petri net candidate + that is syntactically incorrect. + #{" "}|] + german [iii| + Geben Sie Ihre Antwort durch Angabe der Nummer des Petrinetzkandidaten an, + der syntaktisch inkorrekt ist. + #{" "}|] + pure () + paragraph hoveringInformation + pure () + +findCapacity + :: (MonadAlloy m, MonadThrow m, RandomGen g) + => CapacityConfig + -> Int + -> RandT + g + m + (PetriLike SimpleNode String, ActivatedTransitions String) +findCapacity = taskInstance + findTaskInstance + petriNetFindCapacity + parseCapacity + Find.alloyConfig + +pickCapacity + :: (MonadAlloy m, MonadThrow m, RandomGen g) + => (config -> String) + -> (config -> AlloyConfig) + -> config + -> Int + -> RandT + g + m + (PetriLike CapacityNode String) +pickCapacity alloyF alloyC config segment = do + let is = Find.maxInstances (alloyC config) + list <- getInstances is (Find.timeout $ alloyC config) (alloyF config) + inst <- case fromIntegral <$> is of + Nothing -> randomInstance list + Just n -> do + x <- randomInSegment segment n + case drop x list of + x':_ -> return x' + [] -> randomInstance list + getDefaultNet inst + where + randomInstance list = do + n <- randomInSegment segment (1 + ((length list - segment - 1) `div` 4)) + return $ list !! n + +petriNetFindCapacity :: CapacityConfig -> String +petriNetFindCapacity CapacityConfig { + basicConfig, + advConfig, + maxCapacity + } + = petriNetFindCapacityAlloy + basicConfig + advConfig + maxCapacity + +petriNetPickCapacity :: CapacityConfig -> String +petriNetPickCapacity CapacityConfig{ + basicConfig, + advConfig, + maxCapacity + } = + petriNetFindCapacityAlloy + basicConfig + advConfig + maxCapacity + +parseCapacity :: MonadThrow m => AlloyInstance -> m (ActivatedTransitions Object) +parseCapacity inst = do + t <- unscopedSingleSig inst activatedTransitions "" + pure $ ActivatedTransitions (Set.toList t) + +petriNetFindCapacityAlloy + :: BasicConfig + -> AdvConfig + -> Int + -> String +petriNetFindCapacityAlloy basicC advConfig maxCapacity + = [i|module PetriNetCapacity + +#{modulePetriSignature} +#{const modulePetriAdditions advConfig} +#{moduleHelpers} +#{modulePetriConcepts} +#{modulePetriConstraints} + +sig placesWithCapacity extends givenPlaces +{ + capacity : one Int, + complement : disj one addedPlaces +} +{ + capacity > 0 + capacity =< #{maxCapacity} + complement.@tokens = minus[capacity, tokens] +} + +fact { + noChangesToGivenParts + no addedTransitions +} + +pred #{capacityPredicateName}[#{activated} : set Transitions] { + #{defaultConstraints activated basicC} + #{compAdvConstraints advConfig} + + all t : Transitions, p : givenPlaces | + let n = minus[t.flow[p], p.flow[t]] | + n < 0 implies (t.flow[p.complement] = minus[0, n] and no p.complement.flow[t]) + else + n > 0 implies (p.complement.flow[t] = n and no t.flow[p.complement]) + else + no p.complement.flow[t] and no t.flow[p.complement] + all p : placesWithCapacity, w : p.flow[Transitions] + Transitions.flow[p] | p.capacity >= w + +} + +run #{capacityPredicateName} for exactly #{places basicC} givenPlaces, exactly #{places basicC} addedPlaces, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int +|] + where + activated = skolemName + +capacityPredicateName :: String +capacityPredicateName = "showCapacity" + +activatedTransitions :: String +activatedTransitions = skolemVariable capacityPredicateName skolemName + +skolemName :: String +skolemName = "activatedTrans" + From 41691fb8a112a617a15278cbe8e10af54f2dc780 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 31 Mar 2025 00:19:35 +0200 Subject: [PATCH 119/256] added new net type for capacity task in this new net places have a capacity --- src/Modelling/PetriNet/Alloy.hs | 1 + src/Modelling/PetriNet/Types.hs | 95 +++++++++++++++++++++++++++++++++ 2 files changed, 96 insertions(+) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index a997749f4..a53551b9d 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -18,6 +18,7 @@ module Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, + randomInSegment, signatures, skolemVariable, taskInstance, diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 607c9455d..17b94cc8c 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -23,7 +23,9 @@ module Modelling.PetriNet.Types ( AdvConfig (..), AlloyConfig (..), BasicConfig (..), + Capacity (Capacity), CapacityConfig (..), + CapacityNode (..), Change, ChangeConfig (..), Concurrent (..), @@ -242,6 +244,9 @@ newtype Concurrent a = Concurrent (a, a) newtype ActivatedTransitions a = ActivatedTransitions [a] deriving (Functor, Foldable, Traversable, Generic, Read, Show) +newtype Capacity a b = Capacity ([(Place, String, Int)], [(a, b, Int)]) + deriving (Functor, Foldable, Traversable, Generic, Read, Show) + class Show (n String) => PetriNode n where initialTokens :: n a -> Int @@ -268,6 +273,8 @@ class Show (n String) => PetriNode n where -} mapNode :: Ord b => (a -> b) -> n a -> n b + capacityPlace :: n a -> Int + {-| This function acts like 'traverse' on 'Traversable'. @@ -357,6 +364,45 @@ instance PetriNode SimpleNode where traverseNode f (SimpleTransition o) = SimpleTransition <$> traverseKeyMap f o +data CapacityNode a = + CapacityPlace { + initial :: Int, + capacity :: Int, + -- | max allowed token number of a 'CapacityNode' + flowIn :: Map a Int, + flowOut :: Map a Int + } | + CapacityTransition { + flowIn :: Map a Int, + flowOut :: Map a Int + } + deriving (Eq, Generic, Read, Show) + +instance PetriNode CapacityNode where + initialTokens CapacityPlace {initial} = initial + initialTokens CapacityTransition {} = + error "A CapacityTransition does not have initial tokens!" + + isPlaceNode CapacityPlace {} = True + isPlaceNode _ = False + + isTransitionNode CapacityTransition {} = True + isTransitionNode _ = False + + mapNode f (CapacityPlace s c i o) = + CapacityPlace s c (M.mapKeys f i) (M.mapKeys f o) + mapNode f (CapacityTransition i o) = + CapacityTransition (M.mapKeys f i) (M.mapKeys f o) + + traverseNode f (CapacityPlace s c i o) = + CapacityPlace s c <$> traverseKeyMap f i <*> traverseKeyMap f o + traverseNode f (CapacityTransition i o) = + CapacityTransition <$> traverseKeyMap f i <*> traverseKeyMap f o + + capacityPlace CapacityPlace {capacity} = capacity + capacityPlace CapacityTransition {} = + error "A CapacityTransition does not have a capacity!" + {-| Returns 'Just' the 'initial' tokens of the given node, if it is a place 'PetriNode', otherwise it returns 'Nothing'. @@ -558,6 +604,55 @@ updateSimpleNode g (SimpleTransition o) = SimpleTransition (g o) type SimplePetriLike = PetriLike SimpleNode type SimplePetriNet = SimplePetriLike String +--{- +instance Net PetriLike CapacityNode where + emptyNet = PetriLike M.empty + + flow x y = (M.lookup y . flowOutCN) <=< (M.lookup x . allNodes) + + nodes = allNodes + + deleteFlow x y (PetriLike ns) = PetriLike + . M.adjust (updateCapacityNode (M.delete y)) x + . M.adjust (updateCapacityNode (M.delete x)) y + $ ns + + deleteNode x ns = PetriLike + . adjustAll (updateCapacityNode (M.delete x)) (Just $ M.keys $ allNodes ns) + . adjustAll (updateCapacityNode (M.delete x)) (Just $ M.keys $ allNodes ns) + . M.delete x + . allNodes + $ ns + + + alterFlow x f y = PetriLike + . M.adjust (updateCapacityNode (M.insert y f)) x + . M.adjust (updateCapacityNode (M.insert x f)) y + . allNodes + + + alterNode x mt = PetriLike . M.alter alterNode' x . allNodes + where + alterNode' = Just . fromMaybe + (maybe (CapacityTransition M.empty M.empty) (\m -> CapacityPlace m 0 M.empty M.empty) mt) + + outFlow x = maybe M.empty flowOutCN . M.lookup x . allNodes + + mapNet = mapPetriLike + traverseNet = traversePetriLike + +flowOutCN :: CapacityNode a -> Map a Int +flowOutCN CapacityPlace {flowOut} = flowOut +flowOutCN CapacityTransition {flowOut} = flowOut + +updateCapacityNode :: (Map a Int -> Map b Int) -> CapacityNode a -> CapacityNode b +updateCapacityNode g (CapacityPlace t c i o) = CapacityPlace t c (g i) (g o) +updateCapacityNode g (CapacityTransition i o) = CapacityTransition (g i) (g o) + +type CapacityPetriLike = PetriLike CapacityNode +type CapacityPetriNet = CapacityPetriLike String +---} + {-| A 'Functor' like 'fmap' on 'PetriLike'. From 3f41cb5c38ebda0a845a724520f3aaa524888c42 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 31 Mar 2025 00:26:39 +0200 Subject: [PATCH 120/256] fixed ambiguity for "flowIn" since flowIn can refer to both CapacityNode and Node, everywhere flowIn is used on Node, flowInForNode is used --- src/Modelling/PetriNet/Types.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 17b94cc8c..319c9233b 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -536,7 +536,7 @@ instance Net PetriLike Node where $ ns deleteNode x (PetriLike ns) = PetriLike - . adjustAll (updateNode id (M.delete x)) (M.keys . flowIn <$> n) + . adjustAll (updateNode id (M.delete x)) (M.keys . flowInForNode <$> n) . adjustAll (updateNode (M.delete x) id) (M.keys . flowOutN <$> n) . M.delete x $ ns @@ -763,22 +763,26 @@ petriLikeToPetri p = do = throwM RelatedNodesOfTransitionsContainTransitions | any (`M.member` ps) (allRelatedNodes ps) = throwM RelatedNodesOfPlacesContainPlaces - | any (any (<= 0) . flowIn) ts + | any (any (<= 0) . flowInForNode) ts = throwM FlowToATransitionIsZeroOrLess | any (any (<= 0) . flowOutN) ts = throwM FlowFromATransitionIsZeroOrLess | otherwise = pure () - toChangeTuple n = (toFlowList flowIn n, toFlowList flowOutN n) + toChangeTuple n = (toFlowList flowInForNode n, toFlowList flowOutN n) toFlowList f n = M.foldrWithKey (\k _ xs -> fromMaybe 0 (M.lookup k $ f n) : xs) [] ps - relatedNodes n = M.keysSet (flowIn n) `S.union` M.keysSet (flowOutN n) + relatedNodes n = M.keysSet (flowInForNode n) `S.union` M.keysSet (flowOutN n) allRelatedNodes = foldr (S.union . relatedNodes) S.empty +flowInForNode :: Node a -> Map a Int +flowInForNode (PlaceNode _ flowIn _ ) = flowIn +flowInForNode (TransitionNode flowIn _) = flowIn + type Marking = [Int] type Transition = (Marking,Marking) From 255d9c1d78726caab204e1d97a5b9eee494dae44 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 31 Mar 2025 00:30:53 +0200 Subject: [PATCH 121/256] remove debugging --- src/Modelling/PetriNet/Capacity.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index f4efa676f..bdb20d121 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -122,7 +122,6 @@ import Language.Alloy.Call ( ) import GHC.Generics (Generic) -import Control.Monad.IO.Class (liftIO, MonadIO) data CapacityInstance = CapacityInstance { @@ -137,7 +136,7 @@ data CapacityInstance = CapacityInstance { deriving (Generic, Read, Show) capacityGenerate - :: (MonadAlloy m, MonadThrow m, MonadIO m) + :: (MonadAlloy m, MonadThrow m) => CapacityConfig -> Int -> Int @@ -150,9 +149,6 @@ capacityGenerate config seed segment = (net, condition) <- findCapacity config segment condition' <- lift $ traverse (parseWith parseTransitionPrec) condition - liftIO $ print net - liftIO $ print condition - liftIO $ print tn return $ CapacityInstance { drawWith = DrawSettings { withPlaceNames = not $ hidePlaceNames gc From 2bf34c96569bbc577ae38e500ab251a8f9c195d8 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 31 Mar 2025 23:45:14 +0200 Subject: [PATCH 122/256] fixed errors --- src/Modelling/PetriNet/Types.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 319c9233b..c308098c8 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -604,7 +604,6 @@ updateSimpleNode g (SimpleTransition o) = SimpleTransition (g o) type SimplePetriLike = PetriLike SimpleNode type SimplePetriNet = SimplePetriLike String ---{- instance Net PetriLike CapacityNode where emptyNet = PetriLike M.empty @@ -649,10 +648,6 @@ updateCapacityNode :: (Map a Int -> Map b Int) -> CapacityNode a -> CapacityNode updateCapacityNode g (CapacityPlace t c i o) = CapacityPlace t c (g i) (g o) updateCapacityNode g (CapacityTransition i o) = CapacityTransition (g i) (g o) -type CapacityPetriLike = PetriLike CapacityNode -type CapacityPetriNet = CapacityPetriLike String ----} - {-| A 'Functor' like 'fmap' on 'PetriLike'. From fcdf2719142a7972007ed94c427540b131c4a3c2 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 31 Mar 2025 23:48:09 +0200 Subject: [PATCH 123/256] added capacityPlace behavior for other node types --- src/Modelling/PetriNet/Types.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index c308098c8..20eb41b9c 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -333,6 +333,8 @@ instance PetriNode Node where traverseNode f (TransitionNode i o) = TransitionNode <$> traverseKeyMap f i <*> traverseKeyMap f o + capacityPlace _ = error "This node type does not support capacities." + data SimpleNode a = SimplePlace { initial :: Int, @@ -364,6 +366,7 @@ instance PetriNode SimpleNode where traverseNode f (SimpleTransition o) = SimpleTransition <$> traverseKeyMap f o + capacityPlace _ = error "This node type does not support capacities." data CapacityNode a = CapacityPlace { initial :: Int, From 00724edbc323ace3fa3ac3b16a6eea850394b7d2 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 31 Mar 2025 23:54:33 +0200 Subject: [PATCH 124/256] added first implementations for ...syntax, ...evaluation --- src/Modelling/PetriNet/Capacity.hs | 119 ++++++++++++++++++++++++----- 1 file changed, 99 insertions(+), 20 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index bdb20d121..3b1e7fcca 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -7,7 +7,9 @@ {-# LANGUAGE DeriveGeneric #-} module Modelling.PetriNet.Capacity ( + capacityEvaluation, capacityGenerate, + capacitySyntax, capacityTask, findCapacity, petriNetFindCapacity, @@ -61,10 +63,11 @@ import Modelling.PetriNet.Diagram ( renderWith, ) import Modelling.PetriNet.Find ( - FindInstance (..), findTaskInstance, + toFindEvaluationList, ) import Modelling.PetriNet.Reach.Type ( + ShowTransition (ShowTransition), Transition (Transition), parseTransitionPrec, ) @@ -73,22 +76,13 @@ import Modelling.PetriNet.Types ( AdvConfig (..), AlloyConfig (..), BasicConfig (..), - Capacity (Capacity), CapacityConfig (..), - Drawable, DrawSettings (..), GraphConfig (..), - Net (..), PetriLike (PetriLike, allNodes), SimpleNode (..), CapacityNode (..), - SimplePetriNet, petriScopeBitWidth, - transitionListShow, - transitionNames, - placeNames, - randomDrawSettings, - manyRandomDrawSettings, ) import Control.Monad.Catch (MonadThrow) @@ -115,6 +109,7 @@ import Control.Monad.Random ( mkStdGen ) import Control.Monad.Trans (MonadTrans (lift)) +import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) import Data.String.Interpolate (i, iii) import Language.Alloy.Call ( @@ -180,21 +175,70 @@ capacityTask -> CapacityInstance -> LangM m capacityTask path task = do + paragraph $ translate $ do + english "Consider the following Petri net with capacities:" + german "Betrachten Sie folgendes Petrinetz mit Kapazitäten:" image $=<< renderWith path "capacity" (originalNet task) (drawWith task) - paragraph $ translate $ do - english [iii| - State your answer by giving the number of the Petri net candidate - that is syntactically incorrect. - #{" "}|] - german [iii| - Geben Sie Ihre Antwort durch Angabe der Nummer des Petrinetzkandidaten an, - der syntaktisch inkorrekt ist. - #{" "}|] + image + $=<< renderWith path "capacity" (transformedNet task) (drawWith task) + paragraph $ do + translate $ do + english [iii| + Given the isolated Places . With how many tokens and how should they be connected to Transitions so that the + resulting Petri net without capacities is equivalent to the given Petri net with capacities? + |] + german [iii| + Gegeben der isolierten Stellen. Mit wie vielen Marken und wie sollten diese mit Transitionen verbunden werden, sodass + das resultierende Petrinetz ohne Kapazitäten äquivalent zum gegebenen Petrinetz mit Kapazitäten ist? + |] + translate $ do + english [iii| + State your answer by giving a tuple consisting of the complement places and their flows. + #{" "}|] + german [iii| + Geben Sie Ihre Antwort in Form eines Tupels an, das aus den Komplementstellen und ihren Flüssen besteht. + #{" "}|] pure () paragraph hoveringInformation pure () +capacitySyntax + :: OutputCapable m + => CapacityInstance + -> [Transition] + -> LangM' m () +capacitySyntax task input = do + for_ input assertTransition + pure () + where + assert = continueOrAbort False + assertTransition t = assert (isValidTransition t) $ translate $ do + let t' = show $ ShowTransition t + english $ t' ++ " is a transition of the given Petri net?" + german $ t' ++ " ist eine Transition des gegebenen Petrinetzes?" + isValidTransition (Transition x) = x >= 1 && x <= numberOfTransitions task + +capacityEvaluation + :: (Monad m, OutputCapable m) + => CapacityInstance + -> [Transition] + -> Rated m +capacityEvaluation task x = do + let what = translations $ do + english "are activated" + german "sind aktiviert" + uncurry (printSolutionAndAssert DefiniteArticle) + $=<< unLangM $ toFindEvaluationList what withSol active x + where + active = capacitySolution task + withSol = showSolution task + +capacitySolution :: CapacityInstance -> [Transition] +capacitySolution task = active + where + ActivatedTransitions active = toFind task + findCapacity :: (MonadAlloy m, MonadThrow m, RandomGen g) => CapacityConfig @@ -307,7 +351,8 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { } -run #{capacityPredicateName} for exactly #{places basicC} givenPlaces, exactly #{places basicC} addedPlaces, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int +run #{capacityPredicateName} for exactly #{places basicC} givenPlaces, exactly #{places basicC} addedPlaces, +exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int |] where activated = skolemName @@ -321,3 +366,37 @@ activatedTransitions = skolemVariable capacityPredicateName skolemName skolemName :: String skolemName = "activatedTrans" +defaultCapacityInstance :: CapacityInstance +defaultCapacityInstance = CapacityInstance { + drawWith = DrawSettings { + withPlaceNames = True, + withSvgHighlighting = True, + withTransitionNames = True, + with1Weights = False, + withGraphvizCommand = Circo + }, + toFind = ActivatedTransitions [Transition 1, Transition 2], + originalNet = PetriLike { + allNodes = M.fromList [ + ("s1",CapacityPlace {initial = 0, capacity = 0, flowIn = M.empty, flowOut = M.empty}), + ("s2",CapacityPlace {initial = 0, capacity = 0, flowIn = M.empty, flowOut = M.empty}), + ("s3",CapacityPlace {initial = 1, capacity = 3, flowIn = M.fromList [("t1",2),("t2",2)], flowOut = M.empty}), + ("s4",CapacityPlace {initial = 2, capacity = 4, flowIn = M.empty, flowOut = M.fromList [("t1",1),("t2",2)]}), + ("t1",CapacityTransition {flowIn = M.fromList [("s3",2),("s4",1)], flowOut = M.fromList [("s3",2)]}), + ("t2",CapacityTransition {flowIn = M.fromList [("s3",2),("s4",2)], flowOut = M.fromList [("s3",2)]}) + ] + }, + transformedNet = PetriLike { + allNodes = M.fromList [ + ("s1",SimplePlace {initial = 2, flowOut = M.fromList [("t1",2),("t2",2)]}), + ("s2",SimplePlace {initial = 2, flowOut = M.empty}), + ("s3",SimplePlace {initial = 1, flowOut = M.empty}), + ("s4",SimplePlace {initial = 2, flowOut = M.fromList [("t1",1),("t2",2)]}), + ("t1",SimpleTransition {flowOut = M.fromList [("s2",1),("s3",2)]}), + ("t2",SimpleTransition {flowOut = M.fromList [("s2",2),("s3",2)]}) + ] + }, + numberOfPlaces = 4, + numberOfTransitions = 3, + showSolution = False +} From b265e874bf0acc812be6d511a7b504bf70e7224c Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 1 Apr 2025 00:22:25 +0200 Subject: [PATCH 125/256] fixed other errors --- src/Modelling/PetriNet/Capacity.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 3b1e7fcca..11a9efd8f 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -11,6 +11,7 @@ module Modelling.PetriNet.Capacity ( capacityGenerate, capacitySyntax, capacityTask, + defaultCapacityInstance, findCapacity, petriNetFindCapacity, petriNetPickCapacity, From 3f4aa43052b58c350701657bc5ccaa3a531fa784 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 1 Apr 2025 09:50:48 +0200 Subject: [PATCH 126/256] split off capacityPlace into separate type class --- src/Modelling/PetriNet/Types.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 20eb41b9c..18fe59c79 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -48,6 +48,7 @@ module Modelling.PetriNet.Types ( PetriLike (..), PetriMath (..), PetriNode (..), + PetriNodeWithCapacity (..), PickConcurrencyConfig (..), PickConflictConfig (..), PickMistakeConfig (..), @@ -273,8 +274,6 @@ class Show (n String) => PetriNode n where -} mapNode :: Ord b => (a -> b) -> n a -> n b - capacityPlace :: n a -> Int - {-| This function acts like 'traverse' on 'Traversable'. @@ -291,6 +290,10 @@ class Show (n String) => PetriNode n where -} traverseNode :: (Applicative f, Ord b) => (a -> f b) -> n a -> f (n b) +class PetriNode n => PetriNodeWithCapacity n where + capacityPlace :: n a -> Int + capacityPlace _ = error "This node type does not support capacities." + {-| A node is part of a Petri like graph (see 'PetriLike'). Each node stores its predecessor and successor nodes together with their weight @@ -333,8 +336,6 @@ instance PetriNode Node where traverseNode f (TransitionNode i o) = TransitionNode <$> traverseKeyMap f i <*> traverseKeyMap f o - capacityPlace _ = error "This node type does not support capacities." - data SimpleNode a = SimplePlace { initial :: Int, @@ -366,7 +367,6 @@ instance PetriNode SimpleNode where traverseNode f (SimpleTransition o) = SimpleTransition <$> traverseKeyMap f o - capacityPlace _ = error "This node type does not support capacities." data CapacityNode a = CapacityPlace { initial :: Int, @@ -402,6 +402,7 @@ instance PetriNode CapacityNode where traverseNode f (CapacityTransition i o) = CapacityTransition <$> traverseKeyMap f i <*> traverseKeyMap f o +instance PetriNodeWithCapacity CapacityNode where capacityPlace CapacityPlace {capacity} = capacity capacityPlace CapacityTransition {} = error "A CapacityTransition does not have a capacity!" From 426bf9c5f09dc4383e0be24dcbda3c56b445e846 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 1 Apr 2025 23:34:51 +0200 Subject: [PATCH 127/256] added app for capacity --- app/capacity.hs | 83 ++++++++++++++++++++++++++++++++++++++++++++++++ app/package.yaml | 13 ++++++++ package.yaml | 1 + 3 files changed, 97 insertions(+) create mode 100644 app/capacity.hs diff --git a/app/capacity.hs b/app/capacity.hs new file mode 100644 index 000000000..212a6dfd1 --- /dev/null +++ b/app/capacity.hs @@ -0,0 +1,83 @@ +{-# Language DuplicateRecordFields #-} +{-# Language RecordWildCards #-} + +module Main (main) where + +import Capabilities.Alloy.IO () +import Capabilities.Cache.IO () +import Capabilities.Diagrams.IO () +import Capabilities.Graphviz.IO () +import Common ( + forceErrors, + instanceInput, + withLang, + ) +import Modelling.PetriNet.Capacity ( + checkCapacityConfigs, + capacityGenerate, + simpleCapacityTask, + ) +import Modelling.PetriNet.Types ( + BasicConfig(..), + CapacityConfig(..), + defaultCapacityConfig, + ) + +import Control.OutputCapable.Blocks (Language (English)) +import Control.Monad.Trans.Class (lift) +import Data.Maybe (isNothing) +import System.IO ( + BufferMode (NoBuffering), hSetBuffering, stdout, + ) +import Text.Pretty.Simple (pPrint) +import Text.Read (readMaybe) + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + putStrLn "Generating instance for converting nets with capacities into nets without capacities" + i <- instanceInput + if i >= 0 + then mainFind i + else print "There is no negative index" + +mainFind :: Int -> IO () +mainFind i = forceErrors $ do + let theConfig@CapacityConfig{..} = defaultCapacityConfig + lift $ pPrint theConfig + (pls, trns, maxCap) <- lift $ userInput theConfig + let config = theConfig { + basicConfig = basicConfig { + places = pls, + transitions = trns + }, + maxCapacity = maxCap + } :: CapacityConfig + let c = checkCapacityConfigs config + if isNothing c + then do + t <- capacityGenerate config 0 i + lift . (`withLang` English) $ simpleCapacityTask "tmp/" t + lift $ print t + else + lift $ print c + +validateInput :: Read a => a -> IO a +validateInput d = do + input <- getLine + if null input then return d + else case readMaybe input of + Just n -> return n + Nothing -> do + putStrLn "Invalid input" + validateInput d + +userInput :: CapacityConfig -> IO (Int, Int, Int) +userInput CapacityConfig{basicConfig = BasicConfig{..}, maxCapacity = maxCapacity} = do + putStr "Number of Places: " + pls <- validateInput places + putStr "Number of Transitions: " + trns <- validateInput transitions + putStr "Highest capacity for a place: " + maxCap <- validateInput maxCapacity + return (pls, trns, maxCap) diff --git a/app/package.yaml b/app/package.yaml index 4100f1c49..ba50985a2 100644 --- a/app/package.yaml +++ b/app/package.yaml @@ -21,6 +21,19 @@ dependencies: - mtl - transformers executables: + capacity: + main: capacity.hs + source-dirs: + - . + - common + dependencies: + - bytestring + - digest + - modelling-tasks + - output-blocks + - pretty-simple + other-modules: + - Common check-cds: main: check-cds.hs source-dirs: . diff --git a/package.yaml b/package.yaml index 0f71d7436..8215ec250 100644 --- a/package.yaml +++ b/package.yaml @@ -130,6 +130,7 @@ library: - Modelling.PetriNet.MatchToMath - Modelling.PetriNet.Parser - Modelling.PetriNet.Types + - Modelling.PetriNet.Capacity - Modelling.PetriNet.Concurrency - Modelling.PetriNet.Conflict - Modelling.PetriNet.ConflictPlaces From 2d8c2146c3110270422b9e34fb4fca2d5e2c309c Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 1 Apr 2025 23:36:52 +0200 Subject: [PATCH 128/256] added necessities for app --- src/Modelling/PetriNet/Capacity.hs | 43 ++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 11a9efd8f..2d3b08af8 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -11,12 +11,14 @@ module Modelling.PetriNet.Capacity ( capacityGenerate, capacitySyntax, capacityTask, + checkCapacityConfigs, defaultCapacityInstance, findCapacity, petriNetFindCapacity, petriNetPickCapacity, parseCapacity, pickCapacity, + simpleCapacityTask, ) where import qualified Modelling.PetriNet.Types as Find ( @@ -164,6 +166,19 @@ capacityGenerate config seed segment = bc = Find.basicConfig config gc = Pick.graphConfig config +simpleCapacityTask + :: ( + MonadCache m, + MonadDiagrams m, + MonadGraphviz m, + MonadThrow m, + OutputCapable m + ) + => FilePath + -> CapacityInstance + -> LangM m +simpleCapacityTask = capacityTask + capacityTask :: ( MonadCache m, @@ -367,6 +382,34 @@ activatedTransitions = skolemVariable capacityPredicateName skolemName skolemName :: String skolemName = "activatedTrans" +checkCapacityConfigs :: CapacityConfig -> Maybe String +checkCapacityConfigs CapacityConfig { + basicConfig, + advConfig, + maxCapacity + } + = checkActivatedSourceConfig basicConfig advConfig + <|> checkCapacityConfig basicConfig maxCapacity + +checkCapacityConfig :: BasicConfig -> Int -> Maybe String +checkCapacityConfig BasicConfig { + atLeastActive, + maxTokensPerPlace, + maxFlowPerEdge + } + maxCapacity + | maxCapacity <= 0 + = Just "'maxCapacity' has to be positive." + | maxCapacity < maxFlowPerEdge + = Just "'maxCapacity' can not be too low for flow weights." + | maxCapacity < maxTokensPerPlace + = Just "The starting tokens can not exceed 'maxCapacity'." + | atLeastActive == 0 + = Just "At least one transition has to be activated." + | otherwise + = Nothing + +{- defaultCapacityInstance :: CapacityInstance defaultCapacityInstance = CapacityInstance { drawWith = DrawSettings { From dd10107a1206d95fb79b813fe723a276236f2f83 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 2 Apr 2025 00:05:27 +0200 Subject: [PATCH 129/256] added missing imports --- app/modelling-tasks-apps.cabal | 26 ++++++++++++++++++++++++++ modelling-tasks.cabal | 2 +- src/Modelling/PetriNet/Capacity.hs | 3 ++- 3 files changed, 29 insertions(+), 2 deletions(-) diff --git a/app/modelling-tasks-apps.cabal b/app/modelling-tasks-apps.cabal index 0db5e0989..5ad30d158 100644 --- a/app/modelling-tasks-apps.cabal +++ b/app/modelling-tasks-apps.cabal @@ -8,6 +8,32 @@ name: modelling-tasks-apps version: 0.0.0 build-type: Simple +executable capacity + main-is: capacity.hs + other-modules: + Common + hs-source-dirs: + ./ + common + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints -Werror -Wwarn=incomplete-uni-patterns -Wwarn=orphans + build-tools: + alex + , happy + build-depends: + MonadRandom + , base + , bytestring + , containers + , diagrams-lib + , diagrams-svg + , digest + , modelling-tasks + , mtl + , output-blocks + , pretty-simple + , transformers + default-language: Haskell2010 + executable check-cds main-is: check-cds.hs hs-source-dirs: diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index 920488d3d..7b3d74d4c 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -84,6 +84,7 @@ library Modelling.PetriNet.MatchToMath Modelling.PetriNet.Parser Modelling.PetriNet.Types + Modelling.PetriNet.Capacity Modelling.PetriNet.Concurrency Modelling.PetriNet.Conflict Modelling.PetriNet.ConflictPlaces @@ -103,7 +104,6 @@ library Modelling.CdOd.Phrasing Modelling.CdOd.Phrasing.English Modelling.CdOd.Phrasing.German - Modelling.PetriNet.Capacity Modelling.PetriNet.Reach.Draw Modelling.PetriNet.Reach.Roll Paths_modelling_tasks diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 2d3b08af8..03617eb9f 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -85,9 +85,11 @@ import Modelling.PetriNet.Types ( PetriLike (PetriLike, allNodes), SimpleNode (..), CapacityNode (..), + checkActivatedSourceConfig, petriScopeBitWidth, ) +import Control.Applicative ((<|>)) import Control.Monad.Catch (MonadThrow) import Control.OutputCapable.Blocks ( ArticleToUse (DefiniteArticle), @@ -409,7 +411,6 @@ checkCapacityConfig BasicConfig { | otherwise = Nothing -{- defaultCapacityInstance :: CapacityInstance defaultCapacityInstance = CapacityInstance { drawWith = DrawSettings { From ade5686b8a3fa75669f8338d428a6b37e2f48cd4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Wed, 2 Apr 2025 13:44:10 +0200 Subject: [PATCH 130/256] like #317 --- src/Modelling/PetriNet/Capacity.hs | 2 +- src/Modelling/PetriNet/FindActivatedTransitions.hs | 2 +- src/Modelling/PetriNet/PickMistake.hs | 5 ++++- 3 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 03617eb9f..98c4535db 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -333,7 +333,7 @@ petriNetFindCapacityAlloy basicC advConfig maxCapacity = [i|module PetriNetCapacity #{modulePetriSignature} -#{const modulePetriAdditions advConfig} +#{modulePetriAdditions} #{moduleHelpers} #{modulePetriConcepts} #{modulePetriConstraints} diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 193a3fb45..29f3c5949 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -303,7 +303,7 @@ petriNetActivatedTransitionsAlloy basicC changeC atMost advConfig = [i|module PetriNetFindActivatedTransitions #{modulePetriSignature} -#{const modulePetriAdditions advConfig} +#{modulePetriAdditions} #{moduleHelpers} #{modulePetriConcepts} #{modulePetriConstraints} diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index c48fb9257..0ad8173d1 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -39,6 +39,7 @@ import Modelling.PetriNet.Alloy ( modulePetriConcepts, modulePetriConstraints, modulePetriSignature, + signatures, taskInstance, ) import Modelling.PetriNet.Pick ( @@ -199,6 +200,7 @@ petriNetPickMistakeAlloy basicC changeC mistakeC = [i|module PetriNetPickMistake #{modulePetriSignature} +#{sigs} #{moduleHelpers} #{modulePetriConcepts} #{modulePetriConstraints} @@ -211,9 +213,10 @@ pred #{mistakePredicateName} { #{prohibitSelfLoops mistakeC} } -run #{mistakePredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int +run #{mistakePredicateName} for #{petriScopeBitWidth basicC} Int |] where + sigs = signatures "given" (places basicC) (transitions basicC) prohibitSelfLoops :: MistakeConfig -> String prohibitSelfLoops MistakeConfig{ canHaveTransitionToTransition, canHavePlaceToPlace } | canHaveTransitionToTransition && canHavePlaceToPlace From a7ff61f9782e991df44f6773e533ba7f92c97f08 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 2 Apr 2025 20:00:08 +0200 Subject: [PATCH 131/256] moved check for place names from specific tasks to find --- src/Modelling/PetriNet/ConflictPlaces.hs | 9 +-------- src/Modelling/PetriNet/Find.hs | 12 +++++++++++- src/Modelling/PetriNet/MatchToMath.hs | 16 ++++++---------- 3 files changed, 18 insertions(+), 19 deletions(-) diff --git a/src/Modelling/PetriNet/ConflictPlaces.hs b/src/Modelling/PetriNet/ConflictPlaces.hs index 59df2d59f..911503e3e 100644 --- a/src/Modelling/PetriNet/ConflictPlaces.hs +++ b/src/Modelling/PetriNet/ConflictPlaces.hs @@ -36,6 +36,7 @@ import Modelling.PetriNet.Find ( checkFindTwoActive, drawFindWith, findInitialTuple, + prohibitHidePlaceNames, ) import Modelling.PetriNet.Diagram ( renderWith, @@ -51,7 +52,6 @@ import Modelling.PetriNet.Types ( Conflict, DrawSettings (..), FindConflictConfig (..), - GraphConfig (..), Net, PetriConflict (..), PetriLike (..), @@ -218,13 +218,6 @@ checkFindConflictPlacesConfig FindConflictConfig { <|> checkConfigForFind basicConfig changeConfig graphConfig <|> checkConflictConfig basicConfig conflictConfig -prohibitHidePlaceNames :: GraphConfig -> Maybe String -prohibitHidePlaceNames gc - | hidePlaceNames gc - = Just "Place names are required for this task type." - | otherwise - = Nothing - defaultFindConflictPlacesInstance :: FindInstance SimplePetriNet Conflict defaultFindConflictPlacesInstance = FindInstance { drawFindWith = DrawSettings { diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 8ece5b3a4..fadf5b82f 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -10,13 +10,16 @@ module Modelling.PetriNet.Find ( FindInstance (..), - checkFindTwoActive, + checkBasicConfig, checkConfigForFind, + checkFindTwoActive, findInitialList, findInitialTuple, findTaskInstance, lToFind, + prohibitHidePlaceNames, prohibitHideTransitionNames, + prohibitPatchworkRenderer, toFindEvaluation, toFindEvaluationList, toFindEvaluationTuple, @@ -181,6 +184,13 @@ checkConfigForFind basic change graph = <|> checkChangeConfig basic change <|> prohibitPatchworkRenderer graph +prohibitHidePlaceNames :: GraphConfig -> Maybe String +prohibitHidePlaceNames gc + | hidePlaceNames gc + = Just "Place names are required for this task type." + | otherwise + = Nothing + prohibitHideTransitionNames :: GraphConfig -> Maybe String prohibitHideTransitionNames gc | hideTransitionNames gc diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 1adfa93ea..2f16ce121 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -61,6 +61,10 @@ import Modelling.PetriNet.Alloy ( ) import Modelling.PetriNet.Diagram (cacheNet) import Modelling.PetriNet.LaTeX (toPetriMath) +import Modelling.PetriNet.Find ( + prohibitHidePlaceNames, + prohibitHideTransitionNames, + ) import Modelling.PetriNet.Parser ( parseChange, parseRenamedNet, @@ -512,22 +516,14 @@ checkMathConfig c@MathConfig { useDifferentGraphLayouts, wrongInstances } = checkBasicConfig basicConfig - <|> prohibitHideNames graphConfig + <|> prohibitHidePlaceNames graphConfig + <|> prohibitHideTransitionNames graphConfig <|> checkActivatedSourceConfig basicConfig advConfig <|> checkChangeConfig basicConfig changeConfig <|> checkConfig c <|> checkGraphLayouts useDifferentGraphLayouts wrongInstances graphConfig <|> prohibitPatchworkRenderer graphConfig -prohibitHideNames :: GraphConfig -> Maybe String -prohibitHideNames gc - | hidePlaceNames gc - = Just "Place names are required for this task type" - | hideTransitionNames gc - = Just "Transition names are required for this task type" - | otherwise - = Nothing - checkConfig :: MathConfig -> Maybe String checkConfig MathConfig { generatedWrongInstances, From 6d73604b3065f56d25ac8688e42e19e84ae98514 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 2 Apr 2025 20:00:23 +0200 Subject: [PATCH 132/256] added new checks to capacity --- src/Modelling/PetriNet/Capacity.hs | 13 +++++++++++-- src/Modelling/PetriNet/Types.hs | 4 ++-- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 98c4535db..78a5917fb 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -66,7 +66,11 @@ import Modelling.PetriNet.Diagram ( renderWith, ) import Modelling.PetriNet.Find ( + checkBasicConfig, findTaskInstance, + prohibitHidePlaceNames, + prohibitHideTransitionNames, + prohibitPatchworkRenderer, toFindEvaluationList, ) import Modelling.PetriNet.Reach.Type ( @@ -388,9 +392,14 @@ checkCapacityConfigs :: CapacityConfig -> Maybe String checkCapacityConfigs CapacityConfig { basicConfig, advConfig, - maxCapacity + maxCapacity, + graphConfig } - = checkActivatedSourceConfig basicConfig advConfig + = prohibitHidePlaceNames graphConfig + <|> prohibitHideTransitionNames graphConfig + <|> checkBasicConfig basicConfig + <|> prohibitPatchworkRenderer graphConfig + <|> checkActivatedSourceConfig basicConfig advConfig <|> checkCapacityConfig basicConfig maxCapacity checkCapacityConfig :: BasicConfig -> Int -> Maybe String diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 18fe59c79..236270186 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1064,9 +1064,9 @@ data CapacityConfig = CapacityConfig defaultCapacityConfig :: CapacityConfig defaultCapacityConfig = CapacityConfig - { basicConfig = defaultBasicConfig { places = 2, transitions = 2, atLeastActive = 1 } + { basicConfig = defaultBasicConfig { places = 2, transitions = 2, atLeastActive = 1, maxTokensPerPlace = 4, tokensOverall = (2, 8)} , advConfig = defaultAdvConfig - , maxCapacity = 8 + , maxCapacity = 4 , graphConfig = defaultGraphConfig { hidePlaceNames = False, hideTransitionNames = False } , printSolution = True , useDifferentGraphLayouts = False From 1682fbe97e880532d4c38ba83f5187162a417bda Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 2 Apr 2025 20:05:55 +0200 Subject: [PATCH 133/256] remove redundant check --- src/Modelling/PetriNet/Capacity.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 78a5917fb..2768748f8 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -409,8 +409,6 @@ checkCapacityConfig BasicConfig { maxFlowPerEdge } maxCapacity - | maxCapacity <= 0 - = Just "'maxCapacity' has to be positive." | maxCapacity < maxFlowPerEdge = Just "'maxCapacity' can not be too low for flow weights." | maxCapacity < maxTokensPerPlace From 4041e1cb7dc329d09179cb7f8110a1f0566fe89d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 2 Apr 2025 21:08:31 +0200 Subject: [PATCH 134/256] added new fields to the capacity config --- app/capacity.hs | 21 ++++++++++++++++----- src/Modelling/PetriNet/Capacity.hs | 15 +++++++++++++-- src/Modelling/PetriNet/Types.hs | 4 ++++ 3 files changed, 33 insertions(+), 7 deletions(-) diff --git a/app/capacity.hs b/app/capacity.hs index 212a6dfd1..79c3febe6 100644 --- a/app/capacity.hs +++ b/app/capacity.hs @@ -45,13 +45,15 @@ mainFind :: Int -> IO () mainFind i = forceErrors $ do let theConfig@CapacityConfig{..} = defaultCapacityConfig lift $ pPrint theConfig - (pls, trns, maxCap) <- lift $ userInput theConfig + (pls, trns, maxCap, newFlow, oneMin) <- lift $ userInput theConfig let config = theConfig { basicConfig = basicConfig { places = pls, transitions = trns }, - maxCapacity = maxCap + maxCapacity = maxCap, + newFlowToComplement = newFlow, + oneMinCapacity = oneMin } :: CapacityConfig let c = checkCapacityConfigs config if isNothing c @@ -72,12 +74,21 @@ validateInput d = do putStrLn "Invalid input" validateInput d -userInput :: CapacityConfig -> IO (Int, Int, Int) -userInput CapacityConfig{basicConfig = BasicConfig{..}, maxCapacity = maxCapacity} = do +userInput :: CapacityConfig -> IO (Int, Int, Int, Int, Int) +userInput CapacityConfig{ + basicConfig = BasicConfig{..}, + maxCapacity = maxCapacity, + newFlowToComplement = newFlowToComplement, + oneMinCapacity = oneMinCapacity + } = do putStr "Number of Places: " pls <- validateInput places putStr "Number of Transitions: " trns <- validateInput transitions putStr "Highest capacity for a place: " maxCap <- validateInput maxCapacity - return (pls, trns, maxCap) + putStr "How many new flows are connected to complement places: " + newFlow <- validateInput newFlowToComplement + putStr "What capacity should one place have: " + oneMin <- validateInput oneMinCapacity + return (pls, trns, maxCap, newFlow, oneMin) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 2768748f8..50168884b 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -393,6 +393,8 @@ checkCapacityConfigs CapacityConfig { basicConfig, advConfig, maxCapacity, + newFlowToComplement, + oneMinCapacity, graphConfig } = prohibitHidePlaceNames graphConfig @@ -400,19 +402,28 @@ checkCapacityConfigs CapacityConfig { <|> checkBasicConfig basicConfig <|> prohibitPatchworkRenderer graphConfig <|> checkActivatedSourceConfig basicConfig advConfig - <|> checkCapacityConfig basicConfig maxCapacity + <|> checkCapacityConfig basicConfig maxCapacity newFlowToComplement oneMinCapacity -checkCapacityConfig :: BasicConfig -> Int -> Maybe String +checkCapacityConfig :: BasicConfig -> Int -> Int -> Int -> Maybe String checkCapacityConfig BasicConfig { + transitions, atLeastActive, maxTokensPerPlace, maxFlowPerEdge } maxCapacity + newFlowToComplement + oneMinCapacity | maxCapacity < maxFlowPerEdge = Just "'maxCapacity' can not be too low for flow weights." | maxCapacity < maxTokensPerPlace = Just "The starting tokens can not exceed 'maxCapacity'." + | newFlowToComplement <= 0 + = Just "At least one flow has to be connected to a complement place." + | newFlowToComplement > 2 * transitions + = Just "'newFlowToComplement' is set unreasonably high, given the number of transitions." + | oneMinCapacity > maxCapacity + = Just "'maxCapacity' has to be larger than 'oneMinCapacity'." | atLeastActive == 0 = Just "At least one transition has to be activated." | otherwise diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 236270186..71a87e8e6 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1056,6 +1056,8 @@ data CapacityConfig = CapacityConfig { basicConfig :: BasicConfig , advConfig :: AdvConfig , maxCapacity :: Int + , newFlowToComplement :: Int + , oneMinCapacity :: Int , graphConfig :: GraphConfig , printSolution :: Bool , useDifferentGraphLayouts :: Bool @@ -1067,6 +1069,8 @@ defaultCapacityConfig = CapacityConfig { basicConfig = defaultBasicConfig { places = 2, transitions = 2, atLeastActive = 1, maxTokensPerPlace = 4, tokensOverall = (2, 8)} , advConfig = defaultAdvConfig , maxCapacity = 4 + , newFlowToComplement = 4 + , oneMinCapacity = 2 , graphConfig = defaultGraphConfig { hidePlaceNames = False, hideTransitionNames = False } , printSolution = True , useDifferentGraphLayouts = False From d5b461ef83935149f4799cf8404b7536fb6db2b7 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 2 Apr 2025 21:24:08 +0200 Subject: [PATCH 135/256] new function for bit width that also compares maxCapacity --- src/Modelling/PetriNet/Capacity.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 50168884b..c7d62c82b 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -90,7 +90,6 @@ import Modelling.PetriNet.Types ( SimpleNode (..), CapacityNode (..), checkActivatedSourceConfig, - petriScopeBitWidth, ) import Control.Applicative ((<|>)) @@ -374,7 +373,7 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { } run #{capacityPredicateName} for exactly #{places basicC} givenPlaces, exactly #{places basicC} addedPlaces, -exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int +exactly #{transitions basicC} Transitions, #{petriScopeBitWidthCapacity basicC maxCapacity} Int |] where activated = skolemName @@ -388,6 +387,15 @@ activatedTransitions = skolemVariable capacityPredicateName skolemName skolemName :: String skolemName = "activatedTrans" +petriScopeBitWidthCapacity :: BasicConfig -> Int -> Int +petriScopeBitWidthCapacity BasicConfig + { flowOverall, places, tokensOverall, transitions } + maxCapacity = + floor + (2 + ((logBase :: Double -> Double -> Double ) 2.0 . fromIntegral) + (maximum [snd flowOverall, snd tokensOverall, places, transitions, maxCapacity]) + ) + checkCapacityConfigs :: CapacityConfig -> Maybe String checkCapacityConfigs CapacityConfig { basicConfig, From f94da9c984aebfe60c3a1c6ca0d3df4fedb504c1 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 4 Apr 2025 00:29:48 +0200 Subject: [PATCH 136/256] changed how sink and source transitions interact with capacities --- src/Modelling/PetriNet/Capacity.hs | 38 ++++++++++++++++++++++++++++-- 1 file changed, 36 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index c7d62c82b..413e23b2f 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -1,6 +1,7 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE DeriveFunctor #-} @@ -49,8 +50,8 @@ import Modelling.Auxiliary.Output ( hoveringInformation, ) import Modelling.PetriNet.Alloy ( - compAdvConstraints, defaultConstraints, + enforceConstraints, moduleHelpers, modulePetriAdditions, modulePetriConcepts, @@ -357,9 +358,23 @@ fact { no addedTransitions } +pred sourceTransitionsCapacity[ts : set Transitions] { + no Nodes.flow[ts] + all p : placesWithCapacity | + let flows = p.flow[ts] | + flows + p.tokens <= p.capacity +} + +pred sinkTransitionsCapacity[ts : set Transitions] { + no ts.flow + all p : placesWithCapacity | + let flows = p.flow[ts] | + flows - p.tokens <= p.capacity +} + pred #{capacityPredicateName}[#{activated} : set Transitions] { #{defaultConstraints activated basicC} - #{compAdvConstraints advConfig} + #{compAdvConstraintsCapacity advConfig} all t : Transitions, p : givenPlaces | let n = minus[t.flow[p], p.flow[t]] | @@ -377,6 +392,25 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidthCapacity basicC m |] where activated = skolemName + compAdvConstraintsCapacity :: AdvConfig -> String + compAdvConstraintsCapacity AdvConfig + { presenceOfSelfLoops, presenceOfSinkTransitions + , presenceOfSourceTransitions + } = [i| + #{maybe "" petriLoops presenceOfSelfLoops} + #{maybe "" petriSink presenceOfSinkTransitions} + #{maybe "" petriSource presenceOfSourceTransitions} + |] + where + petriLoops = \case + True -> "some n : Nodes | selfLoop[n]" + False -> "no n : Nodes | selfLoop[n]" + petriSink = \case + True -> "some t : Transitions | sinkTransitionsCapacity[t]" + False -> "no t : Transitions | sinkTransitionsCapacity[t]" + petriSource = \case + True -> "some t : Transitions | sourceTransitionsCapacity[t]" + False -> "no t : Transitions | sourceTransitionsCapacity[t]" capacityPredicateName :: String capacityPredicateName = "showCapacity" From fc895ec40f07552302ad2d51abb0aa18da83a5fc Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 4 Apr 2025 00:30:28 +0200 Subject: [PATCH 137/256] atLeastActive is only checked for the transformed net --- src/Modelling/PetriNet/Alloy.hs | 1 + src/Modelling/PetriNet/Capacity.hs | 7 +++++-- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index a53551b9d..c2bf616e0 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -12,6 +12,7 @@ module Modelling.PetriNet.Alloy ( compChange, connected, defaultConstraints, + enforceConstraints, isolated, moduleHelpers, modulePetriAdditions, diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 413e23b2f..52eb653e4 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -50,7 +50,6 @@ import Modelling.Auxiliary.Output ( hoveringInformation, ) import Modelling.PetriNet.Alloy ( - defaultConstraints, enforceConstraints, moduleHelpers, modulePetriAdditions, @@ -373,7 +372,7 @@ pred sinkTransitionsCapacity[ts : set Transitions] { } pred #{capacityPredicateName}[#{activated} : set Transitions] { - #{defaultConstraints activated basicC} + #{defaultConstraintsAtLeastZero activated basicC} #{compAdvConstraintsCapacity advConfig} all t : Transitions, p : givenPlaces | @@ -392,6 +391,10 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidthCapacity basicC m |] where activated = skolemName + defaultConstraintsAtLeastZero :: String -> BasicConfig -> String + defaultConstraintsAtLeastZero activated basicC = + enforceConstraints True Nothing activated (basicC { atLeastActive = 0 }) ++ + concat [ [i|\##{activated} >= #{atLeastActive basicC}|] | atLeastActive basicC > 0] compAdvConstraintsCapacity :: AdvConfig -> String compAdvConstraintsCapacity AdvConfig { presenceOfSelfLoops, presenceOfSinkTransitions From 76eabf041bdf2d1a068fe279675e8f7bdbec5afc Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 4 Apr 2025 00:38:58 +0200 Subject: [PATCH 138/256] changed name of capacity field --- app/capacity.hs | 6 +++--- src/Modelling/PetriNet/Capacity.hs | 12 ++++++------ src/Modelling/PetriNet/Types.hs | 4 ++-- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/app/capacity.hs b/app/capacity.hs index 79c3febe6..7531551a2 100644 --- a/app/capacity.hs +++ b/app/capacity.hs @@ -52,7 +52,7 @@ mainFind i = forceErrors $ do transitions = trns }, maxCapacity = maxCap, - newFlowToComplement = newFlow, + newFlowWithComplement = newFlow, oneMinCapacity = oneMin } :: CapacityConfig let c = checkCapacityConfigs config @@ -78,7 +78,7 @@ userInput :: CapacityConfig -> IO (Int, Int, Int, Int, Int) userInput CapacityConfig{ basicConfig = BasicConfig{..}, maxCapacity = maxCapacity, - newFlowToComplement = newFlowToComplement, + newFlowWithComplement = newFlowWithComplement, oneMinCapacity = oneMinCapacity } = do putStr "Number of Places: " @@ -88,7 +88,7 @@ userInput CapacityConfig{ putStr "Highest capacity for a place: " maxCap <- validateInput maxCapacity putStr "How many new flows are connected to complement places: " - newFlow <- validateInput newFlowToComplement + newFlow <- validateInput newFlowWithComplement putStr "What capacity should one place have: " oneMin <- validateInput oneMinCapacity return (pls, trns, maxCap, newFlow, oneMin) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 52eb653e4..ec542a1f7 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -438,7 +438,7 @@ checkCapacityConfigs CapacityConfig { basicConfig, advConfig, maxCapacity, - newFlowToComplement, + newFlowWithComplement, oneMinCapacity, graphConfig } @@ -447,7 +447,7 @@ checkCapacityConfigs CapacityConfig { <|> checkBasicConfig basicConfig <|> prohibitPatchworkRenderer graphConfig <|> checkActivatedSourceConfig basicConfig advConfig - <|> checkCapacityConfig basicConfig maxCapacity newFlowToComplement oneMinCapacity + <|> checkCapacityConfig basicConfig maxCapacity newFlowWithComplement oneMinCapacity checkCapacityConfig :: BasicConfig -> Int -> Int -> Int -> Maybe String checkCapacityConfig BasicConfig { @@ -457,16 +457,16 @@ checkCapacityConfig BasicConfig { maxFlowPerEdge } maxCapacity - newFlowToComplement + newFlowWithComplement oneMinCapacity | maxCapacity < maxFlowPerEdge = Just "'maxCapacity' can not be too low for flow weights." | maxCapacity < maxTokensPerPlace = Just "The starting tokens can not exceed 'maxCapacity'." - | newFlowToComplement <= 0 + | newFlowWithComplement <= 0 = Just "At least one flow has to be connected to a complement place." - | newFlowToComplement > 2 * transitions - = Just "'newFlowToComplement' is set unreasonably high, given the number of transitions." + | newFlowWithComplement > 2 * transitions + = Just "'newFlowWithComplement' is set unreasonably high, given the number of transitions." | oneMinCapacity > maxCapacity = Just "'maxCapacity' has to be larger than 'oneMinCapacity'." | atLeastActive == 0 diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 71a87e8e6..ce6f51c57 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1056,7 +1056,7 @@ data CapacityConfig = CapacityConfig { basicConfig :: BasicConfig , advConfig :: AdvConfig , maxCapacity :: Int - , newFlowToComplement :: Int + , newFlowWithComplement :: Int , oneMinCapacity :: Int , graphConfig :: GraphConfig , printSolution :: Bool @@ -1069,7 +1069,7 @@ defaultCapacityConfig = CapacityConfig { basicConfig = defaultBasicConfig { places = 2, transitions = 2, atLeastActive = 1, maxTokensPerPlace = 4, tokensOverall = (2, 8)} , advConfig = defaultAdvConfig , maxCapacity = 4 - , newFlowToComplement = 4 + , newFlowWithComplement = 4 , oneMinCapacity = 2 , graphConfig = defaultGraphConfig { hidePlaceNames = False, hideTransitionNames = False } , printSolution = True From 4d9f2be5f708ab497665d81644c6599796c4cb97 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 4 Apr 2025 00:39:16 +0200 Subject: [PATCH 139/256] changed checkCapacityConfig --- src/Modelling/PetriNet/Capacity.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index ec542a1f7..31be9f66a 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -467,8 +467,10 @@ checkCapacityConfig BasicConfig { = Just "At least one flow has to be connected to a complement place." | newFlowWithComplement > 2 * transitions = Just "'newFlowWithComplement' is set unreasonably high, given the number of transitions." + | oneMinCapacity <= 0 + = Just "'oneMinCapacity' has to be positive." | oneMinCapacity > maxCapacity - = Just "'maxCapacity' has to be larger than 'oneMinCapacity'." + = Just "'oneMinCapacity' can not be higher than 'maxCapacity'." | atLeastActive == 0 = Just "At least one transition has to be activated." | otherwise From 8ddddb6aef69a369d28ce02642e6f45e8efdb487 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 4 Apr 2025 15:35:35 +0200 Subject: [PATCH 140/256] changed petriScopeBitWidth to get a [Int] instead of a BasicConfig --- src/Modelling/PetriNet/Capacity.hs | 13 +++---------- src/Modelling/PetriNet/Concurrency.hs | 3 ++- src/Modelling/PetriNet/Conflict.hs | 3 ++- src/Modelling/PetriNet/FindActivatedTransitions.hs | 3 ++- src/Modelling/PetriNet/MatchToMath.hs | 5 +++-- src/Modelling/PetriNet/PickMistake.hs | 3 ++- src/Modelling/PetriNet/Types.hs | 13 ++++++++----- test/Modelling/PetriNet/AlloySpec.hs | 2 +- 8 files changed, 23 insertions(+), 22 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 31be9f66a..92779fa95 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -89,7 +89,9 @@ import Modelling.PetriNet.Types ( PetriLike (PetriLike, allNodes), SimpleNode (..), CapacityNode (..), + basicCBitWidth, checkActivatedSourceConfig, + petriScopeBitWidth, ) import Control.Applicative ((<|>)) @@ -387,7 +389,7 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { } run #{capacityPredicateName} for exactly #{places basicC} givenPlaces, exactly #{places basicC} addedPlaces, -exactly #{transitions basicC} Transitions, #{petriScopeBitWidthCapacity basicC maxCapacity} Int +exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC ++ [maxCapacity])} Int |] where activated = skolemName @@ -424,15 +426,6 @@ activatedTransitions = skolemVariable capacityPredicateName skolemName skolemName :: String skolemName = "activatedTrans" -petriScopeBitWidthCapacity :: BasicConfig -> Int -> Int -petriScopeBitWidthCapacity BasicConfig - { flowOverall, places, tokensOverall, transitions } - maxCapacity = - floor - (2 + ((logBase :: Double -> Double -> Double ) 2.0 . fromIntegral) - (maximum [snd flowOverall, snd tokensOverall, places, transitions, maxCapacity]) - ) - checkCapacityConfigs :: CapacityConfig -> Maybe String checkCapacityConfigs CapacityConfig { basicConfig, diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index b9bf080f7..6916f240e 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -106,6 +106,7 @@ import Modelling.PetriNet.Types ( PickConcurrencyConfig (..), SimpleNode (..), SimplePetriNet, + basicCBitWidth, petriScopeBitWidth, transitionPairShow, ) @@ -434,7 +435,7 @@ pred #{concurrencyPredicateName}[#{skolemSets}#{t1}, #{t2} : Transitions] { #{compConstraints} } -run #{concurrencyPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int +run #{concurrencyPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC)} Int |] where activated = "activatedTrans" diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index 308e77a46..060d03fdc 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -123,6 +123,7 @@ import Modelling.PetriNet.Types ( PickConflictConfig (..), SimpleNode (..), SimplePetriNet, + basicCBitWidth, lConflictPlaces, petriScopeBitWidth, transitionPairShow, @@ -506,7 +507,7 @@ pred #{conflictPredicateName}[#{p} : some Places, #{skolemSets}#{t1}, #{t2} : Tr #{compConstraints} } -run #{conflictPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int +run #{conflictPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC)} Int |] where activated = "activatedTrans" diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 29f3c5949..d032ac4c0 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -83,6 +83,7 @@ import Modelling.PetriNet.Types ( PetriLike (PetriLike, allNodes), SimpleNode (..), SimplePetriNet, + basicCBitWidth, checkActivatedSourceConfig, petriScopeBitWidth, transitionListShow, @@ -316,7 +317,7 @@ pred #{activePredicateName}[#{activated} : set Transitions] { no t : givenTransitions | activatedDefault[t] } -run #{activePredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth basicC} Int +run #{activePredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC)} Int |] where activated = skolemName diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 2f16ce121..88e87e5ec 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -84,6 +84,7 @@ import Modelling.PetriNet.Types ( PetriNode (..), SimpleNode (..), SimplePetriLike, + basicCBitWidth, checkActivatedSourceConfig, checkBasicConfig, checkChangeConfig, @@ -560,7 +561,7 @@ pred showNets[#{skolemSet}] { #{compBasicConstraints True Nothing activated basicC} #{compAdvConstraints advConfig} } -run showNets for exactly #{places} Places, exactly #{transitions} Transitions, #{petriScopeBitWidth basicC} Int +run showNets for exactly #{places} Places, exactly #{transitions} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC)} Int |] where (skolemSet, activated) @@ -591,7 +592,7 @@ pred showFalseNets[#{skolemSet}]{ #{compChange changeConfig} } -run showFalseNets for exactly #{places basicConfig} Places, exactly #{transitions basicConfig} Transitions, #{petriScopeBitWidth basicConfig} Int +run showFalseNets for exactly #{places basicConfig} Places, exactly #{transitions basicConfig} Transitions, #{petriScopeBitWidth (basicCBitWidth basicConfig)} Int |] where allNodes = nodes net diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index 0ad8173d1..28f1dc98d 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -61,6 +61,7 @@ import Modelling.PetriNet.Types ( PickMistakeConfig (..), SimpleNode (..), SimplePetriNet, + basicCBitWidth, petriScopeBitWidth, ) @@ -213,7 +214,7 @@ pred #{mistakePredicateName} { #{prohibitSelfLoops mistakeC} } -run #{mistakePredicateName} for #{petriScopeBitWidth basicC} Int +run #{mistakePredicateName} for #{petriScopeBitWidth (basicCBitWidth basicC)} Int |] where sigs = signatures "given" (places basicC) (transitions basicC) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index ce6f51c57..f0379d1af 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -55,6 +55,7 @@ module Modelling.PetriNet.Types ( SimpleNode (..), SimplePetriLike, SimplePetriNet, + basicCBitWidth, checkActivatedSourceConfig, checkBasicConfig, checkChangeConfig, @@ -1127,14 +1128,16 @@ transitionPairShow = bimap ShowTransition ShowTransition transitionListShow :: [Petri.Transition] -> [ShowTransition] transitionListShow = map ShowTransition -petriScopeBitWidth :: BasicConfig -> Int -petriScopeBitWidth BasicConfig - { flowOverall, places, tokensOverall, transitions } = +petriScopeBitWidth :: [Int] -> Int +petriScopeBitWidth values = floor (2 + ((logBase :: Double -> Double -> Double) 2.0 . fromIntegral) - (maximum [snd flowOverall, snd tokensOverall, places, transitions]) + (maximum values) ) +basicCBitWidth :: BasicConfig -> [Int] +basicCBitWidth BasicConfig {places, transitions, flowOverall, tokensOverall} = [places, transitions, snd flowOverall, snd tokensOverall] + checkBasicConfig :: BasicConfig -> Maybe String checkBasicConfig basicC@BasicConfig{ atLeastActive, @@ -1179,7 +1182,7 @@ checkBasicConfig basicC@BasicConfig{ = Just "The maximum 'flowOverall' is set unreasonably high, given the other parameters." | transitions + places > 1 + fst flowOverall = Just "The number of transitions and places exceeds the minimum 'flowOverall' too much to create a connected net." - | Just maxValue <- maxBitWidth, petriScopeBitWidth basicC > maxValue + | Just maxValue <- maxBitWidth, petriScopeBitWidth (basicCBitWidth basicC) > maxValue = Just "'places', 'transitions' and the maximum 'flowOverall' and 'tokensOverall' should not be set too high." | otherwise = Nothing diff --git a/test/Modelling/PetriNet/AlloySpec.hs b/test/Modelling/PetriNet/AlloySpec.hs index 4a8e38de6..2c4b469b0 100644 --- a/test/Modelling/PetriNet/AlloySpec.hs +++ b/test/Modelling/PetriNet/AlloySpec.hs @@ -12,4 +12,4 @@ spec = do describe "petriScopeBitWidth" $ context "computes the needed bit width for generating Petri nets with Alloy" $ it "taking some values out of the user's input" $ - petriScopeBitWidth defaultBasicConfig `shouldSatisfy` (< 7) + petriScopeBitWidth (basicCBitWidth basicC) `shouldSatisfy` (< 7) From a772f2016cd8c3c672b7809f259ade887a84a40d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 4 Apr 2025 16:21:25 +0200 Subject: [PATCH 141/256] make it possible for capacity to also use compAdvConstraints --- src/Modelling/PetriNet/Alloy.hs | 14 +++++++----- src/Modelling/PetriNet/Capacity.hs | 22 ++----------------- src/Modelling/PetriNet/Concurrency.hs | 2 +- src/Modelling/PetriNet/Conflict.hs | 2 +- .../PetriNet/FindActivatedTransitions.hs | 2 +- src/Modelling/PetriNet/MatchToMath.hs | 4 ++-- 6 files changed, 15 insertions(+), 31 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index c2bf616e0..cdf92c187 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -162,11 +162,11 @@ connected p = maybe "" $ \c -> (if c then "" else "not ") ++ p isolated :: String -> Maybe Bool -> String isolated p = maybe p $ \c -> if c then "" else p -compAdvConstraints :: AdvConfig -> String +compAdvConstraints :: AdvConfig -> Bool -> String compAdvConstraints AdvConfig { presenceOfSelfLoops, presenceOfSinkTransitions , presenceOfSourceTransitions - } = [i| + } isCapacity = [i| #{maybe "" petriLoops presenceOfSelfLoops} #{maybe "" petriSink presenceOfSinkTransitions} #{maybe "" petriSource presenceOfSourceTransitions} @@ -176,11 +176,13 @@ compAdvConstraints AdvConfig True -> "some n : Nodes | selfLoop[n]" False -> "no n : Nodes | selfLoop[n]" petriSink = \case - True -> "some t : Transitions | sinkTransitions[t]" - False -> "no t : Transitions | sinkTransitions[t]" + True -> "some t : Transitions | sinkTransitions" ++ addCapacity ++ "[t]" + False -> "no t : Transitions | sinkTransitions" ++ addCapacity ++ "[t]" petriSource = \case - True -> "some t : Transitions | sourceTransitions[t]" - False -> "no t : Transitions | sourceTransitions[t]" + True -> "some t : Transitions | sourceTransitions" ++ addCapacity ++ "[t]" + False -> "no t : Transitions | sourceTransitions" ++ addCapacity ++ "[t]" + addCapacity :: String + addCapacity = if isCapacity then "Capacity" else "" compChange :: ChangeConfig -> String compChange ChangeConfig diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 92779fa95..5c1816359 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -50,6 +50,7 @@ import Modelling.Auxiliary.Output ( hoveringInformation, ) import Modelling.PetriNet.Alloy ( + compAdvConstraints, enforceConstraints, moduleHelpers, modulePetriAdditions, @@ -375,7 +376,7 @@ pred sinkTransitionsCapacity[ts : set Transitions] { pred #{capacityPredicateName}[#{activated} : set Transitions] { #{defaultConstraintsAtLeastZero activated basicC} - #{compAdvConstraintsCapacity advConfig} + #{compAdvConstraints advConfig True} all t : Transitions, p : givenPlaces | let n = minus[t.flow[p], p.flow[t]] | @@ -397,25 +398,6 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth defaultConstraintsAtLeastZero activated basicC = enforceConstraints True Nothing activated (basicC { atLeastActive = 0 }) ++ concat [ [i|\##{activated} >= #{atLeastActive basicC}|] | atLeastActive basicC > 0] - compAdvConstraintsCapacity :: AdvConfig -> String - compAdvConstraintsCapacity AdvConfig - { presenceOfSelfLoops, presenceOfSinkTransitions - , presenceOfSourceTransitions - } = [i| - #{maybe "" petriLoops presenceOfSelfLoops} - #{maybe "" petriSink presenceOfSinkTransitions} - #{maybe "" petriSource presenceOfSourceTransitions} - |] - where - petriLoops = \case - True -> "some n : Nodes | selfLoop[n]" - False -> "no n : Nodes | selfLoop[n]" - petriSink = \case - True -> "some t : Transitions | sinkTransitionsCapacity[t]" - False -> "no t : Transitions | sinkTransitionsCapacity[t]" - petriSource = \case - True -> "some t : Transitions | sourceTransitionsCapacity[t]" - False -> "no t : Transitions | sourceTransitionsCapacity[t]" capacityPredicateName :: String capacityPredicateName = "showCapacity" diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index 6916f240e..0b23694a5 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -442,7 +442,7 @@ run #{concurrencyPredicateName} for exactly #{places basicC} Places, exactly #{t activatedDefault = "defaultActiveTrans" compConstraints = either (const $ defaultConstraints activatedDefault basicC) - compAdvConstraints + (\advConfig -> compAdvConstraints advConfig False) specific sourceTransitionConstraints | Left True <- specific = [i| diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index 060d03fdc..a01171326 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -514,7 +514,7 @@ run #{conflictPredicateName} for exactly #{places basicC} Places, exactly #{tran activatedDefault = "defaultActiveTrans" compConstraints = either (const $ defaultConstraints activatedDefault basicC) - compAdvConstraints + (\advConfig -> compAdvConstraints advConfig False) specific sourceTransitionConstraints | Left True <- specific = [i| diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index d032ac4c0..f89cc3749 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -312,7 +312,7 @@ petriNetActivatedTransitionsAlloy basicC changeC atMost advConfig pred #{activePredicateName}[#{activated} : set Transitions] { #{compBasicConstraints True atMost activated basicC} #{compChange changeC} - #{compAdvConstraints advConfig} + #{compAdvConstraints advConfig False} #{activatedConstraint basicC atMost} no t : givenTransitions | activatedDefault[t] } diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 88e87e5ec..ff6f01b95 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -559,7 +559,7 @@ fact{ pred showNets[#{skolemSet}] { #{compBasicConstraints True Nothing activated basicC} - #{compAdvConstraints advConfig} + #{compAdvConstraints advConfig False} } run showNets for exactly #{places} Places, exactly #{transitions} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC)} Int |] @@ -588,7 +588,7 @@ fact{ pred showFalseNets[#{skolemSet}]{ #{compBasicConstraints True Nothing activated basicConfig} - #{compAdvConstraints advConfig} + #{compAdvConstraints advConfig False} #{compChange changeConfig} } From 312144735fdd8b4f323454c4832f5a9e41dfc628 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 6 Apr 2025 17:51:31 +0200 Subject: [PATCH 142/256] renamed functions/parameters in capacity --- src/Modelling/PetriNet/Alloy.hs | 12 ++++++------ src/Modelling/PetriNet/Types.hs | 8 ++++---- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index cdf92c187..776b6e2d6 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -176,13 +176,13 @@ compAdvConstraints AdvConfig True -> "some n : Nodes | selfLoop[n]" False -> "no n : Nodes | selfLoop[n]" petriSink = \case - True -> "some t : Transitions | sinkTransitions" ++ addCapacity ++ "[t]" - False -> "no t : Transitions | sinkTransitions" ++ addCapacity ++ "[t]" + True -> "some t : Transitions | sinkTransitions" ++ addDefault ++ "[t]" + False -> "no t : Transitions | sinkTransitions" ++ addDefault ++ "[t]" petriSource = \case - True -> "some t : Transitions | sourceTransitions" ++ addCapacity ++ "[t]" - False -> "no t : Transitions | sourceTransitions" ++ addCapacity ++ "[t]" - addCapacity :: String - addCapacity = if isCapacity then "Capacity" else "" + True -> "some t : Transitions | sourceTransitions" ++ addDefault ++ "[t]" + False -> "no t : Transitions | sourceTransitions" ++ addDefault ++ "[t]" + addDefault :: String + addDefault = if isCapacity then "Default" else "" compChange :: ChangeConfig -> String compChange ChangeConfig diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index f0379d1af..4c75af9af 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1057,8 +1057,8 @@ data CapacityConfig = CapacityConfig { basicConfig :: BasicConfig , advConfig :: AdvConfig , maxCapacity :: Int - , newFlowWithComplement :: Int - , oneMinCapacity :: Int + , minNewArrowsWithComplement :: Maybe Int + , oneMinCapacity :: Maybe Int , graphConfig :: GraphConfig , printSolution :: Bool , useDifferentGraphLayouts :: Bool @@ -1070,8 +1070,8 @@ defaultCapacityConfig = CapacityConfig { basicConfig = defaultBasicConfig { places = 2, transitions = 2, atLeastActive = 1, maxTokensPerPlace = 4, tokensOverall = (2, 8)} , advConfig = defaultAdvConfig , maxCapacity = 4 - , newFlowWithComplement = 4 - , oneMinCapacity = 2 + , minNewArrowsWithComplement = Just 2 + , oneMinCapacity = Just 2 , graphConfig = defaultGraphConfig { hidePlaceNames = False, hideTransitionNames = False } , printSolution = True , useDifferentGraphLayouts = False From bae0e22cdf9d896dc1f99ea15ebbc5345af21df3 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 6 Apr 2025 17:57:12 +0200 Subject: [PATCH 143/256] changed checks because of new Maybe Int --- src/Modelling/PetriNet/Capacity.hs | 47 ++++++++++++++++++++---------- 1 file changed, 31 insertions(+), 16 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 5c1816359..5f13e7d4f 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -307,23 +307,31 @@ petriNetFindCapacity :: CapacityConfig -> String petriNetFindCapacity CapacityConfig { basicConfig, advConfig, - maxCapacity + maxCapacity, + minNewArrowsWithComplement, + oneMinCapacity } = petriNetFindCapacityAlloy basicConfig advConfig maxCapacity + minNewArrowsWithComplement + oneMinCapacity petriNetPickCapacity :: CapacityConfig -> String petriNetPickCapacity CapacityConfig{ basicConfig, advConfig, - maxCapacity + maxCapacity, + minNewArrowsWithComplement, + oneMinCapacity } = petriNetFindCapacityAlloy basicConfig advConfig maxCapacity + minNewArrowsWithComplement + oneMinCapacity parseCapacity :: MonadThrow m => AlloyInstance -> m (ActivatedTransitions Object) parseCapacity inst = do @@ -334,8 +342,10 @@ petriNetFindCapacityAlloy :: BasicConfig -> AdvConfig -> Int + -> Maybe Int + -> Maybe Int -> String -petriNetFindCapacityAlloy basicC advConfig maxCapacity +petriNetFindCapacityAlloy basicC advConfig maxCapacity minNewArrowsWithComplement oneMinCapacity = [i|module PetriNetCapacity #{modulePetriSignature} @@ -413,7 +423,7 @@ checkCapacityConfigs CapacityConfig { basicConfig, advConfig, maxCapacity, - newFlowWithComplement, + minNewArrowsWithComplement, oneMinCapacity, graphConfig } @@ -422,34 +432,39 @@ checkCapacityConfigs CapacityConfig { <|> checkBasicConfig basicConfig <|> prohibitPatchworkRenderer graphConfig <|> checkActivatedSourceConfig basicConfig advConfig - <|> checkCapacityConfig basicConfig maxCapacity newFlowWithComplement oneMinCapacity + <|> checkCapacityConfig basicConfig maxCapacity minNewArrowsWithComplement oneMinCapacity -checkCapacityConfig :: BasicConfig -> Int -> Int -> Int -> Maybe String +checkCapacityConfig :: BasicConfig -> Int -> Maybe Int -> Maybe Int -> Maybe String checkCapacityConfig BasicConfig { + places, transitions, atLeastActive, maxTokensPerPlace, maxFlowPerEdge } maxCapacity - newFlowWithComplement + minNewArrowsWithComplement oneMinCapacity | maxCapacity < maxFlowPerEdge = Just "'maxCapacity' can not be too low for flow weights." | maxCapacity < maxTokensPerPlace = Just "The starting tokens can not exceed 'maxCapacity'." - | newFlowWithComplement <= 0 - = Just "At least one flow has to be connected to a complement place." - | newFlowWithComplement > 2 * transitions - = Just "'newFlowWithComplement' is set unreasonably high, given the number of transitions." - | oneMinCapacity <= 0 - = Just "'oneMinCapacity' has to be positive." - | oneMinCapacity > maxCapacity - = Just "'oneMinCapacity' can not be higher than 'maxCapacity'." | atLeastActive == 0 = Just "At least one transition has to be activated." | otherwise - = Nothing + = case minNewArrowsWithComplement of + Just minNew + | minNew <= 0 + -> Just "At least one flow has to be connected to a complement place." + | minNew > 2 * transitions * places + -> Just "'minNewArrowsWithComplement' is set unreasonably high, given the number of transitions." + _ -> case oneMinCapacity of + Just oneMin + | oneMin <= 0 + -> Just "'oneMinCapacity' has to be positive." + | oneMin > maxCapacity + -> Just "'oneMinCapacity' can not be higher than 'maxCapacity'." + _ -> Nothing defaultCapacityInstance :: CapacityInstance defaultCapacityInstance = CapacityInstance { From 8c52999fb9ba26009005acd7dbcfc3f50779736b Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 6 Apr 2025 17:58:18 +0200 Subject: [PATCH 144/256] new alloy functions for sink/source transitions --- src/Modelling/PetriNet/Capacity.hs | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 5f13e7d4f..eb9229b7e 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -370,18 +370,12 @@ fact { no addedTransitions } -pred sourceTransitionsCapacity[ts : set Transitions] { - no Nodes.flow[ts] - all p : placesWithCapacity | - let flows = p.flow[ts] | - flows + p.tokens <= p.capacity +pred sinkTransitionsDefault[ts : set Transitions]{ + no ts.defaultFlow } -pred sinkTransitionsCapacity[ts : set Transitions] { - no ts.flow - all p : placesWithCapacity | - let flows = p.flow[ts] | - flows - p.tokens <= p.capacity +pred sourceTransitionsDefault[ts : set Transitions]{ + no Nodes.defaultFlow[ts] } pred #{capacityPredicateName}[#{activated} : set Transitions] { From bc89a249cf4f918aaa01a00d5fcfe6fd69c5cd5a Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 6 Apr 2025 18:00:53 +0200 Subject: [PATCH 145/256] implemented capacityConfig parameters into alloy-code --- src/Modelling/PetriNet/Capacity.hs | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index eb9229b7e..d6557e833 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -391,6 +391,9 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { no p.complement.flow[t] and no t.flow[p.complement] all p : placesWithCapacity, w : p.flow[Transitions] + Transitions.flow[p] | p.capacity >= w + #{minNewArrowsWithComplementConstraints minNewArrowsWithComplement} + #{oneMinCapacityConstraints oneMinCapacity} + } run #{capacityPredicateName} for exactly #{places basicC} givenPlaces, exactly #{places basicC} addedPlaces, @@ -398,10 +401,20 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth |] where activated = skolemName - defaultConstraintsAtLeastZero :: String -> BasicConfig -> String - defaultConstraintsAtLeastZero activated basicC = - enforceConstraints True Nothing activated (basicC { atLeastActive = 0 }) ++ - concat [ [i|\##{activated} >= #{atLeastActive basicC}|] | atLeastActive basicC > 0] + minNewArrowsWithComplementConstraints :: Maybe Int -> String + minNewArrowsWithComplementConstraints minNewArrows = + case minNewArrows of + Just minNew -> + "let totalFlow = " ++ + "#({p: placesWithCapacity | some p.complement.flow[Transitions]}.complement.flow[Transitions]) + " ++ + "#(Transitions.flow[{p: placesWithCapacity | some Transitions.flow[p.complement]}.complement]) | " ++ + "totalFlow >= " ++ show minNew + Nothing -> "" + oneMinCapacityConstraints :: Maybe Int -> String + oneMinCapacityConstraints oneMinCap = + case oneMinCap of + Just oneMin -> [i|some p : placesWithCapacity | p.capacity >= #{oneMin}|] + Nothing -> "" capacityPredicateName :: String capacityPredicateName = "showCapacity" From 98a1f6ed199d5c3abd4203c8e940099f42d07587 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 6 Apr 2025 22:45:53 +0200 Subject: [PATCH 146/256] updated app because of changes --- app/capacity.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/app/capacity.hs b/app/capacity.hs index 7531551a2..5001803a9 100644 --- a/app/capacity.hs +++ b/app/capacity.hs @@ -52,7 +52,7 @@ mainFind i = forceErrors $ do transitions = trns }, maxCapacity = maxCap, - newFlowWithComplement = newFlow, + minNewArrowsWithComplement = newFlow, oneMinCapacity = oneMin } :: CapacityConfig let c = checkCapacityConfigs config @@ -74,11 +74,11 @@ validateInput d = do putStrLn "Invalid input" validateInput d -userInput :: CapacityConfig -> IO (Int, Int, Int, Int, Int) +userInput :: CapacityConfig -> IO (Int, Int, Int, Maybe Int, Maybe Int) userInput CapacityConfig{ basicConfig = BasicConfig{..}, maxCapacity = maxCapacity, - newFlowWithComplement = newFlowWithComplement, + minNewArrowsWithComplement = minNewArrowsWithComplement, oneMinCapacity = oneMinCapacity } = do putStr "Number of Places: " @@ -87,8 +87,8 @@ userInput CapacityConfig{ trns <- validateInput transitions putStr "Highest capacity for a place: " maxCap <- validateInput maxCapacity - putStr "How many new flows are connected to complement places: " - newFlow <- validateInput newFlowWithComplement - putStr "What capacity should one place have: " + putStr "How many new flows are at minimum connected to complement places: " + newFlow <- validateInput minNewArrowsWithComplement + putStr "What capacity should one place at least have: " oneMin <- validateInput oneMinCapacity return (pls, trns, maxCap, newFlow, oneMin) From 60f3d7e800da3f2717a06b27115d9cc245cea2b8 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 6 Apr 2025 23:32:37 +0200 Subject: [PATCH 147/256] fixed hlint --- src/Modelling/PetriNet/Concurrency.hs | 2 +- src/Modelling/PetriNet/Conflict.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index 0b23694a5..7be0836d0 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -442,7 +442,7 @@ run #{concurrencyPredicateName} for exactly #{places basicC} Places, exactly #{t activatedDefault = "defaultActiveTrans" compConstraints = either (const $ defaultConstraints activatedDefault basicC) - (\advConfig -> compAdvConstraints advConfig False) + (`compAdvConstraints` False) specific sourceTransitionConstraints | Left True <- specific = [i| diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index a01171326..c3eb6e445 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -514,7 +514,7 @@ run #{conflictPredicateName} for exactly #{places basicC} Places, exactly #{tran activatedDefault = "defaultActiveTrans" compConstraints = either (const $ defaultConstraints activatedDefault basicC) - (\advConfig -> compAdvConstraints advConfig False) + (`compAdvConstraints` False) specific sourceTransitionConstraints | Left True <- specific = [i| From 4492f6590953dcd2d72be8521e457d8f2f589114 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 7 Apr 2025 00:00:08 +0200 Subject: [PATCH 148/256] fixed spelling --- src/Modelling/PetriNet/Capacity.hs | 4 ++-- src/Modelling/PetriNet/Concurrency.hs | 4 ++-- src/Modelling/PetriNet/Conflict.hs | 4 ++-- src/Modelling/PetriNet/FindActivatedTransitions.hs | 4 ++-- src/Modelling/PetriNet/MatchToMath.hs | 6 +++--- src/Modelling/PetriNet/PickMistake.hs | 4 ++-- src/Modelling/PetriNet/Types.hs | 8 ++++---- test/Modelling/PetriNet/AlloySpec.hs | 2 +- 8 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index d6557e833..743b11821 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -90,7 +90,7 @@ import Modelling.PetriNet.Types ( PetriLike (PetriLike, allNodes), SimpleNode (..), CapacityNode (..), - basicCBitWidth, + basicConfigBitWidthInput, checkActivatedSourceConfig, petriScopeBitWidth, ) @@ -397,7 +397,7 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { } run #{capacityPredicateName} for exactly #{places basicC} givenPlaces, exactly #{places basicC} addedPlaces, -exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC ++ [maxCapacity])} Int +exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC ++ [maxCapacity])} Int |] where activated = skolemName diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index 7be0836d0..4b5f3a2cc 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -106,7 +106,7 @@ import Modelling.PetriNet.Types ( PickConcurrencyConfig (..), SimpleNode (..), SimplePetriNet, - basicCBitWidth, + basicConfigBitWidthInput, petriScopeBitWidth, transitionPairShow, ) @@ -435,7 +435,7 @@ pred #{concurrencyPredicateName}[#{skolemSets}#{t1}, #{t2} : Transitions] { #{compConstraints} } -run #{concurrencyPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC)} Int +run #{concurrencyPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC)} Int |] where activated = "activatedTrans" diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index c3eb6e445..b71472fb0 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -123,7 +123,7 @@ import Modelling.PetriNet.Types ( PickConflictConfig (..), SimpleNode (..), SimplePetriNet, - basicCBitWidth, + basicConfigBitWidthInput, lConflictPlaces, petriScopeBitWidth, transitionPairShow, @@ -507,7 +507,7 @@ pred #{conflictPredicateName}[#{p} : some Places, #{skolemSets}#{t1}, #{t2} : Tr #{compConstraints} } -run #{conflictPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC)} Int +run #{conflictPredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC)} Int |] where activated = "activatedTrans" diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index f89cc3749..72eed3d56 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -83,7 +83,7 @@ import Modelling.PetriNet.Types ( PetriLike (PetriLike, allNodes), SimpleNode (..), SimplePetriNet, - basicCBitWidth, + basicConfigBitWidthInput, checkActivatedSourceConfig, petriScopeBitWidth, transitionListShow, @@ -317,7 +317,7 @@ pred #{activePredicateName}[#{activated} : set Transitions] { no t : givenTransitions | activatedDefault[t] } -run #{activePredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC)} Int +run #{activePredicateName} for exactly #{places basicC} Places, exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC)} Int |] where activated = skolemName diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index ff6f01b95..fbe656c5d 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -84,7 +84,7 @@ import Modelling.PetriNet.Types ( PetriNode (..), SimpleNode (..), SimplePetriLike, - basicCBitWidth, + basicConfigBitWidthInput, checkActivatedSourceConfig, checkBasicConfig, checkChangeConfig, @@ -561,7 +561,7 @@ pred showNets[#{skolemSet}] { #{compBasicConstraints True Nothing activated basicC} #{compAdvConstraints advConfig False} } -run showNets for exactly #{places} Places, exactly #{transitions} Transitions, #{petriScopeBitWidth (basicCBitWidth basicC)} Int +run showNets for exactly #{places} Places, exactly #{transitions} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC)} Int |] where (skolemSet, activated) @@ -592,7 +592,7 @@ pred showFalseNets[#{skolemSet}]{ #{compChange changeConfig} } -run showFalseNets for exactly #{places basicConfig} Places, exactly #{transitions basicConfig} Transitions, #{petriScopeBitWidth (basicCBitWidth basicConfig)} Int +run showFalseNets for exactly #{places basicConfig} Places, exactly #{transitions basicConfig} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicConfig)} Int |] where allNodes = nodes net diff --git a/src/Modelling/PetriNet/PickMistake.hs b/src/Modelling/PetriNet/PickMistake.hs index 28f1dc98d..37e30acaa 100644 --- a/src/Modelling/PetriNet/PickMistake.hs +++ b/src/Modelling/PetriNet/PickMistake.hs @@ -61,7 +61,7 @@ import Modelling.PetriNet.Types ( PickMistakeConfig (..), SimpleNode (..), SimplePetriNet, - basicCBitWidth, + basicConfigBitWidthInput, petriScopeBitWidth, ) @@ -214,7 +214,7 @@ pred #{mistakePredicateName} { #{prohibitSelfLoops mistakeC} } -run #{mistakePredicateName} for #{petriScopeBitWidth (basicCBitWidth basicC)} Int +run #{mistakePredicateName} for #{petriScopeBitWidth (basicConfigBitWidthInput basicC)} Int |] where sigs = signatures "given" (places basicC) (transitions basicC) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 4c75af9af..56c8d6895 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -55,7 +55,7 @@ module Modelling.PetriNet.Types ( SimpleNode (..), SimplePetriLike, SimplePetriNet, - basicCBitWidth, + basicConfigBitWidthInput, checkActivatedSourceConfig, checkBasicConfig, checkChangeConfig, @@ -1135,8 +1135,8 @@ petriScopeBitWidth values = (maximum values) ) -basicCBitWidth :: BasicConfig -> [Int] -basicCBitWidth BasicConfig {places, transitions, flowOverall, tokensOverall} = [places, transitions, snd flowOverall, snd tokensOverall] +basicConfigBitWidthInput :: BasicConfig -> [Int] +basicConfigBitWidthInput BasicConfig {places, transitions, flowOverall, tokensOverall} = [places, transitions, snd flowOverall, snd tokensOverall] checkBasicConfig :: BasicConfig -> Maybe String checkBasicConfig basicC@BasicConfig{ @@ -1182,7 +1182,7 @@ checkBasicConfig basicC@BasicConfig{ = Just "The maximum 'flowOverall' is set unreasonably high, given the other parameters." | transitions + places > 1 + fst flowOverall = Just "The number of transitions and places exceeds the minimum 'flowOverall' too much to create a connected net." - | Just maxValue <- maxBitWidth, petriScopeBitWidth (basicCBitWidth basicC) > maxValue + | Just maxValue <- maxBitWidth, petriScopeBitWidth (basicConfigBitWidthInput basicC) > maxValue = Just "'places', 'transitions' and the maximum 'flowOverall' and 'tokensOverall' should not be set too high." | otherwise = Nothing diff --git a/test/Modelling/PetriNet/AlloySpec.hs b/test/Modelling/PetriNet/AlloySpec.hs index 2c4b469b0..6978e9d4b 100644 --- a/test/Modelling/PetriNet/AlloySpec.hs +++ b/test/Modelling/PetriNet/AlloySpec.hs @@ -12,4 +12,4 @@ spec = do describe "petriScopeBitWidth" $ context "computes the needed bit width for generating Petri nets with Alloy" $ it "taking some values out of the user's input" $ - petriScopeBitWidth (basicCBitWidth basicC) `shouldSatisfy` (< 7) + petriScopeBitWidth (basicConfigBitWidthInput basicC) `shouldSatisfy` (< 7) From b277d755a453aef7c182a5450966445cb429625a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 7 Apr 2025 22:23:44 +0200 Subject: [PATCH 149/256] =?UTF-8?q?Alloy-Expression=20f=C3=BCr=20minNewArr?= =?UTF-8?q?owsWithComplement?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Modelling/PetriNet/Capacity.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 743b11821..145d227ba 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -389,6 +389,7 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { n > 0 implies (p.complement.flow[t] = n and no t.flow[p.complement]) else no p.complement.flow[t] and no t.flow[p.complement] + all p : placesWithCapacity, w : p.flow[Transitions] + Transitions.flow[p] | p.capacity >= w #{minNewArrowsWithComplementConstraints minNewArrowsWithComplement} @@ -405,10 +406,9 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW minNewArrowsWithComplementConstraints minNewArrows = case minNewArrows of Just minNew -> - "let totalFlow = " ++ - "#({p: placesWithCapacity | some p.complement.flow[Transitions]}.complement.flow[Transitions]) + " ++ - "#(Transitions.flow[{p: placesWithCapacity | some Transitions.flow[p.complement]}.complement]) | " ++ - "totalFlow >= " ++ show minNew + "let newArrows = " ++ + "plus[#(addedPlaces <: flowChange), #(flowChange.Int :> addedPlaces)] | " ++ + "newArrows >= " ++ show minNew Nothing -> "" oneMinCapacityConstraints :: Maybe Int -> String oneMinCapacityConstraints oneMinCap = From c571423950be4f523b508f4fcb79a3be562133a9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 7 Apr 2025 22:32:41 +0200 Subject: [PATCH 150/256] even much simpler --- src/Modelling/PetriNet/Capacity.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 145d227ba..944feba3d 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -406,9 +406,7 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW minNewArrowsWithComplementConstraints minNewArrows = case minNewArrows of Just minNew -> - "let newArrows = " ++ - "plus[#(addedPlaces <: flowChange), #(flowChange.Int :> addedPlaces)] | " ++ - "newArrows >= " ++ show minNew + "#flowChange >= " ++ show minNew Nothing -> "" oneMinCapacityConstraints :: Maybe Int -> String oneMinCapacityConstraints oneMinCap = From 90f079f2c53ddaebfe775cad0e6a2fc735364743 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 7 Apr 2025 23:15:12 +0200 Subject: [PATCH 151/256] move alloy predicates to PetriConcepts --- alloy/petri/PetriConcepts.als | 10 ++++++++++ src/Modelling/PetriNet/Capacity.hs | 8 -------- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/alloy/petri/PetriConcepts.als b/alloy/petri/PetriConcepts.als index be9486c2a..340a2b07f 100644 --- a/alloy/petri/PetriConcepts.als +++ b/alloy/petri/PetriConcepts.als @@ -53,3 +53,13 @@ pred sinkTransitions[ts : set Transitions]{ pred sourceTransitions[ts : set Transitions]{ no Nodes.flow[ts] // under assumption of valid Petri nets, could use Places instead of Nodes here } + +//check if some transitions are sink transitions under default condition +pred sinkTransitionsDefault[ts : set givenTransitions]{ + no ts.defaultFlow +} + +//check if some transitions are sink transitions under default condition +pred sourceTransitionsDefault[ts : set givenTransitions]{ + no givenNodes.defaultFlow[ts] +} diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 944feba3d..8fd0e362f 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -370,14 +370,6 @@ fact { no addedTransitions } -pred sinkTransitionsDefault[ts : set Transitions]{ - no ts.defaultFlow -} - -pred sourceTransitionsDefault[ts : set Transitions]{ - no Nodes.defaultFlow[ts] -} - pred #{capacityPredicateName}[#{activated} : set Transitions] { #{defaultConstraintsAtLeastZero activated basicC} #{compAdvConstraints advConfig True} From 8ebeea97f9d31ed95314e14c9d57a4dd16aa72ea Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 7 Apr 2025 23:16:18 +0200 Subject: [PATCH 152/256] changed order of input and aaded strings --- src/Modelling/PetriNet/Alloy.hs | 22 +++++++++---------- src/Modelling/PetriNet/Concurrency.hs | 2 +- src/Modelling/PetriNet/Conflict.hs | 2 +- .../PetriNet/FindActivatedTransitions.hs | 2 +- src/Modelling/PetriNet/MatchToMath.hs | 4 ++-- 5 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 776b6e2d6..e13f27c42 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -162,27 +162,27 @@ connected p = maybe "" $ \c -> (if c then "" else "not ") ++ p isolated :: String -> Maybe Bool -> String isolated p = maybe p $ \c -> if c then "" else p -compAdvConstraints :: AdvConfig -> Bool -> String -compAdvConstraints AdvConfig +compAdvConstraints :: Bool -> AdvConfig -> String +compAdvConstraints underDefault AdvConfig { presenceOfSelfLoops, presenceOfSinkTransitions , presenceOfSourceTransitions - } isCapacity = [i| + } = [i| #{maybe "" petriLoops presenceOfSelfLoops} #{maybe "" petriSink presenceOfSinkTransitions} #{maybe "" petriSource presenceOfSourceTransitions} |] where petriLoops = \case - True -> "some n : Nodes | selfLoop[n]" - False -> "no n : Nodes | selfLoop[n]" + True -> "some n :" ++ addGiven ++ "Nodes | selfLoop[n]" + False -> "no n :" ++ addGiven ++ "Nodes | selfLoop[n]" petriSink = \case - True -> "some t : Transitions | sinkTransitions" ++ addDefault ++ "[t]" - False -> "no t : Transitions | sinkTransitions" ++ addDefault ++ "[t]" + True -> "some t :" ++ addGiven ++ "Transitions | sinkTransitions" ++ addDefault ++ "[t]" + False -> "no t :" ++ addGiven ++ "Transitions | sinkTransitions" ++ addDefault ++ "[t]" petriSource = \case - True -> "some t : Transitions | sourceTransitions" ++ addDefault ++ "[t]" - False -> "no t : Transitions | sourceTransitions" ++ addDefault ++ "[t]" - addDefault :: String - addDefault = if isCapacity then "Default" else "" + True -> "some t :" ++ addGiven ++ "Transitions | sourceTransitions" ++ addDefault ++ "[t]" + False -> "no t :" ++ addGiven ++ "Transitions | sourceTransitions" ++ addDefault ++ "[t]" + addDefault = if underDefault then "Default" else "" + addGiven = if underDefault then "given" else "" compChange :: ChangeConfig -> String compChange ChangeConfig diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index 4b5f3a2cc..a3cce9130 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -442,7 +442,7 @@ run #{concurrencyPredicateName} for exactly #{places basicC} Places, exactly #{t activatedDefault = "defaultActiveTrans" compConstraints = either (const $ defaultConstraints activatedDefault basicC) - (`compAdvConstraints` False) + (compAdvConstraints False) specific sourceTransitionConstraints | Left True <- specific = [i| diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index b71472fb0..752f07f5a 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -514,7 +514,7 @@ run #{conflictPredicateName} for exactly #{places basicC} Places, exactly #{tran activatedDefault = "defaultActiveTrans" compConstraints = either (const $ defaultConstraints activatedDefault basicC) - (`compAdvConstraints` False) + (compAdvConstraints False) specific sourceTransitionConstraints | Left True <- specific = [i| diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 72eed3d56..6801b8819 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -312,7 +312,7 @@ petriNetActivatedTransitionsAlloy basicC changeC atMost advConfig pred #{activePredicateName}[#{activated} : set Transitions] { #{compBasicConstraints True atMost activated basicC} #{compChange changeC} - #{compAdvConstraints advConfig False} + #{compAdvConstraints False advConfig} #{activatedConstraint basicC atMost} no t : givenTransitions | activatedDefault[t] } diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index fbe656c5d..d69495082 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -559,7 +559,7 @@ fact{ pred showNets[#{skolemSet}] { #{compBasicConstraints True Nothing activated basicC} - #{compAdvConstraints advConfig False} + #{compAdvConstraints False advConfig} } run showNets for exactly #{places} Places, exactly #{transitions} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC)} Int |] @@ -588,7 +588,7 @@ fact{ pred showFalseNets[#{skolemSet}]{ #{compBasicConstraints True Nothing activated basicConfig} - #{compAdvConstraints advConfig False} + #{compAdvConstraints False advConfig} #{compChange changeConfig} } From fc297d0fb19913ee18f1e06309d8bb8a424b48aa Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 7 Apr 2025 23:16:35 +0200 Subject: [PATCH 153/256] fixed error when testing --- test/Modelling/PetriNet/AlloySpec.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/Modelling/PetriNet/AlloySpec.hs b/test/Modelling/PetriNet/AlloySpec.hs index 6978e9d4b..322df0919 100644 --- a/test/Modelling/PetriNet/AlloySpec.hs +++ b/test/Modelling/PetriNet/AlloySpec.hs @@ -1,6 +1,7 @@ module Modelling.PetriNet.AlloySpec where import Modelling.PetriNet.Types ( + basicConfigBitWidthInput, defaultBasicConfig, petriScopeBitWidth, ) @@ -12,4 +13,4 @@ spec = do describe "petriScopeBitWidth" $ context "computes the needed bit width for generating Petri nets with Alloy" $ it "taking some values out of the user's input" $ - petriScopeBitWidth (basicConfigBitWidthInput basicC) `shouldSatisfy` (< 7) + petriScopeBitWidth (basicConfigBitWidthInput defaultBasicConfig) `shouldSatisfy` (< 7) From 054d47f45c0e46dce40a904aaf78020c706a569b Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 7 Apr 2025 23:20:12 +0200 Subject: [PATCH 154/256] added new Capacity type --- src/Modelling/PetriNet/Capacity.hs | 15 ++++++++++++--- src/Modelling/PetriNet/Types.hs | 8 ++++++-- 2 files changed, 18 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 8fd0e362f..12948d3fd 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -22,6 +22,10 @@ module Modelling.PetriNet.Capacity ( simpleCapacityTask, ) where +import qualified Modelling.PetriNet.Reach.Type as Reach ( + Place(..), + Transition(..), + ) import qualified Modelling.PetriNet.Types as Find ( AlloyConfig (maxInstances, timeout), CapacityConfig (..), @@ -29,6 +33,9 @@ import qualified Modelling.PetriNet.Types as Find ( import qualified Modelling.PetriNet.Types as Pick ( CapacityConfig (..), ) +import qualified Modelling.PetriNet.Types as Types ( + NodeC(..) + ) import qualified Data.Map as M ( empty, fromList, @@ -84,9 +91,11 @@ import Modelling.PetriNet.Types ( AdvConfig (..), AlloyConfig (..), BasicConfig (..), + Capacity (..), CapacityConfig (..), DrawSettings (..), GraphConfig (..), + NodeC (..), PetriLike (PetriLike, allNodes), SimpleNode (..), CapacityNode (..), @@ -241,7 +250,7 @@ capacitySyntax task input = do let t' = show $ ShowTransition t english $ t' ++ " is a transition of the given Petri net?" german $ t' ++ " ist eine Transition des gegebenen Petrinetzes?" - isValidTransition (Transition x) = x >= 1 && x <= numberOfTransitions task + isValidTransition (Reach.Transition x) = x >= 1 && x <= numberOfTransitions task capacityEvaluation :: (Monad m, OutputCapable m) @@ -372,7 +381,7 @@ fact { pred #{capacityPredicateName}[#{activated} : set Transitions] { #{defaultConstraintsAtLeastZero activated basicC} - #{compAdvConstraints advConfig True} + #{compAdvConstraints True advConfig} all t : Transitions, p : givenPlaces | let n = minus[t.flow[p], p.flow[t]] | @@ -472,7 +481,7 @@ defaultCapacityInstance = CapacityInstance { with1Weights = False, withGraphvizCommand = Circo }, - toFind = ActivatedTransitions [Transition 1, Transition 2], + toFind = ActivatedTransitions [Reach.Transition 1, Reach.Transition 2], originalNet = PetriLike { allNodes = M.fromList [ ("s1",CapacityPlace {initial = 0, capacity = 0, flowIn = M.empty, flowOut = M.empty}), diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 56c8d6895..8862e08f9 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -41,6 +41,7 @@ module Modelling.PetriNet.Types ( MistakeConfig (..), Net (..), Node (..), + NodeC (..), Petri (..), PetriChange (..), PetriConflict (..), @@ -246,8 +247,11 @@ newtype Concurrent a = Concurrent (a, a) newtype ActivatedTransitions a = ActivatedTransitions [a] deriving (Functor, Foldable, Traversable, Generic, Read, Show) -newtype Capacity a b = Capacity ([(Place, String, Int)], [(a, b, Int)]) - deriving (Functor, Foldable, Traversable, Generic, Read, Show) +data NodeC = Place String | Transition String + deriving (Eq, Ord, Read, Show, Generic) + +newtype Capacity = Capacity ([(Place, Int)], [(NodeC, NodeC, Int)]) + deriving (Generic, Read, Show) class Show (n String) => PetriNode n where initialTokens :: n a -> Int From 14b5c25f6b7e221fe6f8a482ad1c295375f8e543 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 7 Apr 2025 23:22:04 +0200 Subject: [PATCH 155/256] added parseCapacityPrec to parse the input --- src/Modelling/PetriNet/Capacity.hs | 77 +++++++++++++++++++++++++++++- 1 file changed, 76 insertions(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 12948d3fd..4d80ef0e5 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -18,6 +18,7 @@ module Modelling.PetriNet.Capacity ( petriNetFindCapacity, petriNetPickCapacity, parseCapacity, + parseCapacityPrec, pickCapacity, simpleCapacityTask, ) where @@ -83,7 +84,8 @@ import Modelling.PetriNet.Find ( ) import Modelling.PetriNet.Reach.Type ( ShowTransition (ShowTransition), - Transition (Transition), + Transition, + parsePlacePrec, parseTransitionPrec, ) import Modelling.PetriNet.Types ( @@ -105,6 +107,7 @@ import Modelling.PetriNet.Types ( ) import Control.Applicative ((<|>)) +import Control.Monad (void) import Control.Monad.Catch (MonadThrow) import Control.OutputCapable.Blocks ( ArticleToUse (DefiniteArticle), @@ -137,6 +140,15 @@ import Language.Alloy.Call ( ) import GHC.Generics (Generic) +import Text.Parsec ( + char, + optionMaybe, + sepBy, + spaces, + ) +import Text.Parsec.Char (digit) +import Text.Parsec.Combinator (many1) +import Text.Parsec.String (Parser) data CapacityInstance = CapacityInstance { @@ -347,6 +359,69 @@ parseCapacity inst = do t <- unscopedSingleSig inst activatedTransitions "" pure $ ActivatedTransitions (Set.toList t) +parseCapacityPrec :: Int -> Parser Capacity +parseCapacityPrec _ = do + spaces + void $ char '(' + spaces + places <- parsePlacesWithInts + spaces + void $ char ',' + spaces + flows <- parseFlowTriples + spaces + void $ char ')' + return (Capacity (places, flows)) + where + parsePlacesWithInts = + char '[' *> parsePlaceWithInt `sepBy` (spaces *> char ',' <* spaces) <* char ']' + + parsePlaceWithInt = do + spaces + void $ char '(' + spaces + p <- parsePlacePrec 0 + spaces + void $ char ',' + spaces + n <- parseInt + spaces + void $ char ')' + return (p, n) + + parseFlowTriples = + char '[' *> parseFlowTriple `sepBy` (spaces *> char ',' <* spaces) <* char ']' + + parseFlowTriple = do + spaces + void $ char '(' + spaces + a <- parseNodeC + spaces + void $ char ',' + spaces + b <- parseNodeC + spaces + void $ char ',' + spaces + n <- parseInt + spaces + void $ char ')' + return (a, b, n) + + parseInt = read <$> many1 digit + + parseNodeC :: Parser NodeC + parseNodeC = do + tag <- optionMaybe (char 'p') + case tag of + Just _ -> do + Reach.Place n <- parsePlacePrec 0 + return $ Types.Place (show n) + Nothing -> do + Reach.Transition n <- parseTransitionPrec 0 + return $ Types.Transition (show n) + petriNetFindCapacityAlloy :: BasicConfig -> AdvConfig From 4494bd0c4d69cd4f0b439ac8ba37267b5df38e0f Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 7 Apr 2025 23:23:21 +0200 Subject: [PATCH 156/256] added back defaultConstraints for capacity --- src/Modelling/PetriNet/Capacity.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 4d80ef0e5..ab8cca505 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -138,8 +138,6 @@ import Data.String.Interpolate (i, iii) import Language.Alloy.Call ( AlloyInstance ) - -import GHC.Generics (Generic) import Text.Parsec ( char, optionMaybe, @@ -160,7 +158,7 @@ data CapacityInstance = CapacityInstance { numberOfTransitions :: !Int, showSolution :: !Bool } - deriving (Generic, Read, Show) + deriving (Read, Show) capacityGenerate :: (MonadAlloy m, MonadThrow m) @@ -478,6 +476,13 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW |] where activated = skolemName + defaultConstraintsAtLeastZero :: String -> BasicConfig -> String + defaultConstraintsAtLeastZero activatedT basicConfig@BasicConfig { atLeastActive } = + enforceConstraints True Nothing activatedT (basicConfig { atLeastActive = 0 }) + ++ + "#" ++ activatedT ++ " >= " ++ show atLeastActive ++ "\n" + ++ + " theActivatedTransitions[" ++ activatedT ++ "]" minNewArrowsWithComplementConstraints :: Maybe Int -> String minNewArrowsWithComplementConstraints minNewArrows = case minNewArrows of From 18a4cb787aad61f3f4cd33bfdefccccb23444b96 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 7 Apr 2025 23:26:34 +0200 Subject: [PATCH 157/256] missing space in alloy-code --- src/Modelling/PetriNet/Alloy.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index e13f27c42..bb06ed6b0 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -173,14 +173,14 @@ compAdvConstraints underDefault AdvConfig |] where petriLoops = \case - True -> "some n :" ++ addGiven ++ "Nodes | selfLoop[n]" - False -> "no n :" ++ addGiven ++ "Nodes | selfLoop[n]" + True -> "some n : " ++ addGiven ++ "Nodes | selfLoop[n]" + False -> "no n : " ++ addGiven ++ "Nodes | selfLoop[n]" petriSink = \case - True -> "some t :" ++ addGiven ++ "Transitions | sinkTransitions" ++ addDefault ++ "[t]" - False -> "no t :" ++ addGiven ++ "Transitions | sinkTransitions" ++ addDefault ++ "[t]" + True -> "some t : " ++ addGiven ++ "Transitions | sinkTransitions" ++ addDefault ++ "[t]" + False -> "no t : " ++ addGiven ++ "Transitions | sinkTransitions" ++ addDefault ++ "[t]" petriSource = \case - True -> "some t :" ++ addGiven ++ "Transitions | sourceTransitions" ++ addDefault ++ "[t]" - False -> "no t :" ++ addGiven ++ "Transitions | sourceTransitions" ++ addDefault ++ "[t]" + True -> "some t : " ++ addGiven ++ "Transitions | sourceTransitions" ++ addDefault ++ "[t]" + False -> "no t : " ++ addGiven ++ "Transitions | sourceTransitions" ++ addDefault ++ "[t]" addDefault = if underDefault then "Default" else "" addGiven = if underDefault then "given" else "" From d983dc58bbac5eda7a14bc3e7871688bcba05303 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 8 Apr 2025 08:50:46 +0200 Subject: [PATCH 158/256] address a commit comment --- src/Modelling/PetriNet/Capacity.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index ab8cca505..181129b9e 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -478,7 +478,7 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW activated = skolemName defaultConstraintsAtLeastZero :: String -> BasicConfig -> String defaultConstraintsAtLeastZero activatedT basicConfig@BasicConfig { atLeastActive } = - enforceConstraints True Nothing activatedT (basicConfig { atLeastActive = 0 }) + enforceConstraints True Nothing undefined (basicConfig { atLeastActive = 0 }) ++ "#" ++ activatedT ++ " >= " ++ show atLeastActive ++ "\n" ++ From 1b8b9623b2b1296c12282a6a6b9411c69b904335 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 8 Apr 2025 08:56:02 +0200 Subject: [PATCH 159/256] avoid superfluous parameter passing --- src/Modelling/PetriNet/Capacity.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 181129b9e..22115846b 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -453,7 +453,7 @@ fact { } pred #{capacityPredicateName}[#{activated} : set Transitions] { - #{defaultConstraintsAtLeastZero activated basicC} + #{defaultConstraintsAtLeastZero} #{compAdvConstraints True advConfig} all t : Transitions, p : givenPlaces | @@ -476,13 +476,12 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW |] where activated = skolemName - defaultConstraintsAtLeastZero :: String -> BasicConfig -> String - defaultConstraintsAtLeastZero activatedT basicConfig@BasicConfig { atLeastActive } = - enforceConstraints True Nothing undefined (basicConfig { atLeastActive = 0 }) + defaultConstraintsAtLeastZero = + enforceConstraints True Nothing undefined (basicC { atLeastActive = 0 }) ++ - "#" ++ activatedT ++ " >= " ++ show atLeastActive ++ "\n" + "#" ++ activated ++ " >= " ++ show (atLeastActive basicC) ++ "\n" ++ - " theActivatedTransitions[" ++ activatedT ++ "]" + " theActivatedTransitions[" ++ activated ++ "]" minNewArrowsWithComplementConstraints :: Maybe Int -> String minNewArrowsWithComplementConstraints minNewArrows = case minNewArrows of From 80a4d0f5f3068ee548fdb84b0b436f8621c8d359 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 8 Apr 2025 08:58:37 +0200 Subject: [PATCH 160/256] address a commit comment --- src/Modelling/PetriNet/Capacity.hs | 2 +- src/Modelling/PetriNet/Find.hs | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 22115846b..31cc515e2 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -75,7 +75,6 @@ import Modelling.PetriNet.Diagram ( renderWith, ) import Modelling.PetriNet.Find ( - checkBasicConfig, findTaskInstance, prohibitHidePlaceNames, prohibitHideTransitionNames, @@ -103,6 +102,7 @@ import Modelling.PetriNet.Types ( CapacityNode (..), basicConfigBitWidthInput, checkActivatedSourceConfig, + checkBasicConfig, petriScopeBitWidth, ) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index fadf5b82f..f0f6c3c52 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -10,7 +10,6 @@ module Modelling.PetriNet.Find ( FindInstance (..), - checkBasicConfig, checkConfigForFind, checkFindTwoActive, findInitialList, From 8971c15ffc6950f6c6e9a637965a6861aecde78f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 8 Apr 2025 09:03:46 +0200 Subject: [PATCH 161/256] address a commit comment about naming convention agreement with `flowOut`/`flowOutN` --- src/Modelling/PetriNet/Types.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 8862e08f9..ddc496218 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -545,7 +545,7 @@ instance Net PetriLike Node where $ ns deleteNode x (PetriLike ns) = PetriLike - . adjustAll (updateNode id (M.delete x)) (M.keys . flowInForNode <$> n) + . adjustAll (updateNode id (M.delete x)) (M.keys . flowInN <$> n) . adjustAll (updateNode (M.delete x) id) (M.keys . flowOutN <$> n) . M.delete x $ ns @@ -767,25 +767,25 @@ petriLikeToPetri p = do = throwM RelatedNodesOfTransitionsContainTransitions | any (`M.member` ps) (allRelatedNodes ps) = throwM RelatedNodesOfPlacesContainPlaces - | any (any (<= 0) . flowInForNode) ts + | any (any (<= 0) . flowInN) ts = throwM FlowToATransitionIsZeroOrLess | any (any (<= 0) . flowOutN) ts = throwM FlowFromATransitionIsZeroOrLess | otherwise = pure () - toChangeTuple n = (toFlowList flowInForNode n, toFlowList flowOutN n) + toChangeTuple n = (toFlowList flowInN n, toFlowList flowOutN n) toFlowList f n = M.foldrWithKey (\k _ xs -> fromMaybe 0 (M.lookup k $ f n) : xs) [] ps - relatedNodes n = M.keysSet (flowInForNode n) `S.union` M.keysSet (flowOutN n) + relatedNodes n = M.keysSet (flowInN n) `S.union` M.keysSet (flowOutN n) allRelatedNodes = foldr (S.union . relatedNodes) S.empty -flowInForNode :: Node a -> Map a Int -flowInForNode (PlaceNode _ flowIn _ ) = flowIn -flowInForNode (TransitionNode flowIn _) = flowIn +flowInN :: Node a -> Map a Int +flowInN (PlaceNode _ flowIn _ ) = flowIn +flowInN (TransitionNode flowIn _) = flowIn type Marking = [Int] type Transition = (Marking,Marking) From 3530dccf17b41beaa4ac282e47b5da4c95a3e4e0 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 8 Apr 2025 23:40:56 +0200 Subject: [PATCH 162/256] added two new parameters to CapacityConfig --- app/capacity.hs | 28 ++++++++++++++++++++-------- src/Modelling/PetriNet/Capacity.hs | 19 +++++++++++++------ src/Modelling/PetriNet/Types.hs | 12 ++++++++---- 3 files changed, 41 insertions(+), 18 deletions(-) diff --git a/app/capacity.hs b/app/capacity.hs index 5001803a9..95012a8f1 100644 --- a/app/capacity.hs +++ b/app/capacity.hs @@ -45,15 +45,17 @@ mainFind :: Int -> IO () mainFind i = forceErrors $ do let theConfig@CapacityConfig{..} = defaultCapacityConfig lift $ pPrint theConfig - (pls, trns, maxCap, newFlow, oneMin) <- lift $ userInput theConfig + (pls, trns, maxCap, newFlowMin, newFlowMax, oneMin, distractMin, distractMax, atMostAct) <- lift $ userInput theConfig let config = theConfig { basicConfig = basicConfig { places = pls, transitions = trns }, maxCapacity = maxCap, - minNewArrowsWithComplement = newFlow, - oneMinCapacity = oneMin + minNewArrowsWithComplement = (newFlowMin, newFlowMax), + oneMinCapacity = oneMin, + distractors = (distractMin, distractMax), + atMostActive = atMostAct } :: CapacityConfig let c = checkCapacityConfigs config if isNothing c @@ -74,12 +76,14 @@ validateInput d = do putStrLn "Invalid input" validateInput d -userInput :: CapacityConfig -> IO (Int, Int, Int, Maybe Int, Maybe Int) +userInput :: CapacityConfig -> IO (Int, Int, Int, Int, Int, Int, Int, Int, Maybe Int) userInput CapacityConfig{ basicConfig = BasicConfig{..}, maxCapacity = maxCapacity, - minNewArrowsWithComplement = minNewArrowsWithComplement, - oneMinCapacity = oneMinCapacity + minNewArrowsWithComplement = (minNewFlowMin, minNewFlowMax), + oneMinCapacity = oneMinCapacity, + distractors = (distractorsMin, distractorsMax), + atMostActive = atMost } = do putStr "Number of Places: " pls <- validateInput places @@ -88,7 +92,15 @@ userInput CapacityConfig{ putStr "Highest capacity for a place: " maxCap <- validateInput maxCapacity putStr "How many new flows are at minimum connected to complement places: " - newFlow <- validateInput minNewArrowsWithComplement + newFlowMin <- validateInput minNewFlowMin + putStr "How many new flows are at maximum connected to complement places: " + newFlowMax <- validateInput minNewFlowMax putStr "What capacity should one place at least have: " oneMin <- validateInput oneMinCapacity - return (pls, trns, maxCap, newFlow, oneMin) + putStr "How many distractors (transitions that are activated, but not given the capacity) at minimum: " + distractMin <- validateInput distractorsMin + putStr "How many distractors (transitions that are activated, but not given the capacity) at maximum: " + distractMax <- validateInput distractorsMax + putStr "Number of active Transitions (Just Int/Nothing): " + atMostAct <- validateInput atMost + return (pls, trns, maxCap, newFlowMin, newFlowMax, oneMin, distractMin, distractMax, atMostAct) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 31cc515e2..c538f223e 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -328,7 +328,8 @@ petriNetFindCapacity CapacityConfig { advConfig, maxCapacity, minNewArrowsWithComplement, - oneMinCapacity + oneMinCapacity, + distractors } = petriNetFindCapacityAlloy basicConfig @@ -336,6 +337,7 @@ petriNetFindCapacity CapacityConfig { maxCapacity minNewArrowsWithComplement oneMinCapacity + distractors petriNetPickCapacity :: CapacityConfig -> String petriNetPickCapacity CapacityConfig{ @@ -343,7 +345,8 @@ petriNetPickCapacity CapacityConfig{ advConfig, maxCapacity, minNewArrowsWithComplement, - oneMinCapacity + oneMinCapacity, + distractors } = petriNetFindCapacityAlloy basicConfig @@ -351,6 +354,7 @@ petriNetPickCapacity CapacityConfig{ maxCapacity minNewArrowsWithComplement oneMinCapacity + distractors parseCapacity :: MonadThrow m => AlloyInstance -> m (ActivatedTransitions Object) parseCapacity inst = do @@ -424,8 +428,9 @@ petriNetFindCapacityAlloy :: BasicConfig -> AdvConfig -> Int - -> Maybe Int - -> Maybe Int + -> (Int, Int) + -> Int + -> (Int, Int) -> String petriNetFindCapacityAlloy basicC advConfig maxCapacity minNewArrowsWithComplement oneMinCapacity = [i|module PetriNetCapacity @@ -510,6 +515,8 @@ checkCapacityConfigs CapacityConfig { maxCapacity, minNewArrowsWithComplement, oneMinCapacity, + distractors, + atMostActive, graphConfig } = prohibitHidePlaceNames graphConfig @@ -517,9 +524,9 @@ checkCapacityConfigs CapacityConfig { <|> checkBasicConfig basicConfig <|> prohibitPatchworkRenderer graphConfig <|> checkActivatedSourceConfig basicConfig advConfig - <|> checkCapacityConfig basicConfig maxCapacity minNewArrowsWithComplement oneMinCapacity + <|> checkCapacityConfig basicConfig maxCapacity minNewArrowsWithComplement oneMinCapacity distractors -checkCapacityConfig :: BasicConfig -> Int -> Maybe Int -> Maybe Int -> Maybe String +checkCapacityConfig :: BasicConfig -> Int -> (Int, Int) -> Int -> (Int, Int) -> Maybe String checkCapacityConfig BasicConfig { places, transitions, diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index ddc496218..193addec8 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1061,8 +1061,10 @@ data CapacityConfig = CapacityConfig { basicConfig :: BasicConfig , advConfig :: AdvConfig , maxCapacity :: Int - , minNewArrowsWithComplement :: Maybe Int - , oneMinCapacity :: Maybe Int + , minNewArrowsWithComplement :: (Int, Int) + , oneMinCapacity :: Int + , distractors :: (Int, Int) + , atMostActive :: Maybe Int , graphConfig :: GraphConfig , printSolution :: Bool , useDifferentGraphLayouts :: Bool @@ -1074,8 +1076,10 @@ defaultCapacityConfig = CapacityConfig { basicConfig = defaultBasicConfig { places = 2, transitions = 2, atLeastActive = 1, maxTokensPerPlace = 4, tokensOverall = (2, 8)} , advConfig = defaultAdvConfig , maxCapacity = 4 - , minNewArrowsWithComplement = Just 2 - , oneMinCapacity = Just 2 + , minNewArrowsWithComplement = (2, 6) + , oneMinCapacity = 2 + , atMostActive = Nothing + , distractors = (1, 2) , graphConfig = defaultGraphConfig { hidePlaceNames = False, hideTransitionNames = False } , printSolution = True , useDifferentGraphLayouts = False From 085fc55f7d8db4a65a57a6ad883093e1376836f3 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 8 Apr 2025 23:47:22 +0200 Subject: [PATCH 163/256] checkBasicConfig now also takes a [Int] for specific check for the check with petriScopeBitWidth additional elements are needed. it also should update the string depending on the list --- src/Modelling/PetriNet/Find.hs | 2 +- src/Modelling/PetriNet/MatchToMath.hs | 2 +- src/Modelling/PetriNet/Pick.hs | 2 +- src/Modelling/PetriNet/Types.hs | 13 +++++++++---- test/Modelling/PetriNet/TypesSpec.hs | 4 ++-- 5 files changed, 14 insertions(+), 9 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index f0f6c3c52..b8870e86e 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -179,7 +179,7 @@ checkFindTwoActive BasicConfig { atLeastActive } checkConfigForFind :: BasicConfig -> ChangeConfig -> GraphConfig -> Maybe String checkConfigForFind basic change graph = prohibitHideTransitionNames graph - <|> checkBasicConfig basic + <|> checkBasicConfig [] basic <|> checkChangeConfig basic change <|> prohibitPatchworkRenderer graph diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index d69495082..8bd27af25 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -516,7 +516,7 @@ checkMathConfig c@MathConfig { graphConfig, useDifferentGraphLayouts, wrongInstances - } = checkBasicConfig basicConfig + } = checkBasicConfig [] basicConfig <|> prohibitHidePlaceNames graphConfig <|> prohibitHideTransitionNames graphConfig <|> checkActivatedSourceConfig basicConfig advConfig diff --git a/src/Modelling/PetriNet/Pick.hs b/src/Modelling/PetriNet/Pick.hs index c24fc53d5..634a90d5b 100644 --- a/src/Modelling/PetriNet/Pick.hs +++ b/src/Modelling/PetriNet/Pick.hs @@ -191,7 +191,7 @@ checkConfigForPick -> GraphConfig -> Maybe String checkConfigForPick useDifferent numWrongInstances basic change graph - = checkBasicConfig basic + = checkBasicConfig [] basic <|> checkChangeConfig basic change <|> checkGraphLayouts useDifferent numWrongInstances graph <|> prohibitPatchworkRenderer graph diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 193addec8..6d2d5581f 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1146,8 +1146,8 @@ petriScopeBitWidth values = basicConfigBitWidthInput :: BasicConfig -> [Int] basicConfigBitWidthInput BasicConfig {places, transitions, flowOverall, tokensOverall} = [places, transitions, snd flowOverall, snd tokensOverall] -checkBasicConfig :: BasicConfig -> Maybe String -checkBasicConfig basicC@BasicConfig{ +checkBasicConfig :: [Int] -> BasicConfig -> Maybe String +checkBasicConfig values basicC@BasicConfig{ atLeastActive, flowOverall, maxFlowPerEdge, @@ -1190,11 +1190,16 @@ checkBasicConfig basicC@BasicConfig{ = Just "The maximum 'flowOverall' is set unreasonably high, given the other parameters." | transitions + places > 1 + fst flowOverall = Just "The number of transitions and places exceeds the minimum 'flowOverall' too much to create a connected net." - | Just maxValue <- maxBitWidth, petriScopeBitWidth (basicConfigBitWidthInput basicC) > maxValue - = Just "'places', 'transitions' and the maximum 'flowOverall' and 'tokensOverall' should not be set too high." + | Just maxValue <- maxBitWidth, petriScopeBitWidth (basicConfigBitWidthInput basicC ++ values) > maxValue + = Just ("'places', 'transitions', " ++ addStrings values ++ "and the maximum 'flowOverall' and 'tokensOverall' should not be set too high.") | otherwise = Nothing +addStrings :: [Int] -> String +addStrings [] = "" +addStrings [x] = "'" ++ show x ++ "'" +addStrings (x:xs) = "'" ++ show x ++ "', " ++ addStrings xs + checkActivatedSourceConfig :: BasicConfig -> AdvConfig -> Maybe String checkActivatedSourceConfig BasicConfig{ atLeastActive } AdvConfig{ presenceOfSourceTransitions } | presenceOfSourceTransitions == Just True && atLeastActive == 0 diff --git a/test/Modelling/PetriNet/TypesSpec.hs b/test/Modelling/PetriNet/TypesSpec.hs index 61f2a4ff5..bd9d36283 100644 --- a/test/Modelling/PetriNet/TypesSpec.hs +++ b/test/Modelling/PetriNet/TypesSpec.hs @@ -27,10 +27,10 @@ spec :: Spec spec = do describe "checkBasicConfig" $ do it "checks if the basic Input is in given boundaries" $ - checkBasicConfig defaultBasicConfig `shouldBe` Nothing + checkBasicConfig [] defaultBasicConfig `shouldBe` Nothing context "when provided with Input out of the constraints" $ it "it returns a String with necessary changes" $ - checkBasicConfig defaultBasicConfig{places = 0} + checkBasicConfig [] defaultBasicConfig{places = 0} `shouldSatisfy` isJust describe "checkChangeConfig" $ do it "checks if the input for Changes is in given boundaries" $ From b4b287a752d2de9db763172f15f13f8e7eb69d9c Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 8 Apr 2025 23:47:48 +0200 Subject: [PATCH 164/256] fixed alloy predicate --- alloy/petri/PetriConcepts.als | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/alloy/petri/PetriConcepts.als b/alloy/petri/PetriConcepts.als index 340a2b07f..580701c4c 100644 --- a/alloy/petri/PetriConcepts.als +++ b/alloy/petri/PetriConcepts.als @@ -59,7 +59,7 @@ pred sinkTransitionsDefault[ts : set givenTransitions]{ no ts.defaultFlow } -//check if some transitions are sink transitions under default condition +//check if some transitions are source transitions under default condition pred sourceTransitionsDefault[ts : set givenTransitions]{ - no givenNodes.defaultFlow[ts] + no givenPlaces.defaultFlow[ts] } From bf5dbeae15254a7845e057ce7c8dfa0190b9448f Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 8 Apr 2025 23:49:51 +0200 Subject: [PATCH 165/256] added checks for new parameters in CapacityConfig --- src/Modelling/PetriNet/Capacity.hs | 37 +++++++++++++++++++----------- 1 file changed, 23 insertions(+), 14 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index c538f223e..6a94f2b44 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -81,6 +81,9 @@ import Modelling.PetriNet.Find ( prohibitPatchworkRenderer, toFindEvaluationList, ) +import Modelling.PetriNet.FindActivatedTransitions ( + checkActivatedTransitionsConfig, + ) import Modelling.PetriNet.Reach.Type ( ShowTransition (ShowTransition), Transition, @@ -521,10 +524,11 @@ checkCapacityConfigs CapacityConfig { } = prohibitHidePlaceNames graphConfig <|> prohibitHideTransitionNames graphConfig - <|> checkBasicConfig basicConfig + <|> checkBasicConfig [fst minNewArrowsWithComplement, maxCapacity] basicConfig <|> prohibitPatchworkRenderer graphConfig <|> checkActivatedSourceConfig basicConfig advConfig <|> checkCapacityConfig basicConfig maxCapacity minNewArrowsWithComplement oneMinCapacity distractors + <|> checkActivatedTransitionsConfig basicConfig atMostActive checkCapacityConfig :: BasicConfig -> Int -> (Int, Int) -> Int -> (Int, Int) -> Maybe String checkCapacityConfig BasicConfig { @@ -537,26 +541,31 @@ checkCapacityConfig BasicConfig { maxCapacity minNewArrowsWithComplement oneMinCapacity + distractors | maxCapacity < maxFlowPerEdge = Just "'maxCapacity' can not be too low for flow weights." | maxCapacity < maxTokensPerPlace = Just "The starting tokens can not exceed 'maxCapacity'." | atLeastActive == 0 = Just "At least one transition has to be activated." + | uncurry (>) minNewArrowsWithComplement + = Just "The first element of 'minNewArrowsWithComplement' has to be smaller than the second element." + | fst minNewArrowsWithComplement <= 0 + = Just "At least one flow has to be connected to a complement place." + | snd minNewArrowsWithComplement > 2 * transitions * places + = Just "'minNewArrowsWithComplement' is set unreasonably high, given the number of transitions." + | oneMinCapacity <= 0 + = Just "'oneMinCapacity' has to be positive." + | oneMinCapacity > maxCapacity + = Just "'oneMinCapacity' can not be higher than 'maxCapacity'." + | uncurry (>) distractors + = Just "The first element of 'distractors' has to be smaller than the second element." + | fst distractors < 0 + = Just "The first element of 'distractors' has to be positive." + | snd distractors > transitions + = Just "'distractors' can not be higher than the number of transitions." | otherwise - = case minNewArrowsWithComplement of - Just minNew - | minNew <= 0 - -> Just "At least one flow has to be connected to a complement place." - | minNew > 2 * transitions * places - -> Just "'minNewArrowsWithComplement' is set unreasonably high, given the number of transitions." - _ -> case oneMinCapacity of - Just oneMin - | oneMin <= 0 - -> Just "'oneMinCapacity' has to be positive." - | oneMin > maxCapacity - -> Just "'oneMinCapacity' can not be higher than 'maxCapacity'." - _ -> Nothing + = Nothing defaultCapacityInstance :: CapacityInstance defaultCapacityInstance = CapacityInstance { From 15dca9c907703abf21c4471514b7d3e0fa6d9e21 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 8 Apr 2025 23:50:52 +0200 Subject: [PATCH 166/256] updated implementation of new parameters in alloy-code --- src/Modelling/PetriNet/Capacity.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 6a94f2b44..3b202089c 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -435,7 +435,7 @@ petriNetFindCapacityAlloy -> Int -> (Int, Int) -> String -petriNetFindCapacityAlloy basicC advConfig maxCapacity minNewArrowsWithComplement oneMinCapacity +petriNetFindCapacityAlloy basicC advConfig maxCapacity minNewArrowsWithComplement oneMinCapacity distractors = [i|module PetriNetCapacity #{modulePetriSignature} @@ -476,11 +476,12 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { #{minNewArrowsWithComplementConstraints minNewArrowsWithComplement} #{oneMinCapacityConstraints oneMinCapacity} + #{distractorsConstraints distractors} } run #{capacityPredicateName} for exactly #{places basicC} givenPlaces, exactly #{places basicC} addedPlaces, -exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC ++ [maxCapacity])} Int +exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC ++ [fst minNewArrowsWithComplement, maxCapacity])} Int |] where activated = skolemName @@ -490,17 +491,17 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW "#" ++ activated ++ " >= " ++ show (atLeastActive basicC) ++ "\n" ++ " theActivatedTransitions[" ++ activated ++ "]" - minNewArrowsWithComplementConstraints :: Maybe Int -> String - minNewArrowsWithComplementConstraints minNewArrows = - case minNewArrows of - Just minNew -> - "#flowChange >= " ++ show minNew - Nothing -> "" - oneMinCapacityConstraints :: Maybe Int -> String + minNewArrowsWithComplementConstraints :: (Int, Int) -> String + minNewArrowsWithComplementConstraints (minNewArrowsMin, minNewArrowsMax) = + "#flowChange >= " ++ show minNewArrowsMin ++ "\n" ++ + " #flowChange <= " ++ show minNewArrowsMax + oneMinCapacityConstraints :: Int -> String oneMinCapacityConstraints oneMinCap = - case oneMinCap of - Just oneMin -> [i|some p : placesWithCapacity | p.capacity >= #{oneMin}|] - Nothing -> "" + [i|some p : placesWithCapacity | p.capacity >= #{oneMinCap}|] + distractorsConstraints :: (Int, Int) -> String + distractorsConstraints (distractorsMin, distractorsMax) = + "let distractors = {t: givenTransitions | activatedDefault[t] and not theActivatedTransitions[t]} |" ++ "\n" ++ + " #" ++ "distractors >= " ++ show distractorsMin ++ " and " ++ "#" ++ "distractors <= " ++ show distractorsMax capacityPredicateName :: String capacityPredicateName = "showCapacity" From 0964d17a20d3c7576118a2010c271862f251a16d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 9 Apr 2025 00:03:00 +0200 Subject: [PATCH 167/256] fixed small mistakes --- src/Modelling/PetriNet/Capacity.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 3b202089c..1e8d0dd62 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -231,7 +231,7 @@ capacityTask path task = do paragraph $ do translate $ do english [iii| - Given the isolated Places . With how many tokens and how should they be connected to Transitions so that the + Given the isolated Places. With how many tokens and how should they be connected to Transitions so that the resulting Petri net without capacities is equivalent to the given Petri net with capacities? |] german [iii| @@ -562,7 +562,7 @@ checkCapacityConfig BasicConfig { | uncurry (>) distractors = Just "The first element of 'distractors' has to be smaller than the second element." | fst distractors < 0 - = Just "The first element of 'distractors' has to be positive." + = Just "The first element of 'distractors' can not be negative." | snd distractors > transitions = Just "'distractors' can not be higher than the number of transitions." | otherwise From 8b4178c7ba0c2c4e26de41ce080080c7c061df2c Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 9 Apr 2025 23:17:20 +0200 Subject: [PATCH 168/256] rename capacity parameter --- app/capacity.hs | 4 ++-- src/Modelling/PetriNet/Capacity.hs | 30 +++++++++++++++--------------- src/Modelling/PetriNet/Types.hs | 4 ++-- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/app/capacity.hs b/app/capacity.hs index 95012a8f1..e70d2c36f 100644 --- a/app/capacity.hs +++ b/app/capacity.hs @@ -52,7 +52,7 @@ mainFind i = forceErrors $ do transitions = trns }, maxCapacity = maxCap, - minNewArrowsWithComplement = (newFlowMin, newFlowMax), + newArrowsWithComplement = (newFlowMin, newFlowMax), oneMinCapacity = oneMin, distractors = (distractMin, distractMax), atMostActive = atMostAct @@ -80,7 +80,7 @@ userInput :: CapacityConfig -> IO (Int, Int, Int, Int, Int, Int, Int, Int, Maybe userInput CapacityConfig{ basicConfig = BasicConfig{..}, maxCapacity = maxCapacity, - minNewArrowsWithComplement = (minNewFlowMin, minNewFlowMax), + newArrowsWithComplement = (minNewFlowMin, minNewFlowMax), oneMinCapacity = oneMinCapacity, distractors = (distractorsMin, distractorsMax), atMostActive = atMost diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 1e8d0dd62..dab750fb3 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -330,7 +330,7 @@ petriNetFindCapacity CapacityConfig { basicConfig, advConfig, maxCapacity, - minNewArrowsWithComplement, + newArrowsWithComplement, oneMinCapacity, distractors } @@ -338,7 +338,7 @@ petriNetFindCapacity CapacityConfig { basicConfig advConfig maxCapacity - minNewArrowsWithComplement + newArrowsWithComplement oneMinCapacity distractors @@ -347,7 +347,7 @@ petriNetPickCapacity CapacityConfig{ basicConfig, advConfig, maxCapacity, - minNewArrowsWithComplement, + newArrowsWithComplement, oneMinCapacity, distractors } = @@ -355,7 +355,7 @@ petriNetPickCapacity CapacityConfig{ basicConfig advConfig maxCapacity - minNewArrowsWithComplement + newArrowsWithComplement oneMinCapacity distractors @@ -474,7 +474,7 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { all p : placesWithCapacity, w : p.flow[Transitions] + Transitions.flow[p] | p.capacity >= w - #{minNewArrowsWithComplementConstraints minNewArrowsWithComplement} + #{newArrowsWithComplementConstraints newArrowsWithComplement} #{oneMinCapacityConstraints oneMinCapacity} #{distractorsConstraints distractors} @@ -491,8 +491,8 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW "#" ++ activated ++ " >= " ++ show (atLeastActive basicC) ++ "\n" ++ " theActivatedTransitions[" ++ activated ++ "]" - minNewArrowsWithComplementConstraints :: (Int, Int) -> String - minNewArrowsWithComplementConstraints (minNewArrowsMin, minNewArrowsMax) = + newArrowsWithComplementConstraints :: (Int, Int) -> String + newArrowsWithComplementConstraints (minNewArrowsMin, minNewArrowsMax) = "#flowChange >= " ++ show minNewArrowsMin ++ "\n" ++ " #flowChange <= " ++ show minNewArrowsMax oneMinCapacityConstraints :: Int -> String @@ -517,7 +517,7 @@ checkCapacityConfigs CapacityConfig { basicConfig, advConfig, maxCapacity, - minNewArrowsWithComplement, + newArrowsWithComplement, oneMinCapacity, distractors, atMostActive, @@ -540,7 +540,7 @@ checkCapacityConfig BasicConfig { maxFlowPerEdge } maxCapacity - minNewArrowsWithComplement + newArrowsWithComplement oneMinCapacity distractors | maxCapacity < maxFlowPerEdge @@ -549,12 +549,12 @@ checkCapacityConfig BasicConfig { = Just "The starting tokens can not exceed 'maxCapacity'." | atLeastActive == 0 = Just "At least one transition has to be activated." - | uncurry (>) minNewArrowsWithComplement - = Just "The first element of 'minNewArrowsWithComplement' has to be smaller than the second element." - | fst minNewArrowsWithComplement <= 0 - = Just "At least one flow has to be connected to a complement place." - | snd minNewArrowsWithComplement > 2 * transitions * places - = Just "'minNewArrowsWithComplement' is set unreasonably high, given the number of transitions." + | uncurry (>=) newArrowsWithComplement + = Just "The first element of 'newArrowsWithComplement' can not be higher than the second element." + | fst newArrowsWithComplement < places + = Just "At least one flow has to be connected to each complement place." + | snd newArrowsWithComplement > 2 * transitions * places + = Just "'newArrowsWithComplement' is set unreasonably high, given the number of transitions and places." | oneMinCapacity <= 0 = Just "'oneMinCapacity' has to be positive." | oneMinCapacity > maxCapacity diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 6d2d5581f..dbe13d523 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1061,7 +1061,7 @@ data CapacityConfig = CapacityConfig { basicConfig :: BasicConfig , advConfig :: AdvConfig , maxCapacity :: Int - , minNewArrowsWithComplement :: (Int, Int) + , newArrowsWithComplement :: (Int, Int) , oneMinCapacity :: Int , distractors :: (Int, Int) , atMostActive :: Maybe Int @@ -1076,7 +1076,7 @@ defaultCapacityConfig = CapacityConfig { basicConfig = defaultBasicConfig { places = 2, transitions = 2, atLeastActive = 1, maxTokensPerPlace = 4, tokensOverall = (2, 8)} , advConfig = defaultAdvConfig , maxCapacity = 4 - , minNewArrowsWithComplement = (2, 6) + , newArrowsWithComplement = (2, 6) , oneMinCapacity = 2 , atMostActive = Nothing , distractors = (1, 2) From 780b0792832570512dbf936d1d34ca3c96b42d06 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 9 Apr 2025 23:18:09 +0200 Subject: [PATCH 169/256] fixed smaller mistakes --- app/capacity.hs | 2 +- src/Modelling/PetriNet/Alloy.hs | 4 ++-- src/Modelling/PetriNet/Capacity.hs | 12 ++++++------ 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/app/capacity.hs b/app/capacity.hs index e70d2c36f..67d210e0c 100644 --- a/app/capacity.hs +++ b/app/capacity.hs @@ -101,6 +101,6 @@ userInput CapacityConfig{ distractMin <- validateInput distractorsMin putStr "How many distractors (transitions that are activated, but not given the capacity) at maximum: " distractMax <- validateInput distractorsMax - putStr "Number of active Transitions (Just Int/Nothing): " + putStr "Maximum number of active Transitions (Just Int/Nothing): " atMostAct <- validateInput atMost return (pls, trns, maxCap, newFlowMin, newFlowMax, oneMin, distractMin, distractMax, atMostAct) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index bb06ed6b0..467fe843c 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -173,8 +173,8 @@ compAdvConstraints underDefault AdvConfig |] where petriLoops = \case - True -> "some n : " ++ addGiven ++ "Nodes | selfLoop[n]" - False -> "no n : " ++ addGiven ++ "Nodes | selfLoop[n]" + True -> "some n : Nodes | selfLoop[n]" + False -> "no n : Nodes | selfLoop[n]" petriSink = \case True -> "some t : " ++ addGiven ++ "Transitions | sinkTransitions" ++ addDefault ++ "[t]" False -> "no t : " ++ addGiven ++ "Transitions | sinkTransitions" ++ addDefault ++ "[t]" diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index dab750fb3..7959fe9a2 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -481,7 +481,7 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { } run #{capacityPredicateName} for exactly #{places basicC} givenPlaces, exactly #{places basicC} addedPlaces, -exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC ++ [fst minNewArrowsWithComplement, maxCapacity])} Int +exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitWidthInput basicC ++ [snd newArrowsWithComplement, maxCapacity])} Int |] where activated = skolemName @@ -500,7 +500,7 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW [i|some p : placesWithCapacity | p.capacity >= #{oneMinCap}|] distractorsConstraints :: (Int, Int) -> String distractorsConstraints (distractorsMin, distractorsMax) = - "let distractors = {t: givenTransitions | activatedDefault[t] and not theActivatedTransitions[t]} |" ++ "\n" ++ + "let distractors = {t: givenTransitions | activatedDefault[t] and t not in " ++ activated ++ "} |" ++ "\n" ++ " #" ++ "distractors >= " ++ show distractorsMin ++ " and " ++ "#" ++ "distractors <= " ++ show distractorsMax capacityPredicateName :: String @@ -525,7 +525,7 @@ checkCapacityConfigs CapacityConfig { } = prohibitHidePlaceNames graphConfig <|> prohibitHideTransitionNames graphConfig - <|> checkBasicConfig [fst minNewArrowsWithComplement, maxCapacity] basicConfig + <|> checkBasicConfig [snd newArrowsWithComplement, maxCapacity] basicConfig <|> prohibitPatchworkRenderer graphConfig <|> checkActivatedSourceConfig basicConfig advConfig <|> checkCapacityConfig basicConfig maxCapacity minNewArrowsWithComplement oneMinCapacity distractors @@ -559,11 +559,11 @@ checkCapacityConfig BasicConfig { = Just "'oneMinCapacity' has to be positive." | oneMinCapacity > maxCapacity = Just "'oneMinCapacity' can not be higher than 'maxCapacity'." - | uncurry (>) distractors - = Just "The first element of 'distractors' has to be smaller than the second element." + | uncurry (>=) distractors + = Just "The first element of 'distractors' can not be higher than the second element." | fst distractors < 0 = Just "The first element of 'distractors' can not be negative." - | snd distractors > transitions + | snd distractors > maximum [transitions, (fromMaybe 0 atMostActive)] = Just "'distractors' can not be higher than the number of transitions." | otherwise = Nothing From 2a6ec620c2ab804c30309d7ff8713b22b427c2e5 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 9 Apr 2025 23:19:37 +0200 Subject: [PATCH 170/256] added funtion to parse the capacity in a net --- src/Modelling/PetriNet/Parser.hs | 7 ++++++- src/Modelling/PetriNet/Types.hs | 21 +++++++++++++++++++-- 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index f72192a05..8a8c54e1c 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -36,7 +36,7 @@ import qualified Data.Map.Lazy as Map ( import Modelling.Auxiliary.Common (Object (Object, oName, oIndex), toMap) import Modelling.PetriNet.Types ( - Net (emptyNet, outFlow, alterFlow, alterNode, traverseNet), + Net (emptyNet, outFlow, alterFlow, alterNode, traverseNet, updateCapacity), Petri, PetriChange (..), PetriNode (..), @@ -116,9 +116,14 @@ parseNet flowSetName tokenSetName inst = do nodes <- singleSig inst "this" "Nodes" "" rawTokens <- doubleSig inst "this" "Places" tokenSetName let tokens = relToMap (second oIndex) rawTokens + rawCapacity <- doubleSig inst "this" "placesWithCapacity" "capacity" + let capacities = relToMap (second oIndex) rawCapacity flow <- tripleSig inst "this" "Nodes" flowSetName + return . foldrFlip (\(x, y, z) -> alterFlow x (oIndex z) y) flow + . foldrFlip + (\x -> updateCapacity x $ Map.lookup x capacities >>= Set.lookupMin) nodes . foldrFlip (\x -> alterNode x $ Map.lookup x tokens >>= Set.lookupMin) nodes diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index dbe13d523..aed6618be 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -143,6 +143,7 @@ import Control.Monad.Random (MonadRandom, RandT, RandomGen) import Control.Monad.Trans (MonadTrans(lift)) import Data.Bimap (Bimap) import Data.GraphViz.Attributes.Complete (GraphvizCommand (..)) +import Data.List (intercalate) import Data.Map.Lazy (Map) import Data.Maybe (fromMaybe) import GHC.Generics (Generic) @@ -489,6 +490,13 @@ class (PetriNode n, Show (p n String)) => Net p n where -> p n a -> p n a + updateCapacity + :: Ord a + => a + -> Maybe Int + -> p n a + -> p n a + {-| Removes the flow going from the first given key to the second one.. -} @@ -564,6 +572,8 @@ instance Net PetriLike Node where outFlow x = maybe M.empty flowOutN . M.lookup x . allNodes + updateCapacity _ _ net = net + mapNet = mapPetriLike traverseNet = traversePetriLike @@ -599,6 +609,8 @@ instance Net PetriLike SimpleNode where outFlow x = maybe M.empty flowOutSN . M.lookup x . allNodes + updateCapacity _ _ net = net + mapNet = mapPetriLike traverseNet = traversePetriLike @@ -632,13 +644,11 @@ instance Net PetriLike CapacityNode where . allNodes $ ns - alterFlow x f y = PetriLike . M.adjust (updateCapacityNode (M.insert y f)) x . M.adjust (updateCapacityNode (M.insert x f)) y . allNodes - alterNode x mt = PetriLike . M.alter alterNode' x . allNodes where alterNode' = Just . fromMaybe @@ -646,6 +656,13 @@ instance Net PetriLike CapacityNode where outFlow x = maybe M.empty flowOutCN . M.lookup x . allNodes + updateCapacity x y (PetriLike ns) = + PetriLike $ M.alter updateCapacity' x ns + where + updateCapacity' Nothing = Just $ CapacityPlace 0 (fromMaybe 0 y) M.empty M.empty + updateCapacity' (Just (CapacityPlace t _ i o)) = Just $ CapacityPlace t (fromMaybe 0 y) i o + updateCapacity' (Just (CapacityTransition i o)) = Just $ CapacityTransition i o + mapNet = mapPetriLike traverseNet = traversePetriLike From 39a84466979bcc15228a13b3ed0682633981405d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 9 Apr 2025 23:20:26 +0200 Subject: [PATCH 171/256] added checks for atMostActive --- src/Modelling/PetriNet/Capacity.hs | 22 +++++++++++++++++----- src/Modelling/PetriNet/Types.hs | 4 +--- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 7959fe9a2..ff2b49098 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -137,6 +137,7 @@ import Control.Monad.Random ( import Control.Monad.Trans (MonadTrans (lift)) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) +import Data.Maybe (fromMaybe) import Data.String.Interpolate (i, iii) import Language.Alloy.Call ( AlloyInstance @@ -332,7 +333,8 @@ petriNetFindCapacity CapacityConfig { maxCapacity, newArrowsWithComplement, oneMinCapacity, - distractors + distractors, + atMostActive } = petriNetFindCapacityAlloy basicConfig @@ -341,6 +343,7 @@ petriNetFindCapacity CapacityConfig { newArrowsWithComplement oneMinCapacity distractors + atMostActive petriNetPickCapacity :: CapacityConfig -> String petriNetPickCapacity CapacityConfig{ @@ -349,7 +352,8 @@ petriNetPickCapacity CapacityConfig{ maxCapacity, newArrowsWithComplement, oneMinCapacity, - distractors + distractors, + atMostActive } = petriNetFindCapacityAlloy basicConfig @@ -358,6 +362,7 @@ petriNetPickCapacity CapacityConfig{ newArrowsWithComplement oneMinCapacity distractors + atMostActive parseCapacity :: MonadThrow m => AlloyInstance -> m (ActivatedTransitions Object) parseCapacity inst = do @@ -434,8 +439,9 @@ petriNetFindCapacityAlloy -> (Int, Int) -> Int -> (Int, Int) + -> Maybe Int -> String -petriNetFindCapacityAlloy basicC advConfig maxCapacity minNewArrowsWithComplement oneMinCapacity distractors +petriNetFindCapacityAlloy basicC advConfig maxCapacity newArrowsWithComplement oneMinCapacity distractors atMostActive = [i|module PetriNetCapacity #{modulePetriSignature} @@ -490,12 +496,17 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW ++ "#" ++ activated ++ " >= " ++ show (atLeastActive basicC) ++ "\n" ++ + (case atMostActive of + Nothing -> "" + Just n -> "#" ++ activated ++ " <= " ++ show n ++ "\n") + ++ " theActivatedTransitions[" ++ activated ++ "]" newArrowsWithComplementConstraints :: (Int, Int) -> String newArrowsWithComplementConstraints (minNewArrowsMin, minNewArrowsMax) = "#flowChange >= " ++ show minNewArrowsMin ++ "\n" ++ " #flowChange <= " ++ show minNewArrowsMax oneMinCapacityConstraints :: Int -> String + oneMinCapacityConstraints 1 = "" oneMinCapacityConstraints oneMinCap = [i|some p : placesWithCapacity | p.capacity >= #{oneMinCap}|] distractorsConstraints :: (Int, Int) -> String @@ -528,10 +539,10 @@ checkCapacityConfigs CapacityConfig { <|> checkBasicConfig [snd newArrowsWithComplement, maxCapacity] basicConfig <|> prohibitPatchworkRenderer graphConfig <|> checkActivatedSourceConfig basicConfig advConfig - <|> checkCapacityConfig basicConfig maxCapacity minNewArrowsWithComplement oneMinCapacity distractors + <|> checkCapacityConfig basicConfig maxCapacity newArrowsWithComplement oneMinCapacity distractors atMostActive <|> checkActivatedTransitionsConfig basicConfig atMostActive -checkCapacityConfig :: BasicConfig -> Int -> (Int, Int) -> Int -> (Int, Int) -> Maybe String +checkCapacityConfig :: BasicConfig -> Int -> (Int, Int) -> Int -> (Int, Int) -> Maybe Int -> Maybe String checkCapacityConfig BasicConfig { places, transitions, @@ -543,6 +554,7 @@ checkCapacityConfig BasicConfig { newArrowsWithComplement oneMinCapacity distractors + atMostActive | maxCapacity < maxFlowPerEdge = Just "'maxCapacity' can not be too low for flow weights." | maxCapacity < maxTokensPerPlace diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index aed6618be..ed8ee799a 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1213,9 +1213,7 @@ checkBasicConfig values basicC@BasicConfig{ = Nothing addStrings :: [Int] -> String -addStrings [] = "" -addStrings [x] = "'" ++ show x ++ "'" -addStrings (x:xs) = "'" ++ show x ++ "', " ++ addStrings xs +addStrings xs = intercalate ", " (map (\x -> "'" ++ show x ++ "'") xs) checkActivatedSourceConfig :: BasicConfig -> AdvConfig -> Maybe String checkActivatedSourceConfig BasicConfig{ atLeastActive } AdvConfig{ presenceOfSourceTransitions } From 32ce42841a94bde470ea8ed40e0c3ca51ecef7b5 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 9 Apr 2025 23:23:43 +0200 Subject: [PATCH 172/256] fixed hlint --- src/Modelling/PetriNet/Capacity.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index ff2b49098..828c062e7 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -575,7 +575,7 @@ checkCapacityConfig BasicConfig { = Just "The first element of 'distractors' can not be higher than the second element." | fst distractors < 0 = Just "The first element of 'distractors' can not be negative." - | snd distractors > maximum [transitions, (fromMaybe 0 atMostActive)] + | snd distractors > max transitions (fromMaybe 0 atMostActive) = Just "'distractors' can not be higher than the number of transitions." | otherwise = Nothing From f68b8e05ad89a6f4b3817f635fad585c91b92659 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 11 Apr 2025 08:20:07 +0200 Subject: [PATCH 173/256] about inequalities --- src/Modelling/PetriNet/Capacity.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 828c062e7..6443d2055 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -561,7 +561,7 @@ checkCapacityConfig BasicConfig { = Just "The starting tokens can not exceed 'maxCapacity'." | atLeastActive == 0 = Just "At least one transition has to be activated." - | uncurry (>=) newArrowsWithComplement + | uncurry (>) newArrowsWithComplement = Just "The first element of 'newArrowsWithComplement' can not be higher than the second element." | fst newArrowsWithComplement < places = Just "At least one flow has to be connected to each complement place." @@ -571,7 +571,7 @@ checkCapacityConfig BasicConfig { = Just "'oneMinCapacity' has to be positive." | oneMinCapacity > maxCapacity = Just "'oneMinCapacity' can not be higher than 'maxCapacity'." - | uncurry (>=) distractors + | uncurry (>) distractors = Just "The first element of 'distractors' can not be higher than the second element." | fst distractors < 0 = Just "The first element of 'distractors' can not be negative." From 605ee5e037ec8c88d6efca56c6f8708c58e5eafb Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 10 Apr 2025 23:23:10 +0200 Subject: [PATCH 174/256] added back 'NoInstanceAvailable' --- src/Modelling/PetriNet/Capacity.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 6443d2055..2f4a499f2 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -50,6 +50,7 @@ import Capabilities.Cache (MonadCache) import Capabilities.Diagrams (MonadDiagrams) import Capabilities.Graphviz (MonadGraphviz) import Modelling.Auxiliary.Common ( + TaskGenerationException (NoInstanceAvailable), Object, oneOf, parseWith, @@ -134,6 +135,8 @@ import Control.Monad.Random ( evalRandT, mkStdGen ) +import Control.Monad (when) +import Control.Monad.Catch (MonadThrow (throwM)) import Control.Monad.Trans (MonadTrans (lift)) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) @@ -313,6 +316,8 @@ pickCapacity pickCapacity alloyF alloyC config segment = do let is = Find.maxInstances (alloyC config) list <- getInstances is (Find.timeout $ alloyC config) (alloyF config) + when (null $ drop segment list) + $ throwM NoInstanceAvailable inst <- case fromIntegral <$> is of Nothing -> randomInstance list Just n -> do From 693144560bc85aa2da94aef90cc8f36cef927d55 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 10 Apr 2025 23:27:56 +0200 Subject: [PATCH 175/256] updated the checks for capacity --- src/Modelling/PetriNet/Capacity.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 2f4a499f2..6c746d076 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -140,7 +140,6 @@ import Control.Monad.Catch (MonadThrow (throwM)) import Control.Monad.Trans (MonadTrans (lift)) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) -import Data.Maybe (fromMaybe) import Data.String.Interpolate (i, iii) import Language.Alloy.Call ( AlloyInstance @@ -544,10 +543,10 @@ checkCapacityConfigs CapacityConfig { <|> checkBasicConfig [snd newArrowsWithComplement, maxCapacity] basicConfig <|> prohibitPatchworkRenderer graphConfig <|> checkActivatedSourceConfig basicConfig advConfig - <|> checkCapacityConfig basicConfig maxCapacity newArrowsWithComplement oneMinCapacity distractors atMostActive + <|> checkCapacityConfig basicConfig maxCapacity newArrowsWithComplement oneMinCapacity distractors <|> checkActivatedTransitionsConfig basicConfig atMostActive -checkCapacityConfig :: BasicConfig -> Int -> (Int, Int) -> Int -> (Int, Int) -> Maybe Int -> Maybe String +checkCapacityConfig :: BasicConfig -> Int -> (Int, Int) -> Int -> (Int, Int) -> Maybe String checkCapacityConfig BasicConfig { places, transitions, @@ -559,7 +558,6 @@ checkCapacityConfig BasicConfig { newArrowsWithComplement oneMinCapacity distractors - atMostActive | maxCapacity < maxFlowPerEdge = Just "'maxCapacity' can not be too low for flow weights." | maxCapacity < maxTokensPerPlace @@ -580,7 +578,7 @@ checkCapacityConfig BasicConfig { = Just "The first element of 'distractors' can not be higher than the second element." | fst distractors < 0 = Just "The first element of 'distractors' can not be negative." - | snd distractors > max transitions (fromMaybe 0 atMostActive) + | snd distractors > transitions - atLeastActive = Just "'distractors' can not be higher than the number of transitions." | otherwise = Nothing From d7cb44f498b961529d3d7998d4a3bc77f6a4ab94 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 11 Apr 2025 20:38:23 +0200 Subject: [PATCH 176/256] generalized capacity --- src/Modelling/PetriNet/Capacity.hs | 31 ++++++++++++++---------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 6c746d076..cfeb0e9a1 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -155,11 +155,11 @@ import Text.Parsec.Combinator (many1) import Text.Parsec.String (Parser) -data CapacityInstance = CapacityInstance { +data CapacityInstance a = CapacityInstance { drawWith :: !DrawSettings, toFind :: !(ActivatedTransitions Transition), originalNet :: !(PetriLike CapacityNode String), - transformedNet :: !(PetriLike SimpleNode String), + transformedNet :: !a, numberOfPlaces :: !Int, numberOfTransitions :: !Int, showSolution :: !Bool @@ -167,18 +167,17 @@ data CapacityInstance = CapacityInstance { deriving (Read, Show) capacityGenerate - :: (MonadAlloy m, MonadThrow m) + :: (MonadAlloy m, MonadThrow m, Net p n) => CapacityConfig -> Int -> Int - -> m CapacityInstance + -> m (CapacityInstance (p n String)) capacityGenerate config seed segment = flip evalRandT (mkStdGen seed) $ do gl <- oneOf $ graphLayouts gc - tn <- pickCapacity petriNetPickCapacity Pick.alloyConfig config segment + (original, transformed, condition) <- combinedCapacity petriNetFindCapacity Find.alloyConfig config segment - (net, condition) <- findCapacity config segment condition' <- lift $ traverse (parseWith parseTransitionPrec) condition return $ CapacityInstance { drawWith = DrawSettings @@ -189,8 +188,8 @@ capacityGenerate config seed segment = , withGraphvizCommand = gl } , toFind = condition' - , originalNet = tn - , transformedNet = net + , originalNet = original + , transformedNet = transformed , numberOfPlaces = places bc , numberOfTransitions = transitions bc , showSolution = Find.printSolution config @@ -208,7 +207,7 @@ simpleCapacityTask OutputCapable m ) => FilePath - -> CapacityInstance + -> CapacityInstance (SimplePetriNet) -> LangM m simpleCapacityTask = capacityTask @@ -218,10 +217,11 @@ capacityTask MonadDiagrams m, MonadGraphviz m, MonadThrow m, + Net p n, OutputCapable m ) => FilePath - -> CapacityInstance + -> CapacityInstance (p n String) -> LangM m capacityTask path task = do paragraph $ translate $ do @@ -254,7 +254,7 @@ capacityTask path task = do capacitySyntax :: OutputCapable m - => CapacityInstance + => CapacityInstance net -> [Transition] -> LangM' m () capacitySyntax task input = do @@ -270,7 +270,7 @@ capacitySyntax task input = do capacityEvaluation :: (Monad m, OutputCapable m) - => CapacityInstance + => CapacityInstance net -> [Transition] -> Rated m capacityEvaluation task x = do @@ -283,7 +283,7 @@ capacityEvaluation task x = do active = capacitySolution task withSol = showSolution task -capacitySolution :: CapacityInstance -> [Transition] +capacitySolution :: CapacityInstance net -> [Transition] capacitySolution task = active where ActivatedTransitions active = toFind task @@ -308,11 +308,8 @@ pickCapacity -> (config -> AlloyConfig) -> config -> Int - -> RandT - g - m - (PetriLike CapacityNode String) pickCapacity alloyF alloyC config segment = do + -> RandT g m (PetriLike CapacityNode String, p n String, ActivatedTransitions String) let is = Find.maxInstances (alloyC config) list <- getInstances is (Find.timeout $ alloyC config) (alloyF config) when (null $ drop segment list) From deff71f218ce8724c248a383d52c018faf763d73 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 11 Apr 2025 20:40:03 +0200 Subject: [PATCH 177/256] combined net generation into one function --- src/Modelling/PetriNet/Capacity.hs | 64 +++++++++--------------------- 1 file changed, 18 insertions(+), 46 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index cfeb0e9a1..a79c1bf41 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -8,18 +8,16 @@ {-# LANGUAGE DeriveGeneric #-} module Modelling.PetriNet.Capacity ( + CapacityInstance (..), capacityEvaluation, capacityGenerate, capacitySyntax, capacityTask, checkCapacityConfigs, defaultCapacityInstance, - findCapacity, petriNetFindCapacity, - petriNetPickCapacity, parseCapacity, parseCapacityPrec, - pickCapacity, simpleCapacityTask, ) where @@ -68,15 +66,14 @@ import Modelling.PetriNet.Alloy ( modulePetriSignature, randomInSegment, skolemVariable, - taskInstance, unscopedSingleSig, ) import Modelling.PetriNet.Diagram ( getDefaultNet, + getNet, renderWith, ) import Modelling.PetriNet.Find ( - findTaskInstance, prohibitHidePlaceNames, prohibitHideTransitionNames, prohibitPatchworkRenderer, @@ -100,9 +97,11 @@ import Modelling.PetriNet.Types ( CapacityConfig (..), DrawSettings (..), GraphConfig (..), + Net, NodeC (..), PetriLike (PetriLike, allNodes), SimpleNode (..), + SimplePetriNet, CapacityNode (..), basicConfigBitWidthInput, checkActivatedSourceConfig, @@ -288,28 +287,14 @@ capacitySolution task = active where ActivatedTransitions active = toFind task -findCapacity - :: (MonadAlloy m, MonadThrow m, RandomGen g) - => CapacityConfig - -> Int - -> RandT - g - m - (PetriLike SimpleNode String, ActivatedTransitions String) -findCapacity = taskInstance - findTaskInstance - petriNetFindCapacity - parseCapacity - Find.alloyConfig - -pickCapacity - :: (MonadAlloy m, MonadThrow m, RandomGen g) +combinedCapacity + :: (MonadThrow m, RandomGen g, MonadAlloy m, Net p n) => (config -> String) -> (config -> AlloyConfig) -> config -> Int -pickCapacity alloyF alloyC config segment = do -> RandT g m (PetriLike CapacityNode String, p n String, ActivatedTransitions String) +combinedCapacity alloyF alloyC config segment = do let is = Find.maxInstances (alloyC config) list <- getInstances is (Find.timeout $ alloyC config) (alloyF config) when (null $ drop segment list) @@ -321,11 +306,14 @@ pickCapacity alloyF alloyC config segment = do case drop x list of x':_ -> return x' [] -> randomInstance list - getDefaultNet inst + first <- getDefaultNet inst + (second, third) <- getNet parseCapacity inst + + return (first, second, third) where - randomInstance list = do - n <- randomInSegment segment (1 + ((length list - segment - 1) `div` 4)) - return $ list !! n + randomInstance list = do + n <- randomInSegment segment (1 + ((length list - segment - 1) `div` 4)) + return $ list !! n petriNetFindCapacity :: CapacityConfig -> String petriNetFindCapacity CapacityConfig { @@ -346,25 +334,6 @@ petriNetFindCapacity CapacityConfig { distractors atMostActive -petriNetPickCapacity :: CapacityConfig -> String -petriNetPickCapacity CapacityConfig{ - basicConfig, - advConfig, - maxCapacity, - newArrowsWithComplement, - oneMinCapacity, - distractors, - atMostActive - } = - petriNetFindCapacityAlloy - basicConfig - advConfig - maxCapacity - newArrowsWithComplement - oneMinCapacity - distractors - atMostActive - parseCapacity :: MonadThrow m => AlloyInstance -> m (ActivatedTransitions Object) parseCapacity inst = do t <- unscopedSingleSig inst activatedTransitions "" @@ -481,9 +450,12 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { all p : placesWithCapacity, w : p.flow[Transitions] + Transitions.flow[p] | p.capacity >= w + all p : addedPlaces | some p.flowChange.Int or some p.~(flowChange.Int) + #{newArrowsWithComplementConstraints newArrowsWithComplement} #{oneMinCapacityConstraints oneMinCapacity} #{distractorsConstraints distractors} + Places.flow.Int in Transitions } @@ -580,7 +552,7 @@ checkCapacityConfig BasicConfig { | otherwise = Nothing -defaultCapacityInstance :: CapacityInstance +defaultCapacityInstance :: CapacityInstance SimplePetriNet defaultCapacityInstance = CapacityInstance { drawWith = DrawSettings { withPlaceNames = True, From 24e317432912839d8511e25b538438dd2d073223 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 11 Apr 2025 23:41:29 +0200 Subject: [PATCH 178/256] parseNet now differentiates between CapacityNode and other Node types --- src/Modelling/PetriNet/Diagram.hs | 15 +++++++++------ src/Modelling/PetriNet/Parser.hs | 26 +++++++++++++++++++------- src/Modelling/PetriNet/Pick.hs | 2 +- test/Modelling/PetriNet/DiagramSpec.hs | 2 +- 4 files changed, 30 insertions(+), 15 deletions(-) diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index 9eda113c1..ae6512845 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -98,17 +98,18 @@ getNet -> m (p n String, t String) getNet parseSpecial inst = do (net, rename) <- - getNetWith "flow" "tokens" inst + getNetWith "flow" "tokens" Nothing inst special <- parseSpecial inst renamedSpecial <- traverse rename special return (net, renamedSpecial) getDefaultNet :: (MonadThrow m, Net p n) - => AlloyInstance + => Maybe String + -> AlloyInstance -> m (p n String) -getDefaultNet inst= fst <$> - getNetWith "defaultFlow" "defaultTokens" inst +getDefaultNet c inst = fst <$> + getNetWith "defaultFlow" "defaultTokens" c inst {-| Returns a Petri net like graph using 'parseNet'. @@ -122,11 +123,13 @@ getNetWith -- ^ flow -> String -- ^ tokens + -> Maybe String + -- ^ capacity (optional) -> AlloyInstance -- ^ the instance to parse -> m (p n String, Object -> m String) -getNetWith f t inst = do - pl <- parseNet f t inst +getNetWith f t c inst = do + pl <- parseNet f t c inst let rename = simpleRenameWith pl pl' <- traverseNet rename pl return (pl', rename) diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 8a8c54e1c..21a58e85b 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -28,6 +28,7 @@ import qualified Data.Set as Set ( Set, findMin, fromList, lookupMin, null, size, toList, ) import qualified Data.Map.Lazy as Map ( + empty, findIndex, foldlWithKey', foldrWithKey, @@ -74,7 +75,7 @@ convertPetri -> AlloyInstance -- ^ the Petri net 'AlloyInstance' -> m Petri convertPetri f t inst = do - p <- parseNet f t inst + p <- parseNet f t Nothing inst petriLikeToPetri p {-| @@ -89,7 +90,7 @@ parseRenamedNet -> AlloyInstance -> m (p n String) parseRenamedNet flowSetName tokenSetName inst = do - petriLike <- parseNet flowSetName tokenSetName inst + petriLike <- parseNet flowSetName tokenSetName Nothing inst let rename = simpleRenameWith petriLike traverseNet rename petriLike @@ -110,20 +111,31 @@ parseNet :: (MonadThrow m, Net p n) => String -- ^ the name of the flow set -> String -- ^ the name of the token set + -> Maybe String -- ^ the optional name of the capacity set -> AlloyInstance -- ^ the Petri net 'AlloyInstance' -> m (p n Object) -parseNet flowSetName tokenSetName inst = do +parseNet flowSetName tokenSetName maybeCapacitySetName inst = do nodes <- singleSig inst "this" "Nodes" "" rawTokens <- doubleSig inst "this" "Places" tokenSetName let tokens = relToMap (second oIndex) rawTokens - rawCapacity <- doubleSig inst "this" "placesWithCapacity" "capacity" - let capacities = relToMap (second oIndex) rawCapacity + flow <- tripleSig inst "this" "Nodes" flowSetName + capacities <- case maybeCapacitySetName of + Just capacitySetName -> do + rawCapacity <- doubleSig inst "this" "placesWithCapacity" capacitySetName + return $ relToMap (second oIndex) rawCapacity + Nothing -> return Map.empty + + let applyCapacity net = + case maybeCapacitySetName of + Just _ -> foldrFlip + (\x -> updateCapacity x $ Map.lookup x capacities >>= Set.lookupMin) nodes net + Nothing -> net + return + . applyCapacity . foldrFlip (\(x, y, z) -> alterFlow x (oIndex z) y) flow - . foldrFlip - (\x -> updateCapacity x $ Map.lookup x capacities >>= Set.lookupMin) nodes . foldrFlip (\x -> alterNode x $ Map.lookup x tokens >>= Set.lookupMin) nodes diff --git a/src/Modelling/PetriNet/Pick.hs b/src/Modelling/PetriNet/Pick.hs index 634a90d5b..1fbfeccf0 100644 --- a/src/Modelling/PetriNet/Pick.hs +++ b/src/Modelling/PetriNet/Pick.hs @@ -101,7 +101,7 @@ pickTaskInstance -> m [(p n String, Maybe (t String))] pickTaskInstance parseSpecial inst = do special <- second Just <$> getNet parseSpecial inst - net <- (,Nothing) <$> getDefaultNet inst + net <- (,Nothing) <$> getDefaultNet Nothing inst return [special, net] pickGenerate diff --git a/test/Modelling/PetriNet/DiagramSpec.hs b/test/Modelling/PetriNet/DiagramSpec.hs index 513495453..96d6e1ec5 100644 --- a/test/Modelling/PetriNet/DiagramSpec.hs +++ b/test/Modelling/PetriNet/DiagramSpec.hs @@ -27,7 +27,7 @@ spec = do (inst:_) <- getInstances (Just 1) (petriNetRnd defaultBasicConfig defaultAdvConfig) - pl <- parseNet "flow" "tokens" inst + pl <- parseNet "flow" "tokens" Nothing inst dia <- drawNet show (pl :: SimplePetriLike Object) DrawSettings { withPlaceNames = True, withSvgHighlighting = True, From be003c92835563ad4a437ab7388c09c0d6b40145 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 11 Apr 2025 23:42:46 +0200 Subject: [PATCH 179/256] fixed smaller mistakes --- app/capacity.hs | 4 ++-- src/Modelling/PetriNet/Capacity.hs | 10 ++++------ 2 files changed, 6 insertions(+), 8 deletions(-) diff --git a/app/capacity.hs b/app/capacity.hs index 67d210e0c..e27d8ce1e 100644 --- a/app/capacity.hs +++ b/app/capacity.hs @@ -91,9 +91,9 @@ userInput CapacityConfig{ trns <- validateInput transitions putStr "Highest capacity for a place: " maxCap <- validateInput maxCapacity - putStr "How many new flows are at minimum connected to complement places: " + putStr "How many new arrows are at minimum connected to complement places: " newFlowMin <- validateInput minNewFlowMin - putStr "How many new flows are at maximum connected to complement places: " + putStr "How many new arrows are at maximum connected to complement places: " newFlowMax <- validateInput minNewFlowMax putStr "What capacity should one place at least have: " oneMin <- validateInput oneMinCapacity diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index a79c1bf41..7118c502f 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -110,8 +110,8 @@ import Modelling.PetriNet.Types ( ) import Control.Applicative ((<|>)) -import Control.Monad (void) -import Control.Monad.Catch (MonadThrow) +import Control.Monad (void, when) +import Control.Monad.Catch (MonadThrow, MonadThrow (throwM)) import Control.OutputCapable.Blocks ( ArticleToUse (DefiniteArticle), GenericOutputCapable (..), @@ -134,8 +134,6 @@ import Control.Monad.Random ( evalRandT, mkStdGen ) -import Control.Monad (when) -import Control.Monad.Catch (MonadThrow (throwM)) import Control.Monad.Trans (MonadTrans (lift)) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) @@ -206,7 +204,7 @@ simpleCapacityTask OutputCapable m ) => FilePath - -> CapacityInstance (SimplePetriNet) + -> CapacityInstance SimplePetriNet -> LangM m simpleCapacityTask = capacityTask @@ -306,7 +304,7 @@ combinedCapacity alloyF alloyC config segment = do case drop x list of x':_ -> return x' [] -> randomInstance list - first <- getDefaultNet inst + first <- getDefaultNet (Just "capacity") inst (second, third) <- getNet parseCapacity inst return (first, second, third) From 4fedbae80aac9ad15420b76fb33615380e673dd7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 13 Apr 2025 19:38:11 +0200 Subject: [PATCH 180/256] specialize legality constraint --- src/Modelling/PetriNet/Capacity.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 7118c502f..49b2ccdaf 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -430,8 +430,11 @@ sig placesWithCapacity extends givenPlaces } fact { - noChangesToGivenParts no addedTransitions + no givenPlaces.tokenChange + no givenPlaces.flowChange + Transitions.flowChange.Int in addedPlaces + addedPlaces.flowChange.Int in Transitions } pred #{capacityPredicateName}[#{activated} : set Transitions] { @@ -453,7 +456,6 @@ pred #{capacityPredicateName}[#{activated} : set Transitions] { #{newArrowsWithComplementConstraints newArrowsWithComplement} #{oneMinCapacityConstraints oneMinCapacity} #{distractorsConstraints distractors} - Places.flow.Int in Transitions } From 1e151c6004c543fccf1492dbc8bf54957614db54 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 13 Apr 2025 19:51:31 +0200 Subject: [PATCH 181/256] simplify constraint string building --- src/Modelling/PetriNet/Capacity.hs | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 49b2ccdaf..3067912d6 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -474,18 +474,15 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW Just n -> "#" ++ activated ++ " <= " ++ show n ++ "\n") ++ " theActivatedTransitions[" ++ activated ++ "]" - newArrowsWithComplementConstraints :: (Int, Int) -> String newArrowsWithComplementConstraints (minNewArrowsMin, minNewArrowsMax) = - "#flowChange >= " ++ show minNewArrowsMin ++ "\n" ++ - " #flowChange <= " ++ show minNewArrowsMax - oneMinCapacityConstraints :: Int -> String + "let newArrows = #flowChange | newArrows >= " ++ show minNewArrowsMin ++ + " and newArrows =< " ++ show minNewArrowsMax oneMinCapacityConstraints 1 = "" oneMinCapacityConstraints oneMinCap = [i|some p : placesWithCapacity | p.capacity >= #{oneMinCap}|] - distractorsConstraints :: (Int, Int) -> String distractorsConstraints (distractorsMin, distractorsMax) = - "let distractors = {t: givenTransitions | activatedDefault[t] and t not in " ++ activated ++ "} |" ++ "\n" ++ - " #" ++ "distractors >= " ++ show distractorsMin ++ " and " ++ "#" ++ "distractors <= " ++ show distractorsMax + "let distractors = #{t : Transitions | activatedDefault[t] and t not in " ++ activated ++ "} |\n" ++ + " distractors >= " ++ show distractorsMin ++ " and distractors =< " ++ show distractorsMax capacityPredicateName :: String capacityPredicateName = "showCapacity" From f5c2a2c41c74e58e2b92881847e0f5d95a95cd5e Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 13 Apr 2025 21:03:49 +0200 Subject: [PATCH 182/256] capacity now parses PetriChange for the solution --- src/Modelling/PetriNet/Capacity.hs | 26 ++++++++------------------ src/Modelling/PetriNet/Types.hs | 19 +++++++++++++++++-- 2 files changed, 25 insertions(+), 20 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 3067912d6..ab7bb907f 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -16,7 +16,6 @@ module Modelling.PetriNet.Capacity ( checkCapacityConfigs, defaultCapacityInstance, petriNetFindCapacity, - parseCapacity, parseCapacityPrec, simpleCapacityTask, ) where @@ -39,9 +38,6 @@ import qualified Data.Map as M ( empty, fromList, ) -import qualified Data.Set as Set ( - toList, - ) import Capabilities.Alloy (MonadAlloy, getInstances) import Capabilities.Cache (MonadCache) @@ -51,7 +47,6 @@ import Modelling.Auxiliary.Common ( TaskGenerationException (NoInstanceAvailable), Object, oneOf, - parseWith, ) import Modelling.Auxiliary.Output ( hoveringInformation, @@ -65,8 +60,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConstraints, modulePetriSignature, randomInSegment, - skolemVariable, - unscopedSingleSig, ) import Modelling.PetriNet.Diagram ( getDefaultNet, @@ -82,6 +75,9 @@ import Modelling.PetriNet.Find ( import Modelling.PetriNet.FindActivatedTransitions ( checkActivatedTransitionsConfig, ) +import Modelling.PetriNet.Parser ( + parseChange, + ) import Modelling.PetriNet.Reach.Type ( ShowTransition (ShowTransition), Transition, @@ -154,14 +150,14 @@ import Text.Parsec.String (Parser) data CapacityInstance a = CapacityInstance { drawWith :: !DrawSettings, - toFind :: !(ActivatedTransitions Transition), + toFind :: !(PetriChangeList String), originalNet :: !(PetriLike CapacityNode String), transformedNet :: !a, numberOfPlaces :: !Int, numberOfTransitions :: !Int, showSolution :: !Bool } - deriving (Read, Show) + deriving (Show) capacityGenerate :: (MonadAlloy m, MonadThrow m, Net p n) @@ -175,7 +171,6 @@ capacityGenerate config seed segment = (original, transformed, condition) <- combinedCapacity petriNetFindCapacity Find.alloyConfig config segment - condition' <- lift $ traverse (parseWith parseTransitionPrec) condition return $ CapacityInstance { drawWith = DrawSettings { withPlaceNames = not $ hidePlaceNames gc @@ -184,7 +179,7 @@ capacityGenerate config seed segment = , with1Weights = not $ hideWeight1 gc , withGraphvizCommand = gl } - , toFind = condition' + , toFind = condition , originalNet = original , transformedNet = transformed , numberOfPlaces = places bc @@ -291,7 +286,7 @@ combinedCapacity -> (config -> AlloyConfig) -> config -> Int - -> RandT g m (PetriLike CapacityNode String, p n String, ActivatedTransitions String) + -> RandT g m (PetriLike CapacityNode String, p n String, PetriChangeList String) combinedCapacity alloyF alloyC config segment = do let is = Find.maxInstances (alloyC config) list <- getInstances is (Find.timeout $ alloyC config) (alloyF config) @@ -305,7 +300,7 @@ combinedCapacity alloyF alloyC config segment = do x':_ -> return x' [] -> randomInstance list first <- getDefaultNet (Just "capacity") inst - (second, third) <- getNet parseCapacity inst + (second, third) <- getNet (fmap toChangeList . parseChange) inst return (first, second, third) where @@ -332,11 +327,6 @@ petriNetFindCapacity CapacityConfig { distractors atMostActive -parseCapacity :: MonadThrow m => AlloyInstance -> m (ActivatedTransitions Object) -parseCapacity inst = do - t <- unscopedSingleSig inst activatedTransitions "" - pure $ ActivatedTransitions (Set.toList t) - parseCapacityPrec :: Int -> Parser Capacity parseCapacityPrec _ = do spaces diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index ed8ee799a..91174baa5 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -44,6 +44,7 @@ module Modelling.PetriNet.Types ( NodeC (..), Petri (..), PetriChange (..), + PetriChangeList (..), PetriConflict (..), PetriConflict' (..), PetriLike (..), @@ -105,6 +106,7 @@ module Modelling.PetriNet.Types ( prohibitPatchworkRenderer, randomDrawSettings, shuffleNames, + toChangeList, transformNet, transitionListShow, transitionNames, @@ -129,6 +131,7 @@ import qualified Data.Map.Lazy as M ( mapKeys, member, null, + toList, ) import qualified Data.Set as S (empty, union) @@ -183,6 +186,18 @@ data PetriChange a = Change { } deriving (Eq, Generic, Show) +data PetriChangeList a = ChangeList { + tokenChanges :: [(a, Int)], + flowChanges :: [(a, a, Int)] +} deriving (Eq, Show, Functor, Foldable, Traversable) + +toChangeList :: PetriChange a -> PetriChangeList a +toChangeList (Change tokenMap flowMap) = ChangeList { + tokenChanges = M.toList tokenMap, + flowChanges = [ (source, target, n) | (source, targets) <- M.toList flowMap + , (target, n) <- M.toList targets ] +} + {-| This function acts like 'fmap' on other 'Functor's. @@ -1091,12 +1106,12 @@ data CapacityConfig = CapacityConfig defaultCapacityConfig :: CapacityConfig defaultCapacityConfig = CapacityConfig { basicConfig = defaultBasicConfig { places = 2, transitions = 2, atLeastActive = 1, maxTokensPerPlace = 4, tokensOverall = (2, 8)} - , advConfig = defaultAdvConfig + , advConfig = defaultAdvConfig { presenceOfSinkTransitions = Just True } , maxCapacity = 4 , newArrowsWithComplement = (2, 6) , oneMinCapacity = 2 , atMostActive = Nothing - , distractors = (1, 2) + , distractors = (0, 1) , graphConfig = defaultGraphConfig { hidePlaceNames = False, hideTransitionNames = False } , printSolution = True , useDifferentGraphLayouts = False From 87f785a8a3322f7e82df204e1132161c074e0176 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 13 Apr 2025 21:04:46 +0200 Subject: [PATCH 183/256] updated ...Task --- src/Modelling/PetriNet/Capacity.hs | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index ab7bb907f..c77437a8a 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -220,9 +220,9 @@ capacityTask path task = do english "Consider the following Petri net with capacities:" german "Betrachten Sie folgendes Petrinetz mit Kapazitäten:" image - $=<< renderWith path "capacity" (originalNet task) (drawWith task) + $=<< renderWith path "capacityTask" (originalNet task) (drawWith task) image - $=<< renderWith path "capacity" (transformedNet task) (drawWith task) + $=<< renderWith path "capacitySolution" (transformedNet task) (drawWith task) paragraph $ do translate $ do english [iii| @@ -240,6 +240,20 @@ capacityTask path task = do german [iii| Geben Sie Ihre Antwort in Form eines Tupels an, das aus den Komplementstellen und ihren Flüssen besteht. #{" "}|] + translate $ do + english [i|Stating |] + german [i|Die Angabe von |] + let ts :: ([(String, Int)], [(String, String, Int)]) + ts = ([("s1", 2), ("s2", 0)], [("t1", "s1", 1), ("t2", "s1", 1), ("s2", "t2", 2)]) + code $ show ts + translate $ do + english ("as answer would indicate that there are two complement places - p1 with 2 tokens and p2 with 0 tokens - and t1 points to s1 with a weight of 1, " ++ + "t2 points to s1 with a weight of 1 and s2 connects to t2 with a weight of 2.") + german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - p1 mit 2 Token und p2 mit 0 Token - und t1 zeigt auf s1 mit einem Gewicht von 1, " ++ + "t2 zeigt auf s1 mit einem Gewicht von 1, und s2 ist mit t2 mit einem Gewicht von 2 verbunden.") + translate $ do + english "The order of tupels within the lists does not matter here." + german "Die Reihenfolge der Tupel innerhalb der Listen spielt hierbei keine Rolle." pure () paragraph hoveringInformation pure () From 4ba36421ac30e83f5370b59ff481ecb0f81536bd Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 13 Apr 2025 21:08:58 +0200 Subject: [PATCH 184/256] updated ...Syntax --- src/Modelling/PetriNet/Capacity.hs | 35 +++++++++++++++++++++--------- 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index c77437a8a..92ef5d757 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -79,8 +79,6 @@ import Modelling.PetriNet.Parser ( parseChange, ) import Modelling.PetriNet.Reach.Type ( - ShowTransition (ShowTransition), - Transition, parsePlacePrec, parseTransitionPrec, ) @@ -146,6 +144,7 @@ import Text.Parsec ( import Text.Parsec.Char (digit) import Text.Parsec.Combinator (many1) import Text.Parsec.String (Parser) +import Text.Read (readMaybe) data CapacityInstance a = CapacityInstance { @@ -261,18 +260,34 @@ capacityTask path task = do capacitySyntax :: OutputCapable m => CapacityInstance net - -> [Transition] + -> ([(String, Int)], [(String, String, Int)]) -> LangM' m () -capacitySyntax task input = do - for_ input assertTransition +capacitySyntax task (tokenChanges, flowChanges) = do + for_ tokenChanges assertTokenChanges + for_ flowChanges assertFlowChanges pure () where assert = continueOrAbort False - assertTransition t = assert (isValidTransition t) $ translate $ do - let t' = show $ ShowTransition t - english $ t' ++ " is a transition of the given Petri net?" - german $ t' ++ " ist eine Transition des gegebenen Petrinetzes?" - isValidTransition (Reach.Transition x) = x >= 1 && x <= numberOfTransitions task + + assertTokenChanges (p, tokens) = assert (isValidComplementPlace p && tokens >= 0) $ translate $ do + let p' = show (p, tokens) + english $ p' ++ " is a valid complement place of the resulting Petri net?" + german $ p' ++ " ist eine gültige Komplementstelle des resultierenden Petrinetzes?" + + assertFlowChanges (src, tgt, weight) = assert (((isValidComplementPlace src && isValidTransition tgt) || (isValidTransition src && isValidComplementPlace tgt)) && weight >= 0) $ translate $ do + let t' = show (src, tgt, weight) + english $ t' ++ " is a valid flow of the resulting Petri net?" + german $ t' ++ " ist ein gültiger Fluss des resultierenden Petrinetzes?" + + isValidComplementPlace :: String -> Bool + isValidComplementPlace s = case s of + ('s':rest) -> maybe False (\x -> x >= 1 && x <= (numberOfPlaces task `div` 2)) (readMaybe rest) + _ -> False + + isValidTransition :: String -> Bool + isValidTransition s = case s of + ('t':rest) -> maybe False (\x -> x >= 1 && x <= numberOfTransitions task) (readMaybe rest) + _ -> False capacityEvaluation :: (Monad m, OutputCapable m) From f703d9f86cf8b4c6659e585a164a19e6dfe381a5 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 13 Apr 2025 21:12:11 +0200 Subject: [PATCH 185/256] updated ---Evaluation --- src/Modelling/PetriNet/Capacity.hs | 27 ++++++++++-------------- src/Modelling/PetriNet/Find.hs | 33 +++++++++++++++++++++++++++++- 2 files changed, 43 insertions(+), 17 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 92ef5d757..bb3c4bf39 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -70,7 +70,7 @@ import Modelling.PetriNet.Find ( prohibitHidePlaceNames, prohibitHideTransitionNames, prohibitPatchworkRenderer, - toFindEvaluationList, + toFindEvaluationTupleList, ) import Modelling.PetriNet.FindActivatedTransitions ( checkActivatedTransitionsConfig, @@ -128,13 +128,10 @@ import Control.Monad.Random ( evalRandT, mkStdGen ) -import Control.Monad.Trans (MonadTrans (lift)) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) +import Data.Maybe (fromMaybe) import Data.String.Interpolate (i, iii) -import Language.Alloy.Call ( - AlloyInstance - ) import Text.Parsec ( char, optionMaybe, @@ -292,22 +289,20 @@ capacitySyntax task (tokenChanges, flowChanges) = do capacityEvaluation :: (Monad m, OutputCapable m) => CapacityInstance net - -> [Transition] + -> ([(String, Int)], [(String, String, Int)]) -> Rated m -capacityEvaluation task x = do - let what = translations $ do - english "are activated" - german "sind aktiviert" +capacityEvaluation task (tokenChanges, _) = do + let whatTokens = translations $ do + english "are added complement places" + german "sind hinzugefügte Komplementstellen" uncurry (printSolutionAndAssert DefiniteArticle) - $=<< unLangM $ toFindEvaluationList what withSol active x + $=<< unLangM $ toFindEvaluationTupleList whatTokens withSol tokens tokenChanges where - active = capacitySolution task + (tokens, _) = capacitySolution task withSol = showSolution task -capacitySolution :: CapacityInstance net -> [Transition] -capacitySolution task = active - where - ActivatedTransitions active = toFind task +capacitySolution :: CapacityInstance net -> ([(String, Int)], [(String, String, Int)]) +capacitySolution task = (tokenChanges $ toFind task, flowChanges $ toFind task) combinedCapacity :: (MonadThrow m, RandomGen g, MonadAlloy m, Net p n) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index b8870e86e..9442000f0 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -22,6 +22,8 @@ module Modelling.PetriNet.Find ( toFindEvaluation, toFindEvaluationList, toFindEvaluationTuple, + toFindEvaluationTupleList, + toFindEvaluation3TupleList, toFindSyntax, ) where @@ -70,8 +72,9 @@ import Control.Monad.Random ( RandomGen, ) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Data.List (sort) +import Data.List (sort, sortBy, sortOn) import Data.Map (Map) +import Data.Ord (comparing) import Language.Alloy.Call ( AlloyInstance, ) @@ -170,6 +173,34 @@ toFindEvaluationList toFindEvaluationList what withSol = toFindEvaluation what withSol (\x y -> sort x == sort y) (show . transitionListShow) +toFindEvaluationTupleList + :: (Num a, OutputCapable m) + => Map Language String + -> Bool + -> [(String, Int)] + -> [(String, Int)] + -> LangM' m (Maybe String, a) +toFindEvaluationTupleList what withSol = + toFindEvaluation what withSol (\xs ys -> sortList xs == sortList ys) (show . tokenListShow) + where + sortList = sortBy (comparing fst) + tokenListShow :: [(String, Int)] -> String + tokenListShow = show . sortList + +toFindEvaluation3TupleList + :: (Num a, OutputCapable m) + => Map Language String + -> Bool + -> [(String, String, Int)] + -> [(String, String, Int)] + -> LangM' m (Maybe String, a) +toFindEvaluation3TupleList what withSol = + toFindEvaluation what withSol (\xs ys -> sortFlowList xs == sortFlowList ys) (show . flowListShow) + where + sortFlowList = sortOn (\ (a, b, c) -> (a, b, c)) + flowListShow :: [(String, String, Int)] -> String + flowListShow = show . sortFlowList + checkFindTwoActive :: BasicConfig -> Maybe String checkFindTwoActive BasicConfig { atLeastActive } | atLeastActive < 2 From de0a5d859b9cf5acae086c531fba40eafa31960c Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 13 Apr 2025 21:12:50 +0200 Subject: [PATCH 186/256] updated capacity checks --- src/Modelling/PetriNet/Capacity.hs | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index bb3c4bf39..4174bc46b 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -13,6 +13,7 @@ module Modelling.PetriNet.Capacity ( capacityGenerate, capacitySyntax, capacityTask, + checkCapacityConfig, checkCapacityConfigs, defaultCapacityInstance, petriNetFindCapacity, @@ -523,21 +524,23 @@ checkCapacityConfigs CapacityConfig { <|> checkBasicConfig [snd newArrowsWithComplement, maxCapacity] basicConfig <|> prohibitPatchworkRenderer graphConfig <|> checkActivatedSourceConfig basicConfig advConfig - <|> checkCapacityConfig basicConfig maxCapacity newArrowsWithComplement oneMinCapacity distractors + <|> checkCapacityConfig basicConfig maxCapacity newArrowsWithComplement oneMinCapacity distractors atMostActive <|> checkActivatedTransitionsConfig basicConfig atMostActive -checkCapacityConfig :: BasicConfig -> Int -> (Int, Int) -> Int -> (Int, Int) -> Maybe String +checkCapacityConfig :: BasicConfig -> Int -> (Int, Int) -> Int -> (Int, Int) -> Maybe Int -> Maybe String checkCapacityConfig BasicConfig { places, transitions, atLeastActive, maxTokensPerPlace, - maxFlowPerEdge + maxFlowPerEdge, + isConnected } maxCapacity newArrowsWithComplement oneMinCapacity distractors + atMostActive | maxCapacity < maxFlowPerEdge = Just "'maxCapacity' can not be too low for flow weights." | maxCapacity < maxTokensPerPlace @@ -558,8 +561,12 @@ checkCapacityConfig BasicConfig { = Just "The first element of 'distractors' can not be higher than the second element." | fst distractors < 0 = Just "The first element of 'distractors' can not be negative." + | fst distractors > transitions - fromMaybe transitions atMostActive + = Just "'distractors' can not be higher than the number of transitions." | snd distractors > transitions - atLeastActive = Just "'distractors' can not be higher than the number of transitions." + | isConnected /= Just True + = Just "The petri net must be connected." | otherwise = Nothing From c12c66e5933cf007dcc88be8613640ed9b7f9ccf Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 13 Apr 2025 21:33:05 +0200 Subject: [PATCH 187/256] added new default Instance --- src/Modelling/PetriNet/Capacity.hs | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 4174bc46b..d27d3bf14 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -502,9 +502,6 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW capacityPredicateName :: String capacityPredicateName = "showCapacity" -activatedTransitions :: String -activatedTransitions = skolemVariable capacityPredicateName skolemName - skolemName :: String skolemName = "activatedTrans" @@ -579,25 +576,30 @@ defaultCapacityInstance = CapacityInstance { with1Weights = False, withGraphvizCommand = Circo }, - toFind = ActivatedTransitions [Reach.Transition 1, Reach.Transition 2], +toFind = ChangeList { + tokenChanges = [("s1", 1), ("s2", 0)] + , flowChanges = [("s1", "t2", 1), ("t1", "s1", 1), ("t2", "s2", 1), ("s2", "t1", 1)] + }, originalNet = PetriLike { allNodes = M.fromList [ ("s1",CapacityPlace {initial = 0, capacity = 0, flowIn = M.empty, flowOut = M.empty}), ("s2",CapacityPlace {initial = 0, capacity = 0, flowIn = M.empty, flowOut = M.empty}), - ("s3",CapacityPlace {initial = 1, capacity = 3, flowIn = M.fromList [("t1",2),("t2",2)], flowOut = M.empty}), - ("s4",CapacityPlace {initial = 2, capacity = 4, flowIn = M.empty, flowOut = M.fromList [("t1",1),("t2",2)]}), - ("t1",CapacityTransition {flowIn = M.fromList [("s3",2),("s4",1)], flowOut = M.fromList [("s3",2)]}), - ("t2",CapacityTransition {flowIn = M.fromList [("s3",2),("s4",2)], flowOut = M.fromList [("s3",2)]}) + ("s3",CapacityPlace {initial = 1, capacity = 2, flowIn = M.fromList [("t2",1)], flowOut = M.fromList [("t1",1)]}), + ("s4",CapacityPlace {initial = 0, capacity = 1, flowIn = M.fromList [("t1",1)], flowOut = M.fromList [("t2",1),("t3",1)]}), + ("t1",CapacityTransition {flowIn = M.fromList [("s3",1)], flowOut = M.fromList [("s4",1)]}), + ("t2",CapacityTransition {flowIn = M.fromList [("s4",1)], flowOut = M.fromList [("s3",1)]}), + ("t3",CapacityTransition {flowIn = M.fromList [("s4",1)], flowOut = M.empty}) ] }, transformedNet = PetriLike { allNodes = M.fromList [ - ("s1",SimplePlace {initial = 2, flowOut = M.fromList [("t1",2),("t2",2)]}), - ("s2",SimplePlace {initial = 2, flowOut = M.empty}), - ("s3",SimplePlace {initial = 1, flowOut = M.empty}), - ("s4",SimplePlace {initial = 2, flowOut = M.fromList [("t1",1),("t2",2)]}), - ("t1",SimpleTransition {flowOut = M.fromList [("s2",1),("s3",2)]}), - ("t2",SimpleTransition {flowOut = M.fromList [("s2",2),("s3",2)]}) + ("s1",SimplePlace {initial = 1, flowOut = M.fromList [("t2",1)]}), + ("s2",SimplePlace {initial = 0, flowOut = M.fromList [("s1",1)]}), + ("s3",SimplePlace {initial = 1, flowOut = M.fromList [("t1",1)]}), + ("s4",SimplePlace {initial = 0, flowOut = M.fromList [("t2",1),("t3",1)]}), + ("t1",SimpleTransition {flowOut = M.fromList [("s4",1),("s1",1)]}), + ("t2",SimpleTransition {flowOut = M.fromList [("s3",1),("s2",1)]}), + ("t3",SimpleTransition {flowOut = M.fromList [("s2",1)]}) ] }, numberOfPlaces = 4, From b16d673c55a74e289eb98ec9f61a7cfb00b6315b Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 13 Apr 2025 22:51:09 +0200 Subject: [PATCH 188/256] fixed imports --- src/Modelling/PetriNet/Capacity.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index d27d3bf14..08eadbe60 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -15,6 +15,7 @@ module Modelling.PetriNet.Capacity ( capacityTask, checkCapacityConfig, checkCapacityConfigs, + combinedCapacity, defaultCapacityInstance, petriNetFindCapacity, parseCapacityPrec, @@ -46,7 +47,6 @@ import Capabilities.Diagrams (MonadDiagrams) import Capabilities.Graphviz (MonadGraphviz) import Modelling.Auxiliary.Common ( TaskGenerationException (NoInstanceAvailable), - Object, oneOf, ) import Modelling.Auxiliary.Output ( @@ -84,7 +84,6 @@ import Modelling.PetriNet.Reach.Type ( parseTransitionPrec, ) import Modelling.PetriNet.Types ( - ActivatedTransitions (ActivatedTransitions), AdvConfig (..), AlloyConfig (..), BasicConfig (..), @@ -94,6 +93,7 @@ import Modelling.PetriNet.Types ( GraphConfig (..), Net, NodeC (..), + PetriChangeList (..), PetriLike (PetriLike, allNodes), SimpleNode (..), SimplePetriNet, @@ -102,6 +102,7 @@ import Modelling.PetriNet.Types ( checkActivatedSourceConfig, checkBasicConfig, petriScopeBitWidth, + toChangeList, ) import Control.Applicative ((<|>)) From 126373f9d8c4ff86ed236f446a4bad8760c9f5fa Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Sun, 13 Apr 2025 23:43:34 +0200 Subject: [PATCH 189/256] fixed mistakes --- src/Modelling/PetriNet/Capacity.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 08eadbe60..4bae70b6b 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -250,7 +250,7 @@ capacityTask path task = do german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - p1 mit 2 Token und p2 mit 0 Token - und t1 zeigt auf s1 mit einem Gewicht von 1, " ++ "t2 zeigt auf s1 mit einem Gewicht von 1, und s2 ist mit t2 mit einem Gewicht von 2 verbunden.") translate $ do - english "The order of tupels within the lists does not matter here." + english "The order of tuples within the lists does not matter here." german "Die Reihenfolge der Tupel innerhalb der Listen spielt hierbei keine Rolle." pure () paragraph hoveringInformation @@ -273,7 +273,8 @@ capacitySyntax task (tokenChanges, flowChanges) = do english $ p' ++ " is a valid complement place of the resulting Petri net?" german $ p' ++ " ist eine gültige Komplementstelle des resultierenden Petrinetzes?" - assertFlowChanges (src, tgt, weight) = assert (((isValidComplementPlace src && isValidTransition tgt) || (isValidTransition src && isValidComplementPlace tgt)) && weight >= 0) $ translate $ do + assertFlowChanges (src, tgt, weight) = assert (((isValidComplementPlace src && isValidTransition tgt) || + (isValidTransition src && isValidComplementPlace tgt)) && weight >= 0) $ translate $ do let t' = show (src, tgt, weight) english $ t' ++ " is a valid flow of the resulting Petri net?" german $ t' ++ " ist ein gültiger Fluss des resultierenden Petrinetzes?" From fd2edcee132bf8d447cf2912ac8cd80d5843c2b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 14 Apr 2025 08:57:02 +0200 Subject: [PATCH 190/256] wording --- src/Modelling/PetriNet/Capacity.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 4bae70b6b..3f9ad2ca1 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -561,11 +561,11 @@ checkCapacityConfig BasicConfig { | fst distractors < 0 = Just "The first element of 'distractors' can not be negative." | fst distractors > transitions - fromMaybe transitions atMostActive - = Just "'distractors' can not be higher than the number of transitions." + = Just "'fst distractors' is set unreasonably high, given atMostActive." | snd distractors > transitions - atLeastActive - = Just "'distractors' can not be higher than the number of transitions." + = Just "'snd distractors' is set unreasonably high, given atLeastActive." | isConnected /= Just True - = Just "The petri net must be connected." + = Just "The Petri net must be connected." | otherwise = Nothing From d243a2e62c64a389760c0ddbf21612974360a1a3 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 00:03:43 +0200 Subject: [PATCH 191/256] added capacities to conversion from net to graph --- src/Modelling/PetriNet/Parser.hs | 21 +++++++++++++++++++++ src/Modelling/PetriNet/Types.hs | 6 ++++++ 2 files changed, 27 insertions(+) diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 21a58e85b..bb4a4489e 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -11,6 +11,7 @@ module Modelling.PetriNet.Parser ( asSingleton, convertPetri, netToGr, + netToGrCapacity, parseChange, parseNet, parseRenamedNet, @@ -41,6 +42,8 @@ import Modelling.PetriNet.Types ( Petri, PetriChange (..), PetriNode (..), + PetriNodeWithCapacity (..), + maybeCapacity, maybeInitial, petriLikeToPetri, ) @@ -280,3 +283,21 @@ netToGr petriLike = do indexOf x = Map.findIndex x $ PN.nodes petriLike convertEdge source target flow rs = (indexOf source, indexOf target, flow) : rs + +netToGrCapacity + :: (Monad m, Net p n, Ord a, PetriNodeWithCapacity n) + => p n a + -> m (Gr (a, Maybe Int, Maybe Int) Int) +netToGrCapacity petriLike = do + nodes <- Map.foldrWithKey convertNode (return []) $ PN.nodes petriLike + let edges = Map.foldrWithKey convertTransition [] $ PN.nodes petriLike + return $ mkGraph nodes edges + where + convertNode k x ns = do + ns' <- ns + return $ (indexOf k, (k, maybeInitial x, maybeCapacity x)):ns' + convertTransition k _ ns = + Map.foldrWithKey (convertEdge k) ns $ outFlow k petriLike + indexOf x = Map.findIndex x $ PN.nodes petriLike + convertEdge source target flow rs = + (indexOf source, indexOf target, flow) : rs diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 91174baa5..fba572c9c 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -99,6 +99,7 @@ module Modelling.PetriNet.Types ( lUniqueConflictPlace, manyRandomDrawSettings, mapChange, + maybeCapacity, maybeInitial, petriLikeToPetri, petriScopeBitWidth, @@ -437,6 +438,11 @@ maybeInitial n | isPlaceNode n = Just $ initialTokens n | otherwise = Nothing +maybeCapacity :: PetriNodeWithCapacity n => n a -> Maybe Int +maybeCapacity n + | isPlaceNode n = Just $ capacityPlace n + | otherwise = Nothing + {-| A specific traversal for 'Map's changing the keys rather than values. That is why, the result requires an 'Ord' instance. From 5757247c4055bcfa32f3dd9166943d4f76320fba Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 00:07:36 +0200 Subject: [PATCH 192/256] capacities are added to the shown net as a number --- src/Modelling/PetriNet/Capacity.hs | 5 +- src/Modelling/PetriNet/Diagram.hs | 145 +++++++++++++++++++++++++++++ 2 files changed, 148 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 3f9ad2ca1..9be3b4204 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -66,6 +66,7 @@ import Modelling.PetriNet.Diagram ( getDefaultNet, getNet, renderWith, + renderWithCapacity, ) import Modelling.PetriNet.Find ( prohibitHidePlaceNames, @@ -218,7 +219,7 @@ capacityTask path task = do english "Consider the following Petri net with capacities:" german "Betrachten Sie folgendes Petrinetz mit Kapazitäten:" image - $=<< renderWith path "capacityTask" (originalNet task) (drawWith task) + $=<< renderWithCapacity path "capacityTask" (originalNet task) (drawWith task) image $=<< renderWith path "capacitySolution" (transformedNet task) (drawWith task) paragraph $ do @@ -299,7 +300,7 @@ capacityEvaluation task (tokenChanges, _) = do english "are added complement places" german "sind hinzugefügte Komplementstellen" uncurry (printSolutionAndAssert DefiniteArticle) - $=<< unLangM $ toFindEvaluationTupleList whatTokens withSol tokens tokenChanges + $=<< unLangM $ toFindEvaluation2TupleList whatTokens withSol tokens tokenChanges where (tokens, _) = capacitySolution task withSol = showSolution task diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index ae6512845..80a02f4e0 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -7,10 +7,13 @@ Provides the ability to render Petri nets. -} module Modelling.PetriNet.Diagram ( cacheNet, + cacheNetCapacity, drawNet, + drawNetWithCapacity, getDefaultNet, getNet, renderWith, + renderWithCapacity, ) where import qualified Diagrams.TwoD.GraphViz as GV (getGraph) @@ -28,12 +31,14 @@ import Modelling.Auxiliary.Diagrams ( ) import Modelling.PetriNet.Parser ( netToGr, + netToGrCapacity, parseNet, simpleRenameWith, ) import Modelling.PetriNet.Types ( DrawSettings (..), Net (mapNet, traverseNet), + PetriNodeWithCapacity (..), ) import Control.Arrow (first) @@ -65,6 +70,25 @@ cacheNet path labelOf pl drawSettings@DrawSettings {..} = ++ short withGraphvizCommand ++ ".svg" +cacheNetCapacity + :: (MonadCache m, MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n, PetriNodeWithCapacity n) + => String + -> (a -> String) + -> p n a + -> DrawSettings + -> m FilePath +cacheNetCapacity path labelOf pl drawSettings@DrawSettings {..} = + cache path ext "petri" (mapNet labelOf pl) $ \svg pl' -> do + dia <- drawNetWithCapacity id pl' drawSettings + writeSvg svg dia + where + ext = short withPlaceNames + ++ short withTransitionNames + ++ short with1Weights + ++ short withSvgHighlighting + ++ short withGraphvizCommand + ++ ".svg" + newtype UnknownPetriNetNodeException = CouldNotFindNodeWithinGraph String deriving Show @@ -91,6 +115,19 @@ drawNet labelOf pl drawSettings@DrawSettings {..} = do preparedFont <- lin return $ drawGraph labelOf drawSettings preparedFont graph +drawNetWithCapacity + :: (MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n, Ord a, PetriNodeWithCapacity n) + => (a -> String) + -> p n a + -> DrawSettings + -> m (Diagram B) +drawNetWithCapacity labelOf pl drawSettings@DrawSettings {..} = do + gr <- either (throwM . CouldNotFindNodeWithinGraph . labelOf) return + $ netToGrCapacity pl + graph <- layoutGraph withGraphvizCommand gr + preparedFont <- lin + return $ drawGraphWithCapacity labelOf drawSettings preparedFont graph + getNet :: (MonadThrow m, Net p n, Traversable t) => (AlloyInstance -> m (t Object)) @@ -176,6 +213,42 @@ drawGraph labelOf drawSettings@DrawSettings {..} preparedFont graph = withLabel = first labelOf labelOnly = labelOf . fst +drawGraphWithCapacity + :: Ord a + => (a -> String) + -> DrawSettings + -> PreparedFont Double + -> Gr (AttributeNode (a, Maybe Int, Maybe Int)) (AttributeEdge Int) + -> Diagram B +drawGraphWithCapacity labelOf drawSettings@DrawSettings {..} preparedFont graph = + graphEdges' # frame 1 + where + (nodes, edges) = GV.getGraph graph + graphNodes' = M.foldlWithKey + (\g l p -> g + `atop` + drawNodeCapacity drawSettings preparedFont (withLabelC l) p) + mempty + nodes + graphEdges' = foldl + (\g (s, t, l, p) -> + let ls = labelOnly s + lt = labelOnly t + in g # drawEdge + (not with1Weights) + preparedFont + l + ls + lt + (nonEmptyPathBetween p ls lt g) + ) + graphNodes' + edges + + withLabelC (x, tokens, cap) = (labelOf x, tokens, cap) + + labelOnly = labelOf . (\(x, _, _) -> x) + {-| Nodes are either Places (having 'Just' tokens), or Transitions (having 'Nothing'). @@ -233,6 +306,68 @@ drawNode DrawSettings {..} preparedFont (l, Just i) p # translate (r2 (8 * sqrt(fromIntegral (i - 1)), 0)) # rotateBy (fromIntegral j / fromIntegral i) +drawNodeCapacity + :: DrawSettings + -> PreparedFont Double + -> (String, Maybe Int, Maybe Int) + -- ^ a capacity node (the first part is used for its label) with a capacity + -> Point V2 Double + -> Diagram B +drawNodeCapacity DrawSettings {..} preparedFont (l, Nothing, cap) p = + place + (addTransitionName $ rect 20 20 # lwL 0.5 # named l # svgClass "rect" # additionalLabel <> capacityLabel) + p + where + additionalLabel + | withSvgHighlighting = id + | otherwise = svgClass $ ' ' : l + addTransitionName + | not withTransitionNames = id + | otherwise = (center (text' preparedFont 18 l) `atop`) + capacityLabel = maybe mempty (drawCapacity preparedFont) cap + +drawNodeCapacity DrawSettings {..} preparedFont (l, Just i, cap) p + | i == 0 && cap == Just 0 = + place (foldl' atop mempty tokens) p + | i < 5 = + place (foldl' atop label (tokens ++ [emptyPlace, capacityLabel])) p + | otherwise = + place (foldl' atop label + [ token # translate (r2 (spacer, 0)) + , text' preparedFont 20 (show i) # translate (r2 (-spacer,-4)) + , emptyPlace + , capacityLabel + ]) p + where + spacer = 9 + additionalLabel + | withSvgHighlighting = id + | otherwise = svgClass $ ' ' : l + emptyPlace = circle 20 # lwL 0.5 # named l # svgClass "node" # additionalLabel + label + | not withPlaceNames = mempty + | otherwise = center (text' preparedFont 18 l) + # translate (r2 (0, - (3 * spacer))) + # svgClass "nlabel" + tokenGrey = sRGB24 136 136 136 + token = circle 4.5 # lc tokenGrey # fc tokenGrey # lwL 0 # svgClass "token" + tokens = [placeToken j | j <- [1..i]] + placeToken j = token + # translate (r2 (8 * sqrt (fromIntegral (i - 1)), 0)) + # rotateBy (fromIntegral j / fromIntegral i) + capacityLabel = maybe mempty (drawCapacity preparedFont) cap + +drawCapacity + :: PreparedFont Double + -> Int + -> Diagram B +drawCapacity fontC cap = + case cap of + 0 -> mempty + _ -> text' fontC 18 (show cap) + # translate (r2 (0, 25)) + # svgClass "capacity" + {-| Edges are drawn as arcs between nodes (identified by labels). -} @@ -277,3 +412,13 @@ renderWith -> DrawSettings -> m FilePath renderWith path task = cacheNet (path ++ task) id + +renderWithCapacity + :: (MonadCache m, MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n, PetriNodeWithCapacity n) + => String + -> String + -> p n String + -> DrawSettings + -> m FilePath +renderWithCapacity path task = cacheNetCapacity (path ++ task) id + From 6b2313ea0f0c010276455e70bddc62a6dbbfc141 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 00:05:02 +0200 Subject: [PATCH 193/256] renamed several spots --- src/Modelling/PetriNet/Capacity.hs | 20 ++++++++++---------- src/Modelling/PetriNet/Find.hs | 6 +++--- 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 9be3b4204..025909b53 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -72,7 +72,7 @@ import Modelling.PetriNet.Find ( prohibitHidePlaceNames, prohibitHideTransitionNames, prohibitPatchworkRenderer, - toFindEvaluationTupleList, + toFindEvaluation2TupleList, ) import Modelling.PetriNet.FindActivatedTransitions ( checkActivatedTransitionsConfig, @@ -246,10 +246,10 @@ capacityTask path task = do ts = ([("s1", 2), ("s2", 0)], [("t1", "s1", 1), ("t2", "s1", 1), ("s2", "t2", 2)]) code $ show ts translate $ do - english ("as answer would indicate that there are two complement places - p1 with 2 tokens and p2 with 0 tokens - and t1 points to s1 with a weight of 1, " ++ - "t2 points to s1 with a weight of 1 and s2 connects to t2 with a weight of 2.") - german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - p1 mit 2 Token und p2 mit 0 Token - und t1 zeigt auf s1 mit einem Gewicht von 1, " ++ - "t2 zeigt auf s1 mit einem Gewicht von 1, und s2 ist mit t2 mit einem Gewicht von 2 verbunden.") + english ("as answer would indicate that there are two complement places - p3 with 2 tokens and p4 with 0 tokens - and t1 points to s1 with a weight of 1, " ++ + "t2 points to s3 with a weight of 1 and s4 connects to t2 with a weight of 2.") + german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - s3 mit 2 Token und s4 mit 0 Token - und t1 zeigt auf s3 mit einem Gewicht von 1, " ++ + "t2 zeigt auf s3 mit einem Gewicht von 1, und s4 ist mit t2 mit einem Gewicht von 2 verbunden.") translate $ do english "The order of tuples within the lists does not matter here." german "Die Reihenfolge der Tupel innerhalb der Listen spielt hierbei keine Rolle." @@ -271,18 +271,18 @@ capacitySyntax task (tokenChanges, flowChanges) = do assertTokenChanges (p, tokens) = assert (isValidComplementPlace p && tokens >= 0) $ translate $ do let p' = show (p, tokens) - english $ p' ++ " is a valid complement place of the resulting Petri net?" - german $ p' ++ " ist eine gültige Komplementstelle des resultierenden Petrinetzes?" + english $ p' ++ " is a semantically correct complement place of the Petri net?" + german $ p' ++ " ist eine semantisch korrekte Komplementstelle des Petrinetzes?" assertFlowChanges (src, tgt, weight) = assert (((isValidComplementPlace src && isValidTransition tgt) || (isValidTransition src && isValidComplementPlace tgt)) && weight >= 0) $ translate $ do let t' = show (src, tgt, weight) - english $ t' ++ " is a valid flow of the resulting Petri net?" - german $ t' ++ " ist ein gültiger Fluss des resultierenden Petrinetzes?" + english $ t' ++ " is a semantically correct flow of the Petri net?" + german $ t' ++ " ist ein semantisch korrekter Fluss des Petrinetzes?" isValidComplementPlace :: String -> Bool isValidComplementPlace s = case s of - ('s':rest) -> maybe False (\x -> x >= 1 && x <= (numberOfPlaces task `div` 2)) (readMaybe rest) + ('s':rest) -> maybe False (\x -> x >= 1 && x < (numberOfPlaces task - (numberOfPlaces task `div` 2))) (readMaybe rest) _ -> False isValidTransition :: String -> Bool diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 9442000f0..a419c2698 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -22,7 +22,7 @@ module Modelling.PetriNet.Find ( toFindEvaluation, toFindEvaluationList, toFindEvaluationTuple, - toFindEvaluationTupleList, + toFindEvaluation2TupleList, toFindEvaluation3TupleList, toFindSyntax, ) where @@ -173,14 +173,14 @@ toFindEvaluationList toFindEvaluationList what withSol = toFindEvaluation what withSol (\x y -> sort x == sort y) (show . transitionListShow) -toFindEvaluationTupleList +toFindEvaluation2TupleList :: (Num a, OutputCapable m) => Map Language String -> Bool -> [(String, Int)] -> [(String, Int)] -> LangM' m (Maybe String, a) -toFindEvaluationTupleList what withSol = +toFindEvaluation2TupleList what withSol = toFindEvaluation what withSol (\xs ys -> sortList xs == sortList ys) (show . tokenListShow) where sortList = sortBy (comparing fst) From 01d2e73ab1dc4513ca395f80831124231d45160e Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 00:15:34 +0200 Subject: [PATCH 194/256] fixed mistakes --- src/Modelling/PetriNet/Capacity.hs | 7 ++----- src/Modelling/PetriNet/Find.hs | 6 ++---- 2 files changed, 4 insertions(+), 9 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 025909b53..1660b042d 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -100,7 +100,6 @@ import Modelling.PetriNet.Types ( SimplePetriNet, CapacityNode (..), basicConfigBitWidthInput, - checkActivatedSourceConfig, checkBasicConfig, petriScopeBitWidth, toChangeList, @@ -243,7 +242,7 @@ capacityTask path task = do english [i|Stating |] german [i|Die Angabe von |] let ts :: ([(String, Int)], [(String, String, Int)]) - ts = ([("s1", 2), ("s2", 0)], [("t1", "s1", 1), ("t2", "s1", 1), ("s2", "t2", 2)]) + ts = ([("s3",2), ("s4",0)], [("t1","s3",1), ("t2","s3",1), ("s4","t2",2)]) code $ show ts translate $ do english ("as answer would indicate that there are two complement places - p3 with 2 tokens and p4 with 0 tokens - and t1 points to s1 with a weight of 1, " ++ @@ -275,7 +274,7 @@ capacitySyntax task (tokenChanges, flowChanges) = do german $ p' ++ " ist eine semantisch korrekte Komplementstelle des Petrinetzes?" assertFlowChanges (src, tgt, weight) = assert (((isValidComplementPlace src && isValidTransition tgt) || - (isValidTransition src && isValidComplementPlace tgt)) && weight >= 0) $ translate $ do + (isValidTransition src && isValidComplementPlace tgt)) && weight > 0) $ translate $ do let t' = show (src, tgt, weight) english $ t' ++ " is a semantically correct flow of the Petri net?" german $ t' ++ " ist ein semantisch korrekter Fluss des Petrinetzes?" @@ -511,7 +510,6 @@ skolemName = "activatedTrans" checkCapacityConfigs :: CapacityConfig -> Maybe String checkCapacityConfigs CapacityConfig { basicConfig, - advConfig, maxCapacity, newArrowsWithComplement, oneMinCapacity, @@ -523,7 +521,6 @@ checkCapacityConfigs CapacityConfig { <|> prohibitHideTransitionNames graphConfig <|> checkBasicConfig [snd newArrowsWithComplement, maxCapacity] basicConfig <|> prohibitPatchworkRenderer graphConfig - <|> checkActivatedSourceConfig basicConfig advConfig <|> checkCapacityConfig basicConfig maxCapacity newArrowsWithComplement oneMinCapacity distractors atMostActive <|> checkActivatedTransitionsConfig basicConfig atMostActive diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index a419c2698..ae123bc3c 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -181,10 +181,9 @@ toFindEvaluation2TupleList -> [(String, Int)] -> LangM' m (Maybe String, a) toFindEvaluation2TupleList what withSol = - toFindEvaluation what withSol (\xs ys -> sortList xs == sortList ys) (show . tokenListShow) + toFindEvaluation what withSol (\xs ys -> sortList xs == sortList ys) tokenListShow where sortList = sortBy (comparing fst) - tokenListShow :: [(String, Int)] -> String tokenListShow = show . sortList toFindEvaluation3TupleList @@ -195,10 +194,9 @@ toFindEvaluation3TupleList -> [(String, String, Int)] -> LangM' m (Maybe String, a) toFindEvaluation3TupleList what withSol = - toFindEvaluation what withSol (\xs ys -> sortFlowList xs == sortFlowList ys) (show . flowListShow) + toFindEvaluation what withSol (\xs ys -> sortFlowList xs == sortFlowList ys) flowListShow where sortFlowList = sortOn (\ (a, b, c) -> (a, b, c)) - flowListShow :: [(String, String, Int)] -> String flowListShow = show . sortFlowList checkFindTwoActive :: BasicConfig -> Maybe String From b7fb63e26cc7fe96359300ceb056d4123a3783df Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 23:36:46 +0200 Subject: [PATCH 195/256] remove NodeC from files --- src/Modelling/PetriNet/Capacity.hs | 11 ++++------- src/Modelling/PetriNet/Types.hs | 6 +----- 2 files changed, 5 insertions(+), 12 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 1660b042d..725cba2ad 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -33,9 +33,6 @@ import qualified Modelling.PetriNet.Types as Find ( import qualified Modelling.PetriNet.Types as Pick ( CapacityConfig (..), ) -import qualified Modelling.PetriNet.Types as Types ( - NodeC(..) - ) import qualified Data.Map as M ( empty, fromList, @@ -406,16 +403,16 @@ parseCapacityPrec _ = do parseInt = read <$> many1 digit - parseNodeC :: Parser NodeC + parseNodeC :: Parser String parseNodeC = do - tag <- optionMaybe (char 'p') + tag <- optionMaybe (char 's') case tag of Just _ -> do Reach.Place n <- parsePlacePrec 0 - return $ Types.Place (show n) + return $ show n Nothing -> do Reach.Transition n <- parseTransitionPrec 0 - return $ Types.Transition (show n) + return $ show n petriNetFindCapacityAlloy :: BasicConfig diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index fba572c9c..a88ec815e 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -41,7 +41,6 @@ module Modelling.PetriNet.Types ( MistakeConfig (..), Net (..), Node (..), - NodeC (..), Petri (..), PetriChange (..), PetriChangeList (..), @@ -264,10 +263,7 @@ newtype Concurrent a = Concurrent (a, a) newtype ActivatedTransitions a = ActivatedTransitions [a] deriving (Functor, Foldable, Traversable, Generic, Read, Show) -data NodeC = Place String | Transition String - deriving (Eq, Ord, Read, Show, Generic) - -newtype Capacity = Capacity ([(Place, Int)], [(NodeC, NodeC, Int)]) +newtype Capacity = Capacity ([(Place, Int)], [(String, String, Int)]) deriving (Generic, Read, Show) class Show (n String) => PetriNode n where From c38c21c703fc4062b558510cbcb8bf5306c4ad01 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 23:37:23 +0200 Subject: [PATCH 196/256] prepare tests --- src/Modelling/PetriNet/Capacity.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 725cba2ad..d77493ebe 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -16,6 +16,7 @@ module Modelling.PetriNet.Capacity ( checkCapacityConfig, checkCapacityConfigs, combinedCapacity, + combinedCapacityInstance, defaultCapacityInstance, petriNetFindCapacity, parseCapacityPrec, @@ -164,7 +165,7 @@ capacityGenerate config seed segment = flip evalRandT (mkStdGen seed) $ do gl <- oneOf $ graphLayouts gc - (original, transformed, condition) <- combinedCapacity petriNetFindCapacity Find.alloyConfig config segment + (original, transformed, condition) <- combinedCapacityInstance config segment return $ CapacityInstance { drawWith = DrawSettings @@ -185,6 +186,15 @@ capacityGenerate config seed segment = bc = Find.basicConfig config gc = Pick.graphConfig config +combinedCapacityInstance + :: (MonadThrow m, RandomGen g, MonadAlloy m, Net p n) + => CapacityConfig + -> Int + -> RandT g m (PetriLike CapacityNode String, p n String, PetriChangeList String) +combinedCapacityInstance = combinedCapacity + petriNetFindCapacity + Find.alloyConfig + simpleCapacityTask :: ( MonadCache m, From 9bdf4d446e7a65bccb6c758920231128c702460c Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 23:38:59 +0200 Subject: [PATCH 197/256] update capacityEvaluation to also evaluate the second list --- src/Modelling/PetriNet/Capacity.hs | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index d77493ebe..70c366ea6 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -71,6 +71,7 @@ import Modelling.PetriNet.Find ( prohibitHideTransitionNames, prohibitPatchworkRenderer, toFindEvaluation2TupleList, + toFindEvaluation3TupleList, ) import Modelling.PetriNet.FindActivatedTransitions ( checkActivatedTransitionsConfig, @@ -91,7 +92,6 @@ import Modelling.PetriNet.Types ( DrawSettings (..), GraphConfig (..), Net, - NodeC (..), PetriChangeList (..), PetriLike (PetriLike, allNodes), SimpleNode (..), @@ -103,7 +103,7 @@ import Modelling.PetriNet.Types ( toChangeList, ) -import Control.Applicative ((<|>)) +import Control.Applicative ((<|>), liftA2) import Control.Monad (void, when) import Control.Monad.Catch (MonadThrow, MonadThrow (throwM)) import Control.OutputCapable.Blocks ( @@ -301,15 +301,24 @@ capacityEvaluation => CapacityInstance net -> ([(String, Int)], [(String, String, Int)]) -> Rated m -capacityEvaluation task (tokenChanges, _) = do +capacityEvaluation task (tokenChanges, flowChanges) = do let whatTokens = translations $ do english "are added complement places" german "sind hinzugefügte Komplementstellen" + let whatFlows = translations $ do + english "The given tuples are added flows?" + german "Die angegebenen Tupel sind hinzugefügte Flüsse?" uncurry (printSolutionAndAssert DefiniteArticle) - $=<< unLangM $ toFindEvaluation2TupleList whatTokens withSol tokens tokenChanges + $=<< unLangM $ liftA2 combineResults + (toFindEvaluation2TupleList whatTokens withSol tokens tokenChanges) + (toFindEvaluation3TupleList whatFlows withSol flows flowChanges) + where - (tokens, _) = capacitySolution task + (tokens, flows) = capacitySolution task withSol = showSolution task + combineResults (list1, points1) (list2, points2) = (combineLists list1 list2, points1 * points2) + combineLists :: Maybe String -> Maybe String -> Maybe String + combineLists = liftA2 (\string1 string2 -> string1 ++ "," ++ string2) capacitySolution :: CapacityInstance net -> ([(String, Int)], [(String, String, Int)]) capacitySolution task = (tokenChanges $ toFind task, flowChanges $ toFind task) From 7d1a618627948ec72f0d385cfe3185121a47236e Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 23:40:10 +0200 Subject: [PATCH 198/256] text in Find.hs does not fit every task type --- src/Modelling/PetriNet/Capacity.hs | 4 ++-- src/Modelling/PetriNet/Concurrency.hs | 4 ++-- src/Modelling/PetriNet/Conflict.hs | 4 ++-- src/Modelling/PetriNet/Find.hs | 4 ++-- src/Modelling/PetriNet/FindActivatedTransitions.hs | 4 ++-- 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 70c366ea6..eaae87270 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -303,8 +303,8 @@ capacityEvaluation -> Rated m capacityEvaluation task (tokenChanges, flowChanges) = do let whatTokens = translations $ do - english "are added complement places" - german "sind hinzugefügte Komplementstellen" + english "The given tuples are added complement places?" + german "Die angegebenen Tupel sind hinzugefügte Komplementstellen?" let whatFlows = translations $ do english "The given tuples are added flows?" german "Die angegebenen Tupel sind hinzugefügte Flüsse?" diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index a3cce9130..29f068790 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -233,8 +233,8 @@ findConcurrencyEvaluation -> Rated m findConcurrencyEvaluation task x = do let what = translations $ do - english "are concurrently activated" - german "sind nebenläufig aktiviert" + english "The given transitions are concurrently activated?" + german "Die angegebenen Transitionen sind nebenläufig aktiviert?" uncurry (printSolutionAndAssert DefiniteArticle) $=<< unLangM $ toFindEvaluationTuple what withSol concur x where diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index 752f07f5a..e498895e6 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -289,8 +289,8 @@ findConflictPlacesEvaluation task (conflict, ps) = base = fromIntegral $ 2 + numberOfPlaces task size = fromIntegral . length what = translations $ do - english "have a conflict" - german "haben einen Konflikt" + english "The given transitions have a conflict" + german "Die angegebenen Transitionen haben einen Konflikt" findConflictPlacesSolution :: FindInstance n (PetriConflict p t) -> ((t, t), [p]) findConflictPlacesSolution task = diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index ae123bc3c..9067bcd0d 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -144,8 +144,8 @@ toFindEvaluation what withSol isCorrect format correctValue inputValue = do then Just $ format correctValue else Nothing assert correct $ translate $ do - english $ "The given transitions " ++ localise English what ++ "?" - german $ "Die angegebenen Transitionen " ++ localise German what ++ "?" + english $ localise English what + german $ localise German what pure (maybeSolutionString, points) where assert = continueOrAbort withSol diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index 6801b8819..dffd06878 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -249,8 +249,8 @@ findActivatedTransitionsEvaluation -> Rated m findActivatedTransitionsEvaluation task x = do let what = translations $ do - english "are activated" - german "sind aktiviert" + english "The given transitions are activated?" + german "Die angegebenen Transitionen sind aktiviert?" uncurry (printSolutionAndAssert DefiniteArticle) $=<< unLangM $ toFindEvaluationList what withSol active x where From d854de065e5483fa01ddcbfd01765fe12fb1c6aa Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 23:44:09 +0200 Subject: [PATCH 199/256] complement places are for now the first labeled places --- src/Modelling/PetriNet/Capacity.hs | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index eaae87270..1379b5a1e 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -249,13 +249,16 @@ capacityTask path task = do english [i|Stating |] german [i|Die Angabe von |] let ts :: ([(String, Int)], [(String, String, Int)]) - ts = ([("s3",2), ("s4",0)], [("t1","s3",1), ("t2","s3",1), ("s4","t2",2)]) + ts = ([("s1",2), ("s2",0)], [("t1","s1",1), ("t2","s1",1), ("s2","t2",2)]) code $ show ts translate $ do - english ("as answer would indicate that there are two complement places - p3 with 2 tokens and p4 with 0 tokens - and t1 points to s1 with a weight of 1, " ++ - "t2 points to s3 with a weight of 1 and s4 connects to t2 with a weight of 2.") - german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - s3 mit 2 Token und s4 mit 0 Token - und t1 zeigt auf s3 mit einem Gewicht von 1, " ++ - "t2 zeigt auf s3 mit einem Gewicht von 1, und s4 ist mit t2 mit einem Gewicht von 2 verbunden.") + english ("as answer would indicate that there are two complement places - s1 with 2 tokens and s2 with 0 tokens - and t1 points to s1 with a weight of 1, " ++ + "t2 points to s1 with a weight of 1 and s2 connects to t2 with a weight of 2.") + german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - s1 mit 2 Token und s2 mit 0 Token - und t1 zeigt auf s1 mit einem Gewicht von 1, " ++ + "t2 zeigt auf s1 mit einem Gewicht von 1, und s2 ist mit t2 mit einem Gewicht von 2 verbunden.") + translate $ do + english "The first complement place s1 belongs to the first shown place s3, the second complement place s2 belongs to the second shown place s4 and so on." + german "Die erste Komplementstelle s1 gehört zu der ersten gezeigten Stelle s3, die zweite Komplementstelle s2 gehört zu der zweiten gezeigten Stelle s4 und so weiter." translate $ do english "The order of tuples within the lists does not matter here." german "Die Reihenfolge der Tupel innerhalb der Listen spielt hierbei keine Rolle." @@ -277,14 +280,14 @@ capacitySyntax task (tokenChanges, flowChanges) = do assertTokenChanges (p, tokens) = assert (isValidComplementPlace p && tokens >= 0) $ translate $ do let p' = show (p, tokens) - english $ p' ++ " is a semantically correct complement place of the Petri net?" - german $ p' ++ " ist eine semantisch korrekte Komplementstelle des Petrinetzes?" + english $ p' ++ " has a structurally correct form of a complement place?" + german $ p' ++ " hat eine strukturell korrekte Form einer Komplementstelle?" assertFlowChanges (src, tgt, weight) = assert (((isValidComplementPlace src && isValidTransition tgt) || (isValidTransition src && isValidComplementPlace tgt)) && weight > 0) $ translate $ do let t' = show (src, tgt, weight) - english $ t' ++ " is a semantically correct flow of the Petri net?" - german $ t' ++ " ist ein semantisch korrekter Fluss des Petrinetzes?" + english $ t' ++ " has a structurally correct form of a flow?" + german $ t' ++ " hat eine strukturell korrekte Form eines Flusses?" isValidComplementPlace :: String -> Bool isValidComplementPlace s = case s of From 31f2a67c65d3cee06936c7619a64e441d6a88dfe Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 23:44:58 +0200 Subject: [PATCH 200/256] simplfied toFindEvaluation functions --- src/Modelling/PetriNet/Find.hs | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 9067bcd0d..583795561 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -72,9 +72,8 @@ import Control.Monad.Random ( RandomGen, ) import Control.Monad.Trans.Class (MonadTrans (lift)) -import Data.List (sort, sortBy, sortOn) +import Data.List (sort) import Data.Map (Map) -import Data.Ord (comparing) import Language.Alloy.Call ( AlloyInstance, ) @@ -181,10 +180,7 @@ toFindEvaluation2TupleList -> [(String, Int)] -> LangM' m (Maybe String, a) toFindEvaluation2TupleList what withSol = - toFindEvaluation what withSol (\xs ys -> sortList xs == sortList ys) tokenListShow - where - sortList = sortBy (comparing fst) - tokenListShow = show . sortList + toFindEvaluation what withSol (\xs ys -> sort xs == sort ys) (show . sort) toFindEvaluation3TupleList :: (Num a, OutputCapable m) @@ -194,10 +190,7 @@ toFindEvaluation3TupleList -> [(String, String, Int)] -> LangM' m (Maybe String, a) toFindEvaluation3TupleList what withSol = - toFindEvaluation what withSol (\xs ys -> sortFlowList xs == sortFlowList ys) flowListShow - where - sortFlowList = sortOn (\ (a, b, c) -> (a, b, c)) - flowListShow = show . sortFlowList + toFindEvaluation what withSol (\xs ys -> sort xs == sort ys) (show . sort) checkFindTwoActive :: BasicConfig -> Maybe String checkFindTwoActive BasicConfig { atLeastActive } From ae8c874e67e0c48b0fd92f88d1a967831d946622 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 16 Apr 2025 23:45:10 +0200 Subject: [PATCH 201/256] fixed mistakes --- src/Modelling/PetriNet/Capacity.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 1379b5a1e..0d426b152 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -291,11 +291,11 @@ capacitySyntax task (tokenChanges, flowChanges) = do isValidComplementPlace :: String -> Bool isValidComplementPlace s = case s of - ('s':rest) -> maybe False (\x -> x >= 1 && x < (numberOfPlaces task - (numberOfPlaces task `div` 2))) (readMaybe rest) + ('s':rest) -> maybe False (\x -> x >= 1 && x <= (numberOfPlaces task `div` 2)) (readMaybe rest) _ -> False isValidTransition :: String -> Bool - isValidTransition s = case s of + isValidTransition t = case t of ('t':rest) -> maybe False (\x -> x >= 1 && x <= numberOfTransitions task) (readMaybe rest) _ -> False From 2baf5b3479d941ccec39ed9ba2ce997ee74ff111 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 17 Apr 2025 11:04:11 +0200 Subject: [PATCH 202/256] consistency to other places in code --- src/Modelling/PetriNet/Conflict.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index e498895e6..9d13fbf00 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -289,8 +289,8 @@ findConflictPlacesEvaluation task (conflict, ps) = base = fromIntegral $ 2 + numberOfPlaces task size = fromIntegral . length what = translations $ do - english "The given transitions have a conflict" - german "Die angegebenen Transitionen haben einen Konflikt" + english "The given transitions have a conflict?" + german "Die angegebenen Transitionen haben einen Konflikt?" findConflictPlacesSolution :: FindInstance n (PetriConflict p t) -> ((t, t), [p]) findConflictPlacesSolution task = From 8327ba0aca3eef30c3fb43099be98f4891cf7d84 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 17 Apr 2025 11:12:59 +0200 Subject: [PATCH 203/256] as mentioned before, CapacityConfig.useDifferentGraphLayouts shouldn't exist --- src/Modelling/PetriNet/Types.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index a88ec815e..a8eb397e8 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1101,7 +1101,6 @@ data CapacityConfig = CapacityConfig , atMostActive :: Maybe Int , graphConfig :: GraphConfig , printSolution :: Bool - , useDifferentGraphLayouts :: Bool , alloyConfig :: AlloyConfig } deriving (Generic, Read, Show) From 1c83ec152871c2a8c0818224cf1da53bfbc8fb64 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Thu, 17 Apr 2025 23:56:22 +0200 Subject: [PATCH 204/256] fixed problem that flowIn and flowOut for capacityNodes are the same --- src/Modelling/PetriNet/Types.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index a8eb397e8..190040ef1 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -650,20 +650,20 @@ instance Net PetriLike CapacityNode where nodes = allNodes deleteFlow x y (PetriLike ns) = PetriLike - . M.adjust (updateCapacityNode (M.delete y)) x - . M.adjust (updateCapacityNode (M.delete x)) y + . M.adjust (updateCapacityNode id (M.delete y)) x + . M.adjust (updateCapacityNode (M.delete x) id) y $ ns deleteNode x ns = PetriLike - . adjustAll (updateCapacityNode (M.delete x)) (Just $ M.keys $ allNodes ns) - . adjustAll (updateCapacityNode (M.delete x)) (Just $ M.keys $ allNodes ns) + . adjustAll (updateCapacityNode id (M.delete x)) (Just $ M.keys $ allNodes ns) + . adjustAll (updateCapacityNode (M.delete x) id) (Just $ M.keys $ allNodes ns) . M.delete x . allNodes $ ns alterFlow x f y = PetriLike - . M.adjust (updateCapacityNode (M.insert y f)) x - . M.adjust (updateCapacityNode (M.insert x f)) y + . M.adjust (updateCapacityNode id (M.insert y f)) x + . M.adjust (updateCapacityNode (M.insert x f) id) y . allNodes alterNode x mt = PetriLike . M.alter alterNode' x . allNodes @@ -687,9 +687,9 @@ flowOutCN :: CapacityNode a -> Map a Int flowOutCN CapacityPlace {flowOut} = flowOut flowOutCN CapacityTransition {flowOut} = flowOut -updateCapacityNode :: (Map a Int -> Map b Int) -> CapacityNode a -> CapacityNode b -updateCapacityNode g (CapacityPlace t c i o) = CapacityPlace t c (g i) (g o) -updateCapacityNode g (CapacityTransition i o) = CapacityTransition (g i) (g o) +updateCapacityNode :: (Map a Int -> Map b Int) -> (Map a Int -> Map b Int) -> CapacityNode a -> CapacityNode b +updateCapacityNode g h (CapacityPlace t c i o) = CapacityPlace t c (g i) (h o) +updateCapacityNode g h (CapacityTransition i o) = CapacityTransition (g i) (h o) {-| A 'Functor' like 'fmap' on 'PetriLike'. From e63f16b370df991f690b5c70c8fe99b822bf2e6e Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 18 Apr 2025 00:04:19 +0200 Subject: [PATCH 205/256] merged similar toFindEvaluation functions into one --- src/Modelling/PetriNet/Capacity.hs | 7 +++---- src/Modelling/PetriNet/Find.hs | 23 ++++++----------------- 2 files changed, 9 insertions(+), 21 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 0d426b152..11bb8f036 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -70,8 +70,7 @@ import Modelling.PetriNet.Find ( prohibitHidePlaceNames, prohibitHideTransitionNames, prohibitPatchworkRenderer, - toFindEvaluation2TupleList, - toFindEvaluation3TupleList, + toFindEvaluationTupleList, ) import Modelling.PetriNet.FindActivatedTransitions ( checkActivatedTransitionsConfig, @@ -313,8 +312,8 @@ capacityEvaluation task (tokenChanges, flowChanges) = do german "Die angegebenen Tupel sind hinzugefügte Flüsse?" uncurry (printSolutionAndAssert DefiniteArticle) $=<< unLangM $ liftA2 combineResults - (toFindEvaluation2TupleList whatTokens withSol tokens tokenChanges) - (toFindEvaluation3TupleList whatFlows withSol flows flowChanges) + (toFindEvaluationTupleList whatTokens withSol tokens tokenChanges) + (toFindEvaluationTupleList whatFlows withSol flows flowChanges) where (tokens, flows) = capacitySolution task diff --git a/src/Modelling/PetriNet/Find.hs b/src/Modelling/PetriNet/Find.hs index 583795561..bb3427c27 100644 --- a/src/Modelling/PetriNet/Find.hs +++ b/src/Modelling/PetriNet/Find.hs @@ -22,8 +22,7 @@ module Modelling.PetriNet.Find ( toFindEvaluation, toFindEvaluationList, toFindEvaluationTuple, - toFindEvaluation2TupleList, - toFindEvaluation3TupleList, + toFindEvaluationTupleList, toFindSyntax, ) where @@ -172,24 +171,14 @@ toFindEvaluationList toFindEvaluationList what withSol = toFindEvaluation what withSol (\x y -> sort x == sort y) (show . transitionListShow) -toFindEvaluation2TupleList - :: (Num a, OutputCapable m) - => Map Language String - -> Bool - -> [(String, Int)] - -> [(String, Int)] - -> LangM' m (Maybe String, a) -toFindEvaluation2TupleList what withSol = - toFindEvaluation what withSol (\xs ys -> sort xs == sort ys) (show . sort) - -toFindEvaluation3TupleList - :: (Num a, OutputCapable m) +toFindEvaluationTupleList + :: (Num a, Ord b, OutputCapable m, Show b) => Map Language String -> Bool - -> [(String, String, Int)] - -> [(String, String, Int)] + -> [b] + -> [b] -> LangM' m (Maybe String, a) -toFindEvaluation3TupleList what withSol = +toFindEvaluationTupleList what withSol = toFindEvaluation what withSol (\xs ys -> sort xs == sort ys) (show . sort) checkFindTwoActive :: BasicConfig -> Maybe String From 95c10b656d32272ea76d90befc738b3854e9a53a Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 18 Apr 2025 00:04:44 +0200 Subject: [PATCH 206/256] fixed mistakes --- src/Modelling/PetriNet/Capacity.hs | 3 ++- src/Modelling/PetriNet/Types.hs | 1 - 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 11bb8f036..6add99596 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -257,7 +257,8 @@ capacityTask path task = do "t2 zeigt auf s1 mit einem Gewicht von 1, und s2 ist mit t2 mit einem Gewicht von 2 verbunden.") translate $ do english "The first complement place s1 belongs to the first shown place s3, the second complement place s2 belongs to the second shown place s4 and so on." - german "Die erste Komplementstelle s1 gehört zu der ersten gezeigten Stelle s3, die zweite Komplementstelle s2 gehört zu der zweiten gezeigten Stelle s4 und so weiter." + german ("Die erste Komplementstelle s1 gehört zu der ersten gezeigten Stelle s3," ++ + "die zweite Komplementstelle s2 gehört zu der zweiten gezeigten Stelle s4 und so weiter.") translate $ do english "The order of tuples within the lists does not matter here." german "Die Reihenfolge der Tupel innerhalb der Listen spielt hierbei keine Rolle." diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 190040ef1..6a91dfea2 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -1115,7 +1115,6 @@ defaultCapacityConfig = CapacityConfig , distractors = (0, 1) , graphConfig = defaultGraphConfig { hidePlaceNames = False, hideTransitionNames = False } , printSolution = True - , useDifferentGraphLayouts = False , alloyConfig = defaultAlloyConfig } From 7010c304e6cc27618f3dc281459527a82189e6e5 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 18 Apr 2025 00:05:58 +0200 Subject: [PATCH 207/256] both lists are checked in capacitySyntax even if one is incorrect --- src/Modelling/PetriNet/Capacity.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 6add99596..b8ed8536b 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -276,7 +276,7 @@ capacitySyntax task (tokenChanges, flowChanges) = do for_ flowChanges assertFlowChanges pure () where - assert = continueOrAbort False + assert = continueOrAbort True assertTokenChanges (p, tokens) = assert (isValidComplementPlace p && tokens >= 0) $ translate $ do let p' = show (p, tokens) From 0cf99c2ff8a32ad1941b07bc0e797e720aa68634 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 10:04:17 +0200 Subject: [PATCH 208/256] remove flowIn from CapacityNode - the compiler confirmed the field is never used - the SimpleNode type doesn't have this field either --- src/Modelling/PetriNet/Capacity.hs | 14 +++++----- src/Modelling/PetriNet/Types.hs | 41 +++++++++++++----------------- 2 files changed, 25 insertions(+), 30 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index b8ed8536b..a2b8326ac 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -601,13 +601,13 @@ toFind = ChangeList { }, originalNet = PetriLike { allNodes = M.fromList [ - ("s1",CapacityPlace {initial = 0, capacity = 0, flowIn = M.empty, flowOut = M.empty}), - ("s2",CapacityPlace {initial = 0, capacity = 0, flowIn = M.empty, flowOut = M.empty}), - ("s3",CapacityPlace {initial = 1, capacity = 2, flowIn = M.fromList [("t2",1)], flowOut = M.fromList [("t1",1)]}), - ("s4",CapacityPlace {initial = 0, capacity = 1, flowIn = M.fromList [("t1",1)], flowOut = M.fromList [("t2",1),("t3",1)]}), - ("t1",CapacityTransition {flowIn = M.fromList [("s3",1)], flowOut = M.fromList [("s4",1)]}), - ("t2",CapacityTransition {flowIn = M.fromList [("s4",1)], flowOut = M.fromList [("s3",1)]}), - ("t3",CapacityTransition {flowIn = M.fromList [("s4",1)], flowOut = M.empty}) + ("s1",CapacityPlace {initial = 0, capacity = 0, flowOut = M.empty}), + ("s2",CapacityPlace {initial = 0, capacity = 0, flowOut = M.empty}), + ("s3",CapacityPlace {initial = 1, capacity = 2, flowOut = M.fromList [("t1",1)]}), + ("s4",CapacityPlace {initial = 0, capacity = 1, flowOut = M.fromList [("t2",1),("t3",1)]}), + ("t1",CapacityTransition {flowOut = M.fromList [("s4",1)]}), + ("t2",CapacityTransition {flowOut = M.fromList [("s3",1)]}), + ("t3",CapacityTransition {flowOut = M.empty}) ] }, transformedNet = PetriLike { diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 6a91dfea2..73dfb63c1 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -390,11 +390,9 @@ data CapacityNode a = initial :: Int, capacity :: Int, -- | max allowed token number of a 'CapacityNode' - flowIn :: Map a Int, flowOut :: Map a Int } | CapacityTransition { - flowIn :: Map a Int, flowOut :: Map a Int } deriving (Eq, Generic, Read, Show) @@ -410,15 +408,15 @@ instance PetriNode CapacityNode where isTransitionNode CapacityTransition {} = True isTransitionNode _ = False - mapNode f (CapacityPlace s c i o) = - CapacityPlace s c (M.mapKeys f i) (M.mapKeys f o) - mapNode f (CapacityTransition i o) = - CapacityTransition (M.mapKeys f i) (M.mapKeys f o) + mapNode f (CapacityPlace s c o) = + CapacityPlace s c (M.mapKeys f o) + mapNode f (CapacityTransition o) = + CapacityTransition (M.mapKeys f o) - traverseNode f (CapacityPlace s c i o) = - CapacityPlace s c <$> traverseKeyMap f i <*> traverseKeyMap f o - traverseNode f (CapacityTransition i o) = - CapacityTransition <$> traverseKeyMap f i <*> traverseKeyMap f o + traverseNode f (CapacityPlace s c o) = + CapacityPlace s c <$> traverseKeyMap f o + traverseNode f (CapacityTransition o) = + CapacityTransition <$> traverseKeyMap f o instance PetriNodeWithCapacity CapacityNode where capacityPlace CapacityPlace {capacity} = capacity @@ -650,35 +648,32 @@ instance Net PetriLike CapacityNode where nodes = allNodes deleteFlow x y (PetriLike ns) = PetriLike - . M.adjust (updateCapacityNode id (M.delete y)) x - . M.adjust (updateCapacityNode (M.delete x) id) y + . M.adjust (updateCapacityNode (M.delete y)) x $ ns deleteNode x ns = PetriLike - . adjustAll (updateCapacityNode id (M.delete x)) (Just $ M.keys $ allNodes ns) - . adjustAll (updateCapacityNode (M.delete x) id) (Just $ M.keys $ allNodes ns) + . adjustAll (updateCapacityNode (M.delete x)) (Just $ M.keys $ allNodes ns) . M.delete x . allNodes $ ns alterFlow x f y = PetriLike - . M.adjust (updateCapacityNode id (M.insert y f)) x - . M.adjust (updateCapacityNode (M.insert x f) id) y + . M.adjust (updateCapacityNode (M.insert y f)) x . allNodes alterNode x mt = PetriLike . M.alter alterNode' x . allNodes where alterNode' = Just . fromMaybe - (maybe (CapacityTransition M.empty M.empty) (\m -> CapacityPlace m 0 M.empty M.empty) mt) + (maybe CapacityTransition (\m -> CapacityPlace m 0) mt M.empty) outFlow x = maybe M.empty flowOutCN . M.lookup x . allNodes updateCapacity x y (PetriLike ns) = PetriLike $ M.alter updateCapacity' x ns where - updateCapacity' Nothing = Just $ CapacityPlace 0 (fromMaybe 0 y) M.empty M.empty - updateCapacity' (Just (CapacityPlace t _ i o)) = Just $ CapacityPlace t (fromMaybe 0 y) i o - updateCapacity' (Just (CapacityTransition i o)) = Just $ CapacityTransition i o + updateCapacity' Nothing = Just $ CapacityPlace 0 (fromMaybe 0 y) M.empty + updateCapacity' (Just (CapacityPlace t _ o)) = Just $ CapacityPlace t (fromMaybe 0 y) o + updateCapacity' (Just (CapacityTransition o)) = Just $ CapacityTransition o mapNet = mapPetriLike traverseNet = traversePetriLike @@ -687,9 +682,9 @@ flowOutCN :: CapacityNode a -> Map a Int flowOutCN CapacityPlace {flowOut} = flowOut flowOutCN CapacityTransition {flowOut} = flowOut -updateCapacityNode :: (Map a Int -> Map b Int) -> (Map a Int -> Map b Int) -> CapacityNode a -> CapacityNode b -updateCapacityNode g h (CapacityPlace t c i o) = CapacityPlace t c (g i) (h o) -updateCapacityNode g h (CapacityTransition i o) = CapacityTransition (g i) (h o) +updateCapacityNode :: (Map a Int -> Map b Int) -> CapacityNode a -> CapacityNode b +updateCapacityNode h (CapacityPlace t c o) = CapacityPlace t c (h o) +updateCapacityNode h (CapacityTransition o) = CapacityTransition (h o) {-| A 'Functor' like 'fmap' on 'PetriLike'. From ab0e5086d377a802b7f82a6d46c694242a31ee62 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 10:20:30 +0200 Subject: [PATCH 209/256] capacity :: Integer, to get some extra type-checking (letting the type-checker ensure that the "initial" and "capacity" values are never confused) --- src/Modelling/PetriNet/Diagram.hs | 6 +++--- src/Modelling/PetriNet/Parser.hs | 6 ++++-- src/Modelling/PetriNet/Types.hs | 8 ++++---- 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index 80a02f4e0..584847c2a 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -218,7 +218,7 @@ drawGraphWithCapacity => (a -> String) -> DrawSettings -> PreparedFont Double - -> Gr (AttributeNode (a, Maybe Int, Maybe Int)) (AttributeEdge Int) + -> Gr (AttributeNode (a, Maybe Int, Maybe Integer)) (AttributeEdge Int) -> Diagram B drawGraphWithCapacity labelOf drawSettings@DrawSettings {..} preparedFont graph = graphEdges' # frame 1 @@ -309,7 +309,7 @@ drawNode DrawSettings {..} preparedFont (l, Just i) p drawNodeCapacity :: DrawSettings -> PreparedFont Double - -> (String, Maybe Int, Maybe Int) + -> (String, Maybe Int, Maybe Integer) -- ^ a capacity node (the first part is used for its label) with a capacity -> Point V2 Double -> Diagram B @@ -359,7 +359,7 @@ drawNodeCapacity DrawSettings {..} preparedFont (l, Just i, cap) p drawCapacity :: PreparedFont Double - -> Int + -> Integer -> Diagram B drawCapacity fontC cap = case cap of diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index bb4a4489e..6e4b40744 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -48,6 +48,8 @@ import Modelling.PetriNet.Types ( petriLikeToPetri, ) +import GHC.Num (integerFromInt) + import Control.Arrow (second) import Control.Monad.Catch (Exception, MonadThrow (throwM)) import Data.Bimap (Bimap) @@ -127,7 +129,7 @@ parseNet flowSetName tokenSetName maybeCapacitySetName inst = do capacities <- case maybeCapacitySetName of Just capacitySetName -> do rawCapacity <- doubleSig inst "this" "placesWithCapacity" capacitySetName - return $ relToMap (second oIndex) rawCapacity + return $ relToMap (second (integerFromInt . oIndex)) rawCapacity Nothing -> return Map.empty let applyCapacity net = @@ -287,7 +289,7 @@ netToGr petriLike = do netToGrCapacity :: (Monad m, Net p n, Ord a, PetriNodeWithCapacity n) => p n a - -> m (Gr (a, Maybe Int, Maybe Int) Int) + -> m (Gr (a, Maybe Int, Maybe Integer) Int) netToGrCapacity petriLike = do nodes <- Map.foldrWithKey convertNode (return []) $ PN.nodes petriLike let edges = Map.foldrWithKey convertTransition [] $ PN.nodes petriLike diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 73dfb63c1..8a7613614 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -309,7 +309,7 @@ class Show (n String) => PetriNode n where traverseNode :: (Applicative f, Ord b) => (a -> f b) -> n a -> f (n b) class PetriNode n => PetriNodeWithCapacity n where - capacityPlace :: n a -> Int + capacityPlace :: n a -> Integer capacityPlace _ = error "This node type does not support capacities." {-| @@ -388,7 +388,7 @@ instance PetriNode SimpleNode where data CapacityNode a = CapacityPlace { initial :: Int, - capacity :: Int, + capacity :: Integer, -- | max allowed token number of a 'CapacityNode' flowOut :: Map a Int } | @@ -432,7 +432,7 @@ maybeInitial n | isPlaceNode n = Just $ initialTokens n | otherwise = Nothing -maybeCapacity :: PetriNodeWithCapacity n => n a -> Maybe Int +maybeCapacity :: PetriNodeWithCapacity n => n a -> Maybe Integer maybeCapacity n | isPlaceNode n = Just $ capacityPlace n | otherwise = Nothing @@ -508,7 +508,7 @@ class (PetriNode n, Show (p n String)) => Net p n where updateCapacity :: Ord a => a - -> Maybe Int + -> Maybe Integer -> p n a -> p n a From 9a37be47cdf8e097ee6cbe0f600362ca1dd76d53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 10:33:50 +0200 Subject: [PATCH 210/256] switch field order in CapacityPlace --- src/Modelling/PetriNet/Types.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 8a7613614..e27f589b5 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -387,9 +387,9 @@ instance PetriNode SimpleNode where data CapacityNode a = CapacityPlace { - initial :: Int, capacity :: Integer, -- | max allowed token number of a 'CapacityNode' + initial :: Int, flowOut :: Map a Int } | CapacityTransition { @@ -408,13 +408,13 @@ instance PetriNode CapacityNode where isTransitionNode CapacityTransition {} = True isTransitionNode _ = False - mapNode f (CapacityPlace s c o) = - CapacityPlace s c (M.mapKeys f o) + mapNode f (CapacityPlace c s o) = + CapacityPlace c s (M.mapKeys f o) mapNode f (CapacityTransition o) = CapacityTransition (M.mapKeys f o) - traverseNode f (CapacityPlace s c o) = - CapacityPlace s c <$> traverseKeyMap f o + traverseNode f (CapacityPlace c s o) = + CapacityPlace c s <$> traverseKeyMap f o traverseNode f (CapacityTransition o) = CapacityTransition <$> traverseKeyMap f o @@ -664,15 +664,15 @@ instance Net PetriLike CapacityNode where alterNode x mt = PetriLike . M.alter alterNode' x . allNodes where alterNode' = Just . fromMaybe - (maybe CapacityTransition (\m -> CapacityPlace m 0) mt M.empty) + (maybe CapacityTransition (CapacityPlace 0) mt M.empty) outFlow x = maybe M.empty flowOutCN . M.lookup x . allNodes updateCapacity x y (PetriLike ns) = PetriLike $ M.alter updateCapacity' x ns where - updateCapacity' Nothing = Just $ CapacityPlace 0 (fromMaybe 0 y) M.empty - updateCapacity' (Just (CapacityPlace t _ o)) = Just $ CapacityPlace t (fromMaybe 0 y) o + updateCapacity' Nothing = Just $ CapacityPlace (fromMaybe 0 y) 0 M.empty + updateCapacity' (Just (CapacityPlace _ t o)) = Just $ CapacityPlace (fromMaybe 0 y) t o updateCapacity' (Just (CapacityTransition o)) = Just $ CapacityTransition o mapNet = mapPetriLike @@ -683,7 +683,7 @@ flowOutCN CapacityPlace {flowOut} = flowOut flowOutCN CapacityTransition {flowOut} = flowOut updateCapacityNode :: (Map a Int -> Map b Int) -> CapacityNode a -> CapacityNode b -updateCapacityNode h (CapacityPlace t c o) = CapacityPlace t c (h o) +updateCapacityNode h (CapacityPlace c t o) = CapacityPlace c t (h o) updateCapacityNode h (CapacityTransition o) = CapacityTransition (h o) {-| From 49b426921cf6ccc1e85447407a51831d867d7d5d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 11:38:18 +0200 Subject: [PATCH 211/256] don't invent "0 capacities" --- src/Modelling/PetriNet/Types.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index e27f589b5..24b7347e3 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -664,15 +664,15 @@ instance Net PetriLike CapacityNode where alterNode x mt = PetriLike . M.alter alterNode' x . allNodes where alterNode' = Just . fromMaybe - (maybe CapacityTransition (CapacityPlace 0) mt M.empty) + (maybe CapacityTransition (CapacityPlace undefined) mt M.empty) outFlow x = maybe M.empty flowOutCN . M.lookup x . allNodes updateCapacity x y (PetriLike ns) = PetriLike $ M.alter updateCapacity' x ns where - updateCapacity' Nothing = Just $ CapacityPlace (fromMaybe 0 y) 0 M.empty - updateCapacity' (Just (CapacityPlace _ t o)) = Just $ CapacityPlace (fromMaybe 0 y) t o + updateCapacity' Nothing = Just $ CapacityPlace (fromMaybe undefined y) 0 M.empty + updateCapacity' (Just (CapacityPlace _ t o)) = Just $ CapacityPlace (fromMaybe undefined y) t o updateCapacity' (Just (CapacityTransition o)) = Just $ CapacityTransition o mapNet = mapPetriLike From c29ace695b3cc04724ef5869cf25a588ce15d676 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 12:19:21 +0200 Subject: [PATCH 212/256] refactor how capacities are added during parsing by moving that processing out of the parseNet function --- src/Modelling/PetriNet/Diagram.hs | 3 ++- src/Modelling/PetriNet/Parser.hs | 37 ++++++++++++++++--------------- 2 files changed, 21 insertions(+), 19 deletions(-) diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index 584847c2a..63fe67a24 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -30,6 +30,7 @@ import Modelling.Auxiliary.Diagrams ( trailBetween, ) import Modelling.PetriNet.Parser ( + addCapacities, netToGr, netToGrCapacity, parseNet, @@ -166,7 +167,7 @@ getNetWith -- ^ the instance to parse -> m (p n String, Object -> m String) getNetWith f t c inst = do - pl <- parseNet f t c inst + pl <- parseNet f t inst >>= maybe return (addCapacities inst) c let rename = simpleRenameWith pl pl' <- traverseNet rename pl return (pl', rename) diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 6e4b40744..208efd87c 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -8,6 +8,7 @@ of graphs which are similar to Petri nets. -} module Modelling.PetriNet.Parser ( NoSingletonException (..), + addCapacities, asSingleton, convertPetri, netToGr, @@ -29,7 +30,6 @@ import qualified Data.Set as Set ( Set, findMin, fromList, lookupMin, null, size, toList, ) import qualified Data.Map.Lazy as Map ( - empty, findIndex, foldlWithKey', foldrWithKey, @@ -80,7 +80,7 @@ convertPetri -> AlloyInstance -- ^ the Petri net 'AlloyInstance' -> m Petri convertPetri f t inst = do - p <- parseNet f t Nothing inst + p <- parseNet f t inst petriLikeToPetri p {-| @@ -95,7 +95,7 @@ parseRenamedNet -> AlloyInstance -> m (p n String) parseRenamedNet flowSetName tokenSetName inst = do - petriLike <- parseNet flowSetName tokenSetName Nothing inst + petriLike <- parseNet flowSetName tokenSetName inst let rename = simpleRenameWith petriLike traverseNet rename petriLike @@ -116,30 +116,16 @@ parseNet :: (MonadThrow m, Net p n) => String -- ^ the name of the flow set -> String -- ^ the name of the token set - -> Maybe String -- ^ the optional name of the capacity set -> AlloyInstance -- ^ the Petri net 'AlloyInstance' -> m (p n Object) -parseNet flowSetName tokenSetName maybeCapacitySetName inst = do +parseNet flowSetName tokenSetName inst = do nodes <- singleSig inst "this" "Nodes" "" rawTokens <- doubleSig inst "this" "Places" tokenSetName let tokens = relToMap (second oIndex) rawTokens flow <- tripleSig inst "this" "Nodes" flowSetName - capacities <- case maybeCapacitySetName of - Just capacitySetName -> do - rawCapacity <- doubleSig inst "this" "placesWithCapacity" capacitySetName - return $ relToMap (second (integerFromInt . oIndex)) rawCapacity - Nothing -> return Map.empty - - let applyCapacity net = - case maybeCapacitySetName of - Just _ -> foldrFlip - (\x -> updateCapacity x $ Map.lookup x capacities >>= Set.lookupMin) nodes net - Nothing -> net - return - . applyCapacity . foldrFlip (\(x, y, z) -> alterFlow x (oIndex z) y) flow . foldrFlip (\x -> alterNode x $ Map.lookup x tokens >>= Set.lookupMin) @@ -148,6 +134,21 @@ parseNet flowSetName tokenSetName maybeCapacitySetName inst = do where foldrFlip f = flip $ foldr f +addCapacities + :: (MonadThrow m, Net p n) + => AlloyInstance + -> String + -> p n Object + -> m (p n Object) +addCapacities inst capacitySetName net = do + nodes <- singleSig inst "this" "Nodes" "" + + rawCapacity <- doubleSig inst "this" "placesWithCapacity" capacitySetName + + let capacities = relToMap (second (integerFromInt . oIndex)) rawCapacity + + return $ foldr (\x -> updateCapacity x $ Map.lookup x capacities >>= Set.lookupMin) net nodes + relToMap :: (Ord b, Ord c) => (a -> (b, c)) -> Set a -> Map b (Set c) relToMap f = toMap . Set.fromList . map f . Set.toList From 3d2ae89b4ff22872fd1eb5654906edab72fe8640 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 12:34:09 +0200 Subject: [PATCH 213/256] inline getNetWith --- src/Modelling/PetriNet/Diagram.hs | 32 ++++++------------------------- 1 file changed, 6 insertions(+), 26 deletions(-) diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index 63fe67a24..586fd713d 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -135,8 +135,9 @@ getNet -> AlloyInstance -> m (p n String, t String) getNet parseSpecial inst = do - (net, rename) <- - getNetWith "flow" "tokens" Nothing inst + pl <- parseNet "flow" "tokens" inst + let rename = simpleRenameWith pl + net <- traverseNet rename pl special <- parseSpecial inst renamedSpecial <- traverse rename special return (net, renamedSpecial) @@ -146,31 +147,10 @@ getDefaultNet => Maybe String -> AlloyInstance -> m (p n String) -getDefaultNet c inst = fst <$> - getNetWith "defaultFlow" "defaultTokens" c inst - -{-| -Returns a Petri net like graph using 'parseNet'. -It additionally parses another part of the instance. -All nodes are renamed using the 'simpleRenameWith' function. -The renaming is also applied to the additionally parsed instance. --} -getNetWith - :: (MonadThrow m, Net p n) - => String - -- ^ flow - -> String - -- ^ tokens - -> Maybe String - -- ^ capacity (optional) - -> AlloyInstance - -- ^ the instance to parse - -> m (p n String, Object -> m String) -getNetWith f t c inst = do - pl <- parseNet f t inst >>= maybe return (addCapacities inst) c +getDefaultNet c inst = do + pl <- parseNet "defaultFlow" "defaultTokens" inst >>= maybe return (addCapacities inst) c let rename = simpleRenameWith pl - pl' <- traverseNet rename pl - return (pl', rename) + traverseNet rename pl {-| Obtain the Petri net like graph by drawing Nodes and connections between them From 76ce0fcda0f1e492707b83b1166f0c9dec783b98 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 12:47:11 +0200 Subject: [PATCH 214/256] specialize getDefaultNet -> getDefaultNetWithCapacities --- src/Modelling/PetriNet/Capacity.hs | 4 ++-- src/Modelling/PetriNet/Diagram.hs | 17 +++++++++++++---- src/Modelling/PetriNet/Parser.hs | 5 ++--- src/Modelling/PetriNet/Pick.hs | 2 +- 4 files changed, 18 insertions(+), 10 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index a2b8326ac..53c8bc448 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -61,7 +61,7 @@ import Modelling.PetriNet.Alloy ( randomInSegment, ) import Modelling.PetriNet.Diagram ( - getDefaultNet, + getDefaultNetWithCapacities, getNet, renderWith, renderWithCapacity, @@ -345,7 +345,7 @@ combinedCapacity alloyF alloyC config segment = do case drop x list of x':_ -> return x' [] -> randomInstance list - first <- getDefaultNet (Just "capacity") inst + first <- getDefaultNetWithCapacities inst (second, third) <- getNet (fmap toChangeList . parseChange) inst return (first, second, third) diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index 586fd713d..3ced5a9eb 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -11,6 +11,7 @@ module Modelling.PetriNet.Diagram ( drawNet, drawNetWithCapacity, getDefaultNet, + getDefaultNetWithCapacities, getNet, renderWith, renderWithCapacity, @@ -144,11 +145,19 @@ getNet parseSpecial inst = do getDefaultNet :: (MonadThrow m, Net p n) - => Maybe String - -> AlloyInstance + => AlloyInstance + -> m (p n String) +getDefaultNet inst = do + pl <- parseNet "defaultFlow" "defaultTokens" inst + let rename = simpleRenameWith pl + traverseNet rename pl + +getDefaultNetWithCapacities + :: (MonadThrow m, Net p n) + => AlloyInstance -> m (p n String) -getDefaultNet c inst = do - pl <- parseNet "defaultFlow" "defaultTokens" inst >>= maybe return (addCapacities inst) c +getDefaultNetWithCapacities inst = do + pl <- parseNet "defaultFlow" "defaultTokens" inst >>= addCapacities inst let rename = simpleRenameWith pl traverseNet rename pl diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 208efd87c..09edae07a 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -137,13 +137,12 @@ parseNet flowSetName tokenSetName inst = do addCapacities :: (MonadThrow m, Net p n) => AlloyInstance - -> String -> p n Object -> m (p n Object) -addCapacities inst capacitySetName net = do +addCapacities inst net = do nodes <- singleSig inst "this" "Nodes" "" - rawCapacity <- doubleSig inst "this" "placesWithCapacity" capacitySetName + rawCapacity <- doubleSig inst "this" "placesWithCapacity" "capacity" let capacities = relToMap (second (integerFromInt . oIndex)) rawCapacity diff --git a/src/Modelling/PetriNet/Pick.hs b/src/Modelling/PetriNet/Pick.hs index 1fbfeccf0..634a90d5b 100644 --- a/src/Modelling/PetriNet/Pick.hs +++ b/src/Modelling/PetriNet/Pick.hs @@ -101,7 +101,7 @@ pickTaskInstance -> m [(p n String, Maybe (t String))] pickTaskInstance parseSpecial inst = do special <- second Just <$> getNet parseSpecial inst - net <- (,Nothing) <$> getDefaultNet Nothing inst + net <- (,Nothing) <$> getDefaultNet inst return [special, net] pickGenerate From acc47b15a92c493cca0c34fab8fcdf88cb41819f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 13:09:28 +0200 Subject: [PATCH 215/256] move updateCapacity function out of type class --- src/Modelling/PetriNet/Diagram.hs | 6 ++++-- src/Modelling/PetriNet/Parser.hs | 25 +++++++++++++++++++++---- src/Modelling/PetriNet/Types.hs | 18 ------------------ 3 files changed, 25 insertions(+), 24 deletions(-) diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index 3ced5a9eb..4faeea197 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -38,8 +38,10 @@ import Modelling.PetriNet.Parser ( simpleRenameWith, ) import Modelling.PetriNet.Types ( + CapacityNode, DrawSettings (..), Net (mapNet, traverseNet), + PetriLike, PetriNodeWithCapacity (..), ) @@ -153,9 +155,9 @@ getDefaultNet inst = do traverseNet rename pl getDefaultNetWithCapacities - :: (MonadThrow m, Net p n) + :: MonadThrow m => AlloyInstance - -> m (p n String) + -> m (PetriLike CapacityNode String) getDefaultNetWithCapacities inst = do pl <- parseNet "defaultFlow" "defaultTokens" inst >>= addCapacities inst let rename = simpleRenameWith pl diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 09edae07a..919fa412a 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -30,17 +30,22 @@ import qualified Data.Set as Set ( Set, findMin, fromList, lookupMin, null, size, toList, ) import qualified Data.Map.Lazy as Map ( + alter, + empty, findIndex, foldlWithKey', foldrWithKey, lookup, ) +import Data.Maybe (fromMaybe) import Modelling.Auxiliary.Common (Object (Object, oName, oIndex), toMap) import Modelling.PetriNet.Types ( - Net (emptyNet, outFlow, alterFlow, alterNode, traverseNet, updateCapacity), + CapacityNode (..), + Net (emptyNet, outFlow, alterFlow, alterNode, traverseNet), Petri, PetriChange (..), + PetriLike (..), PetriNode (..), PetriNodeWithCapacity (..), maybeCapacity, @@ -135,10 +140,10 @@ parseNet flowSetName tokenSetName inst = do foldrFlip f = flip $ foldr f addCapacities - :: (MonadThrow m, Net p n) + :: MonadThrow m => AlloyInstance - -> p n Object - -> m (p n Object) + -> PetriLike CapacityNode Object + -> m (PetriLike CapacityNode Object) addCapacities inst net = do nodes <- singleSig inst "this" "Nodes" "" @@ -148,6 +153,18 @@ addCapacities inst net = do return $ foldr (\x -> updateCapacity x $ Map.lookup x capacities >>= Set.lookupMin) net nodes +updateCapacity + :: Object + -> Maybe Integer + -> PetriLike CapacityNode Object + -> PetriLike CapacityNode Object +updateCapacity x y (PetriLike ns) = + PetriLike $ Map.alter updateCapacity' x ns + where + updateCapacity' Nothing = Just $ CapacityPlace (fromMaybe undefined y) 0 Map.empty + updateCapacity' (Just (CapacityPlace _ t o)) = Just $ CapacityPlace (fromMaybe undefined y) t o + updateCapacity' (Just (CapacityTransition o)) = Just $ CapacityTransition o + relToMap :: (Ord b, Ord c) => (a -> (b, c)) -> Set a -> Map b (Set c) relToMap f = toMap . Set.fromList . map f . Set.toList diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 24b7347e3..1172e14e9 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -505,13 +505,6 @@ class (PetriNode n, Show (p n String)) => Net p n where -> p n a -> p n a - updateCapacity - :: Ord a - => a - -> Maybe Integer - -> p n a - -> p n a - {-| Removes the flow going from the first given key to the second one.. -} @@ -587,8 +580,6 @@ instance Net PetriLike Node where outFlow x = maybe M.empty flowOutN . M.lookup x . allNodes - updateCapacity _ _ net = net - mapNet = mapPetriLike traverseNet = traversePetriLike @@ -624,8 +615,6 @@ instance Net PetriLike SimpleNode where outFlow x = maybe M.empty flowOutSN . M.lookup x . allNodes - updateCapacity _ _ net = net - mapNet = mapPetriLike traverseNet = traversePetriLike @@ -668,13 +657,6 @@ instance Net PetriLike CapacityNode where outFlow x = maybe M.empty flowOutCN . M.lookup x . allNodes - updateCapacity x y (PetriLike ns) = - PetriLike $ M.alter updateCapacity' x ns - where - updateCapacity' Nothing = Just $ CapacityPlace (fromMaybe undefined y) 0 M.empty - updateCapacity' (Just (CapacityPlace _ t o)) = Just $ CapacityPlace (fromMaybe undefined y) t o - updateCapacity' (Just (CapacityTransition o)) = Just $ CapacityTransition o - mapNet = mapPetriLike traverseNet = traversePetriLike From d3de911b3fee64e7595cd76c55b44498eb0519e1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 13:45:31 +0200 Subject: [PATCH 216/256] remove polymorphism over PetriNodeWithCapacity (type classes with exactly one instances are rarely useful) --- src/Modelling/PetriNet/Diagram.hs | 14 ++++++-------- src/Modelling/PetriNet/Parser.hs | 6 +++--- src/Modelling/PetriNet/Types.hs | 13 ++++--------- 3 files changed, 13 insertions(+), 20 deletions(-) diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index 4faeea197..046133b2d 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -42,7 +42,6 @@ import Modelling.PetriNet.Types ( DrawSettings (..), Net (mapNet, traverseNet), PetriLike, - PetriNodeWithCapacity (..), ) import Control.Arrow (first) @@ -75,10 +74,10 @@ cacheNet path labelOf pl drawSettings@DrawSettings {..} = ++ ".svg" cacheNetCapacity - :: (MonadCache m, MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n, PetriNodeWithCapacity n) + :: (MonadCache m, MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p CapacityNode) => String -> (a -> String) - -> p n a + -> p CapacityNode a -> DrawSettings -> m FilePath cacheNetCapacity path labelOf pl drawSettings@DrawSettings {..} = @@ -120,9 +119,9 @@ drawNet labelOf pl drawSettings@DrawSettings {..} = do return $ drawGraph labelOf drawSettings preparedFont graph drawNetWithCapacity - :: (MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n, Ord a, PetriNodeWithCapacity n) + :: (MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p CapacityNode, Ord a) => (a -> String) - -> p n a + -> p CapacityNode a -> DrawSettings -> m (Diagram B) drawNetWithCapacity labelOf pl drawSettings@DrawSettings {..} = do @@ -406,11 +405,10 @@ renderWith renderWith path task = cacheNet (path ++ task) id renderWithCapacity - :: (MonadCache m, MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p n, PetriNodeWithCapacity n) + :: (MonadCache m, MonadDiagrams m, MonadGraphviz m, MonadThrow m, Net p CapacityNode) => String -> String - -> p n String + -> p CapacityNode String -> DrawSettings -> m FilePath renderWithCapacity path task = cacheNetCapacity (path ++ task) id - diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 919fa412a..101e17f2a 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-| A module for parsing Petri Alloy instances into Haskell representations defined @@ -47,7 +48,6 @@ import Modelling.PetriNet.Types ( PetriChange (..), PetriLike (..), PetriNode (..), - PetriNodeWithCapacity (..), maybeCapacity, maybeInitial, petriLikeToPetri, @@ -304,8 +304,8 @@ netToGr petriLike = do (indexOf source, indexOf target, flow) : rs netToGrCapacity - :: (Monad m, Net p n, Ord a, PetriNodeWithCapacity n) - => p n a + :: (Monad m, Net p CapacityNode, Ord a) + => p CapacityNode a -> m (Gr (a, Maybe Int, Maybe Integer) Int) netToGrCapacity petriLike = do nodes <- Map.foldrWithKey convertNode (return []) $ PN.nodes petriLike diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 1172e14e9..0879e7985 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -49,7 +49,6 @@ module Modelling.PetriNet.Types ( PetriLike (..), PetriMath (..), PetriNode (..), - PetriNodeWithCapacity (..), PickConcurrencyConfig (..), PickConflictConfig (..), PickMistakeConfig (..), @@ -308,10 +307,6 @@ class Show (n String) => PetriNode n where -} traverseNode :: (Applicative f, Ord b) => (a -> f b) -> n a -> f (n b) -class PetriNode n => PetriNodeWithCapacity n where - capacityPlace :: n a -> Integer - capacityPlace _ = error "This node type does not support capacities." - {-| A node is part of a Petri like graph (see 'PetriLike'). Each node stores its predecessor and successor nodes together with their weight @@ -418,9 +413,9 @@ instance PetriNode CapacityNode where traverseNode f (CapacityTransition o) = CapacityTransition <$> traverseKeyMap f o -instance PetriNodeWithCapacity CapacityNode where - capacityPlace CapacityPlace {capacity} = capacity - capacityPlace CapacityTransition {} = +capacityPlace :: CapacityNode a -> Integer +capacityPlace CapacityPlace {capacity} = capacity +capacityPlace CapacityTransition {} = error "A CapacityTransition does not have a capacity!" {-| @@ -432,7 +427,7 @@ maybeInitial n | isPlaceNode n = Just $ initialTokens n | otherwise = Nothing -maybeCapacity :: PetriNodeWithCapacity n => n a -> Maybe Integer +maybeCapacity :: CapacityNode a -> Maybe Integer maybeCapacity n | isPlaceNode n = Just $ capacityPlace n | otherwise = Nothing From b64fb5334d5ebb384f65711b3b5d56a03bf02022 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 13:51:49 +0200 Subject: [PATCH 217/256] more direct pattern-matching --- src/Modelling/PetriNet/Types.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/src/Modelling/PetriNet/Types.hs b/src/Modelling/PetriNet/Types.hs index 0879e7985..bfc58dd8f 100644 --- a/src/Modelling/PetriNet/Types.hs +++ b/src/Modelling/PetriNet/Types.hs @@ -413,11 +413,6 @@ instance PetriNode CapacityNode where traverseNode f (CapacityTransition o) = CapacityTransition <$> traverseKeyMap f o -capacityPlace :: CapacityNode a -> Integer -capacityPlace CapacityPlace {capacity} = capacity -capacityPlace CapacityTransition {} = - error "A CapacityTransition does not have a capacity!" - {-| Returns 'Just' the 'initial' tokens of the given node, if it is a place 'PetriNode', otherwise it returns 'Nothing'. @@ -428,9 +423,8 @@ maybeInitial n | otherwise = Nothing maybeCapacity :: CapacityNode a -> Maybe Integer -maybeCapacity n - | isPlaceNode n = Just $ capacityPlace n - | otherwise = Nothing +maybeCapacity CapacityPlace{capacity} = Just capacity +maybeCapacity _ = Nothing {-| A specific traversal for 'Map's changing the keys rather than values. From fccc61081ef8a633b65eff613a2f922f6a051a32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 14:05:00 +0200 Subject: [PATCH 218/256] make test compile again --- test/Modelling/PetriNet/DiagramSpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Modelling/PetriNet/DiagramSpec.hs b/test/Modelling/PetriNet/DiagramSpec.hs index 96d6e1ec5..513495453 100644 --- a/test/Modelling/PetriNet/DiagramSpec.hs +++ b/test/Modelling/PetriNet/DiagramSpec.hs @@ -27,7 +27,7 @@ spec = do (inst:_) <- getInstances (Just 1) (petriNetRnd defaultBasicConfig defaultAdvConfig) - pl <- parseNet "flow" "tokens" Nothing inst + pl <- parseNet "flow" "tokens" inst dia <- drawNet show (pl :: SimplePetriLike Object) DrawSettings { withPlaceNames = True, withSvgHighlighting = True, From cc55b3590a2f75645948a24ce4a53fe400f9f683 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 14:22:27 +0200 Subject: [PATCH 219/256] inline getDefaultNetWithCapacities and getNet into combinedCapacity --- src/Modelling/PetriNet/Capacity.hs | 19 ++++++++++++++----- src/Modelling/PetriNet/Diagram.hs | 12 ------------ 2 files changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 53c8bc448..a7f3724f1 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -61,8 +61,6 @@ import Modelling.PetriNet.Alloy ( randomInSegment, ) import Modelling.PetriNet.Diagram ( - getDefaultNetWithCapacities, - getNet, renderWith, renderWithCapacity, ) @@ -76,7 +74,10 @@ import Modelling.PetriNet.FindActivatedTransitions ( checkActivatedTransitionsConfig, ) import Modelling.PetriNet.Parser ( + addCapacities, parseChange, + parseNet, + simpleRenameWith, ) import Modelling.PetriNet.Reach.Type ( parsePlacePrec, @@ -90,7 +91,7 @@ import Modelling.PetriNet.Types ( CapacityConfig (..), DrawSettings (..), GraphConfig (..), - Net, + Net (traverseNet), PetriChangeList (..), PetriLike (PetriLike, allNodes), SimpleNode (..), @@ -345,8 +346,16 @@ combinedCapacity alloyF alloyC config segment = do case drop x list of x':_ -> return x' [] -> randomInstance list - first <- getDefaultNetWithCapacities inst - (second, third) <- getNet (fmap toChangeList . parseChange) inst + + plFirst <- parseNet "defaultFlow" "defaultTokens" inst >>= addCapacities inst + let renameFirst = simpleRenameWith plFirst + first <- traverseNet renameFirst plFirst + + plSecond <- parseNet "flow" "tokens" inst + let renameSecond = simpleRenameWith plSecond + second <- traverseNet renameSecond plSecond + change <- fmap toChangeList (parseChange inst) + third <- traverse renameSecond change return (first, second, third) where diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index 046133b2d..e15c9da93 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -11,7 +11,6 @@ module Modelling.PetriNet.Diagram ( drawNet, drawNetWithCapacity, getDefaultNet, - getDefaultNetWithCapacities, getNet, renderWith, renderWithCapacity, @@ -31,7 +30,6 @@ import Modelling.Auxiliary.Diagrams ( trailBetween, ) import Modelling.PetriNet.Parser ( - addCapacities, netToGr, netToGrCapacity, parseNet, @@ -41,7 +39,6 @@ import Modelling.PetriNet.Types ( CapacityNode, DrawSettings (..), Net (mapNet, traverseNet), - PetriLike, ) import Control.Arrow (first) @@ -153,15 +150,6 @@ getDefaultNet inst = do let rename = simpleRenameWith pl traverseNet rename pl -getDefaultNetWithCapacities - :: MonadThrow m - => AlloyInstance - -> m (PetriLike CapacityNode String) -getDefaultNetWithCapacities inst = do - pl <- parseNet "defaultFlow" "defaultTokens" inst >>= addCapacities inst - let rename = simpleRenameWith pl - traverseNet rename pl - {-| Obtain the Petri net like graph by drawing Nodes and connections between them using the specific functions @drawNode@ and @drawEdge@. From ce94f2b1463fe4cbe04bcedd5bad83c800f257fb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 14:42:03 +0200 Subject: [PATCH 220/256] for clarity --- src/Modelling/PetriNet/Capacity.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index a7f3724f1..a1332fdf9 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -354,8 +354,8 @@ combinedCapacity alloyF alloyC config segment = do plSecond <- parseNet "flow" "tokens" inst let renameSecond = simpleRenameWith plSecond second <- traverseNet renameSecond plSecond - change <- fmap toChangeList (parseChange inst) - third <- traverse renameSecond change + change <- parseChange inst + third <- traverse renameSecond (toChangeList change) return (first, second, third) where From 1335fc0a695a1a17902875142d0cecb4ed74ef52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Sun, 20 Apr 2025 16:25:49 +0200 Subject: [PATCH 221/256] generalize and reuse parseRenamedNet --- src/Modelling/PetriNet/Capacity.hs | 16 +++++++++------- src/Modelling/PetriNet/Diagram.hs | 18 +++++++----------- src/Modelling/PetriNet/MatchToMath.hs | 4 ++-- src/Modelling/PetriNet/Parser.hs | 18 +++++------------- 4 files changed, 23 insertions(+), 33 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index a1332fdf9..bcaacaf9a 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -34,6 +34,9 @@ import qualified Modelling.PetriNet.Types as Find ( import qualified Modelling.PetriNet.Types as Pick ( CapacityConfig (..), ) +import qualified Data.Bimap as BM ( + lookup, + ) import qualified Data.Map as M ( empty, fromList, @@ -77,7 +80,8 @@ import Modelling.PetriNet.Parser ( addCapacities, parseChange, parseNet, - simpleRenameWith, + parseRenamedNet, + simpleNameMap, ) import Modelling.PetriNet.Reach.Type ( parsePlacePrec, @@ -348,14 +352,12 @@ combinedCapacity alloyF alloyC config segment = do [] -> randomInstance list plFirst <- parseNet "defaultFlow" "defaultTokens" inst >>= addCapacities inst - let renameFirst = simpleRenameWith plFirst - first <- traverseNet renameFirst plFirst + let nameMapFirst = simpleNameMap plFirst + first <- traverseNet (`BM.lookup` nameMapFirst) plFirst - plSecond <- parseNet "flow" "tokens" inst - let renameSecond = simpleRenameWith plSecond - second <- traverseNet renameSecond plSecond + (second, nameMapSecond) <- parseRenamedNet "flow" "tokens" inst change <- parseChange inst - third <- traverse renameSecond (toChangeList change) + third <- traverse (`BM.lookup` nameMapSecond) (toChangeList change) return (first, second, third) where diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index e15c9da93..3da811b68 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -17,6 +17,7 @@ module Modelling.PetriNet.Diagram ( ) where import qualified Diagrams.TwoD.GraphViz as GV (getGraph) +import qualified Data.Bimap as BM (lookup) import qualified Data.Map as M (foldlWithKey) import Capabilities.Cache (MonadCache, cache, short) @@ -32,13 +33,12 @@ import Modelling.Auxiliary.Diagrams ( import Modelling.PetriNet.Parser ( netToGr, netToGrCapacity, - parseNet, - simpleRenameWith, + parseRenamedNet, ) import Modelling.PetriNet.Types ( CapacityNode, DrawSettings (..), - Net (mapNet, traverseNet), + Net (mapNet), ) import Control.Arrow (first) @@ -134,21 +134,17 @@ getNet -> AlloyInstance -> m (p n String, t String) getNet parseSpecial inst = do - pl <- parseNet "flow" "tokens" inst - let rename = simpleRenameWith pl - net <- traverseNet rename pl + (net, nameMap) <- parseRenamedNet "flow" "tokens" inst special <- parseSpecial inst - renamedSpecial <- traverse rename special + renamedSpecial <- traverse (`BM.lookup` nameMap) special return (net, renamedSpecial) getDefaultNet :: (MonadThrow m, Net p n) => AlloyInstance -> m (p n String) -getDefaultNet inst = do - pl <- parseNet "defaultFlow" "defaultTokens" inst - let rename = simpleRenameWith pl - traverseNet rename pl +getDefaultNet = + fmap fst . parseRenamedNet "defaultFlow" "defaultTokens" {-| Obtain the Petri net like graph by drawing Nodes and connections between them diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 8bd27af25..0124b600f 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -320,7 +320,7 @@ matchToMath ds toOutput config segment = do return ((net, ds), math, changes') else matchToMath ds toOutput config segment where - parse = parseRenamedNet "flow" "tokens" + parse = fmap fst . parseRenamedNet "flow" "tokens" firstM :: Monad m => (a -> m b) -> (a, c) -> m (b, c) firstM f (p, c) = (,c) <$> f p @@ -343,7 +343,7 @@ mathInstance -> AlloyInstance -> RandT g m (String, p n String, Math) mathInstance config inst = do - petriLike <- parseRenamedNet "flow" "tokens" inst + petriLike <- fst <$> parseRenamedNet "flow" "tokens" inst petriLike' <- fst <$> shuffleNames petriLike let math = toPetriMath petriLike' let f = renderFalse petriLike' config diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 101e17f2a..a2b829f40 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -17,7 +17,7 @@ module Modelling.PetriNet.Parser ( parseChange, parseNet, parseRenamedNet, - simpleNameMap, simpleRename, simpleRenameWith, + simpleNameMap, simpleRename, ) where import qualified Modelling.PetriNet.Types as PN ( @@ -91,27 +91,19 @@ convertPetri f t inst = do {-| Parse a 'Net' graph from an 'AlloyInstance' given the instances flow and token set names. -And return an already renamed Petri net. +Return an already renamed Petri net, along with the renaming map. -} parseRenamedNet :: (MonadThrow m, Net p n) => String -> String -> AlloyInstance - -> m (p n String) + -> m (p n String, Bimap Object String) parseRenamedNet flowSetName tokenSetName inst = do petriLike <- parseNet flowSetName tokenSetName inst - let rename = simpleRenameWith petriLike - traverseNet rename petriLike - -{-| -Transform a given value into a 'String' by replacing it according to the -'simpleNameMap' retrieved by the given 'Net'. --} -simpleRenameWith :: (MonadThrow m, Net p n, Ord a) => p n a -> a -> m String -simpleRenameWith petriLike x = do let nameMap = simpleNameMap petriLike - BM.lookup x nameMap + net <- traverseNet (`BM.lookup` nameMap) petriLike + return (net, nameMap) {-| Parse a `Net' graph from an 'AlloyInstance' given the instances flow and From dfe15c46c33fcf6cb04528338b861181f8835d2e Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 21 Apr 2025 00:02:09 +0200 Subject: [PATCH 222/256] added testing for capacity --- test/Modelling/PetriNet/CapacitySpec.hs | 109 ++++++++++++++++++++++++ 1 file changed, 109 insertions(+) create mode 100644 test/Modelling/PetriNet/CapacitySpec.hs diff --git a/test/Modelling/PetriNet/CapacitySpec.hs b/test/Modelling/PetriNet/CapacitySpec.hs new file mode 100644 index 000000000..cb879eaf0 --- /dev/null +++ b/test/Modelling/PetriNet/CapacitySpec.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Modelling.PetriNet.CapacitySpec where + +import qualified Modelling.PetriNet.Types as Find ( + CapacityConfig (alloyConfig), + ) + +import Modelling.PetriNet.Capacity ( + checkCapacityConfigs, + checkCapacityConfig, + combinedCapacityInstance, + petriNetFindCapacity, + ) +import Modelling.PetriNet.Diagram ( + getDefaultNet, + getNet, + ) +import Modelling.PetriNet.Parser ( + parseChange, + ) +import Modelling.PetriNet.Types ( + AdvConfig (AdvConfig), + BasicConfig (..), + CapacityConfig (CapacityConfig), + CapacityNode (..), + PetriLike (..), + PetriChangeList (..), + SimplePetriLike, + defaultCapacityConfig, + toChangeList, + ) + +import Modelling.PetriNet.TestCommon ( + alloyTestConfig, + checkConfigs, + defaultConfigTaskGeneration, + firstInstanceConfig, + testTaskGeneration, + validAdvConfigs, + validConfigsForPick, + validGraphConfig, + ) +import Settings (configDepth) +import Data.Maybe (isNothing) + +import Test.Hspec + +spec :: Spec +spec = do + describe "defaultCapacityConfig" $ + checkConfigs checkCapacityConfigs [defaultCapacityConfig] + describe "validFindCapacityConfigs" $ + checkConfigs checkCapacityConfigs findConfigs' + describe "combinedCapacity" $ do + defaultConfigTaskGeneration + (combinedCapacityInstance defaultCapacityConfig { + Find.alloyConfig = firstInstanceConfig + } 0) + 0 + $ checkCapacityInstance @(SimplePetriLike _) + testCapacityConfig findConfigs + where + findConfigs' = validFindCapacityConfigs + validFinds + (AdvConfig Nothing Nothing Nothing) + findConfigs = validAdvConfigs >>= validFindCapacityConfigs validFinds + validFinds = validConfigsForPick 0 configDepth + +checkCapacityInstance :: (PetriLike CapacityNode String, a, PetriChangeList String) -> Bool +checkCapacityInstance (_, _, change) = isValidCapacity change + +testCapacityConfig :: [CapacityConfig] -> Spec +testCapacityConfig = testTaskGeneration + petriNetFindCapacity + (\inst -> do + first <- getDefaultNet inst + (second, third) <- getNet (fmap toChangeList . parseChange) inst + return (first, second, third) + ) + $ checkCapacityInstance @(SimplePetriLike _) + +validFindCapacityConfigs :: [(BasicConfig, _)] -> AdvConfig -> [CapacityConfig] +validFindCapacityConfigs cs advancedConfig = do + (bc, _) <- cs + (maxCapacity, newArrows, oneMin, distractors, atMost) <- validCapacityConfig bc + return $ CapacityConfig bc advancedConfig maxCapacity newArrows oneMin distractors atMost validGraphConfig False alloyTestConfig + +validCapacityConfig :: BasicConfig -> [(Int, (Int, Int), Int, (Int, Int), Maybe Int)] +validCapacityConfig bc@BasicConfig{ places, transitions, maxFlowPerEdge, maxTokensPerPlace, atLeastActive } = + filter (\(maxCap, arrows, oneMinCap, distract, most) -> isNothing (checkCapacityConfig bc maxCap arrows oneMinCap distract most)) $ do + maxCapacity <- [max maxFlowPerEdge maxTokensPerPlace .. 5] + newArrows <- [(a, b) | a <- [places .. 2 * transitions * places], b <- [a .. 2 * transitions * places]] + oneMin <- [1 .. maxCapacity] + distractors <- [(x, y) | x <- [0 .. transitions], y <- [transitions .. transitions - atLeastActive], x <= y] + atMost <- Nothing : [Just n | n <- [0 .. transitions]] + return (maxCapacity, newArrows, oneMin, distractors, atMost) + +isValidCapacity :: PetriChangeList String -> Bool +isValidCapacity c@(ChangeList {tokenChanges = ts, flowChanges = fs}) + | any (\(_, token) -> token < 0) ts = error $ show c + | any (\(source, target, _) -> source == target) fs = error $ show c + | any (\(_, _, flow) -> flow <= 0) fs = error $ show c + | otherwise = True From 9851296fdc82b01a899109ea17a8c46d68f7651d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 21 Apr 2025 00:07:29 +0200 Subject: [PATCH 223/256] added new parseNet function (for now) that only parses givenNodes --- src/Modelling/PetriNet/Capacity.hs | 4 ++-- src/Modelling/PetriNet/Parser.hs | 28 +++++++++++++++++++++++++++- 2 files changed, 29 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index bcaacaf9a..b00a2b7ee 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -79,7 +79,7 @@ import Modelling.PetriNet.FindActivatedTransitions ( import Modelling.PetriNet.Parser ( addCapacities, parseChange, - parseNet, + parseGivenNet, parseRenamedNet, simpleNameMap, ) @@ -351,7 +351,7 @@ combinedCapacity alloyF alloyC config segment = do x':_ -> return x' [] -> randomInstance list - plFirst <- parseNet "defaultFlow" "defaultTokens" inst >>= addCapacities inst + plFirst <- parseGivenNet "defaultFlow" "defaultTokens" inst >>= addCapacities inst let nameMapFirst = simpleNameMap plFirst first <- traverseNet (`BM.lookup` nameMapFirst) plFirst diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index a2b829f40..a38dc97f2 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -15,6 +15,7 @@ module Modelling.PetriNet.Parser ( netToGr, netToGrCapacity, parseChange, + parseGivenNet, parseNet, parseRenamedNet, simpleNameMap, simpleRename, @@ -131,13 +132,38 @@ parseNet flowSetName tokenSetName inst = do where foldrFlip f = flip $ foldr f +parseGivenNet + :: (MonadThrow m, Net p n) + => String -- ^ the name of the flow set + -> String -- ^ the name of the token set + -> AlloyInstance + -> m (p n Object) +parseGivenNet flowSetName tokenSetName inst = do + givenPlaces <- singleSig inst "this" "givenPlaces" "" + givenTrans <- singleSig inst "this" "givenTransitions" "" + let nodes = Set.toList givenPlaces ++ Set.toList givenTrans + + rawTokens <- doubleSig inst "this" "Places" tokenSetName + let tokens = relToMap (second oIndex) rawTokens + + flow <- tripleSig inst "this" "Nodes" flowSetName + + return + . foldrFlip (\(x, y, z) -> alterFlow x (oIndex z) y) flow + . foldrFlip + (\x -> alterNode x $ Map.lookup x tokens >>= Set.lookupMin) + nodes + $ emptyNet + where + foldrFlip f = flip $ foldr f + addCapacities :: MonadThrow m => AlloyInstance -> PetriLike CapacityNode Object -> m (PetriLike CapacityNode Object) addCapacities inst net = do - nodes <- singleSig inst "this" "Nodes" "" + nodes <- singleSig inst "this" "placesWithCapacity" "" rawCapacity <- doubleSig inst "this" "placesWithCapacity" "capacity" From e9a91172d19c868fdd70fed757e58506b155aded Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 21 Apr 2025 00:07:59 +0200 Subject: [PATCH 224/256] fixed indentation for alloy code --- src/Modelling/PetriNet/Capacity.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index b00a2b7ee..0fb777930 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -518,7 +518,7 @@ exactly #{transitions basicC} Transitions, #{petriScopeBitWidth (basicConfigBitW ++ (case atMostActive of Nothing -> "" - Just n -> "#" ++ activated ++ " <= " ++ show n ++ "\n") + Just n -> " #" ++ activated ++ " <= " ++ show n ++ "\n") ++ " theActivatedTransitions[" ++ activated ++ "]" newArrowsWithComplementConstraints (minNewArrowsMin, minNewArrowsMax) = From c2ab1351a4a164c7c422a18f4e8421add6656a07 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 21 Apr 2025 00:38:19 +0200 Subject: [PATCH 225/256] fixed .cabal consistency --- modelling-tasks.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/modelling-tasks.cabal b/modelling-tasks.cabal index 7b3d74d4c..5c80c358e 100644 --- a/modelling-tasks.cabal +++ b/modelling-tasks.cabal @@ -189,6 +189,7 @@ test-suite modelling-tasks-test Modelling.CdOd.SelectValidCdSpec Modelling.Common Modelling.PetriNet.AlloySpec + Modelling.PetriNet.CapacitySpec Modelling.PetriNet.ConcurrencySpec Modelling.PetriNet.ConflictSpec Modelling.PetriNet.DiagramSpec From ea396ca5beae2a5e1433568ca2a1dd0a5c95aef4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Mon, 21 Apr 2025 09:36:41 +0200 Subject: [PATCH 226/256] remove polymorphism of CapacityInstance over only one of the net types --- src/Modelling/PetriNet/Capacity.hs | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 0fb777930..ccdf8231b 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -99,7 +99,6 @@ import Modelling.PetriNet.Types ( PetriChangeList (..), PetriLike (PetriLike, allNodes), SimpleNode (..), - SimplePetriNet, CapacityNode (..), basicConfigBitWidthInput, checkBasicConfig, @@ -148,11 +147,11 @@ import Text.Parsec.String (Parser) import Text.Read (readMaybe) -data CapacityInstance a = CapacityInstance { +data CapacityInstance = CapacityInstance { drawWith :: !DrawSettings, toFind :: !(PetriChangeList String), originalNet :: !(PetriLike CapacityNode String), - transformedNet :: !a, + transformedNet :: !(PetriLike SimpleNode String), numberOfPlaces :: !Int, numberOfTransitions :: !Int, showSolution :: !Bool @@ -160,11 +159,11 @@ data CapacityInstance a = CapacityInstance { deriving (Show) capacityGenerate - :: (MonadAlloy m, MonadThrow m, Net p n) + :: (MonadAlloy m, MonadThrow m) => CapacityConfig -> Int -> Int - -> m (CapacityInstance (p n String)) + -> m CapacityInstance capacityGenerate config seed segment = flip evalRandT (mkStdGen seed) $ do gl <- oneOf $ graphLayouts gc @@ -208,7 +207,7 @@ simpleCapacityTask OutputCapable m ) => FilePath - -> CapacityInstance SimplePetriNet + -> CapacityInstance -> LangM m simpleCapacityTask = capacityTask @@ -218,11 +217,10 @@ capacityTask MonadDiagrams m, MonadGraphviz m, MonadThrow m, - Net p n, OutputCapable m ) => FilePath - -> CapacityInstance (p n String) + -> CapacityInstance -> LangM m capacityTask path task = do paragraph $ translate $ do @@ -273,7 +271,7 @@ capacityTask path task = do capacitySyntax :: OutputCapable m - => CapacityInstance net + => CapacityInstance -> ([(String, Int)], [(String, String, Int)]) -> LangM' m () capacitySyntax task (tokenChanges, flowChanges) = do @@ -306,7 +304,7 @@ capacitySyntax task (tokenChanges, flowChanges) = do capacityEvaluation :: (Monad m, OutputCapable m) - => CapacityInstance net + => CapacityInstance -> ([(String, Int)], [(String, String, Int)]) -> Rated m capacityEvaluation task (tokenChanges, flowChanges) = do @@ -328,7 +326,7 @@ capacityEvaluation task (tokenChanges, flowChanges) = do combineLists :: Maybe String -> Maybe String -> Maybe String combineLists = liftA2 (\string1 string2 -> string1 ++ "," ++ string2) -capacitySolution :: CapacityInstance net -> ([(String, Int)], [(String, String, Int)]) +capacitySolution :: CapacityInstance -> ([(String, Int)], [(String, String, Int)]) capacitySolution task = (tokenChanges $ toFind task, flowChanges $ toFind task) combinedCapacity @@ -597,7 +595,7 @@ checkCapacityConfig BasicConfig { | otherwise = Nothing -defaultCapacityInstance :: CapacityInstance SimplePetriNet +defaultCapacityInstance :: CapacityInstance defaultCapacityInstance = CapacityInstance { drawWith = DrawSettings { withPlaceNames = True, From ab7e21d4d46d3d76b55d7b1d6372d7f02025ae44 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 21 Apr 2025 23:05:24 +0200 Subject: [PATCH 227/256] tried to parse with or without givenNodes in parseNet --- app/capacity.hs | 34 ++++++++++++++++++++++ src/Modelling/PetriNet/Parser.hs | 48 +++++++++++--------------------- 2 files changed, 50 insertions(+), 32 deletions(-) diff --git a/app/capacity.hs b/app/capacity.hs index e27d8ce1e..4136acfe6 100644 --- a/app/capacity.hs +++ b/app/capacity.hs @@ -31,6 +31,40 @@ import System.IO ( ) import Text.Pretty.Simple (pPrint) import Text.Read (readMaybe) +--import Control.Monad (forM_) + +{- +main :: IO () +main = do + hSetBuffering stdout NoBuffering + putStrLn "Generating 15 instances using defaultCapacityConfig..." + forM_ [0..14] mainFind + +mainFind :: Int -> IO () +mainFind i = forceErrors $ do + let theConfig = defaultCapacityConfig + lift $ pPrint theConfig + {-pls, trns, maxCap, newFlowMin, newFlowMax, oneMin, distractMin, distractMax, atMostAct) <- lift $ userInput theConfig + let config = theConfig { + basicConfig = basicConfig { + places = pls, + transitions = trns + }, + maxCapacity = maxCap, + newArrowsWithComplement = (newFlowMin, newFlowMax), + oneMinCapacity = oneMin, + distractors = (distractMin, distractMax), + atMostActive = atMostAct + } :: CapacityConfig-} + let c = checkCapacityConfigs theConfig + if isNothing c + then do + t <- capacityGenerate theConfig 0 i + lift . (`withLang` English) $ simpleCapacityTask ("tmp/"++ show (i+1)++"/") t + lift $ print t + else + lift $ print c +-} main :: IO () main = do diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index a38dc97f2..5db2abd05 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -12,10 +12,10 @@ module Modelling.PetriNet.Parser ( addCapacities, asSingleton, convertPetri, + doubleSig, netToGr, netToGrCapacity, parseChange, - parseGivenNet, parseNet, parseRenamedNet, simpleNameMap, simpleRename, @@ -42,6 +42,7 @@ import qualified Data.Map.Lazy as Map ( import Data.Maybe (fromMaybe) import Modelling.Auxiliary.Common (Object (Object, oName, oIndex), toMap) +import Modelling.PetriNet.Alloy (unscopedSingleSig) import Modelling.PetriNet.Types ( CapacityNode (..), Net (emptyNet, outFlow, alterFlow, alterNode, traverseNet), @@ -86,7 +87,7 @@ convertPetri -> AlloyInstance -- ^ the Petri net 'AlloyInstance' -> m Petri convertPetri f t inst = do - p <- parseNet f t inst + p <- parseNet False f t inst petriLikeToPetri p {-| @@ -101,23 +102,31 @@ parseRenamedNet -> AlloyInstance -> m (p n String, Bimap Object String) parseRenamedNet flowSetName tokenSetName inst = do - petriLike <- parseNet flowSetName tokenSetName inst + petriLike <- parseNet False flowSetName tokenSetName inst let nameMap = simpleNameMap petriLike net <- traverseNet (`BM.lookup` nameMap) petriLike return (net, nameMap) {-| -Parse a `Net' graph from an 'AlloyInstance' given the instances flow and +Parse a `Net' graph from an 'AlloyInstance', with or without givenNodes, given the instances flow and token set names. -} parseNet :: (MonadThrow m, Net p n) - => String -- ^ the name of the flow set + => Bool -- ^ whether to only parse the given nodes + -> String -- ^ the name of the flow set -> String -- ^ the name of the token set -> AlloyInstance -- ^ the Petri net 'AlloyInstance' -> m (p n Object) -parseNet flowSetName tokenSetName inst = do - nodes <- singleSig inst "this" "Nodes" "" +parseNet onlyGiven flowSetName tokenSetName inst = do + nodes <- case onlyGiven of + True -> do + nodes <- unscopedSingleSig inst "$givenNodes" "" + return $ Set.toList nodes + False -> do + nodes <- singleSig inst "this" "Nodes" "" + return $ Set.toList nodes + rawTokens <- doubleSig inst "this" "Places" tokenSetName let tokens = relToMap (second oIndex) rawTokens @@ -132,31 +141,6 @@ parseNet flowSetName tokenSetName inst = do where foldrFlip f = flip $ foldr f -parseGivenNet - :: (MonadThrow m, Net p n) - => String -- ^ the name of the flow set - -> String -- ^ the name of the token set - -> AlloyInstance - -> m (p n Object) -parseGivenNet flowSetName tokenSetName inst = do - givenPlaces <- singleSig inst "this" "givenPlaces" "" - givenTrans <- singleSig inst "this" "givenTransitions" "" - let nodes = Set.toList givenPlaces ++ Set.toList givenTrans - - rawTokens <- doubleSig inst "this" "Places" tokenSetName - let tokens = relToMap (second oIndex) rawTokens - - flow <- tripleSig inst "this" "Nodes" flowSetName - - return - . foldrFlip (\(x, y, z) -> alterFlow x (oIndex z) y) flow - . foldrFlip - (\x -> alterNode x $ Map.lookup x tokens >>= Set.lookupMin) - nodes - $ emptyNet - where - foldrFlip f = flip $ foldr f - addCapacities :: MonadThrow m => AlloyInstance From 1d98d3a2e0aae4867a3cc9c30797e64b3a1b2f86 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 21 Apr 2025 23:09:22 +0200 Subject: [PATCH 228/256] updated ...Task with with complementMap --- src/Modelling/PetriNet/Capacity.hs | 43 +++++++++++++++++++----------- 1 file changed, 28 insertions(+), 15 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index ccdf8231b..7b2c7a5ea 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -233,35 +233,48 @@ capacityTask path task = do paragraph $ do translate $ do english [iii| - Given the isolated Places. With how many tokens and how should they be connected to Transitions so that the - resulting Petri net without capacities is equivalent to the given Petri net with capacities? + Given the not yet existing complement places that belong to the original places. With how many + tokens should they be generated, and how should they be connected to transitions, + so that the resulting Petri net without capacities is equivalent to the given Petri net with capacities? |] german [iii| - Gegeben der isolierten Stellen. Mit wie vielen Marken und wie sollten diese mit Transitionen verbunden werden, sodass - das resultierende Petrinetz ohne Kapazitäten äquivalent zum gegebenen Petrinetz mit Kapazitäten ist? + Gegeben der noch nicht existierenden, zu den Stellen gehörenden, Komplementstellen. Mit wie vielen Marken + sollten sie erstellt werden und wie sollten sie mit Transitionen verbunden werden, + sodass das resultierende Petrinetz ohne Kapazitäten äquivalent zu dem gegebenen Petrinetz mit Kapazitäten ist? |] translate $ do english [iii| - State your answer by giving a tuple consisting of the complement places and their flows. + State your answer by giving a tuple consisting of: + the complement places with their initial number of tokens, and + the flows connected to the complement places (incoming and outgoing). #{" "}|] german [iii| - Geben Sie Ihre Antwort in Form eines Tupels an, das aus den Komplementstellen und ihren Flüssen besteht. + Geben Sie Ihre Antwort in Form eines Tupels an, bestehend aus: + den Komplementstellen mit ihrer initialen Anzahl an Marken und + den Flüssen, die mit Komplementstellen verbunden sind (eingehend oder ausgehend). #{" "}|] translate $ do - english [i|Stating |] - german [i|Die Angabe von |] + english "The used mapping between complement places and places:" + german "Die genutzte Zuordnung zwischen Komplementstellen und Stellen:" + translate $ do + english $ intercalate ", " + ["Complement place " ++ cap ++ " to place " ++ add | (cap, add) <- complementMap task] + german $ intercalate ", " + ["Komplementstelle " ++ cap ++ " zu Stelle " ++ add | (cap, add) <- complementMap task] + translate $ do + english [i|. Stating |] + + german [i|. Die Angabe von |] let ts :: ([(String, Int)], [(String, String, Int)]) ts = ([("s1",2), ("s2",0)], [("t1","s1",1), ("t2","s1",1), ("s2","t2",2)]) code $ show ts translate $ do - english ("as answer would indicate that there are two complement places - s1 with 2 tokens and s2 with 0 tokens - and t1 points to s1 with a weight of 1, " ++ + english ("as answer would indicate that there are two complement places - s1 with 2 tokens" ++ + "and s2 with 0 tokens - and t1 points to s1 with a weight of 1, " ++ "t2 points to s1 with a weight of 1 and s2 connects to t2 with a weight of 2.") - german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - s1 mit 2 Token und s2 mit 0 Token - und t1 zeigt auf s1 mit einem Gewicht von 1, " ++ - "t2 zeigt auf s1 mit einem Gewicht von 1, und s2 ist mit t2 mit einem Gewicht von 2 verbunden.") - translate $ do - english "The first complement place s1 belongs to the first shown place s3, the second complement place s2 belongs to the second shown place s4 and so on." - german ("Die erste Komplementstelle s1 gehört zu der ersten gezeigten Stelle s3," ++ - "die zweite Komplementstelle s2 gehört zu der zweiten gezeigten Stelle s4 und so weiter.") + german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - s1 mit 2 Token" ++ + "und s2 mit 0 Token - und t1 zeigt auf s1 mit einem Gewicht von 1, " ++ + "t2 zeigt auf s1 mit einem Gewicht von 1, und s2 ist mit t2 mit einem Gewicht von 2 verbunden.") translate $ do english "The order of tuples within the lists does not matter here." german "Die Reihenfolge der Tupel innerhalb der Listen spielt hierbei keine Rolle." From c14c9ba51415ea237037952f453a5f6f7d28ef1c Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 21 Apr 2025 23:09:37 +0200 Subject: [PATCH 229/256] renamed variables --- src/Modelling/PetriNet/Capacity.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 7b2c7a5ea..f6ed7edd6 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -362,15 +362,18 @@ combinedCapacity alloyF alloyC config segment = do x':_ -> return x' [] -> randomInstance list - plFirst <- parseGivenNet "defaultFlow" "defaultTokens" inst >>= addCapacities inst - let nameMapFirst = simpleNameMap plFirst - first <- traverseNet (`BM.lookup` nameMapFirst) plFirst + (transformed, nameMap) <- parseRenamedNet "flow" "tokens" inst + + plFirst <- parseNet True "defaultFlow" "defaultTokens" inst >>= addCapacities inst + original <- traverseNet (`BM.lookup` nameMap) plFirst - (second, nameMapSecond) <- parseRenamedNet "flow" "tokens" inst change <- parseChange inst - third <- traverse (`BM.lookup` nameMapSecond) (toChangeList change) + condition <- traverse (`BM.lookup` nameMap) (toChangeList change) + + complements <- doubleSig inst "this" "placesWithCapacity" "complement" + let complementMap = generateComplementMap nameMap (Set.toList complements) - return (first, second, third) + return (original, transformed, condition, complementMap) where randomInstance list = do n <- randomInSegment segment (1 + ((length list - segment - 1) `div` 4)) From b7b680d608fbebb54277960a47748b368905126d Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 21 Apr 2025 23:09:57 +0200 Subject: [PATCH 230/256] updated imports --- src/Modelling/PetriNet/Capacity.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index f6ed7edd6..5883e2abb 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -37,6 +37,7 @@ import qualified Modelling.PetriNet.Types as Pick ( import qualified Data.Bimap as BM ( lookup, ) +import qualified Data.Set as Set import qualified Data.Map as M ( empty, fromList, @@ -79,9 +80,9 @@ import Modelling.PetriNet.FindActivatedTransitions ( import Modelling.PetriNet.Parser ( addCapacities, parseChange, - parseGivenNet, + parseNet, parseRenamedNet, - simpleNameMap, + doubleSig, ) import Modelling.PetriNet.Reach.Type ( parsePlacePrec, @@ -131,9 +132,13 @@ import Control.Monad.Random ( evalRandT, mkStdGen ) +import Data.Bimap (Bimap) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) +import Data.List (intercalate) import Data.Maybe (fromMaybe) +import Data.Maybe (mapMaybe) +import Modelling.Auxiliary.Common (Object) import Data.String.Interpolate (i, iii) import Text.Parsec ( char, From 0fff0c29086b87da8fae1a69571aa5c1a8c1d617 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 21 Apr 2025 23:13:06 +0200 Subject: [PATCH 231/256] the connection between complement place and palce is parsed from alloy instance --- src/Modelling/PetriNet/Capacity.hs | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 5883e2abb..fd8f4b748 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -157,6 +157,7 @@ data CapacityInstance = CapacityInstance { toFind :: !(PetriChangeList String), originalNet :: !(PetriLike CapacityNode String), transformedNet :: !(PetriLike SimpleNode String), + complementMap :: ![(String, String)], numberOfPlaces :: !Int, numberOfTransitions :: !Int, showSolution :: !Bool @@ -173,7 +174,7 @@ capacityGenerate config seed segment = flip evalRandT (mkStdGen seed) $ do gl <- oneOf $ graphLayouts gc - (original, transformed, condition) <- combinedCapacityInstance config segment + (original, transformed, condition, complementMap) <- combinedCapacityInstance config segment return $ CapacityInstance { drawWith = DrawSettings @@ -186,6 +187,7 @@ capacityGenerate config seed segment = , toFind = condition , originalNet = original , transformedNet = transformed + , complementMap = complementMap , numberOfPlaces = places bc , numberOfTransitions = transitions bc , showSolution = Find.printSolution config @@ -198,7 +200,7 @@ combinedCapacityInstance :: (MonadThrow m, RandomGen g, MonadAlloy m, Net p n) => CapacityConfig -> Int - -> RandT g m (PetriLike CapacityNode String, p n String, PetriChangeList String) + -> RandT g m (PetriLike CapacityNode String, p n String, PetriChangeList String, [(String, String)]) combinedCapacityInstance = combinedCapacity petriNetFindCapacity Find.alloyConfig @@ -353,7 +355,7 @@ combinedCapacity -> (config -> AlloyConfig) -> config -> Int - -> RandT g m (PetriLike CapacityNode String, p n String, PetriChangeList String) + -> RandT g m (PetriLike CapacityNode String, p n String, PetriChangeList String, [(String, String)]) combinedCapacity alloyF alloyC config segment = do let is = Find.maxInstances (alloyC config) list <- getInstances is (Find.timeout $ alloyC config) (alloyF config) @@ -384,6 +386,18 @@ combinedCapacity alloyF alloyC config segment = do n <- randomInSegment segment (1 + ((length list - segment - 1) `div` 4)) return $ list !! n +generateComplementMap + :: Bimap Object String + -> [(Object, Object)] + -> [(String, String)] +generateComplementMap nameMap complements = + mapMaybe placeTuple complements + where + placeTuple (cap, add) = do + capName <- BM.lookup cap nameMap + addName <- BM.lookup add nameMap + return (capName, addName) + petriNetFindCapacity :: CapacityConfig -> String petriNetFindCapacity CapacityConfig { basicConfig, @@ -651,6 +665,7 @@ toFind = ChangeList { ("t3",SimpleTransition {flowOut = M.fromList [("s2",1)]}) ] }, + complementMap = [("s1", "s3"), ("s2", "s4")], numberOfPlaces = 4, numberOfTransitions = 3, showSolution = False From d2356ca80eaf6707f5f233fd3e4682a88e53bd1b Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Tue, 22 Apr 2025 00:23:48 +0200 Subject: [PATCH 232/256] fixed mistakes in Capacity --- src/Modelling/PetriNet/Capacity.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index fd8f4b748..4d7986054 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -48,6 +48,7 @@ import Capabilities.Cache (MonadCache) import Capabilities.Diagrams (MonadDiagrams) import Capabilities.Graphviz (MonadGraphviz) import Modelling.Auxiliary.Common ( + Object, TaskGenerationException (NoInstanceAvailable), oneOf, ) @@ -136,9 +137,7 @@ import Data.Bimap (Bimap) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) import Data.List (intercalate) -import Data.Maybe (fromMaybe) -import Data.Maybe (mapMaybe) -import Modelling.Auxiliary.Common (Object) +import Data.Maybe (fromMaybe, mapMaybe) import Data.String.Interpolate (i, iii) import Text.Parsec ( char, @@ -390,8 +389,7 @@ generateComplementMap :: Bimap Object String -> [(Object, Object)] -> [(String, String)] -generateComplementMap nameMap complements = - mapMaybe placeTuple complements +generateComplementMap nameMap = mapMaybe placeTuple where placeTuple (cap, add) = do capName <- BM.lookup cap nameMap From 93fa26f381b6313a738fae264412d22118920fec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 22 Apr 2025 09:07:42 +0200 Subject: [PATCH 233/256] refactor how the nodes set is accessed during Petri net parsing --- src/Modelling/PetriNet/Alloy.hs | 6 +-- src/Modelling/PetriNet/Capacity.hs | 10 +++-- src/Modelling/PetriNet/Concurrency.hs | 4 +- src/Modelling/PetriNet/Conflict.hs | 6 +-- src/Modelling/PetriNet/Diagram.hs | 5 ++- .../PetriNet/FindActivatedTransitions.hs | 2 +- src/Modelling/PetriNet/MatchToMath.hs | 5 ++- src/Modelling/PetriNet/Parser.hs | 39 ++++++++----------- test/Modelling/PetriNet/DiagramSpec.hs | 4 +- 9 files changed, 41 insertions(+), 40 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 467fe843c..b43ae9157 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -248,11 +248,11 @@ randomInSegment segment segLength = do unscopedSingleSig :: MonadThrow m - => AlloyInstance - -> String + => String -> String + -> AlloyInstance -> m (Set Object) -unscopedSingleSig inst st nd = do +unscopedSingleSig st nd inst = do sig <- lookupSig (unscoped st) inst getSingleAs nd (return .: Object) sig diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 4d7986054..7720303fc 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -64,6 +64,7 @@ import Modelling.PetriNet.Alloy ( modulePetriConstraints, modulePetriSignature, randomInSegment, + unscopedSingleSig, ) import Modelling.PetriNet.Diagram ( renderWith, @@ -84,6 +85,7 @@ import Modelling.PetriNet.Parser ( parseNet, parseRenamedNet, doubleSig, + singleSig, ) import Modelling.PetriNet.Reach.Type ( parsePlacePrec, @@ -368,10 +370,12 @@ combinedCapacity alloyF alloyC config segment = do x':_ -> return x' [] -> randomInstance list - (transformed, nameMap) <- parseRenamedNet "flow" "tokens" inst + (transformed, nameMap) <- + parseRenamedNet (singleSig "this" "Nodes" "") "flow" "tokens" inst - plFirst <- parseNet True "defaultFlow" "defaultTokens" inst >>= addCapacities inst - original <- traverseNet (`BM.lookup` nameMap) plFirst + original <- + parseNet (unscopedSingleSig "$givenNodes" "") "defaultFlow" "defaultTokens" inst + >>= \net -> addCapacities inst net >>= traverseNet (`BM.lookup` nameMap) change <- parseChange inst condition <- traverse (`BM.lookup` nameMap) (toChangeList change) diff --git a/src/Modelling/PetriNet/Concurrency.hs b/src/Modelling/PetriNet/Concurrency.hs index 29f068790..9d82c148b 100644 --- a/src/Modelling/PetriNet/Concurrency.hs +++ b/src/Modelling/PetriNet/Concurrency.hs @@ -481,8 +481,8 @@ It throws an error instead if unexpected behaviour occurs. -} parseConcurrency :: MonadThrow m => AlloyInstance -> m (Concurrent Object) parseConcurrency inst = do - t1 <- unscopedSingleSig inst concurrencyTransition1 "" - t2 <- unscopedSingleSig inst concurrencyTransition2 "" + t1 <- unscopedSingleSig concurrencyTransition1 "" inst + t2 <- unscopedSingleSig concurrencyTransition2 "" inst Concurrent <$> ((,) <$> asSingleton t1 <*> asSingleton t2) checkFindConcurrencyConfig :: FindConcurrencyConfig -> Maybe String diff --git a/src/Modelling/PetriNet/Conflict.hs b/src/Modelling/PetriNet/Conflict.hs index 9d13fbf00..955de93aa 100644 --- a/src/Modelling/PetriNet/Conflict.hs +++ b/src/Modelling/PetriNet/Conflict.hs @@ -596,9 +596,9 @@ It returns an error message instead if unexpected behaviour occurs. -} parseConflict :: MonadThrow m => AlloyInstance -> m (PetriConflict' Object) parseConflict inst = do - tc1 <- unscopedSingleSig inst conflictTransition1 "" - tc2 <- unscopedSingleSig inst conflictTransition2 "" - pc <- unscopedSingleSig inst conflictPlaces1 "" + tc1 <- unscopedSingleSig conflictTransition1 "" inst + tc2 <- unscopedSingleSig conflictTransition2 "" inst + pc <- unscopedSingleSig conflictPlaces1 "" inst PetriConflict' . flip Conflict (Set.toList pc) <$> ((,) <$> asSingleton tc1 <*> asSingleton tc2) diff --git a/src/Modelling/PetriNet/Diagram.hs b/src/Modelling/PetriNet/Diagram.hs index 3da811b68..fb1e6e907 100644 --- a/src/Modelling/PetriNet/Diagram.hs +++ b/src/Modelling/PetriNet/Diagram.hs @@ -34,6 +34,7 @@ import Modelling.PetriNet.Parser ( netToGr, netToGrCapacity, parseRenamedNet, + singleSig, ) import Modelling.PetriNet.Types ( CapacityNode, @@ -134,7 +135,7 @@ getNet -> AlloyInstance -> m (p n String, t String) getNet parseSpecial inst = do - (net, nameMap) <- parseRenamedNet "flow" "tokens" inst + (net, nameMap) <- parseRenamedNet (singleSig "this" "Nodes" "") "flow" "tokens" inst special <- parseSpecial inst renamedSpecial <- traverse (`BM.lookup` nameMap) special return (net, renamedSpecial) @@ -144,7 +145,7 @@ getDefaultNet => AlloyInstance -> m (p n String) getDefaultNet = - fmap fst . parseRenamedNet "defaultFlow" "defaultTokens" + fmap fst . parseRenamedNet (singleSig "this" "Nodes" "") "defaultFlow" "defaultTokens" {-| Obtain the Petri net like graph by drawing Nodes and connections between them diff --git a/src/Modelling/PetriNet/FindActivatedTransitions.hs b/src/Modelling/PetriNet/FindActivatedTransitions.hs index dffd06878..543a38a8b 100644 --- a/src/Modelling/PetriNet/FindActivatedTransitions.hs +++ b/src/Modelling/PetriNet/FindActivatedTransitions.hs @@ -291,7 +291,7 @@ petriNetFindActivatedTransitions FindActivatedTransitionsConfig { parseActivatedTransitions :: MonadThrow m => AlloyInstance -> m (ActivatedTransitions Object) parseActivatedTransitions inst = do - t <- unscopedSingleSig inst activatedTransitions "" + t <- unscopedSingleSig activatedTransitions "" inst pure $ ActivatedTransitions (Set.toList t) petriNetActivatedTransitionsAlloy diff --git a/src/Modelling/PetriNet/MatchToMath.hs b/src/Modelling/PetriNet/MatchToMath.hs index 0124b600f..5a50f81d0 100644 --- a/src/Modelling/PetriNet/MatchToMath.hs +++ b/src/Modelling/PetriNet/MatchToMath.hs @@ -68,6 +68,7 @@ import Modelling.PetriNet.Find ( import Modelling.PetriNet.Parser ( parseChange, parseRenamedNet, + singleSig, ) import Modelling.PetriNet.Types ( AdvConfig, @@ -320,7 +321,7 @@ matchToMath ds toOutput config segment = do return ((net, ds), math, changes') else matchToMath ds toOutput config segment where - parse = fmap fst . parseRenamedNet "flow" "tokens" + parse = fmap fst . parseRenamedNet (singleSig "this" "Nodes" "") "flow" "tokens" firstM :: Monad m => (a -> m b) -> (a, c) -> m (b, c) firstM f (p, c) = (,c) <$> f p @@ -343,7 +344,7 @@ mathInstance -> AlloyInstance -> RandT g m (String, p n String, Math) mathInstance config inst = do - petriLike <- fst <$> parseRenamedNet "flow" "tokens" inst + petriLike <- fst <$> parseRenamedNet (singleSig "this" "Nodes" "") "flow" "tokens" inst petriLike' <- fst <$> shuffleNames petriLike let math = toPetriMath petriLike' let f = renderFalse petriLike' config diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 5db2abd05..9c08b73cb 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -18,6 +18,7 @@ module Modelling.PetriNet.Parser ( parseChange, parseNet, parseRenamedNet, + singleSig, simpleNameMap, simpleRename, ) where @@ -42,7 +43,6 @@ import qualified Data.Map.Lazy as Map ( import Data.Maybe (fromMaybe) import Modelling.Auxiliary.Common (Object (Object, oName, oIndex), toMap) -import Modelling.PetriNet.Alloy (unscopedSingleSig) import Modelling.PetriNet.Types ( CapacityNode (..), Net (emptyNet, outFlow, alterFlow, alterNode, traverseNet), @@ -87,45 +87,40 @@ convertPetri -> AlloyInstance -- ^ the Petri net 'AlloyInstance' -> m Petri convertPetri f t inst = do - p <- parseNet False f t inst + p <- parseNet (singleSig "this" "Nodes" "") f t inst petriLikeToPetri p {-| -Parse a 'Net' graph from an 'AlloyInstance' given the instances flow and -token set names. +Parse a `Net' graph from an 'AlloyInstance', using a certain node set accessor, +and given the instance's flow and token set names. Return an already renamed Petri net, along with the renaming map. -} parseRenamedNet :: (MonadThrow m, Net p n) - => String + => (AlloyInstance -> m (Set Object)) + -> String -> String -> AlloyInstance -> m (p n String, Bimap Object String) -parseRenamedNet flowSetName tokenSetName inst = do - petriLike <- parseNet False flowSetName tokenSetName inst +parseRenamedNet getNodes flowSetName tokenSetName inst = do + petriLike <- parseNet getNodes flowSetName tokenSetName inst let nameMap = simpleNameMap petriLike net <- traverseNet (`BM.lookup` nameMap) petriLike return (net, nameMap) {-| -Parse a `Net' graph from an 'AlloyInstance', with or without givenNodes, given the instances flow and -token set names. +Parse a `Net' graph from an 'AlloyInstance', using a certain node set accessor, +and given the instance's flow and token set names. -} parseNet :: (MonadThrow m, Net p n) - => Bool -- ^ whether to only parse the given nodes + => (AlloyInstance -> m (Set Object))-- ^ how to get the relevant node set -> String -- ^ the name of the flow set -> String -- ^ the name of the token set -> AlloyInstance -- ^ the Petri net 'AlloyInstance' -> m (p n Object) -parseNet onlyGiven flowSetName tokenSetName inst = do - nodes <- case onlyGiven of - True -> do - nodes <- unscopedSingleSig inst "$givenNodes" "" - return $ Set.toList nodes - False -> do - nodes <- singleSig inst "this" "Nodes" "" - return $ Set.toList nodes +parseNet getNodes flowSetName tokenSetName inst = do + nodes <- getNodes inst rawTokens <- doubleSig inst "this" "Places" tokenSetName let tokens = relToMap (second oIndex) rawTokens @@ -147,7 +142,7 @@ addCapacities -> PetriLike CapacityNode Object -> m (PetriLike CapacityNode Object) addCapacities inst net = do - nodes <- singleSig inst "this" "placesWithCapacity" "" + nodes <- singleSig "this" "placesWithCapacity" "" inst rawCapacity <- doubleSig inst "this" "placesWithCapacity" "capacity" @@ -228,12 +223,12 @@ asSingleton s singleSig :: MonadThrow m - => AlloyInstance - -> String + => String -> String -> String + -> AlloyInstance -> m (Set.Set Object) -singleSig inst st nd rd = do +singleSig st nd rd inst = do sig <- lookupSig (scoped st nd) inst getSingleAs rd (return .: Object) sig diff --git a/test/Modelling/PetriNet/DiagramSpec.hs b/test/Modelling/PetriNet/DiagramSpec.hs index 513495453..f9414805c 100644 --- a/test/Modelling/PetriNet/DiagramSpec.hs +++ b/test/Modelling/PetriNet/DiagramSpec.hs @@ -11,7 +11,7 @@ import Modelling.PetriNet.Types ( defaultAdvConfig, defaultBasicConfig, ) -import Modelling.PetriNet.Parser (parseNet) +import Modelling.PetriNet.Parser (parseNet, singleSig) import Data.GraphViz.Attributes.Complete (GraphvizCommand (TwoPi)) import Diagrams.Backend.SVG (renderSVG) @@ -27,7 +27,7 @@ spec = do (inst:_) <- getInstances (Just 1) (petriNetRnd defaultBasicConfig defaultAdvConfig) - pl <- parseNet "flow" "tokens" inst + pl <- parseNet (singleSig "this" "Nodes" "") "flow" "tokens" inst dia <- drawNet show (pl :: SimplePetriLike Object) DrawSettings { withPlaceNames = True, withSvgHighlighting = True, From c12f7ca29d9bc1887d5c1659e8aa1ede8882e0d8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Tue, 22 Apr 2025 09:18:34 +0200 Subject: [PATCH 234/256] use MonadThrow instead of silently swallowing potential lookup failures via mapMaybe --- src/Modelling/PetriNet/Capacity.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 7720303fc..168d6220c 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -139,7 +139,7 @@ import Data.Bimap (Bimap) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) import Data.List (intercalate) -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe) import Data.String.Interpolate (i, iii) import Text.Parsec ( char, @@ -381,7 +381,7 @@ combinedCapacity alloyF alloyC config segment = do condition <- traverse (`BM.lookup` nameMap) (toChangeList change) complements <- doubleSig inst "this" "placesWithCapacity" "complement" - let complementMap = generateComplementMap nameMap (Set.toList complements) + complementMap <- generateComplementMap nameMap (Set.toList complements) return (original, transformed, condition, complementMap) where @@ -390,10 +390,11 @@ combinedCapacity alloyF alloyC config segment = do return $ list !! n generateComplementMap - :: Bimap Object String + :: MonadThrow m + => Bimap Object String -> [(Object, Object)] - -> [(String, String)] -generateComplementMap nameMap = mapMaybe placeTuple + -> m [(String, String)] +generateComplementMap nameMap = mapM placeTuple where placeTuple (cap, add) = do capName <- BM.lookup cap nameMap From f2ffecfa75925437a074493b1db9d81d4da42b01 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 23 Apr 2025 00:19:35 +0200 Subject: [PATCH 235/256] added new function for CapacitySpec --- src/Modelling/PetriNet/Capacity.hs | 27 +++++++++++++++++++-------- 1 file changed, 19 insertions(+), 8 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 168d6220c..bc9b48bbc 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -18,6 +18,7 @@ module Modelling.PetriNet.Capacity ( combinedCapacity, combinedCapacityInstance, defaultCapacityInstance, + findCapacityInstance, petriNetFindCapacity, parseCapacityPrec, simpleCapacityTask, @@ -64,7 +65,6 @@ import Modelling.PetriNet.Alloy ( modulePetriConstraints, modulePetriSignature, randomInSegment, - unscopedSingleSig, ) import Modelling.PetriNet.Diagram ( renderWith, @@ -111,7 +111,7 @@ import Modelling.PetriNet.Types ( ) import Control.Applicative ((<|>), liftA2) -import Control.Monad (void, when) +import Control.Monad (void, when, (>=>)) import Control.Monad.Catch (MonadThrow, MonadThrow (throwM)) import Control.OutputCapable.Blocks ( ArticleToUse (DefiniteArticle), @@ -151,6 +151,7 @@ import Text.Parsec.Char (digit) import Text.Parsec.Combinator (many1) import Text.Parsec.String (Parser) import Text.Read (readMaybe) +import Language.Alloy.Call (AlloyInstance) data CapacityInstance = CapacityInstance { @@ -370,12 +371,26 @@ combinedCapacity alloyF alloyC config segment = do x':_ -> return x' [] -> randomInstance list + findCapacityInstance inst + where + randomInstance list = do + n <- randomInSegment segment (1 + ((length list - segment - 1) `div` 4)) + return $ list !! n + +findCapacityInstance + :: (MonadThrow m, Net p n) + => AlloyInstance + -> RandT g m (PetriLike CapacityNode String, p n String, PetriChangeList String, [(String, String)]) +findCapacityInstance inst = do (transformed, nameMap) <- parseRenamedNet (singleSig "this" "Nodes" "") "flow" "tokens" inst original <- - parseNet (unscopedSingleSig "$givenNodes" "") "defaultFlow" "defaultTokens" inst - >>= \net -> addCapacities inst net >>= traverseNet (`BM.lookup` nameMap) + parseNet (\inst2 -> do + pl <- singleSig "this" "givenPlaces" "" inst2 + tr <- singleSig "this" "givenTransitions" "" inst2 + return (Set.union pl tr)) "defaultFlow" "defaultTokens" inst + >>= (addCapacities inst >=> traverseNet (`BM.lookup` nameMap)) change <- parseChange inst condition <- traverse (`BM.lookup` nameMap) (toChangeList change) @@ -384,10 +399,6 @@ combinedCapacity alloyF alloyC config segment = do complementMap <- generateComplementMap nameMap (Set.toList complements) return (original, transformed, condition, complementMap) - where - randomInstance list = do - n <- randomInSegment segment (1 + ((length list - segment - 1) `div` 4)) - return $ list !! n generateComplementMap :: MonadThrow m From e25086cf4a41546cbe16c44c4cb082b7423deadc Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 23 Apr 2025 00:22:19 +0200 Subject: [PATCH 236/256] as combinedCapacity got larger, it is easier to use a function --- test/Modelling/PetriNet/CapacitySpec.hs | 23 ++++++----------------- 1 file changed, 6 insertions(+), 17 deletions(-) diff --git a/test/Modelling/PetriNet/CapacitySpec.hs b/test/Modelling/PetriNet/CapacitySpec.hs index cb879eaf0..bd428a53c 100644 --- a/test/Modelling/PetriNet/CapacitySpec.hs +++ b/test/Modelling/PetriNet/CapacitySpec.hs @@ -15,15 +15,9 @@ import Modelling.PetriNet.Capacity ( checkCapacityConfigs, checkCapacityConfig, combinedCapacityInstance, + findCapacityInstance, petriNetFindCapacity, ) -import Modelling.PetriNet.Diagram ( - getDefaultNet, - getNet, - ) -import Modelling.PetriNet.Parser ( - parseChange, - ) import Modelling.PetriNet.Types ( AdvConfig (AdvConfig), BasicConfig (..), @@ -33,7 +27,6 @@ import Modelling.PetriNet.Types ( PetriChangeList (..), SimplePetriLike, defaultCapacityConfig, - toChangeList, ) import Modelling.PetriNet.TestCommon ( @@ -47,7 +40,7 @@ import Modelling.PetriNet.TestCommon ( validGraphConfig, ) import Settings (configDepth) -import Data.Maybe (isNothing) +import Data.Maybe (fromMaybe, isNothing) import Test.Hspec @@ -72,17 +65,13 @@ spec = do findConfigs = validAdvConfigs >>= validFindCapacityConfigs validFinds validFinds = validConfigsForPick 0 configDepth -checkCapacityInstance :: (PetriLike CapacityNode String, a, PetriChangeList String) -> Bool -checkCapacityInstance (_, _, change) = isValidCapacity change +checkCapacityInstance :: (PetriLike CapacityNode String, a, PetriChangeList String, [(String, String)]) -> Bool +checkCapacityInstance (_, _, change, _) = isValidCapacity change testCapacityConfig :: [CapacityConfig] -> Spec testCapacityConfig = testTaskGeneration petriNetFindCapacity - (\inst -> do - first <- getDefaultNet inst - (second, third) <- getNet (fmap toChangeList . parseChange) inst - return (first, second, third) - ) + findCapacityInstance $ checkCapacityInstance @(SimplePetriLike _) validFindCapacityConfigs :: [(BasicConfig, _)] -> AdvConfig -> [CapacityConfig] @@ -97,8 +86,8 @@ validCapacityConfig bc@BasicConfig{ places, transitions, maxFlowPerEdge, maxToke maxCapacity <- [max maxFlowPerEdge maxTokensPerPlace .. 5] newArrows <- [(a, b) | a <- [places .. 2 * transitions * places], b <- [a .. 2 * transitions * places]] oneMin <- [1 .. maxCapacity] - distractors <- [(x, y) | x <- [0 .. transitions], y <- [transitions .. transitions - atLeastActive], x <= y] atMost <- Nothing : [Just n | n <- [0 .. transitions]] + distractors <- [(x, y) | x <- [0 .. transitions - fromMaybe transitions atMost], y <- [x .. transitions - atLeastActive], x <= y] return (maxCapacity, newArrows, oneMin, distractors, atMost) isValidCapacity :: PetriChangeList String -> Bool From 4de74bc12e3ba7e734817628147eb8c8808ba021 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 23 Apr 2025 22:31:17 +0200 Subject: [PATCH 237/256] corrected tests + fewer cases are tested as validConfigsForFind uses different values --- test/Modelling/PetriNet/CapacitySpec.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/test/Modelling/PetriNet/CapacitySpec.hs b/test/Modelling/PetriNet/CapacitySpec.hs index bd428a53c..f928bf31f 100644 --- a/test/Modelling/PetriNet/CapacitySpec.hs +++ b/test/Modelling/PetriNet/CapacitySpec.hs @@ -63,7 +63,7 @@ spec = do validFinds (AdvConfig Nothing Nothing Nothing) findConfigs = validAdvConfigs >>= validFindCapacityConfigs validFinds - validFinds = validConfigsForPick 0 configDepth + validFinds = validConfigsForFind 0 configDepth checkCapacityInstance :: (PetriLike CapacityNode String, a, PetriChangeList String, [(String, String)]) -> Bool checkCapacityInstance (_, _, change, _) = isValidCapacity change @@ -86,8 +86,8 @@ validCapacityConfig bc@BasicConfig{ places, transitions, maxFlowPerEdge, maxToke maxCapacity <- [max maxFlowPerEdge maxTokensPerPlace .. 5] newArrows <- [(a, b) | a <- [places .. 2 * transitions * places], b <- [a .. 2 * transitions * places]] oneMin <- [1 .. maxCapacity] - atMost <- Nothing : [Just n | n <- [0 .. transitions]] - distractors <- [(x, y) | x <- [0 .. transitions - fromMaybe transitions atMost], y <- [x .. transitions - atLeastActive], x <= y] + atMost <- Nothing : [Just n | n <- [atLeastActive .. transitions - 1]] + distractors <- [(x, y) | x <- [0 .. transitions - fromMaybe transitions atMost], y <- [x .. transitions - atLeastActive]] return (maxCapacity, newArrows, oneMin, distractors, atMost) isValidCapacity :: PetriChangeList String -> Bool From a86cb6906275ae7254b318bf934de5fc8e94b397 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 23 Apr 2025 22:36:06 +0200 Subject: [PATCH 238/256] condition includes places that did not change betwee nets + to include them in the answer the user has to input --- src/Modelling/PetriNet/Capacity.hs | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index bc9b48bbc..5541079eb 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -178,6 +178,15 @@ capacityGenerate config seed segment = (original, transformed, condition, complementMap) <- combinedCapacityInstance config segment + let conditionMissing changes = + let missing = [ (p, 0) | n <- [1..places bc] + , let p = "s" ++ show n + , ("s" ++ show n) `notElem` map fst (tokenChanges changes) + ] + in changes { tokenChanges = tokenChanges changes ++ missing } + + let conditionWhole = conditionMissing condition + return $ CapacityInstance { drawWith = DrawSettings { withPlaceNames = not $ hidePlaceNames gc @@ -186,7 +195,7 @@ capacityGenerate config seed segment = , with1Weights = not $ hideWeight1 gc , withGraphvizCommand = gl } - , toFind = condition + , toFind = conditionWhole , originalNet = original , transformedNet = transformed , complementMap = complementMap From 85ecfb4f525dee3371c9cb027dfef11981912000 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 23 Apr 2025 22:57:15 +0200 Subject: [PATCH 239/256] corrected defaultCapacityInstance --- src/Modelling/PetriNet/Capacity.hs | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 5541079eb..80ad85a4e 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -664,14 +664,12 @@ defaultCapacityInstance = CapacityInstance { }, toFind = ChangeList { tokenChanges = [("s1", 1), ("s2", 0)] - , flowChanges = [("s1", "t2", 1), ("t1", "s1", 1), ("t2", "s2", 1), ("s2", "t1", 1)] + , flowChanges = [("s1", "t2", 1), ("t1", "s1", 1), ("t2", "s2", 1), ("s2", "t1", 1), ("t3", "s2", 1)] }, originalNet = PetriLike { allNodes = M.fromList [ - ("s1",CapacityPlace {initial = 0, capacity = 0, flowOut = M.empty}), - ("s2",CapacityPlace {initial = 0, capacity = 0, flowOut = M.empty}), ("s3",CapacityPlace {initial = 1, capacity = 2, flowOut = M.fromList [("t1",1)]}), - ("s4",CapacityPlace {initial = 0, capacity = 1, flowOut = M.fromList [("t2",1),("t3",1)]}), + ("s4",CapacityPlace {initial = 1, capacity = 1, flowOut = M.fromList [("t2",1),("t3",1)]}), ("t1",CapacityTransition {flowOut = M.fromList [("s4",1)]}), ("t2",CapacityTransition {flowOut = M.fromList [("s3",1)]}), ("t3",CapacityTransition {flowOut = M.empty}) @@ -680,11 +678,11 @@ toFind = ChangeList { transformedNet = PetriLike { allNodes = M.fromList [ ("s1",SimplePlace {initial = 1, flowOut = M.fromList [("t2",1)]}), - ("s2",SimplePlace {initial = 0, flowOut = M.fromList [("s1",1)]}), + ("s2",SimplePlace {initial = 0, flowOut = M.fromList [("t1",1)]}), ("s3",SimplePlace {initial = 1, flowOut = M.fromList [("t1",1)]}), - ("s4",SimplePlace {initial = 0, flowOut = M.fromList [("t2",1),("t3",1)]}), - ("t1",SimpleTransition {flowOut = M.fromList [("s4",1),("s1",1)]}), - ("t2",SimpleTransition {flowOut = M.fromList [("s3",1),("s2",1)]}), + ("s4",SimplePlace {initial = 1, flowOut = M.fromList [("t2",1),("t3",1)]}), + ("t1",SimpleTransition {flowOut = M.fromList [("s1",1),("s4",1)]}), + ("t2",SimpleTransition {flowOut = M.fromList [("s2",1),("s3",1)]}), ("t3",SimpleTransition {flowOut = M.fromList [("s2",1)]}) ] }, From e116f5389b072331e30aab85f4f72b43bd6d834b Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 23 Apr 2025 23:30:43 +0200 Subject: [PATCH 240/256] fixed spaces in shown text in ...Task --- src/Modelling/PetriNet/Capacity.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 80ad85a4e..258a55c89 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -287,12 +287,12 @@ capacityTask path task = do ts = ([("s1",2), ("s2",0)], [("t1","s1",1), ("t2","s1",1), ("s2","t2",2)]) code $ show ts translate $ do - english ("as answer would indicate that there are two complement places - s1 with 2 tokens" ++ + english ("as answer would indicate that there are two complement places - s1 with 2 tokens " ++ "and s2 with 0 tokens - and t1 points to s1 with a weight of 1, " ++ - "t2 points to s1 with a weight of 1 and s2 connects to t2 with a weight of 2.") - german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - s1 mit 2 Token" ++ + "t2 points to s1 with a weight of 1 and s2 connects to t2 with a weight of 2. ") + german ("als Antwort würde bedeuten, dass es zwei Komplementstellen gibt - s1 mit 2 Token " ++ "und s2 mit 0 Token - und t1 zeigt auf s1 mit einem Gewicht von 1, " ++ - "t2 zeigt auf s1 mit einem Gewicht von 1, und s2 ist mit t2 mit einem Gewicht von 2 verbunden.") + "t2 zeigt auf s1 mit einem Gewicht von 1, und s2 ist mit t2 mit einem Gewicht von 2 verbunden. ") translate $ do english "The order of tuples within the lists does not matter here." german "Die Reihenfolge der Tupel innerhalb der Listen spielt hierbei keine Rolle." From bda7cde2ec38915bd07504811f827285499f3884 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Wed, 23 Apr 2025 23:54:02 +0200 Subject: [PATCH 241/256] fixed mistakes --- test/Modelling/PetriNet/CapacitySpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Modelling/PetriNet/CapacitySpec.hs b/test/Modelling/PetriNet/CapacitySpec.hs index f928bf31f..07f58991a 100644 --- a/test/Modelling/PetriNet/CapacitySpec.hs +++ b/test/Modelling/PetriNet/CapacitySpec.hs @@ -36,7 +36,7 @@ import Modelling.PetriNet.TestCommon ( firstInstanceConfig, testTaskGeneration, validAdvConfigs, - validConfigsForPick, + validConfigsForFind, validGraphConfig, ) import Settings (configDepth) From f3b7873df1e2cc29b7c4c1a6d6d857d121bcdcdd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 24 Apr 2025 11:18:15 +0200 Subject: [PATCH 242/256] be less dependent on place numbering scheme --- src/Modelling/PetriNet/Capacity.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index 258a55c89..e55e84771 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -179,9 +179,9 @@ capacityGenerate config seed segment = (original, transformed, condition, complementMap) <- combinedCapacityInstance config segment let conditionMissing changes = - let missing = [ (p, 0) | n <- [1..places bc] - , let p = "s" ++ show n - , ("s" ++ show n) `notElem` map fst (tokenChanges changes) + let missing = [ (p, 0) + | p <- map snd complementMap + , p `notElem` map fst (tokenChanges changes) ] in changes { tokenChanges = tokenChanges changes ++ missing } From 4bbcb43b144dad9041b8f9aec2e1cc30fcc8e4f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 24 Apr 2025 11:35:44 +0200 Subject: [PATCH 243/256] refactorings, inlinings, argument swapping --- src/Modelling/PetriNet/Capacity.hs | 29 +++++++---------------------- src/Modelling/PetriNet/Parser.hs | 22 +++++++++++----------- 2 files changed, 18 insertions(+), 33 deletions(-) diff --git a/src/Modelling/PetriNet/Capacity.hs b/src/Modelling/PetriNet/Capacity.hs index e55e84771..f9fa418f6 100644 --- a/src/Modelling/PetriNet/Capacity.hs +++ b/src/Modelling/PetriNet/Capacity.hs @@ -49,7 +49,6 @@ import Capabilities.Cache (MonadCache) import Capabilities.Diagrams (MonadDiagrams) import Capabilities.Graphviz (MonadGraphviz) import Modelling.Auxiliary.Common ( - Object, TaskGenerationException (NoInstanceAvailable), oneOf, ) @@ -135,7 +134,7 @@ import Control.Monad.Random ( evalRandT, mkStdGen ) -import Data.Bimap (Bimap) +import Data.Bitraversable (bimapM) import Data.Foldable (for_) import Data.GraphViz.Commands (GraphvizCommand (Circo)) import Data.List (intercalate) @@ -178,14 +177,12 @@ capacityGenerate config seed segment = (original, transformed, condition, complementMap) <- combinedCapacityInstance config segment - let conditionMissing changes = + let addMissingToCondition changes@ChangeList{tokenChanges} = let missing = [ (p, 0) | p <- map snd complementMap - , p `notElem` map fst (tokenChanges changes) + , p `notElem` map fst tokenChanges ] - in changes { tokenChanges = tokenChanges changes ++ missing } - - let conditionWhole = conditionMissing condition + in changes { tokenChanges = tokenChanges ++ missing } return $ CapacityInstance { drawWith = DrawSettings @@ -195,7 +192,7 @@ capacityGenerate config seed segment = , with1Weights = not $ hideWeight1 gc , withGraphvizCommand = gl } - , toFind = conditionWhole + , toFind = addMissingToCondition condition , originalNet = original , transformedNet = transformed , complementMap = complementMap @@ -404,23 +401,11 @@ findCapacityInstance inst = do change <- parseChange inst condition <- traverse (`BM.lookup` nameMap) (toChangeList change) - complements <- doubleSig inst "this" "placesWithCapacity" "complement" - complementMap <- generateComplementMap nameMap (Set.toList complements) + complements <- doubleSig "this" "placesWithCapacity" "complement" inst + complementMap <- mapM (bimapM (`BM.lookup` nameMap) (`BM.lookup` nameMap)) (Set.toList complements) return (original, transformed, condition, complementMap) -generateComplementMap - :: MonadThrow m - => Bimap Object String - -> [(Object, Object)] - -> m [(String, String)] -generateComplementMap nameMap = mapM placeTuple - where - placeTuple (cap, add) = do - capName <- BM.lookup cap nameMap - addName <- BM.lookup add nameMap - return (capName, addName) - petriNetFindCapacity :: CapacityConfig -> String petriNetFindCapacity CapacityConfig { basicConfig, diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 9c08b73cb..596fbf250 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -122,10 +122,10 @@ parseNet parseNet getNodes flowSetName tokenSetName inst = do nodes <- getNodes inst - rawTokens <- doubleSig inst "this" "Places" tokenSetName + rawTokens <- doubleSig "this" "Places" tokenSetName inst let tokens = relToMap (second oIndex) rawTokens - flow <- tripleSig inst "this" "Nodes" flowSetName + flow <- tripleSig "this" "Nodes" flowSetName inst return . foldrFlip (\(x, y, z) -> alterFlow x (oIndex z) y) flow @@ -144,7 +144,7 @@ addCapacities addCapacities inst net = do nodes <- singleSig "this" "placesWithCapacity" "" inst - rawCapacity <- doubleSig inst "this" "placesWithCapacity" "capacity" + rawCapacity <- doubleSig "this" "placesWithCapacity" "capacity" inst let capacities = relToMap (second (integerFromInt . oIndex)) rawCapacity @@ -189,8 +189,8 @@ On error a 'Left' error message will be returned. -} parseChange :: MonadThrow m => AlloyInstance -> m (PetriChange Object) parseChange inst = do - flow <- tripleSig inst "this" "Nodes" "flowChange" - token <- doubleSig inst "this" "Places" "tokenChange" + flow <- tripleSig "this" "Nodes" "flowChange" inst + token <- doubleSig "this" "Places" "tokenChange" inst let tokenMap = relToMap (second oIndex) token tokenChange <- asSingleton `mapM` tokenMap let flowMap = relToMap tripleToOut flow @@ -234,24 +234,24 @@ singleSig st nd rd inst = do doubleSig :: MonadThrow m - => AlloyInstance - -> String + => String -> String -> String + -> AlloyInstance -> m (Set.Set (Object,Object)) -doubleSig inst st nd rd = do +doubleSig st nd rd inst = do sig <- lookupSig (scoped st nd) inst let obj = return .: Object getDoubleAs rd obj obj sig tripleSig :: MonadThrow m - => AlloyInstance - -> String + => String -> String -> String + -> AlloyInstance -> m (Set.Set (Object,Object,Object)) -tripleSig inst st nd rd = do +tripleSig st nd rd inst = do sig <- lookupSig (scoped st nd) inst let obj = return .: Object getTripleAs rd obj obj obj sig From 93f31d66435b1ad5771dae6de6cf234c34514e73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 24 Apr 2025 17:45:06 +0200 Subject: [PATCH 244/256] remove dead code --- src/Modelling/PetriNet/Parser.hs | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 596fbf250..5ac6dc47b 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -75,21 +75,6 @@ import Language.Alloy.Call ( scoped, ) -{-| -Given the name of a flow set and a token set the given alloy instance is parsed -to a 'Net' graph and a 'Petri' is returned if the instance is indeed a -valid Petri net (after applying 'petriLikeToPetri'). --} -convertPetri - :: MonadThrow m - => String -- ^ the name of the flow set - -> String -- ^ the name of the token set - -> AlloyInstance -- ^ the Petri net 'AlloyInstance' - -> m Petri -convertPetri f t inst = do - p <- parseNet (singleSig "this" "Nodes" "") f t inst - petriLikeToPetri p - {-| Parse a `Net' graph from an 'AlloyInstance', using a certain node set accessor, and given the instance's flow and token set names. From f0ebfa1afa408798a7af530538c7a3b8fe664f53 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 24 Apr 2025 17:51:11 +0200 Subject: [PATCH 245/256] fixes --- src/Modelling/PetriNet/Alloy.hs | 2 +- src/Modelling/PetriNet/Parser.hs | 5 ++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index b43ae9157..2e1f40dba 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -200,7 +200,7 @@ Generates signatures of the given kind, number of places and transitions. -} signatures :: String - -- ^ What kind of signatures to generate (e.g., @places@) + -- ^ What kind of signatures to generate (e.g., @given@) -> Int -- ^ How many places of that kind -> Int diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 5ac6dc47b..915604ad9 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -11,7 +11,6 @@ module Modelling.PetriNet.Parser ( NoSingletonException (..), addCapacities, asSingleton, - convertPetri, doubleSig, netToGr, netToGrCapacity, @@ -76,7 +75,7 @@ import Language.Alloy.Call ( ) {-| -Parse a `Net' graph from an 'AlloyInstance', using a certain node set accessor, +Parse a 'Net' graph from an 'AlloyInstance', using a certain node set accessor, and given the instance's flow and token set names. Return an already renamed Petri net, along with the renaming map. -} @@ -94,7 +93,7 @@ parseRenamedNet getNodes flowSetName tokenSetName inst = do return (net, nameMap) {-| -Parse a `Net' graph from an 'AlloyInstance', using a certain node set accessor, +Parse a 'Net' graph from an 'AlloyInstance', using a certain node set accessor, and given the instance's flow and token set names. -} parseNet From 0b05af110fd989e20485df29f3cc2670e78a7d17 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 24 Apr 2025 18:05:32 +0200 Subject: [PATCH 246/256] removed unused inputs --- src/Modelling/PetriNet/Parser.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Modelling/PetriNet/Parser.hs b/src/Modelling/PetriNet/Parser.hs index 915604ad9..ef6a2b19a 100644 --- a/src/Modelling/PetriNet/Parser.hs +++ b/src/Modelling/PetriNet/Parser.hs @@ -45,13 +45,11 @@ import Modelling.Auxiliary.Common (Object (Object, oName, oIndex), toMap) import Modelling.PetriNet.Types ( CapacityNode (..), Net (emptyNet, outFlow, alterFlow, alterNode, traverseNet), - Petri, PetriChange (..), PetriLike (..), PetriNode (..), maybeCapacity, maybeInitial, - petriLikeToPetri, ) import GHC.Num (integerFromInt) From 88cfa7ad653463b36023361d04c128412e579d95 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 25 Apr 2025 00:52:36 +0200 Subject: [PATCH 247/256] made tests easier --- test/Modelling/PetriNet/CapacitySpec.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Modelling/PetriNet/CapacitySpec.hs b/test/Modelling/PetriNet/CapacitySpec.hs index 07f58991a..edecf8dad 100644 --- a/test/Modelling/PetriNet/CapacitySpec.hs +++ b/test/Modelling/PetriNet/CapacitySpec.hs @@ -81,9 +81,9 @@ validFindCapacityConfigs cs advancedConfig = do return $ CapacityConfig bc advancedConfig maxCapacity newArrows oneMin distractors atMost validGraphConfig False alloyTestConfig validCapacityConfig :: BasicConfig -> [(Int, (Int, Int), Int, (Int, Int), Maybe Int)] -validCapacityConfig bc@BasicConfig{ places, transitions, maxFlowPerEdge, maxTokensPerPlace, atLeastActive } = +validCapacityConfig bc@BasicConfig{ places, transitions, maxTokensPerPlace, atLeastActive } = filter (\(maxCap, arrows, oneMinCap, distract, most) -> isNothing (checkCapacityConfig bc maxCap arrows oneMinCap distract most)) $ do - maxCapacity <- [max maxFlowPerEdge maxTokensPerPlace .. 5] + maxCapacity <- [maxTokensPerPlace ..] newArrows <- [(a, b) | a <- [places .. 2 * transitions * places], b <- [a .. 2 * transitions * places]] oneMin <- [1 .. maxCapacity] atMost <- Nothing : [Just n | n <- [atLeastActive .. transitions - 1]] From 5c97e62b3bdc2e4810442577127e09f7612d7f40 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Fri, 25 Apr 2025 23:45:45 +0200 Subject: [PATCH 248/256] added back list upper bound --- test/Modelling/PetriNet/CapacitySpec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Modelling/PetriNet/CapacitySpec.hs b/test/Modelling/PetriNet/CapacitySpec.hs index edecf8dad..619e0ce1f 100644 --- a/test/Modelling/PetriNet/CapacitySpec.hs +++ b/test/Modelling/PetriNet/CapacitySpec.hs @@ -83,7 +83,7 @@ validFindCapacityConfigs cs advancedConfig = do validCapacityConfig :: BasicConfig -> [(Int, (Int, Int), Int, (Int, Int), Maybe Int)] validCapacityConfig bc@BasicConfig{ places, transitions, maxTokensPerPlace, atLeastActive } = filter (\(maxCap, arrows, oneMinCap, distract, most) -> isNothing (checkCapacityConfig bc maxCap arrows oneMinCap distract most)) $ do - maxCapacity <- [maxTokensPerPlace ..] + maxCapacity <- [maxTokensPerPlace .. 5] newArrows <- [(a, b) | a <- [places .. 2 * transitions * places], b <- [a .. 2 * transitions * places]] oneMin <- [1 .. maxCapacity] atMost <- Nothing : [Just n | n <- [atLeastActive .. transitions - 1]] From a2b0102a4dcb62d56f853507f086b5a792ee1e30 Mon Sep 17 00:00:00 2001 From: "Luca E." Date: Mon, 28 Apr 2025 11:51:38 +0200 Subject: [PATCH 249/256] removed unnecessary code --- app/capacity.hs | 34 ---------------------------------- 1 file changed, 34 deletions(-) diff --git a/app/capacity.hs b/app/capacity.hs index 4136acfe6..e27d8ce1e 100644 --- a/app/capacity.hs +++ b/app/capacity.hs @@ -31,40 +31,6 @@ import System.IO ( ) import Text.Pretty.Simple (pPrint) import Text.Read (readMaybe) ---import Control.Monad (forM_) - -{- -main :: IO () -main = do - hSetBuffering stdout NoBuffering - putStrLn "Generating 15 instances using defaultCapacityConfig..." - forM_ [0..14] mainFind - -mainFind :: Int -> IO () -mainFind i = forceErrors $ do - let theConfig = defaultCapacityConfig - lift $ pPrint theConfig - {-pls, trns, maxCap, newFlowMin, newFlowMax, oneMin, distractMin, distractMax, atMostAct) <- lift $ userInput theConfig - let config = theConfig { - basicConfig = basicConfig { - places = pls, - transitions = trns - }, - maxCapacity = maxCap, - newArrowsWithComplement = (newFlowMin, newFlowMax), - oneMinCapacity = oneMin, - distractors = (distractMin, distractMax), - atMostActive = atMostAct - } :: CapacityConfig-} - let c = checkCapacityConfigs theConfig - if isNothing c - then do - t <- capacityGenerate theConfig 0 i - lift . (`withLang` English) $ simpleCapacityTask ("tmp/"++ show (i+1)++"/") t - lift $ print t - else - lift $ print c --} main :: IO () main = do From 83a8fc76ed78baf2dbf8ace6a878a4c0d032a163 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 23 Jan 2026 08:07:45 +0100 Subject: [PATCH 250/256] add autotool-capabilities-io-instances dependency to new apps --- app/package.yaml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/app/package.yaml b/app/package.yaml index bb8484966..63c30c1ce 100644 --- a/app/package.yaml +++ b/app/package.yaml @@ -29,6 +29,7 @@ executables: - . - common dependencies: + - autotool-capabilities-io-instances - bytestring - digest - modelling-tasks @@ -126,6 +127,7 @@ executables: - . - common dependencies: + - autotool-capabilities-io-instances - bytestring - digest - modelling-tasks @@ -200,6 +202,7 @@ executables: - . - common dependencies: + - autotool-capabilities-io-instances - bytestring - digest - modelling-tasks From 1bed2024cddbbb6915095afebc6b6b55ed2cdadd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 23 Jan 2026 07:04:38 +0100 Subject: [PATCH 251/256] spell-checking overhaul --- .github/actions/spelling/README.md | 23 +- .github/actions/spelling/allow.txt | 7 + .github/actions/spelling/candidate.patterns | 527 ++++++++++++++++++ .../actions/spelling/line_forbidden.patterns | 22 +- .github/actions/spelling/patterns.txt | 12 +- .github/actions/spelling/reject.txt | 1 + 6 files changed, 576 insertions(+), 16 deletions(-) create mode 100644 .github/actions/spelling/candidate.patterns diff --git a/.github/actions/spelling/README.md b/.github/actions/spelling/README.md index 516ec071c..ef73ac266 100644 --- a/.github/actions/spelling/README.md +++ b/.github/actions/spelling/README.md @@ -1,16 +1,17 @@ # check-spelling/check-spelling configuration -| File | Purpose | Format | Info | -| -------------------------------------------------- | -------------------------------------------------------------------------------- | --------------------------------------------------------- | ---------------------------------------------------------------------------------------------------- | -| [dictionary.txt](dictionary.txt) | Replacement dictionary (creating this file will override the default dictionary) | one word per line | [dictionary](https://github.com/check-spelling/check-spelling/wiki/Configuration#dictionary) | -| [allow.txt](allow.txt) | Add words to the dictionary | one word per line (only letters and `'`s allowed) | [allow](https://github.com/check-spelling/check-spelling/wiki/Configuration#allow) | -| [reject.txt](reject.txt) | Remove words from the dictionary (after allow) | grep pattern matching whole dictionary words | [reject](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-reject) | -| [excludes.txt](excludes.txt) | Files to ignore entirely | perl regular expression | [excludes](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-excludes) | -| [only.txt](only.txt) | Only check matching files (applied after excludes) | perl regular expression | [only](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-only) | -| [patterns.txt](patterns.txt) | Patterns to ignore from checked lines | perl regular expression (order matters, first match wins) | [patterns](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-patterns) | -| [line_forbidden.patterns](line_forbidden.patterns) | Patterns to flag in checked lines | perl regular expression (order matters, first match wins) | [patterns](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-patterns) | -| [expect.txt](expect.txt) | Expected words that aren't in the dictionary | one word per line (sorted, alphabetically) | [expect](https://github.com/check-spelling/check-spelling/wiki/Configuration#expect) | -| [advice.md](advice.md) | Supplement for GitHub comment when unrecognized words are found | GitHub Markdown | [advice](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-advice) | +| File | Purpose | Format | Info | +| -------------------------------------------------- | -------------------------------------------------------------------------------- | ------------------------------------------------------------------------------------------------- | ---------------------------------------------------------------------------------------------------- | +| [dictionary.txt](dictionary.txt) | Replacement dictionary (creating this file will override the default dictionary) | one word per line | [dictionary](https://github.com/check-spelling/check-spelling/wiki/Configuration#dictionary) | +| [allow.txt](allow.txt) | Add words to the dictionary | one word per line (only letters and `'`s allowed) | [allow](https://github.com/check-spelling/check-spelling/wiki/Configuration#allow) | +| [reject.txt](reject.txt) | Remove words from the dictionary (after allow) | grep pattern matching whole dictionary words | [reject](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-reject) | +| [excludes.txt](excludes.txt) | Files to ignore entirely | perl regular expression | [excludes](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-excludes) | +| [only.txt](only.txt) | Only check matching files (applied after excludes) | perl regular expression | [only](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-only) | +| [patterns.txt](patterns.txt) | Patterns to ignore from checked lines | perl regular expression (order matters, first match wins) | [patterns](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-patterns) | +| [candidate.patterns](candidate.patterns) | Patterns that might be worth adding to [patterns.txt](patterns.txt) | perl regular expression with optional comment block introductions (all matches will be suggested) | [candidates](https://github.com/check-spelling/check-spelling/wiki/Feature:-Suggest-patterns) | +| [line_forbidden.patterns](line_forbidden.patterns) | Patterns to flag in checked lines | perl regular expression (order matters, first match wins) | [patterns](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-patterns) | +| [expect.txt](expect.txt) | Expected words that aren't in the dictionary | one word per line (sorted, alphabetically) | [expect](https://github.com/check-spelling/check-spelling/wiki/Configuration#expect) | +| [advice.md](advice.md) | Supplement for GitHub comment when unrecognized words are found | GitHub Markdown | [advice](https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples%3A-advice) | Note: you can replace any of these files with a directory by the same name (minus the suffix) and then include multiple files inside that directory (with that suffix) to merge multiple files together. diff --git a/.github/actions/spelling/allow.txt b/.github/actions/spelling/allow.txt index dd76c192e..d04eaf82c 100644 --- a/.github/actions/spelling/allow.txt +++ b/.github/actions/spelling/allow.txt @@ -8,6 +8,7 @@ Bifoldable Bifunctor Bitraversable Circo +DMAX DPoint DSL DVal @@ -22,6 +23,9 @@ HXT Hashable Hovern Hspec +Ints +Komplementstelle +Komplementstellen Leftrightarrow Lexer Linkbeschriftung @@ -36,6 +40,8 @@ Perim Petrinetz Petrinetze Petrinetzes +Petrinetzkandidat +Petrinetzkandidaten Petrinetzknoten Programmierparadigmen QDiagram @@ -83,6 +89,7 @@ forkagain forkend fst fusable +ghc ghci github gpt diff --git a/.github/actions/spelling/candidate.patterns b/.github/actions/spelling/candidate.patterns new file mode 100644 index 000000000..340922d57 --- /dev/null +++ b/.github/actions/spelling/candidate.patterns @@ -0,0 +1,527 @@ +# marker to ignore all code on line +^.*/\* #no-spell-check-line \*/.*$ +# marker to ignore all code on line +^.*\bno-spell-check(?:-line|)(?:\s.*|)$ + +# https://cspell.org/configuration/document-settings/ +# cspell inline +^.*\b[Cc][Ss][Pp][Ee][Ll]{2}:\s*[Dd][Ii][Ss][Aa][Bb][Ll][Ee]-[Ll][Ii][Nn][Ee]\b + +# patch hunk comments +^\@\@ -\d+(?:,\d+|) \+\d+(?:,\d+|) \@\@ .* +# git index header +index (?:[0-9a-z]{7,40},|)[0-9a-z]{7,40}\.\.[0-9a-z]{7,40} + +# cid urls +(['"])cid:.*?\g{-1} + +# data url in parens +\(data:[^)]*?(?:[A-Z]{3,}|[A-Z][a-z]{2,}|[a-z]{3,})[^)]*\) +# data url in quotes +([`'"])data:.*?(?:[A-Z]{3,}|[A-Z][a-z]{2,}|[a-z]{3,}).*\g{-1} +# data url +data:[-a-zA-Z=;:/0-9+]*,\S* + +# https/http/file urls +(?:\b(?:https?|ftp|file)://)[-A-Za-z0-9+&@#/%?=~_|!:,.;]+[-A-Za-z0-9+&@#/%=~_|] + +# mailto urls +mailto:[-a-zA-Z=;:/?%&0-9+@.]{3,} + +# magnet urls +magnet:[?=:\w]+ + +# magnet urls +"magnet:[^"]+" + +# obs: +"obs:[^"]*" + +# The `\b` here means a break, it's the fancy way to handle urls, but it makes things harder to read +# In this examples content, I'm using a number of different ways to match things to show various approaches +# asciinema +\basciinema\.org/a/[0-9a-zA-Z]+ + +# apple +\bdeveloper\.apple\.com/[-\w?=/]+ +# Apple music +\bembed\.music\.apple\.com/fr/playlist/usr-share/[-\w.]+ + +# appveyor api +\bci\.appveyor\.com/api/projects/status/[0-9a-z]+ +# appveyor project +\bci\.appveyor\.com/project/(?:[^/\s"]*/){2}builds?/\d+/job/[0-9a-z]+ + +# Amazon + +# Amazon +\bamazon\.com/[-\w]+/(?:dp/[0-9A-Z]+|) +# AWS S3 +\b\w*\.s3[^.]*\.amazonaws\.com/[-\w/&#%_?:=]* +# AWS execute-api +\b[0-9a-z]{10}\.execute-api\.[-0-9a-z]+\.amazonaws\.com\b +# AWS ELB +\b\w+\.[-0-9a-z]+\.elb\.amazonaws\.com\b +# AWS SNS +\bsns\.[-0-9a-z]+.amazonaws\.com/[-\w/&#%_?:=]* +# AWS VPC +vpc-\w+ + +# While you could try to match `http://` and `https://` by using `s?` in `https?://`, sometimes there +# YouTube url +\b(?:(?:www\.|)youtube\.com|youtu.be)/(?:channel/|embed/|user/|playlist\?list=|watch\?v=|v/|)[-a-zA-Z0-9?&=_%]* +# YouTube music +\bmusic\.youtube\.com/youtubei/v1/browse(?:[?&]\w+=[-a-zA-Z0-9?&=_]*) +# YouTube tag +<\s*youtube\s+id=['"][-a-zA-Z0-9?_]*['"] +# YouTube image +\bimg\.youtube\.com/vi/[-a-zA-Z0-9?&=_]* +# Google Accounts +\baccounts.google.com/[-_/?=.:;+%&0-9a-zA-Z]* +# Google Analytics +\bgoogle-analytics\.com/collect.[-0-9a-zA-Z?%=&_.~]* +# Google APIs +\bgoogleapis\.(?:com|dev)/[a-z]+/(?:v\d+/|)[a-z]+/[-@:./?=\w+|&]+ +# Google Storage +\b[-a-zA-Z0-9.]*\bstorage\d*\.googleapis\.com(?:/\S*|) +# Google Calendar +\bcalendar\.google\.com/calendar(?:/u/\d+|)/embed\?src=[@./?=\w&%]+ +\w+\@group\.calendar\.google\.com\b +# Google DataStudio +\bdatastudio\.google\.com/(?:(?:c/|)u/\d+/|)(?:embed/|)(?:open|reporting|datasources|s)/[-0-9a-zA-Z]+(?:/page/[-0-9a-zA-Z]+|) +# The leading `/` here is as opposed to the `\b` above +# ... a short way to match `https://` or `http://` since most urls have one of those prefixes +# Google Docs +/docs\.google\.com/[a-z]+/(?:ccc\?key=\w+|(?:u/\d+|d/(?:e/|)[0-9a-zA-Z_-]+/)?(?:edit\?[-\w=#.]*|/\?[\w=&]*|)) +# Google Drive +\bdrive\.google\.com/(?:file/d/|open)[-0-9a-zA-Z_?=]* +# Google Groups +\bgroups\.google\.com/(?:(?:forum/#!|d/)(?:msg|topics?|searchin)|a)/[^/\s"]+/[-a-zA-Z0-9$]+(?:/[-a-zA-Z0-9]+)* +# Google Maps +\bmaps\.google\.com/maps\?[\w&;=]* +# Google themes +themes\.googleusercontent\.com/static/fonts/[^/\s"]+/v\d+/[^.]+. +# Google CDN +\bclients2\.google(?:usercontent|)\.com[-0-9a-zA-Z/.]* +# Goo.gl +/goo\.gl/[a-zA-Z0-9]+ +# Google Chrome Store +\bchrome\.google\.com/webstore/detail/[-\w]*(?:/\w*|) +# Google Books +\bgoogle\.(?:\w{2,4})/books(?:/\w+)*\?[-\w\d=&#.]* +# Google Fonts +\bfonts\.(?:googleapis|gstatic)\.com/[-/?=:;+&0-9a-zA-Z]* +# Google Forms +\bforms\.gle/\w+ +# Google Scholar +\bscholar\.google\.com/citations\?user=[A-Za-z0-9_]+ +# Google Colab Research Drive +\bcolab\.research\.google\.com/drive/[-0-9a-zA-Z_?=]* + +# GitHub SHAs (api) +\bapi.github\.com/repos(?:/[^/\s"]+){3}/[0-9a-f]+\b +# GitHub SHAs (markdown) +(?:\[`?[0-9a-f]+`?\]\(https:/|)/(?:www\.|)github\.com(?:/[^/\s"]+){2,}(?:/[^/\s")]+)(?:[0-9a-f]+(?:[-0-9a-zA-Z/#.]*|)\b|) +# GitHub SHAs +\bgithub\.com(?:/[^/\s"]+){2}[@#][0-9a-f]+\b +# GitHub wiki +\bgithub\.com/(?:[^/]+/){2}wiki/(?:(?:[^/]+/|)_history|[^/]+(?:/_compare|)/[0-9a-f.]{40,})\b +# githubusercontent +/[-a-z0-9]+\.githubusercontent\.com/[-a-zA-Z0-9?&=_\/.]* +# githubassets +\bgithubassets.com/[0-9a-f]+(?:[-/\w.]+) +# gist github +\bgist\.github\.com/[^/\s"]+/[0-9a-f]+ +# git.io +\bgit\.io/[0-9a-zA-Z]+ +# GitHub JSON +"node_id": "[-a-zA-Z=;:/0-9+]*" +# Contributor +\[[^\]]+\]\(https://github\.com/[^/\s"]+\) +# GHSA +GHSA(?:-[0-9a-z]{4}){3} + +# GitLab commit +\bgitlab\.[^/\s"]*/\S+/\S+/commit/[0-9a-f]{7,16}#[0-9a-f]{40}\b +# GitLab merge requests +\bgitlab\.[^/\s"]*/\S+/\S+/-/merge_requests/\d+/diffs#[0-9a-f]{40}\b +# GitLab uploads +\bgitlab\.[^/\s"]*/uploads/[-a-zA-Z=;:/0-9+]* +# GitLab commits +\bgitlab\.[^/\s"]*/(?:[^/\s"]+/){2}commits?/[0-9a-f]+\b + +# binanace +accounts.binance.com/[a-z/]*oauth/authorize\?[-0-9a-zA-Z&%]* + +# bitbucket diff +\bapi\.bitbucket\.org/\d+\.\d+/repositories/(?:[^/\s"]+/){2}diff(?:stat|)(?:/[^/\s"]+){2}:[0-9a-f]+ +# bitbucket repositories commits +\bapi\.bitbucket\.org/\d+\.\d+/repositories/(?:[^/\s"]+/){2}commits?/[0-9a-f]+ +# bitbucket commits +\bbitbucket\.org/(?:[^/\s"]+/){2}commits?/[0-9a-f]+ + +# bit.ly +\bbit\.ly/\w+ + +# bitrise +\bapp\.bitrise\.io/app/[0-9a-f]*/[\w.?=&]* + +# bootstrapcdn.com +\bbootstrapcdn\.com/[-./\w]+ + +# cdn.cloudflare.com +\bcdnjs\.cloudflare\.com/[./\w]+ + +# circleci +\bcircleci\.com/gh(?:/[^/\s"]+){1,5}.[a-z]+\?[-0-9a-zA-Z=&]+ + +# gitter +\bgitter\.im(?:/[^/\s"]+){2}\?at=[0-9a-f]+ + +# gravatar +\bgravatar\.com/avatar/[0-9a-f]+ + +# ibm +[a-z.]*ibm\.com/[-_#=:%!?~.\\/\d\w]* + +# imgur +\bimgur\.com/[^.]+ + +# Internet Archive +\barchive\.org/web/\d+/(?:[-\w.?,'/\\+&%$#_:]*) + +# discord +/discord(?:app\.com|\.gg)/(?:invite/)?[a-zA-Z0-9]{7,} + +# Disqus +\bdisqus\.com/[-\w/%.()!?&=_]* + +# medium link +\blink\.medium\.com/[a-zA-Z0-9]+ +# medium +\bmedium\.com/\@?[^/\s"]+/[-\w]+ + +# microsoft +\b(?:https?://|)(?:(?:download\.visualstudio|docs|msdn2?|research)\.microsoft|blogs\.msdn)\.com/[-_a-zA-Z0-9()=./%]* +# powerbi +\bapp\.powerbi\.com/reportEmbed/[^"' ]* +# vs devops +\bvisualstudio.com(?::443|)/[-\w/?=%&.]* +# microsoft store +\bmicrosoft\.com/store/apps/\w+ + +# mvnrepository.com +\bmvnrepository\.com/[-0-9a-z./]+ + +# now.sh +/[0-9a-z-.]+\.now\.sh\b + +# oracle +\bdocs\.oracle\.com/[-0-9a-zA-Z./_?#&=]* + +# chromatic.com +/\S+.chromatic.com\S*[")] + +# codacy +\bapi\.codacy\.com/project/badge/Grade/[0-9a-f]+ + +# compai +\bcompai\.pub/v1/png/[0-9a-f]+ + +# mailgun api +\.api\.mailgun\.net/v3/domains/[0-9a-z]+\.mailgun.org/messages/[0-9a-zA-Z=@]* +# mailgun +\b[0-9a-z]+.mailgun.org + +# /message-id/ +/message-id/[-\w@./%]+ + +# Reddit +\breddit\.com/r/[/\w_]* + +# requestb.in +\brequestb\.in/[0-9a-z]+ + +# sched +\b[a-z0-9]+\.sched\.com\b + +# Slack url +slack://[a-zA-Z0-9?&=]+ +# Slack +\bslack\.com/[-0-9a-zA-Z/_~?&=.]* +# Slack edge +\bslack-edge\.com/[-a-zA-Z0-9?&=%./]+ +# Slack images +\bslack-imgs\.com/[-a-zA-Z0-9?&=%.]+ + +# shields.io +\bshields\.io/[-\w/%?=&.:+;,]* + +# stackexchange -- https://stackexchange.com/feeds/sites +\b(?:askubuntu|serverfault|stack(?:exchange|overflow)|superuser).com/(?:questions/\w+/[-\w]+|a/) + +# Sentry +[0-9a-f]{32}\@o\d+\.ingest\.sentry\.io\b + +# Twitter markdown +\[\@[^[/\]:]*?\]\(https://twitter.com/[^/\s"')]*(?:/status/\d+(?:\?[-_0-9a-zA-Z&=]*|)|)\) +# Twitter hashtag +\btwitter\.com/hashtag/[\w?_=&]* +# Twitter status +\btwitter\.com/[^/\s"')]*(?:/status/\d+(?:\?[-_0-9a-zA-Z&=]*|)|) +# Twitter profile images +\btwimg\.com/profile_images/[_\w./]* +# Twitter media +\btwimg\.com/media/[-_\w./?=]* +# Twitter link shortened +\bt\.co/\w+ + +# facebook +\bfburl\.com/[0-9a-z_]+ +# facebook CDN +\bfbcdn\.net/[\w/.,]* +# facebook watch +\bfb\.watch/[0-9A-Za-z]+ + +# dropbox +\bdropbox\.com/sh?/[^/\s"]+/[-0-9A-Za-z_.%?=&;]+ + +# ipfs protocol +ipfs://[0-9a-z]* +# ipfs url +/ipfs/[0-9a-z]* + +# w3 +\bw3\.org/[-0-9a-zA-Z/#.]+ + +# loom +\bloom\.com/embed/[0-9a-f]+ + +# regex101 +\bregex101\.com/r/[^/\s"]+/\d+ + +# figma +\bfigma\.com/file(?:/[0-9a-zA-Z]+/)+ + +# freecodecamp.org +\bfreecodecamp\.org/[-\w/.]+ + +# image.tmdb.org +\bimage\.tmdb\.org/[/\w.]+ + +# mermaid +\bmermaid\.ink/img/[-\w]+|\bmermaid-js\.github\.io/mermaid-live-editor/#/edit/[-\w]+ + +# Wikipedia +\ben\.wikipedia\.org/wiki/[-\w%.#]+ + +# gitweb +[^"\s]+/gitweb/\S+;h=[0-9a-f]+ + +# HyperKitty lists +/archives/list/[^@/]+\@[^/\s"]*/message/[^/\s"]*/ + +# lists +/thread\.html/[^"\s]+ + +# list-management +\blist-manage\.com/subscribe(?:[?&](?:u|id)=[0-9a-f]+)+ + +# kubectl.kubernetes.io/last-applied-configuration +"kubectl.kubernetes.io/last-applied-configuration": ".*" + +# pgp +\bgnupg\.net/pks/lookup[?&=0-9a-zA-Z]* + +# Spotify +\bopen\.spotify\.com/embed/playlist/\w+ + +# Mastodon +\bmastodon\.[-a-z.]*/(?:media/|\@)[?&=0-9a-zA-Z_]* + +# scastie +\bscastie\.scala-lang\.org/[^/]+/\w+ + +# images.unsplash.com +\bimages\.unsplash\.com/(?:(?:flagged|reserve)/|)[-\w./%?=%&.;]+ + +# pastebin +\bpastebin\.com/[\w/]+ + +# heroku +\b\w+\.heroku\.com/source/archive/\w+ + +# quip +\b\w+\.quip\.com/\w+(?:(?:#|/issues/)\w+)? + +# badgen.net +\bbadgen\.net/badge/[^")\]'\s]+ + +# statuspage.io +\w+\.statuspage\.io\b + +# media.giphy.com +\bmedia\.giphy\.com/media/[^/]+/[\w.?&=]+ + +# tinyurl +\btinyurl\.com/\w+ + +# getopts +\bgetopts\s+(?:"[^"]+"|'[^']+') + +# ANSI color codes +(?:\\(?:u00|x)1b|\x1b)\[\d+(?:;\d+|)m + +# URL escaped characters +\%[0-9A-F][A-F] +# IPv6 +\b(?:[0-9a-fA-F]{0,4}:){3,7}[0-9a-fA-F]{0,4}\b +# c99 hex digits (not the full format, just one I've seen) +0x[0-9a-fA-F](?:\.[0-9a-fA-F]*|)[pP] +# Punycode +\bxn--[-0-9a-z]+ +# sha +sha\d+:[0-9]*[a-f]{3,}[0-9a-f]* +# sha-... -- uses a fancy capture +(['"]|")[0-9a-f]{40,}\g{-1} +# hex runs +\b[0-9a-fA-F]{16,}\b +# hex in url queries +=[0-9a-fA-F]*?(?:[A-F]{3,}|[a-f]{3,})[0-9a-fA-F]*?& +# ssh +(?:ssh-\S+|-nistp256) [-a-zA-Z=;:/0-9+]{12,} + +# PGP +\b(?:[0-9A-F]{4} ){9}[0-9A-F]{4}\b +# GPG keys +\b(?:[0-9A-F]{4} ){5}(?: [0-9A-F]{4}){5}\b +# Well known gpg keys +.well-known/openpgpkey/[\w./]+ + +# uuid: +\b[0-9a-fA-F]{8}-(?:[0-9a-fA-F]{4}-){3}[0-9a-fA-F]{12}\b +# hex digits including css/html color classes: +(?:[\\0][xX]|\\u|[uU]\+|#x?|\%23)[0-9_a-fA-FgGrR]*?[a-fA-FgGrR]{2,}[0-9_a-fA-FgGrR]*(?:[uUlL]{0,3}|u\d+)\b +# integrity +integrity="sha\d+-[-a-zA-Z=;:/0-9+]{40,}" + +# https://www.gnu.org/software/groff/manual/groff.html +# man troff content +\\f[BCIPR] +# ' +\\\(aq + +# .desktop mime types +^MimeTypes?=.*$ +# .desktop localized entries +^[A-Z][a-z]+\[[a-z]+\]=.*$ +# Localized .desktop content +Name\[[^\]]+\]=.* + +# IServiceProvider +\bI(?=(?:[A-Z][a-z]{2,})+\b) + +# crypt +"\$2[ayb]\$.{56}" + +# scrypt / argon +\$(?:scrypt|argon\d+[di]*)\$\S+ + +# Input to GitHub JSON +content: "[-a-zA-Z=;:/0-9+]*=" + +# Python stringprefix / binaryprefix +# Note that there's a high false positive rate, remove the `?=` and search for the regex to see if the matches seem like reasonable strings +(?v# +(?:(?<=[A-Z]{2})V|(?<=[a-z]{2}|[A-Z]{2})v)\d+(?:\b|(?=[a-zA-Z_])) +# Compiler flags (Scala) +(?:^|[\t ,>"'`=(])-J-[DPWXY](?=[A-Z]{2,}|[A-Z][a-z]|[a-z]{2,}) +# Compiler flags +(?:^|[\t ,"'`=(])-[DPWXYLlf](?=[A-Z]{2,}|[A-Z][a-z]|[a-z]{2,}) +# Compiler flags (linker) +,-B +# curl arguments +\b(?:\\n|)curl(?:\s+-[a-zA-Z]{1,2}\b)*(?:\s+-[a-zA-Z]{3,})(?:\s+-[a-zA-Z]+)* +# set arguments +\bset(?:\s+-[abefimouxE]{1,2})*\s+-[abefimouxE]{3,}(?:\s+-[abefimouxE]+)* +# tar arguments +\b(?:\\n|)g?tar(?:\.exe|)(?:(?:\s+--[-a-zA-Z]+|\s+-[a-zA-Z]+|\s[ABGJMOPRSUWZacdfh-pr-xz]+\b)(?:=[^ ]*|))+ +# tput arguments -- https://man7.org/linux/man-pages/man5/terminfo.5.html -- technically they can be more than 5 chars long... +\btput\s+(?:(?:-[SV]|-T\s*\w+)\s+)*\w{3,5}\b +# macOS temp folders +/var/folders/\w\w/[+\w]+/(?:T|-Caches-)/ diff --git a/.github/actions/spelling/line_forbidden.patterns b/.github/actions/spelling/line_forbidden.patterns index 4ca15837c..b755b9c11 100644 --- a/.github/actions/spelling/line_forbidden.patterns +++ b/.github/actions/spelling/line_forbidden.patterns @@ -19,6 +19,12 @@ # s.b. greater than \bgreater then\b +# s.b. into +\sin to\s + +# s.b. opt-in +\sopt in\s + # s.b. less than \bless then\b @@ -30,10 +36,22 @@ \b[Nn]o[nt][- ]existent\b # s.b. preexisting -[Pp]re-existing +[Pp]re[- ]existing + +# s.b. preempt +[Pp]re[- ]empt\b # s.b. preemptively -[Pp]re-emptively +[Pp]re[- ]emptively + +# s.b. reentrancy +[Rr]e[- ]entrancy + +# s.b. reentrant +[Rr]e[- ]entrant + +# s.b. workaround(s) +\bwork[- ]arounds?\b # Reject duplicate words \s([A-Z]{3,}|[A-Z][a-z]{2,}|[a-z]{3,})\s\g{-1}\s diff --git a/.github/actions/spelling/patterns.txt b/.github/actions/spelling/patterns.txt index 3820c077b..086cb8f5b 100644 --- a/.github/actions/spelling/patterns.txt +++ b/.github/actions/spelling/patterns.txt @@ -1,6 +1,5 @@ # See https://github.com/check-spelling/check-spelling/wiki/Configuration-Examples:-patterns -# acceptable duplicates # ls directory listings [-bcdlpsw](?:[-r][-w][-sx]){3}\s+\d+\s+(\S+)\s+\g{-1}\s+\d+\s+ # C types @@ -8,14 +7,20 @@ # javadoc / .net (?:\@(?:groupname|param)|(?:public|private)(?:\s+static|\s+readonly)*)\s+(\w+)\s+\g{-1}\s +# Commit message -- Signed-off-by and friends +^\s*(?:(?:Based-on-patch|Co-authored|Helped|Mentored|Reported|Reviewed|Signed-off)-by|Thanks-to): (?:[^<]*<[^>]*>|[^<]*)\s*$ + +# Autogenerated revert commit message +^This reverts commit [0-9a-f]{40}\.$ + # ignore long runs of a single character: \b([A-Za-z])\g{-1}{3,}\b # ignore urls https?://[-+0-9a-zA-Z?&=_\/%.]* -# ignore GHC compiler instructions -^\{-# OPTIONS_GHC .* #-}$ +# GHC LANGUAGE extension, HLINT options etc. +^\{-# .* #-}$ # ignore renaming advices ^Original: [a-zA-Z0-9]+ ––– Here: [a-zA-Z0-9]+$ @@ -34,6 +39,7 @@ Nothing\sNothing String\sString True\sTrue False\sFalse + getDoubleAs\slabel\signore\signore obj\sobj\ssig diff --git a/.github/actions/spelling/reject.txt b/.github/actions/spelling/reject.txt index b5a6d3680..a025b3dd9 100644 --- a/.github/actions/spelling/reject.txt +++ b/.github/actions/spelling/reject.txt @@ -1,5 +1,6 @@ ^attache$ benefitting +formulae occurences? ^dependan.* ^oer$ From e95c44dcfb464f85a75df30971b9154aabcd0d90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Fri, 23 Jan 2026 07:39:58 +0100 Subject: [PATCH 252/256] linter tweaking --- .editorconfig | 3 +++ .github/workflows/hlint.yml | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/.editorconfig b/.editorconfig index 0758e62d1..a5fab1256 100644 --- a/.editorconfig +++ b/.editorconfig @@ -28,3 +28,6 @@ max_line_length = unset [**.{yml,yaml,md,tex,cabal}] max_line_length = unset + +[.github/actions/spelling/*] +max_line_length = unset diff --git a/.github/workflows/hlint.yml b/.github/workflows/hlint.yml index 2a1fdb9fc..4da588914 100644 --- a/.github/workflows/hlint.yml +++ b/.github/workflows/hlint.yml @@ -27,7 +27,7 @@ jobs: - name: "Set up HLint" uses: haskell-actions/hlint-setup@v2 with: - version: "3.5" + version: latest - name: "Run HLint" uses: haskell-actions/hlint-run@v2 From 1fa9f5c6a25989064320863c4db5b420d44b49cd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 29 Jan 2026 08:21:23 +0100 Subject: [PATCH 253/256] make modelling-tasks-apps.cabal consistent --- app/modelling-tasks-apps.cabal | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/app/modelling-tasks-apps.cabal b/app/modelling-tasks-apps.cabal index af8edbf1e..88b1556a7 100644 --- a/app/modelling-tasks-apps.cabal +++ b/app/modelling-tasks-apps.cabal @@ -15,12 +15,13 @@ executable capacity hs-source-dirs: ./ common - ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints -Werror -Wwarn=incomplete-uni-patterns -Wwarn=orphans + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints -Werror -Wwarn=incomplete-uni-patterns -Wwarn=orphans -Wwarn=unrecognised-warning-flags -Wwarn=x-partial build-tools: alex , happy build-depends: MonadRandom + , autotool-capabilities-io-instances , base , bytestring , containers @@ -222,12 +223,13 @@ executable findActivatedTransitions hs-source-dirs: ./ common - ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints -Werror -Wwarn=incomplete-uni-patterns -Wwarn=orphans + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints -Werror -Wwarn=incomplete-uni-patterns -Wwarn=orphans -Wwarn=unrecognised-warning-flags -Wwarn=x-partial build-tools: alex , happy build-depends: MonadRandom + , autotool-capabilities-io-instances , base , bytestring , containers @@ -374,12 +376,13 @@ executable pickMistake hs-source-dirs: ./ common - ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints -Werror -Wwarn=incomplete-uni-patterns -Wwarn=orphans + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Widentities -Wredundant-constraints -Werror -Wwarn=incomplete-uni-patterns -Wwarn=orphans -Wwarn=unrecognised-warning-flags -Wwarn=x-partial build-tools: alex , happy build-depends: MonadRandom + , autotool-capabilities-io-instances , base , bytestring , containers From 3f275e6be027008f66597edc9c3c1bab3a01669c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 29 Jan 2026 09:31:22 +0100 Subject: [PATCH 254/256] add DMAX_BIT_WIDTH=7 to stack.yaml as well --- stack.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/stack.yaml b/stack.yaml index ed05dcb4a..78f378c7e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -7,6 +7,8 @@ flags: quick-testing: true autotool-capabilities: alloy-use-sat4j: false +ghc-options: + autotool-capabilities: -DMAX_BIT_WIDTH=7 extra-deps: - git: https://github.com/fmidue/output-blocks.git commit: d67590cb2e1a72ed72437a8cfe2972b680405569 From 1c3c5faec6280309b0feee5aa2b3f10dc79c4343 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 29 Jan 2026 10:07:25 +0100 Subject: [PATCH 255/256] appease hlint --- src/Modelling/PetriNet/Alloy.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Modelling/PetriNet/Alloy.hs b/src/Modelling/PetriNet/Alloy.hs index 491643d0b..78484f23e 100644 --- a/src/Modelling/PetriNet/Alloy.hs +++ b/src/Modelling/PetriNet/Alloy.hs @@ -149,12 +149,12 @@ enforceConstraints underDefault atMostActive activated BasicConfig { places = given "Places" tokens = prepend "tokens" activatedConstraint = unlines $ - [ [i|\##{activated} >= #{atLeastActive}|] | atLeastActive > 0 ] + [ '#' : activated ++ " >= " ++ show atLeastActive | atLeastActive > 0 ] ++ - [ [i| theActivated#{upperFirst which}Transitions[#{activated}]|] | atLeastActive > 0 || isJust atMostActive ] + [ " theActivated" ++ upperFirst which ++ "Transitions[" ++ activated ++ "]" | atLeastActive > 0 || isJust atMostActive ] ++ case atMostActive of - Just 0 -> [[i| no #{activated}|]] - Just atMost -> [[i| \##{activated} =< #{atMost}|]] + Just 0 -> [ " no " ++ activated ] + Just atMost -> [ " #" ++ activated ++ " =< " ++ show atMost ] Nothing -> [] connected :: String -> Maybe Bool -> String From 62d624b19b7b691f3daec589eb9d6a2656594145 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Janis=20Voigtl=C3=A4nder?= Date: Thu, 29 Jan 2026 10:13:21 +0100 Subject: [PATCH 256/256] turn off the problematic test (petriNetFindCapacity/findCapacityInstance) for the moment --- test/Modelling/PetriNet/CapacitySpec.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/test/Modelling/PetriNet/CapacitySpec.hs b/test/Modelling/PetriNet/CapacitySpec.hs index 6bc159a0d..5861606ea 100644 --- a/test/Modelling/PetriNet/CapacitySpec.hs +++ b/test/Modelling/PetriNet/CapacitySpec.hs @@ -39,7 +39,7 @@ import Modelling.PetriNet.TestCommon ( validConfigsForFind, validGraphConfig, ) -import Settings (configDepth) +import Settings (configDepth, nightly) import Control.Monad.Trans (lift) import Data.Maybe (fromMaybe, isNothing) @@ -51,13 +51,15 @@ spec = do checkConfigs checkCapacityConfigs [defaultCapacityConfig] describe "validFindCapacityConfigs" $ checkConfigs checkCapacityConfigs findConfigs' - describe "combinedCapacity" $ do + describe "combinedCapacity, part 1" $ defaultConfigTaskGeneration (combinedCapacityInstance defaultCapacityConfig { Find.alloyConfig = firstInstanceConfig } 0) 0 $ checkCapacityInstance @(SimplePetriLike _) + nightly $ + describe "combinedCapacity, part 2" $ testCapacityConfig findConfigs where findConfigs' = validFindCapacityConfigs