Require Export Coq.Program.Tactics.
Require Export Coq.Setoids.Setoid.
Require Export Coq.Classes.Morphisms.
Require Export Coq.Arith.Arith_base.
Require Export Coq.Relations.Relations.
Require Export Coq.Lists.List.

Import EqNotations.
Import ListNotations.

(***
 *** Ordered Types = Types with a PreOrder
 ***)

(* NOTE: The idea with this approach is that each type uniquely determines its
ordered type, but we keep the types separate from the ordered types to make
type inference work properly... *)

Class OTRelation (A:Type) : Type := ot_R : relation A.
Class OType (A:Type) {R:OTRelation A} : Prop :=
  { ot_PreOrder :> PreOrder ot_R }.

Arguments OTRelation A%type.
Arguments OType A%type {R}.

Instance OType_Reflexive A `{OType A} : Reflexive ot_R.
Proof. typeclasses eauto. Qed.

Instance OType_Transitive A `{OType A} : Transitive ot_R.
Proof. typeclasses eauto. Qed.

(* The equivalence relation for an OrderedType *)
Definition ot_equiv {A} `{OTRelation A} : relation A :=
  fun x y => ot_R x y /\ ot_R y x.

Instance ot_equiv_Equivalence A `{OType A} : Equivalence ot_equiv.
Proof.
  constructor; intro; intros.
  { split; reflexivity. }
  { destruct H0; split; assumption. }
  { destruct H0; destruct H1; split; transitivity y; assumption. }
Qed.

Notation "x <o= y" :=
  (ot_R x y) (no associativity, at level 70).
Notation "x =o= y" :=
  (ot_equiv x y) (no associativity, at level 70).

(* FIXME: replace "ot_R" below with "<o=" notation *)

(***
 *** Commonly-Used Ordered Types
 ***)

(* The ordered type of propositions *)
Instance OTProp_R : OTRelation Prop := Basics.impl.
Instance OTProp : OType Prop.
Proof. repeat constructor; typeclasses eauto. Qed.

(* The discrete ordered type, where things are only related to themselves; we
make this a definition, not an instance, so that it can be instantiated for
particular types. *)
Definition OTdiscrete_R (A:Type) : OTRelation A := eq.
Definition OTdiscrete A : @OType A (OTdiscrete_R A).
  repeat constructor. typeclasses eauto.
Qed.

(* The only ordered type over unit is the discrete one *)
Instance OTunit_R : OTRelation unit := OTdiscrete_R unit.
Instance OTunit : OType unit := OTdiscrete unit.

(* The ordered type that flips the ordering of an underlying OType; this becomes
a type itself in Coq *)
Inductive Flip A : Type := flip (a:A).
Definition unflip {A} (f:Flip A) : A := let (x) := f in x.

Instance OTFlip_R A (R:OTRelation A) : OTRelation (Flip A) :=
  fun x y => unflip y <o= unflip x.

Instance OTFlip A `{OType A} : OType (Flip A).
Proof.
  repeat constructor; intro; intros.
  - destruct x; compute; reflexivity.
  - destruct x; destruct y; destruct z; compute; transitivity a0; assumption.
Qed.

(* The pointwise relation on pairs *)
Instance OTpair_R A B (RA:OTRelation A) (RB:OTRelation B) : OTRelation (A*B) :=
  fun p1 p2 => ot_R (fst p1) (fst p2) /\ ot_R (snd p1) (snd p2).

Instance OTpair A B `(OType A) `(OType B) : OType (A*B).
Proof.
  repeat constructor.
  - destruct x. reflexivity.
  - destruct x. reflexivity.
  - destruct x; destruct y; destruct z; destruct H1; destruct H2;
      transitivity a0; assumption.
  - destruct x; destruct y; destruct z; destruct H1; destruct H2;
      transitivity b0; assumption.
Qed.

(* The sort-of pointwise relation on sum types *)
Inductive sumR {A B} (RA:OTRelation A) (RB:OTRelation B) : A+B -> A+B -> Prop :=
| sumR_inl a1 a2 : RA a1 a2 -> sumR RA RB (inl a1) (inl a2)
| sumR_inr b1 b2 : RB b1 b2 -> sumR RA RB (inr b1) (inr b2).

Instance OTsum_R A B (RA:OTRelation A) (RB:OTRelation B) : OTRelation (A+B) :=
  sumR RA RB.

Instance OTsum A B `(OType A) `(OType B) : OType (A+B).
Proof.
  repeat constructor; intro; intros.
  { destruct x; constructor; reflexivity. }
  { destruct H1; inversion H2.
    - constructor; transitivity a2; assumption.
    - constructor; transitivity b2; assumption. }
Qed.

(* NOTE: the following definition requires everything above to be polymorphic *)
(* NOTE: The definition we choose for OTType is actually deep: instead of
requiring ot_Type A = ot_Type B, we could just require a coercion function from
ot_Type A to ot_Type B, which would yield something more like HoTT... though
maybe it wouldn't work unless we assumed the HoTT axiom? As it is, we might need
UIP to hold if we want to use the definition given here... *)
(*
Program Definition OTType : OType :=
  {|
    ot_Type := OType;
    ot_R := (fun A B =>
               exists (e:ot_Type A = ot_Type B),
                 forall (x y:A),
                   ot_R A x y ->
                   ot_R B (rew [fun A => A] e in x)
                        (rew [fun A => A] e in y));
  |}.
*)

(***
 *** The Ordered Type for Functions
 ***)

(* The type of continuous, i.e. Proper, functions between ordered types *)
Record Pfun A B {RA:OTRelation A} {RB:OTRelation B} :=
  {
    pfun_app : A -> B;
    pfun_Proper : Proper (ot_R ==> ot_R) pfun_app
  }.

Arguments pfun_app {_ _ _ _} _ _.
Arguments pfun_Proper [_ _ _ _] _ _ _ _.

Notation "A '-o>' B" :=
  (Pfun A B) (right associativity, at level 99).
Notation "x @o@ y" :=
  (pfun_app x y) (left associativity, at level 20).

(* Infix "@" := pfun_app (at level 50). *)

(* The non-dependent function ordered type *)
Instance OTarrow_R A B {RA:OTRelation A} {RB:OTRelation B} : OTRelation (A -o> B) :=
  fun f g =>
    forall a1 a2, ot_R a1 a2 -> ot_R (pfun_app f a1) (pfun_app g a2).

Instance OTarrow A B `{OType A} `{OType B} : OType (A -o> B).
Proof.
  repeat constructor; intro; intros; intro; intros.
  { apply pfun_Proper; assumption. }
  { transitivity (pfun_app y a1).
    - apply H1; reflexivity.
    - apply H2; assumption. }
Qed.

(* Curry a Pfun *)
(*
Program Definition pfun_curry {A B C} (pfun : Pfun (OTpair A B) C)
  : Pfun A (OTarrow B C) :=
  {| pfun_app :=
       fun a =>
         {| pfun_app := fun b => pfun_app pfun (a,b);
            pfun_Proper := _ |};
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros b1 b2 Rb. apply pfun_Proper.
  split; [ reflexivity | assumption ].
Qed.
Next Obligation.
Proof.
  intros a1 a2 Ra b1 b2 Rb; simpl.
  apply pfun_Proper; split; assumption.
Qed.

(* Uncrry a Pfun *)
Program Definition pfun_uncurry {A B C} (pfun : Pfun A (OTarrow B C))
  : Pfun (OTpair A B) C :=
  {| pfun_app :=
       fun ab => pfun_app (pfun_app pfun (fst ab)) (snd ab);
     pfun_Proper := _ |}.
Next Obligation.
Proof.
  intros ab1 ab2 Rab. destruct Rab as [ Ra Rb ].
  exact (pfun_Proper pfun (fst ab1) (fst ab2) Ra (snd ab1) (snd ab2) Rb).
Qed.
 *)

(* Currying and uncurrying of pfuns form an adjunction *)
(* FIXME: figure out the simplest way of stating this adjunction *)

(* OTarrow is right adjoint to OTpair, meaning that (OTarrow (OTpair A B) C) is
isomorphic to (OTarrow A (OTarrow B C)). The following is the first part of this
isomorphism, mapping left-to-right. *)

(* FIXME: could also do a forall type, but need the second type argument, B, to
itself be proper, i.e., to be an element of OTarrow A OType. Would also need a
dependent version of OTContext, below. *)

(* pfun_app is always Proper *)
Instance Proper_pfun_app A B `{OType A} `{OType B} :
  Proper (ot_R ==> ot_R ==> ot_R) (@pfun_app A B _ _).
Proof.
  intros f1 f2 Rf a1 a2 Ra. apply Rf; assumption.
Qed.

(* pfun_app is always Proper w.r.t. ot_equiv *)
Instance Proper_pfun_app_equiv A B `{OType A} `{OType B} :
  Proper (ot_equiv ==> ot_equiv ==> ot_equiv) (@pfun_app A B _ _).
Proof.
  intros f1 f2 Rf a1 a2 Ra; destruct Rf; destruct Ra.
  split; apply Proper_pfun_app; assumption.
Qed.

(***
 *** Building Proper Functions
 ***)

Class ProperPair A `{OTRelation A} (x y:A) : Prop :=
  proper_pair_pf : ot_R x y.

Definition ofun {A B} `{OTRelation A} `{OTRelation B} (f: A -> B)
           {prp:forall x y, ProperPair A x y -> ProperPair B (f x) (f y)}
  : A -o> B :=
  {| pfun_app := f; pfun_Proper := prp |}.

Instance ProperPair_refl A `{OType A} (x:A) : ProperPair A x x.
Proof.
  unfold ProperPair. reflexivity.
Qed.

Instance ProperPair_pfun_app A B `{OType A} `{OType B}
         (fl fr:A -o> B) argl argr
         (prpf:ProperPair (A -o> B) fl fr)
         (prpa:ProperPair A argl argr)
 : ProperPair B (pfun_app fl argl) (pfun_app fr argr).
Proof.
  apply prpf; assumption.
Qed.

Instance ProperPair_ofun A B `{OType A} `{OType B} (f g:A -> B) prpl prpr
         (pf: forall x y, ProperPair A x y -> ProperPair B (f x) (g y)) :
  ProperPair (A -o> B) (@ofun A B _ _ f prpl) (@ofun A B _ _ g prpr).
Proof.
  intros xl xr Rx; apply pf; assumption.
Qed.

(***
 *** Ordered Terms and ProperPair Instances for Pair Operations
 ***)

Instance Proper_pair A B `{OType A} `{OType B} :
  Proper (ot_R ==> ot_R ==> ot_R) (pair : A -> B -> A*B).
Proof.
  repeat intro; split; assumption.
Qed.

Instance ProperPair_fst A B `{OType A} `{OType B} (p1 p2: A*B)
         (pf: ProperPair (A*B) p1 p2) :
  ProperPair A (fst p1) (fst p2).
Proof.
  destruct pf; assumption.
Qed.

Instance ProperPair_snd A B `{OType A} `{OType B} (p1 p2: A*B)
         (pf: ProperPair (A*B) p1 p2) :
  ProperPair B (snd p1) (snd p2).
Proof.
  destruct pf; assumption.
Qed.

Instance ProperPair_pair A B `{OType A} `{OType B}
         (x1 x2:A) (y1 y2:B) (pfx: ProperPair A x1 x2) (pfy: ProperPair B y1 y2) :
  ProperPair (A*B) (pair x1 y1) (pair x2 y2).
Proof.
  split; assumption.
Qed.

(***
 *** Notations for Ordered Types
 ***)

(* FIXME: why don't these work?
Notation "'pfun' ( x : A ) =o> t" :=
  (@ot_Lambda A _ (fun x => t))
    (at level 100, right associativity, x at level 99) : pterm_scope.

Notation "'pfun' x =o> t" :=
  (ot_Lambda (fun x => t))
    (at level 100, right associativity, x at level 99) : pterm_scope.
 *)

(***
 *** Ordered Type Functions
 ***)

(*
Definition ot_fun_app (TF: forall A `{OType A}, Type) A `{OType A} := TF A.

Notation "F @t@ A" :=
  (ot_fun_app F A%type) (left associativity, at level 20).
*)

Class OTRelationF (TF: forall A `{OType A}, Type) : Type :=
  ot_rel_app : forall A `{OType A}, OTRelation (TF A).

Instance OTRelation_ot_rel_app TF `(OTRelationF TF) A `(OType A) :
  OTRelation (TF A _ _) := ot_rel_app A.

Class OTypeF (TF: forall A `{OType A}, Type) `{OTRelationF TF} : Prop :=
  otype_app : forall A `{OType A}, OType (TF A).

Instance OType_otype_app TF `(OTypeF TF) A `(OType A) :
  OType (TF A _ _) := otype_app A.

(***
 *** Automation for Ordered Terms
 ***)

