;   mc-class-2006.lisp                                   February, 2006

;                Warren A. Hunt, Jr. & Laurence Pierre

;  Below we define a model checker where states are represented by
;  symbols and the transition relation and labeling by association
;  lists.

;  We first start with a number of set operations where a set is
;  defined as a list of distinct symbols.

;  NOTE:  We DO prove that every set operation produces a set with no 
;  duplicates.  To that goal, we have defined NO-DUPLICATESP-EQ.


(defun no-duplicatesp-eq (l)
  (declare (xargs :guard (symbol-listp l)))
  (cond ((endp l) t)
        ((member-eq (car l) (cdr l)) nil)
        (t (no-duplicatesp-eq (cdr l)))))

(defun delete-eq (sym s)
  (declare (xargs :guard (or (symbolp sym)
                             (symbol-listp s))))
  (if (atom s)
      nil
    (if (eq sym (car s))
        (cdr s)
      (cons (car s)
            (delete-eq sym (cdr s))))))

(defthm symbol-listp-delete-eq
  (implies (symbol-listp s)
           (symbol-listp (delete-eq sym s))))

(defthm not-member-eq-delete-eq
  (implies (and (symbol-listp s)
                (no-duplicatesp s))
           (not (member-eq sym (delete-eq sym s)))))

(defthm delete-eq-non-existent-symbol
  (implies (and (symbol-listp s)
                (not (member-eq sym s)))
           (equal (delete-eq sym s) s)))

(defthm not-member-eq-delete-eq-two-sym
  (implies (and (symbol-listp s)
                (not (member-eq sym1 s)))
           (not (member-eq sym1 (delete-eq sym2 s)))))

(defthm no-duplicatesp-eq-delete-eq
  (implies (and (symbolp sym)
                (symbol-listp s)
                (no-duplicatesp-eq s))
           (no-duplicatesp-eq (delete-eq sym s))))

(defun delete-all-eq (sym s)
  (declare (xargs :guard (or (symbolp sym)
                             (symbol-listp s))))
  (if (atom s)
      nil
    (if (eq sym (car s))
        (delete-all-eq sym (cdr s))
      (cons (car s)
            (delete-all-eq sym (cdr s))))))

(defthm symbol-listp-delete-all-eq
  (implies (symbol-listp s)
           (symbol-listp (delete-all-eq sym s))))

(defthm not-member-eq-delete-all-eq
  (implies (symbol-listp s)
           (not (member-eq sym (delete-all-eq sym s)))))

(defthm delete-all-eq-non-existent-symbol
  (implies (and (symbol-listp s)
                (not (member-eq sym s)))
           (equal (delete-all-eq sym s) s)))

(defthm not-member-eq-delete-all-eq-two-sym
  (implies (and (symbol-listp s)
                (not (member-eq sym1 s)))
           (not (member-eq sym1 (delete-all-eq sym2 s)))))

(defthm no-duplicatesp-eq-delete-all-eq
  (implies (and (symbolp sym)
                (symbol-listp s)
                (no-duplicatesp-eq s))
           (no-duplicatesp-eq (delete-all-eq sym s))))

(defun setp (s)
  (declare (xargs :guard t))
  (and (symbol-listp s)
       (no-duplicatesp-eq s)))


;;;;; lemmas for "set-complement" (LP)

(defun set-complement (s1 tset)
  (declare (xargs :guard (or (symbol-listp s1)
                             (and (true-listp s1)
                                  (symbol-listp tset)))))
  (if (atom tset)
      nil
    (if (member-eq (car tset) s1)
        (set-complement s1 (cdr tset))
      (cons (car tset)
            (set-complement s1 (cdr tset))))))

(defthm symbol-listp-set-complement
  (implies (symbol-listp tset)
           (symbol-listp (set-complement s1 tset))))


