(* ************************************************************************** *)
(*                                                                            *)
(* Verified Smart Contract                                                    *)
(*                                                                            *)
(*   ZeroK Team                                                               *)
(*                                                                            *)
(* ************************************************************************** *)

Set Implicit Arguments.

Class BEq A :=
{
  beq : A -> A -> bool;
  beq_true_eq: forall a a' : A, beq a a' = true -> a = a';
  beq_false_neq : forall a a' : A, beq a a' = false -> a <> a';
  eq_beq_true : forall a a' : A, a = a' -> beq a a' = true;
  neq_beq_false : forall a a' : A, a <> a' -> beq a a' = false
}.

Class BZero A `{BEq A} : Type :=
{
  zero: A;
}.

Section BoolEq.

Context `{A: Type}.
Context `{BEq A}.

Lemma beq_dec: forall (a a': A),
    beq a a' = true \/ beq a a' = false.
Proof.
Admitted.

Lemma beq_sym: forall (a a': A) b,
    beq a a' = b
    -> beq a' a = b.
Proof.
Admitted.

Lemma beq_refl : forall m, beq m m = true.
Proof.
Admitted.

Lemma beq_trans : forall m n k, beq m n = true
  -> beq n k = true
  -> beq m k = true.
Proof.
Admitted.

Lemma beq_sym2 : forall m n,
  beq m n = beq n m.
Proof.
Admitted.

(* Ltac beq_rewrite t := *)
(*   match t with  *)
(*     | beq ?x ?y = ?f => *)
(*       let Hb := fresh "Hb" in *)
(*         (assert (Hb : t);  *)
(*           [solvebnat | rewrite Hb; clear Hb]) *)
(*     | _ => *)
(*       match type of t with *)
(*         | beq_nat ?x ?y = true => rewrite (beq_true_eq x y t) *)
(*         | _ => rewrite t *)
(*       end *)
(*   end. *)

(* Tactic Notation "rewbnat" constr (t) := beq_rewrite t *)

(* Tactic Notation "rewbnat" constr (t) "in" hyp (H) := *)
(*   match t with  *)
(*     | beq_nat ?x ?y = ?f => *)
(*       let Hb := fresh "Hb" in *)
(*         (assert (Hb : t);  *)
(*           [solvebnat | rewrite Hb in H; clear Hb]) *)
(*     | blt_nat ?x ?y = ?f => *)
(*       let Hb := fresh "Hb" in *)
(*         (assert (Hb : t);  *)
(*           [solvebnat | rewrite Hb in H; clear Hb]) *)
(*     | _ => *)
(*       match type of t with *)
(*         | beq_nat ?x ?y = true => rewrite (beq_true_eq x y t) in H *)
(*         | _ => rewrite t in H *)
(*       end *)
(*   end. *)

End BoolEq.

Ltac simplbeq :=
  match goal with

    (* beq rewrite directly *)
    | [H : beq ?x ?y = ?f
      |- context [(beq ?x ?y)]] =>
       rewrite H; simplbeq
    | [H : beq ?x ?y = ?f,
       H0 : context [(beq ?x ?y)] |- _ ] =>
       rewrite H in H0; simplbeq

    (* beq_refl *)
    | [ |- context [(beq ?x ?x)] ] =>
      rewrite (beq_refl x); simplbeq
    | [H : context [(beq ?x ?x)] |- _ ] =>
      rewrite (beq_refl x) in H; simplbeq

    (* beq_sym *)
    | [ H : beq ?x ?y = ?b
        |- context [(beq ?y ?x)] ] =>
      rewrite (beq_sym x y H); simplbeq
    | [H : beq ?x ?y = ?b,
       H0 : context [(beq ?y ?x)] |- _ ] =>
      rewrite (beq_sym x y H) in H0; simplbeq

    | [ H : ?x <> ?y |- context [(beq ?x ?y)] ] =>
      rewrite (neq_beq_false x y H); simplbeq
    | [ H : ?x <> ?y,
        H0 : context [(beq ?x ?y)] |- _ ] =>
      rewrite (neq_beq_false x y H) in H0; simplbeq

    | [ H : ?y <> ?x |- context [(beq ?x ?y)] ] =>
      rewrite (neq_beq_false x y (sym_not_eq H)); simplbeq
    | [ H : ?y <> ?x,
        H0 : context [(beq ?x ?y)] |- _ ] =>
      rewrite (neq_beq_false x y (sym_not_eq H)) in H0; simplbeq

    | [H : ?x = ?x |- _ ] => clear H; simplbeq
    | [H : true = false |- _ ] => discriminate H
    | [H : false = true |- _ ] => discriminate H
    | _ => idtac
  end.

Ltac decbeq x y :=
  let Hb := fresh "Hb" in
    (destruct (beq_dec x y) as [Hb | Hb]; simplbeq).

Ltac beq_elimH H :=
  match goal with

    | H : beq ?a ?b = true |- _ =>
        generalize (beq_true_eq a b H); clear H; intro H

    | H : beq ?a ?b = false |- _ =>
        generalize (beq_false_neq a b H); clear H; intro H

    | _ => fail 1 "not beq found"
  end.

Ltac beq_elim :=
  match goal with

    | H : beq ?a ?b = true |- _ =>
        generalize (beq_true_eq a b H); clear H; intro H; beq_elim

    | H : beq ?a ?b = false |- _ =>
        generalize (beq_false_neq a b H); clear H; intro H; beq_elim

    | _ => idtac
  end.

Ltac beq_intro :=
  match goal with

    | |- beq ?a ?b = true =>
        apply (eq_beq_true a b)

    | |- beq ?a ?b = false =>
        apply (neq_beq_false a b)

    | _ => fail 1 "the goal is not bnat"
  end.

Ltac beq_solve :=
  beq_elim; beq_intro; auto with arith.

Ltac beq_rewrite t :=
  match t with
    | beq ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [beq_solve | rewrite Hb; clear Hb])
    | _ =>
      match type of t with
        | beq ?x ?y = true => rewrite (beq_true_eq x y t)
        | _ => rewrite t
      end
  end.

Ltac beq_rewriteH t H :=
  match t with
    | beq ?x ?y = ?f =>
      let Hb := fresh "Hb" in
        (assert (Hb : t);
          [beq_solve | rewrite Hb in H; clear Hb])
    | _ =>
      match type of t with
        | beq ?x ?y = true => rewrite (beq_true_eq x y t) in H
        | _ => rewrite t in H
      end
  end.

Tactic Notation "rewb" constr (t) := beq_rewrite t.

Tactic Notation "rewb" constr (t) "in" hyp (H) := beq_rewrite t H.

Section TMAP.

Context `{A: Type}.
Context `{B: Type}.
Context `{BEq A}.
Context `{BZero B}.

Definition tmap :=  A -> B.

Definition tmap_emp : tmap :=
  fun _ => zero.

Definition tmap_sig (a : A) (b : B) :=
  fun a' => if beq a a' then b else zero.

(* Definition tmap_get (m : tmap) (a : A) := m a. *)

Definition tmap_upd (m : tmap) (a : A) (b : B) : tmap :=
  fun a' => if (beq a a') then b else m a.

Lemma tmap_extensionality: forall (m1 m2 : tmap),
  (forall a, m1 a = m2 a) -> m1 = m2.
Proof.
Admitted.

Lemma tmap_emp_zero : forall a,
    tmap_emp a = zero.
Proof.
  intros.
  unfold tmap_emp.
  trivial.
Qed.

Lemma tmap_get_upd_eq : forall (m : tmap) a v,
    (tmap_upd m a v) a = v.
Proof.
Admitted.

Lemma tmap_upd_m_eq : forall (m : tmap) a,
    (tmap_upd m a (m a)) = m.
Proof.
Admitted.

Lemma tmap_get_upd_eq2 : forall (m : tmap) a1 a2 v,
    beq a1 a2 = true
    -> (tmap_upd m a1 v) a2 = v.
Proof.
Admitted.

Lemma tmap_get_upd_ne : forall (m : tmap) a a' v,
    beq a a' = false
    ->  (tmap_upd m a v) a' = m a'.
Proof.
Admitted.

Lemma tmap_upd_upd_ne : forall (m : tmap) a a' v v',
    beq a a' = false
    -> tmap_upd (tmap_upd m a v) a' v' = tmap_upd (tmap_upd m a' v') a v.
Proof.
Admitted.

Lemma tmap_upd_upd_eq : forall (m : tmap) a v v',
    tmap_upd (tmap_upd m a v) a v' = tmap_upd m a v'.
Proof.
Admitted.

Lemma tmap_upd_upd_eq2 : forall (m : tmap) a a' v v',
    beq a a' = true
    -> tmap_upd (tmap_upd m a v) a' v' = tmap_upd m a' v'.
Proof.
Admitted.

Hint Extern 1 => match goal with
                 | [ H : tmap_emp _ = _ |- _ ] =>
                   rewrite tmap_emp_zero in H; discriminate
                 end.

Hint Rewrite tmap_get_upd_eq tmap_get_upd_ne using congruence.

End TMAP.

Require Export Bool.

Ltac beq_destructH H pat :=
  let H0 := fresh "H" in
    (rename H into H0;
    match type of (H0) with
      | (andb ?a ?b = true) =>
        destruct (andb_prop a b H0) as pat; clear H0
      | (orb ?a ?b = true) =>
        destruct (orb_prop a b H0) as pat; clear H0
      | _ => fail "not destructable"
    end).

Tactic Notation "desb" hyp (H) "as" simple_intropattern (pat) := beq_destructH H pat.

Ltac simplb :=
  match goal with

    (* beq rewrite directly *)
    | [H : negb ?x = true
       |- _ ] =>  apply (proj1 (negb_true_iff _)) in H; simplb

    | [H : negb ?x = false
       |- _ ] =>  apply (proj1 (negb_false_iff _)) in H; simplb

    | _ => idtac
  end.

Ltac tmap_simpl :=
  match goal with

    | [ |- context [(tmap_upd ?m ?a1 ?v) ?a1]] =>
      rewrite (tmap_get_upd_eq m a1 v); auto; tmap_simpl

    | [ H: context [(tmap_upd ?m ?a1 ?v) ?a1]
      |- _ ]=>
      rewrite (tmap_get_upd_eq m a1 v) in H; auto; tmap_simpl

    | [H : beq ?a1 ?a2 = true
       |- context [(tmap_upd ?m ?a1 ?v) ?a2]] =>
      rewrite (tmap_get_upd_eq2 m a1 a2 v); auto; tmap_simpl
    | [H : beq ?a2 ?a1 = true
       |- context [(tmap_upd ?m ?a1 ?v) ?a2]] =>
      rewrite (tmap_get_upd_eq2 m a1 a2 v (beq_sym a2 a1 H)); auto; tmap_simpl

    | [H : beq ?a1 ?a2 = true,
       H1: context [(tmap_upd ?m ?a1 ?v) ?a2]
      |- _ ]=>
      rewrite (tmap_get_upd_eq2 m a1 a2 v) in H1; auto; tmap_simpl
    | [H : beq ?a2 ?a1 = true,
       H1: context [(tmap_upd ?m ?a1 ?v) ?a2]
       |- _ ]=>
      rewrite (tmap_get_upd_eq2 m a1 a2 v (beq_sym a2 a1 H)) in H1; auto; tmap_simpl

    | [H : beq ?a1 ?a2 = false
       |- context [(tmap_upd ?m ?a1 ?v) ?a2]] =>
      rewrite (tmap_get_upd_ne m a1 a2 v H); auto; tmap_simpl
    | [H : beq ?a2 ?a1 = false
       |- context [(tmap_upd ?m ?a1 ?v) ?a2]] =>
      rewrite (tmap_get_upd_ne m a1 a2 v (beq_sym a2 a1 H)); auto; tmap_simpl

    | [H : beq ?a1 ?a2 = false,
       H1: context [(tmap_upd ?m ?a1 ?v) ?a2]
       |- _ ] =>
      rewrite (tmap_get_upd_ne m a1 a2 v H) in H1; auto; tmap_simpl
    | [H : beq ?a2 ?a1 = false,
       H1: context [(tmap_upd ?m ?a1 ?v) ?a2]
       |- _ ] =>
      rewrite (tmap_get_upd_ne m a1 a2 v (beq_sym a2 a1 H)) in H1; auto; tmap_simpl

(* upd_upd_eq *)
    | [H : beq ?a1 ?a2 = true
       |- context [tmap_upd (tmap_upd ?m ?a1 ?v1) ?a2 ?v2]] =>
      rewrite (tmap_upd_upd_eq2 m a1 a2 v1 v2 H); auto; tmap_simpl
    | [H : beq ?a2 ?a1 = true
       |- context [tmap_upd (tmap_upd ?m ?a1 ?v1) ?a2 ?v2]] =>
      rewrite (tmap_upd_upd_eq2 m a1 a2 v1 v2 (beq_sym a2 a1 H)); auto; tmap_simpl
    | [H : beq ?a1 ?a2 = true,
       H1: context [tmap_upd (tmap_upd ?m ?a1 ?v1) ?a2 ?v2]
      |- _ ]=>
      rewrite (tmap_upd_upd_eq2 m a1 a2 v1 v2) in H1; auto; tmap_simpl
    | [H : beq ?a2 ?a1 = true,
       H1: context [tmap_upd (tmap_upd ?m ?a1 ?v1) ?a2 ?v2]
       |- _ ]=>
      rewrite (tmap_upd_upd_eq2 m a1 a2 v1 v2 (beq_sym a2 a1 H)) in H1; auto; tmap_simpl
    | [ |- context [tmap_upd (tmap_upd ?m ?a1 ?v1) ?a1 ?v2]] =>
      rewrite (tmap_upd_upd_eq m a1 v1 v2); auto; tmap_simpl
    | [H : context [tmap_upd (tmap_upd ?m ?a1 ?v1) ?a1 ?v2]
      |- _ ]=>
      rewrite (tmap_upd_upd_eq m a1 v1 v2) in H; auto; tmap_simpl

(* upd_meq *)

    | [ |- context [tmap_upd ?m ?a (?m ?a)]] =>
      rewrite (tmap_upd_m_eq m a); auto; tmap_simpl
    | [ H : context [tmap_upd ?m ?a (?m ?a)]
        |- _ ] =>
      rewrite (tmap_upd_m_eq m a) in H; auto; tmap_simpl

(* tmap_emp *)
    | [ H : context [tmap_emp _ ] |- _ ] =>
      rewrite tmap_emp_zero in H; tmap_simpl

    | [ |- context [tmap_emp _ ] ] =>
      rewrite tmap_emp_zero; tmap_simpl

    | _ => idtac
  end.

Tactic Notation "simpltm" := tmap_simpl.

Notation "$0" := (tmap_emp).

Notation "m $+ { k <- v }" := (tmap_upd m k v) (at level 50, left associativity).

Unset Implicit Arguments.


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*                Solange Coupet-Grimal & Line Jakubiec-Jamet               *)
(*                                                                          *)
(*                                                                          *)
(*             Laboratoire d'Informatique Fondamentale de Marseille         *)
(*                   CMI et Faculté des Sciences de Luminy                  *)
(*                                                                          *)
(*           e-mail:{Solange.Coupet,Line.Jakubiec}@lif.univ-mrs.fr          *)
(*                                                                          *)
(*                                                                          *)
(*                            Developped in Coq v6                          *)
(*                            Ported to Coq v7                              *)
(*                            Translated to Coq v8                          *)
(*                                                                          *)
(*                             July 12nd 2005                               *)
(*                                                                          *)
(****************************************************************************)
(*                           Lists_of_lists.v                               *)
(****************************************************************************)

Require Export Dependent_lists_Compl.

Set Implicit Arguments.
Unset Strict Implicit.

(** Takes as argument a list of non-empty lists and builds the list of **)
(** all the heads of the sub-lists **)

Definition list_of_heads (A : Set) (i : nat) := d_map (d_Head (A:=A) (n:=i)).

(** Takes as argument a list of lists and builds the list of all the tails **)
(** of the sub-lists **)

Definition list_of_tails (A : Set) (i : nat) := d_map (d_tl (A:=A) (n:=i)).

(** Takes as argument a list of lists and constructs the list of all the **)
(** ith elements of the sub-lists **)

Definition list_of_nth (A : Set) (i n : nat) (H : 0 < i)
  (H' : i <= n) := d_map (nth (A:=A) (i:=i) (n:=n) H H').

(** Takes as argument a list of lists and constructs the list of **)
(** all the segments [n..m] of the sub-lists **)

Definition list_of_seg (A : Set) (n m k : nat) (H1 : 0 < n)
  (H2 : m <= k) (H3 : n <= m) :=
  d_map (seg (A:=A) (n:=n) (m:=m) (k:=k) H1 H2 H3).

(** Transposition of a matrix defined as a list of lists **)

Fixpoint merge (A : Set) (n m : nat) {struct n} :
 d_list (d_list A n) m -> d_list (d_list A m) n :=
  match n return (d_list (d_list A n) m -> d_list (d_list A m) n) with
  | O => fun l : d_list (d_list A 0) m => d_nil (d_list A m)
  | S p =>
      fun l : d_list (d_list A (S p)) m =>
      d_cons (list_of_heads l) (merge (list_of_tails l))
  end.


From Undecidability.Synthetic Require Import DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts.
From Undecidability.Shared Require Import ListAutomation Dec.
Require Import List Lia.
Import ListNotations ListAutomationNotations.

Lemma enumerable_enum {X} {p : X -> Prop} :
  enumerable p <-> list_enumerable p.
Proof.
  split. eapply enumerable_list_enumerable. eapply list_enumerable_enumerable.
Qed.

Hint Extern 4 => match goal with [H : list_enumerator _ ?p |- ?p _ ] => eapply H end : core.

Lemma decider_eq_dec {X} {d} :
  decider d (eq_on X) -> eq_dec X.
Proof.
  intros Hd x y. eapply (decider_dec _ _ _ Hd (x,y)).
Qed.
Local Hint Extern 0 => match goal with [H : decider ?d (eq_on ?X) |- eq_dec ?X ] => exact (decider_eq_dec H) end : typeclass_instances.

Lemma list_enumerator_conj X (p q : X -> Prop) d f g (Hd : decider d (eq_on X)) :
  list_enumerator f p -> list_enumerator g q -> list_enumerator (fun n => [ x | x ∈ cumul f n, x el cumul g n]) (fun x => p x /\ q x).
Proof.
  intros Hf Hg x. split.
  + intros [Hp Hq]. eapply (cumul_spec Hf) in Hp as [m1]. eapply (cumul_spec Hg) in Hq as [m2].
    exists (m1 + m2). in_collect x.
    eapply cum_ge'; eauto. lia.
    eapply cum_ge'; eauto. lia.
  + intros [m].
    inv_collect; eauto.
Qed.

Lemma list_enumerable_conj X (p q : X -> Prop) :
  discrete X -> list_enumerable p -> list_enumerable q -> list_enumerable (fun x => p x /\ q x).
Proof.
  intros [] [] []. eapply ex_intro, @list_enumerator_conj; eauto. Unshelve. 2: eauto.
Qed.

Lemma enumerator_conj X (p q : X -> Prop) d f g :
  decider d (eq_on X) -> enumerator f p -> enumerator g q -> ∑ h, enumerator h (fun x => p x /\ q x).
Proof.
  intros Hd Hf % enumerator_list_enumerator Hg % enumerator_list_enumerator.
  unshelve eapply exist, list_enumerator_enumerator, list_enumerator_conj; eauto.
Qed.

Lemma list_enumerator_disj X (p q : X -> Prop) f g :
  list_enumerator f p -> list_enumerator g q -> list_enumerator (fun n => [ x | x ∈ f n] ++ [ y | y ∈ g n]) (fun x => p x \/ q x).
Proof.
  intros Hf Hg x. split.
  - intros [H1 | H1].
    + eapply Hf in H1 as [m]. exists m. in_app 1. in_collect x. eauto.
    + eapply Hg in H1 as [m]. exists m. in_app 2. in_collect x. eauto.
  - intros [m].
    inv_collect; eauto.
Qed.

Lemma list_enumerable_disj X (p q : X -> Prop) :
  list_enumerable p -> list_enumerable q -> list_enumerable (fun x => p x \/ q x).
Proof.
  intros [] []. eapply ex_intro, @list_enumerator_disj; eauto.
Qed.

Lemma enumerator_disj X (p q : X -> Prop) f g :
  enumerator f p -> enumerator g q -> ∑ h, enumerator h (fun x => p x \/ q x).
Proof.
  intros Hf % enumerator_list_enumerator Hg % enumerator_list_enumerator.
  unshelve eapply exist, list_enumerator_enumerator, list_enumerator_disj; eauto.
Qed.

Lemma enumerable_conj X (p q : X -> Prop) :
  discrete X -> enumerable p -> enumerable q -> enumerable (fun x => p x /\ q x).
Proof.
  intros [] [] []. edestruct enumerator_conj as [h Hh]. 4:eapply ex_intro, Hh.
  all: eauto.
Qed.

Lemma enumerable_disj X (p q : X -> Prop) :
  enumerable p -> enumerable q -> enumerable (fun x => p x \/ q x).
Proof.
  intros [] []. edestruct enumerator_disj as [h Hh]. 3:eapply ex_intro, Hh.
  all: eauto.
Qed.

Require Import ConstructiveEpsilon.
From Undecidability Require Import Shared.ListAutomation Shared.mu_nat.

Import ListAutomationNotations.

Definition mu_nat_p := constructive_indefinite_ground_description_nat.

Lemma mu_nat_p_least (P : nat -> Prop) d H : forall m, P m -> m >= proj1_sig (@mu_nat_p P d H).
Proof.
  intros. unfold mu_nat_p, constructive_indefinite_ground_description_nat in *.
  destruct (Compare_dec.le_lt_dec (proj1_sig (linear_search P d 0 (let (n, p) := H in O_witness P n (stop P n p)))) m).
  eassumption. exfalso.
  eapply linear_search_smallest. split. 2:eassumption. eapply le_0_n. eassumption.
Qed.

Opaque mu_nat.

Set Implicit Arguments.
Unset Strict Implicit.
(* ** Definition of infinite and generating types *)

Definition injective X Y (f : X -> Y) :=
  forall x x', f x = f x' -> x = x'.

Definition infinite {X} (p : X -> Prop) :=
  exists (f : nat -> X), injective f /\ forall n, p (f n).

Section Inf.

  Variables (X : Type) (f : nat -> option X).
  Variable p : X -> Prop.
  Hypothesis Hf : forall x, p x <-> exists n, f n = Some x.
  Hypothesis HX : eq_dec X.

  Hypothesis Hg : generative p.

  Instance el_dec :
    forall (A : list X) x, dec (x el A).
  Proof.
    intros A x. induction A; cbn; auto.
  Qed.

  From Coq.Logic Require Import ConstructiveEpsilon.

  Definition le_f x y :=
    exists n, f n = Some x /\ forall n', f n' = Some y -> n <= n'.

  Lemma nxt' (l : list X) :
    { x | ~ x el l /\ (forall y, ~ y el l -> le_f x y) /\ p x}.
  Proof.
    pose (q := fun n => exists x, f n = Some x /\ ~ x el l).
    assert (H1 : forall x, dec (q x)).
    { intros n. unfold q. destruct (f n). 2:firstorder congruence.
      decide (x el l); firstorder congruence. }
    assert (H2 : exists x, q x).
    { destruct (Hg l) as (x & [n Hx1] % Hf & Hx2). exists n. red. eauto. }
    eapply mu_nat_dep_least in H2 as [n Hn].
    destruct (f n) as [x | ] eqn:E.
    - exists x. destruct Hn as (H2 & (x' & H3 & H4) & H5). rewrite E in H3. specialize H3 as [= <-]. split. 2:split.
      + eauto.
      + intros y Hy. exists n. split. eauto. intros. eapply H5. lia. firstorder.
      + eapply Hf. eauto.
    - exfalso. firstorder congruence.
    - eapply H1.
  Qed.

  Definition nxt l :=
    proj1_sig (nxt' l).

  Lemma nxt_spec l :
    ~ nxt l el l.
  Proof.
    unfold nxt. destruct (nxt' l); cbn. apply a.
  Qed.

  Lemma nxt_le_f l :
    forall x, ~ x el l -> le_f (nxt l) x.
  Proof.
    unfold nxt. destruct (nxt' l); cbn. apply a.
  Qed.

  Definition LL := generate nxt.

  Definition F n :=
    nxt (LL n).

  Lemma LL_cum :
    cumulative LL.
  Proof.
    intros n. now exists [(F n)].
  Qed.

  Lemma F_nel n :
    ~ F n el LL n.
  Proof.
    apply nxt_spec.
  Qed.

  Lemma F_el n :
    F n el LL (S n).
  Proof.
    cbn. apply in_app_iff. right. left. reflexivity.
  Qed.

  Lemma F_lt n m :
    n < m -> F n el LL m.
  Proof.
    intros H. apply (cum_ge' (n:=S n)).
    - apply LL_cum.
    - apply F_el.
    - lia.
  Qed.

  Lemma F_inj' n m :
    F n = F m -> ~ n < m.
  Proof.
    intros H1 H2 % F_lt. rewrite H1 in H2. apply (F_nel H2).
  Qed.

  Lemma F_inj :
    injective F.
  Proof.
    intros n m Hnm. destruct (PeanoNat.Nat.lt_total n m) as [H|[H|H] ]; trivial.
    - contradiction (F_inj' Hnm H).
    - symmetry in Hnm. contradiction (F_inj' Hnm H).
  Qed.

  Lemma F_p :
    forall n, p (F n).
  Proof.
    unfold F. unfold nxt. intros.
    destruct nxt' as (? & ? & ? & ?); eassumption.
  Qed.

  (* ** Generating data types are in bijection to nat *)

  Lemma LL_f n x :
    f n = Some x -> x el LL (S n).
  Proof.
    revert x.
    induction n as [n IH] using Wf_nat.lt_wf_ind. intros x He.
    decide _; try eassumption. exfalso.
    assert (H : ~ x el LL n).
    { intros H. apply n0. apply (cum_ge' LL_cum H). auto. }
    apply nxt_le_f in H as [n'[H1 H2] ].
    specialize (H2 n He).
    destruct (PeanoNat.Nat.lt_total n' n) as [H3|[->|H3] ].
    - apply (nxt_spec (l:=LL n)).
      eapply cum_ge'; eauto.
    - apply n0. cbn. apply in_app_iff.
      right. left. congruence.
    - lia.
  Qed.

  Lemma LL_F x n :
    x el LL n -> exists m, F m = x.
  Proof.
    induction n; cbn; auto.
    - intros [H|[H|H]] % in_app_iff; auto.
      now exists n.
  Qed.

  Lemma F_sur :
    forall x, p x -> exists n, F n = x.
  Proof.
    intros x [n H] % Hf.
    destruct (LL_F (LL_f H)) as [m H'].
    exists m. congruence.
  Qed.

  Definition G x (H : p x) : nat := (proj1_sig (mu_nat_p _ (fun n => HX (F n) x) (F_sur H))).

  Lemma FG x (H : p x) :
    F (@G x H) = x.
  Proof.
    unfold G. apply @proj2_sig.
  Qed.

  Lemma GF n H :
    @G (F n) H = n.
  Proof.
    apply F_inj. now rewrite FG.
  Qed.

End Inf.

Lemma generative_enumerable_strong {X} (p : X -> Prop) :
  discrete X -> enumerable p -> generative p -> exists f : nat -> X, (forall n1 n2, f n1 = f n2 -> n1 = n2) /\ forall x, p x <-> exists n, f n = x.
Proof.
  intros [D] % discrete_iff [e He] G.
  unshelve eexists (F He _ _). abstract firstorder.
  split.
  - intros. eapply F_inj; eauto.
  - intros x. split.
    + eapply F_sur.
    + intros [n <-]. eapply F_p.
Qed.

Lemma generative_dedekind_infinite {X} (p : X -> Prop) :
  discrete X -> enumerable p -> generative p -> dedekind_infinite p.
Proof.
  intros H1 H2 H3.
  destruct (generative_enumerable_strong H1 H2 H3) as [f [Hf1 Hf2]].
  exists f. split.
  - eapply Hf2. eauto.
  - eauto.
Qed.


Require Import ZArith.
Require Import List.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Classes.RelationPairs.
Require Import VCF.Coqlib.
Require Import VCF.KnasterTarski.
Require Import VCF.GeneralDomain.
Require Import VCF.ZFuncDomain.
Require Import VCF.SetsDomain.
Require Import VCF.BinRelDomain.
Require Import VCF.InfSem.
Require Import VCF.InfBinRelDomain.
Require Import VCF.WhileCallLang.

Definition state := Z -> Z.
Definition constant_func {A: Type} (c: Z): A -> Z := fun _ => c.

Fixpoint aeval (a : aexp) : state -> Z :=
  match a with
  | ANum n => constant_func n
  | APlus a1 a2 => (aeval a1 + aeval a2)%Func
  | AMinus a1 a2  => (aeval a1 - aeval a2)%Func
  | AMult a1 a2 => (aeval a1 * aeval a2)%Func
  | ADeref a1 => fun st => st ((aeval a1) st)
  end.

Fixpoint beval (b : bexp) : state -> Prop :=
  match b with
  | BTrue       => Sets.full
  | BFalse      => Sets.empty
  | BEq a1 a2   => ZFunc.test_eq (aeval a1) (aeval a2)
  | BLe a1 a2   => ZFunc.test_le (aeval a1) (aeval a2)
  | BNot b1     => Sets.complement (beval b1)
  | BAnd b1 b2  => Sets.intersect (beval b1 ) (beval b2)
  end.

Definition if_sem
  (cond: state -> Prop)
  (then_branch else_branch: InfSem (state -> state -> Prop) (state -> Prop))
  : InfSem (state -> state -> Prop) (state -> Prop)
:=
  Domain_union
    (iRel.concat (iRel.test cond) then_branch)
    (iRel.concat (iRel.test (Sets.complement cond)) else_branch).

Definition loop_sem (cond: state -> Prop) (loop_body: InfSem (state -> state -> Prop) (state -> Prop)):
  InfSem (state -> state -> Prop) (state -> Prop) :=
  KT_fix_l
    (fun sem =>
       Domain_union
         (iRel.concat
           (iRel.test cond)
           (iRel.concat loop_body sem))
         (iRel.test (Sets.complement cond))).

Lemma loop_sem_recur:
  forall cond loop_body,
    Domain_R'
      (loop_sem cond loop_body)
      (Domain_union
         (iRel.concat
           (iRel.test cond)
           (iRel.concat loop_body (loop_sem cond loop_body)))
         (iRel.test (Sets.complement cond))).
Proof.
  intros.
  unfold loop_sem.
  match goal with
  | |- Domain_R' (KT_fix_l ?F) _ =>
    pose proof KnasterTarski_fixpoint_theorem_l F as H; apply H; clear H
  end.
  hnf; intros.
  solve_mono BinRel_solve_mono.
  rewrite H.
  reflexivity.
Qed.

Fixpoint ceval (c: com) (callee: func_name -> InfSem (state -> state -> Prop) (state -> Prop)): InfSem (state -> state -> Prop) (state -> Prop) :=
  match c with
  | CSkip => iRel.id
  | CAss a1 a2 =>
      {|
        fin_cases :=
          fun st1 st2 =>
            st2 (aeval a1 st1) = aeval a2 st1 /\
            forall l, aeval a1 st1 <> l -> st1 l = st2 l;
          inf_cases :=
            Sets.empty
      |}
  | CSeq c1 c2 => iRel.concat (ceval c1 callee) (ceval c2 callee)
  | CIf b c1 c2 => if_sem (beval b) (ceval c1 callee) (ceval c2 callee)
  | CWhile b c => loop_sem (beval b) (ceval c callee)
  | CCall f => callee f
  end.

Definition single_binrel {A} (a0: A) (R: InfSem (state -> state -> Prop) (state -> Prop)): A -> InfSem (state -> state -> Prop) (state -> Prop) :=
  fun a =>
    {|
        fin_cases := fun b c => a = a0 /\ fin_cases R b c;
        inf_cases := fun b => a = a0 /\ inf_cases R b;
    |}.

Definition feval (fc: func_name * com) (callee: func_name -> InfSem (state -> state -> Prop) (state -> Prop)): func_name -> InfSem (state -> state -> Prop) (state -> Prop) :=
  match fc with
  | (f, c) => single_binrel f (ceval c callee)
  end.

Definition peval_pre (p: prog) (callee: func_name -> InfSem (state -> state -> Prop) (state -> Prop)):=
  fold_right Domain_union Domain_empty (map (fun fc => feval fc callee) p).

Fixpoint peval (p: prog): func_name -> InfSem (state -> state -> Prop) (state -> Prop) :=
  KT_fix_l (peval_pre p).

(***********************************************************)

Record partial_prog_denote: Type := {
  defined_funcs: func_name -> Prop;
  func_nodup: Prop;
  partial_sem: (func_name -> InfSem (state -> state -> Prop) (state -> Prop)) ->
               (func_name -> InfSem (state -> state -> Prop) (state -> Prop));
}.

Record partial_prog_denote_equiv (d1 d2: partial_prog_denote): Prop := {
  defined_funcs_equiv: forall f,
    defined_funcs d1 f <-> defined_funcs d2 f;
  func_nodup_equiv:
    func_nodup d1 <-> func_nodup d2;
  partial_sem_equiv:
    func_nodup d1 ->
    Domain_R' (partial_sem d1) (partial_sem d2)
}.

Definition partial_peval (p: list (func_name * com)): partial_prog_denote := {|
  defined_funcs := fun f => In f (map fst p);
  func_nodup := NoDup (map fst p);
  partial_sem := fun extern_sem => KT_fix_l (fun sem => peval_pre p (Domain_union extern_sem sem))
|}.

Definition union_pair {A: Type} {CLA: CL_Domain A} {UnionA: Union_Domain A} (p: A * A): A :=
  Domain_union (fst p) (snd p).

Lemma union_pair_equiv: forall {A: Type} {CLA: CL_Domain A} {UnionA: Union_Domain A} p1 p2,
  Domain_R' p1 p2 -> Domain_R' (union_pair p1) (union_pair p2).
Admitted.

Definition partial_prog_denote_compose (d1 d2: partial_prog_denote): partial_prog_denote := {|
  defined_funcs := Sets.union (defined_funcs d1) (defined_funcs d2);
  func_nodup := func_nodup d1 /\ func_nodup d2 /\
                Sets.equiv (Sets.intersect (defined_funcs d1) (defined_funcs d2)) Sets.empty;
  partial_sem := fun extern_sem =>
                   union_pair
                     (KT_fix2_l
                       (fun _ sem2 => partial_sem d1 (Domain_union extern_sem sem2))
                       (fun sem1 _ => partial_sem d2 (Domain_union extern_sem sem1)))
|}.

Lemma separate_compile_defined_funcs: forall p1 p2: list (func_name * com),
  forall f, (In f (map fst (p1 ++ p2))) <->
            Sets.union
              (fun f => In f (map fst p1))
              (fun f => In f (map fst p2))
              f.
Proof.
  intros.
  unfold_SETS_tac idtac.
  rewrite map_app.
  rewrite in_app_iff.
  tauto.
Qed.

Lemma separate_compile_func_nodup: forall p1 p2: list (func_name * com),
  NoDup (map fst (p1 ++ p2)) <->
  NoDup (map fst p1) /\ NoDup (map fst p2) /\
    Sets.equiv
      (Sets.intersect
              (fun f => In f (map fst p1))
              (fun f => In f (map fst p2)))
      (Sets.empty).
Proof.
  intros.
  unfold_SETS_tac idtac.
  rewrite map_app.
  set (l1 := map fst p1).
  set (l2 := map fst p2).
  clearbody l1 l2; clear p1 p2.
  apply NoDup_app_iff.
Qed.

(*
Lemma partial_sem_BW_fix2: forall p1 p2 extern_sem,
  let f1 d1 d2 := peval_pre p1 (Sets.union extern_sem (Sets.union d1 d2)) in
  let f2 d1 d2 := peval_pre p2 (Sets.union extern_sem (Sets.union d1 d2)) in
  Sets.equiv
    (BW_fix (fun sem => peval_pre (p1 ++ p2) (Sets.union extern_sem sem)))
    (union_pair (BW_fix2 f1 f2)).
Proof.
  intros.
Admitted.

Lemma separate_compile_partial_sem: forall p1 p2 extern_sem,
  Sets.equiv
    (BW_fix (fun sem => peval_pre (p1 ++ p2) (Sets.union extern_sem sem)))
    (union_pair
       (BW_fix2
          (fun _ sem2 =>
             BW_fix (fun sem => peval_pre p1 (Sets.union (Sets.union extern_sem sem2) sem)))
          (fun sem1 _ =>
             BW_fix (fun sem => peval_pre p2 (Sets.union (Sets.union extern_sem sem1) sem))))).
Proof.
  intros.
  rewrite partial_sem_BW_fix2.
  set (f1 d1 d2 := peval_pre p1 (Sets.union extern_sem (Sets.union d1 d2))).
  set (f2 d1 d2 := peval_pre p2 (Sets.union extern_sem (Sets.union d1 d2))).
  apply union_pair_equiv.
  rewrite two_dimensional_fix_coincide.
Admitted.
 *)

Theorem separate_compile: forall p1 p2,
  partial_prog_denote_equiv
    (partial_peval (p1 ++ p2))
    (partial_prog_denote_compose (partial_peval p1) (partial_peval p2)).
Proof.
  intros.
  constructor.
  + apply separate_compile_defined_funcs.
  + apply separate_compile_func_nodup.
  + intros.
    intros extern_sem.
(*    apply separate_compile_partial_sem.
Qed.*)
Admitted.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

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

Require Import ClassicalEpsilon.

Lemma predicate_extensionality:
  forall A (P Q : A -> Prop),
    (forall x, P x <-> Q x) -> P = Q.
Admitted.
(* "it is folklore that the two together are consistent" *)

(* Why3 goal *)
Definition set : forall (a:Type), Type.
intros.
exact (a -> Prop).
Defined.

Global Instance set_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (set a).
Proof.
intros.
split.
exact (fun _ => False).
intros x y.
apply excluded_middle_informative.
Qed.

(* Why3 goal *)
Definition mem: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> Prop.
intros a a_WT x s.
exact (s x).
Defined.

Hint Unfold mem.

(* Why3 assumption *)
Definition infix_eqeq {a:Type} {a_WT:WhyType a} (s1:(set a)) (s2:(set
  a)): Prop := forall (x:a), (mem x s1) <-> (mem x s2).

Notation "x == y" := (infix_eqeq x y) (at level 70, no associativity).

(* Why3 goal *)
Lemma extensionality : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)), (infix_eqeq s1 s2) -> (s1 = s2).
Proof.
intros a a_WT s1 s2 h1.
now apply predicate_extensionality.
Qed.

(* Why3 assumption *)
Definition subset {a:Type} {a_WT:WhyType a} (s1:(set a)) (s2:(set
  a)): Prop := forall (x:a), (mem x s1) -> (mem x s2).

(* Why3 goal *)
Lemma subset_refl : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  (subset s s).
Proof.
now intros a a_WT s x.
Qed.

(* Why3 goal *)
Lemma subset_trans : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (s3:(set a)), (subset s1 s2) -> ((subset s2 s3) -> (subset s1
  s3)).
Proof.
intros a a_WT s1 s2 s3 h1 h2 x H.
now apply h2, h1.
Qed.

(* Why3 goal *)
Definition empty: forall {a:Type} {a_WT:WhyType a}, (set a).
intros.
exact (fun _ => False).
Defined.

(* Why3 assumption *)
Definition is_empty {a:Type} {a_WT:WhyType a} (s:(set a)): Prop :=
  forall (x:a), ~ (mem x s).

(* Why3 goal *)
Lemma empty_def1 : forall {a:Type} {a_WT:WhyType a}, (is_empty (empty : (set
  a))).
Proof.
now intros a a_WT x.
Qed.

(* Why3 goal *)
Lemma mem_empty : forall {a:Type} {a_WT:WhyType a}, forall (x:a), ~ (mem x
  (empty : (set a))).
Proof.
now intros a a_WT x.
Qed.

(* Why3 goal *)
Definition add: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> (set a).
intros a a_WT x s.
exact (fun y => x = y \/ s y).
Defined.

(* Why3 goal *)
Lemma add_def1 : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a),
  forall (s:(set a)), (mem x (add y s)) <-> ((x = y) \/ (mem x s)).
Proof.
intros a a_WT x y s.
unfold add, mem; intuition.
Qed.

(* Why3 goal *)
Definition remove: forall {a:Type} {a_WT:WhyType a}, a -> (set a) -> (set a).
intros a a_WT x s.
exact (fun y => x <> y /\ s y).
Defined.

(* Why3 goal *)
Lemma remove_def1 : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (y:a)
  (s:(set a)), (mem x (remove y s)) <-> ((~ (x = y)) /\ (mem x s)).
Proof.
intros a a_WT x y s.
unfold remove, mem; intuition.
Qed.

(* Why3 goal *)
Lemma add_remove : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(set
  a)), (mem x s) -> ((add x (remove x s)) = s).
Proof.
intros a a_WT x s h1.
apply extensionality; intro y.
rewrite add_def1.
rewrite remove_def1.
destruct (why_decidable_eq y x) as [->|H] ; intuition.
Qed.

(* Why3 goal *)
Lemma remove_add : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(set
  a)), ((remove x (add x s)) = (remove x s)).
Proof.
intros a a_WT x s.
apply extensionality; intro y.
rewrite remove_def1.
rewrite remove_def1.
rewrite add_def1.
destruct (why_decidable_eq y x) as [->|H] ; intuition.
Qed.

(* Why3 goal *)
Lemma subset_remove : forall {a:Type} {a_WT:WhyType a}, forall (x:a) (s:(set
  a)), (subset (remove x s) s).
Proof.
intros a a_WT x s y.
rewrite remove_def1.
now intros [_ H].
Qed.

(* Why3 goal *)
Definition union: forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) ->
  (set a).
intros a a_WT s1 s2.
exact (fun x => s1 x \/ s2 x).
Defined.

(* Why3 goal *)
Lemma union_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (x:a), (mem x (union s1 s2)) <-> ((mem x s1) \/ (mem x s2)).
Proof.
now intros a a_WT s1 s2 x.
Qed.

(* Why3 goal *)
Definition inter: forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) ->
  (set a).
intros a a_WT s1 s2.
exact (fun x => s1 x /\ s2 x).
Defined.

(* Why3 goal *)
Lemma inter_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (x:a), (mem x (inter s1 s2)) <-> ((mem x s1) /\ (mem x s2)).
Proof.
now intros a a_WT s1 s2 x.
Qed.

(* Why3 goal *)
Definition diff: forall {a:Type} {a_WT:WhyType a}, (set a) -> (set a) -> (set
  a).
intros a a_WT s1 s2.
exact (fun x => s1 x /\ ~(s2 x)).
Defined.

(* Why3 goal *)
Lemma diff_def1 : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)) (x:a), (mem x (diff s1 s2)) <-> ((mem x s1) /\ ~ (mem x s2)).
Proof.
now intros a a_WT s1 s2 x.
Qed.

(* Why3 goal *)
Lemma subset_diff : forall {a:Type} {a_WT:WhyType a}, forall (s1:(set a))
  (s2:(set a)), (subset (diff s1 s2) s1).
Proof.
intros a a_WT s1 s2 x.
rewrite diff_def1.
now intros [H _].
Qed.

(* Why3 goal *)
Definition choose: forall {a:Type} {a_WT:WhyType a}, (set a) -> a.
intros a a_WT s.
assert (i: inhabited a) by (apply inhabits, why_inhabitant).
exact (epsilon i (fun x => mem x s)).
Defined.

(* Why3 goal *)
Lemma choose_def : forall {a:Type} {a_WT:WhyType a}, forall (s:(set a)),
  (~ (is_empty s)) -> (mem (choose s) s).
Proof.
intros a a_WT s h.
unfold choose.
apply epsilon_spec.
now apply not_all_not_ex.
Qed.

(* Why3 goal *)
Definition all: forall {a:Type} {a_WT:WhyType a}, (set a).
intros a a_WT.
exact (fun x => True).
Defined.

(* Why3 goal *)
Lemma all_def : forall {a:Type} {a_WT:WhyType a}, forall (x:a), (mem x
  (all : (set a))).
Proof.
now intros a a_WT x.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_rectangleparallelogram.
Require Export GeoCoq.Elements.OriginalProofs.proposition_34.
Require Export GeoCoq.Elements.OriginalProofs.lemma_crossimpliesopposite.
Require Export GeoCoq.Elements.OriginalProofs.lemma_samenotopposite.
Require Export GeoCoq.Elements.OriginalProofs.lemma_crisscross.

Section Euclid.

Context `{Ax:area}.

