(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith.

From Undecidability.Shared.Libs.DLW
  Require Import utils_tac utils_nat pos vec.

From Undecidability.MuRec.Util
  Require Import recalg ra_utils recomp ra_recomp.

From Undecidability.H10.Dio
  Require Import dio_single.

Set Implicit Arguments.

Local Notation "'⟦' f '⟧'" := (@ra_rel _ f) (at level 0).

Section dio_poly.

  Variable (n m : nat).

  Fixpoint ra_dio_poly (p : dio_polynomial (pos n) (pos m)) : recalg (n+m).
  Proof.
    destruct p as [ c | i | x | [] p q ].
    + apply ra_cst_n, c.
    + apply ra_proj, pos_left, i.
    + apply ra_proj, pos_right, x.
    + apply ra_comp with (1 := ra_plus), (ra_dio_poly p##ra_dio_poly q##vec_nil).
    + apply ra_comp with (1 := ra_mult), (ra_dio_poly p##ra_dio_poly q##vec_nil).
  Defined.

  Fact ra_dio_poly_prim p : prim_rec (ra_dio_poly p).
  Proof.
    induction p as [ | | | [] ]; simpl; repeat (split; auto);
      intros j; analyse pos j; simpl; auto.
  Qed.

  Opaque ra_cst_n ra_plus ra_mult ra_inject ra_project ra_eq.

  Section ra_dio_poly_eval.

    Variable (v : vec nat (n+m)).

    Notation φ := (fun i => vec_pos v (pos_left _ i)).
    Notation ν := (fun i => vec_pos v (pos_right _ i)).

    Fact ra_dio_poly_val p : ⟦ra_dio_poly p⟧ v (dp_eval φ ν p).
    Proof.
      induction p as [ c | i | x | [] p Hp q Hq ]; simpl.
      + apply ra_cst_n_val.
      + cbv; auto.
      + cbv; auto.
      + exists (dp_eval φ ν p ## dp_eval φ ν q ## vec_nil); split.
        * apply ra_plus_val.
        * intros j; analyse pos j; simpl; auto.
      + exists (dp_eval φ ν p ## dp_eval φ ν q ## vec_nil); split.
        * apply ra_mult_val.
        * intros j; analyse pos j; simpl; auto.
    Qed.

    Variable (p q : dio_polynomial (pos n) (pos m)).

    Definition ra_dio_poly_eq : recalg (n+m).
    Proof using p q.
      apply ra_comp with (1 := ra_eq).
      refine (_##_##vec_nil); apply ra_dio_poly.
      + exact p.
      + exact q.
    Defined.

    Hint Resolve ra_dio_poly_prim : core.

    Fact ra_dio_poly_eq_prim : prim_rec ra_dio_poly_eq.
    Proof.
      simpl; split; auto.
      intros j; analyse pos j; auto.
    Qed.

    Fact ra_dio_poly_eq_val : { e | ⟦ra_dio_poly_eq⟧ v e /\ (e = 0 <-> dp_eval φ ν p = dp_eval φ ν q) }.
    Proof.
      destruct ra_eq_rel with (v := dp_eval φ ν p ## dp_eval φ ν q ## vec_nil) as (e & H1 & H2); simpl in H2.
      exists e; split; auto.
      simpl.
      exists (dp_eval φ ν p ## dp_eval φ ν q ## vec_nil); split; auto.
      intros i; analyse pos i; simpl; apply ra_dio_poly_val.
    Qed.

    Opaque ra_dio_poly_eq.

    Hint Resolve ra_dio_poly_eq_prim : core.

    Definition ra_dio_poly_test : recalg (S m).
    Proof using p q.
      apply ra_comp with (1 := ra_dio_poly_eq).
      apply vec_set_pos; intros i.
      destruct (pos_both _ _ i) as [ j | j ].
      + apply ra_comp with (1 := ra_project j), (ra_proj pos0 ## vec_nil).
      + apply ra_proj, pos_nxt, j.
    Defined.

    Fact ra_dio_poly_test_prim : prim_rec ra_dio_poly_test.
    Proof.
      simpl; split; auto.
      intros i.
      rewrite vec_pos_set.
      destruct (pos_both n m i).
      + simpl; split; auto.
        intros j; analyse pos j; simpl; auto.
      + simpl; auto.
    Qed.

    Fact ra_dio_poly_test_total : total ⟦ra_dio_poly_test⟧.
    Proof. apply prim_rec_tot, ra_dio_poly_test_prim. Qed.

  End ra_dio_poly_eval.

  Notation φ := (fun x w i => vec_pos (vec_app (project n x) w) (pos_left _ i)).
  Notation ν := (fun x w i => vec_pos (vec_app (project n x) w) (pos_right _ i)).

  Variable (p q : dio_polynomial (pos n) (pos m)).

  Fact ra_dio_poly_test_val x w : { e | ⟦ra_dio_poly_test p q⟧ (x##w) e /\ (e = 0 <-> dp_eval (φ x w) (ν x w) p
                                                                                = dp_eval (φ x w) (ν x w) q) }.
  Proof.
    destruct (ra_dio_poly_eq_val (vec_app (project n x) w) p q) as (e & H1 & H2).
    exists e; split; auto.
    exists (vec_app (project n x) w); split; auto.
    intros i; repeat rewrite vec_pos_set.
    generalize (pos_lr_both n m i).
    destruct (pos_both n m i) as [ j | j ]; intros Hj; subst i; simpl.
    * unfold vec_app; rewrite vec_pos_set, pos_both_left.
      exists (x##vec_nil); split.
      - apply ra_project_val.
      - intros k; analyse pos k; simpl; cbv; auto.
    * unfold vec_app; rewrite vec_pos_set, pos_both_right; reflexivity.
  Qed.

  Fact ra_dio_poly_test_rel v e : ⟦ra_dio_poly_test p q⟧ v e
                               -> e = 0 <-> dp_eval (φ (vec_head v) (vec_tail v))
                                                    (ν (vec_head v) (vec_tail v)) p
                                          = dp_eval (φ (vec_head v) (vec_tail v))
                                                    (ν (vec_head v) (vec_tail v)) q.
  Proof.
    vec split v with x; intros H; simpl vec_head; simpl vec_tail.
    destruct (ra_dio_poly_test_val x v) as (e' & H1 & H2).
    rewrite <- H2; clear H2.
    generalize (ra_rel_fun _ _ _ _ H H1); intros []; tauto.
  Qed.

  Opaque ra_dio_poly_test.

  Definition ra_dio_poly_find : recalg m.
  Proof using p q. apply ra_min, (ra_dio_poly_test p q). Defined.

  Lemma ra_dio_poly_find_rel w : (exists e, ⟦ra_dio_poly_find⟧ w e) <-> exists x, ⟦ra_dio_poly_test p q⟧ (x##w) 0.
  Proof.
    simpl; unfold s_min.
    apply μ_min_of_total.
    + intros ? ? ?; apply ra_rel_fun.
    + intros x; destruct (ra_dio_poly_test_val x w) as (e & ? & _).
      exists e; auto.
  Qed.

  Lemma ra_dio_poly_find_rel_strong1 w e : ⟦ra_dio_poly_find⟧ w e -> ⟦ra_dio_poly_test p q⟧ (e ##w) 0.
  Proof.
    simpl; unfold s_min.
    intros [H1 H2]. eauto.
  Qed.

  (* ra_dio_poly_find terminates on w iff some solution of p(w,x1,...,xn) = q(w,x1,...,xn) exists

      so termination of ra_dio_poly_find terminates on w simulates the existence of a solution
      to a given diophantine equation *)

  Theorem ra_dio_poly_find_spec w :  ex (⟦ra_dio_poly_find⟧ w)
                                <-> exists v, dp_eval (vec_pos v) (vec_pos w) p
                                            = dp_eval (vec_pos v) (vec_pos w) q.
  Proof.
    rewrite ra_dio_poly_find_rel; split.
    + intros (x & Hx).
      destruct (ra_dio_poly_test_val x w) as (e & H1 & H2).
      generalize (ra_rel_fun _ _ _ _ H1 Hx); rewrite H2.
      exists (project n x); auto.
      eq goal H; f_equal; apply dp_eval_ext; intro; try rewrite vec_pos_app_left; auto;
        rewrite vec_pos_app_right; auto.
    + intros (v & Hv).
      exists (inject v).
      destruct (ra_dio_poly_test_val (inject v) w) as (e & H1 & H2).
      rewrite project_inject in H2.
      assert (e=0); try (subst; auto; fail).
      apply H2.
      eq goal Hv; f_equal; apply dp_eval_ext; intro; try rewrite vec_pos_app_left; auto;
        rewrite vec_pos_app_right; auto.
  Qed.

  Theorem ra_dio_poly_find_spec_strong1 e w :  ⟦ra_dio_poly_find⟧ w e ->
                                      dp_eval (vec_pos (project n e)) (vec_pos w) p
                                    = dp_eval (vec_pos (project n e)) (vec_pos w) q.
  Proof.
    intros Hx % ra_dio_poly_find_rel_strong1. rename e into x.
    destruct (ra_dio_poly_test_val x w) as (e & H1 & H2).
    assert (e = 0). eapply (ra_rel_fun _ _ _ _ H1 Hx); rewrite H2.
    eapply H2 in H.
    eq goal H; f_equal; apply dp_eval_ext; intro; try rewrite vec_pos_app_left; auto;
        rewrite vec_pos_app_right; auto.
  Qed.

  Theorem ra_dio_poly_find_spec_strong2 v w :
                                      dp_eval (vec_pos v) (vec_pos w) p
                                    = dp_eval (vec_pos v) (vec_pos w) q
                                    ->  exists e, ⟦ra_dio_poly_find⟧ w e.
  Proof.
    intros.
    eapply ra_dio_poly_find_spec. eauto.
  Qed.

End dio_poly.

Opaque ra_dio_poly_find.

Section dio_ra_enum.

  (* Given p = q in dio_eq (pos 1) (pos m), given a total
     µ-rec function of type recalg 1 that enumerates the solutions

     given n compute x#w in vec nat (1+m). Compute
     p[x][w] = q[x][w]. If equal, return (S x), otherwise return 0 *)

   Variable (m : nat) (p q : dio_polynomial (pos m) (pos 1)).

   Let f := ra_dio_poly_test p q.

   Let Hf x w : {e : nat |
       ⟦ f ⟧ (x ## w) e /\
       (e = 0 <->
        dp_eval
          (fun i => vec_pos (vec_app (project m x) w) (pos_left 1 i))
          (fun i => vec_pos (vec_app (project m x) w) (pos_right m i))
          p =
        dp_eval
          (fun i => vec_pos (vec_app (project m x) w) (pos_left 1 i))
          (fun i => vec_pos (vec_app (project m x) w) (pos_right m i)) q) }.
  Proof. apply ra_dio_poly_test_val. Qed.

  Opaque f.

  Let g : recalg 1.
  Proof.
    apply ra_comp with (1 := ra_ite).
    refine (_##_##_##vec_nil).
    + apply ra_comp with (1 := f), ra_vec_project.
    + apply ra_comp with (1 := ra_succ).
      refine (_##vec_nil).
      apply (@ra_project 2 pos1).
    + apply ra_cst_n, 0.
  Defined.

  Opaque ra_decomp_l ra_decomp_r ra_project.

  Let Hg0 : prim_rec g.
  Proof.
    simpl; split; auto.
    intros j; analyse pos j; auto.
    + simpl; split; auto.
      * apply ra_dio_poly_test_prim.
      * intros j; analyse pos j; simpl; auto; split; auto.
    + simpl; split; auto.
      intros j; analyse pos j; auto.
  Qed.

  Let Hg1 x : ex (⟦g⟧ (x##vec_nil)).
  Proof. apply prim_rec_tot; auto. Qed.

  (* Not a very nice proof ... *)

  Let Hg x : (exists n, ⟦g⟧ (n##vec_nil) (S x)) <-> exists w, dp_eval (vec_pos w) (fun _ => x) p
                                                            = dp_eval (vec_pos w) (fun _ => x) q.
  Proof.
    split.
    + intros (n & w & H1 & H2).
      apply ra_ite_rel in H1.
      generalize (H2 pos0) (H2 pos1) (H2 pos2).
      clear H2; revert H1.
      repeat rewrite vec_pos_set.
      vec split w with a; vec split w with b; vec split w with c; vec nil w; clear w.
      simpl; intros H1 H2 H3 H4.
      destruct H3 as (w & H3 & H5).
      generalize (H5 pos0); revert H3; clear H5.
      vec split w with d; vec nil w; clear w; simpl; intros H3 H5.
      apply ra_project_rel in H5; simpl in H5.
      destruct H4 as (w & H4 & _); red in H4; clear w.
      destruct H2 as (w & H2 & H6).
      generalize (H6 pos0) (H6 pos1); clear H6.
      revert H2; vec split w with u; vec split w with v; vec nil w; clear w; simpl.
      intros H2 H6 H7.
      apply ra_project_rel in H6.
      apply ra_project_rel in H7.
      simpl in H5, H6, H7.
      subst c b d u v.
      apply ra_dio_poly_test_rel in H2; simpl in H2.
      exists (project m (decomp_l n)).
      apply proj1 in H2.
      destruct a; try discriminate.
      simpl in H1; injection H1; clear H1; intros H1.
      specialize (H2 eq_refl); subst x.
      eq goal H2; f_equal; apply dp_eval_ext;
        try (intros; rewrite vec_pos_app_left; auto);
        intros j _; analyse pos j; rewrite vec_pos_app_right; simpl; auto.
    + intros (w & Hw).
      destruct (Hf (inject w) (x##vec_nil)) as (e & H1 & H2).
      assert (e = 0) as He.
      { apply H2.
        eq goal Hw; f_equal; apply dp_eval_ext;
          try (intros j _; rewrite vec_pos_app_left; rewrite project_inject; auto);
          intros j _; analyse pos j; rewrite vec_pos_app_right; simpl; auto. }
      clear H2; subst e.
      exists (inject (inject w##x##vec_nil)).
      unfold g.
      exists (0##S x##0##vec_nil); split.
      * apply ra_ite_rel; simpl; auto.
      * intros j; rewrite vec_pos_set; analyse pos j; simpl.
        - exists (inject w ## x ## vec_nil); split; auto.
          intros j; analyse pos j; simpl.
          { apply ra_project_rel; simpl.
            rewrite decomp_l_recomp; auto. }
          { apply ra_project_rel; simpl.
            rewrite decomp_r_recomp, decomp_l_recomp; auto. }
        - exists (x##vec_nil); split; try (red; auto; fail).
          intros j; analyse pos j; simpl.
          apply ra_project_rel; simpl.
          rewrite decomp_r_recomp, decomp_l_recomp; auto.
        - exists vec_nil; split; try (red; auto; fail).
          intros j; analyse pos j.
  Qed.

  Theorem dio_poly_eq_2_ra_prim :
          { g : recalg 1 | prim_rec g
               /\ forall x, (exists n, ⟦g⟧ (n##vec_nil) (S x))
                         <-> exists w, dp_eval (vec_pos w) (fun _ => x) p
                                     = dp_eval (vec_pos w) (fun _ => x) q }.
  Proof. exists g; split; auto. Qed.

End dio_ra_enum.


(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2021 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)

Require Import Program Bvector List Relations.
Require Import Equations.Prop.Equations.
Require Import Utf8.
Set Keyed Unification.

Equations neg (b : bool) : bool :=
neg true := false ;
neg false := true.

Lemma neg_inv : forall b, neg (neg b) = b.
Proof. intros b. funelim (neg b); auto. Qed.

Inductive le : nat -> nat -> Set :=
| le_0 n : le 0 (S n)
| le_S n m : le n m -> le (S n) (S m).
Derive Signature for le.

Equations congS {x y : nat} (p : x = y) : S x = S y :=
congS eq_refl := eq_refl.

(* Equations antisym {x y : nat} (p : le x y) (q : le y x) : x = y := *)
(* antisym (le_S n m p) (le_S ?(m) ?(n) q) := congS (antisym p q). *)

Module TestF.

  Equations? f (n : nat) : nat :=
  f 0 := 42 ;
  f (S m)  with f m :=
  {
    f (S m) IH := _
  }.
  Proof. refine IH. Defined.

End TestF.

#[local]
Instance eqsig {A} (x : A) : Signature (x = x) A (fun a => x = a) := sigmaI _ x.

Module WithUIP.
Set Equations With UIP.
Polymorphic Axiom uip : forall A, UIP A.
Local Existing Instance uip.

Equations K {A} (x : A) (P : x = x -> Type) (p : P eq_refl) (H : x = x) : P H :=
K x P p eq_refl := p.
End WithUIP.
(* Test Equations WithUIP. should be off, setting is local to the module *)

Equations eq_sym {A} (x y : A) (H : x = y) : y = x :=
eq_sym x _ eq_refl := eq_refl.

Equations eq_trans {A} (x y z : A) (p : x = y) (q : y = z) : x = z :=
eq_trans x _ _ eq_refl eq_refl := eq_refl.

Declare Scope vect_scope.
Notation " x |:| y " := (@Vector.cons _ x _ y) (at level 20, right associativity) : vect_scope.
Notation " x |: n :| y " := (@Vector.cons _ x n y) (at level 20, right associativity) : vect_scope.
(* Notation " [[ x .. y ]] " := (Vector.cons x .. (Vector.cons y Vector.nil) ..) : vect_scope. *)
Notation "[]v" := (@Vector.nil _) (at level 0) : vect_scope.

Section FilterDef.
  Context {A} (p : A -> bool).

  Equations filter (l : list A) : list A :=
  filter List.nil := List.nil ;
  filter (List.cons a l) with p a => {
                         | true := a :: filter l ;
                         | false := filter l }.

End FilterDef.

(* Equations filter {A} (l : list A) (p : A -> bool) : list A := *)
(* filter A List.nil p := List.nil ; *)
(* filter A (List.cons a l) p <= p a => { *)
(*   | true := a :: filter l p ; *)
(*   | false := filter l p }. *)

Inductive incl {A} : relation (list A) :=
  stop : incl nil nil
| keep {x : A} {xs ys : list A} : incl xs ys -> incl (x :: xs) (x :: ys)
| skip {x : A} {xs ys : list A} : incl xs ys -> incl (xs) (x :: ys).

Global Transparent filter.

Equations sublist {A} (p : A -> bool) (xs : list A) : incl (filter p xs) xs :=
sublist p nil := stop ;
sublist p (cons x xs) with p x := {
  | true := keep (sublist p xs) ;
  | false := skip (sublist p xs) }.

(* Print Assumptions sublist. *)
Notation vector := Vector.t.
(* Derive Subterm for nat.  *)
Derive Signature for vector.
Derive NoConfusion NoConfusionHom for vector.
Derive Subterm for vector.

Require Import Arith Wf_nat.

#[local]
Instance wf_nat : WellFounded lt := lt_wf.

#[local] Hint Resolve PeanoNat.Nat.lt_succ_diag_r : lt.

Ltac solve_rec ::= simpl in * ; cbv zeta ; intros ;
  try typeclasses eauto with subterm_relation Below lt.
Unset Implicit Arguments.

Equations testn (n : nat) : nat by wf n lt :=
testn 0 := 0 ;
testn (S n) with testn n => {
  | 0 := S 0 ;
  | (S n') := S n' }.

Require Import Vectors.Vector.

Arguments Vector.nil {A}.
Arguments Vector.cons {A} _ {n}.

Local Open Scope vect_scope.
Reserved Notation "x ++v y" (at level 60).

Equations vapp' {A} {n m} (v : vector A n) (w : vector A m) : vector A (n + m) :=
{ []v ++v w := w ;
  (Vector.cons a v) ++v w := Vector.cons a (v ++v w) }
where "x ++v y" := (vapp' x y).

(* Section vapp_def. *)
(*   Context {A : Type}. *)
(*   Equations  vapp' {n m} (v : vector A n) (w : vector A m) : vector A (n + m) := *)
(*   vapp' []v w := w ; *)
(*   vapp' (Vector.cons a n v) w := Vector.cons a (vapp' v w). *)
(* End vapp_def. *)

(* Print Assumptions vapp'. *)

#[local]
Instance vector_eqdec {A n} `(EqDec A) : EqDec (vector A n).
Proof.
  intros. intros x. induction x. left. now depelim y.
  intro y; depelim y.
  destruct (Classes.eq_dec h h0); subst.
  destruct (IHx y). subst.
  left; reflexivity.
  right. intro. noconf H0. contradiction.
  right. intro. noconf H0. contradiction.
Defined.

(* Print Assumptions well_founded_vector_direct_subterm. *)

(** A closed proof of well-foundedness relying on the decidability
   of [A]. *)

Definition vector_subterm A := t_subterm A.

(* Instance well_founded_vector_direct_subterm' : *)
(*   forall A : Type, EqDec A -> WellFounded (vector_subterm A) | 0. *)
(* Proof.   intros.  *)
(*   apply Transitive_Closure.wf_clos_trans. *)
(*   intro. simp_sigmas. induction a. *)
(*   constructor; intros. *)
(*   simp_sigmas. simpl in *.  *)
(*   depelim H. *)
(*   constructor; intros. *)
(*   simp_sigmas. depelim H.  *)
(*   assumption. *)
(* Defined. *)
(* Print Assumptions well_founded_vector_direct_subterm'. *)

#[local]
Instance eqdep_prod A B `(EqDec A) `(EqDec B) : EqDec (prod A B).
Proof. intros. intros x y. decide equality. Defined.

#[local] Hint Unfold vector_subterm : subterm_relation.
(* Typeclasses Opaque vector_subterm. *)
Import Vector.

(* Section unzip_dec_def. *)
(*   Context {A B} `{EqDec A} `{EqDec B}. *)

(*   Equations unzip_dec {n} (v : vector (A * B) n) : vector A n * vector B n := *)
(*   unzip_dec n v by wf v (@vector_subterm (A * B)) := *)
(*   unzip_dec ?(O) nil := ([]v, []v) ; *)
(*   unzip_dec ?(S n) (cons (pair x y) n v) with unzip_dec v := { *)
(*      | pair xs ys := (cons x xs, cons y ys) }. *)
(* End unzip_dec_def. *)
Section foo.
  Context {A B : Type}.
  Equations unzipv {n} (v : vector (A * B) n) : vector A n * vector B n
   by wf (signature_pack v) (@vector_subterm (A * B)) :=
  unzipv []v := ([]v, []v) ;
  unzipv ((x, y) |:| v) with unzipv v := {
    | pair xs ys := (cons x xs, cons y ys) }.
End foo.

#[local]
Typeclasses Transparent vector_subterm.

(** Due to the packing of all arguments, can only be done in sections right now so
 that A and B are treated as parameters (better computational behavior anyway) *)
(* Equations unzip {A B} {n} (v : vector (A * B) n) : vector A n * vector B n := *)
(* unzip v by wf (signature_pack v) (@vector_subterm (A * B)) := *)
(* unzip nil := (nil, nil) ; *)
(* unzip (cons (pair x y) n v) <= unzip v => { *)
(*   | (pair xs ys) := (cons x xs, cons y ys) }. *)

(* Print Assumptions unzip. *)
(* Print Assumptions unzip_dec. *)

(*
Ltac generalize_by_eqs v ::= generalize_eqs v.

Equations unzip_n {A B} {n} (v : vector (A * B) n) : vector A n * vector B n :=
unzip_n A B O Vnil := (Vnil, Vnil) ;
unzip_n A B (S n) (cons (pair x y) n v) with unzip_n v := {
  | pair xs ys := (cons x xs, cons y ys) }. *)
(* Definition nos_with_comp (n : nat) := nat. *)
(* Lemma nos_with (n : nat) : nos_with_comp n. *)
(*   rec_wf_eqns nos n. *)

Equations nos_with (n : nat) : nat by wf n :=
nos_with O := O ;
nos_with (S m) with nos_with m := {
  | O := S O ;
  | S n' := O }.

Equations equal (n m : nat) : { n = m } + { n <> m } :=
equal O O := in_left ;
equal (S n) (S m) with equal n m => {
  equal (S n) (S ?(n)) (left eq_refl) := left eq_refl ;
  equal (S n) (S m) (right p) := in_right } ;
equal x y := in_right.

Import List.
Equations app_with {A} (l l' : list A) : list A :=
app_with nil l := l ;
app_with (cons a v) l with app_with v l => {
  | vl := cons a vl }.

(* Print Assumptions app_with. *)
(* About app_with_elim. *)
(* Print app_with_ind. *)
(* Print app_with_ind_ind. *)

(* Scheme app_with_elim := Minimality for app_with_ind Sort Prop *)
(*   with app_with_help_elim := Minimality for app_with_ind_1 Sort Prop. *)

(* About app_with_elim. *)

Equations plus' (n m : nat) : nat :=
plus' O n := n ;
plus' (S n) m := S (plus' n m).

(* Ltac generalize_by_eqs id ::= generalize_eqs id. *)
(* Ltac generalize_by_eqs_vars id ::= generalize_eqs_vars id. *)

Equations head A (default : A) (l : list A) : A :=
head A default nil := default ;
head A default (cons a v) := a.

Equations tail {A} (l : list A) : list A :=
tail nil := nil ;
tail (cons a v) := v.

(* Eval compute in @tail. *)
(* Eval compute in (tail (cons 1 nil)). *)

Equations app' {A} (l l' : list A) : (list A) :=
app' nil l := l ;
app' (cons a v) l := cons a (app' v l).

Global Transparent app'.

Notation  " x +++ y " := (@app' _ x y%list)  (at level 60, right associativity).

Equations rev_acc {A} (l : list A) (acc : list A) : list A :=
rev_acc nil acc := acc;
rev_acc (cons a v) acc := rev_acc v (a :: acc).

Equations rev {A} (l : list A) : list A :=
rev nil := nil;
rev (cons a v) := rev v +++ (cons a nil).

Notation " [] " := List.nil.

Lemma app'_nil : forall {A} (l : list A), l +++ [] = l.
Proof.
  intros.
  funelim (app' l []); auto.
  now rewrite H.
Qed.

Lemma app'_assoc : forall {A} (l l' l'' : list A), (l +++ l') +++ l'' = app' l (app' l' l'').
Proof. intros. revert l''.
  funelim (l +++ l'); intros; simp app'; trivial.
  now rewrite H.
Qed.

Lemma rev_rev_acc : forall {A} (l : list A), rev_acc l [] = rev l.
Proof. intros. replace (rev l) with (rev l +++ []) by apply app'_nil.
  generalize (@nil A).
  funelim (rev l). reflexivity.
  intros l'. simp rev_acc. rewrite H.
  rewrite app'_assoc. reflexivity.
Qed.
#[local] Hint Rewrite @rev_rev_acc : rev_acc.

Lemma app'_funind : forall {A} (l l' l'' : list A), (l +++ l') +++ l'' = app' l (app' l' l'').
Proof.
  intros.
  funelim (l +++ l'); simp app'; trivial.
  rewrite H. reflexivity.
Qed.

#[local] Hint Rewrite @app'_nil @app'_assoc : app'.

Lemma rev_app' : forall {A} (l l' : list A), rev (l +++ l') = rev l' +++ rev l.
Proof. intros. funelim (l +++ l'); simp rev app'; trivial.
  now (rewrite H, <- app'_assoc).
Qed.
Equations zip' {A} (f : A -> A -> A) (l l' : list A) : list A :=
zip' f nil nil := nil ;
zip' f (cons a v) (cons b w) := cons (f a b) (zip' f v w) ;
zip' f x y := nil.

Equations zip'' {A} (f : A -> A -> A) (l l' : list A) (def : list A) : list A :=
zip'' f nil nil def := nil ;
zip'' f (cons a v) (cons b w) def := cons (f a b) (zip'' f v w def) ;
zip'' f nil (cons b w) def := def ;
zip'' f (cons a v) nil def := def.

Import Vector.

Equations vector_append_one {A n} (v : vector A n) (a : A) : vector A (S n) :=
vector_append_one nil a := cons a nil;
vector_append_one (cons a' v) a := cons a' (vector_append_one v a).

Equations vrev {A n} (v : vector A n) : vector A n :=
vrev nil := nil;
vrev (cons a v) := vector_append_one (vrev v) a.

Definition cast_vector {A n m} (v : vector A n) (H : n = m) : vector A m.
intros; subst; assumption. Defined.

Equations vrev_acc {A n m} (v : vector A n) (w : vector A m) : vector A (n + m) :=
vrev_acc nil w := w;
vrev_acc (cons a v) w := cast_vector (vrev_acc v (cons a w)) _.

Record vect {A} := mkVect { vect_len : nat; vect_vector : vector A vect_len }.
Coercion mkVect : vector >-> vect.
Derive NoConfusion for vect.

Inductive Split {X : Type}{m n : nat} : vector X (m + n) -> Type :=
  append : ∀ (xs : vector X m)(ys : vector X n), Split (vapp' xs ys).

Arguments Split [ X ].

(* Eval compute in @app'. *)
(* About nil. About vector. *)

Equations split {X : Type} {m n} (xs : vector X (m + n)) : Split m n xs
  by wf m :=
split (m:=O) xs := append nil xs ;
split (m:=(S m)) (n:=n) (cons x xs) with split xs => {
  | append xs' ys' := append (cons x xs') ys' }.

Lemma split_vapp' : ∀ (X : Type) m n (v : vector X m) (w : vector X n),
  let 'append v' w' := split (vapp' v w) in
    v = v' /\ w = w'.
Proof.
  intros.
  funelim (vapp' v w). simpl.
  destruct split. depelim xs; intuition.
  simp split in *. destruct split. simpl.
  intuition congruence.
Qed.
Transparent vapp'.
Definition eta_vector {A} (P : forall n, vector A n -> Type) :
  forall n v,
    match v with
    | nil => P 0 nil
    | cons a v => P _ (cons a v)
    end = P n v.
Proof.
  now destruct v.
Defined.
Import Sigma_Notations.

Axiom cheat : forall {A}, A.
Lemma split' {X : Type} : forall {m n} (xs : vector X (Peano.plus m n)), Split m n xs.
Proof.
  fix IH 3. intros m n xs.
  eassert ?[ty].
  refine (match xs as xs' in @t _ k return
                (match xs' as xs'' in vector _ n' return Type with
                 | nil => ((0, nil) = (Peano.plus m n, xs)) -> Split m n xs
                 | @cons _ x' n' xs'' =>
                   (S n', cons x' xs'') = (Peano.plus m n, xs) -> Split m n xs
                 end)
          with
          | nil => _
          | cons x xs => _
          end).
(* FIXME: simplify not agressive enough to find whd *)
  simpl. (* apply cheat. apply cheat. *)
  destruct m as [|m'].
  + simpl. simplify *.
    simpl. apply (append nil nil).
  + simpl. simplify *.
  + destruct m as [|m']; simpl.
    simplify *. simpl. apply (append nil (x |: _ :| xs)).
    simplify *. simpl.
    specialize (IH _ _ xs).
    destruct IH.
    refine (append (cons x xs) ys).
  + rewrite (eta_vector (fun nv v => (nv, v) = (Peano.plus m n, xs) -> Split m n xs)) in X0.
    apply (X0 eq_refl).
Defined.
(* Eval cbv delta[split' eq_rect noConfusion NoConfusion.NoConfusionPackage_nat
                      NoConfusion.noConfusion_nat_obligation_1
              ] beta zeta iota in split'. *)
Extraction Inline Logic.transport.
(* Extraction split'.
Extraction split. *)

(* Eval compute in @zip''. *)

Require Import Bvector.

Equations  split_struct {X : Type} {m n} (xs : vector X (m + n)) : Split m n xs :=
split_struct (m:=0) xs := append nil xs ;
split_struct (m:=(S m)) (cons x xs) with split_struct xs => {
  split_struct (m:=(S m)) (cons x xs) (append xs' ys') := append (cons x xs') ys' }.
(* Extraction split_struct. *)
Lemma split_struct_vapp : ∀ (X : Type) m n (v : vector X m) (w : vector X n),
  let 'append v' w' := split_struct (vapp' v w) in
    v = v' /\ w = w'.
Proof.
  intros. funelim (vapp' v w); simp split_struct in *.
  destruct (split_struct (m:=0) w). depelim xs; intuition.
  destruct (split_struct (vapp' v w)); simpl.
  intuition congruence.
Qed.

Equations vhead {A n} (v : vector A (S n)) : A :=
vhead (cons a v) := a.

Equations vmap' {A B} (f : A -> B) {n} (v : vector A n) : vector B n :=
vmap' f nil := nil ;
vmap' f (cons a v) := cons (f a) (vmap' f v).

#[local] Hint Resolve PeanoNat.Nat.lt_succ_diag_r : subterm_relation.

Equations vmap {A B} (f : A -> B) {n} (v : vector A n) : vector B n
  by wf n :=
vmap f nil := nil ;
vmap f (cons a v) := cons (f a) (vmap f v).

Transparent vmap.

Transparent vmap'.
(* Eval compute in (vmap' id (@Vnil nat)). *)
(* Eval compute in (vmap' id (@cons nat 2 _ Vnil)). *)

(* Eval compute in @vmap'. *)

Section Image.
  Context {S T : Type}.
  Variable f : S -> T.

  Inductive Imf : T -> Type := imf (s : S) : Imf (f s).

  Equations inv (t : T) (im : Imf t) : S :=
  inv ?(f s) (imf s) := s.

End Image.

Section Univ.

  Inductive univ : Set :=
  | ubool | unat | uarrow (from:univ) (to:univ).

  Equations  interp (u : univ) : Set :=
  interp ubool := bool; interp unat := nat;
  interp (uarrow from to) := interp from -> interp to.

  (* Eval compute in interp. *)

  Transparent interp.

  Definition interp' := Eval compute in @interp.

  Equations foo (u : univ) (el : interp' u) : interp' u :=
  foo ubool true := false ;
  foo ubool false := true ;
  foo unat t := t ;
  foo (uarrow from to) f := id ∘ f.

  Transparent foo.
  (* Eval lazy beta delta [ foo foo_obligation_1 foo_obligation_2 ] iota zeta in foo. *)

End Univ.

(* Eval compute in (foo ubool false). *)
(* Eval compute in (foo (uarrow ubool ubool) negb). *)
(* Eval compute in (foo (uarrow ubool ubool) id). *)

Inductive foobar : Set := bar | baz.

Equations bla (f : foobar) : bool :=
bla bar := true ;
bla baz := false.

(* Eval simpl in bla. *)

Lemma eq_trans_eq A x : @eq_trans A x x x eq_refl eq_refl = eq_refl.
Proof. reflexivity. Qed.

Equations vlast {A} {n} (v : vector A (S n)) : A by struct v :=
vlast (cons a (n:=O) nil) := a ;
vlast (cons a (n:=S n) v) := vlast v.

Transparent vlast.
Definition testvlast : 4 = (vlast (cons 2 (cons 5 (cons 4 nil)))) := eq_refl.

Fixpoint vapp {A n m} (v : vector A n) (w : vector A m) : vector A (n + m) :=
  match v with
    | nil => w
    | cons a v' => cons a (vapp v' w)
  end.

(* Eval compute in (split (vapp Vnil (cons 2 Vnil))). *)
(* Eval compute in (split (vapp (cons 3 Vnil) (cons 2 Vnil))). *)

(* Recursive Extraction split. *)
(* Transparent split. *)
(* Eval cbv beta iota zeta delta [ split split_obligation_1 split_obligation_2  ] in @split. *)

Equations mult (n m : nat) : nat :=
mult O m := 0 ; mult (S n) m := mult n m + m.

Transparent mult.

(* Equations mult' (n m acc : nat) : nat := *)
(* mult' O m acc := acc ; mult' (S n) m acc := mult' n m (n + acc). *)

Inductive Parity : nat -> Set :=
| even : forall n, Parity (mult 2 n)
| odd : forall n, Parity (S (mult 2 n)).

(* Eval compute in (fun n => mult 2 (S n)). *)
Definition cast {A B : Type} (a : A) (p : A = B) : B.
  intros. subst. exact a.
Defined.

Equations parity (n : nat) : Parity n :=
parity O := even 0 ;
parity (S n) with parity n => {
  parity (S ?(mult 2 k))     (even k) := odd k ;
  parity (S ?(S (mult 2 k))) (odd k)  := cast (even (S k)) _ }.

Equations half (n : nat) : nat :=
half n with parity n => {
  half ?(S (mult 2 k)) (odd k) := k ;
  half ?(mult 2 k) (even k) := k }.

Equations vtail {A n} (v : vector A (S n)) : vector A n :=
vtail (cons a v') := v'.

(** Well-founded recursion: note that it's polymorphic recursion in a sense:
    the type of vectors change at each recursive call. It does not follow
    a canonical elimination principle in this nested case. *)

Equations diag {A n} (v : vector (vector A n) n) : vector A n
 by wf n lt :=
diag nil := nil ;
diag (cons (cons a v) v') := cons a (diag (vmap vtail v')).

(** The computational content is the right one here: only the vector is
    matched relevantly, not its indices, which could hence
    disappear. *)

(* Extraction diag. *)

(** It can be done structurally as well but we're matching on the index now. *)
Equations diag_struct {A n} (v : vector (vector A n) n) : vector A n :=
diag_struct (n:=O) nil := nil ;
diag_struct (n:=(S _)) (cons (cons a v) v') := cons a (diag_struct (vmap vtail v')).

Definition mat A n m := vector (vector A m) n.

Equations vmake {A} (n : nat) (a : A) : vector A n :=
vmake O a := nil ;
vmake (S n) a := cons a (vmake n a).

Equations vfold_right {A : nat -> Type} {B} (f : ∀ n, B -> A n -> A (S n)) (e : A 0) {n} (v : vector B n) : A n :=
vfold_right f e nil := e ;
vfold_right f e (cons a v) := f _ a (vfold_right f e v).

Equations vzip {A B C n} (f : A -> B -> C) (v : vector A n) (w : vector B n) : vector C n :=
vzip f nil _ := nil ;
vzip f (cons a v) (cons a' v') := cons (f a a') (vzip f v v').

Definition transpose {A m n} : mat A m n -> mat A n m :=
  vfold_right (A:=λ m, mat A n m)
  (λ m', vzip (λ a, cons a))
  (vmake n nil).

(* Lemma vfold_right_e {A : Type} {B} {n} (f : ∀ n', B' -> vector (vector A 0) n' -> vector (vector A 0) (S n')) *)
(*   (e : vector (vector A 0) n) v : vfold_right f (vmake n Vnil) v =  *)
(* Typeclasses eauto :=. *)

Require Import fin.

Generalizable All Variables.

Opaque vmap. Opaque vtail. Opaque nth.

Require Vectors.Vector.
Arguments Vector.nil {A}.
Arguments Vector.cons {A} _ {n}.
Notation vnil := Vector.nil.
Notation vcons := Vector.cons.

Equations nth {A} {n} (v : Vector.t A n) (f : fin n) : A :=
nth (vcons a v) fz := a ;
nth (vcons a v) (fs f) := nth v f.

Lemma nth_vmap {A B n} (v : vector A n) (fn : A -> B) (f : fin n) : nth (vmap fn v) f = fn (nth v f).
Proof. revert B fn. funelim (nth v f); intros; now simp nth vmap. Qed.

Lemma nth_vtail `(v : vector A (S n)) (f : fin n) : nth (vtail v) f = nth v (fs f).
Proof. funelim (vtail v); intros; now simp nth. Qed.

#[local] Hint Rewrite @nth_vmap @nth_vtail : nth.

Lemma diag_nth `(v : vector (vector A n) n) (f : fin n) : nth (diag v) f = nth (nth v f) f.
Proof. revert f. funelim (diag v); intros f.
  depelim f.

  depelim f; simp nth; trivial.
  rewrite H. now simp nth.
Qed.

Equations assoc (x y z : nat) : x + y + z = x + (y + z) :=
assoc 0 y z := eq_refl;
assoc (S x) y z with assoc x y z, x + (y + z) => {
assoc (S x) y z eq_refl _ := eq_refl }.


From Hammer Require Import Hammer.

Require Import BinInt.
Local Open Scope Z_scope.

Definition Zpower_alt n m :=
match m with
| Z0 => 1
| Zpos p => Pos.iter_op Z.mul p n
| Zneg p => 0
end.

Infix "^^" := Zpower_alt (at level 30, right associativity) : Z_scope.

Lemma Piter_mul_acc : forall f,
(forall x y:Z, (f x)*y = f (x*y)) ->
forall p k, Pos.iter f k p = (Pos.iter f 1 p)*k.
Proof. hammer_hook "Zpow_alt" "Zpow_alt.Piter_mul_acc".
intros f Hf.
induction p; simpl; intros.
- set (g := Pos.iter f 1 p) in *. now rewrite !IHp, Hf, Z.mul_assoc.
- set (g := Pos.iter f 1 p) in *. now rewrite !IHp, Z.mul_assoc.
- now rewrite Hf, Z.mul_1_l.
Qed.

Lemma Piter_op_square : forall p a,
Pos.iter_op Z.mul p (a*a) = (Pos.iter_op Z.mul p a)*(Pos.iter_op Z.mul p a).
Proof. hammer_hook "Zpow_alt" "Zpow_alt.Piter_op_square".
induction p; simpl; intros; trivial. now rewrite IHp, Z.mul_shuffle1.
Qed.

Lemma Zpower_equiv a b : a^^b = a^b.
Proof. hammer_hook "Zpow_alt" "Zpow_alt.Zpower_equiv".
destruct b as [|p|p]; trivial.
unfold Zpower_alt, Z.pow, Z.pow_pos.
revert a.
induction p; simpl; intros.
- f_equal.
rewrite Piter_mul_acc.
now rewrite Piter_op_square, IHp.
intros. symmetry; apply Z.mul_assoc.
- rewrite Piter_mul_acc.
now rewrite Piter_op_square, IHp.
intros. symmetry; apply Z.mul_assoc.
- now Z.nzsimpl.
Qed.

Lemma Zpower_alt_0_r n : n^^0 = 1.
Proof. hammer_hook "Zpow_alt" "Zpow_alt.Zpower_alt_0_r".   reflexivity. Qed.

Lemma Zpower_alt_succ_r a b : 0<=b -> a^^(Z.succ b) = a * a^^b.
Proof. hammer_hook "Zpow_alt" "Zpow_alt.Zpower_alt_succ_r".
destruct b as [|b|b]; intros Hb; simpl.
- now Z.nzsimpl.
- now rewrite Pos.add_1_r, Pos.iter_op_succ by apply Z.mul_assoc.
- now elim Hb.
Qed.

Lemma Zpower_alt_neg_r a b : b<0 -> a^^b = 0.
Proof. hammer_hook "Zpow_alt" "Zpow_alt.Zpower_alt_neg_r".
now destruct b.
Qed.

Lemma Zpower_alt_Ppow p q : (Zpos p)^^(Zpos q) = Zpos (p^q).
Proof. hammer_hook "Zpow_alt" "Zpow_alt.Zpower_alt_Ppow".
now rewrite Zpower_equiv, Pos2Z.inj_pow.
Qed.


Require Export Nat.
Require Export List.
Export ListNotations.

(* Deep embedding of untyped pure lambda-calculus
   The goal is to teach lambda-calculus and experiment with
   several reduction strategies and functions (extracting
   bound or free variables, redexes, checking (strong,
   weak, head) normal forms, etc.
   The implementation is not complete nor strictly correct *)

(* To alleviate the notations we use a fixed number of variables
   defined as constructors *)

Inductive letter : Set :=
  | a    | b    | c    | d    | e    | f
  | g    | h    | i    | j    | k    | l
  | m    | n    | o    | p    | q    | r
  | s    | t    | u    | v    | w    | x
  | y    | z
  | a1   | b1   | c1   | d1   | e1   | f1
  | g1   | h1   | i1   | j1   | k1   | l1
  | m1   | n1   | o1   | p1   | q1   | r1
  | s1   | t1   | u1   | v1   | w1   | x1
  | y1   | z1
.

Definition nat_of_letter x :=
  match x with
  | a  =>  0  | b  =>  1  | c  =>  2  | d  =>  3  | e  =>  4  | f  =>  5
  | g  =>  6  | h  =>  7  | i  =>  8  | j  =>  9  | k  => 10  | l  => 11
  | m  => 12  | n  => 13  | o  => 14  | p  => 15  | q  => 16  | r  => 17
  | s  => 18  | t  => 19  | u  => 20  | v  => 21  | w  => 22  | x  => 23
  | y  => 24  | z  => 25
  | a1 => 26  | b1 => 27  | c1 => 28  | d1 => 29  | e1 => 30  | f1 => 31
  | g1 => 32  | h1 => 33  | i1 => 34  | j1 => 35  | k1 => 36  | l1 => 37
  | m1 => 38  | n1 => 39  | o1 => 40  | p1 => 41  | q1 => 42  | r1 => 43
  | s1 => 44  | t1 => 45  | u1 => 46  | v1 => 47  | w1 => 48  | x1 => 49
  | y1 => 50  | z1 => 51
  end.

Definition letter_of_nat nn :=
  match nn with
  |  0 =>  a  |  1 =>  b  |  2 =>  c  |  3 =>  d  |  4 =>  e  |  5 =>  f
  |  6 =>  g  |  7 =>  h  |  8 =>  i  |  9 =>  j  | 10 =>  k  | 11 =>  l
  | 12 =>  m  | 13 =>  n  | 14 =>  o  | 15 =>  p  | 16 =>  q  | 17 =>  r
  | 18 =>  s  | 19 =>  t  | 20 =>  u  | 21 =>  v  | 22 =>  w  | 23 =>  x
  | 24 =>  y  | 25 =>  z
  | 26 => a1  | 27 => b1  | 28 => c1  | 29 => d1  | 30 => e1  | 31 => f1
  | 32 => g1  | 33 => h1  | 34 => i1  | 35 => j1  | 36 => k1  | 37 => l1
  | 38 => m1  | 39 => n1  | 40 => o1  | 41 => p1  | 42 => q1  | 43 => r1
  | 44 => s1  | 45 => t1  | 46 => u1  | 47 => v1  | 48 => w1  | 49 => x1
  | 50 => y1  | 51 => z1
  | _ => a (* fake *)
  end.

Definition first_letter := a.
Definition card_letter := 52.

(* *)

Inductive Name : Set :=
| Lett : letter -> Name
| Prime : Name -> Name
.

Coercion Lett: letter >-> Name.

Notation "X °" := (Prime X) (at level 1, format "X °").

Fixpoint nat_of_Name nn :=
  match nn with
  | Lett xx => nat_of_letter xx
  | Prime nn => card_letter + nat_of_Name nn
  end.

Definition eqb_Name ax ay : bool := eqb (nat_of_Name ax) (nat_of_Name ay).

(* Fresh names *)

Definition rot_nat n :=
    if eqb (S n) card_letter then O else S n.

Definition rot_letter x := letter_of_nat (rot_nat (nat_of_letter x)).

Fixpoint next_name nn :=
  match nn with
  | Lett xx =>
    let rn := rot_nat (nat_of_letter xx) in
    match rn with
    | O => Prime first_letter
    | _ => Lett (letter_of_nat rn)
    end
  | Prime nn => Prime (next_name nn)
  end.

Fixpoint gen_names {A: Type} (ll : list A) n : list Name :=
  match ll with
  | [] => [n]
  | _ :: ll => n :: gen_names ll (next_name n)
  end.

(* Remove all ax in ll, returns None if ax not in ll *)

Fixpoint mayrem (ax:Name) (ll:list Name) : option (list Name) :=
  match ll with
  | [] => None
  | ax1 :: lls =>
    match mayrem ax lls with
    | None => if eqb_Name ax ax1 then Some lls else None
    | Some lls' => if eqb_Name ax ax1 then Some lls' else Some (ax1 :: lls')
    end
  end.

(* remove a name in a list of names *)

(* lavoid <= lstruct in some sense (size, or injection)
   result not in lavoid
*)
Fixpoint fresh_1 (cand:Name) (lavoid lstruct: list Name) : Name :=
  match lstruct with
  | [] => cand
  | _ :: lstruct' => match mayrem cand lavoid with
                     | None => cand
                     | Some lavoid' => fresh_1 (next_name cand) lavoid' lstruct'
                     end
  end.

Definition fresh (avoid:list Name) : Name := fresh_1 first_letter avoid avoid.

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

(* Syntax of lambda expressions *)

Inductive lexp : Type :=
  | Var : Name -> lexp
  | Lam : Name -> lexp -> lexp
  | App : lexp -> lexp -> lexp.

(* Notations
   \x y.x y is written \x y:x y   *)

Notation "\ x .. y ~ M" := (Lam x .. (Lam y M) ..)
   (at level 30, x at level 0, y at level 0, right associativity).
Notation "\ x .. y · M" := (Lam x .. (Lam y M) ..)
   (at level 30, x at level 0, y at level 0, right associativity).
Notation "'λ' x .. y · M" := (Lam x .. (Lam y M) ..)
   (at level 30, x at level 0, y at level 0, right associativity).

Coercion Var: Name >-> lexp.

Coercion App: lexp >-> Funclass.

(*
Lemma Name_eq_dec : forall ax ay:Name, {ax = ay} + {ax <> ay}.
Proof.
intros. destruct ax; destruct ay; try (right; easy); left; easy.
Qed.

Definition eqb_Name ax ay : bool :=
match Name_eq_dec ax ay with
| left _  => true
| right _ => false
end.
*)

(* member function in list of names *)

Fixpoint mem (ax:Name) (xx:list Name) : bool :=
  match xx with
  | [] => false
  | ax1 :: xxs => if eqb_Name ax ax1 then true else mem ax xxs
  end.

(* remove a name in a list of names *)

Fixpoint rem (ax:Name) (xx:list Name) : list Name :=
  match xx with
  | [] => []
  | ax1 :: xx1 => if eqb_Name ax ax1 then rem ax xx1
                  else ax1 :: rem ax xx1
  end.

(* remove duplicates in a list of names *)

Fixpoint make_set xx : list Name :=
  match xx with
  | [] => []
  | ax :: xx1 => if mem ax xx1 then make_set xx1
                 else ax :: (make_set xx1)
  end.

(* intersection of two list of names *)

Fixpoint inter_1 xx yx : list Name :=
  match xx with
  | [] => []
  | ax :: xx1 => if mem ax yx then ax :: inter_1 xx1 yx
                 else inter_1 xx1 yx
  end.

Definition inter xx yx : list Name := inter_1 (make_set xx) yx.

(* returns all names used in a lexp *)

Fixpoint allvars ex : list Name :=
  match ex with
  | Var nx => [nx]
  | Lam nx ex => nx :: (allvars ex)
  | App ex1 ex2 => allvars ex1 ++ allvars ex2
  end.

Definition vars ex := make_set (allvars ex).

(* returns all variables with a free occurrence in a lexp *)

Fixpoint freevars ex : list Name :=
  match ex with
  | Var nx => [nx]
  | Lam nx ex => rem nx (freevars ex)
  | App ex1 ex2 => freevars ex1 ++ freevars ex2
  end.

Definition vlibres ex := make_set (freevars ex).

(* returns all variables with a bound occurrence in a lexp *)

Fixpoint boundvars ex : list Name :=
  match ex with
  | Var nx => []
  | Lam nx ex => if mem nx (freevars ex) then nx :: (boundvars ex)
                 else boundvars ex
  | App ex1 ex2 => boundvars ex1 ++ boundvars ex2
  end.

Definition vliees ex := make_set (boundvars ex).

Fixpoint declaredvars ex : list Name :=
  match ex with
  | Var nx => []
  | Lam nx ex => nx :: (declaredvars ex)
  | App ex1 ex2 => declaredvars ex1 ++ declaredvars ex2
  end.

Definition vdef ex := make_set (declaredvars ex).

(** Replace all free occurrences of [Var ny] by [Var nz] in [ex].
   Used with the hypothesis that [nz] does not occur in [ex]. *)

Fixpoint rename ny nz ex: lexp :=
  match ex with
  | Var nx      => if eqb_Name nx ny then Var nz else ex
  | Lam nx ex1  => if eqb_Name nx ny then ex else
                     Lam nx (rename ny nz ex1)
  | App ex1 ex2 => App (rename ny nz ex1) (rename ny nz ex2)
  end.

(** Change all bound occurrences of [Var ny] by [Var nz] in [ex].
   Used with the hypothesis that [nz] does not occur in [ex]. *)

Fixpoint alpha ny nz ex: lexp :=
  match ex with
  | Var nx      => Var nx
  | Lam nx ex1  => let ex2 := alpha ny nz ex1 in
                   if eqb_Name nx ny then Lam nz (rename nx nz ex2)
                   else Lam nx ex2
  | App ex1 ex2 => App (alpha ny nz ex1) (alpha ny nz ex2)
  end.

(* Renaming of all bound variable of a lexp which also occur in fv *)

(* (* Old buggy version which repeats the computation of the same fresh name *)
Fixpoint renaming fv all ex :=
match fv with
| [] => ex
| fx :: fvs => renaming fvs all (alpha fx (fresh all) ex)
end.
 *)

Fixpoint renaming fv avoid ex :=
  match fv with
  | [] => ex
  | fx :: fvs =>
    let freshname := fresh avoid in
    renaming fvs (freshname :: avoid) (alpha fx freshname ex)
  end.

(* straightforward substitution ex1[z:=ex2] *)

Fixpoint subst_1 nz ex2 ex1: lexp :=
  match ex1 with
  | Var nx        => if eqb_Name nx nz then ex2 else ex1
  | Lam nx ex     => if eqb_Name nx nz then ex1
                     else Lam nx (subst_1 nz ex2 ex)
  | App ex11 ex12 => App (subst_1 nz ex2 ex11) (subst_1 nz ex2 ex12)
  end.

(* substitution ex1[nx:=ex2] avoiding capture using prior renaming *)

Definition subst nx ex2 ex1 : lexp :=
  let vx := inter (vdef ex1) (vlibres ex2) in
  let avoid := allvars ex1 in
  subst_1 nx ex2 (renaming vx avoid ex1).

(* Return the list of redexes of an expression *)
(* JF : il faut en plus les repérer par leur lieu d'occurrence *)

Fixpoint redexes  ex : list lexp :=
  match ex with
  | Var nx             => []
  | App (Lam nx tx) rx => (App (Lam nx tx) rx) :: (redexes tx ++ redexes rx)
  | App lx rx          => redexes lx ++ redexes rx
  | Lam nx tx          => redexes tx
  end.

(* Occurrences *)
Inductive occ : Set :=
| Ici
| UL : occ -> occ (* sous Lam *)
| LA : occ -> occ (* Gauche App  *)
| RA : occ -> occ (* Droite App  *)
.

(* *)

Fixpoint no_UL oc : bool :=
  match oc with
  | Ici => true
  | UL _ => false
  | LA oc => no_UL oc
  | RA oc => no_UL oc
  end.

(* *)

(* Something at an occurrence *)
Definition smtg_occ chk oc ex : Prop :=
  (fix aux oc ex : Prop :=
     match oc, ex with
     | Ici, _ => chk ex
     | UL oc, Lam _ tx => aux oc tx
     | LA oc, App lx rx => aux oc lx
     | RA oc, App lx rx => aux oc rx
     | _, _ => False
     end) oc ex.

Definition anyterm (ex : lexp) := True.
(* redex at root *)
Definition rar (ex : lexp) :=
  match ex with
  | App (λ _ · _) _ => True
  | _ => False
  end.
(* free var at root *)
Definition fvr (nx: Name) (ex : lexp) :=
  match ex with
  | Var ny => if eqb_Name nx ny then True else False
  | _ => False
  end.

Definition has_occ := smtg_occ anyterm.
Definition has_red := smtg_occ rar.

Lemma has_occ_UL_LA {ex oc1 oc2} : has_occ (UL oc1) ex -> has_occ (LA oc2) ex -> False.
Proof. destruct ex; intros; assumption. Qed.

Lemma has_occ_UL_RA {ex oc1 oc2} : has_occ (UL oc1) ex -> has_occ (RA oc2) ex -> False.
Proof. destruct ex; intros; assumption. Qed.

Fixpoint subterm_at ex oc : has_occ oc ex -> lexp :=
     match oc, ex return has_occ oc ex -> lexp with
     | Ici, _ => fun oec => ex
     | UL oc, Lam _ tx => fun oec => subterm_at tx oc oec
     | LA oc, App lx rx => fun oec => subterm_at lx oc oec
     | RA oc, App lx rx => fun oec => subterm_at rx oc oec
     | _, _ => fun oec => match oec with end
     end.

Definition rewrite_at (chk : lexp -> Prop) (rewf: forall ex, chk ex -> lexp)
                      ex oc (oec : smtg_occ chk oc ex) : lexp :=
 (fix rew_at ex oc : smtg_occ chk oc ex -> lexp :=
     match oc, ex return smtg_occ chk oc ex -> lexp with
     | Ici, _ => fun oec => rewf ex oec
     | UL oc, Lam vx tx => fun oec => Lam vx (rew_at tx oc oec)
     | LA oc, App lx rx => fun oec => App (rew_at lx oc oec) rx
     | RA oc, App lx rx => fun oec => App lx (rew_at rx oc oec)
     | _, _ => fun oec => match oec with end
     end) ex oc oec.

(*
Definition rewrite_at (rewf: lexp -> lexp) ex oc (oec : has_occ oc ex) : lexp :=
 (fix rew_at ex oc : has_occ oc ex -> lexp :=
     match oc, ex return has_occ oc ex -> lexp with
     | Ici, _ => fun oec => rewf ex
     | UL oc, Lam vx tx => fun oec => Lam vx (rew_at tx oc oec)
     | LA oc, App lx rx => fun oec => App (rew_at lx oc oec) rx
     | RA oc, App lx rx => fun oec => App lx (rew_at rx oc oec)
     | _, _ => fun oec => match oec with end
     end) ex oc oec.
*)
(* Guarded occurences *)
Inductive gocc_of (chk : lexp -> Prop) ex : Set :=
  o_o : forall oc, smtg_occ chk oc ex -> gocc_of chk ex.
Definition occ_of := gocc_of anyterm.
Definition rocc_of := gocc_of rar.
Definition lift_test (f: occ -> bool) chk ex (go : gocc_of chk ex) : bool :=
  let (oc, _) := go in f oc.

(* *)
Lemma smtg_occ_impl (chk1 chk2 : lexp -> Prop) :
  (forall ex, chk1 ex -> chk2 ex) -> forall oc ex, smtg_occ chk1 oc ex -> smtg_occ chk2 oc ex.
Proof.
  intro chch.
  refine
  (fix aux oc ex : _ :=
     match oc, ex with
     | Ici, _ => chch ex
     | UL oc, Lam _ tx => aux oc tx
     | LA oc, App lx rx => aux oc lx
     | RA oc, App lx rx => aux oc rx
     | _, _ => fun F => F
     end); simpl.
Defined.

Lemma gocc_impl (chk1 chk2 : lexp -> Prop) :
  (forall ex, chk1 ex -> chk2 ex) -> forall ex, gocc_of chk1 ex -> gocc_of chk2 ex.
Proof.
  intros chch ex [oc Hoc]. exists oc. apply (smtg_occ_impl _ _ chch _ _ Hoc).
Defined.

Lemma rocc_occ {ex} : rocc_of ex -> occ_of ex.
Proof.
  apply (gocc_impl rar anyterm).
  clear ex. intros ex _. exact I.
Defined.

(* Term at a guarded occurence *)
Definition subterm_at_g ex (oe : occ_of ex) : lexp :=
  let (oc, oec) := oe in subterm_at ex oc oec.
Definition subterm_at_gr ex (oe : rocc_of ex) : lexp :=
  subterm_at_g ex (rocc_occ oe).

Definition rewrite_at_g chk rewf ex (oe : gocc_of chk ex) : lexp :=
  let (oc, oec) := oe in rewrite_at chk rewf ex oc oec.

Definition root_subst ex : rar ex -> lexp :=
  match ex with
  | App (λ nx · body) actualp => fun _ => subst nx actualp body
  | _ => fun F => match F with end
  end.

(* Applies a substitution at a (guaranteed) occurrence of a redex *)
Definition beta_at : forall ex, rocc_of ex -> lexp := rewrite_at_g rar root_subst.

(* *)

Definition lift1 (f: occ -> occ) (g: lexp -> lexp) :
  (forall oc ex, has_red oc ex -> has_red (f oc) (g ex)) ->
  (forall ex, rocc_of ex -> rocc_of (g ex)).
  intros transf ex [oc eoc].
  exists (f oc). apply (transf oc ex eoc).
Defined.

Definition same_eoc oc ex (eoc : has_red oc ex) := eoc.

Definition lift1_UL nx := lift1 UL (fun ex => λ nx· ex) same_eoc :
   forall ex, rocc_of ex -> rocc_of (λ nx· ex).
Definition lift1_LA rx := lift1 LA (fun lx => App lx rx) same_eoc :
   forall lx, rocc_of lx -> rocc_of (App lx rx).
Definition lift1_RA lx := lift1 RA (fun rx => App lx rx) same_eoc :
   forall rx, rocc_of rx -> rocc_of (App lx rx).

Fixpoint occredexes_of ex : list (rocc_of ex) :=
  match ex with
  | Var nx             => []
  | Lam nx tx          => map (lift1_UL nx tx) (occredexes_of tx)
  | App lx rx =>
    let orl := map (lift1_LA rx lx) (occredexes_of lx) in
    let orr := map (lift1_RA lx rx) (occredexes_of rx) in
    match lx return list (rocc_of (App lx rx)) -> _ with
    | (\nx· tx) => cons (o_o rar ((\nx· tx) rx) Ici I)
    | _ => fun olrx => olrx
    end (orl ++ orr)
  end.

(* For interactive use : pos_redexes, see_redex, red_beta *)

Definition map2 {A B C} (f: B -> C) : list (A*B) -> list (A*C) :=
   map (fun xy:A*B => let (x,y) := xy in (x, f y)).

(* Numbered occurrences *)
Fixpoint nbd_occ_of ex n : nat * list (nat * rocc_of ex) :=
  match ex with
  | Var nx             => (n, [])
  | Lam nx tx          =>
    let (n', l) := nbd_occ_of tx (S n) in
    (n', map2 (lift1_UL nx tx) l)
  | App lx rx =>
    let (n1, l1) := nbd_occ_of lx n in
    let (n2, l2) := nbd_occ_of rx n1 in
    let orl := map2 (lift1_LA rx lx) l1 in
    let orr := map2 (lift1_RA lx rx) l2 in
    (n2, match lx return list (nat * rocc_of (App lx rx)) -> _ with
         | λ nx· tx => cons (n, o_o rar ((λ nx· tx) rx) Ici I)
         | _ => fun olrx => olrx
         end (orl ++ orr))
  end.

Definition nbd_occredexes_of ex : list (nat * rocc_of ex) :=
  let (_, l ) := nbd_occ_of ex 1 in l.

Definition lift_fct_nb {A} (f : occ -> A) ex (nro : nat * rocc_of ex) : A :=
  let (_ , ro) := nro in let (oc, _) := ro in
  f oc.

Definition lift_cmp_nb {A} (cmp : occ -> occ -> A) ex (nro1 nro2 : nat * rocc_of ex) : A :=
  let (_ , ro1) := nro1 in let (oc1, _) := ro1 in
  let (_ , ro2) := nro2 in let (oc2, _) := ro2 in
  cmp oc1 oc2.

Definition pos_redexes ex : list nat := map fst (nbd_occredexes_of ex).
Definition pos_redexes_noUL ex : list nat :=
  let nroex := nbd_occredexes_of ex in
  let nroex_noUL := filter (lift_fct_nb no_UL ex) nroex in
  map fst nroex_noUL.

Definition wrg_nb : lexp := (w r o n g) (n u m b e r).

Definition see_redex nn1 ex : lexp :=
  (fix loop lno :=
  match lno with
  | [] => wrg_nb
  | (nn2, ro) :: lno => if eqb nn1 nn2 then subterm_at_gr ex ro else loop lno
  end) (nbd_occredexes_of ex).

Definition red_beta nn1 ex : lexp :=
  (fix loop lno :=
  match lno with
  | [] => wrg_nb
  | (nn2, ro) :: lno => if eqb nn1 nn2 then beta_at ex ro else loop lno
  end) (nbd_occredexes_of ex).

(* ********************** Comparisons between redexes ********************** *)

Definition morph (f: occ -> occ) (R: occ -> occ -> Prop) : Prop :=
  forall oc1 oc2, R oc1 oc2 -> R (f oc1) (f oc2).

Inductive more_outer : occ -> occ -> Prop :=
| mo_Ici : forall oc, more_outer Ici oc
| mo_mUL : morph UL more_outer
| mo_mLA : morph LA more_outer
| mo_mRA : morph RA more_outer
.

Definition more_inner oc1 oc2 := more_outer oc2 oc1.

Lemma more_outer_refl : forall oc, more_outer oc oc.
Proof.
  induction oc as [ | ex Hex | ex Hex | ex Hex].
  - apply mo_Ici.
  - apply mo_mUL; apply Hex.
  - apply mo_mLA; apply Hex.
  - apply mo_mRA; apply Hex.
Qed.

(* transitive (then partial pre-order) *)
Lemma more_outer_trans :
  forall oc1 oc2 oc3,
  more_outer oc1 oc2 -> more_outer oc2 oc3 -> more_outer oc1 oc3.
Proof.
  intros * lo12. revert oc3.
  induction lo12 as [oc | oc1 oc2 lo12 Hlo12 | oc1 oc2 lo12 Hlo12 | oc1 oc2 lo12 Hlo12];
    intros oc3 lo13.
  - inversion lo13; clear lo13; subst; apply mo_Ici.
  - inversion lo13; clear lo13; subst. apply mo_mUL. apply Hlo12; assumption.
  - inversion lo13; clear lo13; subst. apply mo_mLA. apply Hlo12; assumption.
  - inversion lo13; clear lo13; subst. apply mo_mRA. apply Hlo12; assumption.
Qed.

(* transitive (then partial pre-order) on occurrences of a given lexp *)
Lemma more_outer_trans_complicated :
  forall oc1 oc2 oc3 ex,
  has_occ oc1 ex -> has_occ oc2 ex -> has_occ oc3 ex ->
  more_outer oc1 oc2 -> more_outer oc2 oc3 -> more_outer oc1 oc3.
Proof.
  intros * ho1 ho2 ho3 lo12. revert oc3 ex ho1 ho2 ho3.
  induction lo12 as [oc | oc1 oc2 lo12 Hlo12 | oc1 oc2 lo12 Hlo12 | oc1 oc2 lo12 Hlo12];
    intros oc3 ex ho1 ho2 ho3 lo13.
  - inversion lo13; clear lo13; subst; apply mo_Ici.
  - inversion lo13; clear lo13; subst. apply mo_mUL.
    destruct ex as [ |nx ex | ]; try (case ho1).
    apply Hlo12 with (ex:=ex); assumption.
  - inversion lo13; clear lo13; subst. apply mo_mLA.
    destruct ex as [ |nx ex | ]; try (case ho1).
    apply Hlo12 with (ex:=ex1); assumption.
  - inversion lo13; clear lo13; subst. apply mo_mRA.
    destruct ex as [ |nx ex | ]; try (case ho1).
    apply Hlo12 with (ex:=ex2); assumption.
Qed.

(* Ad-hoc mais a l'air de marcher. Laissé pour le test mais À VIRER + tard *)
Fixpoint mlob oc1 oc2 : bool :=
  match oc1, oc2 with
  | Ici, LA (UL _) => true
  | LA _, Ici => true
  | LA _, RA _ => true
  | Ici, RA _ => true
  | Ici, UL _ => true
  | UL oc1, UL oc2 => mlob oc1 oc2
  | LA oc1, LA oc2 => mlob oc1 oc2
  | RA oc1, RA oc2 => mlob oc1 oc2
  |  _, _ => false
  end.

(* For partial ordering *)
Inductive pcomp : Set := Pe | Pl | Pg | Pn (* not comparable *).

(* outermost - innermost *)
Fixpoint oi oc1 oc2 : pcomp :=
  match oc1, oc2 with
  | Ici, Ici => Pe
  | Ici, _ => Pl
  | _, Ici => Pg
  | UL oc1, UL oc2 => oi oc1 oc2
  | LA oc1, LA oc2 => oi oc1 oc2
  | RA oc1, RA oc2 => oi oc1 oc2
  |  _, _ => Pn
  end.

(* leftmost - rightmost *)
Fixpoint lr oc1 oc2 : comparison :=
  match oc1, oc2 with
  | Ici, Ici => Eq
  | Ici, UL _ => Lt
  | UL _, Ici => Gt
  | UL oc1, UL oc2 => lr oc1 oc2
  | LA oc1, LA oc2 => lr oc1 oc2
  | RA oc1, RA oc2 => lr oc1 oc2
  | LA _, _ => Lt
  | _, LA _ => Gt
  | RA _, _ => Gt
  | _, RA _ => Lt
  end.

(* Pour l'honneur : sans discrminate *)
Lemma oi_eq : forall oc1 oc2, oi oc1 oc2 = Pe -> oc1 = oc2.
Proof.
  pose (discr (oc1 oc2 : occ) x := match x with Pe => oc2 | _ => oc1 end).
  exact (
      fix loop oc1 oc2 : _ :=
        match oc1, oc2 with
        | Ici, Ici => fun e => eq_refl
        | UL oc1, UL oc2 => fun e => f_equal UL (loop oc1 oc2 e)
        | LA oc1, LA oc2 => fun e => f_equal LA (loop oc1 oc2 e)
        | RA oc1, RA oc2 => fun e => f_equal RA (loop oc1 oc2 e)
        | oc1, oc2 => fun e => f_equal (discr oc1 oc2) e
        end).
Qed.

(* leftmore outermore (strict) *)
Definition strict_le_ou oc1 oc2 : bool :=
  match oi oc1 oc2 with
    | Pe => false
    | Pl => true
    | Pg => false
    | Pn => match lr oc1 oc2 with
              | Eq => false
              | Lt => true
              | Gt => false
            end
  end.

(* OK for the next :
   problematic cases are meaningless for occurrences of redexes in an actual lexp *)
Lemma mlob_sameas_strict_le_ou :
  forall oc1 oc2 ex, has_red oc1 ex -> has_red oc2 ex -> mlob oc1 oc2 = strict_le_ou oc1 oc2.
Proof.
Abort.

(* le_ou yields a total order ; anyway only different occurrences will be compared *)
(*
(* Direct version with an artificial excahnge of args in innermost *)
Definition horizontal_obsol := occ -> occ -> bool.
Definition vertical_obsol := horizontal_obsol -> occ -> occ -> bool.
Definition outermost_obsol : vertical_obsol := fun k oc1 oc2 =>
    match oi oc1 oc2 with
    | Pe => true
    | Pl => true
    | Pg => false
    | Pn => k oc1 oc2
    end.
Definition innermost_obsol : vertical_obsol :=
  fun k oc1 oc2 => outermost_obsol (fun oc2 oc1 => k oc1 oc2) oc2 oc1.

Definition leftmost_obsol : horizontal_obsol := fun oc1 oc2 =>
    match lr oc1 oc2 with
    | Eq => true
    | Lt => true
    | Gt => false
    end.

Definition rightmost_obsol : horizontal_obsol := fun oc1 oc2 => leftmost_obsol oc2 oc1.

Definition strategy (h: horizontal_obsol) (v: vertical_obsol) := v h.

Definition le_ou_obsol := strategy leftmost_obsol outermost_obsol.
Definition ri_ou_obsol := strategy rightmost_obsol outermost_obsol.
Definition le_in_obsol := strategy leftmost_obsol innermost_obsol.
Definition ri_in_obsol := strategy rightmost_obsol innermost_obsol.
*)

(* CPS version, with a unit -> to keep lazyness in cbv (pour l'honneur) *)
Definition horizontal := occ -> occ ->  ((unit -> bool) -> bool) -> bool.
Definition vertical := occ -> occ -> ((unit -> bool) -> bool).

Definition outermost : vertical := fun oc1 oc2 =>
    match oi oc1 oc2 with
    | Pe => fun _ => true
    | Pl => fun _ => true
    | Pg => fun _ => false
    | Pn => fun b => b tt
    end.

Definition leftmost : horizontal := fun oc1 oc2 =>
    fun k => k (fun _ =>
    (match lr oc1 oc2 with
    | Eq => true
    | Lt => true
    | Gt => false
    end)).

Definition le_ou oc1 oc2 := leftmost oc1 oc2 (outermost oc1 oc2).
Definition ri_ou oc1 oc2 := leftmost oc2 oc1 (outermost oc1 oc2).
Definition le_in oc1 oc2 := leftmost oc1 oc2 (outermost oc2 oc1).
Definition ri_in oc1 oc2 := leftmost oc2 oc1 (outermost oc2 oc1).

(*
(* The 2 versions are equivalent *)
Lemma verif_le_ou oc1 oc2 : le_ou oc1 oc2 = le_ou_obsol oc1 oc2.
Proof.
  unfold le_ou, le_ou_obsol. unfold strategy, outermost, outermost_obsol.
  destruct (oi oc1 oc2); reflexivity.
Qed.

Lemma verif_ri_ou oc1 oc2 : ri_ou oc1 oc2 = ri_ou_obsol oc1 oc2.
Proof.
  unfold ri_ou, ri_ou_obsol. unfold strategy, outermost, outermost_obsol.
  destruct (oi oc1 oc2); reflexivity.
Qed.

Lemma verif_ri_in oc1 oc2 : ri_in oc1 oc2 = ri_in_obsol oc1 oc2.
Proof.
  unfold ri_in, ri_in_obsol. unfold strategy, outermost, innermost_obsol, leftmost, outermost_obsol.
  destruct (oi oc2 oc1); reflexivity.
Qed.

Lemma verif_le_in oc1 oc2 : le_in oc1 oc2 = le_in_obsol oc1 oc2.
Proof.
  unfold le_in, le_in_obsol. unfold strategy, outermost, innermost_obsol, leftmost, outermost_obsol.
  destruct (oi oc2 oc1); reflexivity.
Qed.
 *)

(* *)

Definition min {A} (cmp : A -> A -> bool) x y := if cmp x y then x else y.

Fixpoint minlist1 {A} (cmp : A -> A -> bool) x l : A :=
  match l with
  | [] => x
  | x' :: l' => min cmp x (minlist1 cmp x' l')
  end.

Definition non_empty {A} (l: list A) : Prop :=
  match l with
  | [] => False
  | x' :: l' => True
  end.

Definition depres {A} (l: list A) : Type :=
  match l with
  | [] => list A
  | x' :: l' => A * list A
  end.

Definition minlistdep {A} (cmp : A -> A -> bool) l : depres l :=
  match l with
  | [] => l
  | x' :: l' => (minlist1 cmp x' l', l)
  end.

Definition hdtl {A} (l: list A) : non_empty l -> A * list A :=
  match l with
  | [] => fun F => match F with end
  | x' :: l' => fun _ => (x', l')
  end.

Definition minlist {A} (cmp : A -> A -> bool) l : non_empty l -> A :=
  match l with
  | [] => fun F => match F with end
  | x' :: l' => fun _ => minlist1 cmp x' l'
  end.

(* ********************** The different types of normal forms ********************** *)

(* Check if an expression is under (strong) normal form
   N :::= λx. N | x N1 N2 .. Nn *)

Fixpoint fnorm  ex : bool :=
  match ex with
  | Var nx             => true
  | App (Lam nx tx) rx => false
  | App lx rx          => (fnorm lx) && (fnorm rx)
  | Lam nx tx          => fnorm tx
  end.

(* Check if an expression is under weak normal form
   W :::= λx. e | x W1 W2 .. Wn *)

Fixpoint is_wnf  ex : bool :=
  match ex with
  | Var nx             => true
  | Lam nx tx          => true
  | App (Lam nx tx) rx => false
  | App lx rx          => (is_wnf lx) && (is_wnf rx)
  end.

(* Check if an expression is under head normal form
   H :::= λx. H | x e1 e2 .. en *)

Fixpoint is_hnf  ex : bool :=
  match ex with
  | Var nx             => true
  | App (Lam nx tx) rx => false
  | App lx rx          => is_hnf lx
  | Lam nx tx          => is_hnf tx
  end.

(* Check if an expression is under weak head normal form
   WH :::= λx. e | x e1 e2 .. en *)

Fixpoint is_whnf  ex : bool :=
  match ex with
  | Var nx             => true
  | Lam nx tx          => true
  | App (Lam nx tx) rx => false
  | App lx rx          => is_whnf lx
  end.

(* ****************** The different reduction strategies ******************* *)

(* One step leftmost outermost beta-reduction *)

Fixpoint red1_lo ex : option lexp :=
  match ex with
  | App (Lam nx ex1) ex2 => Some (subst nx ex2 ex1)
  | App ex1 ex2          => match (red1_lo ex1) with
                            | None => match (red1_lo ex2) with
                                      | None => None
                                      | Some ex2' => Some (App ex1 ex2')
                                      end
                            | Some ex1' => Some (App ex1' ex2)
                            end
  | Lam nx ex1          => match (red1_lo ex1) with
                           | None => None
                           | Some ex1' => Some (Lam nx ex1')
                           end
  | _ => None
  end.

(* One step weak leftmost outermost beta-reduction *)

Fixpoint red1_low ex : option lexp :=
  match ex with
  | App (Lam nx ex1) ex2 => Some (subst nx ex2 ex1)
  | App ex1 ex2          => match (red1_low ex1) with
                            | None =>  None
                            | Some ex1' => Some (App ex1' ex2)
                            end
  | _ => None
  end.

(* One step rightmost outermost beta-reduction *)

Fixpoint red1_ro ex : option lexp :=
  match ex with
  | App (Lam nx ex1) ex2 =>  match (red1_ro ex2) with
                             | None      => Some (subst nx ex2 ex1)
                             | Some ex2' => Some (App (Lam nx ex1) ex2')
                             end

  | App ex1 ex2          => match (red1_ro ex2) with
                            | None => match (red1_ro ex1) with
                                      | None => None
                                      | Some ex1' => Some (App ex1' ex2)
                                      end
                            | Some ex2' => Some (App ex1 ex2')
                            end
  | Lam nx ex1          => match (red1_lo ex1) with
                           | None => None
                           | Some ex1' => Some (Lam nx ex1')
                           end
  | _ => None
  end.

(* One step weak rightmost outermost beta-reduction *)

Fixpoint red1_row ex : option lexp :=
  match ex with
  | App (Lam nx ex1) ex2 =>  match (red1_row ex2) with
                             | None      => Some (subst nx ex2 ex1)
                             | Some ex2' => Some (App (Lam nx ex1) ex2')
                             end

  | App ex1 ex2          => match (red1_row ex2) with
                            | None => match (red1_row ex1) with
                                      | None => None
                                      | Some ex1' => Some (App ex1' ex2)
                                      end
                            | Some ex2' => Some (App ex1 ex2')
                            end
  | _ => None
  end.

(* One reduction step by the one step reduction function rs *)

Definition red1 rs ex : lexp :=
  match rs ex with
  | None => ex
  | Some ex' => ex'
  end.

(* Expression denoting an out of bound computation *)
Definition toolong := \a b o r t·(t o o) (l o n g).

(* Reduction by rs until normal form (bounded by nx steps) *)

Fixpoint redn rs nx ex : lexp :=
  match nx with
  | 0    => toolong
  | S nx => match rs ex with
         | None => ex
         | Some ex' => redn rs nx ex'
            end
  end.

(* ====================================================================== *)
(* Reduction sequences, represented by vide/step lists of
  - a lexp E
  - the list lr of occurrences of all redexes (number for readability) in E
  - the list lw of occurrences of weak redexes (number for readability) in E
  - a number chosen in lr (or lw), or 0 if non-significant
*)

Inductive llexp :=
 | vide : llexp
 | step : lexp * list nat * list nat * nat -> llexp -> llexp.

Notation " { x } " := (step x vide).

Notation " { x '--β->' y '--β->' .. '--β->' z } "
:= (step x (step y .. (step z vide) ..))
   (at level 200,
    format " '{'  x '//' '--β->'  y '//' '--β->'  .. '//' '--β->'  z '}' ").

(* Building the list of reductions by rs until normal form (bounded by nx steps) *)

(* Reductions sequences based on a directly programmed reduction strategy
  (last number is 0 -- not significant *)
Definition showstep ex := step (ex, pos_redexes ex, pos_redexes_noUL ex, 0).
Fixpoint shown rs nx ex :=
  match nx with
  | 0    => step (toolong, [], [], 0) vide
  | S nx => match rs ex with
            | None => showstep ex vide
            | Some ex' => showstep ex (shown rs nx ex')
            end
  end.

(* Reductions sequences based on explicit choice of a redex occurrence,
   strategy represented by a cmp function *)
Fixpoint showncmp (weak: bool) cmp nx ex :=
  match nx with
  | 0    => step (toolong, [], [], 0) vide
  | S nx =>
    let nroex := nbd_occredexes_of ex in
    let nroex_noUL := filter (lift_fct_nb no_UL ex) nroex in
    let actual_nroex := if weak then nroex_noUL else nroex in
    match actual_nroex with
    | [] => step (ex, map fst nroex, [], 0) vide
    | nro1 :: lnro =>
      let chosen := minlist1 (lift_cmp_nb cmp ex) nro1 lnro in
      let ex' := beta_at ex (snd chosen) in
      step (ex, map fst nroex, map fst nroex_noUL, fst chosen) (showncmp weak cmp nx ex')
    end
  end.

(* The reduction strategies *)

(* Strong call-by-name (normal order bounded by 5000 (or 100) reduction steps) *)

Definition red1_cbn ex := red1  red1_lo ex.
Definition red_cbn  ex := redn  red1_lo 5000 ex.
Definition show_cbn_0 ex := shown red1_lo 100 ex.  (* pour mémoire *)
Definition show_cbn_l ex := showncmp false le_ou 100 ex.
Definition show_cbn_r ex := showncmp false ri_ou 100 ex.
Definition show_wcbn_l ex := showncmp true le_ou 100 ex.
Definition show_wcbn_r ex := showncmp true ri_ou 100 ex.
Definition show_cbn := show_cbn_l.
Definition show_wcbn := show_wcbn_l.

(* Strong call-by-value  (bounded by 5000 (or 100) reduction steps) *)
Definition show_cbv_l ex := showncmp false le_in 100 ex.
Definition show_cbv_r ex := showncmp false ri_in 100 ex.
Definition show_cbv := show_cbv_r.

(* Weak call-by-name (normal order bounded by 5000 (or 100) reduction steps) *)
Definition show_wcbv_l ex := showncmp true le_in 100 ex.
Definition show_wcbv_r ex := showncmp true ri_in 100 ex.
Definition show_wcbv := show_wcbv_r.

(* Strong call-by-value  (bounded by 5000 (or 100) reduction steps) *)

Definition red1_cbv ex := red1  red1_ro ex.
Definition red_cbv  ex := redn  red1_ro 5000 ex.
Definition show_cbv_0 ex := shown red1_ro 100 ex. (* pour mémoire *)

(* Weak call-by-name (normal order bounded by 5000 (or 100) reduction steps) *)

Definition red1_wcbn ex := red1  red1_low ex.
Definition red_wcbn  ex := redn  red1_low 5000 ex.
Definition show_wcbn_0 ex := shown red1_low 100 ex. (* pour mémoire *)

(* Weak call-by-value  (bounded by 5000 (or 100) reduction steps) *)

Definition red1_wcbv ex := red1  red1_row ex.
Definition red_wcbv  ex := redn  red1_row 5000 ex.
Definition show_wcbv_0 ex := shown red1_row 100 ex. (* pour mémoire *)

(* Syntactic equality modulo alpha-conversion of lexps *)

Fixpoint eq_lexp tx1 tx2 :bool :=
  match tx1, tx2 with
  | Var nx1, Var nx2         => eqb_Name nx1 nx2
  | App lx1 rx1, App lx2 rx2 => (eq_lexp lx1 lx2) && (eq_lexp rx1 rx2)
  | Lam nx1 tx1, Lam nx2 tx2 => if eqb_Name nx1 nx2 then eq_lexp tx1 tx2
                                else eq_lexp tx1 (subst nx2 (Var nx1) tx2)
  | _, _                     => false
  end.

(* Equivalence (modulo alpha and beta conversion) of lexps *)

Definition equiv_lexp (e1 e2:lexp) := eq_lexp (red_cbn e1) (red_cbn e2).

Definition equiv_lexp_P (e1 e2:lexp) := equiv_lexp e1 e2.

Notation " x == y" := (equiv_lexp_P x y) (at level 10).

(* ------------------------------------------------------------------------------------------
(* Tests et exemples *)

(* x N1 ... Nn *)
Definition xN1Nn := x (\a· a) (\b· b).

(* x e1 .. en *)
Definition xe1en := x ((\a·a) (\b·b)).

(* \x.x N1 ... Nn *)
Definition lxxN1Nn := \x·x (λ a·a) (\b·b).

Print lxxN1Nn.

(* \x.x e1 ... en *)
Definition lxxe1en := \x·x ((\a·a) (\b·b)).

(* \x.e *)
Definition lxe := \x·(\a·a) (\b·b).

(* (\x.E)F *)
Definition lxef := (\a·a)(\b·b).

Definition test := lxe lxef lxe.

Definition testfn := λ x y· y.

Compute (vlibres xN1Nn).
(* [x] *)

Compute (vliees xN1Nn).
(* [a; b] *)

Compute (vars xN1Nn).
(* [x; a; b] *)

Compute (rename y a (\x·x y (\y· y x z))).
(* λ x · (x a) (λ y · (y x) z) *)

Compute (alpha x z1 (\x·x y (\y· y x z))).
(* λ z1 · (z1 y) (λ y · (y z1) z) *)

Definition tol := List.map Lett.

Compute (renaming (tol [y]) (tol [x;y;z]) (\x·x y (\y· y x z))).
(* λ x · (x y) (λ a · (a x) z) *)

Compute (subst x (\x·y) (x y (\y· y x z))).
(* (λ x · y) y (λ a · (a (λ x · y)) z) *)

Compute (pos_redexes (x ((\y·y) (\z·z)))).
(* [1] *)
Compute see_redex 1 (x ((\y·y) (\z·z))).
(* (λ y · y) (λ z · z) *)
Compute red_beta 1  (x ((\y·y) (\z·z))).
(* x (λ z · z) *)

Compute (pos_redexes (x (\y·y) (\z·z))).
(* [] *)

Definition deuxred := (\x y·x)  ((\y·y) (\z·z)).
Compute redexes deuxred.
(* [(λ x y · x) ((λ y · y) (λ z · z)); (λ y · y) (λ z · z) *)

Compute (pos_redexes deuxred). (* [1; 3] *)
Compute see_redex 1 deuxred.
(* (λ x y · x) ((λ y · y) (λ z · z)) *)
Compute red_beta 1 deuxred.
(* λ y · (λ y · y) (λ z · z) *)
Compute see_redex 3 deuxred.
(* (λ y · y) (λ z · z) *)
Compute red_beta 3 deuxred.
(* (λ x y · x) (λ z · z) *)

Definition septred := (deuxred u ((\x· deuxred) (\y·y y)) v deuxred).
Compute septred.
(* (λ x y · x) ((λ y · y) (λ z · z)) u ((λ x · (λ x y · x) ((λ y · y) (λ z · z))) (λ y · y y)) v
         ((λ x y · x) ((λ y · y) (λ z · z))) *)
Compute (pos_redexes septred). (* [1; 3; 5; 6; 8; 11; 13] *)
Compute see_redex 1 septred.
(* (λ x y · x) ((λ y · y) (λ z · z)) *)
Compute red_beta 1 septred.
(* (λ y · y) (λ z · z) u ((λ x · (λ x y · x) ((λ y · y) (λ z · z))) (λ y · y y)) v
         ((λ x y · x) ((λ y · y) (λ z · z))) *)
Compute subterm_at septred (LA (LA (RA Ici))) I.
Compute see_redex 5 septred.
(* (λ x · (λ x y · x) ((λ y · y) (λ z · z))) (λ y · y y) *)
Compute red_beta 5 septred.
(* (λ x y · x) ((λ y · y) (λ z · z)) u (λ y · y y) v ((λ x y · x) ((λ y · y) (λ z · z))) *)

Compute (fnorm xN1Nn).    (* true  *)
Compute (fnorm xe1en).    (* false *)
Compute (fnorm lxxN1Nn).  (* true  *)
Compute (fnorm lxxe1en).  (* false *)
Compute (fnorm lxe).      (* false *)
Compute (fnorm lxef).     (* false *)

Compute (is_wnf xN1Nn).   (* true  *)
Compute (is_wnf xe1en).   (* false *)
Compute (is_wnf lxxN1Nn). (* true  *)
Compute (is_wnf lxxe1en). (* true  *)
Compute (is_wnf lxe).     (* true  *)
Compute (is_wnf lxef).    (* false *)

Compute (is_hnf xN1Nn).   (* true  *)
Compute (is_hnf xe1en).   (* true  *)
Compute (is_hnf lxxN1Nn). (* true  *)
Compute (is_hnf lxxe1en). (* true  *)
Compute (is_hnf lxe).     (* false *)
Compute (is_hnf lxef).    (* false *)

Compute (is_whnf xN1Nn).   (* true  *)
Compute (is_whnf xe1en).   (* true  *)
Compute (is_whnf lxxN1Nn). (* true  *)
Compute (is_whnf lxxe1en). (* true  *)
Compute (is_whnf lxe).     (* true  *)
Compute (is_whnf lxef).    (* false *)

Compute (red1_cbn test).
(* (λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)) *)
Compute (red_cbn  test).
(* λ x b · b *)
Compute (show_cbn test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 0)
--β-> ((λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 4], [1], 0)
--β-> ((λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 3], [1], 0)
--β-> (λ x · (λ a · a) (λ b · b), [2], [], 0)
--β-> (λ x b · b, [], [], 0)}
*)
Compute (show_cbn_l test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 1)
--β-> ((λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 4], [1], 1)
--β-> ((λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 3], [1], 1)
--β-> (λ x · (λ a · a) (λ b · b), [2], [], 2)
--β-> (λ x b · b, [], [], 0)}
*)
Compute (show_cbn_r test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 7)
--β-> ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x b · b), [1; 2; 4], [1; 4], 1)
--β-> ((λ a · a) (λ b · b) (λ x b · b), [1], [1], 1)
--β-> ((λ b · b) (λ x b · b), [1], [1], 1)
--β-> (λ x b · b, [], [], 0)}
*)
Compute (show_wcbn_r test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 1)
--β-> ((λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 4], [1], 1)
--β-> ((λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 3], [1], 1)
--β-> (λ x · (λ a · a) (λ b · b), [2], [], 0)}
 *)

Compute (red1_cbv test).
(* (λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x b · b) *)
Compute (red_cbv  test).
(* λ x b · b *)
Compute (show_cbv test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 0)
--β-> ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x b · b), [1; 2; 4], [1; 4], 0)
--β-> ((λ x · (λ a · a) (λ b · b)) (λ b · b) (λ x b · b), [1; 2], [1], 0)
--β-> ((λ a · a) (λ b · b) (λ x b · b), [1], [1], 0)
--β-> ((λ b · b) (λ x b · b), [1], [1], 0)
--β-> (λ x b · b, [], [], 0)}
*)
Compute (show_cbv_r test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 7)
--β-> ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x b · b), [1; 2; 4], [1; 4], 4)
--β-> ((λ x · (λ a · a) (λ b · b)) (λ b · b) (λ x b · b), [1; 2], [1], 2)
--β-> ((λ x b · b) (λ b · b) (λ x b · b), [1], [1], 1)
--β-> ((λ b · b) (λ x b · b), [1], [1], 1)
--β-> (λ x b · b, [], [], 0)}
*)
Compute (show_cbv_l test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 2)
--β-> ((λ x b · b) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 3; 6], [1; 3], 3)
--β-> ((λ x b · b) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 5], [1], 1)
--β-> ((λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 3], [1], 3)
--β-> ((λ b · b) (λ x b · b), [1], [1], 1)
--β-> (λ x b · b, [], [], 0)}
*)

Compute (red1_wcbn test).
(* (λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)) *)
Compute (red_wcbn  test).
(* λ x · (λ a · a) (λ b · b) *)
Compute (show_wcbn test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 0)
--β-> ((λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 4], [1], 0)
--β-> ((λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 3], [1], 0)
--β-> (λ x · (λ a · a) (λ b · b), [2], [], 0)}
*)
Compute (show_wcbn_l test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 1)
--β-> ((λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 4], [1], 1)
--β-> ((λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 3], [1], 1)
--β-> (λ x · (λ a · a) (λ b · b), [], [], 0)}
 *)

Compute (red1_wcbv test).
(* (λ x · (λ a · a) (λ b · b)) (λ b · b) (λ x · (λ a · a) (λ b · b)) *)
Compute (red_wcbv test).
(* λ x · (λ a · a) (λ b · b) *)
Compute (show_wcbv test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 0)
--β-> ((λ x · (λ a · a) (λ b · b)) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 2; 6], [1], 0)
--β-> ((λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 4], [1], 0)
--β-> ((λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 3], [1], 0)
--β-> (λ x · (λ a · a) (λ b · b), [2], [], 0)}
*)
Compute (show_wcbv_r test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 4)
--β-> ((λ x · (λ a · a) (λ b · b)) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 2; 6], [1], 1)
--β-> ((λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 4], [1], 1)
--β-> ((λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 3], [1], 1)
--β-> (λ x · (λ a · a) (λ b · b), [2], [], 0)}
*)
Compute (show_wcbv_l test).
(*   =  { ((λ x · (λ a · a) (λ b · b)) ((λ a · a) (λ b · b)) (λ x · (λ a · a) (λ b · b)), [1; 2; 4; 7], [1; 4], 4)
--β-> ((λ x · (λ a · a) (λ b · b)) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 2; 6], [1], 1)
--β-> ((λ a · a) (λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 4], [1], 1)
--β-> ((λ b · b) (λ x · (λ a · a) (λ b · b)), [1; 3], [1], 1)
--β-> (λ x · (λ a · a) (λ b · b), [2], [], 0)}
 *)

Compute (equiv_lexp test testfn).  (* true *)
Eval compute in (test == testfn).  (* true *)

*)


Require Import Arith.

Theorem bounded : forall n, exists m, n < m.
Proof.
  refine
    (fix bounded (n : nat) : exists m, n < m :=
      match n as n0 return exists m, n0 < m  with
        | 0 => ex_intro (fun m : nat => 0 < m) 1 (lt_O_Sn 0)
        | S n1 => match (bounded n1) with
                    | ex_intro m P =>  ex_intro (fun m0 : nat => S n1 < m0) (S m) (lt_n_S n1 m P)
                  end
      end).
Defined.


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Theorem plus_id_exercise : forall n m o : nat, n = m -> m = o -> n + m = m + o.
1 subgoal

  ============================
  forall n m o : nat, n = m -> m = o -> n + m = m + o

plus_id_exercise < Proof.
1 subgoal

  ============================
  forall n m o : nat, n = m -> m = o -> n + m = m + o

plus_id_exercise < info_auto.
Debug: (* info auto : *)
Debug:
 intro.
 intro.
 intro.
 intro.
 intro.
 apply f_equal2_nat.
  assumption.
  assumption.
No more subgoals.

plus_id_exercise < Qed.
Proof.
info_auto.

Qed.
plus_id_exercise is defined

Coq <


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat.
From Categories Require Import Functor.Main.
From Categories Require Import Basic_Cons.Product.

Local Open Scope morphism_scope.

(**
Given two objects a and b the exponential (bᵃ, denoted 'Exponential a b' below)
is intuitively the internal representation of homomorphisms from a to b – it is
sometimes referred to as the internal hom. The notion of exponential is a
generalization of the notion function space from set theory.

Definition: bᵃ is an object equipped with an evaluation function eval: bᵃ×a -> b
such that for any other object z with arrow f : z×a -> b, we have a unique arrow
f^ that makes the following diagram commute:

#
<pre>
               eval
        bᵃ×a ——————————> b
         ↑             ↗
  bᵃ     |            /
  ↑      | <f^,idₐ>  /
  |      |          /
  |∃!f̂ ^  |         /
  |      |        / f
  z      |       /
         |      /
         |     /
         |    /
         |   /
         |  /
         z×a
</pre>
#
where <f, g> is the arrow map of the product functor.
*)
Record Exponential {C : Category} {HP : Has_Products C} (c d : Obj) : Type :=
{
  exponential : C;

  eval : ((×ᶠⁿᶜ C) _o (exponential, c))%object --> d;

  Exp_morph_ex :
    ∀ (z : C), (((×ᶠⁿᶜ C) _o (z, c))%object --> d) → (z --> exponential);

  Exp_morph_com : ∀ (z : C) (f : ((×ᶠⁿᶜ C) _o (z, c))%object --> d),
      f = (eval ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _)
                            (Exp_morph_ex z f, id c)))%morphism;

  Exp_morph_unique : ∀ (z : C) (f : ((×ᶠⁿᶜ C) _o (z, c))%object --> d)
                       (u u' : z --> exponential),
      f = (eval ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (u, id c)))%morphism →
      f = (eval ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (u', id c)))%morphism →
      u = u'
}.

Coercion exponential : Exponential >-> Obj.

Arguments Exponential _ {_} _ _, {_ _} _ _.

Arguments exponential {_ _ _ _} _, {_ _} _ _ {_}.
Arguments eval {_ _ _ _} _, {_ _} _ _ {_}.
Arguments Exp_morph_ex {_ _ _ _} _ _ _, {_ _} _ _ {_} _ _.
Arguments Exp_morph_com {_ _ _ _} _ _ _, {_ _} _ _ {_} _ _.
Arguments Exp_morph_unique {_ _ _ _} _ _ _ _ _ _ _, {_ _} _ _ {_} _ _ _ _ _ _.

Notation "a ⇑ b" := (Exponential a b) : object_scope.

(** Exponentials are unique up to isomorphism. *)
Theorem Exponential_iso {C : Category} {HP : Has_Products C} (c d : C)
        (E E' : (c ⇑ d)%object) : (E ≃ E')%isomorphism.
Proof.
  eapply
    (Build_Isomorphism
        _
        _
        _
        (Exp_morph_ex E' _ (eval E))
        (Exp_morph_ex E _ (eval E')));
  eapply Exp_morph_unique; eauto;
  simpl_ids;
  match goal with
      [|- (_ ∘ ?M)%morphism = _] =>
      match M with
        (?U _a (?A ∘ ?B, ?C))%morphism =>
        assert (M = (U @_a (_, _) (_, _) (A, C))
                          ∘ (U @_a (_, _) (_, _) (B, C)))%morphism as HM;
          [simpl_ids; rewrite <- F_compose; simpl; simpl_ids; trivial|rewrite HM]
      end
  end;
  rewrite <- assoc;
  repeat rewrite <- Exp_morph_com; auto.
Qed.

Definition Has_Exponentials (C : Category) {HP : Has_Products C} :=
  ∀ a b, (a ⇑ b)%object.

Existing Class Has_Exponentials.

Section Curry_UnCurry.
  Context (C : Category) {HP : Has_Products C} {HE : Has_Exponentials C}.

  (** Given a arrow f: a×b -> c in a category with exponentials, the curry of f
      is f̂f^ in the definition of Exponential above. *)
  Definition curry {a b c : C} :
    (((×ᶠⁿᶜ C) _o (a, b))%object --> c) → (a --> (HE b c)) :=
    fun (f : ((×ᶠⁿᶜ C) _o (a, b))%object --> c) =>
      Exp_morph_ex (HE b c) _ f.

  (** Given an arrow f: a -> cᵇ, uncurry of f is the arrow
      (eval_cᵇ ∘ <id_b, f>): a×b -> c.
      See definition of Exponential above for details. *)
  Definition uncurry {a b c : C} :
      (a --> (HE b c)) → (((×ᶠⁿᶜ C) _o (a, b))%object --> c) :=
    fun (f : a --> (HE b c)) =>
      ((eval (HE b c)) ∘ ((×ᶠⁿᶜ C) @_a (_, _) (_, _) (f, id C b)))%morphism.

  Section inversion.
    Context {a b c : C}.

    (** See definition of curry and uncurry above for details.
        Frollows immediately from the definition of Exponential above. *)
    Theorem curry_uncurry (f : a --> (HE b c)) : curry (uncurry f) = f.
    Proof.
      unfold curry, uncurry.
      eapply Exp_morph_unique; trivial.
      rewrite <- Exp_morph_com; trivial.
    Qed.

    (** See definition of curry and uncurry above for details.
        Follows immediately from the definition of Exponential above. *)
    Theorem uncurry_curry (f : ((×ᶠⁿᶜ C) _o (a, b))%object --> c) :
      uncurry (curry f) = f.
    Proof.
      unfold curry, uncurry.
      rewrite <- Exp_morph_com; trivial.
    Qed.

  End inversion.

  Section injectivity.
    Context {a b c : C}.

    (** See definition of curry above for details. Follows immediately from
        uncurry_curry above. *)
    Theorem curry_injective (f g : ((×ᶠⁿᶜ C) _o (a, b))%object --> c) :
      curry f = curry g → f = g.
    Proof.
      intros H.
      rewrite <- (uncurry_curry f); rewrite <- (uncurry_curry g).
      rewrite H; trivial.
    Qed.

    (** See definition of uncurry above for details.
        Follows immediately from curry_uncurry above. *)
    Theorem uncurry_injective (f g : a --> (HE b c)) :
      uncurry f = uncurry g → f = g.
    Proof.
      intros H.
      rewrite <- (curry_uncurry f); rewrite <- (curry_uncurry g).
      rewrite H; trivial.
    Qed.

  End injectivity.

  Section curry_compose.
    Context {a b c : C}.

    (** composing with curry is equivalent to compose and then curry: *)
    Lemma curry_compose (f : ((×ᶠⁿᶜ C) _o (a, b))%object --> c)
          {z : C} (g : z --> a)
      : (curry f) ∘ g = curry (f ∘ (Prod_morph_ex _ _ (g ∘ Pi_1) Pi_2)).
    Proof.
      unfold curry.
      eapply Exp_morph_unique; eauto.
      rewrite <- Exp_morph_com.
      match goal with
          [|- ((_ ∘ (_ _a) ?M) ∘ _)%morphism = _] =>
          match M with
              ((?N ∘ ?x)%morphism, id ?y) =>
              replace M with
              (compose (_ × _) (_, _) (_, _) (_, _) (x, id y) (N,id y)) by
                  (cbn; auto)
          end
      end.
      rewrite F_compose.
      cbn; simpl_ids.
      rewrite assoc_sym.
      match goal with
          [|- (?A ∘ ?B = ?C ∘ ?B)%morphism] => assert (A = C) as ->; trivial
      end.
      transitivity (uncurry (curry f));
        [unfold curry, uncurry; cbn; auto|apply uncurry_curry].
    Qed.

  End curry_compose.

End Curry_UnCurry.


Require Import Frap.

(*
 *
 * Modeling a small toy Imperative programming language to allow us to reason about it in Coq
 *
 *)

(*
 * 1: Our imperative language constructs and syntax.
 *)

(* natural number expression *)
Inductive natExp :=
| Const (n : nat)
| Var (x : string)
| Plus (e1 e2 : natExp)
| Minus (e1 e2: natExp)
| Times (e1 e2: natExp)
| FunctionCall (params: list string) (body: natExp) (args: list natExp).

(* BEGIN syntax macros that won't be explained *)
(* These allow us to override Coq's syntax with our own *)
(*
Coercion Const : nat >-> natExp.
Coercion Var : string >-> natExp.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Times : cmd_scope.
Notation "'_call_' f l " := (FunctionCall f l) (at level 75).
Notation "'_func_' l b" := (Def l b) (at level 70).
Delimit Scope cmd_scope with cmd.
Infix "+" := plus : reset_scope.
Infix "-" := minus : reset_scope.
Infix "*" := mult : reset_scope.
Delimit Scope reset_scope with reset.
Open Scope reset_scope.
*)

(* Finite map notation: *)
(* <map> $? <key> -> Some <value> or None if key is not in the map *)
(* <map> $! <key> -> <value> or 0 if key is not in the map *)
(* <map> $+ (<key>, <value>) adds (key, value) to the map *)
Notation "m $! k" := (match m $? k with Some n => n | None => O end) (at level 30).
(* END macros *)

(*
 * End of 1
 *)

(*
 * 2: The semantics of our programming languages: we are explaining
 *    to coq what each construct in our programming language mean
 *)

(* our simple RAM: maps variables to their values *)
Definition valuation := fmap var nat.

(* Creates a new valuation representing the scope of a function call
   basically assigns the given arguments to the corresponding parameters *)
Fixpoint createScope (args: list nat) (parameters: list string): valuation :=
  match args with
  | nil => $0
  | cons n args' =>
      match parameters with
      | nil => $0
      | cons p params' => (createScope args' params') $+ (p, n)
      end
  end.

(* Given a natural number expression and a valuation giving each variable a value
   This function describes the meaning of the expression by actually evaluating it *)
Fixpoint eval_nat_exp (e: natExp) (v: valuation): nat :=
  match e with
  | Const n => n
  | Var x => (v $! x) (* gets x from v, or returns 0 if x is not in v *)
  | Plus e1 e2 => (eval_nat_exp e1 v) + (eval_nat_exp e2 v)
  | Minus e1 e2 => (eval_nat_exp e1 v) - (eval_nat_exp e2 v)
  | Times e1 e2 => (eval_nat_exp e1 v) * (eval_nat_exp e2 v)
  | FunctionCall params e args =>
      let
        fix eval_args (args: list natExp): list nat :=
          match args with
          | nil => nil
          | cons e a' => cons (eval_nat_exp e v) (eval_args a')
          end
      in
        eval_nat_exp e (createScope (eval_args args) params)
  end.

Definition interpret (e: natExp): nat :=
  eval_nat_exp e $0.


From mathcomp Require Import all_ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Print eq.

Set Printing Universes.
Check Type: Type.
Check Prop: Type.

Section tst.
Variable t : nat -> Type.
Variable g : forall n, t n.

End tst.

Inductive my_type := A (i: nat) | B (j: bool).

Definition tst: my_type -> bool :=
  fun t => match t with
           | A i => true
           | B i => false
           end.

Compute (tst (A 1)).
Compute (tst (B false)).

Definition coerce_bool_pred: bool -> Prop :=
  fun b => b = true.

Coercion coerce_bool_pred: bool >-> Sortclass.


From Undecidability.Shared.Libs.PSL Require Import FinTypes.

(* * Definition of prod as finType *)
Lemma ProdCount (T1 T2: eqType) (A: list T1) (B: list T2) (a:T1) (b:T2)  :
  count (list_prod A B) (a,b) =  count A a * count B b .
Proof.
  induction A.
  - reflexivity.
  - cbn. rewrite <- countSplit. decide (a = a0) as [E | E].
    + cbn. f_equal. subst a0. apply countMap. eauto.
    + rewrite <- plus_O_n. f_equal. now apply countMapZero. eauto.
Qed.

Lemma prod_enum_ok (T1 T2: finType) (x: T1 * T2):
  count (list_prod (elem T1) (elem T2)) x = 1.
Proof.
  destruct x as [x y]. rewrite ProdCount. unfold elem.
  now repeat rewrite enum_ok.
Qed.

#[global]
Instance finTypeC_Prod (F1 F2: finType) : finTypeC (EqType (F1 * F2)).
Proof.
  econstructor.  apply prod_enum_ok.
Defined.

(* * Definition of option as finType *)

(* Wrapping elements in "Some" does not change the number of occurences in a list *)
Lemma SomeElement (X: eqType) (A: list X) x:
  count (toOptionList A) (Some x) = count A x .
Proof.
  unfold toOptionList. simpl. dec; try congruence.
  induction A.
  + tauto.
  + simpl. dec; congruence.
Qed.

(* A list produced by toOptionList contains None exactly once *)
Lemma NoneElement (X: eqType) (A: list X) :
  count (toOptionList A) None = 1.
Proof.
  unfold toOptionList. simpl. dec; try congruence. f_equal.
  induction A.
  - reflexivity.
  - simpl; dec; congruence.
Qed.

Lemma option_enum_ok (T: finType) x :
  count (toOptionList (elem T)) x = 1.
Proof.
  destruct x.
  + rewrite SomeElement. apply enum_ok.
  + apply NoneElement.
Qed.

#[global]
Instance  finTypeC_Option(F: finType): finTypeC (EqType (option F)).
Proof.
  eapply FinTypeC.  apply option_enum_ok.
Defined.

(* * Definition of sum as finType *)

(* The sum of two nats can only be 1 if one of them is 1 and the other one is 0 *)
Lemma proveOne m n: m = 1 /\ n = 0 \/ n = 1 /\ m = 0 -> m + n = 1.
Proof.
  lia.
Qed.

(* toSumlist1 does not change the number of occurences of an existing element in the list *)
Lemma toSumList1_count (X: eqType) (x: X) (Y: eqType) (A: list X) :
  count (toSumList1 Y A) (inl x) =  count A x .
Proof.
  induction A; simpl; dec; congruence.
Qed.

(* toSumlist2 odes not change the numbe of occurences of an existing element in the list *)
Lemma toSumList2_count (X Y: eqType) (y: Y) (A: list Y):
  count (toSumList2 X A) (inr y) = count A y.
Proof.
  induction A; simpl; dec; congruence.
Qed.

(* to sumList1 does not produce inr proofs *)
Lemma toSumList1_missing (X Y: eqType) (y: Y) (A: list X):
  count (toSumList1 Y A ) (inr y) = 0.
Proof.
  induction A; dec; firstorder.
Qed.

(* toSumlist2 does not produce inl proofs *)
Lemma toSumList2_missing (X Y: eqType) (x: X) (A: list Y):
  count (toSumList2 X A ) (inl x) = 0.
Proof.
  induction A; dec; firstorder.
Qed.

Lemma sum_enum_ok (X: finType) (Y: finType) x :
  count (toSumList1 Y (elem X) ++ toSumList2 X (elem Y)) x = 1.
Proof.
  rewrite <- countSplit. apply proveOne. destruct x.
  - left. split; cbn.
    + rewrite toSumList1_count. apply enum_ok.
    + apply toSumList2_missing.
  - right. split; cbn.
    + rewrite toSumList2_count. apply enum_ok.
    + apply toSumList1_missing.
Qed.

(* Instance declaration for sum types for  the type class *)
#[global]
Instance finTypeC_sum (X Y: finType) : finTypeC (EqType ( X + Y)).
Proof.
  eapply FinTypeC. apply sum_enum_ok.
Defined.

(* Some hints to make the typeclass inference work *)

#[export] Hint Extern 4 (finTypeC (EqType (_ * _))) => eapply finTypeC_Prod : typeclass_instances.
#[export] Hint Extern 4 (finTypeC (EqType (_ + _))) => eapply finTypeC_sum : typeclass_instances.
#[export] Hint Extern 4 (finTypeC (EqType (option _))) => eapply finTypeC_Option : typeclass_instances.


Require Import CoRN.algebra.RSetoid.
Require Import CoRN.model.totalorder.QposMinMax.
Require Import CoRN.metric2.Metric.
Require Import CoRN.reals.fast.CRArith.

Local Open Scope CR.

Record is_DistanceMetricSpace (X : RSetoid) (distance: X -> X -> CR) : Prop
  := Build_is_DistanceMetricSpace
  { dmsp_refl: forall x y, st_eq x y <-> distance x y == 0
  ; dmsp_sym: forall x y, distance x y == distance y x
  ; dmsp_triangle: forall x y z, distance x z <= distance x y + distance y z
  ; dmsp_nonneg: forall x y, 0 <= distance x y
  }.

Record DistanceMetricSpace: Type := Build_alt_MetricSpace
  { dmsp_is_setoid:> RSetoid;
    distance: dmsp_is_setoid -> dmsp_is_setoid -> CR;
    distance_wd: Proper (@st_eq _ ==> @st_eq _ ==> @msp_eq _) distance;
    dmsp : is_DistanceMetricSpace dmsp_is_setoid distance }.

Arguments distance [d].
#[global]
Existing Instance distance_wd.

Section DistanceMetricSpace. (* Just mimicking Russell's code for MetricSpace here. *)

  Context {X: DistanceMetricSpace}.

  Lemma distance_refl (x y: X): st_eq x y <-> distance x y == 0.
  Proof. apply dmsp_refl, dmsp. Qed.

  Lemma distance_sym (x y: X): distance x y == distance y x.
  Proof. apply dmsp_sym, dmsp. Qed.

  Lemma distance_triangle (x y z: X):
    distance x z <= distance x y + distance y z.
  Proof. apply dmsp_triangle, dmsp. Qed.

End DistanceMetricSpace.

(* We show that a DistanceMetricSpace immediately yields a MetricSpace. *)

Section from_alt.

  Variable (X: DistanceMetricSpace).

  Definition ball (q: Q) (x y: X): Prop
    := (0 <= q)%Q /\ distance x y <= inject_Q_CR q.

  Instance ball_wd: Proper (Qeq ==> @st_eq X ==> @st_eq X ==> iff) ball.
  Proof.
   intros ?? E ?? F ?? G. unfold ball.
   split.
   - intros [qpos H]. assert (Qle 0 y). rewrite <- E. exact qpos.
     split. exact H0. rewrite <- F, <- G.
     rewrite <- E. exact H.
   - intros [qpos H]. assert (Qle 0 x). rewrite E. exact qpos.
     split. exact H0. rewrite F, G.
     rewrite E. exact H.
  Qed.

  Lemma ball_refl e: Qle 0 e -> Reflexive (ball e).
  Proof.
   unfold Reflexive, ball. intros.
   split. exact H.
   rewrite (proj1 (distance_refl x x)).
   apply CRle_Qle. exact H.
   reflexivity.
  Qed.

  Lemma ball_sym e: Symmetric (ball e).
  Proof with auto.
   unfold Symmetric, ball. intros.
   destruct H as [qpos H].
   split. exact qpos.
   rewrite distance_sym...
  Qed.

  Lemma ball_closed (e:Q) x y: (forall d:Q, 0 < d -> ball (e+d) x y)%Q -> ball e x y.
  Proof.
   unfold ball. intro H.
   assert (Qle 0 e).
   { apply Qnot_lt_le. intro abs.
     destruct (H (-e*(1#2))%Q). rewrite <- (Qmult_0_l (1#2)).
     apply Qmult_lt_r. reflexivity.
     apply (Qplus_lt_l _ _ e). ring_simplify. exact abs.
     clear H1. ring_simplify in H0.
     rewrite <- (Qmult_0_r (1#2)) in H0.
     apply Qmult_le_l in H0. exact (Qlt_not_le _ _ abs H0). reflexivity. }
   split. exact H0.
   apply CRle_not_lt. intro abs.
   apply CRlt_Qmid in abs.
   destruct abs as [q [H1 H2]].
   specialize (H (q-e)%Q).
   revert H2.
   apply CRle_not_lt.
   setoid_replace q with (e+(q-e))%Q
     by (unfold canonical_names.equiv, stdlib_rationals.Q_eq; ring).
   apply H.
   unfold Qminus. rewrite <- Qlt_minus_iff.
   apply Qlt_from_CRlt, H1.
  Qed.

  Lemma ball_triangle (e1 e2 : Q) a b c
    : ball e1 a b -> ball e2 b c -> ball (e1+e2) a c.
  Proof with auto.
   unfold ball.
   intros. destruct H, H0.
   assert (Qle 0 (e1+e2)).
   { apply (Qle_trans _ (e1+0)). rewrite Qplus_0_r.
     exact H. apply Qplus_le_r. exact H0. }
   split. exact H3.
   apply CRle_trans with (distance a b + distance b c).
   apply distance_triangle.
   rewrite <- CRplus_Qplus.
   apply CRplus_le_compat; assumption.
  Qed.

  Lemma ball_eq x y: (forall e, Qlt 0 e -> ball e x y) -> st_eq x y.
  Proof.
   unfold ball.
   intros.
   apply distance_refl.
   apply CRle_antisym. split.
   2: apply (dmsp_nonneg _ _ (dmsp X)).
   apply CRle_not_lt.
   intro abs.
   apply CRlt_Qmid in abs.
   destruct abs as [q [H1 H2]].
   apply Qlt_from_CRlt in H1.
   specialize (H q H1) as [_ H].
   revert H2.
   apply CRle_not_lt, H.
  Qed.

  Lemma is_MetricSpace: is_MetricSpace ball.
  Proof with auto.
   constructor.
   - apply ball_refl.
   - apply ball_sym.
   - apply ball_triangle.
   - apply ball_closed.
   - intros. destruct H. exact H.
   - unfold ball. split.
     destruct (Qlt_le_dec e 0).
     exfalso. contradict H; intros [H _].
     exact (Qlt_not_le _ _ q H). exact q.
     apply CRle_not_lt.
     intro abs.
     contradict H; intros [_ H].
     revert abs.
     apply CRle_not_lt, H.
  Qed.

  Definition ballSpace: MetricSpace.
   apply (@Build_MetricSpace X ball).
   intros. rewrite H. reflexivity.
   apply is_MetricSpace.
  Defined.

End from_alt.

(* Unfortunately, the other way around is not as direct,
   because the ball-based interface permits the distance
   between two points to be infinite, which CR does not support. *)