From d7053f0ccd2415e8a1e4a7931dbb152d545bd57a Mon Sep 17 00:00:00 2001 From: Zixin Wu Date: Fri, 5 Dec 2025 17:39:18 +0100 Subject: [PATCH 1/4] fix x-partial errors --- src/Modelling/StateDiagram/AlloyDiagrams.hs | 474 +++++++++--------- src/Modelling/StateDiagram/Generate.hs | 14 +- src/Modelling/StateDiagram/Instance.hs | 9 +- src/Modelling/StateDiagram/Layout.hs | 118 +++-- test/Modelling/StateDiagram/EnumArrowsSpec.hs | 363 +++++++------- 5 files changed, 513 insertions(+), 465 deletions(-) diff --git a/src/Modelling/StateDiagram/AlloyDiagrams.hs b/src/Modelling/StateDiagram/AlloyDiagrams.hs index 8fa0ff70..6a303e58 100644 --- a/src/Modelling/StateDiagram/AlloyDiagrams.hs +++ b/src/Modelling/StateDiagram/AlloyDiagrams.hs @@ -1,237 +1,237 @@ -{-# OPTIONS_GHC -Wno-error=missing-fields -Wno-error=incomplete-patterns -Wno-error=missing-signatures -Wno-error=type-defaults -Wno-error=name-shadowing #-} -{-# Language QuasiQuotes #-} -{-# Language NamedFieldPuns #-} -{-# Language ViewPatterns #-} - -module Modelling.StateDiagram.AlloyDiagrams (render) where - -import Modelling.StateDiagram.Datatype (UMLStateDiagram - ,unUML - ,StateDiagram(..) - ,Connection(..) - ,HistoryType(..) - ,globalise) - -import Data.String.Interpolate (i) -import Data.List (intercalate) -import Data.List.Extra (nubOrd, notNull) -import Data.Maybe (isNothing, fromJust) - -data Inherited = Inherited - { context :: [Int] - , nameMapping :: [(String,String)] - } - -data Synthesized = Synthesized - { alloy :: String - , names :: [String] - , rootNodes :: [String] - , innerStarts :: Int - , endNodes :: Bool - , normalStates :: Bool - , hierarchicalStates :: Bool - , regionsStates :: Bool - , deepHistoryNodes :: Bool - , shallowHistoryNodes :: Bool - , forkNodes :: Bool - , joinNodes :: Bool - } - -render :: Int -> UMLStateDiagram String Int -> String -render protoFlowScope = - unUML (\name substates connection startState -> - let Synthesized {alloy, names, innerStarts, endNodes, normalStates, hierarchicalStates, regionsStates, deepHistoryNodes, shallowHistoryNodes, forkNodes, joinNodes} = - renderInner renderNode substates - Inherited {context = [], nameMapping = nameMapping - } - nameMapping = zipWith (\name -> (name,) . ("Name" ++) . show) (nubOrd names) [1..] - nameOutput = map (\(_,component) -> [i|one sig #{component} extends ComponentNames{}|]) - nameMapping - transitionMapping = zipWith (\name -> (name,) . ("T" ++) . show) (nubOrd (filter (not . null) (map transition connection))) [1..] - transitionOutput = map (\(_,trigger) -> [i|one sig #{trigger} extends TriggerNames{}|]) - transitionMapping - numberOfFlows = length connection + innerStarts + if null startState then 0 else 1 - nullScopes = - concatMap ((" 0 "++) . (++",\n ") . snd) . filter fst $ - [ (not endNodes, "EndNodes") - , (null startState && innerStarts == 0, "StartNodes") - , (null names, "ComponentNames") - , (null transitionMapping, "TriggerNames") - , (not normalStates, "NormalStates") - , (not hierarchicalStates, "HierarchicalStates") - , (not regionsStates, "RegionsStates") - , (not regionsStates, "Regions") - , (not deepHistoryNodes, "DeepHistoryNodes") - , (not shallowHistoryNodes, "ShallowHistoryNodes") - , (not forkNodes, "ForkNodes") - , (not joinNodes, "JoinNodes") ] - in - [i|module diagram // name: #{show name} -open uml_state_diagram -#{if null startState then "" else renderStart ("S", startState)} -#{alloy} -#{unlines $ zipWith (renderConnection transitionMapping) connection [1..]} -#{unlines nameOutput} -#{unlines transitionOutput} -run {} for - #{nullScopes} #{show protoFlowScope} ProtoFlows, exactly #{show numberOfFlows} Flows -|] - ) - . globalise - -renderStart :: (String, [Int]) -> String -renderStart (start, target) = [i|one sig #{start} extends StartNodes{} -one sig #{start}Flow extends Flows{}{ - from = #{start} - label = EmptyTrigger - to = N_#{address target} -}|] - -renderConnection :: [(String, String)] -> Connection Int -> Int -> String -renderConnection transitionMapping Connection{ pointFrom, pointTo, transition } n = [i|one sig Connection#{n} extends Flows{}{ - from = N_#{address pointFrom} - label = #{if null transition then "EmptyTrigger" else fromJust (lookup transition transitionMapping) ++ " // " ++ show transition} - to = N_#{address pointTo} -}|] - -renderInner :: (StateDiagram String Int a -> Inherited -> Synthesized) -> [StateDiagram String Int a] -> Inherited -> Synthesized -renderInner recurse substates inherited = - let - recursively = map (`recurse` inherited) substates - in - Synthesized - { alloy = unlines $ map alloy recursively - , names = concatMap names recursively - , rootNodes = concatMap rootNodes recursively - , innerStarts = sum (map innerStarts recursively) - , endNodes = any endNodes recursively - , normalStates = any normalStates recursively - , hierarchicalStates = any hierarchicalStates recursively - , regionsStates = any regionsStates recursively - , deepHistoryNodes = any deepHistoryNodes recursively - , shallowHistoryNodes = any shallowHistoryNodes recursively - , forkNodes = any forkNodes recursively - , joinNodes = any joinNodes recursively - } - -renderComposite :: String -> (StateDiagram String Int a -> Inherited -> Synthesized) -> StateDiagram String Int a -> Inherited -> Synthesized -renderComposite kind eachWith StateDiagram{ substates, label, name, startState } inherited@Inherited{context, nameMapping} = - let - here = context ++ [label] - node = [i|#{if kind == "Regions" then "R" else "N"}_#{address here}|] - start = if null startState then Nothing else Just ([i|S_#{address here}|], here ++ startState) - Synthesized {alloy, names, rootNodes, innerStarts, endNodes, normalStates, hierarchicalStates, regionsStates, deepHistoryNodes, shallowHistoryNodes, forkNodes, joinNodes} = - renderInner eachWith substates - inherited {context = here} - in - Synthesized - { alloy = unlines $ - [i|one sig #{node} extends #{kind}{}{#{if kind == "RegionsStates" then "" else if null name then noName else "\n name = " ++ fromJust (lookup name nameMapping) ++ " // " ++ show name} - contains = #{intercalate " + " (maybe [] (\x -> [fst x]) start ++ rootNodes)} -}|] - : maybe id ((:) . renderStart) start - [ alloy ] - , names = if null name then names else name : names - , rootNodes = [node] - , innerStarts = innerStarts + if isNothing start then 0 else 1 - , endNodes = endNodes - , normalStates = normalStates - , hierarchicalStates = kind == "HierarchicalStates" || hierarchicalStates - , regionsStates = kind == "RegionsStates" || regionsStates - , deepHistoryNodes = deepHistoryNodes - , shallowHistoryNodes = shallowHistoryNodes - , forkNodes = forkNodes - , joinNodes = joinNodes - } - where - noName = "\n no name" -- because the line length limit is 200 characters -renderComposite _ _ _ _ = error "not defined" - -defaultSynthesized :: Synthesized -defaultSynthesized = Synthesized - { names = [] - , innerStarts = 0 - , endNodes = False - , normalStates = False - , hierarchicalStates = False - , regionsStates = False - , deepHistoryNodes = False - , shallowHistoryNodes = False - , forkNodes = False - , joinNodes = False - } - -renderNode :: StateDiagram String Int a -> Inherited -> Synthesized - -renderNode d@StateDiagram{} inherited = - renderComposite "HierarchicalStates" renderNode d inherited - -renderNode CombineDiagram { substates, label } inherited = - renderComposite "RegionsStates" - (renderComposite "Regions" renderNode) - StateDiagram{ substates = substates, label = label, name = "", startState = [] } - inherited - -renderNode InnerMostState { label, name } Inherited{context, nameMapping} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends NormalStates{}{ - #{if null name then "no name" else "name = " ++ fromJust (lookup name nameMapping) ++ " // " ++ show name} -}|] - , names = [name | notNull name] - , rootNodes = [node] - , normalStates = True - } - -renderNode EndState { label } Inherited{context} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends EndNodes{}|] - , rootNodes = [node] - , endNodes = True - } - -renderNode History { label, historyType } Inherited{context} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends #{show historyType}HistoryNodes{}|] - , rootNodes = [node] - , deepHistoryNodes = historyType == Deep - , shallowHistoryNodes = historyType == Shallow - } - -renderNode Fork {label} Inherited {context} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends ForkNodes{}|] - , rootNodes = [node] - , forkNodes = True - , joinNodes = False - } - -renderNode Join {label} Inherited {context} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends JoinNodes{}|] - , rootNodes = [node] - , forkNodes = False - , joinNodes = True - } - -address :: [Int] -> String -address = intercalate "_" . map show +{-# OPTIONS_GHC -Wno-error=missing-fields -Wno-error=incomplete-patterns -Wno-error=missing-signatures -Wno-error=type-defaults -Wno-error=name-shadowing #-} +{-# Language QuasiQuotes #-} +{-# Language NamedFieldPuns #-} +{-# Language ViewPatterns #-} + +module Modelling.StateDiagram.AlloyDiagrams (render) where + +import Modelling.StateDiagram.Datatype (UMLStateDiagram + ,unUML + ,StateDiagram(..) + ,Connection(..) + ,HistoryType(..) + ,globalise) + +import Data.String.Interpolate (i) +import Data.List (intercalate) +import Data.List.Extra (nubOrd, notNull) +import Data.Maybe (isNothing, fromJust) + +data Inherited = Inherited + { context :: [Int] + , nameMapping :: [(String,String)] + } + +data Synthesized = Synthesized + { alloy :: String + , names :: [String] + , rootNodes :: [String] + , innerStarts :: Int + , endNodes :: Bool + , normalStates :: Bool + , hierarchicalStates :: Bool + , regionsStates :: Bool + , deepHistoryNodes :: Bool + , shallowHistoryNodes :: Bool + , forkNodes :: Bool + , joinNodes :: Bool + } + +render :: Int -> UMLStateDiagram String Int -> String +render protoFlowScope = + unUML (\name substates connection startState -> + let Synthesized {alloy, names, innerStarts, endNodes, normalStates, hierarchicalStates, regionsStates, deepHistoryNodes, shallowHistoryNodes, forkNodes, joinNodes} = + renderInner renderNode substates + Inherited {context = [], nameMapping = nameMapping + } + nameMapping = zipWith (\name -> (name,) . ("Name" ++) . show) (nubOrd names) [1..] + nameOutput = map (\(_,component) -> [i|one sig #{component} extends ComponentNames{}|]) + nameMapping + transitionMapping = zipWith (\name -> (name,) . ("T" ++) . show) (nubOrd (filter (not . null) (map transition connection))) [1..] + transitionOutput = map (\(_,trigger) -> [i|one sig #{trigger} extends TriggerNames{}|]) + transitionMapping + numberOfFlows = length connection + innerStarts + if null startState then 0 else 1 + nullScopes = + concatMap ((" 0 "++) . (++",\n ") . snd) . filter fst $ + [ (not endNodes, "EndNodes") + , (null startState && innerStarts == 0, "StartNodes") + , (null names, "ComponentNames") + , (null transitionMapping, "TriggerNames") + , (not normalStates, "NormalStates") + , (not hierarchicalStates, "HierarchicalStates") + , (not regionsStates, "RegionsStates") + , (not regionsStates, "Regions") + , (not deepHistoryNodes, "DeepHistoryNodes") + , (not shallowHistoryNodes, "ShallowHistoryNodes") + , (not forkNodes, "ForkNodes") + , (not joinNodes, "JoinNodes") ] + in + [i|module diagram // name: #{show name} +open uml_state_diagram +#{if null startState then "" else renderStart ("S", startState)} +#{alloy} +#{unlines $ zipWith (renderConnection transitionMapping) connection [1..]} +#{unlines nameOutput} +#{unlines transitionOutput} +run {} for + #{nullScopes} #{show protoFlowScope} ProtoFlows, exactly #{show numberOfFlows} Flows +|] + ) + . globalise + +renderStart :: (String, [Int]) -> String +renderStart (start, target) = [i|one sig #{start} extends StartNodes{} +one sig #{start}Flow extends Flows{}{ + from = #{start} + label = EmptyTrigger + to = N_#{address target} +}|] + +renderConnection :: [(String, String)] -> Connection Int -> Int -> String +renderConnection transitionMapping Connection{ pointFrom, pointTo, transition } n = [i|one sig Connection#{n} extends Flows{}{ + from = N_#{address pointFrom} + label = #{if null transition then "EmptyTrigger" else fromJust (lookup transition transitionMapping) ++ " // " ++ show transition} + to = N_#{address pointTo} +}|] + +renderInner :: (StateDiagram String Int a -> Inherited -> Synthesized) -> [StateDiagram String Int a] -> Inherited -> Synthesized +renderInner recurse substates inherited = + let + recursively = map (`recurse` inherited) substates + in + Synthesized + { alloy = unlines $ map alloy recursively + , names = concatMap names recursively + , rootNodes = concatMap rootNodes recursively + , innerStarts = sum (map innerStarts recursively) + , endNodes = any endNodes recursively + , normalStates = any normalStates recursively + , hierarchicalStates = any hierarchicalStates recursively + , regionsStates = any regionsStates recursively + , deepHistoryNodes = any deepHistoryNodes recursively + , shallowHistoryNodes = any shallowHistoryNodes recursively + , forkNodes = any forkNodes recursively + , joinNodes = any joinNodes recursively + } + +renderComposite :: String -> (StateDiagram String Int a -> Inherited -> Synthesized) -> StateDiagram String Int a -> Inherited -> Synthesized +renderComposite kind eachWith StateDiagram{ substates, label, name, startState } inherited@Inherited{context, nameMapping} = + let + here = context ++ [label] + node = [i|#{if kind == "Regions" then "R" else "N"}_#{address here}|] + start = if null startState then Nothing else Just ([i|S_#{address here}|], here ++ startState) + Synthesized {alloy, names, rootNodes, innerStarts, endNodes, normalStates, hierarchicalStates, regionsStates, deepHistoryNodes, shallowHistoryNodes, forkNodes, joinNodes} = + renderInner eachWith substates + inherited {context = here} + in + Synthesized + { alloy = unlines $ + [i|one sig #{node} extends #{kind}{}{#{if kind == "RegionsStates" then "" else if null name then noName else "\n name = " ++ fromJust (lookup name nameMapping) ++ " // " ++ show name} + contains = #{intercalate " + " (maybe [] (\x -> [fst x]) start ++ rootNodes)} +}|] + : maybe id ((:) . renderStart) start + [ alloy ] + , names = if null name then names else name : names + , rootNodes = [node] + , innerStarts = innerStarts + if isNothing start then 0 else 1 + , endNodes = endNodes + , normalStates = normalStates + , hierarchicalStates = kind == "HierarchicalStates" || hierarchicalStates + , regionsStates = kind == "RegionsStates" || regionsStates + , deepHistoryNodes = deepHistoryNodes + , shallowHistoryNodes = shallowHistoryNodes + , forkNodes = forkNodes + , joinNodes = joinNodes + } + where + noName = "\n no name" -- because the line length limit is 200 characters +renderComposite _ _ _ _ = error "not defined" + +defaultSynthesized :: Synthesized +defaultSynthesized = Synthesized + { names = [] + , innerStarts = 0 + , endNodes = False + , normalStates = False + , hierarchicalStates = False + , regionsStates = False + , deepHistoryNodes = False + , shallowHistoryNodes = False + , forkNodes = False + , joinNodes = False + } + +renderNode :: StateDiagram String Int a -> Inherited -> Synthesized + +renderNode d@StateDiagram{} inherited = + renderComposite "HierarchicalStates" renderNode d inherited + +renderNode CombineDiagram { substates, label } inherited = + renderComposite "RegionsStates" + (renderComposite "Regions" renderNode) + StateDiagram{ substates = substates, label = label, name = "", startState = [] } + inherited + +renderNode InnerMostState { label, name } Inherited{context, nameMapping} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends NormalStates{}{ + #{if null name then "no name" else "name = " ++ fromJust (lookup name nameMapping) ++ " // " ++ show name} +}|] + , names = [name | notNull name] + , rootNodes = [node] + , normalStates = True + } + +renderNode EndState { label } Inherited{context} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends EndNodes{}|] + , rootNodes = [node] + , endNodes = True + } + +renderNode History { label, historyType } Inherited{context} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends #{show historyType}HistoryNodes{}|] + , rootNodes = [node] + , deepHistoryNodes = historyType == Deep + , shallowHistoryNodes = historyType == Shallow + } + +renderNode Fork {label} Inherited {context} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends ForkNodes{}|] + , rootNodes = [node] + , forkNodes = True + , joinNodes = False + } + +renderNode Join {label} Inherited {context} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends JoinNodes{}|] + , rootNodes = [node] + , forkNodes = False + , joinNodes = True + } + +address :: [Int] -> String +address = intercalate "_" . map show diff --git a/src/Modelling/StateDiagram/Generate.hs b/src/Modelling/StateDiagram/Generate.hs index 2412799f..0ed3b435 100644 --- a/src/Modelling/StateDiagram/Generate.hs +++ b/src/Modelling/StateDiagram/Generate.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-error=x-partial -Wno-error=deprecations #-} +{-# OPTIONS_GHC -Wno-error=deprecations #-} {-# LANGUAGE LambdaCase, RecordWildCards #-} module Modelling.StateDiagram.Generate (randomSD) where @@ -70,10 +70,10 @@ checkParallelRegion [_] _ _ = True checkParallelRegion _ [_] _ = True checkParallelRegion [_,_] _ _ = True checkParallelRegion _ [_,_] _ = True -checkParallelRegion (x:xs) (y:ys) subs - = case (x == y, all (isNotCD x) subs) of - (True, True) -> checkParallelRegion xs ys (getSubstates x subs) - (True, False) -> head xs == head ys && checkParallelRegion xs ys (getSubstates x subs) +checkParallelRegion (x1:x2:xs) (y1:y2:ys) subs + = case (x1 == y1, all (isNotCD x1) subs) of + (True, True) -> checkParallelRegion (x2:xs) (y2:ys) (getSubstates x1 subs) + (True, False) -> x2 == y2 && checkParallelRegion (x2:xs) (y2:ys) (getSubstates x1 subs) (False, _) -> True --haveForkOrJoin:: StateDiagram n Int [Connection Int] -> Bool @@ -239,8 +239,8 @@ randomSD' outermost c cdMaxNum leastTwoLevels ns alphabet (l,nm,mustCD) exclude start randomInnerSD :: Int -> Int -> [Int] -> [String] -> (Int,NodeType,[String],Bool) -> [String]-> Gen (StateDiagram String Int [Connection Int]) -randomInnerSD counter cdMaxNum ns alphabet (l,t,s,mustCD) exclude = do - let nm = head s +randomInnerSD _ _ _ _ (_,_,[],_) _ = error "randomInnerSD: empty name list" +randomInnerSD counter cdMaxNum ns alphabet (l,t,s@(nm:_),mustCD) exclude = do case t of Hist -> frequency [(1,return (History l Shallow)),(1,return (History l Deep))] End -> return (EndState l) diff --git a/src/Modelling/StateDiagram/Instance.hs b/src/Modelling/StateDiagram/Instance.hs index c293c843..909c892d 100644 --- a/src/Modelling/StateDiagram/Instance.hs +++ b/src/Modelling/StateDiagram/Instance.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-error=x-partial -Wwarn=incomplete-patterns #-} +{-# OPTIONS_GHC -Wwarn=incomplete-patterns #-} module Modelling.StateDiagram.Instance ( parseInstance, failWith @@ -158,7 +158,10 @@ Get path to element in the forest. Assumes there is just one such element. Fails if the element does not exist within the forest. -} getPathTo :: Eq a => Forest (a, b) -> a -> b -getPathTo x = head . catMaybes . getPathsTo x +getPathTo x y = + case catMaybes (getPathsTo x y) of + (p:_) -> p + [] -> error "getPathTo: element not found in forest" getPathsTo :: Eq a => Forest (a, b) -> a -> [Maybe b] getPathsTo [] _ = [] @@ -208,7 +211,7 @@ Like 'tail', but never trying to shorten the empty list. -} stail :: [a] -> [a] stail [] = [] -stail xs = tail xs +stail (_:xs) = xs treeToStateDiagram :: (Node -> String) diff --git a/src/Modelling/StateDiagram/Layout.hs b/src/Modelling/StateDiagram/Layout.hs index b3dec8a4..877f3226 100644 --- a/src/Modelling/StateDiagram/Layout.hs +++ b/src/Modelling/StateDiagram/Layout.hs @@ -1,4 +1,3 @@ -{-# OPTIONS_GHC -Wno-error=x-partial #-} {-# LANGUAGE RecordWildCards #-} module Modelling.StateDiagram.Layout @@ -12,7 +11,9 @@ import Diagrams.Backend.SVG.CmdLine import qualified Data.Map as Map import Data.Graph import Data.Tree +import Data.List (find) import Data.List.Index +import Data.Maybe (fromMaybe) import Modelling.StateDiagram.Arrows import Modelling.StateDiagram.Support import Modelling.StateDiagram.Style (Styling(..)) @@ -122,12 +123,19 @@ drawWrapper _ a (Transition b c l rightType layouts) = appendEdges layouts # named (a ++ [b]) where x = drawText c black -drawWrapper style a s@AndDecomposition {} = appendEdges (roundedRect (width f) (height f) 0.1 # lc (hashToColour style (head (dropWhile null (map strings (component s)) ++ [""]))) - <> f) (lengthXY s) (rightC s) (outerLayout s) # named (a ++ - [key s]) +drawWrapper style a s@AndDecomposition {} = + appendEdges + (roundedRect (width f) (height f) 0.1 + # lc (hashToColour style (fromMaybe "" (find (not . null) (map strings (component s))))) + <> f) + (lengthXY s) (rightC s) (outerLayout s) # named (a ++ [key s]) where - w = maximum (fmap (width . drawWrapper style (a ++ [key s])) (component s)) - h = maximum (fmap (height . drawWrapper style (a ++ [key s])) (component s)) + w = case fmap (width . drawWrapper style (a ++ [key s])) (component s) of + [] -> error "drawWrapper AndDecomposition: empty component" + xs -> maximum xs + h = case fmap (height . drawWrapper style (a ++ [key s])) (component s) of + [] -> error "drawWrapper AndDecomposition: empty component" + xs -> maximum xs d = (vcat . fmap alignL) (drawSwimlane False (fmap (drawWrapper' style (a ++ [key s])) (component s)) w) # centerXY e = (hcat . fmap alignT) (drawSwimlane True (fmap (drawWrapper' style (a ++ [key @@ -230,7 +238,9 @@ toWrapper s@StateDiagram {} = OrDecomposition toWrapper' (label s) (name s) newConnection = if null (startState s) then connections s else Connection [-1] (startState s) "" : connections s convertedConnection = changeConnectionType newConnection toWrapper' [] - maxKey = maximum (Map.keys $ mapWithLabel $ substates s) + maxKey = case Map.keys (mapWithLabel $ substates s) of + [] -> error "toWrapper: empty substates" + ks -> maximum ks createGraph :: Map.Map Int [Int] -> [StateDiagram String Int [Connection Int]] -> [(StateDiagram String Int [Connection Int], Int, [Int])] -> (Graph, Vertex -> (StateDiagram String Int [Connection Int], Int, [Int]), Int -> Maybe @@ -265,7 +275,9 @@ placeStartState [[a]] _ = [StartS (-1) 0 NoConnection Unspecified] : [[a]] placeStartState originalW ss = modifyAt layerToInsert (++ [StartS (-1) 0 NoConnection Unspecified]) originalW where - ssLayer = findLayer (head ss) originalW 0 + ssLayer = case ss of + h:_ -> findLayer h originalW 0 + [] -> error "placeStartState: empty startState list" layerToInsert = if ssLayer == (length originalW -1) then ssLayer - 1 else ssLayer + 1 @@ -302,12 +314,13 @@ addD :: ConnectionType -> Int -> [Int] -> [[Wrapper]] -> ConnectWithType -> addD a maxKey [_, _] withDummy c@ConnectWithType {} withConnect = (withDummy, maxKey, withConnect ++ [ConnectWithType (Connection [maxKey] (pointTo $ connecting c) (transition $ connecting c)) a]) -addD a maxKey (_:xs) withDummy c@ConnectWithType {} [] = - addD a (maxKey + 1) xs (modifyAt (head xs) (\ x -> x ++ [Dummy (maxKey + 1) +addD a maxKey (_:x1:xs) withDummy c@ConnectWithType {} [] = + addD a (maxKey + 1) (x1:xs) (modifyAt x1 (\ x -> x ++ [Dummy (maxKey + 1) Unspecified 0.1]) withDummy) c [ConnectWithType (Connection (pointFrom $ connecting c) [maxKey + 1] "") (betweenConnection a)] -addD a maxKey (_:xs) withDummy c@ConnectWithType {} withConnect = - addD a (maxKey + 1) xs (modifyAt (head xs) (\ x -> x ++ [Dummy (maxKey + 1) +addD _ maxKey [_] withDummy _ withConnect = (withDummy, maxKey, withConnect) +addD a maxKey (_:x1:xs) withDummy c@ConnectWithType {} withConnect = + addD a (maxKey + 1) (x1:xs) (modifyAt x1 (\ x -> x ++ [Dummy (maxKey + 1) Unspecified 0.1]) withDummy) c (withConnect ++ [ConnectWithType ( Connection [maxKey] [maxKey + 1] "") (betweenConnection a)]) addD _ _ _ _ _ _ = ([], 0, []) @@ -380,8 +393,12 @@ addTransitionStates maxKey transitionLayer originalLayer (x:xs) newConnection = addTransitionStates k (modifyAt endLayer addState transitionLayer) originalLayer xs (newConnection ++ type2) where - startLayer = findLayer (head $ pointFrom $ connecting x) originalLayer 0 - endLayer = findLayer (head $ pointTo $ connecting x) originalLayer 0 + startLayer = case pointFrom (connecting x) of + h:_ -> findLayer h originalLayer 0 + [] -> error "addTransitionStates: empty pointFrom" + endLayer = case pointTo (connecting x) of + h:_ -> findLayer h originalLayer 0 + [] -> error "addTransitionStates: empty pointTo" startLabel = pointFrom $ connecting x endLabel = pointTo $ connecting x connectName = transition (connecting x) @@ -417,16 +434,18 @@ connectionsByLayers (x:xs) layers connectionLayers = startStateFirst :: StateDiagram String Int [Connection Int] -> [Int] -> StateDiagram String Int [Connection Int] startStateFirst a [] = a startStateFirst a@StateDiagram {} (x:xs) = - StateDiagram (loopOrder : tail newOrder) (label a) (name a) (connections a) - (startState a) - where - newOrder = moveToFirst (substates a) x [] - loopOrder = startStateFirst (head newOrder) xs + case moveToFirst (substates a) x [] of + h:ts -> + let loopOrder = startStateFirst h xs + in StateDiagram (loopOrder : ts) (label a) (name a) (connections a) + (startState a) + [] -> error "startStateFirst: target startState not found" startStateFirst a@CombineDiagram {} (x:xs) = - CombineDiagram (loopOrder : tail newOrder) (label a) - where - newOrder = moveToFirst (substates a) x [] - loopOrder = startStateFirst (head newOrder) xs + case moveToFirst (substates a) x [] of + h:ts -> + let loopOrder = startStateFirst h xs + in CombineDiagram (loopOrder : ts) (label a) + [] -> error "startStateFirst: target startState not found" startStateFirst a _ = a rearrangeSubstates :: StateDiagram String Int [Connection Int] -> StateDiagram String Int [Connection Int] @@ -581,8 +600,12 @@ addCrossSuperStateDummy a b = case (pointFrom $ connecting b, pointTo $ ForwardWH startPoint [ConnectWithType (Connection pointFromLabel pointToLabel connectionName) SelfCL] a) where - startLayer = findLayer (head $ pointFrom $ connecting b) (layered a) 0 - endLayer = findLayer (head $ pointTo $ connecting b) (layered a) 0 + startLayer = case pointFrom (connecting b) of + h:_ -> findLayer h (layered a) 0 + [] -> error "addCrossSuperStateDummy: empty pointFrom" + endLayer = case pointTo (connecting b) of + h:_ -> findLayer h (layered a) 0 + [] -> error "addCrossSuperStateDummy: empty pointTo" startPoint = pointFrom $ connecting b endPoint = pointTo $ connecting b connectionName = transition $ connecting b @@ -678,14 +701,22 @@ csdWidth :: Double csdWidth = 0.05 insertDummyLeft :: Wrapper -> [[Wrapper]] -insertDummyLeft a = if all checkWrapperLayer (head $ layered a) then - (CrossStateDummy (maxLabel a + 1) csdWidth : head (layered a)) : tail (layered a) - else [CrossStateDummy (maxLabel a + 1) csdWidth] : layered a +insertDummyLeft a = case layered a of + first:rest -> + if all checkWrapperLayer first + then (CrossStateDummy (maxLabel a + 1) csdWidth : first) : rest + else [CrossStateDummy (maxLabel a + 1) csdWidth] : layered a + [] -> error "insertDummyLeft: layered is empty" insertDummyRight :: Wrapper -> [[Wrapper]] -insertDummyRight a = if all checkWrapperLayer (last $ layered a) then init ( - layered a) ++ [last (layered a) ++ [CrossStateDummy (maxLabel a + 1) csdWidth]] else - layered a ++ [[CrossStateDummy (maxLabel a + 1) csdWidth]] +insertDummyRight a = case reverse (layered a) of + lastPart:restRev -> + let initPart = reverse restRev + dummy = CrossStateDummy (maxLabel a + 1) csdWidth + in if all checkWrapperLayer lastPart + then initPart ++ [lastPart ++ [dummy]] + else reverse (lastPart:restRev) ++ [[dummy]] + [] -> error "insertDummyRight: layered is empty" changeConnectionType :: [Connection Int] -> [[Wrapper]] -> [ConnectWithType] -> [ConnectWithType] @@ -693,8 +724,12 @@ changeConnectionType [] _ withType = withType changeConnectionType (x:xs) layers withType = changeConnectionType xs layers (withType ++ [ConnectWithType x decideType]) where - startLayer = findLayer (head $ pointFrom x) layers 0 - endLayer = findLayer (head $ pointTo x) layers 0 + startLayer = case pointFrom x of + h:_ -> findLayer h layers 0 + [] -> error "changeConnectionType: empty pointFrom" + endLayer = case pointTo x of + h:_ -> findLayer h layers 0 + [] -> error "changeConnectionType: empty pointTo" decideType = decideConnectionType startLayer endLayer changeRightConnection :: Wrapper -> RightConnect -> Wrapper @@ -744,8 +779,12 @@ markRightConnection a b = OrDecomposition (layered afterChange) (key a) (strings (typedConnections a ++ [ConnectWithType (connecting b) decideConnectType]) (layout a) (maxLabel a) (lengthXY a) (rightC a) (outerLayout a) where - startLayer = findLayer (head (pointFrom $ connecting b)) (layered a) 0 - endLayer = findLayer (head (pointTo $ connecting b)) (layered a) 0 + startLayer = case pointFrom (connecting b) of + h:_ -> findLayer h (layered a) 0 + [] -> error "markRightConnection: empty pointFrom" + endLayer = case pointTo (connecting b) of + h:_ -> findLayer h (layered a) 0 + [] -> error "markRightConnection: empty pointTo" stateToModify = if startLayer < endLayer then pointFrom $ connecting b else pointTo $ connecting b afterChange = changeRightConnections stateToModify (key a) (if connectType @@ -902,9 +941,12 @@ edgeRedLayers layersBefore (x:xs) layersAfter connectionList crossingBef modifiedLayer]) connectionList crossingBef (crossingAfter + snd modifiedLayer) loop where - wrapperToInt = last layersAfter - modifiedLayer = edgeRedLayer wrapperToInt x (connectionList !! (length - layersAfter - 1)) [] loop + (wrapperToInt, currentConns) = + case (reverse layersAfter, reverse connectionList) of + (w:_, c:_) -> (w, c) + (w:_, []) -> (w, []) + _ -> error "edgeRedLayers: empty layersAfter/connectionList" + modifiedLayer = edgeRedLayer wrapperToInt x currentConns [] loop countCrossStateCrossing :: [Int] -> [[Int]] -> [ConnectWithType] -> Int -> Int countCrossStateCrossing _ [_] _ totalCrossing = totalCrossing diff --git a/test/Modelling/StateDiagram/EnumArrowsSpec.hs b/test/Modelling/StateDiagram/EnumArrowsSpec.hs index 0e8cd750..d61029db 100644 --- a/test/Modelling/StateDiagram/EnumArrowsSpec.hs +++ b/test/Modelling/StateDiagram/EnumArrowsSpec.hs @@ -1,180 +1,183 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ApplicativeDo #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Modelling.StateDiagram.EnumArrowsSpec (spec) -where - -import Test.Hspec (shouldBe - ,shouldNotBe - ,it - ,describe - ,Spec - ,context) -import Modelling.StateDiagram.EnumArrows(defaultEnumArrowsInstance - ,rate - ,EnumArrowsInstance (taskSolution - ,randomization - ,shuffle - ,flatAndEnumeratedSD) - ,randomiseLayout - ,randomise - ,ShufflePolicy (..) - ,hierarchicalSD - ,defaultEnumArrowsConfig - ,enumArrows - ) - -import Modelling.StateDiagram.Datatype.ClassInstances() -import Data.Bifunctor(first) -import Modelling.StateDiagram.Datatype (Connection(..) - ,globalise - ,UMLStateDiagram (unUML') - ,StateDiagram (connections) - ,collectNames) -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Char (toUpper) -import Data.Ratio ((%)) - - -spec :: Spec -spec - = do - describe "enum arrows task" $ do - context "randomization tests" $ do - - it "randomize chart layout for default chart" $ do - let task = defaultEnumArrowsInstance { randomization = True } - task' <- randomiseLayout task - task `shouldNotBe` task' - - it "test shuffle transition labels" $ do - let task = defaultEnumArrowsInstance { shuffle = Just ShuffleTriggers } - task' <- randomise task - let hsc = connections . unUML' . globalise $ hierarchicalSD task - let hsc' = connections . unUML' . globalise $ hierarchicalSD task' - let transitions x y - = [ (t,t') | Connection{ pointFrom = pF - , pointTo = pT - , transition = t } <- x - , Connection{ pointFrom=pF' - , pointTo=pT' - , transition=t' } <- y - , pF == pF' && pT == pT' ] - let shuffledHsc = transitions hsc hsc' - (hsc `shouldNotBe` hsc') - <* (length shuffledHsc `shouldBe` length hsc) - <* (length shuffledHsc `shouldBe` length hsc') - <* (any (uncurry (/=)) shuffledHsc `shouldBe` True) - <* (all ((\t -> t `elem` map transition hsc) . snd) shuffledHsc `shouldBe` True) - <* shouldNotBe [] hsc - <* shouldNotBe [] hsc' - - it "shuffle state names" $ do - let task = defaultEnumArrowsInstance { shuffle = Just ShuffleNames } - task' <- randomise task - (collectNames . hierarchicalSD $ task) `shouldNotBe` (collectNames . hierarchicalSD $ task') - - it "shuffle state names and transition labels" $ do - let task = defaultEnumArrowsInstance { shuffle = Just ShuffleNamesAndTriggers } - task' <- randomise task - (flatAndEnumeratedSD task `shouldNotBe` flatAndEnumeratedSD task') - *> (hierarchicalSD task `shouldNotBe` hierarchicalSD task') - *> (taskSolution task `shouldNotBe` taskSolution task') - - context "submission rating" $ do - it "no duplicates in answer" $ do - let - noDuplicates answer - = any (\(i,_) -> 1 < length (filter ((==) i . fst) answer)) answer - (submission::[(String,String)]) - = map (\ x_ -> curry (first show) x_ undefined) (take 10 ([1 .. ]::[Int])) - in - noDuplicates submission `shouldBe` False - it "duplicates in answer" $ do - let - noDuplicates answer - = any (\(i,_) -> 1 < length (filter ((==) i . fst) answer)) answer - (submission::[(String,String)]) - = map (\ x_ -> curry (first show) x_ undefined) (take 10 ([1 .. ]::[Int])) - ++ [("1",undefined)] - in - noDuplicates submission `shouldBe` True - it "pass rating test" $ do - let - task = defaultEnumArrowsInstance - answer = concatMap (uncurry zip) $ taskSolution task - in - rate (taskSolution task) answer `shouldBe` 1 - it "fail rating test by one point" $ do - let - task = defaultEnumArrowsInstance - answer = concatMap (uncurry zip) $ taskSolution task - in - rate (taskSolution task) (tail answer) - `shouldBe` - toRational (length answer - 1) / toRational (length answer) - it "ambiguous placeholder test variant 1" $ do - let - solution - = [(["5"],["c"]),(["6"],["e"]),(["7"],["f"]),(["8","9"],["a","b"])] - submission1 - = [("5","c"),("6","e"),("8","b"),("9","a"),("7","f")] - in - rate solution submission1 `shouldBe` 1 - it "ambiguous placeholder test variant 2" $ do - let - solution - = [(["5"],["c"]),(["6"],["e"]),(["7"],["f"]),(["8","9"],["a","b"])] - submission2 - = [("5","c"),("6","e"),("8","a"),("9","b"),("7","f")] - in - rate solution submission2 `shouldBe` 1 - it "ambiguous placeholder test variant 3" $ do - let - solution - = [(["1","2"],["a","b"])] - in - (rate solution [("1","a"),("2","b")] `shouldBe` 1) - *> (rate solution [("1","b"),("2","a")] `shouldBe` 1) - *> (rate solution [("1","a"),("2","a")] `shouldBe` (1 % 2)) - it "ambiguous placeholder test variant 4" $ do - let - solution - = [(["1","2","3"],["a","b","b"])] - in - (rate solution [("1","a"),("2","b"),("3","b")] `shouldBe` 1) - *> (rate solution [("1","b"),("2","a"),("3","b")] `shouldBe` 1) - *> (rate solution [("1","b"),("2","b"),("3","a")] `shouldBe` 1) - *> (rate solution [("1","a"),("2","a"),("3","b")] `shouldBe` (2 % 3)) - *> (rate solution [("1","a"),("2","b"),("3","a")] `shouldBe` (2 % 3)) - *> (rate solution [("1","b"),("2","a"),("3","a")] `shouldBe` (2 % 3)) - *> (rate solution [("1","a"),("2","a"),("3","a")] `shouldBe` (1 % 3)) - *> (rate solution [("1","b"),("2","b"),("3","b")] `shouldBe` (2 % 3)) - context "generate and solve" $ do - it "generate chart and solve it correctly" $ do - (timestamp::Int) <- round <$> getPOSIXTime - task <- enumArrows defaultEnumArrowsConfig timestamp - let sub = concatMap (uncurry zip) $ taskSolution task - rate (taskSolution task) sub `shouldBe` 1 - - it "generate chart and solve it partially" $ do - (timestamp::Int) <- round <$> getPOSIXTime - task <- enumArrows defaultEnumArrowsConfig timestamp - let sub = concatMap (uncurry zip) $ taskSolution task - let sub' - = if even $ length sub - then drop (length sub `div` 2) sub - else drop (length sub `div` 3) sub - rate (taskSolution task) sub' `shouldBe` fromIntegral (length sub') % fromIntegral (length sub) - - it "generate chart and solve it entirely wrong" $ do - (timestamp::Int) <- round <$> getPOSIXTime - task <- enumArrows defaultEnumArrowsConfig timestamp - let sub = map (\(x,y) -> (,) x $ map toUpper y) $ concatMap (uncurry zip) $ taskSolution task - rate (taskSolution task) sub `shouldBe` 0 +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Modelling.StateDiagram.EnumArrowsSpec (spec) +where + +import Test.Hspec (shouldBe + ,shouldNotBe + ,it + ,describe + ,Spec + ,context) +import Modelling.StateDiagram.EnumArrows(defaultEnumArrowsInstance + ,rate + ,EnumArrowsInstance (taskSolution + ,randomization + ,shuffle + ,flatAndEnumeratedSD) + ,randomiseLayout + ,randomise + ,ShufflePolicy (..) + ,hierarchicalSD + ,defaultEnumArrowsConfig + ,enumArrows + ) + +import Modelling.StateDiagram.Datatype.ClassInstances() +import Data.Bifunctor(first) +import Modelling.StateDiagram.Datatype (Connection(..) + ,globalise + ,UMLStateDiagram (unUML') + ,StateDiagram (connections) + ,collectNames) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Char (toUpper) +import Data.Ratio ((%)) + + +spec :: Spec +spec + = do + describe "enum arrows task" $ do + context "randomization tests" $ do + + it "randomize chart layout for default chart" $ do + let task = defaultEnumArrowsInstance { randomization = True } + task' <- randomiseLayout task + task `shouldNotBe` task' + + it "test shuffle transition labels" $ do + let task = defaultEnumArrowsInstance { shuffle = Just ShuffleTriggers } + task' <- randomise task + let hsc = connections . unUML' . globalise $ hierarchicalSD task + let hsc' = connections . unUML' . globalise $ hierarchicalSD task' + let transitions x y + = [ (t,t') | Connection{ pointFrom = pF + , pointTo = pT + , transition = t } <- x + , Connection{ pointFrom=pF' + , pointTo=pT' + , transition=t' } <- y + , pF == pF' && pT == pT' ] + let shuffledHsc = transitions hsc hsc' + (hsc `shouldNotBe` hsc') + <* (length shuffledHsc `shouldBe` length hsc) + <* (length shuffledHsc `shouldBe` length hsc') + <* (any (uncurry (/=)) shuffledHsc `shouldBe` True) + <* (all ((\t -> t `elem` map transition hsc) . snd) shuffledHsc `shouldBe` True) + <* shouldNotBe [] hsc + <* shouldNotBe [] hsc' + + it "shuffle state names" $ do + let task = defaultEnumArrowsInstance { shuffle = Just ShuffleNames } + task' <- randomise task + (collectNames . hierarchicalSD $ task) `shouldNotBe` (collectNames . hierarchicalSD $ task') + + it "shuffle state names and transition labels" $ do + let task = defaultEnumArrowsInstance { shuffle = Just ShuffleNamesAndTriggers } + task' <- randomise task + (flatAndEnumeratedSD task `shouldNotBe` flatAndEnumeratedSD task') + *> (hierarchicalSD task `shouldNotBe` hierarchicalSD task') + *> (taskSolution task `shouldNotBe` taskSolution task') + + context "submission rating" $ do + it "no duplicates in answer" $ do + let + noDuplicates answer + = any (\(i,_) -> 1 < length (filter ((==) i . fst) answer)) answer + (submission::[(String,String)]) + = map (\ x_ -> curry (first show) x_ undefined) (take 10 ([1 .. ]::[Int])) + in + noDuplicates submission `shouldBe` False + it "duplicates in answer" $ do + let + noDuplicates answer + = any (\(i,_) -> 1 < length (filter ((==) i . fst) answer)) answer + (submission::[(String,String)]) + = map (\ x_ -> curry (first show) x_ undefined) (take 10 ([1 .. ]::[Int])) + ++ [("1",undefined)] + in + noDuplicates submission `shouldBe` True + it "pass rating test" $ do + let + task = defaultEnumArrowsInstance + answer = concatMap (uncurry zip) $ taskSolution task + in + rate (taskSolution task) answer `shouldBe` 1 + it "fail rating test by one point" $ do + let + task = defaultEnumArrowsInstance + answer = concatMap (uncurry zip) $ taskSolution task + answerTail = case answer of + [] -> [] + (_:xs) -> xs + in + rate (taskSolution task) answerTail + `shouldBe` + toRational (length answer - 1) / toRational (length answer) + it "ambiguous placeholder test variant 1" $ do + let + solution + = [(["5"],["c"]),(["6"],["e"]),(["7"],["f"]),(["8","9"],["a","b"])] + submission1 + = [("5","c"),("6","e"),("8","b"),("9","a"),("7","f")] + in + rate solution submission1 `shouldBe` 1 + it "ambiguous placeholder test variant 2" $ do + let + solution + = [(["5"],["c"]),(["6"],["e"]),(["7"],["f"]),(["8","9"],["a","b"])] + submission2 + = [("5","c"),("6","e"),("8","a"),("9","b"),("7","f")] + in + rate solution submission2 `shouldBe` 1 + it "ambiguous placeholder test variant 3" $ do + let + solution + = [(["1","2"],["a","b"])] + in + (rate solution [("1","a"),("2","b")] `shouldBe` 1) + *> (rate solution [("1","b"),("2","a")] `shouldBe` 1) + *> (rate solution [("1","a"),("2","a")] `shouldBe` (1 % 2)) + it "ambiguous placeholder test variant 4" $ do + let + solution + = [(["1","2","3"],["a","b","b"])] + in + (rate solution [("1","a"),("2","b"),("3","b")] `shouldBe` 1) + *> (rate solution [("1","b"),("2","a"),("3","b")] `shouldBe` 1) + *> (rate solution [("1","b"),("2","b"),("3","a")] `shouldBe` 1) + *> (rate solution [("1","a"),("2","a"),("3","b")] `shouldBe` (2 % 3)) + *> (rate solution [("1","a"),("2","b"),("3","a")] `shouldBe` (2 % 3)) + *> (rate solution [("1","b"),("2","a"),("3","a")] `shouldBe` (2 % 3)) + *> (rate solution [("1","a"),("2","a"),("3","a")] `shouldBe` (1 % 3)) + *> (rate solution [("1","b"),("2","b"),("3","b")] `shouldBe` (2 % 3)) + context "generate and solve" $ do + it "generate chart and solve it correctly" $ do + (timestamp::Int) <- round <$> getPOSIXTime + task <- enumArrows defaultEnumArrowsConfig timestamp + let sub = concatMap (uncurry zip) $ taskSolution task + rate (taskSolution task) sub `shouldBe` 1 + + it "generate chart and solve it partially" $ do + (timestamp::Int) <- round <$> getPOSIXTime + task <- enumArrows defaultEnumArrowsConfig timestamp + let sub = concatMap (uncurry zip) $ taskSolution task + let sub' + = if even $ length sub + then drop (length sub `div` 2) sub + else drop (length sub `div` 3) sub + rate (taskSolution task) sub' `shouldBe` fromIntegral (length sub') % fromIntegral (length sub) + + it "generate chart and solve it entirely wrong" $ do + (timestamp::Int) <- round <$> getPOSIXTime + task <- enumArrows defaultEnumArrowsConfig timestamp + let sub = map (\(x,y) -> (,) x $ map toUpper y) $ concatMap (uncurry zip) $ taskSolution task + rate (taskSolution task) sub `shouldBe` 0 From 2db60ce5c0e0cac9e1c5df7a70ff27fa9c08d83a Mon Sep 17 00:00:00 2001 From: Zixin Wu Date: Fri, 5 Dec 2025 17:44:18 +0100 Subject: [PATCH 2/4] resolve issues of git diff --- src/Modelling/StateDiagram/AlloyDiagrams.hs | 474 +++++++++--------- src/Modelling/StateDiagram/Support.hs | 51 +- test/Modelling/StateDiagram/EnumArrowsSpec.hs | 366 +++++++------- 3 files changed, 452 insertions(+), 439 deletions(-) diff --git a/src/Modelling/StateDiagram/AlloyDiagrams.hs b/src/Modelling/StateDiagram/AlloyDiagrams.hs index 6a303e58..8fa0ff70 100644 --- a/src/Modelling/StateDiagram/AlloyDiagrams.hs +++ b/src/Modelling/StateDiagram/AlloyDiagrams.hs @@ -1,237 +1,237 @@ -{-# OPTIONS_GHC -Wno-error=missing-fields -Wno-error=incomplete-patterns -Wno-error=missing-signatures -Wno-error=type-defaults -Wno-error=name-shadowing #-} -{-# Language QuasiQuotes #-} -{-# Language NamedFieldPuns #-} -{-# Language ViewPatterns #-} - -module Modelling.StateDiagram.AlloyDiagrams (render) where - -import Modelling.StateDiagram.Datatype (UMLStateDiagram - ,unUML - ,StateDiagram(..) - ,Connection(..) - ,HistoryType(..) - ,globalise) - -import Data.String.Interpolate (i) -import Data.List (intercalate) -import Data.List.Extra (nubOrd, notNull) -import Data.Maybe (isNothing, fromJust) - -data Inherited = Inherited - { context :: [Int] - , nameMapping :: [(String,String)] - } - -data Synthesized = Synthesized - { alloy :: String - , names :: [String] - , rootNodes :: [String] - , innerStarts :: Int - , endNodes :: Bool - , normalStates :: Bool - , hierarchicalStates :: Bool - , regionsStates :: Bool - , deepHistoryNodes :: Bool - , shallowHistoryNodes :: Bool - , forkNodes :: Bool - , joinNodes :: Bool - } - -render :: Int -> UMLStateDiagram String Int -> String -render protoFlowScope = - unUML (\name substates connection startState -> - let Synthesized {alloy, names, innerStarts, endNodes, normalStates, hierarchicalStates, regionsStates, deepHistoryNodes, shallowHistoryNodes, forkNodes, joinNodes} = - renderInner renderNode substates - Inherited {context = [], nameMapping = nameMapping - } - nameMapping = zipWith (\name -> (name,) . ("Name" ++) . show) (nubOrd names) [1..] - nameOutput = map (\(_,component) -> [i|one sig #{component} extends ComponentNames{}|]) - nameMapping - transitionMapping = zipWith (\name -> (name,) . ("T" ++) . show) (nubOrd (filter (not . null) (map transition connection))) [1..] - transitionOutput = map (\(_,trigger) -> [i|one sig #{trigger} extends TriggerNames{}|]) - transitionMapping - numberOfFlows = length connection + innerStarts + if null startState then 0 else 1 - nullScopes = - concatMap ((" 0 "++) . (++",\n ") . snd) . filter fst $ - [ (not endNodes, "EndNodes") - , (null startState && innerStarts == 0, "StartNodes") - , (null names, "ComponentNames") - , (null transitionMapping, "TriggerNames") - , (not normalStates, "NormalStates") - , (not hierarchicalStates, "HierarchicalStates") - , (not regionsStates, "RegionsStates") - , (not regionsStates, "Regions") - , (not deepHistoryNodes, "DeepHistoryNodes") - , (not shallowHistoryNodes, "ShallowHistoryNodes") - , (not forkNodes, "ForkNodes") - , (not joinNodes, "JoinNodes") ] - in - [i|module diagram // name: #{show name} -open uml_state_diagram -#{if null startState then "" else renderStart ("S", startState)} -#{alloy} -#{unlines $ zipWith (renderConnection transitionMapping) connection [1..]} -#{unlines nameOutput} -#{unlines transitionOutput} -run {} for - #{nullScopes} #{show protoFlowScope} ProtoFlows, exactly #{show numberOfFlows} Flows -|] - ) - . globalise - -renderStart :: (String, [Int]) -> String -renderStart (start, target) = [i|one sig #{start} extends StartNodes{} -one sig #{start}Flow extends Flows{}{ - from = #{start} - label = EmptyTrigger - to = N_#{address target} -}|] - -renderConnection :: [(String, String)] -> Connection Int -> Int -> String -renderConnection transitionMapping Connection{ pointFrom, pointTo, transition } n = [i|one sig Connection#{n} extends Flows{}{ - from = N_#{address pointFrom} - label = #{if null transition then "EmptyTrigger" else fromJust (lookup transition transitionMapping) ++ " // " ++ show transition} - to = N_#{address pointTo} -}|] - -renderInner :: (StateDiagram String Int a -> Inherited -> Synthesized) -> [StateDiagram String Int a] -> Inherited -> Synthesized -renderInner recurse substates inherited = - let - recursively = map (`recurse` inherited) substates - in - Synthesized - { alloy = unlines $ map alloy recursively - , names = concatMap names recursively - , rootNodes = concatMap rootNodes recursively - , innerStarts = sum (map innerStarts recursively) - , endNodes = any endNodes recursively - , normalStates = any normalStates recursively - , hierarchicalStates = any hierarchicalStates recursively - , regionsStates = any regionsStates recursively - , deepHistoryNodes = any deepHistoryNodes recursively - , shallowHistoryNodes = any shallowHistoryNodes recursively - , forkNodes = any forkNodes recursively - , joinNodes = any joinNodes recursively - } - -renderComposite :: String -> (StateDiagram String Int a -> Inherited -> Synthesized) -> StateDiagram String Int a -> Inherited -> Synthesized -renderComposite kind eachWith StateDiagram{ substates, label, name, startState } inherited@Inherited{context, nameMapping} = - let - here = context ++ [label] - node = [i|#{if kind == "Regions" then "R" else "N"}_#{address here}|] - start = if null startState then Nothing else Just ([i|S_#{address here}|], here ++ startState) - Synthesized {alloy, names, rootNodes, innerStarts, endNodes, normalStates, hierarchicalStates, regionsStates, deepHistoryNodes, shallowHistoryNodes, forkNodes, joinNodes} = - renderInner eachWith substates - inherited {context = here} - in - Synthesized - { alloy = unlines $ - [i|one sig #{node} extends #{kind}{}{#{if kind == "RegionsStates" then "" else if null name then noName else "\n name = " ++ fromJust (lookup name nameMapping) ++ " // " ++ show name} - contains = #{intercalate " + " (maybe [] (\x -> [fst x]) start ++ rootNodes)} -}|] - : maybe id ((:) . renderStart) start - [ alloy ] - , names = if null name then names else name : names - , rootNodes = [node] - , innerStarts = innerStarts + if isNothing start then 0 else 1 - , endNodes = endNodes - , normalStates = normalStates - , hierarchicalStates = kind == "HierarchicalStates" || hierarchicalStates - , regionsStates = kind == "RegionsStates" || regionsStates - , deepHistoryNodes = deepHistoryNodes - , shallowHistoryNodes = shallowHistoryNodes - , forkNodes = forkNodes - , joinNodes = joinNodes - } - where - noName = "\n no name" -- because the line length limit is 200 characters -renderComposite _ _ _ _ = error "not defined" - -defaultSynthesized :: Synthesized -defaultSynthesized = Synthesized - { names = [] - , innerStarts = 0 - , endNodes = False - , normalStates = False - , hierarchicalStates = False - , regionsStates = False - , deepHistoryNodes = False - , shallowHistoryNodes = False - , forkNodes = False - , joinNodes = False - } - -renderNode :: StateDiagram String Int a -> Inherited -> Synthesized - -renderNode d@StateDiagram{} inherited = - renderComposite "HierarchicalStates" renderNode d inherited - -renderNode CombineDiagram { substates, label } inherited = - renderComposite "RegionsStates" - (renderComposite "Regions" renderNode) - StateDiagram{ substates = substates, label = label, name = "", startState = [] } - inherited - -renderNode InnerMostState { label, name } Inherited{context, nameMapping} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends NormalStates{}{ - #{if null name then "no name" else "name = " ++ fromJust (lookup name nameMapping) ++ " // " ++ show name} -}|] - , names = [name | notNull name] - , rootNodes = [node] - , normalStates = True - } - -renderNode EndState { label } Inherited{context} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends EndNodes{}|] - , rootNodes = [node] - , endNodes = True - } - -renderNode History { label, historyType } Inherited{context} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends #{show historyType}HistoryNodes{}|] - , rootNodes = [node] - , deepHistoryNodes = historyType == Deep - , shallowHistoryNodes = historyType == Shallow - } - -renderNode Fork {label} Inherited {context} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends ForkNodes{}|] - , rootNodes = [node] - , forkNodes = True - , joinNodes = False - } - -renderNode Join {label} Inherited {context} = - let - here = context ++ [label] - node = [i|N_#{address here}|] - in - defaultSynthesized - { alloy = [i|one sig #{node} extends JoinNodes{}|] - , rootNodes = [node] - , forkNodes = False - , joinNodes = True - } - -address :: [Int] -> String -address = intercalate "_" . map show +{-# OPTIONS_GHC -Wno-error=missing-fields -Wno-error=incomplete-patterns -Wno-error=missing-signatures -Wno-error=type-defaults -Wno-error=name-shadowing #-} +{-# Language QuasiQuotes #-} +{-# Language NamedFieldPuns #-} +{-# Language ViewPatterns #-} + +module Modelling.StateDiagram.AlloyDiagrams (render) where + +import Modelling.StateDiagram.Datatype (UMLStateDiagram + ,unUML + ,StateDiagram(..) + ,Connection(..) + ,HistoryType(..) + ,globalise) + +import Data.String.Interpolate (i) +import Data.List (intercalate) +import Data.List.Extra (nubOrd, notNull) +import Data.Maybe (isNothing, fromJust) + +data Inherited = Inherited + { context :: [Int] + , nameMapping :: [(String,String)] + } + +data Synthesized = Synthesized + { alloy :: String + , names :: [String] + , rootNodes :: [String] + , innerStarts :: Int + , endNodes :: Bool + , normalStates :: Bool + , hierarchicalStates :: Bool + , regionsStates :: Bool + , deepHistoryNodes :: Bool + , shallowHistoryNodes :: Bool + , forkNodes :: Bool + , joinNodes :: Bool + } + +render :: Int -> UMLStateDiagram String Int -> String +render protoFlowScope = + unUML (\name substates connection startState -> + let Synthesized {alloy, names, innerStarts, endNodes, normalStates, hierarchicalStates, regionsStates, deepHistoryNodes, shallowHistoryNodes, forkNodes, joinNodes} = + renderInner renderNode substates + Inherited {context = [], nameMapping = nameMapping + } + nameMapping = zipWith (\name -> (name,) . ("Name" ++) . show) (nubOrd names) [1..] + nameOutput = map (\(_,component) -> [i|one sig #{component} extends ComponentNames{}|]) + nameMapping + transitionMapping = zipWith (\name -> (name,) . ("T" ++) . show) (nubOrd (filter (not . null) (map transition connection))) [1..] + transitionOutput = map (\(_,trigger) -> [i|one sig #{trigger} extends TriggerNames{}|]) + transitionMapping + numberOfFlows = length connection + innerStarts + if null startState then 0 else 1 + nullScopes = + concatMap ((" 0 "++) . (++",\n ") . snd) . filter fst $ + [ (not endNodes, "EndNodes") + , (null startState && innerStarts == 0, "StartNodes") + , (null names, "ComponentNames") + , (null transitionMapping, "TriggerNames") + , (not normalStates, "NormalStates") + , (not hierarchicalStates, "HierarchicalStates") + , (not regionsStates, "RegionsStates") + , (not regionsStates, "Regions") + , (not deepHistoryNodes, "DeepHistoryNodes") + , (not shallowHistoryNodes, "ShallowHistoryNodes") + , (not forkNodes, "ForkNodes") + , (not joinNodes, "JoinNodes") ] + in + [i|module diagram // name: #{show name} +open uml_state_diagram +#{if null startState then "" else renderStart ("S", startState)} +#{alloy} +#{unlines $ zipWith (renderConnection transitionMapping) connection [1..]} +#{unlines nameOutput} +#{unlines transitionOutput} +run {} for + #{nullScopes} #{show protoFlowScope} ProtoFlows, exactly #{show numberOfFlows} Flows +|] + ) + . globalise + +renderStart :: (String, [Int]) -> String +renderStart (start, target) = [i|one sig #{start} extends StartNodes{} +one sig #{start}Flow extends Flows{}{ + from = #{start} + label = EmptyTrigger + to = N_#{address target} +}|] + +renderConnection :: [(String, String)] -> Connection Int -> Int -> String +renderConnection transitionMapping Connection{ pointFrom, pointTo, transition } n = [i|one sig Connection#{n} extends Flows{}{ + from = N_#{address pointFrom} + label = #{if null transition then "EmptyTrigger" else fromJust (lookup transition transitionMapping) ++ " // " ++ show transition} + to = N_#{address pointTo} +}|] + +renderInner :: (StateDiagram String Int a -> Inherited -> Synthesized) -> [StateDiagram String Int a] -> Inherited -> Synthesized +renderInner recurse substates inherited = + let + recursively = map (`recurse` inherited) substates + in + Synthesized + { alloy = unlines $ map alloy recursively + , names = concatMap names recursively + , rootNodes = concatMap rootNodes recursively + , innerStarts = sum (map innerStarts recursively) + , endNodes = any endNodes recursively + , normalStates = any normalStates recursively + , hierarchicalStates = any hierarchicalStates recursively + , regionsStates = any regionsStates recursively + , deepHistoryNodes = any deepHistoryNodes recursively + , shallowHistoryNodes = any shallowHistoryNodes recursively + , forkNodes = any forkNodes recursively + , joinNodes = any joinNodes recursively + } + +renderComposite :: String -> (StateDiagram String Int a -> Inherited -> Synthesized) -> StateDiagram String Int a -> Inherited -> Synthesized +renderComposite kind eachWith StateDiagram{ substates, label, name, startState } inherited@Inherited{context, nameMapping} = + let + here = context ++ [label] + node = [i|#{if kind == "Regions" then "R" else "N"}_#{address here}|] + start = if null startState then Nothing else Just ([i|S_#{address here}|], here ++ startState) + Synthesized {alloy, names, rootNodes, innerStarts, endNodes, normalStates, hierarchicalStates, regionsStates, deepHistoryNodes, shallowHistoryNodes, forkNodes, joinNodes} = + renderInner eachWith substates + inherited {context = here} + in + Synthesized + { alloy = unlines $ + [i|one sig #{node} extends #{kind}{}{#{if kind == "RegionsStates" then "" else if null name then noName else "\n name = " ++ fromJust (lookup name nameMapping) ++ " // " ++ show name} + contains = #{intercalate " + " (maybe [] (\x -> [fst x]) start ++ rootNodes)} +}|] + : maybe id ((:) . renderStart) start + [ alloy ] + , names = if null name then names else name : names + , rootNodes = [node] + , innerStarts = innerStarts + if isNothing start then 0 else 1 + , endNodes = endNodes + , normalStates = normalStates + , hierarchicalStates = kind == "HierarchicalStates" || hierarchicalStates + , regionsStates = kind == "RegionsStates" || regionsStates + , deepHistoryNodes = deepHistoryNodes + , shallowHistoryNodes = shallowHistoryNodes + , forkNodes = forkNodes + , joinNodes = joinNodes + } + where + noName = "\n no name" -- because the line length limit is 200 characters +renderComposite _ _ _ _ = error "not defined" + +defaultSynthesized :: Synthesized +defaultSynthesized = Synthesized + { names = [] + , innerStarts = 0 + , endNodes = False + , normalStates = False + , hierarchicalStates = False + , regionsStates = False + , deepHistoryNodes = False + , shallowHistoryNodes = False + , forkNodes = False + , joinNodes = False + } + +renderNode :: StateDiagram String Int a -> Inherited -> Synthesized + +renderNode d@StateDiagram{} inherited = + renderComposite "HierarchicalStates" renderNode d inherited + +renderNode CombineDiagram { substates, label } inherited = + renderComposite "RegionsStates" + (renderComposite "Regions" renderNode) + StateDiagram{ substates = substates, label = label, name = "", startState = [] } + inherited + +renderNode InnerMostState { label, name } Inherited{context, nameMapping} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends NormalStates{}{ + #{if null name then "no name" else "name = " ++ fromJust (lookup name nameMapping) ++ " // " ++ show name} +}|] + , names = [name | notNull name] + , rootNodes = [node] + , normalStates = True + } + +renderNode EndState { label } Inherited{context} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends EndNodes{}|] + , rootNodes = [node] + , endNodes = True + } + +renderNode History { label, historyType } Inherited{context} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends #{show historyType}HistoryNodes{}|] + , rootNodes = [node] + , deepHistoryNodes = historyType == Deep + , shallowHistoryNodes = historyType == Shallow + } + +renderNode Fork {label} Inherited {context} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends ForkNodes{}|] + , rootNodes = [node] + , forkNodes = True + , joinNodes = False + } + +renderNode Join {label} Inherited {context} = + let + here = context ++ [label] + node = [i|N_#{address here}|] + in + defaultSynthesized + { alloy = [i|one sig #{node} extends JoinNodes{}|] + , rootNodes = [node] + , forkNodes = False + , joinNodes = True + } + +address :: [Int] -> String +address = intercalate "_" . map show diff --git a/src/Modelling/StateDiagram/Support.hs b/src/Modelling/StateDiagram/Support.hs index e1171751..6148d968 100644 --- a/src/Modelling/StateDiagram/Support.hs +++ b/src/Modelling/StateDiagram/Support.hs @@ -1,9 +1,6 @@ -{-# OPTIONS_GHC -Wno-error=x-partial #-} - module Modelling.StateDiagram.Support where import Modelling.StateDiagram.Datatype import Data.Graph -import Data.Maybe import qualified Data.Map as Map import Data.List @@ -16,14 +13,14 @@ betweenConnection _ = ForwardH buildEmptyWrapperByLayer :: [[Wrapper]] -> [[Wrapper]] -> [[Wrapper]] buildEmptyWrapperByLayer [_, _] list = list ++ [[]] -buildEmptyWrapperByLayer xs list = buildEmptyWrapperByLayer (tail xs) - (list ++ [[]]) +buildEmptyWrapperByLayer (_:xs) list = buildEmptyWrapperByLayer xs (list ++ [[]]) +buildEmptyWrapperByLayer [] _ = error "buildEmptyWrapperByLayer: insufficient layers" buildEmptyConnectionByLayer :: [[Wrapper]] -> [[ConnectWithType]] -> [[ConnectWithType]] buildEmptyConnectionByLayer [_, _] list = list ++ [[]] -buildEmptyConnectionByLayer xs list = buildEmptyConnectionByLayer (tail xs) - (list ++ [[]]) +buildEmptyConnectionByLayer (_:xs) list = buildEmptyConnectionByLayer xs (list ++ [[]]) +buildEmptyConnectionByLayer [] _ = error "buildEmptyConnectionByLayer: insufficient layers" checkWrapperLayer :: Wrapper -> Bool checkWrapperLayer StartS {} = True @@ -88,9 +85,11 @@ findLayer num (x:xs) layer getCompareList :: Bool -> Wrapper -> [[Int]] getCompareList checkType wrapper = case wrapper of - OrDecomposition {} -> if checkType then fmap ((\ a -> key wrapper : [a]) . key) - (head $ layered wrapper) else fmap ((\ a -> key wrapper : [a]) . key) - (last $ layered wrapper) + OrDecomposition {} -> case layered wrapper of + [] -> error "getCompareList: empty layered" + layers@(l:_) -> + let pick = if checkType then l else last layers + in fmap ((\ a -> key wrapper : [a]) . key) pick AndDecomposition {} -> fmap (key wrapper :) (concatMap (getCompareList checkType) (component wrapper)) _ -> [] @@ -103,13 +102,16 @@ getConnection a = fmap (\ (ConnectWithType x y) -> ((a ++ pointFrom x, a ++ getConnectionWithLayerBefore2 :: Wrapper -> [ConnectWithType] -> [[Int]] -> [[Int]] getConnectionWithLayerBefore2 _ [] connected = connected getConnectionWithLayerBefore2 wrapper (x:xs) connected - | head (pointFrom y) == key wrapper = getConnectionWithLayerBefore2 wrapper xs + | startsWithWrapper (pointFrom y) = getConnectionWithLayerBefore2 wrapper xs (connected ++ [pointTo y]) - | head (pointTo y) == key wrapper = getConnectionWithLayerBefore2 wrapper xs + | startsWithWrapper (pointTo y) = getConnectionWithLayerBefore2 wrapper xs (connected ++ [pointFrom y]) | otherwise = getConnectionWithLayerBefore2 wrapper xs connected where y = connecting x + startsWithWrapper z = case z of + h:_ -> h == key wrapper + [] -> error "getConnectionWithLayerBefore2: empty point list" getConnectionWithLayerBefore3 :: [Int] -> [ConnectWithType] -> [[Int]] -> [[Int]] getConnectionWithLayerBefore3 _ [] connected = connected @@ -143,14 +145,18 @@ getDeeperLevelL ([a], [b]) commonValue layersBef = higherIndex (a, b) (fmap key newLayerBef) where newState = returnState layersBef commonValue - newLayerBef = last $ layered newState + newLayerBef = case layered newState of + [] -> error "getDeeperLevelL: empty layered" + xs -> last xs getDeeperLevelL ([a, as], [b, bs]) commonValue layersBef = if a /= b then higherIndex (a, b) (fmap key (component newState)) else higherIndex (as, bs) newAndLayerBef where newState = returnState layersBef commonValue newState' = returnState (component newState) a - newAndLayerBef = fmap key (last (layered newState')) + newAndLayerBef = case layered newState' of + [] -> error "getDeeperLevelL: empty layered (nested)" + xs -> fmap key (last xs) getDeeperLevelL _ _ _ = 0 -- jscpd:ignore-end @@ -159,14 +165,18 @@ getDeeperLevelR ([a], [b]) commonValue layersBef = higherIndex (a, b) (fmap key newLayerBef) where newState = returnState layersBef commonValue - newLayerBef = head $ layered newState + newLayerBef = case layered newState of + [] -> error "getDeeperLevelR: empty layered" + (x:_) -> x getDeeperLevelR ([a, as], [b, bs]) commonValue layersBef = if a /= b then higherIndex (a, b) (fmap key (component newState)) else higherIndex (as, bs) newAndLayerBef where newState = returnState layersBef commonValue newState' = returnState (component newState) a - newAndLayerBef = fmap key (head (layered newState')) + newAndLayerBef = case layered newState' of + [] -> error "getDeeperLevelR: empty layered (nested)" + (x:_) -> fmap key x getDeeperLevelR _ _ _ = 0 getFirstFromTuple3 :: (a, b, c) -> a @@ -193,7 +203,9 @@ getUMLStateDiagram vertex graphFE = getFirstFromTuple3 (getSecondFromTuple3 higherIndex :: (Int, Int) -> [Int] -> Int higherIndex (fstValue, sndValue) list - | fromJust (elemIndex fstValue list) > fromJust (elemIndex sndValue list) = 1 + | Just i1 <- elemIndex fstValue list + , Just i2 <- elemIndex sndValue list + , i1 > i2 = 1 | otherwise = 0 higherIndex2 :: ([Int], [Int]) -> [Wrapper] -> Bool -> Int @@ -213,8 +225,9 @@ mapWithLabel a = Map.fromList (fmap (\ x -> (label x, x)) a) mapWithConnection :: Ord a => [Connection a] -> Map.Map a [a] mapWithConnection - = foldl (\ a x -> Map.insertWith (++) (head (pointFrom x)) (pointTo x) a) - Map.empty + = foldl (\ a x -> case pointFrom x of + h:_ -> Map.insertWith (++) h (pointTo x) a + [] -> error "mapWithConnection: empty pointFrom") Map.empty mapWithConnection' :: [StateDiagram n Int [Connection Int]] -> Map.Map Int [Int] -> Map.Map Int [Int] diff --git a/test/Modelling/StateDiagram/EnumArrowsSpec.hs b/test/Modelling/StateDiagram/EnumArrowsSpec.hs index d61029db..9805e3e1 100644 --- a/test/Modelling/StateDiagram/EnumArrowsSpec.hs +++ b/test/Modelling/StateDiagram/EnumArrowsSpec.hs @@ -1,183 +1,183 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ApplicativeDo #-} -{-# OPTIONS_GHC -Wno-deprecations #-} - -module Modelling.StateDiagram.EnumArrowsSpec (spec) -where - -import Test.Hspec (shouldBe - ,shouldNotBe - ,it - ,describe - ,Spec - ,context) -import Modelling.StateDiagram.EnumArrows(defaultEnumArrowsInstance - ,rate - ,EnumArrowsInstance (taskSolution - ,randomization - ,shuffle - ,flatAndEnumeratedSD) - ,randomiseLayout - ,randomise - ,ShufflePolicy (..) - ,hierarchicalSD - ,defaultEnumArrowsConfig - ,enumArrows - ) - -import Modelling.StateDiagram.Datatype.ClassInstances() -import Data.Bifunctor(first) -import Modelling.StateDiagram.Datatype (Connection(..) - ,globalise - ,UMLStateDiagram (unUML') - ,StateDiagram (connections) - ,collectNames) -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Char (toUpper) -import Data.Ratio ((%)) - - -spec :: Spec -spec - = do - describe "enum arrows task" $ do - context "randomization tests" $ do - - it "randomize chart layout for default chart" $ do - let task = defaultEnumArrowsInstance { randomization = True } - task' <- randomiseLayout task - task `shouldNotBe` task' - - it "test shuffle transition labels" $ do - let task = defaultEnumArrowsInstance { shuffle = Just ShuffleTriggers } - task' <- randomise task - let hsc = connections . unUML' . globalise $ hierarchicalSD task - let hsc' = connections . unUML' . globalise $ hierarchicalSD task' - let transitions x y - = [ (t,t') | Connection{ pointFrom = pF - , pointTo = pT - , transition = t } <- x - , Connection{ pointFrom=pF' - , pointTo=pT' - , transition=t' } <- y - , pF == pF' && pT == pT' ] - let shuffledHsc = transitions hsc hsc' - (hsc `shouldNotBe` hsc') - <* (length shuffledHsc `shouldBe` length hsc) - <* (length shuffledHsc `shouldBe` length hsc') - <* (any (uncurry (/=)) shuffledHsc `shouldBe` True) - <* (all ((\t -> t `elem` map transition hsc) . snd) shuffledHsc `shouldBe` True) - <* shouldNotBe [] hsc - <* shouldNotBe [] hsc' - - it "shuffle state names" $ do - let task = defaultEnumArrowsInstance { shuffle = Just ShuffleNames } - task' <- randomise task - (collectNames . hierarchicalSD $ task) `shouldNotBe` (collectNames . hierarchicalSD $ task') - - it "shuffle state names and transition labels" $ do - let task = defaultEnumArrowsInstance { shuffle = Just ShuffleNamesAndTriggers } - task' <- randomise task - (flatAndEnumeratedSD task `shouldNotBe` flatAndEnumeratedSD task') - *> (hierarchicalSD task `shouldNotBe` hierarchicalSD task') - *> (taskSolution task `shouldNotBe` taskSolution task') - - context "submission rating" $ do - it "no duplicates in answer" $ do - let - noDuplicates answer - = any (\(i,_) -> 1 < length (filter ((==) i . fst) answer)) answer - (submission::[(String,String)]) - = map (\ x_ -> curry (first show) x_ undefined) (take 10 ([1 .. ]::[Int])) - in - noDuplicates submission `shouldBe` False - it "duplicates in answer" $ do - let - noDuplicates answer - = any (\(i,_) -> 1 < length (filter ((==) i . fst) answer)) answer - (submission::[(String,String)]) - = map (\ x_ -> curry (first show) x_ undefined) (take 10 ([1 .. ]::[Int])) - ++ [("1",undefined)] - in - noDuplicates submission `shouldBe` True - it "pass rating test" $ do - let - task = defaultEnumArrowsInstance - answer = concatMap (uncurry zip) $ taskSolution task - in - rate (taskSolution task) answer `shouldBe` 1 - it "fail rating test by one point" $ do - let - task = defaultEnumArrowsInstance - answer = concatMap (uncurry zip) $ taskSolution task - answerTail = case answer of - [] -> [] - (_:xs) -> xs - in - rate (taskSolution task) answerTail - `shouldBe` - toRational (length answer - 1) / toRational (length answer) - it "ambiguous placeholder test variant 1" $ do - let - solution - = [(["5"],["c"]),(["6"],["e"]),(["7"],["f"]),(["8","9"],["a","b"])] - submission1 - = [("5","c"),("6","e"),("8","b"),("9","a"),("7","f")] - in - rate solution submission1 `shouldBe` 1 - it "ambiguous placeholder test variant 2" $ do - let - solution - = [(["5"],["c"]),(["6"],["e"]),(["7"],["f"]),(["8","9"],["a","b"])] - submission2 - = [("5","c"),("6","e"),("8","a"),("9","b"),("7","f")] - in - rate solution submission2 `shouldBe` 1 - it "ambiguous placeholder test variant 3" $ do - let - solution - = [(["1","2"],["a","b"])] - in - (rate solution [("1","a"),("2","b")] `shouldBe` 1) - *> (rate solution [("1","b"),("2","a")] `shouldBe` 1) - *> (rate solution [("1","a"),("2","a")] `shouldBe` (1 % 2)) - it "ambiguous placeholder test variant 4" $ do - let - solution - = [(["1","2","3"],["a","b","b"])] - in - (rate solution [("1","a"),("2","b"),("3","b")] `shouldBe` 1) - *> (rate solution [("1","b"),("2","a"),("3","b")] `shouldBe` 1) - *> (rate solution [("1","b"),("2","b"),("3","a")] `shouldBe` 1) - *> (rate solution [("1","a"),("2","a"),("3","b")] `shouldBe` (2 % 3)) - *> (rate solution [("1","a"),("2","b"),("3","a")] `shouldBe` (2 % 3)) - *> (rate solution [("1","b"),("2","a"),("3","a")] `shouldBe` (2 % 3)) - *> (rate solution [("1","a"),("2","a"),("3","a")] `shouldBe` (1 % 3)) - *> (rate solution [("1","b"),("2","b"),("3","b")] `shouldBe` (2 % 3)) - context "generate and solve" $ do - it "generate chart and solve it correctly" $ do - (timestamp::Int) <- round <$> getPOSIXTime - task <- enumArrows defaultEnumArrowsConfig timestamp - let sub = concatMap (uncurry zip) $ taskSolution task - rate (taskSolution task) sub `shouldBe` 1 - - it "generate chart and solve it partially" $ do - (timestamp::Int) <- round <$> getPOSIXTime - task <- enumArrows defaultEnumArrowsConfig timestamp - let sub = concatMap (uncurry zip) $ taskSolution task - let sub' - = if even $ length sub - then drop (length sub `div` 2) sub - else drop (length sub `div` 3) sub - rate (taskSolution task) sub' `shouldBe` fromIntegral (length sub') % fromIntegral (length sub) - - it "generate chart and solve it entirely wrong" $ do - (timestamp::Int) <- round <$> getPOSIXTime - task <- enumArrows defaultEnumArrowsConfig timestamp - let sub = map (\(x,y) -> (,) x $ map toUpper y) $ concatMap (uncurry zip) $ taskSolution task - rate (taskSolution task) sub `shouldBe` 0 +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Modelling.StateDiagram.EnumArrowsSpec (spec) +where + +import Test.Hspec (shouldBe + ,shouldNotBe + ,it + ,describe + ,Spec + ,context) +import Modelling.StateDiagram.EnumArrows(defaultEnumArrowsInstance + ,rate + ,EnumArrowsInstance (taskSolution + ,randomization + ,shuffle + ,flatAndEnumeratedSD) + ,randomiseLayout + ,randomise + ,ShufflePolicy (..) + ,hierarchicalSD + ,defaultEnumArrowsConfig + ,enumArrows + ) + +import Modelling.StateDiagram.Datatype.ClassInstances() +import Data.Bifunctor(first) +import Modelling.StateDiagram.Datatype (Connection(..) + ,globalise + ,UMLStateDiagram (unUML') + ,StateDiagram (connections) + ,collectNames) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Char (toUpper) +import Data.Ratio ((%)) + + +spec :: Spec +spec + = do + describe "enum arrows task" $ do + context "randomization tests" $ do + + it "randomize chart layout for default chart" $ do + let task = defaultEnumArrowsInstance { randomization = True } + task' <- randomiseLayout task + task `shouldNotBe` task' + + it "test shuffle transition labels" $ do + let task = defaultEnumArrowsInstance { shuffle = Just ShuffleTriggers } + task' <- randomise task + let hsc = connections . unUML' . globalise $ hierarchicalSD task + let hsc' = connections . unUML' . globalise $ hierarchicalSD task' + let transitions x y + = [ (t,t') | Connection{ pointFrom = pF + , pointTo = pT + , transition = t } <- x + , Connection{ pointFrom=pF' + , pointTo=pT' + , transition=t' } <- y + , pF == pF' && pT == pT' ] + let shuffledHsc = transitions hsc hsc' + (hsc `shouldNotBe` hsc') + <* (length shuffledHsc `shouldBe` length hsc) + <* (length shuffledHsc `shouldBe` length hsc') + <* (any (uncurry (/=)) shuffledHsc `shouldBe` True) + <* (all ((\t -> t `elem` map transition hsc) . snd) shuffledHsc `shouldBe` True) + <* shouldNotBe [] hsc + <* shouldNotBe [] hsc' + + it "shuffle state names" $ do + let task = defaultEnumArrowsInstance { shuffle = Just ShuffleNames } + task' <- randomise task + (collectNames . hierarchicalSD $ task) `shouldNotBe` (collectNames . hierarchicalSD $ task') + + it "shuffle state names and transition labels" $ do + let task = defaultEnumArrowsInstance { shuffle = Just ShuffleNamesAndTriggers } + task' <- randomise task + (flatAndEnumeratedSD task `shouldNotBe` flatAndEnumeratedSD task') + *> (hierarchicalSD task `shouldNotBe` hierarchicalSD task') + *> (taskSolution task `shouldNotBe` taskSolution task') + + context "submission rating" $ do + it "no duplicates in answer" $ do + let + noDuplicates answer + = any (\(i,_) -> 1 < length (filter ((==) i . fst) answer)) answer + (submission::[(String,String)]) + = map (\ x_ -> curry (first show) x_ undefined) (take 10 ([1 .. ]::[Int])) + in + noDuplicates submission `shouldBe` False + it "duplicates in answer" $ do + let + noDuplicates answer + = any (\(i,_) -> 1 < length (filter ((==) i . fst) answer)) answer + (submission::[(String,String)]) + = map (\ x_ -> curry (first show) x_ undefined) (take 10 ([1 .. ]::[Int])) + ++ [("1",undefined)] + in + noDuplicates submission `shouldBe` True + it "pass rating test" $ do + let + task = defaultEnumArrowsInstance + answer = concatMap (uncurry zip) $ taskSolution task + in + rate (taskSolution task) answer `shouldBe` 1 + it "fail rating test by one point" $ do + let + task = defaultEnumArrowsInstance + answer = concatMap (uncurry zip) $ taskSolution task + answerTail = case answer of + [] -> [] + (_:xs) -> xs + in + rate (taskSolution task) answerTail + `shouldBe` + toRational (length answer - 1) / toRational (length answer) + it "ambiguous placeholder test variant 1" $ do + let + solution + = [(["5"],["c"]),(["6"],["e"]),(["7"],["f"]),(["8","9"],["a","b"])] + submission1 + = [("5","c"),("6","e"),("8","b"),("9","a"),("7","f")] + in + rate solution submission1 `shouldBe` 1 + it "ambiguous placeholder test variant 2" $ do + let + solution + = [(["5"],["c"]),(["6"],["e"]),(["7"],["f"]),(["8","9"],["a","b"])] + submission2 + = [("5","c"),("6","e"),("8","a"),("9","b"),("7","f")] + in + rate solution submission2 `shouldBe` 1 + it "ambiguous placeholder test variant 3" $ do + let + solution + = [(["1","2"],["a","b"])] + in + (rate solution [("1","a"),("2","b")] `shouldBe` 1) + *> (rate solution [("1","b"),("2","a")] `shouldBe` 1) + *> (rate solution [("1","a"),("2","a")] `shouldBe` (1 % 2)) + it "ambiguous placeholder test variant 4" $ do + let + solution + = [(["1","2","3"],["a","b","b"])] + in + (rate solution [("1","a"),("2","b"),("3","b")] `shouldBe` 1) + *> (rate solution [("1","b"),("2","a"),("3","b")] `shouldBe` 1) + *> (rate solution [("1","b"),("2","b"),("3","a")] `shouldBe` 1) + *> (rate solution [("1","a"),("2","a"),("3","b")] `shouldBe` (2 % 3)) + *> (rate solution [("1","a"),("2","b"),("3","a")] `shouldBe` (2 % 3)) + *> (rate solution [("1","b"),("2","a"),("3","a")] `shouldBe` (2 % 3)) + *> (rate solution [("1","a"),("2","a"),("3","a")] `shouldBe` (1 % 3)) + *> (rate solution [("1","b"),("2","b"),("3","b")] `shouldBe` (2 % 3)) + context "generate and solve" $ do + it "generate chart and solve it correctly" $ do + (timestamp::Int) <- round <$> getPOSIXTime + task <- enumArrows defaultEnumArrowsConfig timestamp + let sub = concatMap (uncurry zip) $ taskSolution task + rate (taskSolution task) sub `shouldBe` 1 + + it "generate chart and solve it partially" $ do + (timestamp::Int) <- round <$> getPOSIXTime + task <- enumArrows defaultEnumArrowsConfig timestamp + let sub = concatMap (uncurry zip) $ taskSolution task + let sub' + = if even $ length sub + then drop (length sub `div` 2) sub + else drop (length sub `div` 3) sub + rate (taskSolution task) sub' `shouldBe` fromIntegral (length sub') % fromIntegral (length sub) + + it "generate chart and solve it entirely wrong" $ do + (timestamp::Int) <- round <$> getPOSIXTime + task <- enumArrows defaultEnumArrowsConfig timestamp + let sub = map (\(x,y) -> (,) x $ map toUpper y) $ concatMap (uncurry zip) $ taskSolution task + rate (taskSolution task) sub `shouldBe` 0 From 784d19c8ba6ff77f4dd10ffd8474409e294968bd Mon Sep 17 00:00:00 2001 From: Zixin Wu Date: Sat, 6 Dec 2025 02:36:29 +0100 Subject: [PATCH 3/4] fix issues of the semantic change --- src/Modelling/StateDiagram/Layout.hs | 11 ++++------- src/Modelling/StateDiagram/Support.hs | 5 ++--- 2 files changed, 6 insertions(+), 10 deletions(-) diff --git a/src/Modelling/StateDiagram/Layout.hs b/src/Modelling/StateDiagram/Layout.hs index 877f3226..d20a7c6d 100644 --- a/src/Modelling/StateDiagram/Layout.hs +++ b/src/Modelling/StateDiagram/Layout.hs @@ -318,7 +318,7 @@ addD a maxKey (_:x1:xs) withDummy c@ConnectWithType {} [] = addD a (maxKey + 1) (x1:xs) (modifyAt x1 (\ x -> x ++ [Dummy (maxKey + 1) Unspecified 0.1]) withDummy) c [ConnectWithType (Connection (pointFrom $ connecting c) [maxKey + 1] "") (betweenConnection a)] -addD _ maxKey [_] withDummy _ withConnect = (withDummy, maxKey, withConnect) +addD _ _ [_] _ _ _ = error "addD: single element list - insufficient layers" addD a maxKey (_:x1:xs) withDummy c@ConnectWithType {} withConnect = addD a (maxKey + 1) (x1:xs) (modifyAt x1 (\ x -> x ++ [Dummy (maxKey + 1) Unspecified 0.1]) withDummy) c (withConnect ++ [ConnectWithType ( @@ -941,12 +941,9 @@ edgeRedLayers layersBefore (x:xs) layersAfter connectionList crossingBef modifiedLayer]) connectionList crossingBef (crossingAfter + snd modifiedLayer) loop where - (wrapperToInt, currentConns) = - case (reverse layersAfter, reverse connectionList) of - (w:_, c:_) -> (w, c) - (w:_, []) -> (w, []) - _ -> error "edgeRedLayers: empty layersAfter/connectionList" - modifiedLayer = edgeRedLayer wrapperToInt x currentConns [] loop + wrapperToInt = last layersAfter + modifiedLayer = edgeRedLayer wrapperToInt x (connectionList !! (length + layersAfter - 1)) [] loop countCrossStateCrossing :: [Int] -> [[Int]] -> [ConnectWithType] -> Int -> Int countCrossStateCrossing _ [_] _ totalCrossing = totalCrossing diff --git a/src/Modelling/StateDiagram/Support.hs b/src/Modelling/StateDiagram/Support.hs index 6148d968..80145083 100644 --- a/src/Modelling/StateDiagram/Support.hs +++ b/src/Modelling/StateDiagram/Support.hs @@ -1,6 +1,7 @@ module Modelling.StateDiagram.Support where import Modelling.StateDiagram.Datatype import Data.Graph +import Data.Maybe import qualified Data.Map as Map import Data.List @@ -203,9 +204,7 @@ getUMLStateDiagram vertex graphFE = getFirstFromTuple3 (getSecondFromTuple3 higherIndex :: (Int, Int) -> [Int] -> Int higherIndex (fstValue, sndValue) list - | Just i1 <- elemIndex fstValue list - , Just i2 <- elemIndex sndValue list - , i1 > i2 = 1 + | fromJust (elemIndex fstValue list) > fromJust (elemIndex sndValue list) = 1 | otherwise = 0 higherIndex2 :: ([Int], [Int]) -> [Wrapper] -> Bool -> Int From aebc58d0acdbf0d9c33b25894a38a8ac11c0b25d Mon Sep 17 00:00:00 2001 From: Zixin Wu Date: Mon, 8 Dec 2025 13:22:08 +0100 Subject: [PATCH 4/4] replace stail with drop 1 --- src/Modelling/StateDiagram/Instance.hs | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/src/Modelling/StateDiagram/Instance.hs b/src/Modelling/StateDiagram/Instance.hs index 909c892d..8d4abfb4 100644 --- a/src/Modelling/StateDiagram/Instance.hs +++ b/src/Modelling/StateDiagram/Instance.hs @@ -200,19 +200,12 @@ forestToStateDiagram -> StateDiagram String Int () forestToStateDiagram getName getStart ts = StateDiagram { label = 1, - substates = treeToStateDiagram getName (stail . getStart) <$> ts, + substates = treeToStateDiagram getName (drop 1 . getStart) <$> ts, name = "", connections = (), -- TODO startState = getStart Nothing } -{-| -Like 'tail', but never trying to shorten the empty list. --} -stail :: [a] -> [a] -stail [] = [] -stail (_:xs) = xs - treeToStateDiagram :: (Node -> String) -> (Maybe Node -> [Int]) @@ -246,7 +239,7 @@ treeToStateDiagram getName getStart n = case node of l = last $ snd root root = rootLabel n node = fst root - fromTree = treeToStateDiagram getName (stail . getStart) + fromTree = treeToStateDiagram getName (drop 1 . getStart) {-| Transforms a mapping of containments into a tree structure.