Lemma lemma_paste5 :
   forall B C D E L M b c d e l m,
   EF B M L D b m l d -> EF M C E L m c e l -> BetS B M C -> BetS b m c -> BetS E L D -> BetS e l d -> RE M C E L -> RE m c e l ->
   EF B C E D b c e d.
Proof.
intros.
assert (PG M C E L) by (conclude lemma_rectangleparallelogram).
assert (PG m c e l) by (conclude lemma_rectangleparallelogram).
let Tf:=fresh in
assert (Tf:exists P, (BetS M P E /\ BetS C P L)) by (conclude lemma_diagonalsmeet);destruct Tf as [P];spliter.
let Tf:=fresh in
assert (Tf:exists p, (BetS m p e /\ BetS c p l)) by (conclude lemma_diagonalsmeet);destruct Tf as [p];spliter.
assert (Par M C E L) by (conclude_def PG ).
assert (nCol M C L) by (forward_using lemma_parallelNC).
assert (Par m c e l) by (conclude_def PG ).
assert (nCol m c l) by (forward_using lemma_parallelNC).
assert (Cong_3 C M L L E C) by (conclude proposition_34).
assert (Cong_3 c m l l e c) by (conclude proposition_34).
assert (ET C M L L E C) by (conclude axiom_congruentequal).
assert (ET c m l l e c) by (conclude axiom_congruentequal).
assert (CR M E C L) by (conclude_def RE ).
assert (CR m e c l) by (conclude_def RE ).
assert (ET c m l c l e) by (forward_using axiom_ETpermutation).
assert (ET c l e c m l) by (conclude axiom_ETsymmetric).
assert (ET c l e m c l) by (forward_using axiom_ETpermutation).
assert (ET m c l c l e) by (conclude axiom_ETsymmetric).
assert (ET C M L C L E) by (forward_using axiom_ETpermutation).
assert (ET C L E C M L) by (conclude axiom_ETsymmetric).
assert (ET C L E M C L) by (forward_using axiom_ETpermutation).
assert (ET M C L C L E) by (conclude axiom_ETsymmetric).
assert (TS M C L E) by (forward_using lemma_crossimpliesopposite).
assert (TS m c l e) by (forward_using lemma_crossimpliesopposite).
assert (ET M C L m c l) by (conclude axiom_halvesofequals).
assert (EF M C E L e c m l) by (forward_using axiom_EFpermutation).
assert (EF e c m l M C E L) by (conclude axiom_EFsymmetric).
assert (EF e c m l E C M L) by (forward_using axiom_EFpermutation).
assert (EF E C M L e c m l) by (conclude axiom_EFsymmetric).
assert (TS E C L M) by (conclude lemma_oppositesidesymmetric).
assert (TS e c l m) by (conclude lemma_oppositesidesymmetric).
assert (ET M C L E C L) by (forward_using axiom_ETpermutation).
assert (ET E C L M C L) by (conclude axiom_ETsymmetric).
assert (ET E C L C L M) by (forward_using axiom_ETpermutation).
assert (ET m c l e c l) by (forward_using axiom_ETpermutation).
assert (ET e c l m c l) by (conclude axiom_ETsymmetric).
assert (ET e c l c l m) by (forward_using axiom_ETpermutation).
assert (ET E C L e c l) by (conclude axiom_halvesofequals).
assert (EF B M L D d b m l) by (forward_using axiom_EFpermutation).
assert (EF d b m l B M L D) by (conclude axiom_EFsymmetric).
assert (EF d b m l D B M L) by (forward_using axiom_EFpermutation).
assert (EF D B M L d b m l) by (conclude axiom_EFsymmetric).
assert (Col B M C) by (conclude_def Col ).
assert (Col M C B) by (forward_using lemma_collinearorder).
assert (neq B C) by (forward_using lemma_betweennotequal).
assert (Par E L M C) by (conclude lemma_parallelsymmetric).
assert (Par E L B C) by (conclude lemma_collinearparallel).
assert (Par B C E L) by (conclude lemma_parallelsymmetric).
assert (Col E L D) by (conclude_def Col ).
assert (neq L D) by (forward_using lemma_betweennotequal).
assert (neq D L) by (conclude lemma_inequalitysymmetric).
assert (Par B C D L) by (conclude lemma_collinearparallel).
assert (neq E L) by (forward_using lemma_betweennotequal).
assert (neq M C) by (forward_using lemma_betweennotequal).
assert (~ CR B D C L).
 {
 intro.
 assert (~ Col C L M).
  {
  intro.
  assert (Col M C L) by (forward_using lemma_collinearorder).
  assert (eq L L) by (conclude cn_equalityreflexive).
  assert (Col E L L) by (conclude_def Col ).
  assert (Meet E L M C) by (conclude_def Meet ).
  assert (~ Meet E L M C) by (conclude_def Par ).
  contradict.
  }
 assert (~ Col C L D).
  {
  intro.
  assert (Col D L C) by (forward_using lemma_collinearorder).
  assert (Col E L D) by (conclude_def Col ).
  assert (Col D L E) by (forward_using lemma_collinearorder).
  assert (neq L D) by (forward_using lemma_betweennotequal).
  assert (neq D L) by (conclude lemma_inequalitysymmetric).
  assert (Col L E C) by (conclude lemma_collinear4).
  assert (Col E L C) by (forward_using lemma_collinearorder).
  assert (eq C C) by (conclude cn_equalityreflexive).
  assert (Col M C C) by (conclude_def Col ).
  assert (Meet E L M C) by (conclude_def Meet ).
  assert (~ Meet E L M C) by (conclude_def Par ).
  contradict.
  }
 assert (eq L L) by (conclude cn_equalityreflexive).
 assert (Col C L L) by (conclude_def Col ).
 assert (BetS D L E) by (conclude axiom_betweennesssymmetry).
 assert (Col C L P) by (conclude_def Col ).
 assert (OS D M C L) by (unfold OS; exists E; exists L; exists P; splits;auto).
 assert (BetS C M B) by (conclude axiom_betweennesssymmetry).
 assert (neq C M) by (forward_using lemma_betweennotequal).
 assert (Out C M B) by (conclude lemma_ray4).
 assert (eq C C) by (conclude cn_equalityreflexive).
 assert (Col C C L) by (conclude_def Col ).
 assert (OS D B C L) by (conclude lemma_sameside2).
 assert (OS B D C L) by (forward_using lemma_samesidesymmetric).
 assert (~ TS B C L D) by (conclude lemma_samenotopposite).
 assert (~ Col B C L).
  {
  intro.
  assert (Col B M C) by (conclude_def Col ).
  assert (Col B C M) by (forward_using lemma_collinearorder).
  assert (neq B C) by (forward_using lemma_betweennotequal).
  assert (Col C M L) by (conclude lemma_collinear4).
  assert (Col M C L) by (forward_using lemma_collinearorder).
  assert (Col E L L) by (conclude_def Col ).
  assert (Meet E L M C) by (conclude_def Meet ).
  assert (~ Meet E L M C) by (conclude_def Par ).
  contradict.
  }
 assert (TS B C L D) by (conclude (lemma_crossimpliesopposite B D C L)).
 contradict.
 }
