;; a tlc-state is a pair consisting of highway light, farm light colors,
;;   and timer state 

(defun make-tlc-state (hcolor fcolor time)
  (list hcolor fcolor time))

(defun get-hcolor (tlc-state)
  (car tlc-state))

(defun get-fcolor (tlc-state)
  (cadr tlc-state))

(defun get-time (tlc-state)
  (caddr tlc-state))

;; define a function envp to generate sequences of car, no car.

(defun carvalp (val)
  (or (equal val 'car) (equal val 'nocar)))

(defun carlistp (val)
  (or (null val)
      (and (carvalp (car val))
	   (carlistp (cdr val)))))

(defun envp (val) (carlistp val))       

;; do a version with the timer generated ND.

(defconst *expired* 2)

(defun get-new-tlc-state (astate carval)
  (let ((hcolor (get-hcolor astate))
	(fcolor (get-fcolor astate))
	(timer (get-time astate)))
    (make-tlc-state
     (cond ((and (equal hcolor 'red) (equal fcolor 'yellow)) 'green)
	   ((equal hcolor 'yellow) 'red)
	   ((and (equal hcolor 'green) (equal timer *expired*)
		 (equal carval 'car)) 'yellow)
	   (t hcolor))
     (cond ((and (equal fcolor 'red) (equal hcolor 'yellow)) 'green)
	   ((equal fcolor 'yellow) 'red)
	   ((and (equal fcolor 'green) (equal timer *expired*)) 'yellow)
	   (t fcolor))
     (mod (+ timer 1) 3))))	   

;; run-tlc : tlc-state env -> 'done
;; executes tlc from given starting state on given environment
(defun run-tlc (tlc-state env)
  (if (envp env)
      (cond ((null env) nil)
	    (t (let ((newstate (get-new-tlc-state tlc-state (car env))))
		 (cons newstate (run-tlc newstate (cdr env))))))
    'env-error))

(defun run-tlc2 (tlc-state env)
  (if (envp env)
      (cond ((null env) nil)
	    (t (let ((newstate (get-new-tlc-state tlc-state (car env))))
		 (cons newstate (run-tlc2 newstate (cdr env))))))
    'env-error))

;; (run-tlc (make-tlc-state 'green 'red 0) (list 'nocar 'nocar 'car 'car))

;; theorems on traffic light

(defun two-green-statep (astate)
  (and (equal (get-hcolor astate) 'green) (equal (get-fcolor astate) 'green)))

(defun run-has-two-green-statep (statelist)
  (if (listp statelist)
      (cond ((null statelist) nil)
	    (t (or (two-green-statep (car statelist))
		   (run-has-two-green-statep (cdr statelist)))))
    'error))

(defun run-has-no-two-green-statep (statelist)
  (if (listp statelist)
      (cond ((null statelist) t)
	    (t (and (not (two-green-statep (car statelist)))
		    (run-has-no-two-green-statep (cdr statelist)))))
    'error))

;; theorem that two lights are never green at once
(defthm tlc-no-two-green-thm
  (implies (envp env)
	   (not (run-has-two-green-statep
		 (run-tlc (make-tlc-state 'green 'red 0) env)))))

(defun valid-light-colorp (val)
  (or (equal val 'red) (equal val 'green) (equal val 'yellow)))

(defun tlc-statep (astate)
  (and (valid-light-colorp (get-hcolor astate))
       (valid-light-colorp (get-fcolor astate))))

(defthm next-state-valid-thm
  (implies (and (carvalp carval)
		(tlc-statep astate))
	   (tlc-statep (get-new-tlc-state astate carval))))

(defthm next-state-not-two-green-thm
  (implies (and (carvalp carval)
		(tlc-statep astate)
		(not (two-green-statep astate)))
	   (not (two-green-statep (get-new-tlc-state astate carval)))))

(defthm tlc-no-two-green-thm2
  (implies (envp env)
	   (not (run-has-two-green-statep
		 (run-tlc (make-tlc-state 'green 'red 0) env))))
  :hints (("Goal" :hands-off get-new-tlc-state)))