; Here is one of the problems we can have with Warren's original
; definition of all-member-eq :
;    ACL2 !>(all-member-eq '(a a) '(a b))
;    T
; Here is a new version of this function, without deleting elements
; in s2 :
(defun all-member-eq (s1 s2)
  (declare (xargs :guard (or (and (symbol-listp s1)
                                  (true-listp s2))
                             (symbol-listp s2))))
  (if (setp s1)
      (if (endp s1)
	  t
	(and (member-eq (car s1) s2)
	     (all-member-eq (cdr s1) s2)))
    nil))

(defthm member-eq-delete-all-eq-member
  (implies (and (symbol-listp s)
                (member-eq sym1 (delete-all-eq sym2 s)))
           (member-eq sym1 s)))

(defthm all-member-eq-s2-s1-implies-member-eq
   (implies (and (symbol-listp s1)
                 (all-member-eq s2 s1)
                 (member-eq sym s2))
            (member-eq sym s1)))

(defthm all-member-eq-cdr-implies-all-member-eq
   (implies (all-member-eq s2 (cdr s1))
            (all-member-eq s2 s1))))

(defthm all-member-eq-set-complement
  (implies (setp tset)
           (all-member-eq (set-complement s1 tset) tset)))

(defthm all-member-eq-no-duplicatesp-eq  
   (implies (and (setp s1)
                 (all-member-eq s2 s1))
            (no-duplicatesp-eq s2)))

(defthm no-duplicatesp-eq-set-complement
  (implies (setp tset)
           (no-duplicatesp-eq (set-complement s1 tset)))
  :hints (("Goal" :use (all-member-eq-set-complement  
                        (:instance all-member-eq-no-duplicatesp-eq
                                   (s1 tset)
                                   (s2 (set-complement s1 tset)))))))

;;;;;;;;;;;;;;

  
;;;;; lemmas for "set-union"

(defun set-union (s1 s2)
  (declare (xargs :guard (and (symbol-listp s1)
                              (symbol-listp s2))))
  (if (atom s1)
      s2
    (if (member-eq (car s1) s2)
        (set-union (cdr s1) s2)
      (cons (car s1) (set-union (cdr s1) s2)))))

(defthm symbol-listp-set-union
  (implies (and (symbol-listp s1)
                (symbol-listp s2))
           (symbol-listp (set-union s1 s2))))

(defthm not-member-eq-union      ; added by LP
  (implies (and (symbol-listp l1) (symbol-listp l2)
                (not (member-eq e l1))
                (not (member-eq e l2)))
           (not (member-eq e (set-union l1 l2)))))

(defthm no-duplicatesp-eq-set-union  
  (implies (and (setp s1)
                (setp s2))
           (no-duplicatesp-eq (set-union s1 s2))))

;;;;;;;;;;;;;;

;;;;; lemmas for "set-intersection"

(defun set-intersection (s1 s2)
  (declare (xargs :guard (and (symbol-listp s1)
                              (true-listp s2))))
  (if (atom s1)
      nil
    (if (member-eq (car s1) s2)
        (cons (car s1)
              (set-intersection (cdr s1) s2))
      (set-intersection (cdr s1) s2))))

(defthm symbol-listp-set-intersection
  (implies (and (symbol-listp s1)
                (symbol-listp s2))
           (symbol-listp (set-intersection s1 s2))))

(defthm not-member-eq-intersection     ; added by LP
  (implies (and (symbol-listp l1) (symbol-listp l2)
                (or (not (member-eq e l1))
                    (not (member-eq e l2))))
           (not (member-eq e (set-intersection l1 l2)))))


(defthm no-duplicatesp-eq-set-intersection
  (implies (and (setp s1)
                (setp s2))
           (no-duplicatesp-eq (set-intersection s1 s2))))

;;;;;;;;;;;;;;

; replaced by LP's definition (above)
;(defun all-member-eq (s1 s2)
;  (declare (xargs :guard (or (and (symbol-listp s1)
;                                  (true-listp s2))
;                             (symbol-listp s2))))
;  (if (atom s1)
;      t
;    (and (member-eq (car s1) s2)
;         (all-member-eq (cdr s1) s2))))

