(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2013: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * paterson: Equivalence of two flowchart schemes, due to Paterson
   cf. "Mathematical theory of computation", Manna, 1974
   cf. "Kleene algebra with tests and program schematology", A. Angus and D. Kozen, 2001
*)

Require Import kat normalisation rewriting move kat_tac comparisons rel.
Set Implicit Arguments.

Unset Injection On Proofs.

(** * Memory model  *)

(** we need only five memory locations: the [y_i] are temporary
   variables and [io] is used for input and output *)
Inductive loc := y1 | y2 | y3 | y4 | io.
Record state := { v1: nat; v2: nat; v3: nat; v4: nat; vio: nat }.

(** getting the content of a memory cell *)
Definition get x := match x with y1 => v1 | y2 => v2 | y3 => v3 | y4 => v4 | io => vio end.

(** setting the content of a memory cell *)
Definition set x n m :=
  match x with
    | y1 => {| v1:=n; v2:=v2 m; v3:=v3 m; v4:=v4 m; vio:=vio m |}
    | y2 => {| v1:=v1 m; v2:=n; v3:=v3 m; v4:=v4 m; vio:=vio m |}
    | y3 => {| v1:=v1 m; v2:=v2 m; v3:=n; v4:=v4 m; vio:=vio m |}
    | y4 => {| v1:=v1 m; v2:=v2 m; v3:=v3 m; v4:=n; vio:=vio m |}
    | io => {| v1:=v1 m; v2:=v2 m; v3:=v3 m; v4:=v4 m; vio:=n |}
  end.

(** basic properties of [get] and [set] *)
Lemma get_set x v m: get x (set x v m) = v.
Proof. now destruct x. Qed.

Lemma get_set' x y v m: x<>y -> get x (set y v m) = get x m.
Proof. destruct y; destruct x; simpl; trivial; congruence. Qed.

Lemma set_set x v v' m: set x v (set x v' m) = set x v m.
Proof. now destruct x. Qed.

