(** %\chapter{%#<H0>#Finite automata%}%#</H0># *)

(* Proofs *)
 Section Automata.
(*Load FinSets.*)
Load Finitesets.
Require Import List.

Set Implicit Arguments.

(*Definition Alphabet := nat.*)
(*Variable Sigma : Alphabet. *)

(** * Introduction

  In finite automata theory, the basic element that we need to use in order  to reason about the behaviour of an automaton is the _word_ .

  By definition, we call  a word to be a list of _symbols_.

  - A symbol is an element of an alphabet( usually denoted as $\Sigma $ ).

  - A set of words is defined to be called a _language_ .

  In our implementation , a language is represented as a function that takes a word

  and decides whether it is a member of the set (type [Prop]).

      *)
Definition Word(x:Alphabet) := list (Fin x).

Definition Language (a:Alphabet):= Word a -> Prop.

Inductive Starl(c:Alphabet)(x:Language c) : Language c :=
  | nil0: (Starl x) nil
  | cons0 : forall (a: Word c)(b:Word c),Starl x a /\ x b -> Starl x (app a b).

(** An empty word is defined as the [nil] list constructor *)

Definition eps (a:Alphabet):Word a:=nil.

(**  * Deterministic finite automata

  As in "Automata and theory of computation"(J.Hopcroft), a deterministic finite automaton

 (DFA) is defined a 5-uple (Q,$\Sigma $ , $\sigma $, ${q}_{0}$, F)

  - A finite set of states Q (here denoted by [states])

  - A set of symbols ([Fin a])

  - A transition function $\sigma $ : Q * $\Sigma $ -> Q , denoted by [delta]

  - An initial state ${q}_{0}$

  - A set of final states F .

*)

Record dfa (n:nat) (a:Alphabet) :Type:= DFA {
  states :=  Fin n; (*finite sets*)
  symbol := Fin a;
  delta : Fin n ->Fin a  -> Fin n;
  q0 : Fin n ; (*only 1 initial state*)
  final :Fin n -> bool (*multiple states*)
}.
Check dfa.

(** * Language of a finite deterministic automaton *)

(*Definition is_accepting (n:nat)(a:Alphabet)(d:dfa n a)(q: states d)  := In q (final d).*)

(** Below, we have the extended transition function for a DFA , [deltah] : *)

Fixpoint deltah (n:nat)(a:Alphabet)(d: dfa n a)(q: Fin n) (w: Word a) : (Fin n):=
  match w with
     | nil => q
     | h :: t => (deltah d (delta  d q h ) t)
  end.
Lemma deltah_prop:
  forall (a:Alphabet)(n:nat)(q:Fin n) (d:dfa n a) (xs ys :Word a),
   deltah d (q) (xs++ ys) = deltah d (deltah d (q) xs) ys.

induction xs.
simpl in *.
reflexivity.
simpl in *.

intros.
simpl in *.
(*induction ys.
simpl in *.
assert (xs++nil = xs).
intuition.
rewrite H.
reflexivity.
simpl in *.
intuition. *)
admit.
Qed.
Lemma deltah_property :
    forall (a:Alphabet)(n:nat) (d:dfa n a)(q:Fin n)(xs ys zs :Word a) ,
   deltah d (q) (xs ++ ys ++ zs) =
    deltah d(deltah d (deltah d (q) xs) ys ) zs.
induction xs.
simpl.
induction ys.
simpl in *.
reflexivity.
simpl in *.
apply deltah_prop.

simpl in *.
intros.
assert (xs ++ ys ++ zs = (xs ++ ys)++ zs).
auto with *.
admit.

(*simpl in *.
induction xs.

induction zs.
simpl in *.
intuition.
assert (ys ++ nil = ys).
intuition.
 (*very well known property*)
rewrite H.
reflexivity.
simpl in *. *)

Qed.

Notation " x ^ y " := (exps x y).

Definition dfa_lang1 (n:nat)(a:Alphabet)(d: dfa n a) :Language a :=
  fun w:Word a => final  d (deltah  d(q0 d ) w)=true.

(** The actual definition of the language of a DFA *)

Definition dfa_lang (n:nat)(a:Alphabet)(d: dfa n a) :Language a :=
  fun w:Word a => match  final  d (deltah  d(q0 d ) w)  with
              | true => True
              | false => False
             end.

Check dfa_lang.
Check tt.

(** Empty automaton : a (initial )state with no final states*)

Definition dfa_void(q:Fin 1)(a:Alphabet) : dfa 1 a :=
          DFA (fun x:Fin 1 => fun b:Fin a => q ) q (fun x:Fin 1 => false).

Print dfa_void.

(** The empty automaton will not accept any word *)

Definition empty_lang (a:Alphabet):Language a:= fun w:Word a=>False.

Definition isNil (a:Alphabet) (w:Word a): Prop :=
    match w with  |nil => True
                  | _  => False
                              end.

Definition eps_lang (a:Alphabet) :Language a :=

             fun w:Word a=> w=nil.

              (*fun w:Word a => match w with  |nil => True
                                            | _  => False
                              end. *)

Definition eps_lang1 (a:Alphabet) :Language a :=
        fun w:Word a => w =nil.

Lemma dfa_void_correct: forall (a:Alphabet)(q:Fin 1) (w:Word a),
     dfa_lang (dfa_void q a) w -> empty_lang w.
intros.
unfold dfa_lang in H.
unfold empty_lang.
simpl in H.

auto with *.
Qed.

(*The automaton that will take the epsilon language *)

Print option.
Check (S (S 0)).
Definition dfa_epsilon (q:Fin 1)(a:Alphabet) : dfa (1) a :=
   DFA( fun _:Fin 1 => fun _:Fin a=> q) q   (fun x:Fin 1 => eqf q x).

Print dfa_epsilon.

Definition dfa_compl (a:Alphabet)(n:nat)(d:dfa n a) : dfa n a :=

   DFA( delta d) (q0 d) (fun q : Fin n=>

    negb (final d q)).
Inductive empty :Set := .
Inductive singleton :Set := emptyx : singleton.
Print emptyx.

(** Remove states that are unreachable !!! *)

Definition reachable_immediate (a:Alphabet) (n:nat) (d: dfa n a)(x y :Fin n)  :=

  exists c:Fin a,   (delta d x c) = y.

Definition reachable (a:Alphabet)(n:nat) (d:dfa n a) (y:Fin n) :=

   exists w:Word a , deltah d ( q0 d)w = y.

Definition isconnected (a:Alphabet)(n:nat) (d:dfa n a) :=

    forall (x:Fin n), exists w:Word a, deltah d (q0 d) w = x.

(** * Nondeterministic finite automaton

   A _nondeterministic finite automaton_ (NFA) A is defined as a 5-uple Q,$\Sigma $ , $\sigma $, S, F),
   where :

   - [Q] represent a finite set of initial states ( [nstates])

   - A set of symbols $\Sigma $ ([Fin a])

   - A transition function $\sigma $ : Q * $\Sigma $ -> $P (Q)$ ([ndelta])

   - A set of initial states [S] , denoted by [ninitial]

   - A set of final states [F], denoted by [nfinal].

*)

Record nfa (n:nat)(a:Alphabet) := NFA {

   nstates :=Fin n;
   nsymbol := Fin a;
   ndelta : Fin n-> Fin a  ->Fin (2^n);
   ninitial : Fin n -> bool (* multiple states*);
   nfinal : Fin n -> bool
 }.
Check nfa.

(** We want to generate the union of 2 sets, taking into account the isomorphism [(Fin n -> bool) <-> Fin (2^n)], proven in the library of

    finite sets. *)

Definition unionf (n:nat) (sets : (Fin n -> bool) -> bool) (x:Fin n) : bool :=
  existsf1 (fun q : Fin (2^n) => sets( allexp2 q) && allexp2 q x).

Definition prepare (n:nat)(a:Alphabet) (nr:nfa n a)(states : Fin (2^n)) (x:Fin a)  : (Fin n -> bool)  :=
   fun s : Fin n  => existsf1 (fun st : Fin n => allexp2 (states) (st) &&  allexp2(ndelta  nr st x) s).

(** The extended transition function for an NFA  [ndeltah]: *)

Fixpoint ndeltah (n : nat) (a:Alphabet) (nr: nfa n a) (qs : (Fin (2^ n))) (w:Word a) :(Fin (2^n)) :=
       match w with
     | nil    =>  qs
     | h :: t =>  (ndeltah nr (allexp1 (prepare nr qs h)) t)
       end.
(*Definition nfa_lang (n:nat)(a:Alphabet) (nr: nfa n a) :Language a :=
  fun w :Word a => (existsf1(fun q :Fin n=>( allexp2(ndeltah nr (allexp1 (ninitial nr) ) w)) q && (nfinal  nr q)))=true.
*)
Definition nfa_lang (n:nat)(a:Alphabet) (nr: nfa n a) :Language a :=
  fun w :Word a => match (existsf1(fun q :Fin n=>( allexp2(ndeltah nr (allexp1 (ninitial nr) ) w)) q && (nfinal  nr q))) with
                   | true => True
                  | false => False
                   end .
Definition nfa_lang1 (n:nat)(a:Alphabet) (nr: nfa n a) :Language a :=
  fun w :Word a => (existsf1(fun q :Fin n=>( allexp2(ndeltah nr (allexp1 (ninitial nr) ) w)) q && (nfinal  nr q)))=true.

(** * The subset construction *)

(*Convert a dfa to an nfa: *)

Definition dfa2nfa (n:nat) (a:Alphabet) (d:dfa n a): nfa n a :=
    NFA(fun k : Fin n => fun a : Fin a =>

     (allexp1 ( fun x:Fin n => eqf x (delta d k a) ))) (fun x:Fin n => eqf x (q0 d)) (final d).

(* union of ndelta *)

Definition nfa2dfa (n:nat) (a:Alphabet) (nr: nfa n a) : dfa (2^n) a :=

 DFA (fun k:Fin (2^n)=> fun a : Fin a => allexp1 (prepare nr k a)) (allexp1 (ninitial nr ))
    (fun k:Fin (2^n)=>existsf1(fun q:Fin n=> (allexp2 k q ) && nfinal nr  q)).

Definition nfa_void (a:Alphabet) : nfa 1 a :=
  NFA(fun x:Fin 1 => fun a:Fin a=> allexp1 (fun y:Fin 1 => false))
      (fun x:Fin 1 =>existsf1 (fun y:Fin 1 => eqf x y))
       (fun x:Fin 1 =>existsf1 (fun y:Fin 1 => false)).

Lemma nfa_void_lang :  forall (a:Alphabet)(w:Word a),
     nfa_lang (nfa_void a) w -> empty_lang w.
intros.
unfold empty_lang.
unfold nfa_lang in H.
simpl in H.
auto with *.

Qed.
Print eps.
(*
Definition chec (a:Alphabet) (p :Fin a) :=

 if (p::nil)=eps a then true else false.*)

Definition nfa_eps(a:Alphabet):nfa 1 a :=

  NFA(fun x:Fin 1 => fun a0:Fin a => allexp1 (fun y:Fin 1 => eqf x  y))
   (fun x:Fin 1 => true ) (fun x:Fin 1 => true).

Print nfa_eps.

Print option.

Lemma nfa_eps_lang1 : forall (a:Alphabet)(w:Word a) ,
     eps_lang w -> nfa_lang (nfa_eps a) w.
intros.
unfold eps_lang in H.
unfold nfa_lang.
simpl.
split.
Qed.
Lemma nfa_eps_lang :forall (a:Alphabet) (w:Word a) ,
   nfa_lang (nfa_eps a) w -> eps_lang w.
intros.
unfold eps_lang.

unfold nfa_lang in H.
simpl in *.

admit.
Qed.

(*
Definition nfa_var (a:Alphabet) :=

   NFA (fun xs : Fin 2 => fun c:Fin a =>

     allexp1 (fun ys : Fin 2 => eqf xs ys =false) )

     (fun xs :Fin 2 =>   *)

Definition nfa_var(a:Alphabet)(cc:Fin a)  :=
    NFA( fun it :Fin 2 => fun aa :Fin a =>  allexp1 (fun final:Fin 2=>if negb (eqf it final)&& eqf cc aa then true  else  false ))
      (fun x : Fin 2 => existsf1 (fun y: Fin 2 => eqf x y) )
    (fun x:Fin 2 => existsf1 ( fun y :Fin 2 => eqf x y)).

Print nfa_var.
(*
Definition nfa_var1(a:Alphabet)(x:Fin a) : nfa 2 a:=

   NFA (fun xs :Fin 2 => fun c :Fin a => allexp1(existsf1(fun y:Fin 2 =>
           end))) tt tt. *)

Definition single_lang (a:Alphabet):Language a:=
  fun w =>

match w with
        | a::nil => True
        | _ => False
     end.
Print single_lang.

Definition single_lang1 (a:Alphabet)(x:Fin a) :Language a :=
  fun w : Word a => match w with

     | p :: nil => if eqf p x then True else False
     | _ => False
    end.
Lemma nfa_var_lang : forall (a:Alphabet)(w:Word a)(cc:Fin a) ,
    nfa_lang (nfa_var  cc) w -> single_lang1 cc w.
intros.
unfold nfa_lang in H.
(*intuition.
(*We want to prove that in an nfa with the epsilon language does not accept a word
different from <nil>  useful in the theorem of correctness nfa_eps_lang *)
rewrite H0 in H.
assert(False). *)
unfold nfa_var in *.
simpl in *.
unfold single_lang1.
simpl.
admit.
Qed.
Print nfa_var.

Print sum.
Print prod.

Definition condition1 (a:Alphabet)(p q :nat) (c:Fin a) (n1:nfa p a)(n2:nfa q a) (xd : Fin (p+q)) : bool :=

         match (addfin1 p q xd) with
        | inl x => existsf1 (fun tx:Fin(2^p) => eqf tx (ndelta n1 x c))

        | inr y => existsf1 (fun ty :Fin (2^q) => eqf ty (ndelta n2 y c))

       end.

Definition nfa_disj (a:Alphabet)(p q :nat) (n1:nfa p a)(n2:nfa q a) : nfa(p+q) a :=

    NFA( fun xs : Fin (p+q) => fun c:Fin a =>

    allexp1 (fun xss :Fin (p+q) => eqf xs xss &&  condition1 c n1 n2 xss))

    (fun xs :Fin (p+q) =>

       match (addfin1 p q xs) with

          | inl x => ninitial n1 x

          | inr y => ninitial n2 y

     end)

    (fun xs :Fin (p+q)  =>

       match (addfin1 p q xs) with

          | inl x => nfinal n1 x

          | inr y => nfinal n2 y

     end) .

Definition lang_conc(a:Alphabet)(l1:Language a)(l2:Language a):Language a:=
    fun w:Word a=> exists w1:Word a, exists w2:Word a,  w1 ++ w2=w /\ l1 w1 /\ l2 w2.

Definition lang_union(a:Alphabet) (l1:Language a )(l2:Language a):Language a:=
    fun w:Word a=>  l1 w \/ l2 w.
Print nfa_lang1.
Lemma nfa_disj_lang : forall (a:Alphabet) (p q:nat) (n1: nfa p a) (n2: nfa q a) (w:Word a),

        nfa_lang1 ( nfa_disj n1 n2 ) w -> lang_union (nfa_lang1 n1  ) (nfa_lang1 n2 ) w.
intros.
unfold lang_union.
unfold nfa_lang1 in *.
simpl.
simpl in *.
set( PP:= fun qx :Fin (p+q) => match addfin1 p q qx with
  | inl x => nfinal n1 x

  | inr y => nfinal n2 y end).

left.
admit.
Qed.

Lemma nfa_disj_lang1 : forall (a:Alphabet) (p q:nat) (n1: nfa p a) (n2: nfa q a) (w:Word a),

       lang_union (nfa_lang1 n1  ) (nfa_lang1 n2 ) w -> nfa_lang1 ( nfa_disj n1 n2 ) w.
intros.
unfold lang_union in *.
unfold nfa_lang1 in *.
destruct H.
simpl in *.
set( PP:= fun qx :Fin (p+q) => match addfin1 p q qx with
  | inl x => nfinal n1 x

  | inr y => nfinal n2 y end).

set (pp:= fun q :Fin p => nfinal n1 q).
admit.

simpl in *.
admit.

(*
intros.
unfold lang_union.
unfold nfa_lang.
simpl in *.
unfold nfa_lang in H.
simpl in *.
left.
case_eq( existsf1(fun q1:Fin p => nfinal n1 q1)).
intro.
split.
intro.

left.*)

Qed.

Eval compute in existsf1( fun y: Fin 3=>(existsf1 (fun x:Fin 2 => true&& false))).

Print sum.

(*Inductive empty :Set := .*)
(**For a set with a single element, we consider an element x defined itself on  the singleton.

*)
(*Inductive singleton :Set := emptyx : singleton.  *)

Check (inr  emptyx).
Check existsf1(fun (t:Fin 2)=> existsf1 (fun o : Fin 2 => eqf t o )).

Print nfa_disj.

Check ( fun (c:Fin 2) => fun (d:Fin 3)=> inr (Fin 3) c).

Definition nfa_conc(a:Alphabet)(p q:nat) (n1:nfa p a) (n2:nfa q a) : nfa( p+q) a:=

    NFA( fun xs:(Fin (p+q)) => fun c:Fin a=>
  ( allexp1( fun xss:Fin (p+q) => eqf xss xs && (  existsf1 (fun x:Fin p=> existsf1(fun y:Fin q =>

          (*
      match addfin1 x , addfin1 y with

      | inl x , inl y =>  existsf1 (fun t:Fin (2^p) => (eqf(ndelta n1 x c) t))

      | inl x, inr y =>  (nfinal n1 x) && ndelta (n2) *)

         match (addfin1 p q xs) with
       | inl  x => existsf1 (fun t:Fin (2^p) => (eqf(ndelta n1 x c) t)) ||

                          existsf1 (fun q'': Fin q => existsf1 (fun q' :Fin p =>

                     existsf1 (fun tx:Fin (2^p)=>

                        (nfinal n1 q') && (ninitial n2 q'') && (allexp2 (ndelta n1 x c) q'))))

       | inr  y => existsf1( fun tr: Fin (2^q) => (eqf(ndelta n2 y c) tr))

        end ))))))
      (fun xs :Fin (p+q) =>
          existsf1(fun x:Fin p => existsf1(fun y:Fin q =>

           match  (addfin1 p q xs) with
         | inl x =>  ninitial n1 x

         | inr y => nfinal n2 y && existsf1( fun t: Fin p => ninitial n1 t && nfinal n1 t)

         end)))

     (fun xs :Fin (p+q) =>
        existsf1 (fun x:Fin p=> existsf1(fun y:Fin q =>
           match  (addfin1 p q xs) with

         | inl x =>  false

         | inr y => nfinal n2 y
        end ))).

Print nfa_conc.

Lemma nfa_conc1 : forall (a:Alphabet) (p q:nat)
        (n1 :nfa p a) (n2 : nfa q a)  (w:Word a) ,

   nfa_lang1 (nfa_conc n1 n2) w -> lang_conc (nfa_lang1 n1) (nfa_lang1 n2) w.

intros.
unfold lang_conc in *.
unfold nfa_lang1 in *.
simpl in *.
admit . (*??*)
Qed.
Definition nfa_star (a:Alphabet) (p:nat) (n1:nfa p a) : nfa (p+1) a :=

    NFA( fun xs:Fin (p+1) => fun c:Fin a=>

    allexp1 (fun xss:Fin(p+1) => eqf xs xss && existsf1( fun _:Fin p =>

        match (addfin1 p 1 xs) with

     | inl x => existsf1 (fun tx:Fin (2^p) => eqf tx (ndelta n1 x c)) ||

                existsf1 (fun q' :Fin p => existsf1 (fun tx:Fin (p) =>

                           (ninitial n1 q') &&  (allexp2  (ndelta n1 x c) tx )&& (nfinal n1 tx)))

     | inr y => false

   end )))

    (fun xs:Fin (p+1) =>

        match (addfin1 p 1 xs) with

    | inl x => ninitial n1 x

    | inr y => true

       end)

     (fun xs:Fin (p+1) =>

        match (addfin1 p 1 xs) with

    | inl x => nfinal n1 x

    | inr y => true

       end) .

Lemma nfa_eps_lang12 :  forall (a:Alphabet)(w:Word a),
     nfa_lang1 (nfa_eps a) w -> eps_lang1 w.

intros.
unfold nfa_lang1 in H.

unfold eps_lang1.

simpl in *.
destruct w.
split.
inversion H.
induction w.
simpl.

simpl. (*
rewrite IHw.

simpl in H.
simpl in IHw.
inversion H.
simpl in IHw.
unfold isNil in IHw.*)
(*induction w.
split.
simpl in H.
simpl in IHw.
apply IHw in H.
simpl in H. *)

admit.
admit.
Qed.
Check negb.
Print negb.
Check inl.

Lemma dfa2nfa_correct2 : forall (n:nat)(a:Alphabet)(w:Word a)(d:dfa n a),
              dfa_lang d w-> nfa_lang (dfa2nfa d)w.
intros.
unfold dfa_lang in H.
unfold nfa_lang.
simpl.

case_eq (existsf1 (fun q:Fin n => final d q)).
intros.
split.
intro.
assert( final d (deltah d (q0 d) w)=false).
admit.

(*must prove that if there is no state that is final, then
also the initial state cannot be final, taken as a particular case of the problem *)

rewrite H1 in H.
destruct H.
(*reflexivity.*)
Qed.

Lemma dfa2nfa_correct1 : forall (n:nat)(a:Alphabet)(w:Word a)(d:dfa n a),
               nfa_lang (dfa2nfa d)w-> dfa_lang d w .
(*intros.
unfold nfa_lang1 in *.
unfold dfa_lang1 in *.
simpl in *.*)

intros.
unfold nfa_lang in H.
simpl in H.
unfold dfa_lang.
simpl.
simpl in H.
case_eq (existsf1 (fun q:Fin n => final d q)).
intro.
simpl.
simpl in *.
rewrite H0 in H.

case_eq (final d (deltah d (q0 d) w)).
split.
intro.
admit.
intro.

rewrite H0 in H.
destruct H.
Qed.

Theorem nfa2dfa_correct1 :forall (n:nat)(a:Alphabet)(w:Word a) (nr:nfa n a),
       dfa_lang (nfa2dfa nr) w -> nfa_lang nr w.
Proof.
intros.
unfold dfa_lang in H.
unfold nfa_lang.
simpl in H.
simpl.
exact H.
Qed.

Theorem nfa2dfa_correct2: forall (n:nat)(a:Alphabet)(w:Word a) (nr:nfa n a),
       nfa_lang nr w -> dfa_lang (nfa2dfa nr) w.
Proof.
intros.
unfold dfa_lang.
unfold nfa_lang in H.
simpl.
simpl in H.
assumption.
Qed.

(*Lemma for the equivalence of extended transition functions of a DFA and an NFA*)
Lemma eqref: forall (n:nat) (p :Fin n)  , equalsf p p =true.
intros.
induction n.
simpl.

assert (False).
apply fin0empty.
exact p.
destruct H.

unfold equalsf.
unfold equalsf in IHn.
simpl.
admit. (*prove inductive step *)
Qed.
Lemma ext_delta_coincide: forall (n:nat)(a:Alphabet) (nr:nfa n a)(w:Word a) ,
    eqf (ndeltah nr  (allexp1(ninitial nr)) w)(deltah (nfa2dfa nr) (q0 (nfa2dfa nr)) w)=true.

intros.
unfold eqf.
simpl.
induction w.
simpl.
rewrite eqref.

reflexivity.

set(P:=deltah (nfa2dfa nr) (allexp1 (ninitial nr )) w).

assert(deltah (nfa2dfa nr) (allexp1 (ninitial nr)) (a0:: w) =

      (deltah (nfa2dfa nr) (delta  (nfa2dfa nr) (allexp1 (ninitial nr)) a0 ) w)).
simpl.
reflexivity.
simpl.
trivial.

Qed.

End Automata.


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(**************************************************************)
(* MSetDecide.v                                               *)
(*                                                            *)
(* Author: Aaron Bohannon                                     *)
(**************************************************************)

(** This file implements a decision procedure for a certain
    class of propositions involving finite sets.  *)

Require Import Decidable DecidableTypeEx MSetFacts.

(** First, a version for Weak Sets in functorial presentation *)

Module WDecideOn (E : DecidableType)(Import M : WSetsOn E).
 Module F := MSetFacts.WFactsOn E M.

(** * Overview
    This functor defines the tactic [fsetdec], which will
    solve any valid goal of the form
<<
    forall s1 ... sn,
    forall x1 ... xm,
    P1 -> ... -> Pk -> P
>>
    where [P]'s are defined by the grammar:
<<

P ::=
| Q
| Empty F
| Subset F F'
| Equal F F'

Q ::=
| E.eq X X'
| In X F
| Q /\ Q'
| Q \/ Q'
| Q -> Q'
| Q <-> Q'
| ~ Q
| True
| False

F ::=
| S
| empty
| singleton X
| add X F
| remove X F
| union F F'
| inter F F'
| diff F F'

X ::= x1 | ... | xm
S ::= s1 | ... | sn

>>

The tactic will also work on some goals that vary slightly from
the above form:
- The variables and hypotheses may be mixed in any order and may
  have already been introduced into the context.  Moreover,
  there may be additional, unrelated hypotheses mixed in (these
  will be ignored).
- A conjunction of hypotheses will be handled as easily as
  separate hypotheses, i.e., [P1 /\ P2 -> P] can be solved iff
  [P1 -> P2 -> P] can be solved.
- [fsetdec] should solve any goal if the MSet-related hypotheses
  are contradictory.
- [fsetdec] will first perform any necessary zeta and beta
  reductions and will invoke [subst] to eliminate any Coq
  equalities between finite sets or their elements.
- If [E.eq] is convertible with Coq's equality, it will not
  matter which one is used in the hypotheses or conclusion.
- The tactic can solve goals where the finite sets or set
  elements are expressed by Coq terms that are more complicated
  than variables.  However, non-local definitions are not
  expanded, and Coq equalities between non-variable terms are
  not used.  For example, this goal will be solved:
<<
    forall (f : t -> t),
    forall (g : elt -> elt),
    forall (s1 s2 : t),
    forall (x1 x2 : elt),
    Equal s1 (f s2) ->
    E.eq x1 (g (g x2)) ->
    In x1 s1 ->
    In (g (g x2)) (f s2)
>>
  This one will not be solved:
<<
    forall (f : t -> t),
    forall (g : elt -> elt),
    forall (s1 s2 : t),
    forall (x1 x2 : elt),
    Equal s1 (f s2) ->
    E.eq x1 (g x2) ->
    In x1 s1 ->
    g x2 = g (g x2) ->
    In (g (g x2)) (f s2)
>>
*)

  (** * Facts and Tactics for Propositional Logic
      These lemmas and tactics are in a module so that they do
      not affect the namespace if you import the enclosing
      module [Decide]. *)
  Module MSetLogicalFacts.
    Require Export Decidable.
    Require Export Setoid.

    (** ** Lemmas and Tactics About Decidable Propositions *)

    (** ** Propositional Equivalences Involving Negation
        These are all written with the unfolded form of
        negation, since I am not sure if setoid rewriting will
        always perform conversion. *)

    (** ** Tactics for Negations *)

    Tactic Notation "fold" "any" "not" :=
      repeat (
        match goal with
        | H: context [?P -> False] |- _ =>
          fold (~ P) in H
        | |- context [?P -> False] =>
          fold (~ P)
        end).

    (** [push not using db] will pushes all negations to the
        leaves of propositions in the goal, using the lemmas in
        [db] to assist in checking the decidability of the
        propositions involved.  If [using db] is omitted, then
        [core] will be used.  Additional versions are provided
        to manipulate the hypotheses or the hypotheses and goal
        together.

        XXX: This tactic and the similar subsequent ones should
        have been defined using [autorewrite]. However, dealing
        with multiples rewrite sites and side-conditions is
        done more cleverly with the following explicit
        analysis of goals. *)

    Ltac or_not_l_iff P Q tac :=
      (rewrite (or_not_l_iff_1 P Q) by tac) ||
      (rewrite (or_not_l_iff_2 P Q) by tac).

    Ltac or_not_r_iff P Q tac :=
      (rewrite (or_not_r_iff_1 P Q) by tac) ||
      (rewrite (or_not_r_iff_2 P Q) by tac).

    Ltac or_not_l_iff_in P Q H tac :=
      (rewrite (or_not_l_iff_1 P Q) in H by tac) ||
      (rewrite (or_not_l_iff_2 P Q) in H by tac).

    Ltac or_not_r_iff_in P Q H tac :=
      (rewrite (or_not_r_iff_1 P Q) in H by tac) ||
      (rewrite (or_not_r_iff_2 P Q) in H by tac).

    Tactic Notation "push" "not" "using" ident(db) :=
      let dec := solve_decidable using db in
      unfold not, iff;
      repeat (
        match goal with
        | |- context [True -> False] => rewrite not_true_iff
        | |- context [False -> False] => rewrite not_false_iff
        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
        | |- context [(?P -> False) -> (?Q -> False)] =>
            rewrite (contrapositive P Q) by dec
        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
        | |- context [?P \/ ?Q -> False] => rewrite (not_or_iff P Q)
        | |- context [?P /\ ?Q -> False] => rewrite (not_and_iff P Q)
        | |- context [(?P -> ?Q) -> False] => rewrite (not_imp_iff P Q) by dec
        end);
      fold any not.

    Tactic Notation "push" "not" :=
      push not using core.

    Tactic Notation
      "push" "not" "in" "*" "|-" "using" ident(db) :=
      let dec := solve_decidable using db in
      unfold not, iff in * |-;
      repeat (
        match goal with
        | H: context [True -> False] |- _ => rewrite not_true_iff in H
        | H: context [False -> False] |- _ => rewrite not_false_iff in H
        | H: context [(?P -> False) -> False] |- _ =>
          rewrite (not_not_iff P) in H by dec
        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
          rewrite (contrapositive P Q) in H by dec
        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
        | H: context [(?P -> False) -> ?Q] |- _ =>
          rewrite (imp_not_l P Q) in H by dec
        | H: context [?P \/ ?Q -> False] |- _ => rewrite (not_or_iff P Q) in H
        | H: context [?P /\ ?Q -> False] |- _ => rewrite (not_and_iff P Q) in H
        | H: context [(?P -> ?Q) -> False] |- _ =>
          rewrite (not_imp_iff P Q) in H by dec
        end);
      fold any not.

    Tactic Notation "push" "not" "in" "*" "|-"  :=
      push not in * |- using core.

    Tactic Notation "push" "not" "in" "*" "using" ident(db) :=
      push not using db; push not in * |- using db.
    Tactic Notation "push" "not" "in" "*" :=
      push not in * using core.

    (** A simple test case to see how this works.  *)
    Lemma test_push : forall P Q R : Prop,
      decidable P ->
      decidable Q ->
      (~ True) ->
      (~ False) ->
      (~ ~ P) ->
      (~ (P /\ Q) -> ~ R) ->
      ((P /\ Q) \/ ~ R) ->
      (~ (P /\ Q) \/ R) ->
      (R \/ ~ (P /\ Q)) ->
      (~ R \/ (P /\ Q)) ->
      (~ P -> R) ->
      (~ ((R -> P) \/ (Q -> R))) ->
      (~ (P /\ R)) ->
      (~ (P -> R)) ->
      True.
    Proof.
      intros. push not in *.
       (* note that ~(R->P) remains (since R isnt decidable) *)
      tauto.
    Qed.

    (** [pull not using db] will pull as many negations as
        possible toward the top of the propositions in the goal,
        using the lemmas in [db] to assist in checking the
        decidability of the propositions involved.  If [using
        db] is omitted, then [core] will be used.  Additional
        versions are provided to manipulate the hypotheses or
        the hypotheses and goal together. *)

    Tactic Notation "pull" "not" "using" ident(db) :=
      let dec := solve_decidable using db in
      unfold not, iff;
      repeat (
        match goal with
        | |- context [True -> False] => rewrite not_true_iff
        | |- context [False -> False] => rewrite not_false_iff
        | |- context [(?P -> False) -> False] => rewrite (not_not_iff P) by dec
        | |- context [(?P -> False) -> (?Q -> False)] =>
          rewrite (contrapositive P Q) by dec
        | |- context [(?P -> False) \/ ?Q] => or_not_l_iff P Q dec
        | |- context [?P \/ (?Q -> False)] => or_not_r_iff P Q dec
        | |- context [(?P -> False) -> ?Q] => rewrite (imp_not_l P Q) by dec
        | |- context [(?P -> False) /\ (?Q -> False)] =>
          rewrite <- (not_or_iff P Q)
        | |- context [?P -> ?Q -> False] => rewrite <- (not_and_iff P Q)
        | |- context [?P /\ (?Q -> False)] => rewrite <- (not_imp_iff P Q) by dec
        | |- context [(?Q -> False) /\ ?P] =>
          rewrite <- (not_imp_rev_iff P Q) by dec
        end);
      fold any not.

    Tactic Notation "pull" "not" :=
      pull not using core.

    Tactic Notation
      "pull" "not" "in" "*" "|-" "using" ident(db) :=
      let dec := solve_decidable using db in
      unfold not, iff in * |-;
      repeat (
        match goal with
        | H: context [True -> False] |- _ => rewrite not_true_iff in H
        | H: context [False -> False] |- _ => rewrite not_false_iff in H
        | H: context [(?P -> False) -> False] |- _ =>
          rewrite (not_not_iff P) in H by dec
        | H: context [(?P -> False) -> (?Q -> False)] |- _ =>
          rewrite (contrapositive P Q) in H by dec
        | H: context [(?P -> False) \/ ?Q] |- _ => or_not_l_iff_in P Q H dec
        | H: context [?P \/ (?Q -> False)] |- _ => or_not_r_iff_in P Q H dec
        | H: context [(?P -> False) -> ?Q] |- _ =>
          rewrite (imp_not_l P Q) in H by dec
        | H: context [(?P -> False) /\ (?Q -> False)] |- _ =>
          rewrite <- (not_or_iff P Q) in H
        | H: context [?P -> ?Q -> False] |- _ =>
          rewrite <- (not_and_iff P Q) in H
        | H: context [?P /\ (?Q -> False)] |- _ =>
          rewrite <- (not_imp_iff P Q) in H by dec
        | H: context [(?Q -> False) /\ ?P] |- _ =>
          rewrite <- (not_imp_rev_iff P Q) in H by dec
        end);
      fold any not.

    Tactic Notation "pull" "not" "in" "*" "|-"  :=
      pull not in * |- using core.

    Tactic Notation "pull" "not" "in" "*" "using" ident(db) :=
      pull not using db; pull not in * |- using db.
    Tactic Notation "pull" "not" "in" "*" :=
      pull not in * using core.

    (** A simple test case to see how this works.  *)
    Lemma test_pull : forall P Q R : Prop,
      decidable P ->
      decidable Q ->
      (~ True) ->
      (~ False) ->
      (~ ~ P) ->
      (~ (P /\ Q) -> ~ R) ->
      ((P /\ Q) \/ ~ R) ->
      (~ (P /\ Q) \/ R) ->
      (R \/ ~ (P /\ Q)) ->
      (~ R \/ (P /\ Q)) ->
      (~ P -> R) ->
      (~ (R -> P) /\ ~ (Q -> R)) ->
      (~ P \/ ~ R) ->
      (P /\ ~ R) ->
      (~ R /\ P) ->
      True.
    Proof.
      intros. pull not in *. tauto.
    Qed.

  End MSetLogicalFacts.
  Import MSetLogicalFacts.

  (** * Auxiliary Tactics
      Again, these lemmas and tactics are in a module so that
      they do not affect the namespace if you import the
      enclosing module [Decide].  *)
  Module MSetDecideAuxiliary.

    (** ** Generic Tactics
        We begin by defining a few generic, useful tactics. *)

    (** remove logical hypothesis inter-dependencies (fix #2136). *)

    Ltac no_logical_interdep :=
      match goal with
        | H : ?P |- _ =>
          match type of P with
            | Prop =>
              match goal with H' : context [ H ] |- _ => clear dependent H' end
            | _ => fail
          end; no_logical_interdep
        | _ => idtac
      end.

    (** [if t then t1 else t2] executes [t] and, if it does not
        fail, then [t1] will be applied to all subgoals
        produced.  If [t] fails, then [t2] is executed. *)
    Tactic Notation
      "if" tactic(t)
      "then" tactic(t1)
      "else" tactic(t2) :=
      first [ t; first [ t1 | fail 2 ] | t2 ].

    (** [prop P holds by t] succeeds (but does not modify the
        goal or context) if the proposition [P] can be proved by
        [t] in the current context.  Otherwise, the tactic
        fails. *)
    Tactic Notation "prop" constr(P) "holds" "by" tactic(t) :=
      let H := fresh in
      assert P as H by t;
      clear H.

    (** This tactic acts just like [assert ... by ...] but will
        fail if the context already contains the proposition. *)
    Tactic Notation "assert" "new" constr(e) "by" tactic(t) :=
      match goal with
      | H: e |- _ => fail 1
      | _ => assert e by t
      end.

    (** [subst++] is similar to [subst] except that
        - it never fails (as [subst] does on recursive
          equations),
        - it substitutes locally defined variable for their
          definitions,
        - it performs beta reductions everywhere, which may
          arise after substituting a locally defined function
          for its definition.
        *)
    Tactic Notation "subst" "++" :=
      repeat (
        match goal with
        | x : _ |- _ => subst x
        end);
      cbv zeta beta in *.

    (** [decompose records] calls [decompose record H] on every
        relevant hypothesis [H]. *)
    Tactic Notation "decompose" "records" :=
      repeat (
        match goal with
        | H: _ |- _ => progress (decompose record H); clear H
        end).

    (** ** Discarding Irrelevant Hypotheses
        We will want to clear the context of any
        non-MSet-related hypotheses in order to increase the
        speed of the tactic.  To do this, we will need to be
        able to decide which are relevant.  We do this by making
        a simple inductive definition classifying the
        propositions of interest. *)

    Inductive MSet_elt_Prop : Prop -> Prop :=
    | eq_Prop : forall (S : Type) (x y : S),
        MSet_elt_Prop (x = y)
    | eq_elt_prop : forall x y,
        MSet_elt_Prop (E.eq x y)
    | In_elt_prop : forall x s,
        MSet_elt_Prop (In x s)
    | True_elt_prop :
        MSet_elt_Prop True
    | False_elt_prop :
        MSet_elt_Prop False
    | conj_elt_prop : forall P Q,
        MSet_elt_Prop P ->
        MSet_elt_Prop Q ->
        MSet_elt_Prop (P /\ Q)
    | disj_elt_prop : forall P Q,
        MSet_elt_Prop P ->
        MSet_elt_Prop Q ->
        MSet_elt_Prop (P \/ Q)
    | impl_elt_prop : forall P Q,
        MSet_elt_Prop P ->
        MSet_elt_Prop Q ->
        MSet_elt_Prop (P -> Q)
    | not_elt_prop : forall P,
        MSet_elt_Prop P ->
        MSet_elt_Prop (~ P).

    Inductive MSet_Prop : Prop -> Prop :=
    | elt_MSet_Prop : forall P,
        MSet_elt_Prop P ->
        MSet_Prop P
    | Empty_MSet_Prop : forall s,
        MSet_Prop (Empty s)
    | Subset_MSet_Prop : forall s1 s2,
        MSet_Prop (Subset s1 s2)
    | Equal_MSet_Prop : forall s1 s2,
        MSet_Prop (Equal s1 s2).

    (** Here is the tactic that will throw away hypotheses that
        are not useful (for the intended scope of the [fsetdec]
        tactic). *)
    Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop.
    Ltac discard_nonMSet :=
      decompose records;
      repeat (
        match goal with
        | H : ?P |- _ =>
          if prop (MSet_Prop P) holds by
            (auto 100 with MSet_Prop)
          then fail
          else clear H
        end).

    (** ** Turning Set Operators into Propositional Connectives
        The lemmas from [MSetFacts] will be used to break down
        set operations into propositional formulas built over
        the predicates [In] and [E.eq] applied only to
        variables.  We are going to use them with [autorewrite].
        *)

    Hint Rewrite
      F.empty_iff F.singleton_iff F.add_iff F.remove_iff
      F.union_iff F.inter_iff F.diff_iff
    : set_simpl.

    (** ** Decidability of MSet Propositions *)

    (** [In] is decidable. *)
    Lemma dec_In : forall x s,
      decidable (In x s).
    Proof.
      red; intros; generalize (F.mem_iff s x); case (mem x s); intuition.
    Qed.

    (** [E.eq] is decidable. *)
    Lemma dec_eq : forall (x y : E.t),
      decidable (E.eq x y).
    Proof.
      red; intros x y; destruct (E.eq_dec x y); auto.
    Qed.

    (** The hint database [MSet_decidability] will be given to
        the [push_neg] tactic from the module [Negation]. *)
    Hint Resolve dec_In dec_eq : MSet_decidability.

    (** ** Normalizing Propositions About Equality
        We have to deal with the fact that [E.eq] may be
        convertible with Coq's equality.  Thus, we will find the
        following tactics useful to replace one form with the
        other everywhere. *)

    (** The next tactic, [Logic_eq_to_E_eq], mentions the term
        [E.t]; thus, we must ensure that [E.t] is used in favor
        of any other convertible but syntactically distinct
        term. *)
    Ltac change_to_E_t :=
      repeat (
        match goal with
        | H : ?T |- _ =>
          progress (change T with E.t in H);
          repeat (
            match goal with
            | J : _ |- _ => progress (change T with E.t in J)
            | |- _ => progress (change T with E.t)
            end )
        | H : forall x : ?T, _ |- _ =>
          progress (change T with E.t in H);
          repeat (
            match goal with
            | J : _ |- _ => progress (change T with E.t in J)
            | |- _ => progress (change T with E.t)
            end )
       end).

    (** These two tactics take us from Coq's built-in equality
        to [E.eq] (and vice versa) when possible. *)

    Ltac Logic_eq_to_E_eq :=
      repeat (
        match goal with
        | H: _ |- _ =>
          progress (change (@Logic.eq E.t) with E.eq in H)
        | |- _ =>
          progress (change (@Logic.eq E.t) with E.eq)
        end).

    Ltac E_eq_to_Logic_eq :=
      repeat (
        match goal with
        | H: _ |- _ =>
          progress (change E.eq with (@Logic.eq E.t) in H)
        | |- _ =>
          progress (change E.eq with (@Logic.eq E.t))
        end).

    (** This tactic works like the built-in tactic [subst], but
        at the level of set element equality (which may not be
        the convertible with Coq's equality). *)
    Ltac substMSet :=
      repeat (
        match goal with
        | H: E.eq ?x ?y |- _ => rewrite H in *; clear H
        end).

    (** ** Considering Decidability of Base Propositions
        This tactic adds assertions about the decidability of
        [E.eq] and [In] to the context.  This is necessary for
        the completeness of the [fsetdec] tactic.  However, in
        order to minimize the cost of proof search, we should be
        careful to not add more than we need.  Once negations
        have been pushed to the leaves of the propositions, we
        only need to worry about decidability for those base
        propositions that appear in a negated form. *)
    Ltac assert_decidability :=
      (** We actually don't want these rules to fire if the
          syntactic context in the patterns below is trivially
          empty, but we'll just do some clean-up at the
          afterward.  *)
      repeat (
        match goal with
        | H: context [~ E.eq ?x ?y] |- _ =>
          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
        | H: context [~ In ?x ?s] |- _ =>
          assert new (In x s \/ ~ In x s) by (apply dec_In)
        | |- context [~ E.eq ?x ?y] =>
          assert new (E.eq x y \/ ~ E.eq x y) by (apply dec_eq)
        | |- context [~ In ?x ?s] =>
          assert new (In x s \/ ~ In x s) by (apply dec_In)
        end);
      (** Now we eliminate the useless facts we added (because
          they would likely be very harmful to performance). *)
      repeat (
        match goal with
        | _: ~ ?P, H : ?P \/ ~ ?P |- _ => clear H
        end).

    (** ** Handling [Empty], [Subset], and [Equal]
        This tactic instantiates universally quantified
        hypotheses (which arise from the unfolding of [Empty],
        [Subset], and [Equal]) for each of the set element
        expressions that is involved in some membership or
        equality fact.  Then it throws away those hypotheses,
        which should no longer be needed. *)
    Ltac inst_MSet_hypotheses :=
      repeat (
        match goal with
        | H : forall a : E.t, _,
          _ : context [ In ?x _ ] |- _ =>
          let P := type of (H x) in
          assert new P by (exact (H x))
        | H : forall a : E.t, _
          |- context [ In ?x _ ] =>
          let P := type of (H x) in
          assert new P by (exact (H x))
        | H : forall a : E.t, _,
          _ : context [ E.eq ?x _ ] |- _ =>
          let P := type of (H x) in
          assert new P by (exact (H x))
        | H : forall a : E.t, _
          |- context [ E.eq ?x _ ] =>
          let P := type of (H x) in
          assert new P by (exact (H x))
        | H : forall a : E.t, _,
          _ : context [ E.eq _ ?x ] |- _ =>
          let P := type of (H x) in
          assert new P by (exact (H x))
        | H : forall a : E.t, _
          |- context [ E.eq _ ?x ] =>
          let P := type of (H x) in
          assert new P by (exact (H x))
        end);
      repeat (
        match goal with
        | H : forall a : E.t, _ |- _ =>
          clear H
        end).

    (** ** The Core [fsetdec] Auxiliary Tactics *)

    (** Here is the crux of the proof search.  Recursion through
        [intuition]!  (This will terminate if I correctly
        understand the behavior of [intuition].) *)
    Ltac fsetdec_rec :=
      try (match goal with
      | H: E.eq ?x ?x -> False |- _ => destruct H
      end);
      (reflexivity ||
      contradiction ||
      (progress substMSet; intuition fsetdec_rec)).

    (** If we add [unfold Empty, Subset, Equal in *; intros;] to
        the beginning of this tactic, it will satisfy the same
        specification as the [fsetdec] tactic; however, it will
        be much slower than necessary without the pre-processing
        done by the wrapper tactic [fsetdec]. *)
    Ltac fsetdec_body :=
      inst_MSet_hypotheses;
      autorewrite with set_simpl in *;
      push not in * using MSet_decidability;
      substMSet;
      assert_decidability;
      auto using (@Equivalence_Reflexive _ _ E.eq_equiv);
      (intuition fsetdec_rec) ||
      fail 1
        "because the goal is beyond the scope of this tactic".

  End MSetDecideAuxiliary.
  Import MSetDecideAuxiliary.

  (** * The [fsetdec] Tactic
      Here is the top-level tactic (the only one intended for
      clients of this library).  It's specification is given at
      the top of the file. *)
  Ltac fsetdec :=
    (** We first unfold any occurrences of [iff]. *)
    unfold iff in *;
    (** We fold occurrences of [not] because it is better for
        [intros] to leave us with a goal of [~ P] than a goal of
        [False]. *)
    fold any not; intros;
    (** We remove dependencies to logical hypothesis. This way,
        later "clear" will work nicely (see bug #2136) *)
    no_logical_interdep;
    (** Now we decompose conjunctions, which will allow the
        [discard_nonMSet] and [assert_decidability] tactics to
        do a much better job. *)
    decompose records;
    discard_nonMSet;
    (** We unfold these defined propositions on finite sets.  If
        our goal was one of them, then have one more item to
        introduce now. *)
    unfold Empty, Subset, Equal in *; intros;
    (** We now want to get rid of all uses of [=] in favor of
        [E.eq].  However, the best way to eliminate a [=] is in
        the context is with [subst], so we will try that first.
        In fact, we may as well convert uses of [E.eq] into [=]
        when possible before we do [subst] so that we can even
        more mileage out of it.  Then we will convert all
        remaining uses of [=] back to [E.eq] when possible.  We
        use [change_to_E_t] to ensure that we have a canonical
        name for set elements, so that [Logic_eq_to_E_eq] will
        work properly.  *)
    change_to_E_t; E_eq_to_Logic_eq; subst++; Logic_eq_to_E_eq;
    (** The next optimization is to swap a negated goal with a
        negated hypothesis when possible.  Any swap will improve
        performance by eliminating the total number of
        negations, but we will get the maximum benefit if we
        swap the goal with a hypotheses mentioning the same set
        element, so we try that first.  If we reach the fourth
        branch below, we attempt any swap.  However, to maintain
        completeness of this tactic, we can only perform such a
        swap with a decidable proposition; hence, we first test
        whether the hypothesis is an [MSet_elt_Prop], noting
        that any [MSet_elt_Prop] is decidable. *)
    pull not using MSet_decidability;
    unfold not in *;
    match goal with
    | H: (In ?x ?r) -> False |- (In ?x ?s) -> False =>
      contradict H; fsetdec_body
    | H: (In ?x ?r) -> False |- (E.eq ?x ?y) -> False =>
      contradict H; fsetdec_body
    | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False =>
      contradict H; fsetdec_body
    | H: ?P -> False |- ?Q -> False =>
      if prop (MSet_elt_Prop P) holds by
        (auto 100 with MSet_Prop)
      then (contradict H; fsetdec_body)
      else fsetdec_body
    | |- _ =>
      fsetdec_body
    end.

  (** * Examples *)

  Module MSetDecideTestCases.

    Lemma test_eq_trans_1 : forall x y z s,
      E.eq x y ->
      ~ ~ E.eq z y ->
      In x s ->
      In z s.
    Proof. fsetdec. Qed.

    Lemma test_eq_trans_2 : forall x y z r s,
      In x (singleton y) ->
      ~ In z r ->
      ~ ~ In z (add y r) ->
      In x s ->
      In z s.
    Proof. fsetdec. Qed.

    Lemma test_eq_neq_trans_1 : forall w x y z s,
      E.eq x w ->
      ~ ~ E.eq x y ->
      ~ E.eq y z ->
      In w s ->
      In w (remove z s).
    Proof. fsetdec. Qed.

    Lemma test_eq_neq_trans_2 : forall w x y z r1 r2 s,
      In x (singleton w) ->
      ~ In x r1 ->
      In x (add y r1) ->
      In y r2 ->
      In y (remove z r2) ->
      In w s ->
      In w (remove z s).
    Proof. fsetdec. Qed.

    Lemma test_In_singleton : forall x,
      In x (singleton x).
    Proof. fsetdec. Qed.

    Lemma test_add_In : forall x y s,
      In x (add y s) ->
      ~ E.eq x y ->
      In x s.
    Proof. fsetdec. Qed.

    Lemma test_Subset_add_remove : forall x s,
      s [<=] (add x (remove x s)).
    Proof. fsetdec. Qed.

    Lemma test_eq_disjunction : forall w x y z,
      In w (add x (add y (singleton z))) ->
      E.eq w x \/ E.eq w y \/ E.eq w z.
    Proof. fsetdec. Qed.

    Lemma test_not_In_disj : forall x y s1 s2 s3 s4,
      ~ In x (union s1 (union s2 (union s3 (add y s4)))) ->
      ~ (In x s1 \/ In x s4 \/ E.eq y x).
    Proof. fsetdec. Qed.

    Lemma test_not_In_conj : forall x y s1 s2 s3 s4,
      ~ In x (union s1 (union s2 (union s3 (add y s4)))) ->
      ~ In x s1 /\ ~ In x s4 /\ ~ E.eq y x.
    Proof. fsetdec. Qed.

    Lemma test_iff_conj : forall a x s s',
    (In a s' <-> E.eq x a \/ In a s) ->
    (In a s' <-> In a (add x s)).
    Proof. fsetdec. Qed.

    Lemma test_set_ops_1 : forall x q r s,
      (singleton x) [<=] s ->
      Empty (union q r) ->
      Empty (inter (diff s q) (diff s r)) ->
      ~ In x s.
    Proof. fsetdec. Qed.

    Lemma eq_chain_test : forall x1 x2 x3 x4 s1 s2 s3 s4,
      Empty s1 ->
      In x2 (add x1 s1) ->
      In x3 s2 ->
      ~ In x3 (remove x2 s2) ->
      ~ In x4 s3 ->
      In x4 (add x3 s3) ->
      In x1 s4 ->
      Subset (add x4 s4) s4.
    Proof. fsetdec. Qed.

    Lemma test_too_complex : forall x y z r s,
      E.eq x y ->
      (In x (singleton y) -> r [<=] s) ->
      In z r ->
      In z s.
    Proof.
      (** [fsetdec] is not intended to solve this directly. *)
      intros until s; intros Heq H Hr; lapply H; fsetdec.
    Qed.

    Lemma function_test_1 :
      forall (f : t -> t),
      forall (g : elt -> elt),
      forall (s1 s2 : t),
      forall (x1 x2 : elt),
      Equal s1 (f s2) ->
      E.eq x1 (g (g x2)) ->
      In x1 s1 ->
      In (g (g x2)) (f s2).
    Proof. fsetdec. Qed.

    Lemma function_test_2 :
      forall (f : t -> t),
      forall (g : elt -> elt),
      forall (s1 s2 : t),
      forall (x1 x2 : elt),
      Equal s1 (f s2) ->
      E.eq x1 (g x2) ->
      In x1 s1 ->
      g x2 = g (g x2) ->
      In (g (g x2)) (f s2).
    Proof.
      (** [fsetdec] is not intended to solve this directly. *)
      intros until 3. intros g_eq. rewrite <- g_eq. fsetdec.
    Qed.

    Lemma test_baydemir :
      forall (f : t -> t),
      forall (s : t),
      forall (x y : elt),
      In x (add y (f s)) ->
      ~ E.eq x y ->
      In x (f s).
    Proof.
      fsetdec.
    Qed.

  End MSetDecideTestCases.

End WDecideOn.

Require Import MSetInterface.

(** Now comes variants for self-contained weak sets and for full sets.
    For these variants, only one argument is necessary. Thanks to
    the subtyping [WS<=S], the [Decide] functor which is meant to be
    used on modules [(M:S)] can simply be an alias of [WDecide]. *)

Module WDecide (M:WSets) := WDecideOn M.E M.
Module Decide := WDecide.


Require Import Option.
Require Import List.
Require Import MyTactics.
Require Import LambdaCalculusSyntax.
Require Import LambdaCalculusFreeVars.
Require Import LambdaCalculusBigStep.

(* We now wish to define an interpreter for the lambda-calculus. In other
   words, whereas [ebigcbv] is a relation, we now wish to define a function
   [interpret] whose graph is the relation [ebigcbv]. *)

(* At the moment, our lambda-calculus is pure (every value is a function)
   so the interpreter cannot encounter a runtime error. *)

(* -------------------------------------------------------------------------- *)

(* We might naively wish to write the following code, which Coq rejects,
   because this function is not obviously terminating. (Exercise: which
   recursive call is the culprit?) Indeed, an interpreter for the untyped
   lambda-calculus does not always terminate: there are lambda-terms whose
   evaluation diverges. (Exercise: exhibit a term that reduces to itself
   in one or more reduction steps. Prove in Coq that this is the case.) *)

Fail Fixpoint interpret (e : cenv) (t : term) : cvalue :=
  match t with
  | Var x =>
      nth x e dummy_cvalue
        (* dummy is used when x is out of range *)
  | Lam t =>
      Clo t e
  | App t1 t2 =>
      let cv1 := interpret e t1 in
      let cv2 := interpret e t2 in
      match cv1 with Clo u1 e' =>
        interpret (cv2 :: e') u1
      end
  | Let t1 t2 =>
      let cv1 := interpret e t1 in
      interpret (cv1 :: e) t2
  end.

(* -------------------------------------------------------------------------- *)

(* There are several potential solutions to the above problem. One solution
   would be to write code in (some implementation of) the partiality monad.
   (See Dagand's lectures.) The solution proposed here is to parameterize
   the function [interpret] with a natural integer [n], which serves as an
   amount of "fuel" (or "effort") that we are willing to invest before we
   give up. Thus, termination becomes obvious. The downside is that the
   interpreter can now fail (which means "not enough fuel"). Fortunately,
   given enough fuel, every terminating term can be evaluated. *)

(* For Coq to accept the following definition, the fuel [n] must decrease at
   every recursive call. We might wish to be more precise and somehow explain
   that [n] needs to decrease only at the third recursive call in the case of
   [App]lications. That would require defining a lexicographic ordering on the
   pair [n, t], arguing that this ordering is well-founded, and defining
   [interpret] by well-founded recursion. This can be done in Coq but is more
   complicated, so (here) not worth the trouble. *)

Fixpoint interpret (n : nat) e t : option cvalue :=
  match n with
  | 0   => None (* not enough fuel *)
  | S n =>
      match t with
      | Var x     => Some (nth x e dummy_cvalue)
      | Lam t     => Some (Clo t e)
      | App t1 t2 =>
          interpret n e t1 >>= fun cv1 =>
          interpret n e t2 >>= fun cv2 =>
          match cv1 with Clo u1 e' =>
            interpret n (cv2 :: e') u1
          end
      | Let t1 t2 =>
          interpret n e t1 >>= fun cv1 =>
          interpret n (cv1 :: e) t2
  end end.

(* -------------------------------------------------------------------------- *)

(* The interpreter is correct with respect to the big-step semantics. *)

Lemma interpret_ebigcbv:
  forall n e t cv,
  interpret n e t = Some cv ->
  fv (length e) t ->
  wf_cenv e ->
  ebigcbv e t cv.
Proof.
  (* The definition of [interpret] is by induction on [n], so this proof
     must be by induction on [n] as well. *)
  induction n; destruct t; simpl; intros;
  fv; unpack; injections; subst;
  try solve [ congruence ].
  (* Var *)
  { econstructor; eauto. }
  (* Lam *)
  { econstructor; eauto. }
  (* App *)
  { repeat invert_bind_Some.
    (* Every cvalue is a closure. Name the components of the closure
       obtained by interpreting [t1]. *)
    match goal with h: interpret _ _ t1 = Some ?cv |- _ =>
      destruct cv as [ t' e' ]
    end.
    (* The goal follows. *)
    econstructor; eauto 11 with wf_cvalue. }
  (* Let *)
  { invert_bind_Some.
    econstructor; eauto with wf_cvalue. }
Qed.

(* A simplified corollary, where [t] is closed and is therefore evaluated
   under the empty environment, and where we conclude with a [bigcbv]
   judgement. *)

Lemma interpret_bigcbv_nil:
  forall n t cv,
  interpret n nil t = Some cv ->
  closed t ->
  bigcbv t (decode cv).
Proof.
  eauto using ebigcbv_bigcbv_nil, interpret_ebigcbv with wf_cvalue.
Qed.

(* -------------------------------------------------------------------------- *)

(* The interpreter is monotonic with respect to the amount of fuel that is
   provided: the more fuel, the better (that is, the more defined the result). *)

Lemma interpret_monotonic:
  forall n1 n2 e t,
  n1 <= n2 ->
  less_defined (interpret n1 e t) (interpret n2 e t).
Proof.
  (* This series of tactics get rid of the easy cases: *)
  induction n1; destruct t; simpl; intros;
  (* [less_defined None _] is always true. *)
  eauto with less_defined;
  (* If [S n1 <= n2], then [n2] must be a successor. *)
  (destruct n2; [ lia |]); simpl;
  (* [less_defined] is reflexive. *)
  eauto with less_defined.

  (* Two more complex cases remain, namely [App] and [Let]. Probably
     the proof could be further automated, but I did not try. *)
  (* App *)
  { eapply prove_less_defined_bind.
    { eauto using le_S_n. }
    { intros _ [ t' e' ]. (* destruct the closure produced by [t1] *)
      eapply prove_less_defined_bind; eauto using le_S_n. }
  }
  (* Let *)
  { eauto 6 using le_S_n with less_defined. }
Qed.

(* A reformulation. *)

Lemma interpret_monotonic_corollary:
  forall n1 n2 e t cv,
  interpret n1 e t = Some cv ->
  n1 <= n2 ->
  interpret n2 e t = Some cv.
Proof.
  generalize interpret_monotonic. unfold less_defined. eauto.
Qed.

(* -------------------------------------------------------------------------- *)

(* The interpreter is complete with respect to the big-step semantics
   [ebigcbv]. That is, given enough fuel, and given a term whose value is
   [cv], it will compute [cv]. *)

Lemma ebigcbv_interpret:
  forall e t cv,
  ebigcbv e t cv ->
  exists n,
  interpret n e t = Some cv.
Proof.
  (* We can see, in the proof, that the necessary amount of fuel, [n], is
     the height of the derivation of the judgement [ebigcbv e t cv].
     Indeed, at every [App] or [Let] node, we count 1 plus the maximum
     amount of fuel required by our children. *)
  induction 1; intros; subst.
  (* EBigcbvVar *)
  { exists 1. eauto. }
  (* EBigcbvLam *)
  { exists 1. eauto. }
  (* EBigcbvApp *)
  { destruct IHebigcbv1 as [ n1 ? ].
    destruct IHebigcbv2 as [ n2 ? ].
    destruct IHebigcbv3 as [ n3 ? ].
    eexists (S (max (max n1 n2) n3)). simpl.
    eauto 6 using prove_bind_Some, interpret_monotonic_corollary with lia. }
  (* EBigcbvLet *)
  { destruct IHebigcbv1 as [ n1 ? ].
    destruct IHebigcbv2 as [ n2 ? ].
    eexists (S (max n1 n2)). simpl.
    eauto using prove_bind_Some, interpret_monotonic_corollary with lia. }
Qed.

(* The interpreter is complete with respect to the big-step semantics
   [bigcbv]. That is, given enough fuel, and given a term [t] whose value is
   [v], it will compute a cvalue [cv] which decodes to [v]. We state this in
   the case where [t] is closed and is therefore evaluated under the empty
   environment. *)

Lemma bigcbv_interpret_nil:
  forall t v,
  bigcbv t v ->
  closed t ->
  exists n cv,
  interpret n nil t = Some cv /\ decode cv = v.
Proof.
  intros.
  edestruct bigcbv_ebigcbv_nil; eauto. unpack.
  edestruct ebigcbv_interpret; eauto.
Qed.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
Require Import maps.
Require Import smallstep2.
Require Import typerevise.

Module STLC.

Inductive ty : Type :=
  | TBool : ty
  | TArrow : ty -> ty -> ty.

Inductive tm : Type :=
  | tvar : string -> tm
  | tapp : tm -> tm -> tm
  | tabs : string -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Open Scope string_scope.
Definition x := "x".
Definition y := "y".
Definition z := "z".
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Notation idB :=
  (tabs x TBool (tvar x)).
Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).
Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))(tvar x)).
Notation k := (tabs x TBool (tabs y TBool (tvar x))).
Notation notB := (tabs x TBool (tif (tvar x) tfalse ttrue)).

(* (We write these as Notations
rather than Definitions to make
things easier for auto.)
 *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | v_true :
      value ttrue
  | v_false :
      value tfalse.
Hint Constructors value.

Reserved Notation "'[' x ':=' s ']' t"
(at level 20).
Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_string x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_string x x'
      then t1 else ([x:=s] t1))
  | tapp t1 t2 =>
      tapp ([x:=s] t1) ([x:=s] t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif ([x:=s] t1) ([x:=s] t2) ([x:=s] t3)
  end

where "'[' x ':=' s ']' t" := (subst x s t).

Inductive substi (s:tm) (x:string) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  | s_var2 : forall x', x <> x' ->
      substi s x (tvar x') (tvar x')
  | s_abs1 : forall T t1 t1', t1 = tabs x T t1' ->
              substi s x (tabs x T t1') t1
  | s_abs2 : forall x' T t1 t1', x<>x'->
    substi s x t1 t1' ->
    substi s x (tabs x' T t1) (tabs x' T t1')
  | s_app : forall t1 t1' t2 t2',
       substi s x t1' t1 ->  substi s x t2' t2 ->
         substi s x (tapp t1' t2') (tapp t1 t2)
  | s_true : substi s x ttrue ttrue
  | s_false : substi s x tfalse tfalse
  | s_if :  forall t1 t2 t3 t1' t2' t3',
     substi s x t1 t1' -> substi s x t2 t2'
     -> substi s x t3 t3' ->
     substi s x (tif t1 t2 t3)
(tif t1' t2' t3').

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
intros. inversion H.
Qed.

Hint Constructors substi.
Theorem substi_correct : forall s x t t',
  [x:=s]t = t' <-> substi s x t t'.
Proof with eauto.
intros. split.
- generalize dependent t'.
  induction t.
  + intros. simpl in H.
    unfold beq_string in H.
    destruct (string_dec x0 s0) in H.
    rewrite <- e,H. apply s_var1.
    rewrite <- H. apply s_var2.
    apply n.
 + intros. simpl in H. rewrite <- H.
   apply s_app. apply IHt1. reflexivity.
   apply IHt2. reflexivity.
 + intros. simpl in H. unfold beq_string in H.
   destruct (string_dec x0 s0) in H.
   rewrite <-H. rewrite e. apply s_abs1.
   reflexivity.
   rewrite <- H. apply s_abs2. apply n. apply IHt.
   reflexivity.
 + intros. simpl in H. rewrite <-H. apply s_true.
 + intros. simpl in H. rewrite <-H. apply s_false.
 + intros. simpl in H. rewrite <-H.
   apply s_if. apply IHt1. reflexivity.
   apply IHt2. reflexivity.
   apply IHt3. reflexivity.
- generalize dependent t'.
  induction t.
  + intros. inversion H. simpl.
    unfold beq_string.
    destruct (string_dec s0 s0). reflexivity.
    apply ex_falso_quodlibet.
    apply n. reflexivity.
    simpl. unfold beq_string.
    destruct (string_dec x0 s0).
    rewrite e in H1. apply ex_falso_quodlibet.
   apply H1. reflexivity. reflexivity.
 + intros. inversion H. simpl.
apply IHt1 in H2. apply IHt2 in H4.
rewrite <- H2,H4. reflexivity.
 + intros. inversion H. simpl.
   unfold beq_string.
  destruct (string_dec s0 s0). rewrite <-H4.
  reflexivity. apply ex_falso_quodlibet.
  apply n. reflexivity.
  simpl. unfold beq_string.
  destruct (string_dec x0 s0). apply IHt in H5.
  apply ex_falso_quodlibet.
  rewrite e in H4. apply H4. reflexivity.
  apply IHt in H5. rewrite <-H5.
  reflexivity.
 + intros. simpl. inversion H. reflexivity.
 + intros. simpl. inversion H. reflexivity.
 + intros. simpl. inversion H.
   apply IHt1 in H3. apply IHt2 in H5.
   apply IHt3 in H6. rewrite <- H3,H5,H6.
   reflexivity.
Qed.

Reserved Notation "t1 '-->' t2" (at level 40).
Inductive step : tm ->tm ->Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) --> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         tapp t1 t2 --> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         tapp v1 t2 --> tapp v1 t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) --> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (tif t1 t2 t3) --> (tif t1' t2 t3)

where "t1 '-->' t2" := (step t1 t2).
Hint Constructors step.
Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Lemma step_example1 :
  (tapp idBB idB) -->* idB.
Proof.
eapply multi_step.
apply ST_AppAbs.
apply v_abs.
apply multi_refl.
Qed.

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) -->* idB.
Proof.
eapply multi_step.
apply ST_App2. apply v_abs.
apply ST_AppAbs. apply v_abs.
eapply multi_step.
apply ST_AppAbs.
apply v_abs.
simpl. apply multi_refl.
Qed.

Lemma step_example3 :
  tapp (tapp idBB notB) ttrue -->* tfalse.
Proof.
eapply multi_step.
apply ST_App1. apply ST_AppAbs.
apply v_abs.
simpl. eapply multi_step.
apply ST_AppAbs. apply v_true.
simpl. eapply multi_step.
apply ST_IfTrue.
apply multi_refl.
Qed.

Lemma step_example4 :
  tapp idBB (tapp notB ttrue) -->* tfalse.
Proof.
eapply multi_step.
apply ST_App2. apply v_abs.
apply ST_AppAbs. apply v_true.
simpl. eapply multi_step.
apply ST_App2. apply v_abs.
apply ST_IfTrue.
eapply multi_step.
apply ST_AppAbs.
apply v_false. simpl.
apply multi_refl.
Qed.

Lemma step_example4' :
  tapp idBB (tapp notB ttrue) -->* tfalse.
Proof.
(* normalize. *)
Admitted.

Lemma step_example5 :
       tapp (tapp idBBBB idBB) idB
  -->* idB.
Proof.
eapply multi_step.
apply ST_App1. apply ST_AppAbs.
apply v_abs.
eapply multi_step. apply ST_AppAbs.
apply v_abs. simpl.
apply multi_refl.
Qed.

Lemma step_example5_with_normalize :
       tapp (tapp idBBBB idBB) idB
  -->* idB.
Proof.
eapply multi_step.
apply ST_App1.
apply ST_AppAbs. apply v_abs.
eapply multi_step.
apply ST_AppAbs. apply v_abs. simpl.
apply multi_refl.
Qed.

Definition context := partial_map ty.
Reserved Notation "Gamma '|-' t 'in' T"
(at level 40).
Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      Gamma |- tvar x in T
  | T_Abs : forall Gamma x T11 T12 t12,
      (update Gamma x T11) |- t12 in T12 ->
      Gamma |- tabs x T11 t12 in TArrow T11 T12
  | T_App : forall T11 T12 Gamma t1 t2,
      Gamma |- t1 in TArrow T11 T12 ->
      Gamma |- t2 in T11 ->
      Gamma |- tapp t1 t2 in T12
  | T_True : forall Gamma,
       Gamma |- ttrue in TBool
  | T_False : forall Gamma,
       Gamma |- tfalse in TBool
  | T_If : forall t1 t2 t3 T Gamma,
       Gamma |- t1 in TBool ->
       Gamma |- t2 in T ->
       Gamma |- t3 in T ->
       Gamma |- tif t1 t2 t3 in T

where "Gamma '|-' t 'in' T" := (has_type Gamma t T).
Hint Constructors has_type.

Example typing_example_1 :
  empty |- tabs x TBool (tvar x) in
  TArrow TBool TBool.
Proof.
apply T_Abs.
apply T_Var.
reflexivity.
Qed.

Example typing_example_2 :
empty |-  (tabs x TBool
    (tabs y (TArrow TBool TBool)
    (tapp (tvar y) (tapp (tvar y) (tvar x))))) in
  (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using update_eq.
apply T_Abs. apply T_Abs.
eapply T_App. apply T_Var...
eapply T_App. apply T_Var...
apply T_Var...
Qed.

Example typing_example_2' :
empty |-  (tabs x TBool
    (tabs y (TArrow TBool TBool)
    (tapp (tvar y) (tapp (tvar y) (tvar x))))) in
  (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
Admitted.

(* Example one: exists T,
empty |-
(tapp (tvar y) (tapp (tvar x) (tvar z))) in T.
Proof with auto.
exists TBool.
apply T_App with TBool.
apply T_Var...  *)

Example typing_example_3 :
  exists T,
    empty |-
    (tabs y (TArrow TBool TBool)
    (tabs z TBool
    (tapp (tvar y) (tvar z)))) in
     T.
Proof with auto.
exists (TArrow (TArrow TBool TBool)
(TArrow TBool TBool)).
eapply T_Abs.
eapply T_Abs.
eapply T_App.
apply T_Var.
reflexivity.
apply T_Var.
reflexivity.
Qed.

Example typing_nonexample_1 :
  ~exists T,
      empty |-
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y)))) in
        T.
Proof.
intros H. inversion H.
inversion H0. subst. clear H0.
inversion H6. subst. clear H6.
inversion H5. subst. clear H5.
inversion H3. subst. clear H3.
inversion H2. Qed.

Lemma no_infinite_nested_type :
  ~ (exists T, exists S, T = TArrow T S).
Proof.
  intros Hc. inversion Hc as [T H].
 clear Hc. induction T.
  + inversion H. inversion H0.
  + inversion H as [S' H1].
 inversion H1. apply IHT1. exists T2. assumption.
Qed.

Example typing_nonexample_3 :
  not(exists S T,
        empty |-
          (tabs x S
             (tapp (tvar x) (tvar x))) in
          T).
Proof.
intros Hc. inversion Hc as [S H]. clear Hc.
  inversion H as [T H1]. subst.
  inversion H1. subst. clear H1.
  inversion H6. subst. clear H6.
  inversion H3. subst. clear H3.
  inversion H2. subst. inversion H5.
subst. rewrite H2 in H3. inversion H3.
  symmetry in H1.
apply no_infinite_nested_type.
exists T11. exists T12. assumption.
Qed.


Require Import rt.util.all.
Require Import rt.model.basic.job rt.model.basic.task rt.model.basic.schedule
               rt.model.basic.task_arrival rt.model.basic.response_time
               rt.model.basic.schedulability.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq div fintype bigop path.

Module Workload.

  Import Job SporadicTaskset Schedule ScheduleOfSporadicTask SporadicTaskArrival ResponseTime Schedulability.

  (* Let's define the workload. *)
  Section WorkloadDef.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_task: Job -> sporadic_task.
    Context {arr_seq: arrival_sequence Job}.

    Context {num_cpus: nat}.
    Variable sched: schedule num_cpus arr_seq.

    (* Consider some task *)
    Variable tsk: sporadic_task.

    (* First, we define a function that returns the amount of service
       received by this task in a particular processor. *)
    Definition service_of_task (cpu: processor num_cpus)
                               (j: option (JobIn arr_seq)) : time :=
      match j with
        | Some j' => (job_task j' == tsk)
        | None => 0
      end.

    (* Next, workload is defined as the service received by jobs of
       the task in the interval [t1,t2). *)
    Definition workload (t1 t2: time) :=
      \sum_(t1 <= t < t2)
        \sum_(cpu < num_cpus)
          service_of_task cpu (sched cpu t).

    (* Now, we define workload by summing up the cumulative service
       during [t1,t2) of the scheduled jobs, but only those spawned
       by the task that we care about. *)
    Definition workload_joblist (t1 t2: time) :=
      \sum_(j <- jobs_of_task_scheduled_between job_task sched tsk t1 t2)
        service_during sched j t1 t2.

    (* Next, we show that the two definitions are equivalent. *)
    Lemma workload_eq_workload_joblist :
      forall t1 t2,
      workload t1 t2 = workload_joblist t1 t2.
    Proof.
      intros t1 t2; unfold workload, workload_joblist, service_during.
      rewrite big_filter [\sum_(j <- jobs_scheduled_between _ _ _ | _) _]exchange_big /=.
      apply eq_big_nat; unfold service_at; intros t LEt.
      rewrite [\sum_(i <- jobs_scheduled_between _ _ _ | _) _](eq_bigr (fun i =>
               \sum_(cpu < num_cpus) (sched cpu t == Some i)));
        last by ins; rewrite big_mkcond; apply eq_bigr; ins; rewrite mulnbl.
      rewrite exchange_big /=; apply eq_bigr.
      intros cpu LEcpu; rewrite -big_filter.
      destruct (sched cpu t) eqn:SCHED; simpl;
        last by rewrite big_const_seq iter_addn mul0n addn0.
      destruct (job_task j == tsk) eqn:EQtsk;
        try rewrite mul1n; try rewrite mul0n.
      {
        rewrite -> bigD1_seq with (j := j); last by rewrite filter_undup undup_uniq.
        {
          rewrite -> eq_bigr with (F2 := fun i => 0); last first.
          {
            intros i DIFF.
            destruct (Some j == Some i) eqn:SOME; rewrite SOME; last by done.
            move: SOME => /eqP SOME; inversion SOME as [EQ].
            by rewrite EQ eq_refl in DIFF.
          }
          by rewrite /= big_const_seq iter_addn mul0n 2!addn0 eq_refl.
        }
        {
          rewrite mem_filter; apply/andP; split; first by ins.
          rewrite mem_undup.
          apply mem_bigcat_nat with (j := t); first by ins.
          apply mem_bigcat_ord with (j := cpu); first by apply ltn_ord.
          by rewrite SCHED inE; apply/eqP.
        }
      }
      {
        rewrite big_filter; rewrite -> eq_bigr with (F2 := fun i => 0);
          first by rewrite big_const_seq iter_addn mul0n addn0.
        intros i EQtsk2; destruct (Some j == Some i) eqn:SOME; last by done.
        move: SOME => /eqP SOME; inversion SOME; subst.
        by rewrite EQtsk2 in EQtsk.
      }
    Qed.

  End WorkloadDef.

End Workload.


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Basic_Cons.CCC Basic_Cons.PullBack.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.

(** Type_Cat has pullbacks. The pullback of two functions f : a → b and
    g : c → b is {(x, y) | f x = g y} *)
Section PullBack.
  Context {A B C : Type} (f : A → C) (g : B → C).

  Local Hint Extern 1 =>
  match goal with
    [x : sig _ |- _ ] =>
    let H := fresh "H" in
    destruct x as [x H]
  end.

  Program Definition Type_Cat_PullBack : @PullBack Type_Cat _ _ _ f g :=
    {|
      pullback := {x : A * B| f (fst x) = g (snd x)};
      pullback_morph_1 := fun z => (fst (proj1_sig z));
      pullback_morph_2 := fun z => (snd (proj1_sig z));
      pullback_morph_ex := fun x p1 p2 H x' => (exist _ (p1 x', p2 x') _)
    |}.

  Next Obligation.
  Proof.
    match goal with
      [|- ?A1 (?A2 ?x) = ?B1 (?B2 ?x)] =>
      match goal with
        [H : (fun w => A1 (A2 w)) = (fun w' => B1 (B2 w'))  |- _] =>
        apply (equal_f H)
      end
    end.
  Qed.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros X p1 p2 H u u' H1 H2 H3 H4.
    destruct H3; destruct H4.
    extensionality x.
    set (H1x := equal_f H1 x); clearbody H1x; clear H1.
    set (H2x := equal_f H2 x); clearbody H2x; clear H2.
    cbn in *.
    match goal with
      [|- ?A = ?B] => destruct A as [[a1 a2] Ha]; destruct B as [[b1 b2] Hb]
    end.
    cbn in *.
    apply sig_proof_irrelevance; cbn.
    rewrite H1x; rewrite H2x; trivial.
  Qed.

End PullBack.

Instance Type_Cat_Has_PullBacks : Has_PullBacks Type_Cat :=
  fun a b c f g => Type_Cat_PullBack f g.