Instance Proper_ot_R_ot_R A `{OType A} :
  Proper (Basics.flip ot_R ==> ot_R ==> Basics.impl) ot_R.
Proof.
  intros x1 x2 Rx y1 y2 Ry Rxy.
  transitivity x1; [ assumption | ]; transitivity y1; assumption.
Qed.

Instance Proper_ot_equiv_ot_R A `{OType A} :
  Proper (ot_equiv ==> ot_equiv ==> iff) ot_R.
Proof.
  intros x1 x2 Rx y1 y2 Ry; destruct Rx; destruct Ry; split; intro Rxy.
  transitivity x1; [ assumption | ]; transitivity y1; assumption.
  transitivity x2; [ assumption | ]; transitivity y2; assumption.
Qed.

Instance Proper_ot_R_pfun_app A B `{OType A} `{OType B} :
  Proper (ot_R ==> ot_R ==> ot_R) (@pfun_app A B _ _).
Proof.
  intros f1 f2 Rf x1 x2 Rx. apply Rf; apply Rx.
Qed.

Instance Proper_ot_R_pfun_app_partial A B `{OType A} `{OType B} f :
  Proper (ot_R ==> ot_R) (@pfun_app A B _ _ f).
Proof.
  apply pfun_Proper.
Qed.

Create HintDb OT.