(defun set-eq (s1 s2)
  (declare (xargs :guard (and (symbol-listp s1)
                              (symbol-listp s2))))
  (and (all-member-eq s1 s2)
       (all-member-eq s2 s1)))


(defun lst-symbol-listp (x)
  (declare (xargs :guard t))
  (if (atom x)
      (null x)
    (and (symbol-listp (car x))
         (lst-symbol-listp (cdr x)))))

(defthm symbol-listp-of-assoc-eq-lst-symbol-listp
  (implies (and (symbol-alistp alst)
                (lst-symbol-listp alst)
                (symbolp name)
                (assoc-eq name alst))
           (symbol-listp (assoc-eq name alst))))

(defthm symbol-listp-of-cdr-assoc-eq-of-lst-symbol-listp
  (implies (and (symbol-alistp alst)
                (lst-symbol-listp alst)
                (symbolp name)
                (assoc-eq name alst))
           (symbol-listp (cdr (assoc-eq name alst)))))


;  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;  Here we start the definition of our model checker by defining a
;  recognizer for a Kripke structure.  We then define operations on
;  lists of states (sets) so we can evaluate a model-checking formula.
;  Finally, we define the model checker itself -- this model checker,
;  given a formula to check, finds all states satisfying the formula.

; (defmacro natp         (x)  `(and (integerp ,x) (<= 0 ,x)))

(defmacro get-states   (l)  `(car ,l))
(defmacro get-relation (l)  `(cadr ,l))
(defmacro get-labeling (l)  `(caddr ,l))

(defun kripkep (k)
  (declare (xargs :guard t))
  (and (consp k)
       (consp (cdr k))
       (consp (cddr k))
       (null (cdddr k))
       (let ((states   (get-states k))
             (relation (get-relation k))
             (labeling (get-labeling k)))
         (and (symbol-listp states)
              (symbol-alistp    relation)
              (lst-symbol-listp relation)
              (symbol-alistp    labeling)
              (lst-symbol-listp labeling)
              ))))

;  In CTL* formulas are composed of path quanifiers and temporal
;  operators.  Path quanifiers are used to describe the branching
;  structure:  A -- for all paths, and E -- for some path; these
;  quanifiers are used in a particular state to specify that either
;  all paths or some paths starting at that state have some property.

;  The temporal operators describe properties of a path; there are
;  several operators:
;  X ("next time") specifies that a property holds in the next state.
;  G ("always" or "globally") specifies a property holds at every state.
;  U ("until") operator combines two properties; it holds when if the
;    second property holds at a state then the first property holds at
;    every preceeding state on the path.

;  In CTL* there are state formulas, which are true of a specific state;
;  and path formulas, which are true along a specific path.

;  A label l identifies a subset of the states
;  The formulas are:
;  If p is a label, then p is a state formula
;  If f and g are state formulas, then so are:  (not f), (or f g), (and f g).
;  If f is a path formula, then (E f) and (A f) are state formulas.
;  If f is a state formula, then f is also a path formula.
;  If f and g are path formulas, then so are:  (not f), (or f g), (and f g),
;     (X f), (G f), and (U f g).

;  CTL is a subset of CTL* where X, G, and U, must be immediately proceeded
;  by a path quanifier (either A or E).

;  If f and g are state formulas, then (X f), (G f), and (U f g) are path
;  formulas.

;  Each CTL operator can be expressed in terms of EX, EG, and EU, i.e.,
;  (AX f)   = (not (EX (not f)))
;  (EF f)   = (EU t f)
;  (AG f)   = (not (EF (not f)))
;  (AF f)   = (not (EG (not f)))
;  (AU f g) = (and (not (EU (not g) (and (not f) (not g)))) (EG (not g)))
;  (AR f g) = (not (EU (not f) (not g)))
;  (ER f g) = (not (AU (not f) (not g)))

(defun not-p (p kripke)
  (declare (xargs :guard (and (symbol-listp p)
                              (kripkep kripke))))
  (set-complement p (get-states kripke)))

