(* ---------------------------------------------------------------------

   This file is part of a repository containing the definitions and
   proof scripts related to the formalization of context-free language
   theory in Coq. Specifically, the following results were obtained:

   (i) languages square, prime and anbncn are not context-free;
   (ii) context-free languages are not closed under intersection.

   More information can be found in the paper "Some Applications of the
   Formalization of the Pumping Lemma for Context-Free Languages",
   submitted to LSFA 2018 by Marcus Vinícius Midena Ramos, Ruy J. G. B.
   de Queiroz, Nelma Moreira and José Carlos Bacelar Almeida.
   Also, in the thesis "Formalization of
   Context-Free Language Theory", submitted to the Informatics
   Center of the Pernambuco Federal University (CIn/UFPE) in
   Brazil.

   The file README.md describes the contents of each file and
   provides instructions on how to compile them.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

(* --------------------------------------------------------------------- *)
(* LIST LEMMAS                                                           *)
(* --------------------------------------------------------------------- *)

Require Import List.
Require Import Omega.

Require Import misc_arith.

Import ListNotations.
Open Scope list_scope.

Lemma map_expand:
forall (A B: Type) (f: A -> B) (l: list A) (s1 s2: list B),
s1 ++ s2 = map f l ->
exists s1' s2': list A,
l = s1' ++ s2' /\ map f s1' = s1 /\ map f s2' = s2.
Proof.
intros A B f l.
induction l.
- intros s1 s2 H.
  simpl in H.
  apply app_eq_nil in H.
  destruct H as [H1 H2].
  subst.
  exists [], [].
  auto.
- intros s1 s2 H.
  simpl in H.
  destruct s1.
  + simpl in H.
    destruct s2.
    * inversion H.
    * inversion H.
      exists [], (a::l). {
      split.
      - simpl.
        reflexivity.
      - split.
        + simpl.
          reflexivity.
        + simpl.
          reflexivity. }
  + destruct s2.
    * inversion H.
      exists (a::l), []. {
      split.
      - simpl.
        rewrite app_nil_r.
        reflexivity.
      - split.
        + simpl.
          rewrite <- H2.
          rewrite app_nil_r.
          reflexivity.
        + simpl.
          reflexivity. }
    * inversion H.
      specialize (IHl s1 (b0::s2)).
      specialize (IHl H2).
      destruct IHl as [s1' [s2' [H3 [H4 H5]]]].
      exists (a::s1').
      exists s2'. {
      split.
      - rewrite H3.
        simpl.
        reflexivity.
      - split.
        + simpl.
          rewrite H4.
          reflexivity.
        + rewrite H5.
          reflexivity. }
Qed.

Lemma equal_app (A: Type) :
forall l1 l2 s1 s2 : list A,
l1 ++ l2 = s1 ++ s2 ->
(exists l, s1 = l1 ++ l /\ l2 = l ++ s2) \/ (exists l, l1 = s1 ++ l /\ s2 = l ++ l2).
Proof.
intros l1.
induction l1 as [|a l1 IH].
- intros l2 s1 s2 H.
  simpl in H.
  subst.
  simpl.
  left.
  exists s1.
  split.
  reflexivity.
  reflexivity.
