(** * Merge:  Merge Sort, With Specification and Proof of Correctness*)

Require Import Le Lt Gt Decidable PeanoNat Recdef.
From Coq Require Import Recdef.  (* needed for [Function] feature *)
From Coq Require Import Strings.String.  (* for manual grading *)
From Coq Require Export Bool.Bool.
From Coq Require Export Arith.Arith.
From Coq Require Export Arith.EqNat.
From Coq Require Export Lia.
From Coq Require Export Lists.List.
Export ListNotations.
From Coq Require Export Permutation.

Notation  "a >=? b" := (Nat.leb b a)
                          (at level 70) : nat_scope.
Notation  "a >? b"  := (Nat.ltb b a)
                         (at level 70) : nat_scope.

Lemma eqb_reflect : forall x y, reflect (x = y) (x =? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.eqb_eq.
Qed.

Lemma ltb_reflect : forall x y, reflect (x < y) (x <? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.ltb_lt.
Qed.

Lemma leb_reflect : forall x y, reflect (x <= y) (x <=? y).
Proof.
  intros x y. apply iff_reflect. symmetry.
  apply Nat.leb_le.
Qed.

Ltac bdestruct X :=
  let H := fresh in let e := fresh "e" in
   evar (e: Prop);
   assert (H: reflect e X); subst e;
    [eauto with bdestruct
    | destruct H as [H|H];
      [ | try first [apply not_lt in H | apply not_le in H]]].

Hint Resolve ltb_reflect leb_reflect eqb_reflect : bdestruct.

Ltac inv H := inversion H; clear H; subst.

Inductive sorted: list nat -> Set :=
| sorted_nil:
    sorted nil
| sorted_1: forall x,
    sorted (x::nil)
| sorted_cons: forall x y l,
   x <= y -> sorted (y::l) -> sorted (x::y::l).
(** Mergesort is a well-known sorting algorithm, normally presented
    as an imperative algorithm on arrays, that has worst-case
    O(n log n) execution time and requires O(n) auxiliary space.

    The basic idea is simple: we divide the data to be sorted into two
    halves, recursively sort each of them, and then
    merge together the (sorted) results from each half:

    [[
    mergesort xs =
      split xs into ys,zs;
      ys' = mergesort ys;
      zs' = mergesort zs;
      return (merge ys' zs')
    ]]

    (As usual, if you are unfamiliar with mergesort see Wikipedia or
    your favorite algorithms textbook.)

    Mergesort on lists works essentially the same way: we split the
    original list into two halves, recursively sort each sublist,
    and then merge the two sublists together again.  The only
    difference, compared to the imperative algorithm, is that splitting
    the list takes O(n) rather than O(1) time; however, that
    does not affect the asymptotic cost, since the merge step already
    takes O(n) anyhow.
*)

(* ================================================================= *)
(** ** Split and its properties *)

(** Let us try to write down the Gallina code for mergesort.
    The first step is to write a splitting function. There are
    several ways to do this, since the exact splitting method does
    not matter as long as the results are (roughly) equal in size.
    For example, if we know the length of the list, we could use that to split
    at the half-way point. But here is an attractive alternative, which simply
    alternates assigning the elements into left and right sublists:
*)

Fixpoint split {X:Type} (l:list X) : (list X * list X) :=
  match l with
  | [] => ([],[])
  | [x] => ([x],[])
  | x1::x2::l' =>
    let (l1,l2) := split l' in
    (x1::l1,x2::l2)
  end.

(** Note: For generality, we made this function polymorphic, since the
    type of the values in the list is irrelevant to the splitting process.

    While this function is straightforward to define, it can be a bit challenging
    to work with.  Let's try to prove the following lemma, which is obviously true:
*)

Lemma split_len_first_try: forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
  induction l; intros.
  - inv H. simpl. lia.
  - destruct l as [| x l'].
    + inv H.
      split; simpl; auto.
    + inv H. destruct (split l') as [l1' l2'] eqn:E. inv H1.
      (* We're stuck! The IH talks about [split (x::l')] but we
         only know aobut [split (a::x::l')]. *)
Abort.

(** The problem here is that the standard induction principle for lists
    requires us to show that the property being proved follows for
    any non-empty list if it holds for the tail of that list.
    What we want here is a "two-step" induction principle, that instead requires
    us to show that the property being proved follows for a list of
    length at least two, if it holds for the tail of the tail of that list.
    Formally:
*)

Definition list_ind2_principle:=
    forall (A : Type) (P : list A -> Prop),
      P [] ->
      (forall (a:A), P [a]) ->
      (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
      forall l : list A, P l.

(** If we assume the correctness of this "non-standard" induction principle,
    our [split_len] proof is easy, using a form of the [induction] tactic
    that lets us specify the induction principle to use:
*)

Lemma split_len': list_ind2_principle ->
    forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
  unfold list_ind2_principle; intro IP.
  induction l using IP; intros.
  - inv H. lia.
  - inv H. simpl; lia.
  - inv H. destruct (split l) as [l1' l2']. inv H1.
    simpl.
    destruct (IHl l1' l2') as [P1 P2]; auto; lia.
Qed.

(** We still need to prove [list_ind2_principle].  There are several
    ways to do this, but one direct way is to write an explicit proof
    term, thus: *)

Definition list_ind2 :
  forall (A : Type) (P : list A -> Prop),
      P [] ->
      (forall (a:A), P [a]) ->
      (forall (a b : A) (l : list A), P l -> P (a :: b :: l)) ->
      forall l : list A, P l :=
  fun (A : Type)
      (P : list A -> Prop)
      (H : P [])
      (H0 : forall a : A, P [a])
      (H1 : forall (a b : A) (l : list A), P l -> P (a :: b :: l))  =>
    fix IH (l : list A) :  P l :=
    match l with
    | [] => H
    | [x] => H0 x
    | x::y::l' => H1 x y l' (IH l')
    end.

(** Here, the [fix] keyword defines a local recursive function [IH]
    of type [forall l:list A, P l], which is returned as the overall value of
    [list_ind2]. As usual, this function must be obviously terminating
    to Coq (which it is because the recursive call is on a sublist [l']
    of the original argument [l]) and the [match] must be exhaustive over
    all possible lists (which it evidently is).
*)

(** With our induction principle in hand, we can finally prove
    [split_len] free and clear:
*)

Lemma split_len: forall {X} (l:list X) (l1 l2: list X),
    split l = (l1,l2) ->
    length l1 <= length l /\
    length l2 <= length l.
Proof.
 apply (@split_len' list_ind2).
Qed.

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

(** Here's another fact about [split] that we will find useful later on.
*)

Lemma split_perm : forall {X:Type} (l l1 l2: list X),
    split l = (l1,l2) -> Permutation l (l1 ++ l2).
Proof.
  induction l as [| x | x1 x2 l1' IHl'] using list_ind2; intros.
  inv H. simpl. auto.
  inv H. simpl. auto.
  inv H.
  destruct (split l1').
  inv H1.
  assert (Permutation l1' (l ++ l0)) .
  apply (IHl' l l0 ) . auto.
  simpl.   econstructor.
  assert (Permutation (x2 :: l1') (x2 :: (l ++ l0))).
  econstructor. auto.
  econstructor. apply H0. clear H0.
  assert (Permutation (x2 :: l ++ l0) (x2 :: l0 ++ l)).
  econstructor.    apply Permutation_app_comm.
  econstructor. apply H0.
  assert ((x2 :: l0 ++ l) = ((x2 :: l0) ++ l )) .
  auto.
  rewrite H1.
  apply Permutation_app_comm.
Qed.

(* ================================================================= *)
(** ** Defining Merge *)

(** Next, we need a [merge] function, which takes two
    sorted lists (of naturals) and returns their sorted result.
    This would seem easy to write:

    [[
    Fixpoint merge l1 l2 :=
      match l1, l2 with
      | [], _ => l2
      | _, [] => l1
      | a1::l1', a2::l2' =>
          if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge l1 l2'
      end.
    ]]

    But Coq will reject this definition with the message:

    [[
    Error: Cannot guess decreasing argument of fix.
    ]]

    Coq insists the every [Fixpoint] definition be structurally recursive
    on some specified argument, meaning that at each recursive call the
    callee is passed a value that is a sub-term of the caller's argument value.
    This check guarantees that every [Fixpoint] is actually terminating.

    It is fairly obvious that this function is in fact terminating, because
    at each call, either [l1] or [l2] is passed the tail of its original value.
    But unfortunately, [Fixpoint] recursive calls must always decrease on
    a _single fixed_ argument -- and neither [l1] nor [l2] will do. (That's
    why Coq couldn't guess the one to use.)  We might reasonably wish
    that Coq was a little smarter, but it isn't.

    There are a number of ways to get around the problem of convincing
    Coq that a function is actually terminating when the "natural" [Fixpoint]
    doesn't work. In this case, a little creativity (or a peek at the Coq
    library) might lead us to the following definition:
*)

Fixpoint merge l1 l2  {struct l1} :=
  let fix merge_aux l2 :=
  match l1, l2 with
  | [], _ => l2
  | _, [] => l1
  | a1::l1', a2::l2' =>
      if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
  end
  in merge_aux l2.

(** Coq accepts the outer definition because it is structurally
    decreasing on [l1] (we specify that with the [{struct l1}] annotation,
    although Coq would have guessed this even if we didn't write it),
    and it accepts the inner definition because it is structurally recursive
    on its (sole) argument. (Note that [let fix ... in ... end] is just a
    mechanism for  defining a local recursive function.)

    This definition will turn out to work pretty well; the only irritation
    is that simplification will show the definition of [merge_aux], as
    illustrated by the following examples.

    First, let's remind ourselves that Coq desugars a [match] over multiple
    arguments into a nested sequence of matches:
*)

Print merge.

(** ==> (after a little renaming for clarity)

    [[
    fix merge (l1 l2 : list nat) {struct l1} : list nat :=
      let
        fix merge_aux (l2 : list nat) : list nat :=
          match l1 with
          | [] => l2
          | a1 :: l1' =>
              match l2 with
              | [] => l1
              | a2 :: l2' =>
                  if a1 <=? a2 then a1 :: merge l1' l2 else a2 :: merge_aux l2'
              end
          end in
      merge_aux l2.
    ]]
*)

(** Let's prove the following simple lemmas about [merge]:
*)

Lemma merge2 : forall (x1 x2:nat) r1 r2,
    x1 <= x2 ->
    merge (x1::r1) (x2::r2) =
    x1::merge r1 (x2::r2).
Proof.
  intros.
  simpl. (* This blows up in an unpleasant way, but we can
      still make some sense of it.  Look at the
      [(fix merge_aux ...)] term. It represents the
      the local function [merge_aux] after the value of the
      free variable [l1] has been substituted by [x1::r1],
      the match over [l1] has been simplified to its
      second arm (the non-empty case) and [x1] and [r1] have
      been substituted for the pattern variables [a1] and [l1'].
      The entire [fix] is applied to [r2], but Coq won't attempt
      any further simplification until the structure of [r2]
      is known. *)
  bdestruct (x1 <=? x2).
  - auto.
  - (* Since [H] and [H0] are contradictory, this case follows by [lia].
       But (ignoring that for the moment), note that we can get further
       simplification to occur if we give some structure to [l2]: *)
    simpl. (* does nothing *)
    destruct r2; simpl.  (* makes some progress *)
    + lia.
    + lia.
Qed.

Lemma merge_nil_l : forall l, merge [] l = l.
Proof.
  intros. simpl.
  (* Once again, we see a version of [merge_aux] specialized to
  the value [l1 = nil]. Now we see only the first arm (the
  empty case) of the [match] expression, which simply returns [l2];
  in other words, here the [fix] is just the identity function.
  And once again, the [fix] is applied to [l].  Irritatingly,
  Coq _still_ refuses to perform the application unless [l]
  is destructured first (even though the answer is always [l]). *)
  destruct l.
  - auto.
  - auto.
Qed.

(** Morals:

    (1) Even though the proof state involving local recursive
        functions can can be hard to read, persevere!

    (2) If Coq won't simplify an "obvious" application, try destructing
        the argument.

    We will defer stating and proving other properties of [merge] until later.
*)

(* ================================================================= *)
(** ** Defining Mergesort *)

(** Finally, we need to define the main mergesort function itself.
    Once again, we might hope to write something simple like this:

    [[
    Fixpoint mergesort (l: list nat) :  list nat :=
       let (l1,l2) := split l in
       merge (mergesort l1) (mergesort l2).
    ]]

    Since this function has only one argument, Coq guesses that it is
    intended to be structurally decreasing, but still
    rejects the definition, this time with the complaint:

    [[
    Recursive call to mergesort has principal argument equal to
    "l1" instead of a subterm of "l".
    ]]

    Again, the problem is that Coq has no way to know that [l1] and [l2]
    are "smaller" than [l].  And this time, it is hard to complain that
    Coq is being stupid, since the fact that [split] returns smaller
    lists than it is passed is nontrivial.

    In fact, it isn't true! Consider the behavior of [split] on
    empty or singleton lists...  This is case where Coq's totality
    requirements can actually help us correct the definition of
    our code.  What we really want to write is something more like:

    [[
    Fixpoint mergesort (l: list nat) :  list nat :=
        match l with
        | [] => []
        | [x] => [x]
        | _ => let (l1,l2) := split l in merge (mergesort l1) (mergesort l2).
    ]]

    Now this function really is terminating!  But Coq still won't let us
    write it with a [Fixpoint].  Instead, we need to use a mechanism
    (there are several available) for defining functions that accommodates
    an explicit way to show that the function only calls itself on smaller
    arguments.   We will use the [Function] command:
*)

Function mergesort (l: list nat) {measure length l} :  list nat :=
  match l with
  | [] => []
  | [x] => [x]
  | _ => let (l1,l2) := split l in
         merge (mergesort l1) (mergesort l2)
  end.

(** [Function] is similar to [Fixpoint], but it lets us specify
    an explicit _measure_ on the function arguments.
    The annotation [{measure length l}] says that the function
    [length] applied to argument [l] serves as a decreasing measure.
    After processing this definition, Coq enters proof mode and demands
    proofs that each recursive call is indeed on a shorter list.
    Happily, we proved that fact already.
*)

Proof.
  - (* recursive call on l1 *)
    intros.
    simpl in *. destruct (split l1) as [l1' l2'] eqn:E. inv teq1. simpl.
    destruct (split_len _ _ _ E).
    lia.
  - (* recursive call on l2 *)
    intros.
    simpl in *. destruct (split l1) as [l1' l2'] eqn:E. inv teq1. simpl.
    destruct (split_len _ _ _ E).
    lia.
Defined.

(** Notice that the [Proof] must end with the keyword [Defined] rather
    than [Qed]; if we don't do this, we won't be able to actually
    compute with [mergesort].

    Defining [mergesort] with [Function] rather than [Fixpoint] causes
    the automatic generation of some useful auxiliary definitions that we
    will need when working with it.
    First, we get a lemma [mergesort_equation], which performs a one-level
    unfolding of the function. *)

Check mergesort_equation.

(** ==>

    [[
    mergesort_equation
     : forall l : list nat,
       mergesort l =
       match l with
       | [] => []
       | [x] => [x]
       | x :: _ :: _ =>
           let (l2, l3) := split l in merge (mergesort l2) (mergesort l3)
       end
    ]]

    We should always use [apply mergesort_equation]
    to simplify a call to [mergesort] rather than trying to [unfold] or [simpl]
    it, which will lead to ugly or mysterious results.

    Second, we get an induction principle [mergesort_ind]; performing
    induction using this principle can be much easier than trying to
    use list induction over the argument [l].
*)

Check mergesort_ind.

(** ==>
    [[
    mergesort_ind
     : forall P : list nat -> list nat -> Prop,
       (forall l : list nat, l = [] -> P [] []) ->
       (forall (l : list nat) (x : nat), l = [x] -> P [x] [x]) ->
       (forall l _x : list nat,
        l = _x ->
        match _x with
        | _ :: _ :: _ => True
        | _ => False
        end ->
        forall l1 l2 : list nat,
        split l = (l1, l2) ->
        P l1 (mergesort l1) ->
        P l2 (mergesort l2) -> P _x (merge (mergesort l1) (mergesort l2))) ->
        forall l : list nat, P l (mergesort l)
    ]]
*)

(* ================================================================= *)
(** ** Correctness: Sortedness *)

(** As with insertion sort, our goal is to prove that mergesort produces
    a sorted list that is a permutation of the original list, i.e. to prove

    [[
    is_a_sorting_algorithm mergesort
    ]]

    We will start by showing that [mergesort] produces a sorted list.  The key
    lemma is to show that [merge] of two sorted lists produces a sorted list.
    It is perhaps easiest to break out a sub-lemma first:
*)

Lemma sorted_inv : forall x l , sorted (x :: l) -> sorted l.
Proof.
  intros.
  induction l.
  constructor.
  inv H.
  auto.
Qed.

(** **** Exercise: 2 stars, standard (sorted_merge1) *)
Lemma sorted_merge1 : forall x x1 l1 x2 l2,
    x <= x1 -> x <= x2 ->
    sorted (merge (x1::l1) (x2::l2)) ->
    sorted (x :: merge (x1::l1) (x2::l2)).
Proof.
  firstorder.
  simpl in *.
  bdestruct (x2 >=? x1); constructor; auto.
Qed.

Lemma sorted_merge2 : forall x l1 l2 ,
    sorted (x :: l1) ->
    sorted (x :: l2) ->
    sorted (merge l1 l2) ->
    sorted (x :: merge l1 l2).
Proof.
destruct l1; intros.
rewrite (merge_nil_l l2) in *.
auto.
destruct l2.
simpl in *.
auto.
apply sorted_merge1.
inv H. auto.
inv H0. auto.
auto.
Qed.

(** **** Exercise: 4 stars, standard (sorted_merge) *)
Lemma sorted_merge : forall l1, sorted l1 ->
                     forall l2, sorted l2 ->
                     sorted (merge l1 l2).
Proof.
  intro.
  induction l1.
  intros.
  rewrite (merge_nil_l l2).
  auto.

  intro.
  induction l2; intros; simpl.

  auto.

  assert (sorted l1).
  eapply sorted_inv. apply H.
  specialize (IHl1 H1).

  bdestruct (a0 >=? a).
  apply sorted_merge2.
  auto.
  constructor; auto.
  apply IHl1.
  auto.

  assert (sorted (a0 :: merge (a :: l1) l2)).
  apply sorted_merge2.
  constructor. lia. auto. auto.
  apply IHl2.
  eapply sorted_inv.
  apply H0.

  exact H3.

Qed.

(** **** Exercise: 2 stars, standard (mergesort_sorts) *)
Lemma mergesort_sorts: forall l, sorted (mergesort l).
Proof.
  intro.
  functional induction (mergesort l).
  constructor.
  constructor.
  apply sorted_merge; auto.
Qed.

(* ================================================================= *)
(** ** Correctness: Permutation *)

(** Finally, we must show that [mergesort] returns a permutation of its input.

    As usual, the key lemma is for [merge].

    Incidentally, you are welcome to import the alternative characterizations
    of permutations as multisets given in [Multiset] or [BagPerm]
    and use that instead of [Permutation] if you think it will be easier.
    (I'm not sure!)
*)

(** **** Exercise: 3 stars, advanced (merge_perm) *)
Lemma merge_perm: forall (l1 l2: list nat),
    Permutation (l1 ++ l2) (merge l1 l2).
Proof.
    (* Hint: A nested induction on [l2] is required. *)
  induction l1.
  intros. rewrite (merge_nil_l l2).
  simpl in *.
  auto.

  induction l2.
  simpl.
  assert (a :: l1 ++ [] = a :: l1).
  f_equal.
  apply app_nil_r.
  rewrite H.
  auto.
  simpl.
  bdestruct (a0 >=? a).
  simpl.
  econstructor.
  apply IHl1.
  assert  (Permutation ((a :: l1) ++ a0 :: l2) ((a0 :: l2) ++ a :: l1)).
  apply Permutation_app_comm.
  assert ((a :: l1 ++ a0 :: l2) = ((a :: l1) ++ a0 :: l2)).
  auto.
  rewrite H1.
  econstructor.
  apply H0.
  simpl.
  econstructor.
  econstructor.
  apply Permutation_app_comm.
  exact IHl2.
Qed.

(** **** Exercise: 3 stars, advanced (mergesort_perm) *)
Lemma mergesort_perm: forall l, Permutation l (mergesort l).
Proof.
    apply mergesort_ind; intros.
    auto.
    auto.
    subst _x.
    econstructor.
    apply (split_perm l l1 l2 e0).
    assert (Permutation (l1 ++ l2) ((mergesort l1) ++ (mergesort l2))).
    apply Permutation_app.
    auto. auto.
    econstructor.
    apply H1.
    apply merge_perm.
Qed.

(*
(** Putting it all together: *)

Theorem mergesort_correct:
  is_a_sorting_algorithm mergesort.
Proof.
  split.
  apply mergesort_perm.
  apply mergesort_sorts.
Qed.
*)
(** $Date$ *)

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


Require Import Coq.Lists.List.
Require Import Shorthand.

(** Lexicographical ordering on binary lists *)

Inductive lex : list bool -> list bool -> Prop :=
  | nil_lex : forall a, lex nil a
  | car_lex : forall a b, lex (false :: a) (true :: b)
  | cdr_lex : forall a b c, lex a b -> lex (c :: a) (c :: b).

(** nil is never larger *)

Lemma nnil_lex :  forall b l, ~ lex (b :: l) nil.
Proof.
  intros b l.
  induction l.
  induction b.
  intros H.
  inversion H.
  intros H.
  inversion H.
  intros H.
  inversion H.
Qed.

(** lexicographical ordering is decidable *)

Lemma dec_lex: forall a b, (lex a b) + (~ lex a b).
Proof.
  induction a.
  intros b.
  apply inl.
  apply nil_lex.
  induction b.
  apply inr.
  apply nnil_lex.
  induction (IHa b).
  induction a.
  induction a1.
  apply inl.
  apply cdr_lex.
  apply a2.
  apply inr.
  intros q.
  inversion q.
  induction a1.
  apply inl.
  apply car_lex.
  apply inl.
  apply cdr_lex.
  apply a2.
  induction a.
  induction a1.
  apply inr.
  contradict b0.
  inversion  b0.
  trivial.
  apply inr.
  intros.
  intros U.
  inversion U.
  induction a1.
  apply inl.
  apply car_lex.
  apply inr.
  intros q.
  inversion q.
  auto.
Qed.

Lemma lex_cdr : forall a b i, lex (i :: a) (i :: b) -> lex a b.
Proof.
  intros a b i H.
  inversion H.
  trivial.
Qed.

Lemma lex_refl : forall a, lex a a.
Proof.
  induction a.
  apply nil_lex.
  apply cdr_lex.
  auto.
Qed.

Lemma lex_nil_is_nil : forall c, lex c nil -> c = nil.
Proof.
  induction c.
  auto.
  intro H.
  contradict H.
  apply nnil_lex.
Qed.

Theorem lex_trans : forall a b c, lex a b -> lex b c -> lex a c.
refine (fix f (a b c : list bool) : lex a b -> lex b c -> lex a c :=
          match b with
              | nil => _
              | false :: b' => match a with
                                   | nil => _
                                   | false :: a' => match c with
                                                        | nil => _
                                                        | false :: c' => _
                                                        | true :: c' => _
                                                    end
                                   | true :: a' => _
                               end
              | true :: b' => match a with
                                   | nil => _
                                   | false :: a' => match c with
                                                        | nil => _
                                                        | false :: c' => _
                                                        | true :: c' => _
                                                    end
                                   | true :: a' => match c with
                                                       | nil => _
                                                       | false :: c' => _
                                                       | true :: c' => _
                                                   end
                               end
          end
 ).

intros.
assert(H1 : a = nil).
apply lex_nil_is_nil.
trivial.
rewrite -> H1.
trivial.

intros.
apply nil_lex.
intros ? J.
contradict J.
apply nnil_lex.

intros H H0.
inversion H.
inversion H0.
apply cdr_lex.
apply (f a' b' c').
trivial.
trivial.

intros ? H.
inversion H.

intros ? H.
inversion H.

intros.
apply car_lex.

intros ? H0.
inversion H0.

intros.
apply nil_lex.
intro H.
inversion H.

intros ? H.
inversion H.

intros.
apply car_lex.

intros H H0.
inversion H.
inversion H0.
apply cdr_lex.
apply (f _ b').
auto.
auto.
Qed.

Theorem lex_antisym : forall a b, lex a b /\ lex b a -> a = b.
refine (fix f a b : lex a b /\ lex b a -> a = b :=
          match a with
              | nil => _
              | true :: a' => match b with
                                | nil => _
                                | false :: b' => _
                                | true :: b' => _
                              end
              | false :: a' => match b with
                                 | nil => _
                                 | false :: b' => _
                                 | true :: b' => _
                               end
          end).

(* Todo: make this proof nicer *)

intro H; destruct H as [H0 H1]; apply eq_sym; [apply lex_nil_is_nil; [trivial]].

intro H; destruct H as [H H0]; inversion H.

intro H.
destruct H as [H H0].
assert(H1 : a' = b').
apply f.
split.
apply (lex_cdr _ _ true).
trivial.
apply (lex_cdr _ _ true).
trivial.
rewrite -> H1.
auto.

intro H.
destruct H as [H H0].
inversion H.

intro H.
destruct H as [H H0].
inversion H.

intro H.
destruct H as [H H0].
inversion H0.

intro H.
destruct H as [H H0].
assert(H1 : a'=b').
apply f.
split.
apply (lex_cdr _ _ false).
trivial.
apply (lex_cdr _ _ false).
trivial.
rewrite -> H1.
auto.
Qed.

Definition lex_total : forall a b, lex a b + lex b a.
refine (fix f a b : lex a b + lex b a :=
          match a with
              | nil => _
              | x :: a' => match b with
                               | nil => _
                               | y :: b' => _
                           end
          end).

apply inl.
apply nil_lex.

apply inr.
apply nil_lex.

induction x.
induction y.
assert (lex a' b' + lex b' a').
apply f.
induction H.
apply inl.
apply cdr_lex.
trivial.
apply inr.
apply cdr_lex.
trivial.
apply inr.
apply car_lex.
induction y.
apply inl.
apply car_lex.
assert (lex a' b' + lex b' a').
apply f.
induction H.
apply inl.
apply cdr_lex.
trivial.
apply inr.
apply cdr_lex.
trivial.
Qed.

Lemma lex_total_lemma : forall a b, ~ lex a b -> lex b a.
Proof.
  intros.
  assert (lex a b + lex b a).
  apply lex_total.
  induction H0.
  contradict a0.
  trivial.
  trivial.
Qed.

Lemma lex_apprm : forall a b c, lex (a ++ b) (a ++ c) -> lex b c.
Proof.
  induction a.
  intros b c.
  unfold app.
  auto.
  intros b c lx.
  replace ((a :: a0) ++ b) with (a :: a0 ++ b) in lx.
  replace ((a :: a0) ++ c) with (a :: a0 ++ c) in lx.
  apply IHa.
  apply (lex_cdr _ _ a).
  apply lx.
  auto.
  auto.
Qed.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool.
From PLF Require Import Maps.
From PLF Require Import Smallstep.
From PLF Require Import Stlc.
From PLF Require MoreStlc.
Module STLCTypes.
Export STLC.

Fixpoint eqb_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | Bool, Bool =>
      true
  | Arrow T11 T12, Arrow T21 T22 =>
      andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | _,_ =>
      false
  end.

Lemma eqb_ty_refl : forall T1,
  eqb_ty T1 T1 = true.
Proof.
  intros T1. induction T1; simpl.
    reflexivity.
    rewrite IHT1_1. rewrite IHT1_2. reflexivity. Qed.

Lemma eqb_ty__eq : forall T1 T2,
  eqb_ty T1 T2 = true -> T1 = T2.
Proof with auto.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  - (* T1=Bool *)
    reflexivity.
  - (* T1=Arrow T1_1 T1_2 *)
    rewrite andb_true_iff in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst... Qed.
End STLCTypes.

Module FirstTry.
Import STLCTypes.
Fixpoint type_check (Gamma : context) (t : tm) : option ty :=
  match t with
  | var x =>
      Gamma x
  | abs x T11 t12 =>
      match type_check (update Gamma x T11) t12 with
      | Some T12 => Some (Arrow T11 T12)
      | _ => None
      end
  | app t1 t2 =>
      match type_check Gamma t1, type_check Gamma t2 with
      | Some (Arrow T11 T12),Some T2 =>
          if eqb_ty T11 T2 then Some T12 else None
      | _,_ => None
      end
  | tru =>
      Some Bool
  | fls =>
      Some Bool
  | test guard t f =>
      match type_check Gamma guard with
      | Some Bool =>
          match type_check Gamma t, type_check Gamma f with
          | Some T1, Some T2 =>
              if eqb_ty T1 T2 then Some T1 else None
          | _,_ => None
          end
      | _ => None
      end
  end.
End FirstTry.

(* Monadic way *)

Notation " x <- e1 ;; e2" := (match e1 with
                              | Some x => e2
                              | None => None
                              end)
         (right associativity, at level 60).

Notation " 'return' e "
  := (Some e) (at level 60).
Notation " 'fail' "
  := None.
Module STLCChecker.
  Import STLCTypes.

Fixpoint type_check (Gamma : context) (t : tm) : option ty :=
  match t with
  | var x =>
      match Gamma x with
      | Some T => return T
      | None => fail
      end
  | abs x T11 t12 =>
      T12 <- type_check (update Gamma x T11) t12 ;;
      return (Arrow T11 T12)
  | app t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1 with
      | Arrow T11 T12 =>
          if eqb_ty T11 T2 then return T12 else fail
      | _ => fail
      end
  | tru =>
      return Bool
  | fls =>
      return Bool
  | test guard t1 t2 =>
      Tguard <- type_check Gamma guard ;;
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match Tguard with
      | Bool =>
          if eqb_ty T1 T2 then return T1 else fail
      | _ => fail
      end
  end.

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - (* var *) rename s into x. destruct (Gamma x) eqn:H.
    rename t into T'. inversion H0. subst. eauto. solve_by_invert.
  - (* app *)
    remember (type_check Gamma t1) as TO1.
    destruct TO1 as [T1|]; try solve_by_invert;
    destruct T1 as [|T11 T12]; try solve_by_invert;
    remember (type_check Gamma t2) as TO2;
    destruct TO2 as [T2|]; try solve_by_invert.
    destruct (eqb_ty T11 T2) eqn: Heqb.
    apply eqb_ty__eq in Heqb.
    inversion H0; subst...
    inversion H0.
  - (* abs *)
    rename s into x. rename t into T1.
    remember (update Gamma x T1) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve_by_invert.
    inversion H0; subst...
  - (* tru *) eauto.
  - (* fls *) eauto.
  - (* test *)
    remember (type_check Gamma t1) as TOc.
    remember (type_check Gamma t2) as TO1.
    remember (type_check Gamma t3) as TO2.
    destruct TOc as [Tc|]; try solve_by_invert.
    destruct Tc; try solve_by_invert;
    destruct TO1 as [T1|]; try solve_by_invert;
    destruct TO2 as [T2|]; try solve_by_invert.
    destruct (eqb_ty T1 T2) eqn:Heqb;
    try solve_by_invert.
    apply eqb_ty__eq in Heqb.
    inversion H0. subst. subst...
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof with auto.
  intros Gamma t T Hty.
  induction Hty; simpl.
  - (* T_Var *) destruct (Gamma x0) eqn:H0; assumption.
  - (* T_Abs *) rewrite IHHty...
  - (* T_App *)
    rewrite IHHty1. rewrite IHHty2.
    rewrite (eqb_ty_refl T11)...
  - (* T_True *) eauto.
  - (* T_False *) eauto.
  - (* T_If *) rewrite IHHty1. rewrite IHHty2.
    rewrite IHHty3. rewrite (eqb_ty_refl T)...
Qed.

End STLCChecker.

Module TypecheckerExtensions.

Import MoreStlc.
Import STLCExtended.
Fixpoint eqb_ty (T1 T2 : ty) : bool :=
  match T1,T2 with
  | Nat, Nat =>
      true
  | Unit, Unit =>
      true
  | Arrow T11 T12, Arrow T21 T22 =>
      andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | Prod T11 T12, Prod T21 T22 =>
      andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | Sum T11 T12, Sum T21 T22 =>
      andb (eqb_ty T11 T21) (eqb_ty T12 T22)
  | List T11, List T21 =>
      eqb_ty T11 T21
  | _,_ =>
      false
  end.
Lemma eqb_ty_refl : forall T1,
  eqb_ty T1 T1 = true.
Proof.
  intros T1.
  induction T1; simpl;
    try reflexivity;
    try (rewrite IHT1_1; rewrite IHT1_2; reflexivity);
    try (rewrite IHT1; reflexivity). Qed.
Lemma eqb_ty__eq : forall T1 T2,
  eqb_ty T1 T2 = true -> T1 = T2.
Proof.
  intros T1.
  induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq;
    try reflexivity;
    try (rewrite andb_true_iff in H0; inversion H0 as [Hbeq1 Hbeq2];
         apply IHT1_1 in Hbeq1; apply IHT1_2 in Hbeq2; subst; auto);
    try (apply IHT1 in Hbeq; subst; auto).
 Qed.
Fixpoint type_check (Gamma : context) (t : tm) : option ty :=
  match t with
  | var x =>
      match Gamma x with
      | Some T => return T
      | None => fail
      end
  | abs x1 T1 t2 =>
      T2 <- type_check (update Gamma x1 T1) t2 ;;
      return (Arrow T1 T2)
  | app t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1 with
      | Arrow T11 T12 =>
          if eqb_ty T11 T2 then return T12 else fail
      | _ => fail
      end
  | const _ =>
      return Nat
  | scc t1 =>
      T1 <- type_check Gamma t1 ;;
      match T1 with
      | Nat => return Nat
      | _ => fail
      end
  | prd t1 =>
      T1 <- type_check Gamma t1 ;;
      match T1 with
      | Nat => return Nat
      | _ => fail
      end
  | mlt t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      match T1, T2 with
      | Nat, Nat => return Nat
      | _,_ => fail
      end
  | test0 guard t f =>
      Tguard <- type_check Gamma guard ;;
      T1 <- type_check Gamma t ;;
      T2 <- type_check Gamma f ;;
      match Tguard with
      | Nat => if eqb_ty T1 T2 then return T1 else fail
      | _ => fail
      end

  (* Complete the following cases. *)
  (* sums *)
  | tinl Tr v =>
      Tl <- type_check Gamma v ;;
      return (Sum Tl Tr)
  | tinr Tl v =>
      Tr <- type_check Gamma v ;;
      return (Sum Tl Tr)
  | tcase t0 y1 t1 y2 t2 =>
      Ts <- type_check Gamma t0 ;;
      match Ts with
      | Sum T1 T2 =>
          T11 <- type_check (y1 |-> T1; Gamma) t1 ;;
          T21 <- type_check (y2 |-> T2; Gamma) t2 ;;
          if eqb_ty T11 T21 then return T11 else fail
      | _ => fail
      end
  (* lists (the tlcase is given for free) *)
  | tnil T => return (List T)
  | tcons t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      Tl <- type_check Gamma t2 ;;
      match Tl with
      | List T2 =>
          if eqb_ty T1 T2 then return (List T1) else fail
      | _ => fail
      end
  | tlcase t0 t1 x21 x22 t2 =>
      match type_check Gamma t0 with
      | Some (List T) =>
          match type_check Gamma t1,
                type_check (update (update Gamma x22 (List T)) x21 T) t2 with
          | Some T1', Some T2' =>
              if eqb_ty T1' T2' then Some T1' else None
          | _,_ => None
          end
      | _ => None
      end
  (* unit *)
  | unit => return Unit
  (* pairs *)
  | pair t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check Gamma t2 ;;
      return (Prod T1 T2)
  | fst t1 =>
      Tp <- type_check Gamma t1 ;;
      match Tp with
      | Prod T11 T12 => return T11
      | _ => fail
      end
  | snd t1 =>
      Tp <- type_check Gamma t1 ;;
      match Tp with
      | Prod T11 T12 => return T12
      | _ => fail
      end
  (* let *)
  | tlet x t1 t2 =>
      T1 <- type_check Gamma t1 ;;
      T2 <- type_check (x |-> T1;Gamma) t2 ;;
      return T2
  (* fix *)
  | tfix t1 =>
      Tf <- type_check Gamma t1 ;;
      match Tf with (* pattern match can't match sameness of T1 T2*)
      | Arrow T1 T2 =>
          if eqb_ty T1 T2 then return T1 else fail
      | _ => fail
      end
  end.

Ltac invert_typecheck Gamma t T :=
  remember (type_check Gamma t) as TO;
  destruct TO as [T|];
  try solve_by_invert; try (inversion H0; eauto); try (subst; eauto).
Ltac analyze T T1 T2 :=
  destruct T as [T1 T2| |T1 T2|T1| |T1 T2]; try solve_by_invert.
Ltac fully_invert_typecheck Gamma t T T1 T2 :=
  let TX := fresh T in
  remember (type_check Gamma t) as TO;
  destruct TO as [TX|]; try solve_by_invert;
  destruct TX as [T1 T2| |T1 T2|T1| |T1 T2];
  try solve_by_invert; try (inversion H0; eauto); try (subst; eauto).
Ltac case_equality S T :=
  destruct (eqb_ty S T) eqn: Heqb;
  inversion H0; apply eqb_ty__eq in Heqb; subst; subst; eauto.
Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof with eauto.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - (* var *) rename s into x. destruct (Gamma x) eqn:H.
    rename t into T'. inversion H0. subst. eauto. solve_by_invert.
  - (* app *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    analyze T1 T11 T12.
    case_equality T11 T2.
  - (* abs *)
    rename s into x. rename t into T1.
    remember (update Gamma x T1) as Gamma'.
    invert_typecheck Gamma' t0 T0.
  - (* const *) eauto.
  - (* scc *)
    rename t into t1.
    fully_invert_typecheck Gamma t1 T1 T11 T12.
  - (* prd *)
    rename t into t1.
    fully_invert_typecheck Gamma t1 T1 T11 T12.
  - (* mlt *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    analyze T1 T11 T12; analyze T2 T21 T22.
    inversion H0. subst. eauto.
  - (* test0 *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    invert_typecheck Gamma t3 T3.
    destruct T1; try solve_by_invert.
    case_equality T2 T3.
  - (* tinl *)
    invert_typecheck Gamma t0 Tl.
  - (* tinr *)
    invert_typecheck Gamma t0 Tr.
  - (* tcase *)
    fully_invert_typecheck Gamma t1 T1 T11 T12.
    invert_typecheck (s |-> T11; Gamma) t2 T13.
    invert_typecheck (s0 |-> T12; Gamma) t3 T21.
    case_equality T13 T21.
  - (* tnil *)
    auto.
  - (* tcons *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
    destruct T2; try solve_by_invert.
    case_equality T1 T2.
  - (* tlcase *)
    rename s into x31. rename s0 into x32.
    fully_invert_typecheck Gamma t1 T1 T11 T12.
    invert_typecheck Gamma t2 T2.
    remember (update (update Gamma x32 (List T11)) x31 T11) as Gamma'2.
    invert_typecheck Gamma'2 t3 T3.
    case_equality T2 T3.
  - (* tunit *)
    auto.
  - (* pair *)
    invert_typecheck Gamma t1 T1.
    invert_typecheck Gamma t2 T2.
  - (* fst *)
    invert_typecheck Gamma t Tp.
    analyze Tp T11 T12.
    inversion H0. subst. eauto.
  - (* snd *)
    invert_typecheck Gamma t Tp.
    analyze Tp T11 T12.
    inversion H0; subst. eauto.
  - (* tlet *)
    invert_typecheck Gamma t1 T1.
    remember (s |-> T1; Gamma) as Gamma2.
    invert_typecheck Gamma2 t2 T2.
  - (* tfix *)
    invert_typecheck Gamma t Tf.
    analyze Tf T1 T2.
    case_equality T1 T2.
Qed.

Theorem type_checking_complete : forall Gamma t T,
  has_type Gamma t T -> type_check Gamma t = Some T.
Proof.
  intros Gamma t T Hty.
  induction Hty; simpl;
    try (rewrite IHHty);
    try (rewrite IHHty1);
    try (rewrite IHHty2);
    try (rewrite IHHty3);
    try (rewrite (eqb_ty_refl T));
    try (rewrite (eqb_ty_refl T1));
    try (rewrite (eqb_ty_refl T2));
    eauto.
  - destruct (Gamma x); try solve_by_invert. eauto.
Qed. (* ... and uncomment this one *)
End TypecheckerExtensions.


Theorem Disjunctive_syllogism :
forall (P Q : Prop), (P \/ Q) -> ~P -> Q.
unfold not.
Proof.
  intros.
  destruct H.
  destruct H0.
  apply H.
  apply H.
Qed.


Require Import List.
Import ListNotations.

Require Import eq.
Require Import utils.
Require Import identity.
Require Import composition.
Require Import injective.
Require Import map.
Require Import incl.
Require Import term.
Require Import var.
Require Import inj_on_list.
Require Import permute.
Require Import inj_on_term.
Require Import remove.
Require Import vmap.
Require Import swap.
Require Import free.
Require Import adpair.

(* This inductive predicate defines alpha-equivalence.          *)
(* There are four ways of establishing alpha-equivalence:       *)
(* 1. Given a variable x:v, we always have x ~ x.               *)
(* 2. t1 ~ t1' and t2 ~ t2' implies t1 t2 ~ t1' t2'             *)
(* 3. t1 ~ t1' implies Lam x t1 ~ Lam x t1'                     *)
(* 4. The final and most interesting way relies on [x:y]:       *)
(* In order to establish the equivalence Lam x t1 ~ Lam y t1'   *)
(* in the case when x <> y, we need to ensure that y is not     *)
(* a free variable of t1, and furthermore that t1' ~ t1[x:y]    *)
(* i.e. that t1' is equivalent to t1 after x and y have been    *)
(* exchanged for one another. Note that we cannot do away with  *)
(* the third constructor (by removing condition x <> y in 4.)   *)
(* Lam x (Var x) ~ Lam x (Var x) cannot be proven simply by     *)
(* taking x = y in 4. because of the requirement that y not     *)
(* be a free variable of t1.                         *)
(*                                                              *)
(* The definition presented here relies on the permutation      *)
(* function [x:y] (which permutes x and y while leaving         *)
(* everything else unchanged). This choice has two benefits:    *)
(* firstly, [x:y] is an injective function (in fact it is a     *)
(* bijection with itself as inverse), which is not the case     *)
(* of [y/x] (which simply replaces x by y). This property       *)
(* facilitates many of the formal developments. Secondly,       *)
(* the choice of [x:y] leads to the condition 'y not a free     *)
(* variable of t1', whereas [y/x] would require the condition   *)
(* 'y not a variable of t1' or 'y be a variable which can be    *)
(* substituted for x in t1 without variable capture', and       *)
(* these conditions make it compulsory to have an infinite      *)
(* supply of variables. In the extreme case when the variable   *)
(* type v has only two instances x and y, the usual approach    *)
(* based on [y/x] makes it impossible to prove the alpha-equi   *)
(* valence of 'Lam x (Lam y (x y))' and 'Lam y (Lam x (y x))':  *)
(* When faced with Lam y (x y), the only variable which we      *)
(* can substitute for x is the variable y, but this would       *)
(* lead to variable capture, whereas using the permutation      *)
(* [x:y] (note that y is not free in Lam y (x y)), we obtain    *)
(* Lam x (y x) very naturally. So the definition below allows   *)
(* for the development of the theory with finite variable types *)

(* The alpha-equivalence t ~ t' is expressed as -alpha p t t'-  *)
(* which requires an additional argument 'p', namely a proof    *)
(* that the variable type v has decidable equality. This 'p'    *)
(* is needed because it is required by the notion of free       *)
(* variable on which alpha-equivalence relies. The argument p   *)
(* cannot be made implicit, because it cannot be inferred by    *)
(* the knowledge of terms t and t' (unlike v which can be       *)
(* inferred). Hence we are stuck having to write alpha p t t'   *)
(* rather than just alpha t t'                                  *)

Inductive alpha (v:Type) (p:Eq v) : P v -> P v -> Prop :=
| AVar  : forall (x:v), alpha v p (Var x) (Var x)

| AApp  : forall (t1 t1' t2 t2':P v),
    alpha v p t1 t1' ->
    alpha v p t2 t2' ->
    alpha v p (App t1 t2) (App t1' t2')

| ALam1 :forall (x:v) (t1 t1':P v),
    alpha v p t1 t1' ->
    alpha v p (Lam x t1) (Lam x t1')

| ALam2 : forall (x y:v) (t1 t1':P v),
    x <> y ->
    ~In y (Fr p t1) ->                  (* y not free in t1     *)
    alpha v p t1' (swap p x y t1) ->    (* t1' ~ t1[x:y]        *)
    alpha v p (Lam x t1) (Lam y t1')    (* Lam x t1 ~ Lam y t1' *)
.

Arguments alpha {v} _ _ _.

(* alpha-equivalent terms have the same free variables.         *)
(* In fact, this equality holds as lists, not just as sets.     *)

Lemma alpha_free : forall (v:Type) (p:Eq v) (t t':P v),
    alpha p t t' -> Fr p t = Fr p t'.
Proof.
    intros v p t t' H.
    induction H.
    - reflexivity.
    - simpl.
        assert (Fr p t1 = Fr p t1') as E1. { assumption. }
        assert (Fr p t2 = Fr p t2') as E2. { assumption. }
        rewrite E1, E2. reflexivity.
    - simpl.
        assert (Fr p t1 = Fr p t1') as E1. { assumption. }
        rewrite E1. reflexivity.
    - simpl. assert (Fr p t1' = Fr p (swap p x y t1)) as E. { assumption. }
      rewrite E. unfold swap. rewrite (free_vmap_inj v v p p).
      remember (permute p x y) as f eqn:F.
      assert (f x = y) as Fx. { rewrite F. apply permute_x. }
      rewrite <- Fx. rewrite (remove_inj2 v v p p).
        + symmetry. apply map_invariant.
            { intros u Hu. rewrite F. apply permute_not_xy.
                { intros H'. rewrite H' in Hu. revert Hu. apply remove_In. }
                { intros H'. rewrite H' in Hu. apply H0.
                    apply (remove_incl v p x). assumption.
                }
            }
        + apply inj_is_inj_on_list. rewrite F. apply permute_injective.
        + apply inj_is_inj_on_list. apply permute_injective.
Qed.

(* two alpha-equivalent terms are still alpha-equivalent after  *)
(* injective variable renaming                                  *)

Lemma alpha_injective : forall (v w:Type) (p:Eq v) (q:Eq w) (t t':P v) (f:v -> w),
    injective f ->
    alpha p t t' ->                     (* t ~ t'               *)
    alpha q (vmap f t) (vmap f t').     (* f t ~ f t'           *)
Proof.
    intros v w p q t t' f I H. induction H; simpl.
    - constructor.
    - constructor; assumption.
    - constructor; assumption.
    - constructor.
        + intros H'. apply H. apply I. assumption.
        + rewrite (free_vmap_inj v w p q).
            { apply injective_not_in.
                { apply inj_is_inj_on_list. assumption. }
                { assumption. }
            }
            { apply inj_is_inj_on_list. assumption. }
        + rewrite <- (swap_inj v w p q); assumption.
Qed.

(* A simple application of the previous lemma                   *)
Lemma alpha_injective_swap : forall (v:Type) (p:Eq v) (x y:v) (t t':P v),
    alpha p t t' <-> alpha p (swap p x y t) (swap p x y t').
Proof.
    intros v p x y t t'. split; intros H.
    - unfold swap. apply alpha_injective with p.
        + apply permute_injective.
        + assumption.
    - rewrite <- (swap_involution v p x y t), <- (swap_involution v p x y t').
        + unfold swap at 1. unfold swap at 2. apply alpha_injective with p.
            { apply permute_injective. }
            { assumption. }
Qed.

(* alpha-equivalence is a reflexive relation                    *)

Lemma alpha_refl : forall (v:Type) (p:Eq v) (t:P v), alpha p t t.
Proof.
    intros v p t.
    induction t.
    - constructor.
    - constructor; assumption.
    - constructor; assumption.
Qed.

(* alpha-equivalence is a symmetric relation                    *)

Lemma alpha_sym : forall (v:Type) (p:Eq v) (t t':P v),
    alpha p t t' -> alpha p t' t.
Proof.
    intros v p t t' H.
    induction H.
    - constructor.
    - constructor; assumption.
    - constructor; assumption.
    - constructor.
        + intros E. apply H. symmetry. assumption.
        + assert (Fr p t1' = Fr p (swap p x y t1)) as H'.
            { apply alpha_free. assumption. }
          rewrite H'. clear H'. unfold swap.
          remember (permute p x y) as f eqn:F.
          assert (Fr p (vmap f t1) = map f (Fr p t1)) as H'.
            { apply free_vmap_inj. apply inj_is_inj_on_list.
              rewrite F. apply permute_injective.
            }
          rewrite H'. clear H'.
          assert (f y = x) as H'.
            { rewrite F. apply permute_y. }
          rewrite <- H'. clear H'.
          apply injective_not_in.
            { apply inj_is_inj_on_list. rewrite F. apply permute_injective. }
            { assumption. }
        + rewrite swap_commute.
          rewrite <- (swap_involution v p x y t1).
          apply (alpha_injective v v p p).
            { apply permute_injective. }
            { assumption. }
Qed.

(* This is motivated by and constitues a generalization of:     *)
(* t ~ t'[x:y]  <=>   t[x:y] ~ t'                               *)
(* We are now stating that:                                     *)
(* t ~ f t'     <=>   g t ~  t'                                 *)
(* provided f and g are inverses of each other.                 *)

Lemma alpha_swap_gen : forall (v:Type) (p:Eq v) (t t':P v) (f g:v -> v),
    (forall x, g (f x) = x) ->
    (forall x, f (g x) = x) ->
    alpha p t (vmap f t') <-> alpha p (vmap g t) t'.
Proof.
    intros v p t t' f g GF FG. split; intros H'.
    - rewrite <- (vmap_id v t'). rewrite (vmap_eq v v id (g;f) t').
        + rewrite vmap_comp. apply alpha_injective with p.
            { intros x y Hxy. rewrite <- (FG x), <- (FG y), Hxy. reflexivity. }
            { assumption. }
        + intros x _. symmetry. apply GF.
    - rewrite <- (vmap_id v t). rewrite (vmap_eq v v id (f;g) t).
        + rewrite vmap_comp. apply alpha_injective with p.
            { intros x y Hxy. rewrite <- (GF x), <- (GF y), Hxy. reflexivity. }
            { assumption. }
        + intros x _. symmetry. apply FG.
Qed.

(* We apply the previous lemma to the permutation [x:y]         *)

Lemma alpha_swap : forall (v:Type) (p:Eq v) (x y:v) (t t':P v),
    alpha p t (swap p x y t') <-> alpha p (swap p x y t) t'.
Proof.
    intros v p x y t t'. unfold swap. apply alpha_swap_gen;
    intros z; apply permute_involution.
Qed.

(* Simple convenience wrapper                                   *)

Lemma alpha_swap_gen' : forall (v:Type) (p:Eq v) (t t' s:P v) (f g:v -> v),
    adpair p s f g ->
    alpha p t (vmap f t') <-> alpha p (vmap g t) t'.
Proof.
    intros v p t t' s f g [GF FG _].
    apply alpha_swap_gen; assumption.
Qed.

(* If t[x:y] ~ t' then x is not a free variable of t'           *)
(* if and only if y is not a free variable of t.                *)

Lemma alpha_free_swap : forall (v:Type) (p:Eq v) (x y:v) (t t':P v),
    alpha p (swap p x y t) t' ->
    ~In y (Fr p t) <-> ~In x (Fr p t').
Proof.
    intros v p x y t t' H. split; intros H'.
    - rewrite (alpha_free v p t' (swap p x y t)).
        + apply free_swap. assumption.
        + apply alpha_sym. assumption.
    - apply alpha_swap in H. rewrite (alpha_free v p t (swap p x y t')).
        + rewrite swap_commute. apply free_swap. assumption.
        + assumption.
Qed.

(* This is a very difficult technical lemma, needed to prove    *)
(* that the alpha-equivalence relation is transitive.           *)
(* Whenever a function f : v -> v is such that f is injective   *)
(* and f does not change the free variables of a term t, we can *)
(* easily believe that 'f t' should be alpha-equivalent to t    *)
(* i.e. f t ~ t. We have used stronger assumptions here by      *)
(* assuming that f has an inverse g (so the pair (f,g) is an    *)
(* 'admissible pair for t'. Furthermore, the lemma proves       *)
(* a conclusion which is stronger than t ~ f t, namely that     *)
(* s ~ t => s ~ f t. This distinction will prove important      *)
(* when establishing the transitivity of alpha-equivalence.     *)
(* This lemma is only needed in the particular case when        *)
(* f = [x:y] = g, i.e. we need the implication:                 *)
(* s ~ t => s ~ t[x:y]                                          *)
(* whenever it is the case that x,y are not free in t           *)
(* However, like very often in induction proofs, it is          *)
(* necessary to strengthen the induction hypothesis, with       *)
(* general f and g, rather than [x:y]                           *)

Lemma alpha_adpair : forall (v:Type) (p:Eq v) (f g:v -> v) (t s:P v),
    adpair p t f g -> alpha p s t -> alpha p s (vmap f t).
Proof.
    intros v p f g t s A H. revert f g A.
    induction H; intros f g A; simpl.
    - rewrite (adpair_invl v p (Var x) f g).
        + constructor.
        + assumption.
        + simpl. left. reflexivity.
    - constructor.
        + apply IHalpha1 with g. apply adpair_Appl with t2'. assumption.
        + apply IHalpha2 with g. apply adpair_Appr with t1'. assumption.
    - remember (f x) as y eqn:Y. destruct (p y x) as [Hyx|Hyx].
        + rewrite Hyx. constructor. apply IHalpha with g. constructor.
            { intros z. apply (adpair_gf v p) with (Lam x t1'). assumption. }
            { intros z. apply (adpair_fg v p) with (Lam x t1'). assumption. }
            { intros z Hz. destruct (p x z) as [Hxz|Hxz]; subst.
                { assumption. }
                { apply (adpair_invl v p (Lam x t1')) with g.
                    { assumption. }
                    { simpl. apply remove_In2; assumption. }
                }
            }
        + constructor.
            { apply neq_sym. assumption. }
            { intros H'. apply Hyx. assert (injective f) as I.
                { apply (adpair_injl v p (Lam x t1')) with g. assumption. }
              apply I. rewrite <- Y.
              apply (adpair_invl v p (Lam x t1')) with g.
                { assumption. }
                { simpl. apply remove_In2.
                    { apply neq_sym. assumption. }
                    { rewrite (alpha_free v p t1' t1).
                        { assumption. }
                        { apply alpha_sym. assumption. }
                    }
                }
            }
            { apply alpha_sym. apply alpha_swap. unfold swap.
              rewrite <- vmap_comp. apply IHalpha with (g; permute p x y).
              constructor.
                { intros z. unfold comp. rewrite permute_involution.
                  apply (adpair_gf v p (Lam x t1')). assumption.
                }
                { intros z. unfold comp.
                    rewrite (adpair_fg v p (Lam x t1') f g (permute p x y z)).
                        { apply permute_involution. }
                        { assumption. }
                }
                { intros z Hz. destruct (p z x) as [Hzx|Hzx]; unfold comp.
                    { rewrite Hzx. rewrite <- Y. apply permute_y. }
                    { assert (f z = z) as Z.
                        { apply (adpair_invl v p (Lam x t1')) with g.
                            { assumption. }
                            { simpl. apply remove_In2.
                                { apply neq_sym. assumption. }
                                { assumption. }
                            }
                        }
                      rewrite Z. apply permute_not_xy.
                        { assumption. }
                        { intros H'. apply Hzx. assert (injective f) as I.
                            { apply (adpair_injl v p (Lam x t1')) with g.
                              assumption.
                            }
                          apply I. rewrite <- Y. rewrite <- H'.
                          apply (adpair_invl v p (Lam x t1')) with g.
                            { assumption. }
                            { simpl. apply remove_In2.
                                { apply neq_sym. assumption. }
                                { assumption. }
                            }
                        }
                    }
                }
            }
    - remember (f y) as z eqn:Z. destruct (p x z) as [Hxz|Hxz].
        + rewrite <- Hxz. constructor.
          rewrite (alpha_swap_gen' v p t1 t1' (Lam y t1') f g).
            { apply alpha_sym.
              rewrite <- (swap_involution v p x y t1).
              unfold swap at 1.
              rewrite <- vmap_comp.
              apply IHalpha with (permute p x y ; f).
              constructor; generalize A; intros [GF FG _].
                { intros u. unfold comp. rewrite FG. apply permute_involution. }
                { intros u. unfold comp. rewrite permute_involution. apply GF. }
                { intros u Hu. unfold comp. destruct (p u y) as [Huy|Huy].
                    { rewrite Huy, permute_y, Hxz, Z. apply GF. }
                    { apply adpair_sym in A. generalize A. intros [_ _ FR].
                      rewrite permute_not_xy.
                        { apply FR. simpl. apply remove_In2.
                            { apply neq_sym. assumption. }
                            { rewrite (alpha_free v p t1' (swap p x y t1));
                              assumption.
                            }
                        }
                        { intros Hux. rewrite (free_swap v p x y t1) in H0.
                          apply H0. rewrite <- Hux at 1. assumption.
                        }
                        { assumption. }
                    }
                }
            }
            { assumption. }
        + constructor.
            { assumption. }
            { intros H'. apply adpair_sym in A.
              generalize A. intros [FG GF FR]. assert (y = z) as Hyz.
                { rewrite <- (GF y), <- Z. apply FR. simpl.
                  apply remove_In2.
                    { intros Hyz. apply H0. rewrite Hyz. assumption. }
                    { rewrite (alpha_free v p t1' (swap p x y t1)).
                        { rewrite free_permute, <- (permute_not_xy v p x y z).
                            { apply incl_map. assumption. }
                            { apply neq_sym. assumption. }
                            { intros Hyz. apply H0. rewrite <- Hyz. assumption. }
                        }
                        { assumption. }
                    }
                }
              apply H0. rewrite Hyz. assumption.
            }
            { apply alpha_sym.
              apply (alpha_swap_gen v p (swap p x z t1) t1' f g);
              generalize A; intros [GF FG _].
                { apply GF. }
                { apply FG. }
                { apply alpha_sym.
                  rewrite <- (swap_involution v p x y t1).
                  unfold swap at 1. rewrite <- vmap_comp.
                  unfold swap at 1. rewrite <- vmap_comp.
                  apply IHalpha with ((permute p x y); (permute p x z; f)).
                  constructor.
                  { intros u. unfold comp. rewrite FG.
                    rewrite permute_involution, permute_involution.
                    reflexivity.
                  }
                  { intros u. unfold comp.
                    rewrite permute_involution, permute_involution, GF.
                    reflexivity.
                  }
                  { intros u Hu. unfold comp. assert (u <> x) as Hux.
                      { intros Hux. rewrite Hux in Hu. revert Hu.
                        apply free_swap. assumption.
                      }
                    apply adpair_sym in A. generalize A. intros [_ _ FR].
                    destruct (p u y) as [Huy|Huy].
                        { rewrite Huy, permute_y, permute_x, Z. apply GF. }
                        { rewrite permute_not_xy.
                            { rewrite permute_not_xy; try (assumption).
                                { apply FR. simpl. apply remove_In2.
                                    { apply neq_sym. assumption. }
                                    { rewrite (alpha_free v p t1' (swap p x y t1));
                                      assumption.
                                    }
                                }
                            }
                            { rewrite permute_not_xy; assumption. }
                            { rewrite permute_not_xy; try (assumption).
                                { intros Huz. apply Huy. rewrite Huz.
                                  symmetry. rewrite <- (GF y), <- Z.
                                  apply FR. simpl. apply remove_In2.
                                    { apply neq_sym. rewrite <- Huz. assumption. }
                                    { rewrite (alpha_free v p t1' (swap p x y t1)).
                                        { rewrite <- Huz. assumption. }
                                        { assumption. }
                                    }
                                }
                            }
                        }
                    }
                }
            }
Qed.

(* Applying previous lemma in case when f = [x:y] = g, also     *)
(* establishing equivalence rather than mere implication.       *)

Lemma alpha_adpair_swap : forall (v:Type) (p:Eq v) (x y:v) (t s:P v),
    ~In x (Fr p t)  ->
    ~In y (Fr p t)  ->
    alpha p s t <-> alpha p s (swap p x y t).
Proof.
    intros v p x y t s Fx Fy. split; intro H; unfold swap.
    - apply alpha_adpair with (permute p x y).
        + constructor.
            { intros z. apply permute_involution. }
            { intros z. apply permute_involution. }
            { intros z Hz. apply permute_not_xy.
                { intros Hzx. apply Fx. rewrite <- Hzx. assumption. }
                { intros Hzy. apply Fy. rewrite <- Hzy. assumption. }
            }
        + assumption.
    - rewrite <- (swap_involution v p x y t). unfold swap at 1.
      apply alpha_adpair with (permute p x y).
        + constructor.
            { intros z. apply permute_involution. }
            { intros z. apply permute_involution. }
            { intros z Hz. apply permute_not_xy.
                { intros Hzx. revert Hz. rewrite Hzx.
                  apply free_swap. assumption.
                }
                { intros Hzy. revert Hz. rewrite Hzy. rewrite swap_commute.
                  apply free_swap. assumption.
                }
            }
        + assumption.
Qed.

(* Attempting to prove the transitivity of alpha-equivalence    *)
(* directly leads to the common problem of having an induction  *)
(* hypothesis which is too weak to successfully complete an     *)
(* induction proof. So we focus on the stronger result below.   *)
(* The proof fundamentally relies on the alpha_adpair_swap      *)
(* lemma, which itself relies on alpha_adpair.                  *)

Lemma alpha_tran_ : forall (v:Type) (p:Eq v) (t t' s: P v),
    alpha p t t' -> alpha p t s <-> alpha p t' s.
Proof.
    intros v p t t' s H. revert s.
    induction H; intros s.
    - split; intros H'; assumption.
    - split; intros H'; inversion H'; constructor; subst.
        + apply IHalpha1. assumption.
        + apply IHalpha2. assumption.
        + apply IHalpha1. assumption.
        + apply IHalpha2. assumption.
    - split; intros H'; inversion H'; constructor; subst.
        + apply IHalpha. assumption.
        + assumption.
        + assert (Fr p t1' = Fr p t1) as F.
            { apply alpha_free. apply IHalpha. apply alpha_refl. }
          rewrite F. assumption.
        + apply alpha_swap. apply alpha_sym. apply IHalpha.
          apply alpha_sym. apply alpha_swap. assumption.
        + apply IHalpha. assumption.
        + assumption.
        + assert (Fr p t1 = Fr p t1') as F.
            { apply alpha_free. apply IHalpha. apply alpha_refl. }
          rewrite F. assumption.
        + apply alpha_swap. apply alpha_sym. apply IHalpha.
          apply alpha_sym. apply alpha_swap. assumption.
    - split; intros H'; inversion H'; subst.
        + constructor.
            { intros E. apply H. symmetry. assumption. }
            { apply (alpha_free_swap v p x y t1 t1').
                { apply IHalpha. apply alpha_refl. }
                { assumption. }
            }
            { apply alpha_swap. apply alpha_sym. apply IHalpha.
              rewrite (swap_commute v p y x).
              apply (alpha_injective v v p p).
                { apply permute_injective. }
                { assumption. }
            }

        + rename y0 into z. destruct (p y z) as [Hyz|Hyz]; subst.
            { constructor. apply IHalpha. apply alpha_sym. assumption. }
            { constructor.
                { assumption. }
                { rewrite (alpha_free v p t1' (swap p x y t1)).
                    { rewrite free_permute.
                      rewrite <- (permute_not_xy v p x y z).
                        { apply injective_not_in.
                            { apply inj_is_inj_on_list.
                              apply permute_injective.
                            }
                            { assumption. }
                        }
                        { intros E. apply H4. symmetry. assumption. }
                        { intros E. apply Hyz. symmetry. assumption. }
                    }
                    { assumption. }
                }
                { rename t1'0 into t0. rename t1' into t2.
                  apply alpha_swap. apply alpha_sym.
                  apply IHalpha. apply alpha_swap.
                  apply alpha_sym. apply (alpha_adpair_swap v p x y).
                    { rewrite <- (permute_not_xy v p y z x) at 1.
                        { rewrite free_permute.
                          apply injective_not_in.
                            { apply inj_is_inj_on_list.
                              apply permute_injective.
                            }
                            { apply free_swap. assumption. }
                        }
                        { assumption. }
                        { assumption. }
                    }
                    { apply free_swap.
                      rewrite <- (permute_not_xy v p x y z) at 1.
                        { rewrite free_permute.
                          apply injective_not_in.
                            { apply inj_is_inj_on_list.
                              apply permute_injective.
                            }
                            { assumption. }
                        }
                        { apply neq_sym. assumption. }
                        { apply neq_sym. assumption. }
                    }
                    { rewrite swap_thrice; assumption. }
                }
            }
        + constructor; try (assumption).
          apply alpha_sym. apply IHalpha. assumption.
        + rename y0 into z. destruct (p x z) as [Hxz|Hxz]; subst.
            { constructor. rewrite <- (swap_involution v p z y t1).
              apply alpha_swap, IHalpha, alpha_sym, alpha_swap.
              rewrite swap_commute. assumption.
            }
            { constructor.
                { assumption. }
                { apply alpha_swap in H1.
                  rewrite <- (alpha_free v p (swap p x y t1') t1).
                    { rewrite free_permute.
                      rewrite <- (permute_not_xy v p x y z).
                        { apply injective_not_in.
                            { apply inj_is_inj_on_list, permute_injective. }
                            { assumption. }
                        }
                        { apply neq_sym. assumption. }
                        { apply neq_sym. assumption. }
                    }
                   assumption.
                }
                { rename t1'0 into t0. rename t1' into t2.
                  apply alpha_swap. rewrite swap_commute.
                  apply (alpha_injective_swap v p x y).
                  apply alpha_sym, IHalpha, alpha_sym.
                  apply (alpha_adpair_swap v p z x).
                    { assumption. }
                    { rewrite (alpha_free v p t2 (swap p x y t1)).
                        { apply (free_swap v p x y). assumption. }
                        { assumption. }
                    }
                    { apply alpha_swap. rewrite swap_thrice.
                        { apply alpha_swap. rewrite swap_commute. assumption. }
                        { apply neq_sym. assumption. }
                        { assumption. }
                    }
                }
            }
Qed.

(* The alpha-equivalence relation is transitive                 *)
Lemma alpha_tran : forall (v:Type) (p:Eq v) (t1 t2 t3:P v),
    alpha p t1 t2 -> alpha p t2 t3 -> alpha p t1 t3.
Proof.
    intros v p t1 t2 t3 H12 H23.
    apply (alpha_tran_ v p t1 t2 t3); assumption.
Qed.


Require Import List.
Require Import Program.

Lemma exists_Forall2_fw A B (R : A -> B -> Prop) x1 l1 l2 : In x1 l1 -> Forall2 (fun x1 x2 => R x1 x2) l1 l2 ->
    exists x2, R x1 x2 /\ In x2 l2.
  revert l2.
  induction l1.
    easy.
  destruct l2.
    easy.
  intros.
  dependent destruction H0.
  destruct H.
    exists b.
    split.
      rewrite <- H.
      auto.
    left.
    auto.
  destruct (IHl1 l2); auto.
  exists x.
  destruct H2.
  split.
    auto.
  right.
  auto.
Qed.

Lemma exists_Forall2_bw A B (R : A -> B -> Prop) x2 l1 l2 : In x2 l2 -> Forall2 (fun x1 x2 => R x1 x2) l1 l2 ->
    exists x1, R x1 x2 /\ In x1 l1.
  revert l1.
  induction l2.
    easy.
  destruct l1.
    easy.
  intros.
  dependent destruction H0.
  destruct H.
    exists a0.
    split.
      rewrite <- H.
      auto.
    left.
    auto.
  destruct (IHl2 l1); auto.
  exists x.
  destruct H2.
  split.
    auto.
  right.
  auto.
Qed.

Lemma Forall2_map_com A B C D (R : C -> D -> Prop) (F1 : A -> C) (F2 : B -> D) l1 l2 :
    Forall2 R (map F1 l1) (map F2 l2) <-> Forall2 (fun x1 x2 => R (F1 x1) (F2 x2)) l1 l2.
  split; intro.
    dependent induction H.
      destruct l1; try easy.
      destruct l2; try easy.
    destruct l1; try easy.
    destruct l2; try easy.
    simplify_eq x1.
    simplify_eq x.
    intros.
    apply Forall2_cons.
      rewrite <- H1.
      rewrite <- H3.
      auto.
    auto.
  dependent induction H.
    apply Forall2_nil.
  apply Forall2_cons; auto.
Qed.

Lemma Forall2_self A (R : A -> A -> Prop) l : (forall x, In x l -> R x x) -> Forall2 (fun x1 x2 => R x1 x2) l l.
  rewrite <- Forall_forall.
  induction 1.
    easy.
  apply Forall2_cons; easy.
Qed.

Lemma Forall2_map A B C (R : B -> C -> Prop) (F1 : A -> B) (F2 : A -> C) l :
    (forall x, In x l -> R (F1 x) (F2 x)) -> Forall2 R (map F1 l) (map F2 l).
  rewrite <- Forall_forall.
  intro.
  dependent induction H.
    apply Forall2_nil.
  apply Forall2_cons; auto.
Qed.

Lemma repeat_app_com A (x : A) n1 n2 : repeat x n1 ++ repeat x n2 = repeat x (n1 + n2).
  induction n1; auto.
  simpl.
  rewrite IHn1.
  auto.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_congruencetransitive.

Section Euclid.

Context `{Ax1:euclidean_neutral}.

Lemma lemma_lessthancongruence2 :
   forall A B C D E F,
   Lt A B C D -> Cong A B E F ->
   Lt E F C D.
Proof.
intros.
let Tf:=fresh in
assert (Tf:exists G, (BetS C G D /\ Cong C G A B)) by (conclude_def Lt );destruct Tf as [G];spliter.
assert (Cong C G E F) by (conclude lemma_congruencetransitive).
assert (Lt E F C D) by (conclude_def Lt ).
close.
Qed.

End Euclid.


Require Import Coq.NArith.NArith.
Open Scope N_scope.
Require Import Frap.Frap.
Require Import Pset2.
Import Pset2.Impl.

Notation "x !" := (fact x) (at level 12, format "x !"). (* local in Pset2 *)

(* This file demonstrates a number of useful Coq tactics.  Step though the
   examples, and check Coq's reference manual or ask us in office hours if
   you're confused about any of these tactics.

   There are no exercises to complete in this file, just neat examples; feel
   free to work on it at your pace over multiple psets and to refer to it at
   later points; no need to go through it all at once.  *)

(* The tactic we introduce in each example is underlined like this. *)
                                             (********************)

Parameter whatever: Prop.

(* ‘apply’ matches the conclusion of a theorem to the current goal, then
   replaces it with one subgoal per premise of that theorem: *)

Goal forall (P Q R: Prop) (H1: P) (H2: Q) (IH: P -> Q -> R), R.
Proof.
  simplify.
  apply IH.
 (********)
Abort.

(* Apply works with implications (`A -> B`) but also with equivalences, where
   it tries to pick the right direction based on the goal: *)
Goal forall (n m k: N), n = m.
Proof.
  simplify.
  Check N.mul_cancel_r.

  (* Careful: apply only works if it's clear how the theorem applies to your goal: *)
  Fail apply N.mul_cancel_r.
  (* Here, Coq wants to know the value of ‘p’ before it can apply the lemma; so,
     we use the ‘with’ for of ‘apply’ to supply it: *)
  apply N.mul_cancel_r with (p := n - k + 1).
 (****)               (****)
Abort.

(* Apply also works in hypotheses, where it tuns premises into conclusions: *)
Goal forall (n m k: N), n = m -> whatever.
Proof.
  simplify.
  apply N.mul_cancel_r with (p := n - k + 1) in H.
 (*****)              (****)                (**)
Abort.

Goal forall (n m k: N), n - k + 1 <> 0 -> n = m -> whatever.
Proof.
  simplify.

  (* Specifying parameters by hand is not always convenient, so we can ask Coq
     to create placeholders instead, to be filled later: *)
  eapply N.mul_cancel_r in H0.
 (******)              (**)
  2: { (* This ‘2:’ notation means: operate on the second goal *)
    apply H.
  } (* … and the curly braces delimit a subproof. *)
Abort.

Goal forall (P Q R S: Prop), (P -> S) -> (R -> S) -> P \/ Q \/ R -> S.
Proof.
  simplify.
  cases H1. (* You are familiar with ‘cases’ from pset 1. *)
 (*****)
  - apply H. apply H1.
  - admit. (* ‘admit’ is just like ‘Admitted’ but for a single goal *)
   (*****)
  - apply H0. apply H1.
Fail Qed. (* But if you use ‘admit’, no ‘Qed’ for you! *)
Admitted.

(* Here is a convenient pattern that you will be familiar with from math
   classes.  It's called a “cut”.  We state an intermediate fact and prove it
   as part of a larger proof. *)

Goal forall (f : N -> N) (count : N)
       (IHcount : forall i start : N, i < count ->
                                 ith i (seq f count start) = f (start + i))
       (i start : N)
       (H : i < count + 1),
  ith i (f start :: seq f count (start + 1)) = f (start + i).
Proof.
  simplify.

  (* ‘assert’ introduces the fact that we want to prove, then uses *)
  assert (i = 0 \/ 0 < i) as A. { (* the ‘as’ clause to name the resulting fact *)
 (******)                (**)
    linear_arithmetic.          (* The proof of the lemma comes first. *)
  }
  cases A.                      (* Then we get to use the lemma itself. *)
  - subst. (* ‘subst’ rewrites all equalities. *)
   (*****)  (* or "subst i" for just one var *)
    simplify. admit.
  - (* Another assertion! This time we fit the whole proof in a ‘by’ clause. *)
    assert (i = i - 1 + 1) as E by linear_arithmetic.
   (******)                    (**)
    rewrite E.
    unfold_recurse ith (i - 1).
Abort.

Goal forall (n x0 k: N),
    0 < k ->
    k + 1 < n ->
    n! = x0 * ((n - (k - 1))! * (k - 1)!) ->
    whatever.
Proof.
  intros n m.
 (******)
  (* ‘simplify’ takes care of moving variables into the “context” above the
     line, but ‘intros’ gives finer grained control and lets you name
     hypotheses.  Users of Proof General with company-coq can type ‘intros!’ to
     get names automatically inserted. *)
  intros. (* A plain ‘intros’ takes care of all remaining variables. *)
  (******)

  (* Sometimes we want to say “a = b, so replace all ‘a’s with ‘b’s.”.  Replace
     is the perfect tactic for these cases; it's like ‘assert’ followed by
     ‘rewrite’. *)
  replace (n - (k - 1)) with (n - k + 1) in H1 by linear_arithmetic.
 (*******)             (****)           (**)  (**)
  (* "in" and "by" are optional *)
  unfold_recurse fact (n - k).
Abort.

Goal forall (P Q R: Prop) (H0: Q) (x: N) (H: forall (a b: N), P -> Q -> a < b -> R), whatever.
Proof.
  simplify.
  (* Often you have a general hypothesis, and you want to make it more specific
     to your case.  Then, ‘specialize’ is the tactic you want: *)
  specialize H with (b := x).
 (**********) (****)
  assert (3 < x) by admit.
  specialize H with (2 := H0) (3 := H1).
Abort.

Goal forall (f : N -> N) (start : N),
    f start = f (start + 0).
Proof.
  simplify.

  (* We have seen ‘apply’ earlier, which applies a theorem ending with an
     implication to a complete goal.  ‘rewrite’ takes theorems ending in an
     equality and replaces matching subterms of the goal according to that
     equality: *)
  rewrite N.add_0_r.
 (*******)
  (* Options like "with (a := 2)", "in H", "by tactic" also work! *)
  equality.
Abort.

Goal forall (f : N -> N) (start : N),
    f start = f (start + 0).
Proof.
  simplify.
  (* Alternatively, sometimes, it helps to apply the principle that, if two
     function arguments match, then the function calls themselves match: *)
  f_equal.
 (*******)
  linear_arithmetic.
Abort.

Goal forall (f : N -> N) (start : N),
    f start = f (start + 0).
Proof.
  simplify.
  (* How many other ways can we find to deal with this theorem? *)
  assert (start + 0 = start) as E by linear_arithmetic.
  rewrite E.
Abort.

Goal forall (A B: Type) (f: A -> B) (a1 a2 a3: A),
    Some a1 = Some a2 ->
    Some a2 = Some a3 ->
    f a3 = f a1.
Proof.
  (* ‘simplify’ is a favorite of this class, which does all sorts of small goal
     reorganization to make things more readable. *)
  simplify.

  (* ‘invert’ is another favorite: it “replaces hypothesis H with other facts that can be deduced from the structure of H's statement”.

     Specifically, it looks at the structure of the arguments passed to the
     constructor of inductive types appearing in H and deduces equalities from
     that and then substitutes the equalities.  It's also particularly useful
     for inductive ‘Prop’s, which we will see later in this class. *)
  invert H. (* Watch what happens carefully in this example *)
 (******)
  invert H0.
  equality.
Abort.

Goal forall (A B: Type) (f: A -> B) (a1 a2 a3: A),
    Some a1 = Some a2 ->
    Some a2 = Some a3 ->
    f a3 = f a1.
Proof.
  simplify.
  equality. (* Of course, ‘equality’ can do all the work for us here. *)
 (********)
Abort.

Goal forall (a1 a2 b1 b2: N) (l1 l2: list N),
    a1 :: b1 :: l1 = a2 :: b2 :: l2 ->
    a1 = a2 /\ b1 = b2 /\ l1 = l2.
Proof.
  simplify.
  (* ‘invert’ works at arbitrary depth, btw: *)
  invert H.
 (******)
Abort.

(* If you ever end up with contradictory hypotheses, you'll want to apply the
   pompously named “ex falso quodlibet” principle (also known under the
   scary-sounding name of “principle of explosion”), through the aptly named
   ‘exfalso’ tactic: *)
Goal forall (P: Prop) (a b: N),
    (a < b -> ~P) ->
    P ->
    whatever.
Proof.
  simplify.
  assert (a < b \/ b <= a) as C by linear_arithmetic. cases C.
  - exfalso.
   (*******)
    unfold not in H.
    apply H.
    all: assumption.
Abort.

(* Contradictions can take many forms; a common one is Coq is an impossible equality between two constructors; here the empty list ‘[]’ and a non-empty list ‘a :: l’. *)
Goal forall (a : N) (l : list N),
    a :: l = [] ->
    whatever.
Proof.
  simplify.
  discriminate.
 (************)
Abort.

Goal forall (P Q R S T: Prop), (P \/ Q -> T) -> (R \/ S -> T) -> P \/ S -> T.
Proof.
  simplify.
  cases H1.
  - apply H. left. assumption.
  - apply H0. right. assumption.
Abort.

(* Here are some more interesting tactics to look into along your Coq journey.
   Happy proving!

   - constructor, econstructor
   - eassumption
   - eexists
   - first_order
   - induct
   - left, right
   - trivial
   - transitivity
   - symmetry
*)

(* References:

   - FRAP book Appendix A.2. Tactic Reference (http://adam.chlipala.net/frap/frap_book.pdf)
   - Coq Reference Manual, Chapter on Tactics (https://coq.inria.fr/refman/proof-engine/tactics.html)
*)


(*
        #####################################################
        ###  PLEASE DO NOT DISTRIBUTE SOLUTIONS PUBLICLY  ###
        #####################################################
*)
Require Turing.Util.
Require Import Coq.Lists.List.
Import ListNotations.

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

(**

Study the definition of [Turing.Util.pow] and [Turing.Util.pow1]
and then show that [Turing.Util.pow1] can be formulated in terms of
[Turing.Util.pow].
Material: https://gitlab.com/cogumbreiro/turing/blob/master/src/Util.v

 *)
Theorem ex1:
  forall (A:Type) (x:A) n, Util.pow [x] n = Util.pow1 x n.
Proof.
  intros.
  induction n.
  - simpl.
    reflexivity.
  - simpl.
    rewrite -> IHn.
    reflexivity.
Qed.

(**

Study recursive definition of [List.In] and the inductive definition of
[List.Exists]. Then show that [List.In] can be formulated in terms
of [List.Exists].

Material: https://coq.inria.fr/library/Coq.Lists.List.html

 *)
Theorem ex2:
  forall (A:Type) (x:A) l, List.Exists (eq x) l <-> List.In x l.
Proof.
  intros.
  induction l.
  - simpl.
    apply Exists_nil.
  - simpl.
    rewrite -> Exists_cons.
    rewrite <- IHl.
    split.
    + simpl.
      intros.
      inversion H.
      * simpl.
        subst.
        apply H.
      * simpl.
        intuition.
    + simpl.
      intros.
      intuition.
Qed.

(**

Create an inductive relation that holds if, and only if, element 'x'
appears before element 'y' in the given list.
We can define `succ` inductively as follows:

                                (x, y) succ l
-----------------------R1     ------------------R2
(x, y) succ x :: y :: l       (x, y) succ z :: l

Rule R1 says that x succeeds y in the list that starts with [x, y].

Rule R2 says that if x succeeds y in list l then x succeeds y in a list
the list that results from adding z to list l.

 *)

Inductive succ {X : Type} (x:X) (y:X): list X -> Prop :=
  (* TODO: FILL THIS IN AND REMOVE THIS COMMENT *)
(*  Lemma nil_not: ~ In [] Vowel.*)
  | R1 : forall (l: list X), succ x y (x :: y :: l)
  | R2 : forall (z:X) (l:list X), succ x y l -> succ x y (z::l).

Theorem succ1:
    (* Only one of the following propositions is provable.
       Replace 'False' by the only provable proposition and then prove it:
     1) succ 2 3 [1;2;3;4]
     2) ~ succ 2 3 [1;2;3;4]
     *)
    succ 2 3 [1;2;3;4].
Proof.
  simpl.
  apply R2.
  apply R1.
Qed.

Theorem succ2:
    (* Only one of the following propositions is provable.
       Replace 'False' by the only provable proposition and then prove it:
     1) succ 2 3 []
     2) ~ succ 2 3 []
     *)
    ~ succ 2 3 [].
Proof.
  simpl.
  unfold not.
  intros.
  inversion H.
Qed.

Theorem succ3:
    (* Only one of the following propositions is provable.
       Replace 'False' by the only provable proposition and then prove it:
     1) succ 2 4 [1;2;3;4]
     2) ~ succ 2 4 [1;2;3;4]
     *)
    ~ succ 2 4 [1;2;3;4].
Proof.
  simpl.
  unfold not.
  intros.
  inversion H.
  inversion H1.
  inversion H4.
  inversion H7.
  inversion H10.
Qed.

Theorem succ4:
  forall (X:Type) (x y : Type), succ x y [x;y].
Proof.
  simpl.
  intros.
  apply R1.
Qed.

Theorem ex3:
  forall (X:Type) (l1 l2:list X) (x y:X), succ x y (l1 ++ (x :: y :: l2)).
Proof.
  simpl.
  intros.
  simpl.
  induction l1.
  - simpl.
    induction l2.
    + simpl.
      apply R1.
    + simpl.
      apply R1.
  - simpl.
    apply R2.
    apply IHl1.
Qed.

Theorem ex4:
  forall (X:Type) (x y:X) (l:list X), succ x y l -> exists l1 l2, l1 ++ (x:: y:: l2) = l.
Proof.
  simpl.
  intros.
  induction H.
  - simpl.
    exists [].
    exists l.
    simpl.
    reflexivity.
  - simpl.
    inversion IHsucc.
    inversion H0.
    + simpl.
      apply R2.
      * simpl.
        intuition.
      apply R1.
    destruct H0.
    subst.
Admitted.