(defthm symbol-listp-not-p
  (implies (and (symbol-listp p)
                (kripkep kripke))
           (symbol-listp (not-p p kripke))))

(in-theory (disable not-p))

(defun or-pq (p q kripke)
  (declare (xargs :guard (and (symbol-listp p)
                              (symbol-listp q)))
           (ignore kripke))
  (set-union p q))

(defthm symbol-listp-or-pq
  (implies (and (symbol-listp s1)
                (symbol-listp s2))
           (symbol-listp (or-pq s1 s2 kripke))))

(in-theory (disable or-pq))

(defun and-pq (p q kripke)
  (declare (xargs :guard (and (symbol-listp p)
                              (symbol-listp q)))
           (ignore kripke))
  (set-intersection p q))

(defthm symbol-listp-and-pq
  (implies (and (symbol-listp s1)
                (symbol-listp s2))
           (symbol-listp (and-pq s1 s2 kripke))))

(in-theory (disable and-pq))

(defun EX-help (p rel)
  (declare (xargs :guard (and (symbol-listp p)
                              (symbol-alistp    rel)
                              (lst-symbol-listp rel))))
  (if (atom rel)
      nil
    (let ((cur (car rel))
          (rest (cdr rel)))
      (if (null (set-intersection p (cdr cur)))
          (EX-help p rest)
        (cons (car cur) (EX-help p rest))))))

(defthm symbol-listp-EX-help
  (implies (and (symbol-listp p)
                (symbol-alistp    rel)
                (lst-symbol-listp rel))
           (symbol-listp (EX-help p rel))))

(defun EX (p kripke)
  (declare (xargs :guard (and (symbol-listp p)
                              (kripkep kripke))))
  (EX-help p (get-relation kripke)))

(defthm symbol-listp-EX
  (implies (and (symbol-listp p)
                (kripkep kripke))
           (symbol-listp (EX p kripke))))

(in-theory (disable EX))

(defun AX-help (p rel)
  (declare (xargs :guard (and (symbol-listp p)
                              (symbol-alistp    rel)
                              (lst-symbol-listp rel))))
  (if (atom rel)
      nil
    (let ((cur (car rel))
          (rest (cdr rel)))
      (if (all-member-eq (cdr cur) p)
          (cons (car cur) (AX-help p rest))
        (AX-help p rest)))))

(defthm symbol-listp-AX-help
  (implies (and (symbol-listp p)
                (symbol-alistp    rel)
                (lst-symbol-listp rel))
           (symbol-listp (AX-help p rel))))

(defun AX (p kripke)
  (declare (xargs :guard (and (symbol-listp p)
                              (kripkep kripke))))
  (let ((rel (get-relation kripke)))
    (AX-help p rel)))

(defthm symbol-listp-AX
  (implies (and (symbol-listp p)
                (kripkep kripke))
           (symbol-listp (AX p kripke))))

(in-theory (disable AX))

(defun EU (n p q y kripke)
  (declare (xargs :guard (and (natp n)
                              (symbol-listp p)
                              (symbol-listp q)
                              (symbol-listp y)
                              (kripkep kripke))))
  (let ((yprime (set-union q (set-intersection p (EX y kripke)))))
    (if (set-eq y yprime)
        y
      (if (zp n)
          y
        (EU (1- n) p q yprime kripke)))))

(defthm symbol-listp-EU
  (implies (and (symbol-listp p)
                (symbol-listp q)
                (symbol-listp y)
                (kripkep kripke))
           (symbol-listp (EU n p q y kripke))))

(in-theory (disable EU))

(defun EG (n p y kripke)
  (declare (xargs :guard (and (natp n)
                              (symbol-listp p)
                              (symbol-listp y)
                              (kripkep kripke))))
  (let ((yprime (set-intersection p (EX y kripke))))
    (if (set-eq y yprime)
        y
      (if (zp n)
          y
        (EG (1- n) p yprime kripke)))))