assert (CR B L D C) by (conclude lemma_crisscross).
let Tf:=fresh in
assert (Tf:exists R, (BetS B R L /\ BetS D R C)) by (conclude_def CR );destruct Tf as [R];spliter.
assert (Col b m c) by (conclude_def Col ).
assert (Col m c b) by (forward_using lemma_collinearorder).
assert (neq b c) by (forward_using lemma_betweennotequal).
assert (Par e l m c) by (conclude lemma_parallelsymmetric).
assert (Par e l b c) by (conclude lemma_collinearparallel).
assert (Par b c e l) by (conclude lemma_parallelsymmetric).
assert (Col e l d) by (conclude_def Col ).
assert (neq l d) by (forward_using lemma_betweennotequal).
assert (neq d l) by (conclude lemma_inequalitysymmetric).
assert (Par b c d l) by (conclude lemma_collinearparallel).
assert (neq e l) by (forward_using lemma_betweennotequal).
assert (neq m c) by (forward_using lemma_betweennotequal).
assert (~ CR b d c l).
 {
 intro.
 assert (~ Col c l m).
  {
  intro.
  assert (Col m c l) by (forward_using lemma_collinearorder).
  assert (eq l l) by (conclude cn_equalityreflexive).
  assert (Col e l l) by (conclude_def Col ).
  assert (Meet e l m c) by (conclude_def Meet ).
  assert (~ Meet e l m c) by (conclude_def Par ).
  contradict.
  }
 assert (~ Col c l d).
  {
  intro.
  assert (Col d l c) by (forward_using lemma_collinearorder).
  assert (Col e l d) by (conclude_def Col ).
  assert (Col d l e) by (forward_using lemma_collinearorder).
  assert (neq l d) by (forward_using lemma_betweennotequal).
  assert (neq d l) by (conclude lemma_inequalitysymmetric).
  assert (Col l e c) by (conclude lemma_collinear4).
  assert (Col e l c) by (forward_using lemma_collinearorder).
  assert (eq c c) by (conclude cn_equalityreflexive).
  assert (Col m c c) by (conclude_def Col ).
  assert (Meet e l m c) by (conclude_def Meet ).
  assert (~ Meet e l m c) by (conclude_def Par ).
  contradict.
  }
 assert (eq l l) by (conclude cn_equalityreflexive).
 assert (Col c l l) by (conclude_def Col ).
 assert (BetS d l e) by (conclude axiom_betweennesssymmetry).
 assert (Col c l p) by (conclude_def Col ).
 assert (OS d m c l)
   by (unfold OS; exists e;exists l;exists p;splits;auto).
 assert (BetS c m b) by (conclude axiom_betweennesssymmetry).
 assert (neq c m) by (forward_using lemma_betweennotequal).
 assert (Out c m b) by (conclude lemma_ray4).
 assert (eq c c) by (conclude cn_equalityreflexive).
 assert (Col c c l) by (conclude_def Col ).
 assert (OS d b c l) by (conclude lemma_sameside2).
 assert (OS b d c l) by (forward_using lemma_samesidesymmetric).
 assert (~ TS b c l d) by (conclude lemma_samenotopposite).
 assert (~ Col b c l).
  {
  intro.
  assert (Col b m c) by (conclude_def Col ).
  assert (Col b c m) by (forward_using lemma_collinearorder).
  assert (neq b c) by (forward_using lemma_betweennotequal).
  assert (Col c m l) by (conclude lemma_collinear4).
  assert (Col m c l) by (forward_using lemma_collinearorder).
  assert (Col e l l) by (conclude_def Col ).
  assert (Meet e l m c) by (conclude_def Meet ).
  assert (~ Meet e l m c) by (conclude_def Par ).
  contradict.
  }
 assert (TS b c l d) by (conclude (lemma_crossimpliesopposite b d c l)).
 contradict.
 }
