(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(***********************************************************************
    Proof of Bertrand's conjecture: Partition.v
                                         Laurent.Thery@inria.fr (2002)
  *********************************************************************)

From Coq Require Import Div2 Even Wf_nat Arith ArithRing List.
From Bertrand Require Import Bertrand.

(*** All these theorems are in coq 8.16 *)
Lemma even_double n : Nat.Even n -> n = Nat.double (Nat.div2 n).
Proof.
intros [x ->]; rewrite Nat.div2_double; unfold Nat.double; ring.
Qed.

Lemma even_mul_l n m : Nat.Even n -> Nat.Even (n * m).
Proof.
intros [x ->]; exists (x * m); ring.
Qed.

Lemma odd_add_even_inv_r  n m : Nat.Odd (n + m) -> Nat.Odd n -> Nat.Even m.
Proof.
intros [x Hmn] [y Hn]; exists (x - y).
rewrite Nat.mul_sub_distr_l, <- Nat.sub_succ.
rewrite <- Nat.add_1_r, <- Hmn, <- Nat.add_1_r, <- Hn.
rewrite Nat.add_comm, Nat.add_sub; auto.
Qed.

Lemma odd_add_odd_inv_r n m :  Nat.Odd (n + m) -> Nat.Even n -> Nat.Odd m.
Proof.
destruct m as [|m].
rewrite Nat.add_0_r; intros; case (Nat.Even_Odd_False n); auto.
intros [x Hmn] [y Hn]; exists (x - y).
rewrite Nat.mul_sub_distr_l, <- Nat.sub_succ.
rewrite <- (Nat.add_1_r (2 * x)), <- Hmn, <- Hn.
rewrite <- (Nat.add_succ_comm n), (Nat.add_comm (S n)).
rewrite Nat.add_sub, Nat.add_1_r; auto.
Qed.

(***  *)

Theorem prime_2 : forall p : nat, prime p -> p = 2 \/ Nat.Odd p.
Proof.
intros p H.
case (Nat.Even_or_Odd p); auto; intros H1; left.
case H; intros H2 H3; apply H3; auto with arith.
exists (Nat.div2 p); auto with arith.
apply trans_equal with (Nat.double (Nat.div2 p)); auto with arith.
rewrite <- even_double; auto.
unfold Nat.double in |- *; ring.
Qed.

Theorem lt_mult_inv : forall a b c : nat, a * b < a * c -> b < c.
Proof.
intros a; case a.
intros b c H1; inversion H1.
intros a1 b c H; case (Nat.le_gt_cases c b); auto; intros H1.
absurd (S a1 * c <= S a1 * b); auto with arith.
Qed.

Fixpoint bertrand_fun_aux (n m : nat) {struct m} : nat :=
  match primeb n with
  | true => n
  | false => match m with
             | O => 0
             | S m1 => bertrand_fun_aux (S n) m1
             end
  end.

Theorem bertrand_fun_aux_correct :
 forall n m : nat,
 match bertrand_fun_aux n m with
 | O => forall p : nat, n <= p /\ p <= n + m -> ~ prime p
 | S p => n <= S p /\ S p <= n + m /\ prime (S p)
 end.
Proof.
intros n m; generalize n; elim m; simpl in |- *; auto; clear n m.
intros n; generalize (primeb_correct n); case (primeb n).
case n; simpl in |- *; auto with arith.
rewrite <- plus_n_O; intros H p (H1, H2); replace p with n;
 try apply Nat.le_antisymm; auto with arith.
intros m Rec n.
generalize (primeb_correct n); case (primeb n); auto with arith.
case n; simpl in |- *; auto with arith.
intros H; generalize (Rec (S n)); case (bertrand_fun_aux (S n) m);
 auto with arith.
intros H0 p (H1, H2).
case (proj1 (Nat.lt_eq_cases _ _) H1); auto with arith.
intros H3; apply H0; auto with arith.
split; auto with arith.
rewrite Nat.add_succ_comm; auto.
intros H3; rewrite <- H3; auto.
intros n1 (H1, (H2, H3)); split; auto with arith; split; auto with arith.
rewrite <- Nat.add_succ_comm; auto with arith.
Qed.

Definition bertrand_fun :
  forall n : nat, {p : nat | 1 < n -> n < p /\ p < 2 * n /\ prime p}.
intros n; exists (bertrand_fun_aux (S n) (pred (pred n))).
intros H1; generalize (bertrand_fun_aux_correct (S n) (pred (pred n))).
case (bertrand_fun_aux (S n) (pred (pred n))).
intros H2; case (Bertrand n); auto.
intros p (H3, (H4, H5)).
absurd (prime p); auto with arith.
apply H2; split; auto with arith.
rewrite Nat.add_succ_comm, Nat.succ_pred_pos; auto with arith.
apply Nat.lt_succ_r.
rewrite plus_n_Sm; rewrite (Nat.lt_succ_pred 0 n); auto with arith.
replace (n + n) with (2 * n); auto with arith; ring.
intros p (H3, (H4, H5)).
split; auto with arith.
split; auto with arith.
replace (2 * n) with (S (S n + pred (pred n))); auto with arith.
rewrite Nat.add_succ_comm; rewrite (Nat.lt_succ_pred 0 (pred n)); auto with arith.
rewrite plus_n_Sm; rewrite (Nat.lt_succ_pred 0 n); auto with arith; ring.
Defined.

Definition Partition :
  forall n : nat,
  {f : nat -> nat |
  forall m : nat,
  1 <= m /\ m <= 2 * n ->
  f m <> m /\ f (f m) = m /\ (1 <= f m /\ f m <= 2 * n) /\ prime (f m + m)}.
intros n; pattern n in |- *; apply lt_wf_rec; clear n; intros n.
case n.
intros H; exists (fun x : nat => x).
intros m; rewrite <- mult_n_O; intros (H1, H2);
 (absurd (1 <= m); auto; inversion H2); auto with arith.
clear n; intros n Rec.
case (bertrand_fun (2 * S n)); auto with arith.
intros p Hp.
case Hp;
 [ simpl in |- *; rewrite <- plus_n_Sm; auto with arith
 | intros Hp1 (Hp2, Hp3) ].
cut (Nat.Even (2 * S n));
  [ intros Hn | apply even_mul_l; exists 1; auto].
cut (Nat.Even (pred (p - 2 * S n))); [ intros Heven | idtac ].
cut (Nat.div2 (pred (p - 2 * S n)) < S n); [ intros H4 | idtac ].
case (Rec (Nat.div2 (pred (p - 2 * S n))) H4).
intros f1 Rf1.
exists
 (fun x : nat =>
  match le_lt_dec x (2 * S n) with
  | left _ =>
      match le_lt_dec (p - 2 * S n) x with
      | left _ => p - x
      | right _ => f1 x
      end
  | right _ => 0
  end).
case Hp; auto with arith.
simpl in |- *; rewrite <- plus_n_Sm; auto with arith.
intros H1 (H2, H3).
intros m1 (H5, H6).
cut (m1 <= p);
 [ intros Hm1 | apply Nat.le_trans with (1 := H6); auto with arith ].
split.
case (le_lt_dec m1 (2 * S n)); intros H7; auto with arith.
case (le_lt_dec (p - 2 * S n) m1); intros H8; auto with arith.
2: case (Rf1 m1); auto.
2: split; auto.
case (prime_2 p); auto; intros H9.
absurd (p <= 2 * S n); auto with arith; rewrite H9; auto with arith.
replace 2 with (2 * 1) at 1 by auto; auto with arith.
red in |- *; intros H; apply (Nat.Even_Odd_False  p); auto with arith.
replace p with (2 * m1).
apply even_mul_l; exists 1; auto.
simpl in |- *; pattern m1 at 1 in |- *; rewrite <- H.
rewrite <- plus_n_O.
rewrite Nat.sub_add; auto.
cut (forall x : nat, 2 * x = Nat.double x);
 [ intros tmp; rewrite tmp | idtac ].
rewrite <- even_double; auto with arith.
generalize H8; case (p - 2 * S n); simpl in |- *; auto with arith.
intros x; simpl in |- *; unfold Nat.double in |- *; auto with arith.
case (le_lt_dec m1 (2 * S n)); intros H7; auto with arith.
case (le_lt_dec (p - 2 * S n) m1); intros H8; auto with arith.
case (le_lt_dec (p - m1) (2 * S n)); intros H9; auto with arith.
case (le_lt_dec (p - 2 * S n) (p - m1)); intros H10; auto with arith.
split.
apply Nat.add_sub_eq_l.
rewrite Nat.sub_add; auto with arith.
rewrite Nat.sub_add; auto with arith.
split; auto.
split; auto.
apply Nat.le_add_le_sub_r.
rewrite Nat.add_1_l.
apply Nat.le_succ_l.
apply Nat.le_lt_trans with (2 := H1); auto with arith.
absurd (2 * S n < m1); auto with arith.
apply Nat.add_lt_mono_l with (p := p).
pattern p at 1 in |- *; rewrite <- (Nat.sub_add m1); auto with arith.
rewrite (Nat.add_comm _ m1).
pattern p at 2 in |- *; rewrite <- (Nat.sub_add (2 * S n)); auto with arith.
rewrite (Nat.add_comm (p - _) (2 * S n)).
replace (m1 + (p - m1) + 2 * S n) with (2 * S n + (p - m1) + m1);
 auto with arith; ring.
absurd (m1 < p - 2 * S n); auto with arith.
apply Nat.add_lt_mono_l  with (p := 2 * S n); auto with arith.
rewrite (Nat.add_comm _ (_ - _)), Nat.sub_add; auto with arith.
rewrite <- (Nat.sub_add m1 p); auto with arith.
case (Rf1 m1); auto with arith.
split; auto with arith.
cut (forall x : nat, 2 * x = Nat.double x);
 [ intros tmp; rewrite tmp | idtac ].
rewrite <- even_double; auto with arith.
generalize H8; case (p - 2 * S n); simpl in |- *; auto with arith.
intros x; simpl in |- *; unfold Nat.double in |- *; auto with arith.
intros H9 (H10, ((H11, H12), H13)).
case (le_lt_dec (f1 m1) (2 * S n)); auto with arith.
case (le_lt_dec (p - 2 * S n) (f1 m1)); auto with arith.
intros H14; absurd (2 * Nat.div2 (pred (p - 2 * S n)) < f1 m1); auto with arith.
cut (forall x : nat, 2 * x = Nat.double x);
 [ intros tmp; rewrite tmp | idtac ].
rewrite <- even_double; auto with arith.
generalize H14; case (p - 2 * S n); simpl in |- *; auto with arith.
intros x; simpl in |- *; unfold Nat.double in |- *; auto with arith.
intros H14; absurd (2 * Nat.div2 (pred (p - 2 * S n)) < f1 m1); auto with arith.
cut (forall x : nat, 2 * x = Nat.double x);
 [ intros tmp; rewrite tmp | idtac ].
rewrite <- even_double; auto with arith.
apply Nat.lt_trans with (2 := H14).
apply Nat.succ_lt_mono.
rewrite Nat.succ_pred_pos; auto with arith.
apply Nat.lt_succ_r; auto with arith.
apply (fun p n m : nat => Nat.add_le_mono_l n m p) with (p := 2 * S n).
rewrite Nat.add_comm, Nat.sub_add; auto with arith.
replace (2 * S n + 2 * S n) with (2 * (2 * S n)); auto with arith; ring.
apply Nat.add_lt_mono_l with (p := 2 * S n); auto with arith.
rewrite (Nat.add_comm _ (p - 2 * S n)), Nat.sub_add; auto with arith.
rewrite <- plus_n_O; auto.
intros x; simpl in |- *; unfold Nat.double in |- *; auto with arith.
absurd (2 * S n < m1); auto with arith.
apply lt_mult_inv with (a := 2); auto with arith.
cut (forall x : nat, 2 * x = Nat.double x);
 [ intros tmp; rewrite tmp | idtac ].
rewrite <- even_double; auto with arith.
apply Nat.succ_lt_mono.
rewrite Nat.succ_pred_pos; auto with arith.
apply Nat.lt_succ_r; auto with arith.
apply (fun p n m : nat => Nat.add_le_mono_l n m p) with (p := 2 * S n).
rewrite Nat.add_comm, Nat.sub_add; auto with arith.
replace (2 * S n + 2 * S n) with (2 * (2 * S n)); auto with arith; ring.
apply Nat.add_lt_mono_l with (p := 2 * S n); auto with arith.
rewrite (Nat.add_comm _ (p - 2 * S n)), Nat.sub_add; auto with arith.
rewrite <- plus_n_O; auto.
intros x; simpl in |- *; unfold Nat.double in |- *; auto with arith.
apply (odd_add_even_inv_r 1); auto with arith.
change (Nat.Odd (S (pred (p - 2 * S n)))) in |- *.
rewrite Nat.succ_pred_pos.
apply (odd_add_odd_inv_r (2 * S n)); auto.
rewrite Nat.add_comm, Nat.sub_add; auto with arith.
case (prime_2 p); auto.
intros H9.
absurd (p <= 2 * S n); auto with arith.
rewrite H9; case n; simpl in |- *; auto with arith.
apply lt_minus_O_lt; auto.
exists 0; auto.
Defined.

Fixpoint make_partition_aux (f : nat -> nat) (n : nat) {struct n} :
 list (nat * nat) :=
  match n with
  | O => nil (A:=nat * nat)
  | S n1 =>
      match le_lt_dec (f n) n with
      | left _ => make_partition_aux f n1
      | right _ => (n, f n) :: make_partition_aux f n1
      end
  end.

Theorem make_partition_aux_correct :
 forall (n : nat) (f : nat -> nat),
 (forall i j : nat,
  In (i, j) (make_partition_aux f n) -> 1 <= i /\ i <= n /\ i < j /\ j = f i) /\
 (forall i : nat,
  1 <= i /\ i <= n /\ i < f i -> In (i, f i) (make_partition_aux f n)).
Proof.
intros n f; elim n; simpl in |- *; auto.
split.
intros i j H; elim H.
intros i (H1, (H2, H3)); absurd (0 < i); auto with arith.
intros n1 (Rec, Rec1); case (le_lt_dec (f (S n1)) (S n1)); simpl in |- *;
 auto.
intros H; split.
intros i j H1; case (Rec i j); auto.
intros H2 (H3, H4); auto with arith.
intros i (H1, (H2, H3)).
case (le_lt_eq_dec _ _ H2); auto with arith.
intros H4; absurd (f i <= i); auto with arith; rewrite H4; auto with arith.
intros H; split.
intros i j [H1| H1]; auto.
injection H1.
intros H2 H3; rewrite <- H2; rewrite <- H3; auto with arith.
case (Rec i j); auto.
intros H2 (H3, H4); auto with arith.
intros i (H1, (H2, H3)).
case (le_lt_eq_dec _ _ H2); auto with arith.
Qed.

Definition make_partition : nat -> list (nat * nat).
intros n; case (Partition n).
intros f1 Hf1.
exact (make_partition_aux f1 (2 * n)).
Defined.

(** make_partition:
    Create a partition of  1..2n in pairs such that the sum of each
    pair is a prime number
*)
Theorem make_partition_correct :
 forall n : nat,
 (forall i j k l : nat,
  In (i, j) (make_partition n) /\ In (k, l) (make_partition n) ->
  (i = k <-> j = l) /\ i <> l /\ j <> k) /\
 (forall i : nat,
  1 <= i /\ i <= 2 * n ->
  exists j : nat,
    In (i, j) (make_partition n) \/ In (j, i) (make_partition n)) /\
 (forall i j : nat,
  In (i, j) (make_partition n) ->
  (1 <= i /\ i <= 2 * n) /\ 1 <= j /\ j <= 2 * n) /\
 (forall i j : nat, In (i, j) (make_partition n) -> prime (i + j)).
Proof.
intros n; unfold make_partition in |- *.
case (Partition n).
intros f Hf; split.
intros i j k l (H1, H2).
case (make_partition_aux_correct (2 * n) f); intros HR1 HR2.
case (HR1 _ _ H1); intros H3 (H4, (H5, H6)).
case (HR1 _ _ H2); intros H7 (H8, (H9, H10)).
case (Hf i); auto with arith; intros H11 (H12, ((H13, H14), H15)).
case (Hf k); auto with arith; intros H16 (H17, ((H18, H19), H20)).
split; split.
intros H21; apply trans_equal with (1 := H6);
 apply trans_equal with (2 := sym_equal H10); apply f_equal with (f := f);
 auto with arith.
intros H21; apply trans_equal with (1 := sym_equal H12);
 apply trans_equal with (2 := H17); apply f_equal with (f := f);
 auto with arith; apply trans_equal with (1 := sym_equal H6);
 apply trans_equal with (1 := H21); auto.
red in |- *; intros H21; absurd (j <= i); auto with arith.
rewrite H6; rewrite H21; rewrite H10; rewrite H17; rewrite <- H10;
 auto with arith.
red in |- *; intros H21; absurd (l <= k); auto with arith.
rewrite H10; rewrite <- H21; rewrite H6; rewrite H12; rewrite <- H6;
 auto with arith.
split.
intros i (H1, H2); exists (f i).
case (make_partition_aux_correct (2 * n) f); intros HR1 HR2.
case (Nat.le_gt_cases i (f i)); intros H3.
case (le_lt_eq_dec _ _ H3); intros H4; auto with arith.
left; apply HR2; repeat (split; auto with arith).
case (Hf i); auto with arith.
intros H5; case H5; auto.
right; case (Hf i); auto with arith.
intros H4 (H5, ((H6, H7), H8)).
pattern i at 2 in |- *; rewrite <- H5.
apply HR2; repeat (split; auto with arith).
rewrite H5; auto.
split.
intros i j H1.
case (make_partition_aux_correct (2 * n) f); intros HR1 HR2.
case (HR1 _ _ H1).
intros H2 (H3, (H4, H5)); split; auto.
rewrite H5; case (Hf i); auto with arith.
intros H6 (H7, ((H8, H9), H10)); auto.
intros i j H1.
case (make_partition_aux_correct (2 * n) f); intros HR1 HR2.
case (HR1 _ _ H1).
intros H2 (H3, (H4, H5)); auto.
rewrite H5; auto.
case (Hf i); auto with arith.
rewrite (Nat.add_comm i); intuition.
Qed.


Require Import XR_Rabs.
Require Import XR_Rcase_abs.
Require Import XR_Ropp_plus_distr.
Require Import XR_Rplus_le_compat.
Require Import XR_Ropp_0.
Require Import XR_Ropp_le_contravar.

Local Open Scope R_scope.

Lemma Rabs_triang : forall a b:R, Rabs (a + b) <= Rabs a + Rabs b.
Proof.
  intros x y.
  unfold Rabs.
  destruct (Rcase_abs (x+y)) as [ hp | hp ] ;
  destruct (Rcase_abs x) as [ hx | hx ] ;
  destruct (Rcase_abs y) as [ hy | hy ].
  {
    rewrite Ropp_plus_distr.
    right.
    reflexivity.
  }
  {
    rewrite Ropp_plus_distr.
    apply Rplus_le_compat_l.
    apply Rle_trans with R0.
    {
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      exact hy.
    }
    { exact hy. }
  }
  {
    rewrite Ropp_plus_distr.
    apply Rplus_le_compat_r.
    apply Rle_trans with R0.
    {
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      exact hx.
    }
    { exact hx. }
  }
  {
    rewrite Ropp_plus_distr.
    apply Rplus_le_compat.
    {
      apply Rle_trans with R0.
      {
        rewrite <- Ropp_0.
        apply Ropp_le_contravar.
        exact hx.
      }
      { exact hx. }
    }
    {
      apply Rle_trans with R0.
      {
        rewrite <- Ropp_0.
        apply Ropp_le_contravar.
        exact hy.
      }
      { exact hy. }
    }
  }
  {
    apply Rplus_le_compat.
    {
      apply Rle_trans with R0.
      {
        left.
        exact hx.
      }
      {
        rewrite <- Ropp_0.
        apply Ropp_le_contravar.
        left.
        exact hx.
      }
    }
    {
      apply Rle_trans with R0.
      {
        left.
        exact hy.
      }
      {
        rewrite <- Ropp_0.
        apply Ropp_le_contravar.
        left.
        exact hy.
      }
    }
  }
  {
    apply Rplus_le_compat_r.
    apply Rle_trans with R0.
    {
      left.
      exact hx.
    }
    {
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      left.
      exact hx.
    }
  }
  {
    apply Rplus_le_compat_l.
    apply Rle_trans with R0.
    {
      left.
      exact hy.
    }
    {
      rewrite <- Ropp_0.
      apply Ropp_le_contravar.
      left.
      exact hy.
    }
  }
  {
    right.
    reflexivity.
  }
Qed.


(* (c) Copyright 2006-2016 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat fintype bigop finset.
From mathcomp
Require Import binomial fingroup morphism automorphism quotient gfunctor.

(******************************************************************************)
(*   This files contains the proofs of several key properties of commutators, *)
(* including the Hall-Witt identity and the Three Subgroup Lemma.             *)
(*   The definition and notation for both pointwise and set wise commutators  *)
(* ([~x, y, ...] and [~: A, B ,...], respectively) are given in fingroup.v    *)
(* This file defines the derived group series:                                *)
(*           G^`(0) ==  G                                                     *)
(*       G^`(n.+1) == [~: G^`(n), G^`(n)]                                     *)
(* as several classical results involve the (first) derived group G^`(1),     *)
(* such as the equivalence H <| G /\ G / H abelian <-> G^`(1) \subset H.      *)
(* The connection between the derived series and solvable groups will only be *)
(* established in nilpotent.v, however.                                       *)
(******************************************************************************)

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

Import GroupScope.

Definition derived_at_rec n (gT : finGroupType) (A : {set gT}) :=
  iter n (fun B => [~: B, B]) A.

(* Note: 'nosimpl' MUST be used outside of a section -- the end of section   *)
(* "cooking" destroys it.                                                    *)
Definition derived_at := nosimpl derived_at_rec.

Arguments derived_at n%N {gT} A%g.
Notation "G ^` ( n )" := (derived_at n G) : group_scope.

Section DerivedBasics.

Variables gT : finGroupType.
Implicit Type A : {set gT}.
Implicit Types G : {group gT}.

Lemma derg0 A : A^`(0) = A. Proof. by []. Qed.
Lemma derg1 A : A^`(1) = [~: A, A]. Proof. by []. Qed.
Lemma dergSn n A : A^`(n.+1) = [~: A^`(n), A^`(n)]. Proof. by []. Qed.

Lemma der_group_set G n : group_set G^`(n).
Proof. by case: n => [|n]; apply: groupP. Qed.

Canonical derived_at_group G n := Group (der_group_set G n).

End DerivedBasics.

Notation "G ^` ( n )" := (derived_at_group G n) : Group_scope.

Section Basic_commutator_properties.

Variable gT : finGroupType.
Implicit Types x y z : gT.

Lemma conjg_mulR x y : x ^ y = x * [~ x, y].
Proof. by rewrite mulKVg. Qed.

Lemma conjg_Rmul x y : x ^ y = [~ y, x^-1] * x.
Proof. by rewrite commgEr invgK mulgKV. Qed.

Lemma commMgJ x y z : [~ x * y, z] = [~ x, z] ^ y * [~ y, z].
Proof. by rewrite !commgEr conjgM mulgA -conjMg mulgK. Qed.

Lemma commgMJ x y z : [~ x, y * z] = [~ x, z] * [~ x, y] ^ z.
Proof. by rewrite !commgEl conjgM -mulgA -conjMg mulKVg. Qed.

Lemma commMgR x y z : [~ x * y, z] = [~ x, z] * [~ x, z, y] * [~ y, z].
Proof. by rewrite commMgJ conjg_mulR. Qed.

Lemma commgMR x y z : [~ x, y * z] = [~ x, z] * [~ x, y] * [~ x, y, z].
Proof. by rewrite commgMJ conjg_mulR mulgA. Qed.

Lemma Hall_Witt_identity x y z :
  [~ x, y^-1, z] ^ y * [~ y, z^-1, x] ^ z * [~ z, x^-1, y] ^ x = 1.
Proof. (* gsimpl *)
pose a x y z : gT := x * z * y ^ x.
suffices{x y z} hw_aux x y z: [~ x, y^-1, z] ^ y = (a x y z)^-1 * (a y z x).
  by rewrite !hw_aux 2!mulgA !mulgK mulVg.
by rewrite commgEr conjMg -conjgM -conjg_Rmul 2!invMg conjgE !mulgA.
Qed.

(* the following properties are useful for studying p-groups of class 2 *)

Section LeftComm.

Variables (i : nat) (x y : gT).
Hypothesis cxz : commute x [~ x, y].

Lemma commVg : [~ x^-1, y] = [~ x, y]^-1.
Proof.
apply/eqP; rewrite commgEl eq_sym eq_invg_mul invgK mulgA -cxz.
by rewrite -conjg_mulR -conjMg mulgV conj1g.
Qed.

Lemma commXg : [~ x ^+ i, y] = [~ x, y] ^+ i.
Proof.
elim: i => [|i' IHi]; first exact: comm1g.
by rewrite !expgS commMgJ /conjg commuteX // mulKg IHi.
Qed.

End LeftComm.

Section RightComm.

Variables (i : nat) (x y : gT).
Hypothesis cyz : commute y [~ x, y].
Let cyz' := commuteV cyz.

Lemma commgV : [~ x, y^-1] = [~ x, y]^-1.
Proof. by rewrite -invg_comm commVg -(invg_comm x y) ?invgK. Qed.

Lemma commgX : [~ x, y ^+ i] = [~ x, y] ^+ i.
Proof. by rewrite -invg_comm commXg -(invg_comm x y) ?expgVn ?invgK. Qed.

End RightComm.

Section LeftRightComm.

Variables (i j : nat) (x y : gT).
Hypotheses (cxz : commute x [~ x, y]) (cyz : commute y [~ x, y]).

Lemma commXXg : [~ x ^+ i, y ^+ j] = [~ x, y] ^+ (i * j).
Proof. by rewrite expgM commgX commXg //; apply: commuteX. Qed.

Lemma expMg_Rmul : (y * x) ^+ i = y ^+ i * x ^+ i * [~ x, y] ^+ 'C(i, 2).
Proof.
rewrite -triangular_sum; symmetry.
elim: i => [|k IHk] /=; first by rewrite big_geq ?mulg1.
rewrite big_nat_recr //= addnC expgD !expgS -{}IHk !mulgA; congr (_ * _).
by rewrite -!mulgA commuteX2 // -commgX // [mulg y]lock 3!mulgA -commgC.
Qed.

End LeftRightComm.

End Basic_commutator_properties.

(***** Set theoretic commutators *****)
Section Commutator_properties.

Variable gT : finGroupType.
Implicit Type (rT : finGroupType) (A B C : {set gT}) (D G H K : {group gT}).

Lemma commG1 A : [~: A, 1] = 1.
Proof. by apply/commG1P; rewrite centsC sub1G. Qed.

Lemma comm1G A : [~: 1, A] = 1.
Proof. by rewrite commGC commG1. Qed.

Lemma commg_sub A B : [~: A, B] \subset A <*> B.
Proof. by rewrite comm_subG // (joing_subl, joing_subr). Qed.

Lemma commg_norml G A : G \subset 'N([~: G, A]).
Proof.
apply/subsetP=> x Gx; rewrite inE -genJ gen_subG.
apply/subsetP=> _ /imsetP[_ /imset2P[y z Gy Az ->] ->].
by rewrite -(mulgK [~ x, z] (_ ^ x)) -commMgJ !(mem_commg, groupMl, groupV).
Qed.

Lemma commg_normr G A : G \subset 'N([~: A, G]).
Proof. by rewrite commGC commg_norml. Qed.

Lemma commg_norm G H : G <*> H \subset 'N([~: G, H]).
Proof. by rewrite join_subG ?commg_norml ?commg_normr. Qed.

Lemma commg_normal G H : [~: G, H] <| G <*> H.
Proof. by rewrite /(_ <| _) commg_sub commg_norm. Qed.

Lemma normsRl A G B : A \subset G -> A \subset 'N([~: G, B]).
Proof. by move=> sAG; apply: subset_trans (commg_norml G B). Qed.

Lemma normsRr A G B : A \subset G -> A \subset 'N([~: B, G]).
Proof. by move=> sAG; apply: subset_trans (commg_normr G B). Qed.

Lemma commg_subr G H : ([~: G, H] \subset H) = (G \subset 'N(H)).
Proof.
rewrite gen_subG; apply/subsetP/subsetP=> [sRH x Gx | nGH xy].
  rewrite inE; apply/subsetP=> _ /imsetP[y Ky ->].
  by rewrite conjg_Rmul groupMr // sRH // mem_imset2 ?groupV.
case/imset2P=> x y Gx Hy ->{xy}.
by rewrite commgEr groupMr // memJ_norm (groupV, nGH).
Qed.

Lemma commg_subl G H : ([~: G, H] \subset G) = (H \subset 'N(G)).
Proof. by rewrite commGC commg_subr. Qed.

Lemma commg_subI A B G H :
  A \subset 'N_G(H) -> B \subset 'N_H(G) -> [~: A, B] \subset G :&: H.
Proof.
rewrite !subsetI -(gen_subG _ 'N(G)) -(gen_subG _ 'N(H)).
rewrite -commg_subr -commg_subl; case/andP=> sAG sRH; case/andP=> sBH sRG.
by rewrite (subset_trans _ sRG) ?(subset_trans _ sRH) ?commgSS ?subset_gen.
Qed.

Lemma quotient_cents2 A B K :
    A \subset 'N(K) -> B \subset 'N(K) ->
  (A / K \subset 'C(B / K)) = ([~: A, B] \subset K).
Proof.
move=> nKA nKB.
by rewrite (sameP commG1P trivgP) /= -quotientR // quotient_sub1 // comm_subG.
Qed.

Lemma quotient_cents2r A B K :
  [~: A, B] \subset K -> (A / K) \subset 'C(B / K).
Proof.
move=> sABK; rewrite -2![_ / _]morphimIdom -!quotientE.
by rewrite quotient_cents2 ?subsetIl ?(subset_trans _ sABK) ?commgSS ?subsetIr.
Qed.

Lemma sub_der1_norm G H : G^`(1) \subset H -> H \subset G -> G \subset 'N(H).
Proof.
by move=> sG'H sHG; rewrite -commg_subr (subset_trans _ sG'H) ?commgS.
Qed.

Lemma sub_der1_normal G H : G^`(1) \subset H -> H \subset G -> H <| G.
Proof. by move=> sG'H sHG; rewrite /(H <| G) sHG sub_der1_norm. Qed.

Lemma sub_der1_abelian G H : G^`(1) \subset H -> abelian (G / H).
Proof. by move=> sG'H; apply: quotient_cents2r. Qed.

Lemma der1_min G H : G \subset 'N(H) -> abelian (G / H) -> G^`(1) \subset H.
Proof. by move=> nHG abGH; rewrite -quotient_cents2. Qed.

Lemma der_abelian n G : abelian (G^`(n) / G^`(n.+1)).
Proof. by rewrite sub_der1_abelian // der_subS. Qed.

Lemma commg_normSl G H K : G \subset 'N(H) -> [~: G, H] \subset 'N([~: K, H]).
Proof. by move=> nHG; rewrite normsRr // commg_subr. Qed.

Lemma commg_normSr G H K : G \subset 'N(H) -> [~: H, G] \subset 'N([~: H, K]).
Proof. by move=> nHG; rewrite !(commGC H) commg_normSl. Qed.

Lemma commMGr G H K : [~: G, K] * [~: H, K] \subset [~: G * H , K].
Proof. by rewrite mul_subG ?commSg ?(mulG_subl, mulG_subr). Qed.

Lemma commMG G H K :
  H \subset 'N([~: G, K]) -> [~: G * H , K] = [~: G, K] * [~: H, K].
Proof.
move=> nRH; apply/eqP; rewrite eqEsubset commMGr andbT.
have nRHK: [~: H, K] \subset 'N([~: G, K]) by rewrite comm_subG ?commg_normr.
have defM := norm_joinEr nRHK; rewrite -defM gen_subG /=.
apply/subsetP=> _ /imset2P[_ z /imset2P[x y Gx Hy ->] Kz ->].
by rewrite commMgJ {}defM mem_mulg ?memJ_norm ?mem_commg // (subsetP nRH).
Qed.

Lemma comm3G1P A B C :
  reflect {in A & B & C, forall h k l, [~ h, k, l] = 1} ([~: A, B, C] :==: 1).
Proof.
have R_C := sameP trivgP commG1P.
rewrite -subG1 R_C gen_subG -{}R_C gen_subG.
apply: (iffP subsetP) => [cABC x y z Ax By Cz | cABC xyz].
  by apply/set1P; rewrite cABC // !mem_imset2.
by case/imset2P=> _ z /imset2P[x y Ax By ->] Cz ->; rewrite cABC.
Qed.

Lemma three_subgroup G H K :
  [~: G, H, K] :=: 1 -> [~: H, K, G] :=: 1-> [~: K, G, H] :=: 1.
Proof.
move/eqP/comm3G1P=> cGHK /eqP/comm3G1P cHKG.
apply/eqP/comm3G1P=> x y z Kx Gy Hz; symmetry.
rewrite -(conj1g y) -(Hall_Witt_identity y^-1 z x) invgK.
by rewrite cGHK ?groupV // cHKG ?groupV // !conj1g !mul1g conjgKV.
Qed.

Lemma der1_joing_cycles (x y : gT) :
  let XY := <[x]> <*> <[y]> in let xy := [~ x, y] in
  xy \in 'C(XY) -> XY^`(1) = <[xy]>.
Proof.
rewrite joing_idl joing_idr /= -sub_cent1 => /norms_gen nRxy.
apply/eqP; rewrite eqEsubset cycle_subG mem_commg ?mem_gen ?set21 ?set22 //.
rewrite der1_min // quotient_gen -1?gen_subG // quotientU abelian_gen.
rewrite /abelian subUset centU !subsetI andbC centsC -andbA -!abelianE.
rewrite !quotient_abelian ?(abelianS (subset_gen _) (cycle_abelian _)) //=.
by rewrite andbb quotient_cents2r ?genS // /commg_set imset2_set1l imset_set1.
Qed.

Lemma commgAC G x y z : x \in G -> y \in G -> z \in G ->
  commute y z -> abelian [~: [set x], G] -> [~ x, y, z] = [~ x, z, y].
Proof.
move=> Gx Gy Gz cyz /centsP cRxG; pose cx' u := [~ x^-1, u].
have xR3 u v: [~ x, u, v] = x^-1 * (cx' u * cx' v) * x ^ (u * v).
  rewrite mulgA -conjg_mulR conjVg [cx' v]commgEl mulgA -invMg.
  by rewrite -mulgA conjgM -conjMg -!commgEl.
suffices RxGcx' u: u \in G -> cx' u \in [~: [set x], G].
  by rewrite !xR3 {}cyz; congr (_ * _ * _); rewrite cRxG ?RxGcx'.
move=> Gu; suffices/groupMl <-: [~ x, u] ^ x^-1 \in [~: [set x], G].
  by rewrite -commMgJ mulgV comm1g group1.
by rewrite memJ_norm ?mem_commg ?set11 // groupV (subsetP (commg_normr _ _)).
Qed.

(* Aschbacher, exercise 3.6 (used in proofs of Aschbacher 24.7 and B & G 1.10 *)
Lemma comm_norm_cent_cent H G K :
    H \subset 'N(G) -> H \subset 'C(K) -> G \subset 'N(K) ->
  [~: G, H] \subset 'C(K).
Proof.
move=> nGH /centsP cKH nKG; rewrite commGC gen_subG centsC.
apply/centsP=> x Kx _ /imset2P[y z Hy Gz ->]; red.
rewrite mulgA -[x * _]cKH ?groupV // -!mulgA; congr (_ * _).
rewrite (mulgA x) (conjgC x) (conjgCV z) 3!mulgA; congr (_ * _).
by rewrite -2!mulgA (cKH y) // -mem_conjg (normsP nKG).
Qed.

Lemma charR H K G : H \char G -> K \char G -> [~: H, K] \char G.
Proof.
case/charP=> sHG chH /charP[sKG chK]; apply/charP.
by split=> [|f infj Gf]; [rewrite comm_subG | rewrite morphimR // chH // chK].
Qed.

Lemma der_char n G : G^`(n) \char G.
Proof. by elim: n => [|n IHn]; rewrite ?char_refl // dergSn charR. Qed.

Lemma der_sub n G : G^`(n) \subset G.
Proof. by rewrite char_sub ?der_char. Qed.

Lemma der_norm n G : G \subset 'N(G^`(n)).
Proof. by rewrite char_norm ?der_char. Qed.

Lemma der_normal n G : G^`(n) <| G.
Proof. by rewrite char_normal ?der_char. Qed.

Lemma der_subS n G : G^`(n.+1) \subset G^`(n).
Proof. by rewrite comm_subG. Qed.

Lemma der_normalS n G : G^`(n.+1) <| G^`(n).
Proof. by rewrite sub_der1_normal // der_subS. Qed.

Lemma morphim_der rT D (f : {morphism D >-> rT}) n G :
   G \subset D -> f @* G^`(n) = (f @* G)^`(n).
Proof.
move=> sGD; elim: n => // n IHn.
by rewrite !dergSn -IHn morphimR ?(subset_trans (der_sub n G)).
Qed.

Lemma dergS n G H : G \subset H -> G^`(n) \subset H^`(n).
Proof. by move=> sGH; elim: n => // n IHn; apply: commgSS. Qed.

Lemma quotient_der n G H : G \subset 'N(H) -> G^`(n) / H = (G / H)^`(n).
Proof. exact: morphim_der. Qed.

Lemma derJ G n x : (G :^ x)^`(n) = G^`(n) :^ x.
Proof. by elim: n => //= n IHn; rewrite !dergSn IHn -conjsRg. Qed.

Lemma derG1P G : reflect (G^`(1) = 1) (abelian G).
Proof. exact: commG1P. Qed.

End Commutator_properties.

Arguments derG1P {gT G}.

Lemma der_cont n : GFunctor.continuous (@derived_at n).
Proof. by move=> aT rT G f; rewrite morphim_der. Qed.

Canonical der_igFun n := [igFun by der_sub^~ n & der_cont n].
Canonical der_gFun n := [gFun by der_cont n].
Canonical der_mgFun n := [mgFun by dergS^~ n].

Lemma isog_der (aT rT : finGroupType) n (G : {group aT}) (H : {group rT}) :
  G \isog H -> G^`(n) \isog H^`(n).
Proof. exact: gFisog. Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Module_util.
Require Export Sub_module.
Require Export Group_kernel.
(** Title "Kernel and image of a module homomorphism." *)
Section Def.
Variable R : RING.
Variable Mod Mod2 : MODULE R.
Variable f : Hom Mod Mod2.

Definition Ker : submodule Mod.
apply (Build_submodule (R:=R) (M:=Mod) (submodule_subgroup:=Ker f)).
simpl in |- *.
intros a x H'; try assumption.
apply Trans with (module_mult a (f x)); auto with algebra.
apply Trans with (module_mult a (monoid_unit (module_carrier Mod2)));
 auto with algebra.
Defined.

Definition coKer : submodule Mod2.
apply (Build_submodule (R:=R) (M:=Mod2) (submodule_subgroup:=coKer f)).
simpl in |- *.
intros a x H'; try assumption.
elim H'; intros x0 E; elim E; intros H'0 H'1; try exact H'1; clear E H'.
exists (module_mult a x0); split; [ try assumption | idtac ].
apply Trans with (module_mult a (f x0)); auto with algebra.
Defined.

Lemma Ker_prop :
 forall x : Mod, in_part x Ker -> Equal (f x) (monoid_unit Mod2).
auto with algebra.
Qed.

Lemma Ker_prop_rev :
 forall x : Mod, Equal (f x) (monoid_unit Mod2) -> in_part x Ker.
auto with algebra.
Qed.

Lemma coKer_prop : forall x : Mod, in_part (f x) coKer.
simpl in |- *.
intros x; exists x; split; [ idtac | try assumption ]; auto with algebra.
Qed.
End Def.
Hint Resolve Ker_prop coKer_prop: algebra.


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Strings.String.
From Coq Require Import Logic.Eqdep_dec.
From Coq Require Import Lia.
From PFPL Require Import PartialMap_Set.
From PFPL Require Import Definitions.
From PFPL Require Import Lemmas_Vars.
From PFPL Require Import Lemmas_Rename.
From PFPL Require Import Lemmas_Same_Structure.
From PFPL Require Import Induction_Expr.
From PFPL Require Import Lemmas_AlphaEquiv.
From PFPL Require Import Lemmas_Rename_AlphaEquiv.
From PFPL Require Import Lemmas_FreshRename.
From PFPL Require Import Lemmas_FreshRename_AlphaEquiv.
From PFPL Require Import Lemmas_Rename_FreshRename.
From PFPL Require Import Lemmas_Subst.
From PFPL Require Import Lemmas_Rename_Subst.
From PFPL Require Import Theorems_AlphaEquiv.
From PFPL Require Import Theorems_Eval.

(** At most one type for each expression (In Harper's book) *)
Lemma unicity_of_typing: forall Gamma e t t',
  hastype Gamma e t -> hastype Gamma e t' -> t = t'.
Proof.
  intros Gamma e t t' H1. generalize dependent t'.
  induction H1; intros t' H2; inversion H2; subst.
  all: try reflexivity.
  rewrite H in H3. inversion H3. reflexivity.
  apply IHhastype1 in H5. subst. apply IHhastype2. assumption.
Qed.

(** Typing rules are syntax-directed (In Harper's book) *)
Lemma inversion_for_typing : forall Gamma e t,
  hastype Gamma e t -> (
    (forall (x: nat), e = EId x -> Gamma x = Some(t)) /\
    (forall (s: string), e = EStr s -> t = TStr) /\
    (forall (n: nat), e = ENum n -> t = TNum) /\
    (forall e1 e2, e = EPlus e1 e2 -> t = TNum /\ hastype Gamma e1 TNum /\ hastype Gamma e2 TNum) /\
    (forall e1 e2, e = ETimes e1 e2 -> t = TNum /\ hastype Gamma e1 TNum /\ hastype Gamma e2 TNum) /\
    (forall e1 e2, e = ECat e1 e2 -> t = TStr /\ hastype Gamma e1 TStr /\ hastype Gamma e2 TStr) /\
    (forall e1, e = ELen e1 -> t = TNum /\ hastype Gamma e1 TStr) /\
    (forall e1 x e2, e = ELet e1 x e2 -> (exists t1 t2, t = t2 /\ hastype Gamma e1 t1 /\ hastype (update Gamma x t1) e2 t2))
  ).
Proof.
  intros Gamma e t H. induction H.
  - repeat split; intros; inversion H0.
    subst. assumption.
  - repeat split; intros; inversion H.
  - repeat split; intros; inversion H.
  - repeat split; intros; inversion H1.
    subst. assumption. subst. assumption.
  - repeat split; intros; inversion H1.
    subst. assumption. subst. assumption.
  - repeat split; intros; inversion H1.
    subst. assumption. subst. assumption.
  - repeat split; intros; inversion H0.
    subst. assumption.
  - repeat split; intros; inversion H1.
    subst. exists t1. exists t2.
    repeat split; assumption.
Qed.

(** Weakening (In Harper's book) *)
Lemma weakening : forall Gamma e t,
  hastype Gamma e t -> (forall x t', Gamma x = None -> hastype (x |-> t'; Gamma) e t).
Proof.
  intros Gamma e t H1 y t' H2. induction H1.
  - apply T_Var. rewrite <- H. apply (update_neq _ Gamma x y t').
    unfold not. intros H4. subst. rewrite H2 in H. inversion H.
  - apply T_Str.
  - apply T_Num.
  - apply T_Plus. apply IHhastype1. assumption. apply IHhastype2. assumption.
  - apply T_Times. apply IHhastype1. assumption. apply IHhastype2. assumption.
  - apply T_Cat. apply IHhastype1. assumption. apply IHhastype2. assumption.
  - apply T_Len. apply IHhastype. assumption.
  - assert (H2' := H2). apply IHhastype1 in H2.
    clear IHhastype1. apply (T_Let _ _ t1).
    + assumption.
    + case_eq (x =? y).
      * intros. apply Nat.eqb_eq in H. subst. rewrite (update_shadow EType Gamma y). assumption.
      * intros. apply Nat.eqb_neq in H. rewrite update_permute.
        apply IHhastype2. rewrite <- H2'. apply (update_neq _ Gamma). assumption.
        apply not_eq_sym. assumption.
Qed.

(** Different enunciation of the weakening property *)
Lemma weakening_2 : forall Gamma e t,
  hastype Gamma e t -> (forall x t', free_vars e x = false -> hastype (x |-> t'; Gamma) e t).
Proof.
  intros Gamma e t H1 y t' H2. induction H1.
  - apply T_Var. rewrite <- H. apply (update_neq _ Gamma x y t').
    unfold not. intros. subst. simpl in H2. unfold singletonSet in H2.
    rewrite Nat.eqb_refl in H2. discriminate.
  - apply T_Str.
  - apply T_Num.
  - simpl in H2. unfold unionSet in H2. apply orb_false_iff in H2. destruct H2.
    apply T_Plus. apply IHhastype1. assumption. apply IHhastype2. assumption.
  - simpl in H2. unfold unionSet in H2. apply orb_false_iff in H2. destruct H2.
    apply T_Times. apply IHhastype1. assumption. apply IHhastype2. assumption.
  - simpl in H2. unfold unionSet in H2. apply orb_false_iff in H2. destruct H2.
    apply T_Cat. apply IHhastype1. assumption. apply IHhastype2. assumption.
  - simpl in H2.
    apply T_Len. apply IHhastype. assumption.
  - simpl in H2. unfold unionSet in H2. apply orb_false_iff in H2. destruct H2.
    unfold removeFromSet in H0.
    apply (T_Let _ _ t1).
    + apply IHhastype1. assumption.
    + case_eq (x =? y); intros.
      * apply Nat.eqb_eq in H1. subst. rewrite (update_shadow EType Gamma y). assumption.
      * rewrite H1 in H0. apply Nat.eqb_neq in H1.
        rewrite update_permute. apply IHhastype2.
        assumption. apply not_eq_sym. assumption.
Qed.

(** Different enunciation of the weakening property *)
Lemma weakening_3 : forall Gamma e t x t',
  hastype (update Gamma x t') e t -> free_vars e x = false -> hastype Gamma e t.
Proof.
  intros Gamma e t y t' H H0. remember (y |-> t'; Gamma) as Gamma'.
  generalize dependent Gamma.
  induction H; intros; subst.
  - simpl in H0. unfold singletonSet in H0.
    case_eq (x =? y); intro XY.
    rewrite XY in H0. discriminate.
    unfold update in H. rewrite Nat.eqb_sym in XY. rewrite XY in H.
    apply T_Var. assumption.
  - apply T_Str.
  - apply T_Num.
  - simpl in H0. unfold unionSet in H0. apply orb_false_iff in H0. destruct H0.
    apply T_Plus. apply IHhastype1. assumption. reflexivity.
    apply IHhastype2. assumption. reflexivity.
  - simpl in H0. unfold unionSet in H0. apply orb_false_iff in H0. destruct H0.
    apply T_Times. apply IHhastype1. assumption. reflexivity.
    apply IHhastype2. assumption. reflexivity.
  - simpl in H0. unfold unionSet in H0. apply orb_false_iff in H0. destruct H0.
    apply T_Cat. apply IHhastype1. assumption. reflexivity.
    apply IHhastype2. assumption. reflexivity.
  - simpl in H.
    apply T_Len. apply IHhastype. assumption. reflexivity.
  - simpl in H0. unfold unionSet in H0. apply orb_false_iff in H0. destruct H0.
    unfold removeFromSet in H2.
    apply (T_Let _ _ t1).
    + apply IHhastype1. assumption. reflexivity.
    + case_eq (x =? y); intros.
      * apply Nat.eqb_eq in H3. subst.
        rewrite (update_shadow EType Gamma0 y) in H1. assumption.
      * rewrite H3 in H2. apply Nat.eqb_neq in H3.
        apply IHhastype2. assumption.
        rewrite update_permute. reflexivity.
        apply not_eq_sym. assumption.
Qed.

(** Auxiliary lemma to prove that typing is preserved by alpha equivalence *)
Lemma same_type_with_renamed : forall Gamma e t x x' t',
  all_vars e x' = false ->
  hastype (x |-> t'; Gamma) e t <->
  hastype (x' |-> t'; Gamma) (rename e x x') t.
Proof.
  intros. split; intro.
  {
    remember (x |-> t'; Gamma) as Gamma'.
    generalize dependent Gamma.
    induction H0; intros; simpl; simpl in H; subst.
    - unfold update in H0.
      case_eq (x =? x0); intro XX0; rewrite XX0 in H0.
      inversion H0. subst.
      constructor. unfold update.
      rewrite Nat.eqb_refl. reflexivity.
      constructor. unfold update.
      unfold singletonSet in H. rewrite Nat.eqb_sym.
      destruct (x0 =? x'). discriminate. assumption.
    - constructor.
    - constructor.
    - unfold unionSet in H. apply orb_false_iff in H. destruct H as [H H'].
      constructor.
      apply IHhastype1; auto.
      apply IHhastype2; auto.
    - unfold unionSet in H. apply orb_false_iff in H. destruct H as [H H'].
      constructor.
      apply IHhastype1; auto.
      apply IHhastype2; auto.
    - unfold unionSet in H. apply orb_false_iff in H. destruct H as [H H'].
      constructor.
      apply IHhastype1; auto.
      apply IHhastype2; auto.
    - constructor.
      apply IHhastype; auto.
    - unfold unionSet in H. apply orb_false_iff in H. destruct H as [H H'].
      unfold updateSet in H'.
      case_eq (x0 =? x'); intro X0X'; rewrite X0X' in H'.
      discriminate.
      case_eq (x =? x0); intro XX0.
      + apply Nat.eqb_eq in XX0. subst.
        apply (T_Let _ _ t1). apply IHhastype1.
        assumption. reflexivity.
        rewrite update_shadow in H0_0.
        rewrite update_permute.
        apply weakening_2. assumption.
        apply not_in_expr_not_free. assumption.
        apply Nat.eqb_neq. rewrite Nat.eqb_sym. assumption.
      + apply (T_Let _ _ t1). apply IHhastype1.
        assumption. reflexivity.
        rewrite update_permute.
        apply IHhastype2. assumption.
        rewrite update_permute. reflexivity.
        apply Nat.eqb_neq. assumption.
        apply Nat.eqb_neq. rewrite Nat.eqb_sym. assumption.
  }
  {
    generalize dependent H0.
    generalize dependent H.
    generalize dependent t'.
    generalize dependent t0.
    generalize dependent Gamma.
    induction e; intros; simpl; simpl in H;
    simpl in H0; subst.
    - inversion H0. constructor.
    - inversion H0. constructor.
    - case_eq (x =? x0); intro X0X; rewrite X0X in H0.
      apply Nat.eqb_eq in X0X. subst.
      inversion H0. subst. constructor.
      unfold update in H3. rewrite Nat.eqb_refl in H3.
      inversion H3. subst.
      unfold update. rewrite Nat.eqb_refl. reflexivity.
      inversion H0. subst. constructor.
      unfold update in H3.
      unfold singletonSet in H. rewrite Nat.eqb_sym in H.
      case_eq (x' =? x0); intro X'X0; rewrite X'X0 in H.
      discriminate. rewrite X'X0 in H3.
      unfold update. rewrite X0X. assumption.
    - unfold unionSet in H. apply orb_false_iff in H. destruct H as [H H'].
      inversion H0. subst. constructor.
      apply IHe1; auto.
      apply IHe2; auto.
    - unfold unionSet in H. apply orb_false_iff in H. destruct H as [H H'].
      inversion H0. subst. constructor.
      apply IHe1; auto.
      apply IHe2; auto.
    - unfold unionSet in H. apply orb_false_iff in H. destruct H as [H H'].
      inversion H0. subst. constructor.
      apply IHe1; auto.
      apply IHe2; auto.
    - inversion H0. subst. constructor.
      apply IHe; auto.
    - unfold unionSet in H. apply orb_false_iff in H. destruct H as [H H'].
      unfold updateSet in H'. case_eq (x0 =? x'); intro X0X'; rewrite X0X' in H'.
      discriminate.
      case_eq (x =? x0); intro XX0; rewrite XX0 in H0.
      apply Nat.eqb_eq in XX0. subst. inversion H0. subst.
      apply (T_Let _ _ t1).
      apply IHe1; auto.
      rewrite update_shadow.
      rewrite update_permute in H7.
      apply (weakening_3 (x0 |-> t1; Gamma) e2 t0 x' t').
      assumption. apply not_in_expr_not_free. assumption.
      rewrite Nat.eqb_sym in X0X'. apply Nat.eqb_neq. assumption.
      inversion H0. subst.
      apply (T_Let _ _ t1).
      apply IHe1; auto.
      rewrite update_permute.
      apply IHe2. assumption.
      rewrite update_permute. assumption.
      apply Nat.eqb_neq. assumption.
      apply Nat.eqb_neq. assumption.
  }
Qed.

Lemma alpha_variants_same_type_aux : forall e e' Gamma t,
  alpha_equiv_rel e e' -> hastype Gamma e t -> hastype Gamma e' t.
Proof.
  intros e e' Gamma t H.
  generalize dependent t.
  generalize dependent Gamma.
  induction H; intros.
  - assumption.
  - inversion H2. subst.
    apply (T_Let _ _ t1).
    apply IHalpha_equiv_rel. assumption.
    remember (max (get_fresh_var e2) (get_fresh_var e2')) as newX.
    assert (C1 : all_vars e2 newX = false).
    rewrite HeqnewX. apply fresh_var_not_in_all_vars_left.
    assert (C2 : all_vars e2' newX = false).
    rewrite HeqnewX. apply fresh_var_not_in_all_vars_right.
    apply (same_type_with_renamed Gamma e2' t0 x' newX t1 C2).
    apply (H1 newX C1 C2).
    apply (same_type_with_renamed Gamma e2 t0 x newX t1 C1).
    assumption.
  - assumption.
  - apply eqb_eq in H. subst. assumption.
  - inversion H1. subst. apply T_Plus.
    apply IHalpha_equiv_rel1; assumption.
    apply IHalpha_equiv_rel2; assumption.
  - inversion H1. subst. apply T_Times.
    apply IHalpha_equiv_rel1; assumption.
    apply IHalpha_equiv_rel2; assumption.
  - inversion H1. subst. apply T_Cat.
    apply IHalpha_equiv_rel1; assumption.
    apply IHalpha_equiv_rel2; assumption.
  - inversion H0. subst. apply T_Len.
    apply IHalpha_equiv_rel; assumption.
Qed.

(** Alpha-variants have the same type *)
Theorem alpha_variants_same_type : forall e e' Gamma t,
  alpha_equiv_rel e e' -> (hastype Gamma e t <-> hastype Gamma e' t).
Proof.
  intros. split.
  apply alpha_variants_same_type_aux. auto.
  apply alpha_variants_same_type_aux. symmetry. auto.
Qed.

(** Substitution property assuming no capture of variables *)
Lemma substitution_aux : forall Gamma x t e t' e',
  (forall v, bound_vars e v = true -> free_vars e' v = false) ->
  hastype (x |-> t'; Gamma) e t -> hastype Gamma e' t' -> hastype Gamma (subst' e' x e) t.
Proof.
  intros Gamma x t e t' e' H1 H2 H3.
  remember (x |-> t'; Gamma) as Gamma'.
  generalize dependent Gamma.
  induction H2; intros Gamma' G H3; simpl.
  - case_eq (x =? x0); intros.
    * apply Nat.eqb_eq in H0. subst. unfold update in H.
      rewrite Nat.eqb_refl in H. inversion H. subst. assumption.
    * apply Nat.eqb_neq in H0. apply T_Var. rewrite <- H.
      rewrite G. symmetry. apply update_neq. assumption.
  - apply T_Str.
  - apply T_Num.
  - simpl in H1. unfold unionSet in H1.
    apply T_Plus.
    + apply IHhastype1. intros.
      apply H1. apply orb_true_iff. left. assumption.
      assumption. assumption.
    + apply IHhastype2. intros.
      apply H1. apply orb_true_iff. right. assumption.
      assumption. assumption.
  - simpl in H1. unfold unionSet in H1.
    apply T_Times.
    + apply IHhastype1. intros.
      apply H1. apply orb_true_iff. left. assumption.
      assumption. assumption.
    + apply IHhastype2. intros.
      apply H1. apply orb_true_iff. right. assumption.
      assumption. assumption.
  - simpl in H1. unfold unionSet in H1.
    apply T_Cat.
    + apply IHhastype1. intros.
      apply H1. apply orb_true_iff. left. assumption.
      assumption. assumption.
    + apply IHhastype2. intros.
      apply H1. apply orb_true_iff. right. assumption.
      assumption. assumption.
  - simpl in H1.
    apply T_Len.
    apply IHhastype. intros.
    apply H1. assumption.
    assumption. assumption.
  - simpl in H1. unfold unionSet in H1. unfold updateSet in H1.
    case_eq (x =? x0); intro XX0.
    + apply Nat.eqb_eq in XX0. subst x0.
      apply (T_Let _ _ t1).
      * apply IHhastype1. intros.
        apply H1. apply orb_true_iff. left. assumption.
        assumption. assumption.
      * rewrite G in H2_0.
        rewrite update_shadow in H2_0. assumption.
    + apply (T_Let _ _ t1).
      * apply IHhastype1. intros.
        apply H1. apply orb_true_iff. left. assumption.
        assumption. assumption.
      * rewrite G in H2_0.
        apply IHhastype2. intros.
        apply H1. apply orb_true_iff. right.
        rewrite H. case_eq (x0 =? v); reflexivity.
        rewrite G.
        apply update_permute. apply Nat.eqb_neq. assumption.
        apply weakening_2. assumption.
        apply H1. rewrite Nat.eqb_refl.
        apply orb_true_r.
Qed.

(** Substitution (In Harper's book) *)
Lemma substitution : forall Gamma x t e t' e',
  hastype (x |-> t'; Gamma) e t -> hastype Gamma e' t' -> hastype Gamma (subst e' x e) t.
Proof.
  intros.
  unfold subst.
  remember (max (get_fresh_var e) (get_fresh_var e')) as o.
  apply (substitution_aux Gamma _ _ _ t'); auto.
  apply fresh_rename_removes_conflicts; auto.
  apply (alpha_variants_same_type e); auto.
  apply fresh_rename_keeps_alpha_equiv. lia.
Qed.

(** Decomposition property assuming no capture of variables *)
Lemma decomposition_aux : forall Gamma e x e' t,
  (forall v, bound_vars e v = true -> free_vars e' v = false) ->
  hastype Gamma (subst' e' x e) t -> (forall t', hastype Gamma e' t' -> hastype (x |-> t'; Gamma) e t).
Proof.
  intros Gamma e x. generalize dependent Gamma.
  induction e; intros; simpl in H0.
  - inversion H0. subst. apply T_Num.
  - inversion H0. subst. apply T_Str.
  - case_eq (x =? x0); intros.
    * rewrite H2 in H0. apply T_Var.
      unfold update. rewrite H2.
      apply (unicity_of_typing Gamma e' t0 t' H0) in H1.
      subst. reflexivity.
    * rewrite H2 in H0. inversion H0. subst.
      apply T_Var. unfold update.
      rewrite H2. assumption.
  - simpl in H. unfold unionSet in H.
    inversion H0. subst.
    apply T_Plus; [apply (IHe1 _ e') | apply (IHe2 _ e')].
    all: try assumption.
    all: intros; apply H; rewrite H2.
    apply orb_true_l. apply orb_true_r.
  - simpl in H. unfold unionSet in H.
    inversion H0. subst.
    apply T_Times; [apply (IHe1 _ e') | apply (IHe2 _ e')].
    all: try assumption.
    all: intros; apply H; rewrite H2.
    apply orb_true_l. apply orb_true_r.
  - simpl in H. unfold unionSet in H.
    inversion H0. subst.
    apply T_Cat; [apply (IHe1 _ e') | apply (IHe2 _ e')].
    all: try assumption.
    all: intros; apply H; rewrite H2.
    apply orb_true_l. apply orb_true_r.
  - simpl in H. inversion H0. subst.
    apply T_Len. apply (IHe _ e'); assumption.
  - simpl in H. unfold unionSet in H. unfold updateSet in H.
    case_eq (x =? x0); intro.
    + apply Nat.eqb_eq in H2. subst x0.
      rewrite Nat.eqb_refl in H0. inversion H0. subst.
      apply (T_Let _ _ t1).
      * apply (IHe1 _ e').
        all: try assumption.
        intros; apply H; rewrite H2.
        apply orb_true_l.
      * rewrite update_shadow. assumption.
    + rewrite H2 in H0. inversion H0. subst.
      apply (T_Let _ _ t1).
      * apply (IHe1 _ e').
        all: try assumption.
        intros; apply H; rewrite H3.
        apply orb_true_l.
      * rewrite update_permute.
        apply (IHe2 _ e').
        all: try assumption.
        intros; apply H; rewrite H3.
        destruct (x0 =? v); apply orb_true_r.
        apply weakening_2. assumption.
        apply H. rewrite Nat.eqb_refl.
        apply orb_true_r.
        apply Nat.eqb_neq. assumption.
Qed.

(** Decomposition (In Harper's book) *)
Lemma decomposition : forall Gamma e x e' t,
  hastype Gamma (subst e' x e) t -> (forall t', hastype Gamma e' t' -> hastype (x |-> t'; Gamma) e t).
Proof.
  intros.
  unfold subst in H.
  remember (max (get_fresh_var e) (get_fresh_var e')) as o.
  apply (alpha_variants_same_type (fresh_rename e emptySet o)).
  apply alpha_equiv_sym.
  apply fresh_rename_keeps_alpha_equiv. lia.
  apply (decomposition_aux Gamma _ _ e'); auto.
  apply fresh_rename_removes_conflicts; auto.
Qed.

(** Steps of evaluation preserve typing (In Harper's book) *)
Theorem preservation : forall Gamma e t e',
  hastype Gamma e t -> Eval e e' -> hastype Gamma e' t.
Proof.
  intros Gamma e t e' H1 H2. generalize dependent t. induction H2; intros t H1.
  - inversion H1. subst. apply T_Num.
  - inversion H1. subst. apply T_Plus. apply IHEval. assumption. assumption.
  - inversion H1. subst. apply T_Plus. assumption. apply IHEval. assumption.
  - inversion H1. subst. apply T_Num.
  - inversion H1. subst. apply T_Times. apply IHEval. assumption. assumption.
  - inversion H1. subst. apply T_Times. assumption. apply IHEval. assumption.
  - inversion H1. subst. apply T_Str.
  - inversion H1. subst. apply T_Cat. apply IHEval. assumption. assumption.
  - inversion H1. subst. apply T_Cat. assumption. apply IHEval. assumption.
  - inversion H1. subst. apply T_Num.
  - inversion H1. subst. apply T_Len. apply IHEval. assumption.
  - inversion H1. subst. apply (T_Let _ _ t1).
    + apply IHEval. assumption.
    + assumption.
  - inversion H1. subst. apply (substitution Gamma x t e2 t1).
    all: assumption.
Qed.

(** Canonical Forms (In Harper's book) *)
Lemma canonical_forms : forall Gamma e t,
  Val e -> hastype Gamma e t -> (
    (t = TNum -> exists n, e = ENum n) /\
    (t = TStr -> exists s, e = EStr s)
  ).
Proof.
  intros Gamma e t H1.
  induction H1; intros; split; intros; subst.
  exists n. reflexivity.
  inversion H.
  inversion H.
  exists s. reflexivity.
Qed.

(** Well-typed programs cannot get stuck (In Harper's book) *)
Theorem progress : forall e t,
  hastype empty_ctx e t -> Val e \/ exists e', Eval e e'.
Proof.
  intros e t H.
  remember empty_ctx as Gamma.
  induction H; subst.
  - subst. discriminate H.
  - left. apply valStr.
  - left. apply valNum.
  - right.
    assert (IHhastype1 := IHhastype1 Logic.eq_refl).
    assert (IHhastype2 := IHhastype2 Logic.eq_refl).
    destruct IHhastype1; destruct IHhastype2.
    + apply (canonical_forms empty_ctx e1 TNum) in H1.
      apply (canonical_forms empty_ctx e2 TNum) in H2.
      destruct H1. destruct H2.
      assert (H1 := H1 Logic.eq_refl).
      assert (H2 := H2 Logic.eq_refl).
      destruct H1. destruct H2. subst.
      exists (ENum (x + x0)). constructor. reflexivity.
      assumption. assumption.
    + destruct H2. exists (EPlus e1 x). constructor; assumption.
    + destruct H1. exists (EPlus x e2). constructor; assumption.
    + destruct H1. exists (EPlus x e2). constructor; assumption.
  - right.
    assert (IHhastype1 := IHhastype1 Logic.eq_refl).
    assert (IHhastype2 := IHhastype2 Logic.eq_refl).
    destruct IHhastype1; destruct IHhastype2.
    + apply (canonical_forms empty_ctx e1 TNum) in H1.
      apply (canonical_forms empty_ctx e2 TNum) in H2.
      destruct H1. destruct H2.
      assert (H1 := H1 Logic.eq_refl).
      assert (H2 := H2 Logic.eq_refl).
      destruct H1. destruct H2. subst.
      exists (ENum (x * x0)). constructor. reflexivity.
      assumption. assumption.
    + destruct H2. exists (ETimes e1 x). constructor; assumption.
    + destruct H1. exists (ETimes x e2). constructor; assumption.
    + destruct H1. exists (ETimes x e2). constructor; assumption.
  - right.
    assert (IHhastype1 := IHhastype1 Logic.eq_refl).
    assert (IHhastype2 := IHhastype2 Logic.eq_refl).
    destruct IHhastype1; destruct IHhastype2.
    + apply (canonical_forms empty_ctx e1 TStr) in H1.
      apply (canonical_forms empty_ctx e2 TStr) in H2.
      destruct H1. destruct H2.
      assert (H3 := H3 Logic.eq_refl).
      assert (H4 := H4 Logic.eq_refl).
      destruct H3. destruct H4. subst.
      exists (EStr (append x x0)). constructor. reflexivity.
      assumption. assumption.
    + destruct H2. exists (ECat e1 x). constructor; assumption.
    + destruct H1. exists (ECat x e2). constructor; assumption.
    + destruct H1. exists (ECat x e2). constructor; assumption.
  - right.
    assert (IHhastype := IHhastype Logic.eq_refl).
    destruct IHhastype.
    + apply (canonical_forms empty_ctx e TStr) in H0.
      destruct H0.
      assert (H1 := H1 Logic.eq_refl).
      destruct H1. subst.
      exists (ENum (length x)). constructor. reflexivity.
      assumption.
    + destruct H0. exists (ELen x). constructor; assumption.
  - right.
    assert (IHhastype1 := IHhastype1 Logic.eq_refl).
    destruct IHhastype1.
    + exists (subst e1 x e2). constructor; assumption.
    + destruct H1. exists (ELet x0 x e2). constructor; assumption.
Qed.

(** Based on https://softwarefoundations.cis.upenn.edu/plf-current/StlcProp.html#lab244 *)
Theorem type_safety : forall e e' t,
  hastype empty_ctx e t -> EvalStar e e' -> Val e' \/ exists e'', Eval e' e''.
Proof.
  intros e e' t H1 H2. induction H2.
  - apply progress in H1. assumption.
  - apply IHEvalStar. apply (preservation _ _ _ _ H1 H).
Qed.

(** Proof of termination of well-typed programs *)
Theorem well_typed_programs_terminate : forall e t,
  hastype empty_ctx e t -> exists e', EvalBig e e'.
Proof.
  intro e. remember (subexprs_count e) as c.
  generalize dependent e.
  generalize dependent c.
  induction c using lt_wf_ind; intros.
  assert (T := progress e t0 H0).
  destruct T.
  - inversion H1; subst.
    exists (ENum n). constructor.
    exists (EStr s). constructor.
  - destruct H1.
    assert (T1 := preservation empty_ctx e t0 x H0 H1).
    assert (T2 := progress x t0 T1).
    remember (subexprs_count x) as c2.
    cut (c2 < c). intro C.
    assert (T3 := H c2 C x Heqc2 t0 T1).
    destruct T3 as [e' T3]. exists e'.
    apply eval_big_equiv_eval_star.
    apply eval_big_equiv_eval_star in T3.
    destruct T3 as [T3 T4]. split.
    apply (starN _ _ x); assumption.
    assumption.
    subst. apply eval_reduces. assumption.
Qed.


Add LoadPath "???\syntax".
Add LoadPath "???\type_system".
Add LoadPath "???\substitution".

Require Export subtyping_lemmas.

(* ================== Reflexivity, Symmetry, Transitivity ================== *)

(* We 'upgrade' it to arbitrary hypotheses in aux_type_lemmas *)
Fixpoint veq_refl_raw Γ v A (orig : has_vtype Γ v A) {struct orig}:
  judg Γ HypØ (Veq A v v)
with ceq_refl_raw Γ c C (orig : has_ctype Γ c C) {struct orig}:
  judg Γ HypØ (Ceq C c c)
with heq_refl_raw Γ h Σ D (orig : has_htype Γ h Σ D) {struct orig}:
  judg Γ HypØ (Heq Σ D h h).
Proof.
{
apply WfJudg. inv orig. auto.
apply WfVeq; auto. apply WfHypØ. destruct orig. destruct H1.
+ apply VeqUnit.
+ apply VeqInt.
+ eapply VeqVar. eauto.
+ apply VeqPair; eauto.
+ inv H0. eapply VeqLeft; eauto. all: apply vsubtype_refl; auto.
+ inv H0. eapply VeqRight; eauto. all: apply vsubtype_refl; auto.
+ inv H0. eapply VeqNil; eauto. all: apply vsubtype_refl; auto.
+ apply VeqCons; eauto.
+ inv H0. eapply VeqFun; eauto. all: apply vsubtype_refl; auto.
+ inv H0. inv H6. eapply VeqHandler; eauto. all: apply vsubtype_refl; auto.
+ apply veq_refl_raw in H1. eapply VeqSubsume; eauto.
}{
apply WfJudg. inv orig. auto.
apply WfCeq; auto. apply WfHypØ. destruct orig. destruct H1.
+ apply CeqRet. auto.
+ eapply CeqAbsurd; apply csubtype_refl; auto.
+ eapply CeqProdMatch; eauto.
+ eapply CeqSumMatch; eauto.
+ eapply CeqListMatch; eauto.
+ eapply CeqDo; eauto.
+ eapply CeqApp; eauto.
+ eapply CeqHandle; eauto.
+ eapply CeqLetRec; eauto.
+ eapply CeqOp; eauto.
  - apply get_op_type_wf in H1. destruct H1. apply veq_refl_raw in H4 as IH.
    assert (has_vtype Γ v Aop') as tys'.
    { apply TypeV; auto. eapply TypeVSubsume; eauto. }
    apply WfJudg; auto. apply WfVeq; auto. apply WfHypØ.
    eapply VeqSubsume; eauto.
    inv H0. auto.
  - apply get_op_type_wf in H1. destruct H1.
    apply ceq_refl_raw in H5 as IH. eapply ctx_subtype_judg; eauto.
    all: apply WfCtxU || apply STyCtxU || inv H0; auto.
    apply ctx_subtype_refl. auto.
+ apply ceq_refl_raw in H1. eapply CeqSubsume; eauto.
}{
apply WfJudg. inv orig. auto. eapply WfHeq; auto.
inv orig. assumption.
apply sig_subtype_refl. inv orig. assumption.
apply sig_subtype_refl. inv orig. assumption.
assumption. assumption. apply WfHypØ.
destruct orig. destruct H2.
+ eapply HeqSigØ.
+ inv H0. eapply HeqExtend; eauto; eapply wf_sig_unique_cases; eauto.
}
Qed.

Lemma veq_sym A Γ Ψ v1 v2 :
  judg Γ Ψ (Veq A v1 v2) -> judg Γ Ψ (Veq A v2 v1)
with ceq_sym C Γ Ψ c1 c2 :
  judg Γ Ψ (Ceq C c1 c2) -> judg Γ Ψ (Ceq C c2 c1)
with heq_sym Σ D Γ Ψ h1 h2 :
  judg Γ Ψ (Heq Σ D h1 h2) -> judg Γ Ψ (Heq Σ D h2 h1).
Proof.
{
intro orig. apply WfJudg. inv orig. auto.
apply WfVeq. all: try (inv orig; inv H0; assumption).
apply VeqSym. auto.
}{
intro orig. apply WfJudg. inv orig. auto.
apply WfCeq. all: try (inv orig; inv H0; assumption).
apply CeqSym. auto.
}{
intro orig. apply WfJudg. inv orig. auto.
inv orig. inv H0.
eapply WfHeq. 3: exact H9. all: eauto. inv orig. auto.
apply HeqSym. auto.
}
Qed.

Lemma veq_trans A Γ Ψ v1 v2 v3:
  judg Γ Ψ (Veq A v1 v2) -> judg Γ Ψ (Veq A v2 v3) -> judg Γ Ψ (Veq A v1 v3)

with  ceq_trans C Γ Ψ c1 c2 c3:
  judg Γ Ψ (Ceq C c1 c2) -> judg Γ Ψ (Ceq C c2 c3) -> judg Γ Ψ (Ceq C c1 c3)

with  heq_trans Σ D Γ Ψ h1 h2 h3:
  judg Γ Ψ (Heq Σ D h1 h2) -> judg Γ Ψ (Heq Σ D h2 h3) ->
  judg Γ Ψ (Heq Σ D h1 h3).

Proof.
{
intros veq1 veq2. apply WfJudg. inv veq1. auto. apply WfVeq.
+ inv veq1. inv H0. auto.
+ inv veq2. inv H0. auto.
+ inv veq1. auto.
+ eapply VeqTrans; eauto.
}{
intros ceq1 ceq2. apply WfJudg. inv ceq1. auto. apply WfCeq.
+ inv ceq1. inv H0. auto.
+ inv ceq2. inv H0. auto.
+ inv ceq1. auto.
+ eapply CeqTrans; eauto.
}{
intros heq1 heq2. apply WfJudg. inv heq1. auto.
+ inv heq1. inv H0. inv heq2. inv H3. eapply WfHeq.
  4: eauto. 4: eauto. all:eauto.
+ inv heq1. auto.
+ eapply HeqTrans; eauto.
}
Qed.


(* Copyright (c) 2008-2009, 2015, Adam Chlipala
 *
 * This work is licensed under a
 * Three-clause BSD Licence
 *
 * All rights reserved.
 *
 * Redistribution and use in source and binary forms, with or without
 * modification, are permitted provided that the following conditions are met:
 *
 * - Redistributions of source code must retain the above copyright notice,
 *   this list of conditions and the following disclaimer.
 * - Redistributions in binary form must reproduce the above copyright notice,
 *   this list of conditions and the following disclaimer in the documentation
 *   and/or other materials provided with the distribution.
 * - The names of contributors may not be used to endorse or promote products
 *   derived from this software without specific prior written permission.
 *
 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 * POSSIBILITY OF SUCH DAMAGE.
 *)

(* Dependent list types presented in Chapter 9 *)

Require Import Arith List Cpdt.CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.

Section ilist.
  Variable A : Type.

  Inductive ilist : nat -> Type :=
  | INil : ilist O
  | ICons : forall n, A -> ilist n -> ilist (S n).

  Definition hd n (ls : ilist (S n)) :=
    match ls in ilist n' return match n' with
                                  | O => unit
                                  | S _ => A
                                end with
      | INil => tt
      | ICons _ x _ => x
    end.
  Definition tl n (ls : ilist (S n)) :=
    match ls in ilist n' return match n' with
                                  | O => unit
                                  | S n => ilist n
                                end with
      | INil => tt
      | ICons _ _ ls' => ls'
    end.

  Inductive fin : nat -> Set :=
  | First : forall n, fin (S n)
  | Next : forall n, fin n -> fin (S n).

  Fixpoint get n (ls : ilist n) : fin n -> A :=
    match ls with
      | INil => fun idx =>
        match idx in fin n' return (match n' with
                                        | O => A
                                        | S _ => unit
                                      end) with
          | First _ => tt
          | Next _ _ => tt
        end
      | ICons _ x ls' => fun idx =>
        match idx in fin n' return (fin (pred n') -> A) -> A with
          | First _ => fun _ => x
          | Next _ idx' => fun get_ls' => get_ls' idx'
        end (get ls')
    end.

  Section everywhere.
    Variable x : A.

    Fixpoint everywhere (n : nat) : ilist n :=
      match n with
        | O => INil
        | S n' => ICons x (everywhere n')
      end.
  End everywhere.

  Section singleton.
    Variables x default : A.

    Fixpoint singleton (n m : nat) : ilist n :=
      match n with
        | O => INil
        | S n' =>
          match m with
            | O => ICons x (everywhere default n')
            | S m' => ICons default (singleton n' m')
          end
      end.
  End singleton.

  Section map2.
    Variable f : A -> A -> A.

    Fixpoint map2 n (il1 : ilist n) : ilist n -> ilist n :=
      match il1 in ilist n return ilist n -> ilist n with
        | INil => fun _ => INil
        | ICons _ x il1' => fun il2 => ICons (f x (hd il2)) (map2 il1' (tl il2))
      end.
  End map2.

  Section fold.
    Variable B : Type.
    Variable f : A -> B -> B.
    Variable i : B.

    Fixpoint foldr n (il : ilist n) : B :=
      match il with
        | INil => i
        | ICons _ x il' => f x (foldr il')
      end.
  End fold.
End ilist.

Implicit Arguments INil [A].
Implicit Arguments First [n].

Section imap.
  Variables A B : Type.
  Variable f : A -> B.

  Fixpoint imap n (il : ilist A n) : ilist B n :=
    match il with
      | INil => INil
      | ICons _ x il' => ICons (f x) (imap il')
    end.
End imap.

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls).

  Definition hhd ls (hl : hlist ls) :=
    match hl in hlist ls return match ls with
                                  | nil => unit
                                  | x :: _ => B x
                                end with
      | HNil => tt
      | HCons _ _ v _ => v
    end.

  Definition htl ls (hl : hlist ls) :=
    match hl in hlist ls return match ls with
                                  | nil => unit
                                  | _ :: ls' => hlist ls'
                                end with
      | HNil => tt
      | HCons _ _ _ hl' => hl'
    end.

  Variable elm : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elm :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).

  Fixpoint hget ls (mls : hlist ls) : member ls -> B elm :=
    match mls with
      | HNil => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => B elm
                                          | _ :: _ => unit
                                        end) with
          | HFirst _ => tt
          | HNext _ _ _ => tt
        end
      | HCons _ _ x mls' => fun mem =>
        match mem in member ls' return (match ls' with
                                          | nil => Empty_set
                                          | x' :: ls'' =>
                                            B x' -> (member ls'' -> B elm) -> B elm
                                        end) with
          | HFirst _ => fun x _ => x
          | HNext _ _ mem' => fun _ get_mls' => get_mls' mem'
        end x (hget mls')
    end.

  Fixpoint happ (ls1 : list A) (hl1 : hlist ls1) : forall ls2, hlist ls2 -> hlist (ls1 ++ ls2) :=
    match hl1 in hlist ls1 return forall ls2, hlist ls2 -> hlist (ls1 ++ ls2) with
      | HNil => fun _ hl2 => hl2
      | HCons _ _ x hl1' => fun _ hl2 => HCons x (happ hl1' hl2)
    end.

  Variable f : forall x, B x.

  Fixpoint hmake (ls : list A) : hlist ls :=
    match ls with
      | nil => HNil
      | x :: ls' => HCons (f x) (hmake ls')
    end.

  Theorem hget_hmake : forall ls (m : member ls),
    hget (hmake ls) m = f elm.
    induction ls; crush;
      match goal with
        | [ |- context[match ?E with HFirst _ => _ | HNext _ _ _ => _ end] ] => dep_destruct E
      end; crush.
  Qed.
End hlist.

Implicit Arguments HNil [A B].
Implicit Arguments HCons [A B x ls].
Implicit Arguments hmake [A B].

Implicit Arguments HFirst [A elm ls].
Implicit Arguments HNext [A elm x ls].

Infix ":::" := HCons (right associativity, at level 60).
Infix "+++" := happ (right associativity, at level 60).

Section hmap.
  Variable A : Type.
  Variables B1 B2 : A -> Type.

  Variable f : forall x, B1 x -> B2 x.

  Fixpoint hmap (ls : list A) (hl : hlist B1 ls) : hlist B2 ls :=
    match hl with
      | HNil => HNil
      | HCons _ _ x hl' => f x ::: hmap hl'
    end.

  Theorem hmap_happ : forall ls2 (h2 : hlist B1 ls2) ls1 (h1 : hlist B1 ls1),
    hmap h1 +++ hmap h2 = hmap (h1 +++ h2).
    induction h1; crush.
  Qed.

  Theorem hget_hmap : forall elm ls (hls : hlist B1 ls) (m : member elm ls),
    hget (hmap hls) m = f (hget hls m).
    induction hls; crush;
      match goal with
        | [ |- context[match ?E with HFirst _ => _ | HNext _ _ _ => _ end] ] => dep_destruct E
      end; crush.
  Qed.
End hmap.

Implicit Arguments hmap [A B1 B2 ls].


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Module_kernel.
Require Export Free_module.
Section Generated_module_def.
Variable R : RING.
Variable Mod : MODULE R.
Variable A : part_set Mod.

Definition generated_module : submodule Mod := coKer (FMd_lift (inj_part A)).
End Generated_module_def.

Lemma generated_module_minimal :
 forall (R : RING) (Mod : MODULE R) (A : part_set Mod) (H : submodule Mod),
 included A H -> included (generated_module A) H.
unfold included in |- *.
simpl in |- *.
intros R Mod A H H' x H'0; try assumption.
elim H'0; intros x0; clear H'0.
generalize x; clear x.
elim x0.
intros c; try assumption.
elim c.
simpl in |- *.
intros y subtype_prf x H'0; elim H'0; intros H'1 H'2; try exact H'2;
 clear H'0.
apply in_part_comp_l with y; auto with algebra.
intros f H'0 f0 H'1 x H'2; elim H'2; intros H'3 H'4; try exact H'4; clear H'2.
simpl in H'4.
apply
 in_part_comp_l
  with
    (sgroup_law Mod (FMd_lift_fun (inj_part A) f)
       (FMd_lift_fun (inj_part A) f0)); auto with algebra.
simpl in |- *.
intros x H'0; elim H'0; intros H'1 H'2; try exact H'2; clear H'0.
apply in_part_comp_l with (monoid_unit Mod); auto with algebra.
intros f H'0 x H'1; try assumption.
elim H'1; intros H'2 H'3; simpl in H'3; clear H'1.
apply in_part_comp_l with (group_inverse Mod (FMd_lift_fun (inj_part A) f));
 auto with algebra.
intros c f H'0 x H'1; try assumption.
simpl in H'1.
elim H'1; intros H'2 H'3; try exact H'3; clear H'1.
apply in_part_comp_l with (module_mult c (FMd_lift_fun (inj_part A) f));
 auto with algebra.
Qed.

Lemma generated_module_prop_included :
 forall (R : RING) (Mod : MODULE R) (A : part_set Mod),
 included A (generated_module A).
unfold included in |- *.
simpl in |- *.
intros R Mod A x H'; try assumption.
exists (Var R (V:=A) (Build_subtype (E:=Mod) (P:=A) (subtype_elt:=x) H'));
 split; [ idtac | try assumption ].
auto with algebra.
simpl in |- *.
auto with algebra.
Qed.

Lemma generated_module_prop :
 forall (R : RING) (Mod : MODULE R) (A : part_set Mod) (y : Mod),
 in_part y (generated_module A) ->
 exists x : FMd R A, Equal y (FMd_lift (inj_part A) x).
simpl in |- *; auto with algebra.
intros R Mod A y H'; try assumption.
elim H'; intros x E; elim E; intros H'0 H'1; try exact H'1; clear E H'.
exists x; try assumption.
Qed.

Lemma generated_module_prop_rev :
 forall (R : RING) (Mod : MODULE R) (A : part_set Mod) (y : Mod),
 (exists x : FMd R A, Equal y (FMd_lift (inj_part A) x)) ->
 in_part y (generated_module A).
intros R Mod A y H'; try assumption.
elim H'; intros x E; try exact E; clear H'.
simpl in |- *; auto with algebra.
exists x; split; [ idtac | try assumption ].
auto with algebra.
Qed.
Hint Resolve generated_module_minimal generated_module_prop_included
  generated_module_prop_rev: algebra.


From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From pcm Require Import options axioms pred.
From pcm Require Import pcm unionmap heap autopcm automap.
From htt Require Import options model heapauto.

(* Linked lists, storing a value and next pointer in consecutive locations. *)
(* We start with a more general "segment" definition, where the last node's *)
(* next pointer is an arbitrary q *)

Fixpoint lseg {A} (p q : ptr) (xs : seq A) :=
  if xs is hd::tl then
    [Pred h | exists r h',
       h = p :-> hd \+ (p .+ 1 :-> r \+ h') /\ h' \In lseg r q tl]
  else [Pred h | p = q /\ h = Unit].

Definition EmptyList : exn := exn_from_nat 15.

Section LSeg.
Variable A : Type.

(* appending a value to the list segment *)

Lemma lseg_rcons (xs : seq A) x p r h :
        h \In lseg p r (rcons xs x) <->
        exists q h', h = h' \+ (q :-> x \+ q .+ 1 :-> r) /\ h' \In lseg p q xs.
Proof.
move: xs x p r h; elim=>[|x xs IH] y p r h /=.
- by split; case=>x [h'][->][<- ->]; [exists p | exists r]; hhauto.
split.
- case=>z [h1][->]; case/IH=>w [h2][->] H1.
  by exists w, (p :-> x \+ (p .+ 1 :-> z \+ h2)); hhauto.
case=>q [h1][->][z][h2][->] H1.
exists z, (h2 \+ q :-> y \+ q .+ 1 :-> r).
by rewrite -!joinA; split=>//; apply/IH; eauto.
Qed.

(* null pointer represents an empty segment *)

Lemma lseg_null (xs : seq A) q h :
        valid h -> h \In lseg null q xs ->
        [/\ q = null, xs = [::] & h = Unit].
Proof.
case: xs=>[|x xs] D /= H; first by case: H=><- ->.
case: H D=>r [h'][->] _; rewrite validPtUn; hhauto.
Qed.

(* empty heap represents an empty segment *)

Lemma lseg_empty (xs : seq A) p q : Unit \In lseg p q xs -> p = q /\ xs = [::].
Proof.
by case: xs=>[|x xs][] // r [h][/esym/join0E][/unitbE]; rewrite /heap_pts ptsU um_unitbU.
Qed.

(* reformulation of the specification *)

Lemma lseg_case (xs : seq A) p q h :
        h \In lseg p q xs ->
        [/\ p = q, xs = [::] & h = Unit] \/
        exists x r h',
          [/\ xs = x :: behead xs,
              h = p :-> x \+ (p .+ 1 :-> r \+ h') &
              h' \In lseg r q (behead xs)].
Proof.
case: xs=>[|x xs] /=; first by case=>->->; left.
by case=>r [h'][->] H; right; hhauto.
Qed.

(* non-trivial segment represents a non-empty list *)

Corollary lseg_neq (xs : seq A) p q h :
        p != q -> h \In lseg p q xs ->
        exists x r h',
         [/\ xs = x :: behead xs,
             h = p :-> x \+ (p .+ 1 :-> r \+ h') &
             h' \In lseg r q (behead xs)].
Proof.
move=>H /lseg_case; case=>//; case=>E.
by rewrite E eq_refl in H.
Qed.

(* non-empty list is represented by a non-trivial segment *)

Corollary lseg_lt0n (xs : seq A) p q h :
        0 < size xs -> h \In lseg p q xs ->
        exists x r h',
         [/\ xs = x :: behead xs,
             h = p :-> x \+ (p .+ 1 :-> r \+ h') &
             h' \In lseg r q (behead xs)].
Proof.
move=>H /lseg_case; case=>//; case=>_ E.
by rewrite E in H.
Qed.

(* splitting the list corresponds to splitting the heap *)

Lemma lseg_cat (xs ys : seq A) p q h :
        h \In lseg p q (xs++ys) <->
          exists j, h \In lseg p j xs # lseg j q ys.
Proof.
elim: xs h p=>/=.
- move=>h p; split; first by move=>H; exists p, Unit, h; rewrite unitL.
  by case=>j[_][h2][{h}-> [->->]]; rewrite unitL.
move=>x xs IH h p; split.
- case=>r[_][{h}-> /IH][j][h1][h2][-> H1 H2].
  exists j, (p :-> x \+ p.+ 1 :-> r \+ h1), h2; rewrite !joinA; split=>//.
  by exists r, h1; rewrite joinA.
case=>j[_][h2][{h}-> [r][h1][-> H1 H2]].
exists r, (h1 \+ h2); rewrite !joinA; split=>//.
by apply/IH; exists j, h1, h2.
Qed.

End LSeg.

(* Special case when q = null, i.e. the list is self-contained *)
Definition lseq {A} p (xs : seq A) := lseg p null xs.

Section LList.
Variable (A : Type).

(* specializing the null and neq lemmas *)

Lemma lseq_null (xs : seq A) h :
        valid h -> h \In lseq null xs -> xs = [::] /\ h = Unit.
Proof. by move=>D; case/(lseg_null D)=>_ ->. Qed.

Lemma lseq_pos (xs : seq A) p h :
        p != null -> h \In lseq p xs ->
        exists x r h',
          [/\ xs = x :: behead xs,
              h = p :-> x \+ (p .+ 1 :-> r \+ h') &
              h' \In lseq r (behead xs)].
Proof. by apply: lseg_neq. Qed.

(* a valid heap cannot match two different specs *)

Lemma lseq_func (l1 l2 : seq A) p h :
        valid h -> h \In lseq p l1 -> h \In lseq p l2 -> l1 = l2.
Proof.
elim: l1 l2 p h => [|x1 xt IH] /= l2 p h V.
- by case=>->->; case/lseq_null.
case=>q1 /= [h1][E] H; rewrite {}E in H V *.
case/(lseq_pos (defPt_nullO V))=>x2 [q2][h2][->] /=.
do 2![case/(cancel V)=>/dynE/jmE<-{}V].
by move=><- /(IH (behead l2) _ _ V H)=>->.
Qed.

(* main methods *)

(* creating an empty list (a no-op) *)

Program Definition new : STsep (emp, [vfun x => lseq x (@nil A)]) :=
  Do (ret null).
Next Obligation. by move=>[] /= _ ->; step. Qed.

(* prepending a value *)

Program Definition insert p (x : A) :
  {l}, STsep (lseq p l, [vfun p' => lseq p' (x::l)]) :=
  Do (q <-- allocb p 2;
      q ::= x;;
      ret q).
Next Obligation.
(* pull out ghost var + precondition, run the first step *)
move=>p x [l][] i /= H; step=>q.
(* run the last 2 steps, guess the final pointer and heap from the goal *)
rewrite unitR -joinA; heval.
Qed.

(* getting the head element *)
(* an example of a partial program, doesn't modify the heap *)

Program Definition head p :
  {l}, STsep (lseq p l,
              fun (y : ans A) h => h \In lseq p l /\
                match y with Val v => l = v :: behead l
                           | Exn e => e = EmptyList /\ l = [::] end) :=
  Do (if p == null then throw EmptyList
        else v <-- !p;
             ret v).
Next Obligation.
(* pull out ghost + precondition, branch *)
move=>p [l][] i /= H; case: ifP H=>[/eqP-> H|/negbT Hp].
- (* there is no head element, abort *)
  step=>V; do!split=>//.
  (* the only non-trivial goal is the list being empty *)
  by case/lseq_null: H.
(* deconstruct non-empty list, run the rest *)
case/(lseq_pos Hp)=>v [r][h1][E {i}-> H1].
by do 2![step]=>_; split=>//; rewrite E; hhauto.
Qed.

(* removing the head element, no-op for an empty list *)

Program Definition remove p :
  {xs : seq A}, STsep (lseq p xs, [vfun p' => lseq p' (behead xs)]) :=
  Do (if p == null then ret p
      else pnext <-- !(p .+ 1);
           dealloc p;;
           dealloc p .+ 1;;
           ret pnext).
Next Obligation.
(* pull out ghost + precondition, branch *)
move=>p [xs][] i /= H; case: ifP H=>[/eqP-> H|/negbT Ep].
- (* the list must be empty *)
  by step=>V; case/lseq_null: H=>//->->.
(* deconstruct non-empty list, run the rest *)
case/(lseq_pos Ep)=>x [q][h][-> {i}-> /= H1].
by heval; rewrite 2!unitL.
Qed.

(* calculating the list length *)

(* the loop invariant: *)
(* 1. heap is unchanged *)
(* 2. total length is accumulator + the length of unprocessed list *)
Definition lenT : Type := forall (pl : ptr * nat),
  {xs : seq A}, STsep (lseq pl.1 xs,
                      [vfun l h => l == pl.2 + length xs /\ lseq pl.1 xs h]).

Program Definition len p :
  {xs : seq A}, STsep (lseq p xs,
                      [vfun l h => l == length xs /\ lseq p xs h]) :=
  Do (let len := Fix (fun (go : lenT) '(p, l) =>
                       Do (if p == null then ret l
                           else pnext <-- !(p .+ 1);
                                go (pnext, l + 1)))
      in len (p, 0)).
(* first, the loop *)
Next Obligation.
(* pull out ghosts+precondition, branch *)
move=>_ go _ p l /= [xs][] i /= H; case: eqP H=>[->|/eqP Ep] H.
- (* the end is reached *)
  by step=>V; case/(lseq_null V): H=>->->/=; rewrite addn0.
(* deconstruct non-empty list, run one step *)
case/lseq_pos: H=>// x0 [r][h'][-> {i}-> /= H1]; step.
apply: [gX (behead xs)]@h'=>//= _ h2 [/eqP -> Hl] /= _.
rewrite -addnA add1n; eauto.
Qed.
Next Obligation.
(* pull out the ghost var and immediately feed it to the loop *)
by move=>/= p [xs []] i /= H; apply: [gE xs].
Qed.

(* concatenation: modifies the first list, returning nothing *)

(* the loop invariant: *)
(* the first list should not be empty and not overlap the second *)
Definition catT (p2 : ptr) : Type :=
  forall (p1 : ptr), {xs1 xs2 : seq A},
    STsep (fun h => p1 != null /\ (lseq p1 xs1 # lseq p2 xs2) h,
           [vfun _ : unit => lseq p1 (xs1 ++ xs2)]).

Program Definition concat p1 p2 :
  {xs1 xs2 : seq A}, STsep (lseq p1 xs1 # lseq p2 xs2,
                           [vfun a => lseq a (xs1 ++ xs2)]) :=
  Do (let cat := Fix (fun (go : catT p2) q =>
                      Do (next <-- !(q .+ 1);
                          if (next : ptr) == null
                             then q .+ 1 ::= p2;;
                                  ret tt
                             else go next))
      in if p1 == null
           then ret p2
           else cat p1;;
                ret p1).
(* first, the loop *)
Next Obligation.
(* pull out ghosts + preconditions *)
move=>_ p2 go q [xs1][xs2][] _ /= [Hq][i1][i2][-> H1 H2].
(* deconstruct the first non-empty list, branch *)
case/(lseq_pos Hq): H1=>x [r][i][E {i1}-> H1]; step.
case: ifP H1=>[/eqP ->{r}|/negbT N] H1.
- (* we've reached the last node of the first list *)
  (* make it point to the second list *)
  do 2![step]=>V.
  (* the remaining heap for the first list is empty *)
  case/(lseq_null (validX V)): H1 E=>/=->->->/=.
  (* the rest is just the second list *)
  by rewrite unitR -joinA; eauto.
(* feed new ghosts and subheap to the recursive call *)
(* we use a generalized ghost autolemma here *)
apply: [gX (behead xs1), xs2]@(i \+ i2)=>//= _.
- (* the tail is not null so the precondition is satisfied *)
  by split=>//; vauto.
(* assemble the concatenation from head and tail *)
by move=>m H _; rewrite E /=; eauto.
Qed.
(* next, the initial call *)
Next Obligation.
(* pull out ghosts + preconditions, branch on null check *)
move=>p1 p2 [xs1][xs2][] /= _ [i1][i2][-> H1 H2].
case: ifP H1=>[/eqP ->|/negbT N] H1.
- (* first list is empty, the result simplifies to the second list *)
  by step=>V; case/(lseq_null (validL V)): H1=>->->; rewrite unitL.
(* otherwise, feed everything to the loop *)
by apply: [stepE xs1, xs2]=>//= [|_ m Hm]; heval.
Qed.

(* in-place reversal by pointer swinging *)

(* the loop invariant: *)
(* 1. the processed and remaining parts should not overlap *)
(* 2. the result is processed part + a reversal of remainder *)
Definition revT : Type := forall (p : ptr * ptr),
  {i done : seq A}, STsep (lseq p.1 i # lseq p.2 done,
                          [vfun y => lseq y (catrev i done)]).

Program Definition reverse p :
  {xs : seq A}, STsep (lseq p xs, [vfun p' => lseq p' (rev xs)]) :=
  Do (let reverse := Fix (fun (go : revT) '(i, done) =>
                          Do (if i == null then ret done
                              else next <-- !i .+ 1;
                                   i .+ 1 ::= done;;
                                   go (next, i)))
      in reverse (p, null)).
(* first, the loop *)
Next Obligation.
(* pull out ghosts + preconditions, branch *)
move=>_ go _ i done [x1][x2][] _ /= [i1][i2][-> H1 H2].
case: eqP H1=>[->|/eqP E] H1.
- (* nothing left to reverse, return the accumulator *)
  by step=>/validL V1; case/(lseq_null V1): H1=>->->/=; rewrite unitL.
(* deconstruct non-empty remainder *)
case/lseq_pos: H1=>// xd [xn][h'][-> {i1}-> /= H1].
(* swing the pointer, feed shifted ghosts to recursive call *)
do 2!step; apply: [gE (behead x1), xd::x2]=>//=.
(* rearrange the heap to match context *)
rewrite !(pull h') -!joinA; vauto.
Qed.
Next Obligation.
(* pull out ghost, feed it + empty accumulator to the loop *)
move=>p [xs][] /= i H; apply: [gE xs, [::]]=>//=; exists i; hhauto.
Qed.

Variable B : Type.

(* list mapping, an example of a higher-order function *)

(* the loop invariant: *)
(* the result is a mapped list *)
Definition lmapT (f : A -> B) :=
  forall (p : ptr),
    {xs : seq A}, STsep (lseq p xs,
                        [vfun _ : unit => lseq p (map f xs)]).

Program Definition lmap f : lmapT f :=
  Fix (fun (lmap : lmapT f) p =>
    Do (if p == null
        then ret tt
        else t <-- !p;
             p ::= f t;;
             nxt <-- !p .+ 1;
             lmap nxt)).
Next Obligation.
(* pull out ghost + precondition, branch *)
move=>f lmap p [xs][] h /= H; case: ifP H=>[/eqP ->|/negbT N] H.
- (* the list is empty *)
  by step=>V; case/(lseq_null V): H=>->->.
(* deconstruct non-empty list, run the rest *)
case/(lseq_pos N): H=>t [nxt][h'][-> {h}-> /= H]; heval.
(* feed the tail as a ghost var + subheap to recursive call *)
apply/[gX (behead xs)]@h'=>//= _ h2 Q V'; eauto.
Qed.

End LList.

Arguments head {A} p.
Arguments remove {A} p.