(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 9 *)

Require Import Frap.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu)
 * Ben Sherman (sherman@csail.mit.edu)
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

Set Implicit Arguments.

(** Data Abstraction via Contextual Equivalence *)

(* Here's a typical student reaction to the content on type systems from a
 * course like this one:
 *   "Yeah, it's good to prove that programs don't crash, but it's so much more
 *   exciting to prove that programs actually return correct answers, and we've
 *   seen plenty of techniques for that already (and will see more in the rest
 *   of the course).  Can we get this type-system stuff over with so we can move
 *   on to the _important_ stuff?"
 *
 * However, it turns out that type systems are very handy for formalizing a very
 * thorough kind of correctness condition for code libraries!  In particular,
 * let's return to _abstract data types_, which we first studied in Pset 4,
 * where we define a formal _interface_ for a data structure and prove that some
 * _implementation_ satisfies the interface.  Recall that Pset 4 asked you to
 * prove a selection of algebraic laws for some implementation.  But how do we
 * know that we picked the right set of laws?  What if we could show that the
 * laws were somehow _complete_ for the interface, prescribing _all possible
 * behaviors_ of the abstract data type?
 *
 * The concept of _contextual equivalence_ formalizes that idea in a general
 * way.  Say we have a simple _reference implementation_ of an abstract data
 * type, and we also have a more fancy, optimized implementation.  Consider all
 * possible _client code_ that imports a library for this data structure.  It
 * doesn't known which of the two it will be linked with; it must work for both.
 * The two libraries are _contextually equivalent_ if no client code can tell
 * them apart, so, say, the client code computes the same answer regardless.
 *
 * It is crucial to formalize the library interface with a type, so that we can
 * constraint which client programs are valid.  That's exactly what we do in
 * this pset, in addition to introducing a method for proving contextual
 * equivalence. *)

(** * Language syntax, semantics, and typing *)

(* Here's our base language, which only uses features familiar from the last
 * pset and class examples. *)