- intros l2 s1 s2 H.
  simpl in H.
  destruct s1 as [|a' s1].
  + simpl in H.
    subst.
    simpl.
    right.
    exists (a::l1).
    split.
    * reflexivity.
    * simpl.
      reflexivity.
  + simpl in H.
    inversion H.
    subst a'.
    clear H.
    apply IH in H2.
    destruct H2 as [(l & ? & ?) | (l & ? & ?)].
    * subst.
      simpl.
      left.
      exists l. {
      split.
      - reflexivity.
      - reflexivity. }
    * right.
      exists l. {
      split.
      - rewrite H.
        simpl.
        reflexivity.
      - rewrite H0.
        reflexivity. }
Qed.

Lemma last_last:
forall A: Type,
forall s d: A,
forall l: list A,
last (l++[s]) d = s.
Proof.
intros A s d l.
induction l.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + simpl.
    reflexivity.
  + rewrite <- app_comm_cons.
    exact IHl.
Qed.

Lemma length_ge_0:
forall A: Type,
forall l: list A,
length l >= 0.
Proof.
intros A l.
destruct l.
- simpl.
  omega.
- simpl.
  omega.
Qed.

Lemma length_ge_2:
forall A: Type,
forall a1 a2: A,
forall l: list A,
length (a1::a2::l) >= 2.
Proof.
intros A a1 a2 l.
simpl.
apply Le.le_n_S.
apply Le.le_n_S.
apply Le.le_0_n.
Qed.

Lemma length_lt_1:
forall A: Type,
forall l: list A,
length l < 1 -> l = [].
Proof.
intros A l H.
destruct l.
- reflexivity.
- replace (a::l) with ([a]++l) in H.
  + rewrite app_length in H.
    simpl in H.
    apply lt_S_n in H.
    apply lt_n_O in H.
    contradiction.
  + simpl.
    reflexivity.
Qed.

Lemma nth_cons:
forall A: Type,
forall a e: A,
forall l: list A,
forall i: nat,
nth (S i) (a::l) e = nth i l e.
Proof.
intros A a e l i.
simpl.
destruct i.
- simpl.
  reflexivity.
- reflexivity.
Qed.

Lemma length_not_zero:
forall A: Type,
forall l: list A,
length l > 0 -> [] <> l.
Proof.
intros A l H.
destruct l.
- simpl in H.
  apply gt_irrefl in H.
  contradiction.
- apply nil_cons.
Qed.

Lemma length_not_zero_inv:
forall A: Type,
forall l: list A,
l <> [] -> length l > 0.
Proof.
intros A l H.
destruct l.
- destruct H.
  reflexivity.
- simpl.
  omega.
Qed.

Lemma not_nil:
forall A: Type,
forall l: list A,
l <> [] -> length l <> 0.
Proof.
destruct l.
- intro H.
  auto.
- intro H.
  replace (a::l) with ([a]++l).
  + rewrite app_length.
    simpl.
    apply not_eq_sym.
    apply O_S.
  + simpl.
    reflexivity.
Qed.

Lemma not_nil_ge_1:
forall A: Type,
forall l: list A,
l <> [] -> length l >= 1.
Proof.
intros A l H.
apply not_nil in H.
destruct l.
- simpl in H.
  destruct H.
  reflexivity.
- simpl.
  apply le_n_S.
  apply le_0_n.
Qed.

Lemma list_last:
forall A: Type,
forall d: A,
forall l: list A,
removelast l <> [] -> nth (length (removelast l) - 1) (removelast l ++ [last l d]) d = last (removelast l) d.
Proof.
intros A d l H.
rewrite app_nth1 with (l:=removelast l).
- rewrite app_removelast_last with (l:=removelast l)(d:=d).
  + rewrite app_nth2.
    * rewrite app_length.
      assert (H1: Datatypes.length (removelast (removelast l)) + 1 - 1 -
                  Datatypes.length (removelast (removelast l)) = 0).
        {
        omega.
        }
      simpl.
      rewrite H1.
      rewrite last_last.
      reflexivity.
    * rewrite app_length.
      simpl.
      omega.
  + exact H.
- apply n_minus_1.
  apply not_nil.
  exact H.
Qed.

Lemma length_zero:
forall A: Type,
forall l: list A,
length l = 0 -> l = [].
Proof.
intros A l H.
destruct l.
- reflexivity.
- simpl in H.
  symmetry in H.
  apply O_S in H.
  contradiction.
Qed.

Lemma list_single:
forall A: Type,
forall l: list A,
forall d e: A,
nth 0 l d = e -> length l = 1 -> l = [e].
Proof.
intros A l d e H1 H2.
destruct l.
- simpl in H2.
  apply O_S in H2.
  contradiction.
- simpl in H1.
  rewrite H1.
  simpl in H2.
  inversion H2.
  apply length_zero in H0.
  rewrite H0.
  reflexivity.
Qed.

Lemma hd_nth0:
forall A: Type,
forall d: A,
forall l: list A,
hd d l = nth 0 l d.
Proof.
intros A d l.
destruct l.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma last_nth1:
forall A: Type,
forall d: A,
forall l: list A,
length l = 2 -> last l d = nth 1 l d.
Proof.
intros A d l H.
destruct l.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + simpl in H.
    inversion H.
  + replace (a :: a0 :: l) with ([a] ++ [a0] ++ l) in H.
    * repeat rewrite app_length in H.
      simpl in H.
      inversion H.
      apply length_zero in H1.
      subst.
      simpl.
      reflexivity.
    * simpl.
      reflexivity.
Qed.

Lemma hd_tl_nth1:
forall A: Type,
forall d: A,
forall l: list A,
length l > 2 -> hd d (tl l) = nth 1 l d.
Proof.
intros A d l H.
destruct l.
- simpl.
  reflexivity.
- simpl.
  apply hd_nth0.
Qed.

Lemma last_tl_last:
forall A: Type,
forall d: A,
forall l: list A,
length l > 2 -> last (tl l) d = last l d.
Proof.
intros A d l H.
destruct l.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + simpl in H.
    apply gt_S_n in H.
    apply lt_n_0 in H.
    contradiction.
  + reflexivity.
Qed.

Lemma nth_S:
forall A: Type,
forall i: nat,
forall s s0 s1: A,
forall l: list A,
nth (S i) (s::s0::s1::l) = nth i (s0::s1::l).
Proof.
intros A i s s0 s1 l.
destruct i.
- simpl.
  reflexivity.
- destruct i.
  + simpl.
    reflexivity.
  + destruct i.
    * simpl.
      reflexivity.
    * simpl.
      reflexivity.
Qed.

Lemma skipn_S:
forall i: nat,
forall A: Type,
forall a: A,
forall l: list A,
skipn (S i) (a :: l) = skipn i l.
Proof.
intros i A a l.
destruct i.
- simpl.
  reflexivity.
- simpl.
  destruct l.
  + reflexivity.
  + reflexivity.
Qed.

Lemma hd_skip:
forall i: nat,
forall A: Type,
forall d: A,
forall l: list A,
hd d (skipn i l) = nth i l d.
Proof.
intros i A d.
induction i as [| i IH].
- intros l.
  destruct l.
  + trivial.
  + trivial.
- intros l.
  destruct l.
  + trivial.
  + simpl.
    rewrite IH.
    reflexivity.
Qed.

Lemma last_skip:
forall i: nat,
forall A: Type,
forall d: A,
forall l: list A,
i < length l -> last (skipn i l) d = last l d.
Proof.
intros i A d.
induction i as [|i IH].
- intros l.
  destruct l.
  + trivial.
  + trivial.
- intros l.
  destruct l.
  + trivial.
  + simpl.
    intros Hl.
    assert (Hl' : i < length l) by omega.
    rewrite IH.
    * {
      destruct l.
      - simpl in Hl'.
        omega.
      - trivial.
      }
    * trivial.
Qed.

Lemma hd_hd:
forall A: Type,
forall d: A,
forall l l': list A,
length l >= 1 -> hd d l = hd d (l ++ l').
Proof.
intros A d l l' H.
destruct l.
- simpl in H.
  apply le_Sn_0 in H.
  contradiction.
- simpl.
  reflexivity.
Qed.

Lemma hd_first:
forall A: Type,
forall d: A,
forall l: list A,
forall i: nat,
i >= 1 -> hd d (firstn i l) = hd d l.
Proof.
intros A d l i H.
destruct l.
- destruct i.
  + simpl.
    reflexivity.
  + simpl.
    reflexivity.
- destruct i.
  + apply le_Sn_0 in H.
    contradiction.
  + simpl.
    reflexivity.
Qed.

Lemma firstn_empty:
forall A: Type,
forall a: A,
forall i: nat,
a :: firstn i [] = [a].
Proof.
intros A a i.
destruct i.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma firstn_single:
forall A: Type,
forall a: A,
forall i: nat,
firstn (S i) [a] = [a].
intros A a i.
destruct i.
- simpl.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma nth_S':
forall i: nat,
forall A: Type,
forall a d: A,
forall l: list A,
nth (S i) (a :: l) d = nth i l d.
Proof.
intros i A a d l.
destruct i.
- simpl. reflexivity.
- simpl. reflexivity.
Qed.

Lemma firstn_S:
forall A: Type,
forall a: A,
forall l: list A,
forall i: nat,
firstn (S i) (a :: l) = a :: firstn i l.
Proof.
intros A a l.
induction l.
- intros i. simpl. reflexivity.
- intros i. destruct i.
  + simpl. reflexivity.
  + simpl. reflexivity.
Qed.

Lemma last_cons:
forall A: Type,
forall a d: A,
forall l: list A,
l <> [] -> last (a :: l) d = last l d.
Proof.
intros A a d l H.
induction l.
- destruct H. reflexivity.
- trivial.
Qed.

Lemma not_nil_firstn:
forall A: Type,
forall l: list A,
forall i: nat,
l <> [] -> firstn (S i) l <> [].
Proof.
intros A l i H.
destruct l.
- simpl. exact H.
- simpl. apply not_eq_sym. apply nil_cons.
Qed.

Lemma nil_not_nil:
forall A: Type,
forall l: list A,
l = [] \/ l <> [].
Proof.
destruct l.
- left.
  reflexivity.
- right.
  apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma last_first_nth:
forall A: Type,
forall d: A,
forall l: list A,
forall i: nat,
length l >= S i -> last (firstn (S i) l) d = nth i l d.
Proof.
intros A d l.
induction l.
- destruct i.
  + trivial.
  + trivial.
- destruct i.
  + trivial.
  + intros H.
    rewrite nth_S'.
    rewrite <- IHl.
    * rewrite firstn_S.
      {
      rewrite last_cons.
      - reflexivity.
      - apply not_nil_firstn.
        specialize (IHl i).
        replace (a::l) with ([a]++l) in H.
        + rewrite app_length in H.
          simpl in H.
          assert (H1: length l > 0) by omega.
          destruct l.
          * simpl in H1.
            omega.
          * apply not_eq_sym.
            apply nil_cons.
        + simpl.
          reflexivity.
      }
    * {
      replace (a::l) with ([a]++l) in H.
      - rewrite app_length in H.
        simpl in H.
        omega.
      - simpl.
        reflexivity.
      }
Qed.

Lemma nth_last:
forall A: Type,
forall l: list A,
forall d: A,
nth (length l - 1) l d = last l d.
Proof.
intros A l d.
destruct l.
- simpl.
  reflexivity.
- remember (a::l) as l0.
  rewrite app_removelast_last with (l:=l0) (d:=d).
  + rewrite app_length.
    simpl.
    rewrite last_last.
    rewrite app_nth2.
    * assert (H: (Datatypes.length (removelast l0) + 1 - 1 - Datatypes.length (removelast l0) = 0)) by omega.
      rewrite H.
      simpl.
      reflexivity.
    * omega.
  + rewrite Heql0.
    apply not_eq_sym.
    replace (a::l) with ([]++a::l).
    * apply app_cons_not_nil.
    * simpl.
      reflexivity.
Qed.

Lemma hd_app:
forall A: Type,
forall l l': list A,
forall a d: A,
l <> [] ->
l' <> [] ->
hd d l = hd d l' ->
hd d (l ++ [a]) = hd d (l' ++ [a]).
Proof.
intros A l l' a d H1 H2 H3.
destruct l.
- destruct l'.
  + simpl.
    reflexivity.
  + destruct H1.
    reflexivity.
- destruct l'.
  + destruct H2.
    reflexivity.
  + simpl.
    simpl in H3.
    exact H3.
Qed.

Lemma last_2_1:
forall A: Type,
forall l: list A,
forall a1 a2 d: A,
last (a1 :: a2 :: l) d = last (a2 :: l) d.
Proof.
intros A l a1 a2 d.
simpl.
reflexivity.
Qed.

Lemma last_app:
forall A: Type,
forall l l': list A,
forall a d: A,
l <> [] ->
l' <> [] ->
last l d = last l' d ->
last ([a] ++ l) d = last ([a] ++ l') d.
Proof.
intros A l l' a d H1 H2 H3.
induction l, l'.
- simpl.
  reflexivity.
- destruct H1.
  reflexivity.
- destruct H2.
  reflexivity.
- replace ([a] ++ a0 :: l) with (a :: a0 :: l).
  + replace ([a] ++ a1 :: l') with (a :: a1 :: l').
    * repeat rewrite last_2_1.
      exact H3.
    * simpl.
      reflexivity.
  + simpl.
    reflexivity.
Qed.

Lemma hd_not_nil:
forall A: Type,
forall l: list A,
forall a d: A,
d <> a ->
hd d l = a ->
l <> [].
Proof.
intros A l a d H1 H2.
destruct l.
- simpl in H2.
  contradiction.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma hd_not_nil_v2:
forall A: Type,
forall l: list A,
forall d: A,
hd d l <> d -> l <> [].
Proof.
intros A l d H.
destruct l.
- simpl in H.
  destruct H.
  reflexivity.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma hd_not_zero:
forall A: Type,
forall l: list A,
forall a d: A,
d <> a ->
hd d l = a ->
length l > 0.
Proof.
intros A l a d H1 H2.
destruct l.
- simpl in H2.
  contradiction.
- simpl.
  apply gt_Sn_O.
Qed.

Lemma hd_removelast:
forall A: Type,
forall s d: A,
forall l l': list A,
l <> [] -> hd d (removelast (s :: l) ++ l') = s.
Proof.
intros A s d l l' H.
destruct l.
- destruct H.
  reflexivity.
- simpl.
  reflexivity.
Qed.

Lemma length_cons_gt_1:
forall A: Type,
forall s: A,
forall l: list A,
length (s :: l) > 1 -> l <> [].
Proof.
intros A s l H.
replace (s :: l) with ([s] ++ l) in H.
- rewrite app_length in H.
  simpl in H.
  apply gt_S_n in H.
  apply not_eq_sym.
  apply length_not_zero.
  exact H.
- simpl.
  reflexivity.
Qed.

Lemma length_cons_eq_1:
forall A: Type,
forall s: A,
forall l: list A,
length (s :: l) = 1 -> l = [].
Proof.
intros A s l H.
destruct l.
- reflexivity.
- simpl in H.
  apply eq_add_S in H.
  symmetry in H.
  apply O_S in H.
  contradiction.
Qed.

Lemma not_exists_forall_not:
forall A B: Type,
forall l: list (A+B),
~ (exists a': A, l = [inl a']) ->
forall a': A, (l <> [inl a']).
Proof.
intros A B l H a'.
unfold not at 1 in H.
unfold not.
destruct l.
- intro H1.
  inversion H1.
- intro H1.
  apply H.
  exists a'.
  exact H1.
Qed.

Lemma in_in:
forall A: Type,
forall s: A,
forall s1 s2: list A,
In s (s1 ++ [s] ++ s2).
Proof.
intros A s s1 s2.
induction s1.
- simpl.
  left.
  reflexivity.
- apply in_app_iff.
  right.
  simpl.
  left.
  reflexivity.
Qed.

Lemma in_out:
forall A: Type,
forall s: A,
forall l s1 s2: list A,
l = s1 ++ [s] ++ s2 ->
In s l.
Proof.
intros A s l s1 s2 H.
rewrite H.
apply in_in.
Qed.

Lemma exists_length_eq_2:
forall A: Type,
forall l: list A,
length l = 2 ->
exists s1 s2: A,
l = [s1] ++ [s2].
Proof.
intros A l H.
destruct l.
- simpl in H.
  apply O_S in H.
  contradiction.
- destruct l.
  + simpl in H.
    apply eq_add_S in H.
    apply O_S in H.
    contradiction.
  + destruct l.
    * exists a, a0.
      reflexivity.
    * simpl in H.
      repeat apply eq_add_S in H.
      symmetry in H.
      apply O_S in H.
      contradiction.
Qed.

Lemma exists_length_gt_2:
forall A: Type,
forall d: A,
forall l: list A,
length l > 2 ->
exists s1 s2: A,
exists l': list A,
l = [s1] ++ l' ++ [s2].
Proof.
intros A d l H.
destruct l.
- simpl in H.
  apply lt_n_0 in H.
  contradiction.
- destruct l.
  + simpl in H.
    apply gt_S_n in H.
    apply lt_n_0 in H.
    contradiction.
  + destruct l.
    * simpl in H.
      repeat apply gt_S_n in H.
      apply lt_n_0 in H.
      contradiction.
    * assert (H1: l = [] \/ l <> []).
        {
        apply nil_not_nil.
        }
      {
      destruct H1 as [H1 | H1].
      - subst.
        exists a, a1, [a0].
        reflexivity.
      - change (a :: a0 :: a1 :: l) with (([a] ++ [a0] ++ [a1]) ++ l) in H.
        exists a.
        rewrite app_removelast_last  with (A:=A) (l:=l) (d:=d).
        + exists (last l d).
          exists (a0 :: a1 :: removelast l).
          reflexivity.
        + exact H1.
      }
Qed.

Lemma exists_length_ge_2:
forall A: Type,
forall def: A,
forall l: list A,
length l >= 2 ->
exists s1 s2: A,
exists l': list A,
l = [s1] ++ l' ++ [s2].
Proof.
intros A def l H1.
assert (H2: length l > 2 \/ length l = 2) by omega.
destruct H2 as [H2 | H2].
- apply exists_length_gt_2 in H2.
  + exact H2.
  + exact def.
- apply exists_length_eq_2 in H2.
  destruct H2 as [s1 [s2 H3]].
  exists s1, s2, [].
  simpl.
  exact H3.
Qed.

Lemma length_eq_0:
forall A: Type,
forall l: list A,
length l = 0 -> l = [].
Proof.
intros A l H.
destruct l.
- reflexivity.
- change (a ::l) with ([a] ++ l) in H.
  rewrite app_length in H.
  simpl in H.
  symmetry in H.
  apply O_S in H.
  contradiction.
Qed.

Lemma elem_not_nil:
forall A: Type,
forall w1 w2: list A,
forall X: A,
w1 ++ [X] ++ w2 <> [].
Proof.
intros A w1 w2 X.
destruct w1.
- simpl.
  apply not_eq_sym.
  apply nil_cons.
- simpl.
  apply not_eq_sym.
  replace (a :: w1 ++ X :: w2) with (([a] ++ w1) ++ [X] ++ w2).
  + apply app_cons_not_nil.
  + simpl.
    reflexivity.
Qed.

Lemma map_map_app:
forall A B : Type,
forall f: A -> B,
forall x y: list A,
forall z: list B,
map f x = map f y ++ z ->
exists z': list A,
z = map f z'.
Proof.
intros A B f x y z H.
symmetry in H.
apply map_expand in H.
destruct H as [s1' [s2' [H1 [H2 H3]]]].
exists s2'.
symmetry.
exact H3.
Qed.

Lemma cat_left:
forall A: Type,
forall a: A,
forall l1 l2: list A,
l1 = l2 -> [a] ++ l1 = [a] ++ l2.
Proof.
intros A a l1 l2 H.
rewrite H.
reflexivity.
Qed.

Lemma map_not_nil:
forall A B: Type,
forall f: A -> B,
forall l: list A,
map f l <> [] -> l <> [].
Proof.
intros A B f l H.
destruct l.
- destruct H.
  simpl.
  reflexivity.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma map_not_nil_inv:
forall A B: Type,
forall f: A -> B,
forall l: list A,
l <> [] -> map f l <> [].
Proof.
intros A B f l H.
destruct l.
- destruct H.
  reflexivity.
- simpl.
  apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma app_not_nil:
forall A: Type,
forall x y: list A,
x ++ y <> [] ->
(x <> [] \/ y <> []).
Proof.
intros A x y H.
assert (H1: x = [] \/ x <> []).
  {
  apply nil_not_nil.
  }
assert (H2: y = [] \/ y <> []).
  {
  apply nil_not_nil.
  }
destruct H1 as [H1 | H1].
- destruct H2 as [H2 | H2].
  + rewrite H1 in H.
    rewrite H2 in H.
    simpl in H.
    destruct H.
    reflexivity.
  + right.
    exact H2.
- destruct H2 as [H2 | H2].
  + rewrite H2 in H.
    rewrite app_nil_r in H.
    left.
    exact H.
  + left.
    exact H1.
Qed.

Lemma app_not_nil_inv:
forall A: Type,
forall x y: list A,
(x <> [] \/ y <> []) ->
x ++ y <> [].
Proof.
intros A x y H.
destruct H as [H | H].
- intros H2.
  apply app_eq_nil in H2.
  destruct H2 as [H2 _].
  contradiction.
- intros H2.
  apply app_eq_nil in H2.
  destruct H2 as [_ H2].
  contradiction.
Qed.

Lemma list_not_nil:
forall A: Type,
forall l: list A,
l <> [] ->
exists l1 l2 l3: list A,
l = l1 ++ l2 ++ l3 /\
l2 <> [].
Proof.
intros A l H.
destruct l.
- destruct H.
  reflexivity.
- exists [], [a], l.
  split.
  + simpl.
    reflexivity.
  + apply not_eq_sym.
    apply nil_cons.
Qed.

Lemma app_eq:
forall A: Type,
forall a: A,
forall l1 l2: list A,
l1 = l2 -> [a] ++ l1 = [a] ++ l2.
Proof.
intros A a l1 l2 H.
destruct l1, l2.
- simpl.
  reflexivity.
- inversion H.
- inversion H.
- rewrite H.
  reflexivity.
Qed.

Lemma list_single_elem:
forall A: Type,
forall l1 l2: list A,
forall a b: A,
l1 ++ a :: l2 = [b] ->
l1 = []/\ l2 = [].
Proof.
intros A l1 l2 a b H1.
split.
- destruct l1.
  + reflexivity.
  + inversion H1.
    destruct l1.
    * inversion H2.
    * inversion H2.
- destruct l1.
  + inversion H1.
    reflexivity.
  + inversion H1.
    destruct l1.
    * inversion H2.
    * inversion H2.
Qed.

Lemma last_not_nil:
forall A: Type,
forall l: list A,
forall d: A,
(last l d) <> d -> l <> [].
Proof.
intros A l d H.
destruct l.
- simpl in H.
  destruct H.
  reflexivity.
- apply not_eq_sym.
  apply nil_cons.
Qed.

Lemma app_cons_eq:
forall A: Type,
forall s1 s2: list A,
forall a b: A,
s1 ++ a :: s2 = [b] ->
s1 = [] /\ s2 = [] /\ a = b.
Proof.
intros A s1 s2 a b H.
destruct s1.
- inversion H.
  subst.
  auto.
- inversion H.
  destruct s1.
  + inversion H2.
  + inversion H2.
Qed.

Lemma not_in_not_eq:
forall A: Type,
forall a b: A,
~ In a [b] -> a <> b.
Proof.
intros A a b H.
simpl in H.
intros H2.
apply H.
left.
symmetry.
exact H2.
Qed.

Lemma inl_neq:
forall X Y: Type,
forall a b: X,
@inl X Y a <> @inl X Y b -> a <> b.
Proof.
intros X Y a b H.
intro.
apply H.
subst.
reflexivity.
Qed.

Lemma length_cons_le:
forall A: Type,
forall l1 l2: list A,
forall a: A,
forall n: nat,
length (l1 ++ a :: l2) <= n ->
length (l1 ++ l2) <= n.
Proof.
intros A l1 l2 a n H.
rewrite app_length.
change (a :: l2) with ([a] ++ l2) in H.
repeat rewrite app_length in H.
simpl in H.
omega.
Qed.

Lemma in_app_cons:
forall A: Type,
forall l1 l2: list A,
forall a b: A,
In a (l1 ++ l2) ->
In a (l1 ++ b :: l2).
Proof.
intros A l1 l2 a b H.
apply in_app_or in H.
apply in_or_app.
destruct H as [H | H].
- left.
  exact H.
- right.
  change (b :: l2) with ([b] ++ l2).
  apply in_or_app.
  right.
  exact H.
Qed.

Lemma cons_app:
forall (A: Type) (s: A) (l: list A),
s :: l = [s] ++ l.
Proof.
intros.
simpl.
reflexivity.
Qed.

Lemma length_map_ge:
forall A B: Type,
forall n: nat,
forall f: A -> B,
forall s: list A,
length s >= n ->
length (map f s) >= n.
Proof.
induction n, s.
- simpl.
  auto.
- simpl.
  intros H.
  omega.
- simpl.
  auto.
- simpl.
  intros H.
  apply le_S_n in H.
  specialize (IHn f s H).
  apply le_n_S in IHn.
  exact IHn.
Qed.

Lemma length_map_le:
forall A B: Type,
forall n: nat,
forall f: A -> B,
forall s: list A,
length s <= n ->
length (map f s) <= n.
Proof.
induction n, s.
- simpl.
  auto.
- simpl.
  intros H.
  omega.
- simpl.
  auto.
- simpl.
  intros H.
  apply le_S_n in H.
  specialize (IHn f s H).
  apply le_n_S in IHn.
  exact IHn.
Qed.

Lemma length_map_le_inv:
forall A B: Type,
forall n: nat,
forall f: A -> B,
forall s: list A,
length (map f s) <= n ->
length s <= n.
Proof.
induction n, s.
- simpl.
  auto.
- simpl.
  intros H.
  omega.
- simpl.
  auto.
- simpl.
  intros H.
  apply le_S_n in H.
  specialize (IHn f s H).
  apply le_n_S in IHn.
  exact IHn.
Qed.

Lemma map_eq:
forall A B: Type,
forall f: A -> B,
forall l1 l2: list A,
injective A B f ->
map f l1 = map f l2 -> l1 = l2.
Proof.
intros A B f.
induction l1.
- intros l2 H1 H2.
  simpl in H2.
  symmetry in H2.
  apply map_eq_nil in H2.
  symmetry.
  exact H2.
- intros l2 H1 H2.
  simpl in H2.
  destruct l2.
  + simpl in H2.
    inversion H2.
  + simpl in H2.
    inversion H2.
    assert (H1':= H1).
    specialize (H1 a a0 H0).
    specialize (IHl1 l2 H1' H3).
    subst.
    reflexivity.
Qed.

Fixpoint iter {A: Type} (w: list A) (n: nat): list A:=
match n with
| O => []
| S n => w ++ iter w n
end.

Lemma iter_comm:
forall A: Type,
forall l: list A,
forall i: nat,
l ++ iter l i = iter l i ++ l.
Proof.
intros A l i.
revert l.
induction i.
- simpl.
  intros l.
  rewrite app_nil_r.
  reflexivity.
- intros l.
  simpl.
  rewrite <- app_assoc.
  rewrite <- IHi.
  reflexivity.
Qed.

Lemma iter_length:
forall A: Type,
forall w: list A,
forall i: nat,
length (iter w i) = i*(length w).
Proof.
induction i.
- simpl.
  reflexivity.
- simpl.
  rewrite app_length.
  rewrite IHi.
  reflexivity.
Qed.

Lemma cons_neq:
forall A: Type,
forall a: A,
forall l: list A,
l <> a :: l.
Proof.
intros A a l.
induction l.
- intros H.
  inversion H.
- intros H.
  inversion H.
  contradiction.
Qed.

Lemma list_split:
forall A: Type,
forall l: list A,
forall n m: nat,
length l = n + m ->
exists l1 l2: list A,
l = l1 ++ l2 /\
length l1 = n /\
length l2 = m.
Proof.
intros A l n m H1.
assert (H2: firstn n l ++ skipn n l = l).
  {
  apply firstn_skipn.
  }
assert (H3: length (firstn n l) = min n (length l)).
  {
  apply firstn_length.
  }
assert (H4: min n (n + m) = n).
  {
  apply min_l.
  omega.
  }
assert (H5: length (firstn n l) = n).
  {
  rewrite H1 in H3.
  rewrite H4 in H3.
  exact H3.
  }
clear H3 H4.
rewrite <- H2 in H1.
rewrite app_length in H1.
rewrite H5 in H1.
assert (H6: length (skipn n l) = m) by omega.
exists (firstn n l), (skipn n l).
split.
- symmetry.
  exact H2.
- split.
  + exact H5.
  + exact H6.
Qed.

Lemma list_split_exists:
forall A: Type,
forall l: list A,
exists l1 l2: list A,
l = l1 ++ l2.
Proof.
intros A.
induction l.
- exists [], [].
  reflexivity.
- destruct IHl as [l1 [l2 IHl]].
  rewrite IHl.
  exists (a :: l1), l2.
  reflexivity.
Qed.

Fixpoint get_As (A B: Type) (l: list (A + B)): list A:=
match l with
| [] => []
| inl a :: l => a :: get_As A B l
| inr b :: l => get_As A B l
end.

Lemma get_As_correct:
forall A B: Type,
forall r: list (A + B),
(forall e: (A + B), In e r -> exists a: A, e = inl a) ->
r = map inl (get_As A B r).
Proof.
intros A B r H.
induction r.
- simpl.
  reflexivity.
- destruct a.
  + simpl.
    rewrite <- IHr.
    * reflexivity.
    * intros e H1.
      apply H.
      simpl.
      right.
      exact H1.
  + specialize (H (inr b)).
    assert (H1: In (inr b) (inr b :: r)).
      {
      simpl.
      left.
      reflexivity.
      }
    specialize (H H1).
    destruct H as [n H].
    discriminate.
Qed.

Fixpoint get_Bs (A B: Type) (l: list (A + B)): list B:=
match l with
| [] => []
| inl a :: l => get_Bs A B l
| inr b :: l => b :: get_Bs A B l
end.

Lemma get_Bs_correct:
forall A B: Type,
forall r: list (A + B),
(forall e: (A + B), In e r -> exists b: B, e = inr b) ->
r = map inr (get_Bs A B r).
Proof.
intros A B r H.
induction r.
- simpl.
  reflexivity.
- destruct a.
  + specialize (H (inl a)).
    assert (H1: In (inl a) (inl a :: r)).
      {
      simpl.
      left.
      reflexivity.
      }
    specialize (H H1).
    destruct H as [n H].
    discriminate.
  + simpl.
    rewrite <- IHr.
    * reflexivity.
    * intros e H1.
      apply H.
      simpl.
      right.
      exact H1.
Qed.

Lemma split_app:
forall A: Type,
forall l l1 l2: list A,
l = l1 ++ l2 ->
exists l' l'': list A,
l = l' ++ l'' /\
l' = l1 /\
l'' = l2.
Proof.
intros A l.
destruct l.
- intros l1 l2 H.
  symmetry in H.
  apply app_eq_nil in H.
  destruct H as [H H1].
  subst.
  exists [], [].
  simpl.
  auto.
- intros l1 l2 H.
  exists l1, l2.
  split.
  + exact H.
  + auto.
Qed.

Lemma not_nil_app:
forall A: Type,
forall l1 l2: list A,
l1 <> [] ->
l1 ++ l2 <> [].
Proof.
intros A l1 l2 H.
destruct l1.
- destruct H.
  reflexivity.
- apply not_eq_sym.
  intros H1.
  inversion H1.
Qed.

Fixpoint flat {A: Type} (l: list (list A)): list A:=
match l with
| [] => []
| s :: l => s ++ flat l
end.

Lemma flat_app:
forall A: Type,
forall l1 l2: list (list A),
flat (l1 ++ l2) = flat l1 ++ flat l2.
Proof.
induction l1.
- simpl.
  reflexivity.
- intros l2.
  simpl.
  specialize (IHl1 l2).
  rewrite IHl1.
  rewrite <- app_assoc.
  reflexivity.
Qed.

Lemma app_single:
forall A: Type,
forall l1 l2: list A,
forall a: A,
l1 ++ l2 = [a] ->
l1 = [a] /\ l2 = [] \/
l1 = [] /\ l2 = [a].
Proof.
intros A l1 l2 a H.
destruct l1, l2.
- inversion H.
- inversion H.
  subst.
  right.
  auto.
- inversion H.
  subst.
  left.
  rewrite app_nil_r.
  auto.
- inversion H.
  destruct l1.
  + inversion H2.
  + inversion H2.
Qed.

Lemma length_tl:
forall A: Type,
forall w: list A,
forall i: nat,
length w = i ->
i > 0 ->
length (tl w) = i - 1.
Proof.
destruct w.
- intros i H1 H2.
  simpl in H1.
  omega.
- intros i H1 H2.
  simpl.
  simpl in H1.
  omega.
Qed.

Lemma length_split_3:
forall A: Type,
forall i n: nat,
forall w x y z: list A,
length w = 3*n ->
w=x++y++z ->
length x = i ->
length y = i ->
length z = i ->
n = i.
Proof.
destruct i.
- intros n w x y z H1 H2 H3 H4 H5.
  apply length_zero in H3.
  apply length_zero in H4.
  apply length_zero in H5.
  rewrite H3, H4, H5 in H2.
  rewrite H2 in H1.
  simpl in H1.
  omega.
- intros n w x y z H1 H2 H3 H4 H5.
  rewrite H2 in H1.
  repeat rewrite app_length in H1.
  rewrite H3, H4, H5 in H1.
  omega.
Qed.

Lemma length_split_4:
forall A: Type,
forall i n: nat,
forall w v x y z: list A,
length w = 4*n ->
w=v++x++y++z ->
length v = i ->
length x = i ->
length y = i ->
length z = i ->
n = i.
Proof.
destruct i.
- intros n w v x y z H1 H2 H3 H4 H5 H6.
  apply length_zero in H3.
  apply length_zero in H4.
  apply length_zero in H5.
  apply length_zero in H6.
  rewrite H3, H4, H5, H6 in H2.
  rewrite H2 in H1.
  simpl in H1.
  omega.
- intros n w v x y z H1 H2 H3 H4 H5 H6.
  rewrite H2 in H1.
  repeat rewrite app_length in H1.
  rewrite H3, H4, H5, H6 in H1.
  omega.
Qed.

Lemma app_last:
forall A: Type,
forall w1 w2: list A,
forall d: A,
w2 <> [] -> last (w1++w2) d = last w2 d.
Proof.
induction w1.
- intros w2 d _.
  rewrite app_nil_l.
  reflexivity.
- intros w2 d H1.
  simpl.
  rewrite IHw1.
  + destruct w1, w2.
    * destruct H1.
      reflexivity.
    * simpl.
      reflexivity.
    * simpl.
      reflexivity.
    * simpl.
      reflexivity.
  + exact H1.
Qed.

Lemma hd_to_last:
forall A: Type,
forall w: list A,
forall t: A,
exists w': list A,
exists t': A,
t::w=w'++[t'].
Proof.
induction w.
- intros t.
  exists [], t.
  reflexivity.
- intros t.
  specialize (IHw t).
  destruct IHw as [w' [t' IHw]].
  destruct w'.
  + inversion IHw.
    exists [t'], a.
    reflexivity.
  + inversion IHw.
    exists (a0::a::w'), t'.
    reflexivity.
Qed.

Lemma length_iter:
forall A: Type,
forall a: A,
forall n: nat,
length (iter [a] n) = n.
Proof.
intros A a.
induction n.
- simpl.
  reflexivity.
- simpl.
  rewrite IHn.
  reflexivity.
Qed.

Lemma iter_sym:
forall A: Type,
forall a: A,
forall n: nat,
iter [a] n ++ [a] = [a] ++ iter [a] n.
Proof.
intros A a.
induction n.
- simpl.
  reflexivity.
- simpl.
  rewrite IHn.
  reflexivity.
Qed.

Lemma app_single_v2:
forall A: Type,
forall s1 s2: list A,
forall a b: A,
s1 ++ [a] ++ s2 = [b] ->
s1=[] /\ s2=[] /\ a=b.
Proof.
intros A s1 s2 a b H1.
split.
- destruct s1.
  + reflexivity.
  + inversion H1.
    apply app_eq_nil in H2.
    destruct H2 as [_ H2].
    inversion H2.
- split.
  + destruct s1.
    * simpl in H1.
      inversion H1.
      reflexivity.
    * inversion H1.
      apply app_eq_nil in H2.
      destruct H2 as [_ H2].
      inversion H2.
  + destruct s1.
    * inversion H1.
      reflexivity.
    * inversion H1.
      apply app_eq_nil in H2.
      destruct H2 as [_ H2].
      inversion H2.
Qed.

Lemma not_empty_eq_app_single:
forall A: Type,
forall a: A,
forall s: list A,
~ [] = s ++ [a].
Proof.
intros A a s H.
destruct s.
- inversion H.
- inversion H.
Qed.

Lemma length_gt_0:
forall A: Type,
forall w: list A,
length w > 0 ->
(exists w': list A, exists a: A, w = [a] ++ w') /\
(exists w': list A, exists a: A, w = w' ++ [a]).
Proof.
intros A w H1.
split.
- destruct w.
  + simpl in H1.
    omega.
  + exists w, a.
    reflexivity.
- apply length_not_zero in H1.
  apply not_eq_sym in H1.
  apply exists_last in H1.
  destruct H1 as [l' [a H1]].
  exists l', a.
  exact H1.
Qed.

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

Section Sublist.

Variable A: Type.

Definition sublist {A: Type} (w1 w2: list A): Prop:=
exists p s: list A,
w1 = p ++ w2 ++ s.

Lemma sublist_cat_l:
forall w1 w2: list A,
sublist w1 w2 ->
forall w: list A,
sublist (w++w1) w2.
Proof.
intros w1 w2 H1.
induction w.
- exact H1.
- destruct IHw as [p [s IHw]].
  change ((a :: w) ++ w1) with (a :: (w ++ w1)).
  rewrite IHw.
  exists (a :: p),s.
  reflexivity.
Qed.

Lemma sublist_last:
forall w1 w2: list A,
sublist w1 w2 ->
forall t: A,
sublist (w1 ++ [t]) w2.
Proof.
intros w1 w2 H1 t.
destruct H1 as [p [s H1]].
rewrite H1.
exists p,(s++[t]).
repeat rewrite <- app_assoc.
reflexivity.
Qed.

Lemma sublist_cat_r:
forall w1 w2: list A,
sublist w1 w2 ->
forall w: list A,
sublist (w1++w) w2.
Proof.
intros w1 w2 H1 w.
revert w1 w2 H1.
induction w.
- intros w1 w2 H1.
  rewrite app_nil_r.
  exact H1.
- intros w1 w2 H1.
  specialize (IHw (w1 ++ [a]) w2).
  apply sublist_last with (t:=a) in H1.
  specialize (IHw H1).
  change (w1 ++ a :: w) with (w1 ++ [a] ++ w).
  repeat rewrite <-app_assoc in IHw.
  exact IHw.
Qed.

End Sublist.

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

Section Suffix.

Variable A: Type.

Definition suffix_v1 (l1 l2: list A): Prop:=
exists l,
l2 = l ++ l1.

Inductive suffix_v2: list A -> list A -> Prop:=
| suffix_eq:  forall l1 l2: list A, l1 = l2 -> suffix_v2 l1 l2
| suffix_app: forall l1 l2: list A, forall a: A, suffix_v2 l1 l2 -> suffix_v2 l1 (a :: l2).

Fixpoint suffix_v3 (l1 l2: list A): Prop:=
l1 = l2 \/
match l2 with
| [] => False
| e :: l' => suffix_v3 l1 l'
end.

Lemma suffix_v1_nil:
forall l: list A,
suffix_v1 [] l.
Proof.
intros l.
exists l.
rewrite app_nil_r.
reflexivity.
Qed.

Lemma suffix_v2_nil:
forall l: list A,
suffix_v2 [] l.
Proof.
induction l.
- apply suffix_eq.
  reflexivity.
- apply suffix_app.
  exact IHl.
Qed.

Lemma suffix_v3_nil:
forall l: list A,
suffix_v3 [] l.
Proof.
intros l.
induction l.
- simpl.
  left.
  reflexivity.
- simpl.
  right.
  exact IHl.
Qed.

Lemma suffix_v1_equiv_suffix_v2:
forall l1 l2: list A,
suffix_v1 l1 l2 <-> suffix_v2 l1 l2.
Proof.
intros l1 l2.
split.
- intros H.
  destruct H as [l H].
  subst.
  induction l.
  + simpl.
    apply suffix_eq.
    reflexivity.
  + simpl.
    apply suffix_app.
    exact IHl.
- intros H.
  induction H.
  + subst.
    exists [].
    reflexivity.
  + destruct IHsuffix_v2 as [l IHsuffix_v2].
    subst.
    exists (a :: l).
    reflexivity.
Qed.

Lemma suffix_v2_equiv_suffix_v3:
forall l1 l2: list A,
suffix_v2 l1 l2 <-> suffix_v3 l1 l2.
Proof.
intros l1 l2.
split.
- intros H.
  induction H.
  + subst.
    destruct l2.
    * simpl.
      left.
      reflexivity.
    * simpl.
      left.
      reflexivity.
  + simpl.
    right.
    exact IHsuffix_v2.
- generalize dependent l2.
  induction l2.
  + intros H.
    simpl in H.
    destruct H as [H | H].
    * subst.
      apply suffix_eq.
      reflexivity.
    * contradiction.
  + intros H.
    simpl in H.
    destruct H as [H | H].
    * subst.
      apply suffix_eq.
      reflexivity.
    * apply suffix_app.
      apply IHl2.
      exact H.
Qed.

Lemma suffix_v1_split:
forall l1 l2: list A,
suffix_v1 l1 l2 ->
exists l: list A,
l ++ l1 = l2.
Proof.
intros l1 l2 H.
unfold suffix_v1 in H.
destruct H as [l H].
subst.
exists l.
reflexivity.
Qed.

Lemma suffix_v2_split:
forall l1 l2: list A,
suffix_v2 l1 l2 ->
exists l: list A,
l ++ l1 = l2.
Proof.
intros l1 l2 H.
induction H.
- subst.
  exists [].
  reflexivity.
- destruct IHsuffix_v2 as [l H2].
  rewrite <- H2.
  exists (a :: l).
  reflexivity.
Qed.

Lemma suffix_v3_split:
forall l1 l2: list A,
suffix_v3 l1 l2 ->
exists l: list A,
l ++ l1 = l2.
Proof.
induction l2.
- intros H.
  simpl in H.
  destruct H as [H | H].
  + subst.
    exists [].
    reflexivity.
  + contradiction.
- intros H.
  simpl in H.
  destruct H as [H | H].
  + subst.
    exists [].
    reflexivity.
  + specialize (IHl2 H).
    destruct IHl2 as [l H2].
    subst.
    exists (a :: l).
    reflexivity.
Qed.

End Suffix.


(**
----
_This file is part of_

----
*** A Formal Definition of JML in Coq #
# and its Application to Runtime Assertion Checking
Ph.D. Thesis by Hermann Lehner
----
Online available at #jmlcoq.info#

Authors:
  - Hermann Lehner
  - David Pichardie (Bicolano)
  - Andreas Kaegi (Syntax Rewritings, Implementation of ADTs)

Copyright 2011 Hermann Lehner

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

----
*)

From Coq Require Import List Arith.

(**
  Useful functions on lists, not part of the Coq standard library.
  Most functions are taken from the Haskell standard libary module Data.List.

 *)

Section ListFunctions.
  Variable A : Type.
  Variable B : Type.
  Variable P : A -> Prop.
  Variable P_dec : forall a, {P a}+{~ P a}.

  (** Make a singleton list from the given element a. *)
  Definition singleton (a:A) : list A := a :: nil.

  (** Drop all prefix elements of l that satisfy p. *)
  Fixpoint dropWhile (p:A->bool) (l:list A) {struct l} : list A :=
    match l with
    | nil     => nil
    | (x::xs) => if p x then dropWhile p xs else xs
    end.

  (** Concatenate all given lists into a flat list. *)
  Definition concat : list (list A) -> list A := flat_map (fun x:list A => x).

  (** Maximum element of the given list of natural numbers. *)
  Fixpoint maximum (e:nat) (l:list nat) {struct l} : nat :=
    match l with
    | nil     => e
    | (x::xs) => max x (maximum e xs)
    end.

  (**
    Like fold_left but take e for the empty list.
    e is not used for a non-empty list.
   *)
  Definition fold_left1 (op:A->A->A) (l:list A) (e:A) : A :=
    match l with
    | nil   => e
    | x::xs => fold_left op xs x
    end.

  (**
    Like fold_right but take e for the empty list.
    e is not used for a non-empty list.
   *)
  Fixpoint fold_right1 (op:A->A->A) (l:list A) (e:A) : A :=
    match l with
    | nil    => e
    | x::nil => x
    | x::xs  => op x (fold_right1 op xs e)
    end.

  Program Fixpoint Find (l : list A) {struct l} :
    { a : A | In a l & P a }+{ AllS (fun a' => ~ P a') l } :=
    match l with
    | nil => inright _
    | a0 :: l' =>
      match P_dec a0 with
      | left Hdec => inleft (exist2 _ _ a0 _ _)
      | right Hdec =>
        match Find l' with
        | inleft (exist2 _ _ a1 _ _) => inleft (exist2 _ _ a1 _ _)
        | inright Hdec => inright _
        end
      end
    end.

End ListFunctions.

Arguments singleton [A].
Arguments dropWhile [A].
Arguments concat [A].
Arguments fold_left1 [A].
Arguments fold_right1 [A].

Inductive Expr : Set :=
    | Lit : nat -> Expr
    | Add : Expr -> Expr -> Expr.

(* Eval compute in fold_right1 Add (Lit 1 :: Lit 2 :: Lit 3 :: nil) (Lit 10). *)

Section Proofs.
  Variable A : Type.

  (**
    For every element y in the result list (concat l),
    there exists a list x in l that contains y.
   *)
  Lemma in_concat : forall (l:list (list A)) (y:A),
    In y (concat l) <-> exists x, In x l /\ In y x.
  Proof.
    apply (in_flat_map (fun x:list A => x)).
  Qed.

  (** e is the maximum of the empty list. *)
  Lemma maximum_e_nil : forall (e:nat) (l:list nat), l=nil -> maximum e l=e.
  Proof.
    intros e l H.
    rewrite H.
    simpl.
    reflexivity.
  Qed.

  (** maximum is composable using max and cons. *)
  Lemma maximum_e_cons : forall (e:nat) (x:nat) (l:list nat),
    maximum e (x::l) = max x (maximum e l).
  Proof.
    intros e x l.
    simpl.
    reflexivity.
  Qed.

  (** fold_left1 op nil e = e *)
  Lemma fold_left1_e_nil : forall (op:A->A->A) (e:A) (l:list A),
    l=nil ->
    fold_left1 op l e = e.
  Proof.
    intros op e l H.
    rewrite H.
    simpl.
    reflexivity.
  Qed.

  (** fold_left1 op (x::l) e = fold_left1 op l x,
     e vanishes for a non-empty list.
    *)
  Lemma fold_left1_fold_left : forall (op:A->A->A) (e:A) (x:A) (l:list A),
    fold_left1 op (x::l) e = fold_left op l x.
  Proof.
    intros op e x l.
    simpl.
    reflexivity.
  Qed.

  (** The element found by find satisfies predicate p. *)
  Lemma find_def : forall (p:A->bool) (l:list A) (x:A), find p l = Some x -> p x = true.
  Proof.
    intros p l x H.
    induction l.
    (* BC *)
    discriminate H.
    (* IH *)
    simpl in H.
    assert (p a = true \/ p a = false).
    case (p a); auto.

    elim H0; intro Hpa; rewrite Hpa in H.
    congruence.
    auto.
  Qed.

End Proofs.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

Require Import int.EuclideanDivision.

(* Why3 goal *)
Lemma div2 : forall (x:Z), exists y:Z, (x = (2%Z * y)%Z) \/
  (x = ((2%Z * y)%Z + 1%Z)%Z).
Proof.
intros x.
exists (div x 2).
refine (_ (Mod_bound x 2 _) (Div_mod x 2 _)) ; try easy.
intros H1 H2.
simpl in H1.
omega.
Qed.


From AIM Require Export Coqlib.
From AIM Require Export Map.
Require Import Arith.
From AIM Require Export Machine.
From AIM Require Export Assertions.
Require Import Lia.
From AIM Require Export Mem_Lemmas.
From AIM Require Export Assertion_Lemmas.

Set Implicit Arguments.
Unset Strict Implicit.

(* ************************************************)
(* portage                                        *)

Definition mjudge (h : Mem) (A : MPred) := A h.

Notation "M ||- A" := (mjudge M A) (at level 80).

Notation " A ** B " := (mstar A B) (at level 67, right associativity).

Notation "A ==> B" :=
  (forall M, M ||- A -> M ||- B) (at level 13).

Notation "A <==> B" :=
  (forall M, M ||- A <-> M ||- B) (at level 13).

Implicit Types A B C D : MPred.

Implicit Types M h : Mem.

Notation sconj := mstar (only parsing).

Notation join := MemMod.disjUnion (only parsing).

Notation emp := MemMod.emp (only parsing).

Notation meq := mEq (only parsing).

Notation unit := Aemp (only parsing).

Lemma join_comm : forall M1 M2 M,
  join M1 M2 M -> join M2 M1 M.
Proof.
  intros M1 M2 M.
  auto with PMap.
Qed.

Definition bang (A:Prop) : MPred :=
  fun h => unit h /\ A.

Require Import List.
Fixpoint itr (tdata : Set) (p : tdata -> MPred) (lst : list tdata) {struct lst} : MPred :=
  match lst with
    | nil => unit
    | cons data lst' => (p data) ** (itr p lst')
  end.

Notation "! A" := (bang A) (at level 55).

Notation set := MemMod.put.

Notation top := mTrue.

(* Parameter sig : forall (l : Label) (v : nat), Mem. *)

(* ************************************************)
(* mjudge                                         *)

Lemma mjudge_intro : forall M A,
  A M -> M ||- A.
Proof.
  unfold mjudge; trivial.
Qed.

Lemma mjudge_elim : forall M A,
  M ||- A -> A M.
Proof.
  unfold mjudge; trivial.
Qed.

(* ************************************************)
(* sconj                                          *)

Lemma sconj_intro : forall ha hb h A B,
  ha ||- A -> hb ||- B -> join ha hb h ->
    h ||- A ** B.
Proof.
  intros.
  exists ha; exists hb; auto.
Qed.
Arguments sconj_intro [ha hb h A B].

Lemma sconj_elim : forall M A B,
  M ||- A ** B
    -> exists ha, exists hb, join ha hb M
      /\ (ha ||- A) /\ (hb ||- B).
Proof.
  unfold sconj; trivial.
Qed.

Lemma sconj_sym : forall h A B,
  h ||- A ** B -> h ||- B ** A.
Admitted.

Lemma sconj_mono_left : forall h A B,
  h ||- (A ** B) ->
    forall A', (A ==> A') ->
      h ||- (A' ** B).
Proof.
  destruct 1 as [ha [hb [J [HA HB]]]].
  exists ha; exists hb.
  intuition.
  apply H.
  apply HA.
Qed.

Lemma sconj_mono_right : forall h A B,
  h ||- (A ** B) ->
    forall B', (B ==> B') ->
      h ||- (A ** B').
Proof.
  destruct 1 as [ha [hb [J [HA HB]]]].
  exists ha; exists hb.
  intuition.
  apply H.
  apply HB.
Qed.

Lemma sconj_mono : forall h A A' B B',
  h ||- A ** B ->
    (A ==> A') -> (B ==> B') ->
    h ||- A' ** B'.
Proof.
  intros.
  assert (h ||- (A' ** B)).
  eapply sconj_mono_left; [eauto | assumption].
  eapply sconj_mono_right; [eauto | assumption].
Qed.

Lemma sconj_eqv_left : forall M A B,
  M ||- A ** B -> forall A',
    (A <==> A')
  -> M ||- A' ** B.
Admitted.
Arguments sconj_eqv_left [M A B].

Lemma sconj_assoc_left : forall A B C h,
  h ||- (A ** B) ** C -> h ||- A ** (B ** C).
Admitted.

Lemma sconj_assoc_right : forall A B C h,
  h ||- A ** (B ** C) -> h ||- (A ** B) ** C.
Admitted.

(* ************************************************)
(* unit                                           *)

Lemma unit_intro : emp ||- unit.
Proof.
  unfold mjudge, unit, Aemp.
  trivial.
Qed.

Lemma unit_intro_left : forall h A,
  h ||- A -> h ||- unit ** A.
Admitted.
Arguments unit_intro_left [h A].

Lemma unit_intro_right : forall h A,
  h ||- A -> h ||- A ** unit.
Admitted.

Lemma unit_elim : forall h,
  h ||- unit -> h = emp.
Admitted.

Lemma join_emp_l : forall m1 m : Mem, join emp m1 m -> m1 = m.
Proof.
 intros.
 auto with PMap.
Qed.

Lemma unit_elim_left : forall h A,
  h ||- unit ** A -> h ||- A.
Admitted.
Arguments unit_elim_left [h A].

Lemma unit_elim_right : forall h A,
  h ||- A ** unit -> h ||- A.
Proof.
  intros.
  apply (unit_elim_left (sconj_sym H)).
Qed.
Arguments unit_elim_right [h A].

(* ************************************************)
(* top                                            *)

Lemma top_intro : forall h, h ||- top.
Proof.
  unfold mjudge, top, top.
  tauto.
Qed.

Lemma top_intro_left : forall h A,
  h ||- A -> h ||- top ** A.
Proof.
  intros.
  assert (join emp h h).
  unfold join,emp; auto with PMap.
  apply (sconj_intro (top_intro emp) H H0).
Qed.
Arguments top_intro_left [h A].

Lemma top_intro_left1 : forall M A B,
  M ||- B ** A -> M ||- top ** A.
Proof.
  intros.
  destruct (sconj_elim H) as [M1 [M2 [HJM [HM1 HM2]]]].
  apply sconj_intro with M1 M2; auto.
  apply top_intro; auto.
Qed.
Arguments top_intro_left1 [M A B].

Lemma top_intro_right : forall M A,
  M ||- A -> M ||- A ** top.
Proof.
  intros M A H.
  substH H with (top_intro_left H).
  apply sconj_sym; trivial.
Qed.
Arguments top_intro_right [M A].

Lemma top_intro_right1 : forall M A B,
  M ||- A ** B -> M ||- A ** top.
Proof.
  intros M A B H.
  destruct (sconj_elim H) as [M1 [M2 [HJM [HM1 HM2]]]].
  apply sconj_intro with M1 M2; auto.
  apply top_intro; auto.
Qed.
Arguments top_intro_right1 [M A B].

(* *********************************************** *)
(* bang                                            *)

Lemma bang_intro : forall h (A:Prop),
  h ||- unit -> A ->
    h ||- ! A.
Proof.
  unfold bang.
  intros h A Hp Aok.
  constructor; assumption.
Qed.

Lemma bang_elim1 : forall h P,
  h ||- ! P -> P.
Proof.
  unfold mjudge, bang.
  intuition.
Qed.

Lemma bang_elim2 : forall h P,
    h ||- ! P -> h ||- unit.
Proof.
  unfold mjudge, bang.
  intuition.
Qed.

Lemma bang_elim : forall h P,
  h ||- ! P ->
    h ||- unit /\ P.
Proof.
  intros h P Hp.
  constructor.
  exact (bang_elim2 Hp).
  exact (bang_elim1 Hp).
Qed.

Lemma bang_elim_left : forall h P B,
    h ||- ! P ** B ->
      P /\ h ||- B.
Proof.
  intros h A B H.
  assert (A /\ h ||- unit ** B).
  destruct H as [ha [hb [J [HA HB]]]].
  constructor.
  apply (bang_elim1 HA).
  assert (HA' := bang_elim2 HA).
  eapply sconj_intro; eauto.
  intuition.
  intuition.
  apply unit_elim_left; trivial.
Qed.

Lemma bang_elim_left1 : forall h P B,
  h ||- ! P ** B ->
    P.
Proof.
  intros h A B H.
  destruct (bang_elim_left H).
  assumption.
Qed.

Lemma bang_elim_left2 : forall h P B,
  h ||- ! P ** B ->
    h ||- B.
Proof.
  intros h A B H.
  destruct (bang_elim_left H).
  assumption.
Qed.

Lemma bang_elim_right : forall h P B,
    h ||- B ** ! P ->
      P /\ h ||- B.
Proof.
  intros h A B H.
  substH H with (sconj_sym H).
  apply bang_elim_left; auto.
Qed.

Lemma bang_intro_left : forall h (P:Prop) B,
  P -> h ||- B ->
    h ||- ! P ** B.
Proof.
  intros h A B HA HB.
  unfold bang.
  assert (Q := unit_intro_left HB).
  eapply sconj_mono; eauto.
  intros M H.
  unfold mjudge in * .
  auto.
Qed.

Lemma bang_intro_right : forall h (P:Prop) B,
  P -> h ||- B ->
    h ||- B ** ! P.
Proof.
  intros.
  apply sconj_sym.
  apply bang_intro_left; auto.
Qed.

(* *********************************************** *)
(* pto                                             *)

Lemma pto_intro : forall M l w,
  (forall l', (l' = l -> M l' = Some w)
    /\ (l' <> l -> M l' = None))
  -> M ||- l |-> w.
Admitted.

Lemma pto_elim : forall M l w,
  (M ||- l |-> w)
  -> (forall l', (l' = l -> M l' = Some w)
    /\ (l' <> l -> M l' = None)).
Admitted.

Lemma pto_get_eq : forall M l w,
  M ||- l |-> w ->
    M l = Some w.
Admitted.

Lemma pto_get_eq1 : forall M l w A,
  M ||- l |-> w ** A ->
    M l = Some w.
Admitted.

Lemma pto_update : forall M l v1 v2,
  M ||- l |-> v1 ->
    set M l v2 ||- l |-> v2.
Admitted.

Lemma pto_update1 : forall M l v1 A,
  M ||- (l |-> v1 ** A) -> forall v2,
    set M l v2 ||- (l |-> v2 ** A).
Admitted.

Lemma pto_pto_eq : forall h x v1 v2,
  h ||- x |-> v1 ->
  h ||- x |-> v2 ->
   v1 = v2.
Admitted.

Lemma pto_pto_eq1 : forall h x v1 v2 A B,
  h ||- x |-> v1 ** A ->
    h ||- x |-> v2 ** B ->
      v1 = v2.
Admitted.

(* *********************************************** *)
(* ptox                                             *)

Lemma pto_ptox : forall M l v,
  M ||- l |-> v
  -> M ||- l |->_.
Admitted.

Lemma pto_ptox1 : forall M l v A,
  M ||- l |-> v ** A
  -> M ||- l |->_ ** A.
Admitted.

Lemma ptox_pto : forall M l,
  (M ||- l |->_)
  -> exists v, M ||- l |-> v.
Proof.
  intros M l H.
  unfold ptox in H.
  unfold mjudge in H.
  apply H.
Qed.

Lemma ptox_pto1 : forall M l A,
  (M ||- l |->_ ** A)
  -> exists v, M ||- l |-> v ** A.
Admitted.

Lemma ptox_elim1 : forall M l A,
  (M ||- l |->_ *^* A)
  -> exists w, M ||- l |-> w *^* A.
Proof.
  apply ptox_pto1.
Qed.

Lemma ptox_update : forall M l v,
  M ||- l |->_
  -> set M l v ||- l |-> v.
Admitted.

Lemma ptox_update1 : forall M l A,
  M ||- l |->_ ** A
  -> forall v, set M l v ||- l |-> v ** A.
Admitted.

(* ********************************************** *)
(* leadsTo                                        *)

Lemma leadsTo_pto : forall M l v,
  M ||- l |~> v
  -> M ||- l |-> v ** top.
Admitted.
Hint Resolve leadsTo_pto : splogic.

Lemma leadsTo_pto1 : forall M l v A,
  M ||- l |~> v ** A
  -> M ||- l |-> v ** top ** A.
Admitted.

Lemma pto_leadsTo : forall M l v,
  M ||- l |-> v
  -> M ||- l |~> v.
Admitted.
Hint Resolve pto_leadsTo : splogic.

Lemma pto_leadsTo1 : forall M l v A,
  M ||- l |-> v ** A
  -> M ||- l |~> v.
Admitted.

Lemma leadsTo_mono : forall M l v A,
  M ||- l |~> v ** A
  -> M ||- l |~> v.
Admitted.
Hint Resolve leadsTo_mono : splogic.

Lemma leadsTo_get_eq : forall M l v,
  M ||- l |~> v
  -> M l = Some v.
Admitted.

Lemma leadsTo_update : forall M l v1 v2,
  M ||- l |~> v1 ->
    set M l v2 ||- l |~> v2.
Admitted.

(* ********************************************** *)
(* leadsTox                                       *)

Lemma leadsTox_leadsTo : forall M l,
  M ||- l |~>_
  -> exists v, M ||- l |~> v.
Admitted.

Lemma leadsTo_leadsTox : forall M l v,
  M ||- l |~> v
  -> M ||- l |~>_.
Admitted.

(* under construction *)

(* ************************************************)
(* WORD-wise                                      *)

(* ************************************************)
(* setW                                           *)

Notation junk := 0.

Notation setW := (MemUpdW) (only parsing).

(* ************************************************)
(* ptoW                                          *)

Lemma ptoW_pto : forall M l v,
  (M ||- l |->w v)
  -> M ||- l |-> v ** l+1 |->_ .
Admitted.
Hint Resolve ptoW_pto : splogic.

Lemma ptoW_pto1 : forall M l v A,
  (M ||- l |->w v ** A)
  -> M ||- (l |-> v ** l+1 |->_ ) ** A .
Admitted.

Lemma pto_ptoW : forall M l v,
  M ||- l |-> v ** l+1 |->_
  -> (M ||- l |->w v).
Admitted.
Hint Resolve pto_ptoW : splogic.

Lemma pto_ptoW1 : forall M l v A,
  M ||- (l |-> v ** l+1 |->_ ) ** A
  -> (M ||- l |->w v ** A).
Admitted.

Lemma ptoW_get_eq : forall M l v,
  M ||- l |->w v ->
    M l = Some v.
Admitted.

Lemma ptoW_get_eq1 : forall M l v A,
  M ||- l |->w v ** A ->
    M l = Some v.
Admitted.

Lemma ptoW_ptoW_eq : forall M l v1 v2,
  M ||- l |->w v1 ->
  M ||- l |->w v2 ->
    v1 = v2.
Admitted.

Lemma ptoW_ptoW_eq1 : forall M l v1 v2 A B,
  M ||- l |->w v1 ** A ->
  M ||- l |->w v2 ** B ->
      v1 = v2.
Admitted.

(* temporary *)
Lemma ptoW_pto_eq : forall M l v1 v2,
  M ||- l |->w v1 ->
  M ||- l |-> v2 ->
    v1 = v2.
Admitted.

(* temporary *)
Lemma ptoW_pto_eq1 : forall M l v1 v2 A B,
  M ||- l |->w v1 ** A ->
  M ||- l |-> v2 ** B ->
      v1 = v2.
Admitted.

Lemma ptoW_update : forall M l v1,
  M ||- l |->w v1 -> forall v2 v',
    setW M l v2 v' ||- l |->w v2.
Admitted.

Lemma ptoW_update1 : forall M l v1 A,
  M ||- l |->w v1 *^* A -> forall v2 v',
    setW M l v2 v' ||- l |->w v2 *^* A.
Admitted.

Lemma ptoW_elim  : forall M l v,
  (M ||- l |->w v)
  -> exists x, M ||- l |-> v ** l+1 |-> x.
Admitted.

Lemma ptoW_elim1 : forall M l v m,
  (M ||- l |->w v *^* m)
  -> exists x, M ||- l |-> v ** l+1 |-> x *^* m.
Admitted.

Lemma ptoW_intro : forall M l v x,
  M ||- l |-> v ** l+1 |-> x
  -> (M ||- l |->w v).
Admitted.

Lemma ptoW_intro1 : forall M l v x m,
  M ||- l |-> v ** l+1 |-> x *^* m
  -> M ||- l |->w v *^* m.
Admitted.

(**********************************************)
(* ptoxW                                      *)

Lemma ptoxW_ptoW : forall M l,
  M ||- l |->w_ -> exists x, M ||- l |->w x.
Admitted.

Lemma ptoxW_ptoW1 : forall M l A,
  M ||- l |->w_ ** A -> exists x, M ||- l |->w x ** A.
Admitted.

Lemma ptoW_ptoxW : forall M l x,
  M ||- l |->w x -> M ||- l |->w_ .
Admitted.

Lemma ptoW_ptoxW1 : forall M l x A,
  M ||- l |->w x ** A -> M ||- l |->w_ ** A.
Admitted.

Lemma ptoxW_update : forall M l,
  M ||- l |->w_ -> forall v2 v',
    MemUpdW M l v2 v' ||- l |->w v2.
Admitted.

Lemma ptoxW_update1 : forall M l A,
  M ||- l |->w_ *^* A
  -> forall v2 v',
  setW M l v2 v' ||- l |->w v2 *^* A.
Admitted.

(*********************************)
(* leadsToW                      *)

Lemma ptoW_leadsToW : forall M l v,
     M ||- l |->w v
  -> M ||- l |~>w v.
Admitted.
Arguments ptoW_leadsToW [M l v].
Hint Resolve ptoW_leadsToW : splogic.

Lemma leadsToW_ptoW : forall M l v,
     M ||- l |~>w v
  -> M ||- l |->w v ** top.
Admitted.
Arguments leadsToW_ptoW [M l v].
Hint Resolve leadsToW_ptoW : splogic.

Lemma ptoW_leadsToW1 : forall M l v A,
     M ||- l |->w v ** A
  -> M ||- l |~>w v.
Admitted.
Arguments ptoW_leadsToW1 [M l v A].
Hint Resolve ptoW_leadsToW1 : splogic.

Lemma leadsToW_leadsTo : forall M l v,
  M ||- l |~>w v
    -> M ||- l |~> v
      /\ M ||- (l + 1) |~>_.
Admitted.
Arguments leadsToW_leadsTo [M l v].
Hint Resolve leadsToW_leadsTo : splogic.

Lemma ptoW_leadsToW_eq1 : forall M l v v' A,
     M ||- l |->w v ** A
  -> M ||- l |~>w v'
  -> v = v'.
Admitted.
Arguments ptoW_leadsToW_eq1 [M l v v' A].

(* temporary *)
Lemma pto_leadsToW_eq1 : forall M l v v' A,
     M ||- l |-> v ** A
  -> M ||- l |~>w v'
  -> v = v'.
Admitted.
Arguments ptoW_leadsToW_eq1 [M l v v' A].

Lemma leadsToW_get_eq : forall M l v,
     M ||- l |~>w v
  -> M l = Some v.
Admitted.
Arguments leadsToW_get_eq [M l v].

Lemma leadsToW_leadsToW_eq : forall M l v v',
  M ||- l |~>w v
  -> M ||- l |~>w v'
  -> v = v'.
Admitted.
Arguments leadsToW_leadsToW_eq [M l v v'].

Lemma leadsToW_update : forall M l v1,
  M ||- l |~>w v1 -> forall v2 v',
    setW M l v2 v' ||- l |~>w v2.
Proof.
  intros M l v1 H v2 v'.
  substH H with (leadsToW_ptoW H).
  apply ptoW_leadsToW1 with top; trivial.
  apply ptoW_update1 with v1; trivial.
Qed.

(**********************************)
(* leadsToxW                      *)

Lemma leadsToW_leadsToxW : forall M l v,
  M ||- l |~>w v
  -> M ||- l|~>w_.
Proof.
  unfold leadsToxW.
  intros M l v H.
  substH H with (leadsToW_ptoW H).
  unfold imprecM.
  apply ptoW_ptoxW1 with v; trivial.
Qed.
Arguments leadsToW_leadsToxW [M l v].

Lemma leadsToxW_leadsToW : forall M l,
  M ||- l |~>w_
  -> exists v, M ||- l|~>w v.
Admitted.
Arguments leadsToxW_leadsToW [M l].

Lemma ptoW_leadsToxW1 : forall M l v A,
     M ||- l |->w v *^* A
  -> M ||- l |~>w_ .
Admitted.
Arguments ptoW_leadsToxW1 [M l v A].

Lemma ptoxW_leadsToxW1 : forall M l A,
     M ||- l |->w_ *^* A
  -> M ||- l |~>w_ .
Admitted.
Arguments ptoxW_leadsToxW1 [M l A].

Lemma leadsToxW_update : forall M l,
  M ||- l |~>w_ -> forall v2 v',
    setW M l v2 v' ||- l |~>w v2.
Admitted.
Arguments leadsToxW_update [M l].

(* ************************************************)
(* meq                                            *)

Lemma meq_intro : forall M,
  M ||- meq M.
Proof.
  unfold mjudge, meq; auto.
Qed.
Hint Resolve meq_intro : splogic.

Lemma meq_elim : forall M M',
  M ||- meq M' -> M = M'.
Proof.
  unfold mjudge, meq; auto.
Qed.

Lemma meq_update : forall M l v x,
  setW M l v x ||- meq (setW M l v x).
Proof.
  intros; apply meq_intro; trivial.
Qed.

Lemma meq_update1 : forall M1 M l v x A,
  (M ||- meq M1 ** A)
  -> (M1 ||- l |~>w_)
  -> setW M l v x ||- meq (setW M1 l v x) ** A.
Admitted.

(*********************************)
(* ptoxBlk                       *)

Lemma imp_ptoxBlk_unit : forall l,
  (ptoxBlk l 0) ==> (unit).
Proof.
  unfold ptoxBlk; intros l; trivial.
Qed.

Lemma imp_unit_ptoxBlk : forall l,
  (unit) ==> (ptoxBlk l 0).
Proof.
  unfold ptoxBlk; intros l; trivial.
Qed.

Hint Resolve imp_ptoxBlk_unit imp_unit_ptoxBlk : splogic.

Lemma imp_ptoxBlk_ptox : forall l,
  (ptoxBlk l 1) ==> (ptox l).
Proof.
  unfold ptoxBlk; intro l; intros.
  apply unit_elim_right; trivial.
Qed.

Lemma imp_ptox_ptoxBlk : forall l,
  (ptox l) ==> (ptoxBlk l 1).
Proof.
  unfold ptoxBlk; intro l; intros.
  apply unit_intro_right; trivial.
Qed.

Hint Resolve imp_ptoxBlk_ptox imp_ptox_ptoxBlk : splogic.

Lemma imp_ptoxBlk_ptoxW : forall l,
  (ptoxBlk l 2) ==> (ptoxW l).
Proof.
  unfold ptoxBlk, ptoxW; intro l; intros.
  apply unit_elim_right; trivial.
  apply sconj_assoc_right; trivial.
Qed.

Lemma imp_ptoxW_ptoxBlk : forall l,
  (ptoxW l) ==> (ptoxBlk l 2).
Proof.
  unfold ptoxBlk, ptoxW; intro l; intros.
  apply sconj_assoc_left; trivial.
  apply unit_intro_right; trivial.
Qed.

Hint Resolve imp_ptoxBlk_ptoxW imp_ptoxW_ptoxBlk : splogic.

Lemma ptoxBlk_split : forall s1 s2 M l,
  M ||- ptoxBlk l (s1 + s2)
  -> M||- (ptoxBlk l s1) ** (ptoxBlk (l+s1) s2).
Admitted.

Lemma ptoxBlk_merge : forall s1 s2 M l,
  M||- (ptoxBlk l s1) ** (ptoxBlk (l+s1) s2)
  -> M ||- ptoxBlk l (s1 + s2).
Admitted.
Lemma imp_ptoxBlk_split : forall l s1 s2,
  (ptoxBlk l (s1 + s2)) ==> ((ptoxBlk l s1) ** (ptoxBlk (l+s1) s2)).
Proof.
  intros l s1 s2 M.
  intro H.
  apply ptoxBlk_split; trivial.
Qed.

Lemma imp_ptoxBlk_merge : forall l s1 s2,
  ((ptoxBlk l s1) ** (ptoxBlk (l+s1) s2)) ==> (ptoxBlk l (s1 + s2)).
Proof.
  intros l s1 s2 M.
  intro H.
  apply ptoxBlk_merge; trivial.
Qed.

Hint Resolve imp_ptoxBlk_split imp_ptoxBlk_merge : splogic.

(* ******************************************************)
(* Basic tactics                                        *)
(* ******************************************************)

Ltac hyprep H y :=
  let H' := fresh in
    (assert (H' := y); try (clear H; rename H' into H)).

Ltac sep_mjudge :=
  apply mjudge_elim.

Ltac sep_mjudgeH H :=
  hyprep H (mjudge_intro H).

Ltac sep_turnon :=
  match goal with
    | H : unit ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : top ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (sconj ?A ?B) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (ptox ?l) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (pto ?l ?x) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (leadsTo ?l ?x) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (leadsTox ?l) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (ptoxW ?l) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (ptoW ?l ?x) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (leadsToW ?l ?x) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (leadsToxW ?l) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (stkSpacePrec ?sp ?size) ?M |- _ => sep_mjudgeH H; sep_turnon
    | H : (stkSpace ?sp ?size) ?M |- _ => sep_mjudgeH H; sep_turnon
    | _ => (try sep_mjudge); idtac
  end.

Ltac sep_turnoff := unfold mjudge in * .

Tactic Notation "sep" "on" := sep_turnon.

Tactic Notation "sep" "off" := sep_turnoff.

Ltac assocl H :=
  match type of H with
    | _ ||- sconj (ptoxW ?l) _ => idtac
    | _ ||- sconj (ptoW ?l ?x) _ => idtac
    | _ ||- sconj (sconj _ _) _ => hyprep H (sconj_assoc_left H); assocl H
    | _ => idtac
  end.

(* Ltac assocl H := *)
(*   repeat (hyprep H (sconj_assoc_left H)). *)

Ltac assocr :=
  match goal with
    | |- _ ||- sconj (ptoxW ?l) _ => idtac
    | |- _ ||- sconj (ptoW ?l ?w) _ => idtac
    | |- _ ||- sconj (sconj _ _) _ => apply sconj_assoc_right; assocr
    | _ => idtac
  end.

(* Ltac assocr := *)
(*   repeat (apply sconj_assoc_right). *)

Ltac sep_inj :=
  match goal with

    | H : ?M ||- (pto ?l ?v),
      H0 : ?M ||- (pto ?l ?v2) |- _
        => generalize (pto_pto_eq H H0)

    | H : ?M ||- sconj (pto ?l ?v) _,
      H0 : ?M ||- sconj (pto ?l ?v2) _ |- _
        => generalize (pto_pto_eq1 H H0)

    | H : ?M ||- (ptoW ?l ?v),
      H0 : ?M ||- (ptoW ?l ?v2) |- _
        => generalize (ptoW_ptoW_eq H H0)

    | H : ?M ||- sconj (ptoW ?l ?v) _,
      H0 : ?M ||- sconj (ptoW ?l ?v2) _ |- _
        => generalize (ptoW_ptoW_eq1 H H0)

(* temporary *)
    | H : ?M ||- (ptoW ?l ?v),
      H0 : ?M ||- (pto ?l ?v2) |- _
        => generalize (ptoW_pto_eq H H0)
(* temporary *)
    | H : ?M ||- sconj (ptoW ?l ?v) _,
      H0 : ?M ||- sconj (pto ?l ?v2) _ |- _
        => generalize (ptoW_pto_eq1 H H0)

    | H : ?M ||- sconj (ptoW ?l ?v) _,
      H0 : ?M ||- leadsToW ?l ?v2 |- _
        => generalize (ptoW_leadsToW_eq1 H H0)
(* temporary *)
    | H : ?M ||- sconj (pto ?l ?v) _,
      H0 : ?M ||- leadsToW ?l ?v2 |- _
        => generalize (pto_leadsToW_eq1 H H0)

    | H : ?M ||- leadsToW ?l ?v,
      H0 : ?M ||- leadsToW ?l ?v2 |- _
        => generalize (leadsToW_leadsToW_eq H H0)
  end.

Tactic Notation "sep" "inj" := sep_inj.

Ltac sep_update :=
  match goal with
    | |- MemUpdW ?M ?l ?v ?junk ||- ptoW ?l ?v
      => apply ptoxW_update

    | |- MemUpdW ?M ?l ?v ?junk ||- ptoxW ?l
      => apply ptoW_ptoxW with v; apply ptoxW_update

    | |- MemUpdW ?M ?l ?v ?junk ||- sconj (ptoW ?l ?v) ?B =>
      apply ptoxW_update1

    | |- MemUpdW ?M ?l ?v ?junk ||- sconj (ptoxW ?l) ?B =>
      apply ptoW_ptoxW1 with v; apply ptoxW_update1

    | |- MemUpdW ?M ?l ?v ?junk ||- (leadsToW ?l ?v)
      => apply leadsToxW_update

    | |- MemUpdW ?M ?l ?v ?junk ||- (leadsToxW ?l)
      => apply leadsToW_leadsToxW with v; apply leadsToxW_update

    | |- MemUpdW ?M ?l ?v ?junk ||- sconj (meq (MemUpdW ?M1 ?l ?v ?junk)) ?B
      => apply meq_update1; auto

    | _ => fail 1 "Error: format"
  end.

Tactic Notation "sep" "upd" := sep_update.

(**************************************************************)
(* memory shift                                               *)
(**************************************************************)

Ltac sep_lift n :=
  match eval compute in n with
    | O => assocr
    | _ => assocr; apply sconj_sym; sep_lift (pred n)
  end.

Ltac sep_liftH H n :=
  match eval compute in n with
    | O => assocl H
    | _ => assocl H; hyprep H (sconj_sym H); sep_liftH H (pred n)
  end.

Ltac sep_shift_l n :=
  match eval compute in n with
    | 0 => apply sconj_sym
    | _ => sep_lift (pred n); apply sconj_sym
  end.

Tactic Notation "sep" "lift" constr (n) :=
  sep_lift n.

Tactic Notation "sep" "lift" constr (n) "in" hyp (H):=
  sep_liftH H n.

Tactic Notation "sep" "lift" constr (n) "in" hyp (H) "as" hyp (Hx):=
  generalize H; intro Hx; sep_liftH Hx n.

Ltac sep_searchH H C n :=
  match eval compute in n with
    | O => assocl H;
      match type of H with
        | _ ||- C ** ?B => idtac
        | _ ||- ?A ** ?B => fail 1 "Error: Not found"
        | _ => fail 1 "Error:"
      end
    | _ => assocl H;
      match type of H with
        | _ ||- C ** ?B => idtac
        | _ ||- ?A ** ?B => hyprep H (sconj_sym H); sep_searchH H C (pred n)
        | _ => fail 1 "Error:"
      end
  end.

Ltac sep_search C n :=
  match eval compute in n with
    | O => assocr;
      match goal with
        | |- _ ||- sconj C ?B => idtac
        | |- _ ||- sconj ?A ?B => fail 1 "Error: Not found"
        | _ => fail 1 "Error:"
      end
    | _ => assocr;
      match goal with
        | |- _ ||- sconj C ?B => idtac
        | |- _ ||- sconj ?A ?B => apply sconj_sym; sep_search C (pred n)
        | _ => fail 1 "Error:"
      end
  end.

Tactic Notation "sep" "search" constr (C) "in" hyp (H) "with" constr (n) :=
  sep_searchH H C n.

Tactic Notation "sep" "search" constr (C) "in" hyp (H) :=
  sep_searchH H C 10.

Tactic Notation "sep" "search" constr (C) "with" constr (n) :=
  sep_search C n.

Tactic Notation "sep" "search" constr (C) :=
  sep_search C 30.

(**************************************************************)
(* stack operation                                            *)
(**************************************************************)

Lemma stkSpacePrec_stkSpace : forall M sp size,
  M ||- (stkSpacePrec sp size)
  -> M ||- stkSpace sp size.
Admitted.
Arguments stkSpacePrec_stkSpace [M sp size].

Lemma stkSpacePrec_stkSpace1 : forall M sp size A,
  M ||- (stkSpacePrec sp size *^* A)
  -> M ||- stkSpace sp size.
Admitted.
Arguments stkSpacePrec_stkSpace1 [M sp size A].

Lemma stkSpacePrec_ptoxW :forall M sp,
  M ||- stkSpacePrec sp 2
  -> M ||- ptoxW (sp - 2).
Admitted.

Lemma ptoxW_stkSpacePrec :forall M l,
  M ||- ptoxW l
  -> M ||- stkSpacePrec (l+2) 2.
Admitted.

Lemma stkSpacePrec_unit : forall M sp,
  M ||- stkSpacePrec sp 0
  -> M ||- unit.
Admitted.

Lemma stkSpacePrec_unit1 : forall M sp A,
  M ||- (stkSpacePrec sp 0 ** A)
  -> M ||- A.
Admitted.

Lemma unit_stkSpacePrec : forall M sp,
  M ||- unit
  -> M ||- stkSpacePrec sp 0.
Admitted.

Lemma unit_stkSpacePrec_unit : forall M sp A,
  M ||- A
  -> M ||- sconj (stkSpacePrec sp 0) A.
Admitted.

(*************************)
(* ** stack split     ** *)

Lemma stkSpacePrec_splitW : forall M sp size,
  M ||- stkSpacePrec (sp+2) (size+2)
    -> M ||- stkSpacePrec sp size *^*
      (sp |->w_ ).
Admitted.
Arguments stkSpacePrec_splitW [M sp size].

Lemma stkSpacePrec_splitWh : forall M sp size,
  M ||- stkSpacePrec sp size
    -> size >= 2
    -> M ||- stkSpacePrec (sp - 2) (size - 2) *^*
      (sp - 2 |->w_ ).
Admitted.
Arguments stkSpacePrec_splitWh [M sp size].

Lemma stkSpacePrec_splitWh1 : forall M sp size A,
  M ||- stkSpacePrec sp size *^* A
    -> size >= 2
    -> M ||- stkSpacePrec (sp - 2) (size - 2) *^*
      (sp -2 |->w_ *^* A).
Admitted.
Arguments stkSpacePrec_splitWh1 [M sp size A].

Lemma stkSpacePrec_splitW1 : forall M sp size A,
  M ||- stkSpacePrec (sp + 2) (size + 2) *^* A
    -> M ||- stkSpacePrec sp size *^*
      (sp |->w_ *^* A).
Admitted.
Arguments stkSpacePrec_splitW1 [M sp size A].

Lemma stkSpacePrec_mergeW : forall M sp size,
  M ||- stkSpacePrec (sp - 2) (size - 2) *^* sp - 2 |->w_
    -> sp >= 2
    -> size >= 2
    ->  M ||- stkSpacePrec sp size.
Admitted.
Arguments stkSpacePrec_mergeW [M sp size].

Lemma stkSpacePrec_mergeW1 : forall M sp size A,
  M ||- stkSpacePrec (sp - 2) (size - 2) *^*
    (sp - 2 |->w_ *^* A)
    -> sp >= 2
    -> size >= 2
    ->  M ||- stkSpacePrec sp size *^* A.
Admitted.
Arguments stkSpacePrec_mergeW1 [M sp size A].

Lemma stkSpacePrec_mergeWh : forall M sp size,
  M ||- stkSpacePrec sp size *^* sp |->w_
    ->  M ||- stkSpacePrec (sp + 2) (size + 2).
Admitted.
Arguments stkSpacePrec_mergeWh [M sp size].

Lemma stkSpacePrec_mergeWh1 : forall M sp size A,
  M ||- stkSpacePrec sp size *^*
    (sp |->w_ *^* A)
    ->  M ||- stkSpacePrec (sp + 2) (size + 2) *^* A.
Admitted.
Arguments stkSpacePrec_mergeWh1 [M sp size A].

Ltac stk_splitw :=
  match goal with
    | |- _ ||- stkSpacePrec (?sp + 2) (?size + 2) => apply stkSpacePrec_mergeWh
    | |- _ ||- sconj (stkSpacePrec (?sp + 2) (?size +2)) _ => apply stkSpacePrec_mergeWh1
    | |- _ ||- stkSpacePrec ?sp ?size =>
      apply stkSpacePrec_mergeW;
        [ idtac
          | simpl; auto with arith; lia || fail 1 "Error: top address of stake should be >= 2"
          | simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= 2"
        ]
    | |- _ ||- sconj (stkSpacePrec ?sp ?size) _ =>
      apply stkSpacePrec_mergeW1;
        [ idtac
          | simpl; auto with arith; lia || fail 1 "Error: top address of stake should be >= 2"
          | simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= 2"
        ]
    | _ => fail 1 "Error: cannot split the current goal"
  end.

Ltac stk_splitwH H :=
  match type of H with
    | _ ||- stkSpacePrec (?sp + 2) (?size + 2)
      => hyprep H (stkSpacePrec_splitW H)
    | _ ||- sconj (stkSpacePrec (?sp + 2) (?size +2)) _
      => hyprep H (stkSpacePrec_splitW1 H)
    | _ ||- stkSpacePrec ?sp ?size
      => let Hx := fresh "H" in
        (assert (Hx : size >= 2);
          [ simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= 2" | idtac];
          hyprep H (stkSpacePrec_splitWh H Hx); clear Hx)
    | _ ||- sconj (stkSpacePrec ?sp ?size) _
      => let Hx := fresh "H" in
        (assert (Hx : size >= 2);
          [ simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= 2" | idtac];
            hyprep H (stkSpacePrec_splitWh1 H Hx); clear Hx)
    | _ => fail 1 "Error: cannot split the current hypothesis"
  end.

Lemma stkSpacePrec_split : forall M sp size k,
  M ||- stkSpacePrec (sp+k) (size+k)
    -> M ||- stkSpacePrec (sp+k) k *^* stkSpacePrec sp size.
Admitted.
Arguments stkSpacePrec_split [M sp size k].

Lemma stkSpacePrec_splith : forall M sp size k,
  M ||- stkSpacePrec sp size
    -> k <= size
    -> M ||- stkSpacePrec (sp - k) (size - k) *^* stkSpacePrec sp k.
Admitted.
Arguments stkSpacePrec_splith [M sp size k].

Lemma stkSpacePrec_splith1 : forall M sp size k A,
  M ||- stkSpacePrec sp size *^* A
    -> k <= size
    -> M ||- stkSpacePrec sp k *^* stkSpacePrec (sp - k) (size - k) *^* A.
Admitted.
Arguments stkSpacePrec_splith1 [M sp size k A].

Lemma stkSpacePrec_split1 : forall M sp size k A,
  M ||- stkSpacePrec (sp + k) (size + k) *^* A
    -> M ||- stkSpacePrec (sp+k) k *^* stkSpacePrec sp size *^* A.
Admitted.
Arguments stkSpacePrec_split1 [M sp size k A].

Lemma stkSpacePrec_merge : forall M sp size k,
  M ||- stkSpacePrec (sp - k) (size - k) *^* stkSpacePrec sp k
    -> sp >= k
    -> size >= k
    ->  M ||- stkSpacePrec sp size.
Admitted.
Arguments stkSpacePrec_merge [M sp size k].

Lemma stkSpacePrec_merge1 : forall M sp size k A,
  M ||- stkSpacePrec (sp - k) (size - k) *^* stkSpacePrec sp k *^* A
    -> sp >= k
    -> size >= k
    ->  M ||- stkSpacePrec sp size *^* A.
Admitted.
Arguments stkSpacePrec_merge1 [M sp size k A].

Lemma stkSpacePrec_mergeh : forall M sp size k,
  M ||- stkSpacePrec sp size *^* stkSpacePrec (sp+k) k
    ->  M ||- stkSpacePrec (sp + k) (size + k).
Admitted.
Arguments stkSpacePrec_mergeh [M sp size k].

Lemma stkSpacePrec_mergeh1 : forall M sp size k A,
  M ||- stkSpacePrec sp size *^* stkSpacePrec (sp+k) k *^* A
    ->  M ||- stkSpacePrec (sp + k) (size + k) *^* A.
Admitted.
Arguments stkSpacePrec_mergeh1 [M sp size k A].

Ltac stk_split k :=
  match goal with
    | |- _ ||- stkSpacePrec (?sp + k) (?size + k) => apply stkSpacePrec_mergeh
    | |- _ ||- sconj (stkSpacePrec (?sp + k) (?size +k)) _ => apply stkSpacePrec_mergeh1
    | |- _ ||- stkSpacePrec ?sp ?size
      => apply stkSpacePrec_merge with k;
        [ idtac
          | simpl; auto with arith; lia || fail 1 "Error: top address of stake should be >= k"
          | simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= k"
        ]
    | |- _ ||- sconj (stkSpacePrec ?sp ?size) _
      => apply stkSpacePrec_merge1 with k;
        [ idtac
          | simpl; auto with arith; lia || fail 1 "Error: top address of stake should be >= k"
          | simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= k"
        ]
    | _ => fail 1 "Error: cannot split the current goal"
  end.

Ltac stk_splitH H k :=
  match type of H with
    | _ ||- stkSpacePrec (?sp + k) (?size + k)
      => hyprep H (stkSpacePrec_split H)
    | _ ||- sconj (stkSpacePrec (?sp + k) (?size + k)) _
      => hyprep H (stkSpacePrec_split1 H)
    | _ ||- stkSpacePrec ?sp ?size
      => let Hx := fresh "H" in
        (assert (Hx : size >= k);
          [ simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= k" | hyprep H (stkSpacePrec_splith H Hx); clear Hx])
    | _ ||- sconj (stkSpacePrec ?sp ?size) _
      => let Hx := fresh "H" in
        (assert (Hx : size >= k);
          [ simpl; auto with arith; lia || fail 1 "Error: size of stake should be >= k" | hyprep H (stkSpacePrec_splith1 H Hx); clear Hx])
    | _ => fail 1 "Error: cannot split the current hypothesis"
  end.

Tactic Notation "sep" "stksplit" := stk_splitw.

Tactic Notation "sep" "stksplit" "in" hyp (H) := stk_splitwH H.

Tactic Notation "sep" "stksplit" constr (k) := stk_split k.

Tactic Notation "sep" "stksplit" constr (k) "in" hyp (H) := stk_splitH H k.

(**************************************************************)
(* memory re-order macth                                      *)
(**************************************************************)

Ltac matchhp ig ih sg sh Hp :=
  match goal with
    | |- _ ||- top => apply top_intro (* true *)
    | |- ?h ||- ?A =>
      match type of Hp with
        | h ||- A => exact Hp (* assumption *)
      end

    | |- _ ||- unit => try (apply unit_intro)
    | |- _ ||- bang _ => apply bang_intro; auto

    | |- ?h ||- ptoxW ?l => (* match: ptoW |- ptoxW *)
      match type of Hp with
        | h ||- ptoW l ?v =>
          apply (ptoW_ptoxW Hp); trivial; fail 1 "Error : unknown"
      end

    | |- _ ||- sconj _ unit => apply unit_intro_right;
      matchhp (pred ig) sh (pred sg) sh Hp
    | |- _ ||- sconj unit _ => apply unit_intro_left;
      matchhp (pred ig) sh (pred sg) sh Hp

    | |- _ ||- sconj (bang _) _ => apply bang_intro_left;
      [auto | matchhp (pred ig) sh (pred sg) sh Hp]
    | |- _ ||- sconj _ (bang _) => apply bang_intro_right;
      [auto | matchhp (pred ig) sh (pred sg) sh Hp]

(*     | [NI : ~ set_in ?x ?s |- *)
(*       ?h ||- fas ?P (set_add ?x ?s)] => apply fas_intro1;  *)
(*     [assocr; matchhp (S ig) sh (S sg) sh | assumption] *)

(*     | [NI : ~ set_in ?x ?s |- *)
(*       ?h ||- sconj (fas ?P (set_add ?x ?s)) _] => apply fas_intro;  *)
(*      [assocr; matchhp (S ig) sh (S sg) sh | assumption] *)

    | |- _ ||- sconj _ (bang _) => apply bang_intro_right;
      [auto | matchhp (pred ig) sh (pred sg) sh Hp]

    | |- ?h ||- sconj ?A ?C => (* match left *)
      match type of Hp with
        | h ||- sconj A ?B =>
          let h1 := fresh "h" in
            (apply (sconj_mono_right Hp);
              (clear h Hp; intros h Hp) || (clear Hp; intros h1 Hp);
                assocl Hp; assocr;
                matchhp (pred ig) (pred sh) (pred sg) (pred sh) Hp)
      end

    | |- ?h ||- sconj (ptoxW ?l) ?C => (* match left: ptoW |- ptoxW *)
      match type of Hp with
        | h ||- sconj (ptoW l ?v) ?B =>
          let h1 := fresh "h" in
            (apply (sconj_mono (A':=ptoxW l)(B':=C) Hp);
              (clear h Hp; intros h Hp) || (clear Hp; intros h1 Hp);
                [ apply (ptoW_ptoxW Hp); fail 1 "Error : unknown"
                  |
                  assocl Hp; assocr;
                  matchhp (pred ig) (pred sh) (pred sg) (pred sh) Hp ])
      end

    | |- ?h ||- sconj ?C ?B => (* match right *)
      match type of Hp with
        | h ||- sconj ?A B =>
          let h' := fresh "h" in
            (apply (sconj_mono_left Hp);
              (clear h Hp; intros h Hp) || (clear Hp; intros h' Hp);
                assocl Hp; assocr;
                matchhp (pred ig) (pred sh) (pred sg) (pred sh) Hp)
      end

    | |- ?h ||- sconj ?C ?D => (* shift *)
      match type of Hp with
        | h ||- sconj ?A ?B =>
          match eval compute in ig with
            | O => (* no more shift on goal *)
              match eval compute in ih with
            | O => idtac (* finished *)
                | _ => (* shift hyp, continue with matching *)
                  hyprep Hp (sconj_sym Hp); assocl Hp;
                  matchhp sg (pred ih) sg sh Hp
              end
            | _ => (* shift goal *)
              apply sconj_sym; assocr;  matchhp (pred ig) ih sg sh Hp
          end
      end
    | _ => match type of Hp with
             | _ ||- sconj _ unit => hyprep Hp (unit_elim_right Hp);
               matchhp ig (pred sh) sg (pred sh) Hp
             | _ ||- sconj unit _ => hyprep Hp (unit_elim_left Hp);
               matchhp ig (pred sh) sg (pred sh) Hp
             | _ => idtac
           end
(*     | _ => idtac *)
  end.

Ltac simplsep sizeg sizeh Hp :=
  match type of Hp with
    | ?h ||- _ =>
      match goal with
        | |- h ||- _ =>
          assocl Hp; assocr; matchhp sizeg sizeh sizeg sizeh Hp
      end
 end.

Tactic Notation "sep" "matchH" hyp (H) "with" constr (size) :=
  simplsep size size H.

(**************************************************************)
(* memory macth                                               *)
(**************************************************************)

Ltac sep_trivial :=
  match goal with

    | |- emp ||- unit =>
      apply unit_intro; trivial

    | |- ?M ||- top =>
      apply top_intro; trivial

    | H: ?M ||- pto ?l ?v
      |- ?M ||- ptox ?l => apply pto_ptox with v; trivial

    | H : ?M ||- stkSpacePrec ?sp 2
       |- ?M ||- ptoxW (?sp-2) =>
        apply (stkSpacePrec_ptoxW H); trivial

    | H : ?M ||- ptoxW ?l
       |- ?M ||- stkSpacePrec (?l+2) 2 =>
        apply (ptoxW_stkSpacePrec H); trivial

    | H : ?M ||- (stkSpacePrec ?sp ?size)
       |- ?M ||- stkSpace ?sp ?size =>
        apply (stkSpacePrec_stkSpace H); trivial

    | H : ?M ||- sconj (stkSpacePrec ?sp ?size) _
       |- ?M ||- stkSpace ?sp ?size =>
        apply (stkSpacePrec_stkSpace1 H); trivial

    | H : ?M ||- sconj (ptoW ?l ?v) _
       |- ?M ||- leadsToW ?l ?v => (* match: ptoW |- leadsToW *)
          apply (ptoW_leadsToW1 H); trivial

    | H : ?M ||- sconj (ptoW ?l ?v) _
       |- ?M ||- leadsToxW ?l => (* match: ptoW, ptoxW |- leadsToxW *)
          apply (ptoW_leadsToxW1 H); trivial

    | H : ?M ||- sconj (ptoxW ?l) _
       |- ?M ||- leadsToxW ?l => (* match: ptoW, ptoxW |- leadsToxW *)
          apply (ptoxW_leadsToxW1 H); trivial

    | H: ?M ||- ptoW ?l ?v
      |- ?M ||- ptoxW ?l => apply ptoW_ptoxW with v; trivial

    | H: ?M ||- leadsToW ?l ?v
      |- ?M ||- leadsToxW ?l => apply leadsToW_leadsToxW with v; trivial

    | H: ?M ||- ?A
      |- ?M ||- ?B => auto with splogic; fail

    | |- ?A ==> ?B => intros; auto with splogic; fail

    | _ => trivial
  end.

Tactic Notation "sep" "trivial" := sep_trivial.

Ltac sep_simpl :=
  match goal with

(* unit *)
    | H : ?M ||- unit ** ?A
       |- _  =>
        hyprep H (unit_elim_left H)

    |  |- ?M ||- unit ** ?A =>
        apply unit_intro_left

    | H : ?M ||- ?A ** unit
       |- _  =>
        hyprep H (unit_elim_right H)

    |  |- ?M ||- ?A ** unit =>
        apply unit_intro_right

(* stkSpacePrec empty *)
    | H : ?M ||- (stkSpacePrec ?sp 0) ** ?A
       |- _  =>
        hyprep H (stkSpacePrec_unit1 H)

    | H : ?M ||- stkSpacePrec ?sp 0
       |- _  =>
        hyprep H (stkSpacePrec_unit H)

    | |- ?M ||- sconj (stkSpacePrec ?sp 0) _ =>
      apply stkSpacePrec_unit1

    | |- ?M ||- stkSpacePrec ?sp 0 =>
      apply stkSpacePrec_unit

    | _ => trivial
  end.

Tactic Notation "sep" "simpl" := sep_simpl.

(* obselete *)
Ltac sep_elim_left H :=
  match type of H with

    | ?M ||- unit =>
      hyprep H (unit_elim H); subst M

    | ?M ||- (ptoxW ?l) =>
      let v:= fresh "v" in
      (hyprep H (ptoxW_ptoW H); destruct H as [v H])

    | ?M ||- sconj (ptoxW ?l) ?A =>
      let v:= fresh "v" in
      (hyprep H (ptoxW_ptoW1 H); destruct H as [v H])

    | _ => fail 1 "Format Error : M |- l |-> _ * _ "
  end.

Tactic Notation "sep" "elim_left" hyp (H) := sep_elim_left H.

(* new *)

Ltac sep_match_left H :=
  match goal with
    | |- ?M ||- sconj ?A' ?B' =>
      match type of H with
        | M ||- sconj ?A ?B =>
          let M1 := fresh "M" in
            (apply (sconj_mono (A':=A') (B':=B') H);
              (clear M H; intros M H; sep_trivial)
              || (clear H; intros M1 H; sep_trivial))
      end
  end.

Tactic Notation "sep" "match_left" hyp (H) := sep_match_left H.

Ltac sep_subst_left A :=
  match goal with
    | |- ?M ||- ?A' ** ?B' =>
      apply sconj_mono_left with A; [ idtac | sep_trivial ]
  end.

Ltac sep_subst_leftH H A' :=
  match type of H with
    | ?M ||- ?A ** ?B =>
      let Hx := fresh "Hx" in
        (assert (Hx : A ==> A');
          [sep_trivial
            | hyprep H (sconj_mono_left H (A':=A') Hx); clear Hx])
  end.

Tactic Notation "sep" "subst_left" "with" constr (A) "in" hyp (H) := sep_subst_leftH H A.

Tactic Notation "sep" "subst_left" "with" constr (A) := sep_subst_left A.

(* new *)
Ltac sep_elim H :=
  match type of H with

    | ?M ||- unit =>
      hyprep H (unit_elim H); subst M

    | ?M ||- unit ** ?A =>
      hyprep H (unit_elim_left H)

    | ?M ||- (ptoW ?l ?v) =>
      hyprep H (ptoW_pto H)

    | ?M ||- (ptoW ?l ?v) ** ?A =>
      hyprep H (ptoW_pto1 H)

    | ?M ||- (ptoxW ?l) =>
      let v:= fresh "v" in
      (hyprep H (ptoxW_ptoW H); destruct H as [v H])

    | ?M ||- sconj (ptoxW ?l) ?A =>
      let v:= fresh "v" in
      (hyprep H (ptoxW_ptoW1 H); destruct H as [v H])

    | ?M ||- (leadsToxW ?l) =>
      let v:= fresh "v" in
      (hyprep H (leadsToxW_leadsToW H); destruct H as [v H])

    | _ => fail 1 "Format Error : M |- l |-> _ * _ "
  end.

Tactic Notation "sep" "elim" hyp (H) := sep_elim H.

Tactic Notation "sep" "destruct" hyp (H) := sep_elim H.

Ltac sep_exists_left v :=
  match goal with

    | |- ?M ||- sconj (ptoxW ?l) ?A =>
      apply ptoW_ptoxW1 with v

    | |- ?M ||- ptoxW ?l =>
      apply ptoW_ptoxW with v

    | |- ?M ||- leadsToxW ?l =>
      apply leadsToW_leadsToxW with v
    | _ => fail 1 "Format Error : M |- l |-> _ * _ "
  end.

Tactic Notation "sep" "exists_left" constr (v) := sep_exists_left v.

Tactic Notation "sep" "exists" constr (v) := sep_exists_left v.

(* some tactics added by Xinyu *)
Ltac sep_leqv_subst m :=
  match goal with
    | |- ?M ||- ?A *^* ?B =>
      let Hx := fresh in
        (assert (Hx : leqvM m A);
          [(auto || idtac) | (apply (leqvM_app_subst (H := M) (mstar_eqv_subst_left B Hx)); auto; clear Hx) || fail 1 "failed" ])
    | _ => idtac
  end.

Tactic Notation "sep" "leqv_subst" "with" constr (m) := sep_leqv_subst m.

Ltac sep_leqv_substH H m :=
  match type of H with
    | ?M ||- ?A *^* ?B =>
      let Hx := fresh in
        (assert (Hx : leqvM A m);
        [(auto || idtac) | hypreplace H (leqvM_app_subst (mstar_eqv_subst_left B Hx) H)])
    | _ => idtac
  end.

Tactic Notation "sep" "leqv_subst" "in" hyp (H) "with" constr (m) := sep_leqv_substH H m.

Ltac sep_weaker_subst H m :=
  match type of H with
    | ?M ||- ?A *^* ?B =>
      let Hx := fresh in
        (assert (Hx : forall H, A H -> m H);
          [(auto || idtac) | hypreplace H (mstar_subst_weaker_left H Hx)])
    | _ => idtac
  end.

Tactic Notation "sep" "weaker_subst" "in" hyp (H) "with" constr (m) := sep_weaker_subst H m.

Lemma stkSpace_sp_ge_sz:
forall M sp sz,
  M ||- stkSpace sp sz -> sp >= sz.
Proof.
  intros.
  sep off. unfold stkSpace in H.
  inversion H; auto.
Qed.

Lemma stkSpace_sp_ge_sz1:
forall M sp sz B,
  M ||- stkSpace sp sz *^* B -> sp >= sz.
Admitted.

Lemma stkSpacePrec_sp_ge_sz:
forall M sp sz,
  M ||- stkSpacePrec sp sz -> sp >= sz.
Admitted.

Lemma stkSpacePrec_sp_ge_sz1:
forall M sp sz B,
  M ||- stkSpacePrec sp sz *^* B -> sp >= sz.
Proof.
  intros. sep off.
  unfold mstar in H.
  InvertAll.
  apply stkSpacePrec_sp_ge_sz with x; auto.
Qed.

Ltac sep_update2 :=
  match goal with
    | |- MemUpdW ?M ?l ?v ?junk ||- ptoW ?l ?v
      => apply ptoxW_update
    | |- MemUpdW ?M ?l ?v ?junk ||- ptoxW ?l
      => apply ptoW_ptoxW with v; apply ptoxW_update
    | |- MemUpdW ?M ?l ?v ?junk ||- (ptoW ?l ?v) *^* ?B =>
      apply ptoxW_update1
    | |- MemUpdW ?M ?l ?v ?junk ||- (ptoxW ?l) *^* ?B =>
      apply ptoW_ptoxW1 with v; apply ptoxW_update1
    | |- MemUpdW ?M ?l ?v ?junk ||- (leadsToW ?l ?v)
      => apply leadsToxW_update
    | |- MemUpdW ?M ?l ?v ?junk ||- (leadsToxW ?l)
      => apply leadsToW_leadsToxW with v; apply leadsToxW_update
    | |- MemMod.put ?M ?l ?v ||- (pto ?l ?v) *^* ?B
      => apply ptox_update1
    | _ => fail 1 "Error: format"
  end.

Tactic Notation "sep" "upd2" := sep_update2.

Lemma ptoW_precise:
forall l v, precise (l |->w v).
Admitted.

Lemma ptoW_indom1:
forall M l v A,
  (l |->w v *^* A) M -> MemMod.in_dom l M /\ MemMod.in_dom (l+1) M.
Admitted.

Lemma ptoxW_indom1:
forall M l A,
  (l |->w_ *^* A) M -> MemMod.in_dom l M /\ MemMod.in_dom (l+1) M.
Admitted.


(******************************************************************************)
(*       Copyright (C) 2014 Florent Hivert <florent.hivert@lri.fr>            *)
(*                                                                            *)
(*  Distributed under the terms of the GNU General Public License (GPL)       *)
(*                                                                            *)
(*    This code 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.                                *)
(*                                                                            *)
(*  The full text of the GPL is available at:                                 *)
(*                                                                            *)
(*                  http://www.gnu.org/licenses/                              *)
(******************************************************************************)
Add Rec LoadPath "ALEA/src" as ALEA.
Add Rec LoadPath "../Combi/LRrule".

Set Implicit Arguments.
Unset Strict Implicit.

Require Import ssreflect ssrfun ssrbool eqtype choice ssrnat seq
        ssrint div rat fintype bigop path ssralg ssrnum.
(* Import bigop before ssralg/ssrnum to get correct printing of \sum \prod*)

Require Import tools combclass ordtype subseq partition tableau Schensted std stdtab.
Require Import hook.

Section Identity.

Definition is_stdtab_pair_of_shape sh p :=
  (is_stdtab_of_shape sh p.1) && (is_stdtab_of_shape sh p.2).
Definition is_stdtab_pair_of_n n p :=
  [&& (is_stdtab_of_n n p.1), (is_stdtab_of_n n p.2) & (shape p.1 == shape p.2)].

Variable n : nat.

Section Shape.

Variable sh : intpartn n.

Definition stpsh : predArgType := ((stdtabsh sh) * (stdtabsh sh))%type.
Definition seq_of_stpsh (p : stpsh) := let: (p1, p2) := p in (val p1, val p2).
Definition stpsh_of_seq p : is_stdtab_pair_of_shape sh p -> stpsh.
Proof. move=> /andP [] /(@StdtabSh sh) p1 /(@StdtabSh sh) p2; exact: (p1, p2). Defined.

Lemma stpshP (p : stpsh) : is_stdtab_pair_of_shape sh (seq_of_stpsh p).
Proof.
  rewrite /is_stdtab_pair_of_shape.
  case: p => [p1 p2] /=.
  by rewrite !stdtabshP !stdtabsh_shape !eq_refl.
Qed.

Lemma seq_of_stpshK p : (stpsh_of_seq (stpshP p)) = p.
Proof.
  apply/eqP; rewrite /stpsh_of_seq /eq_op /=.
  apply/andP; split; case: p => [[p1 H1] [p2 H2]] /=; apply /eqP => /=.
  - case: (elimTF _ _) => /= H _; by apply val_inj.
  - case: (elimTF _ _) => /= _ H; by apply val_inj.
Qed.

Lemma stpsh_of_seqK p (Hp : is_stdtab_pair_of_shape sh p) :
  seq_of_stpsh (@stpsh_of_seq p Hp) = p.
Proof.
  rewrite /stpsh_of_seq /=.
  case: (elimTF _ _) => /= _ _.
  by case: p {Hp}.
Qed.

Lemma stpsh_val_rect :
  forall F : stpsh -> Type,
    (forall p Px, F (@stpsh_of_seq p Px)) ->
    forall u : stpsh, F u.
Proof. move=> F H p; rewrite -(seq_of_stpshK p); exact: H. Qed.

Canonical stpsh_subType := SubType _ seq_of_stpsh stpsh_of_seq stpsh_val_rect stpsh_of_seqK.
Definition stpsh_eqMixin := Eval hnf in [eqMixin of stpsh by <:].
Definition stpsh_subCountType := Eval hnf in [subCountType of stpsh_subType].

Lemma enum_stpshP : Finite.axiom (T:=stpsh_subCountType) (enum stpsh).
Proof.
  rewrite /Finite.axiom => [[p1 p2]].
  rewrite enumT /= -(@enumP _ (p1, p2)).
  by apply eq_count => [[x1 x2]] /=.
Qed.

Definition stpsh_finMixin := Eval hnf in FinMixin enum_stpshP.
Definition stpsh_finType := Eval hnf in FinType stpsh_subCountType stpsh_finMixin.
Definition stpsh_subFinType := Eval hnf in [subFinType of stpsh_finType].

Lemma card_stpsh : #|stpsh_finType| = #|stdtabsh_finType sh|^2.
Proof.
  rewrite -mulnn -card_prod.
  by rewrite !cardE enumT unlock /=.
Qed.

End Shape.

Lemma stpn_PredEq (ev : intpartn_subFinType n) :
  predI (is_stdtab_pair_of_n n) (pred1 (val ev) \o shape \o (fun x => x.1)) =1
  is_stdtab_pair_of_shape ev.
Proof.
  move=> [p1 p2] /=; rewrite /is_stdtab_pair_of_n /is_stdtab_pair_of_shape /=.
  case: (altP (shape p1 =P ev)) => [Hsh1|]; last by rewrite !andbF /=.
  rewrite [shape p1 == _]eq_sym Hsh1 !andbT.
  case: (altP (shape p2 =P ev)) => [Hsh2|]; last by rewrite ?andbF /=.
  by rewrite !andbT /size_tab Hsh1 Hsh2 intpartn_sumn eq_refl !andbT.
Qed.

Lemma stpn_partition_shape tabp :
  is_stdtab_pair_of_n n tabp -> is_part_of_n n ((shape \o (fun x => x.1)) tabp).
Proof.
  rewrite /is_stdtab_pair_of_n; move: tabp => [p1 p2] /= /andP [].
  rewrite /size_tab => /andP [] /andP [] H _ -> _ /=.
  exact: is_part_sht.
Qed.

Structure stpn : predArgType :=
  STPN {stpnval :> seq (seq nat) * seq (seq nat); _ : is_stdtab_pair_of_n n stpnval }.
Canonical stpn_subType := Eval hnf in [subType for stpnval].
Definition stpn_eqMixin := Eval hnf in [eqMixin of stpn by <:].
Canonical stpn_eqType := Eval hnf in EqType stpn stpn_eqMixin.
Definition stpn_choiceMixin := Eval hnf in [choiceMixin of stpn by <:].
Canonical stpn_choiceType := Eval hnf in ChoiceType stpn stpn_choiceMixin.
Definition stpn_countMixin := Eval hnf in [countMixin of stpn by <:].
Canonical stpn_countType := Eval hnf in CountType stpn stpn_countMixin.
Canonical stpn_subCountType := Eval hnf in [subCountType of stpn].

Definition type :=
  union_finType
    (Pi := fun sh : seq nat => is_stdtab_pair_of_shape sh)
    (fun p : intpartn_subFinType n => (stpsh_subFinType p))
    stpn_PredEq stpn_partition_shape stpn_subCountType.
Canonical stpn_finType := Eval hnf in [finType of stpn for type].
Canonical stpn_subFinType := Eval hnf in [subFinType of stpn].

Lemma card_stpn : #|stpn_finType| = \sum_(p : intpartn n) (n`! %/ (F_deno p))^2.
Proof.
  rewrite card_unionE.
  rewrite (eq_bigr (fun sh : intpartn_subFinType n => #|stdtabsh_finType sh|^2)); first last.
  move=> i _; by rewrite card_stpsh.
  apply eq_bigr => sh _.
  by rewrite HookLengthFormula intpartn_sumn.
Qed.

Lemma RSstdmapP (s : stdwordn n) : is_stdtab_pair_of_n n (RStabmap s).
Proof.
  have := RStabmap_spec s.
  have := RStabmapE s.
  rewrite /is_stdtab_pair_of_n /is_RStabpair /=.
  move H : (RStabmap s) => [p q] /= HRS /and3P [] Hp Hq /eqP Hsh.
  rewrite /size_tab -Hsh Hq eq_refl /= !andbT.
  rewrite HRS RSstdE stdwordnP /=.
  by rewrite -/(size_tab _) size_RS size_sdtn eq_refl !andbT.
Qed.
Definition RSstd (s : stdwordn n) : stpn := STPN (RSstdmapP s).

Lemma rspair_stpnP (p : stpn) : is_RStabpair (val p).
Proof.
  rewrite /is_RStabpair; case: p => [[p q]] /=.
  by rewrite /is_stdtab_pair_of_n /= => /and3P [] /andP [] /andP [] -> _ _ /andP [] -> _ ->.
Qed.
Definition rspair_stpn (p : stpn) : (rstabpair nat_ordType) := RSTabPair (rspair_stpnP p).
Lemma RSstdmap_invP (p : stpn) : is_std_of_n n (RStabinv (rspair_stpn p)).
Proof.
  have /= := RStabinvK (rspair_stpn p).
  rewrite /RStab /= => Hcan.
  have := erefl (val (rspair_stpn p)).
  rewrite -{1}Hcan {Hcan} /= => Hp.
  rewrite /is_std_of_n /=; apply/andP; split.
  - rewrite -RSstdE -RStabmapE Hp {Hp}.
    case: p => [[p q]]; by rewrite /is_stdtab_pair_of_n /= => /andP [] /andP [].
  - rewrite -size_RS -RStabmapE Hp {Hp}.
    case: p => [[p q]]; by rewrite /is_stdtab_pair_of_n /= => /andP [] /andP [].
Qed.
Definition RSstdinv (p : stpn) : stdwordn n := StdWordN (RSstdmap_invP p).

Lemma RSstdinvK : cancel RSstdinv RSstd.
Proof.
  move=> pq; have := RStabinvK (rspair_stpn pq).
  rewrite /RStab /= => Hcan.
  have := erefl (val (rspair_stpn pq)).
  rewrite -{1}Hcan {Hcan} /= => Hpq.
  move: pq Hpq => [[p q]] Hpq; rewrite /RSstd /RSstdinv /= => H.
  by apply val_inj => /=.
Qed.
Lemma RSstdK : cancel RSstd RSstdinv.
Proof.
  move=> s /=; apply val_inj; rewrite /= -(RStabK s).
  congr (RStabinv _); by apply val_inj => /=.
Qed.
Lemma bijRSstd : bijective RSstd.
Proof. split with (g := RSstdinv). exact: RSstdK. exact: RSstdinvK. Qed.

Theorem Ident : n`! = \sum_(p : intpartn n) (n`! %/ (F_deno p))^2.
Proof. rewrite -{1}card_stdwordn -card_stpn; exact: bij_card bijRSstd. Qed.

Open Scope ring_scope.

Import GRing.Theory.
Import Num.Theory.

Theorem IdentBis : 1 / (n`!)%:Q = \sum_(p : intpartn n) 1 / (F_deno p)%:Q ^+ 2.
Proof.
  rewrite -[RHS]mulr1.
  have Hfn0 : n`!%:Q != 0 by rewrite intr_eq0 eqz_nat -lt0n fact_gt0.
  rewrite -{5}(@divff _ ((n`!%:Q) ^+ 2)); last by rewrite sqrf_eq0.
  rewrite mulrA mulr_suml.
  rewrite (eq_bigr (fun p : intpartn n => ((n`! %/ (F_deno p)) ^ 2)%N%:Q)); first last.
    move=> p _; rewrite PoszM intrM.
    have -> : (n`! %/ F_deno p)%:Q = (n`!)%:Q / (F_deno p)%:Q.
      rewrite -[LHS]mulr1 -{2}(@divff _ (F_deno p)%:Q); first last.
        rewrite intr_eq0 eqz_nat /=; exact: (F_deno_non0 p).
      rewrite !mulrA -intrM -PoszM.
      have := divF_deno p.
      by rewrite intpartn_sumn dvdn_eq => /eqP ->.
    by rewrite -expr2 expr_div_n mulrC mul1r.
  rewrite -!(big_morph intr (@intrD _) (id2 := 0)) //=.
  rewrite -!(big_morph Posz PoszD (id2 := 0%N)) //=.
  rewrite -Ident expr2.
  by rewrite invfM mulrA divff.
Qed.

End Identity.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall B O P T R Tprime : Universe, ((wd_ O P /\ (wd_ R B /\ (wd_ T R /\ (wd_ T Tprime /\ (wd_ B O /\ (wd_ R O /\ (wd_ R Tprime /\ (col_ R B R /\ (col_ R B T /\ col_ R T Tprime))))))))) -> col_ R B Tprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C Aprime Bprime Cprime O L Lprime : Universe, ((wd_ B O /\ (wd_ C O /\ (wd_ Bprime O /\ (wd_ Cprime O /\ (wd_ A O /\ (wd_ A Bprime /\ (wd_ A Aprime /\ (wd_ O Aprime /\ (wd_ O Lprime /\ (wd_ C Bprime /\ (wd_ O L /\ (wd_ B Cprime /\ (col_ O A B /\ (col_ O B C /\ (col_ O Aprime Bprime /\ (col_ O Bprime Cprime /\ (col_ O A C /\ (col_ O Aprime Cprime /\ (col_ B Cprime L /\ (col_ C Bprime Lprime /\ (col_ O L Lprime /\ col_ O C Aprime))))))))))))))))))))) -> col_ O A Aprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Definition ifdec (A B:Prop) (C:Type) (H:{A} + {B}) (x y:C) : C :=
if H then x else y.

Theorem ifdec_left :
forall (A B:Prop) (C:Set) (H:{A} + {B}),
~ B -> forall x y:C, ifdec H x y = x.
Proof. hammer_hook "DecBool" "DecBool.ifdec_left".
intros; case H; auto.
intro; absurd B; trivial.
Qed.

Theorem ifdec_right :
forall (A B:Prop) (C:Set) (H:{A} + {B}),
~ A -> forall x y:C, ifdec H x y = y.
Proof. hammer_hook "DecBool" "DecBool.ifdec_right".
intros; case H; auto.
intro; absurd A; trivial.
Qed.

Unset Implicit Arguments.