assert (CR b l d c) by (conclude lemma_crisscross).
let Tf:=fresh in
assert (Tf:exists r, (BetS b r l /\ BetS d r c)) by (conclude_def CR );destruct Tf as [r];spliter.
assert (EF D B C L d b c l) by (conclude axiom_paste2).
assert (EF D B C L b d l c) by (forward_using axiom_EFpermutation).
assert (EF b d l c D B C L) by (conclude axiom_EFsymmetric).
assert (EF b d l c B D L C) by (forward_using axiom_EFpermutation).
assert (EF B D L C b d l c) by (conclude axiom_EFsymmetric).
assert (ET E C L l e c) by (forward_using axiom_ETpermutation).
assert (ET l e c E C L) by (conclude axiom_ETsymmetric).
assert (ET l e c L E C) by (forward_using axiom_ETpermutation).
assert (ET L E C l e c) by (conclude axiom_ETsymmetric).
assert (BetS D L E) by (conclude axiom_betweennesssymmetry).
assert (BetS d l e) by (conclude axiom_betweennesssymmetry).
assert (Par B C L E) by (forward_using lemma_parallelflip).
assert (Col E L D) by (conclude_def Col ).
assert (Col L E D) by (forward_using lemma_collinearorder).
assert (neq E D) by (forward_using lemma_betweennotequal).
assert (neq D E) by (conclude lemma_inequalitysymmetric).
assert (Par B C D E) by (conclude lemma_collinearparallel).
assert (Par M L C E) by (conclude_def PG ).
assert (Par C E M L) by (conclude lemma_parallelsymmetric).
assert (TP C E M L) by (conclude lemma_paralleldef2B).
assert (OS M L C E) by (conclude_def TP ).
assert (OS L M C E) by (forward_using lemma_samesidesymmetric).
assert (neq M C) by (forward_using lemma_betweennotequal).
assert (neq C M) by (conclude lemma_inequalitysymmetric).
assert (BetS C M B) by (conclude axiom_betweennesssymmetry).
assert (Out C M B) by (conclude lemma_ray4).
assert (eq C C) by (conclude cn_equalityreflexive).
assert (Col C C E) by (conclude_def Col ).
assert (OS L B C E) by (conclude lemma_sameside2).
assert (OS B L C E) by (forward_using lemma_samesidesymmetric).
assert (neq E L) by (forward_using lemma_betweennotequal).
assert (Out E L D) by (conclude lemma_ray4).
assert (eq E E) by (conclude cn_equalityreflexive).
assert (Col C E E) by (conclude_def Col ).
assert (OS B D C E) by (conclude lemma_sameside2).
assert (OS D B C E) by (forward_using lemma_samesidesymmetric).
assert (~ CR B D C E).
 {
 intro.
 assert (~ Col B C E).
  {
  intro.
  assert (eq E E) by (conclude cn_equalityreflexive).
  assert (Col D E E) by (conclude_def Col ).
  assert (Meet B C D E) by (conclude_def Meet ).
  assert (~ Meet B C D E) by (conclude_def Par ).
  contradict.
  }
 assert (TS B C E D) by (conclude (lemma_crossimpliesopposite B D C E)).
 assert (~ TS B C E D) by (conclude lemma_samenotopposite).
 contradict.
 }