(* Split ot_equiv equalities into the left and right cases *)
Definition split_ot_equiv A `{OTRelation A} (x y : A)
           (pf1: x <o= y) (pf2 : y <o= x) : x =o= y :=
  conj pf1 pf2.

Hint Resolve split_ot_equiv : OT.

(* Extensionality for ot_R *)
(*
Definition ot_arrow_ext A B `{OTRelation A} `{OTRelation B} (f1 f2 : A -o> B)
           (pf:forall x y, x <o= y -> f1 @o@ x <o= f2 @o@ y) : f1 <o= f2 := pf.

Hint Resolve ot_arrow_ext : OT.
*)

(* Add the above rules to the OT rewrite set *)
(* Hint Rewrite @mkOTerm_apply @ot_unlift_iso_OTForType_refl_id : OT. *)

(* Eta-equality for pairs *)
Lemma ot_pair_eta A B `{OType A} `{OType B} (x: A*B) :
  (fst x , snd x) =o= x.
  split; split; reflexivity.
Qed.

Hint Rewrite ot_pair_eta : OT.

(* Tactic to apply rewrites in the OT rewrite set *)
Ltac rewrite_OT := rewrite_strat (topdown (hints OT)).

(* General tactic to try to prove theorems about ordered terms *)
Ltac prove_OT :=
  simpl; try (rewrite_OT; simpl);
  lazymatch goal with
  | |- @ot_equiv (_ -o> _) _ _ _ =>
    split; apply ot_arrow_ext; intro; intro; intro; prove_OT
  | |- @ot_R (_ -o> _) _ _ _ =>
    apply ot_arrow_ext; intro; intro; intro; prove_OT
  | |- _ =>
    match goal with
    | H : (?x <o= ?y) |- _ => rewrite H; prove_OT
    | H : (?x =o= ?y) |- _ => rewrite H; prove_OT
    | |- _ => try reflexivity
    end
  end.

(***
 *** Examples of Ordered Terms
 ***)

Module OTExamples.

Definition ex1 : Prop -o> Prop := ofun (fun p => p).
(* Eval compute in (pfun_app ex1 : Prop -> Prop). *)

Definition ex2 {A} `{OType A} : A -o> A := ofun (fun p => p).
(* Eval simpl in (fun A `{OType A} => pfun_app (@ex2 A _ _) : A -> A). *)

Definition ex3 {A} `{OType A} : A -o> A -o> A :=
  ofun (fun p1 => ofun (fun p2 => p1)).
(* Eval simpl in (fun (A:OType) x => pfun_app (pfun_app (@ex3 A) x)). *)

Definition ex4 {A B} `{OType A} `{OType B} : (A * B -o> A) :=
  ofun (fun p => fst p).
(* Eval simpl in (fun (A B:OType) => pfun_app ex4 : A * B -> A). *)

Definition ex5 {A B} `{OType A} `{OType B} : A * B -o> B * A :=
  ofun (fun p => (snd p , fst p)).
(* Eval simpl in (fun (A B:OType) => pfun_app ex5 : A *o* B -> B *o* A). *)

Definition ex6 {A B C} `{OType A} `{OType B} `{OType C} : A * B * C -o> C * A :=
  ofun (fun triple => (snd triple , fst (fst triple))).

Definition ex7 {A B C} `{OType A} `{OType B} `{OType C}
  : (A * B -o> C) -o> C -o> A -o> B -o> C :=
  ofun (fun f =>
               ofun
                 (fun c =>
                    ofun
                      (fun a =>
                         ofun (fun b => f @o@ (a , b))))).

End OTExamples.


Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Logic.PropExtensionality.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import coqutil.Tactics.destr.

Definition set(A: Type) := A -> Prop.

Definition elem_of{K: Type}(k: K)(ks: K -> Prop): Prop := ks k.

Notation "x '\in' s" := (elem_of x s) (at level 70, no associativity).

Section PropSet. Local Set Default Proof Using "All".
  Context {E: Type}.

  (* basic definitions (which require knowing that set E = E -> Prop *)
  Definition empty_set: set E := fun _ => False.
  Definition singleton_set: E -> set E := eq.
  Definition union: set E -> set E -> set E :=
    fun s1 s2 x => x \in s1 \/ x \in s2.
  Definition intersect: set E -> set E -> set E :=
    fun s1 s2 x => x \in s1 /\ x \in s2.
  Definition diff: set E -> set E -> set E :=
    fun s1 s2 x => x \in s1 /\ ~ x \in s2.
  Definition of_list(l: list E): set E := fun e => List.In e l.

  (* derived definitions (based on basic definitions, without knowing that set E = E -> Prop) *)
  Definition add(s: set E)(e: E) := union (singleton_set e) s.
  Definition remove(s: set E)(e: E) := diff s (singleton_set e).
  Definition subset(s1 s2: set E) := forall x, x \in s1 -> x \in s2.
  Definition sameset(s1 s2: set E) := subset s1 s2 /\ subset s2 s1.
  Definition disjoint(s1 s2: set E) := forall x, (~ x \in s1) \/ (~ x \in s2).
  Definition of_option(o: option E) := match o with
                                       | Some e => singleton_set e
                                       | None => empty_set
                                       end.

End PropSet.

#[global] Hint Unfold
     elem_of
     empty_set
     singleton_set
     union
     intersect
     diff
     of_list
  : unf_basic_set_defs.

#[global] Hint Unfold
     add
     remove
     subset
     sameset
     disjoint
     of_option
  : unf_derived_set_defs.

Section PropSetLemmas. Local Set Default Proof Using "All".
  Context {E: Type}.

  Lemma of_list_cons: forall (e: E) (l: list E),
      sameset (of_list (e :: l)) (add (of_list l) e).
  Proof.
    intros. repeat autounfold with unf_derived_set_defs. simpl. auto.
  Qed.

  Lemma of_list_app: forall (l1 l2: list E),
      sameset (of_list (l1 ++ l2)) (union (of_list l1) (of_list l2)).
  Proof.
    induction l1; repeat autounfold with unf_basic_set_defs unf_derived_set_defs in *;
      intros; simpl; [intuition idtac|].
    setoid_rewrite in_app_iff in IHl1.
    setoid_rewrite in_app_iff.
    intuition idtac.
  Qed.

  Lemma disjoint_diff_l: forall (A B C: set E),
      disjoint A C ->
      disjoint (diff A B) C.
  Proof.
    intros. unfold set, disjoint, diff in *. firstorder idtac.
  Qed.

  Lemma disjoint_diff_r: forall (A B C: set E),
      disjoint C A ->
      disjoint C (diff A B).
  Proof.
    intros. unfold set, disjoint, diff in *. firstorder idtac.
  Qed.

  Lemma subset_empty_l (s : set E) :
    subset empty_set s.
  Proof. firstorder idtac. Qed.

  Lemma subset_refl: forall (s: set E), subset s s.
  Proof. intros s x. exact id. Qed.

  Lemma union_empty_l (s : set E) :
    sameset (union empty_set s) s.
  Proof. firstorder idtac. Qed.

  Lemma union_empty_r (s : set E) :
    sameset (union s empty_set) s.
  Proof. firstorder idtac. Qed.

  Lemma disjoint_empty_l (s : set E) :
    disjoint empty_set s.
  Proof. firstorder idtac. Qed.

  Lemma disjoint_empty_r (s : set E) :
    disjoint s empty_set.
  Proof. firstorder idtac. Qed.

  Lemma union_comm (s1 s2 : set E) :
    sameset (union s1 s2) (union s2 s1).
  Proof. firstorder idtac. Qed.

  Lemma union_assoc (s1 s2 s3 : set E) :
    sameset (union s1 (union s2 s3)) (union (union s1 s2) s3).
  Proof. firstorder idtac. Qed.

  Lemma of_list_nil : sameset (@of_list E []) empty_set.
  Proof. firstorder idtac. Qed.

  Lemma of_list_singleton x: sameset (@of_list E [x]) (singleton_set x).
  Proof. firstorder idtac. Qed.

  Lemma singleton_set_eq_of_list: forall (x: E),
      singleton_set x = of_list [x].
  Proof.
    unfold singleton_set, of_list, elem_of, In.
    intros. extensionality y. apply propositional_extensionality.
    intuition idtac.
  Qed.

  Lemma in_union_l: forall x (s1 s2: set E), x \in s1 -> x \in (union s1 s2).
  Proof. unfold union, elem_of. auto. Qed.

  Lemma in_union_r: forall x (s1 s2: set E), x \in s2 -> x \in (union s1 s2).
  Proof. unfold union, elem_of. auto. Qed.

  Lemma in_of_list: forall x (l: list E), List.In x l -> x \in (of_list l).
  Proof. unfold of_list, elem_of. auto. Qed.

  Lemma in_singleton_set: forall (x: E), x \in singleton_set x.
  Proof. unfold elem_of, singleton_set. intros. reflexivity. Qed.

  Lemma sameset_iff (s1 s2 : set E) :
    sameset s1 s2 <-> (forall e, s1 e <-> s2 e).
  Proof. firstorder idtac. Qed.

  Lemma add_union_singleton (x : E) s :
    add s x = union (singleton_set x) s.
  Proof. firstorder idtac. Qed.

  Lemma not_union_iff (s1 s2 : set E) x :
    ~ union s1 s2 x <-> ~ s1 x /\ ~ s2 x.
  Proof. firstorder idtac. Qed.

  Lemma disjoint_cons (s : set E) x l :
    disjoint s (of_list (x :: l)) ->
    disjoint s (of_list l) /\ disjoint s (singleton_set x).
  Proof. firstorder idtac. Qed.

  Lemma disjoint_sameset (s1 s2 s3 : set E) :
    sameset s3 s1 ->
    disjoint s1 s2 ->
    disjoint s3 s2.
  Proof. firstorder idtac. Qed.

  Lemma disjoint_union_l_iff (s1 s2 s3 : set E) :
    disjoint (union s1 s2) s3 <-> disjoint s1 s3 /\ disjoint s2 s3.
  Proof. firstorder idtac. Qed.

  Lemma disjoint_union_r_iff (s1 s2 s3 : set E) :
    disjoint s1 (union s2 s3) <-> disjoint s1 s2 /\ disjoint s1 s3.
  Proof. firstorder idtac. Qed.

  Lemma subset_union_l (s1 s2 s3 : set E) :
    subset s1 s3 ->
    subset s2 s3 ->
    subset (union s1 s2) s3.
  Proof. firstorder idtac. Qed.

  Lemma subset_union_rl (s1 s2 s3 : set E) :
    subset s1 s2 ->
    subset s1 (union s2 s3).
  Proof. firstorder idtac. Qed.

  Lemma subset_union_rr (s1 s2 s3 : set E) :
    subset s1 s3 ->
    subset s1 (union s2 s3).
  Proof. firstorder idtac. Qed.

  Lemma subset_disjoint_r (s1 s2 s3 : set E) :
    subset s2 s3 ->
    disjoint s1 s3 ->
    disjoint s1 s2.
  Proof. firstorder idtac. Qed.

  Lemma subset_disjoint_l (s1 s2 s3 : set E) :
    subset s1 s3 ->
    disjoint s3 s2 ->
    disjoint s1 s2.
  Proof. firstorder idtac. Qed.

  Global Instance Proper_union :
    Proper (sameset ==> sameset ==> sameset) (@union E).
  Proof. firstorder idtac. Defined.

  Global Instance Proper_intersect :
    Proper (sameset ==> sameset ==> sameset) (@intersect E).
  Proof. firstorder idtac. Defined.

  Global Instance Proper_diff :
    Proper (sameset ==> sameset ==> sameset) (@diff E).
  Proof. firstorder idtac. Defined.

  Global Instance Proper_add :
    Proper (sameset ==> eq ==> sameset) (@add E).
  Proof.
    repeat intro; apply Proper_union; auto.
    subst. firstorder idtac.
  Defined.

  Global Instance Proper_remove :
    Proper (sameset ==> eq ==> sameset) (@remove E).
  Proof.
    repeat intro; apply Proper_diff; auto.
    subst. firstorder idtac.
  Defined.

  Global Instance subset_trans : Transitive (@subset E) | 10.
  Proof. firstorder idtac. Defined.
  Global Instance subset_ref : Reflexive (@subset E) | 10.
  Proof. firstorder idtac. Defined.
  Global Instance Proper_subset
    : Proper (sameset ==> sameset ==> iff) (@subset E).
  Proof. firstorder idtac. Defined.

  Global Instance sameset_sym : Symmetric (@sameset E) | 10.
  Proof. firstorder idtac. Defined.
  Global Instance sameset_trans : Transitive (@sameset E) | 10.
  Proof. firstorder idtac. Defined.
  Global Instance sameset_ref : Reflexive (@sameset E) | 10.
  Proof. firstorder idtac. Defined.

  Global Instance disjoint_sym : Symmetric (@disjoint E) | 10.
  Proof. firstorder idtac. Defined.
  Global Instance Proper_disjoint
    : Proper (sameset ==> sameset ==> iff) (@disjoint E).
  Proof. firstorder idtac. Defined.

  Section with_eqb. Local Set Default Proof Using "All".
    Context {eqb}
            {eq_dec : forall x y : E, BoolSpec (x = y) (x <> y) (eqb x y)}.

    Lemma disjoint_singleton_r_iff (x : E) (s : set E) :
      ~ s x <->
      disjoint s (singleton_set x).
    Proof.
      intros. split; [|firstorder idtac].
      intros. intro y.
      destruct (eq_dec x y);
        subst; try firstorder idtac.
    Qed.

    Lemma disjoint_singleton_singleton (x y : E) :
      y <> x ->
      disjoint (singleton_set x) (singleton_set y).
    Proof.
      intros.
      apply disjoint_singleton_r_iff;
        firstorder congruence.
    Qed.

    Lemma disjoint_not_in x (l : list E) :
      ~ In x l ->
      disjoint (singleton_set x) (of_list l).
    Proof.
      intros. symmetry. apply disjoint_singleton_r_iff; eauto.
    Qed.

    Lemma NoDup_disjoint (l1 l2 : list E) :
      NoDup (l1 ++ l2) ->
      disjoint (of_list l1) (of_list l2).
    Proof.
      revert l2; induction l1; intros *;
        rewrite ?app_nil_l, <-?app_comm_cons;
        [ solve [firstorder idtac] | ].
      inversion 1; intros; subst.
      rewrite of_list_cons.
      apply disjoint_union_l_iff; split; eauto.
      apply disjoint_not_in; eauto.
      rewrite in_app_iff in *. tauto.
    Qed.

    Lemma disjoint_NoDup (l1 l2 : list E) :
      NoDup l1 ->
      NoDup l2 ->
      disjoint (of_list l1) (of_list l2) ->
      NoDup (l1 ++ l2).
    Proof.
      revert l2; induction l1; intros *;
        rewrite ?app_nil_l, <-?app_comm_cons;
        [ solve [firstorder idtac] | ].
      inversion 1; intros; subst.
      match goal with H : disjoint (of_list (_ :: _)) _ |- _ =>
                      symmetry in H;
                        apply disjoint_cons in H; destruct H end.
      match goal with H : disjoint _ (singleton_set _) |- _ =>
                      apply disjoint_singleton_r_iff in H1;
                        cbv [of_list] in H1
      end.
      constructor; [ rewrite in_app_iff; tauto | ].
      apply IHl1; eauto using disjoint_sym.
    Qed.

    Lemma disjoint_of_list_disjoint_Forall: forall (l1 l2: list E) (P1 P2: E -> Prop),
        Forall P1 l1 ->
        Forall P2 l2 ->
        (forall x, P1 x -> P2 x -> False) ->
        disjoint (of_list l1) (of_list l2).
    Proof.
      unfold disjoint, of_list, elem_of. intros.
      destr (List.find (eqb x) l1).
      - eapply find_some in E0. destruct E0 as [E1 E2].
        destr (eqb x e). 2: discriminate.
        destr (List.find (eqb e) l2).
        + eapply find_some in E0. destruct E0 as [F1 F2].
          destr (eqb e e0). 2: discriminate.
          eapply Forall_forall in H. 2: eassumption.
          eapply Forall_forall in H0. 2: eassumption.
          exfalso. eauto.
        + right. intro C. eapply find_none in E0. 2: exact C.
          destr (eqb e e); congruence.
      - left. intro C. eapply find_none in E0. 2: exact C.
        destr (eqb x x); congruence.
    Qed.
  End with_eqb.
End PropSetLemmas.

Require Import Coq.Program.Tactics.
Require Import coqutil.Tactics.Tactics.

Ltac set_solver_generic E :=
  repeat (so fun hyporgoal => match hyporgoal with
  | context [of_list (?l1 ++ ?l2)] => unique pose proof (of_list_app l1 l2)
  | context [of_list (?h :: ?t)] => unique pose proof (of_list_cons h t)
  end);
  repeat autounfold with unf_basic_set_defs unf_derived_set_defs in *;
  unfold elem_of in *;
  destruct_products;
  intros;
  specialize_with E;
  intuition (subst *; auto).

Goal forall T (l1 l2: list T) (e: T),
    subset (of_list (l2 ++ l1)) (union (of_list (e :: l1)) (of_list l2)).
Proof. intros. set_solver_generic T. Qed.


(** * 6.887 Formal Reasoning About Programs - Lab 4
    * Operational Semantics *)

Require Import Frap.

(* Authors: Peng Wang (wangpeng@csail.mit.edu), Adam Chlipala (adamc@csail.mit.edu) *)

(** * Challenge 1: Nondeterminism *)

Module Challenge1.

  Inductive arith : Set :=
  | Const (n : nat)
  | Var (x : var)
  | Plus (e1 e2 : arith)
  | Minus (e1 e2 : arith)
  | Times (e1 e2 : arith).

  Inductive cmd :=
  | Skip
  | Assign (x : var) (e : arith)
  | Sequence (c1 c2 : cmd)
  | If (e : arith) (then_ else_ : cmd)
  | While (e : arith) (body : cmd)
  | Choice (c1 c2 : cmd).

  Definition valuation := fmap var nat.
  Fixpoint interp (e : arith) (v : valuation) : nat :=
    match e with
    | Const n => n
    | Var x =>
      match v $? x with
      | None => 0
      | Some n => n
      end
    | Plus e1 e2 => interp e1 v + interp e2 v
    | Minus e1 e2 => interp e1 v - interp e2 v
    | Times e1 e2 => interp e1 v * interp e2 v
    end.

  (** Big-step semantics *)

  Inductive eval : valuation -> cmd -> valuation -> Prop :=
  | EvalSkip : forall v,
      eval v Skip v
  | EvalAssign : forall v x e,
      eval v (Assign x e) (v $+ (x, interp e v))
  | EvalSeq : forall v c1 v1 c2 v2,
      eval v c1 v1
      -> eval v1 c2 v2
      -> eval v (Sequence c1 c2) v2
  | EvalIfTrue : forall v e then_ else_ v',
      interp e v <> 0
      -> eval v then_ v'
      -> eval v (If e then_ else_) v'
  | EvalIfFalse : forall v e then_ else_ v',
      interp e v = 0
      -> eval v else_ v'
      -> eval v (If e then_ else_) v'
  | EvalWhileTrue : forall v e body v' v'',
      interp e v <> 0
      -> eval v body v'
      -> eval v' (While e body) v''
      -> eval v (While e body) v''
  | EvalWhileFalse : forall v e body,
      interp e v = 0
      -> eval v (While e body) v
  | EvalChoice1 : forall v c1 c2 v',
      eval v c1 v'
      -> eval v (Choice c1 c2) v'
  | EvalChoice2 : forall v c1 c2 v',
      eval v c2 v'
      -> eval v (Choice c1 c2) v'.

  (** Small-step semantics *)

  Inductive step : valuation * cmd -> valuation * cmd -> Prop :=
  | StepAssign : forall v x e,
      step (v, Assign x e) (v $+ (x, interp e v), Skip)
  | StepSeq1 : forall v c1 c2 v' c1',
      step (v, c1) (v', c1')
      -> step (v, Sequence c1 c2) (v', Sequence c1' c2)
  | StepSeq2 : forall v c2,
      step (v, Sequence Skip c2) (v, c2)
  | StepIfTrue : forall v e then_ else_,
      interp e v <> 0
      -> step (v, If e then_ else_) (v, then_)
  | StepIfFalse : forall v e then_ else_,
      interp e v = 0
      -> step (v, If e then_ else_) (v, else_)
  | StepWhileTrue : forall v e body,
      interp e v <> 0
      -> step (v, While e body) (v, Sequence body (While e body))
  | StepWhileFalse : forall v e body,
      interp e v = 0
      -> step (v, While e body) (v, Skip)
  | StepChoice1 : forall v c1 c2,
      step (v, Choice c1 c2) (v, c1)
  | StepChoice2 : forall v c1 c2,
      step (v, Choice c1 c2) (v, c2).

  Hint Constructors trc step eval.

  Lemma step_star_Seq : forall v c1 c2 v' c1',
      step^* (v, c1) (v', c1')
      -> step^* (v, Sequence c1 c2) (v', Sequence c1' c2).
  Proof.
    induct 1; eauto.
    cases y; eauto.
  Qed.

  Hint Resolve step_star_Seq.

  Theorem big_small : forall v c v', eval v c v'
                                     -> step^* (v, c) (v', Skip).
  Proof.
    induct 1; eauto 6 using trc_trans.
  Qed.

  Lemma small_big'' : forall v c v' c', step (v, c) (v', c')
                                        -> forall v'', eval v' c' v''
                                                       -> eval v c v''.
  Proof.
    induct 1; simplify;
      repeat match goal with
             | [ H : eval _ _ _ |- _ ] => invert1 H
             end; eauto.
  Qed.

  Hint Resolve small_big''.

  Lemma small_big' : forall v c v' c', step^* (v, c) (v', c')
                                         -> forall v'', eval v' c' v''
                                                  -> eval v c v''.
  Proof.
    induct 1; eauto.
    cases y; eauto.
  Qed.

  Hint Resolve small_big'.

  Theorem small_big : forall v c v', step^* (v, c) (v', Skip)
                                     -> eval v c v'.
  Proof.
    eauto.
  Qed.

  (** Contextual small-step semantics *)

  Inductive context :=
  | Hole
  | CSeq (C : context) (c : cmd).

  Inductive plug : context -> cmd -> cmd -> Prop :=
  | PlugHole : forall c, plug Hole c c
  | PlugSeq : forall c C c' c2,
      plug C c c'
      -> plug (CSeq C c2) c (Sequence c' c2).

  Inductive step0 : valuation * cmd -> valuation * cmd -> Prop :=
  | Step0Assign : forall v x e,
      step0 (v, Assign x e) (v $+ (x, interp e v), Skip)
  | Step0Seq : forall v c2,
      step0 (v, Sequence Skip c2) (v, c2)
  | Step0IfTrue : forall v e then_ else_,
      interp e v <> 0
      -> step0 (v, If e then_ else_) (v, then_)
  | Step0IfFalse : forall v e then_ else_,
      interp e v = 0
      -> step0 (v, If e then_ else_) (v, else_)
  | Step0WhileTrue : forall v e body,
      interp e v <> 0
      -> step0 (v, While e body) (v, Sequence body (While e body))
  | Step0WhileFalse : forall v e body,
      interp e v = 0
      -> step0 (v, While e body) (v, Skip)
  | Step0Choice1 : forall v c1 c2,
      step0 (v, Choice c1 c2) (v, c1)
  | Step0Choice2 : forall v c1 c2,
      step0 (v, Choice c1 c2) (v, c2).

  Inductive cstep : valuation * cmd -> valuation * cmd -> Prop :=
  | CStep : forall C v c v' c' c1 c2,
      plug C c c1
      -> step0 (v, c) (v', c')
      -> plug C c' c2
      -> cstep (v, c1) (v', c2).

  Hint Constructors plug step0 cstep.

  Theorem step_cstep : forall v c v' c',
      step (v, c) (v', c')
      -> cstep (v, c) (v', c').
  Proof.
    induct 1; repeat match goal with
                     | [ H : cstep _ _ |- _ ] => invert H
                     end; eauto.
  Qed.

  Lemma step0_step : forall v c v' c',
      step0 (v, c) (v', c')
      -> step (v, c) (v', c').
  Proof.
    induct 1; eauto.
  Qed.

  Hint Resolve step0_step.

  Lemma cstep_step' : forall C c0 c,
      plug C c0 c
      -> forall v' c'0 v c', step0 (v, c0) (v', c'0)
                       -> plug C c'0 c'
                       -> step (v, c) (v', c').
  Proof.
    induct 1; simplify; repeat match goal with
                               | [ H : plug _ _ _ |- _ ] => invert1 H
                               end; eauto.
  Qed.

  Hint Resolve cstep_step'.

  Theorem cstep_step : forall v c v' c',
      cstep (v, c) (v', c')
      -> step (v, c) (v', c').
  Proof.
    induct 1; eauto.
  Qed.

End Challenge1.

(** * Challenge 2: Functions and Control Stack *)

Module Challenge2.

  Inductive arith : Set :=
  | Const (n : nat)
  | Var (x : var)
  | Plus (e1 e2 : arith)
  | Minus (e1 e2 : arith)
  | Times (e1 e2 : arith).

  Definition valuation := fmap var nat.

  Inductive cmd :=
  | Skip
  | Assign (x : var) (e : arith)
  | Sequence (c1 c2 : cmd)
  | If (e : arith) (then_ else_ : cmd)
  | While (e : arith) (body : cmd)
  | Call (lhs f : var) (arg : arith)
  | InCall (v : valuation) (lhs ret : var) (c : cmd)
  | Return (e : arith).

  Fixpoint interp (e : arith) (v : valuation) : nat :=
    match e with
    | Const n => n
    | Var x =>
      match v $? x with
      | None => 0
      | Some n => n
      end
    | Plus e1 e2 => interp e1 v + interp e2 v
    | Minus e1 e2 => interp e1 v - interp e2 v
    | Times e1 e2 => interp e1 v * interp e2 v
    end.

  (* function specification *)
  Record fun_spec := {
    Arg : var;
    Ret : var;
    Body : cmd
  }.

  (** An environment is a mapping from function names to function specs *)
  Definition environment := fmap var fun_spec.

  Section env.

    Variable env : environment.

    (** Big-step semantics *)
    Inductive eval : valuation -> cmd -> valuation -> Prop :=
    | EvalSkip : forall v,
        eval v Skip v
    | EvalAssign : forall v x e,
        eval v (Assign x e) (v $+ (x, interp e v))
    | EvalSeq : forall v c1 v1 c2 v2,
        eval v c1 v1
        -> eval v1 c2 v2
        -> eval v (Sequence c1 c2) v2
    | EvalIfTrue : forall v e then_ else_ v',
        interp e v <> 0
        -> eval v then_ v'
        -> eval v (If e then_ else_) v'
    | EvalIfFalse : forall v e then_ else_ v',
        interp e v = 0
        -> eval v else_ v'
        -> eval v (If e then_ else_) v'
    | EvalWhileTrue : forall v e body v' v'',
        interp e v <> 0
        -> eval v body v'
        -> eval v' (While e body) v''
        -> eval v (While e body) v''
    | EvalWhileFalse : forall v e body,
        interp e v = 0
        -> eval v (While e body) v
    | EvalCall : forall v lhs f arg spec v',
        env $? f = Some spec
        -> eval ($0 $+ (spec.(Arg), interp arg v)) spec.(Body) v'
        -> eval v (Call lhs f arg) (v $+ (lhs, interp (Var spec.(Ret)) v'))
    | EvalInCall : forall v0 lhs ret v c v',
        eval v c v'
        -> eval v (InCall v0 lhs ret c) (v0 $+ (lhs, interp (Var ret) v')).

    (** Small-step semantics *)

    Inductive step : valuation * cmd -> valuation * cmd -> Prop :=
    | StepAssign : forall v x e,
        step (v, Assign x e) (v $+ (x, interp e v), Skip)
    | StepSeq1 : forall v c1 c2 v' c1',
        step (v, c1) (v', c1')
        -> step (v, Sequence c1 c2) (v', Sequence c1' c2)
    | StepSeq2 : forall v c2,
        step (v, Sequence Skip c2) (v, c2)
    | StepIfTrue : forall v e then_ else_,
        interp e v <> 0
        -> step (v, If e then_ else_) (v, then_)
    | StepIfFalse : forall v e then_ else_,
        interp e v = 0
        -> step (v, If e then_ else_) (v, else_)
    | StepWhileTrue : forall v e body,
        interp e v <> 0
        -> step (v, While e body) (v, Sequence body (While e body))
    | StepWhileFalse : forall v e body,
        interp e v = 0
        -> step (v, While e body) (v, Skip)
    | StepStartCall : forall v lhs f arg spec,
        env $? f = Some spec
        -> step (v, Call lhs f arg) ($0 $+ (spec.(Arg), interp arg v), InCall v lhs spec.(Ret) spec.(Body))
    | StepInCall : forall v c v' c' v0 lhs ret,
        step (v, c) (v', c')
        -> step (v, InCall v0 lhs ret c) (v', InCall v0 lhs ret c')
    | StepEndCall : forall v0 lhs ret v,
        step (v, InCall v0 lhs ret Skip) (v0, Assign lhs (Const (interp (Var ret) v))).

    Hint Constructors trc step eval.

    Lemma step_star_Seq : forall v c1 c2 v' c1',
        step^* (v, c1) (v', c1')
        -> step^* (v, Sequence c1 c2) (v', Sequence c1' c2).
    Proof.
      induct 1; eauto.
      cases y; eauto.
    Qed.

    Hint Resolve step_star_Seq.

    Lemma step_star_InCall : forall v c v' c' v0 lhs ret,
        step^* (v, c) (v', c')
        -> step^* (v, InCall v0 lhs ret c) (v', InCall v0 lhs ret c').
    Proof.
      induct 1; eauto.
      cases y; eauto.
    Qed.

    Hint Resolve step_star_InCall.

    Theorem big_small : forall v c v',
        eval v c v'
        -> step^* (v, c) (v', Skip).
    Proof.
      induct 1; simplify; eauto 4 using trc_trans.
      {
        econstructor.
        eauto.
        eapply trc_trans.
        apply step_star_Seq.
        eassumption.
        eauto.
      }
      {
        econstructor; eauto.
        eapply trc_trans.
        {
          apply step_star_InCall.
          eassumption.
        }
        eauto.
      }
      {
        eapply trc_trans.
        {
          apply step_star_InCall.
          eassumption.
        }
        eauto.
      }
    Qed.

    Lemma small_big'' : forall v c v' c',
        step (v, c) (v', c')
        -> forall v'', eval v' c' v''
                       -> eval v c v''.
    Proof.
      induct 1; simplify;
        repeat match goal with
               | [ H : eval _ _ _ |- _ ] => invert1 H
               end; eauto.
      {
        econstructor; eauto.
      }
    Qed.

    Hint Resolve small_big''.

    Lemma small_big' : forall v c v' c',
        step^* (v, c) (v', c')
        -> forall v'', eval v' c' v''
                       -> eval v c v''.
    Proof.
      induct 1; eauto.
      cases y; eauto.
    Qed.

    Hint Resolve small_big'.

    Theorem small_big : forall v c v',
        step^* (v, c) (v', Skip)
        -> eval v c v'.
    Proof.
      eauto.
    Qed.

    (** Small-step semantics with control stack *)

    Inductive step0 : valuation * cmd -> valuation * cmd -> Prop :=
    | Step0Assign : forall v x e,
        step0 (v, Assign x e) (v $+ (x, interp e v), Skip)
    | Step0IfTrue : forall v e then_ else_,
        interp e v <> 0
        -> step0 (v, If e then_ else_) (v, then_)
    | Step0IfFalse : forall v e then_ else_,
        interp e v = 0
        -> step0 (v, If e then_ else_) (v, else_)
    | Step0WhileTrue : forall v e body,
        interp e v <> 0
        -> step0 (v, While e body) (v, Sequence body (While e body))
    | Step0WhileFalse : forall v e body,
        interp e v = 0
        -> step0 (v, While e body) (v, Skip).

    Record frame := {
      Val : valuation;
      Cont : cmd;
      LHS : var;
      RetVar : var
    }.

    Definition stack := list frame.

    Inductive stepcs : stack * valuation * cmd * cmd -> stack * valuation * cmd * cmd -> Prop :=
    | StepcsStep0 : forall v c v' c' s k,
        step0 (v, c) (v', c') ->
        stepcs (s, v, c, k) (s, v', c', k)
    | StepcsSeq : forall s v c1 c2 k,
        stepcs (s, v, Sequence c1 c2, k) (s, v, c1, Sequence c2 k)
    | StepcsCont : forall s v k1 k2,
        stepcs (s, v, Skip, Sequence k1 k2) (s, v, k1, k2)
    | StepcsReturn : forall fr s v,
        stepcs (fr :: s, v, Skip, Skip) (s, fr.(Val) $+ (fr.(LHS), interp (Var fr.(RetVar)) v), Skip, fr.(Cont))
    | StepcsCall : forall s v lhs f arg k spec,
        env $? f = Some spec
        -> stepcs (s, v, Call lhs f arg, k) ({| Val := v; Cont := k; LHS := lhs; RetVar := spec.(Ret)|} :: s, $0 $+ (spec.(Arg), interp arg v), spec.(Body), Skip)
    | StepcsInCall : forall s v0 lhs ret v c k,
        stepcs (s, v, InCall v0 lhs ret c, k) ({| Val := v0; Cont := k; LHS := lhs; RetVar := ret|} :: s, v, c, Skip).

    Hint Constructors step0 stepcs.

    Hint Extern 0 (_ <> _) => equality.

    Lemma eval_stepcs' : forall v c v',
        eval v c v'
        -> forall s k, stepcs^* (s, v, c, k) (s, v', Skip, k).
    Proof.
      induct 1; simplify; eauto 4 using trc_trans.
      {
        econstructor; eauto.
        econstructor; eauto.
        eapply trc_trans; eauto.
      }
      {
        econstructor; eauto.
        eapply trc_trans; eauto.
      }
    Qed.

    Theorem eval_stepcs : forall v c v',
        eval v c v'
        -> stepcs^* ([], v, c, Skip) ([], v', Skip, Skip).
    Proof.
      simplify.
      eapply eval_stepcs'.
      eauto.
    Qed.

    Definition unravel_frame c fr := Sequence (InCall fr.(Val) fr.(LHS) fr.(RetVar) c) fr.(Cont).
    Arguments unravel_frame _ _ / .

    Definition unravel s c := fold_left unravel_frame s c.
    Arguments unravel / .

    Lemma eval_unravel : forall s v c v' c',
        (forall v'', eval v' c' v'' -> eval v c v'') ->
        forall v'',
          eval v' (unravel s c') v'' ->
          eval v (unravel s c) v''.
    Proof.
      induct s; simplify.
      { eauto. }
      eapply IHs; try eassumption.
      simplify.
      repeat match goal with
             | [ H : eval _ _ _ |- _ ] => invert1 H
             end; eauto.
      econstructor; try eassumption.
      eauto.
    Qed.

    Lemma step0_eval : forall v c v' c',
        step0 (v, c) (v', c')
        -> forall v'', eval v' c' v''
                       -> eval v c v''.
    Proof.
      induct 1; simplify;
        repeat match goal with
               | [ H : eval _ _ _ |- _ ] => invert1 H
               end; eauto.
    Qed.

    Hint Resolve step0_eval.

    Lemma stepcs_eval'' : forall s v c k s' v' c' k',
        stepcs (s, v, c, k) (s', v', c', k')
        -> forall v'', eval v' (unravel s' (Sequence c' k')) v''
                       -> eval v (unravel s (Sequence c k)) v''.
    Proof.
      induct 1; simplify; eapply eval_unravel; try eassumption; simplify;
        repeat match goal with
               | [ H : eval _ _ _ |- _ ] => invert1 H
               end; eauto 6.
      {
        econstructor; try eassumption.
        econstructor; eauto.
      }
      {
        econstructor; try eassumption.
        econstructor; eauto.
      }
    Qed.

    Hint Resolve stepcs_eval''.

    Lemma stepcs_eval' : forall s v c k s' v' c' k',
        stepcs^* (s, v, c, k) (s', v', c', k')
        -> forall v'', eval v' (unravel s' (Sequence c' k')) v''
                       -> eval v (unravel s (Sequence c k)) v''.
    Proof.
      induct 1; eauto.
      repeat match goal with
             | [ H : (_ * _)%type |- _ ] => cases H
             end; eauto.
    Qed.

    Hint Resolve stepcs_eval'.

    Theorem stepcs_eval : forall v c v',
        stepcs^* ([], v, c, Skip) ([], v', Skip, Skip)
        -> eval v c v'.
    Proof.
      simplify.
      eapply stepcs_eval' in H; simplify;
        repeat match goal with
               | [ H : eval _ _ _ |- _ ] => invert1 H
               end; eauto.
    Qed.

  End env.

  (* Here's how to handle the [Return] command. *)
  Module StrangeAlternateUniverse.
    Section Return.
      Variable env : environment.

      Inductive stepcs : stack * valuation * cmd * cmd -> stack * valuation * cmd * cmd -> Prop :=
      | StepcsStep0 : forall v c v' c' s k,
          step0 (v, c) (v', c') ->
          stepcs (s, v, c, k) (s, v', c', k)
      | StepcsSeq : forall s v c1 c2 k,
          stepcs (s, v, Sequence c1 c2, k) (s, v, c1, Sequence c2 k)
      | StepcsCont : forall s v k1 k2,
          stepcs (s, v, Skip, Sequence k1 k2) (s, v, k1, k2)
      | StepcsReturn : forall fr s v,
          stepcs (fr :: s, v, Skip, Skip) (s, fr.(Val) $+ (fr.(LHS), interp (Var fr.(RetVar)) v), Skip, fr.(Cont))

      (****)
      | StepcsExplicitReturn : forall fr s v e k,
          stepcs (fr :: s, v, Return e, k) (s, fr.(Val) $+ (fr.(LHS), interp e v), Skip, fr.(Cont))
      (****)

      | StepcsCall : forall s v lhs f arg k spec,
          env $? f = Some spec
          -> stepcs (s, v, Call lhs f arg, k) ({| Val := v; Cont := k; LHS := lhs; RetVar := spec.(Ret)|} :: s, $0 $+ (spec.(Arg), interp arg v), spec.(Body), Skip)
      | StepcsInCall : forall s v0 lhs ret v c k,
          stepcs (s, v, InCall v0 lhs ret c, k) ({| Val := v0; Cont := k; LHS := lhs; RetVar := ret|} :: s, v, c, Skip).
    End Return.
  End StrangeAlternateUniverse.

End Challenge2.


Set Implicit Arguments.

Inductive SKI : Type :=
  | S
  | K
  | I
  | App : SKI -> SKI -> SKI.

Declare Custom Entry ski_expr.
Notation "[[ e ]]" := e (e custom ski_expr at level 2).
Notation "x y" := (App x y) (in custom ski_expr at level 1, left associativity).
Notation "( x )" := x (in custom ski_expr, x at level 2).
Notation "'S'" := S (in custom ski_expr at level 0).
Notation "'K'" := K (in custom ski_expr at level 0).
Notation "'I'" := I (in custom ski_expr at level 0).
Notation "{ x }" := x (in custom ski_expr at level 0, x constr).
Notation "x" := x (in custom ski_expr at level 0, x ident).

Reserved Notation "x ==> y" (at level 90, no associativity).

Inductive red_step : SKI -> SKI -> Prop :=
  | red_S : forall a b c, [[S a b c]] ==> [[a c (b c)]]
  | red_K : forall a b, [[K a b]] ==> [[a]]
  | red_I : forall a, [[I a]] ==> [[a]]
  | red_head : forall a a' b, [[a]] ==> [[a']] -> [[a b]] ==> [[a' b]]
  | red_tail : forall a b b', [[b]] ==> [[b']] -> [[a b]] ==> [[a b']]
where "x ==> y" := (red_step x y).

Inductive rtc (T : Type) (rel : T -> T -> Prop) : T -> T -> Prop :=
  | rtc_refl (a : T) : rtc rel a a
  | rtc_trans1 (a b c : T) : rel a b -> rtc rel b c -> rtc rel a c.

Definition red_rtc := rtc red_step.
Notation "x ==>* y" := (red_rtc x y) (at level 90, no associativity).

Hint Constructors red_step : core.
Hint Constructors rtc : core.
Hint Unfold red_rtc : core.

(* Notations for expressing a term is extensionally equal to T or F, respectively. *)
Notation "t ~~>*T" := (forall x y, [[{t} x y]] ==>* [[x]]) (at level 90, only parsing).
Notation "t ~~>*F" := (forall x y, [[{t} x y]] ==>* [[y]]) (at level 90, only parsing).
(*

\ab.ba
[\a.[\b.ba]]
[\a.SI(Ka)]
S(K(SI))K
 *)
Ltac reduce :=
  match goal with
    | |- ?a ==>* ?a => apply rtc_refl
    | |- _ ==>* _ => eapply rtc_trans1
    | |- [[K {_} {_}]] ==> _ => apply red_K
    | |- [[S {_} {_} {_}]] ==> _ => apply red_S
    | |- [[I {_}]] ==> _ => apply red_I
  end.

(*
rev x f := f x *)

Definition rev : SKI := [[ S (K (S I)) K ]].
Theorem rev_correct : forall f x, [[{rev} x f]] ==>* [[f x]].
Proof.
  intros.
  unfold rev.
  eapply rtc_trans1.
  constructor.
  constructor.
  eapply rtc_trans1.
  constructor.
  constructor.
  constructor.
  eapply rtc_trans1.
  constructor.
  eapply rtc_trans1.
  constructor.
  constructor.
  eapply rtc_trans1.
  apply red_tail.
  constructor.
  constructor.
Qed.

Require Import Nat.

Inductive Lam : Set :=
  | Abstr : Lam -> Lam
  | Appl : Lam -> Lam -> Lam
  | Var : nat -> Lam.

Fixpoint len l : nat :=
  match l with
    | Abstr a => 1 + len a
    | Appl a b => len a + len b
    | Var _ => 1
  end.

Definition LS := Abstr (Abstr (Abstr (Appl (Appl (Var 2) (Var 0)) (Appl (Var 1) (Var 0))))).
Definition LK := Abstr (Abstr (Var 1)).
Definition LI := Abstr (Var 0).

Fixpoint unskify s : Lam :=
  match s with
    | App a b => Appl (unskify a) (unskify b)
    | S => LS
    | K => LK
    | I => LI
  end.

Fixpoint skify_i (n : nat) (l : Lam) : Lam := match n with 0 => l | Datatypes.S m =>
  match l with
    | Abstr (Abstr l) => skify_i m (Abstr (skify_i m (Abstr l)))
    | Abstr (Var 0) => LI
    | Abstr (Var (Datatypes.S a)) => Appl LK (Var a)
    | Abstr (Appl a b) => Appl (Appl LS (skify_i m a)) (skify_i m b)
    | Appl a b => Appl (skify_i m a) (skify_i m b)
    | Var i => Var i
  end end.

Definition skify l: Lam := let ln := len l in skify_i 10000 l.

Fixpoint SKIfy l: SKI :=
  match l with
    | Abstr (Abstr (Abstr (Appl (Appl (Var 2) (Var 0)) (Appl (Var 1) (Var 0))))) => S
    | Abstr (Abstr (Var 1)) => K
    | Abstr (Var 0) => I
    | Appl a b => App (SKIfy a) (SKIfy b)
    | _ => [[I I I]] end.

(* B f g x := f (g x) *)
Definition B : SKI := SKIfy (skify (Abstr (Abstr (Abstr (Appl (Var 2) (Appl (Var 1) (Var 0))))))).
Print B.
Theorem B_correct : forall f g x, [[{B} f g x]] ==>* [[f (g x)]].
Proof.
  intros.
  unfold B.
  simpl.

(* C f x y := f y x *)
Definition C : SKI. Admitted.
Theorem C_correct : forall f x y, [[{C} f x y]] ==>* [[f y x]].
Proof. Admitted.

(* rotr y f x := f x y *)
Definition rotr : SKI. Admitted.
Theorem rotr_correct : forall f x y, [[{rotr} y f x]] ==>* [[f x y]].
Proof. Admitted.

(* rotv x y f := f x y *)
Definition rotv : SKI. Admitted.
Theorem rotv_correct : forall f x y, [[{rotv} x y f]] ==>* [[f x y]].
Proof. Admitted.

(* Y f := (\x. f (x x)) (\x. f (x x)) *)
(* The Y combinator has the property `Y f = f (Y f)`, but we can't prove it with direct reduction.
   Instead, we prove that both sides reduce to the same term. *)
Definition Y : SKI. Admitted.
Theorem Y_correct : forall f, exists t, ([[{Y} f]] ==>* t) /\ ([[f ({Y} f)]] ==>* t).
Proof. Admitted.

(* Boolean logic. Church booleans are used. *)
(* T x y := x *)
(* F x y := y *)
Definition T : SKI. Admitted.
Theorem T_correct : forall x y, [[{T} x y]] ==>* [[x]].
Proof. Admitted.

Definition F : SKI. Admitted.
Theorem F_correct : forall x y, [[{F} x y]] ==>* [[y]].
Proof. Admitted.

(* Notations for expressing a term is extensionally equal to T or F, respectively. *)
Notation "t ~~>*T" := (forall x y, [[{t} x y]] ==>* [[x]]) (at level 90, only parsing).
Notation "t ~~>*F" := (forall x y, [[{t} x y]] ==>* [[y]]) (at level 90, only parsing).

Definition Not : SKI. Admitted.
Theorem NotT_F : [[{Not} {T}]] ~~>*F.
Proof. Admitted.
Theorem NotF_T : [[{Not} {F}]] ~~>*T.
Proof. Admitted.

Definition And : SKI. Admitted.
Theorem AndTT_T : [[{And} {T} {T}]] ~~>*T.
Proof. Admitted.
Theorem AndTF_F : [[{And} {T} {F}]] ~~>*F.
Proof. Admitted.
Theorem AndFT_F : [[{And} {F} {T}]] ~~>*F.
Proof. Admitted.
Theorem AndFF_F : [[{And} {F} {F}]] ~~>*F.
Proof. Admitted.

Definition Or : SKI. Admitted.
Theorem OrTT_T : [[{Or} {T} {T}]] ~~>*T.
Proof. Admitted.
Theorem OrTF_T : [[{Or} {T} {F}]] ~~>*T.
Proof. Admitted.
Theorem OrFT_T : [[{Or} {F} {T}]] ~~>*T.
Proof. Admitted.
Theorem OrFF_F : [[{Or} {F} {F}]] ~~>*F.
Proof. Admitted.

Definition Xor : SKI. Admitted.
Theorem XorTT_F : [[{Xor} {T} {T}]] ~~>*F.
Proof. Admitted.
Theorem XorTF_T : [[{Xor} {T} {F}]] ~~>*T.
Proof. Admitted.
Theorem XorFT_T : [[{Xor} {F} {T}]] ~~>*T.
Proof. Admitted.
Theorem XorFF_F : [[{Xor} {F} {F}]] ~~>*F.
Proof. Admitted.


Set Warnings "-notation-overridden".

From Equations Require Import Equations.
Unset Equations With Funext.

Generalizable All Variables.
Set Universe Polymorphism.
Set Nested Proofs Allowed.

Equations total : list nat -> nat :=
total nil := 0%nat;
total (cons x xs) := x + total xs.

Fixpoint total_app (xs ys : list nat) :
  total (xs ++ ys) = (total xs + total ys)%nat.
destruct xs.
{
  reflexivity.
}
{
  rewrite total_equation_2.
  simpl.
  rewrite total_equation_2.
  rewrite <- PeanoNat.Nat.add_assoc.
  f_equal.
  exact (total_app _ _).
}
Qed.


Require Import Coq.omega.Omega.
Require Import Examples.AutoSep.

Set Implicit Arguments.

Definition copyS : spec := SPEC("dst", "src", "sz") reserving 3
  Al src, Al dst,
  PRE[V] array src (V "src") * array dst (V "dst")
    * [| V "sz" = length src |] * [| V "sz" = length dst |]
  POST[_] array src (V "src") * array src (V "dst").

Definition agreeUpTo (a b : list W) (i : nat) :=
  exists c, length c = i
    /\ exists a', a = c ++ a'
    /\ exists b', b = c ++ b'.

Definition array := bmodule "array" {{
  bfunction "copy"("dst", "src", "sz", "i", "to", "from") [copyS]
    "i" <- 0;;

    [Al src, Al dst,
      PRE[V] array src (V "src") * array dst (V "dst")
        * [| V "sz" = length src |] * [| V "sz" = length dst |]
        * [| agreeUpTo dst src (wordToNat (V "i")) |]
      POST[_] array src (V "src") * array src (V "dst")]
    While ("i" < "sz") {
      "to" <- 4 * "i";;
      "to" <- "dst" + "to";;

      "from" <- 4 * "i";;
      "from" <- "src" + "from";;

      "from" <-* "from";;
      "to" *<- "from";;

      "i" <- "i" + 1
    };;

    Return 0
  end
}}.

Lemma agreeUpTo_0 : forall a b, agreeUpTo a b 0.
  unfold agreeUpTo; exists nil; simpl; eauto.
Qed.

Local Hint Resolve agreeUpTo_0.

Lemma agreeUpTo_S : forall a b n, agreeUpTo a b (wordToNat n)
  -> n < natToW (length a)
  -> n < natToW (length b)
  -> goodSize (length a)
  -> agreeUpTo (Array.upd a n (Array.sel b n)) b (wordToNat (n ^+ $1)).
  unfold agreeUpTo; intros;
    repeat match goal with
             | [ H : Logic.ex _ |- _ ] => destruct H; intuition; subst
           end; autorewrite with Arr in *.

  exists (x ++ Array.sel (x ++ x1) n :: nil).

  autorewrite with Arr; simpl.
  rewrite H3; intuition eauto.

  destruct x1; simpl in *.
  rewrite H3 in H1.
  unfold natToW in H1; autorewrite with Arr in H1; generalize H1; clear; intros; nomega.

  destruct x0; simpl in *.
  rewrite H3 in H0.
  unfold natToW in H0; autorewrite with Arr in H0; generalize H0; clear; intros; nomega.

  exists x0; autorewrite with Arr; intuition.
  exists x1; autorewrite with Arr; intuition.
Qed.

Local Hint Resolve agreeUpTo_S.

Lemma agreeUpTo_done : forall a b n,
  agreeUpTo a b n
  -> (length a <= n)%nat
  -> (length b <= n)%nat
  -> a = b.
  unfold agreeUpTo; firstorder; subst.
  rewrite app_length in *.
  assert (length x0 = 0) by omega.
  destruct x0; simpl in *; try omega.
  destruct x1; simpl in *; try omega.
  auto.
Qed.

Local Hint Extern 1 (_ < _) => congruence.

Theorem arrayOk : moduleOk array.
  vcgen; abstract (sep_auto;
    match goal with
      | [ |- himp _ (Array.array ?A _) (Array.array ?B _) ] =>
        replace B with A by (eapply agreeUpTo_done; eauto 10); reflexivity
      | _ => eauto 10
    end).
Qed.


(*
  Author(s):
    Andrej Dudenhefner (1)
  Affiliation(s):
    (1) TU Dortmund University, Dortmund, Germany
*)

(*
  Abstract machine for closed L-term evaluation.

  A closed L-term s evaluates to a term t iff
  the abstract "machine" relates s with some closure y such that flatten y = t
*)

Require Import List Relations.
Import ListNotations.
Require Import Undecidability.L.L Undecidability.L.Util.L_facts.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

(* (closure ctx t) is a L-term t in the environment ctx *)
Inductive eterm := closure : list eterm -> term -> eterm.

Inductive machine : eterm -> list (bool * eterm) -> eterm -> Prop :=
  | machine_var_0 x xs vs y :
      machine x vs y ->
      machine (closure (x :: xs) (var 0)) vs y
  | machine_var_S x xs n vs y :
      machine (closure xs (var n)) vs y ->
      machine (closure (x :: xs) (var (S n))) vs y
  | machine_app xs s t vs y :
      machine (closure xs s) ((true, (closure xs t)) :: vs) y ->
      machine (closure xs (app s t)) vs y
  | machine_lam_swap xs s z vs y :
      machine z ((false, (closure xs s)) :: vs) y ->
      machine (closure xs (lam s)) ((true, z) :: vs) y
  | machine_lam_subst xss xts s t vs y :
      machine (closure ((closure xts (lam t)) :: xss) s) vs y ->
      machine (closure xts (lam t)) ((false, (closure xss s)) :: vs) y
  | machine_lam xs s :
      machine (closure xs (lam s)) nil (closure xs (lam s)).

(* generic facts *)
Module Facts.

(* transforms a goal (A -> B) -> C into goals A and B -> C *)
Lemma unnest : forall (A B C : Type), A -> (B -> C) -> (A -> B) -> C.
Proof. auto. Qed.

Lemma cons_inj {X : Type} {x1 x2 : X} {l1 l2} : x1 :: l1 = x2 :: l2 -> x1 = x2 /\ l1 = l2.
Proof. by case. Qed.

End Facts.

Import Facts.

(* highly sensitive! *)
Fixpoint subst_many (s : term) n (ts : list term) :=
  match s with
  | var x => nth x (map var (seq 0 n) ++ ts) (var x)
  | app s t => app (subst_many s n ts) (subst_many t n ts)
  | lam s => lam (subst_many s (S n) ts)
  end.

(* recursively substitute each local context *)
Fixpoint flatten (u : eterm) : term :=
  let '(closure ctx t) := u in subst_many t 0 (map flatten ctx).

Fixpoint term_size (t : term) : nat :=
  match t with
  | var n => S n
  | app s t => 1 + term_size s + term_size t
  | lam s => 2 + term_size s
  end.

Fixpoint eterm_size (u : eterm) : nat :=
  let '(closure ctx t) := u in list_sum (map eterm_size ctx) + (term_size t).

Definition context_size (ctx : list eterm) : nat :=
  eterm_size (closure ctx (var 0)).

Lemma term_size_S s : term_size s = S (Nat.pred (term_size s)).
Proof.
  elim: s => /=; lia.
Qed.

Lemma machineE xs s vs y : machine (closure xs s) vs y ->
  match s with
  | var 0 =>
    match xs with
    | x :: xs => machine x vs y
    | _ => False
    end
  | var (S n) =>
    match xs with
    | x :: xs => machine (closure xs (var n)) vs y
    | _ => False
    end
  | app s t => machine (closure xs s) ((true, (closure xs t)) :: vs) y
  | lam s =>
    match vs with
    | (true, z) :: vs => machine z ((false, (closure xs s)) :: vs) y
    | (false, (closure x's s')) :: vs => machine (closure ((closure xs (lam s)) :: x's) s') vs y
    | nil => True
    end
  end.
Proof.
  intros H. by inversion H.
Qed.

#[local] Notation all := (fold_right and True).

Fixpoint eclosed (u : eterm) :=
  let '(closure ctx t) := u in bound (length ctx) t /\ all (map eclosed ctx).

(* construct term from context *)
Fixpoint traverse (s : term) (vs : list (bool * eterm)) : term :=
  match vs with
  | nil => s
  | (true, u) :: vs => traverse (app s (flatten u)) vs
  | (false, closure xs u) :: vs => traverse (app (flatten (closure xs (lam u))) s) vs
  end.

Lemma boundE k s : bound k s ->
  match s with
  | var n => k > n
  | app s t => bound k s /\ bound k t
  | lam s => bound (S k) s
  end.
Proof. by case. Qed.

Lemma all_Forall {X : Type} {P : X -> Prop} {l : list X} : all (map P l) <-> Forall P l.
Proof.
  elim: l; [done|].
  move=> x l IH /=. split.
  - move=> [? /IH ?]. by constructor.
  - by move=> /Forall_cons_iff [? /IH ?].
Qed.

Lemma all_map_impl {X : Type} {P Q : X -> Prop} {l : list X} :
  (forall x, P x -> Q x) -> all (map P l) -> all (map Q l).
Proof.
  move=> /Forall_impl H /all_Forall /H ?. by apply /all_Forall.
Qed.

Lemma bound_subst_many s n ts : all (map closed ts) ->
  bound (n + length ts) s -> bound n (subst_many s n ts).
Proof.
  move=> Hts. elim: s n.
  - move=> x n /boundE ? /=.
    have [?|?] : x < n \/ n <= x by lia.
    + rewrite app_nth1. { by rewrite map_length seq_length. }
      by rewrite map_nth seq_nth; [|constructor].
    + rewrite app_nth2 map_length seq_length; [done|].
      apply: (@bound_ge 0); [|lia].
      apply /closed_dcl.
      rewrite (nth_indep _ _ (lam (var 0))); [lia|].
      case: (nth_in_or_default (x - n) ts (lam # 0)).
      * move: Hts => /all_Forall /Forall_forall. by apply.
      * by move=> ->.
  - move=> s IHs t IHt n /boundE [/IHs ? /IHt ?]. by constructor.
  - move=> s IHs n /boundE /(IHs (S n)) ?. by constructor.
Qed.

Lemma eclosed_closed_flatten x : eclosed x -> closed (flatten x).
Proof.
  elim /(induction_ltof1 _ eterm_size) : x.
  move=> [ctx s] /= IH [Hs] Hctx.
  apply /closed_dcl. apply: bound_subst_many; [|by rewrite map_length].
  rewrite map_map.
  apply /all_Forall /Forall_forall => y Hy. apply: IH.
  - rewrite /ltof /=.
    move: Hy => /(@in_split eterm) [?] [?] ->.
    rewrite map_app /= list_sum_app /= term_size_S. lia.
  - move: Hctx => /all_Forall /Forall_forall. by apply.
Qed.

Lemma bound_var_S_iff n x : bound (S n) (var (S x)) <-> bound n (var x).
Proof.
  split; intros H; inversion H; constructor; lia.
Qed.

Lemma traverse_step s t vs : step s t -> step (traverse s vs) (traverse t vs).
Proof.
  elim: vs s t; [done|].
  move=> [[] [xs u]] vs IH s t ?.
  - apply: IH. by apply: stepAppL.
  - apply: IH. by apply: stepAppR.
Qed.

Lemma subst_subst_many s n ts u : all (map closed ts) ->
  subst (subst_many s (S n) ts) n u = subst_many s n (u :: ts).
Proof.
  move=> Hts. elim: s n.
  - move=> x n. rewrite /subst_many.
    have -> : S n = n + 1 by lia.
    rewrite seq_app /= map_app -app_assoc /=.
    suff: forall k, subst (nth x (map var (seq k n) ++ (var (k+n)) :: ts) (var (k + x))) (k+n) u =
      nth x (map var (seq k n) ++ u :: ts) (var (k+x)) by apply.
    elim: n x.
    + move=> [|x] k /=; [by rewrite Nat.eqb_refl|].
      have : k + S x > k by lia.
      elim: ts Hts x (k + S x).
      * move=> _ [|x] ? /=; case Ek: (Nat.eqb _ _); move=> /Nat.eqb_spec in Ek; by [|lia].
      * move=> t ts IH /= [Ht ?] [|x] ??; [by apply: Ht|].
        by apply: IH.
    + move=> n IH [|x] k /=.
      * by case Ek: (Nat.eqb _ _); move=> /Nat.eqb_spec in Ek; [lia|].
      * rewrite -!Nat.add_succ_comm. by apply: IH.
  - move=> s IHs t IHt n /=. by rewrite IHs IHt.
  - move=> s IHs n /=. by rewrite IHs.
Qed.

Lemma flatten_app xs s t : flatten (closure xs (app s t)) = app (flatten (closure xs s)) (flatten (closure xs t)).
Proof. done. Qed.

Lemma flatten_lam xs s : flatten (closure xs (lam s)) = lam (subst_many s 1 (map flatten xs)).
Proof. done. Qed.

Lemma flatten_var xs x : flatten (closure xs (var x)) = nth x (map flatten xs) (var x).
Proof. done. Qed.

#[local] Arguments flatten : simpl never.

Definition eclosed_future v :=
  match v with
  | (true, x) => eclosed x
  | (false, closure xs s) => eclosed (closure xs (lam s))
  end.

Lemma machine_inverse_simulation x vs y : machine x vs y -> eclosed x -> Forall eclosed_future vs ->
  L.eval (traverse (flatten x) vs) (flatten y).
Proof.
  elim; cbn.
  - move=> {}x xs {}vs {}y _ IH.
    move=> [?] [??]. by apply: IH.
  - move=> {}x xs n {}vs {}y _ IH.
    move=> [/bound_var_S_iff] /[dup] /boundE Hxsn ? [? ?].
    rewrite flatten_var.
    rewrite (nth_indep _ _ (var n)). { rewrite map_length. cbn. lia. }
    by apply: IH.
  - move=> xs s t {}vs {}y _ IH.
    move=> [/boundE] [??] ??. by apply: IH; [|constructor].
  - move=> xs s z {}vs {}y _ IH [??] /Forall_cons_iff [??].
    by apply: IH; [|constructor].
  - move=> xss xts s t {}vs {}y _ IH.
    move=> [??] /Forall_cons_iff /= [[/boundE]] ? Hxss ?.
    apply: step_eval. { apply: traverse_step. by apply: stepApp. }
    suff -> : subst (subst_many s 1 (map flatten xss)) 0 (lam (subst_many t 1 (map flatten xts))) =
      subst_many s 0 (lam (subst_many t 1 (map flatten xts)) :: map flatten xss) by apply: IH.
    apply subst_subst_many.
    rewrite map_map. apply: all_map_impl Hxss.
    by apply: eclosed_closed_flatten.
  - move=> {}xs s *. by apply: eval_abs.
Qed.

#[local] Arguments in_split {A x l}.
#[local] Arguments ltof /.

Lemma flatten_closure_var_S x xs n :
  n < length xs ->
  flatten (closure (x :: xs) (var (S n))) = flatten (closure xs (var n)).
Proof.
  move=> ?.
  rewrite !flatten_var /=.
  apply: nth_indep. by rewrite map_length.
Qed.

Definition flatten_future v :=
  match v with
  | (true, x) => (true, flatten x)
  | (false, closure xs s) => (false, flatten (closure xs (lam s)))
  end.

Lemma machine_var_bound xs x vs y : machine (closure xs (var x)) vs y -> x < length xs.
Proof.
  elim: x xs.
  - move=> [|??] /machineE /=; lia.
  - move=> ? IH [|??] /machineE; [done|].
    move=> /IH /=. lia.
Qed.

Lemma flatten_closure_var_bound xs x : (if flatten (closure xs (var x)) is var _ then False else True) -> x < length xs.
Proof.
  rewrite flatten_var.
  move=> H. suff: not (length xs <= x) by lia.
  move=> ?. by rewrite nth_overflow in H; [rewrite map_length|].
Qed.

Lemma flatten_eq_var_S {xs s x' x's x} :
  flatten (closure xs s) = flatten (closure (x' :: x's) (var (S x))) ->
  if s is var _ then True else flatten (closure xs s) = flatten (closure x's (var x)).
Proof.
  move=> H.
  have := @flatten_closure_var_bound (x' :: x's) (S x).
  rewrite -H [in _ = _]H.
  move: s {H} => [] /=.
  - done.
  - move=> ?? /(_ Logic.I) ?. by rewrite flatten_closure_var_S; [lia|].
  - move=> ? /(_ Logic.I) ?. by rewrite flatten_closure_var_S; [lia|].
Qed.

Lemma eclosed_app xs s t : eclosed (closure xs (app s t)) -> eclosed (closure xs s) /\ eclosed (closure xs t).
Proof.
  move=> /= [/boundE]. tauto.
Qed.

Lemma eclosed_var_0 x xs : eclosed (closure (x :: xs) (var 0)) -> eclosed x.
Proof.
  by move=> [?] [?].
Qed.

Lemma eclosed_var_S x xs n : eclosed (closure (x :: xs) (var (S n))) -> eclosed (closure xs (var n)).
Proof.
  by move=> /= [/bound_var_S_iff ?] [??].
Qed.

(* machine is invariant closure flattening *)
Lemma machine_flatten_equiv {x1 vs1 y1 x2 vs2} :
  machine x1 vs1 y1 ->
  eclosed x1 ->
  eclosed x2 ->
  Forall eclosed_future vs1 ->
  Forall eclosed_future vs2 ->
  map flatten_future vs1 = map flatten_future vs2 ->
  flatten x1 = flatten x2 ->
  exists y2, flatten y1 = flatten y2 /\ machine x2 vs2 y2.
Proof.
  have H' : forall y1 (P Q : eterm -> Prop), (forall y2, P y2 -> Q y2) ->
    (exists y2 : eterm, flatten y1 = flatten y2 /\ P y2) ->
    (exists y2 : eterm, flatten y1 = flatten y2 /\ Q y2).
  { move=> > ? [y2] [??]. exists y2. firstorder done. }
  move=> H. elim: H x2 vs2.
  - move=> {}x1 xs1 {}vs1 {}y1 ? IH x2 vs2 /= [? [??]] ???. by apply: IH.
  - move=> {}x1 xs1 n1 {}vs1 {}y1 /machine_var_bound ? IH x2 vs2.
    rewrite flatten_closure_var_S. { done. }
    move=> /= [/bound_var_S_iff ? [??]].
    move=> /IH /[apply] /[apply] /[apply] /[apply]. by apply.
  - move=> xs1 s1 t1 {}vs1 {}y1 ? IH [xs2 u] vs2 Hs1t1 Hu Hvs1 Hvs2 ?.
    elim /(@induction_ltof1 _ context_size): xs2 u Hu.
    move=> xs2 IH2 [].
    + move=> [|x2].
      * move: xs2 IH2 => [|[? ?] ?]; [done|].
        move=> IH2 /eclosed_var_0 ?. rewrite flatten_var /=.
        move=> /IH2.
        apply: unnest. { rewrite /context_size /= term_size_S. lia. }
        apply: unnest. { done. }
        apply: H' => y2 ?. by apply: machine_var_0.
      * move: xs2 IH2 => [|[? ?] ?]; [done|].
        move=> IH2 /eclosed_var_S ? /flatten_eq_var_S /IH2.
        apply: unnest. { cbn. rewrite /list_sum term_size_S. lia. }
        apply: unnest. { done. }
        apply: H' => y2 ?. by apply: machine_var_S.
    + move=> s2 t2. move: Hs1t1. rewrite !flatten_app.
      move=> /eclosed_app [??] /eclosed_app [??].
      move=> [+ ?] => /IH => /(_ ((true, closure xs2 t2) :: vs2)).
      apply: unnest. { done. }
      apply: unnest. { done. }
      apply: unnest. { by constructor. }
      apply: unnest. { by constructor. }
      apply: unnest. { cbn. by congruence. }
      move=> [y2] [? ?]. exists y2. split; [done|].
      by apply: machine_app.
    + done.
  - move=> xs1 s1 z1 {}vs1 {}y1 ? IH [xs2 u] vs2 Hs1 Hu Hvs1 Hvs2 Hvs.
    elim /(@induction_ltof1 _ context_size): xs2 u Hu.
    move=> xs2 IH2 [].
    + move=> [|x2].
      * move: xs2 IH2 => [|[? ?] ?]; [done|].
        move=> IH2 /eclosed_var_0 ?. rewrite flatten_var /=.
        move=> /IH2.
        apply: unnest. { rewrite /context_size /= term_size_S. lia. }
        apply: unnest. { done. }
        apply: H' => y2 ?. by apply: machine_var_0.
      * move: xs2 IH2 => [|[? ?] ?]; [done|].
        move=> IH2 /eclosed_var_S ? /flatten_eq_var_S /IH2.
        apply: unnest. { cbn. rewrite /list_sum term_size_S. lia. }
        apply: unnest. { done. }
        apply: H' => y2 ?. by apply: machine_var_S.
    + done.
    + move=> s2. move: Hvs1 => /Forall_cons_iff [Hz1 Hvs1].
      move: vs2 Hvs Hvs2 {IH2} => [|[[] [xss2 t2]]vs2]; [done| |done].
      move=> /= /cons_inj [] /pair_equal_spec [_] + ? /Forall_cons_iff [??] ? Hs.
      move=> /IH => /(_ ((false, closure xs2 s2) :: vs2)).
      apply: unnest. { done. }
      apply: unnest. { done. }
      apply: unnest. { by constructor. }
      apply: unnest. { by constructor. }
      apply: unnest. { cbn. by congruence. }
      apply: H' => y2 ?. by apply: machine_lam_swap.
  - move=> xss1 xts1 s1 t1 {}vs1 {}y1 ? IH [xs2 u] vs2 Ht1 Hu Hvs1 Hvs2 Hvs.
    elim /(@induction_ltof1 _ context_size): xs2 u Hu.
    move=> xs2 IH2 [].
    + move=> [|x2].
      * move: xs2 IH2 => [|[? ?] ?]; [done|].
        move=> IH2 /eclosed_var_0 ?. rewrite flatten_var /=.
        move=> /IH2.
        apply: unnest. { rewrite /context_size /= term_size_S. lia. }
        apply: unnest. { done. }
        apply: H' => y2 ?. by apply: machine_var_0.
      * move: xs2 IH2 => [|[? ?] ?]; [done|].
        move=> IH2 /eclosed_var_S ? /flatten_eq_var_S /IH2.
        apply: unnest. { cbn. rewrite /list_sum term_size_S. lia. }
        apply: unnest. { done. }
        apply: H' => y2 ?. by apply: machine_var_S.
    + done.
    + move=> t2 /= ?. move: Hvs1 => /= /Forall_cons_iff [Hs1 Hvs1].
      move: vs2 Hvs Hvs2 {IH2} => [|[[] [xss2 s2]]vs2]; [done|done|].
      move=> /= /cons_inj [] /pair_equal_spec [_] Hs.
      move=> + /Forall_cons_iff [] /= [/boundE ? Hxss2] ? Ht.
      move=> /(IH (closure (closure xs2 (lam t2) :: xss2) s2)).
      apply: unnest. { move: Ht1 Hs1 => /= [??] [/boundE ??]. tauto. }
      apply: unnest. { cbn. tauto. }
      apply: unnest. { done. }
      apply: unnest. { done. }
      apply: unnest.
      { move: (Hs). rewrite /flatten -/flatten /= Ht.
        move=> [].
        rewrite -subst_subst_many.
        { move: Hs1 => /= [?]. rewrite map_map.
          apply: all_map_impl. by apply: eclosed_closed_flatten. }
        rewrite -subst_subst_many.
        { move: Hxss2. rewrite map_map.
          apply: all_map_impl. by apply: eclosed_closed_flatten. }
        by move=> ->. }
      apply: H' => y2 ?. by apply: machine_lam_subst.
  - move=> xs1 s1 [xs2 u] [|??]; [|done].
    move=> _ _ _ _ _.
    elim /(@induction_ltof1 _ context_size): xs2 u.
    move=> xts2 IH2 [].
    + move=> [|x2].
      * move: xts2 IH2 => [|[? ?] ?]; [done|].
        move=> IH2. rewrite flatten_var /=.
        move=> /IH2. apply: unnest. { rewrite /context_size /= term_size_S. lia. }
        apply: H' => y2 ?. by apply: machine_var_0.
      * move: xts2 IH2 => [|[? ?] ?]; [done|].
        move=> IH2 /flatten_eq_var_S /IH2.
        apply: unnest. { cbn. rewrite /list_sum term_size_S. lia. }
        apply: H' => y2 ?. by apply: machine_var_S.
    + done.
    + move=> s2 ?. eexists. split; [eassumption|].
      by apply: machine_lam.
Qed.

(* reduces rhs only if lhs is already lam *)
Inductive step' : term -> term -> Prop :=
  | step'App  s t     : step' (app (lam s) (lam t)) (subst s 0 (lam t))
  | step'AppR s t  t' : step' t t' -> step' (app (lam s) t) (app (lam s) t')
  | step'AppL s s' t  : step' s s' -> step' (app s t) (app s' t).

Lemma subst_many_nil s n : subst_many s n [] = s.
Proof.
  elim: s n.
  - move=> x n /=. rewrite app_nil_r map_nth. congr var.
    have [?|?] : x < n \/ n <= x by lia.
    + by apply seq_nth.
    + apply nth_overflow. by rewrite seq_length.
  - by move=> /= ? + ? + ? => -> ->.
  - by move=> /= ? + ? => ->.
Qed.

Lemma flatten_term s : flatten (closure [] s) = s.
Proof.
  by apply subst_many_nil.
Qed.

Lemma subst_subst_many_single s n t : subst s n t = subst_many s n [t].
Proof.
  elim: s n.
  - move=> x n /=.
    have [?|[->|Hxn]] : x < n \/ x = n \/ (x - n = S (x - n - 1)) by lia.
    + rewrite app_nth1. { by rewrite map_length seq_length. }
      rewrite map_nth seq_nth. { done. }
      case E: (Nat.eqb _ _); move=> /Nat.eqb_spec in E; [lia|done].
    + rewrite Nat.eqb_refl. by rewrite app_nth2 map_length seq_length ?Nat.sub_diag.
    + case E: (Nat.eqb _ _); move=> /Nat.eqb_spec in E; [lia|].
      rewrite app_nth2 map_length seq_length. { lia. }
      rewrite Hxn /=. by case: (x - n - 1).
  - by move=> ? + ? + ? /= => -> ->.
  - by move=> ? + ? /= => ->.
Qed.

Lemma step'_machine s t vs y : step' s t -> closed s -> Forall eclosed_future vs ->
  machine (closure [] t) vs y -> exists y', flatten y' = flatten y /\ machine (closure [] s) vs y'.
Proof.
  move=> H. elim: H vs y.
  - move=> {}s {}t vs y /closed_app [/closed_dcl /boundE Hs /closed_dcl Ht] Hvs IH.
    have : flatten (closure [] (subst s 0 (lam t))) = flatten (closure [closure [] (lam t)] s).
    { rewrite /flatten -/flatten /= !flatten_term subst_many_nil. by apply: subst_subst_many_single. }
    move: IH => /machine_flatten_equiv /[apply] => /(_ vs).
    apply: unnest. { by split; [apply: closed_subst|]. }
    apply: unnest. { done. }
    move=> /(_ Hvs Hvs erefl) [y' [? ?]].
    exists y'. split; [done|].
    apply: machine_app.
    apply: machine_lam_swap.
    by apply: machine_lam_subst.
  - move=> {}s {}t u ? IH vs y /closed_app [Hs Ht] Hvs.
    move=> /machineE /machineE /(IH _ y Ht).
    apply: unnest. { constructor; [|done]. by split; [apply /closed_dcl|]. }
    move=> [y'] [??].
    exists y'. split; [done|].
    apply: machine_app. by apply: machine_lam_swap.
  - move=> {}s {}t u ? IH vs y /closed_app [Hs ?] Hvs.
    move=> /machineE /(IH _ y Hs).
    apply: unnest. { constructor; [|done]. by split; [apply /closed_dcl|]. }
    move=> [y'] [??].
    exists y'. by split; [|apply: machine_app].
Qed.

#[local] Notation steps' := (clos_refl_trans term step').

Lemma steps'AppL {s s' t} : steps' s s' -> steps' (app s t) (app s' t).
Proof.
  elim.
  - move=> *. apply: rt_step. by apply: step'AppL.
  - move=> *. by apply: rt_refl.
  - move=> *. by apply: rt_trans; eassumption.
Qed.

Lemma steps'AppR {s t t'} : steps' t t' -> steps' (app (lam s) t) (app (lam s) t').
Proof.
  elim.
  - move=> *. apply: rt_step. by apply: step'AppR.
  - move=> *. by apply: rt_refl.
  - move=> *. by apply: rt_trans; eassumption.
Qed.

Lemma eval_is_lam s t : L.eval s t -> exists t', t = lam t'.
Proof.
  by elim => *; [eexists|].
Qed.

Lemma eval_steps' s t : L.eval s t -> steps' s t.
Proof.
  elim. { move=> ?. by apply: rt_refl. }
  move=> {}s s' {}t t' u' _ Hss' /eval_is_lam [t''] -> Htt' _ H.
  apply: rt_trans; [|eassumption].
  apply: rt_trans. { by apply: (steps'AppL Hss'). }
  apply: rt_trans. { by apply: (steps'AppR Htt'). }
  apply: rt_step. by apply: step'App.
Qed.

Lemma step_step' s t : step' s t -> step s t.
Proof.
  elim; by auto using step with nocore.
Qed.

Lemma step'_closed s t : step' s t -> closed s -> closed t.
Proof.
  by move=> /step_step' /closed_step.
Qed.

Lemma machine_simulation {s t} : L.eval s t -> closed s ->
  exists y, flatten y = t /\ machine (closure [] s) [] y.
Proof.
  move=> /[dup] + /eval_is_lam [t'].
  move=> /eval_steps' /clos_rt_rt1n_iff. elim.
  { move=> ? -> ?. eexists. by split; [apply flatten_term|apply machine_lam]. }
  move=> {}s u {}t /[dup] /step'_machine Hsu /step'_closed H'su _ /[apply].
  move=> + /[dup] /H'su => /[apply] - [y] [<-].
  move=> /Hsu /[apply]. by apply.
Qed.

(*
  A closed L-term s evaluates to a term t iff
  machine relates s with some y such that flatten y = t
*)
Theorem machine_correctness {s t} : closed s -> (L.eval s t) <->
  (exists y, flatten y = t /\ machine (closure [] s) [] y).
Proof.
  move=> Hs. split.
  - move=> /machine_simulation. by apply.
  - move=> [?] [+] /machine_inverse_simulation.
    move=> ->. rewrite flatten_term.
    move=> /closed_dcl in Hs. by apply.
Qed.


Require Import Ctl.BinaryRelations.
Require Import Ctl.Paths.
Require Import Ctl.Definition.
Open Scope tprop_scope.

Section Basic.

Context (state: Type) (R: relation state) {T: transition R} (s: state).

Theorem tentails_ttop :
  R @s ⊨ ⊤.
Proof using. intros; exact I. Qed.

Theorem ntentails_tbot :
  R @s ⊭ ⊥.
Proof using. auto. Qed.

Theorem tentails_tconj : forall P Q,
  R @s ⊨ P ->
  R @s ⊨ Q ->
  R @s ⊨ P && Q.
Proof using.
  intros.
  split; assumption.
Qed.

Theorem rew_tconj : forall P Q,
  R @s ⊨ P && Q =
  (R @s ⊨ P /\ R @s ⊨ Q).
Proof using. reflexivity. Qed.

Theorem tentails_tdisj_l : forall P Q,
  R @s ⊨ P ->
  R @s ⊨ P || Q.
Proof using.
  intros.
  left.
  assumption.
Qed.

Theorem tentails_tdisj_r : forall P Q,
  R @s ⊨ Q ->
  R @s ⊨ P || Q.
Proof using.
  intros.
  right.
  assumption.
Qed.

Theorem rew_tdisj : forall P Q,
  R @s ⊨ P || Q =
  (R @s ⊨ P \/ R @s ⊨ Q).
Proof using. reflexivity. Qed.

Theorem rew_timpl : forall P Q,
  R @s ⊨ P ⇾ Q =
  (R @s ⊨ P -> R @s ⊨ Q).
Proof using. reflexivity. Qed.

Theorem rew_tbiimpl : forall P Q,
  R @s ⊨ P ⇿ Q =
  (R @s ⊨ P <-> R @s ⊨ Q).
Proof using. reflexivity. Qed.

Theorem rew_tnot : forall P,
  R @s ⊨ !P =
  (R @s ⊭ P).
Proof using. reflexivity. Qed.

Theorem rew_tlift : forall P,
  R @s ⊨ ⟦P⟧ =
  P s.
Proof using. reflexivity. Qed.

Theorem rew_AX : forall P,
  R @s ⊨ AX P =
  forall s', R s s' -> R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_EX : forall P,
  R @s ⊨ EX P =
  exists s', R s s' /\ R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_AG : forall P,
  R @s ⊨ AG P =
  forall (p: path R s) s', in_path s' p -> R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_EG : forall P,
  R @s ⊨ EG P =
  exists p: path R s, forall s', in_path s' p -> R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_AF : forall P,
  R @s ⊨ AF P =
  forall p: path R s, exists s', in_path s' p /\ R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_EF : forall P,
  R @s ⊨ EF P =
  exists (p: path R s) s', in_path s' p /\ R @s' ⊨ P.
Proof using. reflexivity. Qed.

Theorem rew_AU : forall P Q,
  R @s ⊨ A[P U Q] =
  forall p: path R s, exists i,
    (forall x, in_path_before x i p -> R @x ⊨ P) /\
    R @(p i) ⊨ Q.
Proof using. reflexivity. Qed.

Theorem rew_EU : forall P Q,
  R @s ⊨ E[P U Q] =
  exists (p: path R s) i,
    (forall x, in_path_before x i p -> R @x ⊨ P) /\
    R @(p i) ⊨ Q.
Proof using. reflexivity. Qed.

Theorem rew_AW : forall P Q,
  R @s ⊨ A[P W Q] =
  forall p: path R s,
    (forall x, in_path x p -> R @x ⊨ P && !Q) \/
    (exists i,
      (forall x, in_path_before x i p -> R @x ⊨ P) /\
      R @(p i) ⊨ Q).
Proof using. reflexivity. Qed.

End Basic.
Close Scope tprop_scope.


Require Export euclidean__axioms.
Require Export lemma__TCreflexive.
Definition lemma__ETreflexive : forall A B C, (euclidean__axioms.Triangle A B C) -> (euclidean__axioms.ET A B C A B C).
Proof.
intro A.
intro B.
intro C.
intro H.
assert (euclidean__axioms.nCol A B C) as H0 by exact H.
assert (* Cut *) (euclidean__axioms.Cong__3 A B C A B C) as H1.
- apply (@lemma__TCreflexive.lemma__TCreflexive A B C H0).
- assert (* Cut *) (euclidean__axioms.ET A B C A B C) as H2.
-- apply (@euclidean__axioms.axiom__congruentequal A B C A B C H1).
-- exact H2.
Qed.


(* The curly less then equal operator defined in tech report *)

Inductive curlyless : trace -> trace -> Prop :=
	| fewerblocks :
		forall t1 t2,
		(numblocks t1 <= numblocks t2) ->
		(curlyless t1 t2)

	| othercurlyless1 :
		forall t1' t1'' t2' t2'',
		(numblocks t1' + numblocks t1'' =
				numblocks t2' + numblocks t2'') ->
		(numblocks t1' >numblocks t2') ->
		(curlyless (concat t1' t1'') (concat t2' t2''))

	| othercurlyless2 :
		forall t1' t1'' t2' t2'',
		(numblocks t1' + numblocks t1'' =
				numblocks t2' + numblocks t2'') ->
		(numblocks t1'  = numblocks t2') ->
		(curlyless t1' t2') ->
		(curlyless (concat t1' t1'') (concat t2' t2''))

	| othercurlyless3 :
		forall t1' t1'' t2' t2'',
		(numblocks t1' + numblocks t1'' =
				numblocks t2' + numblocks t2'') ->
		(t1' = t2') ->
		(curlyless t1'' t2'') ->
		(curlyless (concat t1' t1'') (concat t2' t2'')).


Definition N := 6.

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

Fixpoint binary_tree c n :=
  match n with
  | 0 => Leaf
  | S n =>
    let t := binary_tree c n in
    Node c t t
  end.

Definition t0 := Eval vm_compute in binary_tree 0 N.
Definition t1 := Eval vm_compute in binary_tree 1 N.


Require Import Coq.Setoids.Setoid.

Require Import Brzozowski.Alphabet.
Require Import Brzozowski.Derive.
Require Import Brzozowski.Language.
Require Import Brzozowski.Setoid.

Require Import Coinduction.Bisimilar.

(* bisimilar_setoid makes it possible to use:
  - rewrite for proven bisimilar theorems
  - reflexivity for bisimilar relations where both sides are equal
*)

Section BisimilarSetoid.

Theorem bisimilar_refl : forall A:lang, A <<->> A.
  Proof.
    intros.
    rewrite bisimilar_is_equivalence.
    apply Brzozowski.Setoid.lang_iff_refl.
  Qed.

Theorem bisimilar_trans : forall A B C:lang, (A <<->> B) -> (B <<->> C) -> (A <<->> C).
  Proof.
    intros.
    rewrite bisimilar_is_equivalence in *.
    apply (Brzozowski.Setoid.lang_iff_trans A B C); assumption.
  Qed.

Theorem bisimilar_sym : forall A B:lang, (A <<->> B) -> (B <<->> A).
  Proof.
    intros.
    rewrite bisimilar_is_equivalence in *.
    apply (Brzozowski.Setoid.lang_iff_sym A B); assumption.
  Qed.

Add Parametric Relation: lang bisimilar
  reflexivity proved by bisimilar_refl
  symmetry proved by bisimilar_sym
  transitivity proved by bisimilar_trans as bisimilar_setoid.

End BisimilarSetoid.

Existing Instance bisimilar_setoid.

Add Parametric Morphism : bisimilar
  with signature lang_iff ==> lang_iff ==> iff as bisimilar_lang_morphism.
Proof.
  intros ?? H ?? H'.
  apply  bisimilar_is_equivalence in H, H'.
  split; intro H0.
  now rewrite <- H, H0.
  now rewrite H, H'.
Qed.

Example example_rewriting_using_lang_iff_in_bisimilar:
  forall (P Q: lang)
  (pq: P {<->} Q),
  bisimilar Q P.
Proof.
  intros.
  rewrite pq.
  reflexivity.
Qed.

Add Parametric Morphism: or_lang
  with signature bisimilar ==> bisimilar ==> bisimilar as or_bisim_morph.
Proof.
intros.
rewrite bisimilar_is_equivalence in *.
apply or_lang_morph; assumption.
Qed.

Add Parametric Morphism: neg_lang
  with signature bisimilar ==> bisimilar as neg_bisim_morph.
Proof.
intros.
rewrite bisimilar_is_equivalence in *.
apply neg_lang_morph; assumption.
Qed.

Add Parametric Morphism: concat_lang
  with signature bisimilar ==> bisimilar ==> bisimilar as concat_bisim_morph.
Proof.
intros.
rewrite bisimilar_is_equivalence in *.
apply concat_lang_morph; assumption.
Qed.

Add Parametric Morphism: star_lang
  with signature bisimilar ==> bisimilar as star_bisim_morph.
Proof.
intros.
rewrite bisimilar_is_equivalence in *.
apply star_lang_morph; assumption.
Qed.

Add Parametric Morphism {s: str}: (elem s)
  with signature bisimilar ==> iff
  as elem_bisim_morph.
Proof.
intros.
rewrite bisimilar_is_equivalence in *.
apply elem_morph; assumption.
Qed.

Add Parametric Morphism {s: str}: (derive_langs s)
  with signature bisimilar ==> bisimilar
  as derive_langs_bisim_morph.
Proof.
intros.
rewrite bisimilar_is_equivalence in *.
apply derive_langs_morph; assumption.
Qed.

Add Parametric Morphism {a: alphabet}: (derive_lang a)
  with signature bisimilar ==> bisimilar
  as derive_lang_bism_morph.
Proof.
intros.
rewrite bisimilar_is_equivalence in *.
apply derive_lang_morph; assumption.
Qed.