-- Copyright (c) Emil Axelsson 2012

-- This file defines the syntax and semantics of CTL*. The aim has been to make
-- a faithful transcription of the rules given in the lecture slides.
--
-- The semantics is bounded (see the `bound` variable), so it can only prove
-- sufficiently time-bounded properties or disprove properties with sufficiently
-- short counter-examples.



--------------------------------------------------------------------------------
-- Transition systems
--------------------------------------------------------------------------------

-- Atomic propositions
type AP = String

type State = String
type Path  = [State]

type S = [State]           -- Set of states
type R = State -> [State]  -- Transition relation
type A = [AP]              -- Atomic propositions
type L = State -> [AP]     -- State interpretation

-- Finite state model
type M = (S,R,A,L)



--------------------------------------------------------------------------------
-- CTL* syntax
--------------------------------------------------------------------------------

-- State formulas
data SFormula
    = Atomic AP
    | SNot SFormula
    | SFormula `SOr` SFormula
    | E PFormula
  deriving (Eq,Show)

-- Path formulas
data PFormula
    = State SFormula
    | PNot PFormula
    | PFormula `POr` PFormula
    | X PFormula
    | PFormula `U` PFormula
  deriving (Eq,Show)



--------------------------------------------------------------------------------
-- Derived constructs
--------------------------------------------------------------------------------

sAnd :: SFormula -> SFormula -> SFormula
f1 `sAnd` f2 = SNot (SNot f1 `SOr` SNot f2)

pAnd :: PFormula -> PFormula -> PFormula
f1 `pAnd` f2 = PNot (PNot f1 `POr` PNot f2)

_A :: PFormula -> SFormula
_A f = SNot (E (PNot f))

_F :: PFormula -> PFormula
_F f = State (Atomic "true") `U` f

_G :: PFormula -> PFormula
_G f = PNot (_F (PNot f))



--------------------------------------------------------------------------------
-- Semantics
--------------------------------------------------------------------------------

bound = 100

-- Breadth-first concatenation (for a finite list of infinite lists)
breadthConcat :: [[a]] -> [a]
breadthConcat ass = map head ass ++ breadthConcat (map tail ass)

pathsFrom' :: M -> State -> [Path]
pathsFrom' m@(s,r,a,l) st = map (st:) $ breadthConcat $ map (pathsFrom m) (r st)

-- Breadth-first enumeration of all paths starting in a given state
pathsFrom :: M -> State -> [Path]
pathsFrom m st = take bound $ pathsFrom' m st

sHolds :: M -> SFormula -> State -> Bool
sHolds m@(s,r,a,l) (Atomic ap)   st = ap `elem` l st
sHolds m@(s,r,a,l) (SNot f)      st = not (sHolds m f st)
sHolds m@(s,r,a,l) (f1 `SOr` f2) st = sHolds m f1 st || sHolds m f2 st
sHolds m@(s,r,a,l) (E f)         st = any (pHolds m f) (pathsFrom m st)

pHolds :: M -> PFormula -> Path -> Bool
pHolds m@(s,r,a,l) (State f)     path = sHolds m f (head path)
pHolds m@(s,r,a,l) (PNot f)      path = not (pHolds m f path)
pHolds m@(s,r,a,l) (f1 `POr` f2) path = pHolds m f1 path || pHolds m f2 path
pHolds m@(s,r,a,l) (X f)         path = pHolds m f (tail path)
pHolds m@(s,r,a,l) (f1 `U` f2)   path = any until [0..bound]
  where
    until k
         = pHolds m f2 (drop k path)
        && and [pHolds m f1 (drop j path) | j <- [0..k-1]]

-- Check that a path formula holds for all paths
checkLTL :: M -> PFormula -> State -> Bool
checkLTL m f st = sHolds m (_A f) st



--------------------------------------------------------------------------------
-- Example
--
-- (from <http://en.wikipedia.org/wiki/Kripke_structure_%28model_checking%29>)
--------------------------------------------------------------------------------

model =
  ( ["S1","S2","S3"]

  , \st -> case st of
        "S1" -> ["S2"]
        "S2" -> ["S1","S3"]
        "S3" -> ["S3"]

  , ["true","p","q"]

  , \st -> case st of
        "S1" -> ["true","p","q"]
        "S2" -> ["true","q"]
        "S3" -> ["true","p"]

  )

-- EX p
form0 = E (X (State (Atomic "p")))
test0 = sHolds model form0 "S1"
  -- Result: false
  --
  -- Time-bounded property

-- EX (EX p)
form1 = E (X (State (E (X (State (Atomic "p"))))))
test1 = sHolds model form1 "S1"
  -- Result: true
  --
  -- Time-bounded property

-- AG p
form2 = _A (_G (State (Atomic "p")))
test2 = sHolds model form2 "S1"
  -- Result: false
  --
  -- Finite counter-example

-- FG p
form3 = _F (_G (State (Atomic "p")))
test3 = checkLTL model form3 "S1"
  -- Result: false
  --
  -- Liveness property

-- EF (G p)
form4 = E (_F (_G (State (Atomic "p"))))
test4 = sHolds model form4 "S1"
  -- Result: true
  --
  -- Liveness property

-- EG (F p)
form5 = E (_G (_F (State (Atomic "p"))))
test5 = sHolds model form5 "S1"
  -- Result: true
  --
  -- Liveness property