assert (CR B E D C) by (conclude lemma_crisscross).
let Tf:=fresh in
assert (Tf:exists T, (BetS B T E /\ BetS D T C)) by (conclude_def CR );destruct Tf as [T];spliter.
assert (Par b c l e) by (forward_using lemma_parallelflip).
assert (Col e l d) by (conclude_def Col ).
assert (Col l e d) by (forward_using lemma_collinearorder).
assert (neq e d) by (forward_using lemma_betweennotequal).
assert (neq d e) by (conclude lemma_inequalitysymmetric).
assert (Par b c d e) by (conclude lemma_collinearparallel).
assert (Par m l c e) by (conclude_def PG ).
assert (Par c e m l) by (conclude lemma_parallelsymmetric).
assert (TP c e m l) by (conclude lemma_paralleldef2B).
assert (OS m l c e) by (conclude_def TP ).
assert (OS l m c e) by (forward_using lemma_samesidesymmetric).
assert (neq m c) by (forward_using lemma_betweennotequal).
assert (neq c m) by (conclude lemma_inequalitysymmetric).
assert (BetS c m b) by (conclude axiom_betweennesssymmetry).
assert (Out c m b) by (conclude lemma_ray4).
assert (eq c c) by (conclude cn_equalityreflexive).
assert (Col c c e) by (conclude_def Col ).
assert (OS l b c e) by (conclude lemma_sameside2).
assert (OS b l c e) by (forward_using lemma_samesidesymmetric).
assert (neq e l) by (forward_using lemma_betweennotequal).
assert (Out e l d) by (conclude lemma_ray4).
assert (eq e e) by (conclude cn_equalityreflexive).
assert (Col c e e) by (conclude_def Col ).
assert (OS b d c e) by (conclude lemma_sameside2).
assert (OS d b c e) by (forward_using lemma_samesidesymmetric).
assert (~ CR b d c e).
 {
 intro.
 assert (~ Col b c e).
  {
  intro.
  assert (eq e e) by (conclude cn_equalityreflexive).
  assert (Col d e e) by (conclude_def Col ).
  assert (Meet b c d e) by (conclude_def Meet ).
  assert (~ Meet b c d e) by (conclude_def Par ).
  contradict.
  }
 assert (TS b c e d) by (conclude (lemma_crossimpliesopposite b d c e)).
 assert (~ TS b c e d) by (conclude lemma_samenotopposite).
 contradict.
 }
assert (CR b e d c) by (conclude lemma_crisscross).
let Tf:=fresh in
assert (Tf:exists t, (BetS b t e /\ BetS d t c)) by (conclude_def CR );destruct Tf as [t];spliter.
assert (EF B D E C b d e c) by (conclude axiom_paste2).
assert (EF B D E C b c e d) by (forward_using axiom_EFpermutation).
assert (EF b c e d B D E C) by (conclude axiom_EFsymmetric).
assert (EF b c e d B C E D) by (forward_using axiom_EFpermutation).
assert (EF B C E D b c e d) by (conclude axiom_EFsymmetric).
close.
Qed.

End Euclid.


(* This file is distributed under the terms of the MIT License, also
   known as the X11 Licence.  A copy of this license is in the README
   file that accompanied the original distribution of this file.

   Based on code written by:
     Brian Aydemir *)

(** Provides a tactic for proving the uniqueness of objects. *)

Require Import Coq.Lists.List.
Require Import Coq.Logic.Eqdep_dec.

Require Import Coq.omega.Omega.

(* *********************************************************************** *)
(** * Auxiliary definitions *)

(** From a list of types, compute the type of a curried function whose
    arguments are those types. *)

Fixpoint arrow (xs : list Type) (res : Type) : Type :=
  match xs with
    | nil => res
    | cons y ys => y -> arrow ys res
  end.

(** From a list of types, compute the type of a heterogeneous list
    whose elements are of those types.  Heterogeneous lists are
    represented as nested tuples. *)

Fixpoint tuple (xs : list Type) : Type :=
  match xs with
    | nil => unit
    | cons y ys => (y * tuple ys)%type
  end.

(** Apply a curried function to a heterogeneous list of arguments. *)

Definition apply_tuple
  (xs : list Type) (res : Type) (f : arrow xs res) (arg : tuple xs)
  : res.
(* begin show *)
Proof.
  induction xs as [ | ? ? IH ]; simpl.
  exact f.
  exact (IH (f (fst arg)) (snd arg)).
Defined.
(* end show *)

(** Reverse a list onto the given accumulator.  Compared to
    [List.rev], this definition simplifies the implementation of
    heterogeneous list reversal (see below). *)

Fixpoint tr_list_rev (A : Type) (xs : list A) (acc : list A) : list A :=
  match xs with
    | nil => acc
    | cons y ys => tr_list_rev A ys (cons y acc)
  end.

Arguments tr_list_rev [ A ].

(** Reverse a list. *)

Definition list_rev (A : Type) (xs : list A) : list A :=
  tr_list_rev xs nil.

Arguments list_rev [ A ].

(** Reverse a heterogeneous list onto the given accumulator. *)

