(** * Introduction to interaction trees *)

(** This file contains exercises to get familiar with the
    Interaction Trees library, via the simplified
    interface of [theories/ITree/Simple.v].

    The solutions can be found in [examples/IntroductionSolutions.v].
 *)

(* begin hide *)
From Coq Require Import
     Arith
     Lia
     List.

From ExtLib Require Import
     Monad
     Traversable
     Data.List.

From ITree Require Import
     Simple.

Import ListNotations.
Import ITreeNotations.
Import MonadNotation.
Open Scope monad_scope.
(* end hide *)

(** * Events *)

(** We first show how to represent effectful computations
    as interaction trees. The [itree] type is parameterized
    by an _event type_, which is typically an indexed type
    with constructors describing the possible interactions
    with the environment.

    For instance, [ioE] below is a type of simple input/output
    events. The fields of each constructor contain data produced
    by the tree, and the type index the type of answer that the
    tree expects as a response to the event.
 *)

Inductive ioE : Type -> Type :=
| Input : ioE (list nat)
  (** Ask for a list of [nat] from the environment. *)

| Output : list nat -> ioE unit
  (** Send a list of [nat]. *)
.

(** Events are wrapped as ITrees using [ITree.trigger], and
    composed using monadic operations [bind] and [ret]. *)

(** Read some input, and echo it back, appending [1] to it. *)
Definition write_one : itree ioE unit :=
  xs <- ITree.trigger Input;;
  ITree.trigger (Output (xs ++ [1])).

(** We can _interpret_ interaction trees by giving semantics
    to their events individually, as a _handler_: a function
    of type [forall R, ioE R -> M R] for some monad [M]. *)

(** The handler [handle_io] below responds to every [Input] event
    with [[0]], and appends any [Output] to a global log.

    Here the target monad is [M := stateT (list nat) (itree void1)],
    - [stateT] is the state monad transformer, that type unfolds to
      [M R := list nat -> itree void1 (list nat * R)];
    - [void1] is the empty event (so the resulting ITree can trigger
      no event). *)

Compute Monads.stateT (list nat) (itree void1) unit.
Print void1.

Definition handle_io
  : forall R, ioE R -> Monads.stateT (list nat) (itree void1) R
  := fun R e log =>
       match e with
       | Input => ret (log, [0])
       | Output o => ret (log ++ o, tt)
       end.

(** [interp] lifts any handler into an _interpreter_, of type
    [forall R, itree ioE R -> M R]. *)
Definition interp_io
  : forall R, itree ioE R -> itree void1 (list nat * R)
  := fun R t => Monads.run_stateT (interp handle_io t) [].

(** We can now interpret [write_one]. *)
Definition interpreted_write_one : itree void1 (list nat * unit)
  := interp_io _ write_one.

(** Intuitively, [interp_io] replaces every [ITree.trigger] in the
    definition of [write_one] with [handle_io]:
[[
  interpreted_write_one =
    xs <- handle_io _ Input;;
    handle_io _ (Output (xs ++ [1]))
]]

    We can prove such a lemma in a more restricted setting, where
    [handle_io] targets some monad of the form [itree F], rather than
    [T (itree F)] (above, [T := stateT (list nat)]). (The library is
    currently missing some theory about the monads we can instantiate
    [interp] with.)

    The proof of [interp_write_one] will require us to rewrite an
    expression under a binder---i.e., on the right side of a
    [;;]. The [rewrite] tactic will fail in this situation; instead,
    we can use [setoid_rewrite], which works under binders.
 *)
Lemma interp_write_one F (handle_io : forall R, ioE R -> itree F R)
  : interp handle_io write_one
  ≈ (xs <- handle_io _ Input;;
     handle_io _ (Output (xs ++ [1]))).
Proof.
  unfold write_one.
  (* Use lemmas from [ITree.Simple] ([theories/Simple.v]). *)
  (* FILL IN HERE *) Admitted.

(** An [itree void1] is a computation which can either return a value,
    or loop infinitely. Since Coq is total, [interpreted_write_one]
    will not be reduced naively.

    Instead, we can force computation with fuel, using [burn]:
 *)
Compute (burn 100 interpreted_write_one).

(** * General recursion with interaction trees *)

(** One application of [interp] is to define and reason about recursive
    functions as ITrees. In this section, we will demonstrate:
    - [rec]
    - equational reasoning using [≈] ([\approx])
*)

(** In this file, we won't use external events, so we will use this
    empty event type [void1]. *)
Definition E := void1.

(** ** Factorial *)

(** This is the Coq specification -- the usual mathematical definition. *)
Fixpoint factorial_spec (n : nat) : nat :=
  match n with
  | 0 => 1
  | S m => n * factorial_spec m
  end.

(** The generic [rec] interface of the library's [Interp] module can
    be used to define a single recursive function.  The more general
    [mrec] (from which [rec] is defined) allows multiple, mutually
    recursive definitions.

    The argument of [rec] is an interaction tree with an event type
    [callE A B] to represent "recursive calls", with input [A]
    and output [B]. The function [call : A -> itree _ B] can be used
    to make such calls.

    In this case, since [factorial : nat -> nat], we use
    [callE nat nat].
 *)