Lemma set_set' x y v v' m: x<>y -> set x v (set y v' m) = set y v' (set x v m).
Proof. destruct y; destruct x; simpl; trivial; congruence. Qed.

(** comparing locations *)
Definition eqb x y :=
  match x,y with
    | y1,y1 | y2,y2 | y3,y3 | y4,y4 | io,io => true
    | _,_ => false
  end.
Lemma eqb_spec: forall x y, reflect (x=y) (eqb x y).
Proof. destruct x; destruct y; simpl; try constructor; congruence. Qed.
Lemma eqb_false x y: x<>y -> eqb x y = false.
Proof. case eqb_spec; congruence. Qed.
Lemma neqb_spec x y: negb (eqb x y) <-> x<>y.
Proof. case eqb_spec; intuition; congruence. Qed.

(** * Arithmetic and Boolean expressions *)

Section s.

(** we assume arbitrary functions to interpret symbols [f], [g], and [p]  *)
Variable ff: nat -> nat.
Variable gg: nat -> nat -> nat.
Variable pp: nat -> bool.

(** we use a single inductive to represent Arithmetic and Boolean
   expressions: this allows us to share code about evaluation, free
   variables and so on, through polymorphism *)
Inductive expr: Set -> Set :=
  | e_var: loc -> expr nat
  | O: expr nat
  | f': expr nat -> expr nat
  | g': expr nat -> expr nat -> expr nat
  | p': expr nat -> expr bool
  | e_cap: expr bool -> expr bool -> expr bool
  | e_cup: expr bool -> expr bool -> expr bool
  | e_neg: expr bool -> expr bool
  | e_bot: expr bool
  | e_top: expr bool.

Coercion e_var: loc >-> expr.

(** ** evaluation of expressions  *)
Fixpoint eval A (e: expr A) (m: state): A :=
  match e with
    | e_var x => get x m
    | O => 0%nat
    | f' e => ff (eval e m)
    | g' e f => gg (eval e m) (eval f m)
    | p' e => pp (eval e m)
    | e_cap e f => eval e m &&& eval f m
    | e_cup e f => eval e m ||| eval f m
    | e_neg e => negb (eval e m)
    | e_bot => false
    | e_top => true
  end.

(** ** Free variables *)

Fixpoint free y A (e: expr A): bool :=
  match e with
    | e_var x => negb (eqb x y)
    | f' e | p' e | e_neg e => free y e
    | g' e f | e_cap e f | e_cup e f => free y e &&& free y f
    | _ => true
  end.

(** ** Substitution *)

Fixpoint subst x v A (f: expr A): expr A :=
  match f with
    | e_var y => if eqb x y then v else e_var y
    | O => O
    | f' e => f' (subst x v e)
    | p' e => p' (subst x v e)
    | g' e f => g' (subst x v e) (subst x v f)
    | e_cup e f => e_cup (subst x v e) (subst x v f)
    | e_cap e f => e_cap (subst x v e) (subst x v f)
    | e_neg e => e_neg (subst x v e)
    | e_bot => e_bot
    | e_top => e_top
  end.

Lemma subst_free x v A (e: expr A): free x e -> subst x v e = e.
Proof.
  induction e; simpl; trivial.
   rewrite neqb_spec. case eqb_spec; congruence.
   intro. now rewrite IHe.
   rewrite landb_spec. intros [? ?]. now rewrite IHe1, IHe2.
   intro. now rewrite IHe.
   rewrite landb_spec. intros [? ?]. now rewrite IHe1, IHe2.
   rewrite landb_spec. intros [? ?]. now rewrite IHe1, IHe2.
   intro. now rewrite IHe.
Qed.

Lemma free_subst x e A (f: expr A): free x e -> free x (subst x e f).
Proof.
  intro. induction f; simpl; rewrite ?IHf1; auto.
  case eqb_spec; trivial. simpl. rewrite neqb_spec. congruence.
Qed.

(** * Programs *)
(** We just use KAT expressions, since any gflowchat scheme can be encoded as such an expression *)
Inductive prog :=
| p_tst(t: expr bool)
| p_aff(x: loc)(e: expr nat)
| p_str(p: prog)
| p_dot(p q: prog)
| p_pls(p q: prog).

(** * Bigstep semantics *)

(** updating the memory, according to the assignment [x<-e] *)
Definition update x e m := set x (eval e m) m.
(** relational counterpart of this function *)
Notation upd x e := (frel (update x e)).

(** Bigstep semantics, as a fixpoint *)
Fixpoint bstep (p: prog): rel state state :=
  match p with
    | p_tst p => [eval p: dset state]
    | p_aff x e => upd x e
    | p_str p => bstep p ^*
    | p_dot p q => bstep p * bstep q
    | p_pls p q => bstep p + bstep q
  end.

(** auxiliary lemma relating the evaluation of expressions, the
   assignments to the memory, and subsitution of expressions *)
Lemma eval_update x v A (e: expr A) m: eval e (update x v m) = eval (subst x v e) m.
Proof.
  induction e; simpl; try congruence.
   unfold update. case eqb_spec. intros <-. apply get_set.
   intro. apply get_set'. congruence.
  now rewrite IHe1, IHe2.
  now rewrite IHe1, IHe2.
Qed.

(** Now we make the set of programs a Kleene algebra with tests: we
   declare canonical structures for Boolean expressions (tests),
   programs (Kleene elements), and the natural injection of the former
   into the latter *)

Canonical Structure expr_lattice_ops: lattice.ops := {|
  car := expr bool;
  leq := fun x y => eval x <== eval y;
  weq := fun x y => eval x == eval y;
  cup := e_cup;
  cap := e_cap;
  bot := e_bot;
  top := e_top;
  neg := e_neg
|}.

Canonical Structure prog_lattice_ops: lattice.ops := {|
  car := prog;
  leq := fun x y => bstep x <== bstep y;
  weq := fun x y => bstep x == bstep y;
  cup := p_pls;
  cap := assert_false p_pls;
  bot := p_tst e_bot;
  top := assert_false (p_tst e_bot);
  neg := assert_false id
|}.

Canonical Structure prog_monoid_ops: monoid.ops := {|
  ob  := unit;
  mor n m := prog_lattice_ops;
  dot n m p := p_dot;
  one n := p_tst e_top;
  itr n := (fun x => p_dot x (p_str x));
  str n := p_str;
  cnv n m := assert_false id;
  ldv n m p := assert_false (fun _ => id);
  rdv n m p := assert_false (fun _ => id)
|}.

Canonical Structure prog_kat_ops: kat.ops := {|
  kar := prog_monoid_ops;
  tst n := expr_lattice_ops;
  inj n := p_tst
|}.

Notation prog' := (prog_kat_ops tt tt).
Notation test := (@tst prog_kat_ops tt).

(** proving that the laws of KAT are satisfied is almost trivial,
   since the model faithfully embeds in the relational model *)

Instance expr_lattice_laws: lattice.laws BL expr_lattice_ops.
Proof.
  apply laws_of_injective_morphism with (@eval bool: expr bool -> dset state); trivial.
  split; simpl; tauto.
Qed.

Instance prog_monoid_laws: monoid.laws BKA prog_monoid_ops.
Proof.
  apply laws_of_faithful_functor with (fun _ => state) (fun _ _: unit => bstep); trivial.
  split; simpl; try discriminate; try tauto. 2: firstorder.
  split; simpl; try discriminate; try tauto. firstorder.
Qed.
Instance prog_lattice_laws: lattice.laws BKA prog_lattice_ops := lattice_laws tt tt.

Instance prog_kat_laws: kat.laws prog_kat_ops.
Proof.
  constructor; simpl; eauto with typeclass_instances. 2: tauto.
  split; try discriminate; try (simpl; tauto).
  intros x y H. apply inj_leq. intro m. apply H.
  intros x y H. apply inj_weq. intro m. apply H.
  intros _ x y. apply (inj_cup (X:=rel_kat_ops)).
  intros _ x y. apply (inj_cap (X:=rel_kat_ops)).
Qed.

(** ** variables read by a program *)

(** [dont_read y p] holds if [p] never reads [y] *)
Fixpoint dont_read y (p: prog'): bool :=
  match p with
    | p_str p => dont_read y p
    | p_dot p q | p_pls p q => dont_read y p &&& dont_read y q
    | p_aff x e => free y e
    | p_tst t => free y t
  end.

(** ** Additional notation  *)

Infix " ;" := (dot _ _ _) (left associativity, at level 40): ra_terms.
Definition aff x e: prog' := p_aff x e.
Notation "x <- e" := (aff x e) (at level 30).
Notation del y := (y<-O).

(** * Laws of schematic KAT *)

Arguments rel_monoid_ops : simpl never.
Arguments rel_lattice_ops : simpl never.

(** (the numbering corresponds to Angus and Kozen's paper)  *)
Lemma eq_6 (x y: loc) (s t: expr nat):
  negb (eqb x y) &&& free y s -> x<-s;y<-t == y<-subst x s t; x<-s.
Proof.
  rewrite landb_spec, neqb_spec. intros [D H]. cbn.
  rewrite 2frel_comp. apply frel_weq. intro m.
  unfold update at 1 2 3. rewrite set_set' by congruence. f_equal.
  now rewrite eval_update, subst_free.
  unfold update. now rewrite <-eval_update.
Qed.

Lemma eq_7 (x y: loc) (s t: expr nat):
  negb (eqb x y) &&& free x s -> x<-s;y<-t == x<-s;y<-subst x s t.
Proof.
  rewrite landb_spec, neqb_spec. intros [D H]. cbn.
  rewrite 2frel_comp. apply frel_weq. intro m.
  unfold update at 1 3. f_equal.
  rewrite 2eval_update. symmetry. rewrite subst_free. reflexivity.
  now apply free_subst.
Qed.

Lemma eq_8 (x: loc) (s t: expr nat): x<-s;x<-t == x<-subst x s t.
Proof.
  cbn. rewrite frel_comp. apply frel_weq. intro m.
  unfold update. rewrite set_set. f_equal. apply eval_update.
Qed.

Lemma eq_9 (x: loc) (t: expr nat) (phi: test): [subst x t phi: test];x<-t == x<-t;[phi].
Proof.
  Transparent rel_lattice_ops. intros m m'. split. Opaque rel_lattice_ops.
   intros [m0 [<- H] ->]. eexists. reflexivity. split; trivial. now rewrite eval_update.
   intros [m0 -> [<- H]]. eexists. 2: reflexivity. split; trivial. now rewrite <-eval_update.
Qed.

Lemma eq_6' (x y: loc) (s t: expr nat): free x t &&& negb (eqb x y) &&& free y s ->
  x<-s;y<-t == y<-t; x<-s.
Proof. rewrite landb_spec. intros [? ?]. now rewrite eq_6, subst_free. Qed.

Lemma eq_9' (x: loc) (t: expr nat) (phi: test): free x phi -> [phi];x<-t == x<-t;[phi].
Proof. intro. now rewrite <-eq_9, subst_free. Qed.

Transparent rel_lattice_ops.
Arguments rel_lattice_ops : simpl never.

Lemma same_value (f: state -> state) (p: prog') (a b: test):
  bstep p == frel f -> (forall m, eval a (f m) = eval b (f m)) ->
  p;[a\cap !b \cup !a\cap b] <== 0.
Proof.
  intros Hp H. cbn. rewrite Hp.
   intros m m' [? -> [<- E]].
  exfalso. rewrite lorb_spec, 2landb_spec, 2negb_spec, H in E. intuition congruence.
Qed.

(** * Garbage-collecting assignments to unread variables *)

(** (i.e., Lemma 4.5 in Angus and Kozen's paper)  *)
Fixpoint gc y (p: prog'): prog' :=
  match p with
    | p_str p => gc y p^*
    | p_tst _ => p
    | p_aff x e => if eqb x y then 1 else x<-e
    | p_dot p q => gc y p ; gc y q
    | p_pls p q => gc y p + gc y q
  end.

Arguments prog_monoid_ops : simpl never.
Arguments prog_lattice_ops : simpl never.
Arguments prog_kat_ops : simpl never.

Lemma gc_correct y p: dont_read y p -> gc y p; del y == p; del y.
Proof.
  intro H. transitivity (del y; gc y p).
  induction p; cbn.
   now apply eq_9'.
   case eqb_spec. ra. intro. apply eq_6'. now rewrite eqb_false.
   symmetry. apply str_move. symmetry. now auto.
   apply landb_spec in H as [? ?]. mrewrite IHp2. 2: assumption. now mrewrite IHp1.
   apply landb_spec in H as [? ?]. ra_normalise. now apply cup_weq; auto.
  symmetry. induction p; cbn.
   now apply eq_9'.
   case eqb_spec. intros <-. rewrite eq_8. ra. intro D. apply eq_6'. now rewrite eqb_false.
   symmetry. apply str_move. symmetry. now auto.
   apply landb_spec in H as [? ?]. mrewrite IHp2. 2: assumption. now mrewrite IHp1.
   apply landb_spec in H as [? ?]. ra_normalise. now apply cup_weq; auto.
Qed.

Ltac solve_rmov ::=
  first
    [ eassumption
    | symmetry; eassumption
    | eapply rmov_x_dot
    | apply rmov_x_pls
    | apply rmov_x_str
    | apply rmov_x_itr
    | apply rmov_x_cap
    | apply rmov_x_cup
    | apply rmov_x_neg
    | apply rmov_inj
    | apply rmov_x_1
    | apply rmov_x_0 ];
    match goal with |- ?x == ?y => solve_rmov end.

(** * Paterson's equivalence *)
Theorem Paterson:
  let a1 := p' y1: test in
  let a2 := p' y2: test in
  let a3 := p' y3: test in
  let a4 := p' y4: test in
  let clr := del y1; del y2; del y3; del y4 in
  let x1 := y1<-io in
  let s1 := y1<-f' io in
  let s2 := y2<-f' io in
  let z1 := io<-y1; clr in
  let z2 := io<-y2; clr in
  let p11 := y1<-f' y1 in
  let p13 := y1<-f' y3 in
  let p22 := y2<-f' y2 in
  let p41 := y4<-f' y1 in
  let q222 := y2<-g' y2 y2 in
  let q214 := y2<-g' y1 y4 in
  let q211 := y2<-g' y1 y1 in
  let q311 := y3<-g' y1 y1 in
  let r11 := y1<-f' (f' y1) in
  let r12 := y1<-f' (f' y2) in
  let r13 := y1<-f' (f' y3) in
  let r22 := y2<-f' (f' y2) in
  let rhs := s2;[a2];q222;([!a2];r22;[a2];q222)^*;[a2];z2 in
  x1;p41;p11;q214;q311;([!a1];p11;q214;q311)^*;[a1];p13;
  (([!a4]+[a4];([!a2];p22)^*;[a2\cap !a3];p41;p11);q214;q311;([!a1];p11;q214;q311)^*;[a1];p13)^*;
  [a4];([!a2];p22)^*;[a2\cap a3];z2  ==  rhs.
Proof.
  intros.
  (** simple commutation hypotheses, to be exploited by [hkat] *)
  assert (a1p22:  [a1];p22  == p22;[a1])  by now apply eq_9'.
  assert (a1q214: [a1];q214 == q214;[a1]) by now apply eq_9'.
  assert (a1q211: [a1];q211 == q211;[a1]) by now apply eq_9'.
  assert (a1q311: [a1];q311 == q311;[a1]) by now apply eq_9'.
  assert (a2p13:  [a2];p13  == p13;[a2])  by now apply eq_9'.
  assert (a2r12:  [a2];r12  == r12;[a2])  by now apply eq_9'.
  assert (a2r13:  [a2];r13  == r13;[a2])  by now apply eq_9'.
  assert (a3p13:  [a3];p13  == p13;[a3])  by now apply eq_9'.
  assert (a3p22:  [a3];p22  == p22;[a3])  by now apply eq_9'.
  assert (a3r12:  [a3];r12  == r12;[a3])  by now apply eq_9'.
  assert (a3r13:  [a3];r13  == r13;[a3])  by now apply eq_9'.
  assert (a4p13:  [a4];p13  == p13;[a4])  by now apply eq_9'.
  assert (a4p11:  [a4];p11  == p11;[a4])  by now apply eq_9'.
  assert (a4p22:  [a4];p22  == p22;[a4])  by now apply eq_9'.
  assert (a4q214: [a4];q214 == q214;[a4]) by now apply eq_9'.
  assert (a4q211: [a4];q211 == q211;[a4]) by now apply eq_9'.
  assert (a4q311: [a4];q311 == q311;[a4]) by now apply eq_9'.
  assert (p41p11: p41;p11;[a1\cap !a4 \cup !a1\cap a4] <== 0).
   eapply same_value. apply frel_comp. reflexivity.
  assert (q211q311: q211;q311;[a2\cap !a3 \cup !a2\cap a3] <== 0).
   eapply same_value. apply frel_comp. reflexivity.
  assert (r12p22: r12;p22;p22;[a1\cap !a2 \cup !a1\cap a2] <== 0).
   eapply same_value. simpl bstep. rewrite 2frel_comp. reflexivity. reflexivity.
  (** this one cannot be used by [hkat], it's used by [rmov1]  *)
  assert (p13p22: p13;p22 == p22;p13) by now apply eq_6'.

  (** here starts the proof; the numbers in the comments refer to the
     equation numbers in Angus and Kozen's paper proof *)

  (** (19) *)
  transitivity (
    x1;p41;p11;q214;q311;
    ([!a1\cap !a4];p11;q214;q311 +
     [!a1\cap  a4];p11;q214;q311 +
     [ a1\cap !a4];p13;[!a4];q214;q311 +
     [a1\cap a4];p13;([!a2];p22)^*;[a2 \cap !a3];p41;p11;q214;q311)^*;
    [a1];p13;([!a2];p22)^*;[a2 \cap a3 \cap a4];z2).
  clear -a4p13 a4p22. hkat.
  do 2 rmov1 p13.
  (** (23+) *)
  transitivity (
    x1;p41;p11;q214;q311;
    ([!a1\cap !a4];p11;q214;q311 +
     [!a1\cap  a4];p11;q214;q311 +
     [ a1\cap !a4];p13;[!a4];q214;q311 +
     [a1\cap a4];p13;([!a2];p22)^*;[a2 \cap !a3];p41;p11;q214;q311)^*;
    ([!a2];p22)^*;[a1 \cap a2 \cap a3 \cap a4];(p13;z2)).
  clear -a1p22; hkat.
  setoid_replace (p13;z2) with z2
     by (unfold z2, clr; mrewrite <-(gc_correct y1); [ simpl gc; kat | reflexivity ]).
  (** (24) *)
  transitivity (x1;p41;p11;q214;q311;
    ([a1 \cap a4];p13;([!a2];p22)^*;[a2 \cap !a3];p41;p11;q214;q311)^*;
    ([!a2];p22)^*;[a1 \cap a2 \cap a3 \cap a4];z2).
  clear -p41p11 a1p22 a1q214 a1q311 a4p11 a4p13 a4p22 a4q214 a4q311; hkat.
  (** big simplification w.r.t the paper proof here... *)

  (** (27) *)
  assert (p41p11q214: p41;p11;q214 == p41;p11;q211).
  change (upd y4 (f' y1) ; upd y1 (f' y1) ; upd y2 (g' y1 y4) == upd y4 (f' y1) ; upd y1 (f' y1) ; upd y2 (g' y1 y1)).
  now rewrite 3frel_comp.
  do 2 mrewrite p41p11q214. clear p41p11q214.
  (** (29) *)
  transitivity (x1;(p41;(p11;q211;q311;[a1];p13;([!a2];p22)^*;[a2\cap!a3]))^*;
                p41;p11;q211;q311;([!a2];p22)^*;[a1\cap a2\cap a3];z2).
  clear -p41p11 a1p22 a1q211 a1q311 a4p22 a4q211 a4q311; hkat.
  (** (31) *)
  transitivity (x1;(p11;q211;q311;[a1];p13;([!a2];p22)^*;[a2\cap!a3])^*;
                p11;q211;q311;([!a2];p22)^*;[a1\cap a2\cap a3];z2).
  unfold z2, clr. mrewrite <-(gc_correct y4). 2: reflexivity. simpl gc. kat.
  (** (32) *)
  rmov1 p13.
  transitivity ((x1;p11);(q211;q311;([!a2];p22)^*;[a1\cap a2\cap!a3];(p13;p11))^*;
                q211;q311;([!a2];p22)^*;[a1\cap a2\cap a3];z2).
  clear -a1p22 a2p13 a3p13; hkat.
  (** big simplification w.r.t the paper proof here... *)

  (** (33) *)
  setoid_replace (x1;p11) with s1 by apply eq_8.
  setoid_replace (p13;p11) with r13 by apply eq_8.
  (** (34) *)
  transitivity (s1;(q211;q311;(([!a2];p22)^*;([a1];r13));[a2\cap!a3])^*;
                q211;q311;([!a2];p22)^*;[a1\cap a2\cap a3];z2).
  clear -a2r13 a3r13; hkat.
  setoid_replace (([!a2];p22)^*;([a1];r13)) with ([a1];r13;([!a2];p22)^*)
   by (assert (r13;p22 == p22;r13) by (now apply eq_6'); rmov1 r13; clear -a1p22; hkat).
  transitivity (s1;([a1];(q211;q311;r13);([!a2];p22)^*;[a2\cap!a3])^*;
                q211;q311;([!a2];p22)^*;[a1\cap a2\cap a3];z2).
  clear -a1q311 a1q211; hkat.
  (** (35) *)
  setoid_replace (q211;q311;r13) with (q211;q311;r12).
  2: change (upd y2 (g' y1 y1) ; upd y3 (g' y1 y1) ; upd y1 (f' (f' y3)) == upd y2 (g' y1 y1) ; upd y3 (g' y1 y1) ; upd y1 (f' (f' y2))); now rewrite 3frel_comp.
  (** (36) *)
  transitivity (s1;([a1];(q211;q311);[!a2];r12;([!a2];p22)^*;[a2])^*;
                (q211;q311);[a2];([!a2];p22)^*;[a1\cap a2];z2).
  clear -a3p22 a3r12 q211q311. hkat.
  (** (37) *)
  transitivity (s1;([a1];q211;[!a2];r12;([!a2];p22)^*;[a2])^*;
                q211;[a2];([!a2];p22)^*;[a1\cap a2];z2).
  unfold z2, clr. mrewrite <-(gc_correct y3). 2: reflexivity. simpl gc. kat.
  (** (38) *)
  transitivity (s1;[a1];q211;([!a2];r12;[a1];p22;[a2];q211 +
                              [!a2];r12;[a1];p22;[!a2];(p22;q211))^*;[a2];z2).
  clear -a1p22 a1q211 a2r12 r12p22 a1p22. hkat.
  (** big simplification w.r.t the paper proof here... *)

  (** (43) *)
  assert (p22q211: p22;q211 == q211) by apply eq_8. rewrite p22q211.
  transitivity (s1;[a1];q211;([!a2];r12;[a1];(p22;q211))^*;[a2];z2). kat.
  rewrite p22q211. clear p22q211.
  (** (44) *)
  unfold s1, a1, q211, r12, a2. rewrite <-eq_9. mrewrite eq_7. 2: reflexivity.
  mrewrite <-eq_9. mrewrite (eq_7 y1 y2 (f' (f' y2))). 2: reflexivity.
  unfold z2, clr. mrewrite <-(gc_correct y1). 2: reflexivity.
  unfold rhs, z2, clr, s2, a2. rewrite <-eq_9.
  unfold q222. mrewrite eq_7. 2: reflexivity.
  unfold r22. mrewrite <-eq_9. do 2 mrewrite eq_8.
  simpl gc. kat.
  (** (47) *)
Qed.

End s.


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

Require Import BinInt Znat.
Local Open Scope Z_scope.

(** Factorization lemmas *)

Theorem Zred_factor0 n : n = n * 1.
Proof.
  now Z.nzsimpl.
Qed.

Theorem Zred_factor1 n : n + n = n * 2.
Proof.
  rewrite Z.mul_comm. apply Z.add_diag.
Qed.

Theorem Zred_factor2 n m : n + n * m = n * (1 + m).
Proof.
  rewrite Z.mul_add_distr_l; now Z.nzsimpl.
Qed.

Theorem Zred_factor3 n m : n * m + n = n * (1 + m).
Proof.
  now Z.nzsimpl.
Qed.

Theorem Zred_factor4 n m p : n * m + n * p = n * (m + p).
Proof.
  symmetry; apply Z.mul_add_distr_l.
Qed.

Theorem Zred_factor5 n m : n * 0 + m = m.
Proof.
  now Z.nzsimpl.
Qed.

Theorem Zred_factor6 n : n = n + 0.
Proof.
  now Z.nzsimpl.
Qed.

(** Other specific variants of theorems dedicated for the Omega tactic *)

Lemma new_var : forall x : Z, exists y : Z, x = y.
Proof.
intros x; now exists x.
Qed.

Lemma OMEGA1 x y : x = y -> 0 <= x -> 0 <= y.
Proof.
now intros ->.
Qed.

Lemma OMEGA2 x y : 0 <= x -> 0 <= y -> 0 <= x + y.
Proof.
Z.order_pos.
Qed.

Lemma OMEGA3 x y k : k > 0 -> x = y * k -> x = 0 -> y = 0.
Proof.
intros LT -> EQ. apply Z.mul_eq_0 in EQ. destruct EQ; now subst.
Qed.

Lemma OMEGA4 x y z : x > 0 -> y > x -> z * y + x <> 0.
Proof.
Z.swap_greater. intros Hx Hxy.
rewrite Z.add_move_0_l, <- Z.mul_opp_l.
destruct (Z.lt_trichotomy (-z) 1) as [LT|[->|GT]].
- intro. revert LT. apply Z.le_ngt, (Z.le_succ_l 0).
  apply Z.mul_pos_cancel_r with y; Z.order.
- Z.nzsimpl. Z.order.
- rewrite (Z.mul_lt_mono_pos_r y), Z.mul_1_l in GT; Z.order.
Qed.

Lemma OMEGA5 x y z : x = 0 -> y = 0 -> x + y * z = 0.
Proof.
now intros -> ->.
Qed.

Lemma OMEGA6 x y z : 0 <= x -> y = 0 -> 0 <= x + y * z.
Proof.
intros H ->. now Z.nzsimpl.
Qed.

Lemma OMEGA7 x y z t :
 z > 0 -> t > 0 -> 0 <= x -> 0 <= y -> 0 <= x * z + y * t.
Proof.
intros. Z.swap_greater. Z.order_pos.
Qed.

Lemma OMEGA8 x y : 0 <= x -> 0 <= y -> x = - y -> x = 0.
Proof.
intros H1 H2 H3. rewrite <- Z.opp_nonpos_nonneg in H2. Z.order.
Qed.

Lemma OMEGA9 x y z t : y = 0 -> x = z -> y + (- x + z) * t = 0.
Proof.
intros. subst. now rewrite Z.add_opp_diag_l.
Qed.

Lemma OMEGA10 v c1 c2 l1 l2 k1 k2 :
 (v * c1 + l1) * k1 + (v * c2 + l2) * k2 =
 v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2).
Proof.
rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
rewrite <- !Z.add_assoc. f_equal. apply Z.add_shuffle3.
Qed.

Lemma OMEGA11 v1 c1 l1 l2 k1 :
 (v1 * c1 + l1) * k1 + l2 = v1 * (c1 * k1) + (l1 * k1 + l2).
Proof.
rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
now rewrite Z.add_assoc.
Qed.

Lemma OMEGA12 v2 c2 l1 l2 k2 :
 l1 + (v2 * c2 + l2) * k2 = v2 * (c2 * k2) + (l1 + l2 * k2).
Proof.
rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
apply Z.add_shuffle3.
Qed.

Lemma OMEGA13 (v l1 l2 : Z) (x : positive) :
 v * Zpos x + l1 + (v * Zneg x + l2) = l1 + l2.
Proof.
 rewrite Z.add_shuffle1.
 rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r.
 now Z.nzsimpl.
Qed.

Lemma OMEGA14 (v l1 l2 : Z) (x : positive) :
 v * Zneg x + l1 + (v * Zpos x + l2) = l1 + l2.
Proof.
 rewrite Z.add_shuffle1.
 rewrite <- Z.mul_add_distr_l, <- Pos2Z.opp_neg, Z.add_opp_diag_r.
 now Z.nzsimpl.
Qed.

Lemma OMEGA15 v c1 c2 l1 l2 k2 :
 v * c1 + l1 + (v * c2 + l2) * k2 = v * (c1 + c2 * k2) + (l1 + l2 * k2).
Proof.
 rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
 apply Z.add_shuffle1.
Qed.

Lemma OMEGA16 v c l k : (v * c + l) * k = v * (c * k) + l * k.
Proof.
 now rewrite ?Z.mul_add_distr_r, ?Z.mul_add_distr_l, ?Z.mul_assoc.
Qed.

Lemma OMEGA17 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
Proof.
 unfold Zne, not. intros NE EQ. subst. now Z.nzsimpl.
Qed.

Lemma OMEGA18 x y k : x = y * k -> Zne x 0 -> Zne y 0.
Proof.
 unfold Zne, not. intros. subst; auto.
Qed.

Lemma OMEGA19 x : Zne x 0 -> 0 <= x + -1 \/ 0 <= x * -1 + -1.
Proof.
 unfold Zne. intros Hx. apply Z.lt_gt_cases in Hx.
 destruct Hx as [LT|GT].
 - right. change (-1) with (-(1)).
   rewrite Z.mul_opp_r, <- Z.opp_add_distr. Z.nzsimpl.
   rewrite Z.opp_nonneg_nonpos. now apply Z.le_succ_l.
 - left. now apply Z.lt_le_pred.
Qed.

Lemma OMEGA20 x y z : Zne x 0 -> y = 0 -> Zne (x + y * z) 0.
Proof.
 unfold Zne, not. intros H1 H2 H3; apply H1; rewrite H2 in H3;
 simpl in H3; rewrite Z.add_0_r in H3; trivial with arith.
Qed.

Definition fast_Zplus_comm (x y : Z) (P : Z -> Prop)
  (H : P (y + x)) := eq_ind_r P H (Z.add_comm x y).

Definition fast_Zplus_assoc_reverse (n m p : Z) (P : Z -> Prop)
  (H : P (n + (m + p))) := eq_ind_r P H (Zplus_assoc_reverse n m p).

Definition fast_Zplus_assoc (n m p : Z) (P : Z -> Prop)
  (H : P (n + m + p)) := eq_ind_r P H (Z.add_assoc n m p).

Definition fast_Zplus_permute (n m p : Z) (P : Z -> Prop)
  (H : P (m + (n + p))) := eq_ind_r P H (Z.add_shuffle3 n m p).

Definition fast_OMEGA10 (v c1 c2 l1 l2 k1 k2 : Z) (P : Z -> Prop)
  (H : P (v * (c1 * k1 + c2 * k2) + (l1 * k1 + l2 * k2))) :=
  eq_ind_r P H (OMEGA10 v c1 c2 l1 l2 k1 k2).

Definition fast_OMEGA11 (v1 c1 l1 l2 k1 : Z) (P : Z -> Prop)
  (H : P (v1 * (c1 * k1) + (l1 * k1 + l2))) :=
  eq_ind_r P H (OMEGA11 v1 c1 l1 l2 k1).
Definition fast_OMEGA12 (v2 c2 l1 l2 k2 : Z) (P : Z -> Prop)
  (H : P (v2 * (c2 * k2) + (l1 + l2 * k2))) :=
  eq_ind_r P H (OMEGA12 v2 c2 l1 l2 k2).

Definition fast_OMEGA15 (v c1 c2 l1 l2 k2 : Z) (P : Z -> Prop)
  (H : P (v * (c1 + c2 * k2) + (l1 + l2 * k2))) :=
  eq_ind_r P H (OMEGA15 v c1 c2 l1 l2 k2).
Definition fast_OMEGA16 (v c l k : Z) (P : Z -> Prop)
  (H : P (v * (c * k) + l * k)) := eq_ind_r P H (OMEGA16 v c l k).

Definition fast_OMEGA13 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
  (H : P (l1 + l2)) := eq_ind_r P H (OMEGA13 v l1 l2 x).

Definition fast_OMEGA14 (v l1 l2 : Z) (x : positive) (P : Z -> Prop)
  (H : P (l1 + l2)) := eq_ind_r P H (OMEGA14 v l1 l2 x).
Definition fast_Zred_factor0 (x : Z) (P : Z -> Prop)
  (H : P (x * 1)) := eq_ind_r P H (Zred_factor0 x).

Definition fast_Zopp_eq_mult_neg_1 (x : Z) (P : Z -> Prop)
  (H : P (x * -1)) := eq_ind_r P H (Z.opp_eq_mul_m1 x).

Definition fast_Zmult_comm (x y : Z) (P : Z -> Prop)
  (H : P (y * x)) := eq_ind_r P H (Z.mul_comm x y).

Definition fast_Zopp_plus_distr (x y : Z) (P : Z -> Prop)
  (H : P (- x + - y)) := eq_ind_r P H (Z.opp_add_distr x y).

Definition fast_Zopp_involutive (x : Z) (P : Z -> Prop) (H : P x) :=
  eq_ind_r P H (Z.opp_involutive x).

Definition fast_Zopp_mult_distr_r (x y : Z) (P : Z -> Prop)
  (H : P (x * - y)) := eq_ind_r P H (Zopp_mult_distr_r x y).

Definition fast_Zmult_plus_distr_l (n m p : Z) (P : Z -> Prop)
  (H : P (n * p + m * p)) := eq_ind_r P H (Z.mul_add_distr_r n m p).
Definition fast_Zmult_opp_comm (x y : Z) (P : Z -> Prop)
  (H : P (x * - y)) := eq_ind_r P H (Z.mul_opp_comm x y).

Definition fast_Zmult_assoc_reverse (n m p : Z) (P : Z -> Prop)
  (H : P (n * (m * p))) := eq_ind_r P H (Zmult_assoc_reverse n m p).

Definition fast_Zred_factor1 (x : Z) (P : Z -> Prop)
  (H : P (x * 2)) := eq_ind_r P H (Zred_factor1 x).

Definition fast_Zred_factor2 (x y : Z) (P : Z -> Prop)
  (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor2 x y).

Definition fast_Zred_factor3 (x y : Z) (P : Z -> Prop)
  (H : P (x * (1 + y))) := eq_ind_r P H (Zred_factor3 x y).

Definition fast_Zred_factor4 (x y z : Z) (P : Z -> Prop)
  (H : P (x * (y + z))) := eq_ind_r P H (Zred_factor4 x y z).

Definition fast_Zred_factor5 (x y : Z) (P : Z -> Prop)
  (H : P y) := eq_ind_r P H (Zred_factor5 x y).

Definition fast_Zred_factor6 (x : Z) (P : Z -> Prop)
  (H : P (x + 0)) := eq_ind_r P H (Zred_factor6 x).

Theorem intro_Z :
  forall n:nat,  exists y : Z, Z.of_nat n = y /\ 0 <= y * 1 + 0.
Proof.
  intros n; exists (Z.of_nat n); split; trivial.
  rewrite Z.mul_1_r, Z.add_0_r. apply Nat2Z.is_nonneg.
Qed.


Load Identifiers.
Require Import List.

(* Terms *)
Inductive term : Type :=
  | ConT : term
  | VarT : id -> term
  | LamT : term -> ids -> term -> term
  | AppT : term -> term -> term.

Fixpoint free_vars (t : term) : ids :=
  match t with
  | ConT        => ids_empty
  | VarT x      => ids_add x ids_empty
  | LamT p th a => ids_diff (ids_union (free_vars p) (free_vars a)) th
  | AppT a b    => ids_union (free_vars a) (free_vars b)
  end.

Fixpoint bound_vars (t : term) : ids :=
  match t with
  | ConT        => ids_empty
  | VarT x      => ids_empty
  | LamT p th a => ids_union (ids_union (bound_vars p) (bound_vars a)) th
  | AppT a b    => ids_union (bound_vars a) (bound_vars b)
  end.

Fixpoint all_vars (t : term) : ids :=
  match t with
  | ConT        => ids_empty
  | VarT x      => ids_add x ids_empty
  | LamT p th a => ids_union (ids_union (all_vars p) (all_vars a)) th
  | AppT a b    => ids_union (all_vars a) (all_vars b)
  end.

(*
Lemma all_vars_eq_free_union_bound :
  forall t : term,
  all_vars t = ids_union (free_vars t) (bound_vars t).
Proof.
  induction t.
  (* ConT *)
  compute. trivial.
  (* VarT *)
  compute. trivial.
  (* LamT *)
  unfold all_vars. fold all_vars.
  unfold free_vars. fold free_vars.
  unfold bound_vars. fold bound_vars.
    (* ... *)
  (* AppT *)
  unfold all_vars. fold all_vars.
  unfold free_vars. fold free_vars.
  unfold bound_vars. fold bound_vars.
    (* ... *)
*)

(* Bound variables of subterms *)

Lemma bound_vars_lam :
    forall p : term, forall th : ids, forall a : term,
      ids_includes (bound_vars (LamT p th a))
                   (ids_union (bound_vars p)
                              (bound_vars a)).
Proof.
  intros p th a.
  unfold ids_includes.
  intros x x_in_bvp.
  unfold bound_vars. fold bound_vars.
  apply ids_union_intro1.
  assumption.
Qed.

Lemma bound_vars_lam_pattern :
    forall p : term, forall th : ids, forall a : term,
      ids_includes (bound_vars (LamT p th a))
                   (bound_vars p).
Proof.
  intros p th a.
  apply ids_includes_transitivity
     with (B := (ids_union (bound_vars p) (bound_vars a))).
  apply bound_vars_lam.
  apply ids_includes_union1.
Qed.

Lemma bound_vars_lam_body :
    forall p : term, forall th : ids, forall a : term,
      ids_includes (bound_vars (LamT p th a))
                   (bound_vars a).
Proof.
  intros p th a.
  apply ids_includes_transitivity
     with (B := (ids_union (bound_vars p) (bound_vars a))).
  apply bound_vars_lam.
  apply ids_includes_union2.
Qed.

Lemma bound_vars_app1 :
  forall t1 t2 : term,
    ids_includes (bound_vars (AppT t1 t2))
                 (bound_vars t1).
Proof.
  intros t1 t2.
  unfold ids_includes.
  intros x x_in_bv_t1.
  unfold bound_vars. fold bound_vars.
  apply ids_union_intro1.
  assumption.
Qed.

Lemma bound_vars_app2 :
  forall t1 t2 : term,
    ids_includes (bound_vars (AppT t1 t2))
                 (bound_vars t2).
Proof.
  intros t1 t2.
  unfold ids_includes.
  intros x x_in_bv_t2.
  unfold bound_vars. fold bound_vars.
  apply ids_union_intro2.
  assumption.
Qed.

(* Substitutions *)
Inductive subst : Type :=
  | SubstS (domain : ids) (mapping : id -> term) : subst
  | NoneS  : subst.

Definition subst_domain (s : subst) : ids :=
  match s with
  | SubstS dom _ => dom
  | NoneS        => ids_empty
  end.

Fixpoint subst_free_vars (s : subst) : ids :=
  match s with
  | SubstS dom f => ids_union_map (fun x : id => free_vars (f x)) dom
  | NoneS        => ids_empty
  end.

Definition subst_variables (s : subst) : ids :=
  ids_union (subst_domain s) (subst_free_vars s).

Definition subst_apply_to_id (s : subst) (x : id) : term :=
  match s with
  | SubstS _ f => f x
  | NoneS      => VarT x
  end.

Lemma subst_free_vars_monotone :
  forall dom1 dom2 mapping,
  ids_includes dom1 dom2 ->
  ids_includes (subst_free_vars (SubstS dom1 mapping))
               (subst_free_vars (SubstS dom2 mapping)).
Proof.
  intros dom1 dom2 mapping dom1_includes_dom2.
  induction dom1.
    (* nil *)
    apply ids_includes_nil in dom1_includes_dom2.
    replace dom2 with ids_empty.
    compute. trivial.
    (* a :: dom1 *)

(*
 * To model application of a substitution to a term, we follow
 * these steps:
 *
 * - First, define the *safe* application of a substitution to
 *   a term. An application is safe if it can assume that variables
 *   are renamed apart. (It shall receive a proof of this fact).
 *
 * - Define alpha-equivalence and renaming in terms of the
 *   safe substitution.
 *
 * - Define the general application of a substitution to a term,
 *   which composes the safe application with a previous step of
 *   renaming bound variables in the term, for them to be renamed
 *   apart.
 *
 *)

(*
 * A substitution and a term are *apart* if the bound
 * variables of the term do not occur in the substitution
 * (either in the domain, or as free variables in the
 * codomain).
 *
 *)
Definition apart (s : subst) (t : term) :=
  ids_disjoint (subst_variables s) (bound_vars t).

(* apart: weakening of terms *)

(*
 * Given a substitution "s" apart from a given term,
 * "s" is also apart from a term with less bound variables.
 *)
Lemma apart_weakening :
    forall t1 t2 : term,
      ids_includes (bound_vars t1) (bound_vars t2) ->
      forall s : subst, apart s t1 -> apart s t2.
Proof.
  (* Unfold equivalent disjoint definitions *)
  intros t1 t2 inclusion s hyp.
  unfold apart.
  unfold apart in hyp.
  assert (ids_disjoint2 (subst_variables s)
                        (bound_vars t1))
         as hyp2.
      apply ids_disjoint_implies_ids_disjoint2.
      assumption.
  unfold ids_disjoint2 in hyp2.
  apply ids_disjoint2_implies_ids_disjoint.
  unfold ids_disjoint2.
  unfold ids_includes in inclusion.

  (* Suppose x is both in the substitution and in BV(t2) *)
  intros x x_in_s x_in_bv_t2.
  (* x is in BV(t1) *)
  assert (ids_In x (bound_vars t1)).
      specialize inclusion with x.
      apply inclusion.
      assumption.
  (* x is not in BV(t1) *)
  specialize hyp2 with x.
  assert (~ ids_In x (bound_vars t1)).
      apply hyp2.
      assumption.
  contradiction.
Qed.

Definition apart_weakening_lam_pattern
             (p : term) (th : ids) (a : term) :
             forall s : subst,
                 apart s (LamT p th a) -> apart s p
  := apart_weakening (LamT p th a) p (bound_vars_lam_pattern p th a).

Definition apart_weakening_lam_body
             (p : term) (th : ids) (a : term) :
             forall s : subst,
                 apart s (LamT p th a) -> apart s a
  := apart_weakening (LamT p th a) a (bound_vars_lam_body p th a).

Definition apart_weakening_app1
             (t1 t2 : term) :
             forall s : subst,
                 apart s (AppT t1 t2) -> apart s t1
  := apart_weakening (AppT t1 t2) t1 (bound_vars_app1 t1 t2).

Definition apart_weakening_app2
             (t1 t2 : term) :
             forall s : subst,
                 apart s (AppT t1 t2) -> apart s t2
  := apart_weakening (AppT t1 t2) t2 (bound_vars_app2 t1 t2).

(* apart: weakening of substitutions *)

Lemma apart_weakening_domain :
  forall dom1 dom2 mapping t,
    ids_includes dom1 dom2 ->
    apart (SubstS dom1 mapping) t ->
    apart (SubstS dom2 mapping) t.
Proof.
  intros dom1 dom2 mapping t dom1_includes_dom2 apart_s1_t.
  unfold apart, subst_variables.
  apply ids_disjoint_union_complete.
  unfold apart, subst_variables in apart_s1_t.
  apply ids_disjoint_union_correct in apart_s1_t.
  destruct apart_s1_t as (apart_dom1_t, apart_fv1_t).
  split.
    (* domain *)
    unfold subst_domain.
    unfold subst_domain in apart_dom1_t.
    apply ids_disjoint_weakening with (A := dom1).
    assumption. assumption.
    (* free variables *)
    unfold subst_free_vars.

(*
 * "subst_apply_safe" takes a substitution "s" and a term "t"
 * and returns a resulting function.
 *
 * The resulting function requires a proof that
 * "s" and "t" are renamed apart, and returns the
 * result of applying "s" to "t".
 *)
Fixpoint subst_apply_safe (s : subst) (t : term) : apart s t -> term :=
  match s with
  | NoneS      => fun _ => t
  | SubstS _ _ =>
      match t return apart s t -> term with
      | ConT        => fun _ => ConT

      | VarT x      => fun _ =>
                          if ids_mem x (subst_domain s)
                              then subst_apply_to_id s x
                              else VarT x

      | LamT p th a => fun apart_st =>
                         LamT
                           (subst_apply_safe s p
                             (apart_weakening_lam_pattern p th a s apart_st))
                           th
                           (subst_apply_safe s a
                             (apart_weakening_lam_body p th a s apart_st))

      | AppT a b    => fun apart_st =>
                         AppT
                           (subst_apply_safe s a
                             (apart_weakening_app1 a b s apart_st))
                           (subst_apply_safe s b
                             (apart_weakening_app2 a b s apart_st))
      end
  end.

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

Fixpoint replace_var_in_set (th : ids) (x : id) (y : id) : ids :=
  match th with
  | nil       => ids_empty
  | z :: zs => (if id_eq z x
                 then y
                 else z) :: replace_var_in_set zs x y
  end.

Fixpoint replace_var_in_term (t : term) (x : id) (y : id) : term :=
  match t with
  | ConT        => ConT
  | VarT z      => if id_eq z x
                    then VarT y
                    else VarT z
  | LamT p th a => if ids_mem x th
                    then LamT p th a
                    else LamT (replace_var_in_term p x y)
                              (replace_var_in_set th x y)
                              (replace_var_in_term a x y)
  | AppT a b    => AppT (replace_var_in_term a x y)
                        (replace_var_in_term b x y)
  end.

Inductive alpha_equivalent (t1 t2 : term) :=
  | alpha_axiom :
      forall x y p th a, not (ids_In y (ids_union (free_vars p)
                                                  (free_vars a)))
                         -> t1 = LamT p th a
                         -> t2 = LamT
                                   (replace_var_in_term p x y)
                                   (replace_var_in_set th x y)
                                   (replace_var_in_term a x y)
                         -> alpha_equivalent t1 t2
  | alpha_refl  : t1 = t2 -> alpha_equivalent t1 t2
  | alpha_symm  : alpha_equivalent t2 t1 -> alpha_equivalent t1 t2
  | alpha_trans : forall t3 : term,
                    alpha_equivalent t1 t3 ->
                    alpha_equivalent t2 t3 ->
                    alpha_equivalent t1 t2
  | alpha_congr_lam_pattern :
                  forall p1 p2 th a,
                  alpha_equivalent p1 p2 ->
                  t1 = LamT p1 th a ->
                  t2 = LamT p2 th a ->
                  alpha_equivalent t1 t2
  | alpha_congr_lam_body :
                  forall p th a1 a2,
                  alpha_equivalent a1 a2 ->
                  t1 = LamT p th a1 ->
                  t2 = LamT p th a2 ->
                  alpha_equivalent t1 t2
  | alpha_congr_app1 :
                  forall a1 a2 b,
                  alpha_equivalent a1 a2 ->
                  t1 = AppT a1 b ->
                  t2 = AppT a2 b ->
                  alpha_equivalent t1 t2
  | alpha_congr_app2 :
                  forall a b1 b2,
                  alpha_equivalent b1 b2 ->
                  t1 = AppT a b1 ->
                  t2 = AppT a b2 ->
                  alpha_equivalent t1 t2.

Lemma apart_nilsubst :
  forall t mapping, apart (SubstS nil mapping) t.
Proof.
  intros t mapping.
  compute.
  contradiction.
Qed.

Lemma subst_apply_nilsubst :
  forall t mapping ap,
    subst_apply_safe (SubstS nil mapping) t ap = t.
Proof.
  intros t mapping ap.
  induction t.
  (* ConT *)
  compute. trivial.
  (* VarT *)
  compute. trivial.
  (* LamT *)
  unfold subst_apply_safe.
  fold subst_apply_safe.
    rewrite IHt1. rewrite IHt2. trivial.
  (* AppT *)
  unfold subst_apply_safe.
  fold subst_apply_safe.
    rewrite IHt1. rewrite IHt2. trivial.
Qed.

(*
Lemma subst_apply_nonnilsubst :
  forall t mapping ap,
    subst_apply_safe (SubstS (cons x xs) mapping) t ap
    = subst_apply_safe (SubstS xs mapping) (replace_var_in_term t x (mapping xs)) ....
Proof.
*)

Lemma subst_defined_implies_alpha_equivalent :
  forall s t1 t2
         (ap1: apart s t1)
         (ap2: apart s t2),
     alpha_equivalent t1 t2 ->
     alpha_equivalent (subst_apply_safe s t1 ap1) (subst_apply_safe s t2 ap2).
Proof.
  intros s t1 t2 ap1 ap2 eq_t1_t2.
  induction s.
      (* SubstS *)
      induction domain.
          (* nil domain *)
          rewrite subst_apply_nilsubst.
          rewrite subst_apply_nilsubst.
          assumption.
          (* cons x xs domain *)
          induction t1.


From discprob.basic Require Import base order nify exp_ext.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.rec Require Import karp quickselect_rec.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
From Coquelicot Require Import Derive.
From Coquelicot Require AutoDerive.
Require Import Reals Fourier FunctionalExtensionality.
Require Import Psatz.
Require Import Coq.omega.Omega.
Require Import Ranalysis5.

Module Type rec_factor.
  Parameter alpha : R.
  Parameter alpha_range: 1/2 < alpha < 1.
  Parameter ln_alpha: -/ln alpha > 1/alpha.
End rec_factor.

Module recurrence_log (ALPHA: rec_factor).
  Import ALPHA.
  Definition d := 1.
  Definition umin := 1.

  Definition a x :=
    match Rle_dec x 1 with
      | left _ => 0
      | _ =>
        match Rlt_dec x 2 with
        | left _ => (x - 1)
        | _ => 1
        end
    end.

  Definition m x :=
    match Rlt_dec x (1/alpha) with
      | left _ => 0
      | _ => x * alpha
    end.

  Definition k := -/ ln(alpha).

  Definition u x :=
    match Rle_dec x 1 with
      | left _ => 1
      | _ => ((k * ln x + 1))
    end.

  Definition u' x :=
    match Rle_dec x 1 with
      | left _ => 1
      | _ => exp ((x - 1) / k)
    end.

  Lemma umin_non_neg: 0 ≤ umin.
  Proof. rewrite /umin; fourier. Qed.

  Lemma Rlt_0_ln x: 1 < x → 0 < ln x.
  Proof.
    intros Hlt; rewrite -ln_1; apply ln_increasing; fourier.
  Qed.

  Lemma one_lt_inv_alpha:
    1 < / alpha.
  Proof.
    generalize (alpha_range), ln_alpha; intros.
    apply (Rmult_lt_reg_l alpha); first nra. field_simplify; nra.
  Qed.

  Lemma kgt1: 1 < k.
  Proof.
    generalize (alpha_range), ln_alpha; intros.
    rewrite /k.
    transitivity (/ alpha); last auto; try nra.
    apply one_lt_inv_alpha.
  Qed.

  Lemma kgt0: 0 < k.
  Proof.
    etransitivity; last apply kgt1. fourier.
  Qed.

  Lemma u_mono x y: x ≤ y → u x ≤ u y.
  Proof.
    rewrite /u/a/m/d => Hle.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    -
      cut (0 ≤ ln y).
      {
        intros. generalize kgt1 => ?.
        assert (k * ln y ≥ 0).
        { transitivity (1 * ln y); last fourier.
          apply Rle_ge, Rmult_le_compat; try fourier.
        }
        fourier.
      }
      left. apply Rlt_0_ln; nra.
    - specialize (kgt0) => Hk.
      apply Rplus_le_compat; last nra.
      cut (ln x ≤ ln y).
      {
        specialize (kgt0); cut (0 ≤ ln x); intros; first apply Rmult_le_compat; auto; try fourier.
        rewrite -(ln_1). left; apply ln_increasing; nra.
      }
      * inversion Hle; auto; subst; last by nra. left. apply ln_increasing; intros; nra.
  Qed.

  (* This basically covers half the case for the above, so could remove some redundancy *)
  Lemma u_strict_inc x y: x ≥ d → x < y → u x < u y.
  Proof.
    rewrite /u/a/m/d => Hle Hlt.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    - specialize (kgt0) => Hk.
      assert (0 < k * ln y).
      {
        apply Rmult_lt_0_compat; first nra.
        apply Rlt_0_ln; fourier.
      }
      rewrite ?Rmult_1_r //=; nra.
    - specialize (kgt0) => Hk.
      apply Rplus_lt_compat_r.
      cut (ln x < ln y).
      {
        specialize (kgt0); cut (0 < ln x); intros; first apply Rmult_lt_compat_l; auto; try fourier.
        rewrite -(ln_1). apply ln_increasing; nra.
      }
      apply ln_increasing; nra.
  Qed.

  Lemma u'_mono x y: x ≤ y → u' x ≤ u' y.
  Proof.
    rewrite /u'/a/m/d => Hle.
    destruct (Rle_dec) as [Hle'|Hnle']; try nra;
    destruct (Rle_dec) as [Hle''|Hnle'']; try nra.
    - rewrite -{1}exp_0.
      left; apply exp_increasing.
      rewrite /Rdiv. apply Rlt_mult_inv_pos; last apply kgt0. nra.
    - apply exp_increasing_le.
      generalize (kgt0) => Hk.
      apply Rdiv_le_compat_contra; nra.
  Qed.

  Lemma u'_pos x: u' x > 0.
  Proof.
    rewrite /u'/a/m/d.
    destruct (Rle_dec _); try nra.
    apply exp_pos.
  Qed.

  Lemma u'_inv_above x: d < x → u' (u x) = x.
  Proof.
    rewrite /u/u'/d.
    destruct (Rle_dec) as [Hc1|Hc1] => //=; try nra;
    destruct (Rle_dec) as [Hc2|Hc2] => //=; try nra.
    - intros. exfalso.
      assert (0 < ln x) by (apply Rlt_0_ln; auto).
      assert (0 < k * ln x) by (apply Rmult_lt_0_compat; auto using kgt0).
      assert (0 < (k * ln x) * (k * ln x)) by (repeat apply Rmult_lt_0_compat; auto using kgt0).
      nra.
    - rewrite -[a in _ = a]exp_ln; last nra.
      intros; do 1 f_equal.
      assert (0 < ln x) by (apply Rlt_0_ln; auto).
      assert (0 < k * ln x) by (apply Rmult_lt_0_compat; auto using kgt0).
      field. apply Rgt_not_eq, kgt0.
  Qed.

  Lemma u'u x: x ≤ u' (u x).
  Proof.
    destruct (Rlt_dec 1 x) as [Hlt|Hnlt].
    - rewrite u'_inv_above //. reflexivity.
    - rewrite /u/u'.
      apply Rnot_lt_le in Hnlt.
      destruct (Rle_dec) => //=; try nra.
      destruct (Rle_dec) => //=; try nra.
  Qed.

  Lemma u_inv_above x: umin < x → u (u' x) = x.
  Proof.
    rewrite /u/u'/umin.
    destruct (Rle_dec) as [Hc1|?] => //=; try nra;
    destruct (Rle_dec) as [?|?] => //=; try nra.
    - exfalso. rewrite -{2}exp_0 in Hc1.
      apply exp_le_embedding in Hc1.
      specialize (kgt1) => Hk.
      cut (0 < (x - 1) / k).
      { by intros ?%Rlt_not_le. }
      apply Rdiv_lt_0_compat; nra.
    - rewrite ln_exp. rewrite /Rdiv. intros.
      field. apply Rgt_not_eq, kgt0.
  Qed.

  Lemma ud_umin: u d = umin.
  Proof.
    rewrite /u/d/umin//=.
    destruct (Rle_dec); nra.
  Qed.

  Lemma u_cont: continuity u.
  Proof.
    apply piecewise_continuity' with (g := λ x, (k * ln x + 1))
                                      (f := λ x, 1) (z := 1).
    - intros; apply continuity_const => ? //.
    - intros. repeat apply continuity_pt_mult.
      * apply continuity_pt_plus.
        ** apply continuity_pt_mult.
           *** apply continuity_pt_const => ? //.
           *** apply ln_continuity_pt; fourier.
        ** apply continuity_pt_const => ? //.
    - rewrite /u => x. destruct (Rle_dec); nra.
    - rewrite /u => x.
      destruct (Rle_dec); intros.
      * assert (x = 1) as -> by (apply Rle_antisym; fourier).
        rewrite ln_1 Rmult_0_r Rplus_0_l. done.
      * done.
  Qed.

  Lemma a_cont_pt: ∀ x, d < x → continuity_pt a x.
  Proof.
    rewrite /d. intros.
    apply piecewise_continuity_pt with (P := λ x, d < x)
                                               (g := λ x,
                                                     match Rlt_dec x 2 with
                                                     | left _ => (x - 1)
                                                     | _ => 1
                                                     end)
                                               (f := λ x, 0) (z := 1).
    - intros. apply continuity_const => ??. done.
    - intros. apply piecewise_continuity_pt with (g := λ x, 1)
                                                 (f := λ x, (x - 1))
                                                 (z := 2)
                                                 (P := λ x, d < x);
                try (intros; destruct (Rlt_dec); nra); try nra.
      * rewrite /d. intros.
        ** apply continuity_minus.
           *** apply continuity_id => ??.
           *** apply continuity_const => ??. done.
      * intros. apply continuity_const => ?? //=.
    - intros x'. rewrite /a. destruct Rle_dec; try nra; destruct Rlt_dec; nra.
    - intros x'. rewrite /a. destruct Rle_dec; nra.
    - rewrite /d. intros. fourier.
    - rewrite /d. fourier.
  Qed.

  Lemma kinv: /k = ln (/alpha).
  Proof.
    rewrite /k.
    generalize (alpha_range), ln_alpha; intros.
    rewrite ln_Rinv; last by nra.
    assert (0 < ln (/alpha)).
    { rewrite -ln_1. apply ln_increasing; first nra. apply one_lt_inv_alpha. }
    rewrite Ropp_inv_permute.
    - rewrite Rinv_involutive //.
      cut (ln alpha ≠ 0); first by nra.
      apply Rlt_not_eq. rewrite -ln_1.
      apply ln_increasing; nra.
    - cut (ln alpha ≠ 0); first by nra.
      apply Rlt_not_eq. rewrite -ln_1.
      apply ln_increasing; nra.
  Qed.

  Lemma urec0 x: x > d → u x ≥ a x + u (m x).
  Proof.
    generalize (alpha_range), ln_alpha => ??.
    rewrite /u/a/m/d.
    destruct (Rle_dec) as [Hc1|Hc1] => //=; first nra.
    destruct (Rle_dec) as [Hc2|Hc2] => //=.
    - destruct (Rlt_dec) as [?|?].
      {
        destruct (Rlt_dec) as [?|?]; try nra; last first.
        { intros.
          assert (1 / alpha < 2).
          { destruct alpha_range as (Hlt&?).
            apply Rinv_lt_contravar in Hlt; last nra.
            nra.
          }
          nra.
        }
        intros.
        transitivity (x - 1 +  1); last first.
        { right. field. }
        cut (k * ln x > x - 1); first by (intros; fourier).
        cut (k * ln x - (x - 1) > 0); first by (intros; fourier).
        apply Rlt_gt.
        eapply (Rle_lt_trans _ (k * ln(1) - (1 - 1))).
        { right. rewrite ln_1 Rmult_0_r. field. }
        eapply incr_function_le with (f := λ x, k * ln x - (x - 1))
                                               (x := 1)
                                               (y := x)
                                               (a := 1)
                                               (b := /alpha)
                                               (df := λ x, k * 1/x - 1); try fourier; eauto.
        * rewrite //= => ???. AutoDerive.auto_derive; nra.
        * rewrite //=. intros x' ? ?.
          cut (k */ x' > 1).
          { intros. set (p := k */ x'). assert (p > 1) by (rewrite /p; auto).
            nra.
          }
          apply Rlt_gt, (Rmult_lt_reg_r x'); first fourier.
          rewrite Rmult_assoc Rinv_l; first (rewrite /k; nra).
          apply Rgt_not_eq; fourier.
        * rewrite //=. nra.
        * rewrite //=. nra.
      }
      assert (x = /alpha) as ->.
      {
        apply (Rmult_le_compat_r (/alpha)) in Hc2; last first.
        {
          left. transitivity 1; first nra. apply one_lt_inv_alpha.
        }
        rewrite Rmult_assoc Rinv_r in Hc2; last first.
        { apply Rgt_not_eq. nra. }
        rewrite Rmult_1_l Rmult_1_r in Hc2.
        apply Rle_antisym; nra.
      }
      destruct (Rlt_dec); last by nra.
      intros; rewrite -kinv Rinv_r; first nra.
      apply Rgt_not_eq, kgt0.
    - assert (0 < ln x) by (apply Rlt_0_ln; nra).
      destruct (Rlt_dec); first by nra; intros.
      intros; rewrite ln_mult; try nra.
      rewrite (Rmult_plus_distr_l k _).
      assert (k * ln (alpha) = -1) as ->.
      { rewrite /k. field. apply Rlt_not_eq.
        rewrite -(ln_1). apply ln_increasing; nra.
      }
      destruct Rlt_dec.
      * field_simplify; last nra.
      * rewrite /Rdiv; first fourier.
  Qed.

  Lemma alower: ∀ x, x ≤ d → a x = 0.
  Proof.
    rewrite /a => x; destruct (Rle_dec) => //=; nra.
  Qed.

  Lemma a_nonneg: ∀ x, a x ≥ 0.
  Proof.
    intros. rewrite /a. destruct (Rlt_dec); destruct (Rle_dec); nra.
  Qed.

  Lemma a_pos: ∀ x, d < x → 0 < a x.
  Proof.
    rewrite /d/a => ??. destruct (Rlt_dec); destruct (Rle_dec); nra.
  Qed.

  Lemma a_mono: Rmono a.
  Proof.
    rewrite /Rmono. intros x x' Hle.
    inversion Hle; subst; try reflexivity.
    destruct (Rle_dec d x) as [?|?%Rnot_le_gt].
    * rewrite /a. do 2 (destruct (Rle_dec); try destruct (Rlt_dec)); nra.
    * rewrite alower; auto; try fourier. apply Rge_le, a_nonneg.
  Qed.

  Lemma mnondec: ∀ y y', 0 < y → y ≤ y' → (m y / y) ≤ (m y' / y').
  Proof.
    generalize (alpha_range), ln_alpha => ??.
    intros y y' Hlt Hle.
    rewrite /m.
    destruct (Rlt_dec).
    {  destruct (Rlt_dec).
       - intros. rewrite /Rdiv ?Rmult_0_l. fourier.
       - intros. rewrite /Rdiv ?Rmult_0_l.
         rewrite Rmult_comm -Rmult_assoc Rinv_l; nra.
    }
    destruct (Rlt_dec); first by nra.
    intros. right. field. split; apply Rgt_not_eq; fourier.
  Qed.

  Lemma d_non_neg: 0 ≤ d.
  Proof.
    rewrite /d. fourier.
  Qed.

End recurrence_log.


Require Import HoTT.

Local Open Scope pointed_scope.

Section pType_prelim.

(* 	(*The constant map between two pointed types*)
	Definition const_map (A B: pType) : A->B :=
		fun a:(pointed_type A) => point B.
 *)
	(*This map is a pointed map*)
	Definition pconst (A B: pType) : pMap A B :=
		Build_pMap A B (const (point B)) idpath.

	Global Instance ispointed_pmap {A B:pType} : IsPointed (pMap A B) :=
		pconst A B.

	(* (*The pointed type of pointed maps
		(Overwrite the standard definition, which is not a pointed type)*)
	Definition ptMap (A B: pType) : pType :=
		Build_pType (pMap A B) (const_pmap A B).
	 *)

	(*Define the pointed sphere.
	It may not be evident here, but the basepoint is always North.*)
	Fixpoint pSphere (n:nat) : pType :=
		match n with
		|O => Build_pType (Sphere O) North
		|S n => psusp (pSphere n)
		end.
	Definition add_pt (A:Type) :  pType := Build_pType (A+Unit) (inr tt).
	Definition pBool : pType := Build_pType Bool true.
	Definition pUnit : pType := Build_pType Unit tt.

	(*Define the wedge. The basepoint could just as well have been pushr tt,
	but some choice had to be made.*)
	Definition wedge (A B:pType) :=
		Build_pType
			(pushout (@const Unit A (point A)) (@const Unit B (point B) ) )
			(pushl tt).

	Definition wedgepush {A B:pType} :=
		@push pUnit A B (@const Unit A (point A)) (@const Unit B (point B)).

	Definition wedge_functor {A B C:pType} (f:A->*B) :
		(wedge A C) ->* (wedge B C).
		refine (Build_pMap _ _ _ _).
			-refine (pushout_rec _ _ _).
				+ intros [a|c].
						*exact (wedgepush (inl (f a))).
						*exact (wedgepush (inr c)).
				+intros [].
				rewrite (point_eq f).
				exact (pp tt).
			- simpl. unfold const. rewrite (point_eq f). exact idpath.
	Defined.

	(*Todo: This is a functor.*)

	Definition sum_to_product {A B:pType} (x : A+B) : A*B:=
		match x with
			|inl a => (a, point B)
			|inr b => (point A, b)
		end.

	Definition wedge_in_product {A B:pType} : wedge A B -> A*B :=
		pushout_rec (A*B) sum_to_product (fun _ => idpath).

	Definition smash (A B : pType) :=
		Build_pType
			(pushout (wedge_in_product) (pconst (wedge A B) pUnit))
			(pushr (point (wedge A B))).

	Definition smashpush {A B:pType} :=
		@push (wedge A B) (A*B) pUnit wedge_in_product (pconst (wedge A B) pUnit).

	Definition smash_functor {A B C:pType} (f:A->*B) :
		smash A C ->* smash B C.
		refine (Build_pMap _ _ _ _).
			-refine (pushout_rec _ _ _).
				+intros [ [a c] |  [] ].
					* exact (smashpush (inl (f a, c))).
					* exact (point _).
				+simpl. refine (pushout_ind _ _ _ _ _).
					*intros [a|c].
						** exact (pp (wedgepush (inl (f a)) )).
						**simpl.
 						(* equiv_via (smashpush (inl (point B, c))). *)
 						eapply (concat ((ap (fun b:B => smashpush (inl (b, c)))) (point_eq f))  _).
					*simpl. intros [].
					 admit.
			-exact idpath.
	Admitted.

	Lemma const_comp (A B C: pType) (f:A->*B) :
		pconst B C o* f = pconst A C.
		Proof.
		decompose record f.
		unfold pconst.
		unfold pmap_compose ; simpl.
		unfold const.
		rewrite ap_const; simpl.
		reflexivity.
	Qed.

End pType_prelim.

(*Show that my two-pointed types are equivalent*)
Section Two_points.
	Definition two_pts := add_pt Unit. (*TODO: Sphere 0 instead of pBool. . .*)

	Definition sph0_to_two_pts : (pSphere 0) ->* two_pts.
		refine (Build_pMap _ _ _ _).
			(*Construct map*)
			-apply (Susp_rec (inr tt) (inl tt)).
				+intros [].
			-exact idpath.
	Defined.

	Definition two_pts_to_sph0 : two_pts -> (pSphere 0).
		intros [].
			-exact (Unit_rec (pSphere 0) South).
			-exact (Unit_rec (pSphere 0) North).
	Defined.

	Definition isretr : Sect two_pts_to_sph0 sph0_to_two_pts.
		intros [ [] | [] ] ; exact idpath.
	Defined.

	Definition issect : Sect sph0_to_two_pts two_pts_to_sph0.
		refine (Susp_ind _ idpath idpath _).
		intros [].
	Defined.

	(*TODO: Is equiv*)

	Definition pBool_to_two_pts : pBool ->* two_pts.
		refine (Build_pMap _ _ _ _).
				(*Construct map*)
				-intro b.	exact (if b then (inr tt) else (inl tt)).
				(*Show it is pointed.*)
				-exact idpath.
	Defined.

	Definition two_pts_to_bool : add_pt Unit -> pBool.
		intro x; elim x.
					(*Left element (non-basepoint*)
					apply Unit_rec. exact false.
					(*Right element (basepoint)*)
					apply Unit_rec. exact true.
	Defined.

	Definition Sect_1 : Sect two_pts_to_bool pBool_to_two_pts.
		unfold Sect. induction x.
				+ induction a. exact idpath.
				+ induction b. exact idpath.
	Defined.

	Definition Sect_2 : Sect pBool_to_two_pts two_pts_to_bool.
			-unfold Sect. apply Bool_ind ; exact idpath.
	Defined.

	Lemma pequiv_bool_addpt1 : pBool <~>* add_pt Unit.
		Proof.
		refine (Build_pEquiv pBool (add_pt Unit) pBool_to_two_pts _).
		refine (BuildIsEquiv pBool (add_pt Unit) pBool_to_two_pts two_pts_to_bool Sect_1 Sect_2 _).
		apply Bool_ind ; reflexivity.
	Qed.

	Definition pMap_to_Map {A:Type } {B:pType} : ( (add_pt A) ->* B  ) -> ( A -> (pointed_type B) ).
		intro f.
		exact (f o inl).
	Defined.

	Definition Map_to_pMap {A:Type } {B:pType} : ( A->(pointed_type B) ) -> ( (add_pt A) ->* B  ).
		intro f.
		transparent assert (h: (add_pt A -> B)).
			-intros [a | []].
				*exact (f a).
				*exact (point B).
		-exact (Build_pMap _ _ h idpath).
	Defined.

	Lemma isequiv_pMap_to_Map {A:Type } {B:pType} `{Funext} : IsEquiv (@pMap_to_Map A B).
		apply (@isequiv_adjointify ( (add_pt A) ->* B  ) (A->B) pMap_to_Map Map_to_pMap).
			-exact (fun _ => idpath).
			-intros [pf pe].
			unfold pMap_to_Map; unfold Map_to_pMap. simpl.

			assert (Ht :
							pf ==
							(fun X : A + Unit =>
               match X with
               | inl a => pf (inl a)
               | inr tt => point B
               end )
               ).
				+intros [ a | [] ].
					*exact idpath.
					*exact pe^.
			+assert (p : (fun X : A + Unit =>
               match X with
               | inl a => pf (inl a)
               | inr tt => point B
               end )
               =
               pf ).
				apply path_forall. exact Ht.
			clear Ht.
			pointed_reduce.

			rewrite (path_forall _ _ p).

	(*Lemma 6_5_3 in book:*)
	Lemma addpt_forget_adjoint {A:Type} {B:pType} :
		( (add_pt A) ->* B  ) <~> ( A -> (pointed_type B) ).
		refine (BuildEquiv _ _ pMap_to_Map _ ).
		refine (BuildIsEquiv _ _ pMap_to_Map Map_to_pMap _ _ _).
			-exact (fun _ => idpath).
			-unfold Sect.
			intro f; destruct f.
			rename pointed_fun into pf; rename point_eq into pe.
			unfold pMap_to_Map. simpl.

			simpl in pe. unfold point in pe at 1.
			unfold Map_to_pMap.

	Admitted. (*TODO*)

	Lemma twotoA_is_A {A:pType} : (two_pts ->* A) <~> A.
		(*TODO: Find result on  Unit->A <~> A  *)
	Admitted.
End Two_points.

(*Results on the relation between smash product and spheres.*)
Section Smash_and_Spheres.

	Definition sph0xA_to_A {A:pType} : A*(Sphere 0) -> A.
		intro p; elim p.
		intro a.
		exact (Susp_rec (point A) (a) (Empty_rec)).
	Defined.

	Definition smashpush' {A:pType} : A*(pSphere 0) + pUnit -> A.
		intro x; elim x.
			-exact sph0xA_to_A.
			-exact (pconst _ _).
	Defined.

	Definition f {A:pType} := fun w : A+pSphere 0 =>
		sph0xA_to_A (wedge_in_product (@wedgepush A (pSphere 0) w)).
	Definition g {A:pType} := fun _ : A+pSphere 0 => point A.

	Definition welldefined {A:pType} : forall w : A + pSphere 0,
		f w = g w.

		apply sum_ind.
			-intro a. exact idpath.
			-apply (@Susp_ind Empty _ idpath idpath); apply Empty_ind.
	Defined.

	Definition smash_A_to_A  {A:pType} : smash A (pSphere 0)  -> A.
		refine (pushout_rec _ smashpush' _).
		refine (pushout_ind _ _ _ welldefined _).
			simpl.
			intro a; destruct a.
			unfold const at 11.

			Check (transport_paths_FlFr (pp tt) idpath).

(* 			equiv_via (((ap (@f A)) idpath)^ @ idpath) @ ap g (pp tt). *)

			unfold wedge_in_product.
			unfold sum_to_product.
			simpl.

			unfold wedge_in_product.
			unfold sph0xA_to_A.
			simpl.

			admit.
	Admitted.

	Definition A_to_smash_A {A:pType} : A->smash A (pSphere 0) :=
		fun a:A => @smashpush A (pSphere 0) (inl (a,South)).

	Definition ispointed_A_to_smash_A {A:pType} :
		A_to_smash_A (point A) = point (smash A (pSphere 0)) :=
			pp (@wedgepush A (pSphere 0) (inr South)).

	Lemma isretr {A:pType} : Sect (@A_to_smash_A A) (@smash_A_to_A A).
		Admitted.

	Lemma issect {A:pType} : Sect (@smash_A_to_A A) (@A_to_smash_A A).
		Admitted.

	Lemma isequiv_A_to_smash_A {A:pType} : IsEquiv (@A_to_smash_A A).
		refine (BuildIsEquiv _ _ A_to_smash_A smash_A_to_A issect isretr _).
		Admitted.

	Lemma is_pequiv_A_smash_A (A:pType) : A <~>* smash A (pSphere 0).
		refine (Build_pEquiv _ _
			(Build_pMap _ _ (@A_to_smash_A A) ispointed_A_to_smash_A)
			_).
		exact isequiv_A_to_smash_A.
	Qed.

	Lemma commute_smash_susp {A B:pType} : smash (psusp A) B <~>* psusp (smash A B).
	Admitted.

End Smash_and_Spheres.

Section Loops.
	(*Define Omega n A as pointed maps from the n-sphere*)
	Definition Omega (n:nat) (A:pType) :pType :=
		Build_pType (pMap (pSphere n) A) _.

Lemma Omega0_Equiv_A {A:pType} : Omega 0 A <~> A.
		cut ( (pSphere 0 ->* A) <~> (two_pts ->* A) ).
			-intro f.
			equiv_via (two_pts ->* A).
				exact f.
				exact twotoA_is_A.
			-
			(*TODO*)
			(* exact (equiv_compose addpt_forget_adjoint f).

			exact ( functor_arrow pBool_to_two_pts idmap ).
	 *)
	Admitted.

	(*This should be equivalent to the loop space in the library*)
	Theorem omega_loops_equiv `{Funext} : forall n:nat, forall A:pType,
		Omega n A <~> iterated_loops n A.
		induction n.
			-intro A. exact Omega0_Equiv_A.
			-intro A.
			equiv_via (pSphere n ->* loops A).
				+apply loop_susp_adjoint.
				+exact (IHn (loops A) ).
	Qed.

	(*TODO*) Theorem omega_loops_peq `{Funext} :forall n:nat, forall A:pType,
		Omega n A <~>* iterated_loops n A. Abort.

End Loops.

Section homotopy_groups.

Definition homotopy_group (n:nat) (A:pType) :pType :=
	pTr 0 (Omega n A).

Notation "'HtGr'" := homotopy_group.

Definition SphereToOmega_functor {m n:nat} (f:pSphere m ->* pSphere n) (A:pType) :
	Omega n A ->* Omega m A.

	refine (Build_pMap _ _ _ _).
	(*Define the map*)
	* intro h. exact (h o* f).
	(*Prove that it is pointed map.*)
	* apply const_comp.
Defined.

Definition OmegaToHtGr_functor {m n : nat} {A:pType} (f : Omega n A ->* Omega m A) :
	HtGr n A ->* HtGr m A.

	refine (Build_pMap _ _ _ _).
	(*Construct map*)
	*apply Trunc_rec.
	intro loop.
	apply tr.
	exact (f loop).
	(*Show that it is pointed.*)
	*apply (ap tr).
	rewrite (point_eq f).
	reflexivity.
Defined.

Definition SphereToHtGr_functor {m n : nat} (f:pSphere m ->* pSphere n) (A:pType) :
	HtGr n A ->* HtGr m A :=
		OmegaToHtGr_functor (SphereToOmega_functor f A).

End homotopy_groups.

(*Stuff that probably should be removed:*)

(*Alternative definition to Omega. Should be possible to show that these are equivalent.*)
Fixpoint Omega' (n:nat) (A:pType) : pType :=
	match n with
		|O => A
		|S n => Build_pType (point A = point A) idpath
	end.

Definition pSph0_to_Bool : pSphere 0 ->* pBool.
	refine (Build_pMap _ _ _ _).
			-exact Sph0_to_Bool.
			-reflexivity.
Defined.

Lemma isequiv_pSph0_to_Bool : IsEquiv pSph0_to_Bool.
	exact isequiv_Sph0_to_Bool.
Qed.

(* Definition sph0map_to_boolmap {A:pType} : (pBool -> A) -> (pSphere 0 -> A)
	 := functor_arrow pSph0_to_Bool idmap.

Lemma isEquiv_sph0mapToBoolmap `{Funext} {A:pType} : IsEquiv (@sph0map_to_boolmap A).
	apply isequiv_functor_arrow.
Qed. *)

Lemma equiv_sph0pMap_boolpMap `{Funext} {A:pType} : (pBool ->* A) <~> (pSphere 0 ->* A).
	refine (BuildEquiv _ _ _ _).
		*intro f.
		refine (Build_pMap _ _ _ _).
			-exact (sph0mapToBoolmap f).
			-(* cbn. *)
			unfold sph0mapToBoolmap.
			unfold functor_arrow.
			unfold functor_forall.
			rewrite (point_eq pSph0ToBool).
			exact (point_eq f).
		*refine (BuildIsEquiv _ _ _ _).

(* Lemma pIsEquiv_Sph0ToBool : IsEquiv pSph0ToBool.
	exact isequiv_Sph0_to_Bool.
Defined. *)

(*Construct map equivalence between omega and iterated loops (base case)*)

Definition f {A:pType} : Omega 0 A -> A.
	intro h.
	exact (h South).
Defined.

Definition g {A:pType} : A -> Omega 0 A.
	intro a.
	unfold Omega.
	refine (Build_pMap _ _ _ _).
		(*Construct map from S^0 to A. North is mapped to point A, South is mapped to a.*)
		*transparent assert (bin : (Bool -> A)).
			intro b.
			exact match b with
				|true => point A
				|false => a
			end.
		exact (bin o pSph0ToBool).
		*reflexivity.
Defined.

Lemma Omega0_Equiv_A {A:pType} : Omega 0 A <~> A.
	refine (BuildEquiv _ _ _ _).
		*exact f.
		*refine (BuildIsEquiv  _ _ _ _ _ _ _).
			-exact g.
			-unfold Sect. reflexivity. (*fg==id*)
			-unfold Sect. (*gf==id*)
			intro h.

			unfold Omega.
			intro h.
			unfold f.
			unfold g.
			intro x; elim x; intros h p; clear x.
			simpl.
			unfold g.
			unfold point at 1 in p. simpl in p.

Theorem omega_loops_equiv `{Funext} : forall n:nat, forall A:pType,
	Omega n A <~> iterated_loops n A.
	intros n A.
	induction n.
	(*Base case*)
		*refine (BuildEquiv _ _ _ _).
			(*Construct equivalence*)
			-simpl.
			intro f.
			exact (f South).
			(*Show that it is an equivalence*)
			-refine (BuildIsEquiv  _ _ _ _ _ _ _).
				(*Construct inverse*)
				+simpl.
				intro a.
				refine (Build_pMap _ _ _ _).
				transparent assert (g : (Susp Empty -> A)).
					intro x.
					exact (match x with
						|North => point A
						|South => a
					end ).


(*|
#############################################
Prove that the only zero-length vector is nil
#############################################

:Link: https://stackoverflow.com/q/47945424
|*)

(*|
Question
********

I have a type defined as
|*)

Inductive bits : nat -> Set :=
| bitsNil : bits 0
| bitsCons : forall {l}, bool -> bits l -> bits (S l).

(*| and I'm trying to prove: |*)

Lemma emptyIsAlwaysNil : forall {a: bits 0}, a = bitsNil.

(*|
After ``intros``, I've tried ``constructor 1``, ``case a``,
``intuition``, to no avail. ``case a`` seems like the closest, but it
gets an error:
|*)
  intros. (* .none *) Fail case a. (* .unfold .messages *)
Abort. (* .none *)

(*|
It sounds like it can't determine whether a bit-vector of an arbitrary
length is equal to one of zero-length, because they're different at
the type level. Is that correct?
|*)

(*|
Answer (Tej Chajed)
*******************

Yes, you're basically correct: specifically, what isn't type checking
is Coq's attempt to construct a ``match`` on ``a:bits 0`` (which is
what ``case`` does): the ``bitsCons`` case has an ill-typed
conclusion.

Here's an axiom-free proof. The key idea is to manually generalize the
statement to any ``n = 0`` (I couldn't figure out how to do this with
tactics; they all trip up on the dependency). The equality proof then
makes the conclusion type check regardless of what ``n`` is, and we
can dismiss the ``bitsCons`` case because we'll have ``n = S n'``. In
the more difficult ``bitsNil`` case, we make use of
``eq_rect_eq_dec``, which is a consequence of Axiom K but is provable
when the type index (``nat``, in this case) has decidable equality.
See the `Coq standard library documentation
<https://coq.inria.fr/library/Coq.Logic.Eqdep_dec.html>`__ for some
other things you can do without axioms with decidable equality.
|*)

Reset Initial. (* .none *)
Require PeanoNat.
Require Import Eqdep_dec.
Import EqNotations.

Inductive bits : nat -> Set :=
| bitsNil : bits 0
| bitsCons : forall {l}, bool -> bits l -> bits (S l).

Lemma emptyIsAlwaysNil_general :
  forall n (H: n = 0) {a: bits n}, rew [bits] H in a = bitsNil.
Proof.
  intros. induction a; simpl.
  - (* bitsNil *)
    rewrite <- eq_rect_eq_dec. auto.
    apply PeanoNat.Nat.eq_dec.
  - (* bitsCons - derive a contradiction *)
    exfalso; discriminate H.
Qed.

Lemma emptyIsAlwaysNil : forall {a: bits 0}, a = bitsNil.
Proof.
  intros.
  change a with (rew [bits] eq_refl in a).
  apply emptyIsAlwaysNil_general.
Qed.

(*|
You don't need the ``rew H in x`` notation from ``EqNotations`` (it
just wraps ``eq_rect``, the equality recursion principle), but I find
it makes things much more readable.

However, you can prove this theorem more simply if you're willing to
use an axiom, specifically ``JMeq_eq`` (see `CPDT's equality chapter
<http://adam.chlipala.net/cpdt/html/Equality.html>`__ for more
details), since then you can use ``dependent induction`` or
``dependent destruction``:
|*)

Reset Initial. (* .none *)
Require Import Program.Equality.

Inductive bits : nat -> Set :=
| bitsNil : bits 0
| bitsCons : forall {l}, bool -> bits l -> bits (S l).

Lemma emptyIsAlwaysNil : forall {a: bits 0}, a = bitsNil.
Proof.
  intros. dependent destruction a; reflexivity.
Qed.

Print Assumptions emptyIsAlwaysNil. (* .unfold *)

(*|
Answer (Anton Trunov)
*********************

Here is a simple proof (borrowed from `this Coq Club thread
<http://coq-club.inria.narkive.com/wrDwvaNY/how-to-prove-that-all-vectors-of-0-length-are-equal-to-vector-nil>`__):
|*)

Reset emptyIsAlwaysNil. (* .none *)
Definition emptyIsAlwaysNil {a: bits 0} : a = bitsNil :=
  match a with bitsNil => eq_refl end.

Opaque emptyIsAlwaysNil.

(*| Here is what Coq builds under the hood: |*)

Print emptyIsAlwaysNil. (* .unfold *)

(*|
----

**A:** Reminds me of Monin's small inversions:
`hal.archives-ouvertes.fr/inria-00489412
<https://hal.archives-ouvertes.fr/inria-00489412/>`__
|*)


Require Import ZArith.
Require Import Classical.
Require Export Reals.

(* real numbers *)

Lemma real_expr: (0 <= 9 * 4)%R.
ergo.
Qed.

Lemma powerRZ_translation: (powerRZ 2 15 < powerRZ 2 17)%R.
ergo.
Qed.

Dp_debug.
Dp_timeout 3.

(* module renamings *)

Module M.
  Parameter t : Set.
End M.

Lemma test_module_0 : forall x:M.t, x=x.
ergo.
Qed.

Module N := M.

Lemma test_module_renaming_0 : forall x:N.t, x=x.
ergo.
Qed.

Dp_predefined M.t => "int".

Lemma test_module_renaming_1 : forall x:N.t, x=x.
ergo.
Qed.

(* Coq lists *)

Require Export List.

Lemma test_pol_0 : forall l:list nat, l=l.
ergo.
Qed.

Parameter nlist: list nat -> Prop.

Lemma poly_1 : forall l,  nlist l -> True.
intros.
simplify.
Qed.

(* user lists *)

Inductive list (A:Set) : Set :=
| nil : list A
| cons: forall a:A, list A -> list A.

Fixpoint app (A:Set) (l m:list A) {struct l} : list A :=
match l with
| nil => m
| cons a l1 => cons A a (app A l1 m)
end.

Lemma entail: (nil Z) = app Z (nil Z) (nil Z) -> True.
intros; ergo.
Qed.

(* polymorphism *)
Require Import List.

Inductive mylist (A:Set) : Set :=
  mynil : mylist A
| mycons : forall a:A, mylist A -> mylist A.

Parameter my_nlist: mylist nat -> Prop.

 Goal forall l,  my_nlist l -> True.
 intros.
 simplify.
Qed.

(* First example with the 0 and the equality translated *)

Goal 0 = 0.
simplify.
Qed.

(* Examples in the Propositional Calculus
   and theory of equality *)

Parameter A C : Prop.

Goal A -> A.
simplify.
Qed.

Goal A -> (A \/ C).

simplify.
Qed.

Parameter x y z : Z.

Goal x = y -> y = z -> x = z.
ergo.
Qed.

Goal ((((A -> C) -> A) -> A) -> C) -> C.

ergo.
Qed.

(* Arithmetic *)
Open Scope Z_scope.

Goal 1 + 1 = 2.
yices.
Qed.

Goal 2*x + 10 = 18 -> x = 4.

simplify.
Qed.

(* Universal quantifier *)

Goal (forall (x y : Z), x = y) -> 0=1.
try zenon.
ergo.
Qed.

Goal forall (x: nat), (x + 0 = x)%nat.

induction x0; ergo.
Qed.

(* No decision procedure can solve this problem
  Goal forall (x a b : Z), a * x + b = 0 -> x = - b/a.
*)

(* Functions definitions *)

Definition fst (x y : Z) : Z := x.

Goal forall (g : Z -> Z) (x y : Z), g (fst x y) = g x.

simplify.
Qed.

(* Eta-expansion example *)

Definition snd_of_3 (x y z : Z) : Z := y.

Definition f : Z -> Z -> Z := snd_of_3 0.

Goal forall (x y z z1 : Z), snd_of_3 x y z = f y z1.

simplify.
Qed.

(* Inductive types definitions - call to dp/injection function *)

Inductive even : Z -> Prop :=
| even_0 : even 0
| even_plus2 : forall z : Z, even z -> even (z + 2).

(* Simplify and Zenon can't prove this goal before the timeout
   unlike CVC Lite *)

Goal even 4.
ergo.
Qed.

Definition skip_z (z : Z) (n : nat) := n.

Definition skip_z1 := skip_z.

Goal forall (z : Z) (n : nat), skip_z z n = skip_z1 z n.
yices.
Qed.

(* Axioms definitions and dp_hint *)

Parameter add : nat -> nat -> nat.
Axiom add_0 : forall (n : nat), add 0%nat n = n.
Axiom add_S : forall (n1 n2 : nat), add (S n1) n2 = S (add n1 n2).

Dp_hint add_0.
Dp_hint add_S.

(* Simplify can't prove this goal before the timeout
   unlike zenon *)

Goal forall n : nat, add n 0 = n.
induction n ; yices.
Qed.

Definition pred (n : nat) : nat := match n with
  | 0%nat => 0%nat
  | S n' => n'
end.

Goal forall n : nat, n <> 0%nat -> pred (S n) <> 0%nat.
yices.
(*zenon.*)
Qed.

Fixpoint plus (n m : nat) {struct n} : nat :=
  match n with
  | 0%nat => m
  | S n' => S (plus n' m)
end.

Goal forall n : nat, plus n 0%nat = n.

induction n; ergo.
Qed.

(* Mutually recursive functions *)

Fixpoint even_b (n : nat) : bool := match n with
  | O => true
  | S m => odd_b m
end
with odd_b (n : nat) : bool := match n with
  | O => false
  | S m => even_b m
end.

Goal even_b (S (S O)) = true.
ergo.
(*
simplify.
zenon.
*)
Qed.

(* sorts issues *)

Parameter foo : Set.
Parameter ff : nat -> foo -> foo -> nat.
Parameter g : foo -> foo.
Goal (forall x:foo, ff 0 x x = O) -> forall y, ff 0 (g y) (g y) = O.
yices.
(*zenon.*)
Qed.

(* abstractions *)

Parameter poly_f : forall A:Set, A->A.

Goal forall x:nat, poly_f nat x = poly_f nat x.
ergo.
(*zenon.*)
Qed.

(* Anonymous mutually recursive functions : no equations are produced

Definition mrf :=
  fix even2 (n : nat) : bool := match n with
    | O => true
    | S m => odd2 m
  end
  with odd2 (n : nat) : bool := match n with
    | O => false
    | S m => even2 m
  end for even.

   Thus this goal is unsolvable

Goal mrf (S (S O)) = true.

zenon.

*)


From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
From Coq Require Import ssrfun Classical Utf8.
Require Export AutosubstSsr ARS.

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

Inductive term : Type :=
| Var (x : var)
| Lam (m : {bind term})
| App (m n : term).

Instance Ids_term : Ids term. derive. Defined.
Instance Rename_term : Rename term. derive. Defined.
Instance Subst_term : Subst term. derive. Defined.
Instance substLemmas_term : SubstLemmas term. derive. Qed.

Inductive clo : Type :=
| Clo : term -> list (option clo) -> clo.

Definition env : Type := list (option clo).
Definition stack : Type := list clo.
Definition konfig : Type := term * env * stack.

Notation "m ::: ms" := (Some m :: ms) (right associativity, at level 30).

Inductive step : term -> term -> Prop :=
| step_app m m' n :
  step m m' ->
  step (App m n) (App m' n)
| step_beta m n :
  step (App (Lam m) n) m.[n/].

Inductive kam : konfig -> konfig -> Prop :=
| kam_lam m e c s :
  kam (Lam m, e, c :: s) (m, c ::: e, s)
| kam_app m n e s :
  kam (App m n, e, s) (m, e, Clo n e :: s)
| kam_var x e e' m s :
  nth None e x = Some (Clo m e') ->
  kam (Var x, e, s) (m, e', s).

Notation sred := (star step).
Notation kred := (star kam).

Ltac step_simpl1 :=
  match goal with
  | [ |- step (App (Lam _) _) _ ] => apply step_beta
  | [ |- step (App _ _) _ ] => apply step_app
  end.
Ltac step_simpl := repeat (progress step_simpl1).
Ltac step_solve :=
  repeat (eauto; match goal with
                 | [ |- sred _ _ ] =>
                     eapply star_trans;[apply star1; step_simpl|asimpl]
                 end).

Ltac kam_simpl := try eapply star_trans; [eapply star1; solve[constructor; asimpl; eauto]|asimpl].
Ltac kam_solve := repeat progress (kam_simpl; eauto).

Example step_ex1 :
  sred (App (Lam (Var 0)) (Lam (Var 0))) (Lam (Var 0)).
Proof. step_solve. Qed.

Example kam_ex1 :
  kred (App (Lam (Var 0)) (Lam (Var 0)), nil, nil) (Lam (Var 0), nil, nil).
Proof. kam_solve. Qed.

Example step_ex2 :
  sred (App (App (Lam (Lam (Var 1))) (Lam (Var 0))) (Var 2)) (Lam (Var 0)).
Proof. step_solve. Qed.

Example kam_ex2 :
  kred (App (App (Lam (Lam (Var 1))) (Lam (Var 0))) (Var 2), nil, nil) (Lam (Var 0), nil, nil).
Proof. kam_solve. Qed.

Example step_ex3 :
  sred (App (Lam (Lam (Var 1))) (Lam (Var 0))) (Lam (Lam (Var 0))).
Proof. step_solve. Qed.

Example kam_ex3 :
  kred (App (Lam (Lam (Var 1))) (Lam (Var 0)), nil, nil)
       (Lam (Var 1), Clo (Lam (Var 0)) nil ::: nil, nil).
Proof. kam_solve. Qed.

Example step_ex4 :
  sred (App (Lam (Lam (App (Var 5) (Var 1)))) (Var 7)) (Lam (App (Var 4) (Var 8))).
Proof. step_solve. Qed.

Example kam_ex4 :
  kred (App (Lam (Lam (App (Var 5) (Var 1)))) (Var 7), nil, nil)
       (Lam (App (Var 5) (Var 1)), Clo (Var 7) [::] ::: [::], [::]).
Proof. kam_solve. Qed.

Inductive resolve_env : env -> (var -> term) -> Prop :=
| resolve_env_nil :
  resolve_env nil ids
| resolve_some n e e' σ σ' :
  resolve_env e σ ->
  resolve_env e' σ' ->
  resolve_env (Clo n e' ::: e) (n.[σ'] .: σ)
| resolve_none x e σ :
  resolve_env e σ ->
  resolve_env (None :: e) (x .: σ).

Inductive resolve_stack : term -> stack -> term -> Prop :=
| resolve_stack_nil m : resolve_stack m nil m
| resolve_cons m m' n e σ s :
  resolve_env e σ ->
  resolve_stack (App m n.[σ]) s m' ->
  resolve_stack m (Clo n e :: s) m'.

Inductive resolve : term -> env -> stack -> term -> Prop :=
| Resolve x y e s σ :
  resolve_env e σ ->
  resolve_stack x.[σ] s y ->
  resolve x e s y.

Inductive shift : term -> env -> term -> Prop :=
| shift_nil m e σ :
  resolve_env e σ ->
  shift m e m.[σ]
| shift_cons m m' n σ' e e' :
  resolve_env e' σ' ->
  shift (Lam m) e m' ->
  shift m (Clo n e' ::: e) (App m' n.[σ']).

Example res_ex1 :
  resolve (Lam (Var 1)) (Clo (Lam (Var 0)) nil ::: nil) nil (Lam (Lam (Var 0))).
Proof.
  econstructor.
  constructor.
  constructor.
  constructor.
  asimpl.
  constructor.
Qed.

Example res_ex2 :
  resolve (Lam (Lam (Var 1))) nil (Clo (Lam (Var 0)) nil :: nil) (App (Lam (Lam (Var 1))) (Lam (Var 0))).
Proof.
  econstructor.
  constructor.
  asimpl.
  replace (Lam (Var 0)) with (Lam (Var 0)).[ids] by autosubst.
  econstructor.
  constructor.
  constructor.
Qed.

Example res_ex3 :
  resolve (Lam (App (Var 5) (Var 1))) (Clo (Var 7) [::] ::: [::]) [::] (Lam (App (Var 4) (Var 8))).
Proof.
  econstructor.
  constructor.
  econstructor.
  econstructor.
  asimpl.
  constructor.
Qed.

Lemma resolve_refl m : resolve m nil nil m.
Proof.
  econstructor.
  constructor.
  asimpl.
  constructor.
Qed.

Lemma shift_resolve m m' e :
  shift m e m' -> exists x, resolve m e nil x /\ sred m' x.
Proof with eauto.
  elim=>{m e m'}.
  { move=>m e σ rs. exists m.[σ]. split...
    econstructor...
    constructor. }
  { move=>m m' n σ' e e' rs1 sh[x[rs2 rd]]. inv rs2.
    inv H0. asimpl in rd.
    exists (m.[up σ]).[n.[σ']/]. split.
    econstructor.
    constructor...
    asimpl. constructor.
    apply: star_trans.
    apply: (star_hom (App^~ n.[σ'])) rd=>x y.
    apply: step_app.
    apply: star1.
    apply: step_beta. }
Qed.

Lemma resolve_stack_shift m m' n e s :
  resolve_stack m' s n -> shift m e m' ->
  exists x, resolve m e s x /\ sred n x.
Proof with eauto.
  move=>rs/shift_resolve[x[rs' rd]]. inv rs'. inv H0.
  elim: rs m e σ rd H=>{m' s n}.
  { move=>m m0 e σ rd rs. exists m0.[σ]. split...
    econstructor...
    econstructor. }
  { move=>m m' n e σ s rs1 rs2 ih m0 e0 σ0 rd rs3.
    assert (sred (App m n.[σ]) (App m0.[σ0] n.[σ]).[ids]).
    { asimpl. apply: star_trans.
      apply: (star_hom (App^~ n.[σ])) rd=>x y.
      apply: step_app.
      eauto. }
    have[x[rs rdx]]:=ih _ _ _ H (resolve_env_nil).
    inv rs. inv H0. asimpl in H1.
    exists x. split...
    econstructor...
    econstructor... }
Qed.

Lemma resolve_stack_ok m n n' e e' σ σ' s :
  resolve_stack (App (Lam m.[up σ]) n'.[σ']) s n ->
  resolve_env e σ -> resolve_env e' σ' ->
  exists x, resolve m (Clo n' e' ::: e) s x /\ sred n x.
Proof with eauto.
  intros.
  apply: resolve_stack_shift...
  constructor...
  replace (Lam m.[up σ]) with (Lam m).[σ] by autosubst.
  constructor...
Qed.

Lemma resolve_env_ok e e' x m σ :
  resolve_env e σ ->
  nth None e x = Some (Clo m e') ->
  exists σ', resolve_env e' σ' /\ σ x = m.[σ'].
Proof with eauto.
  move=>rs. elim: rs e' x m=>{e σ}.
  { move=>e' [|x] m//=eq. }
  { move=>n e e' σ σ' rs1 ih1 rs2 ih2 e'0 [|x] m//=eq...
    inv eq. exists σ'. split... }
  { move=>x e σ rs ih e' [|n] m//=eq.
    have[σ'[rs' eq']]:=ih _ _ _ eq.
    exists σ'. split... }
Qed.

Lemma kam_step m m' n e e' s s' :
  kam (m, e, s) (m', e', s') -> resolve m e s n -> exists n', resolve m' e' s' n' /\ sred n n'.
Proof with eauto using resolve, step.
  move e1:(m, e, s)=>x.
  move e2:(m', e', s')=>y km.
  elim: km m m' n e e' s s' e1 e2=>{x y}.
  { move=>m e c s m0 m' n e0 e' s0 s'[e1 e2 e3][e4 e5 e6]rs; subst. inv rs.
    asimpl in H0. inv H0.
    apply: resolve_stack_ok... }
  { move=>m n e s m0 m' n0 e0 e' s0 s'[e1 e2 e3][e4 e5 e6]rs; subst. inv rs.
    asimpl in H0.
    exists n0. split...
    econstructor...
    econstructor... }
  { move=>x e e' m s eq m0 m' n e0 e'0 s0 s'[e1 e2 e3][e4 e5 e6]rs; subst. inv rs.
    asimpl in H0.
    have[σ'[rs' eq']]:=resolve_env_ok H eq.
    rewrite eq' in H0.
    exists n. split... }
Qed.


Require Import Arith.
Require Import List.
Import ListNotations.
Require Import Omega.

Require Import v1.NeutronTactics.
Require Import v1.Util.

Require Import v1.Multi.
Require Import v1.ListLemmas.

Set Default Timeout 5.

Fixpoint MForall' {n} {A : Set} (P : A -> Prop) : multi' n A -> Prop :=
    match n as n_ return multi' n_ A -> Prop with
    | 0 => fun m =>
            let x := m in
            P m
    | S n => fun m =>
            let '(m', x) := m in
            MForall' P m' /\ P x
    end.

Definition MForall {n} {A : Set} (P : A -> Prop) : multi n A -> Prop :=
    match n as n_ return multi n_ A -> Prop with
    | 0 => fun _ => True
    | S n' => MForall' P
    end.

Lemma rep_MForall' : forall n (A : Set) (P : A -> Prop) v,
    P v ->
    MForall' P (multi'_rep n v).
induction n; intros0 Hv.
- assumption.
- constructor; eauto.
Qed.

Lemma MForall'_get : forall n (A : Set) (P : A -> Prop) (x : multi' n A) i,
    MForall' P x ->
    P (multi'_get x i).
induction n; intros0 Hfa.
- destruct i as [i' Hlt]. destruct i'; try solve [exfalso; omega].
  simpl. assumption.
- destruct i as [i' Hlt].
  simpl. break_match.
  + destruct x. destruct Hfa. auto.
  + destruct x. destruct Hfa. simpl.
    eapply IHn. eassumption.
Qed.

Lemma set_MForall' : forall n (A : Set) (P : A -> Prop) (x : multi' n A) i v,
    MForall' P x ->
    P v ->
    MForall' P (multi'_set x i v).
induction n; intros0 Hfa Hv.
- destruct i as [i' Hlt]. destruct i'; try solve [exfalso; omega].
  simpl. assumption.
- destruct i as [i' Hlt].
  simpl. break_match. break_match.
  + destruct x, Hfa. simpl in *. inject_pair. auto.
  + destruct x, Hfa. simpl in *. inject_pair. auto.
Qed.

Definition MForall'_dec : forall n (A : Set) (P : A -> Prop) (x : multi' n A),
    (forall v, { P v } + { ~ P v }) ->
    { MForall' P x } + { ~ MForall' P x }.
induction n; intros0 P_dec.
- eapply P_dec.
- destruct x as [x' v].
  destruct (P_dec v); cycle 1.
    { right. inversion 1. auto. }
  destruct (IHn _ _ x' P_dec); cycle 1.
    { right. inversion 1. auto. }
  left. constructor; eauto.
Defined.

Lemma rep_MForall : forall n (A : Set) (P : A -> Prop) v,
    P v ->
    MForall P (multi_rep n v).
destruct n.
- intros. constructor.
- eapply rep_MForall'.
Qed.

Lemma MForall_get : forall n (A : Set) (P : A -> Prop) (x : multi n A) i,
    MForall P x ->
    P (multi_get x i).
destruct n.
- intros. destruct i. exfalso. omega.
- eapply MForall'_get.
Qed.

Lemma set_MForall : forall n (A : Set) (P : A -> Prop) (x : multi n A) i v,
    MForall P x ->
    P v ->
    MForall P (multi_set x i v).
destruct n.
- intros. constructor.
- eapply set_MForall'.
Qed.

Definition MForall_dec : forall n (A : Set) (P : A -> Prop) (x : multi n A),
    (forall v, { P v } + { ~ P v }) ->
    { MForall P x } + { ~ MForall P x }.
destruct n.
- intros. left. constructor.
- eapply MForall'_dec.
Defined.

Fixpoint MForall2' {n} {A B : Set} (P : A -> B -> Prop) : multi' n A -> multi' n B -> Prop :=
    match n as n_ return multi' n_ A -> multi' n_ B -> Prop with
    | 0 => fun x y =>
            let xv := x in
            let yv := y in
            P xv yv
    | S n => fun x y =>
            let '(x', xv) := x in
            let '(y', yv) := y in
            MForall2' P x' y' /\ P xv yv
    end.

Definition MForall2 {n} {A B : Set} (P : A -> B -> Prop) : multi n A -> multi n B -> Prop :=
    match n as n_ return multi n_ A -> multi n_ B -> Prop with
    | 0 => fun _ _ => True
    | S n' => MForall2' P
    end.

Lemma rep_MForall2' : forall n (A B : Set) (P : A -> B -> Prop) xv yv,
    P xv yv ->
    MForall2' P (multi'_rep n xv) (multi'_rep n yv).
induction n; intros0 Hv.
- assumption.
- constructor; eauto.
Qed.

Lemma MForall2'_get : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi' n A) (y : multi' n B) i,
    MForall2' P x y ->
    P (multi'_get x i) (multi'_get y i).
induction n; intros0 Hfa.
- destruct i as [i' Hlt]. destruct i'; try solve [exfalso; omega].
  simpl. assumption.
- destruct i as [i' Hlt].
  simpl. break_match.
  + destruct x, y, Hfa. auto.
  + destruct x, y, Hfa.  eapply IHn. eassumption.
Qed.

Lemma set_MForall2' : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi' n A) (y : multi' n B) i xv yv,
    MForall2' P x y ->
    P xv yv ->
    MForall2' P (multi'_set x i xv) (multi'_set y i yv).
induction n; intros0 Hfa Hv.
- destruct i as [i' Hlt]. destruct i'; try solve [exfalso; omega].
  simpl. assumption.
- destruct i as [i' Hlt].
  simpl. do 3 break_match.
  + destruct x, y, Hfa. simpl in *. inject_pair. auto.
  + destruct x, y, Hfa. simpl in *. inject_pair. auto.
Qed.

Definition MForall2'_dec : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi' n A) (y : multi' n B),
    (forall xv yv, { P xv yv } + { ~ P xv yv }) ->
    { MForall2' P x y } + { ~ MForall2' P x y }.
induction n; intros0 P_dec.
- eapply P_dec.
- destruct x as [x' xv], y as [y' yv].
  destruct (P_dec xv yv); cycle 1.
    { right. inversion 1. auto. }
  destruct (IHn _ _ _ x' y' P_dec); cycle 1.
    { right. inversion 1. auto. }
  left. constructor; eauto.
Defined.

Lemma rep_MForall2 : forall n (A B : Set) (P : A -> B -> Prop) xv yv,
    P xv yv ->
    MForall2 P (multi_rep n xv) (multi_rep n yv).
destruct n.
- intros. constructor.
- eapply rep_MForall2'.
Qed.

Lemma MForall2_get : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi n A) (y : multi n B) i,
    MForall2 P x y ->
    P (multi_get x i) (multi_get y i).
destruct n.
- intros. destruct i. exfalso. omega.
- eapply MForall2'_get.
Qed.

Lemma set_MForall2 : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi n A) (y : multi n B) i xv yv,
    MForall2 P x y ->
    P xv yv ->
    MForall2 P (multi_set x i xv) (multi_set y i yv).
destruct n.
- intros. constructor.
- eapply set_MForall2'.
Qed.

Definition MForall2_dec : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi n A) (y : multi n B),
    (forall xv yv, { P xv yv } + { ~ P xv yv }) ->
    { MForall2 P x y } + { ~ MForall2 P x y }.
destruct n.
- intros. left. constructor.
- eapply MForall2'_dec.
Defined.

Lemma multi'_to_list'_in_acc : forall n A (x : multi' n A) acc a,
    In a acc ->
    In a (multi'_to_list' n A x acc).
induction n; intros0 Hin; simpl in *.
- eauto.
- destruct x. simpl in *. eapply IHn. simpl. eauto.
Qed.

Lemma MForall'_list'_Forall : forall n (A : Set) (P : A -> Prop) (x : multi' n A) acc,
    Forall P acc ->
    MForall' P x <-> Forall P (multi'_to_list' n A x acc).
induction n; intros0 Hacc; simpl in *; split; intro HH.
- eauto.
- invc HH. eauto.
- break_match. break_and. simpl. rewrite <- IHn; eauto.
- break_match. simpl in *.
  assert (P a).
    { rewrite Forall_forall in HH. eapply HH.
      eapply multi'_to_list'_in_acc. simpl. eauto. }
  split; eauto.
  rewrite IHn; eauto.
Qed.

Lemma MForall'_Forall : forall n (A : Set) (P : A -> Prop) (x : multi' n A),
    MForall' P x <-> Forall P (multi'_to_list x).
intros. eapply MForall'_list'_Forall; eauto.
Qed.

Lemma MForall_Forall : forall n (A : Set) (P : A -> Prop) (x : multi n A),
    MForall P x <-> Forall P (multi_to_list x).
destruct n; intros.
- destruct x. simpl. intuition.
- simpl. eapply MForall'_Forall.
Qed.

Lemma multi'_to_list'_nth_error_acc : forall n A (x : multi' n A) acc i,
    i >= S n ->
    nth_error (multi'_to_list' n A x acc) i = nth_error acc (i - S n).
induction n; intros; simpl in *.
- destruct i; [ exfalso; omega | ]. simpl in *.
  replace (i - 0) with i by omega. reflexivity.
- destruct x. simpl in *.
  rewrite IHn.
  + replace (i - S n) with (S (i - S (S n))) by omega.
    simpl. reflexivity.
  + omega.
Qed.

Lemma MForall2'_list'_Forall2 : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi' n A) (y : multi' n B) acc1 acc2,
    Forall2 P acc1 acc2 ->
    MForall2' P x y <->
        Forall2 P (multi'_to_list' n A x acc1) (multi'_to_list' n B y acc2).
induction n; intros0 Hacc; simpl in *; split; intro HH.
- eauto.
- invc HH. eauto.
- do 2 break_match. break_and. simpl. rewrite <- IHn; eauto.
- do 2 break_match. simpl in *.
  assert (P a b).
    { eapply Forall2_nth_error with (i := S n); eauto.
      - erewrite multi'_to_list'_nth_error_acc; eauto.
        replace (S n - S n) with 0 by omega. reflexivity.
      - erewrite multi'_to_list'_nth_error_acc; eauto.
        replace (S n - S n) with 0 by omega. reflexivity. }
  split; eauto.
  rewrite IHn; eauto.
Qed.

Lemma MForall2'_Forall2 : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi' n A) (y : multi' n B),
    MForall2' P x y <-> Forall2 P (multi'_to_list x) (multi'_to_list y).
intros. eapply MForall2'_list'_Forall2; eauto.
Qed.

Lemma MForall2_Forall2 : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi n A) (y : multi n B),
    MForall2 P x y <-> Forall2 P (multi_to_list x) (multi_to_list y).
destruct n; intros.
- destruct x, y. simpl. intuition.
- simpl. eapply MForall2'_Forall2.
Qed.

Lemma MForall'_forall : forall n (A : Set) (P : A -> Prop) (x : multi' n A),
    MForall' P x <-> (forall i val, multi'_get x i = val -> P val).
induction n; intros.
- simpl.  assert (index 1) by (mk_index 0).
  split; intros; [ congruence | auto ].
- destruct x as [x val]. split; intros.
  + destruct i as [i Hlt]. on >@MForall', invc.
    unfold multi'_get; fold multi'_get. break_match; auto; simpl.
    rewrite IHn in *. on _, eapply_. reflexivity.
  + split.
    * rewrite IHn. intros.
      destruct i as [i Hlt].
      on _, eapply_.  unfold multi'_get. fold multi'_get.
      instantiate (1 := ltac:(mk_index i)). cbv iota beta. break_match; [ omega | ].
      simpl. erewrite multi'_get_eq; eauto.
    * on _, eapply_.
      instantiate (1 := ltac:(mk_index (S n))). simpl. break_match; try congruence.
Qed.

Lemma MForall_forall : forall n (A : Set) (P : A -> Prop) (x : multi n A),
    MForall P x <-> (forall i val, multi_get x i = val -> P val).
destruct n; intros.
- destruct x. simpl. intuition.  destruct i as [i Hlt]. omega.
- simpl. eapply MForall'_forall.
Qed.

Lemma MForall2'_forall : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi' n A) (y : multi' n B),
    MForall2' P x y <-> (forall i xv yv,
        multi'_get x i = xv ->
        multi'_get y i = yv ->
        P xv yv).
induction n; intros.
- simpl.  assert (index 1) by (mk_index 0).
  split; intros; [ congruence | auto ].
- destruct x as [x xv], y as [y yv]. split; intros.
  + destruct i as [i Hlt]. on >@MForall2', invc.
    unfold multi'_get; fold multi'_get. break_match; auto; simpl.
    rewrite IHn in *. on _, eapply_; reflexivity.
  + split.
    * rewrite IHn. intros.
      destruct i as [i Hlt].
      on _, eapply_;  unfold multi'_get; fold multi'_get.
      instantiate (1 := ltac:(mk_index i)).
      all: cbv iota beta; break_match; [ omega | ].
      all: simpl; erewrite multi'_get_eq; eauto.
    * on _, eapply_.
      instantiate (1 := ltac:(mk_index (S n))).
      all: simpl; break_match; try congruence.
Qed.

Lemma MForall2_forall : forall n (A B : Set) (P : A -> B -> Prop)
        (x : multi n A) (y : multi n B),
    MForall2 P x y <-> (forall i xv yv,
        multi_get x i = xv ->
        multi_get y i = yv ->
        P xv yv).
destruct n; intros.
- destruct x. simpl. intuition.  destruct i as [i Hlt]. omega.
- simpl. eapply MForall2'_forall.
Qed.