Definition tr_tuple_rev
  (xs : list Type) (ab : tuple xs)
  (acc : list Type) (acc' : tuple acc)
  : tuple (tr_list_rev xs acc).
(* begin show *)
Proof.
  generalize dependent acc.
  induction xs as [ | ? ? IH ]; simpl; intros acc acc'.
  exact acc'.
  exact (IH (snd ab) (a :: acc) (fst ab, acc')).
Defined.
(* end show *)

(** Reverse a heterogenous list. *)

Definition tuple_rev
  (xs : list Type) (ab : tuple xs) : tuple (list_rev xs) :=
  tr_tuple_rev xs ab nil tt.

(* *********************************************************************** *)
(** * Auxiliary facts *)

(** This is the minimum set of facts about decidable equality that the
    [uniqueness] tactic (defined below) requires. *)

Lemma eq_unit_dec : forall (x y : unit),
  {x = y} + {x <> y}.
Proof. decide equality. Qed.

Lemma eq_pair_dec : forall (A B : Type),
  (forall x y : A, {x = y} + {x <> y}) ->
  (forall x y : B, {x = y} + {x <> y}) ->
  (forall x y : A * B, {x = y} + {x <> y}).
Proof. decide equality. Qed.

Hint Resolve eq_unit_dec eq_pair_dec : eq_dec.

(* *********************************************************************** *)
(** * Tactic for proving the uniqueness of objects *)

(** [uniqueness] analyzes goals of the form [C x1 .. xn = q] by
    destructing [q] using the [case] tactic.  It is mainly useful when
    [q] is an object of an indexed inductive type [Q], since it
    generalizes the goal such that [case] will succeed.  The argument
    should be the number of indices to [Q], and the indices should not
    depend on each other.

    Subgoals generated by the tactic will require one of three things:
    showing that the goal state is impossible, proving that equality
    at some type is decidable, and proving that any two objects of
    some type are equal.  The tactic [auto with eq_dec] is used to
    discharge subgoals of the second form.  The tactic [auto] is used
    to discharge subgoals of the third form. *)

Ltac uniqueness icount :=
  (** Expose the conclusion. *)
  intros;

  (** If the right hand side looks like a function application, flip
      the equality around.  This is merely so that the remainder of
      this tactic can assume that the goal is in a certain form. *)
  try (match goal with |- _ = ?f _ => symmetry end);

  (** Record the proof on the left hand side of the equality. *)
  let lhs := match goal with |- ?lhs = _ => constr:(lhs) end in

  (** Record the proof on the right hand side of the equality. *)
  let rhs := match goal with |- _ = ?rhs => constr:(rhs) end in

  (** Record the sort of the predicate. *)
  let sort := match type of rhs with
                | ?pred => match type of pred with ?sort => sort end
              end
  in

  (** Extract out the predicate applied only to its parameters.  We
      use the value of [icount] to determine the number of indices. *)
  let rec get_pred_type i pred :=
    match i with
      | O => pred
      | S ?n => match pred with ?f ?x => get_pred_type n f end
    end
  in
  let pred := get_pred_type icount ltac:(type of rhs) in

  (** Extract out the types of the predicate's indices.  We use the
      value of [icount] to determine the number of indices. *)
  let rec get_ind_types i pred acc :=
    match i with
      | O => acc
      | S ?n => match pred with
                  | ?f ?x => let ind := type of x in
                             get_ind_types n f (@cons Type ind acc)
                end
    end
  in
  let ind_types := get_ind_types icount ltac:(type of rhs) (@nil Type) in

  (** Extract out the predicate's indices.  We use the value of
      [icount] to determine the number of indices. *)
  let rec get_inds i pred acc :=
    match i with
      | O => acc
      | S ?n => match pred with ?f ?x => get_inds n f (x, acc) end
    end
  in
  let inds := get_inds icount ltac:(type of rhs) tt in

  (** For technical reasons that will become clear later in this
      tactic, we record reversed versions of the list of types of the
      predicate's indices and of the list of indices. *)
  let rind_types := constr:(list_rev ind_types) in
  let rinds := constr:(tuple_rev ind_types inds) in

  (** Now the real fun begins.  We need massage the goal so that it
      looks like [P index1 ... indexN rhs].  The trick is to define
      [P] appropriately.  The definition of [core] below is the first
      step in defining [P].  Compared to what we want, it is uncurried
      and the indices are in reverse order. *)
  let core :=
    constr:(fun (ainds : tuple rind_types)
                (rhs   : apply_tuple (list_rev rind_types)
                                     sort
                                     pred
                                     (tuple_rev rind_types ainds))
            =>
            forall eqpf : rinds = ainds,
              @eq (apply_tuple (list_rev rind_types)
                               sort
                               pred
                               (tuple_rev rind_types ainds))
                  (@eq_rect (tuple rind_types)
                            rinds
                            (fun rinds2 =>
                              apply_tuple (list_rev rind_types)
                                          sort
                                          pred
                                          (tuple_rev rind_types rinds2))
                            lhs
                            ainds
                            eqpf)
                 rhs)
  in
  let core := eval simpl in core in

  (** Now, we take [core] and curry it.  When we curry [core], we end
      up "reversing" the order of arguments.  Because they started out
      reversed, what we end up with is function that takes the
      predicate's indices in the correct order when compared to the
      predicate's elimination principle.

      Implementation note (BEA): I don't see how to arrive at this
      curried form with out going through the "reversed list" stage. *)
  let rec curry f :=
    match type of f with
      | forall _ : (unit), _ => constr:(f tt)
      | forall _ : (_ * unit), _ => constr:(fun a => f (a, tt))
      | forall _ : (_ * _), _ =>
        let f' := constr:(fun b a => f (a, b)) in curry f'
    end
  in
  let core := curry core in
  let core := eval simpl in core in

  (** Now we supply to [core] the indices and the proof on the right
      hand side of the equality (the one we want to apply [case] to). *)
  let rec apply_core f args :=
    match args with
      | tt => constr:(f)
      | (?x, ?xs) => apply_core (f x) xs
    end
  in
  let core := apply_core core inds in
  let core := constr:(core rhs) in

  (** In order to make [core] convertible with the goal, we need to
      introduce an equality for the predicate's indices and generalize
      over that equality. *)
  change lhs with (@eq_rect (tuple rind_types)
                            rinds
                            (fun rinds2 =>
                              apply_tuple (list_rev rind_types)
                                          sort
                                          pred
                                          (tuple_rev rind_types rinds2))
                            lhs
                            rinds
                            (refl_equal rinds));
  generalize (refl_equal rinds);

  (** We now have everything we need in order to use the [case] tactic. *)
  change core;
  case rhs;

  (** At this point, all that remains is to simplify everything.
      We begin by making sure all functions have reduced. *)
  unfold list_rev, tuple_rev in *;
  simpl tr_list_rev in *;
  simpl tr_tuple_rev in *;

  (** Next, we simplify the equality that we introduced earlier,
      checking for "obvious" contradictions in the process. *)
  repeat (match goal with
            | |- (_, _) = (_, _) -> _ =>
              let H := fresh in intros H; try discriminate; injection H
            | _ => progress intro
          end);
  subst;

  (** All that is left now is to use [eq_rect_eq_dec] to simplify
      occurrences of [eq_rect].  Since we have an equality between
      constructors, we can use [f_equal] to safely make progress from
      there.  We use [auto] and [auto with eq_dec] to clean up any
      subgoals. *)
  try (rewrite <- eq_rect_eq_dec; [ f_equal; auto | auto with eq_dec ]).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(* Test des definitions inductives imbriquees *)

Require Import List.

Inductive X : Set :=
    cons1 : list X -> X.

Inductive Y : Set :=
    cons2 : list (Y * Y) -> Y.

(* Test inductive types with local definitions *)

Inductive eq1 : forall A:Type, let B:=A in A -> Prop :=
  refl1 : eq1 True I.

Check
 fun (P : forall A : Type, let B := A in A -> Type) (f : P True I) (A : Type) =>
   let B := A in
     fun (a : A) (e : eq1 A a) =>
       match e in (eq1 A0 B0 a0) return (P A0 a0) with
       | refl1 => f
       end.

Inductive eq2 (A:Type) (a:A)
  : forall B C:Type, let D:=(A*B*C)%type in D -> Prop :=
  refl2 : eq2 A a unit bool (a,tt,true).

(* Check that induction variables are cleared even with in clause *)

Lemma foo : forall n m : nat, n + m = n + m.
Proof.
  intros; induction m as [|m] in n |- *.
  auto.
  auto.
Qed.


(* Author: Jasper Hugunin *)

(**
We use the -noinit option in _CoqProject to start from a blank slate.
*)

#[export] Set Universe Polymorphism.
(* #[export] Set Polymorphic Inductive Cumulativity. (* Probably not needed, but cool. *) *)
#[export] Set Primitive Projections. (* strict eta for pairs *)
#[export] Unset Elimination Schemes. (* we'll declare only the ones we need *)
#[export] Set Definitional UIP. (* Definitional UIP is essential to this development .*)

(*
We'll avoid conflicting with Coq's notation levels.
Consists of just Reserved Notations and Scopes.
*)
From Coq Require Export Init.Notations.

(** We use Unicode characters freely in our notations. *)

(** * Functions *)

Notation "'Π' x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[  ' '[  ' Π  x  ..  y ']' ,  '/' P ']'") : type_scope.
Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[  ' '[  ' ∀  x  ..  y ']' ,  '/' P ']'") : type_scope.

(** Can't go far without implication. *)
Notation "A -> B" := (forall (_ : A), B) : type_scope.
Notation "A → B" := (A -> B)
  (at level 99, right associativity, B at level 200) : type_scope.

Notation "'λ' x .. y ↦ z" := (fun x => .. (fun y => z) ..)
  (at level 8, x binder, y binder, z at level 200, right associativity)
  : core_scope.
Notation "'λ' x ↦ y" := (fun x => y)
  (* Hack to mostly hide types of function binders in printing. *)
  (at level 0, x name, y at level 200, right associativity, only printing)
  : core_scope.

(** composition of functions *)
Notation "f ∘ g" := (λ x ↦ f (g x))
  (at level 40, left associativity) : core_scope.

(** * Finite types *)
Inductive void : Set := .
(* Notation "⊥" := void : type_scope. *)
Notation "0" := void : type_scope.

Inductive unit : Set := tt.
(* Notation "⊤" := unit : type_scope. *)
Notation "1" := unit : type_scope.
Notation "★" := tt : core_scope.

Inductive bool : Set := true | false.
Notation "2" := bool : type_scope.

Notation "! x" := match x with end
  (at level 35, x constr, right associativity, only printing) : core_scope.
Notation "! x" := match x as x' return _ with end
  (at level 35, right associativity) : core_scope.

(** * Dependent pairs *)
Record prod@{i} (A : Type@{i}) (B : A → Type@{i}) : Type@{i} :=
  pair { fst : A ; snd : B fst }.
Arguments pair {A B} & fst snd.
Arguments fst {A B} _.
Arguments snd {A B} _.

Notation "x .1" := (x.(fst))
  (at level 1, left associativity, format "x .1") : core_scope.
Notation "x .2" := (x.(snd))
  (at level 1, left associativity, format "x .2") : core_scope.

(* Notation "∃ x .. y , P" := (prod _ (λ x ↦ .. (prod _ (λ y ↦ P)) ..))
  (at level 200, x binder, y binder, right associativity,
   format "'[  ' '[  ' ∃  x  ..  y ']' ,  '/' P ']'")
  : type_scope. *)
Notation "'Σ' x .. y , P" := (prod _ (λ x ↦ .. (prod _ (λ y ↦ P)) ..))
  (at level 200, x binder, y binder, right associativity,
   format "'[  ' '[  ' Σ  x  ..  y ']' ,  '/' P ']'")
  : type_scope.
Notation "( x , .. , y , z )" := (pair x .. (pair y z) ..) : core_scope.
Notation "( x ; .. ; y ; z )" := (pair x .. (pair y z) ..) : core_scope.

Notation "A * B" := (prod A (λ _ ↦ B))  : type_scope.
(* Notation "A ∧ B" := (prod A (λ _ ↦ B))
  (at level 80, right associativity) : type_scope. *)
Notation "A × B" := (prod A (λ _ ↦ B))
  (at level 80, right associativity) : type_scope.

(* tuple notation *)
Notation "[ x ; .. ; y ]" := (pair x .. (pair y ★) ..) : core_scope.
Notation "[ ]" := ★ : core_scope.

(** * W types *)
Inductive W@{i} (A : Type@{i}) (B : A → Type@{i}) : Type@{i} :=
  | sup (a : A) (f : B a → W A B) : W A B.
Arguments sup {A B} & a f.

Definition W_rect@{i j} (A : Type@{i}) (B : A → Type@{i}) (P : W A B → Type@{j})
  (IS : ∀ a f, (∀ b, P (f b)) → P (sup a f)) : ∀ w, P w :=
  fix rect w := match w with sup a f => IS a f (rect ∘ f) end.

(** * Sum types *)
(** We define sum types from bool and Σ *)

Notation sum A B :=
  (Σ (b : 2), match b with false => A | true => B end).
Definition sum'@{i} (A B : Type@{i}) : Type@{i} := sum A B.
Notation inl a := (false; a).
Notation inr b := (true; b).
Definition inl'@{i} {A B : Type@{i}} (a : A) : sum'@{i} A B := inl a.
Definition inr'@{i} {A B : Type@{i}} (b : B) : sum'@{i} A B := inr b.

Notation "A + B" := (sum A B) : type_scope.
(* Notation "A ∨ B" := (sum A B) (at level 85, right associativity) : type_scope. *)
Notation "A ⊎ B" := (sum A B) (at level 85, right associativity) : type_scope.
Notation "A ⊔ B" := (sum A B) (at level 85, right associativity) : type_scope.

Definition option@{i} (A : Type@{i}) : Type@{i} := sum 1 A.
Notation None := (inl ★).
Notation Some a := (inr a).
Definition Some'@{i} {A : Type@{i}} (a : A) : option@{i} A := Some a.

(** * Universe *)
Definition U@{i} := Type@{i}.

(** SProp *)

Inductive True : SProp := I.
Inductive False : SProp := .
Notation "⊤" := True : type_scope.
Notation "⊥" := False : type_scope.

Record dep_and (P : SProp) (Q : P → SProp) : SProp := conj { proj1 : P; proj2 : Q proj1 }.
Arguments conj {P Q} & _ _.
Arguments proj1 {P Q} _.
Arguments proj2 {P Q} _.
Notation "A ∧ B" := (dep_and A (λ _ ↦ B))
  (at level 80, right associativity) : type_scope.

Inductive Box (P : SProp) : Set := box (p : P).
Arguments box {P} p.
Definition unbox {P : SProp} (b : Box P) : P := match b with box p => p end.

(* different eta rule from (prod A (Box ∘ P)) *)
Record sub@{i} (A : Type@{i}) (P : A → SProp) : Type@{i} :=
  sub_in { wit : A; prf : P wit }.
Arguments sub_in {A P} & _ _.
Arguments wit {A P} _.
Arguments prf {A P} _.
Notation "{ x | P }" := (sub _ (fun x => P)) : type_scope.
Notation "{ x : A | P }" := (sub A (fun x => P)) : type_scope.
Notation "{ ' pat | P }" := (sub _ (fun pat => P)) : type_scope.
Notation "{ ' pat : A | P }" := (sub A (fun pat => P)) : type_scope.

(** * Identity types *)
Inductive Id@{i} (A : Type@{i}) (x : A) : A → SProp := refl : Id A x x.
Arguments Id {A} x y.
Arguments refl {A} x, {A x}.
Notation "x = y :> A" := (Id (A := A) x y) : type_scope.
Notation "x = y" := (Id x y) : type_scope.

(** A few lemmas about Id *)
Definition cong@{i j} {A : Type@{i}} {B : Type@{j}} (f : A → B) {x y : A}
  (e : Id x y) : Id (f x) (f y) :=
  match e with refl => refl end.
(* Transitivity from the middle. *)
Definition v_trans@{i} {A : Type@{i}} {x y z : A}
  (e1 : Id y x) (e2 : Id y z) : Id x z :=
  match e1 with refl => e2 end.

(** * Notation for tests *)
Notation convertible x y := (refl : x = y).


From stdpp Require Import countable fin_sets functions.
From iris Require Import proofmode.proofmode proofmode.tactics.
From cgraphs Require Import util bi.
From Coq.Logic Require Export FunctionalExtensionality Classical.

Lemma big_sepS_pure_impl {PROP : bi} `{Countable A} (s : gset A) (P : A -> PROP) (Q : A -> Prop) :
  (□ ∀ i, ⌜ i ∈ s ⌝ -∗ P i -∗ ⌜ Q i ⌝) -∗
  ([∗ set] i ∈ s, P i) -∗ ⌜ set_Forall Q s ⌝.
Proof.
  iIntros "#H G".
  iApply big_sepS_pure_1.
  iApply (big_sepS_impl with "G"). Unshelve.
  iModIntro. iIntros (x HH) "Q". Unshelve. iApply "H"; eauto.
Qed.

Lemma big_sepF_pure_impl {PROP : bi} n (P : fin n -> PROP) (Q : fin n -> Prop) :
  (□ ∀ i, P i -∗ ⌜ Q i ⌝) -∗
  ([∗ set] i ∈ all_fin n, P i) -∗ ⌜ ∀ i, Q i ⌝.
Proof.
  iIntros "#H G".
  iDestruct (big_sepS_pure_impl with "[] G") as %G.
  { iModIntro. iIntros (i Hi) "Q". iApply "H". done. }
  iPureIntro. intros.
  apply G. apply all_fin_all.
Qed.

Lemma big_sepS_impl1 {PROP : bi} `{Countable A} (s : gset A) (P P' : A -> PROP) (x0 : A) :
  x0 ∈ s ->
  □ (∀ x, ⌜⌜ x ≠ x0 ⌝⌝ -∗ P x -∗ P' x) -∗
    (P x0 -∗ P' x0) -∗
    ([∗ set] x ∈ s, P x) -∗ [∗ set] x ∈ s, P' x.
Proof.
  iIntros (Hx0) "#Hr H1 H".
  rewrite big_sepS_delete //.
  iApply big_sepS_delete; first done.
  iDestruct "H" as "[H0 H]".
  iSplitL "H1 H0".
  - iApply "H1". done.
  - iApply (big_sepS_impl with "H"). iModIntro.
    iIntros (x Hx) "H".
    iApply ("Hr" with "[%] H"). set_solver.
Qed.

Lemma subset_exists `{Countable A} (P : A -> Prop) (s : gset A) :
  (∀ x, P x -> x ∈ s) -> ∃ s' : gset A, ∀ x, x ∈ s' <-> P x.
Proof.
  revert P; induction s using set_ind_L; intros P Q.
  - exists ∅. set_solver.
  - destruct (IHs (λ y, P y ∧ y ≠ x)); first set_solver.
    destruct (classic (P x)); last set_solver.
    exists (x0 ∪ {[ x ]}). set_solver.
Qed.


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

(**********************************************************************)
(*                  SF-Calculus                                       *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                   Substituting.v                                   *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import ArithRing.
Require Import List.
Require Import Max.
Require Import Test.
Require Import General.
Require Import SF_Terms.
Require Import SF_Tactics.
Require Import Substitution_term.
Require Import SF_reduction.
Require Import SF_Normal.
Require Import SF_Closed.
Require Import SF_Eval.
Require Import Star.
Require Import Equal.
Require Import Extensions.
Require Import SF_arithmetic.
Require Import Lifting.

Lemma maxvar_lift: forall M k, maxvar M > 0 -> maxvar(lift k M) = maxvar M + k.
Proof.
induction M; split_all. relocate_lt. omega. noway.
unfold lift in *.
assert(maxvar M1 = 0 -> maxvar (lift_rec M1 0 k) = 0)
by (split_all;  rewrite lift_rec_closed; auto).
assert(maxvar M2 = 0 -> maxvar (lift_rec M2 0 k) = 0)
by (split_all;  rewrite lift_rec_closed; auto).
gen3_case IHM1 H H0 (maxvar M1); gen3_case IHM2 H H1 (maxvar M2); try noway.
rewrite H0; try omega;  rewrite IHM2; simpl; omega.
rewrite H1; try omega.   rewrite IHM1; simpl.  omega. omega.
rewrite IHM1; try omega; rewrite IHM2; try omega.
rewrite <- max_succ. rewrite <- max_plus. auto.
Qed.

Definition predecessor i := App (App (App f_op i) i) (App k_op i_op).

Definition insert_Ref_comb i N M :=
  (* from subst_rec (var i M) N *)
  App (App (App f_op i) (App (App fold_app N) M))
      (App k_op (App k_op (var (predecessor i) M)))
.

Lemma maxvar_insert_Ref_comb: forall i N M,
maxvar (insert_Ref_comb i N M) = maxvar (App i (App N M)).
Proof.
assert(maxvar fold_app = 0).
unfold fold_app; split_all.
intros; unfold insert_Ref_comb, predecessor.
rewrite maxvar_app. rewrite maxvar_app. rewrite maxvar_app. rewrite maxvar_app.
rewrite maxvar_app. rewrite H. rewrite maxvar_app. rewrite maxvar_app.
rewrite maxvar_var. unfold_op; split_all.
assert(max (max (maxvar i) (max (maxvar N) (maxvar M)))
     (max (max (max (maxvar i) (maxvar i)) 0) (maxvar M)) >=
   max (maxvar i) (max (maxvar N) (maxvar M)))
by max_l.
assert(max (maxvar i) (max (maxvar N) (maxvar M)) >=
       max (max (maxvar i) (max (maxvar N) (maxvar M)))
     (max (max (max (maxvar i) (maxvar i)) 0) (maxvar M))).
eapply2 max_max2. rewrite max_zero.
eapply2 max_max2. eapply2 max_max2; max_l. max_r. max_r.
omega.
Qed.

Lemma subst_rec_preserves_insert_Ref_comb:
forall i M N k1 N1,
subst_rec (insert_Ref_comb i N M) N1 k1 =
insert_Ref_comb (subst_rec i N1 k1) (subst_rec N N1 k1) (subst_rec M N1 k1).
Proof.
intros; unfold insert_Ref_comb. unfold_op; unfold subst_rec; fold subst_rec.
rewrite (subst_rec_closed fold_app).
2: unfold fold_app, fold_app_fn; rewrite maxvar_fix_comb; repeat rewrite maxvar_star; simpl; omega.
rewrite subst_rec_preserves_var.
unfold predecessor; split_all.
Qed.

Definition swap_vars s M := App (lambda_term s (App (App (App lift_rec_comb s) M)
                                                    (church 2)))
                                (var (church 1) s_op).

Definition subst_rec_comb_fn :=   (* abs = fix \s.\M.\N.... *)
  star(extension (var (Ref 1) (Ref 0))
                 (star (insert_Ref_comb (Ref 2) (Ref 0) (App (App (Ref 3) (Ref 1)) (Ref 0))))
      (extension (lambda_term (Ref 1) (Ref 0))
                 (star(App(App(App(App equal_comb (Ref 3)) (Ref 2))
                              (lambda_term (Ref 2)
                                           (App(lambda_term (Ref 2)
                                                            (swap_vars (Ref 3) (Ref 1)))
                                               (App (App(App lift_rec_comb (Ref 3))
                                                        (Ref 0)) s_op))))
                          (lambda_term (App(App(Ref 3)(Ref 2))(Ref 0))
                                       (App(App(Ref 3)(Ref 1))(Ref 0)))))
       (star(App(App (App f_op (Ref 0)) (App k_op (Ref 0)))
                (star(star(App(App s_op (App(Ref 3)(Ref 1)))
                              (App(Ref 3)(Ref 0)))))))))
.

Definition subst_rec_comb := fix_comb (subst_rec_comb_fn).
Definition abs M := app_comb subst_rec_comb M .

Lemma maxvar_subst_rec_comb: maxvar subst_rec_comb = 0.
Proof.
unfold subst_rec_comb. rewrite maxvar_fix_comb.
unfold subst_rec_comb_fn, lambda_term.
rewrite maxvar_star. rewrite maxvar_extension. rewrite maxvar_star at 1.
rewrite maxvar_insert_Ref_comb at 1.
rewrite maxvar_extension. rewrite maxvar_star at 1.
unfold maxvar at 1; fold maxvar.
rewrite maxvar_app at 1. rewrite maxvar_app at 1.
rewrite maxvar_app at 1. rewrite maxvar_app at 1.
rewrite maxvar_equal_comb at 1.
rewrite maxvar_app_comb at 1. rewrite maxvar_app at 1. rewrite maxvar_app at 1.
rewrite maxvar_app_comb at 1.
rewrite maxvar_app at 1. unfold swap_vars, lambda_term. rewrite maxvar_app at 1.
rewrite maxvar_app_comb at 1.
rewrite maxvar_app at 1. rewrite maxvar_app at 1.
rewrite maxvar_app at 1. rewrite maxvar_app at 1.
rewrite maxvar_lift_rec_comb.
rewrite maxvar_app at 1. rewrite maxvar_app at 1.
rewrite maxvar_app at 1.
rewrite maxvar_lift_rec_comb.
rewrite maxvar_star at 1.
split_all.
Qed.

Lemma normal_subst_rec_comb: normal subst_rec_comb.
Proof.
  unfold subst_rec_comb. eapply fix_comb_normal. unfold subst_rec_comb_fn. eapply2 star_normal.
Qed.

Hint Resolve maxvar_subst_rec_comb normal_subst_rec_comb.

Proposition subst_rec_comb_op :
  forall N o, sf_red (App (App subst_rec_comb (Op o)) N) (Op o).
Proof.
  intros. eapply transitive_red. eapply preserves_app_sf_red.
   unfold subst_rec_comb.
   eapply2 fix_comb_fix. auto.
   unfold subst_rec_comb_fn at 1.
   eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
   eapply2 star_beta. auto. auto.
   unfold subst. repeat rewrite fold_subst.
   eapply transitive_red. eapply preserves_app_sf_red.
   repeat eapply subst_preserves_sf_red.
   unfold lift, lift_rec.
   2: auto. 2: auto.
   (* 2 *)
   eapply2 extensions_by_matchfail.
   eapply2 matchfail_app_op.
   unfold_op; repeat eapply2 nf_compound.
   (* 1 *)
   eapply transitive_red.  eapply preserves_app_sf_red. repeat eapply subst_preserves_sf_red.
   (* 2 *)
   eapply2 extensions_by_matchfail.
   eapply2 matchfail_app_op. unfold_op; repeat eapply2 nf_compound. auto. auto.
   (* 1 *)
   eapply transitive_red. eapply preserves_app_sf_red. eapply subst_preserves_sf_red.
   eapply transitive_red.  eapply2 star_beta. unfold_op; unfold subst, subst_rec; fold subst_rec.
   insert_Ref_out. eval_SF0. auto. auto.  unfold subst, subst_rec; fold subst_rec.
   eval_SF0.
Qed.

Proposition subst_rec_comb_var :
  forall N i M, sf_red (App (App subst_rec_comb (var i M)) N)
                      (insert_Ref_comb i N (App (App subst_rec_comb M) N)).
Proof.
  intros. eapply transitive_red. eapply preserves_app_sf_red.
   unfold subst_rec_comb.
   eapply2 fix_comb_fix. auto.
   unfold subst_rec_comb_fn at 1.
   eapply transitive_red. eapply preserves_app_sf_red.
   eapply preserves_app_sf_red.   eapply2 star_beta. auto. auto.
   eapply transitive_red. repeat (unfold subst; rewrite fold_subst).
   repeat eapply subst_preserves_sf_red. eapply preserves_app_sf_red.
   2: auto. 2: auto.
   (* 2 *)
   unfold lift. repeat rewrite lift_rec_preserves_var.
   eapply2 extensions_by_matching.
   eapply2 var_matching.
   (* 1 *)
   unfold length; fold length.
   unfold map; fold map. unfold app; fold app. unfold fold_left; fold fold_left.
   unfold subst. repeat rewrite fold_subst.
  match goal with
    | |- _ _ (subst_rec ?M ?N 0) _ =>
      replace (subst_rec M N 0) with (subst M N) by auto
  end.
  eapply transitive_red. repeat (eapply subst_preserves_sf_red).
  eapply2 star_beta.   auto. auto. auto.
  (* 1 *)
  unfold subst. repeat (rewrite subst_rec_preserves_insert_Ref_comb).
  simpl. insert_Ref_out. repeat rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega). repeat rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega). repeat rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega). repeat rewrite lift_rec_null.
auto.
Qed.

Proposition subst_rec_comb_abs :
  forall N M, sf_red (App (App subst_rec_comb (abs M)) N)
                    (abs (App (abs (swap_vars subst_rec_comb M))
                              (App (App (App lift_rec_comb subst_rec_comb) N) s_op))).
Proof.
  intros. unfold abs, lambda_term.
  eapply transitive_red. eapply preserves_app_sf_red.
   unfold subst_rec_comb. eapply2 fix_comb_fix. auto.
unfold subst_rec_comb_fn at 1.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 star_beta. auto. auto.
unfold subst. repeat rewrite fold_subst. unfold subst. repeat rewrite fold_subst.
eapply transitive_red. repeat eapply subst_preserves_sf_red. eapply preserves_app_sf_red.
unfold lift. repeat (rewrite (lift_rec_preserves_app_comb)).
2: auto. 2: auto.
(* 2 *)
eapply2 extensions_by_matchfail.
unfold var. eapply2 app_comb_matchfail.
eapply2 matchfail_app_l.
 eapply2 matchfail_app_r.
repeat(rewrite lift_rec_closed; try (rewrite maxvar_subst_rec_comb; auto)).
eapply2 app_comb_matchfail. eapply2 matchfail_app_l.
eapply2 pattern_is_program3;  unfold program; split_all. discriminate.
assert(maxvar subst_rec_comb = 0) by eapply2 maxvar_subst_rec_comb.
unfold subst_rec_comb in H. auto.
(* 1 *)
eapply transitive_red. repeat eapply subst_preserves_sf_red. eapply preserves_app_sf_red.
2: auto. 2: auto.
eapply2 extensions_by_matching.
unfold lambda_term.
eapply2 app_comb_matching.
unfold length, map, app, fold_left.
unfold subst; repeat rewrite fold_subst.
  match goal with
    | |- _ _ (subst_rec ?M ?N 0) _ =>
      replace (subst_rec M N 0) with (subst M N) by auto
  end.
  eapply transitive_red. repeat (eapply subst_preserves_sf_red).
eapply2 star_beta. auto. auto. auto.
(* 1 *)
unfold subst, subst_rec; fold subst_rec.
repeat (rewrite (subst_rec_closed equal_comb)). 2: rewrite maxvar_equal_comb; auto.
repeat (rewrite insert_Ref_gt; [| omega]).
unfold subst, subst_rec; fold subst_rec.
repeat (rewrite insert_Ref_gt; [| omega]).
unfold subst, subst_rec; fold subst_rec.
repeat (rewrite insert_Ref_gt; [| omega]).
unfold subst, subst_rec; fold subst_rec.
repeat (rewrite insert_Ref_eq; [| omega]).
unfold lift; repeat rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
 rewrite lift_rec_null.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply equal_programs. replace (fix_comb subst_rec_comb_fn) with subst_rec_comb by auto.
 unfold program; split; auto. auto. auto.
unfold_op.  eapply succ_red. eapply2 f_op_red.
unfold lambda_term, swap.
repeat rewrite subst_rec_preserves_app_comb.
unfold subst_rec; fold subst_rec.
repeat rewrite subst_rec_preserves_app_comb.
unfold subst_rec; fold subst_rec.
eapply app_comb_preserves_sf_red.
(* 2 *)
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_eq; try omega.
unfold lift; rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega.  rewrite lift_rec_null.
auto.
(* 1 *)
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_eq; try omega.
unfold lift; rewrite lift_rec_null.
unfold_op; unfold subst_rec; fold subst_rec.
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_eq; try omega.
unfold lift; rewrite lift_rec_null.
rewrite insert_Ref_eq; try omega.
unfold lift; rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega). repeat rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega). repeat rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega). repeat rewrite lift_rec_null.
rewrite (subst_rec_closed lift_rec_comb) at 1; try (rewrite maxvar_lift_rec_comb; omega).
rewrite (subst_rec_closed lift_rec_comb) at 1; try (rewrite maxvar_lift_rec_comb; omega).
rewrite (subst_rec_closed lift_rec_comb) at 1; try (rewrite maxvar_lift_rec_comb; omega).
rewrite (subst_rec_closed lift_rec_comb) at 1; try (rewrite maxvar_lift_rec_comb; omega).
eapply2 preserves_app_sf_red.
eapply2 app_comb_preserves_sf_red.

Lemma subst_rec_preserves_lambda_term :
forall M1 M2 N k, subst_rec (lambda_term M1 M2) N k =
                  lambda_term (subst_rec M1 N k) (subst_rec M2 N k).
Proof. unfold lambda_term, app_comb; split_all. Qed.

Lemma subst_rec_preserves_swap_vars:
forall M1 M2 N k, subst_rec (swap_vars M1 M2) N k =
                  swap_vars (subst_rec M1 N k) (subst_rec M2 N k).
Proof.
unfold swap_vars.  intros. unfold subst_rec; fold subst_rec.
rewrite subst_rec_preserves_lambda_term. unfold subst_rec; fold subst_rec.
rewrite (subst_rec_closed lift_rec_comb).
repeat rewrite subst_rec_preserves_var.
unfold church; unfold_op; unfold subst_rec; fold subst_rec. split_all.
rewrite maxvar_lift_rec_comb; omega.
Qed.

  repeat (rewrite subst_rec_preserves_swap_vars). unfold subst_rec; fold subst_rec.
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_eq; try omega.
unfold lift; rewrite lift_rec_null.
rewrite insert_Ref_gt; try omega.
unfold subst_rec; fold subst_rec.
rewrite insert_Ref_eq; try omega.
unfold lift; rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega). repeat rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega). repeat rewrite lift_rec_null.
auto.
Qed.

Proposition subst_rec_comb_app :
  forall N M1 M2, compound (App M1 M2) ->
                      matchfail (var (Ref 1) (Ref 0))  (App M1 M2) ->
                      matchfail (lambda_term  (Ref 1) (Ref 0)) (App M1 M2) ->
      sf_red (App (App subst_rec_comb (App M1 M2)) N)
            (App (App (App subst_rec_comb M1) N)
                 (App (App subst_rec_comb M2) N))
.
Proof.
  intros.
  eapply transitive_red. eapply preserves_app_sf_red.
  unfold subst_rec_comb.
  eapply2 fix_comb_fix. auto.
  unfold subst_rec_comb_fn at 1.
  eapply transitive_red. eapply preserves_app_sf_red.
  eapply preserves_app_sf_red.
  eapply2 star_beta. auto. auto.
  unfold subst. repeat rewrite fold_subst. unfold subst. repeat rewrite fold_subst.
  eapply transitive_red.   repeat eapply subst_preserves_sf_red. eapply preserves_app_sf_red.
  2: auto. 2: auto.
  (* 2 *)
  eapply2 extensions_by_matchfail.
  repeat eapply2 matchfail_lift.
  (* 1 *)
  eapply transitive_red. repeat eapply subst_preserves_sf_red. eapply preserves_app_sf_red.
  2: auto. 2: auto.
  (* 2 *)
  apply extensions_by_matchfail.
  repeat eapply2 matchfail_lift.
  (* 1 *)
  eapply transitive_red. repeat eapply subst_preserves_sf_red. eapply preserves_app_sf_red.
  eapply2 star_beta.  auto. auto.
  eapply transitive_red. repeat eapply subst_preserves_sf_red. eapply preserves_app_sf_red.
  unfold_op; unfold subst, subst_rec; fold subst_rec. insert_Ref_out.
  repeat rewrite lift_rec_null.
  eapply succ_red. eapply2 f_compound_red.
  replace (App (lift_rec M1 0 1) (lift_rec M2 0 1))
  with (lift_rec (App M1 M2) 0 1) by auto.
eapply2 lift_rec_preserves_compound.
unfold left_component, right_component.
  rewrite fold_subst. unfold subst;  rewrite fold_subst.
  eapply subst_preserves_sf_red. eapply2 star_beta2. split_all. auto. auto.
  (* 1 *)
  unfold subst, subst_rec; fold subst_rec.
  rewrite insert_Ref_gt; try omega.
  rewrite insert_Ref_gt; try omega.
  rewrite insert_Ref_eq; try omega.
  unfold subst, subst_rec; fold subst_rec.
  rewrite insert_Ref_gt; try omega.
  rewrite insert_Ref_eq; try omega.
  unfold subst, subst_rec; fold subst_rec.
  rewrite insert_Ref_gt; try omega.
  unfold lift; repeat rewrite lift_rec_null.
  unfold subst, subst_rec; fold subst_rec.
  rewrite insert_Ref_eq; try omega.
  unfold lift; repeat rewrite lift_rec_null.
  repeat (rewrite subst_rec_lift_rec; try omega; repeat rewrite lift_rec_null).
  eval_SF0.
Qed.

(* abstraction *)

Theorem beta: forall M N, sf_red (App (abs M) N) (App (App subst_rec_comb M) N).
Proof.
intros; unfold abs. eapply transitive_red. eapply2 app_comb_red. eapply2 preserves_app_sf_red.
Qed.

Theorem xi: forall M N, sf_red M N -> sf_red (abs M) (abs N).
Proof. intros; repeat eapply2 preserves_app_sf_red. Qed.

Lemma insert_Ref_comb_zero:
 forall N M, sf_red (insert_Ref_comb s_op N M) (App (App fold_app N) M).
Proof.  intros. unfold insert_Ref_comb. unfold_op; eval_SF0. Qed.

Lemma insert_Ref_comb_succ :
  forall i M N, sf_red (insert_Ref_comb (church (S i)) N M) (var (church i) M).
Proof.
  intros.  eapply transitive_red. unfold insert_Ref_comb, church; fold church; unfold_op.
eapply succ_red. eapply2 f_compound_red. eval_SF0.
unfold predecessor. eapply var_preserves_sf_red. eval_SF0. eval_SF0. eval_SF0. auto.
Qed.