Fri Nov 4 14:06:50 WET 2005 Malcolm.Wallace@cs.york.ac.uk
* remove all the FPTC stuff
The FPTC backend should not be publically available (yet). Initially,
it was in the repository as a guide to how to use the class Analysis.
This has now been replaced by a more trivial example, using just Ints
stored at nodes, and propagating them along edges.
{
hunk ./src/FPTC/Analysis.hs 1
-module FPTC.Analysis where
-
-import FPTC.Expressions
-import FPTC.FaultSpec
-import FPTC.PointTrace as PointTrace
-import FPTC.ListStuff (permute,transpose)
-import InfoKind
-import Analysis
-import Set (Set)
-import qualified Set as Set
-import Data.FiniteMap
-import IntMap (IntMap)
-import qualified IntMap
-import Network
-import Node
-import Maybe (fromJust)
-
--- FPTC analysis takes a FaultTransform on each node, and produces
--- a Set Fault on each edge.
-instance Analysis FaultModel FaultTransform (Set Fault) where
- analyse (g, nodemap, edgemap) = (g, nodemap, edgemap')
- where edgemap' = stabilise nodemap (IntMap.map (\e->e{edgeInfo=()}) edgemap)
- revert (g, nodemap, edgemap) = (g, nodemap, edgemap')
- where edgemap' = IntMap.map (\e-> e { edgeInfo = blank }) edgemap
-
-------------------------------------------------------------------------
-
--- | The outcome of the analysis associates a faultset to each connection.
--- The Int keys here are identical to those in the original IntMap (Edge e).
-type Outcome = IntMap (Set (Fault,PointTrace))
-
--- | A simplified representation of nodes - we are only interested in
--- their connections, and their FTPC clauses.
-data SimpleNode = SimpleNode
- { transforms :: [FaultClause]
- , inbound :: [EdgeNr] -- ordered by incoming port number ?
- , outbound :: [EdgeNr] -- ordered by outgoing port number ?
- }
-type SimpleGraph = IntMap SimpleNode -- keys are identical to IntMap (Node n)
-
-------------------------------------------------------------------------
-
--- | Do the FPTC propagation and transformation until a stable point is reached.
-stabilise :: IntMap (Node FaultTransform) -> IntMap (Edge ())
- -> IntMap (Edge (Set Fault))
-stabilise ns es =
- let (init, graph) = initialise True es ns
- outcome = fixpoint (calculateOutwardFaults True graph)
- eqFaultSets init
- in IntMap.mapWithKey -- drop PointTraces silently here
- (\k e-> e { edgeInfo = maybe errorSet (Set.map fst)
- (IntMap.lookup k outcome) } )
- es
- where
- errorSet = Set.singleton (Fault "***mistake_in_algorithm***")
-
--- | Calculate a function's fixpoint by repeated application until two
--- successive values are equal.
-fixpoint :: (a->a) -> (a->a->Bool) -> a -> a
-fixpoint f eq x | fx `eq` x = x
- | otherwise = fixpoint f eq fx
- where fx = f x
-
--- | Compare two network's FaultSets, component by component, to determine
--- equality (and hence the termination of the fixpoint algorithm).
--- Assumes that the finitemaps have identical key sets (and orderings).
---eqFaultSets :: Eq a => Outcome a -> Outcome a -> Bool
---eqFaultSets fm1 fm2 = foldr1 (&&) (zipWith (==) (eltsFM fm1) (eltsFM fm2))
--- ^^^^^ Note that we really do mean (==) here, not `eqF`, because we need
--- to compare the auxiliary info as well as the faults themselves.
-eqFaultSets :: Outcome -> Outcome -> Bool
-eqFaultSets = (==)
-
--- | Grab a first-approximation to the faultset for each connection,
--- and a simplified version of the graph.
-initialise :: Bool -> IntMap (Edge ()) -> IntMap (Node FaultTransform)
- -> (Outcome, SimpleGraph)
-initialise closed edges nodes =
- ( IntMap.map (const (if closed then Set.singleton (Normal,noInfo)
- else Set.empty))
- edges
- , IntMap.mapWithKey simple nodes
- )
- where
- simple key node =
- SimpleNode
- { transforms = tsort (clauses (getInfo node))
- , inbound = IntMap.keys $ IntMap.filter ((==key) . edgeTo) edges
- , outbound = IntMap.keys $ IntMap.filter ((==key) . edgeFrom) edges
- }
- -- Topological sort of transforms, by partial ordering on pattern
- -- generality, most specific pattern first.
- tsort [] = [] -- no implicit default clause
- tsort cs = foldr tinsert [] cs
- where tinsert x [] = [x]
- tinsert x (y:ys) = case poTuple (lhs x) (lhs y) of
- LessThan -> y: tinsert x ys
- _ -> x: y: ys
-
-------------------------------------------------------------------------
-
--- | Calculate an individual component's outbound faults from its inbound
--- faults, using the transform for that component.
-calculateOutwardFaults :: Bool -> SimpleGraph -> Outcome -> Outcome
-calculateOutwardFaults closed graph before =
- IntMap.fold (\n outcome->
- foldr (\ (edgeNr,fs) z->
- IntMap.insertWith joinOutcomes edgeNr fs z)
- outcome
- (zip (outbound n) (apply (transforms n) (infaults n))))
- before
- graph
- where
- infaults c = case inbound c of
- [] -> if closed then [Set.singleton Normal] else []
- cs -> map (Set.map fst . fromJust
- . flip (IntMap.lookup) before) cs
-
--- | Apply the fault transform expression to the actual inbound faultsets,
--- to generate the outbound faultsets. The inbound faults are permuted,
--- to give all possible combinations. On each combination, the first rule
--- to match is triggered. (Rules are ordered by most-specific to
--- most-general.) If no rule matches, the expression is in error.
-
-apply :: [FaultClause] -> [Set Fault] -> [Set (Fault,PointTrace)]
-apply rules =
- map amalgamate
- . transpose
- . map ((rules `app`) . map A)
- . permute
- . map Set.elems
- where
- -- infaults: is a sequence 1..n of faultsets, one set per input port.
- -- permuted infaults: is an unordered list of sequences 1..n, each element
- -- of the sequence being a single fault, one per input port.
- -- Every permuted input *must* find a matching rule, since there are no
- -- automatic defaults. Not every rule needs to fire, if no input matches.
-
- app :: [FaultClause] -> [FaultSpec] -> [Set (Fault,PointTrace)]
- [] `app` f = error ("no matching rule for fault permutation "
- ++ show f ++" in rules\n "++ show rules)
- (rule:rules) `app` f | rule `matches` f = rule `bind` (map deA f)
- | otherwise = rules `app` f
-
- -- does a clause match the pattern?
- matches :: FaultClause -> [FaultSpec] -> Bool
- rule `matches` input = foldr (&&) True (zipWith match (lhs rule) input)
-
- -- given that a clause matches, return the RHS with variables bound
- -- by substitution, and a point trace attached to everything.
- bind :: FaultClause -> [Fault] -> [Set (Fault,PointTrace)]
- rule `bind` input = map ( attach (mkTrace rule input)
- . chain (zipWith mkEnv (lhs rule) input))
- (rhs rule)
- where
- -- 'mkEnv' creates a point environment mapping vars to faults
- -- first arg is LHS particle, second is actual propagated fault,
- -- third is RHS potential use of variable,
- -- result is resolved RHS use.
- mkEnv :: FaultSpec -> Fault -> FaultSpec -> FaultSpec
- mkEnv (A (Var v)) f (A (Var w)) | w==v [_$_]
- = A f
- mkEnv v f (Or s) = Or (Set.map (deA . mkEnv v f . A) s)
- mkEnv _ _ f = f
-
- -- 'chain' together a bunch of functions
- chain :: [a->a] -> a -> a
- chain fs = foldr (.) id fs
-
- attach :: PointTrace -> FaultSpec -> Set (Fault,PointTrace)
- attach t (A Normal) = Set.singleton (Normal, noInfo)
- attach t (A f) = Set.singleton (f,t)
- attach t (Or s) = Set.map (\f-> case f of
- Normal -> (Normal,noInfo)
- _ -> (f,t))
- s
- attach t f = error ("Could not resolve RHS term "++show f
- ++" when applying: \n "++show rule
- ++"\n to input: "++show input)
-
-------------------------------------------------------------------------
--- join singleton faults and sets produced as output of 'bind',
--- and amalgamate all PointTraces for any particular fault
-amalgamate :: [Set (Fault,PointTrace)] -> Set (Fault,PointTrace)
-amalgamate ss =
- let x :: FiniteMap Fault PointTrace
- x = foldr (\s acc-> Set.fold (\ (f,t) fm->
- addToFM_C PointTrace.plus fm f t)
- acc s)
- emptyFM ss
- in Set.fromList (fmToList x)
-
--- pairwise join of faultsets
-joinOutcomes :: Set (Fault,PointTrace) -> Set (Fault,PointTrace)
- -> Set (Fault,PointTrace)
-joinOutcomes s1 s2 = amalgamate [s1,s2]
-
-{-
-amalgamate :: [Set Fault] -> Set Fault
-amalgamate = foldr Set.union Set.empty
-
-joinOutcomes :: Set Fault -> Set Fault -> SetFault
-joinOutcomes = Set.union
--}
-------------------------------------------------------------------------
rmfile ./src/FPTC/Analysis.hs
hunk ./src/FPTC/Expressions.hs 1
-module FPTC.Expressions where
-
-import Text.ParserCombinators.TextParser
-import InfoKind
-import FPTC.ListStuff (commasep,readSequence,mapFst,permute,indent,intersperse)
-import Char (isSpace)
-import FPTC.FaultSpec
-import Text.XML.HaXml.XmlContent
-import Set (Set)
-import qualified Set as Set
-
--- data types
-data FaultModel = FaultModel [String] deriving (Eq)
-data FaultTransform = FaultTransform
- { clauses :: [FaultClause] } deriving (Eq)
-data FaultClause = Pattern :->: Pattern deriving (Eq,Ord)
-type Pattern = [FaultSpec]
-
--- projections
-lhs :: FaultClause -> Pattern
-rhs :: FaultClause -> Pattern
-lhs (i :->: _) = i
-rhs (_ :->: o) = o
-
--- instances
-instance Show FaultModel where
- show (FaultModel fs) = "FaultModel ["++concat (intersperse "," fs) ++"]"
-instance Show FaultTransform where
- show (FaultTransform cls) = unlines (map show cls)
-instance Show FaultClause where
- show (l :->: r) = (commasep . map show) l ++ " -> "
- ++ (commasep . map show) r
-
-{-
-instance Read FaultTransform where
- readsPrec _ r = (\ (cs,t)-> [(FaultTransform cs, t)]) $
- foldr (\x (xs,t)-> case reads x of
- [(v,"")] -> (v:xs, t)
- [(v,u)] -> (v:xs, u++t)
- _ | all isSpace x -> (xs, t)
- | otherwise -> (xs, x++t) )
- ([],"")
- (lines r)
-instance Read FaultClause where
- readsPrec _ r = [ (p:->:q, u) | (p, s) <- readSequence "(" "," ")" r
- , ("->",t) <- lex s
- , (q, u) <- readSequence "(" "," ")" t ]
--}
-
-instance Parse FaultModel where
- parse = fmap FaultModel $ do
- { isWord "FaultModel"
- ; bracketSep (isWord "[") (isWord ",") (isWord "]") word
- }
-instance Parse FaultTransform where
- parse = fmap FaultTransform $ many1 parse
-{-
- parse s = mapFst (either Left (Right . FaultTransform)) $
- foldl (\z x-> case z of
- (Left e, t) -> (Left e, t++x)
- (Right vs, _) ->
- case parse x of
- (Left e, t) -> (Left e, t++x)
- (Right v,t) -> (Right (vs++[v]), t) )
- (Right [], "")
- (lines s)
--}
-{-
- parse = fmap FaultTransform $
- P (\s-> foldl (\z x-> case z of
- (Left e, t) -> (Left e, t++x)
- (Right vs, _) ->
- case runParser parse x of
- (Left e, t) -> (Left e, t++x)
- (Right v,t) -> (Right (vs++[v]), t) )
- (Right [], "")
- (lines s) )
--}
-instance Parse FaultClause where
- parse = do { lhs <- bracketSep (isWord "(") (isWord ",") (isWord ")") parse
- `onFail`
- fmap (:[]) parse
- `adjustErr` ("On lhs of FPTC clause\n"++)
- ; isWord "->" `onFail` fail "missing ->"
- ; rhs <- bracketSep (isWord "(") (isWord ",") (isWord ")") parse
- `onFail`
- fmap (:[]) parse
- `adjustErr` ("On rhs of FPTC clause\n"++)
- ; return (lhs :->: rhs)
- }
-
-instance InfoKind FaultTransform FaultModel where
- blank = FaultTransform [[A (Var 'x')] :->: [A (Var 'x')]]
- check nm faultnames fptc =
- allFaultsValid nm faultnames fptc
- ++ allClausesSameArity nm faultnames fptc
- ++ fptcExhaustive nm faultnames fptc
- -- ++ fptcNoOverlaps
- -- ++ fptcNoDuplicateLhsVariables
- -- ++ fptcAllLhsVariablesUsed
- -- ++ fptcAllLhsSetsKosher
- -- ++ fptcAllRhsVariablesBound
-instance InfoKind (Set Fault) FaultModel where
- blank = Set.empty
- check nm (FaultModel fs) set =
- let rogues = filter (`notElem` (map Fault fs)) (Set.toList set)
- in if not (null rogues) then ["These faults found on edge "++nm
- ++" are invalid:\n\t"++show rogues]
- else []
-
-
-instance HTypeable FaultTransform where
- toHType _ = Defined "FaultTransforms" [] []
-instance XmlContent FaultTransform where
- toContents ft = concatMap toContents (clauses ft)
- parseContents = fmap FaultTransform $ many1 parseContents
-
-instance HTypeable FaultClause where
- toHType _ = Defined "FaultClause" [] []
-instance XmlContent FaultClause where
- toContents (p:->:q) =
- [ CElem (Elem "Pattern" [] (concatMap toContents p)) ()
- , CElem (Elem "Result" [] (concatMap toContents q)) () ]
- parseContents = do
- { ps <- inElement "Pattern" $ many1 parseContents
- ; qs <- inElement "Result" $ many1 parseContents
- ; return (ps:->:qs)
- }
-
-instance HTypeable FaultModel where
- toHType _ = Defined "FaultModel" [] []
-instance XmlContent FaultModel where
- toContents (FaultModel fs) =
- [ CElem (Elem "FaultModel" [] (concatMap toContents fs)) () ]
- parseContents = do
- { fs <- inElement "FaultModel" $ many1 parseContents
- ; return (FaultModel fs)
- }
-
-fptcExhaustive :: String -> FaultModel -> FaultTransform -> [String]
-fptcExhaustive nm (FaultModel faultnames) fptc =
- check nm (maximum (map (length.lhs) rules)) rules
- where
- rules = clauses fptc
- check nm 0 rules = []
- check nm n rules =
- case foldr remove (combinations n) (map lhs rules) of
- [] -> []
- xs -> ["non-exhaustive patterns in FPTC for component \""++show nm
- ++"\"\n expression is "++indent 8 (show rules)
- ++" fault combinations not covered:\n"
- ++indent 8 (unlines (map show xs)) ]
- combinations n = permute (replicate n allFaults)
- allFaults = A Normal: map (A . Fault) faultnames
- remove pat combs = filter (not . foldr1 (&&) . zipWith match pat) combs
-
-allFaultsValid :: String -> FaultModel -> FaultTransform -> [String]
-allFaultsValid nm (FaultModel faultnames) fptc =
- check nm (clauses fptc)
- where
- check n cls = let fs = actuals (concat (map lhs cls ++ map rhs cls))
- in case filter (`notElem` faultnames) fs of
- [] -> []
- es -> ["FPTC for node \""++n ++"\" mentions unknown\
- \ fault(s):\n "++show es]
- actuals fs = [ f | A (Fault f) <- fs ] ++
- [ f | Or s <- fs, Fault f <- Set.elems s ]
-
-allClausesSameArity :: String -> FaultModel -> FaultTransform -> [String]
-allClausesSameArity n _ fptc =
- let rules = clauses fptc
- lhss = map (length.lhs) rules
- rhss = map (length.rhs) rules
- in if any (< maximum lhss) lhss
- then ["FPTC for node \""++n++"\" has differing LHS arities: "++show lhss]
- else []
- ++
- if any (< maximum rhss) rhss
- then ["FPTC for node \""++n++"\" has differing RHS arities: "++show rhss]
- else []
rmfile ./src/FPTC/Expressions.hs
hunk ./src/FPTC/FaultSpec.hs 1
-module FPTC.FaultSpec where
-
-import Text.ParserCombinators.TextParser
-import FPTC.ListStuff (commasep,readSequence,mapFst)
-import Set (Set)
-import qualified Set as Set
-import Text.XML.HaXml.XmlContent as XML
-import Char (isAlpha)
-
--- FaultSpec is one of
--- * = no fault (normal behaviour)
--- _ = wildcard
--- v = variable
--- Fault = named fault type
--- {...} = a set of faults (including *, and sometimes variables)
--- Represented as a two-level type, to capture constraints on what can
--- appear as part of a set.
-data Fault = Normal | Fault { fault::String } | Var { var::Char }
- deriving (Eq,Ord) -- instance Ord Fault only needed for Set ops
-data Spec a = A { deA::a } | Wildcard | Or { set::Set a }
- deriving (Eq,Ord)
-
--- A simple FaultSpec:
-type FaultSpec = Spec Fault
--- Or each fault type could have some extra information associated with it,
--- e.g. probability, severity:
--- type FaultSpec a = Spec (Fault,a)
-
-instance Show Fault where
- show Normal = "*"
- show (Fault s) = s
- show (Var v) = [v]
-instance Show a => Show (Spec a) where
- show Wildcard = "_"
- show (A x) = show x
- show (Or s) = show s
-
-instance Parse Fault where
- parse = do { isWord "*"; return Normal }
- `onFail`
- do { [c] <- word; if isAlpha c then return (Var c) else fail "" }
- `onFail`
- do { f <- word; if not (null f) && isAlpha (head f)
- then return (Fault f)
- else fail ("expected a fault, var, or *: got "++f) }
-instance (Parse a, Ord a) => Parse (Spec a) where
- parse = do { isWord "_"; return Wildcard }
- `onFail`
- do { fmap Or $ parse } -- try "{" before other possibilities
- `onFail`
- do { fmap A $ parse }
- `adjustErr` (++"\nlooking for _, {}, *, or fault")
-
-instance (Parse a, Ord a) => Parse (Set a) where
- parse = fmap Set.fromList $
- bracketSep (isWord "{") (isWord ",") (isWord "}") parse
-
-
-instance HTypeable Fault where
- toHType _ = Defined "Fault" [] [ Constr "Normal" [] []
- , Constr "Fault" [] [Prim "String" "string"]
- , Constr "Var" [] [Prim "Char" "char"] ]
-instance XmlContent Fault where
- toContents Normal = [CElem (Elem "Normal" [] []) ()]
- toContents (Var v) = [CElem (Elem "Var" [] (toContents v)) ()]
- toContents (Fault s) = [CElem (Elem "Fault" [] (toContents s)) ()]
- parseContents = do
- { e@(Elem t _ _) <- element ["Normal","Var","Fault"]
- ; case t of
- "Normal" -> interior e $ return Normal
- "Var" -> interior e $ fmap Var parseContents
- "Fault" -> interior e $ fmap Fault parseContents
- }
-instance (HTypeable a) => HTypeable (Spec a) where
- toHType x = Defined "Spec" [ha] [ Constr "A" [ha] [ha]
- , Constr "Wildcard" [] []
- , Constr "Or" [ha] [hb] ]
- where ha = toHType $ (\ (A a)->a) $ x
- hb = toHType $ (\ (Or a)->a) $ x
-instance (XmlContent a, Ord a) => XmlContent (Spec a) where
- toContents (A x) = [CElem (Elem "A" [] (toContents x)) ()]
- toContents Wildcard = [CElem (Elem "Wildcard" [] []) ()]
- toContents (Or x) = [CElem (Elem "Or" [] (toContents x)) ()]
- parseContents = do
- { e@(Elem t _ _) <- element ["A","Wildcard","Or"]
- ; case t of
- "A" -> interior e $ fmap A parseContents
- "Wildcard" -> interior e $ return Wildcard
- "Or" -> interior e $ fmap Or parseContents
- }
-instance (HTypeable a) => HTypeable (Set a) where
- toHType s = Defined "Set" [toHType x] []
- where x = head (Set.toList s)
-instance (XmlContent a, Ord a) => XmlContent (Set a) where
- toContents s = concatMap toContents (Set.toList s)
- parseContents = fmap Set.fromList (many parseContents)
-
-{-
-instance Ord a => Functor Spec where -- change Spec a -> Spec b
- fmap f Wildcard = Wildcard
- fmap f (A x) = A (f x)
- fmap f (Or s) = Or (Set.map f s)
--}
-
--- should matching be one-way? or symmetric as below?
-match :: FaultSpec -> FaultSpec -> Bool
-(A Normal) `match` (A Normal) = True
-Wildcard `match` _ = True
-_ `match` Wildcard = True
-(A (Var _)) `match` _ = True
-_ `match` (A (Var _)) = True
-(A (Fault f)) `match` (A (Fault f')) = f==f'
---(Or fs) `match` f = any (`match` f) (map A fs)
---f `match` (Or fs) = any (`match` f) (map A fs)
--- because of equation ordering, the next three clauses replace the above two.
-(Or fs) `match` (A f) = f `Set.member` fs
-(A f) `match` (Or fs) = f `Set.member` fs
-f@(Or _) `match` (Or fs) = any (`match` f) (map A (Set.elems fs))
-_ `match` _ = False
-
-freevars :: [FaultSpec] -> [Char]
-freevars fs = [ v | A (Var v) <- fs ]
- ++ [ v | Or s <- fs, Var v <- Set.elems s ]
-
--- Order FPTC particles by more specific to less specific.
-data PartialOrder = LessThan | GreaterThan | Equal | Incomparable
- | Overlapping -- for sets only
- deriving Eq
-po :: FaultSpec -> FaultSpec -> PartialOrder
-(A Normal) `po` (A Normal) = Equal
-(A Normal) `po` (A (Fault _)) = Incomparable
-(A Normal) `po` (A (Var _)) = GreaterThan
-(A Normal) `po` Wildcard = GreaterThan
-(A s@Normal) `po` (Or fs) | s `Set.member` fs = Equal
- | otherwise = Incomparable
-(A (Fault _)) `po` (A Normal) = Incomparable
-(A (Fault f)) `po` (A (Fault g)) | f==g = Equal
- | otherwise = Incomparable
-(A (Fault _)) `po` (A (Var _)) = GreaterThan
-(A (Fault _)) `po` Wildcard = GreaterThan
-(A f@(Fault _)) `po` (Or fs) | f `Set.member` fs = Equal
- | otherwise = Incomparable
-(A (Var _)) `po` (A Normal) = LessThan
-(A (Var _)) `po` (A (Fault _)) = LessThan
-(A (Var _)) `po` (A (Var _)) = Equal
-(A (Var _)) `po` Wildcard = Equal -- GreaterThan
-(A (Var _)) `po` (Or _) = LessThan
-Wildcard `po` (A Normal) = LessThan
-Wildcard `po` (A (Fault _)) = LessThan
-Wildcard `po` (A (Var _)) = Equal -- LessThan
-Wildcard `po` Wildcard = Equal
-Wildcard `po` (Or _) = LessThan
-(Or fs) `po` (A s@Normal) | s `Set.member` fs = Equal
- | otherwise = Incomparable
-(Or fs) `po` (A f@(Fault _)) | f `Set.member` fs = Equal
- | otherwise = Incomparable
-(Or _) `po` (A (Var _)) = GreaterThan
-(Or _) `po` Wildcard = GreaterThan
-
--- more complicated for set/set comparison
-(Or fs) `po` (Or gs) | Set.null (fs `Set.intersection` gs) = Incomparable
- | fs == gs = Equal
- | otherwise = Overlapping
-
--- partial ordering of pattern-tuples, assuming there is no overlapping.
--- Used to decide which of two equations (LHS) is more specific.
-poTuple :: [FaultSpec] -> [FaultSpec] -> PartialOrder
-poTuple fs gs = let diffs = zipWith po fs gs in
- if any (==Incomparable) diffs then Incomparable
- -- else if all (==Equal) diffs then Equal
- else safehead (filter (/=Equal) diffs)
- where
- safehead [] = error ("Cannot choose an ordering for these two LHSs:"
- ++"\n "++ commasep (map show fs)
- ++"\n "++ commasep (map show gs))
- safehead (x:_) = x
rmfile ./src/FPTC/FaultSpec.hs
hunk ./src/FPTC/ListStuff.hs 1
-module FPTC.ListStuff
- ( module List
- , module FPTC.ListStuff
- ) where
-
-import List
-
-permute :: [[a]] -> [[a]]
-permute [] = [[]]
-permute (xs:xss) = [ f:fs | f <- xs, fs <- permute xss ]
-
----- pretty-printing
-indent n = unlines . map (replicate n ' ' ++) . lines
-commasep,curlysep :: [String] -> String
-commasep [x] = x
-commasep xs = "("++ concat (intersperse ", " xs) ++ ")"
-curlysep [x] = x
-curlysep xs = "{"++ concat (intersperse ", " xs) ++ "}"
-dotted xs = concat (intersperse "." xs)
-
--- parsing
--- e.g. readSequence "(" "," ")"
--- e.g. readSequence "{" "," "}"
--- e.g. readSequence "<" "|" ">"
--- e.g. readSequence "begin" ";" "end"
--- if only one item, brackets/separators are not required to be present.
-readSequence :: Read a => String -> String -> String -> ReadS [a]
-readSequence bra comma ket r = [ pr | (c,s) <- lex r
- , c==bra
- , pr <- readl s ] ++
- [ ([p],s) | (p,s) <- reads r ]
- where readl s = [([],t) | (c,t) <- lex s, c==ket ] ++
- [(x:xs,u) | (x,t) <- readsPrec 0 s
- , (xs,u) <- readl' t]
- readl' s = [([],t) | (c,t) <- lex s, c==ket] ++
- [(x:xs,v) | (c,t) <- lex s
- , c==comma
- , (x,u) <- readsPrec 0 t
- , (xs,v) <- readl' u]
-
--- useful for parsing
-mapFst :: (a->b) -> (a,c) -> (b,c)
-mapFst f (x,y) = (f x, y)
rmfile ./src/FPTC/ListStuff.hs
hunk ./src/FPTC/PointTrace.hs 1
-{- A pointwise-trace type, and its operations.
--}
-module FPTC.PointTrace where
-
-import FPTC.Expressions
-import FPTC.FaultSpec
-import Set (Set)
-import qualified Set as Set
-
--- | A PointTrace is a collection of clause/pattern pairs whose invocation
--- caused a fault token to be attached to an arc. Note the caused fault
--- is not stored here - the association is represented elsewhere.
-data PointTrace = Trace (Set (FaultClause,[Fault]))
- deriving (Eq,Ord)
-instance Show PointTrace where
- show (Trace cps) = let (clauses,patterns) = unzip (Set.elems cps)
- in '\n':unlines (zipWith table clauses patterns)
- where table cl pat = "\t"++show pat++"\tmatched by "++show cl
-
-
--- Some info-theoretic operations on traces:
-
--- | 'noInfo': the algebraic zero of the information type
-noInfo :: PointTrace
-noInfo = Trace Set.empty
-
--- | combine information generated by different rules firing based on
--- different inputs.
-plus :: PointTrace -> PointTrace -> PointTrace
-plus (Trace t1) (Trace t2) = Trace (t1 `Set.union` t2)
-
--- | create a pointtrace
-mkTrace :: FaultClause -> [Fault] -> PointTrace
-mkTrace rule pat = Trace (Set.singleton (rule,pat))
-
-
-{-
--- Lift trace operations into useful functions over FaultSpecs:
-
-empty :: [(FaultSpec,PointTrace)]
-empty = []
---empty = Set [Star noInfo] -- normal behaviour is always possible!
-
-combine :: Info a => [FaultSpec a] -> FaultSpec a
-combine fs = Set (foldr join [] fs)
- where join item [] = [item]
- join f (f':faults)
- | f `eqF` f' = f { info = info f `plus` info f' } : faults
- | otherwise = f' : join f faults
--}
rmfile ./src/FPTC/PointTrace.hs
rmdir ./src/FPTC
hunk ./Makefile 25
- src/FPTC/Expressions.hs src/FPTC/FaultSpec.hs \
- src/FPTC/ListStuff.hs src/FPTC/PointTrace.hs \
- src/FPTC/Analysis.hs \
hunk ./Makefile 90
-src/Main.o : lib/DData/Set.hi
-src/Main.o : src/FPTC/Analysis.hi
-src/Main.o : src/FPTC/FaultSpec.hi
-src/Main.o : src/FPTC/Expressions.hi
+src/Main.o : lib/DData/IntMap.hi
+src/Main.o : src/Analysis.hi
+src/Main.o : src/Network.hi
+src/Main.o : src/Node.hi
hunk ./Makefile 227
-src/FPTC/Expressions.o : src/FPTC/Expressions.hs
-src/FPTC/Expressions.o : lib/DData/Set.hi
-src/FPTC/Expressions.o : src/FPTC/FaultSpec.hi
-src/FPTC/Expressions.o : src/FPTC/ListStuff.hi
-src/FPTC/Expressions.o : src/InfoKind.hi
-src/FPTC/FaultSpec.o : src/FPTC/FaultSpec.hs
-src/FPTC/FaultSpec.o : lib/DData/Set.hi
-src/FPTC/FaultSpec.o : src/FPTC/ListStuff.hi
-src/FPTC/ListStuff.o : src/FPTC/ListStuff.hs
-src/FPTC/PointTrace.o : src/FPTC/PointTrace.hs
-src/FPTC/PointTrace.o : lib/DData/Set.hi
-src/FPTC/PointTrace.o : src/FPTC/FaultSpec.hi
-src/FPTC/PointTrace.o : src/FPTC/Expressions.hi
-src/FPTC/Analysis.o : src/FPTC/Analysis.hs
-src/FPTC/Analysis.o : src/Node.hi
-src/FPTC/Analysis.o : src/Network.hi
-src/FPTC/Analysis.o : lib/DData/IntMap.hi
-src/FPTC/Analysis.o : lib/DData/Set.hi
-src/FPTC/Analysis.o : src/Analysis.hi
-src/FPTC/Analysis.o : src/InfoKind.hi
-src/FPTC/Analysis.o : src/FPTC/ListStuff.hi
-src/FPTC/Analysis.o : src/FPTC/PointTrace.hi
-src/FPTC/Analysis.o : src/FPTC/FaultSpec.hi
-src/FPTC/Analysis.o : src/FPTC/Expressions.hi
hunk ./RTN.blobpalette 1
- Palette
- [ ("activity"
- , Circle { shapeStyle = ShapeStyle { styleStrokeWidth = 1
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 200 128
- }
- , shapeRadius = 0.5 }
- , Just (v -> v) )
- , ("source"
- , Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 2
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 200 128 200
- }
- , shapePerimeter = [ DoublePoint (-0.5) (-0.5)
- , DoublePoint 0.5 (-0.5)
- , DoublePoint 0.5 0.5
- , DoublePoint (-0.5) 0.5 ] }
- , Just (_ -> *) )
- , ("sink"
- , Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 2
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 200 128 200
- }
- , shapePerimeter = [ DoublePoint (-0.5) (-0.5)
- , DoublePoint 0.5 (-0.5)
- , DoublePoint 0.5 0.5
- , DoublePoint (-0.5) 0.5 ] }
- , Just (_ -> *) )
- , ("splitter"
- , Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 200 200
- }
- , shapePerimeter = [ DoublePoint (-0.5) 0
- , DoublePoint 0.5 (-0.5)
- , DoublePoint 0.5 0.5 ] }
- , Just (v -> (v,v)) )
- , ("consolidator"
- , Polygon { shapeStyle = ShapeStyle { styleStrokeWidth = 1
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 200 200
- }
- , shapePerimeter = [ DoublePoint (-0.5) (-0.5)
- , DoublePoint (-0.5) 0.5
- , DoublePoint 0.5 0.0 ] }
- , Just ((v,v) -> v) )
- , ("wire"
- , Composite { shapeSegments =
- [ Lines { shapeStyle = ShapeStyle
- { styleStrokeWidth = 2
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 128 128
- }
- , shapePerimeter = [ DoublePoint 0.0 (-0.5)
- , DoublePoint (-0.2) 0.5 ] }
- , Lines { shapeStyle = ShapeStyle
- { styleStrokeWidth = 2
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 128 128
- }
- , shapePerimeter = [ DoublePoint 0.2 (-0.5)
- , DoublePoint 0.0 0.5 ] }
- ] }
- , Just (v -> v) )
- , ("pool"
- , Lines { shapeStyle = ShapeStyle { styleStrokeWidth = 2
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 128 128
- }
- , shapePerimeter = [ DoublePoint (-0.2) (-0.5)
- , DoublePoint 0.0 (-0.5)
- , DoublePoint 0.0 0.5
- , DoublePoint (-0.2) 0.5 ] }
- , Just ( late -> value
- early -> *
- omission -> value
- commission -> *
- v -> v ) )
- , ("signal"
- , Lines { shapeStyle = ShapeStyle { styleStrokeWidth = 2
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 128 128
- }
- , shapePerimeter = [ DoublePoint (-0.2) (-0.5)
- , DoublePoint 0.0 (-0.5)
- , DoublePoint 0.0 0.5
- , DoublePoint 0.2 0.5 ] }
- , Just ( omission -> late
- commission -> *
- early -> *
- v -> v ) )
- , ("channel"
- , Composite { shapeSegments =
- [ Lines { shapeStyle = ShapeStyle
- { styleStrokeWidth = 2
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 128 128
- }
- , shapePerimeter = [ DoublePoint (-0.2) (-0.5)
- , DoublePoint 0.2 (-0.5) ] }
- , Lines { shapeStyle = ShapeStyle
- { styleStrokeWidth = 2
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 128 128
- }
- , shapePerimeter = [ DoublePoint 0.0 (-0.5)
- , DoublePoint 0.0 0.5 ] }
- , Lines { shapeStyle = ShapeStyle
- { styleStrokeWidth = 2
- , styleStrokeColour = RGB 0 0 0
- , styleFill = RGB 128 128 128
- }
- , shapePerimeter = [ DoublePoint (-0.2) 0.5
- , DoublePoint 0.2 0.5 ] }
- ] }
- , Just ( early -> *
- omission -> late
- commission -> late
- * -> late
- v -> v ) )
- ]
rmfile ./RTN.blobpalette
hunk ./src/Main.hs 8
-import FPTC.Expressions (FaultModel(..),FaultTransform)
-import FPTC.FaultSpec (Fault)
-import FPTC.Analysis
-import Set (Set,empty)
+import Node
+import Network
+import Analysis
+import IntMap (IntMap)
+import qualified IntMap
+import List (nub)
+import Maybe (fromJust)
hunk ./src/Main.hs 19
- ; NetworkUI.create state (FaultModel [])
- (undefined::FaultTransform)
- (Set.empty::Set Fault)
+ ; NetworkUI.create state ()
+ (undefined::Int)
+ ([]::[Int])
hunk ./src/Main.hs 24
+
+instance InfoKind Int () where
+ blank = 0
+ check n _ i | i<0 = ["Number should not be negative in "++n]
+ | otherwise = []
+instance InfoKind [Int] () where
+ blank = []
+ check _ _ _ = []
+instance Analysis () Int [Int] where
+ analyse (g, nodemap, edgemap) =
+ (g, nodemap, IntMap.map (\e-> push nodemap e) edgemap)
+ revert (g, nodemap, edgemap) =
+ (g, nodemap, IntMap.map (\e-> e{edgeInfo=[]}) edgemap)
+
+push :: IntMap (Node Int) -> Edge [Int] -> Edge [Int]
+push nodemap edge = edge { edgeInfo = nub (n:edgeInfo edge) }
+ where n = (Node.getInfo . fromJust . flip IntMap.lookup nodemap . edgeFrom)
+ edge
hunk ./wiring.blobs 1
-<Network
- ><Width
- >15.0</Width
- ><Height
- >9.0</Height
- ><Info
- ><FaultModel
- ><string
- >Loss</string></FaultModel></Info
- ><Nodes
- ><Node id="N1"
- ><X
- >1.4111111111111114</X
- ><Y
- >5.150555555555556</Y
- ><Name
- >sensor</Name
- ><LabelAbove
- >True</LabelAbove
- ><Shape
- ><Polygon
- ><ShapeStyle
- ><int value="2"
- /><RGB
- ><int value="0"
- /><int value="0"
- /><int value="0"/></RGB
- ><RGB
- ><int value="200"
- /><int value="128"
- /><int value="200"/></RGB></ShapeStyle
- ><list-DoublePoint
- ><X
- >-0.5</X
- ><Y
- >-0.5</Y
- ><X
- >0.5</X
- ><Y
- >-0.5</Y
- ><X
- >0.5</X
- ><Y
- >0.5</Y
- ><X
- >-0.5</X
- ><Y
- >0.5</Y></list-DoublePoint></Polygon></Shape
- ><Info
- ><Pattern
- ><Wildcard/></Pattern
- ><Result
- ><A
- ><Fault
- ><string
- >Loss</string></Fault></A></Result></Info></Node
- ><Node id="N2"
- ><X
- >4.762500000000001</X
- ><Y
- >5.115277777777779</Y
- ><Name
- >splitter</Name
- ><LabelAbove
- >True</LabelAbove
- ><Shape
- ><Polygon
- ><ShapeStyle
- ><int value="1"
- /><RGB
- ><int value="0"
- /><int value="0"
- /><int value="0"/></RGB
- ><RGB
- ><int value="128"
- /><int value="200"
- /><int value="200"/></RGB></ShapeStyle
- ><list-DoublePoint
- ><X
- >-0.5</X
- ><Y
- >0.0</Y
- ><X
- >0.5</X
- ><Y
- >-0.5</Y
- ><X
- >0.5</X
- ><Y
- >0.5</Y></list-DoublePoint></Polygon></Shape
- ><Info
- ><Pattern
- ><A
- ><Var
- ><char value="x"/></Var></A></Pattern
- ><Result
- ><A
- ><Var
- ><char value="x"/></Var></A
- ><A
- ><Var
- ><char value="x"/></Var></A></Result></Info></Node
- ><Node id="N3"
- ><X
- >14.14638888888889</X
- ><Y
- >5.080000000000001</Y
- ><Name
- >consolidator</Name
- ><LabelAbove
- >True</LabelAbove
- ><Shape
- ><Polygon
- ><ShapeStyle
- ><int value="1"
- /><RGB
- ><int value="0"
- /><int value="0"
- /><int value="0"/></RGB
- ><RGB
- ><int value="128"
- /><int value="200"
- /><int value="200"/></RGB></ShapeStyle
- ><list-DoublePoint
- ><X
- >-0.5</X
- ><Y
- >-0.5</Y
- ><X
- >-0.5</X
- ><Y
- >0.5</Y
- ><X
- >0.5</X
- ><Y
- >0.0</Y></list-DoublePoint></Polygon></Shape
- ><Info
- ><Pattern
- ><A
- ><Fault
- ><string
- >Loss</string></Fault></A
- ><A
- ><Normal/></A></Pattern
- ><Result
- ><A
- ><Normal/></A></Result
- ><Pattern
- ><A
- ><Normal/></A
- ><A
- ><Fault
- ><string
- >Loss</string></Fault></A></Pattern
- ><Result
- ><A
- ><Normal/></A></Result
- ><Pattern
- ><A
- ><Fault
- ><string
- >Loss</string></Fault></A
- ><A
- ><Fault
- ><string
- >Loss</string></Fault></A></Pattern
- ><Result
- ><A
- ><Fault
- ><string
- >Loss</string></Fault></A></Result
- ><Pattern
- ><A
- ><Normal/></A
- ><A
- ><Normal/></A></Pattern
- ><Result
- ><A
- ><Normal/></A></Result></Info></Node
- ><Node id="N4"
- ><X
- >17.638888888888886</X
- ><Y
- >5.08</Y
- ><Name
- >CPU</Name
- ><LabelAbove
- >True</LabelAbove
- ><Shape
- ><Circle
- ><ShapeStyle
- ><int value="1"
- /><RGB
- ><int value="0"
- /><int value="0"
- /><int value="0"/></RGB
- ><RGB
- ><int value="128"
- /><int value="200"
- /><int value="128"/></RGB></ShapeStyle
- ><double value="0.5"/></Circle></Shape
- ><Info
- ><Pattern
- ><A
- ><Var
- ><char value="x"/></Var></A></Pattern
- ><Result
- ><A
- ><Var
- ><char value="x"/></Var></A></Result></Info></Node
- ><Node id="N5"
- ><X
- >9.630833333333335</X
- ><Y
- >3.5277777777777777</Y
- ><Name
- ><![CDATA[wiring L]]></Name
- ><LabelAbove
- >True</LabelAbove
- ><Shape
- ><Composite
- ><list-Shape
- ><Lines
- ><ShapeStyle
- ><int value="2"
- /><RGB
- ><int value="0"
- /><int value="0"
- /><int value="0"/></RGB
- ><RGB
- ><int value="128"
- /><int value="128"
- /><int value="128"/></RGB></ShapeStyle
- ><list-DoublePoint
- ><X
- >0.0</X
- ><Y
- >-0.5</Y
- ><X
- >-0.2</X
- ><Y
- >0.5</Y></list-DoublePoint></Lines
- ><Lines
- ><ShapeStyle
- ><int value="2"
- /><RGB
- ><int value="0"
- /><int value="0"
- /><int value="0"/></RGB
- ><RGB
- ><int value="128"
- /><int value="128"
- /><int value="128"/></RGB></ShapeStyle
- ><list-DoublePoint
- ><X
- >0.2</X
- ><Y
- >-0.5</Y
- ><X
- >0.0</X
- ><Y
- >0.5</Y></list-DoublePoint></Lines></list-Shape></Composite></Shape
- ><Info
- ><Pattern
- ><A
- ><Var
- ><char value="x"/></Var></A></Pattern
- ><Result
- ><A
- ><Var
- ><char value="x"/></Var></A></Result
- ><Pattern
- ><A
- ><Normal/></A></Pattern
- ><Result
- ><A
- ><Fault
- ><string
- >Loss</string></Fault></A></Result></Info></Node
- ><Node id="N6"
- ><X
- >9.595555555555555</X
- ><Y
- >6.526388888888889</Y
- ><Name
- ><![CDATA[wiring R]]></Name
- ><LabelAbove
- >True</LabelAbove
- ><Shape
- ><Composite
- ><list-Shape
- ><Lines
- ><ShapeStyle
- ><int value="2"
- /><RGB
- ><int value="0"
- /><int value="0"
- /><int value="0"/></RGB
- ><RGB
- ><int value="128"
- /><int value="128"
- /><int value="128"/></RGB></ShapeStyle
- ><list-DoublePoint
- ><X
- >0.0</X
- ><Y
- >-0.5</Y
- ><X
- >-0.2</X
- ><Y
- >0.5</Y></list-DoublePoint></Lines
- ><Lines
- ><ShapeStyle
- ><int value="2"
- /><RGB
- ><int value="0"
- /><int value="0"
- /><int value="0"/></RGB
- ><RGB
- ><int value="128"
- /><int value="128"
- /><int value="128"/></RGB></ShapeStyle
- ><list-DoublePoint
- ><X
- >0.2</X
- ><Y
- >-0.5</Y
- ><X
- >0.0</X
- ><Y
- >0.5</Y></list-DoublePoint></Lines></list-Shape></Composite></Shape
- ><Info
- ><Pattern
- ><A
- ><Var
- ><char value="x"/></Var></A></Pattern
- ><Result
- ><A
- ><Var
- ><char value="x"/></Var></A></Result
- ><Pattern
- ><A
- ><Normal/></A></Pattern
- ><Result
- ><A
- ><Fault
- ><string
- >Loss</string></Fault></A></Result></Info></Node></Nodes
- ><Edges
- ><Edge id="E1"
- ><From
- >1</From
- ><To
- >2</To
- ><Via
- /><Info
- ><Normal
- /><Fault
- ><string
- >Loss</string></Fault></Info></Edge
- ><Edge id="E3"
- ><From
- >3</From
- ><To
- >4</To
- ><Via
- /><Info
- ><Normal
- /><Fault
- ><string
- >Loss</string></Fault></Info></Edge
- ><Edge id="E4"
- ><From
- >2</From
- ><To
- >5</To
- ><Via
- ><X
- >7.126111111111111</X
- ><Y
- >3.5277777777777777</Y></Via
- ><Info
- ><Normal
- /><Fault
- ><string
- >Loss</string></Fault></Info></Edge
- ><Edge id="E5"
- ><From
- >5</From
- ><To
- >3</To
- ><Via
- ><X
- >12.065000000000001</X
- ><Y
- >3.5277777777777777</Y></Via
- ><Info
- ><Normal
- /><Fault
- ><string
- >Loss</string></Fault></Info></Edge
- ><Edge id="E6"
- ><From
- >2</From
- ><To
- >6</To
- ><Via
- ><X
- >7.12611111111111</X
- ><Y
- >6.5263888888888895</Y></Via
- ><Info
- ><Normal
- /><Fault
- ><string
- >Loss</string></Fault></Info></Edge
- ><Edge id="E7"
- ><From
- >6</From
- ><To
- >3</To
- ><Via
- ><X
- >11.959166666666667</X
- ><Y
- >6.526388888888889</Y></Via
- ><Info
- ><Normal
- /><Fault
- ><string
- >Loss</string></Fault></Info></Edge></Edges></Network>
+
rmfile ./wiring.blobs
}