Skip to content

GitLab

Commit cad2e135 authored by John van Groningen's avatar John van Groningen
Browse files

in clean-classic for linux-x86 remove txt/Gast, use gast repository instead

parent 2a7532f5
Pipeline #49827 passed with stage
in 19 minutes and 6 seconds
Expand all Hide whitespace changes
Inline Side-by-side
clean-classic/linux-x86/Gast/ESMSpec.dcl deleted 100755 → 0
View file @ 2a7532f5
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
clean-classic/linux-x86/Gast/ESMSpec.icl deleted 100755 → 0
View file @ 2a7532f5
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
clean-classic/linux-x86/Gast/Graphviz.dcl deleted 100755 → 0
View file @ 2a7532f5
// 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
= SS_regular | SS_self | SS_random
:: StartType
= { startStyle :: Maybe StartStyle
, startSeed :: Maybe Int
}
:: ViewPort
= { vp_W :: Real
, vp_H :: Real
, vp_Z :: Maybe Real
, vp_xy :: Maybe Pointf
}
pointNode :: [NodeAttribute] // attributes of a point-shaped node
hiddenNode :: [NodeAttribute] // attributes of a hidden node
:: NodeShape
= NShape_box
| NShape_circle
| NShape_diamond
| NShape_doublecircle
| NShape_doubleoctagon
| NShape_egg
| NShape_ellipse
| NShape_hexagon
| NShape_house
| NShape_invtriangle
| NShape_invtrapezium
| NShape_invhouse
| NShape_octagon
| NShape_Mdiamond
| NShape_Msquare
| NShape_Mcircle
| NShape_parallelogram
| NShape_pentagon
| NShape_plainText
| NShape_polygon
| NShape_point
| NShape_rect
| NShape_rectangle
| NShape_septagon
| NShape_trapezium
| NShape_triangle
| NShape_tripleoctagon
| NShape_none
instance toString NodeShape
instance == NodeShape
derive gEq NodeShape // PK++
:: NodeStyle
= NStyle_filled
| NStyle_invis
| NStyle_diagonals
| NStyle_rounded
| NStyle_dashed
| NStyle_dotted
| NStyle_solid
| NStyle_bold
instance toString NodeStyle
instance == NodeStyle
derive gEq NodeStyle // PK++
:: EdgeStyle
= EStyle_solid
| EStyle_bold
| EStyle_dashed
| EStyle_dotted
| EStyle_invis
instance toString EdgeStyle
instance == EdgeStyle
derive gEq EdgeStyle // PK++
:: Color
= RGB Int Int Int
| HSV Real Real Real
| Color String // X11 1.2 color names; see rgb.txt
C_black :== Color "black"
C_white :== Color "white"
C_gray :== Color "gray"
C_red :== Color "red"
C_green :== Color "green"
C_blue :== Color "blue"
C_yellow :== Color "yellow"
instance toString Color
instance == Color
derive gEq Color // PK++
:: ArrowType =
{ closest :: Arrow
, furthest :: Maybe Arrow
}
:: Arrow =
{ open :: Bool
, side :: Maybe Side
, shape :: ArrowShape
}
:: Side
= Side_l
| Side_r
:: ArrowShape
= AShape_box
| AShape_crow
| AShape_diamond
| AShape_dot
| AShape_inv
| AShape_none
| AShape_normal
| AShape_tee
| AShape_vee
instance toString ArrowType
instance == ArrowType
derive gEq ArrowType // PK++
// direction of the edge
:: DirType
= DT_forward
| DT_back
| DT_both
| DT_none
instance toString DirType
instance == DirType
derive gEq DirType // PK++
layersep :== ":\t"
mkDigraph :: String (KnownAutomaton s i o,s,[s],[s],[SeenTrans s i o],[SeenTrans s i o]) -> Digraph | render, gEq{|*|} s
& render, gEq{|*|} i
& render, gEq{|*|} o
clean-classic/linux-x86/Gast/Graphviz.icl deleted 100755 → 0
View file @ 2a7532f5
// Péter Diviánszky, 2007
// Code extended and adapted for using generics by Peter Achten, 2007
implementation module Graphviz
import StdArray, StdOverloaded, StdList, StdOrdList, StdTuple, StdString, StdBool, StdMisc
import StdMaybe, StdListExtensions
import GenLib
import ESMSpec
derive gEq EdgeStyle, NodeStyle, DirType, NodeShape, Side, ArrowShape, Maybe, ArrowType, Arrow, Color
derive gPrint EdgeStyle, NodeStyle, DirType, NodeShape, Side, ArrowShape, Maybe, CompassPoint, StartStyle,
ClusterMode, OutputMode, PageDir, RankDir, RankType
derive printNameValuePair GraphAttribute, NodeAttribute, EdgeAttribute
// Almost regular toString instances:
instance toString EdgeStyle where toString es = /*quote*/ (skipXXX_InConstructorName (printToString es))
instance toString NodeStyle where toString ns = quote (skipXXX_InConstructorName (printToString ns))
instance toString DirType where toString dir = quote (skipXXX_InConstructorName (printToString dir))
instance toString NodeShape where toString ns = skipXXX_InConstructorName (printToString ns)
instance toString Side where toString s = skipXXX_InConstructorName (printToString s)