Definition fact_body (x : nat) : itree (callE nat nat +' E) nat :=
  match x with
  | 0 => Ret 1
  | S m =>
    y <- call m ;;  (* Recursively compute [y := m!] *)
    Ret (x * y)
  end.

(** The factorial function itself is defined as an ITree by "tying
    the knot" using [rec].
 *)
Definition factorial (n : nat) : itree E nat :=
  rec fact_body n.

(** *** Evaluation *)

(** Contrary to definitions by [Fixpoint], there are no restrictions
    on the arguments of recursive calls: [rec] may thus produce
    diverging computations, and Coq will not naively reduce
    [factorial 5].

    We can force the computation with fuel, e.g., using [burn]...
 *)
Compute (burn 100 (factorial 5)).

(** ... or with tactics, such as [tau_steps], which removes
    all taus from the left-hand side of an [≈] equation. *)
Example fact_5 : factorial 5 ≈ Ret 120.
Proof.
  tau_steps. reflexivity.
Qed.

(** *** Alternative notation *)

(** An equivalent definition with a [rec-fix] notation looking like
    [fix], where the recursive call can be given a more specific name.
 *)
Definition factorial' : nat -> itree E nat :=
  rec-fix fact x :=
    match x with
    | 0 => Ret 1
    | S m => y <- fact m ;; Ret (x * y)
    end.

(** These two definitions are definitionally equal. *)
Lemma factorial_same : factorial = factorial'.
Proof. reflexivity. Qed.

(** *** Correctness *)

(** [rec] is actually a special version of [interp], which replaces
    every [call] in [fact_body] with [factorial] itself.
 *)
Lemma unfold_factorial : forall x,
    factorial x ≈ match x with
                  | 0 => Ret 1
                  | S m =>
                    y <- factorial m ;;
                    Ret (x * y)
                  end.
Proof.
  intros x.
  unfold factorial.
  (* FILL IN HERE *) Admitted.

(** We can prove that the ITrees version [factorial] is "equivalent"
    to the [factorial_spec] version.  The proof goes by induction on
    [n] and uses only rewriting -- no coinduction necessary.

    Here, we detail each step of rewriting to illustrate the use of
    the equational theory, which is mostly applications of the monad
    laws and the properties of [rec].

    In this proof, we do all of the rewriting steps explicitly.
 *)
Lemma factorial_correct : forall n,
    factorial n ≈ Ret (factorial_spec n).
Proof.
  intros n.
  (* FILL IN HERE *) Admitted.

(** ** Fibonacci *)

(** Carry out the analogous proof of correctness for the Fibonacci
    function, whose naturally recursive coq definition is given below.
 *)

Fixpoint fib_spec (n : nat) : nat :=
  match n with
  | 0 => 0
  | S n' =>
    match n' with
    | 0 => 1
    | S n'' => fib_spec n'' + fib_spec n'
    end
  end.

Definition fib_body : nat -> itree (callE nat nat +' E) nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Definition fib n : itree E nat :=
  rec fib_body n.

Example fib_3_6 : mapT fib [4;5;6] ≈ Ret [3; 5; 8].
Proof.
  (* Use [tau_steps] to compute. *)
  (* FILL IN HERE *) Admitted.

(** Since fib uses two recursive calls, we need to strengthen the
    induction hypothesis.  One way to do that is to prove the
    property for all [m <= n].

    You may find the following two lemmas useful at the start
    of each case.
[[
Nat.le_0_r : forall n : nat, n <= 0 <-> n = 0
Nat.le_succ_r : forall n m : nat, n <= S m <-> n <= m \/ n = S m
]]
 *)

Lemma fib_correct_aux : forall n m, m <= n ->
    fib m ≈ Ret (fib_spec m).
Proof.
  intros n.
  unfold fib.
  induction n as [ | n' IH ]; intros.
  - (* n = 0 *)
    apply Nat.le_0_r in H. subst m.
    (* FILL IN HERE *) admit.
  - (* n = S n' *)
    apply Nat.le_succ_r in H.
    (* FILL IN HERE *) admit.
(* FILL IN HERE *) Admitted.

(** ** Logarithm *)

(** An example of a function which is not structurally recursive.
    [log_ b n]: logarithm of [n] in base [b].

    Specification:
      [log_ b (b ^ y) ≈ Ret y] when [1 < b].

    (Note that this only constrains a very small subset of inputs,
    and in fact our solution diverges for some of them.)
 *)
Definition log (b : nat) : nat -> itree E nat
  (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

Example log_2_64 : log 2 (2 ^ 6) ≈ Ret 6.
Proof.
  (* FILL IN HERE *) Admitted.

(** These lemmas take care of the boring arithmetic. *)
Lemma log_correct_helper :
  forall b y, 1 < b ->
              (b * b ^ y <=? 1) = false.
Proof.
  intros.
  apply Nat.leb_gt.
  apply Nat.lt_1_mul_pos; auto.
  apply Nat.neq_0_lt_0. intro.
  apply (Nat.pow_nonzero b y); lia.
Qed.

Lemma log_correct_helper2 :
  forall b y, 1 < b ->
              (b * b ^ y / b) = (b ^ y).
Proof.
  intros; rewrite Nat.mul_comm, Nat.div_mul; lia.
Qed.

Lemma log_correct : forall b y, 1 < b -> log b (b ^ y) ≈ Ret y.
Proof.
  intros b y H.
  (* FILL IN HERE *) Admitted.


(** * Lambda calculus parametric de Bruijn terms *)

(**
  We use the parametric de Bruijn convention of
  https://coq.inria.fr/cocorico/UntypedLambdaTerms
  and earlier Bird and Patterson \cite{bird1999bruijn}.
  See also Capretta and Felty \cite{capretta2007combining}.
*)

Definition Succ := S%nat.  (* an alias for later *)

Require Import Coq.Program.Basics.
Require Import Coq.Program.Equality.
Require Import Coq.Setoids.Setoid.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Export Notations.

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

Inductive Term {Var : Set} : Set :=
  | term_top : Term
  | term_bot : Term
  | term_join : Term -> Term -> Term
  | term_rand : Term -> Term -> Term
  | term_app : Term -> Term -> Term
  | term_var : Var -> Term
  | term_lambda : @Term (option Var) -> Term.
Arguments Term : default implicits.
Hint Constructors Term.
Definition ClosedTerm := Term Empty_set.

Notation "'TOP'" := term_top : term_scope.
Notation "'BOT'" := term_bot : term_scope.
Notation "'JOIN'" := term_join : term_scope.
Notation "'RAND'" := term_rand : term_scope.
Notation "'APP'" := term_app : term_scope.
Notation "'VAR'" := term_var : term_scope.
Notation "'LAMBDA'" := term_lambda : term_scope.

Open Scope term_scope.
Delimit Scope term_scope with term.
Bind Scope term_scope with Term.

Notation "x * y" := (APP x y)%term : term_scope.
Notation "x || y" := (JOIN x y)%term : term_scope.
Notation "x (+) y" := (RAND x y)%term : term_scope.

(* ------------------------------------------------------------------------ *)
(** ** Lambda notation *)

Fixpoint iter {a : Type} (z : a) (s : a -> a) (n : nat) {struct n} :=
  match n with
  | 0 => z
  | Succ n' => s (iter z s n')
  end.

Fixpoint iter_dep
  {tz : Set} {ts : Set -> Set}
  (x : tz) (f : forall t : Set, t -> ts t) (n : nat) {struct n} :=
  match n return iter tz ts n with
  | 0 => x
  | Succ n' => f _ (iter_dep x f n')
  end.

Fixpoint iter_depT
  {tz : Type} {ts : Type -> Type}
  (x : tz) (f : forall t : Type, t -> ts t) (n : nat) {struct n} :=
  match n return iter tz ts n with
  | 0 => x
  | Succ n' => f _ (iter_depT x f n')
  end.

(* restrict [option] to [Set] level *)
Definition option' (a : Set) : Set := option a.
Definition Some' (a : Set) (x : a) : option' a := Some x.
Definition None' {a : Set} : option' a := None.

Definition option_ (n : nat) (v : Set) := iter v option' n.
Definition Some_ (n : nat) (v : Set) := iter_depT v Some n.
Definition lam_ {Var : Set} (n : nat) (x : Term (option_ n Var)) :=
  iter_dep x (@term_var) n.
(*
Definition var_ {Var : Set} (n : nat) : Term (option_ n Var) :=
  @VAR (option_ n Var) (iter_dep (@None' Var) Some' n).
*)

Section I.
  Definition v0 {Var : Set} : Term (option_ 1 Var) := VAR None.
  Definition v1 {Var : Set} : Term (option_ 2 Var) := VAR (Some None).
  Definition v2 {Var : Set} : Term (option_ 3 Var) := VAR (Some (Some None)).
  Context {Var : Set}.

  Definition I : Term Var := Eval compute in
    LAMBDA v0.
  Definition K : Term Var := Eval compute in
    LAMBDA (LAMBDA (VAR (Some None))).
  Definition F : Term Var := Eval compute in
    LAMBDA (LAMBDA (VAR None)).
  Definition B : Term Var := Eval compute in
    LAMBDA (LAMBDA (LAMBDA (v2 * (v1 * v0)))).
  Definition C : Term Var := Eval compute in
    LAMBDA (LAMBDA (LAMBDA (v2 * v0 * v1))).
  Definition S : Term Var := Eval compute in
    LAMBDA (LAMBDA (LAMBDA (v2 * v0 * (v1 * v0)))).
  Definition J : Term Var := Eval compute in
    LAMBDA (LAMBDA (v0 || v1)).
  Definition R : Term Var := Eval compute in
    LAMBDA (LAMBDA (v0 (+) v1)).
End I.
Print S.  (* Ugly! *)

Notation "x 'o' y" := (B * x * y)%term : term_scope.

(* TODO figure out how to use lambda notation
Notation "\ x , y" := (LAMBDA)%term : code_scope.
*)

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

(* adapted from https://coq.inria.fr/cocorico/UntypedLambdaTerms *)

Lemma ext_respectful
  (a b : Type) (f g : a -> b) (r : relation b) (fg : forall x, r (f x) (g x)) :
  respectful eq r f g.
Proof.
  intros x x' xx'; rewrite xx'; auto.
Qed.

Instance option_map_proper (Var Var' : Set) :
  Proper ((eq ==> eq) ==> eq ==> eq) (@option_map Var Var').
Proof.
  intros f f' ff' v v' vv'; compute in ff'; rewrite <- vv'; clear v' vv'.
  case_eq v; intro v0; intros; simpl; auto.
  assert (f v0 = f' v0) as eq; [apply ff' | rewrite eq]; auto.
Qed.

Fixpoint term_map {Var Var' : Set} (f : Var -> Var') (x : Term Var) :
  Term Var' :=
  match x with
  | TOP => TOP
  | BOT => BOT
  | x1 || x2 => term_map f x1 || term_map f x2
  | x1 (+) x2 => term_map f x1 (+) term_map f x2
  | x1 * x2 => term_map f x1 * term_map f x2
  | term_var x => VAR (f x)
  | term_lambda x1 => LAMBDA (term_map (option_map f) x1)
  end.

Instance term_map_proper (Var Var' : Set) :
  Proper ((eq ==> eq) ==> eq ==> eq) (@term_map Var Var').
Proof.
  intros f f' ff' x x' xx'; compute in ff'; rewrite <- xx'; clear x' xx'.
  revert Var' f f' ff'; induction x; intros Var' f f' ff'; simpl; auto.
  - rewrite (IHx1 Var' f f'), (IHx2 Var' f f'); auto.
  - rewrite (IHx1 Var' f f'), (IHx2 Var' f f'); auto.
  - rewrite (IHx1 Var' f f'), (IHx2 Var' f f'); auto.
  - rewrite (ff' v v); auto.
  - rewrite (IHx (option Var') (option_map f) (option_map f')); auto.
    apply option_map_proper; auto.
Qed.

Definition some_sub
  {Var Var' : Set} (f : Var -> Term Var') (v : option Var) :
  Term (option Var') :=
  match v with
  | None => VAR None
  | Some v' => term_map (@Some Var') (f v')
  end.

Instance some_sub_proper (Var Var' : Set) :
  Proper ((eq ==> eq) ==> eq ==> eq) (@some_sub Var Var').
Proof.
  intros f f' ff' v v' vv'; compute in ff'; rewrite <- vv'; clear v' vv'.
  case_eq v; intro v0; intros; simpl; auto.
  assert (f v0 = f' v0) as eq; [apply ff' | rewrite eq]; auto.
Qed.

Fixpoint term_sub {Var Var' : Set} (f : Var -> Term Var') (x : Term Var) :
  Term Var' :=
  match x with
  | TOP => TOP
  | BOT => BOT
  | x1 || x2 => term_sub f x1 || term_sub f x2
  | x1 (+) x2 => term_sub f x1 (+) term_sub f x2
  | x1 * x2 => term_sub f x1 * term_sub f x2
  | term_var v => f v
  | term_lambda x1 => LAMBDA (term_sub (some_sub f) x1)
  end.

Instance term_sub_proper (Var Var' : Set) :
  Proper ((eq ==> eq) ==> eq ==> eq) (@term_sub Var Var').
Proof.
  intros f f' ff'; compute in ff'.
  intros x x' xx'; rewrite <- xx'; clear x' xx'.
  revert Var' f f' ff'; induction x; intros Var' f f' ff'; auto.
  - simpl; rewrite (IHx1 Var' f f'), (IHx2 Var' f f'); auto.
  - simpl; rewrite (IHx1 Var' f f'), (IHx2 Var' f f'); auto.
  - simpl; rewrite (IHx1 Var' f f'), (IHx2 Var' f f'); auto.
  - compute; auto.
  - simpl; rewrite (IHx _ (some_sub f) (some_sub f')); clear IHx; auto.
    intros v v' vv'; rewrite <- vv'; clear v' vv' x.
    apply some_sub_proper; auto.
Qed.

Notation "x @ f" := (term_sub f x)%term : term_scope.

Definition sub_top {Var : Set} (v : Var) : ClosedTerm := TOP.
Definition close {Var : Set} : Term Var -> ClosedTerm := term_sub sub_top.

Definition sub_empty {Var : Set} (v : Empty_set) : Var := match v with end.
Definition open (Var : Set) : ClosedTerm -> Term Var := term_map sub_empty.

Tactic Notation "term_simpl" := autorewrite with term_simpl.
Tactic Notation "term_simpl" "in" hyp(H) := autorewrite with term_simpl in H.

Lemma var_monad_unit_right (Var : Set) (x : Term Var) : x @ VAR = x.
Proof.
  induction x; auto; simpl;
  repeat
    match goal with
    | [H : _ @ VAR = _ |- _] => rewrite H; clear H
    end;
  try reflexivity.
  admit.
Qed.
Hint Rewrite var_monad_unit_right : term_simpl.

Lemma var_monad_unit_left (Var Var' : Set) (f : Var -> Term Var') x :
  (VAR x) @ f = f x.
Proof.
  compute; auto.
Qed.
Hint Rewrite var_monad_unit_left : term_simpl.

Lemma term_sub_ap (Var Var' : Set) (x y : Term Var) (f : Var -> Term Var') :
  (x * y @ f) = (x @ f) * (y @ f).
Proof.
  simpl; auto.
Qed.
Hint Rewrite term_sub_ap : term_simpl.

Lemma term_sub_join (Var Var' : Set) (x y : Term Var) (f : Var -> Term Var') :
  (x || y @ f) = (x @ f) || (y @ f).
Proof.
  simpl; auto.
Qed.
Hint Rewrite term_sub_join : term_simpl.

Lemma term_sub_rand (Var Var' : Set) (x y : Term Var) (f : Var -> Term Var') :
  (x (+) y @ f) = (x @ f) (+) (y @ f).
Proof.
  simpl; auto.
Qed.
Hint Rewrite term_sub_rand : term_simpl.

Lemma term_sub_lambda
  (Var Var' : Set) (x : Term (option Var)) (f : Var -> Term Var') :
  (LAMBDA x @ f) = LAMBDA (x @ some_sub f).
Proof.
  simpl; auto.
Qed.
Hint Rewrite term_sub_lambda : term_simpl.

Lemma var_monad_assoc
  (Var Var' Var'' : Set)
  (f : Var -> Term Var')
  (g : Var' -> Term Var'')
  (x : Term Var) :
  (x @ f) @ g = x @ (fun v => (f v) @ g).
Proof.
  revert Var' Var'' f g; induction x; intros Var' Var'' f g; auto.
  - term_simpl; rewrite IHx1; rewrite IHx2; auto.
  - term_simpl; rewrite IHx1; rewrite IHx2; auto.
  - term_simpl; rewrite IHx1; rewrite IHx2; auto.
  - term_simpl; rewrite IHx; simpl; auto.
    admit.
Qed.
Hint Rewrite var_monad_assoc : term_simpl.

Lemma close_idempotent (Var : Set) (x : Term Var) : close (close x) = close x.
Proof.
  compute; term_simpl; induction x; auto.
Qed.
Hint Rewrite close_idempotent : beta_simpl.
Hint Rewrite close_idempotent : term_simpl.

Lemma close_closed (x : ClosedTerm) : close x = x.
Proof.
  unfold ClosedTerm in x; unfold close, sub_top.
  dependent induction x; term_simpl;
  match goal with [v : Empty_set |- _] => destruct v | _ => idtac end; auto.
  - rewrite IHx1; rewrite IHx2; reflexivity.
  - rewrite IHx1; rewrite IHx2; reflexivity.
  - rewrite IHx1; rewrite IHx2; reflexivity.
  - clear IHx.
    set (f := fun _ : Empty_set => TOP).
    rewrite <- var_monad_unit_right; simpl.
    assert (forall v, f v = VAR v) as eq; [intro v; case v|].
    apply ext_respectful in eq.
    apply some_sub_proper in eq.
    apply term_sub_proper in eq.
    unfold respectful in eq.
    rewrite (eq x x); auto.
Qed.
Hint Rewrite close_closed : beta_simpl.
Hint Rewrite close_closed : term_simpl.

Lemma open_close
  (Var : Set) (f : Var -> Term Empty_set) (x : Term Empty_set) :
  (open Var x) @ f = x.
Proof.
  unfold open.
  revert Var f; dependent induction x; intros Var f; simpl; auto.
  - rewrite (IHx1 Var f), (IHx2 Var f); auto.
  - rewrite (IHx1 Var f), (IHx2 Var f); auto.
  - rewrite (IHx1 Var f), (IHx2 Var f); auto.
  - case v.
  - admit.
Qed.

Lemma term_sub_ext (Var Var' : Set)
  (f g : Var -> Term Var') (fg : forall v, f v = g v) x :
  x @ f = x @ g.
Proof.
  revert Var' f g fg; induction x; intros Var' f g fg; simpl; auto.
  - rewrite (IHx1 Var' f g), (IHx2 Var' f g); auto.
  - rewrite (IHx1 Var' f g), (IHx2 Var' f g); auto.
  - rewrite (IHx1 Var' f g), (IHx2 Var' f g); auto.
  - rewrite (IHx (option Var') (some_sub f) (some_sub g)); auto.
    apply ext_respectful in fg.
    intros; apply (some_sub_proper Var _ f g fg); auto.
Qed.

Definition none_sub {Var : Set} (x : Term Var) (v : option Var) : Term Var :=
  match v with
  | None => x
  | Some v' => VAR v'
  end.

Definition lambda_app_sub {Var : Set} (x : Term (option Var)) (y : Term Var) :
  Term Var := x @ (none_sub y).

Lemma lambda_app_sub_sub
  (Var : Set) (y : Term Var) (x : Term (option Var))
  (Var' : Set) (f : Var -> Term Var') :
  lambda_app_sub x y @ f = lambda_app_sub (x @ some_sub f) (y @ f).
Proof.
  revert Var' f.
  dependent induction x; intros; try (simpl; auto; reflexivity).
Admitted.


(* Copyright (c) 2008, 2011, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Creative Commons Attribution-Noncommercial-No Derivative Works 3.0
 * Unported License.
 * The license text is available at:
 *   http://creativecommons.org/licenses/by-nc-nd/3.0/
 *)

(* Types and notations presented in Chapter 6 *)

Set Implicit Arguments.
Set Asymmetric Patterns.

Notation "!" := (False_rec _ _) : specif_scope.
Notation "[ e ]" := (exist _ e _) : specif_scope.
Notation "x <== e1 ; e2" := (let (x, _) := e1 in e2)
(right associativity, at level 60) : specif_scope.

Local Open Scope specif_scope.
Delimit Scope specif_scope with specif.

Notation "'Yes'" := (left _ _) : specif_scope.
Notation "'No'" := (right _ _) : specif_scope.
Notation "'Reduce' x" := (if x then Yes else No) (at level 50) : specif_scope.

Notation "x || y" := (if x then Yes else Reduce y) (at level 50, left associativity) : specif_scope.

Section sumbool_and.
  Variables P1 Q1 P2 Q2 : Prop.

  Variable x1 : {P1} + {Q1}.
  Variable x2 : {P2} + {Q2}.

  Definition sumbool_and : {P1 /\ P2} + {Q1 \/ Q2} :=
    match x1 with
      | left HP1 =>
        match x2 with
          | left HP2 => left _ (conj HP1 HP2)
          | right HQ2 => right _ (or_intror _ HQ2)
        end
      | right HQ1 => right _ (or_introl _ HQ1)
    end.
End sumbool_and.

Infix "&&" := sumbool_and (at level 40, left associativity) : specif_scope.

Inductive maybe (A : Set) (P : A -> Prop) : Set :=
| Unknown : maybe P
| Found : forall x : A, P x -> maybe P.

Notation "{{ x | P }}" := (maybe (fun x => P)) : specif_scope.
Notation "??" := (Unknown _) : specif_scope.
Notation "[| x |]" := (Found _ x _) : specif_scope.

Notation "x <- e1 ; e2" := (match e1 with
                             | Unknown => ??
                             | Found x _ => e2
                           end)
(right associativity, at level 60) : specif_scope.

Notation "!!" := (inright _ _) : specif_scope.
Notation "[|| x ||]" := (inleft _ [x]) : specif_scope.

Notation "x <-- e1 ; e2" := (match e1 with
                               | inright _ => !!
                               | inleft (exist x _) => e2
                             end)
(right associativity, at level 60) : specif_scope.

Notation "e1 ;; e2" := (if e1 then e2 else ??)
  (right associativity, at level 60) : specif_scope.

Notation "e1 ;;; e2" := (if e1 then e2 else !!)
  (right associativity, at level 60) : specif_scope.

Section partial.
  Variable P : Prop.

  Inductive partial : Set :=
  | Proved : P -> partial
  | Uncertain : partial.
End partial.

Notation "[ P ]" := (partial P) : type_scope.

Notation "'Yes'" := (Proved _) : partial_scope.
Notation "'No'" := (Uncertain _) : partial_scope.

Local Open Scope partial_scope.
Delimit Scope partial_scope with partial.

Notation "'Reduce' v" := (if v then Yes else No) : partial_scope.
Notation "x || y" := (if x then Yes else Reduce y) : partial_scope.
Notation "x && y" := (if x then Reduce y else No) : partial_scope.


Require Export e_sequent_calculus.
Require Import Plus Le Lt.
Set Implicit Arguments.

Module Type cut_mod (B: base_mod) (S: sound_mod B) (C: complete_mod B S) (G: sequent_mod B S C).
Import B S C G.

(** * Cut Elimination

We first give some definitions*)
Reserved Notation "Γ ⊃c A" (at level 80).
Inductive Gcf : list PropF->list PropF->Prop :=
| Gcax  : forall v Γ Δ      , In #v Γ            -> In #v Δ          -> Γ ⊃c Δ
| GcBot : forall Γ Δ        , In ⊥ Γ                                 -> Γ ⊃c Δ
| cAndL : forall A B Γ1 Γ2 Δ, Γ1++A::B::Γ2 ⊃c Δ                      -> Γ1++A∧B::Γ2 ⊃c Δ
| cAndR : forall A B Γ Δ1 Δ2, Γ ⊃c Δ1++A::Δ2    -> Γ ⊃c Δ1++B::Δ2   -> Γ ⊃c Δ1++A∧B::Δ2
| cOrL  : forall A B Γ1 Γ2 Δ, Γ1++A::Γ2 ⊃c Δ    -> Γ1++B::Γ2 ⊃c Δ   -> Γ1++A∨B::Γ2 ⊃c Δ
| cOrR  : forall A B Γ Δ1 Δ2, Γ ⊃c Δ1++A::B::Δ2                      -> Γ ⊃c Δ1++A∨B::Δ2
| cImpL : forall A B Γ1 Γ2 Δ, Γ1++B::Γ2 ⊃c Δ    -> Γ1++Γ2 ⊃c A::Δ   -> Γ1++A→B::Γ2 ⊃c Δ
| cImpR : forall A B Γ Δ1 Δ2, A::Γ ⊃c Δ1++B::Δ2                     -> Γ ⊃c Δ1++A→B::Δ2
where "Γ ⊃c Δ" := (Gcf Γ Δ) : My_scope.

Notation "Γ =⊃ Δ" := (forall v,Satisfies v Γ->Validates v Δ) (at level 80).

Inductive Atomic : Set :=
 | AVar : PropVars -> Atomic
 | ABot : Atomic
.
Fixpoint AtomicF (P:Atomic) : PropF := match P with
| AVar P => #P
| ABot   => ⊥
end.

Fixpoint size A : nat := match A with
 | # P   => 0
 | ⊥     => 0
 | B ∨ C => S (size B + size C)
 | B ∧ C => S (size B + size C)
 | B → C => S (size B + size C)
end.

Definition sizel := map_fold_right size plus 0.
Definition sizes Γ Δ:= sizel Γ + sizel Δ.

(** * Theorems

reverse implication*)

Theorem G_to_Gcf : forall Γ Δ, Γ ⊃c Δ -> Γ ⊃ Δ.
induction 1;[econstructor|constructor|constr..];eassumption.
Qed.

(** Soundness of Gc *)

Theorem G_sound : forall Γ Δ, Γ ⊃ Δ -> Γ =⊃ Δ.
intros. apply G_to_Nc in H. apply Soundness_general in H.
remember (H v H0). clear -i H0.
induction Δ.
 contradiction.
 simpl in i. case_eq (TrueQ v a);intro K;rewrite K in *;simpl in *.
   exists a;split;[in_solve|rewrite K;trivial].
   destruct (IHΔ i) as (?&?&?). exists x;split;[in_solve|assumption].
Qed.

(** Preparation for the nonstructural induction *)

Lemma Atomic_eqdec : forall x y : Atomic, {x = y} + {x <> y}.
intros;destruct x;destruct y;try (right;discriminate);try (left;reflexivity);
 destruct (Varseq_dec p p0);
  (left;f_equal;assumption)||(right;intro HH;injection HH;contradiction).
Qed.

Lemma sizes_comm : forall Γ Δ, sizes Γ Δ = sizes Δ Γ.
intros;unfold sizes;apply plus_comm;reflexivity.
Qed.

Lemma sizes_comm_r : forall Γ1 Γ2 A Δ, sizes (Γ1 ++ Γ2) (A :: Δ) = sizes (Γ1 ++ A::Γ2) Δ.
intros;induction Γ1;unfold sizes;unfold sizel;simpl.
 rewrite plus_assoc;f_equal;apply plus_comm.
 rewrite <- !plus_assoc;f_equal;apply IHΓ1.
Qed.

Lemma sizes_comm_l : forall Γ1 Γ2 A Δ, sizes (A :: Δ) (Γ1 ++ Γ2) = sizes Δ (Γ1 ++ A::Γ2).
intros;rewrite sizes_comm;rewrite sizes_comm_r;apply sizes_comm.
Qed.

Lemma le_plus_trans_r : forall n m p, n <= m -> n <= p + m.
intros;rewrite plus_comm;apply le_plus_trans;assumption.
Qed.

Lemma sizes_decr :
 (forall A B Γ1 Γ2 Δ, sizes (Γ1++A::B::Γ2) Δ < sizes (Γ1++A∧B::Γ2) Δ)/\
 (forall A B Γ Δ1 Δ2, sizes Γ (Δ1++A::Δ2)    < sizes Γ (Δ1++A∧B::Δ2))/\
 (forall A B Γ Δ1 Δ2, sizes Γ (Δ1++B::Δ2)    < sizes Γ (Δ1++A∧B::Δ2))/\
 (forall A B Γ1 Γ2 Δ, sizes (Γ1++A::Γ2) Δ    < sizes (Γ1++A∨B::Γ2) Δ)/\
 (forall A B Γ1 Γ2 Δ, sizes (Γ1++B::Γ2) Δ    < sizes (Γ1++A∨B::Γ2) Δ)/\
 (forall A B Γ Δ1 Δ2, sizes Γ (Δ1++A::B::Δ2) < sizes Γ (Δ1++A∨B::Δ2))/\
 (forall A B Γ1 Γ2 Δ, sizes (Γ1++B::Γ2)  Δ   < sizes (Γ1++A→B::Γ2) Δ)/\
 (forall A B Γ1 Γ2 Δ, sizes (Γ1++Γ2) (A::Δ)  < sizes (Γ1++A→B::Γ2) Δ)/\
 (forall A B Γ Δ1 Δ2, sizes (A::Γ)(Δ1++B::Δ2)< sizes Γ (Δ1++A→B::Δ2)).
repeat split;intros;try (rewrite sizes_comm_l||rewrite sizes_comm_r);
apply plus_lt_compat_l||apply plus_lt_compat_r;induction Γ1||induction Δ1;
unfold sizel;simpl;try (apply plus_lt_compat_l;apply IHΓ1||apply IHΔ1);
apply le_lt_n_Sm;rewrite <- plus_assoc;try constructor;
try apply plus_le_compat_l;apply le_plus_trans_r;constructor.
Qed.

Lemma size_O_atomic : forall Γ, sizel Γ=0 -> exists l, Γ = map AtomicF l.
intros;induction Γ.
 exists [];reflexivity.
 destruct a;try (apply plus_is_O in H as (?&_);simpl in H;discriminate);
  unfold sizel in H;simpl in H;
   destruct (IHΓ H);[exists (AVar p::x)|exists (ABot::x)];simpl;f_equal;assumption.
Qed.

Ltac temp4 := try contradiction;do 2 econstructor;repeat ((left;in_solve;fail)||right);in_solve.

Lemma bool_false : forall b, b=false -> ~Is_true b.
intros;subst;auto.
Qed.

Lemma size_S : forall n Γ Δ, sizes Γ Δ = S n -> exists A B,
In (A→B) Γ \/ In (A→B) Δ \/ In (A∨B) Γ \/ In (A∨B) Δ \/ In (A∧B) Γ \/ In (A∧B) Δ.
intros. induction Γ;[unfold sizes in H;simpl in H;induction Δ;[discriminate|]|];
 (destruct a;[| |temp4..]);unfold sizel in H;simpl in H;
  destruct (IHΔ H) as (?&?&[|[|[|[|[]]]]])||destruct (IHΓ H) as (?&?&[|[|[|[|[]]]]]);temp4.
Qed.

(** The nonstructural induction proof*)

Ltac temp5 A B Hy := let C:= fresh "C" with K1 := fresh "K" with K2 := fresh "KK" in
intros v L;case_eq (TrueQ v A);case_eq (TrueQ v B);intros K1 K2;
try (exists A;split;[in_solve|rewrite K2;simpl;exact I];fail);
try (exists B;split;[in_solve|rewrite K1;simpl;exact I];fail);
try (exfalso;apply (bool_false K1);apply L;in_solve;fail);
try (exfalso;apply (bool_false K2);apply L;in_solve;fail);
(destruct (Hy v) as (C&?&?);
[intros ? ?;in_solve;try (apply L;in_solve;fail);
simpl;try rewrite K1;try rewrite K2;simpl;exact I|
in_solve;try (exists C;split;[in_solve|assumption];fail);
simpl in *;rewrite K1 in *;rewrite K2 in *;simpl in *;contradiction
]).

Theorem Gcf_complete_induction : forall n Γ Δ, sizes Γ Δ <= n -> Γ =⊃ Δ -> Γ ⊃c Δ.
induction n;intros.
 inversion H. apply plus_is_O in H2 as (?&?).
  apply size_O_atomic in H1 as (?&?);apply size_O_atomic in H2 as (?&?);subst.
   remember (fun P => if (in_dec Atomic_eqdec (AVar P) x) then true else false) as v.
    destruct (in_dec Atomic_eqdec ABot x).
      constructor 2;change ⊥ with (AtomicF ABot);eapply in_map;assumption.
      destruct (H0 v) as (?&?&?).
        intros ? ?. apply in_map_iff in H1 as (?&?&?);subst A;simpl;destruct x1.
          rewrite Heqv;simpl. destruct (in_dec Atomic_eqdec (AVar p) x);[exact I|contradiction].
          contradiction.
        apply in_map_iff in H1 as (?&?&?);subst x1. destruct x2.
          constructor 1 with p.
            change #p with (AtomicF (AVar p));apply in_map.
             simpl in H2;rewrite Heqv in H2. destruct (in_dec Atomic_eqdec (AVar p));[assumption|contradiction].
            change #p with (AtomicF (AVar p)). apply in_map. assumption.
          contradiction.
 inversion H;[clear H|apply IHn;assumption];destruct (size_S _ _ H2) as (A&B&[|[|[|[|[]]]]]);
  apply in_split in H as (?&?&?);subst;constr;apply IHn;
   try (apply le_S_n;rewrite <- H2;apply sizes_decr);temp5 A B H0.
Qed.

Theorem Gcf_complete : forall Γ Δ, Γ =⊃ Δ -> Γ ⊃c Δ.
intros;eapply Gcf_complete_induction;[constructor|assumption].
Qed.

Theorem Cut_elimination : forall Γ Δ, Γ ⊃ Δ -> Γ ⊃c Δ.
intros.
apply Gcf_complete.
apply G_sound.
assumption.
Qed.

Print Assumptions Cut_elimination.

End cut_mod.


Definition Let_In {A B} (v : A) (f : A -> B) := let v' := v in f v'.
Reserved Notation "'dlet' x .. y := v 'in' f"
         (at level 200, x binder, y binder, f at level 200, format "'dlet'  x .. y  :=  v  'in' '//' f").
Notation "'dlet' x .. y := v 'in' f" := (Let_In v (fun x => .. (fun y => f) .. )).
Fixpoint some_lets (n : nat) (v : nat) : nat :=
  match n with
  | 0 => v
  | S n' => dlet k := some_lets n' v + some_lets n' v in some_lets n' k
  end.

Definition some_unfolded_lets (n : nat) : { v : nat | v = some_lets 6 n }.
Proof.
  econstructor; cbv beta iota delta [some_lets]; constructor.
Defined.

Inductive let_inM : Type -> Type :=
| ret {A : Type} : A -> let_inM A
| bind {A : Type} {B : Type} : let_inM A -> (A -> let_inM B) -> let_inM B
| app2 {A B C : Type} : (A -> B -> C) -> let_inM A -> let_inM B -> let_inM C.

Fixpoint denote_let_inM {A : Type} (v : let_inM A) : A
  := match v with
     | ret v => v
     | bind v f => (dlet v' := denote_let_inM v in denote_let_inM (f v'))
     | app2 f x y => f (denote_let_inM x) (denote_let_inM y)
     end.

Fixpoint under_lets {A B : Type} (v : let_inM A) : (A -> let_inM B) -> let_inM B
  := match v with
     | ret v => fun f => bind (ret v) f
     | bind v g => fun f => under_lets v (fun v' => under_lets (g v') f)
     | app2 g x y => fun f => under_lets x (fun x' => under_lets y (fun y' => f (g x' y')))
     end.

Definition lift_lets : forall {A : Type} , let_inM A -> let_inM A :=
  fun A v => @under_lets A A v (@ret _).

Lemma denote_under_lets_correct {A : Type} {B : Type} (v : let_inM A)
  : forall (f : A -> let_inM B), @denote_let_inM B (@under_lets A B v f) = @denote_let_inM B (f (@denote_let_inM A v)).
Proof.
  induction v; intro f; try reflexivity; simpl; unfold Let_In; simpl; rewrite ?IHv, ?IHv1, ?IHv2, ?H; try reflexivity.
Qed.
Definition lift_lets_correct {A : Type} (v : let_inM A)
  : denote_let_inM v = denote_let_inM (lift_lets v).
Proof. symmetry; apply @denote_under_lets_correct. Qed.

Ltac reify_to_let_in_pexpr e :=
  lazymatch e with
  | (dlet n : ?T := ?val in ?body)
    => let val' := reify_to_let_in_pexpr val in
       let n' := fresh n in
       let n' := fresh n' in
       let n' := fresh n' in
       let n' := fresh n' in
       let body' := constr:(fun n : T => match body with
                                         | n' => ltac:(let n'' := (eval cbv delta [n'] in n') in
                                                       let ret := reify_to_let_in_pexpr n'' in
                                                       exact ret)
                                         end) in
       constr:(bind val' body')
  | (?a + ?b)%nat
    => let a' := reify_to_let_in_pexpr a in
       let b' := reify_to_let_in_pexpr b in
       constr:(app2 Nat.add a' b')
  | ?v => constr:(ret v)
  end.

Ltac unify_reify_rhs_to_let_in :=
  lazymatch goal with
  | [ |- ?ev = ?v :> ?ty ]
    => let v' := reify_to_let_in_pexpr v in
       let v' := constr:(denote_let_inM v') in
       refine (@eq_trans _ _ v' _ _ _); [ | abstract (cbv [denote_let_inM]; reflexivity) ]
  end.

Ltac vm_compute_rhs :=
  lazymatch goal with
  | [ |- ?ev = ?rhs ]
    => let rhs := match (eval pattern Nat.add in rhs) with ?rhs _ => rhs end in
       let rhs' := (eval vm_compute in rhs) in
       unify ev (rhs' Nat.add);
       abstract (exact_no_check (f_equal (fun f => f Nat.add) (eq_refl rhs' <: rhs' = rhs)))
  end.

Definition some_lifted_lets (n : nat) : { v : nat | v = proj1_sig (some_unfolded_lets n) }.
Proof.
  Time
    econstructor; unfold some_unfolded_lets, proj1_sig; symmetry; etransitivity; symmetry;
    [ unify_reify_rhs_to_let_in; symmetry; apply lift_lets_correct
    | symmetry; etransitivity; symmetry;
        [ apply f_equal; vm_compute_rhs
        | cbv [denote_let_inM]; reflexivity ] ].
Defined.


Require Import Coq.Lists.List.
Require Coq.Sorting.Permutation.
Require Import Coq.FSets.FMapInterface Coq.FSets.FMapFacts.
Require Import MirrorShard.MoreFMapFacts.

Set Implicit Arguments.
Set Strict Implicit.

Module Make (E:OrderedType) (FM : Sfun E).
  Module FACTS := FMapFacts.WFacts_fun E FM.
  Module PROPS := FMapFacts.WProperties_fun E FM.
  Module MFACTS := MoreFMapFacts.MoreFMapFacts E FM.

  Lemma find_Empty : forall T (m : FM.t T) x,
    FM.Empty m -> FM.find x m = None.
  Proof.
    intros.
    apply PROPS.F.not_find_in_iff.
    unfold FM.In, FM.Empty in *. specialize (H x).
    intro. destruct H0. eapply H. eauto.
  Qed.

  Section typed.
    Variable T : Type.

    Definition mmap := FM.t (list T).

    Definition mmap_Equiv : mmap -> mmap -> Prop :=
      FM.Equiv (@Permutation.Permutation _).

    Global Instance Equivalence_mmap_Equiv : RelationClasses.Equivalence mmap_Equiv.
    Proof.
      unfold mmap_Equiv. econstructor; eauto with typeclass_instances.
    Qed.

    Definition empty : mmap := FM.empty _.

    Definition mmap_add (k : FM.key) (v : T) (m : mmap) : mmap :=
      match FM.find k m with
        | None => FM.add k (v :: nil) m
        | Some v' => FM.add k (v :: v') m
      end.

    Hint Constructors Permutation.Permutation : perms.
    Ltac think :=
      repeat (rewrite FACTS.add_o in * ||
        match goal with
          | [ H : FM.MapsTo _ _ _ |- _ ] => apply FACTS.find_mapsto_iff in H
          | [ H : context [ E.eq_dec ?X ?Y ] |- _ ] => destruct (E.eq_dec X Y)
          | [ H : E.eq _ _ |- _ ] => rewrite H in *
          | [ H : ?X = Some _ , H' : ?X = Some _ |- _ ] =>
            rewrite H in H'; inversion H'; clear H'; subst
          | [ H : Some _ = Some _ |- _ ] => inversion H; clear H; subst
        end); eauto with perms.

    Global Add Parametric Morphism : mmap_add with
      signature (E.eq ==> @eq _ ==> mmap_Equiv ==> mmap_Equiv)
      as mmap_add_mor.
    Proof.
      unfold mmap_Equiv, mmap_add, FM.Equiv. intros. destruct H0.
      case_eq (FM.find x x0); case_eq (FM.find y y1); intros;
        rewrite H in * ;
        repeat match goal with
                 | [ H : FM.find _ _ = _ |- _ ] =>
                   apply FACTS.find_mapsto_iff in H ||
                   apply FACTS.not_find_in_iff in H
                 | [ |- _ ] =>
                   rewrite H in *
               end.
      { generalize (@H1 _ _ _ H3 H2).
        intuition (try rewrite H in *).
        apply FACTS.add_in_iff; apply FACTS.add_in_iff in H5.
        destruct H5; auto. right. eapply H0. auto.
        apply FACTS.add_in_iff; apply FACTS.add_in_iff in H5.
        destruct H5; auto. right. eapply H0. auto.
        think; eauto.
        eapply H1. eapply FACTS.find_mapsto_iff; eauto.  eapply FACTS.find_mapsto_iff; eauto. }
      { exfalso. apply H2. eapply H0. eexists; eauto. }
      { exfalso. apply H3. eapply H0. eexists; eauto. }
      { intuition; try rewrite H in *.
        apply FACTS.add_in_iff; apply FACTS.add_in_iff in H4.
        destruct H4; auto. right. eapply H0; eauto.
        apply FACTS.add_in_iff; apply FACTS.add_in_iff in H4.
        destruct H4; auto. right. eapply H0; eauto.
        think. eauto.
        eapply H1; eapply FACTS.find_mapsto_iff; eauto. }
    Qed.

    Lemma mmap_add_comm : forall k1 v1 k2 v2 m,
      mmap_Equiv (mmap_add k1 v1 (mmap_add k2 v2 m)) (mmap_add k2 v2 (mmap_add k1 v1 m)).
    Proof.
      unfold mmap_Equiv, mmap_add; intros.
      repeat match goal with
               | [ |- _ ] => rewrite FACTS.add_o in *
               | [ H : _ = _ |- _ ] => rewrite H in *
               | [ H : Some _ = Some _ |- _ ] => inversion H; clear H; subst
               | [ H : E.eq _ _ |- _ ] => rewrite H in *; clear H
               | [ |- context [ FM.find ?X ?Y ] ] =>
                 match Y with
                   | match _ with | _ => _ end => fail 1
                   | _ => case_eq (FM.find X Y)
                 end; intros
             end; try solve [ exfalso; auto ];
      repeat match goal with
               | [ |- context [ E.eq_dec ?X ?Y ] ] =>
                 destruct (E.eq_dec X Y)
             end; try solve [ exfalso; auto ]; unfold FM.Equiv;
      intuition;
        try solve [ repeat match goal with
                             | [ |- FM.In _ _ ] => apply FACTS.add_in_iff
                             | [ H : FM.In _ _ |- _ ] =>
                               apply FACTS.add_in_iff in H; destruct H
                             | [ H : E.eq _ _ |- _ ] => rewrite H in *
                             | [ |- _ \/ _ ] => solve [ left; auto ] || right; auto
                           end ];
        think; try solve [ congruence | exfalso; auto ].
    Qed.

    Definition mmap_extend (k : FM.key) (v : list T) (m : mmap) : mmap :=
      match FM.find k m with
        | None => FM.add k v m
        | Some v' => FM.add k (v ++ v') m
      end.

    Global Add Parametric Morphism : mmap_extend with
      signature (E.eq ==> (@Permutation.Permutation _) ==> mmap_Equiv ==> mmap_Equiv)
      as mmap_extend_mor.
    Proof.
      unfold mmap_Equiv, mmap_extend, FM.Equiv. intros. destruct H1.
      case_eq (FM.find x x1); case_eq (FM.find y y1); intros;
        rewrite H in * ;
        repeat match goal with
                 | [ H : FM.find _ _ = _ |- _ ] =>
                   apply FACTS.find_mapsto_iff in H ||
                   apply FACTS.not_find_in_iff in H
                 | [ |- _ ] =>
                   rewrite H in *
               end.
      { generalize (@H2 _ _ _ H4 H3).
        intuition (try rewrite H in *).
        apply FACTS.add_in_iff; apply FACTS.add_in_iff in H6.
        destruct H6; auto. right. eapply H1. auto.
        apply FACTS.add_in_iff; apply FACTS.add_in_iff in H6.
        destruct H6; auto. right. eapply H1. auto.
        think; eauto.
        eapply Permutation.Permutation_app; eauto.
        eapply H2. eapply FACTS.find_mapsto_iff; eauto.  eapply FACTS.find_mapsto_iff; eauto. }
      { exfalso. apply H3. eapply H1. eexists; eauto. }
      { exfalso. apply H4. eapply H1. eexists; eauto. }
      { intuition; try rewrite H in *.
        apply FACTS.add_in_iff; apply FACTS.add_in_iff in H5.
        destruct H5; auto. right. eapply H1; eauto.
        apply FACTS.add_in_iff; apply FACTS.add_in_iff in H5.
        destruct H5; auto. right. eapply H1; eauto.
        think; eauto.
        eapply H2; eapply FACTS.find_mapsto_iff; eauto. }
    Qed.

    Lemma Proper_mmap_extend : Proper (E.eq ==> eq ==> FM.Equal ==> FM.Equal) mmap_extend.
    Proof.
      unfold mmap_extend.
      repeat (red; intros; subst). rewrite H; rewrite H0. destruct (FM.find (elt:=list T) y y1); rewrite H; rewrite H0; auto.
    Qed.

    Lemma transpose_neqkey_mmap_extend : PROPS.transpose_neqkey FM.Equal mmap_extend.
    Proof.
      unfold mmap_extend. repeat (red; intros; subst).
      (repeat match goal with
                | [ H : Some _ = Some _ |- _ ] => inversion H; clear H; subst
                | [ H : _ = _ |- _ ] => rewrite H
                | [ H : _ = _ |- _ ] => rewrite H in *
                | [ H : E.eq _ _ |- _ ] => rewrite H
                | [ H : E.eq _ _ |- _ ] => rewrite H in *
                | [ H : context [ FM.find _ _ ] |- _ ] =>
                  rewrite FACTS.add_o in H
                | [ |- context [ FM.find ?k ?a ] ] =>
                  match a with
                    | match _ with
                        | Some _ => _
                        | None => _
                      end => fail 1
                    | _ => case_eq (FM.find k a); intros
                  end
              end);
      repeat match goal with
               | [ H : ~ E.eq ?X ?X |- _ ] => exfalso; apply H; reflexivity
               | [ H : E.eq _ _ |- _ ] => rewrite H
               | [ H : E.eq _ _ |- _ ] => rewrite H in *
               | [ H : Some _ = Some _ |- _ ] => inversion H ; clear H; subst
               | [ H : context [ E.eq_dec ?A ?B ] |- _ ] =>
                 destruct (E.eq_dec A B); try congruence
             end.
    Qed.
    Existing Instance Proper_mmap_extend.
    Existing Class PROPS.transpose_neqkey.
    Existing Instance transpose_neqkey_mmap_extend.

    Definition mmap_join : mmap -> mmap -> mmap :=
      FM.fold mmap_extend.

    Lemma mmap_join_o : forall (a b : mmap) x,
      FM.find x (mmap_join a b) =
      match FM.find x a with
        | Some a =>
          match FM.find x b with
            | Some b => Some (a ++ b)
            | None => Some a
          end
        | None => FM.find x b
      end.
    Proof.
      clear. unfold mmap_join.
      do 2 intro. apply PROPS.map_induction with (m := a); intros.
      rewrite PROPS.fold_Empty; eauto with typeclass_instances.
      symmetry.
      repeat rewrite find_Empty by assumption; auto.

      rewrite PROPS.fold_Add; try solve [ clear; eauto with typeclass_instances ].
      unfold mmap_extend at 1. rewrite H.
      apply PROPS.F.not_find_in_iff in H0. rewrite H0.

      specialize (H1 x0). rewrite H1.
      case_eq (FM.find x b); intros; rewrite FACTS.add_o; destruct (E.eq_dec x x0);
        try rewrite H;
          repeat match goal with
                   | [ H : E.eq _ _ |- _ ] => rewrite H in *; clear H
                   | [ H : ~E.eq ?X ?X |- _ ] => exfalso; apply H; reflexivity
                   | [ H : _ = _ |- _ ] => rewrite H
                   | [ |- context [ E.eq_dec ?X ?Y ] ] =>
                     destruct (E.eq_dec X Y); try congruence
                   | _ => rewrite FACTS.add_o in *
                 end.
    Qed.

    Lemma mmap_join_remove_acc : forall k (a b : mmap),
      ~FM.In k a ->
      FM.Equal (FM.remove k (mmap_join a b)) (mmap_join a (FM.remove k b)).
    Proof.
      unfold FM.Equal. intros.
      repeat (rewrite FACTS.remove_o || rewrite mmap_join_o).
      destruct (E.eq_dec k y); try reflexivity.
      apply PROPS.F.not_find_in_iff in H.
      rewrite e in *.
      rewrite H. reflexivity.
    Qed.

  End typed.

  Definition mmap_map T U (F : T -> U) : mmap T -> mmap U :=
    FM.map (map F).

  Definition mmap_mapi T U (F : FM.key -> T -> U) : mmap T -> mmap U :=
    FM.mapi (fun k => map (F k)).

End Make.


Require Import List.
Require Import Cecoa.Rationals.TopologicalSort Cecoa.Rationals.Lib Cecoa.Rationals.Syntax.

Section Program.

Variables variable function constructor : Type.
Variable variable_eq_dec : forall (x1 x2 : variable), {x1=x2}+{x1<>x2}.
Variable function_eq_dec : forall (x1 x2 : function), {x1=x2}+{x1<>x2}.
Variable constructor_eq_dec : forall (x1 x2 : constructor), {x1=x2}+{x1<>x2}.

Notation value := (Syntax.value constructor).
Notation term := (Syntax.term variable function constructor).
Notation pattern := (Syntax.pattern variable constructor).
Notation rule := (Syntax.rule variable function constructor).

Variable prog : list rule.

Definition function_of_rule (r : rule) :=
  match r with rule_intro f _ _ => f end.

Definition functions_of_prog : list function :=
  map function_of_rule prog.

Definition max_arity_prog := maxl (map (@max_arity_rule _ _ _) prog).

Definition wf_prog : Prop :=
  andl (map (@rule_vars_defined _ _ _) prog).

Definition prog_graph : Graph function :=
  map (fun f => (f, filter (fun g => negb (function_beq function_eq_dec f g))
                          (concat (map (fun r => functions_of_term (rhs_of_rule r))
                                       (filter (fun r => function_beq function_eq_dec f (function_of_rule r)) prog)))))
      (uniquify function_eq_dec functions_of_prog).

Definition ranklist := topologicalRankList function (function_beq function_eq_dec) prog_graph.

Definition max_rank : nat := maxl (map snd ranklist).

End Program.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D X Y : Universe, ((wd_ C D /\ (wd_ A B /\ (wd_ X Y /\ (wd_ A C /\ (col_ A B C /\ col_ A B D))))) -> col_ C A D)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* This is the "wrapped" version of the Set data structure.
   Compared to the Internal version, some of the operations
   require that the type be a lawful instance of the Ord class.
   (Otherwise, we cannot show that the resulting set
   is well-formed.) Clients may either use this interface or
   the Internal interface. *)

Require Data.Set.Internal.
Require Import GHC.Base.
Require Import Proofs.GHC.Base.
Require Import OrdTactic.
Require Import SetProofs.

(* TODO: move the type class instances to this file from SetProofs. *)

Set Bullet Behavior "Strict Subproofs".

(*

** Status

This is the annotated export list of Set. The first column says:

 V verified
 F verified according to the FMapInterface specification
 P skipped, because of partiality
 S skipped, for other reasons
 N nothing to be done (for *this* file)

            -- * Set type
V            Set

            -- * Operators
V            , (\\)

            -- * Query
V            , S.null
V            , size
V            , member
V            , notMember
N            , lookupLT
N            , lookupGT
N            , lookupLE
N            , lookupGE
V            , isSubsetOf
N            , isProperSubsetOf
V            , disjoint

            -- * Construction
V            , empty
V            , singleton
V            , insert
V            , delete
            , powerSet

            -- * Combine
V            , union
V            , unions
V            , difference
V            , intersection
            , cartesianProduct
            , disjointUnion

            -- * Filter
V            , S.filter
            , takeWhileAntitone
            , dropWhileAntitone
            , spanAntitone
V            , partition
V            , split
V            , splitMember
            , splitRoot

            -- * Indexed
V            , lookupIndex
P            , findIndex
P            , elemAt
P            , deleteAt
V            , S.take
V            , S.drop
            , S.splitAt

            -- * Map
            , S.map
V           , mapMonotonic

            -- * Folds
V            , S.foldr
V            , S.foldl
            -- ** Strict folds
V            , foldr'
V            , foldl'
            -- ** Legacy folds
V            , fold

            -- * Min\/Max
V            , lookupMin
V            , lookupMax
P            , findMin
P            , findMax
V            , deleteMin
V            , deleteMax
P            , deleteFindMin
P            , deleteFindMax
V            , maxView
V            , minView

            -- * Conversion

            -- ** List
V            , elems
V            , toList
            , fromList

            -- ** Ordered list
V            , toAscList
            , toDescList
            , fromAscList
            , fromDescList
V            , fromDistinctAscList
            , fromDistinctDescList

            -- * Debugging
S            , showTree
S            , showTreeWith
N            , valid

            ) where
*)

(* Already defined in SetProofs: instance Eq, instance Eq1, instance Monoid, instance Ord, instance Ord1, instance Semigroup *)

Definition Set_ (a:Type) `{Base.Ord a} := WFSet a.

Program Definition null {a}`{Base.Ord a} (x:Set_ a) : bool := Internal.null x.
Program Definition size {a}`{Base.Ord a} (x:Set_ a) : Num.Int := Internal.size x.
Program Definition member {a}`{Base.Ord a} (x:a) (s:Set_ a) : bool :=
  Internal.member x s.
Program Definition notMember {a}`{Base.Ord a} (x:a) (s:Set_ a) : bool :=
  Internal.notMember x s.

Program Definition lookupLT {a}`{Base.Ord a} :  a -> Set_ a -> option a :=
  Internal.lookupLT.
Program Definition lookupLE {a}`{Base.Ord a} :  a -> Set_ a -> option a :=
  Internal.lookupLE.
Program Definition lookupGT {a}`{Base.Ord a} :  a -> Set_ a -> option a :=
  Internal.lookupGT.
Program Definition lookupGE {a}`{Base.Ord a} :  a -> Set_ a -> option a :=
  Internal.lookupGE.

Program Definition isSubsetOf {a}`{Base.Ord a} : Set_ a -> Set_ a -> bool :=
  Internal.isSubsetOf.
Program Definition disjoint {a}`{Base.Ord a} : Set_ a -> Set_ a -> bool :=
  Internal.disjoint.

Program Definition isProperSubsetOf {a}`{Base.Ord a} : Set_ a -> Set_ a -> bool :=
  Internal.isProperSubsetOf.

Program Definition empty {a}`{Base.Ord a} : Set_ a :=
  exist _ Internal.empty SetProofs.empty_WF.

Definition singleton {a} `{Base.Ord a} (x:a) : Set_ a :=
  exist _ (Internal.singleton x) (SetProofs.singleton_WF x).

Ltac applyWF lem :=
  eapply lem with (lb:=None)(ub:=None); intuition.

Ltac destruct_Set_ :=
  repeat match goal with
         | [x: _ |- WF _] =>
           match type of x with
           | Set_ _ => destruct x
           end
         end.

Ltac solveWF lem := destruct_Set_; applyWF lem.

Program Definition insert {a}`{OrdLaws a} : a -> Set_ a -> Set_ a :=
  Internal.insert.
Next Obligation.
  solveWF SetProofs.insert_Desc.
Defined.

Program Definition delete {a}`{OrdLaws a} : a -> Set_ a -> Set_ a := Internal.delete.
Next Obligation.
  solveWF SetProofs.delete_Desc.
Defined.

Program Definition union {a}`{OrdLaws a} : Set_ a -> Set_ a -> Set_ a := Internal.union.
Next Obligation.
  solveWF SetProofs.union_Desc.
Defined.

Program Definition unions {a}`{OrdLaws a} (xs : list (Set_ a)) : Set_ a :=
  Internal.unions (List.map unpack xs).
Next Obligation.
  applyWF SetProofs.unions_Desc.
  unfold unpack.
  apply List.Forall_forall.
  intros.
  edestruct List.in_map_iff as [h0 _].
  destruct (h0 H0).
  destruct x0.
  simpl in *.
  destruct H1. subst.
  assumption.
Defined.

Program Definition difference {a}`{OrdLaws a} : Set_ a -> Set_ a -> Set_ a :=
  Internal.difference.
Next Obligation.
  solveWF SetProofs.difference_Desc.
Defined.

Program Definition intersection {a}`{OrdLaws a} : Set_ a -> Set_ a -> Set_ a :=
  Internal.intersection.
Next Obligation.
  solveWF SetProofs.intersection_Desc.
Defined.

Program Definition filter  {a}`{OrdLaws a} : (a -> bool) -> Set_ a -> Set_ a :=
  Internal.filter.
Next Obligation.
  solveWF SetProofs.filter_Bounded.
Qed.

Program Definition partition  {a}`{OrdLaws a} : (a -> bool) -> Set_ a -> Set_ a * Set_ a
  := Internal.partition.
Next Obligation.
  solveWF SetProofs.partition_Bounded.
Qed.
Next Obligation.
  solveWF SetProofs.partition_Bounded.
Qed.

Program Definition splitMember {a} `{OrdLaws a}
   : a -> Set_ a -> (Set_ a * bool * Set_ a)%type :=  Internal.splitMember.
Next Obligation.
  solveWF SetProofs.splitMember_Desc.
  eapply Bounded_relax_lb_None.
  eassumption.
Defined.
Next Obligation.
  solveWF SetProofs.splitMember_Desc.
  eapply Bounded_relax_ub_None.
  eassumption.
Defined.

Program Definition lookupIndex {a} `{Ord a} : a -> Set_ a -> option Int :=
  Internal.lookupIndex.

Definition Monotonic {a}{b}`{Ord a}`{Ord b} (f : a -> b) :=
   (forall x y, (f x < f y) = (x < y)) /\ (forall x y, (f x == f y) = (x == y)).

Program Definition mapMonotonic {a} `{OrdLaws a} {b}`{OrdLaws b} :
  forall (f: a -> b), Monotonic f -> Set_ a -> Set_ b :=
  fun f _ s => Internal.mapMonotonic f s.
Next Obligation.
  unfold Monotonic in *.
  solveWF SetProofs.mapMonotonic_Desc.
Defined.

Program Definition take {a}`{OrdLaws a} : Int -> Set_ a -> Set_ a := Internal.take.
Next Obligation.
  solveWF toList_take.
Defined.

Program Definition drop {a}`{OrdLaws a} : Int -> Set_ a -> Set_ a := Internal.drop.
Next Obligation.
  solveWF toList_drop.
Defined.

 Program Definition foldl {a}`{OrdLaws a}: forall A : Type, (a -> A -> A) -> Set_ a -> A -> A
    := fun a k s n => Internal.foldl (fun x e => k e x) n s.
 Program Definition foldl' {a}`{OrdLaws a}: forall A : Type, (a -> A -> A) -> Set_ a -> A -> A
    := fun a k s n => Internal.foldl' (fun x e => k e x) n s.
 Program Definition foldr {a}`{OrdLaws a}: forall A : Type, (A -> a -> A) -> Set_ a -> A -> A
    := fun a k s n => Internal.foldr (fun x e => k e x) n s.
 Program Definition foldr' {a}`{OrdLaws a}: forall A : Type, (A -> a -> A) -> Set_ a -> A -> A
    := fun a k s n => Internal.foldr' (fun x e => k e x) n s.
 Program Definition fold {a}`{OrdLaws a}: forall A : Type, (A -> a -> A) -> Set_ a -> A -> A
    := fun a k s n => Internal.fold (fun x e => k e x) n s.

Program Definition lookupMin {a}`{OrdLaws a} : Set_ a -> option a :=
  Internal.lookupMin.

Program Definition lookupMax {a}`{OrdLaws a} : Set_ a -> option a :=
  Internal.lookupMax.

Program Definition deleteMin {a}`{OrdLaws a} : Set_ a -> Set_ a :=
  Internal.deleteMin.
Next Obligation.
  destruct x. simpl.
  rewrite SetProofs.deleteMin_Desc with (lb:=None)(ub:=None); intuition.
  pose proof (SetProofs.lookupMin_Desc x None None w) as HLookup.
  destruct Internal.lookupMin; auto.
  destruct HLookup.
  eapply SetProofs.delete_Desc with (lb:=None)(ub:=None); intuition.
Defined.

Program Definition deleteMax {a}`{OrdLaws a} : Set_ a -> Set_ a :=
  Internal.deleteMax.
Next Obligation.
  destruct x.
  rewrite SetProofs.deleteMax_Desc with (lb:=None)(ub:=None); intuition.
  pose proof (SetProofs.lookupMax_Desc x None None w) as HLookup.
  destruct Internal.lookupMax; auto.
  destruct HLookup.
  eapply SetProofs.delete_Desc with (lb:=None)(ub:=None); intuition.
Defined.

Program Definition maxView {a}`{OrdLaws a} : Set_ a -> option( a * Set_ a) :=
  fun x =>
    match Internal.maxView x with
      | Some (y,z) => Some(y, z)
      | None => None
    end.
Next Obligation.
  destruct x. simpl in *.
  generalize Heq_anonymous.
  eapply SetProofs.maxView_Desc with (lb :=None) (ub:=None); intuition.
  inversion Heq_anonymous0. subst.
  eapply Desc_WF'; eauto.
  inversion Heq_anonymous0.
Defined.

Program Definition minView {a}`{OrdLaws a} : Set_ a -> option( a * Set_ a) :=
  fun x =>
    match Internal.minView x with
      | Some (y,z) => Some(y, z)
      | None => None
    end.
Next Obligation.
  destruct x. simpl in *.
  generalize Heq_anonymous.
  eapply SetProofs.minView_Desc with (lb :=None) (ub:=None); intuition.
  inversion Heq_anonymous0. subst.
  eapply Desc_WF'; eauto.
  inversion Heq_anonymous0.
Defined.

Program Definition toList {a} `{OrdLaws a} : Set_ a -> list a :=
  Internal.toList.

Program Definition toAscList {a} `{OrdLaws a} : Set_ a -> list a :=
  Internal.toDescList.

Program Definition toDescList {a} `{OrdLaws a} : Set_ a -> list a :=
  Internal.toDescList.

Program Definition fromDistinctAscList {a} `{OrdLaws a} : forall x
   {_ : Sorted.StronglySorted (fun x0 y : a => Base.op_zl__ x0 y = true) x},
   Set_ a :=  fun x y => Internal.fromDistinctAscList x.
Next Obligation.
  eapply SetProofs.fromDistinctAscList_Desc; intuition.
Defined.

Definition op_zrzr__ {a} `{OrdLaws a} : Set_ a -> Set_ a -> Set_ a :=
  fun m1 m2 => difference m1 m2.
Notation "'_\\_'" := (op_zrzr__).
Infix "\\" := (_\\_) (at level 99).

Module Notations.
Notation "'_Data.Set.\\_'" := (op_zrzr__).
Infix "Data.Set.\\" := (_\\_) (at level 99).
End Notations.


(* 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 Lia.

(* ********************************************************************** *)
(** * 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.

  #[global]
  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. lia. 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)). lia. 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]. *)

#[export] 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 *)


Require Export Iron.Language.SystemF2Cap.Step.FreshF.

(* Store location is mentioned in (supports) the given frame. *)
Fixpoint SuppF  (l : nat) (f : frame) {struct f} :=
 match f with
 | FLet t x     => SuppX l x
 | FPriv _ _ _  => False
 end.

(* Store location is mentioned in (supports) the given stack. *)
Definition SuppFs (l : nat) (fs : stack)
 := exists f, In f fs /\ SuppF l f.

(* Store environment covers all locations mentioned in the given frame.
   Alternatively: all locations in the given frame point to valid
   entries in the store environment, *)
Definition CoversF  (se : stenv) (f  : frame)
 := forall l, SuppF l f -> (exists t, get l se = Some t).
Hint Unfold CoversF.

(* Store environment covers all locations mentioned in the given stack. *)
Definition CoversFs (se : stenv) (fs : stack)
 := Forall (CoversF se) fs.
Hint Unfold CoversFs.

(********************************************************************)
Lemma coversFs_head
 :  forall se fs f
 ,  CoversFs se (fs :> f)
 -> CoversF  se f.
Proof.
 intros.
 unfold CoversFs in *.
 inverts H. auto.
Qed.
Hint Resolve coversFs_head.

Lemma coversFs_tail
 :  forall se fs f
 ,  CoversFs se (fs :> f)
 -> CoversFs se fs.
Proof.
 intros.
 unfold CoversFs in *.
 inverts H. auto.
Qed.
Hint Resolve coversFs_tail.

Lemma freshSuppF_coversF
 :  forall p se f t
 ,  CoversF se f
 -> FreshSuppF p se f
 -> FreshSuppF p (t <: se) f.
Proof.
 intros.
 unfold CoversF in *.
 destruct f.
 - snorm.
   unfold FreshSuppX in *.
   rip.
   lets D: H H2.
   destruct D as [t'].

   assert (t1 = t').
    eapply get_snoc_some
     with (x2 := t) in H3.
    rewrite H1 in H3. inverts H3.
   eauto. subst.
   eauto.

 - eauto.
Qed.

Lemma freshSuppFs_coveredFs
 :  forall p se fs t
 ,  CoversFs se fs
 -> FreshSuppFs p se fs
 -> FreshSuppFs p (t <: se) fs.
Proof.
 intros.

 induction fs as [|f].
 - snorm.
 - have (CoversF  se f).
   have (CoversFs se fs).
   have (FreshSuppFs p se fs).
   have (FreshSuppF  p se f).
   rip.

   unfold FreshSuppFs.
   eapply Forall_cons; auto.

   eapply freshSuppF_coversF; auto.
Qed.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Language LibTactics.
Require Import Strings.String.

Set Printing Parentheses.

Lemma sub_reflexivity:
  forall (A : typ), sub A A.
Proof.
  induction A; eauto.
Qed.

Hint Resolve sub_reflexivity : core.

Lemma sub_and_inversion1:
  forall (A B C : typ), sub A (typ_and B C) -> sub A B /\ sub A C.
Proof.
  introv Sub.
  dependent induction Sub; eauto.
  destruct (IHSub B C); eauto.
  destruct (IHSub B C); eauto.
Qed.

Lemma sub_and_inversion2:
  forall (A B C : typ), sub (typ_and A B) C -> sub A C \/ sub B C \/ exists C1 C2, C = typ_and C1 C2.
Proof.
  introv Hsub.
  dependent induction Hsub; eauto.
Qed.

Lemma sub_transitivity:
  forall (B A C : typ),
    sub A B -> sub B C -> sub A C.
Proof.
  dependent induction B; intros; eauto.
  - dependent induction H; eauto.
  - dependent induction H; eauto.
    dependent induction H0; eauto.
  - dependent induction H0; eauto.
    clear IHsub1 IHsub2.
    dependent induction H; eauto.
  - eapply sub_and_inversion1 in H. destruct H.
    dependent induction H0; eauto.
Qed.

Lemma sub_toplike1:
  forall (A B : typ),
    toplike A -> sub B A.
Proof.
  intros.
  generalize dependent B.
  dependent induction H; eauto.
Qed.

Lemma sub_toplike2:
  forall (A : typ),
    sub typ_top A -> toplike A.
Proof.
  intros.
  dependent induction H; eauto.
Qed.

Hint Resolve sub_toplike1 : core.
Hint Resolve sub_toplike2 : core.

Ltac inversion_ordinary :=
  match goal with
  | [H: ordinary (_ & _) |- _] => inversion H
  end.

Ltac inversion_toplike :=
  match goal with
  | [H: toplike typ_int |- _] => inversion H
  | [H1: toplike (typ_arrow ?A ?B), H2: not (toplike ?B) |- _] => (inversion H1; contradiction)
  end.

(* aux lemma for tred_determinism *)
Lemma tred_ord_toplike :
  forall (v v' : trm) (A : typ),
    ordinary A -> toplike A -> typedred v A v' ->
    v' = (trm_anno (trm_int 1) A).
Proof.
  induction 3; eauto; try solve [inversion_toplike | inversion_ordinary].
Qed.

Hint Resolve tred_ord_toplike : core.

Ltac simpl_as :=
  match goal with
  | [H: appsub nil ?A ?B |- _] => dependent destruction H
  end.

(* aux lemma for disjoint_value_consistent *)
Lemma tred_sub :
  forall (A : typ) (v v' : trm),
    value v -> typedred v A v' -> forall (B : typ),
    typing nil nil v B ->
    sub B A.
Proof.
  introv Hv Hred.
  dependent induction Hred; eauto; introv Htyp.
  - dependent destruction Htyp.
    dependent destruction Htyp.
    simpl_as.
    assumption.
  - dependent destruction Htyp.
    simpl_as; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp;
    eapply sub_and_l; eapply IHHred; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp;
    eapply sub_and_r; eapply IHHred; eauto.
Qed.

Ltac rewrite_then_refl :=
  match goal with
  | [H1: ?e1 = ?expr, H2: ?e2 = ?expr |- ?e1 = ?e2] => (rewrite H1; rewrite H2; reflexivity)
  | [H1: ?e1 = ?e0, H2: ?e2 = ?e3 |- (trm_merge ?e1 ?e2) = (trm_merge ?e0 ?e3)] => (rewrite H1; rewrite H2; reflexivity)
  | [H1: ?A = ?A0, H2: ?B = ?B0 |- (?A & ?B) = (?A0 & ?B0)] => (rewrite H1; rewrite H2; reflexivity)
  end.

(* aux lemma for disjoint_value_consistent *)
Lemma tred_determinism_toplike :
  forall (A : typ),
    toplike A ->
    forall (e1 e2 e1' e2' : trm), typedred e1 A e1' -> typedred e2 A e2' -> e1' = e2'.
Proof.
  intros A Htop.
  dependent induction Htop; introv Hred1 Hred2.
  - eapply tred_ord_toplike in Hred1; eauto.
    eapply tred_ord_toplike in Hred2; eauto.
    rewrite_then_refl.
  - dependent destruction Hred1; eauto; try solve [inversion_ordinary].
    dependent destruction Hred2; try solve [inversion_ordinary].
    assert (v1 = v0). eapply IHHtop1; eauto 3.
    assert (v2 = v3). eapply IHHtop2; eauto 3.
    rewrite_then_refl.
  - assert (toplike (typ_arrow A B)); eauto.
    eapply tred_ord_toplike in Hred1; eauto.
    eapply tred_ord_toplike in Hred2; eauto.
    rewrite_then_refl.
Qed.

(* aux lemma for tred_determinism *)
Lemma disjoint_value_consistent :
  forall (A B : typ) (v1 v2 : trm),
    disjoint_spec A B -> value v1 -> value v2 ->
    typing nil nil v1 A -> typing nil nil v2 B ->
    consistency_spec v1 v2.
Proof.
  intros. unfold consistency_spec. intros.
  unfold disjoint_spec in *.
  assert (sub A A0). eapply tred_sub with (v:=v1); eauto.
  assert (sub B A0). eapply tred_sub with (v:=v2); eauto.
  assert (toplike A0); eauto.
  eapply tred_determinism_toplike; eauto.
Qed.

Hint Resolve disjoint_value_consistent : core.

Theorem tred_determinism :
  forall (v v1 v2 : trm) (A : typ),
    value v -> (exists B, typing nil nil v B) ->
    typedred v A v1 -> typedred v A v2 -> v1 = v2.
Proof.
  introv Hv Htyp Hred1.
  generalize dependent v2.
  dependent induction Hred1; eauto; introv Hred2.
  - dependent induction Hred2; try solve [inversion_toplike]; eauto.
  - dependent destruction Hred2; try solve [inversion_toplike | inversion_ordinary]; eauto.
    + symmetry. eapply tred_ord_toplike; eauto.
    + symmetry. eapply tred_ord_toplike; eauto.
  - dependent destruction Hred2; try solve [inversion_toplike]; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp.
    dependent destruction Hred2; try solve [inversion_ordinary]; eauto.
    + dependent destruction H; eauto.
    + dependent destruction H; eauto.
      assert (consistency_spec v1 v2).
      eapply disjoint_value_consistent; eauto 3. eauto.
  - dependent destruction Hv.
    dependent destruction Htyp.
    dependent destruction Hred2; try solve [inversion_ordinary]; eauto.
    + dependent destruction H; eauto.
      * assert (consistency_spec v1 v2); eauto.
        symmetry. eauto.
      * symmetry. eauto.
    + dependent destruction H; eauto.
  - dependent destruction Hred2; try solve [inversion_ordinary]; eauto.
    assert (v1 = v0); eauto.
    assert (v2 = v3); eauto.
    rewrite_then_refl.
Qed.

Lemma ptype_determinism :
  forall (e : trm) (A B : typ),
    ptype e A -> ptype e B -> A = B.
Proof.
  intros. generalize dependent B.
  dependent induction H; eauto; intros.
  - dependent destruction H0; eauto.
  - dependent destruction H0; eauto.
  - dependent destruction H1; eauto.
    assert (A = A0); eauto.
    assert (B = B0); eauto.
    rewrite_then_refl.
Qed.

Hint Resolve ptype_determinism : core.

Lemma appsub_determinism :
  forall (A : typ) (B1 B2 : typ) (S : arg),
    appsub S A B1 ->
    appsub S A B2 ->
    B1 = B2.
Proof.
  intros A B1 B2 S Has1 Has2.
  generalize dependent B2.
  dependent induction Has1; intros.
  - dependent destruction Has2.
    + reflexivity.
  - dependent destruction Has2.
    + assert (Heq: D = D0).
      eapply IHHas1; eauto.
      rewrite Heq. reflexivity.
  - dependent destruction Has2.
    + eapply IHHas1; eauto.
    + admit.
  - dependent destruction Has2.
    + admit.
    + eapply IHHas1; eauto.
Admitted.

Lemma disjoint_spec_same :
  forall (A : typ),
    not (toplike A) ->
    disjoint_spec A A -> False.
Proof.
  intros.
  induction A; eauto.
Qed.

Lemma ptype_merge_same :
  forall (v1 v2 : trm) (A : typ),
    value v1 -> value v2 ->
    (exists A, typing nil nil (trm_merge v1 v2) A) ->
(*    ptype v1 A -> ptype v2 A *)
    ptype (trm_merge v1 v2) (typ_and A A) ->
    v1 = v2.
Proof.
  introv Hv1 Hv2 Htyp Hptyp.
  destruct Htyp.
  dependent destruction Hptyp.
  dependent destruction H.
  - induction Hv1. induction Hv2; eauto.
    + dependent destruction Hptyp2.
      dependent destruction Hptyp1.
      dependent destruction H0. dependent destruction H4.
      dependent destruction H5. dependent destruction H6.
      eapply disjoint_spec_same in H; eauto. contradiction. admit.
Admitted.

Lemma value_ptype_int :
  forall (v : trm) (A : typ),
    (exists B, typing nil nil v B) ->
    sub A typ_int -> sub typ_int A ->
    value v -> ptype v A ->
    exists n, v = (trm_anno (trm_int n) A).
Proof.
  introv Htyp Hsub1 Hsub2 Hv Hptyp.
  induction Hv; intros.
  - induction H.
    + dependent destruction Hptyp.
      exists n; eauto.
    + dependent destruction Hptyp.
      destruct Htyp. dependent destruction H.
      simpl_as. dependent destruction H.
      assert (sub (typ_arrow A1 B) typ_int).
      eapply sub_transitivity; eauto.
      inversion H1.
  - dependent destruction Hptyp.
    clear IHHv1 IHHv2.
    (* v = 1,,1 *)
Admitted.

Lemma ptype_merge_same':
  forall (v1 : trm) (A : typ),
    not (toplike A) ->
    (exists B, typing nil nil v1 B) ->
    value v1 -> ptype v1 A -> forall (v2 : trm),
        (exists C, typing nil nil v2 C) ->
        value v2 -> ptype v2 A ->
        consistency_spec v1 v2 ->
        v1 = v2.
Proof.
  introv Htl Htyp1 Hv1 Hptyp1.
  dependent induction Hptyp1; eauto.
  - inversion Hv1.
  - introv Htyp2 Hv2 Hptyp2 Hcons. dependent destruction Hv1.
    dependent induction H.
    + destruct Htyp1. dependent destruction H.
      dependent destruction H. simpl_as.
      (* v2 = n : An *)
      admit.
    + destruct Htyp1. dependent destruction H.
      dependent destruction H. simpl_as.
Admitted.

Ltac simpl_deter :=
  repeat
    match goal with
    | [H1: ptype ?v ?A1, H2: ptype ?v ?A2 |- _] => (eapply ptype_determinism in H1; eauto; subst)
    | [H1: appsub ?S ?A ?B1, H2: appsub ?S ?A ?B2 |- _] => (eapply appsub_determinism in H1; eauto; subst)
    end.

Lemma papp_determinism :
  forall (v vl e1 e2 : trm),
    value v -> value vl ->
    (exists A, typing nil nil v A) ->
    (exists B, typing nil nil vl B) ->
    papp v vl e1 -> papp v vl e2 -> e1 = e2.
Proof.
  introv Hv Hvl Htyp1 Htyp2 Hp1 Hp2.
  generalize dependent e2.
  dependent induction Hp1; eauto; intros.
  - dependent destruction Hp2; try solve [inversion Hv]; eauto.
    + assert (A = A0); eauto. rewrite H3; eauto.
    + dependent destruction H. dependent destruction H0. contradiction.
    + assert (A = C); eauto. subst. contradiction.
    + assert (A = C); eauto. subst. contradiction.
  - dependent destruction Hp2.
    + dependent destruction H1. dependent destruction H2. contradiction.
    + assert (v' = v'0). eapply tred_determinism; eauto.
      destruct Htyp1. dependent destruction H3; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp1.
    eapply IHHp1; eauto.
    dependent destruction H; eauto.
    dependent destruction Hp2; eauto.
    + simpl_deter. contradiction.
    + simpl_deter.
      match goal with
      | [H: ptype (trm_merge ?v1 ?v2) ?A |- _] => dependent destruction H
      end.
      simpl_deter.
      assert (Heq: v1 = v2). eapply ptype_merge_same; eauto.
      rewrite Heq; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp1.
    eapply IHHp1; eauto.
    dependent destruction H; eauto.
    dependent destruction Hp2; eauto.
    + simpl_deter. contradiction.
    + simpl_deter.
      match goal with
      | [H: ptype (trm_merge ?v1 ?v2) ?A |- _] => dependent destruction H
      end.
      simpl_deter.
      assert (Heq: v1 = v2). eapply ptype_merge_same; eauto.
      rewrite <- Heq; eauto.
Qed.

Lemma value_cannot_step_further:
  forall (v : trm),
    value v -> forall (e : trm), not (step v e).
Proof.
  intros v Hv.
  dependent induction v; intros; try solve [inversion Hv]; eauto.
  - dependent destruction Hv. intros Hm.
    dependent destruction Hm.
    + eapply IHv1; eauto.
    + eapply IHv2; eauto.
  - dependent destruction Hv.
    induction H; eauto.
    + intros Hs.
      dependent destruction Hs; eauto.
      dependent destruction H.
    + intros Hs.
      dependent destruction Hs; eauto.
      dependent destruction H.
Qed.

Lemma stack_and_unstack:
  forall (e : trm) (A B : typ) (S : arg),
    typing nil (cons A S) e (typ_arrow A B) ->
    (exists C, typing nil nil e C).
Proof.
  intros.
  dependent induction H; eauto.
  assert (exists C, typing nil nil e1 C); eauto.
  dependent destruction H0; eauto.
Admitted.

Theorem determinism:
  forall (e e1 e2 : trm) (A : typ) (S : arg),
    typing nil nil e A ->
    step e e1 -> step e e2 -> e1 = e2.
Proof.
  intros e e1 e2 A S Htyp Hstep1.
  generalize dependent e2.
  generalize dependent A.
  dependent induction Hstep1; intros.
  - dependent destruction H; eauto.
  - dependent destruction H; eauto.
  - dependent destruction H2; eauto.
    + dependent destruction Htyp; eauto.
      eapply stack_and_unstack in Htyp2.
      eapply papp_determinism with (v:=v) (vl:=vl); eauto.
    + eapply value_cannot_step_further in H2; eauto. inversion H2.
    + eapply value_cannot_step_further in H3; eauto. inversion H3.
  - dependent destruction H1.
    + eapply tred_determinism; eauto.
      dependent destruction Htyp; eauto.
    + eapply value_cannot_step_further in H2; eauto. inversion H2.
  - dependent destruction H0.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
    + assert (Heq: e' = e'0).
      dependent destruction Htyp.
      eapply IHHstep1; eauto.
      dependent destruction Htyp; eauto.
      rewrite Heq. reflexivity.
  - dependent destruction H.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
    + dependent destruction Htyp; eauto.
      eapply stack_and_unstack in Htyp2. destruct Htyp2.
      assert (Heq: e1' = e1'0). eapply IHHstep1; eauto.
      rewrite Heq. reflexivity.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
  - dependent destruction H0.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
    + eapply value_cannot_step_further in H0; eauto. inversion H0.
    + assert (Heq: e2' = e2'0).
      dependent destruction Htyp.
      eapply IHHstep1; eauto.
      rewrite Heq. reflexivity.
  - dependent destruction H.
    + assert (e1' = e1'0).
      dependent destruction Htyp; eapply IHHstep1; eauto.
      rewrite H0. reflexivity.
    + eapply value_cannot_step_further in Hstep1; eauto. inversion Hstep1.
  - dependent destruction H0.
    + eapply value_cannot_step_further in H0; eauto. inversion H0.
    + assert (e2' = e2'0).
      dependent destruction Htyp; eapply IHHstep1; eauto.
      rewrite H2. reflexivity.
Qed.

Lemma appsub_typing :
  forall (v : trm) (S : arg) (A B : typ),
    value v -> typing nil nil v A ->
    appsub S A B ->
    typing nil S v B.
Proof.
  intros v S A B Hv Htyp Has.
  dependent induction Hv.
  - dependent destruction Htyp.
    dependent destruction H1.
    eapply typing_anno; eauto.
  - clear IHHv1 IHHv2.
    dependent induction S.
    + dependent destruction Has; eauto.
    + eapply typing_merge_pick; eauto.
Qed.

Lemma tred_value :
  forall (v v' : trm) (A : typ),
    value v -> typedred v A v' -> value v'.
Proof.
  intros.
  dependent induction H0; try solve [eauto | dependent destruction H; eauto].
Qed.

Hint Resolve tred_value : core.

Lemma toplike_false :
  forall (A : typ),
    toplike A -> sub A typ_int -> False.
Proof.
  induction A; introv Htl Hsub; try solve [inversion Htl | inversion Hsub].
  dependent destruction Htl.
  dependent destruction Hsub; eauto.
Qed.

Ltac inversion_toplike_sub :=
  match goal with
  | [H1: toplike ?A, H2: sub ?A typ_int |- _] => (eapply toplike_false in H1; eauto; inversion H1)
  end.

Lemma tred_transitivity :
  forall (v1 v2 v3 : trm) (A B : typ),
    value v1 ->
    typedred v1 A v2 ->
    typedred v2 B v3 ->
    typedred v1 B v3.
Proof.
  intros.
  generalize dependent v3.
  generalize dependent B.
  dependent induction H0; eauto; introv Hred2.
  - dependent induction Hred2; eauto.
  - dependent induction Hred2; try solve [inversion_toplike_sub]; eauto.
  - dependent induction Hred2; eauto 4.
    eapply tred_arrow_anno; eauto;
    eapply sub_transitivity; eauto.
  - dependent destruction H.
    dependent induction Hred2; eauto.
  - dependent destruction H.
    dependent induction Hred2; eauto.
  - generalize dependent v3.
    induction B0; intros v0 Hred2; try solve [eauto | dependent destruction Hred2; eauto].
Qed.

Lemma tred_consistency :
  forall (v v1 v2 : trm) (A B C : typ),
    value v -> typing nil nil v C ->
    typedred v A v1 ->
    typedred v B v2 ->
    consistency_spec v1 v2.
Proof.
  intros.
  unfold consistency_spec; intros.
  assert (typedred v A0 e1').
  eapply tred_transitivity with (v1:=v) (v2:=v1) (v3:=e1'); eauto.
  assert (typedred v A0 e2').
  eapply tred_transitivity with (v1:=v) (v2:=v2) (v3:=e2'); eauto.
  eapply tred_determinism; eauto.
Qed.

Theorem tred_preservation:
  forall (v v': trm) (A B: typ),
    value v ->
    typing nil nil v B ->
    typedred v A v' ->
    typing nil nil v' A.
Proof.
  intros v v' A B Hv Htyp Hred.
  assert (Hsub: sub B A). eapply tred_sub; eauto.
  generalize dependent B.
  dependent induction Hred; eauto; intros.
  - dependent destruction Htyp.
    dependent destruction Htyp.
    simpl_as.
    eapply typing_anno; eauto.
    eapply sub_transitivity; eauto.
  - dependent destruction Hv.
    dependent destruction Htyp; eapply IHHred; eauto.
    + eapply tred_sub. apply Hv1. apply Hred. apply Htyp1.
    + eapply tred_sub. apply Hv1. apply Hred. apply Htyp1.
  - dependent destruction Hv.
    dependent destruction Htyp; eapply IHHred; eauto.
    + eapply tred_sub. apply Hv2. apply Hred. apply Htyp2.
    + eapply tred_sub. apply Hv2. apply Hred. apply Htyp2.
  - eapply typing_merge_value; eauto.
    + eapply tred_consistency; eauto.
    + eapply IHHred1; eauto.
      eapply tred_sub. apply Hv. apply Hred1. apply Htyp.
    + eapply IHHred2; eauto.
      eapply tred_sub. apply Hv. apply Hred2. apply Htyp.
Qed.

Lemma toplike_or_not_toplike :
  forall (A : typ),
    toplike A \/ not (toplike A).
Proof.
  intros A.
  dependent induction A; eauto; try solve [right; intros Hcontra; inversion Hcontra].
  - destruct IHA1; destruct IHA2; eauto;
      try solve [right; intros H1; dependent destruction H1; contradiction].
  - destruct IHA1; destruct IHA2; eauto;
      try solve [right; intros H1; dependent destruction H1; contradiction].
Qed.

Hint Resolve toplike_or_not_toplike : core.

Lemma papp_pre_helper1:
  forall (S : arg) (A0 A B : typ),
    toplike A0 -> appsub (cons A S) A0 (typ_arrow A B) -> appsub S A0 B.
Proof.
  (* . |- Int -> Top <: Top *)
Abort.

Lemma papp_preservation :
  forall (e e1 e2 : trm) (A B : typ) (S : arg),
    value e1 -> value e2 ->
    typing nil nil e2 A ->
    typing nil (cons A S) e1 (typ_arrow A B) ->
    papp e1 e2 e ->
    typing nil S e B.
Proof.
  introv Hv1 Hv2 Htyp1 Htyp2 Hp.
  dependent destruction Htyp2; eauto.
  - inversion Hv1.
  - dependent destruction Hv1. induction H.
    + dependent destruction Htyp2.
      dependent destruction Hp.
      dependent destruction H2.
      eapply typing_anno; eauto.
Admitted.

Lemma appsub_toplike :
  forall (S : arg) (A B : typ),
    toplike A ->
    appsub S A B ->
    toplike B.
Proof.
  introv Htl Has.
  dependent induction Has; eauto.
  - dependent destruction Htl.
    constructor; eauto.
  - dependent destruction Htl; eauto.
  - dependent destruction Htl; eauto.
Qed.

Lemma papp_preservation_no_toplike :
  forall (e e1 e2 : trm) (A B : typ) (S : arg),
    value e1 -> value e2 ->
    typing nil nil e2 A ->
    not (toplike (typ_arrow A B)) ->
    typing nil (cons A S) e1 (typ_arrow A B) ->
    papp e1 e2 e ->
    typing nil S e B.
Proof.
  introv Hv1 Hv2 Htl Htyp1 Htyp2 Hp.
  dependent destruction Htyp2; eauto.
  - inversion Hv1.
  - dependent destruction Hv1. induction H.
    + dependent destruction Htyp2.
      dependent destruction Hp.
      dependent destruction H2.
      eapply typing_anno; eauto.
      assert (toplike (typ_arrow A B)). eapply appsub_toplike; eauto.
      contradiction.
    + dependent destruction Htyp2.
      dependent destruction Hp.
      * dependent destruction H2.
        assert (toplike (typ_arrow A B)). eapply appsub_toplike; eauto.
        contradiction.
      * dependent destruction H0.
        admit.
        dependent destruction H1.
        eapply typing_anno; eauto.
Admitted.

Theorem preservation :
  forall (e e' : trm) (A : typ) (S : arg),
    typing nil S e A ->
    step e e' ->
    typing nil S e' A.
Proof.
  intros e e' A S Htyp Hred.
  generalize dependent e'.
  dependent induction Htyp; intros; try solve [inversion Hred].
  - dependent destruction Hred.
    eapply typing_anno; eauto.
  - dependent destruction Hred.
    eapply typing_anno; eauto.
  - dependent destruction Hred.
    eapply typing_anno; eauto.
  - dependent destruction Hred; eauto.
    assert (typing nil nil v' A).
    eapply tred_preservation; eauto.
    eapply appsub_typing; eauto.
  - dependent destruction Hred; eauto.
    (* destruct (toplike_or_not_toplike (typ_arrow A B)); eauto. *)
    eapply papp_preservation with (e:=e) (e1:=e1) (e2:=e2); eauto.
  - dependent destruction Hred.
    + eapply typing_merge; eauto.
    + eapply typing_merge; eauto.
  - assert (value (trm_merge v1 v2)); eauto.
    apply value_cannot_step_further in Hred; eauto. inversion Hred.
  - assert (typing nil nil e' B); eauto.
    dependent destruction Hred; eauto.
Qed.

Theorem tred_progress :
  forall (v : trm) (A B : typ),
    value v -> typing nil nil v A ->
    sub A B ->
    exists v', typedred v B v'.
Proof.
  introv Hv Htyp Hsub.
  generalize dependent A.
  induction B; introv Htyp Hsub; eauto.
  - dependent induction Htyp; try solve [inversion Hv].
    + simpl_as. dependent destruction Hv.
      dependent destruction H.
      * clear IHHtyp. dependent destruction Htyp.
        exists (trm_anno (trm_int n) typ_int); eauto.
      * clear IHHtyp.
        dependent destruction Htyp.
        assert (sub (typ_arrow A0 B) typ_int). eapply sub_transitivity; eauto.
        inversion H1.
    + dependent destruction Hv.
      dependent destruction Hsub.
      * assert (exists v', typedred e1 typ_int v'); eauto.
        destruct H0; eauto.
      * assert (exists v', typedred e2 typ_int v'); eauto.
        destruct H0; eauto.
    + dependent destruction Hv.
      dependent destruction Hsub.
      * assert (exists v', typedred v1 typ_int v'); eauto.
        destruct H2; eauto.
      * assert (exists v', typedred v2 typ_int v'); eauto.
        destruct H2; eauto.
  - destruct (toplike_or_not_toplike B2).
    + exists (trm_anno (trm_int 1) (typ_arrow B1 B2)).
      eapply tred_top; eauto.
    + clear IHB1 IHB2.
      dependent induction Htyp; try solve [inversion Hv].
      * simpl_as.
        dependent destruction Hv.
        dependent induction H.
        (* case 1 *)
        dependent destruction Htyp.
        assert (sub typ_int (typ_arrow B1 B2)).
        eapply sub_transitivity; eauto.
        dependent destruction H2.
        assert (toplike B2); eauto.
        (* case 2 *)
        dependent destruction Htyp.
        exists (trm_anno (trm_abs e A0 B) (typ_arrow B1 B2)); eauto.
      * dependent destruction Hv.
        eapply sub_and_inversion2 in Hsub.
        destruct Hsub.
        (* case 1 *)
        assert (exists v', typedred e1 (typ_arrow B1 B2) v'); eauto.
        destruct H2. exists x; eauto.
        destruct H1.
        (* case 2 *)
        assert (exists v', typedred e2 (typ_arrow B1 B2) v'); eauto.
        destruct H2. exists x; eauto.
        (* case 3 *)
        destruct H1. destruct H1. inversion H1.
      * dependent destruction Hv.
        eapply sub_and_inversion2 in Hsub.
        destruct Hsub.
        (* case 1 *)
        assert (exists v', typedred v1 (typ_arrow B1 B2) v'); eauto.
        destruct H4. exists x; eauto.
        destruct H3.
        (* case 2 *)
        assert (exists v', typedred v2 (typ_arrow B1 B2) v'); eauto.
        destruct H4. exists x; eauto.
        (* case 3 *)
        destruct H3. destruct H3. inversion H3.
  - eapply sub_and_inversion1 in Hsub.
    destruct Hsub.
    assert (exists v', typedred v B1 v'); eauto.
    assert (exists v', typedred v B2 v'); eauto.
    destruct H1. destruct H2.
    exists (trm_merge x x0); eauto.
Qed.

Lemma pvalue_cannot_be_value :
  forall (e : trm),
    pvalue e -> value e -> False.
Proof.
  intros e Hp Hv.
  dependent destruction Hp; try solve [inversion Hv].
Qed.

Lemma pvalue_or_not_pvalue :
  forall (e : trm),
    pvalue e \/ not (pvalue e).
Proof.
  intros e.
  dependent induction e; eauto; try solve [right; intro H; inversion H].
Qed.

Lemma value_or_not_value :
  forall (e : trm),
    value e \/ not (value e).
Proof.
  intros e.
  dependent induction e; eauto; try solve [right; unfold not; intros; inversion H].
  - destruct IHe1; destruct IHe2; eauto;
      try solve [right; unfold not; intros; dependent destruction H1; contradiction].
  - destruct IHe.
    + right. unfold not. intros. dependent destruction H0.
      eapply pvalue_cannot_be_value; eauto.
    + assert (Hp: pvalue e \/ not (pvalue e)).
      eapply pvalue_or_not_pvalue.
      destruct Hp.
      * left. constructor. assumption.
      * right. unfold not. intros. dependent destruction H1. contradiction.
Qed.

Hint Resolve value_or_not_value : core.

Lemma papp_progress :
  forall (e1 e2 : trm) (A B : typ),
    value e2 -> typing nil (cons A nil) e1 (typ_arrow A B) ->
    typing nil nil e2 A ->
    exists e', papp e1 e2 e'.
Proof.
Admitted.

Lemma not_value_arrow_inversion :
  forall (e : trm) (S : arg) (A B : typ),
    typing nil (cons A S) e (typ_arrow A B) ->
    not (value e) ->
    exists e', step e e'.
Proof.
  introv Htyp Hnot.
  induction e; try solve [inversion Htyp]; eauto.
  - admit.
Admitted.

Theorem progress :
  forall (e : trm) (A : typ),
    typing nil nil e A ->
    value e \/ (exists e', step e e').
Proof.
  intros e A Htyp.
  dependent induction Htyp; eauto.
  - inversion H0.
  - simpl_as.
    destruct IHHtyp; eauto.
    + dependent destruction H0.
      * right.
        assert (exists v', typedred (trm_anno e A0) A v').
        eapply tred_progress; eauto.
        destruct H1. exists x. eapply step_anno_value; eauto.
      * right.
        assert (exists v', typedred (trm_merge v1 v2) A v').
        eapply tred_progress; eauto.
        destruct H0. exists x. eapply step_anno_value; eauto.
    + assert (value (trm_anno e A) \/ not (value (trm_anno e A))); eauto.
      destruct H1.
      * left. auto.
      * right. destruct H0. exists (trm_anno x A).
        eapply step_anno; eauto.
  - assert (value e2 \/ (exists e', step e2 e')); eauto.
    clear IHHtyp1 IHHtyp2. right.
    destruct H.
    + destruct (value_or_not_value e1).
      * assert (exists e', papp e1 e2 e'). eapply papp_progress; eauto.
        destruct H1. exists x. eapply step_papp; eauto.
      * assert (exists e', step e1 e'). eapply not_value_arrow_inversion; eauto.
        destruct H1. exists (trm_app x e2); eauto.
    + destruct (value_or_not_value e1).
      *  destruct H. exists (trm_app e1 x). eapply step_app_r; eauto.
      *  assert (exists e', step e1 e'). eapply not_value_arrow_inversion; eauto.
         destruct H1. exists (trm_app x e2); eauto.
  - destruct IHHtyp1; destruct IHHtyp2; eauto.
    + right. destruct H1. exists (trm_merge e1 x); eauto.
    + right. destruct H0. exists (trm_merge x e2); eauto.
    + right. destruct H0.
      exists (trm_merge x e2). eapply step_merge_l; eauto.
Qed.

Lemma papp_progress_stack :
  forall (e1 e2 : trm) (A B : typ) (S : arg),
    value e1 -> value e2 ->
    typing nil (cons A S) e1 (typ_arrow A B) ->
    typing nil nil e2 A ->
    exists e', papp e1 e2 e'.
Proof.
  dependent induction e1; introv Hv1 Hv2 Htyp1 Htyp2; try solve [inversion Hv1].
  (* there's inspiring thought here: should we deal with stack at typing_merge *)
  (* clearly, induction on merge term will give us some useful information *)

  (* let's invent a version, distribute the stack into merge *)
Admitted.

(* a stack-version progress *)
Theorem progress_stack :
  forall (e : trm) (A : typ) (S : arg),
    typing nil S e A ->
    value e \/ (exists e', step e e').
Proof.
  introv Htyp.
  dependent induction Htyp; eauto.
  - inversion H0.
  - destruct IHHtyp; eauto.
    + dependent destruction H1; eauto.
      * right.
        assert (exists v', typedred (trm_anno e A0) A v').
        eapply tred_progress; eauto.
        destruct H2. exists x. eapply step_anno_value; eauto.
      * right.
        assert (exists v', typedred (trm_merge v1 v2) A v').
        eapply tred_progress; eauto.
        destruct H1. exists x. eapply step_anno_value; eauto.
    + assert (value (trm_anno e A) \/ not (value (trm_anno e A))); eauto.
      destruct H2.
      * left. auto.
      * right. destruct H1. exists (trm_anno x A).
        eapply step_anno; eauto.
  - right. destruct IHHtyp1; destruct IHHtyp2; eauto.
    + assert (exists e', papp e1 e2 e'). eapply papp_progress_stack; eauto.
      destruct H1. exists x. eapply step_papp; eauto.
    + destruct H0.
      exists (trm_app x e2); eauto.
    + destruct H.
      exists (trm_app e1 x); eauto.
    + destruct H0.
      exists (trm_app x e2); eauto.
  - destruct IHHtyp1; destruct IHHtyp2; eauto.
    + right. destruct H1. exists (trm_merge e1 x); eauto.
    + right. destruct H0. exists (trm_merge x e2); eauto.
    + right. destruct H0.
      exists (trm_merge x e2). eapply step_merge_l; eauto.
Qed.