Commit e270f8cd authored by Pieter Koopman's avatar Pieter Koopman
Browse files

with esmViz

parent de44cfce
definition module ESMSpec
import StdClass, StdMaybe
import gast //gen
:: Traces s i o :== [[SeenTrans s i o]]
:: ESM s i o = { s_0 :: s // the initial state
, d_F :: Spec s i o // the state transition function (\delta_F)
, out :: s i -> [[o]] // outputs to be used if spec does not give them
, pred:: (SeenTrans s i o)->[[String]] // consitency issues
}
:: KnownAutomaton s i o = {trans :: [SeenTrans s i o]
,issues:: [(SeenTrans s i o,[String])]
}
:: SeenTrans s i o :== (s,i,[o],s)
tupToSpec :: (state input -> [([output],state)]) -> Spec state input output // conversion for old specificaions
class render a :: !a -> String // show a concise text representation for rendering purposes
enumerate :: [a] | ggen{|*|} a
possibleInputs :: (ESM s i o) [s] -> [i] | gEq{|*|} s & ggen{|*|}, gEq{|*|} i
nextStates :: (ESM s i o) i ![s] -> [s] | gEq{|*|} s
addStep :: (ESM s i o) [s] i !(Traces s i o) -> Traces s i o | gEq{|*|} s
narrowTraces :: (Traces s i o) [s] -> Traces s i o | gEq{|*|} s
nodesOf :: !(KnownAutomaton s i o) -> [s] | gEq{|*|} s
edgesFrom :: s !(KnownAutomaton s i o) -> [SeenTrans s i o] | gEq{|*|} s
edgesTo :: s !(KnownAutomaton s i o) -> [SeenTrans s i o] | gEq{|*|} s
startStates :: ![SeenTrans s i o] -> [s] | gEq{|*|} s
targetStates :: ![SeenTrans s i o] -> [s] | gEq{|*|} s
addTransitions :: !Int (ESM s i o) [s] [i] !(KnownAutomaton s i o) -> KnownAutomaton s i o | gEq{|*|}, render s & render, ggen{|*|}, gEq{|*|} i & gEq{|*|} o
nrOf :: !(KnownAutomaton s i o) s -> Int | gEq{|*|}, render s
gisMember :: a ![a] -> Bool | gEq{|*|} a
gremoveDup :: !.[a] -> .[a] | gEq{|*|} a
gelemIndex :: a ![a] -> Maybe Int | gEq{|*|} a
implementation module ESMSpec
import StdBool, StdFunc, StdList, StdListExtensions, StdMaybe, StdMisc, StdString, StdTuple
import GenPrint, GenEq
import gast
tupToSpec :: (state input -> [([output],state)]) -> Spec state input output // conversion for old specificaions
tupToSpec fun = \s i = [Pt o t \\ (o,t) <- fun s i]
enumerate :: [a] | ggen{|*|} a
enumerate = generateAll aStream
possibleInputs :: (ESM s i o) [s] -> [i] | gEq{|*|} s & ggen{|*|}, gEq{|*|} i
possibleInputs esm states = gremoveDup (take 100 [i \\ s<-states, i<-enumerate | not (isEmpty (esm.d_F s i))])
nextStates :: (ESM s i o) i ![s] -> [s] | gEq{|*|} s
nextStates esm i states
= gremoveDup [ t
\\ s <- states
, target <- esm.d_F s i
, t <- case target of
Pt outs u = [u];
Ft f = [u \\ o<-esm.out s i, u<-f o]
]
narrowTraces :: (Traces s i o) [s] -> Traces s i o | gEq{|*|} s
narrowTraces trace states = fst (pruneTraces trace states)
pruneTraces :: (Traces s i o) [s] -> (Traces s i o,[s]) | gEq{|*|} s
pruneTraces [] states = ([],states)
pruneTraces [trans:rest] states
# (rest ,states) = pruneTraces rest states
# trans = [tr\\tr=:(s,i,o,t)<-trans|gisMember t states]
= ([trans:rest],startStates trans)
addStep :: (ESM s i o) [s] i !(Traces s i o) -> Traces s i o | gEq{|*|} s
addStep esm states i trace
= narrowTraces trace states ++
[[ (s,i,o,t)
\\ s <- states
, target <- esm.d_F s i
, (o,t) <- case target of
Pt outs u = [(outs,u)];
Ft f = [ (o,u) \\ o<-esm.out s i, u<-f o]
]]
nodesOf :: !(KnownAutomaton s i o) -> [s] | gEq{|*|} s
//nodesOf automaton = gremoveDup (flatten [[startnode,endnode] \\ (startnode,_,_,endnode) <- automaton.trans])
nodesOf automaton = gremoveDup ([s \\ (s,_,_,t) <- automaton.trans]++[t \\ (s,_,_,t) <- automaton.trans])
edgesFrom :: s !(KnownAutomaton s i o) -> [SeenTrans s i o] | gEq{|*|} s
edgesFrom startnode automaton = [edge \\ edge=:(s,i,o,t) <- automaton.trans | s===startnode]
edgesTo :: s !(KnownAutomaton s i o) -> [SeenTrans s i o] | gEq{|*|} s
edgesTo endnode automaton = [edge \\ edge=:(s,i,o,t) <- automaton.trans | t===endnode]
startStates :: ![SeenTrans s i o] -> [s] | gEq{|*|} s
startStates transitions = gremoveDup [ s \\ (s,i,o,t) <- transitions ]
targetStates :: ![SeenTrans s i o] -> [s] | gEq{|*|} s
targetStates transitions = gremoveDup [ t \\ (s,i,o,t) <- transitions ]
addTransitions :: !Int (ESM s i o) [s] [i] !(KnownAutomaton s i o) -> KnownAutomaton s i o | gEq{|*|}, render s & render, ggen{|*|}, gEq{|*|} i & gEq{|*|} o
addTransitions n esm startstates is automaton
| n>0 && not (isEmpty startstates)
# newSeenTrans
= [ (s,i,o,t)
\\ s <- startstates
, i <- map snd (sortBy (\(a,_) (b,_).a<b) (map (\i.(render i,i)) is)) // is // sort inputs
, target <- esm.d_F s i
, (o,t) <- case target of
Pt outs u = [(outs,u)];
Ft f = [ (o,u) \\ o<-esm.out s i, u<-f o]
]
# newStates = targetStates newSeenTrans
# newTrans = [t \\ t <- newSeenTrans | not (gisMember t automaton.trans)]
# newIssues = [(t,e) \\ t<-newTrans, e <- esm.pred t | not (isEmpty e)]
= addTransitions (n-1) esm newStates (possibleInputs esm newStates) {trans=mix automaton.trans newTrans, issues=newIssues++automaton.issues}
| otherwise = automaton
mix :: [SeenTrans s i o] [SeenTrans s i o] -> [SeenTrans s i o] | render s & render i
mix known new = foldl (insertBy less) known new
insertBy :: (a a->Bool) [a] a -> [a]
insertBy le [] e = [e]
insertBy le l=:[a:x] e
| le e a
= [e:l]
= [a:insertBy le x e]
less :: (SeenTrans s i o) (SeenTrans s i o) -> Bool | render s & render i
less (s1,i1,o1,t1) (s2,i2,o2,t2)
# rs1 = render s1
# rs2 = render s2
# ro1 = render i1
# ro2 = render i2
# rt1 = render t1
# rt2 = render t2
= rs1<rs2 || (rs1==rs2 && (ro1<ro2 || (ro1==ro2 && rt1<=rt2)))
nrOf :: !(KnownAutomaton s i o) s -> Int | gEq{|*|}, render s
nrOf automaton s
= case gelemIndex s (nodesOf automaton) of
Just i = i
nothing = abort ("nrOf applied to unknown state: "+++render s+++"\n")
gisMember :: a ![a] -> Bool | gEq{|*|} a
gisMember x [hd:tl] = hd===x || gisMember x tl
gisMember _ _ = False
gremoveDup :: !.[a] -> .[a] | gEq{|*|} a
gremoveDup [x:xs] = [x:gremoveDup (filter ((=!=) x) xs)]
gremoveDup _ = []
gelemIndex :: a ![a] -> Maybe Int | gEq{|*|} a
gelemIndex x l = scan 0 x l
where
scan i x [a:r]
| x===a = Just i
= scan (i+1) x r
scan i x _ = Nothing
definition module ESMVizTool
import StdiData
import ESMSpec
/*
esmVizTool :: !(ESM s i o) *HSt -> ((Bool,String),Html,*HSt)
| iData, gEq{|*|}, render s
& iData, gEq{|*|}, render, ggen{|*|} i
& iData, gEq{|*|}, render o
*/
esmVizTool :: !(ESM s i o) *World -> *World | iData, gEq{|*|}, render s & iData, gEq{|*|}, render, ggen{|*|} i & iData, gEq{|*|}, render o
toHtmlString :: a -> String | gPrint{|*|} a
implementation module ESMVizTool
import StdEnv, StdListExtensions
import StdiData
import StdiTasks //iTasks, iTaskDB
import ESMSpec
import iDataGraphvizForm
import GenPrint
derive gForm KnownAutomaton, Maybe, []
derive gUpd KnownAutomaton, Maybe, []
derive gPrint KnownAutomaton, Maybe
derive gParse KnownAutomaton, Maybe
//esmVizTool :: !(ESM s i o) *HSt -> (Bool,Html,*HSt) | iData, gEq{|*|}, render s & iData, gEq{|*|}, render, ggen{|*|} i & iData, gEq{|*|}, render o
esmVizTool :: !(ESM s i o) *World -> *World | iData, gEq{|*|}, render s & iData, gEq{|*|}, render, ggen{|*|} i & iData, gEq{|*|}, render o
esmVizTool esm world
= singleUserTask [] (iterateTask DiGraphFlow (newKA,[esm.s_0],[],1)) world
where
DiGraphFlow st=:(ka,as,trace,n)
= orTaskL [state
,chooseTaskV [] (sortBy (\(a,_) (b,_).a<b) [(render i,step i) \\ i<-possibleInputs esm as])
,[Br] !>> chooseTask [] [("Back" ,back),("Prune",prune),("Reset",return_V (newKA,[esm.s_0],[],1)),("Clear trace",return_V (ka,as,[],n))]
,stepN <<! traceHtml trace <<! legend
]
where
state = issuesToHtml ka.issues
!>> editTask "OK" (mkDigraph ThisExe (ka,esm.s_0,as,allEdgesFound esm ka,map fst ka.issues,flatten trace))
=>> \dig -> let (as`,trace`) = findSelectedStates dig ka as trace
in return_V (ka,as`,trace`,n)
step i = let next = nextStates esm i as
ka` = addTransitions 1 esm as [i] ka
trace` = addStep esm as i trace
in return_V (ka`,next,trace`,n)
back | isEmpty trace
= return_V (ka,as,[],n)
= let next = startStates (last trace)
trace` = init trace
in return_V (ka,next,trace`,n)
stepN = editTask "Add All" n
=>> \n -> if (n>0)
(return_V (addTransitions n esm as (possibleInputs esm as) ka,as,trace,n))
(return_V (ka,as,trace,1))
prune = return_V ({trans=[t\\t<-ka.trans|gisMember t onTraces],issues=[i\\i=:(t,_)<-ka.issues|gisMember t onTraces]},as,trace,n) where onTraces = flatten trace
newKA = {trans=[],issues=[]}
iterateTask :: (a->Task a) a -> Task a | iData a
iterateTask task a = task a =>> iterateTask task
orTaskL :: [Task a] -> Task a | iData a
orTaskL l = foldl1 (-||-) l
foldl1 op [a] = a
foldl1 op [a:x] = op a (foldl1 op x)
traceHtml trace
= [H3 [] "Trace:"
,Table []
[Tr [] [Td [] (map Txt (flatten [transToStrings t [] \\ t <- step]))]
\\ step <- trace
]
, Br
]
legend
= [ H3 [] "Legend:"
, Txt "Double circled state: intial state."
, Br
, Txt "Red state: current state (change state by click + OK-button)."
, Br
, Txt "Blue state: all defined inputs have been applied."
, Br
, Txt "Blue transitions: part of the current trace."
, Br
, Txt "Red transitions: an issue was found on this trace. Arrow heads are slightly bigger on trace."
]
issuesToHtml :: [(SeenTrans s i o,[String])] -> HtmlCode | render s & render i & render o
issuesToHtml [] = []
issuesToHtml l
= [H3 [] "Issues found:"
: [ Table []
[ Tr [] [Td [] (map Txt (transToStrings t [": ":ss])) ]
\\ (t,ss) <- l
]
]
]
transToStrings :: (SeenTrans s i o) [String] -> [String] | render s & render i & render o
transToStrings (s,i,o,t) c = ["(",render s,",",render i,",[":showList "," o ["],",render t,")":c]]
showList :: !String ![a] [String] -> [String] | render a
showList delimit [] c = c
showList delimit [x] c = [render x:c]
showList delimit [x:r] c = [render x,delimit:showList delimit r c]
findSelectedStates :: Digraph (KnownAutomaton s i o) [s] (Traces s i o) -> ([s],Traces s i o) | render, gEq{|*|} s
findSelectedStates (Digraph _ _ _ Nothing) _ as t = (as,t)
findSelectedStates (Digraph _ _ nodes (Just (Node nr))) ka as trace
# as` = take 1
[ s
\\ NodeDef nr` _ atts _ <- nodes | nr`==nr
, (NAtt_label label) <- atts
, s <- nodesOf ka | render s == label
]
= case as` of
[] = (as,trace)
[ns] | gisMember ns as
= (as`,narrowTraces trace as`)
# oneStep = [tr \\ tr=:(s,i,o,t)<-ka.trans | t===ns && gisMember s as]
| not (isEmpty oneStep)
= (as`,trace++[oneStep])
= (as`,partTraces trace ns [])
= (as`,[]) // ??
partTraces :: (Traces s i o) s (Traces s i o) -> (Traces s i o) | gEq{|*|} s
partTraces [] s seen = []
partTraces [trans:rest] s seen
| gisMember s (targetStates trans)
= narrowTraces (reverse [trans:seen]) [s]
= partTraces rest s [trans:seen]
allEdgesFound :: (ESM s i o) (KnownAutomaton s i o) -> [s] | gEq{|*|} s & ggen{|*|} i
allEdgesFound esm automaton
= [s \\ s <- nodesOf automaton
| length (edgesFrom s automaton) == length [t \\ i<-enumerate,t<-nextStates esm i [s]]
]
toHtmlString :: a -> String | gPrint{|*|} a
toHtmlString x
# string = printToString x
= {checkChar c \\ c <-: string}
where
checkChar '"' = '\''
checkChar c = c
// Péter Diviánszky, 2007
// Code extended and adapted by Peter Achten, 2007
definition module Graphviz
//from StdOverloaded import class ==, class toString
from StdOverloaded import class toString
import StdMaybe
import ESMSpec
import GenEq
// A digraph contains a title and a list of node definitions
:: Digraph
= Digraph String [GraphAttribute] [NodeDef] (Maybe SelectedItem)
:: SelectedItem
= Node Int
digraphTitle :: !Digraph -> String
digraphAtts :: !Digraph -> [GraphAttribute]
digraphNodes :: !Digraph -> [NodeDef]
digraphSelectedItem :: !Digraph -> Maybe SelectedItem
// A node definition contains a unique identifier (an integer), a list of node attributes and a list of edge definitions.
// An edge definition contains an identifier (the id of the end node and edge attributes).
:: NodeDef
= NodeDef !Int ![NodeState] ![NodeAttribute] [EdgeDef]
:: EdgeDef
:== (!Int,![EdgeAttribute])
:: NodeState
= NStAllEdgesFound !Bool // all edges of this node are known
// Convert digraph into list of strings.
// The strings are lines of the graphviz representation of the graph.
printDigraph :: !Digraph -> [String]
:: GraphAttribute
= GAtt_Damping Real
| GAtt_K Real
| GAtt_URL String
| GAtt_bb Rect
| GAtt_bgcolor Color
| GAtt_center Bool
| GAtt_charset String
| GAtt_clusterrank ClusterMode
| GAtt_colorscheme String
| GAtt_comment String
| GAtt_compound Bool
| GAtt_concentrate Bool
| GAtt_defaultdist Real
| GAtt_dim Int
// | GAtt_diredgeconstraints ... PA: ignored, neato only
| GAtt_dpi Real
| GAtt_epsilon Real
| GAtt_esep Real
| GAtt_fontcolor Color
| GAtt_fontname String
| GAtt_fontnames String
| GAtt_fontpath String
| GAtt_fontsize Real
| GAtt_label String
| GAtt_labeljust String
| GAtt_labelloc String
| GAtt_landscape Bool
| GAtt_layers LayerList
| GAtt_layersep String
| GAtt_levelsgap Real
| GAtt_lp DotPoint
| GAtt_margin Margin
| GAtt_maxiter Int
| GAtt_mclimit Real
| GAtt_mindist Real
| GAtt_mode String
| GAtt_model String
| GAtt_mosek Bool
| GAtt_nodesep Real
| GAtt_nojustify Bool
| GAtt_normalize Bool
| GAtt_nslimit Real
| GAtt_nslimit1 Real
| GAtt_ordering String
| GAtt_orientation String
| GAtt_outputorder OutputMode
| GAtt_pad Pad
| GAtt_page Pointf
| GAtt_pagedir PageDir
| GAtt_quantum Real
| GAtt_rank RankType
| GAtt_rankdir RankDir
| GAtt_ranksep Real
| GAtt_ratio Ratio
| GAtt_remincross Bool
| GAtt_resolution Real
| GAtt_root String
| GAtt_rotate Int
| GAtt_searchsize Int
| GAtt_showboxes Int
| GAtt_size Sizef //Pointf // PA++
// | GAtt_splines PA: skipped for the time being
| GAtt_start StartType
| GAtt_stylesheet String
| GAtt_target String
| GAtt_truecolor Bool
| GAtt_viewport ViewPort
| GAtt_voro_margin Real
:: NodeAttribute
= NAtt_URL String
| NAtt_color Color
| NAtt_colorscheme String
| NAtt_comment String
| NAtt_distortion Real
| NAtt_fillcolor Color
| NAtt_fixedsize Bool
| NAtt_fontcolor Color
| NAtt_fontname String
| NAtt_fontsize Real
| NAtt_group String
| NAtt_height Real
| NAtt_label String
| NAtt_layer LayerRange
| NAtt_margin Margin
| NAtt_nojustify Bool
| NAtt_orientation Real
| NAtt_peripheries Int
| NAtt_pin Bool
// | NAtt_pos ... PA: ignored for the time being
| NAtt_rects Rect
| NAtt_regular Bool
| NAtt_samplepoints Int
| NAtt_shape NodeShape
| NAtt_shapefile String
| NAtt_showboxes Int
| NAtt_sides Int
| NAtt_skew Real
| NAtt_style NodeStyle
| NAtt_target String
| NAtt_tooltip String
| NAtt_width Real
| NAtt_z Real
:: EdgeAttribute
= EAtt_URL String
| EAtt_arrowhead ArrowType
| EAtt_arrowsize Real
| EAtt_arrowtail ArrowType
| EAtt_color Color
| EAtt_colorscheme String
| EAtt_comment String
| EAtt_constraint Bool
| EAtt_decorate Bool
| EAtt_dir DirType
| EAtt_edgeURL String
| EAtt_edgehref String
| EAtt_edgetarget String
| EAtt_edgetooltip String
| EAtt_fontcolor Color
| EAtt_fontname String
| EAtt_fontsize Real
| EAtt_headURL String
| EAtt_headclip Bool
| EAtt_headhref String
| EAtt_headlabel String
| EAtt_headport PortPos
| EAtt_headtarget String
| EAtt_headtooltip String
| EAtt_href String
| EAtt_label String
| EAtt_labelURL String
| EAtt_labelangle Real
| EAtt_labeldistance Real
| EAtt_labelfloat Bool
| EAtt_labelfontcolor Color
| EAtt_labelfontname String
| EAtt_labelfontsize Real
| EAtt_labelhref String
| EAtt_labeltarget String
| EAtt_labeltooltip String
| EAtt_layer LayerRange
| EAtt_len Real
| EAtt_lhead String
| EAtt_lp DotPoint
| EAtt_ltail String
| EAtt_minlen Int
| EAtt_nojustify Bool
// | EAtt_pos PA: ignored for the time being
| EAtt_samehead String
| EAtt_sametail String
| EAtt_showboxes Int
| EAtt_style EdgeStyle
| EAtt_tailURL String
| EAtt_tailclip Bool
| EAtt_tailhref String
| EAtt_taillabel String
| EAtt_tailport PortPos
| EAtt_tailtarget String
| EAtt_tailtooltip String
| EAtt_target String
| EAtt_tooltip String
| EAtt_weight Real
:: ClusterMode
= CM_local | CM_global | CM_none
:: CompassPoint
= CP_n | CP_ne | CP_e | CP_se | CP_s | CP_sw | CP_w | CP_nw
:: DotPoint
= DotPoint Real Real Bool
:: LayerId
= LayerAll
| LayerNr Int
| LayerName String
:: LayerList
= LayerList [String]
:: LayerRange
= LayerRange LayerId [LayerId]
:: Margin
= SingleMargin Real
| DoubleMargin Real Real
:: OutputMode
= OM_breadthfirst | OM_nodesfirst | OM_edgesfirst
:: Pad
= SinglePad Real
| DoublePad Real Real
:: PageDir
= PD_BL | PD_BR | PD_TL | PD_TR | PD_RB | PD_RT | PD_LB | PD_LT
:: Pointf
= Pointf Real Real
:: PortPos // PA: for now only compass points are supported
:== CompassPoint
:: RankDir
= RD_TB | RD_LR | RD_BT | RD_RL
:: RankType
= RT_same | RT_min | RT_source | RT_max | RT_sink
:: Ratio
= AspectRatio Real
| R_fill
| R_compress
| R_expand
| R_auto
:: Rect
= {llx :: Int,lly :: Int, urx :: Int, ury :: Int}
:: Sizef // PA++
= Sizef Real Real Bool
:: StartStyle