Inductive exp  :=
(* First, the basic STLC ingredients *)
| Var (x : var)
| Abs (x : var) (e1 : exp)
| App (e1 e2 : exp)
(* Constants and basic arithmetic *)
| Const (n : nat)
| Add (e1 e2 : exp)
(* And pairs; they're less general than tuples in the previous problem set. *)
| Pair (e1 e2 : exp)
| Fst (e : exp)
| Snd (e : exp).

Inductive value : exp -> Prop :=
| VAbs : forall x e1, value (Abs x e1)
| VConst : forall n, value (Const n)
| VPair : forall e1 e2, value e1 -> value e2 -> value (Pair e1 e2).

Hint Constructors value.
Hint Extern 1 (value _) => constructor.

(* Syntax of types *)
Inductive type :=
| Nat
| Fun (dom ran : type)
| Prod (t1 t2 : type)
(* We have a new type, called [AbsT], representing the abstract type.  When
 * implementing a certain data structure, we don't want to expose how it is
 * implemented by giving actual types of the implementation.  Instead, we just
 * claim that the implementation satisfies an abstract type.  Clients use it
 * without knowing the actual implementation, while the implementer should check
 * the type without any abstraction. *)
| AbsT.

(* Fancy notations *)
Coercion Var : var >-> exp.
Notation "\ x , e" := (Abs x e) (at level 51).
Infix "@" := App (at level 49, left associativity).
Coercion Const : nat >-> exp.
Infix "^+^" := Add (at level 50).
Notation "@( e1 , e2 )" := (Pair e1 e2) (at level 51).

Infix "-->" := Fun (at level 60, right associativity).
Notation "t1 ^*^ t2" := (Prod t1 t2) (at level 61).

(** A target ADT: simple counters *)
(* We want to prove that two simple counter implementations are
 * _contextually equivalent_, using a logical relation.  Below we can see two
 * implementations: [counter_impl1] is just using a single number to count.
 * Note that the counter exposes two distinct methods for incrementing its
 * value.  They should do the same work from the perspective of the external
 * world.  [counter_impl2] makes each increment method increment a different
 * private number, storing the two numbers within a pair. *)

Definition counter_type : type :=
  (AbsT ^*^ (* The internal counter value is abstracted; clients cannot use this
             * value.  In Java terms, think of this type part as a private
             * field. *)
  (AbsT --> Nat ^*^  (* Method to get the actual counter value *)
  (AbsT --> AbsT ^*^ (* Method to increase the counter value *)
   AbsT --> AbsT))). (* Second method to increase the counter value *)

(* Here's the simple reference implementation. *)
Definition counter_val1 := Const 0.
Definition counter_get1 := \"x", "x".
Definition counter_inc11 := \"x", "x" ^+^ 1.
Definition counter_inc21 := \"x", "x" ^+^ 1.
Definition counter_impl1 :=
  @(counter_val1, @(counter_get1, @(counter_inc11, counter_inc21))).

(* And here's the more convoluted two-counter version. *)
Definition counter_val2 := @(0, 0).
Definition counter_get2 := \"xy", (Fst "xy") ^+^ (Snd "xy").
Definition counter_inc12 := \"xy", @( (Fst "xy") ^+^ 1, Snd "xy" ).
Definition counter_inc22 := \"xy", @( Fst "xy", (Snd "xy") ^+^ 1 ).
Definition counter_impl2 :=
  @(counter_val2, @(counter_get2, @(counter_inc12, counter_inc22))).

(* Intuitively, client code can't distinguish these two versions, if it doesn't
 * know how the abstract type is implemented.  In this pset, we will work up to
 * proving that property for this example, in the process developing formal
 * machinery also applicable to many related examples.  (And all of this
 * generalizes to fancier languages with more expressive typing, though the
 * details are out of scope for the assignment.) *)

(* Some routine definitions again! They should should now be very familiar, so
 * it's safe for you to skim through quickly. But it is recommended to pay
 * attention to the typing rules, since now there is a new concept with
 * _abstract types_. *)

Fixpoint subst (e1 : exp) (x : var) (e2 : exp) : exp :=
  match e2 with
  | Var y => if y ==v x then e1 else Var y
  | Abs y e => Abs y (if y ==v x then e else subst e1 x e)
  | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
  | Const n => Const n
  | Add e1' e2' => Add (subst e1 x e1') (subst e1 x e2')
  | Pair e1' e2' => Pair (subst e1 x e1') (subst e1 x e2')
  | Fst e => Fst (subst e1 x e)
  | Snd e => Snd (subst e1 x e)
  end.

(* We use a big-step semantics for this problem set. *)
Inductive eval : exp -> exp -> Prop :=
| BigAbs : forall x e,
    eval (Abs x e) (Abs x e)
| BigApp : forall e1 x e1' e2 v2 v,
    eval e1 (Abs x e1') ->
    eval e2 v2 ->
    eval (subst v2 x e1') v ->
    eval (App e1 e2) v
| BigConst : forall n,
    eval (Const n) (Const n)
| BigAdd : forall e1 e2 n1 n2,
    eval e1 (Const n1) ->
    eval e2 (Const n2) ->
    eval (Add e1 e2) (Const (n1 + n2))
| BigPair : forall e1 e2 v1 v2,
    eval e1 v1 ->
    eval e2 v2 ->
    eval (Pair e1 e2) (Pair v1 v2)
| BigFst : forall e v1 v2,
    eval e (Pair v1 v2) ->
    eval (Fst e) v1
| BigSnd : forall e v1 v2,
    eval e (Pair v1 v2) ->
    eval (Snd e) v2.

Hint Constructors eval.

(* Here is an expression-typing relation with a single abstract type.  Clients
 * use [hasty] with the first argument as [None], where the actual type is not
 * exposed.  On the contrary, the implementation side uses [hasty] with the
 * first argument as [Some abst], where [abst] is the actual type used to
 * implement the data structure. *)
Inductive hasty : option type -> fmap var type -> exp -> type -> Prop :=
| HtVar : forall abs G x t,
    G $? x = Some t ->
    hasty abs G (Var x) t

(* Now there are two typing rules for [Abs]. The first one is as usual, but
 * requires argument type not equal to [AbsT]. It is for ensuring that [G]
 * always stores the actual type information, not the abstract one. *)
| HtAbs : forall abs G x e1 t1 t2,
    hasty abs (G $+ (x, t1)) e1 t2 ->
    t1 <> AbsT ->
    hasty abs G (Abs x e1) (Fun t1 t2)
(* The second typing rule for [Abs] is for the case when the argument has an
 * abstract type [AbsT]. In this case, we store the actual type by referring to
 * [Some abst]. *)
| HtAbsAbs : forall abst G x e1 t2,
    hasty (Some abst) (G $+ (x, abst)) e1 t2 ->
    hasty (Some abst) G (Abs x e1) (Fun AbsT t2)

(* Then the next few rules are standard, with [abs] threaded through. *)
| HtApp : forall abs G e1 e2 t1 t2,
    hasty abs G e1 (Fun t1 t2) ->
    hasty abs G e2 t1 ->
    hasty abs G (App e1 e2) t2
| HtConst : forall abs G n,
    hasty abs G (Const n) Nat
| HtAdd : forall abs G e1 e2,
    hasty abs G e1 Nat ->
    hasty abs G e2 Nat ->
    hasty abs G (Add e1 e2) Nat
| HtPair : forall abs G e1 e2 t1 t2,
    hasty abs G e1 t1 ->
    hasty abs G e2 t2 ->
    hasty abs G (Pair e1 e2) (Prod t1 t2)
| HtFst : forall abs G e t1 t2,
    hasty abs G e (Prod t1 t2) ->
    hasty abs G (Fst e) t1
| HtSnd : forall abs G e t1 t2,
    hasty abs G e (Prod t1 t2) ->
    hasty abs G (Snd e) t2

(* Finally, one more rule for the abstract type.  [AbsT] can be instantiated to
 * the actual type only if the actual type is provided, meaning this typing
 * rule is for the implementer. *)
| HtAbsT1 : forall abst G e,
    hasty (Some abst) G e abst ->
    hasty (Some abst) G e AbsT.

Hint Constructors hasty.

(** * Logical relation *)

(* How can we prove that two expressions are contextually equivalent?  That is,
 * how can we show that no well-typed client program could tell them apart?
 * Reasoning explicitly about every possible client program would be a lot of
 * work!  Instead, here's a fun idea from the literature, _logical relations_,
 * that gives a straightforward condition where we avoid reasoning about client
 * programs explicitly.  The key distinguishing property of logical relations is
 * that they are defined by recursion on type structure, helping explain why use
 * of a type system is so critical to the approach. *)

Section LogicalRel.
  Variables (abst1 abst2 : type)
            (value_rel_abs: exp -> exp -> Prop).
  (* The relation is parameterized over two different implementation types for
   * the abstract type, along with a primitive relation for saying when two
   * "private field" values for the two sides should be considered to represent
   * the same abstract value. *)

  (* This relation says when two expressions are equivalent at some type.  It is
   * parameterized on the relation to use to compare two *values* at a type. *)
  Definition exp_rel' (v_rel: type -> exp -> exp -> Prop)
             (t: type) (e1 e2: exp): Prop :=
    (* First, the two expressions really have the claimed type, in the
     * corresponding implementations of the abstract type. *)
    hasty (Some abst1) $0 e1 t /\ hasty (Some abst2) $0 e2 t /\

    (* Then, both evaluate to values that are themselves related. *)
    exists v1 v2, eval e1 v1 /\ eval e2 v2 /\
                  v_rel t v1 v2.

  (* Now we go methodically through the types, explaining what equivalence means
   * for each one. *)
  Fixpoint value_rel (t: type) (e1 e2: exp) : Prop :=
    match t with
    | Nat =>
      (* An easy case: numbers are equivalent when equal. *)
      match e1, e2 with
      | Const n1, Const n2 => n1 = n2
      | _, _ => False
      end

    | Prod t1 t2 =>
      (* Another pretty easy case: equivalent pairs have equivalent
       * components. *)
      match e1, e2 with
      | Pair v11 v12, Pair v21 v22 =>
        value_rel t1 v11 v21 /\ value_rel t2 v12 v22
      | _, _ => False
      end

    | AbsT =>
      (* The abstract type picks up whatever [value_rel_abs] relation we
       * chose, additionally requiring that the two expressions are
       * well-typed. *)
      hasty (Some abst1) $0 e1 AbsT /\
      hasty (Some abst2) $0 e2 AbsT /\
      value_rel_abs e1 e2

    | Fun t' t'' =>
      (* Now the signature case of logical relations: "the two functions map
       * equivalent inputs to equivalent outputs." *)
      match e1, e2 with
      | Abs x1 e1', Abs x2 e2' =>
        hasty (Some abst1) $0 e1 t /\ hasty (Some abst2) $0 e2 t /\
        forall v1 v2, (* <-- These are the two equivalent inputs! *)
          hasty (Some abst1) $0 v1 t' -> hasty (Some abst2) $0 v2 t' ->
          value_rel t' v1 v2 (* ...and this hypothesis says so. *) ->
          exp_rel' value_rel t'' (subst v1 x1 e1') (subst v2 x2 e2')
                   (* These substitution results are the equivalent outputs. *)
      | _, _ => False
      end
    end.

  Definition exp_rel := exp_rel' value_rel.

  (* We also need to argue for equivalence of terms with free variables.
   * This relation formalizes it in terms of typing contexts [G].
   * Basically it says: "two expressions with free variables are equivalent iff
   * we get equivalent expressions by substituting equivalent values for all the
   * free variables." *)
  Definition g_rel (G: fmap var type) (g1 g2: fmap var exp) : Prop :=
    forall x,
      (* Any variable in [G] is mapped to equivalent values. *)
      (forall t,
          G $? x = Some t ->
          exists v1 v2, g1 $? x = Some v1 /\ g2 $? x = Some v2 /\ value_rel t v1 v2) /\

      (* Any variable _not_ in [G] is mapped to nothing. *)
      (G $? x = None -> g1 $? x = None /\ g2 $? x = None).

  (* Here we define substitution for several variables at once. *)
  Fixpoint substs (g : fmap var exp) (e : exp) : exp :=
    match e with
    | Var y =>
      match g $? y with
      | Some v => v
      | _ => Var y
      end
    | Abs y e' => Abs y (substs (g $- y) e')
    | App e' e'' => App (substs g e') (substs g e'')
    | Const n => Const n
    | Add e' e'' => Add (substs g e') (substs g e'')
    | Pair e' e'' => Pair (substs g e') (substs g e'')
    | Fst e' => Fst (substs g e')
    | Snd e' => Snd (substs g e')
    end.

  (* Finally, the most general logical relation, for expressions that are
   * allowed to contain free variables *)
  Definition logical_rel (G: fmap var type) (e1 e2: exp) (t: type) :=
    hasty (Some abst1) G e1 t /\ hasty (Some abst2) G e2 t /\
    forall g1 g2,
      g_rel G g1 g2 ->
      exp_rel t (substs g1 e1) (substs g2 e2).
End LogicalRel.

(** * Returning to the example of counters *)

(* Let's demonstrate this machinery by proving that our two counter
 * implementations inhabit the appropriate logical relation.  We'll use this
 * relation to capture when the "private fields" on the two sides are
 * equivalent. *)
Inductive value_rel_counters : exp -> exp -> Prop :=
| Vrc : forall c inc dec,
    c = inc + dec ->
    value_rel_counters c (@(inc, dec)).

Hint Constructors value_rel_counters.

Hint Extern 1 (_ $? _ = Some _) => simplify; reflexivity.

(* And here's how we prove the relation. *)
Theorem counter_impls_related:
  value_rel Nat (Nat ^*^ Nat) value_rel_counters
            counter_type counter_impl1 counter_impl2.
Proof.
  (* We unfold some symbols and reveal a type-specialized notion of
   * equivalence! *)
  simplify.
  (* Here we see a giant conjunction. Most of the conjuncts are
   * typing requirements, which are easy to discharge either with [eauto]
   * or by applying constructors. *)
  propositional; eauto 15;
    try solve[apply HtAbsAbs; eauto 10]; try solve[repeat constructor].
  (* The three remaining conjuncts are conditions on the three methods of
   * the counter.
   *)
  - (* First is the "get" method.  We have that the two sides have equivalent
     * private-field values, and we must show that the two "get" methods will
     * therefore return equivalent results. *)
    invert H4. constructor. constructor. eauto 10.
    split.  eauto 10.
    do 2 eexists. split.
    repeat constructor. split.
    repeat econstructor.
    constructor.
  - (* Next is the "inc1" method. *)
    invert H4. constructor. constructor. eauto 10.
    split.  eauto 10.
    do 2 eexists. split.
    repeat constructor. split.
    repeat econstructor.
    constructor. eauto 10.
    split. eauto 10. constructor. linear_arithmetic.
  - (* Finally, the "inc2" method. *)
    invert H4. constructor. constructor. eauto 10.
    split.  eauto 10.
    do 2 eexists. split.
    repeat constructor. split.
    repeat econstructor.
    constructor. eauto 10.
    split. eauto 10. constructor. linear_arithmetic.
Qed.

(* Believe it or not, that condition implies contextual equivalence of the two
 * implementations... but we'll need to spend the rest of the pset proving it.
 * ;-)  We should at least prove a more general theorem that applies to many
 * other abstract data types, too. *)

Module Type S.
  (* We ask you to prove the "fundamental property" of the logical relation. It
   * seems very weak (every value is related to itself?  sounds obvious,
   * right?), but it's actually strong enough to prove the contextual equality.
   * According to the definition of [logical_rel], [G] can be regarded as a
   * "placeholder" to substitute two values in the logical relation, where the
   * values may differ! *)
  Axiom logical_rel_fundamental:
    forall abst1 abst2 (value_rel_abs: exp -> exp -> Prop),
      (forall v1 v2, value_rel_abs v1 v2 -> value v1 /\ value v2) ->
      abst1 <> AbsT ->
      abst2 <> AbsT ->
      forall e G t,
        hasty None G e t ->
        logical_rel abst1 abst2 value_rel_abs G e e t.

  (* The following corollary should be quite easy to prove, using
   * [logical_rel_fundamental]. *)
  Axiom counter_impls_equiv:
    forall x e,
      hasty None ($0 $+ (x, counter_type)) e Nat ->
      exists n : nat,
        eval (subst counter_impl1 x e) n /\ eval (subst counter_impl2 x e) n.
End S.

(** We provide some lemmas which may help you prove the theorems. *)

Lemma value_eval : forall v, value v -> eval v v.
Proof.
  induct 1; eauto.
Qed.

Hint Resolve value_eval.

Lemma eval_value : forall e v, eval e v -> value v.
Proof.
  induct 1; eauto.
  - invert IHeval; eauto.
  - invert IHeval; eauto.
Qed.

Hint Resolve eval_value.

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

(* [adds] is a binary operation for [fmap]s, doing a merge between two maps
 * where the second map takes priority for a common key. It should be useful
 * for merging two type environments.
 *)
Section Adds.

  Definition adds {A B} (m1 m2: fmap A B) :=
    merge (fun v1 v2 => match v2 with
                        | Some _ => v2
                        | _ => v1
                        end) m1 m2.

  Lemma adds_empty1:
    forall {B} (m: fmap var B), adds $0 m = m.
  Proof.
    intros; unfold adds.
    rewrite merge_empty1; auto.
    intros; cases x; auto.
  Qed.

  Lemma adds_empty2:
    forall {B} (m: fmap var B), adds m $0 = m.
  Proof.
    intros; unfold adds.
    rewrite merge_empty2; auto.
  Qed.

  Lemma adds_add:
    forall {B} (m1 m2: fmap var B) x v,
      adds m1 m2 $+ (x, v) = adds m1 (m2 $+ (x, v)).
  Proof.
    intros; apply fmap_ext; intros.
    cases (x ==v k); subst; simplify.
    - unfold adds; rewrite lookup_merge; simplify; auto.
    - unfold adds; rewrite lookup_merge; simplify; auto.
  Qed.

  Lemma adds_add2:
    forall {B} (m: fmap var B) x v,
      adds ($0 $+ (x, v)) (m $- x) = m $+ (x, v).
  Proof.
    intros; apply fmap_ext; intros.
    cases (x ==v k); subst; simplify.
    - unfold adds; rewrite lookup_merge; simplify; auto.
    - unfold adds; rewrite lookup_merge; simplify.
      cases (m $? k); equality.
  Qed.

  Lemma adds_remove:
    forall {B} (m1 m2: fmap var B) x v,
      adds (m1 $+ (x, v)) (m2 $- x) = adds m1 (m2 $+ (x, v)).
  Proof.
    intros; apply fmap_ext; intros.
    unfold adds; rewrite 2! lookup_merge.
    cases (x ==v k); subst; simplify; auto.
  Qed.

End Adds.

(* Some facts about [hasty] *)
Section HasTyFacts.

  Lemma hasty_Nat_value:
    forall abst G e,
      hasty abst G e Nat ->
      value e ->
      exists n, e = Const n.
  Proof.
    induct 1; simplify; eauto;
      try match goal with
          | [H: value _ |- _] => invert H
          end.
  Qed.

  (* Note that a different type [t1'] is used when the type information is
   * stored.  It's due to the type instantiation that [hasty] does. *)
  Lemma hasty_Fun_value:
    forall abst G e t1 t2,
      hasty abst G e (Fun t1 t2) ->
      value e ->
      exists x1 t1' e2,
        e = Abs x1 e2 /\ hasty abst (G $+ (x1, t1')) e2 t2.
  Proof.
    induct 1; simplify; eauto;
      try match goal with
          | [H: value _ |- _] => invert H
          end.
  Qed.

  Lemma hasty_Prod_value:
    forall abst G e t1 t2,
      hasty abst G e (Prod t1 t2) ->
      value e ->
      exists e1 e2,
        e = @(e1, e2) /\ hasty abst G e1 t1 /\ hasty abst G e2 t2.
  Proof.
    induct 1; simplify; eauto;
      try match goal with
          | [H: value _ |- _] => invert H
          end.
  Qed.

  Lemma hasty_weakening:
    forall abst G e t,
      hasty abst G e t ->
      forall G',
        (forall x t, G $? x = Some t -> G' $? x = Some t) ->
        hasty abst G' e t.
  Proof.
    induct 1; simplify; eauto.
    - constructor; auto.
      apply IHhasty; intros.
      cases (x ==v x0); simplify; propositional; auto.
    - apply HtAbsAbs.
      apply IHhasty; intros.
      cases (x ==v x0); simplify; propositional; auto.
  Qed.

  Corollary hasty_weakening_empty:
    forall abst e t,
      hasty abst $0 e t ->
      forall G,
        hasty abst G e t.
  Proof.
    intros; apply hasty_weakening with (G:= $0); auto.
  Qed.

  Lemma hasty_weakening_abst:
    forall G e t, hasty None G e t ->
                  forall abst,
                    hasty (Some abst) G e t.
  Proof.
    induct 1; simplify; eauto.
  Qed.

  (* Closedness of expressions.
   * [e] is closed iff it does not have any free variables.
   * We define a more general version that uses argument [vs] to express which
   * free variables are allowed. *)
  Fixpoint closed (e: exp) (vs: set var) :=
    match e with
    | Var x => x \in vs
    | Abs x e' => closed e' (vs \cup {x})
    | App e' e'' => closed e' vs /\ closed e'' vs
    | Const _ => True
    | Add e' e'' => closed e' vs /\ closed e'' vs
    | Pair e' e'' => closed e' vs /\ closed e'' vs
    | Fst e' => closed e' vs
    | Snd e' => closed e' vs
    end.

  (* When [e] is type-checked, then it's closed. *)
  Lemma hasty_closed:
    forall abst G e t,
      hasty abst G e t ->
      closed e (dom G).
  Proof.
    induct 1; simplify; eauto.
    eapply lookup_Some_dom; eauto.
  Qed.

  (* When [e] is closed, then it's not affected by substitutions. *)
  Lemma closed_subst:
    forall e (G: fmap var type),
      closed e (dom G) ->
      forall v x,
        G $? x = None ->
        subst v x e = e.
  Proof.
    induct e; simplify; try (propositional; f_equal; eauto; fail).
    - cases (x ==v x0); subst; propositional.
      apply lookup_None_dom in H0; propositional.
    - cases (x ==v x0); subst; propositional.
      f_equal.
      apply IHe with (G:= G $+ (x, Nat)); simplify; auto.
  Qed.

  (* Here's a special case of the above, for truly closed expressions. *)
  Lemma value_hasty_closed:
    forall e abst t,
      hasty abst $0 e t ->
      forall x v,
        subst v x e = e.
  Proof.
    intros.
    apply closed_subst with (G := $0).
    - eapply hasty_closed. eauto.
    - simplify; equality.
  Qed.

End HasTyFacts.

Hint Immediate hasty_weakening hasty_weakening_abst.

(* Some facts about [substs] *)
Section Substs.

  Lemma substs_empty:
    forall e, substs $0 e = e.
  Proof.
    induct e; simplify; eauto; try (f_equal; auto).
    replace (empty string exp $- x) with (empty string exp); auto.
    clear IHe; apply fmap_ext; simplify.
    cases (x ==v k); subst; simplify; equality.
  Qed.

  Lemma substs_single:
    forall x v e,
      substs ($0 $+ (x, v)) e = subst v x e.
  Proof.
    induct e; simplify; eauto; try (f_equal; auto).
    - cases (x ==v x0); subst; simplify.
      + cases (x0 ==v x0); equality.
      + cases (x0 ==v x); equality.
    - cases (x ==v x0); subst; simplify.
      + cases (x0 ==v x0); try equality.
        rewrite <-substs_empty.
        f_equal.
        apply fmap_ext; simplify.
        cases (x0 ==v k); subst; simplify; equality.
      + cases (x0 ==v x); subst; simplify; try equality.
        replace ($0 $+ (x, v) $- x0) with ($0 $+ (x, v)); auto.
        apply fmap_ext; simplify.
        cases (x ==v k); subst; simplify; try equality.
        cases (x0 ==v k); subst; simplify; try equality.
  Qed.

End Substs.

(* Some facts about logical relations *)
Section LogicalRelFacts.
  Variables (abst1 abst2 : type)
            (value_rel_abs: exp -> exp -> Prop).
  Hypotheses (Hvr: forall v1 v2, value_rel_abs v1 v2 -> value v1 /\ value v2).

  Lemma value_rel_value:
    forall t v1 v2,
      value_rel abst1 abst2 value_rel_abs t v1 v2 ->
      value v1 /\ value v2.
  Proof.
    induct t.
    - simplify.
      cases v1; try invert H.
      cases v2; try invert H.
      auto.
    - simplify.
      cases v1; try invert H.
      cases v2; try invert H.
      auto.
    - simplify.
      cases v1; try invert H.
      cases v2; try invert H.
      specialize (IHt1 _ _ H0).
      specialize (IHt2 _ _ H1).
      first_order; constructor; auto.
    - first_order.
  Qed.

  Lemma value_rel_hasty:
    forall t v1 v2,
      value_rel abst1 abst2 value_rel_abs t v1 v2 ->
      hasty (Some abst1) $0 v1 t /\ hasty (Some abst2) $0 v2 t.
  Proof.
    induct t; simplify; auto.
    - cases v1; try invert H.
      cases v2; try invert H.
      auto.
    - cases v1; try invert H.
      cases v2; try invert H.
      propositional; subst.
    - cases v1; try invert H.
      cases v2; try invert H.
      specialize (IHt1 _ _ H0).
      specialize (IHt2 _ _ H1).
      first_order; constructor; auto.
    - first_order.
  Qed.

  Lemma value_rel_implies_exp_rel:
    forall t v1 v2,
      value_rel abst1 abst2 value_rel_abs t v1 v2 ->
      exp_rel abst1 abst2 value_rel_abs t v1 v2.
  Proof.
    unfold exp_rel, exp_rel'; intros; repeat split.
    - apply value_rel_hasty in H; propositional.
    - apply value_rel_hasty in H; propositional.
    - exists v1, v2; repeat split; auto.
      + apply value_rel_value in H.
        apply value_eval; propositional.
      + apply value_rel_value in H.
        apply value_eval; propositional.
  Qed.

End LogicalRelFacts.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(* File created for Coq V5.10.14b, Oct 1995 *)
(* Classical tactics for proving disjunctions by Julien Narboux, Jul 2005 *)
(* Inferred proof-irrelevance and eq_rect_eq added by Hugo Herbelin, Mar 2006 *)

(** Classical Propositional Logic *)

Require Import ClassicalFacts.

Hint Unfold not: core.

Axiom classic : forall P:Prop, P \/ ~ P.

Lemma NNPP : forall p:Prop, ~ ~ p -> p.
Proof.
unfold not; intros; elim (classic p); auto.
intro NP; elim (H NP).
Qed.

(** Peirce's law states [forall P Q:Prop, ((P -> Q) -> P) -> P].
    Thanks to [forall P, False -> P], it is equivalent to the
    following form *)

Lemma Peirce : forall P:Prop, ((P -> False) -> P) -> P.
Proof.
intros P H; destruct (classic P); auto.
Qed.

Lemma not_imply_elim : forall P Q:Prop, ~ (P -> Q) -> P.
Proof.
intros; apply NNPP; red.
intro; apply H; intro; absurd P; trivial.
Qed.

Lemma not_imply_elim2 : forall P Q:Prop, ~ (P -> Q) -> ~ Q.
Proof. (* Intuitionistic *)
tauto.
Qed.

Lemma imply_to_or : forall P Q:Prop, (P -> Q) -> ~ P \/ Q.
Proof.
intros; elim (classic P); auto.
Qed.

Lemma imply_to_and : forall P Q:Prop, ~ (P -> Q) -> P /\ ~ Q.
Proof.
intros; split.
apply not_imply_elim with Q; trivial.
apply not_imply_elim2 with P; trivial.
Qed.

Lemma or_to_imply : forall P Q:Prop, ~ P \/ Q -> P -> Q.
Proof. (* Intuitionistic *)
tauto.
Qed.

Lemma not_and_or : forall P Q:Prop, ~ (P /\ Q) -> ~ P \/ ~ Q.
Proof.
intros; elim (classic P); auto.
Qed.

Lemma or_not_and : forall P Q:Prop, ~ P \/ ~ Q -> ~ (P /\ Q).
Proof.
simple induction 1; red; simple induction 2; auto.
Qed.

Lemma not_or_and : forall P Q:Prop, ~ (P \/ Q) -> ~ P /\ ~ Q.
Proof. (* Intuitionistic *)
tauto.
Qed.

Lemma and_not_or : forall P Q:Prop, ~ P /\ ~ Q -> ~ (P \/ Q).
Proof. (* Intuitionistic *)
tauto.
Qed.

Lemma imply_and_or : forall P Q:Prop, (P -> Q) -> P \/ Q -> Q.
Proof. (* Intuitionistic *)
tauto.
Qed.

Lemma imply_and_or2 : forall P Q R:Prop, (P -> Q) -> P \/ R -> Q \/ R.
Proof. (* Intuitionistic *)
tauto.
Qed.

Lemma proof_irrelevance : forall (P:Prop) (p1 p2:P), p1 = p2.
Proof proof_irrelevance_cci classic.

(* classical_left  transforms |- A \/ B into ~B |- A *)
(* classical_right transforms |- A \/ B into ~A |- B *)

Ltac classical_right := match goal with
|- ?X \/ _ => (elim (classic X);intro;[left;trivial|right])
end.

Ltac classical_left := match goal with
|- _ \/ ?X => (elim (classic X);intro;[right;trivial|left])
end.

Require Export EqdepFacts.

Module Eq_rect_eq.

Lemma eq_rect_eq :
  forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
Proof.
intros; rewrite proof_irrelevance with (p1:=h) (p2:=eq_refl p); reflexivity.
Qed.

End Eq_rect_eq.

Module EqdepTheory := EqdepTheory(Eq_rect_eq).
Export EqdepTheory.


Require Import Iron.Data.List.Base.
Require Import Iron.Tactics.

(* Select elements that match a given predicate. *)
Fixpoint filter {A: Type} (f: A -> bool) (xx: list A) : list A :=
  match xx with
  | nil     => nil
  | x :: xs
  => if f x then x :: (filter f xs)
            else filter f xs
  end.

(********************************************************************)
(* Lemmas: filter *)

(* The length of a filtered list is the same or smaller than
   the original list. *)
Lemma filter_length
 :  forall A (xx: list A) (f: A -> bool)
 ,  length xx >= length (filter f xx).
Proof.
 intros. induction xx; auto.
 simpl. breaka (f a). simpl. omega.
Qed.


Require Export Tactics.
Require Export mathcomp.ssreflect.all_ssreflect.
Require Export Coq.Program.Program.
Set Implicit Arguments.

(* Program things *)
Set Shrink Obligations.
Unset Transparent Obligations.
Set Hide Obligations.
Obligation Tactic := program_simpl; try (simpl in *; solve by inversion || auto).

Notation fin n := {i : nat | i < n}.
Definition mk_fin {n : nat} (ix : nat) (p : ix < n) : fin n := exist _ ix p.
Arguments mk_fin {n} ix p.

Hint Constructors le.
Hint Resolve le_pred le_S_n le_0_n le_n_S.

Hint Rewrite ltn0.

Hint Extern 1 =>
  match goal with
      | [ _ : ?n < 0 |- _ ] => exfalso; eapply ltn0; eassumption
  end.

Lemma nofin0 : fin 0 -> False.
  destruct 1; eauto. Qed.

Ltac nof0 :=
  match goal with
    | [ f : fin 0 |- _ ] => exfalso; apply (nofin0 f)
  end.

Ltac destr_fins :=
  repeat match goal with [ f : fin _ |- _ ] => destruct f end.

Hint Resolve nofin0.

Program Definition fze {n} : fin (S n) := mk_fin 0 _.
Program Definition fsu {n} (f : fin n) : fin (S n) := mk_fin (S f) _.
Program Definition flsu {n} (f : fin n) : fin (S n) := mk_fin f _.

Lemma sig_flsu n (f : fin n) : ` (flsu f) = ` f.
Proof. destruct f; reflexivity. Qed.

Hint Rewrite sig_flsu.

Ltac Snle_0 :=
  match goal with
    | [ H : S _ <= 0 |- _ ] => exfalso; inversion H
  end.

Ltac Snlt_1 :=
  match goal with
    | [ H : S _ < 1 |- _ ] => exfalso; inversion H; Snle_0
  end.

Local Hint Extern 1 => destr_fins.
Local Hint Extern 1 => Snle_0.
Local Hint Extern 1 => Snlt_1.

Hint Rewrite leq_subLR leq_subr leq_sub2r ltnS.
Hint Rewrite subnKC subSS.
Program Definition finvert {n} (f : fin n) : fin n := mk_fin (n - S f) _.
Next Obligation. destruct n; [auto|clear H]; autorewrite with core in *; auto. Qed.

Lemma finv_eq n : forall (f : fin  n.+1), ` f + ` (finvert f) = n.
Proof. destruct f; simpl; autorewrite with core in *; auto. Qed.


Require Import FSets.
Require Import SetoidList.
Require Import Sumbool_dec.
Require Import OrderedTypeEquiv.

Module makeForall (FS:FSetInterface.S).

  Module FSEquivM := OT_Equiv FS.
  Definition FSEquiv := FSEquivM.Equiv.
  Module ElemEquivM := OT_Equiv FS.E.
  Definition ElemEquiv := ElemEquivM.Equiv.

  Theorem for_all_prop_1: forall P s (SB: forall e, {P e}+{~ P e}), compat_P FS.E.eq P ->
    FS.For_all P s -> FS.for_all (fun e => true_bool_of_sumbool (SB e)) s = true.
  Proof.
    intros.
    apply FS.for_all_1.
    apply compat_P_compat_bool_true_bool_of_sumbool; try exact ElemEquiv; auto.
    unfold FS.For_all in *.
    intros.

    unfold true_bool_of_sumbool.
    apply proof_r_true_bool_of_sumbool.
    auto.
  Qed.

  Theorem for_all_prop_2: forall P s (SB: forall e, {P e}+{~ P e}), compat_P FS.E.eq P ->
    FS.for_all (fun e => true_bool_of_sumbool (SB e)) s = true -> FS.For_all P s.
  Proof.
    intros.
    unfold true_bool_of_sumbool in *.
    apply FS.for_all_2 in H0; try apply compat_P_compat_bool_true_bool_of_sumbool; try exact ElemEquiv; auto.
    unfold FS.For_all in *.
    intros.
    generalize (H0 x H1); intros H2.
    case (SB x); intros Hsb; auto.
    rewrite (proof_l_true_bool_of_sumbool _ (SB x) Hsb) in *.
    discriminate.
  Qed.

  Theorem For_all_dec: forall P s (SB: forall e, {P e}+{~ P e}), compat_P FS.E.eq P ->
    {FS.For_all P s} + {~ FS.For_all P s}.
  Proof.
    intros.
    case (bool_dec (FS.for_all (fun e : FS.elt => true_bool_of_sumbool (SB e)) s) true); intros Hforall;
      [left; apply for_all_prop_2 with (SB:=SB); auto
        |right; intro; apply Hforall; apply for_all_prop_1 with (SB:=SB); auto].
  Qed.

  Theorem forall_iff_dec: forall P s (SB: forall e, {P e}+{~ P e}), compat_P FS.E.eq P ->
    {forall e, FS.In e s <-> P e} + {~ (forall e, FS.In e s <-> P e)}.
  Proof.
    intros.
    (* I should be able to use For_all_dec to build a sumbool with P := In e s <-> P' e from a sumbool P'.  *)
    (* Then the rest should be easy *)
    case (bool_dec (FS.for_all (fun e : FS.elt => true_bool_of_sumbool (SB e)) s) true); intros Hforall;
      [left; apply for_all_prop_2 with (SB:=SB); auto
        |right; intro; apply Hforall; apply for_all_prop_1 with (SB:=SB); auto].
  Qed.

End makeForall.


Require Import Program.Equality.
Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import Lia.
Require Import Language.

(* ---------------------------------------------------------------------- *)
(* Definitions of size for types and terms. Use them when we want to do induction by size. *)
Fixpoint size_typ (A1 : typ) {struct A1} : nat :=
  match A1 with
    | int => 1
    | top => 1
    | arr A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | and A2 B1 => 1 + (size_typ A2) + (size_typ B1)
    | rcd l1 A2 => 1 + (size_typ A2)
  end.

Fixpoint size_exp (e1 : exp) {struct e1} : nat :=
  match e1 with
    | unit => 1
    | lit i1 => 1
    | ctx => 1
    | merge e2 e3 => 1 + (size_exp e2) + (size_exp e3)
    | ann e2 A1 => 1 + (size_exp e2) + (size_typ A1)
    | rec l1 e2 => 1 + (size_exp e2)
    | proj e2 l1 => 1 + (size_exp e2)
    | lam fm e2 => 1 + (size_exp e2)
    | app e2 e3 => 1 + (size_exp e2) + (size_exp e3)
    | box e2 e3 => 1 + (size_exp e2) + (size_exp e3)
    | fixp A e2 => 1 + (size_typ A) + (size_exp e2)
  end.

Ltac indTypSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : typ |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
    | intros ].

Ltac indExpSize s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : exp |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => inverts H end
    | intros ].

(* Some simple lemmas for size *)
Lemma size_typ_min_me: forall A,
  1 <= size_typ A.
Proof.
  intros. inductions A; eauto.
  - simpl. lia.
  - simpl. lia.
  - simpl. lia.
Qed.

Lemma and_decrease_left: forall B C,
  size_typ B < size_typ (and B C).
Proof with (pose proof (size_typ_min_me); simpl in *; try lia).
  intros. simpl. lia.
Qed.

Lemma and_decrease_right: forall B C,
  size_typ C < size_typ (and B C).
Proof with (pose proof (size_typ_min_me); simpl in *; try lia).
  intros. simpl. lia.
Qed.

Lemma arrow_decrease_left: forall B C,
  size_typ B < size_typ (arr B C).
Proof with (pose proof (size_typ_min_me); simpl in *; try lia).
  intros. simpl. lia.
Qed.

Lemma arrow_decrease_right: forall B C,
  size_typ C < size_typ (arr B C).
Proof with (pose proof (size_typ_min_me); simpl in *; try lia).
  intros. simpl. lia.
Qed.

(* a simple tactic for reasoning about sizes *)
Ltac elia :=
  try solve [pose proof (size_typ_min_me);
             simpl in *;
             try lia].

(* multi-step *)
Definition relation (X:Type) := X -> X -> Prop.

Section Star.

Variable A : Type.
Variable R : relation A.

Inductive star: relation A:=
  | star_refl: forall a,
      star a a
  | star_step: forall a b c,
      R a b -> star b c -> star a c.

Lemma star_one:
  forall a b, R a b -> star a b.
Proof.
  eauto using star.
Qed.

Lemma star_trans:
  forall a b, star a b -> forall c, star b c -> star a c.
Proof.
  induction 1; eauto using star.
Qed.

Hypothesis R_functional:
  forall a b c, R a b -> R a c -> b = c.

Lemma star_star_inv:
  forall a b, star a b -> forall c, star a c -> star b c \/ star c b.
Proof.
  induction 1; intros.
  - auto.
  - inversion H1; subst.
    + right. eauto using star.
    + assert (b = b0) by (eapply R_functional; eauto). subst b0.
      apply IHstar; auto.
Qed.

Definition irred a : Prop := forall b, ~(R a b).

Lemma finseq_unique:
  forall a b b',
    star a b -> irred b ->
    star a b' -> irred b' ->
    b = b'.
Proof.
  intros. destruct (star_star_inv _ _ H _ H1).
  - inversion H3; subst. auto. elim (H0 _ H4).
  - inversion H3; subst. auto. elim (H2 _ H4).
Qed.

End Star.

#[export]
Hint Constructors star : core.

#[export]
Hint Resolve star_trans star_one : core.

(* Regularity of relations *)
Lemma step_not_value: forall v,
  value v -> forall v',
  irred exp (step v') v.
Proof.
  introv.
  unfold irred.
  induction v; introv H; inverts* H; unfold not; intros; try inverts* H.
Qed.

Lemma step_env : forall v e e', step v e e' -> value v.
  induction 1; eauto.
  - dependent destruction IHstep; eauto.
Defined.


Require Import Axiom_Extensionality.
Require Import Axiom_Skolem.
Require Import Func.

Definition Func_app (a b:Type) (f:a ==> b) (x:a) : b :=
    proj1_sig (skolem (rel f x) (Func_exists f x) (Func_unique f x)).

Arguments Func_app {a} {b} _ _.

Definition fromFunc (a b:Type) (f:a ==> b) : a -> b :=
    fun (x:a) => Func_app f x.

Arguments fromFunc {a} {b} _ _.

Lemma fromFunc_correct : forall (a b:Type) (f:a ==> b) (x:a),
    rel f x (fromFunc f x).
Proof.
    intros a b [r fTot fFunc] x. simpl. unfold fromFunc, Func_app.
    remember (skolem (rel (func r fTot fFunc) x)
              (Func_exists (func r fTot fFunc) x)
              (Func_unique (func r fTot fFunc) x)) as sk eqn:H.
    exact (proj2_sig sk).
Qed.

Lemma fromFunc_eval : forall (a b:Type) (f:a ==> b) (x:a) (y:b),
    y = fromFunc f x <-> rel f x y.
Proof.
    intros a b f x y. split.
    - intros H. rewrite H. apply fromFunc_correct.
    - intros H. apply (Func_unique f x).
        + exact H.
        + apply fromFunc_correct.
Qed.

Lemma fromTo : forall (a b:Type) (f:a -> b), fromFunc (toFunc f) = f.
Proof.
    intros a b f. apply extensionality. intros x.
    apply (Func_unique (toFunc f) x).
    rewrite relToFunc. apply fromFunc_eval.
    - simpl. unfold toRel. reflexivity.
    - simpl. unfold toRel. reflexivity.
Qed.

Lemma toFrom : forall (a b:Type) (f:a ==> b), toFunc (fromFunc f) = f.
Proof.
    intros a b f. apply eqFunc. apply eqRelation. intros x y. split.
    - intros H. rewrite relToFunc in H. symmetry in H.
        apply fromFunc_eval. exact H.
    - intros H. rewrite relToFunc. symmetry. apply fromFunc_eval. exact H.
Qed.

Corollary toFuncEmbedding : forall (a b:Type) (f g:a -> b),
    toFunc f = toFunc g -> f = g.
Proof.
    intros a b f g H. assert (fromFunc (toFunc f) = fromFunc (toFunc g)) as H'.
    { rewrite H. reflexivity. }
    rewrite fromTo in H'. rewrite fromTo in H'. exact H'.
Qed.

Corollary fromFuncEmbedding : forall (a b:Type) (f g:a ==> b),
    fromFunc f = fromFunc g -> f = g.
Proof.
    intros a b f g H. assert (toFunc (fromFunc f) = toFunc (fromFunc g)) as H'.
    { rewrite H. reflexivity. }
    rewrite toFrom in H'. rewrite toFrom in H'. exact H'.
Qed.

Lemma composeFunc_correct : forall (a b c:Type) (f:a ==> b) (g:b ==> c) (x:a),
    fromFunc (f ; g) x = fromFunc g (fromFunc f x).
Proof.
    intros a b c f g x. symmetry. apply fromFunc_eval.
    destruct f as [r fTot fFunc] eqn:Hf. destruct g as [s gTot gFunc] eqn:Hg.
    simpl. rewrite <- Hf. rewrite <- Hg. exists (fromFunc f x). split.
    - assert (r = rel f) as Hr. { rewrite Hf. reflexivity. }
        rewrite Hr. apply fromFunc_correct.
    - remember (fromFunc f x) as y eqn:Hy.
        assert (s = rel g) as Hs. { rewrite Hg. reflexivity. }
        rewrite Hs. apply fromFunc_correct.
Qed.

Lemma fromFunc_compose : forall (a b c:Type) (f:a ==> b) (g:b ==> c),
    fromFunc (f ; g) = fromFunc g @ fromFunc f.
Proof.
    intros a b c f g. apply extensionality. intros x. unfold compose.
    apply composeFunc_correct.
Qed.

Lemma fromFunc_id : forall (a:Type), fromFunc (idFunc a) = id.
Proof.
    intros a. apply extensionality. intros x. symmetry.
    apply fromFunc_eval. simpl. unfold idRel. unfold id. reflexivity.
Qed.


(** This library describes a [Term], which is the general form of an
    expression considered in Eder's paper. This is essentially a tree
    of function applications and variable instances. *)

Require Import Bool.
Require Import Lists.List.
Require Import Logic.Eqdep_dec.
Require Import PeanoNat.
Require Vectors.Fin.
Require Vectors.VectorDef.

Require Import Top.FinSet.FinMod.
Require Import Top.FinSet.ListMod.

Require Import Top.Terms.VecUtils.

Set Implicit Arguments.

Definition vec := VectorDef.t.

Lemma orb_elim_left a b c
  : orb a b = orb a c -> orb a (eqb b c) = true.
Proof.
  destruct a, b, c; auto.
Qed.

Lemma orb_intro_left a b c
  : is_true a \/ b = c -> orb a b = orb a c.
Proof.
  destruct a; unfold is_true; simpl; auto.
  intro H; destruct H as [ eqFT | ]; auto.
  contradiction (diff_false_true eqFT).
Qed.

(** * Terms

    When talking about terms, we fix types [V] and [F]. Elements of
    [V] are variable names and elements of [F] should be thought of as
    functions or operators. There is also an arity function, [a],
    which gives the arity of each function.

    Rather than pass these types around separately, we pack them into
    a module (in a similar style to that used in mathcomp). *)

Module Lmodule.
  Structure type : Type := Pack { V : Type; F : Type; a : F -> nat }.
End Lmodule.

Notation lType := Lmodule.type.
Notation LType := Lmodule.Pack.

Section Term.
  Variable L : lType.

  Local Definition V := Lmodule.V L.
  Local Definition F := Lmodule.F L.
  Local Definition a := Lmodule.a L.

  Inductive Term : Type :=
  | varTerm : V -> Term
  | funTerm (f : F) (ts : vec Term (a f)) : Term.

  Lemma varTerm_injective v w
    : varTerm v = varTerm w -> v = w.
  Proof.
    injection 1; auto.
  Qed.

  (** When defining a function on terms, you need an induction
      rule. We use vectors to represent the rose tree structure of a
      term and Coq's automatic induction rule isn't strong enough, so
      we define a better one here. *)

  Section Term_ind'.
    Variable P : Term -> Prop.
    Hypothesis vH : forall v, P (varTerm v).
    Hypothesis fH : forall f, forall ts, vec_all P ts -> P (funTerm f ts).

    Fixpoint Term_ind' (t : Term) : P t :=
      match t with
      | varTerm v => vH v
      | funTerm f ts =>
        fH f ts
           (VectorDef.t_rect Term (fun _ v => vec_all P v)
                             (vec_all_nil P)
                             (fun t n v => vec_all_cons _ _ (Term_ind' t))
                             (a f) ts)
      end.
  End Term_ind'.

  (** We also define a structural recursion rule for [Term]
      objects. This is a little more finicky because it lets us
      recurse over the structure of the function vectors as well as
      the term itself.

      The [varH] hypothesis says that [P] holds for all terms that are
      just a variable. The [funH] hypothesis says that if we know [Q]
      holds for a vector of terms (of the correct length), then [P]
      will hold when we use them to make arguments for a function
      term. To show that [Q] ever holds, we then need to know that it
      holds for the empty vector ([qnilH]) and that it holds for a
      cons if [P] holds for the item we're adding. *)

  Section Term_rect'.
    Variable P : Term -> Type.
    Variable Q : forall n, vec Term n -> Type.

    Variable varH : forall v, P (varTerm v).
    Variable funH : forall f, forall ts, Q ts -> P (funTerm f ts).
    Variable qnilH : Q (VectorDef.nil _).
    Variable qconsH : forall t n (ts : vec Term n),
        P t -> Q ts -> Q (VectorDef.cons _ t _ ts).

    Fixpoint Term_rect' (t : Term) : P t :=
      match t with
      | varTerm v => varH v
      | funTerm f ts =>
        funH f
             (VectorDef.t_rect Term Q qnilH
                               (fun t' n ts' => qconsH (Term_rect' t'))
                               (a f) ts)
      end.
  End Term_rect'.

  Lemma varTerm_ne_funTerm v f ts : varTerm v <> funTerm f ts.
  Proof.
    intros eqH. inversion eqH.
  Qed.

  (** The [decTerm] fixpoint shows that equality in [Term] is
      decidable if it is decidable for the functions and variable
      names. *)

  Section DecTerm.
    Hypothesis decV : forall x y : V, {x = y} + {x <> y}.
    Hypothesis decF : forall x y : F, {x = y} + {x <> y}.

    Fixpoint decTerm (x y : Term) : {x = y} + {x <> y}.
      refine (match x, y with
              | varTerm v, varTerm v' => _
              | varTerm v, funTerm f ts => _
              | funTerm f ts, varTerm v => _
              | funTerm f ts, funTerm f' ts' => _
              end
             ).
      - destruct (decV v v') as [ eqH | neH ].
        + exact (left (f_equal varTerm eqH)).
        + enough (H: varTerm v <> varTerm v');
            try (exact (right H)).
          injection; tauto.
      - exact (right (@varTerm_ne_funTerm v f ts)).
      - exact (right (not_eq_sym (@varTerm_ne_funTerm v f ts))).
      - destruct (decF f f') as [ feqH | fneH ].
        + revert ts'. rewrite <- feqH. clear feqH; intro ts'.
          destruct (dec_vec decTerm ts ts') as [ tseqH | tsneH ].
          * apply left. apply f_equal. exact tseqH.
          * apply right. intro funH. inversion funH.
            exact (tsneH (inj_pair2_eq_dec
                            F decF (fun f => vec Term (a f)) f ts ts' H0)).
        + enough (H: funTerm f ts <> funTerm f' ts');
            try (exact (right H)).
          injection; tauto.
    Qed.
  End DecTerm.

  (** If variables have decidable equality then [mod_elt varTerm] is
      decidable. However, [mod_elt varTerm] asks that two things are not equal
      (the substitution should map an element to something different from
      [varTerm]). This isn't great, because if it's false you have a double
      negation, which you can't get rid of without the law of excluded middle.
      Thus we unfold the double negation in the second part of the sumbool. *)

  Lemma dec_mod_elt_varTerm
        (decV : forall v w : V, {v = w} + {v <> w})
        (sigma : V -> Term)
        (v : V)
    : {mod_elt varTerm sigma v} + {sigma v = varTerm v}.
  Proof.
    unfold mod_elt.
    destruct (sigma v) as [ w | ]; clear sigma.
    - destruct (decV v w) as [ eqH | neH ].
      + right; rewrite eqH; auto.
      + left; injection; auto.
    - left; discriminate.
  Qed.

  (** * Heights

      When trying to show things about terms, it's sometimes useful to
      know their heights. This is the maximum nesting depth of
      function terms. In particular, a substitution can never decrease
      the height of a term.
   *)

  Fixpoint term_height (t : Term) : nat :=
    match t with
    | varTerm v => O
    | funTerm f ts => S (vec_max_at term_height ts)
    end.

  (** Of course, if you know a term has height zero (which we'll call
      a "zterm"), you also know that it's a variable. We define a
      function to extract that variable. *)

  Definition zterm_var (t : Term) : term_height t = 0 -> V :=
    match t with
    | varTerm v => fun _ => v
    | funTerm f ts =>
      fun htH =>
        False_rect _ (PeanoNat.Nat.neq_succ_0 (vec_max_at term_height ts) htH)
    end.

  Lemma zterm_var_irrel (t : Term) (htH0 htH1 : term_height t = 0)
    : zterm_var t htH0 = zterm_var t htH1.
  Proof.
    destruct t; auto.
    contradiction (PeanoNat.Nat.neq_succ_0 (vec_max_at term_height ts)).
  Qed.

  Lemma varTerm_zterm_var t H : varTerm (zterm_var t H) = t.
  Proof.
    destruct t; auto.
    contradiction (PeanoNat.Nat.neq_succ_0 _ H).
  Qed.

  Lemma zterm_var_inj t t' (H : term_height t = 0) (H' : term_height t' = 0)
    : zterm_var t H = zterm_var t' H' -> t = t'.
  Proof.
    destruct t; [ | contradiction (PeanoNat.Nat.neq_succ_0 _ H) ].
    destruct t'; [ | contradiction (PeanoNat.Nat.neq_succ_0 _ H') ].
    simpl; intro; f_equal; auto.
  Qed.

End Term.

Arguments zterm_var {L t} htH.
Arguments zterm_var_irrel {L t} htH0 htH1.
Arguments varTerm_zterm_var {L t} H.
Arguments zterm_var_inj {L t t'} H H'.


Require Import init.

Require Import rat.
Require Import set.
Require Import nat.
Require Import order_minmax.

Require Export dedekind_real_base.
Require Import dedekind_real_order.

(* begin hide *)
Open Scope real_scope.
(* end hide *)
Definition real_plus_base a b := λ x, ∃ r s, a r ∧ b s ∧ x = r + s.
Infix "⊕" := real_plus_base : real_scope.

Theorem real_plus_dedekind : ∀ (a b : real), dedekind_cut ([a|] ⊕ [b|]).
Proof.
    intros [a a_cut] [b b_cut]; cbn.
    split.
    2: split.
    3: split.
    -   intros contr.
        pose proof (land a_cut) as a_n.
        pose proof (land b_cut) as b_n.
        apply all_neq in a_n as [x nax], b_n as [y nby].
        assert (all (x + y)) as eq by exact true.
        rewrite <- contr in eq.
        destruct eq as [r [s [ar [bs eq]]]].
        pose proof (dedekind_lt _ a_cut _ _ ar nax) as ltq1.
        pose proof (dedekind_lt _ b_cut _ _ bs nby) as ltq2.
        pose proof (lt_lrplus ltq1 ltq2) as ltq.
        symmetry in eq.
        destruct ltq; contradiction.
    -   apply empty_neq.
        pose proof (land (rand a_cut)) as a_n.
        pose proof (land (rand b_cut)) as b_n.
        apply empty_neq in a_n as [r ar].
        apply empty_neq in b_n as [s bs].
        exists (r + s), r, s.
        repeat split; trivial.
    -   intros l u [r [s [ar [bs eq]]]] lu.
        apply lt_rplus with u in lu.
        rewrite <- (mult_rid u) in lu at 2 3.
        rewrite <- ldist in lu.
        apply lt_rmult_pos with (div 2) in lu.
        2: apply div_pos; exact two_pos.
        rewrite mult_rrinv in lu by apply two_pos.
        rewrite eq in lu at 2.
        pose proof lu as eq2; rename lu into eq1.
        apply lt_plus_rrmove in eq1.
        apply lt_plus_rlmove in eq2.
        pose proof (land (rand (rand a_cut)) _ _ ar eq1) as al.
        pose proof (land (rand (rand b_cut)) _ _ bs eq2) as bl.
        exists ((l + u) * div 2 + -s), (-r + (l + u) * div 2).
        repeat split; try assumption.
        plus_bring_left ((l + u) * div 2).
        rewrite plus_assoc.
        rewrite plus_half.
        rewrite <- neg_plus.
        rewrite (plus_comm s).
        rewrite <- eq.
        rewrite plus_rrinv.
        reflexivity.
    -   intros l [r [s [ar [bs eq]]]].
        pose proof (rand (rand (rand a_cut)) _ ar) as [r' [ar' r_lt]].
        pose proof (rand (rand (rand b_cut)) _ bs) as [s' [bs' s_lt]].
        exists (r' + s').
        split.
        +   exists r', s'.
            repeat split; trivial.
        +   rewrite eq.
            apply lt_lrplus; assumption.
Qed.

Global Instance real_plus : Plus real := {
    plus a b := [_|real_plus_dedekind a b]
}.

Lemma real_plus_comm_ : ∀ a b, a + b = b + a.
Proof.
    intros [a a_cut] [b b_cut].
    unfold plus; cbn.
    apply set_type_eq; cbn.
    apply predicate_ext.
    intros x; split.
    -   intros [r [s [ar [bs eq]]]].
        exists s, r.
        rewrite plus_comm.
        repeat split; assumption.
    -   intros [r [s [br [as_ eq]]]].
        exists s, r.
        rewrite plus_comm.
        repeat split; assumption.
Qed.
Global Instance real_plus_comm : PlusComm real := {
    plus_comm := real_plus_comm_
}.

Lemma real_plus_assoc_ : ∀ a b c, a + (b + c) = (a + b) + c.
Proof.
    intros [a a_cut] [b b_cut] [c c_cut].
    unfold plus; cbn.
    apply set_type_eq; cbn.
    apply predicate_ext.
    intros x; split.
    -   intros [r1 [s1 [ar1 [[r2 [s2 [br2 [cs2 eq1]]]] eq2]]]].
        exists (r1 + r2), s2.
        split.
        +   exists r1, r2.
            repeat split; trivial.
        +   split; try exact cs2.
            rewrite eq2, eq1.
            apply plus_assoc.
    -   intros [r1 [s1 [[r2 [s2 [ar2 [bs2 eq1]]]] [cs1 eq2]]]].
        exists r2, (s1 + s2).
        split; try exact ar2.
        split.
        +   exists s2, s1.
            repeat split; try assumption.
            apply plus_comm.
        +   rewrite eq2, eq1.
            rewrite (plus_comm s1 s2).
            rewrite plus_assoc.
            reflexivity.
Qed.
Global Instance real_plus_assoc : PlusAssoc real := {
    plus_assoc := real_plus_assoc_
}.

Global Instance real_zero : Zero real := {
    zero := rat_to_real 0
}.

Lemma real_plus_lid_ : ∀ a, 0 + a = a.
Proof.
    intros [a a_cut].
    unfold plus, zero; cbn.
    unfold rat_to_real_base; cbn.
    apply set_type_eq; cbn.
    apply predicate_ext; intros x; split.
    -   intros [r [s [r_pos [as_ eq]]]].
        apply (land (rand (rand a_cut)) _ s as_).
        rewrite eq.
        rewrite <- (plus_lid s) at 2.
        apply lt_rplus.
        exact r_pos.
    -   intros ax.
        pose proof (rand (rand (rand a_cut)) x ax) as [y [ay ltq]].
        exists (x + -y), y.
        split.
        +   apply lt_plus_anb_0_a_b.
            exact ltq.
        +   split; try exact ay.
            rewrite plus_rlinv.
            reflexivity.
Qed.
Global Instance real_plus_lid : PlusLid real := {
    plus_lid := real_plus_lid_;
}.

Definition real_neg_base a := λ p, ∃ r, 0 < r ∧ ¬(a (-p + -r)).
Notation "⊖ a" := (real_neg_base a) : real_scope.

Lemma real_neg_dedekind : ∀ a : real, dedekind_cut (⊖ [a|]).
Proof.
    intros [a a_cut]; cbn.
    split.
    2: split.
    3: split.
    -   intro contr.
        pose proof (land (rand a_cut)) as x_ex.
        apply empty_neq in x_ex as [x ax].
        assert (all (-x)) as x_in by exact true.
        rewrite <- contr in x_in.
        destruct x_in as [r [r_pos nin]].
        rewrite neg_neg in nin.
        apply nin.
        apply (land (rand (rand a_cut)) _ _ ax).
        rewrite <- (plus_rid x) at 2.
        apply lt_lplus.
        apply pos_neg2.
        exact r_pos.
    -   apply empty_neq.
        pose proof (land a_cut) as x_ex.
        apply all_neq in x_ex.
        destruct x_ex as [x nax].
        exists (-x + -(1)), 1.
        split; try exact one_pos.
        rewrite neg_plus, neg_neg.
        rewrite plus_rlinv.
        exact nax.
    -   intros l u [r [r_pos na]] ltq.
        exists (u + r + -l).
        split.
        +   apply lt_plus_0_anb_b_a in ltq.
            pose proof (lt_lrplus r_pos ltq) as ltq2.
            rewrite plus_lid, plus_assoc in ltq2.
            rewrite (plus_comm r) in ltq2.
            exact ltq2.
        +   do 2 rewrite neg_plus.
            rewrite plus_comm.
            rewrite plus_rlinv.
            exact na.
    -   intros l [r [r_pos na]].
        assert (0 < r * div 2) as r2_pos.
        {
            apply lt_mult_rcancel_pos with 2; try apply two_pos.
            rewrite mult_lanni.
            rewrite mult_rlinv by apply two_pos.
            exact r_pos.
        }
        exists (l + r * div 2).
        split.
        +   exists (r * div 2).
            split; try exact r2_pos.
            rewrite neg_plus.
            rewrite <- plus_assoc, <- neg_plus.
            rewrite plus_half.
            exact na.
        +   rewrite <- (plus_rid l) at 1.
            apply lt_lplus.
            exact r2_pos.
Qed.

Global Instance real_neg : Neg real := {
    neg a := [_|real_neg_dedekind a]
}.
Lemma real_plus_linv_pos : ∀ a, 0 < a → -a + a = 0.
Proof.
    intros [a a_cut] a_pos'.
    assert (∀ x, x ≤ 0 → a x) as a_pos.
    {
        destruct a_pos' as [a_pos a_neq].
        unfold zero in a_pos; cbn in a_pos.
        unfold rat_to_real, le in a_pos; equiv_simpl in a_pos.
        unfold rat_to_real_base in a_pos.
        unfold zero in a_neq; cbn in a_neq.
        unfold rat_to_real in a_neq; equiv_simpl in a_neq.
        unfold rat_to_real_base in a_neq.
        intros x x_leq.
        classic_case (x = 0) as [xz|xnz].
        -   subst.
            classic_contradiction contr.
            apply a_neq.
            apply set_type_eq; cbn.
            apply antisym; try exact a_pos.
            intros x ax.
            exact (dedekind_lt _ a_cut _ _ ax contr).
        -   apply a_pos.
            split; assumption.
    }
    clear a_pos'.
    unfold plus, neg, zero; cbn.
    unfold rat_to_real; cbn.
    apply set_type_eq; cbn.
    unfold rat_to_real_base.
    apply predicate_ext; intros x; split.
    -   intros [r [s [[t [t_pos na]] [as_ eq]]]].
        pose proof (dedekind_lt _ a_cut _ _ as_ na) as ltq.
        apply lt_plus_rlmove in ltq.
        rewrite neg_neg in ltq.
        rewrite <- eq in ltq.
        apply pos_neg2 in t_pos.
        exact (trans ltq t_pos).
    -   intros x_neg.
        pose proof (land a_cut) as u_ex.
        apply all_neq in u_ex.
        destruct u_ex as [u nau].
        assert (0 < u) as u_pos.
        {
            classic_contradiction contr.
            rewrite nlt_le in contr.
            specialize (a_pos _ contr).
            contradiction.
        }
        apply neg_pos2 in x_neg.
        pose proof (archimedean u (-x) u_pos x_neg) as [n' eq].
        pose (S m := ¬a (m × -x)).
        assert (∃ m, S m) as S_ex.
        {
            exists n'.
            intros contr.
            pose proof (land (rand (rand a_cut)) _ _ contr eq).
            contradiction.
        }
        pose proof (well_ordered S S_ex) as [n [Sn n_least]].
        nat_destruct n.
        +   unfold zero, S in Sn; cbn in Sn.
            specialize (a_pos 0 (refl _)).
            contradiction.
        +   classic_case (∃ u, u < nat_suc n × -x ∧ ¬a u) as [not_cusp|cusp].
            *   exists (nat_suc n × x), (n × -x).
                repeat split.
                --  destruct not_cusp as [u' [u'_lt nau']].
                    apply lt_plus_0_anb_b_a in u'_lt.
                    exists (nat_suc n × -x + -u').
                    split; try exact u'_lt.
                    rewrite nat_mult_rneg.
                    rewrite neg_plus.
                    rewrite plus_lrinv.
                    rewrite neg_neg.
                    exact nau'.
                --  classic_contradiction contr.
                    specialize (n_least _ contr).
                    pose proof (le_lt_trans n_least (nat_lt_suc _)) as [C0 C1].
                    contradiction.
                --  cbn.
                    rewrite <- nat_mult_rneg.
                    rewrite plus_rrinv.
                    reflexivity.
            *   exists (nat_suc n × x + x * div 2), (n × -x + -x * div 2).
                repeat split.
                --  apply lt_rmult_pos with (div 2) in x_neg.
                    2: apply div_pos; exact two_pos.
                    rewrite mult_lanni in x_neg.
                    exists (-x * div 2).
                    split; try exact x_neg.
                    rewrite neg_plus.
                    rewrite nat_mult_rneg.
                    rewrite mult_lneg.
                    rewrite plus_rrinv.
                    exact Sn.
                --  rewrite not_ex in cusp.
                    specialize (cusp (n × -x + -x * div 2)).
                    rewrite not_and, not_not, nlt_le in cusp.
                    destruct cusp as [cusp|cusp]; [>|exact cusp].
                    rewrite nat_mult_suc in cusp.
                    rewrite plus_comm in cusp.
                    apply le_plus_lcancel in cusp.
                    apply le_neg in cusp.
                    rewrite mult_lneg in cusp.
                    do 2 rewrite neg_neg in cusp.
                    apply le_rmult_pos with 2 in cusp.
                    2: apply two_pos.
                    rewrite mult_rlinv in cusp by apply two_pos.
                    rewrite ldist in cusp.
                    rewrite mult_rid in cusp.
                    rewrite <- (plus_rid x) in cusp at 1.
                    apply le_plus_lcancel in cusp.
                    apply pos_neg in cusp.
                    destruct (le_lt_trans cusp x_neg); contradiction.
                --  rewrite nat_mult_suc.
                    rewrite <- nat_mult_rneg.
                    rewrite <- plus_assoc.
                    rewrite (plus_comm (-(n × x))).
                    rewrite mult_lneg.
                    rewrite plus_lrinv.
                    rewrite plus_rrinv.
                    reflexivity.
Qed.

Lemma real_plus_linv_ : ∀ a, -a + a = 0.
Proof.
    intros a.
    destruct (trichotomy 0 a) as [[a_pos|a_z]|a_neg].
    -   apply real_plus_linv_pos.
        exact a_pos.
    -   subst.
        rewrite plus_rid.
        unfold neg, zero; cbn.
        unfold rat_to_real; cbn.
        apply set_type_eq; cbn.
        unfold rat_to_real_base.
        apply predicate_ext; intros x; split.
        +   intros [r [r_pos eq]].
            rewrite nlt_le in eq.
            rewrite le_plus_0_anb_b_a in eq.
            pose proof (lt_le_trans r_pos eq) as ltq.
            apply pos_neg2 in ltq.
            rewrite neg_neg in ltq.
            exact ltq.
        +   intros x_neg.
            exists (-x).
            split.
            *   exact (land (neg_pos2 _) x_neg).
            *   intro contr.
                rewrite plus_rinv in contr.
                destruct contr; contradiction.
    -   assert (0 < -a) as a_pos.
        {
            classic_contradiction leq.
            rewrite nlt_le in leq.
            destruct a_neg as [ltq neq].
            destruct a as [a a_cut].
            unfold le, neg, zero in *; cbn in *.
            unfold rat_to_real, rat_to_real_base in *.
            apply neq; clear neq.
            apply set_type_eq; cbn.
            apply predicate_ext; intros x; split.
            -   apply ltq.
            -   intros x_neg.
                unfold subset in leq.
                classic_contradiction contr.
                assert (∃ r, 0 < r ∧ ¬a (-0 + -r)) as r_ex.
                {
                    exists (-x).
                    split.
                    -   exact (land (neg_pos2 _) x_neg).
                    -   rewrite neg_neg, neg_zero, plus_lid.
                        exact contr.
                }
                specialize (leq 0 r_ex) as [C0 C1]; contradiction.
        }
        assert (a = --a) as eq.
        {
            destruct a as [a a_cut].
            destruct a_neg as [leq neq].
            unfold le, neg, zero in leq; cbn in leq.
            unfold rat_to_real_base in leq.
            unfold neg; cbn.
            apply set_type_eq; cbn.
            apply predicate_ext; intros x; split.
            -   intros ax.
                pose proof ax as x_neg.
                apply leq in x_neg.
                assert (∃ u, u < 0 ∧ ¬a u) as [u [u_neg nau]].
                {
                    classic_contradiction contr.
                    apply neq.
                    unfold zero; cbn.
                    apply set_type_eq; cbn.
                    apply antisym; try exact leq.
                    intros y y_lt.
                    rewrite not_ex in contr.
                    specialize (contr y).
                    rewrite not_and_impl, not_not in contr.
                    apply contr.
                    exact y_lt.
                }
                pose proof (rand (rand (rand a_cut)) _ ax) as [x' [ax' lt]].
                exists (x' + -x).
                split.
                +   apply lt_plus_0_anb_b_a.
                    exact lt.
                +   intros [r [r_pos eq]].
                    apply eq.
                    do 2 rewrite neg_plus.
                    rewrite (plus_comm (-x')).
                    rewrite neg_plus.
                    rewrite plus_lrinv.
                    rewrite neg_neg.
                    apply (land (rand (rand a_cut)) _ _ ax').
                    rewrite <- (plus_rid x') at 2.
                    apply lt_lplus.
                    apply pos_neg2.
                    exact r_pos.
            -   intros [r [r_pos n]].
                classic_contradiction ax.
                apply n.
                exists r.
                split; try exact r_pos.
                rewrite neg_plus.
                rewrite plus_rlinv, neg_neg.
                exact ax.
        }
        rewrite eq at 2.
        rewrite plus_comm.
        apply real_plus_linv_pos.
        exact a_pos.
Qed.
Global Instance real_plus_linv : PlusLinv real := {
    plus_linv := real_plus_linv_;
}.

Lemma real_le_lplus_ : ∀ a b c, a ≤ b → c + a ≤ c + b.
Proof.
    intros [a a_cut] [b b_cut] [c c_cut].
    unfold le, plus; cbn.
    intros ab x [r [s [cr [as_ eq]]]].
    exists r, s.
    apply ab in as_.
    repeat split; assumption.
Qed.
Global Instance real_le_lplus : OrderLplus real := {
    le_lplus := real_le_lplus_;
}.
(* begin hide *)
Close Scope real_scope.
(* end hide *)


(*

    _   _    ___    __  __   _____  __        __   ___    ____    _  __    _
   | | | |  / _ \  |  \/  | | ____| \ \      / /  / _ \  |  _ \  | |/ /   / |
   | |_| | | | | | | |\/| | |  _|    \ \ /\ / /  | | | | | |_) | | ' /    | |
   |  _  | | |_| | | |  | | | |___    \ V  V /   | |_| | |  _ <  | . \    | |
   |_| |_|  \___/  |_|  |_| |_____|    \_/\_/     \___/  |_| \_\ |_|\_\   |_|

*)

(*
 * This homework assignment is a tutorial introduction to Coq.
 *
 * Set up Coq as described in README.md. Then step through this file with VSCode
 * (or another IDE for Coq), and complete the problems. Search for "PROBLEM" to
 * be sure you find them all---not all problems correspond to Coq code!
 *
 * Throughout, we include the approximate lines of code (LOC) or number of
 * tactics for each of our solutions to these problems.  These are rough
 * guidelines to help you figure out if you are getting off track.
 *
 * There is no penalty for writing a shorter or longer solution! However, if
 * you find yourself writing a much longer solution, you might save yourself
 * some time by taking a step back and seeing if you can find a simpler way.
 *
 * Every problem on this homework is designed to be conceptually
 * straightforward; the hard part is just getting up to speed on Coq.
 *
 * There are 9 problems worth a total of 50 points.
 *
 * See the bottom of README.md for quite a bit more information, including some
 * advice on how to do this homework, how this homework will be graded, and a
 * list of tactics used in our solution.
 *)

(* --- Setting up Coq --- *)

(*
 * PROBLEM 1 [0 points, ~1 LOC]
 * Set up Coq as described in README.md
 *
 * Once Coq is installed according to directions, you should be able to step
 * through this entire file in your IDE.
 *
 * We will always have a non-problem PROBLEM 1, because Gradescope makes the
 * autograder results "Problem 1" :)
 *
 * You've heard of computer scientists counting from zero, but have you heard of
 * them counting from two?!
 *)

(* infer type arguments *)
Set Implicit Arguments.

(* --- Boolean practice --- *)

(* Here are some definitions about booleans from lecture.  *)

Inductive bool : Type :=
| true : bool
| false : bool.

Definition notb (b : bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

(*
 * PROBLEM 2 [4 points, ~5 LOC]
 * Write a function called `orb` that implements boolean disjunction.
 *
 * Hint: Kinda like `andb`, but different.
 *)
Definition orb (b1 : bool) (b2 : bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

(*
 * Remember that `Compute` just runs programs.
 * We can use it for simple testing.
 *)
Compute orb true true.   (* should be true. *)
Compute orb true false.  (* should be true. *)
Compute orb false true.  (* should be true. *)
Compute orb false false. (* should be false. *)

(*
 * PROBLEM 3 [4 points, ~15 tactics]
 * Prove the following theorem, that `orb` is commutative.
 *
 * Hint: Kinda like `andb_comm` from lecture.
 * Hint: You may need fewer tactics if you use semicolon chains.
 *)
Lemma orb_comm :
  forall b1 b2,
    orb b1 b2 = orb b2 b1.
Proof.
  intro b1. intro b2.
  destruct b1.
  - simpl.
    destruct b2.
    + simpl. reflexivity.
    + simpl. reflexivity.
  - destruct b2.
    + simpl. reflexivity.
    + simpl. reflexivity.
Qed.

(*
 * PROBLEM 4 [4 points, ~7 tactics]
 * Prove the following theorem about `notb`, `orb`, and `andb`.
 *
 * Hint: You may need fewer tactics if you use semicolon chains.
 * Hint: All these proofs start to look the same after a while...
 *)
Lemma notb_andb_is_orb_notb :
  forall b1 b2,
    notb (andb b1 b2) = orb (notb b1) (notb b2).
Proof.
  intro b1. intro b2.
  destruct b1.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

(* --- Natural numbers practice --- *)

(*
 * Here are some more definitions from lecture,
 * this time about natural numbers.
 *)

Inductive nat : Type :=
| O : nat
| S : nat -> nat.

Fixpoint add (n1 : nat) (n2 : nat) : nat :=
  match n1 with
  | O => n2
  | S m1 => S (add m1 n2)
  end.

(*
 * PROBLEM 5 [4 points, ~4 tactics]
 * Prove the following theorem about add.
 *
 * Hint: Do you think you'll need induction? Hmm...
 *)
Lemma add_S_n :
  forall n1 n2,
    add (S n1) n2 = S (add n1 n2).
Proof.
  intro n1. intro n2.
  simpl. reflexivity.
Qed.

(*
 * PROBLEM 6 [8 points, ~1 sentences]
 * Consider the following theorem, superficially similar to the previous one.
 *
 * The problem below asks you to prove it, but before that, describe here
 * whether you expect it to be less difficult than, more difficult than,
 * or about the same difficulty as the previous theorem.
 *
 * Please explain your answer in 1 to 2 sentences, using your mental model
 * for what kinds of things different tactics are good at.
 *
 * Hint: If you don't know, it's okay to try to prove it (the next problem
 *       below), and then come back and explain the outcome.
 *)
Lemma add_n_S :
  forall n1 n2,
    add n1 (S n2) = S (add n1 n2).
Proof.
Abort.
  (*This will be more difficult to prove compared to the previous theorem since the pattern matching in our add function above is done for the first argument n1 and not the second argument n2. So, just simplification and reflexivity won't work here.*)

(*
 * PROBLEM 7 [8 points, ~8 tactics]
 * Now go ahead and prove the theorem from the previous problem
 * (restated below).
 *
 * Hint: You may need fewer tactics than we did if you use semicolon chains.
 *
 * Hint: Do you think you'll need induction? Hmm...
 *)
Lemma add_n_S :
  forall n1 n2,
    add n1 (S n2) = S (add n1 n2).
Proof.
  intro n1. intro n2.
  induction n1 as [| p IHp].
  - simpl. reflexivity.
  - simpl. rewrite IHp. reflexivity.
Qed.

(*
Added this Lemma from the lectures to use in Problem 8 rewrite.
*)
Lemma add_n_O (n: nat) :
    add n O = n.
Proof.
  induction n as [| p IHp].
  - simpl. reflexivity.
  - simpl. rewrite IHp. reflexivity.
Qed.

(*
 * PROBLEM 8 [15 points, ~20 tactics]
 * Prove the following theorem about add.
 *
 * Hint: Proceed by induction.
 *
 * Hint: Don't forget to reuse previously proved Lemmas by using
 *       the `rewrite` tactic.
 *
 * Hint: It's okay to copy-paste lemmas we proved in lecture if you need them.
 *)
Lemma add_comm :
  forall n1 n2,
    add n1 n2 = add n2 n1.
Proof.
  intro n1. intro n2.
  induction n1 as [| p IHp].
  - simpl. rewrite add_n_O. reflexivity.
  - simpl. rewrite IHp. rewrite add_n_S. reflexivity.
Qed.

(*
 * PROBLEM 9 [3 points, ~3 sentences]
 *
 * Please take a moment to let us know how the homework went for you by
 * answering the following three questions:
 *    1. How long did the homework take you?
 *    2. Which parts were most interesting or helpful for you?
 *    3. Which parts were especially frustrating, confusing, or tedious?
 *       What should we do better next time?
 *
 * It's fine if your answers are short if you don't have much to say!
 *)

(* Your feedback here! *)
(*
      1. Roughly 2 hours.
      2. Problem 7 and 8 were the most interesting as well has helpful since it required some reading through Coq documentation and learning new ways of writing proofs.
      3. Nothing in particular felt frustrating or confusing. The directions and expectation were pretty clear.
*)

(*
 * This is the end of Homework 1.  It's never too early to get started on
 * Homework 2!
 *
 * To submit your homework, please follow the instructions at the end of the
 * README.md file in this directory.
 *
 * Please also see the README.md file to read about how we will grade this
 * homework.
 *)


Require Import Grph.Graph.
Require Import Grph.GraphCat.
Require Import Pro.Preorder.
Require Import ProGrphFun.
Require Import Func.Functor.
Require Import Cat.Category.
Require Import Iso.Isomorphism.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Basics.

Inductive has_path (G : Grph) : vert_of G -> vert_of G -> Prop :=
    | refl {a : vert_of G} : has_path G a a
    | item
        {a b : vert_of G}
        (edge : arr_of G)
        (proof : src_of G edge = a /\ tgt_of G edge = b)
            : has_path G a b
    | trans
        {a b c : vert_of G}
        (proof_f : has_path G b c)
        (proof_g : has_path G a b)
            : has_path G a c.

Definition HasPathO (G : Grph) : PrO.
    refine (cons_pro (vert_of G) (has_path G) _).
    split.
        apply refl.
        apply trans.
Defined.

Hint Resolve refl trans item.

Definition HasPathHom (P Q : Grph) (f : GrphHom P Q) : PrOHom (HasPathO P) (HasPathO Q).
    refine (exist _ (vert_fn f) _).
    destruct f.
    intros x y H.
    induction H; simpl in *; auto.
        apply item with (edge := arr_fn edge).
        apply equal_f with (x := edge) in proof_src.
        apply equal_f with (x := edge) in proof_tgt.
        destruct proof.
        split;
            simpl in *;
            [rewrite <- H | rewrite <- H0];
            intuition.

        apply trans with (b := vert_fn b); assumption.
Defined.

Definition HasPath : Functor GrphCat PrOCat.
    refine (cons_functor GrphCat PrOCat HasPathO HasPathHom _ _);
        auto.
Defined.

Definition from_paths_pro_to_original : forall p, PrOHom (HasPathO (PrOGrph p)) p.
    intros p.
    refine (exist _ (fun x => x) _).
    intros x y.
    destruct p as [O M [r t]].
    simpl.
    intro H.
    induction H; simpl in *; auto.
        destruct edge.
        destruct proof as [px py].
        simpl in *.
        subst.
        auto.

        apply t with (b := b); auto.
Defined.

Definition from_original_to_paths_pro (p : PrO) : PrOHom p (HasPathO (PrOGrph p)).
    refine (exist _ (fun x => x) _).
    intros x y.
    destruct p as [O M r t].
    intro H.
    apply item with (edge := cons_proedge _ _ H).
    auto.
Defined.

Theorem all_pro_in_image
    : forall (p : PrO), Isomorphic _ (HasPathO (PrOGrph p)) p.
    intros p.
    exists (from_paths_pro_to_original _).
    exists (from_original_to_paths_pro _).
    split; auto.
Qed.

(**
Theorem all_pro_in_image2
    : forall (p : PrO), HasPathO (PrOGrph p) = p.
    intros p.
    unfold HasPathO.
    unfold PrOGrph.
    destruct p.
    unfold undertype_pro.
    unfold vert_of.
    unfold edge_of.
    unfold ordering.
    unfold undertype_pro.
    pose (u := (has_path (grph (@graph O (PrOEdge O M) pro_src pro_tgt)))).
    fold u.
    unfold vert_of in u.
    assert (u = M).
        unfold u.
        apply functional_extensionality.
        intros x.
        apply functional_extensionality.
        intro y.
        remember (has_path (grph (@graph O (PrOEdge O M) pro_src pro_tgt)) x y) as lhs.

    refine (f_equal4 _ _ _ _ _).
Qed.

Theorem grph_ob_is_pro_ob : forall p, HasPathO (PrOGrph p) = p.
    Hint Unfold HasPathO PrOGrph.
    intros p.
    remember (HasPathO (PrOGrph p)) as lhs.
    remember p as rhs.
    destruct lhs.
    destruct rhs.
    destruct p.
    unfold HasPathO in *.
    simpl in *.
    unfold PrOGrph in *.
    simpl in *.
    inversion Heqrhs.
    subst O0.
    simpl.
    rewrite Heqrhs in Heqlhs.
    unfold grph.
    apply f_equal2.
Qed.

Theorem grph_hom_is_pro_hom (p q : PrO)
    : forall (f : GrphHom (PrOGrph p) (PrOGrph q)),
        f = PrOGrphHom p q (HasPathHom (PrOGrph p) (PrOGrph q) f).
    intro f.
    destruct f as [v a ps pt].

Qed.
**)


Require Export Coq.Unicode.Utf8.
Require Export FProd.

(******************************************************************************)
(* Typing relation.                                                           *)
(******************************************************************************)

Inductive PTyping (Γ: Env) : Pat → Ty → Env → Prop :=
  | P_Var {T} (wfT: wfTy (domainEnv Γ) T) :
      PTyping Γ (pvar T) T (evar empty T)
  | P_Prod {p1 T1 Δ1 p2 T2 Δ2} :
      PTyping Γ p1 T1 Δ1 →
      PTyping (appendEnv Γ Δ1) (weakenPat p2 (domainEnv Δ1))
        (weakenTy T2 (domainEnv Δ1)) Δ2 →
      PTyping Γ (pprod p1 p2) (tprod T1 T2) (appendEnv Δ1 Δ2).

Inductive Typing (Γ: Env) : Tm → Ty → Prop :=
  | T_Var {y T} :
      lookup_evar Γ y T → Typing Γ (var y) T
  | T_Abs {t T1 T2} (wf_T1: wfTy (domainEnv Γ) T1) :
      Typing (evar Γ T1) t T2 →
      Typing Γ (abs T1 t) (tarr T1 T2)
  | T_App {t1 t2 T11 T12} :
      Typing Γ t1 (tarr T11 T12) → Typing Γ t2 T11 →
      Typing Γ (app t1 t2) T12
  | T_Tabs {t T} :
      Typing (etvar Γ) t T →  Typing Γ (tabs t) (tall T)
  | T_Tapp {t1 T12 T2} :
      Typing Γ t1 (tall T12) → wfTy (domainEnv Γ) T2 →
      Typing Γ (tapp t1 T2) (tsubstTy X0 T2 T12)
  | T_Prod {t1 T1 t2 T2} :
      Typing Γ t1 T1 → Typing Γ t2 T2 →
      Typing Γ (prod t1 t2) (tprod T1 T2)
  | T_Let {p t1 t2 T1 T2 Δ} :
      Typing Γ t1 T1 → PTyping Γ p T1 Δ →
      Typing (appendEnv Γ Δ) t2 (weakenTy T2 (domainEnv Δ)) →
      Typing Γ (lett p t1 t2) T2.