(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir
     Arthur Charg\'eraud *)

Require Import Coq.Arith.Arith.
Require Import Coq.Arith.Max.
Require Import Coq.Classes.EquivDec.
Require Import Coq.Lists.List.
Require Import Coq.Structures.Equalities.

Require Import Coq.FSets.FSets.
Require Import Metalib.CoqListFacts.
Require Import Metalib.FSetExtra.
Require Import Metalib.FSetWeakNotin.
Require Import Metalib.LibTactics.

Require Import Omega.

(* ********************************************************************** *)
(** * Defining atoms *)

(** Atoms are structureless objects such that we can always generate
    one fresh from a finite collection.  Equality on atoms is [eq] and
    decidable.  We use Coq's module system to make abstract the
    implementation of atoms. *)

Module Type ATOM <: UsualDecidableType.

  Parameter atom : Set.
  Definition t := atom.

  Parameter eq_dec : forall x y : atom, {x = y} + {x <> y}.

  Parameter atom_fresh_for_list :
    forall (xs : list t), {x : atom | ~ List.In x xs}.

  Parameter fresh : list atom -> atom.

  Parameter fresh_not_in : forall l, ~ In (fresh l) l.

  Parameter nat_of : atom -> nat.

  Hint Resolve eq_dec : core.

  Include HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig.

End ATOM.

(** The implementation of the above interface is hidden for
    documentation purposes. *)

Module Atom : ATOM.

  (* begin hide *)
  Definition atom := nat.
  Definition t := atom.

  Definition eq_dec := eq_nat_dec.

  Lemma max_lt_r : forall x y z,
    x <= z -> x <= max y z.
  Proof.
    induction x. auto with arith.
    induction y. auto with arith.
      simpl. induction z. omega. auto with arith.
  Qed.

  Lemma nat_list_max : forall (xs : list nat),
    { n : nat | forall x, List.In x xs -> x <= n }.
  Proof.
    induction xs as [ | x xs [y H] ].
    (* case: nil *)
    exists 0. inversion 1.
    (* case: cons x xs *)
    exists (max x y). intros z J. simpl in J. destruct J as [K | K].
      subst. auto with arith.
      auto using max_lt_r.
  Qed.

  Lemma atom_fresh_for_list :
    forall (xs : list nat), { n : nat | ~ List.In n xs }.
  Proof.
    intros xs. destruct (nat_list_max xs) as [x H].
    exists (S x). intros J. lapply (H (S x)). omega. trivial.
  Qed.

  Definition fresh (l : list atom) :=
    match atom_fresh_for_list l with
      (exist _ x _) => x
    end.

  Lemma fresh_not_in : forall l, ~ In (fresh l) l.
  Proof.
    intro l. unfold fresh.
    destruct atom_fresh_for_list. auto.
  Qed.

  Definition nat_of := fun (x : atom) => x.

  Include HasUsualEq <+ UsualIsEq <+ UsualIsEqOrig.

  (* end hide *)

End Atom.

(** We make [atom], [fresh], [fresh_not_in] and [atom_fresh_for_list] available
    without qualification. *)

Notation atom := Atom.atom.
Notation fresh := Atom.fresh.
Notation fresh_not_in := Atom.fresh_not_in.
Notation atom_fresh_for_list := Atom.atom_fresh_for_list.

(* Automatically unfold Atom.eq *)
Global Arguments Atom.eq /.

(** It is trivial to declare an instance of [EqDec] for [atom]. *)

Instance EqDec_atom : @EqDec atom eq eq_equivalence.
Proof. exact Atom.eq_dec. Defined.

(* ********************************************************************** *)
(** * Finite sets of atoms *)

(** We use our implementation of atoms to obtain an implementation of
    finite sets of atoms.  We give the resulting type an intuitive
    name, as well as import names of set operations for use within
    this library.  In order to avoid polluting Coq's namespace, we do
    not use [Module Export]. *)

Module Import AtomSetImpl : FSetExtra.WSfun Atom :=
  FSetExtra.Make Atom.

Notation atoms :=
  AtomSetImpl.t.

(** The [AtomSetDecide] module provides the [fsetdec] tactic for
    solving facts about finite sets of atoms. *)

Module Export AtomSetDecide := Coq.FSets.FSetDecide.WDecide_fun Atom AtomSetImpl.

(** The [AtomSetNotin] module provides the [destruct_notin] and
    [solve_notin] for reasoning about non-membership in finite sets of
    atoms, as well as a variety of lemmas about non-membership. *)

Module Export AtomSetNotin := FSetWeakNotin.Notin_fun Atom AtomSetImpl.

(** Given the [fsetdec] tactic, we typically do not need to refer to
    specific lemmas about finite sets.  However, instantiating
    functors from the FSets library makes a number of setoid rewrites
    available.  These rewrites are crucial to developments since they
    allow us to replace a set with an extensionally equal set (see the
    [Equal] relation on finite sets) in propositions about finite
    sets. *)

Module AtomSetFacts := FSetFacts.WFacts_fun Atom AtomSetImpl.
Module AtomSetProperties := FSetProperties.WProperties_fun Atom AtomSetImpl.

Export AtomSetFacts.

(* ********************************************************************** *)
(** * Properties *)

(** For any given finite set of atoms, we can generate an atom fresh
    for it. *)

Lemma atom_fresh : forall L : atoms, { x : atom | ~ In x L }.
Proof.
  intros L. destruct (atom_fresh_for_list (elements L)) as [a H].
  exists a. intros J. contradiction H.
  rewrite <- CoqListFacts.InA_iff_In. auto using elements_1.
Qed.

(* ********************************************************************** *)
(** * Tactic support for picking fresh atoms *)

(* begin hide *)

(** The auxiliary tactic [simplify_list_of_atom_sets] takes a list of
    finite sets of atoms and unions everything together, returning the
    resulting single finite set. *)

Ltac simplify_list_of_atom_sets L :=
  let L := eval simpl in L in
  let L := ltac_remove_dups L in
  let L := eval simpl in (List.fold_right union empty L) in
  match L with
    | context C [union ?E empty] => context C [ E ]
  end.

(* end hide *)

(** [gather_atoms_with F] returns the union of all the finite sets
    [F x] where [x] is a variable from the context such that [F x]
    type checks. *)

Ltac gather_atoms_with F :=
  let apply_arg x :=
    match type of F with
      | _ -> _ -> _ -> _ => constr:(@F _ _ x)
      | _ -> _ -> _ => constr:(@F _ x)
      | _ -> _ => constr:(@F x)
    end in
  let rec gather V :=
    match goal with
      | H : _ |- _ =>
        let FH := apply_arg H in
        match V with
          | context [FH] => fail 1
          | _ => gather (union FH V)
        end
      | _ => V
    end in
  let L := gather empty in eval simpl in L.

(** [beautify_fset V] assumes that [V] is built as a union of finite
    sets and returns the same set cleaned up: empty sets are removed
    and items are laid out in a nicely parenthesized way. *)

Ltac beautify_fset V :=
  let rec go Acc E :=
     match E with
     | union ?E1 ?E2 => let Acc2 := go Acc E2 in go Acc2 E1
     | empty => Acc
     | ?E1 => match Acc with
                | empty => E1
                | _ => constr:(union E1 Acc)
              end
     end
  in go empty V.

(** The tactic [pick fresh Y for L] takes a finite set of atoms [L]
    and a fresh name [Y], and adds to the context an atom with name
    [Y] and a proof that [~ In Y L], i.e., that [Y] is fresh for [L].
    The tactic will fail if [Y] is already declared in the context.

    The variant [pick fresh Y] is similar, except that [Y] is fresh
    for "all atoms in the context."  This version depends on the
    tactic [gather_atoms], which is responsible for returning the set
    of "all atoms in the context."  By default, it returns the empty
    set, but users are free (and expected) to redefine it. *)

Ltac gather_atoms :=
  constr:(empty).

Tactic Notation "pick" "fresh" ident(Y) "for" constr(L) :=
  let Fr := fresh "Fr" in
  let L := beautify_fset L in
  (destruct (atom_fresh L) as [Y Fr]).

Tactic Notation "pick" "fresh" ident(Y) :=
  let L := gather_atoms in
  pick fresh Y for L.

Ltac pick_fresh y :=
  pick fresh y.

(** Example: We can redefine [gather_atoms] to return all the
    "obvious" atoms in the context using the [gather_atoms_with] thus
    giving us a "useful" version of the "[pick fresh]" tactic. *)

Ltac gather_atoms ::=
  let A := gather_atoms_with (fun x : atoms => x) in
  let B := gather_atoms_with (fun x : atom => singleton x) in
  constr:(union A B).

Lemma example_pick_fresh_use : forall (x y z : atom) (L1 L2 L3: atoms), True.
(* begin show *)
Proof.
  intros x y z L1 L2 L3.
  pick fresh k.

  (** At this point in the proof, we have a new atom [k] and a
      hypothesis [Fr] that [k] is fresh for [x], [y], [z], [L1], [L2],
      and [L3]. *)

  trivial.
Qed.
(* end show *)


(** A library for finite sets with extensional equality.

    Author: Brian Aydemir. *)

Require Import FSets.
Require Import ListFacts.
Require Import Coq.Logic.ProofIrrelevance.

(* *********************************************************************** *)
(** * Interface *)

(** The following interface wraps the standard library's finite set
    interface with an additional property: extensional equality. *)

Module Type S.

  Declare Module E : UsualOrderedType.
  Declare Module F : FSetInterface.S with Module E := E.

  Parameter eq_if_Equal :
    forall s s' : F.t, F.Equal s s' -> s = s'.

End S.

(* *********************************************************************** *)
(** * Implementation *)

(** For documentation purposes, we hide the implementation of a
    functor implementing the above interface.  We note only that the
    implementation here assumes (as an axiom) that proof irrelevance
    holds. *)

Module Make (X : UsualOrderedType) <: S with Module E := X.

  (* begin hide *)

  Module E := X.
  Module F := FSetList.Make E.
  Module OFacts := OrderedType.OrderedTypeFacts E.

  Lemma eq_if_Equal :
    forall s s' : F.t, F.Equal s s' -> s = s'.
  Proof.
    intros [s1 pf1] [s2 pf2] Eq.
    assert (s1 = s2).
      unfold F.MSet.Raw.t in *.
      eapply Sort_InA_eq_ext; eauto.
      intros; eapply E.lt_trans; eauto.
      apply E.lt_not_eq.
      apply F.MSet.Raw.isok_iff. auto.
      apply F.MSet.Raw.isok_iff. auto.
    subst s1.
    assert (pf1 = pf2).
    apply proof_irrelevance.
    subst pf2.
    reflexivity.
  Qed.

  (* end hide *)

End Make.


(****************************************************************)
(*  On monadic parametricity of second-order functionals        *)
(*  by Bauer A., Hofmann M., Karbyshev A.                       *)
(*                                                              *)
(*  Aleksandr Karbyshev                                         *)
(*  May 2012                                                    *)
(*  Build with Coq 8.4 + Ssreflect 1.4                          *)
(****************************************************************)

Require Import ssreflect ssrfun.
Require Import FunctionalExtensionality.
Set Automatic Coercions Import.
Require Import relations.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Functional.
Variables A B C : Set.

Definition FuncType : Type :=
  forall (T : monadType), (A -> T B) -> T C.
End Functional.

Section Purity.
Variables A B C : Set.

Definition isPure (F : FuncType A B C) : Prop
  := forall (T T' : monadType) (TRacc : TRaccType T T'),
    ((IdR (X := A) =R=> (TR TRacc) _ _ (IdR (X := B))) =R=>
       (TR TRacc) _ _ (IdR (X := C))) (F T) (F T').
End Purity.

Section Strategy.
Variables A B C : Set.

Inductive Tree :=
  Ans : C -> Tree
| Que : A -> (B -> Tree) -> Tree.

Definition fun2tree (F : FuncType A B C) := F (Cont Tree) Que Ans.

Fixpoint tree2funT (T : monadType) (t : Tree) :=
  match t with
    | Ans c => fun k => tval T c
    | Que a f =>
        fun k => tbind (k a) (fun b => tree2funT T (f b) k)
  end.

Definition tree2fun (t : Tree) : FuncType A B C.
move => T. by apply: (tree2funT t).
Defined.

Lemma tree2fun_simpl (t : Tree) (T : monadType) :
  @tree2fun t T = tree2funT t.
Proof.
by rewrite /tree2fun.
Qed.

Lemma tree2fun_pure (t : Tree) : isPure (@tree2fun t).
Proof.
rewrite /isPure.
elim: t => [| a f Hind].
- rewrite /ArrR. by intuition; apply TRacc.
- rewrite /ArrR /=. rewrite /ArrR /= in Hind.
  move => T T' TRacc k k' H /=.
  eapply (proj2 (Acc TRacc)); first by eapply H.
  rewrite /ArrR => b b' /=; elim. by apply: Hind.
Qed.

Lemma tree2fun2tree (t : Tree) : fun2tree (tree2fun t) = t.
Proof.
rewrite /fun2tree.
elim: t => [// | a f Hind /=].
f_equal. by apply: functional_extensionality.
Qed.

Section conversion.
Variable S : Type.
Variable q : A -> (B -> S) -> S.
Variable a : C -> S.

Definition conv (t : Tree) := @tree2funT (Cont S) t q a.

Definition TRacc1 : TRaccType (Cont Tree) (Cont S).
exists
  (fun X X' (R : Rel X X') => fun H H' =>
    forall h h', (R =R=> Gr conv) h h' -> Gr conv (H h) (H' h')).
split.
- by move => /=; intuition.
- move => X X' Y Y' Q R f f' t t' H H0.
  move => h h' Hhh'. apply: H => x x' Hxx'. by firstorder.
Defined.
End conversion.

Lemma fun2tree2fun_Cont S (F : FuncType A B C) (Hpure : isPure F) :
  @tree2funT (Cont S) (fun2tree F) = F (Cont S).
Proof.
extensionality q. extensionality a.
suff H : Gr (conv q a) (F (Cont Tree) Que Ans) (F (Cont S) q a); first by elim: H.
rewrite /isPure in Hpure.
have H := @Hpure _ _ (TRacc1 q a) => {Hpure}.
apply: H.
- move => a1 a1' /=; elim. move => h h' Hhh'.
  rewrite /Gr /conv /=.
  f_equal. extensionality b. by firstorder.
- by move => c c'; elim.
Qed.

Definition Phi (T : monadType) (F : (A -> Cont (T C) B) -> Cont (T C) C)
  : (A -> T B) -> T C.
move => h. by refine (F ((@tbind _ _ _) \o h) (@tval _ _)).
Defined.

Definition TRacc2 (T : monadType) : TRaccType (Cont (T C)) T.
exists
  (fun X X' (R : Rel X X') => fun H H' =>
    forall h h', (R =R=> @IdR (T C)) h h' ->
      (@IdR (T C) (H h) (tbind H' h'))).
split.
- move => X X' R x x' H h h' H1 /=. rewrite taxiom0. by intuition.
- move => X X' Y Y' Q R f f' t t' H H0.
  move => h h' Hhh'. rewrite taxiom2 //. apply: H => x x' Hxx'. by apply: H0.
Defined.

Lemma lem_Phi (T : monadType) (F : FuncType A B C) (Hpure : isPure F) :
  Phi (F (Cont (T C))) = F T.
Proof.
extensionality g.
rewrite /Phi -[X in _ = X]taxiom1.
have H := @Hpure _ _ (TRacc2 T) => {Hpure}.
apply: H.
- move => a a'. elim. move => h h' Hhh'.
  suff Htmp: h = h'; first by rewrite Htmp.
  by extensionality x; apply: Hhh'.
- by move => c c'; elim.
Qed.

Theorem fun2tree2fun (F : FuncType A B C) (Hpure : isPure F) :
  forall (T : monadType), @tree2fun (fun2tree F) T = @F T.
Proof.
move => T.
rewrite -lem_Phi; last by apply: tree2fun_pure.
rewrite /tree2fun. rewrite fun2tree2fun_Cont //=.
by apply: lem_Phi.
Qed.

(* utils *)
Definition evaltree (t : Tree) (f : A -> B)
  := @tree2fun t Id f.

Lemma evaltree_Que x k f :
  evaltree (Que x k) f = evaltree (k (f x)) f.
Proof.
easy.
Qed.

Definition evaltree_unit (t : Tree) (f : A -> B)
  := fst ((@tree2fun t (State unit) ((@tval _ _) \o f)) tt).

Lemma evaltree_unit_Que x k f :
  evaltree_unit (Que x k) f = evaltree_unit (k (f x)) f.
Proof.
easy.
Qed.

Lemma evaltree_same (t : Tree) (f : A -> B) :
  evaltree t f = evaltree_unit t f.
Proof.
induction t; now firstorder.
Qed.

Definition is_pure (F : FuncType A B C)
  := {t : Tree | F = tree2fun t }.

End Strategy.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.

                    From adtind Require Import goal41.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_2  := ( Cons Zero (Cons Zero (Cons Zero Nil))).
Definition lfind_example_3  := ( Cons Zero Nil).
Definition lfind_example_4  := ( Cons (Succ (Succ Zero))         (Cons (Succ (Succ Zero)) (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_5  := ( Cons Zero Nil).
Definition lfind_example_6  := ( Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_7  := ( Nil).
Definition lfind_example_8  := ( Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)).
Definition lfind_example_9  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_10  := ( Cons Zero Nil).
Definition lfind_example_11  := ( Cons (Succ (Succ Zero))         (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_12  := ( Cons Zero (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))).
Definition lfind_example_13  := ( Cons (Succ Zero)         (Cons Zero            (Cons (Succ (Succ Zero)) (Cons (Succ Zero) (Cons Zero Nil))))).
Definition lfind_example_14  := ( Cons Zero (Cons (Succ (Succ (Succ (Succ (Succ Zero))))) Nil)).
Definition lfind_example_15  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_16  := ( Cons (Succ Zero) Nil).
Definition lfind_example_17  := ( Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_18  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_19  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_20  := ( Nil).
Definition lfind_example_21  := ( Cons (Succ Zero) Nil).
Definition lfind_example_22  := ( Cons (Succ Zero) (Cons (Succ Zero) (Cons Zero Nil))).
Definition lfind_example_23  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_24  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_25  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_26  := ( Nil).
Definition lfind_example_27  := ( Nil).
Definition lfind_example_28  := ( Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))).
Definition lfind_example_29  := ( Cons (Succ (Succ (Succ Zero)))         (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil))).
Definition lfind_example_30  := ( Cons (Succ (Succ (Succ Zero)))         (Cons (Succ (Succ Zero))            (Cons Zero (Cons Zero (Cons (Succ Zero) (Cons (Succ Zero) Nil)))))).
Definition lfind_example_31  := ( Nil).
Definition lfind_example_32  := ( Nil).
Definition lfind_example_33  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_34  := ( Cons (Succ Zero) Nil).
Definition lfind_example_35  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_36  := ( Nil).
Definition lfind_example_37  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal41_subset_append_general_85_mem_append/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 lfind_example_34 lfind_example_35 lfind_example_36 lfind_example_37 .


(** * RIS.closed_languages : languages closed by α-equivalence. *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import tools algebra language regexp alpha_regexp.

Section s.
  Context {atom : Set}{𝐀 : Atom atom}.
  Context {X : Set} {𝐗 : Alphabet 𝐀 X}.
  Definition α_closed : (@language letter) -> Prop := fun L => forall u v, u ≡ v -> L u <-> L v.

  Definition cl_α : language -> language := fun L w => exists u, L u /\ u ≡ w.

  Lemma cl_α_closed L : α_closed (cl_α L).
  Proof.
    intros u v e;split;intros (w&h&e');exists w;(split;[apply h|]).
    - rewrite e',e;reflexivity.
    - rewrite e',e;reflexivity.
  Qed.

  Lemma cl_α_idem l : cl_α (cl_α l) ≃ cl_α l.
  Proof.
    intro w;split.
    - intros (u&(v&h&e1)&e2).
      exists v;split.
      + assumption.
      + rewrite e1,e2;reflexivity.
    - intros (u&h&e);exists u;split.
      + exists u;split.
        * assumption.
        * reflexivity.
      + assumption.
  Qed.

  Lemma cl_α_incr l : l ≲ cl_α l.
  Proof.
    intros w h;exists w;split.
    - assumption.
    - reflexivity.
  Qed.

  Lemma cl_α_closed_idem L : α_closed L -> cl_α L ≃ L.
  Proof.
    intro A;apply inf_lang_PartialOrder;split;[|apply cl_α_incr].
    intros w (u&h&e).
    apply (A _ _ e),h.
  Qed.

  Global Instance inf_lang_cl_α : Proper (ssmaller ==> ssmaller) cl_α.
  Proof.
    intros l1 l2 e w (u&h&eu).
    exists u;split.
    - apply e,h.
    - assumption.
  Qed.

  Lemma minimal_cl_α L M : L ≲ M -> α_closed M -> cl_α L ≲ M.
  Proof. intros l A;rewrite <- (cl_α_closed_idem A);apply inf_lang_cl_α,l. Qed.

  Lemma cl_α_inf L M : cl_α L ≲ cl_α M <-> L ≲ cl_α M.
  Proof.
    split.
    - intros l;rewrite cl_α_incr;apply l.
    - intros l w (u&h&e).
      apply l in h as (v&h&e').
      exists v;split.
      + apply h.
      + rewrite e',e;reflexivity.
  Qed.

  Lemma cl_α_join L M : cl_α (L∪M) ≃ cl_α L ∪ cl_α M.
  Proof. intro w;unfold cl_α,join,joinLang;firstorder. Qed.

  Lemma cl_α_nil L : L [] <-> cl_α L [].
  Proof.
    split;intro I.
    + apply cl_α_incr,I.
    + destruct I as ([|l u]&I&E).
      * assumption.
      * apply αequiv_length in E;simpl in E;discriminate.
  Qed.

  Global Instance cl_α_eq_lang : Proper (sequiv ==> sequiv) cl_α.
  Proof. intros l m E u;unfold cl_α;setoid_rewrite (E _);tauto. Qed.

  Global Instance cl_α_inf_lang : Proper (ssmaller ==> ssmaller) cl_α.
  Proof. intros l m E u (v&I&E');apply E in I;exists v;tauto. Qed.

  Global Instance cl_α_αeq l : Proper (equiv ==> iff) (cl_α l).
  Proof. intros u v E;split;intros (w&I&Ew);exists w;split;assumption||rewrite Ew,E;reflexivity. Qed.

  Lemma cl_α_prod l m: cl_α (l · m) ≃ cl_α (cl_α l · cl_α m).
  Proof.
    apply inf_lang_PartialOrder;split;[|unfold Basics.flip].
    - apply cl_α_inf_lang,joinOrderLang.
      apply proper_prod_inf;apply joinOrderLang, cl_α_incr.
    - intros u (w&(u1&u2&->&(v1&I1&E1)&v2&I2&E2)&E).
      exists (v1++v2);split.
      + exists v1,v2;tauto.
      + rewrite E1,E2,E;reflexivity.
  Qed.

  Lemma cl_α_star l: cl_α (l⋆) ≃ cl_α ((cl_α l)⋆).
  Proof.
    apply inf_lang_PartialOrder;split;[|unfold Basics.flip].
    - apply cl_α_inf_lang,joinOrderLang,proper_star_inf,joinOrderLang,cl_α_incr.
    - intros u (w&(n&I)&E);rewrite <- E;clear E u; revert w I;induction n;simpl;intros w.
      + intros ->; exists [];simpl;split;[exists 0|];reflexivity.
      + intros (u1&u2&->&(u1'&I1&E1)&I2).
        apply IHn in I2 as (u2'&(n'&I2)&E2).
        exists (u1'++u2');split.
        * exists (S n'),u1',u2';tauto.
        * rewrite E1,E2;reflexivity.
  Qed.

  Definition restrict L A : (@language letter) := fun u => L u /\ ⌊u⌋ ⊆ A.

  Infix " ⇂ " := restrict (at level 20).

  Global Instance restrict_eqLists : Proper (sequiv ==> (@equivalent _) ==> sequiv) restrict.
  Proof.
    intros L M E2 A B E1 u;split;intros (Iu&Is);split;try apply E2,Iu.
    - rewrite <- E1;apply Is.
    - rewrite E1;apply Is.
  Qed.
  Global Instance restrict_inclLists : Proper (ssmaller ==> (@incl _) ==> ssmaller) restrict.
  Proof.
    intros L M E2 A B E1 u;intros (Iu&Is);split.
    - apply E2,Iu.
    - rewrite <- E1;apply Is.
  Qed.

  Proposition restrict_inf e f :
    cl_α ⟦e⟧ ≲ cl_α ⟦f⟧ <-> ⟦e⟧ ≲ (cl_α ⟦f⟧) ⇂ (⌊e⌋++⌊f⌋) .
  Proof.
    split.
    - intros h u I.
      split.
      + apply h;exists u;split.
        * assumption.
        * reflexivity.
      + rewrite (support_lang I);apply incl_appl;reflexivity.
    - intros I;apply cl_α_inf;intros u Ie.
      apply (I _ Ie).
  Qed.

  Proposition restrict_inf_bis e f :
    cl_α ⟦e⟧ ≲ cl_α ⟦f⟧ <-> (cl_α ⟦e⟧)⇂(⌊e⌋++⌊f⌋) ≲ (cl_α ⟦f⟧) ⇂ (⌊e⌋++⌊f⌋).
  Proof.
    rewrite restrict_inf;split;intros I u Iu;split.
    - destruct Iu as ((v&Iv&E)&R).
      apply I in Iv as ((w&Iw&Ew)&Rv).
      exists w;split.
      + assumption.
      + etransitivity;eauto.
    - apply Iu.
    - assert (Iu': (cl_α ⟦ e ⟧⇂(⌊ e ⌋ ++ ⌊ f ⌋)) u).
      + split.
        * exists u;split;[assumption|reflexivity].
        * rewrite (support_lang Iu);apply incl_appl;reflexivity.
      + apply (I _ Iu').
    - rewrite (support_lang Iu);apply incl_appl;reflexivity.
  Qed.

  Corollary restrict_eq e f :
    cl_α ⟦e⟧ ≃ cl_α ⟦f⟧ <-> (cl_α ⟦e⟧)⇂(⌊e⌋++⌊f⌋) ≃ (cl_α ⟦f⟧) ⇂ (⌊e⌋++⌊f⌋).
  Proof.
    split;intro E;apply inf_lang_PartialOrder;unfold Basics.flip;split.
    - rewrite <- restrict_inf_bis,E;reflexivity.
    - rewrite app_comm,<-restrict_inf_bis,E;reflexivity.
    - rewrite restrict_inf_bis,E;reflexivity.
    - rewrite restrict_inf_bis,app_comm,E;reflexivity.
  Qed.

End s.


(************************************************************************)
(* Copyright (c) 2015-2019, Ajay Kumar Eeralla                          *)
(*                                                                      *)
(* This work is licensed under the MIT license. The license is          *)
(* described in the file "LICENSE" available at the root of the source  *)
(* or at https://opensource.org/licenses/MIT                            *)
(************************************************************************)

Require Export ex74.

(** This library defines the theorem [EQBRANCH] that states,

[if EQ(x1 , x2) then t[[x1]] else t' = if EQ(x1 ,x2) then t[[x2]] else t'. *)
(** It is a corollary of ex7.4 *)

Theorem eqbrbol_bol :forall ( b1 b2: Bool) (n1 n2 n3 :nat ), (IF (eqb  (Bvar n1)  (Bvar n2)) then [n3 := (Bvar n1)]b1 else b2) ## (IF (eqb  (Bvar n1)(Bvar n2)) then [n3:= (Bvar n2)] b1 else b2).
Proof.
intros.
 assert(H: (IF (eqb  (Bvar n1) (Bvar n2)) then (Bvar n1) else (Bvar n3))  ## (IF (eqb  (Bvar n1) (Bvar n2)) then (Bvar n2) else (Bvar n3))).
apply Example11_B1.
apply Ex12bol_bol with (b:= (eqb (Bvar n1) (Bvar n2)))(n5:= n3)(n6:=n3)(b1:=b1)(b2:=b2) in H.
rewrite invarsub_BBool in H.
apply H.
Qed.

Theorem eqbrbol_msg :forall ( m1 m2: message) (n1 n2 n3 :nat ), ( If (eqb  (Bvar n1)  (Bvar n2)) then ( (n3 := (Bvar n1)) m1) else m2) #  ( If (eqb  (Bvar n1)(Bvar n2)) then ((n3:= (Bvar n2)) m1) else m2).
Proof.
intros.
 assert(H:(IF (eqb (Bvar n1) (Bvar n2)) then (Bvar n1) else (Bvar n3))  ##  (IF (eqb  (Bvar n1) (Bvar n2)) then (Bvar n2) else (Bvar n3))).
apply Example11_B1.
apply Ex12bol_msg with (b:= (eqb (Bvar n1) (Bvar n2)))(n5:= n3)(n6:=n3)(m1:=m1)(m2:=m2) in H.
rewrite invarsub_Bmsg in H.
apply H.
Qed.

Theorem eqbrmsg_msg :forall ( m1 m2 :message) (n1 n2 n3 :nat ), (If (eqm  (Mvar n1)  (Mvar n2)) then {{n3:= (Mvar n1)}}m1 else m2) #   (If (eqm (Mvar n1)(Mvar n2)) then {{n3:= (Mvar n2)}} m1 else m2).
Proof.
intros.
assert(H:   (If (eqm  (Mvar n1) (Mvar n2)) then (Mvar n1) else (Mvar n3) ) # (If (eqm (Mvar n1) (Mvar n2)) then (Mvar n2) else (Mvar n3))).
pose proof(Example11_M1).
apply Example11_M1 with (n1:=n1).
pose proof Ex12msg_msg.
apply Ex12msg_msg  with (b:= (eqm (Mvar n1) (Mvar n2)))(n5:= n3)(n6:=n3)(m1:=m1)(m2:=m2) in H.
rewrite invarsub_mmsg in H.
apply H.
Qed.

Theorem eqbrmsg_bol :forall ( b1 b2: Bool) (n1 n2 n3 :nat ), (IF (eqm  (Mvar n1)  (Mvar n2)) then [[n3 := (Mvar n1)]]b1 else b2) ## (IF (eqm  (Mvar n1)(Mvar n2)) then [[n3:= (Mvar n2)]] b1 else b2).

Proof.
intros.
assert(H:   (If (eqm  (Mvar n1) (Mvar n2)) then (Mvar n1) else (Mvar n3) ) # (If (eqm (Mvar n1) (Mvar n2)) then (Mvar n2) else (Mvar n3))).
pose proof(Example11_M1).
apply Example11_M1 with (n1:=n1).
pose proof Ex12msg_bol.
apply Ex12msg_bol  with (b:= (eqm (Mvar n1) (Mvar n2)))(n5:= n3)(n6:=n3)(b1:=b1)(b2:=b2) in H.
rewrite invarsub_mBool in H.
apply H.
Qed.

Axiom eqbrmsg_msg' :forall (b:Bool) ( m m1 m2 m3 m4 :message) ,  (If (eqm m1 m2) & b then (submsg_msg' m m1 m3) else m4) #  (If (eqm m1 m2) & b then (submsg_msg' m m2 m3) else m4).
Axiom eqbrmsg_msg'' :forall ( m m1 m2:message) (b1 b2: Bool) ,  (IF (eqm m1 m2) then (submsg_bol' m m1 b1) else b2) ##  (IF (eqm m1 m2) then (submsg_bol' m m2 b1) else b2).
Axiom eqbrmsg_msg''' :forall ( m m1 m2 m3 m4 :message) ,  (If (eqm m1 m2 ) then (submsg_msg' m m1 m3) else m4) #  (If (eqm m1 m2) then (submsg_msg' m m2 m3) else m4).


(* Copyright (c) 2012-2017, Coq-std++ developers. *)
(* This file is distributed under the terms of the BSD license. *)
From stdpp Require Import gmap.
Set Default Proof Using "Type".

Record gmultiset A `{Countable A} := GMultiSet { gmultiset_car : gmap A nat }.
Arguments GMultiSet {_ _ _} _ : assert.
Arguments gmultiset_car {_ _ _} _ : assert.

Instance gmultiset_eq_dec `{Countable A} : EqDecision (gmultiset A).
Proof. solve_decision. Defined.

Program Instance gmultiset_countable `{Countable A} :
    Countable (gmultiset A) := {|
  encode X := encode (gmultiset_car X);  decode p := GMultiSet <$> decode p
|}.
Next Obligation. intros A ?? [X]; simpl. by rewrite decode_encode. Qed.

Section definitions.
  Context `{Countable A}.

  Definition multiplicity (x : A) (X : gmultiset A) : nat :=
    match gmultiset_car X !! x with Some n => S n | None => 0 end.
  Global Instance gmultiset_elem_of : ElemOf A (gmultiset A) := λ x X,
    0 < multiplicity x X.
  Global Instance gmultiset_subseteq : SubsetEq (gmultiset A) := λ X Y, ∀ x,
    multiplicity x X ≤ multiplicity x Y.

  Global Instance gmultiset_elements : Elements A (gmultiset A) := λ X,
    let (X) := X in ''(x,n) ← map_to_list X; replicate (S n) x.
  Global Instance gmultiset_size : Size (gmultiset A) := length ∘ elements.

  Global Instance gmultiset_empty : Empty (gmultiset A) := GMultiSet ∅.
  Global Instance gmultiset_singleton : Singleton A (gmultiset A) := λ x,
    GMultiSet {[ x := 0 ]}.
  Global Instance gmultiset_union : Union (gmultiset A) := λ X Y,
    let (X) := X in let (Y) := Y in
    GMultiSet $ union_with (λ x y, Some (S (x + y))) X Y.
  Global Instance gmultiset_difference : Difference (gmultiset A) := λ X Y,
    let (X) := X in let (Y) := Y in
    GMultiSet $ difference_with (λ x y,
      let z := x - y in guard (0 < z); Some (pred z)) X Y.

  Global Instance gmultiset_dom : Dom (gmultiset A) (gset A) := λ X,
    let (X) := X in dom _ X.
End definitions.

Typeclasses Opaque gmultiset_elem_of gmultiset_subseteq.
Typeclasses Opaque gmultiset_elements gmultiset_size gmultiset_empty.
Typeclasses Opaque gmultiset_singleton gmultiset_union gmultiset_difference.
Typeclasses Opaque gmultiset_dom.

Section lemmas.
Context `{Countable A}.
Implicit Types x y : A.
Implicit Types X Y : gmultiset A.

Lemma gmultiset_eq X Y : X = Y ↔ ∀ x, multiplicity x X = multiplicity x Y.
Proof.
  split; [by intros ->|intros HXY].
  destruct X as [X], Y as [Y]; f_equal; apply map_eq; intros x.
  specialize (HXY x); unfold multiplicity in *; simpl in *.
  repeat case_match; naive_solver.
Qed.

(* Multiplicity *)
Lemma multiplicity_empty x : multiplicity x ∅ = 0.
Proof. done. Qed.
Lemma multiplicity_singleton x : multiplicity x {[ x ]} = 1.
Proof. unfold multiplicity; simpl. by rewrite lookup_singleton. Qed.
Lemma multiplicity_singleton_ne x y : x ≠ y → multiplicity x {[ y ]} = 0.
Proof. intros. unfold multiplicity; simpl. by rewrite lookup_singleton_ne. Qed.
Lemma multiplicity_union X Y x :
  multiplicity x (X ∪ Y) = multiplicity x X + multiplicity x Y.
Proof.
  destruct X as [X], Y as [Y]; unfold multiplicity; simpl.
  rewrite lookup_union_with. destruct (X !! _), (Y !! _); simpl; omega.
Qed.
Lemma multiplicity_difference X Y x :
  multiplicity x (X ∖ Y) = multiplicity x X - multiplicity x Y.
Proof.
  destruct X as [X], Y as [Y]; unfold multiplicity; simpl.
  rewrite lookup_difference_with.
  destruct (X !! _), (Y !! _); simplify_option_eq; omega.
Qed.

(* Collection *)
Lemma elem_of_multiplicity x X : x ∈ X ↔ 0 < multiplicity x X.
Proof. done. Qed.

Global Instance gmultiset_simple_collection : SimpleCollection A (gmultiset A).
Proof.
  split.
  - intros x. rewrite elem_of_multiplicity, multiplicity_empty. omega.
  - intros x y. destruct (decide (x = y)) as [->|].
    + rewrite elem_of_multiplicity, multiplicity_singleton. split; auto with lia.
    + rewrite elem_of_multiplicity, multiplicity_singleton_ne by done.
      by split; auto with lia.
  - intros X Y x. rewrite !elem_of_multiplicity, multiplicity_union. omega.
Qed.
Global Instance gmultiset_elem_of_dec : RelDecision (@elem_of _ (gmultiset A) _).
Proof. refine (λ x X, cast_if (decide (0 < multiplicity x X))); done. Defined.

(* Algebraic laws *)
Global Instance gmultiset_comm : Comm (@eq (gmultiset A)) (∪).
Proof.
  intros X Y. apply gmultiset_eq; intros x. rewrite !multiplicity_union; omega.
Qed.
Global Instance gmultiset_assoc : Assoc (@eq (gmultiset A)) (∪).
Proof.
  intros X Y Z. apply gmultiset_eq; intros x. rewrite !multiplicity_union; omega.
Qed.
Global Instance gmultiset_left_id : LeftId (@eq (gmultiset A)) ∅ (∪).
Proof.
  intros X. apply gmultiset_eq; intros x.
  by rewrite multiplicity_union, multiplicity_empty.
Qed.
Global Instance gmultiset_right_id : RightId (@eq (gmultiset A)) ∅ (∪).
Proof. intros X. by rewrite (comm_L (∪)), (left_id_L _ _). Qed.

Global Instance gmultiset_union_inj_1 X : Inj (=) (=) (X ∪).
Proof.
  intros Y1 Y2. rewrite !gmultiset_eq. intros HX x; generalize (HX x).
  rewrite !multiplicity_union. omega.
Qed.
Global Instance gmultiset_union_inj_2 X : Inj (=) (=) (∪ X).
Proof. intros Y1 Y2. rewrite <-!(comm_L _ X). apply (inj _). Qed.

Lemma gmultiset_non_empty_singleton x : {[ x ]} ≠ (∅ : gmultiset A).
Proof.
  rewrite gmultiset_eq. intros Hx; generalize (Hx x).
  by rewrite multiplicity_singleton, multiplicity_empty.
Qed.

(* Properties of the elements operation *)
Lemma gmultiset_elements_empty : elements (∅ : gmultiset A) = [].
Proof.
  unfold elements, gmultiset_elements; simpl. by rewrite map_to_list_empty.
Qed.
Lemma gmultiset_elements_empty_inv X : elements X = [] → X = ∅.
Proof.
  destruct X as [X]; unfold elements, gmultiset_elements; simpl.
  intros; apply (f_equal GMultiSet). destruct (map_to_list X) as [|[]] eqn:?.
  - by apply map_to_list_empty_inv.
  - naive_solver.
Qed.
Lemma gmultiset_elements_empty' X : elements X = [] ↔ X = ∅.
Proof.
  split; intros HX; [by apply gmultiset_elements_empty_inv|].
  by rewrite HX, gmultiset_elements_empty.
Qed.
Lemma gmultiset_elements_singleton x : elements ({[ x ]} : gmultiset A) = [ x ].
Proof.
  unfold elements, gmultiset_elements; simpl. by rewrite map_to_list_singleton.
Qed.
Lemma gmultiset_elements_union X Y :
  elements (X ∪ Y) ≡ₚ elements X ++ elements Y.
Proof.
  destruct X as [X], Y as [Y]; unfold elements, gmultiset_elements.
  set (f xn := let '(x, n) := xn in replicate (S n) x); simpl.
  revert Y; induction X as [|x n X HX IH] using map_ind; intros Y.
  { by rewrite (left_id_L _ _ Y), map_to_list_empty. }
  destruct (Y !! x) as [n'|] eqn:HY.
  - rewrite <-(insert_id Y x n'), <-(insert_delete Y) by done.
    erewrite <-insert_union_with by done.
    rewrite !map_to_list_insert, !bind_cons
      by (by rewrite ?lookup_union_with, ?lookup_delete, ?HX).
    rewrite (assoc_L _), <-(comm (++) (f (_,n'))), <-!(assoc_L _), <-IH.
    rewrite (assoc_L _). f_equiv.
    rewrite (comm _); simpl. by rewrite replicate_plus, Permutation_middle.
  - rewrite <-insert_union_with_l, !map_to_list_insert, !bind_cons
      by (by rewrite ?lookup_union_with, ?HX, ?HY).
    by rewrite <-(assoc_L (++)), <-IH.
Qed.
Lemma gmultiset_elem_of_elements x X : x ∈ elements X ↔ x ∈ X.
Proof.
  destruct X as [X]. unfold elements, gmultiset_elements.
  set (f xn := let '(x, n) := xn in replicate (S n) x); simpl.
  unfold elem_of at 2, gmultiset_elem_of, multiplicity; simpl.
  rewrite elem_of_list_bind. split.
  - intros [[??] [[<- ?]%elem_of_replicate ->%elem_of_map_to_list]]; lia.
  - intros. destruct (X !! x) as [n|] eqn:Hx; [|omega].
    exists (x,n); split; [|by apply elem_of_map_to_list].
    apply elem_of_replicate; auto with omega.
Qed.
Lemma gmultiset_elem_of_dom x X : x ∈ dom (gset A) X ↔ x ∈ X.
Proof.
  unfold dom, gmultiset_dom, elem_of at 2, gmultiset_elem_of, multiplicity.
  destruct X as [X]; simpl; rewrite elem_of_dom, <-not_eq_None_Some.
  destruct (X !! x); naive_solver omega.
Qed.

(* Properties of the size operation *)
Lemma gmultiset_size_empty : size (∅ : gmultiset A) = 0.
Proof. done. Qed.
Lemma gmultiset_size_empty_inv X : size X = 0 → X = ∅.
Proof.
  unfold size, gmultiset_size; simpl. rewrite length_zero_iff_nil.
  apply gmultiset_elements_empty_inv.
Qed.
Lemma gmultiset_size_empty_iff X : size X = 0 ↔ X = ∅.
Proof.
  split; [apply gmultiset_size_empty_inv|].
  by intros ->; rewrite gmultiset_size_empty.
Qed.
Lemma gmultiset_size_non_empty_iff X : size X ≠ 0 ↔ X ≠ ∅.
Proof. by rewrite gmultiset_size_empty_iff. Qed.

Lemma gmultiset_choose_or_empty X : (∃ x, x ∈ X) ∨ X = ∅.
Proof.
  destruct (elements X) as [|x l] eqn:HX; [right|left].
  - by apply gmultiset_elements_empty_inv.
  - exists x. rewrite <-gmultiset_elem_of_elements, HX. by left.
Qed.
Lemma gmultiset_choose X : X ≠ ∅ → ∃ x, x ∈ X.
Proof. intros. by destruct (gmultiset_choose_or_empty X). Qed.
Lemma gmultiset_size_pos_elem_of X : 0 < size X → ∃ x, x ∈ X.
Proof.
  intros Hsz. destruct (gmultiset_choose_or_empty X) as [|HX]; [done|].
  contradict Hsz. rewrite HX, gmultiset_size_empty; lia.
Qed.

Lemma gmultiset_size_singleton x : size ({[ x ]} : gmultiset A) = 1.
Proof.
  unfold size, gmultiset_size; simpl. by rewrite gmultiset_elements_singleton.
Qed.
Lemma gmultiset_size_union X Y : size (X ∪ Y) = size X + size Y.
Proof.
  unfold size, gmultiset_size; simpl.
  by rewrite gmultiset_elements_union, app_length.
Qed.

(* Order stuff *)
Global Instance gmultiset_po : PartialOrder (@subseteq (gmultiset A) _).
Proof.
  split; [split|].
  - by intros X x.
  - intros X Y Z HXY HYZ x. by trans (multiplicity x Y).
  - intros X Y HXY HYX; apply gmultiset_eq; intros x. by apply (anti_symm (≤)).
Qed.

Lemma gmultiset_subseteq_alt X Y :
  X ⊆ Y ↔
  map_relation (≤) (λ _, False) (λ _, True) (gmultiset_car X) (gmultiset_car Y).
Proof.
  apply forall_proper; intros x. unfold multiplicity.
  destruct (gmultiset_car X !! x), (gmultiset_car Y !! x); naive_solver omega.
Qed.
Global Instance gmultiset_subseteq_dec : RelDecision (@subseteq (gmultiset A) _).
Proof.
 refine (λ X Y, cast_if (decide (map_relation (≤)
   (λ _, False) (λ _, True) (gmultiset_car X) (gmultiset_car Y))));
   by rewrite gmultiset_subseteq_alt.
Defined.

Lemma gmultiset_subset_subseteq X Y : X ⊂ Y → X ⊆ Y.
Proof. apply strict_include. Qed.
Hint Resolve gmultiset_subset_subseteq.

Lemma gmultiset_empty_subseteq X : ∅ ⊆ X.
Proof. intros x. rewrite multiplicity_empty. omega. Qed.

Lemma gmultiset_union_subseteq_l X Y : X ⊆ X ∪ Y.
Proof. intros x. rewrite multiplicity_union. omega. Qed.
Lemma gmultiset_union_subseteq_r X Y : Y ⊆ X ∪ Y.
Proof. intros x. rewrite multiplicity_union. omega. Qed.
Lemma gmultiset_union_mono X1 X2 Y1 Y2 : X1 ⊆ X2 → Y1 ⊆ Y2 → X1 ∪ Y1 ⊆ X2 ∪ Y2.
Proof. intros ?? x. rewrite !multiplicity_union. by apply Nat.add_le_mono. Qed.
Lemma gmultiset_union_mono_l X Y1 Y2 : Y1 ⊆ Y2 → X ∪ Y1 ⊆ X ∪ Y2.
Proof. intros. by apply gmultiset_union_mono. Qed.
Lemma gmultiset_union_mono_r X1 X2 Y : X1 ⊆ X2 → X1 ∪ Y ⊆ X2 ∪ Y.
Proof. intros. by apply gmultiset_union_mono. Qed.

Lemma gmultiset_subset X Y : X ⊆ Y → size X < size Y → X ⊂ Y.
Proof. intros. apply strict_spec_alt; split; naive_solver auto with omega. Qed.
Lemma gmultiset_union_subset_l X Y : Y ≠ ∅ → X ⊂ X ∪ Y.
Proof.
  intros HY%gmultiset_size_non_empty_iff.
  apply gmultiset_subset; auto using gmultiset_union_subseteq_l.
  rewrite gmultiset_size_union; omega.
Qed.
Lemma gmultiset_union_subset_r X Y : X ≠ ∅ → Y ⊂ X ∪ Y.
Proof. rewrite (comm_L (∪)). apply gmultiset_union_subset_l. Qed.

Lemma gmultiset_elem_of_singleton_subseteq x X : x ∈ X ↔ {[ x ]} ⊆ X.
Proof.
  rewrite elem_of_multiplicity. split.
  - intros Hx y; destruct (decide (x = y)) as [->|].
    + rewrite multiplicity_singleton; omega.
    + rewrite multiplicity_singleton_ne by done; omega.
  - intros Hx. generalize (Hx x). rewrite multiplicity_singleton. omega.
Qed.

Lemma gmultiset_elem_of_subseteq X1 X2 x : x ∈ X1 → X1 ⊆ X2 → x ∈ X2.
Proof. rewrite !gmultiset_elem_of_singleton_subseteq. by intros ->. Qed.

Lemma gmultiset_union_difference X Y : X ⊆ Y → Y = X ∪ Y ∖ X.
Proof.
  intros HXY. apply gmultiset_eq; intros x; specialize (HXY x).
  rewrite multiplicity_union, multiplicity_difference; omega.
Qed.
Lemma gmultiset_union_difference' x Y : x ∈ Y → Y = {[ x ]} ∪ Y ∖ {[ x ]}.
Proof.
  intros. by apply gmultiset_union_difference,
    gmultiset_elem_of_singleton_subseteq.
Qed.

Lemma gmultiset_size_difference X Y : Y ⊆ X → size (X ∖ Y) = size X - size Y.
Proof.
  intros HX%gmultiset_union_difference.
  rewrite HX at 2; rewrite gmultiset_size_union. omega.
Qed.

Lemma gmultiset_non_empty_difference X Y : X ⊂ Y → Y ∖ X ≠ ∅.
Proof.
  intros [_ HXY2] Hdiff; destruct HXY2; intros x.
  generalize (f_equal (multiplicity x) Hdiff).
  rewrite multiplicity_difference, multiplicity_empty; omega.
Qed.

Lemma gmultiset_difference_subset X Y : X ≠ ∅ → X ⊆ Y → Y ∖ X ⊂ Y.
Proof.
  intros. eapply strict_transitive_l; [by apply gmultiset_union_subset_r|].
  by rewrite <-(gmultiset_union_difference X Y).
Qed.

(* Mononicity *)
Lemma gmultiset_elements_submseteq X Y : X ⊆ Y → elements X ⊆+ elements Y.
Proof.
  intros ->%gmultiset_union_difference. rewrite gmultiset_elements_union.
  by apply submseteq_inserts_r.
Qed.

Lemma gmultiset_subseteq_size X Y : X ⊆ Y → size X ≤ size Y.
Proof. intros. by apply submseteq_length, gmultiset_elements_submseteq. Qed.

Lemma gmultiset_subset_size X Y : X ⊂ Y → size X < size Y.
Proof.
  intros HXY. assert (size (Y ∖ X) ≠ 0).
  { by apply gmultiset_size_non_empty_iff, gmultiset_non_empty_difference. }
  rewrite (gmultiset_union_difference X Y), gmultiset_size_union by auto. lia.
Qed.

(* Well-foundedness *)
Lemma gmultiset_wf : wf (strict (@subseteq (gmultiset A) _)).
Proof.
  apply (wf_projected (<) size); auto using gmultiset_subset_size, lt_wf.
Qed.

Lemma gmultiset_ind (P : gmultiset A → Prop) :
  P ∅ → (∀ x X, P X → P ({[ x ]} ∪ X)) → ∀ X, P X.
Proof.
  intros Hemp Hinsert X. induction (gmultiset_wf X) as [X _ IH].
  destruct (gmultiset_choose_or_empty X) as [[x Hx]| ->]; auto.
  rewrite (gmultiset_union_difference' x X) by done.
  apply Hinsert, IH, gmultiset_difference_subset,
    gmultiset_elem_of_singleton_subseteq; auto using gmultiset_non_empty_singleton.
Qed.
End lemmas.


(** * RecordSub: Subtyping with Records *)

(** In this chapter, we combine two significant extensions of the pure
    STLC -- records (from chapter [Records]) and subtyping (from
    chapter [Sub]) -- and explore their interactions.  Most of the
    concepts have already been discussed in those chapters, so the
    presentation here is somewhat terse.  We just comment where things
    are nonstandard. *)

Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Strings.String.
From PLF Require Import Maps.
From PLF Require Import Smallstep.

Module RecordSub.

(* ################################################################# *)
(** * Core Definitions *)

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

Inductive ty : Type :=
  (* proper types *)
  | Ty_Top   : ty
  | Ty_Base  : string -> ty
  | Ty_Arrow : ty -> ty -> ty
  (* record types *)
  | Ty_RNil : ty
  | Ty_RCons : string -> ty -> ty -> ty.

Inductive tm : Type :=
  (* proper terms *)
  | tm_var : string -> tm
  | tm_app : tm -> tm -> tm
  | tm_abs : string -> ty -> tm -> tm
  | tm_rproj : tm -> string -> tm
  (* record terms *)
  | tm_rnil :  tm
  | tm_rcons : string -> tm -> tm -> tm.

Declare Custom Entry stlc.
Declare Custom Entry stlc_ty.

Notation "<{ e }>" := e (e custom stlc at level 99).
Notation "<{{ e }}>" := e (e custom stlc_ty at level 99).
Notation "( x )" := x (in custom stlc, x at level 99).
Notation "( x )" := x (in custom stlc_ty, x at level 99).
Notation "x" := x (in custom stlc at level 0, x constr at level 0).
Notation "x" := x (in custom stlc_ty at level 0, x constr at level 0).
Notation "S -> T" := (Ty_Arrow S T) (in custom stlc_ty at level 50, right associativity).
Notation "x y" := (tm_app x y) (in custom stlc at level 1, left associativity).
Notation "\ x : t , y" :=
  (tm_abs x t y) (in custom stlc at level 90, x at level 99,
                     t custom stlc_ty at level 99,
                     y custom stlc at level 99,
                     left associativity).
Coercion tm_var : string >-> tm.

Notation "{ x }" := x (in custom stlc at level 1, x constr).

Notation "'Base' x" := (Ty_Base x) (in custom stlc_ty at level 0).

Notation "  l ':' t1  '::' t2" := (Ty_RCons l t1 t2) (in custom stlc_ty at level 3, right associativity).
Notation " l := e1 '::' e2" := (tm_rcons l e1 e2) (in custom stlc at level 3, right associativity).
Notation "'nil'" := (Ty_RNil) (in custom stlc_ty).
Notation "'nil'" := (tm_rnil) (in custom stlc).
Notation "o --> l" := (tm_rproj o l) (in custom stlc at level 0).

Notation "'Top'" := (Ty_Top) (in custom stlc_ty at level 0).

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** The syntax of terms and types is a bit too loose, in the sense
    that it admits things like a record type whose final "tail" is
    [Top] or some arrow type rather than [Nil].  To avoid such cases,
    it is useful to assume that all the record types and terms that we
    see will obey some simple well-formedness conditions.

    [An interesting technical question is whether the basic properties
    of the system -- progress and preservation -- remain true if we
    drop these conditions.  I believe they do, and I would encourage
    motivated readers to try to check this by dropping the conditions
    from the definitions of typing and subtyping and adjusting the
    proofs in the rest of the chapter accordingly.  This is not a
    trivial exercise (or I'd have done it!), but it should not involve
    changing the basic structure of the proofs.  If someone does do
    it, please let me know. --BCP 5/16.] *)

Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty <{{ nil }}>
  | RTcons : forall i T1 T2,
        record_ty <{{ i : T1 :: T2 }}>.

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm <{ nil }>
  | rtcons : forall i t1 t2,
        record_tm <{ i := t1 :: t2 }>.

Inductive well_formed_ty : ty -> Prop :=
  |  wfTop :
        well_formed_ty <{{ Top }}>
  | wfBase : forall (i : string),
        well_formed_ty <{{ Base i }}>
  | wfArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty <{{ T1 -> T2 }}>
  | wfRNil :
        well_formed_ty <{{ nil }}>
  | wfRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty <{{ i : T1 :: T2 }}>.

Hint Constructors record_ty record_tm well_formed_ty : core.

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

(** Substitution and reduction are as before. *)

Reserved Notation "'[' x ':=' s ']' t" (in custom stlc at level 20, x constr).

Fixpoint subst (x : string) (s : tm) (t : tm) : tm :=
  match t with
  | tm_var y =>
      if eqb_string x y then s else t
  | <{\y:T, t1}> =>
      if eqb_string x y then t else <{\y:T, [x:=s] t1}>
  | <{t1 t2}> =>
      <{([x:=s] t1) ([x:=s] t2)}>
  | <{ t1 --> i }> =>
      <{ ( [x := s] t1) --> i }>
  | <{ nil }> =>
      <{ nil }>
  | <{ i := t1 :: tr }> =>
     <{ i :=  [x := s] t1 :: ( [x := s] tr) }>
  end

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

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

Inductive value : tm -> Prop :=
  | v_abs : forall x T2 t1,
      value  <{ \ x : T2, t1 }>
  | v_rnil : value <{ nil }>
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value <{ i := v1 :: vr }>.

Hint Constructors value : core.

Fixpoint Tlookup (i:string) (Tr:ty) : option ty :=
  match Tr with
  | <{{ i' : T :: Tr' }}> =>
      if eqb_string i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Fixpoint tlookup (i:string) (tr:tm) : option tm :=
  match tr with
  | <{ i' := t :: tr' }> =>
      if eqb_string i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t '-->' t'" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T2 t1 v2,
         value v2 ->
         <{(\x:T2, t1) v2}> --> <{ [x:=v2]t1 }>
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         <{t1 t2}> --> <{t1' t2}>
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         <{v1 t2}> --> <{v1  t2'}>
  | ST_Proj1 : forall t1 t1' i,
        t1 --> t1' ->
        <{ t1 --> i }> --> <{ t1' --> i }>
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
        <{ tr --> i }> --> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 --> t1' ->
        <{ i := t1 :: tr2 }> --> <{ i := t1' :: tr2 }>
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 --> tr2' ->
        <{ i := v1 :: tr2 }> --> <{ i := v1 :: tr2' }>

where "t '-->' t'" := (step t t').

Hint Constructors step : core.

(* ################################################################# *)
(** * Subtyping *)

(** Now we come to the interesting part, where the features we've
    added start to interact.  We begin by defining the subtyping
    relation and developing some of its important technical
    properties. *)

(* ================================================================= *)
(** ** Definition *)

(** The definition of subtyping is essentially just what we sketched
    in the discussion of record subtyping in chapter [Sub], but we
    need to add well-formedness side conditions to some of the rules.
    Also, we replace the "n-ary" width, depth, and permutation
    subtyping rules by binary rules that deal with just the first
    field. *)

Reserved Notation "T '<:' U" (at level 40).

Inductive subtype : ty -> ty -> Prop :=
  (* Subtyping between proper types *)
  | S_Refl : forall T,
    well_formed_ty T ->
    T <: T
  | S_Trans : forall S U T,
    S <: U ->
    U <: T ->
    S <: T
  | S_Top : forall S,
    well_formed_ty S ->
    S <: <{{ Top }}>
  | S_Arrow : forall S1 S2 T1 T2,
    T1 <: S1 ->
    S2 <: T2 ->
    <{{ S1 -> S2 }}> <: <{{ T1 -> T2 }}>
  (* Subtyping between record types *)
  | S_RcdWidth : forall i T1 T2,
    well_formed_ty <{{ i : T1 :: T2 }}> ->
    <{{ i : T1 :: T2 }}> <: <{{ nil }}>
  | S_RcdDepth : forall i S1 T1 Sr2 Tr2,
    S1 <: T1 ->
    Sr2 <: Tr2 ->
    record_ty Sr2 ->
    record_ty Tr2 ->
    <{{ i : S1 :: Sr2 }}> <: <{{ i : T1 :: Tr2 }}>
  | S_RcdPerm : forall i1 i2 T1 T2 Tr3,
    well_formed_ty <{{ i1 : T1 :: i2 : T2 :: Tr3 }}> ->
    i1 <> i2 ->
       <{{ i1 : T1 :: i2 : T2 :: Tr3 }}>
    <: <{{ i2 : T2 :: i1 : T1 :: Tr3 }}>

where "T '<:' U" := (subtype T U).

Hint Constructors subtype : core.

(* ================================================================= *)
(** ** Examples *)

Module Examples.
Open Scope string_scope.

Notation x := "x".
Notation y := "y".
Notation z := "z".
Notation j := "j".
Notation k := "k".
Notation i := "i".
Notation A := <{{ Base "A" }}>.
Notation B := <{{ Base "B" }}>.
Notation C := <{{ Base "C" }}>.

Definition TRcd_j  :=
  <{{ j  : (B -> B) :: nil }}>.     (* {j:B->B} *)
Definition TRcd_kj :=
  <{{ k : (A -> A) :: TRcd_j }}>.      (* {k:C->C,j:B->B} *)

Example subtyping_example_0 :
  <{{ C -> TRcd_kj }}> <: <{{ C -> nil }}>.
Proof.
  apply S_Arrow.
    apply S_Refl. auto.
    unfold TRcd_kj, TRcd_j. apply S_RcdWidth; auto.
Qed.

(** The following facts are mostly easy to prove in Coq.  To get full
    benefit, make sure you also understand how to prove them on
    paper! *)

(** **** Exercise: 2 stars, standard (subtyping_example_1) *)
Example subtyping_example_1 :
  TRcd_kj <: TRcd_j.
(* {k:A->A,j:B->B} <: {j:B->B} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, standard (subtyping_example_2) *)
Example subtyping_example_2 :
  <{{ Top -> TRcd_kj }}> <:
          <{{ (C -> C) -> TRcd_j }}>.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 1 star, standard (subtyping_example_3) *)
Example subtyping_example_3 :
  <{{ nil -> (j : A :: nil) }}> <:
          <{{ (k : B :: nil) -> nil }}>.
(* {}->{j:A} <: {k:B}->{} *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (subtyping_example_4) *)
Example subtyping_example_4 :
  <{{ x : A :: y : B :: z : C :: nil }}> <:
  <{{ z : C :: y : B :: x : A :: nil }}>.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples.

(* ================================================================= *)
(** ** Properties of Subtyping *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

(** To get started proving things about subtyping, we need a couple of
    technical lemmas that intuitively (1) allow us to extract the
    well-formedness assumptions embedded in subtyping derivations
    and (2) record the fact that fields of well-formed record types
    are themselves well-formed types.  *)

Lemma subtype__wf : forall S T,
  subtype S T ->
  well_formed_ty T /\ well_formed_ty S.
Proof with eauto.
  intros S T Hsub.
  induction Hsub;
    intros; try (destruct IHHsub1; destruct IHHsub2)...
  - (* S_RcdPerm *)
    split... inversion H. subst. inversion H5...  Qed.

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve_by_invert.
  - (* RCons *)
    inversion H. subst. unfold Tlookup in H0.
    destruct (eqb_string i s)...  inversion H0; subst...  Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

(** The record matching lemmas get a little more complicated in the
    presence of subtyping, for two reasons.  First, record types no
    longer necessarily describe the exact structure of the
    corresponding terms.  And second, reasoning by induction on typing
    derivations becomes harder in general, because typing is no longer
    syntax directed. *)

Lemma rcd_types_match : forall S T i Ti,
  subtype S T ->
  Tlookup i T = Some Ti ->
  exists Si, Tlookup i S = Some Si /\ subtype Si Ti.
Proof with (eauto using wf_rcd_lookup).
  intros S T i Ti Hsub Hget. generalize dependent Ti.
  induction Hsub; intros Ti Hget;
    try solve_by_invert.
  - (* S_Refl *)
    exists Ti...
  - (* S_Trans *)
    destruct (IHHsub2 Ti) as [Ui Hui]... destruct Hui.
    destruct (IHHsub1 Ui) as [Si Hsi]... destruct Hsi.
    exists Si...
  - (* S_RcdDepth *)
    rename i0 into k.
    unfold Tlookup. unfold Tlookup in Hget.
    destruct (eqb_string i k)...
    + (* i = k -- we're looking up the first field *)
      inversion Hget. subst. exists S1...
  - (* S_RcdPerm *)
    exists Ti. split.
    + (* lookup *)
      unfold Tlookup. unfold Tlookup in Hget.
      destruct (eqb_stringP i i1)...
      * (* i = i1 -- we're looking up the first field *)
        destruct (eqb_stringP i i2)...
        (* i = i2 -- contradictory *)
        destruct H0.
        subst...
    + (* subtype *)
      inversion H. subst. inversion H5. subst...  Qed.

(** **** Exercise: 3 stars, standard (rcd_types_match_informal)

    Write a careful informal proof of the [rcd_types_match]
    lemma. *)

(* FILL IN HERE *)

(* Do not modify the following line: *)
Definition manual_grade_for_rcd_types_match_informal : option (nat*string) := None.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemmas *)

(** **** Exercise: 3 stars, standard, optional (sub_inversion_arrow) *)
Lemma sub_inversion_arrow : forall U V1 V2,
     U <: <{{ V1 -> V2 }}> ->
     exists U1 U2,
       (U= <{{ U1 -> U2 }}> ) /\ (V1 <: U1) /\ (U2 <: V2).
Proof with eauto.
  intros U V1 V2 Hs.
  remember <{{ V1 -> V2 }}> as V.
  generalize dependent V2. generalize dependent V1.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ################################################################# *)
(** * Typing *)

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40,
                                          t custom stlc at level 99, T custom stlc_ty at level 0).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma (x : string) T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- x \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      (x |-> T11; Gamma) |- t12 \in T12 ->
      Gamma |- (\ x : T11, t12) \in (T11 -> T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (T1 -> T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- t1 t2 \in T2
  | T_Proj : forall Gamma i t T Ti,
      Gamma |- t \in T ->
      Tlookup i T = Some Ti ->
      Gamma |- t --> i \in Ti
  (* Subsumption *)
  | T_Sub : forall Gamma t S T,
      Gamma |- t \in S ->
      subtype S T ->
      Gamma |- t \in T
  (* Rules for record terms *)
  | T_RNil : forall Gamma,
      Gamma |- nil \in nil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- i := t :: tr \in (i : T :: Tr)

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

Hint Constructors has_type : core.

(* ================================================================= *)
(** ** Typing Examples *)

Module Examples2.
Import Examples.

(** **** Exercise: 1 star, standard (typing_example_0) *)
Definition trcd_kj :=
  <{ k := (\z : A, z) :: j := (\z : B, z) :: nil }>.

Example typing_example_0 :
  empty |- trcd_kj \in TRcd_kj.
(* empty |- {k=(\z:A.z), j=(\z:B.z)} : {k:A->A,j:B->B} *)
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard (typing_example_1) *)
Example typing_example_1 :
  empty |- (\x : TRcd_j, x --> j) trcd_kj \in (B -> B).
(* empty |- (\x:{k:A->A,j:B->B}. x.j)
              {k=(\z:A.z), j=(\z:B.z)}
         : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (typing_example_2) *)
Example typing_example_2 :
  empty |- (\ z : (C -> C) -> TRcd_j, (z (\ x : C, x) ) --> j )
            ( \z : (C -> C), trcd_kj ) \in (B -> B).
(* empty |- (\z:(C->C)->{j:B->B}. (z (\x:C.x)).j)
              (\z:C->C. {k=(\z:A.z), j=(\z:B.z)})
           : B->B *)
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

End Examples2.

(* ================================================================= *)
(** ** Properties of Typing *)

(* ----------------------------------------------------------------- *)
(** *** Well-Formedness *)

Lemma has_type__wf : forall Gamma t T,
  has_type Gamma t T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  - (* T_App *)
    inversion IHHtyp1...
  - (* T_Proj *)
    eapply wf_rcd_lookup...
  - (* T_Sub *)
    apply subtype__wf in H.
    destruct H...
Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr --> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; eauto.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Field Lookup *)

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  empty |- v \in T ->
  Tlookup i T = Some Ti ->
  exists vi, tlookup i v = Some vi /\ empty |- vi \in Ti.
Proof with eauto.
  remember empty as Gamma.
  intros t T i Ti Hval Htyp. generalize dependent Ti.
  induction Htyp; intros; subst; try solve_by_invert.
  - (* T_Sub *)
    apply (rcd_types_match S) in H0...
    destruct H0 as [Si [HgetSi Hsub]].
    eapply IHHtyp in HgetSi...
    destruct HgetSi as [vi [Hget Htyvi]]...
  - (* T_RCons *)
    simpl in H0. simpl. simpl in H1.
    destruct (eqb_string i i0).
    + (* i is first *)
      injection H1 as H1. subst. exists t...
    + (* i in tail *)
      eapply IHHtyp2 in H1...
      inversion Hval...  Qed.

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

(** **** Exercise: 3 stars, standard (canonical_forms_of_arrow_types) *)
Lemma canonical_forms_of_arrow_types : forall Gamma s T1 T2,
     Gamma |- s \in (T1 -> T2) ->
     value s ->
     exists x S1 s2,
        s = <{ \ x  : S1, s2 }>.
Proof with eauto.
  (* FILL IN HERE *) Admitted.
(** [] *)

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t --> t'.
Proof with eauto.
  intros t T Ht.
  remember empty as Gamma.
  revert HeqGamma.
  induction Ht;
    intros HeqGamma; subst...
  - (* T_Var *)
    inversion H.
  - (* T_App *)
    right.
    destruct IHHt1; subst...
    + (* t1 is a value *)
      destruct IHHt2; subst...
      * (* t2 is a value *)
        destruct (canonical_forms_of_arrow_types empty t1 T1 T2)
          as [x [S1 [t12 Heqt1]]]...
        subst. exists <{ [x:=t2] t12 }>...
      * (* t2 steps *)
        destruct H0 as [t2' Hstp]. exists <{ t1 t2' }> ...
    + (* t1 steps *)
      destruct H as [t1' Hstp]. exists <{ t1' t2 }>...
  - (* T_Proj *)
    right. destruct IHHt...
    + (* rcd is value *)
      destruct (lookup_field_in_value t T i Ti)
        as [t' [Hget Ht']]...
    + (* rcd_steps *)
      destruct H0 as [t' Hstp]. exists <{ t' --> i }>...
  - (* T_RCons *)
    destruct IHHt1...
    + (* head is a value *)
      destruct IHHt2...
      * (* tail steps *)
        right. destruct H2 as [tr' Hstp].
        exists <{ i := t :: tr' }>...
    + (* head steps *)
      right. destruct H1 as [t' Hstp].
      exists <{ i := t' :: tr}>...  Qed.

(** _Theorem_ : For any term [t] and type [T], if [empty |- t : T]
    then [t] is a value or [t --> t'] for some term [t'].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We
    proceed by induction on the given typing derivation.

      - The cases where the last step in the typing derivation is
        [T_Abs] or [T_RNil] are immediate because abstractions and
        [{}] are always values.  The case for [T_Var] is vacuous
        because variables cannot be typed in the empty context.

      - If the last step in the typing derivation is by [T_App], then
        there are terms [t1] [t2] and types [T1] [T2] such that [t =
        t1 t2], [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 :
        T1].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [t2] is a value or
        steps.

        - Suppose [t1 --> t1'] for some term [t1'].  Then [t1 t2 -->
          t1' t2] by [ST_App1].

        - Otherwise [t1] is a value.

          - Suppose [t2 --> t2'] for some term [t2'].  Then [t1 t2 -->
            t1 t2'] by rule [ST_App2] because [t1] is a value.

          - Otherwise, [t2] is a value.  By Lemma
            [canonical_forms_for_arrow_types], [t1 = \x:S1.s2] for
            some [x], [S1], and [s2].  But then [(\x:S1.s2) t2 -->
            [x:=t2]s2] by [ST_AppAbs], since [t2] is a value.

      - If the last step of the derivation is by [T_Proj], then there
        are a term [tr], a type [Tr], and a label [i] such that [t =
        tr.i], [empty |- tr : Tr], and [Tlookup i Tr = Some T].

        By the IH, either [tr] is a value or it steps.  If [tr -->
        tr'] for some term [tr'], then [tr.i --> tr'.i] by rule
        [ST_Proj1].

        If [tr] is a value, then Lemma [lookup_field_in_value] yields
        that there is a term [ti] such that [tlookup i tr = Some ti].
        It follows that [tr.i --> ti] by rule [ST_ProjRcd].

      - If the final step of the derivation is by [T_Sub], then there
        is a type [S] such that [S <: T] and [empty |- t : S].  The
        desired result is exactly the induction hypothesis for the
        typing subderivation.

      - If the final step of the derivation is by [T_RCons], then
        there exist some terms [t1] [tr], types [T1 Tr] and a label
        [t] such that [t = {i=t1, tr}], [T = {i:T1, Tr}], [record_ty
        tr], [record_tm Tr], [empty |- t1 : T1] and [empty |- tr :
        Tr].

        The induction hypotheses for these typing derivations yield
        that [t1] is a value or steps, and that [tr] is a value or
        steps.  We consider each case:

        - Suppose [t1 --> t1'] for some term [t1'].  Then [{i=t1, tr}
          --> {i=t1', tr}] by rule [ST_Rcd_Head].

        - Otherwise [t1] is a value.

          - Suppose [tr --> tr'] for some term [tr'].  Then [{i=t1,
            tr} --> {i=t1, tr'}] by rule [ST_Rcd_Tail], since [t1] is
            a value.

          - Otherwise, [tr] is also a value.  So, [{i=t1, tr}] is a
            value by [v_rcons]. *)

(* ----------------------------------------------------------------- *)
(** *** Inversion Lemma *)

Lemma typing_inversion_abs : forall Gamma x S1 t2 T,
     Gamma |- \ x : S1, t2 \in T ->
     (exists S2, <{{ S1 -> S2 }}> <: T
              /\ (x |-> S1; Gamma) |- t2 \in S2).
Proof with eauto.
  intros Gamma x S1 t2 T H.
  remember <{ \ x : S1, t2 }> as t.
  induction H;
    inversion Heqt; subst; intros; try solve_by_invert.
  - (* T_Abs *)
    assert (Hwf := has_type__wf _ _ _ H0).
    exists T12...
  - (* T_Sub *)
    destruct IHhas_type as [S2 [Hsub Hty]]...
    Qed.

Lemma abs_arrow : forall x S1 s2 T1 T2,
  empty |- \x : S1, s2 \in (T1 -> T2) ->
     T1 <: S1
  /\ (x |-> S1) |- s2 \in T2.
Proof with eauto.
  intros x S1 s2 T1 T2 Hty.
  apply typing_inversion_abs in Hty.
  destruct Hty as [S2 [Hsub Hty]].
  apply sub_inversion_arrow in Hsub.
  destruct Hsub as [U1 [U2 [Heq [Hsub1 Hsub2]]]].
  inversion Heq; subst...  Qed.

(* ================================================================= *)
(** ** Weakening *)

(** The weakening lemma is proved as in pure STLC. *)

Lemma weakening : forall Gamma Gamma' t T,
     inclusion Gamma Gamma' ->
     Gamma  |- t \in T  ->
     Gamma' |- t \in T.
Proof.
  intros Gamma Gamma' t T H Ht.
  generalize dependent Gamma'.
  induction Ht; eauto using inclusion_update.
Qed.

Lemma weakening_empty : forall Gamma t T,
     empty |- t \in T  ->
     Gamma |- t \in T.
Proof.
  intros Gamma t T.
  eapply weakening.
  discriminate.
Qed.

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

Lemma substitution_preserves_typing : forall Gamma x U t v T,
   (x |-> U ; Gamma) |- t \in T ->
   empty |- v \in U   ->
   Gamma |- [x:=v]t \in T.
Proof.
Proof.
  intros Gamma x U t v T Ht Hv.
  remember (x |-> U; Gamma) as Gamma'.
  generalize dependent Gamma.
  induction Ht; intros Gamma' G; simpl; eauto.
  - (* T_Var *)
    rename x0 into y.
    destruct (eqb_stringP x y) as [Hxy|Hxy]; subst.
    + (* x = y *)
      rewrite update_eq in H.
      injection H as H. subst.
      apply weakening_empty. assumption.
    + (* x<>y *)
      apply T_Var; [|assumption].
      rewrite update_neq in H; assumption.
  - (* T_Abs *)
    rename x0 into y. subst.
    destruct (eqb_stringP x y) as [Hxy|Hxy]; apply T_Abs; try assumption.
    + (* x=y *)
      subst. rewrite update_shadow in Ht. assumption.
    + (* x <> y *)
      subst. apply IHHt.
      rewrite update_permute; auto.
      - (* rcons *)   (* <=== only new case compared to pure STLC *)
      apply T_RCons; eauto.
      inversion H0; subst; simpl; auto.
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T  ->
     t --> t'  ->
     empty |- t' \in T.
Proof with eauto.
  intros t t' T HT. generalize dependent t'.
  remember empty as Gamma.
  induction HT;
       intros t' HE; subst;
       try solve [inversion HE; subst; eauto].
  - (* T_App *)
    inversion HE; subst...
    + (* ST_AppAbs *)
      destruct (abs_arrow _ _ _ _ _ HT1) as [HA1 HA2].
      apply substitution_preserves_typing with T0...
  - (* T_Proj *)
    inversion HE; subst...
    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Hty]].
    rewrite H4 in Hget. inversion Hget. subst...
  - (* T_RCons *)
    inversion HE; subst...
    eauto using step_preserves_record_tm.  Qed.

(** _Theorem_: If [t], [t'] are terms and [T] is a type such that
     [empty |- t : T] and [t --> t'], then [empty |- t' : T].

    _Proof_: Let [t] and [T] be given such that [empty |- t : T].  We go
     by induction on the structure of this typing derivation, leaving
     [t'] general.  Cases [T_Abs] and [T_RNil] are vacuous because
     abstractions and [{}] don't step.  Case [T_Var] is vacuous as well,
     since the context is empty.

     - If the final step of the derivation is by [T_App], then there
       are terms [t1] [t2] and types [T1] [T2] such that [t = t1 t2],
       [T = T2], [empty |- t1 : T1 -> T2] and [empty |- t2 : T1].

       By inspection of the definition of the step relation, there are
       three ways [t1 t2] can step.  Cases [ST_App1] and [ST_App2]
       follow immediately by the induction hypotheses for the typing
       subderivations and a use of [T_App].

       Suppose instead [t1 t2] steps by [ST_AppAbs].  Then
       [t1 = \x:S.t12] for some type [S] and term [t12], and
       [t' = [x:=t2]t12].

       By Lemma [abs_arrow], we have [T1 <: S] and [x:S1 |- s2 : T2].
       It then follows by lemma [substitution_preserves_typing] that
       [empty |- [x:=t2] t12 : T2] as desired.

     - If the final step of the derivation is by [T_Proj], then there
       is a term [tr], type [Tr] and label [i] such that [t = tr.i],
       [empty |- tr : Tr], and [Tlookup i Tr = Some T].

       The IH for the typing derivation gives us that, for any term
       [tr'], if [tr --> tr'] then [empty |- tr' Tr].  Inspection of
       the definition of the step relation reveals that there are two
       ways a projection can step.  Case [ST_Proj1] follows
       immediately by the IH.

       Instead suppose [tr --> i] steps by [ST_ProjRcd].  Then [tr] is a
       value and there is some term [vi] such that
       [tlookup i tr = Some vi] and [t' = vi].  But by lemma
       [lookup_field_in_value], [empty |- vi : Ti] as desired.

     - If the final step of the derivation is by [T_Sub], then there
       is a type [S] such that [S <: T] and [empty |- t : S].  The
       result is immediate by the induction hypothesis for the typing
       subderivation and an application of [T_Sub].

     - If the final step of the derivation is by [T_RCons], then there
       exist some terms [t1] [tr], types [T1 Tr] and a label [t] such
       that [t = i:=t1 :: tr}], [T = i:T1 :: Tr], [record_ty tr],
       [record_tm Tr], [empty |- t1 : T1] and [empty |- tr : Tr].

       By the definition of the step relation, [t] must have stepped
       by [ST_Rcd_Head] or [ST_Rcd_Tail].  In the first case, the
       result follows by the IH for [t1]'s typing derivation and
       [T_RCons].  In the second case, the result follows by the IH
       for [tr]'s typing derivation, [T_RCons], and a use of the
       [step_preserves_record_tm] lemma. *)

End RecordSub.

(* 2021-08-11 15:11 *)