(defthm symbol-listp-EG
  (implies (and (symbol-listp p)
                (symbol-listp y)
                (kripkep kripke))
           (symbol-listp (EG n p y kripke))))

(in-theory (disable EG))

(defmacro consp-n (x n)
  (declare (xargs :guard (natp n)))
  (if (= n 0)
      `(null ,x)
    (if (= n 1)
        `(and (consp ,x)
              (null (cdr ,x)))
      (list 'and
            `(consp ,x)
            `(consp-n (cdr ,x) ,(- n 1))))))

(mutual-recursion

(defun formp (p)
  (declare (xargs :guard t))
  (if (atom p)
      (symbolp p)
    (let ((fn   (car p))
          (args (cdr p)))
      (and (form-lstp args)
           (case fn
             (not (consp-n args 1))
             (or  (consp-n args 2))
             (and (consp-n args 2))
             (EX  (consp-n args 1))
             (AX  (consp-n args 1))
             (EF  (consp-n args 1))
             (EU  (consp-n args 2))
             (EG  (consp-n args 1))
             (otherwise nil))))))

(defun form-lstp (lst-p)
  (declare (xargs :guard t))
  (if (atom lst-p)
      t
    (and (formp (car lst-p))
         (form-lstp (cdr lst-p)))))
)

(defun eval-mc (p kripke)
  (declare (xargs :guard (and (formp p)
                              (kripkep kripke))
                  :verify-guards nil))
  (if (atom p)
      (cdr (assoc-eq p (get-labeling kripke)))
    (let ((fn   (car p))
          (args (cdr p)))
      (case fn
      (not (not-p  (eval-mc (car args) kripke)
                   kripke))
      (or  (or-pq  (eval-mc (car args) kripke)
                   (eval-mc (cadr args) kripke)
                   kripke))
      (and (and-pq (eval-mc (car args) kripke)
                   (eval-mc (cadr args) kripke)
                   kripke))
      (EX  (EX     (eval-mc (car args) kripke)
                   kripke))
      (AX  (AX     (eval-mc (car args) kripke)
                   kripke))
      (EF  (EU     (1+ (len (get-states kripke)))
                   (get-states kripke)
                   (eval-mc (car args) kripke)
                   nil
                   kripke))
      (EU  (EU     (1+ (len (get-states kripke)))
                   (eval-mc (car args) kripke)
                   (eval-mc (cadr args) kripke)
                   nil
                   kripke))
      (EG  (EG    (1+ (len (get-states kripke)))
                  (eval-mc (car args) kripke)
                  (get-states kripke)
                  kripke))
      (otherwise nil)))))

(defthm symbol-listp-eval-mc
  (implies (and (formp p)
                (kripkep kripke))
           (symbol-listp (eval-mc p kripke))))

(verify-guards eval-mc)


; Notice use of functions instead of macros.

(defun AG (f)
  `(not (EF (not ,f))))

(defun AF (f)
  `(not (EG (not ,f))))

;  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;  Here we have some examples.

(assign kripke
        '((a b c)
          ((a c) (b a c) (c b))
          ((p a b) (q b))))

(kripkep (@ kripke))

(assign form
        '(ex p))

(formp (@ form))

(eval-mc (@ form) (@ kripke))

;  ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

;  Example discussed in class on Feb 27, 2006.

(assign
 kripke
 '((s0 s1 s2 s3)
   ((s0 s1)
    (s1 s2)
    (s2 s0)
    (s3 s2))
   ((s0 s0)
    (s1 s1)
    (s2 s2)
    (s3 s3)
    (g s0 s1 s2)
    (a s0 s1 s2 s3))))

(kripkep (@ kripke))

(assign form
        '(AX g))

(formp (@ form))

(eval-mc (@ form) (@ kripke))

; Notice the use of backquote and comma below.

(assign form `(not ,(AG 'g)))

(assign form2 (AG 'g))


(formp (@ form))

(assign form `(or ,(AG 'g)
                  ,(AF '(not a))))