(** * Base Library for ICL

   - Version: 25 June 2014
   - Author: Gert Smolka, Saarland University
   - Acknowlegments: Sigurd Schneider, Dominik Karst
 *)

(* Switch Coq into implicit argument mode *)

Global Set Implicit Arguments.
Global Unset Strict Implicit.

(* Load basic Coq libraries *)

Require Export Omega List Morphisms.

Module Base.

  (* Inversion tactic *)

  Ltac inv H := inversion H; subst; try clear H.

  (** * Size recursion *)

  Lemma size_recursion (X : Type) (sigma : X -> nat) (p : X -> Type) :
    (forall x, (forall y, sigma y < sigma x -> p y) -> p x) ->
    forall x, p x.
  Proof.
    intros D x. apply D.
    cut (forall n y, sigma y < n -> p y).
    now eauto.
    clear x. intros n.
    induction n; intros y E.
    - exfalso; omega.
    - apply D. intros x F.  apply IHn. omega.
  Qed.

  Arguments size_recursion {X} sigma {p} _ _.

  (** * Iteration *)

  Section Iteration.
    Variable X : Type.
    Variable f : X -> X.

    Fixpoint it (n : nat) (x : X) : X :=
      match n with
        | 0 => x
        | S n' => f (it n' x)
      end.

    Lemma it_ind (p : X -> Prop) x n :
      p x -> (forall z, p z -> p (f z)) -> p (it n x).
    Proof.
      intros A B. induction n; simpl; auto.
    Qed.

    Definition FP (x : X) : Prop := f x = x.

    Lemma it_fp (sigma : X -> nat) x :
      (forall n, FP (it n x) \/ sigma (it n x) > sigma (it (S n) x)) ->
      FP (it (sigma x) x).
    Proof.
      intros A.
      assert (B: forall n, FP (it n x) \/ sigma x >= n + sigma (it n x)).
      { intros n; induction n; simpl.
        - auto.
        - destruct IHn as [B|B].
          + left. now rewrite B.
          + destruct (A n) as [C|C].
            * left. now rewrite C.
            * right. simpl in C. omega. }
      destruct (A (sigma x)), (B (sigma x)); auto; exfalso; omega.
    Qed.
  End Iteration.

  (** * Decidability *)

  Definition dec (X : Prop) : Type := {X} + {~ X}.

  Notation "'eq_dec' X" := (forall x y : X, dec (x=y)) (at level 70).

  (* Register dec as a type class *)

  Existing Class dec.

  Definition decision (X : Prop) (D : dec X) : dec X := D.
  Arguments decision X {D}.

  Tactic Notation "decide" constr(p) :=
    destruct (decision p).
  Tactic Notation "decide" constr(p) "as" simple_intropattern(i) :=
    destruct (decision p) as i.

  (* Hints for auto concerning dec *)

  Hint Extern 4 =>
  match goal with
    | [  |- dec ?p ] => exact (decision p)
  end.

  (* Improves type class inference *)

  Hint Extern 4 =>
  match goal with
    | [  |- dec ((fun _ => _) _) ] => simpl
  end : typeclass_instances.

  (* Register instance rules for dec *)

  Global Instance True_dec :  dec True :=
    left I.

  Global Instance False_dec :  dec False :=
    right (fun A => A).

  Global Instance impl_dec (X Y : Prop) :
    dec X -> dec Y -> dec (X -> Y).
  Proof.
    unfold dec; tauto.
  Defined.

  Global Instance and_dec (X Y : Prop) :
    dec X -> dec Y -> dec (X /\ Y).
  Proof.
    unfold dec; tauto.
  Defined.

  Global Instance or_dec (X Y : Prop) :
    dec X -> dec Y -> dec (X \/ Y).
  Proof.
    unfold dec; tauto.
  Defined.

  (* Coq standard modules make "not" and "iff" opaque for type class inference, can be seen with Print HintDb typeclass_instances. *)

  Global Instance not_dec (X : Prop) :
    dec X -> dec (~ X).
  Proof.
    unfold not. auto.
  Defined.

  Global Instance iff_dec (X Y : Prop) :
    dec X -> dec Y -> dec (X <-> Y).
  Proof.
    unfold iff. auto.
  Qed.

  Lemma dec_DN X :
    dec X -> ~~ X -> X.
  Proof.
    unfold dec; tauto.
  Qed.

  Lemma dec_DM_and X Y :
    dec X -> dec Y -> ~ (X /\ Y) -> ~ X \/ ~ Y.
  Proof.
    unfold dec; tauto.
  Qed.

  Lemma dec_DM_impl X Y :
    dec X -> dec Y -> ~ (X -> Y) -> X /\ ~ Y.
  Proof.
    unfold dec; tauto.
  Qed.

  Lemma dec_prop_iff (X Y : Prop) :
    (X <-> Y) -> dec X -> dec Y.
  Proof.
    unfold dec; tauto.
  Defined.

  Global Instance bool_eq_dec :
    eq_dec bool.
  Proof.
    intros x y. hnf. decide equality.
  Defined.

  Global Instance nat_eq_dec :
    eq_dec nat.
  Proof.
    intros x y. hnf. decide equality.
  Defined.

  Global Instance nat_le_dec (x y : nat) : dec (x <= y) :=
    le_dec x y.

  (** * Lists *)

  (* Notations for lists *)

  Definition equi X (A B : list X) : Prop :=
    incl A B /\ incl B A.

  Hint Unfold equi.

  Export ListNotations.
  Notation "| A |" := (length A) (at level 65).
  Notation "x 'el' A" := (In x A) (at level 70).
  Notation "A <<= B" := (incl A B) (at level 70).
  Notation "A === B" := (equi A B) (at level 70).

  (* The following comments are for coqdoc *)
  (** printing el #âˆŠ# *)
  (** printing <<= #âŠ†# *)
  (** printing === #â‰¡# *)

  (** Register additional simplification rules with autorewrite / simpl_list *)

  Hint Rewrite <- app_assoc : list.
  Hint Rewrite rev_app_distr map_app prod_length : list.
  (* Print Rewrite HintDb list. *)

  (** A useful lemma *)

  Lemma list_cycle  (X : Type) (A : list X) x :
    x::A <> A.
  Proof.
    intros B.
    assert (C: |x::A| <> |A|) by (simpl; omega).
    apply C. now rewrite B.
  Qed.

  (** Decidability laws for lists *)

  Global Instance list_eq_dec X :
    eq_dec X -> eq_dec (list X).
  Proof.
    intros D. apply list_eq_dec. exact D.
  Defined.

  Global Instance list_in_dec (X : Type) (x : X) (A : list X) :
    eq_dec X -> dec (x el A).
  Proof.
    intros D. apply in_dec. exact D.
  Defined.

  Lemma list_sigma_forall X A (p : X -> Prop) (p_dec : forall x, dec (p x)) :
    {x | x el A /\ p x} + {forall x, x el A -> ~ p x}.
  Proof.
    induction A as [|x A]; simpl.
    - tauto.
    - destruct IHA as [[y [D E]]|D].
      + eauto.
      + destruct (p_dec x) as [E|E].
        * eauto.
        * right. intros y [[]|F]; auto.
  Defined.

  Arguments list_sigma_forall {X} A p {p_dec}.

  Global Instance list_forall_dec X A (p : X -> Prop) :
    (forall x, dec (p x)) -> dec (forall x, x el A -> p x).
  Proof.
    intros p_dec.
    destruct (list_sigma_forall A (fun x => ~ p x)) as [[x [D E]]|D].
    - right. auto.
    - left. intros x E. apply dec_DN; auto.
  Defined.

  Global Instance list_exists_dec X A (p : X -> Prop) :
    (forall x, dec (p x)) -> dec (exists x, x el A /\ p x).
  Proof.
    intros p_dec.
    destruct (list_sigma_forall A p) as [[x [D E]]|D].
    - unfold dec. eauto.
    - right. intros [x [E F]]. exact (D x E F).
  Defined.

  Lemma list_exists_DM X A  (p : X -> Prop) :
    (forall x, dec (p x)) ->
    ~ (forall x, x el A -> ~ p x) -> exists x, x el A /\ p x.
  Proof.
    intros D E.
    destruct (list_sigma_forall A p) as [F|F].
    + destruct F as [x F]. eauto.
    + contradiction (E F).
  Qed.

  Lemma list_exists_not_incl X (A B : list X) :
    eq_dec X ->
    ~ A <<= B -> exists x, x el A /\ ~ x el B.
  Proof.
    intros D E.
    apply list_exists_DM; auto.
    intros F. apply E. intros x G.
    apply dec_DN; auto.
  Qed.

  Lemma list_cc X (p : X -> Prop) A :
    (forall x, dec (p x)) ->
    (exists x, x el A /\ p x) -> {x | x el A /\ p x}.
  Proof.
    intros D E.
    destruct (list_sigma_forall A p) as [[x [F G]]|F].
    - eauto.
    - exfalso. destruct E as [x [G H]]. apply (F x); auto.
  Defined.

  (** Membership

We use the following lemmas from Coq's standard library List.
- [in_eq :  x el x::A]
- [in_nil :  ~ x el nil]
- [in_cons :  x el A -> x el y::A]
- [in_or_app :  x el A \/ x el B -> x el A++B]
- [in_app_iff :  x el A++B <-> x el A \/ x el B]
- [in_map_iff :  y el map f A <-> exists x, f x = y /\ x el A]
   *)

  Hint Resolve in_eq in_nil in_cons in_or_app.

  Section Membership.
    Variable X : Type.
    Implicit Types x y : X.
    Implicit Types A B : list X.

    Lemma in_sing x y :
      x el [y] -> x = y.
    Proof.
      simpl. intros [[]|[]]. reflexivity.
    Qed.

    Lemma in_cons_neq x y A :
      x el y::A -> x <> y -> x el A.
    Proof.
      simpl. intros [[]|D] E; congruence.
    Qed.

    Lemma not_in_cons x y A :
      ~ x el y :: A -> x <> y /\ ~ x el A.
    Proof.
      intuition; subst; auto.
    Qed.

    Definition disjoint A B :=
      ~ exists x, x el A /\ x el B.

    Lemma disjoint_nil B :
      disjoint nil B.
    Proof.
      firstorder.
    Qed.

    Lemma disjoint_nil' A :
      disjoint A nil.
    Proof.
      firstorder.
    Qed.

    Lemma disjoint_symm A B :
      disjoint A B -> disjoint B A.
    Proof.
      firstorder.
    Qed.

    Lemma disjoint_incl A B B' :
      B' <<= B -> disjoint A B -> disjoint A B'.
    Proof.
      firstorder.
    Qed.

    Lemma disjoint_forall A B :
      disjoint A B <-> forall x, x el A -> ~ x el B.
    Proof.
      split.
      - intros D x E F. apply D. exists x. auto.
      - intros D [x [E F]]. exact (D x E F).
    Qed.

    Lemma disjoint_cons x A B :
      disjoint (x::A) B <-> ~ x el B /\ disjoint A B.
    Proof.
      split.
      - intros D. split.
        + intros E. apply D. eauto.
        + intros [y [E F]]. apply D. eauto.
      - intros [D E] [y [[F|F] G]].
        + congruence.
        + apply E. eauto.
    Qed.
  End Membership.

  Hint Resolve disjoint_nil disjoint_nil'.

  (** Inclusion

We use the following lemmas from Coq's standard library List.
- [incl_refl :  A <<= A]
- [incl_tl :  A <<= B -> A <<= x::B]
- [incl_cons : x el B -> A <<= B -> x::A <<= B]
- [incl_appl : A <<= B -> A <<= B++C]
- [incl_appr : A <<= C -> A <<= B++C]
- [incl_app : A <<= C -> B <<= C -> A++B <<= C]
   *)

  Hint Resolve incl_refl incl_tl incl_cons incl_appl incl_appr incl_app.

  Lemma incl_nil X (A : list X) :
    nil <<= A.

  Proof. intros x []. Qed.

  Hint Resolve incl_nil.

  Lemma incl_map X Y A B (f : X -> Y) :
    A <<= B -> map f A <<= map f B.

  Proof.
    intros D y E. apply in_map_iff in E as [x [E E']].
    subst y. apply in_map_iff. eauto.
  Qed.

  Section Inclusion.
    Variable X : Type.
    Implicit Types A B : list X.

    Lemma incl_nil_eq A :
      A <<= nil -> A=nil.

    Proof.
      intros D. destruct A as [|x A].
      - reflexivity.
      - exfalso. apply (D x). auto.
    Qed.

    Lemma incl_shift x A B :
      A <<= B -> x::A <<= x::B.

    Proof. auto. Qed.

    Lemma incl_lcons x A B :
      x::A <<= B <-> x el B /\ A <<= B.
    Proof.
      split.
      - intros D. split; hnf; auto.
      - intros [D E] z [F|F]; subst; auto.
    Qed.

    Lemma incl_sing x A y :
      x::A <<= [y] -> x = y /\ A <<= [y].
    Proof.
      rewrite incl_lcons. intros [D E].
      apply in_sing in D. auto.
    Qed.

    Lemma incl_rcons x A B :
      A <<= x::B -> ~ x el A -> A <<= B.

    Proof. intros C D y E. destruct (C y E) as [F|F]; congruence. Qed.

    Lemma incl_lrcons x A B :
      x::A <<= x::B -> ~ x el A -> A <<= B.

    Proof.
      intros C D y E.
      assert (F: y el x::B) by auto.
      destruct F as [F|F]; congruence.
    Qed.

    Lemma incl_app_left A B C :
      A ++ B <<= C -> A <<= C /\ B <<= C.
    Proof.
      firstorder.
    Qed.

  End Inclusion.

  Definition inclp (X : Type) (A : list X) (p : X -> Prop) : Prop :=
    forall x, x el A -> p x.

  (** Setoid rewriting with list inclusion and list equivalence *)

  Global Instance incl_preorder X :
    PreOrder (@incl X).
  Proof.
    constructor; hnf; unfold incl; auto.
  Qed.

  Global Instance equi_Equivalence X :
    Equivalence (@equi X).
  Proof.
    constructor; hnf; firstorder.
  Qed.

  Global Instance incl_equi_proper X :
    Proper (@equi X ==> @equi X ==> iff) (@incl X).
  Proof.
    hnf. intros A B D. hnf. firstorder.
  Qed.

  Global Instance cons_incl_proper X x :
    Proper (@incl X ==> @incl X) (@cons X x).
  Proof.
    hnf. apply incl_shift.
  Qed.

  Global Instance cons_equi_proper X x :
    Proper (@equi X ==> @equi X) (@cons X x).
  Proof.
    hnf. firstorder.
  Qed.

  Global Instance in_incl_proper X x :
    Proper (@incl X ==> Basics.impl) (@In X x).
  Proof.
    intros A B D. hnf. auto.
  Qed.

  Global Instance in_equi_proper X x :
    Proper (@equi X ==> iff) (@In X x).
  Proof.
    intros A B D. firstorder.
  Qed.

  Global Instance app_incl_proper X :
    Proper (@incl X ==> @incl X ==> @incl X) (@app X).
  Proof.
    intros A B D A' B' E. auto.
  Qed.

  Global Instance app_equi_proper X :
    Proper (@equi X ==> @equi X ==> @equi X) (@app X).
  Proof.
    hnf. intros A B D. hnf. intros A' B' E.
    destruct D, E; auto.
  Qed.

  (** Equivalence *)

  Section Equi.
    Variable X : Type.
    Implicit Types A B : list X.

    Lemma equi_push x A :
      x el A -> A === x::A.

    Proof. auto. Qed.

    Lemma equi_dup x A :
      x::A === x::x::A.

    Proof. auto. Qed.

    Lemma equi_swap x y A:
      x::y::A === y::x::A.

    Proof. split; intros z; simpl; tauto. Qed.

    Lemma equi_shift x A B :
      x::A++B === A++x::B.

    Proof.
      split; intros y.
      - intros [D|D].
        + subst; auto.
        + apply in_app_iff in D as [D|D]; auto.
      - intros D. apply in_app_iff in D as [D|D].
        + auto.
        + destruct D; subst; auto.
    Qed.

    Lemma equi_rotate x A :
      x::A === A++[x].

    Proof.
      split; intros y; simpl.
      - intros [D|D]; subst; auto.
      - intros D. apply in_app_iff in D as [D|D].
        + auto.
        + apply in_sing in D. auto.
    Qed.
  End Equi.

  (** * Filter *)

  Definition filter (X : Type) (p : X -> Prop) (p_dec : forall x, dec (p x)) : list X -> list X :=
    fix f A := match A with
                 | nil => nil
                 | x::A' => if decision (p x) then x :: f A' else f A'
               end.

  Arguments filter {X} p {p_dec} A.

  Section FilterLemmas.
    Variable X : Type.
    Variable p : X -> Prop.
    Context {p_dec : forall x, dec (p x)}.

    Lemma in_filter_iff x A :
      x el filter p A <-> x el A /\ p x.

    Proof.
      induction A as [|y A]; simpl.
      - tauto.
      - decide (p y) as [B|B]; simpl;
        rewrite IHA; intuition; subst; tauto.
    Qed.

    Lemma filter_incl A :
      filter p A <<= A.

    Proof.
      intros x D. apply in_filter_iff in D. apply D.
    Qed.

    Lemma filter_mono A B :
      A <<= B -> filter p A <<= filter p B.

    Proof.
      intros D x E. apply in_filter_iff in E as [E E'].
      apply in_filter_iff. auto.
    Qed.

    Lemma filter_id A :
      (forall x, x el A -> p x) -> filter p A = A.
    Proof.
      intros D.
      induction A as [|x A]; simpl.
      - reflexivity.
      - decide (p x) as [E|E].
        + f_equal; auto.
        + exfalso. auto.
    Qed.

    Lemma filter_app A B :
      filter p (A ++ B) = filter p A ++ filter p B.
    Proof.
      induction A as [|y A]; simpl.
      - reflexivity.
      - rewrite IHA. decide (p y); reflexivity.
    Qed.

    Lemma filter_fst x A :
      p x -> filter p (x::A) = x::filter p A.
    Proof.
      simpl. decide (p x); tauto.
    Qed.

    Lemma filter_fst' x A :
      ~ p x -> filter p (x::A) = filter p A.
    Proof.
      simpl. decide (p x); tauto.
    Qed.

  End FilterLemmas.

  Section FilterLemmas_pq.
    Variable X : Type.
    Variable p q : X -> Prop.
    Context {p_dec : forall x, dec (p x)}.
    Context {q_dec : forall x, dec (q x)}.

    Lemma filter_pq_mono A :
      (forall x, x el A -> p x -> q x) -> filter p A <<= filter q A.

    Proof.
      intros D x E. apply in_filter_iff in E as [E E'].
      apply in_filter_iff. auto.
    Qed.

    Lemma filter_pq_eq A :
      (forall x, x el A -> (p x <-> q x)) -> filter p A = filter q A.

    Proof.
      intros C; induction A as [|x A]; simpl.
      - reflexivity.
      - decide (p x) as [D|D]; decide (q x) as [E|E].
        + f_equal. auto.
        + exfalso. apply E, (C x); auto.
        + exfalso. apply D, (C x); auto.
        + auto.
    Qed.

    Lemma filter_and A :
      filter p (filter q A) = filter (fun x => p x /\ q x) A.
    Proof.
      set (r x := p x /\ q x).
      induction A as [|x A]; simpl. reflexivity.
      decide (q x) as [E|E]; simpl; rewrite IHA.
      - decide (p x); decide (r x); unfold r in *|-; auto; tauto.
      - decide (r x); unfold r in *|-; auto; tauto.
    Qed.

  End FilterLemmas_pq.

  Section FilterComm.
    Variable X : Type.
    Variable p q : X -> Prop.
    Context {p_dec : forall x, dec (p x)}.
    Context {q_dec : forall x, dec (q x)}.

    Lemma filter_comm A :
      filter p (filter q A) = filter q (filter p A).
    Proof.
      rewrite !filter_and. apply filter_pq_eq. tauto.
    Qed.
  End FilterComm.

  (** * Element removal *)

  Section Removal.
    Variable X : Type.
    Context {eq_X_dec : eq_dec X}.

    Definition rem (A : list X) (x : X) : list X :=
      filter (fun z => z <> x) A.

    Lemma in_rem_iff x A y :
      x el rem A y <-> x el A /\ x <> y.
    Proof.
      apply in_filter_iff.
    Qed.

    Lemma rem_not_in x y A :
      x = y \/ ~ x el A -> ~ x el rem A y.
    Proof.
      intros D E. apply in_rem_iff in E. tauto.
    Qed.

    Lemma rem_incl A x :
      rem A x <<= A.
    Proof.
      apply filter_incl.
    Qed.

    Lemma rem_mono A B x :
      A <<= B -> rem A x <<= rem B x.
    Proof.
      apply filter_mono.
    Qed.

    Lemma rem_cons A B x :
      A <<= B -> rem (x::A) x <<= B.
    Proof.
      intros E y F. apply E. apply in_rem_iff in F.
      destruct F as [[|]]; congruence.
    Qed.

    Lemma rem_cons' A B x y :
      x el B -> rem A y <<= B -> rem (x::A) y <<= B.
    Proof.
      intros E F u G.
      apply in_rem_iff in G as [[[]|G] H]. exact E.
      apply F. apply in_rem_iff. auto.
    Qed.

    Lemma rem_in x y A :
      x el rem A y -> x el A.
    Proof.
      apply rem_incl.
    Qed.

    Lemma rem_neq x y A :
      x <> y -> x el A -> x el rem A y.
    Proof.
      intros E F. apply in_rem_iff. auto.
    Qed.

    Lemma rem_app x A B :
      x el A -> B <<= A ++ rem B x.
    Proof.
      intros E y F. decide (x=y) as [[]|]; auto using rem_neq.
    Qed.

    Lemma rem_app' x A B C :
      rem A x <<= C -> rem B x <<= C -> rem (A ++ B) x <<= C.
    Proof.
      unfold rem; rewrite filter_app; auto.
    Qed.

    Lemma rem_equi x A :
      x::A === x::rem A x.
    Proof.
      split; intros y;
      intros [[]|E]; decide (x=y) as [[]|D];
      eauto using rem_in, rem_neq.
    Qed.

    Lemma rem_comm A x y :
      rem (rem A x) y = rem (rem A y) x.
    Proof.
      apply filter_comm.
    Qed.

    Lemma rem_fst x A :
      rem (x::A) x = rem A x.
    Proof.
      unfold rem. rewrite filter_fst'; auto.
    Qed.

    Lemma rem_fst' x y A :
      x <> y -> rem (x::A) y = x::rem A y.
    Proof.
      intros E. unfold rem. rewrite filter_fst; auto.
    Qed.

    Lemma rem_id x A :
      ~ x el A -> rem A x = A.
    Proof.
      intros D. apply filter_id.
      intros y E F. subst. auto.
    Qed.

    Lemma rem_reorder x A :
      x el A -> A === x :: rem A x.
    Proof.
      intros D. rewrite <- rem_equi. apply equi_push, D.
    Qed.

    Lemma rem_inclr A B x :
      A <<= B -> ~ x el A -> A <<= rem B x.
    Proof.
      intros D E y F. apply in_rem_iff.
      intuition; subst; auto.
    Qed.

  End Removal.

  Hint Resolve rem_not_in rem_incl rem_mono rem_cons rem_cons' rem_app rem_app' rem_in rem_neq rem_inclr.

  (** * Cardinality *)

  Section Cardinality.
    Variable X : Type.
    Context { eq_X_dec : eq_dec X }.
    Implicit Types A B : list X.

    Fixpoint card A :=
      match A with
        | nil => 0
        | x::A => if decision (x el A) then card A else 1 + card A
      end.

    Lemma card_in_rem x A :
      x el A -> card A = 1 + card (rem A x).
    Proof.
      intros D.
      induction A as [|y A]; simpl.
      - contradiction D.
      - decide (y <> x) as [E|E]; simpl.
        + rewrite IHA.
          * { decide (y el A) as [G|G];
              decide (y el rem A x) as [K|K];
              (reflexivity || exfalso).
              - auto.
              - eapply G, in_rem_iff, K. }
          * destruct D; tauto.
        + apply dec_DN in E; auto; subst y.
          decide (x el A) as [F|F].
          * auto.
          * rewrite rem_id; auto.
    Qed.

    Lemma card_not_in_rem A x :
      ~ x el A -> card A = card (rem A x).
    Proof.
      intros D; rewrite rem_id; auto.
    Qed.

    Lemma card_le A B :
      A <<= B -> card A <= card B.
    Proof.
      revert B.
      induction A as [|x A]; intros B D; simpl.
      - omega.
      - apply incl_lcons in D as [D D1].
        decide (x el A) as [E|E].
        + auto.
        + rewrite (card_in_rem D).
          cut (card A <= card (rem B x)). omega.
          apply IHA. auto.
    Qed.

    Lemma card_eq A B :
      A === B -> card A = card B.
    Proof.
      intros [E F]. apply card_le in E. apply card_le in F. omega.
    Qed.

    Lemma card_cons_rem x A :
      card (x::A) = 1 + card (rem A x).
    Proof.
      rewrite (card_eq (rem_equi x A)). simpl.
      decide (x el rem A x) as [D|D].
      - exfalso. apply in_rem_iff in D; tauto.
      - reflexivity.
    Qed.

    Lemma card_0 A :
      card A = 0 -> A = nil.
    Proof.
      destruct A as [|x A]; intros D.
      - reflexivity.
      - exfalso. rewrite card_cons_rem in D. omega.
    Qed.

    Lemma card_ex A B :
      card A < card B -> exists x, x el B /\ ~ x el A.
    Proof.
      intros D.
      decide (B <<= A) as [E|E].
      - exfalso. apply card_le in E. omega.
      - apply list_exists_not_incl; auto.
    Qed.

    Lemma card_equi A B :
      A <<= B -> card A = card B -> A === B.
    Proof.
      revert B.
      induction A as [|x A]; simpl; intros B D E.
      - symmetry in E. apply card_0 in E. now rewrite E.
      - apply incl_lcons in D as [D D1].
        decide (x el A) as [F|F].
        + rewrite (IHA B); auto.
        + rewrite (IHA (rem B x)).
          * symmetry. apply rem_reorder, D.
          * auto.
          * apply card_in_rem in D. omega.
    Qed.

    Lemma card_lt A B x :
      A <<= B -> x el B -> ~ x el A -> card A < card B.
    Proof.
      intros D E F.
      decide (card A = card B) as [G|G].
      + exfalso. apply F. apply (card_equi D); auto.
      + apply card_le in D. omega.
    Qed.

    Lemma card_or A B :
      A <<= B -> A === B \/ card A < card B.
    Proof.
      intros D.
      decide (card A = card B) as [F|F].
      - left. apply card_equi; auto.
      - right. apply card_le in D. omega.
    Qed.

  End Cardinality.

  Global Instance card_equi_proper X (D: eq_dec X) :
    Proper (@equi X ==> eq) (@card X D).
  Proof.
    hnf. apply card_eq.
  Qed.

  (** * Duplicate-free lists *)

  Inductive dupfree (X : Type) : list X -> Prop :=
  | dupfreeN : dupfree nil
  | dupfreeC x A : ~ x el A -> dupfree A -> dupfree (x::A).

  Section Dupfree.
    Variable X : Type.
    Implicit Types A B : list X.

    Lemma dupfree_cons x A :
      dupfree (x::A) <-> ~ x el A /\ dupfree A.
    Proof.
      split; intros D.
      - inv D; auto.
      - apply dupfreeC; tauto.
    Qed.

    Lemma dupfree_app A B :
      disjoint A B -> dupfree A -> dupfree B -> dupfree (A++B).

    Proof.
      intros D E F. induction E as [|x A E' E]; simpl.
      - exact F.
      - apply disjoint_cons in D as [D D'].
        constructor; [|exact (IHE D')].
        intros G. apply in_app_iff in G; tauto.
    Qed.

    Lemma dupfree_map Y A (f : X -> Y) :
      (forall x y, x el A -> y el A -> f x = f y -> x=y) ->
      dupfree A -> dupfree (map f A).

    Proof.
      intros D E. induction E as [|x A E' E]; simpl.
      - constructor.
      - constructor; [|now auto].
        intros F. apply in_map_iff in F as [y [F F']].
        rewrite (D y x) in F'; auto.
    Qed.

    Lemma dupfree_filter p (p_dec : forall x, dec (p x)) A :
      dupfree A -> dupfree (filter p A).

    Proof.
      intros D. induction D as [|x A C D]; simpl.
      - left.
      - decide (p x) as [E|E]; [|exact IHD].
        right; [|exact IHD].
        intros F. apply C. apply filter_incl in F. exact F.
    Qed.

    Lemma dupfree_dec A :
      eq_dec X -> dec (dupfree A).

    Proof.
      intros D. induction A as [|x A].
      - left. left.
      - decide (x el A) as [E|E].
        + right. intros F. inv F; tauto.
        + destruct (IHA) as [F|F].
          * unfold dec. auto using dupfree.
          * right. intros G. inv G; tauto.
    Qed.

    Lemma dupfree_card A (eq_X_dec : eq_dec X) :
      dupfree A -> card A = |A|.
    Proof.
      intros D.
      induction D as [|x A E F]; simpl.
      - reflexivity.
      - decide (x el A) as [G|].
        + contradiction (E G).
        + omega.
    Qed.

  End Dupfree.

  Section Undup.
    Variable X : Type.
    Context {eq_X_dec : eq_dec X}.
    Implicit Types A B : list X.

    Fixpoint undup (A : list X) : list X :=
      match A with
        | nil => nil
        | x::A' => if decision (x el A') then undup A' else  x :: undup A'
      end.

    Lemma undup_id_equi A :
      undup A === A.
    Proof.
      induction A as [|x A]; simpl.
      - reflexivity.
      - decide (x el A) as [E|E]; rewrite IHA; auto.
    Qed.

    Lemma dupfree_undup A :
      dupfree (undup A).
    Proof.
      induction A as [|x A]; simpl.
      - left.
      - decide (x el A) as [E|E]; auto.
        right; auto. now rewrite undup_id_equi.
    Qed.

    Lemma undup_incl A B :
      A <<= B <-> undup A <<= undup B.
    Proof.
      now rewrite !undup_id_equi.
    Qed.

    Lemma undup_equi A B :
      A === B <-> undup A === undup B.
    Proof.
      now rewrite !undup_id_equi.
    Qed.

    Lemma undup_id A :
      dupfree A -> undup A = A.
    Proof.
      intros E. induction E as [|x A E F]; simpl.
      - reflexivity.
      - rewrite IHF. decide (x el A) as [G|G]; tauto.
    Qed.

    Lemma undup_idempotent A :
      undup (undup A) = undup A.

    Proof. apply undup_id, dupfree_undup. Qed.

  End Undup.

  (** * Power lists *)

  Section PowerRep.
    Variable X : Type.
    Context {eq_X_dec : eq_dec X}.

    Fixpoint power (U : list X ) : list (list X) :=
      match U with
        | nil => [nil]
        | x :: U' => power U' ++ map (cons x) (power U')
      end.

    Lemma power_incl A U :
      A el power U -> A <<= U.

    Proof.
      revert A; induction U as [|x U]; simpl; intros A D.
      - destruct D as [[]|[]]; auto.
      - apply in_app_iff in D as [E|E]. now auto.
        apply in_map_iff in E as [A' [E F]]. subst A.
        auto.
    Qed.

    Lemma power_nil U :
      nil el power U.

    Proof. induction U; simpl; auto. Qed.

    Definition rep (A U : list X) : list X :=
      filter (fun x => x el A) U.

    Lemma rep_power A U :
      rep A U el power U.

    Proof.
      revert A; induction U as [|x U]; intros A.
      - simpl; auto.
      - simpl. decide (x el A) as [D|D]; auto using in_map.
    Qed.

    Lemma rep_incl A U :
      rep A U <<= A.

    Proof.
      unfold rep. intros x D. apply in_filter_iff in D. apply D.
    Qed.

    Lemma rep_in x A U :
      A <<= U -> x el A -> x el rep A U.
    Proof.
      intros D E. apply in_filter_iff; auto.
    Qed.

    Lemma rep_equi A U :
      A <<= U -> rep A U === A.

    Proof.
      intros D. split. now apply rep_incl.
      intros x. apply rep_in, D.
    Qed.

    Lemma rep_mono A B U :
      A <<= B -> rep A U <<= rep B U.

    Proof. intros D. apply filter_pq_mono. auto. Qed.

    Lemma rep_eq' A B U :
      (forall x, x el U -> (x el A <-> x el B)) -> rep A U = rep B U.

    Proof. intros D. apply filter_pq_eq. auto. Qed.

    Lemma rep_eq A B U :
      A === B -> rep A U = rep B U.

    Proof. intros D. apply filter_pq_eq. firstorder. Qed.

    Lemma rep_injective A B U :
      A <<= U -> B <<= U -> rep A U = rep B U -> A === B.

    Proof.
      intros D E F. transitivity (rep A U).
      - symmetry. apply rep_equi, D.
      - rewrite F. apply rep_equi, E.
    Qed.

    Lemma rep_idempotent A U :
      rep (rep A U) U = rep A U.

    Proof.
      unfold rep at 1 3. apply filter_pq_eq.
      intros x D. split.
      + apply rep_incl.
      + intros E. apply in_filter_iff. auto.
    Qed.

    Lemma dupfree_power U :
      dupfree U -> dupfree (power U).

    Proof.
      intros D. induction D as [|x U E D]; simpl.
      - constructor. now auto. constructor.
      - apply dupfree_app.
        + intros [A [F G]]. apply in_map_iff in G as [A' [G G']].
          subst A. apply E. apply (power_incl F). auto.
        + exact IHD.
        + apply dupfree_map; congruence.
    Qed.

    Lemma dupfree_in_power U A :
      A el power U -> dupfree U -> dupfree A.

    Proof.
      intros E D. revert A E.
      induction D as [|x U D D']; simpl; intros A E.
      - destruct E as [[]|[]]. constructor.
      - apply in_app_iff in E as [E|E].
        + auto.
        + apply in_map_iff in E as [A' [E E']]. subst A.
          constructor.
          * intros F; apply D. apply (power_incl E'), F.
          * auto.
    Qed.

    Lemma rep_dupfree A U :
      dupfree U -> A el power U -> rep A U = A.

    Proof.
      intros D; revert A.
      induction D as [|x U E F]; intros A G.
      - destruct G as [[]|[]]; reflexivity.
      - simpl in G. apply in_app_iff in G as [G|G].
        + simpl. decide (x el A) as [H|H].
          * exfalso. apply E. apply (power_incl G), H.
          * auto.
        + apply in_map_iff in G as [A' [G H]]. subst A.
          simpl. decide (x=x \/ x el A') as [G|G].
          * f_equal. rewrite <- (IHF A' H) at 2.
            apply filter_pq_eq. apply power_incl in H.
            intros z K. split; [|now auto].
            intros [L|L]; subst; tauto.
          * exfalso; auto.
    Qed.

    Lemma power_extensional A B U :
      dupfree U -> A el power U -> B el power U -> A === B -> A = B.

    Proof.
      intros D E F G.
      rewrite <- (rep_dupfree D E). rewrite <- (rep_dupfree D F).
      apply rep_eq, G.
    Qed.

  End PowerRep.

  (** * Finite closure iteration *)

  Module FCI.
    Section FCI.
      Variable X : Type.
      Context {eq_X_dec : eq_dec X}.
      Variable step : list X -> X -> Prop.
      Context {step_dec : forall A x, dec (step A x)}.
      Variable V : list X.

      Lemma pick (A : list X) :
        { x | x el V /\ step A x /\ ~ x el A } + { forall x, x el V -> step A x -> x el A }.
      Proof.
        destruct (list_sigma_forall V (fun x => step A x /\ ~ x el A)) as [E|E].
        - auto.
        - right. intros x F G.
          decide (x el A). assumption. exfalso.
          eapply E; eauto.
      Qed.

      Definition F (A : list X) : list X.
        destruct (pick A) as [[x _]|_].
        - exact (x::A).
        - exact A.
      Defined.

      Definition C := it F (card V) nil.

      Lemma it_incl n :
        it F n nil <<= V.
      Proof.
        apply it_ind. now auto.
        intros A E. unfold F.
        destruct (pick A) as [[x G]|G]; intuition.
      Qed.

      Lemma incl :
        C <<= V.
      Proof.
        apply it_incl.
      Qed.

      Lemma ind p :
        (forall A x, inclp A p -> x el V -> step A x -> p x) -> inclp C p.
      Proof.
        intros B. unfold C. apply it_ind.
        + intros x [].
        + intros D G x. unfold F.
          destruct (pick D) as [[y E]|E].
          * intros [[]|]; intuition; eauto.
          * intuition.
      Qed.

      Lemma fp :
        F C = C.
      Proof.
        pose (sigma (A : list X) := card V - card A).
        replace C with (it F (sigma nil) nil).
        - apply it_fp. intros n. simpl.
          set (J:= it F n nil). unfold FP, F.
          destruct (pick J) as [[x B]|B].
          + right.
            assert (G: card J < card (x :: J)).
            { apply card_lt with (x:=x); intuition. }
            assert (H: card (x :: J) <= card V).
            { apply card_le, incl_cons. apply B. apply it_incl. }
            unfold sigma. omega.
          + auto.
        - unfold C, sigma. f_equal. change (card nil) with 0. omega.
      Qed.

      Lemma closure x :
        x el V -> step C x -> x el C.
      Proof.
        assert (A2:= fp).
        unfold F in A2.
        destruct (pick C) as [[y _]| B].
        + contradiction (list_cycle A2).
        + apply B.
      Qed.

    End FCI.

  End FCI.

  (** * Deprecated names, defined for backward compatibilitly *)

  Definition dupfree_inv := dupfree_cons.
  Ltac dupapply H1 lemma H2 := pose (H2:= H1) ; apply lemma in H2.

End Base.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Import
        syntax_ott
        rules_inf
        Typing
        Infrastructure
        Subtyping_inversion
        Key_Properties
        Deterministic
        rules_inf2
        dunfield.
Require Import Lia.

Lemma open_dexp_eqn_aux :
                forall ee1 ee2 x n,
       x `notin` fv_dexp ee1 ->
       x `notin` fv_dexp ee2 ->
       open_dexp_wrt_dexp_rec n (de_var_f x) ee1 = open_dexp_wrt_dexp_rec n (de_var_f x) ee2
       -> ee1 = ee2.
Proof.
  apply_mutual_ind dexp_mutind;
  apply_mutual_ind dexp_mutind;
  default_simp;
  try solve [eapply_first_hyp; eauto].
  lia.
Qed.

Lemma open_dexp_eqn : forall x ee1 ee2,
       x `notin` fv_dexp ee1 ->
       x `notin` fv_dexp ee2 ->
       open_dexp_wrt_dexp ee1 (de_var_f x) = open_dexp_wrt_dexp ee2 (de_var_f x)
       -> ee1 = ee2.
Proof.
  intros x ee1 ee2 H H0 H1.
  unfold open_dexp_wrt_dexp in H1.
  pose proof open_dexp_eqn_aux.
  eauto.
Qed.

Lemma subtyping_completeness : forall A B,
    isub A B -> sub A B.
Proof.
  intros A B H.
  induction* H.
Qed.

Lemma disjoint_completeness : forall A B,
    icfpDisjoint A B -> disjointSpec A B.
Proof.
  intros A B H. apply disjoint_eqv.
  induction~ H.
  (* H: icfpDisjointAx A B *)
  induction~ H.
  (* symm case *)
  applys~ disjoint_symmetric.
Qed.

(* completeness of typing with respect to the extended
 bidirectional type system in ICFP 2016 *)
Theorem typing_completeness : forall G ee dir A e,
    IBTyping G ee dir A e -> Typing G e dir A.
Proof.
  intros G ee dir A e Typ.
  induction* Typ.
Qed.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Section Cats.

Coq < Variables c f k:Prop.
c is assumed
f is assumed
k is assumed

Coq < Goal ((c -> f) /\ (k -> c)) -> (k -> f).
1 subgoal

  c : Prop
  f : Prop
  k : Prop
  ============================
   (c -> f) /\ (k -> c) -> k -> f

Unnamed_thm < intros.
1 subgoal

  c : Prop
  f : Prop
  k : Prop
  H : (c -> f) /\ (k -> c)
  H0 : k
  ============================
   f

Unnamed_thm < elim H.
1 subgoal

  c : Prop
  f : Prop
  k : Prop
  H : (c -> f) /\ (k -> c)
  H0 : k
  ============================
   (c -> f) -> (k -> c) -> f

Unnamed_thm < info_auto.
(* info auto : *)
 intro.
 intro.
 apply H1.
  apply H2.
   assumption.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
info_auto.

Unnamed_thm is defined

*)

Section Cats.
Variables c f k:Prop.
Goal ((c -> f) /\ (k -> c)) -> (k -> f).
intros.
elim H.
info_auto.
Qed.


Require Import List.
Import ListNotations.
Require Import Bool.

Inductive option (A : Type) : Type :=
| None : option A
| Some : A -> option A.

Arguments None {A}.
Arguments Some {A} _.

Definition isNone {A : Type} (o : option A) : bool :=
match o with
| None => true
| _ => false
end.

Definition isSome {A : Type} (ma : option A) : bool :=
match ma with
| Some _ => true
| None => false
end.

Definition orElse {A : Type} (o : option A) (x : A) : A :=
match o with
| None => x
| Some a => a
end.

Notation "o 'or' 'else' x" := (orElse o x) (at level 50).

(*Definition optionToList {A : Type} (o : option A) : list A :=
match o with
| None => []
| Some x => [x]
end.*)

Fixpoint catOptions {A : Type} (l : list (option A)) : list A :=
match l with
| [] => []
| None :: t => catOptions t
| Some h :: t => h :: catOptions t
end.

Definition omap {A B : Type} (f : A -> B) (x : option A) : option B :=
match x with
| None => None
| Some a => Some (f a)
end.

Lemma isSome_or_isNone :
  forall (A : Type) (ma : option A),
    isSome ma || isNone ma = true.
Proof.
  destruct ma; cbn; trivial.
Qed.

Definition bind
  {A B : Type} (ma : option A) (f : A -> option B) : option B :=
match ma with
| Some a => f a
| None => None
end.


(** * Polyadic syntax example *)

Require Export fintype.
Require Import Vectors.Vector.

Section type.

Context {w:nat}.

Inductive type (ntype : nat) : Type :=
  | var_type : (fin) (ntype) -> fin w -> type (ntype)
  | all : Vector.t (type ntype) w -> type  (S ntype) -> type (ntype).

Lemma congr_all { mtype : nat } { s0 : Vector.t (type mtype) w  } { s1 : type  (S mtype) } { t0 : Vector.t (type mtype) w  } { t1 : type  (S mtype) } (H1 : s0 = t0) (H2 : s1 = t1) : all (mtype) s0 s1 = all (mtype) t0 t1 .
Proof. congruence. Qed.

Fixpoint ren_type { mtype : nat } { ntype : nat } (xitype : (fin) (mtype) -> (fin) (ntype)) (s : type (mtype)) : type (ntype) :=
    match s return type (ntype) with
    | var_type _ s i => (var_type (ntype)) (xitype s) i
    | all (_) s0 s1 => all (ntype) (Vector.map (ren_type xitype) s0) ((ren_type (up_ren xitype)) s1)
    end.

Definition up_type_type {n m} (sigma : fin n -> fin w -> type m) : fin (S n) -> fin w -> type (S m).
Proof. destruct 1; intro i. apply (ren_type shift),(sigma f i). exact (var_type _ var_zero i).
Defined.

Fixpoint subst_type { mtype : nat } { ntype : nat } (sigmatype : (fin) (mtype) -> fin w -> type (ntype)) (s : type (mtype)) : type (ntype) :=
    match s return type (ntype) with
    | var_type (_) x i => sigmatype x i
    | all (_) s0 s1 => all (ntype) (Vector.map (subst_type sigmatype) s0) ((subst_type (up_type_type sigmatype)) s1)
    end.
(*
Fixpoint upIdList_type_type p {n} (sigma : ( fin n) -> type n ) (Eq : forall x, sigma x = (var_type _) x) {struct p} : forall x, (upList_type_type p sigma) x = (var_type _) x.
Proof. intro. unfold upList_type_type. unfold scons_p. unfold funcomp. destruct p.
  -rewrite (Eq x). now simpl.
  -destruct x; simpl. 2: auto. rewrite (ap (ren_type (shift_p p))). pose (upIdList_type_type p n sigma Eq f).
   unfold upList_type_type in *. unfold scons_p.
   Admitted.
(* :=
  fun n => match n with
  | S fin_n => (ap) (ren_type (shift)) (Eq fin_n)
  | 0  => eq_refl
  end. *)

Fixpoint idSubst_type { mtype : nat } (sigmatype : (fin) (mtype) -> type (mtype)) (Eqtype : forall x, sigmatype x = (var_type (mtype)) x) (s : type (mtype)) : subst_type sigmatype s = s :=
    match s return subst_type sigmatype s = s with
    | var_type (_) s => Eqtype s
    | all (_) s0 s1 => congr_all ((idSubst_type sigmatype Eqtype) s0) ((idSubst_type (upList_type_type w sigmatype) (upIdList_type_type (_) Eqtype)) s1)
    end.

Fixpoint extRen_type { mtype : nat } { ntype : nat } (xitype : (fin) (mtype) -> (fin) (ntype)) (zetatype : (fin) (mtype) -> (fin) (ntype)) (Eqtype : forall x, xitype x = zetatype x) (s : type (mtype)) : ren_type xitype s = ren_type zetatype s :=
    match s return ren_type xitype s = ren_type zetatype s with
    | var_type (_) s => (ap) (var_type (ntype)) (Eqtype s)
    | all (_) w s0 s1 => congr_all ((extRen_type xitype zetatype Eqtype) s0) ((extRen_type (upRenList_type_type w xitype) (upRenList_type_type w zetatype) (upExtRen_list_type_type (_) (_) Eqtype)) s1)
    end.

Fixpoint ext_type { mtype : nat } { ntype : nat } (sigmatype : (fin) (mtype) -> type (ntype)) (tautype : (fin) (mtype) -> type (ntype)) (Eqtype : forall x, sigmatype x = tautype x) (s : type (mtype)) : subst_type sigmatype s = subst_type tautype s :=
    match s return subst_type sigmatype s = subst_type tautype s with
    | var_type (_) s => Eqtype s
    | all (_) w s0 s1 => congr_all ((ext_type sigmatype tautype Eqtype) s0) ((ext_type (upList_type_type w sigmatype) (upList_type_type w tautype) (upExt_list_type_type (_) (_) Eqtype)) s1)
    end.

Fixpoint compRenRen_type { ktype : nat } { ltype : nat } { mtype : nat } (xitype : (fin) (mtype) -> (fin) (ktype)) (zetatype : (fin) (ktype) -> (fin) (ltype)) (rhotype : (fin) (mtype) -> (fin) (ltype)) (Eqtype : forall x, ((funcomp) zetatype xitype) x = rhotype x) (s : type (mtype)) : ren_type zetatype (ren_type xitype s) = ren_type rhotype s :=
    match s return ren_type zetatype (ren_type xitype s) = ren_type rhotype s with
    | var_type (_) s => (ap) (var_type (ltype)) (Eqtype s)
    | all (_) w s0 s1 => congr_all ((compRenRen_type xitype zetatype rhotype Eqtype) s0) ((compRenRen_type (upRenList_type_type w xitype) (upRenList_type_type w zetatype) (upRenList_type_type w rhotype) (up_ren_ren_p Eqtype)) s1)
    end.

Fixpoint compRenSubst_type { ktype : nat } { ltype : nat } { mtype : nat } (xitype : (fin) (mtype) -> (fin) (ktype)) (tautype : (fin) (ktype) -> type (ltype)) (thetatype : (fin) (mtype) -> type (ltype)) (Eqtype : forall x, ((funcomp) tautype xitype) x = thetatype x) (s : type (mtype)) : subst_type tautype (ren_type xitype s) = subst_type thetatype s :=
    match s return subst_type tautype (ren_type xitype s) = subst_type thetatype s with
    | var_type (_) s => Eqtype s
    | all (_) w s0 s1 => congr_all ((compRenSubst_type xitype tautype thetatype Eqtype) s0) ((compRenSubst_type (upRenList_type_type w xitype) (upList_type_type w tautype) (upList_type_type w thetatype) (up_ren_subst_list_type_type (_) (_) (_) Eqtype)) s1)
    end.

Fixpoint compSubstRen_type { ktype : nat } { ltype : nat } { mtype : nat } (sigmatype : (fin) (mtype) -> type (ktype)) (zetatype : (fin) (ktype) -> (fin) (ltype)) (thetatype : (fin) (mtype) -> type (ltype)) (Eqtype : forall x, ((funcomp) (ren_type zetatype) sigmatype) x = thetatype x) (s : type (mtype)) : ren_type zetatype (subst_type sigmatype s) = subst_type thetatype s :=
    match s return ren_type zetatype (subst_type sigmatype s) = subst_type thetatype s with
    | var_type (_) s => Eqtype s
    | all (_) w s0 s1 => congr_all ((compSubstRen_type sigmatype zetatype thetatype Eqtype) s0) ((compSubstRen_type (upList_type_type w sigmatype) (upRenList_type_type w zetatype) (upList_type_type w thetatype) (up_subst_ren_list_type_type (_) (_) (_) Eqtype)) s1)
    end.

Fixpoint compSubstSubst_type { ktype : nat } { ltype : nat } { mtype : nat } (sigmatype : (fin) (mtype) -> type (ktype)) (tautype : (fin) (ktype) -> type (ltype)) (thetatype : (fin) (mtype) -> type (ltype)) (Eqtype : forall x, ((funcomp) (subst_type tautype) sigmatype) x = thetatype x) (s : type (mtype)) : subst_type tautype (subst_type sigmatype s) = subst_type thetatype s :=
    match s return subst_type tautype (subst_type sigmatype s) = subst_type thetatype s with
    | var_type (_) s => Eqtype s
    | all (_) w s0 s1 => congr_all ((compSubstSubst_type sigmatype tautype thetatype Eqtype) s0) ((compSubstSubst_type (upList_type_type w sigmatype) (upList_type_type w tautype) (upList_type_type w thetatype) (up_subst_subst_list_type_type (_) (_) (_) Eqtype)) s1)
    end.

Fixpoint rinst_inst_type { mtype : nat } { ntype : nat } (xitype : (fin) (mtype) -> (fin) (ntype)) (sigmatype : (fin) (mtype) -> type (ntype)) (Eqtype : forall x, ((funcomp) (var_type (ntype)) xitype) x = sigmatype x) (s : type (mtype)) : ren_type xitype s = subst_type sigmatype s :=
    match s return ren_type xitype s = subst_type sigmatype s with
    | var_type (_) s => Eqtype s
    | all (_) w s0 s1 => congr_all ((rinst_inst_type xitype sigmatype Eqtype) s0) ((rinst_inst_type (upRenList_type_type w xitype) (upList_type_type w sigmatype) (rinstInst_up_list_type_type (_) (_) Eqtype)) s1)
    end.

Lemma rinstInst_type { mtype : nat } { ntype : nat } (xitype : (fin) (mtype) -> (fin) (ntype)) : ren_type xitype = subst_type ((funcomp) (var_type (ntype)) xitype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => rinst_inst_type xitype (_) (fun n => eq_refl) x)). Qed.

Lemma instId_type { mtype : nat } : subst_type (var_type (mtype)) = id .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => idSubst_type (var_type (mtype)) (fun n => eq_refl) ((id) x))). Qed.

Lemma rinstId_type { mtype : nat } : @ren_type (mtype) (mtype) (id) = id .
Proof. exact ((eq_trans) (rinstInst_type ((id) (_))) instId_type). Qed.

Lemma varL_type { mtype : nat } { ntype : nat } (sigmatype : (fin) (mtype) -> type (ntype)) : (funcomp) (subst_type sigmatype) (var_type (mtype)) = sigmatype .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => eq_refl)). Qed.

Lemma varLRen_type { mtype : nat } { ntype : nat } (xitype : (fin) (mtype) -> (fin) (ntype)) : (funcomp) (ren_type xitype) (var_type (mtype)) = (funcomp) (var_type (ntype)) xitype .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun x => eq_refl)). Qed.

Lemma compComp_type { ktype : nat } { ltype : nat } { mtype : nat } (sigmatype : (fin) (mtype) -> type (ktype)) (tautype : (fin) (ktype) -> type (ltype)) (s : type (mtype)) : subst_type tautype (subst_type sigmatype s) = subst_type ((funcomp) (subst_type tautype) sigmatype) s .
Proof. exact (compSubstSubst_type sigmatype tautype (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_type { ktype : nat } { ltype : nat } { mtype : nat } (sigmatype : (fin) (mtype) -> type (ktype)) (tautype : (fin) (ktype) -> type (ltype)) : (funcomp) (subst_type tautype) (subst_type sigmatype) = subst_type ((funcomp) (subst_type tautype) sigmatype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compComp_type sigmatype tautype n)). Qed.

Lemma compRen_type { ktype : nat } { ltype : nat } { mtype : nat } (sigmatype : (fin) (mtype) -> type (ktype)) (zetatype : (fin) (ktype) -> (fin) (ltype)) (s : type (mtype)) : ren_type zetatype (subst_type sigmatype s) = subst_type ((funcomp) (ren_type zetatype) sigmatype) s .
Proof. exact (compSubstRen_type sigmatype zetatype (_) (fun n => eq_refl) s). Qed.

Lemma compRen'_type { ktype : nat } { ltype : nat } { mtype : nat } (sigmatype : (fin) (mtype) -> type (ktype)) (zetatype : (fin) (ktype) -> (fin) (ltype)) : (funcomp) (ren_type zetatype) (subst_type sigmatype) = subst_type ((funcomp) (ren_type zetatype) sigmatype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => compRen_type sigmatype zetatype n)). Qed.

Lemma renComp_type { ktype : nat } { ltype : nat } { mtype : nat } (xitype : (fin) (mtype) -> (fin) (ktype)) (tautype : (fin) (ktype) -> type (ltype)) (s : type (mtype)) : subst_type tautype (ren_type xitype s) = subst_type ((funcomp) tautype xitype) s .
Proof. exact (compRenSubst_type xitype tautype (_) (fun n => eq_refl) s). Qed.

Lemma renComp'_type { ktype : nat } { ltype : nat } { mtype : nat } (xitype : (fin) (mtype) -> (fin) (ktype)) (tautype : (fin) (ktype) -> type (ltype)) : (funcomp) (subst_type tautype) (ren_type xitype) = subst_type ((funcomp) tautype xitype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => renComp_type xitype tautype n)). Qed.

Lemma renRen_type { ktype : nat } { ltype : nat } { mtype : nat } (xitype : (fin) (mtype) -> (fin) (ktype)) (zetatype : (fin) (ktype) -> (fin) (ltype)) (s : type (mtype)) : ren_type zetatype (ren_type xitype s) = ren_type ((funcomp) zetatype xitype) s .
Proof. exact (compRenRen_type xitype zetatype (_) (fun n => eq_refl) s). Qed.

Lemma renRen'_type { ktype : nat } { ltype : nat } { mtype : nat } (xitype : (fin) (mtype) -> (fin) (ktype)) (zetatype : (fin) (ktype) -> (fin) (ltype)) : (funcomp) (ren_type zetatype) (ren_type xitype) = ren_type ((funcomp) zetatype xitype) .
Proof. exact ((FunctionalExtensionality.functional_extensionality _ _ ) (fun n => renRen_type xitype zetatype n)). Qed.
*)
End type.

Arguments var_type {w ntype}.

Arguments all {w ntype}.
(*
Global Instance Subst_type { mtype : nat } { ntype : nat } : Subst1 ((fin) (mtype) -> type (ntype)) (type (mtype)) (type (ntype)) := @subst_type (mtype) (ntype) .

Global Instance Ren_type { mtype : nat } { ntype : nat } : Ren1 ((fin) (mtype) -> (fin) (ntype)) (type (mtype)) (type (ntype)) := @ren_type (mtype) (ntype) .

Global Instance VarInstance_type { mtype : nat } : Var ((fin) (mtype)) (type (mtype)) := @var_type (mtype) .

Notation "x '__type'" := (var_type x) (at level 5, format "x __type") : subst_scope.

Notation "x '__type'" := (@ids (_) (_) VarInstance_type x) (at level 5, only printing, format "x __type") : subst_scope.

Notation "'var'" := (var_type) (only printing, at level 1) : subst_scope.

Class Up_type X Y := up_type : X -> Y.

Notation "↑__type" := (up_type) (only printing) : subst_scope.

Notation "s [ sigmatype ]" := (subst_type sigmatype s) (at level 7, left associativity, only printing) : subst_scope.

Notation "[ sigmatype ]" := (subst_type sigmatype) (at level 1, left associativity, only printing) : fscope.

Notation "s ⟨ xitype ⟩" := (ren_type xitype s) (at level 7, left associativity, only printing) : subst_scope.

Notation "⟨ xitype ⟩" := (ren_type xitype) (at level 1, left associativity, only printing) : fscope.

Ltac auto_unfold := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_type,  Ren_type,  VarInstance_type.

Tactic Notation "auto_unfold" "in" "*" := repeat unfold subst1,  subst2,  Subst1,  Subst2,  ids,  ren1,  ren2,  Ren1,  Ren2,  Subst_type,  Ren_type,  VarInstance_type in *.

Ltac asimpl' := repeat first [progress rewrite ?instId_type| progress rewrite ?compComp_type| progress rewrite ?compComp'_type| progress rewrite ?rinstId_type| progress rewrite ?compRen_type| progress rewrite ?compRen'_type| progress rewrite ?renComp_type| progress rewrite ?renComp'_type| progress rewrite ?renRen_type| progress rewrite ?renRen'_type| progress rewrite ?varL_type| progress rewrite ?varLRen_type| progress (unfold up_ren, upRenList_type_type, upList_type_type)| progress (cbn [subst_type ren_type])| fsimpl].

Ltac asimpl := repeat try unfold_funcomp; auto_unfold in *; asimpl'; repeat try unfold_funcomp.

Tactic Notation "asimpl" "in" hyp(J) := revert J; asimpl; intros J.

Tactic Notation "auto_case" := auto_case (asimpl; cbn; eauto).

Tactic Notation "asimpl" "in" "*" := auto_unfold in *; repeat first [progress rewrite ?instId_type in *| progress rewrite ?compComp_type in *| progress rewrite ?compComp'_type in *| progress rewrite ?rinstId_type in *| progress rewrite ?compRen_type in *| progress rewrite ?compRen'_type in *| progress rewrite ?renComp_type in *| progress rewrite ?renComp'_type in *| progress rewrite ?renRen_type in *| progress rewrite ?renRen'_type in *| progress rewrite ?varL_type in *| progress rewrite ?varLRen_type in *| progress (unfold up_ren, upRenList_type_type, upList_type_type in * )| progress (cbn [subst_type ren_type] in * )| fsimpl in *].

Ltac substify := auto_unfold; try repeat (erewrite rinstInst_type).

Ltac renamify := auto_unfold; try repeat (erewrite <- rinstInst_type).
 *)


(** This is a copy of the parts of the Coq stdlib implementing
    [nsatz], excluding the bit that adds support for [ℝ], which draws
    in axioms reported by coqchk.  Once we move to Coq 8.13 as our
    minimum version, this should be dropped. *)
(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *         Copyright INRIA, CNRS and contributors             *)
(* <O___,, * (see version control and CREDITS file for authors & dates) *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(*
 Tactic nsatz: proofs of polynomials equalities in an integral domain
(commutative ring without zero divisor).

Examples: see test-suite/success/Nsatz.v

Reification is done using type classes, defined in Ncring_tac.v

*)

From Coq Require Import List.
From Coq Require Import Setoid.
From Coq Require Import BinPos.
From Coq Require Import BinList.
From Coq Require Import Znumtheory.
From Coq Require Export Morphisms Setoid Bool.
From Coq Require Export Algebra_syntax.
From Coq Require Export Ncring.
From Coq Require Export Ncring_initial.
From Coq Require Export Ncring_tac.
From Coq Require Export Integral_domain.
From Coq Require Import ZArith.
From Coq Require Import Lia.

Declare ML Module "nsatz_plugin".

Section nsatz1.

Context {R:Type}`{Rid:Integral_domain R}.

Lemma psos_r1b: forall x y:R, x - y == 0 -> x == y.
intros x y H; setoid_replace x with ((x - y) + y); simpl;
 [setoid_rewrite H | idtac]; simpl. cring. cring.
Qed.

Lemma psos_r1: forall x y, x == y -> x - y == 0.
intros x y H; simpl; setoid_rewrite H; simpl; cring.
Qed.

Lemma nsatzR_diff: forall x y:R, not (x == y) -> not (x - y == 0).
intros.
intro; apply H.
simpl; setoid_replace x with ((x - y) + y). simpl.
setoid_rewrite H0.
simpl; cring.
simpl. simpl; cring.
Qed.

(* adpatation du code de Benjamin aux setoides *)
Export Ring_polynom.
Export InitialRing.

Definition PolZ := Pol Z.
Definition PEZ := PExpr Z.

Definition P0Z : PolZ := P0 (C:=Z) 0%Z.

Definition PolZadd : PolZ -> PolZ -> PolZ :=
  @Padd  Z 0%Z Z.add Zeq_bool.

Definition PolZmul : PolZ -> PolZ -> PolZ :=
  @Pmul  Z 0%Z 1%Z Z.add Z.mul Zeq_bool.

Definition PolZeq := @Peq Z Zeq_bool.

Definition norm :=
  @norm_aux Z 0%Z 1%Z Z.add Z.mul Z.sub Z.opp Zeq_bool.

Fixpoint mult_l (la : list PEZ) (lp: list PolZ) : PolZ :=
 match la, lp with
 | a::la, p::lp => PolZadd (PolZmul (norm a) p) (mult_l la lp)
 | _, _ => P0Z
 end.

Fixpoint compute_list (lla: list (list PEZ)) (lp:list PolZ) :=
 match lla with
 | List.nil => lp
 | la::lla => compute_list lla ((mult_l la lp)::lp)
 end.

Definition check (lpe:list PEZ) (qe:PEZ) (certif: list (list PEZ) * list PEZ) :=
 let (lla, lq) := certif in
 let lp := List.map norm lpe in
 PolZeq (norm qe) (mult_l lq (compute_list lla lp)).

(* Correction *)
Definition PhiR : list R -> PolZ -> R :=
  (Pphi ring0 add mul
    (InitialRing.gen_phiZ ring0 ring1 add mul opp)).

Definition PEevalR : list R -> PEZ -> R :=
   PEeval ring0 ring1 add mul sub opp
    (gen_phiZ ring0 ring1 add mul opp)
         N.to_nat pow.

Lemma P0Z_correct : forall l, PhiR l P0Z = 0.
Proof. trivial. Qed.

Lemma Rext: ring_eq_ext add mul opp _==_.
Proof.
constructor; solve_proper.
Qed.

Lemma Rset : Setoid_Theory R _==_.
apply ring_setoid.
Qed.

Definition Rtheory:ring_theory ring0 ring1 add mul sub opp _==_.
apply mk_rt.
apply ring_add_0_l.
apply ring_add_comm.
apply ring_add_assoc.
apply ring_mul_1_l.
apply cring_mul_comm.
apply ring_mul_assoc.
apply ring_distr_l.
apply ring_sub_def.
apply ring_opp_def.
Defined.

Lemma PolZadd_correct : forall P' P l,
  PhiR l (PolZadd P P') == ((PhiR l P) + (PhiR l P')).
Proof.
unfold PolZadd, PhiR. intros. simpl.
 refine (Padd_ok Rset Rext (Rth_ARth Rset Rext Rtheory)
           (gen_phiZ_morph Rset Rext Rtheory) _ _ _).
Qed.

Lemma PolZmul_correct : forall P P' l,
  PhiR l (PolZmul P P') == ((PhiR l P) * (PhiR l P')).
Proof.
unfold PolZmul, PhiR. intros.
 refine (Pmul_ok Rset Rext (Rth_ARth Rset Rext Rtheory)
           (gen_phiZ_morph Rset Rext Rtheory) _ _ _).
Qed.

Lemma R_power_theory
     : Ring_theory.power_theory ring1 mul _==_ N.to_nat pow.
apply Ring_theory.mkpow_th. unfold pow. intros. rewrite Nnat.N2Nat.id.
reflexivity. Qed.

Lemma norm_correct :
  forall (l : list R) (pe : PEZ), PEevalR l pe == PhiR l (norm pe).
Proof.
 intros;apply (norm_aux_spec Rset Rext (Rth_ARth Rset Rext Rtheory)
           (gen_phiZ_morph Rset Rext Rtheory) R_power_theory).
Qed.

Lemma PolZeq_correct : forall P P' l,
  PolZeq P P' = true ->
  PhiR l P == PhiR l P'.
Proof.
 intros;apply
   (Peq_ok Rset Rext (gen_phiZ_morph Rset Rext Rtheory));trivial.
Qed.

Fixpoint Cond0 (A:Type) (Interp:A->R) (l:list A) : Prop :=
  match l with
  | List.nil => True
  | a::l => Interp a == 0 /\ Cond0 A Interp l
  end.

Lemma mult_l_correct : forall l la lp,
  Cond0 PolZ (PhiR l) lp ->
  PhiR l (mult_l la lp) == 0.
Proof.
 induction la;simpl;intros. cring.
 destruct lp;trivial. simpl. cring.
 simpl in H;destruct H.
 rewrite  PolZadd_correct.
 simpl. rewrite PolZmul_correct. simpl. rewrite  H.
 rewrite IHla. cring. trivial.
Qed.

Lemma compute_list_correct : forall l lla lp,
  Cond0 PolZ (PhiR l) lp ->
  Cond0 PolZ (PhiR l) (compute_list lla lp).
Proof.
 induction lla;simpl;intros;trivial.
 apply IHlla;simpl;split;trivial.
 apply mult_l_correct;trivial.
Qed.

Lemma check_correct :
  forall l lpe qe certif,
    check lpe qe certif = true ->
    Cond0 PEZ (PEevalR l) lpe ->
    PEevalR l qe == 0.
Proof.
 unfold check;intros l lpe qe (lla, lq) H2 H1.
 apply PolZeq_correct with (l:=l) in H2.
 rewrite norm_correct, H2.
 apply mult_l_correct.
 apply compute_list_correct.
 clear H2 lq lla qe;induction lpe;simpl;trivial.
 simpl in H1;destruct H1.
 rewrite <- norm_correct;auto.
Qed.

(* fin *)

Definition R2:= 1 + 1.

Fixpoint IPR p {struct p}: R :=
  match p with
    xH => ring1
  | xO xH => 1+1
  | xO p1 => R2*(IPR p1)
  | xI xH => 1+(1+1)
  | xI p1 => 1+(R2*(IPR p1))
  end.

Definition IZR1 z :=
  match z with Z0 => 0
             | Zpos p => IPR p
             | Zneg p => -(IPR p)
  end.

Fixpoint interpret3 t fv {struct t}: R :=
  match t with
  | (PEadd t1 t2) =>
       let v1  := interpret3 t1 fv in
       let v2  := interpret3 t2 fv in (v1 + v2)
  | (PEmul t1 t2) =>
       let v1  := interpret3 t1 fv in
       let v2  := interpret3 t2 fv in (v1 * v2)
  | (PEsub t1 t2) =>
       let v1  := interpret3 t1 fv in
       let v2  := interpret3 t2 fv in (v1 - v2)
  | (PEopp t1) =>
       let v1  := interpret3 t1 fv in (-v1)
  | (PEpow t1 t2) =>
       let v1  := interpret3 t1 fv in pow v1 (N.to_nat t2)
  | (PEc t1) => (IZR1 t1)
  | PEO => 0
  | PEI => 1
  | (PEX _ n) => List.nth (pred (Pos.to_nat n)) fv 0
  end.

End nsatz1.

Ltac equality_to_goal H x y:=
  (* eliminate trivial  hypotheses, but it takes time!:
  let h := fresh "nH" in
    (assert (h:equality x y);
    [solve [cring] | clear H; clear h])
  || *) try (generalize (@psos_r1 _ _ _ _ _ _ _ _ _ _ _ x y H); clear H)
.

Ltac equalities_to_goal :=
  lazymatch goal with
  |  H: (_ ?x ?y) |- _ => equality_to_goal H x y
  |  H: (_ _ ?x ?y) |- _ => equality_to_goal H x y
  |  H: (_ _ _ ?x ?y) |- _ => equality_to_goal H x y
  |  H: (_ _ _ _ ?x ?y) |- _ => equality_to_goal H x y
(* extension possible :-) *)
  |  H: (?x == ?y) |- _ => equality_to_goal H x y
   end.

(* lp est incluse dans fv. La met en tete. *)

Ltac parametres_en_tete fv lp :=
    match fv with
     | (@nil _)          => lp
     | (@cons _ ?x ?fv1) =>
       let res := AddFvTail x lp in
         parametres_en_tete fv1 res
    end.

Ltac append1 a l :=
 match l with
 | (@nil _)     => constr:(cons a l)
 | (cons ?x ?l) => let l' := append1 a l in constr:(cons x l')
 end.

Ltac rev l :=
  match l with
   |(@nil _)      => l
   | (cons ?x ?l) => let l' := rev l in append1 x l'
  end.

Ltac nsatz_call_n info nparam p rr lp kont :=
(*  idtac "Trying power: " rr;*)
  let ll := constr:(PEc info :: PEc nparam :: PEpow p rr :: lp) in
(*  idtac "calcul...";*)
  nsatz_compute ll;
(*  idtac "done";*)
  match goal with
  | |- (?c::PEpow _ ?r::?lq0)::?lci0 = _ -> _ =>
    intros _;
    let lci := fresh "lci" in
    set (lci:=lci0);
    let lq := fresh "lq" in
    set (lq:=lq0);
    kont c rr lq lci
  end.

Ltac nsatz_call radicalmax info nparam p lp kont :=
  let rec try_n n :=
    lazymatch n with
    | 0%N => fail
    | _ =>
        (let r := eval compute in (N.sub radicalmax (N.pred n)) in
         nsatz_call_n info nparam p r lp kont) ||
         let n' := eval compute in (N.pred n) in try_n n'
    end in
  try_n radicalmax.

Ltac lterm_goal g :=
  match g with
    ?b1 == ?b2 => constr:(b1::b2::nil)
  | ?b1 == ?b2 -> ?g => let l := lterm_goal g in constr:(b1::b2::l)
  end.

Ltac reify_goal l le lb:=
  match le with
     nil => idtac
   | ?e::?le1 =>
        match lb with
         ?b::?lb1 => (* idtac "b="; idtac b;*)
           let x := fresh "B" in
           set (x:= b) at 1;
           change x with (interpret3 e l);
           clear x;
           reify_goal l le1 lb1
        end
  end.

Ltac get_lpol g :=
  match g with
  (interpret3 ?p _) == _ => constr:(p::nil)
  | (interpret3 ?p _) == _ -> ?g =>
       let l := get_lpol g in constr:(p::l)
  end.

(** We only make use of [discrR] if [nsatz] support for reals is
    loaded.  To do this, we redefine this tactic in Nsatz.v to make
    use of real discrimination. *)
Ltac nsatz_internal_discrR := idtac.

Ltac nsatz_generic radicalmax info lparam lvar :=
 let nparam := eval compute in (Z.of_nat (List.length lparam)) in
 match goal with
  |- ?g => let lb := lterm_goal g in
     match (match lvar with
              |(@nil _) =>
                 match lparam with
                   |(@nil _) =>
                     let r := eval red in (list_reifyl (lterm:=lb)) in r
                   |_ =>
                     match eval red in (list_reifyl (lterm:=lb)) with
                       |(?fv, ?le) =>
                         let fv := parametres_en_tete fv lparam in
                           (* we reify a second time, with the good order
                              for variables *)
                         let r := eval red in
                                  (list_reifyl (lterm:=lb) (lvar:=fv)) in r
                     end
                  end
              |_ =>
                let fv := parametres_en_tete lvar lparam in
                let r := eval red in (list_reifyl (lterm:=lb) (lvar:=fv)) in r
            end) with
          |(?fv, ?le) =>
            reify_goal fv le lb ;
            match goal with
                   |- ?g =>
                       let lp := get_lpol g in
                       let lpol := eval compute in (List.rev lp) in
                       intros;

  let SplitPolyList kont :=
    match lpol with
    | ?p2::?lp2 => kont p2 lp2
    | _ => idtac "polynomial not in the ideal"
    end in

  SplitPolyList ltac:(fun p lp =>
    let p21 := fresh "p21" in
    let lp21 := fresh "lp21" in
    set (p21:=p) ;
    set (lp21:=lp);
(*    idtac "nparam:"; idtac nparam; idtac "p:"; idtac p; idtac "lp:"; idtac lp; *)
    nsatz_call radicalmax info nparam p lp ltac:(fun c r lq lci =>
      let q := fresh "q" in
      set (q := PEmul c (PEpow p21 r));
      let Hg := fresh "Hg" in
      assert (Hg:check lp21 q (lci,lq) = true);
      [ (vm_compute;reflexivity) || idtac "invalid nsatz certificate"
      | let Hg2 := fresh "Hg" in
            assert (Hg2: (interpret3 q fv) == 0);
        [ (*simpl*) idtac;
          generalize (@check_correct _ _ _ _ _ _ _ _ _ _ _ fv lp21 q (lci,lq) Hg);
          let cc := fresh "H" in
             (*simpl*) idtac; intro cc; apply cc; clear cc;
          (*simpl*) idtac;
          repeat (split;[assumption|idtac]); exact I
        | (*simpl in Hg2;*) (*simpl*) idtac;
          apply Rintegral_domain_pow with (interpret3 c fv) (N.to_nat r);
          (*simpl*) idtac;
            try apply integral_domain_one_zero;
            try apply integral_domain_minus_one_zero;
            try trivial;
            try exact integral_domain_one_zero;
            try exact integral_domain_minus_one_zero
          || (solve [simpl; unfold R2, equality, eq_notation, addition, add_notation,
                     one, one_notation, multiplication, mul_notation, zero, zero_notation;
                     nsatz_internal_discrR || lia ])
          || ((*simpl*) idtac) || idtac "could not prove discrimination result"
        ]
      ]
)
)
end end end .

Ltac nsatz_default:=
  intros;
  try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _);
  match goal with |- (@equality ?r _ _ _) =>
    repeat equalities_to_goal;
    nsatz_generic 6%N 1%Z (@nil r) (@nil r)
  end.

Tactic Notation "nsatz" := nsatz_default.

Tactic Notation "nsatz" "with"
 "radicalmax" ":=" constr(radicalmax)
 "strategy" ":=" constr(info)
 "parameters" ":=" constr(lparam)
 "variables" ":=" constr(lvar):=
  intros;
  try apply (@psos_r1b _ _ _ _ _ _ _ _ _ _ _);
  match goal with |- (@equality ?r _ _ _) =>
    repeat equalities_to_goal;
    nsatz_generic radicalmax info lparam lvar
  end.

(* Rational numbers *)
From Coq Require Import QArith.

Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq) := { }.

Instance Qri : (Ring (Ro:=Qops)).
constructor.
try apply Q_Setoid.
apply Qplus_comp.
apply Qmult_comp.
apply Qminus_comp.
apply Qopp_comp.
 exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc.
 exact Qmult_1_l.  exact Qmult_1_r. apply Qmult_assoc.
 apply Qmult_plus_distr_l.  intros. apply Qmult_plus_distr_r.
reflexivity. exact Qplus_opp_r.
Defined.

Lemma Q_one_zero: not (Qeq 1%Q 0%Q).
Proof. unfold Qeq. simpl. lia.  Qed.

Instance Qcri: (Cring (Rr:=Qri)).
red. exact Qmult_comm. Defined.

Instance Qdi : (Integral_domain (Rcr:=Qcri)).
constructor.
exact Qmult_integral. exact Q_one_zero. Defined.

(* Integers *)
Lemma Z_one_zero: 1%Z <> 0%Z.
Proof. lia. Qed.

Instance Zcri: (Cring (Rr:=Zr)).
red. exact Z.mul_comm. Defined.

Instance Zdi : (Integral_domain (Rcr:=Zcri)).
constructor.
exact Zmult_integral. exact Z_one_zero. Defined.


(* Definitions and Properties of First-Order Terms *)
(*   with holes in [nat] for de Bruijn indices *)

(* arity check based on vectors *)

From Coq Require Export PeanoNat.
From Coq Require Vector.
From OLlibs Require Export dectype List_more.
From Quantifiers Require Export term_tactics.

Set Implicit Arguments.

Notation vec := Vector.t.

(* Extensional equality of functions *)
Definition ext_eq {A B} (f g : A -> B) := (forall a, f a = g a).
Notation " f ~ g " := (ext_eq f g) (at level 60).

(** * First-Order Terms *)

Section Terms.

Context {vatom : DecType} { tatom : Type}.
Context {tarity : tatom -> nat}. (* arity of function symbols *)

(** terms with quantifiable variables

 - [evar] for De Bruijn style eigen variables in proofs,
             type for these indices as parameter called the eigen type,
             but mostly used with [nat].
             Other values can be used (for terms without indices, use [Empty_set]).
 - [tvar] for quantified variables in formulas *)
Inductive term T :=
| evar : T -> term T
| tvar : vatom -> term T
| tconstr : forall f, vec (term T) (tarity f) -> term T.
Arguments evar {T}.
Arguments tconstr {T} f _.

(** appropriate induction for [term] (with list inside): so called "nested fix" *)
Fixpoint term_ind_vec_Forall T t :
  forall P : term T -> Prop,
  (forall n, P (evar n)) ->
  (forall x, P (tvar T x)) ->
  (forall f l, Vector.Forall P l -> P (tconstr f l)) -> P t :=
fun P Pevar Ptvar Pconstr =>
match t with
| evar n => Pevar n
| tvar _ x => Ptvar x
| tconstr c l => Pconstr c l
    ((fix l_ind k l' : Vector.Forall P l' :=
      match l' with
      | Vector.nil _ => Vector.Forall_nil P
      | Vector.cons _ t1 k l1 => Vector.Forall_cons _ _ _
                                   (term_ind_vec_Forall t1 Pevar Ptvar Pconstr)
                                   (l_ind k l1)
      end) (tarity c) l)
end.
Ltac term_induction t :=
  (try intros until t);
  let nn := fresh "n" in
  let xx := fresh "x" in
  let cc := fresh "c" in
  let ll := fresh "l" in
  let IHll := fresh "IHl" in
  let i := fresh "i" in
  let Hi := fresh "Hi" in
  apply (@term_ind_vec_Forall _ t);
  [ intros nn; try (now intuition); simpl
  | intros xx; try (now intuition); simpl
  | intros cc ll IHll; simpl; intros;
    try (apply (f_equal (tconstr _)));
    rewrite ? Vector.to_list_map, ? Vector.map_map;
    rewrite ? flat_map_concat_map, ? map_map;
    try (apply (f_equal (@concat _)));
    match goal with
    | |- Vector.map _ ?l = ?l => rewrite <- (Vector.map_id _ _ l) at 2
    | _ => idtac
    end;
    try apply Vector.map_ext_in; try apply map_ext_in;
    try (intros i Hi; apply Vector.Forall_forall with (a:=i) in IHll);
    try (now apply Vector.to_list_In);
    try (intuition; fail) ];
  try (now rcauto).

(** * Monad structure on [term] via substitution *)

(** substitutes the [term] [r n] for index [n] in [term] [t] *)
Fixpoint tesubs T1 T2 (r : T1 -> term T2) (t : term T1) :=
match t with
| tvar _ x => tvar T2 x
| evar k => r k
| tconstr f l => tconstr f (Vector.map (tesubs r) l)
end.
Notation "t ⟦ r ⟧" := (tesubs r t) (at level 8, left associativity, format "t ⟦ r ⟧").

(** monad structure induced on [term] *)
Lemma evar_tesubs T1 T2 (r : T1 -> term T2) :
  forall x, (evar x)⟦r⟧ = r x.
Proof. reflexivity. Qed.
Hint Rewrite evar_tesubs : term_db.

Lemma tesubs_evar T : forall (t : term T),
  t⟦evar⟧ = t.
Proof. term_induction t. Qed.
Hint Rewrite tesubs_evar : term_db.

Definition fecomp T1 T2 T3 (r : T1 -> term T2) (s : T2 -> term T3) := fun x => (r x)⟦s⟧.
Notation "r ;; s" := (fecomp r s) (at level 20, format "r  ;;  s").

Lemma tesubs_comp T1 T2 T3 (r : T1 -> term T2) (s : T2 -> term T3) t : t⟦r⟧⟦s⟧ = t⟦r ;; s⟧.
Proof. term_induction t. Qed.
Hint Rewrite tesubs_comp : term_db.

(* the result of substitution depends extensionnaly on the substituting function *)
Lemma tesubs_ext T1 T2 (r1 r2 : T1 -> term T2) : r1 ~ r2 -> forall t, t⟦r1⟧ = t⟦r2⟧.
Proof. term_induction t. Qed.
Hint Resolve tesubs_ext : term_db.
(* TODO could be turned into a morphism *)

Section Fixed_Eigen_Type.

Variable T : Type.
Implicit Type t : term T.
Arguments tvar {T} _.

(** * Term substitution *)

(** substitutes [term] [u] for variable [x] in [term] [t] *)
Fixpoint tsubs x u t :=
match t with
| tvar y => if eq_dt_dec y x then u else tvar y
| evar k => evar k
| tconstr c l => tconstr c (Vector.map (tsubs x u) l)
end.
Notation "t [ u // x ]" := (tsubs x u t) (at level 8, format "t [ u // x ]").

Lemma tsubs_tsubs_eq x u v t : t[v//x][u//x] = t[v[u//x]//x].
Proof. term_induction t. Qed.
Hint Rewrite tsubs_tsubs_eq : term_db.

(** * Variables *)

Fixpoint tvars t :=
match t with
| tvar x => cons x List.nil
| evar _ => nil
| tconstr _ l => concat (Vector.to_list (Vector.map tvars l))
end.
Notation "x ∈ t" := (In x (tvars t)) (at level 30).
Notation "x ∉ t" := (~ In x (tvars t)) (at level 30).
Notation closed t := (tvars t = nil).

Lemma closed_notvars t x : closed t -> x ∉ t.
Proof. intros Hc Hin. rewrite Hc in Hin. destruct Hin. Qed.
Hint Resolve closed_notvars : term_db.

Lemma tvars_tsubs_closed x u : closed u -> forall t, tvars t[u//x] = remove eq_dt_dec x (tvars t).
Proof.
term_induction t.
rewrite remove_concat, flat_map_concat_map, ? Vector.to_list_map, ? map_map. f_equal.
apply Vector.to_list_Forall in IHl.
apply map_ext_in. intros v Hv. now specialize_Forall IHl with v.
Qed.
Hint Rewrite tvars_tsubs_closed using intuition; fail : term_db.

Lemma notin_tsubs x u t : x ∉ t -> t[u//x] = t.
Proof.
term_induction t; try rcauto.
apply IHl; intros Hx; apply H.
rewrite Vector.to_list_map, <- flat_map_concat_map.
apply in_flat_map; exists i; intuition.
now apply Vector.to_list_In.
Qed.
Hint Rewrite notin_tsubs using try easy;
                              (try (intuition; fail));
                              (try apply closed_notvars); intuition; fail : term_db.

Lemma tsubs_tsubs: forall x v y u, x <> y -> x ∉ u -> forall t,
  t[v//x][u//y] = t[u//y][v[u//y]//x].
Proof. term_induction t. Qed.
Hint Rewrite tsubs_tsubs using try (intuition; fail);
                              (try apply closed_notvars); intuition; fail : term_db.

Lemma notin_tsubs_bivar x y t : x ∉ t -> t[tvar x//y][tvar y//x] = t.
Proof.
term_induction t.
apply IHl; intros Hx; apply H.
rewrite Vector.to_list_map, <- flat_map_concat_map.
apply in_flat_map; exists i; intuition.
now apply Vector.to_list_In.
Qed.
Hint Rewrite notin_tsubs_bivar using try easy;
                                    (try (intuition; fail));
                                    (try apply closed_notvars); intuition; fail : term_db.

End Fixed_Eigen_Type.

Section Two_Eigen_Types.

Variable T1 T2 : Type.
Variable r : T1 -> term T2.

Notation closed t := (tvars t = nil).
Notation rclosed := (forall n, closed (r n)).
Notation "t [ u // x ]" := (tsubs x u t) (at level 8, format "t [ u // x ]").

Hint Rewrite notin_tsubs using try easy;
                              (try (intuition; fail));
                              (try apply closed_notvars); intuition; fail : term_db.

(** * Additional results with variable eigen type *)

Lemma tvars_tesubs_closed t : rclosed -> tvars t⟦r⟧ = tvars t.
Proof. term_induction t. Qed.
Hint Rewrite tvars_tesubs_closed using intuition; fail : term_db.

Lemma tsubs_tesubs x u t : rclosed -> t[u//x]⟦r⟧ = t⟦r⟧[u⟦r⟧//x].
Proof. term_induction t. Qed.
Hint Rewrite tsubs_tesubs using intuition; fail : term_db.

End Two_Eigen_Types.

(* We restrict to [term nat] *)
Section Eigen_nat.

Hint Rewrite tvars_tesubs_closed using intuition; fail : term_db.

Notation term := (term nat).
Notation tvar := (tvar nat).
Notation "t [ u // x ]" := (tsubs x u t) (at level 8, format "t [ u // x ]").
Notation "x ∈ t" := (In x (tvars t)) (at level 30).
Notation "x ∉ t" := (~ In x (tvars t)) (at level 30).
Notation closed t := (tvars t = nil).
Notation rclosed r := (forall n, closed (r n)).

Definition fup := fun n => evar (S n).
Notation "⇑" := fup.
Notation "t ↑" := (t⟦⇑⟧) (at level 8, format "t ↑").

Lemma closed_fup : rclosed ⇑.
Proof. reflexivity. Qed.
Hint Rewrite closed_fup : term_db.

Lemma tvars_fup t : tvars t↑ = tvars t.
Proof. rcauto. Qed.
Hint Rewrite tvars_fup : term_db.

(* general shape, unused, generated through ↑
Definition fesubs k v := fun n =>
  match n ?= k with
  | Lt => evar n
  | Eq => v
  | Gt => evar (pred n)
  end.
Notation "v // ↓ k" := (fesubs k v) (at level 18, format "v // ↓ k").

Lemma closed_fesubs : forall k v, closed v -> rclosed (v//↓k).
Proof. e_case_intuition unfolding fesubs. Qed.
Hint Resolve closed_fesubs : term_db.

Lemma fesubs_fup k v : ⇑ ;; v↑//↓(S k) == v//↓k ;; ⇑.
Proof. intros ?; unfold fesubs, fup, fecomp; e_case_intuition. Qed.
*)
Definition fesubs v := fun n =>
  match n with
  | 0 => v
  | S n => evar n
  end.
Notation "v ⇓" := (fesubs v) (at level 18, format "v ⇓").

Lemma closed_fesubs v : closed v -> rclosed (v⇓).
Proof. now intros Hc [|]. Qed.
Hint Resolve closed_fesubs : term_db.

Lemma fesubs_fup v : ⇑ ;; v⇓ ~ evar.
Proof. intro. reflexivity. Qed.

Lemma tesubs_fup v t : t↑⟦v⇓⟧ = t.
Proof. rcauto. Qed.
Hint Rewrite tesubs_fup : term_db.

(* In practive only the case [u = evar 0] will be used *)
Definition felift u r := fun n =>
  match n with
  | 0 => u
  | S k => (r k)↑
  end.
Notation "⇑[ u ] r" := (felift u r) (at level 25, format "⇑[ u ] r").

Lemma closed_felift u r : closed u -> rclosed r -> rclosed (⇑[u]r).
Proof. rnow intros ? ? [|]. Qed.
Hint Resolve closed_felift : term_db.

Lemma felift_comp u r : r ;; ⇑ ~ ⇑ ;; ⇑[u]r.
Proof. intro. reflexivity. Qed.
Hint Rewrite felift_comp : term_db.

Lemma felift_tesubs u r t : t⟦r⟧↑ = t↑⟦⇑[u]r⟧.
Proof. rcauto. Qed.
Hint Rewrite felift_tesubs : term_db.

End Eigen_nat.

End Terms.

Ltac term_induction t :=
  (try intros until t);
  let nn := fresh "n" in
  let xx := fresh "x" in
  let cc := fresh "c" in
  let ll := fresh "l" in
  let IHll := fresh "IHl" in
  let i := fresh "i" in
  let Hi := fresh "Hi" in
  apply (@term_ind_vec_Forall _ t);
  [ intros nn; try (now intuition); simpl
  | intros xx; try (now intuition); simpl
  | intros cc ll IHll; simpl; intros;
    try (apply (f_equal (tconstr _)));
    rewrite ? Vector.to_list_map, ? Vector.map_map;
    rewrite ? flat_map_concat_map, ? map_map;
    try (apply (f_equal (@concat _)));
    match goal with
    | |- Vector.map _ ?l = ?l => rewrite <- (Vector.map_id _ _ l) at 2
    | _ => idtac
    end;
    try apply Vector.map_ext_in; try apply map_ext_in;
    try (intros i Hi; apply Vector.Forall_forall with (a:=i) in IHll);
    try (now apply Vector.to_list_In);
    try (intuition; fail) ];
  try (now rcauto).


Require Import values.
Require Import over_instrumented_values.

(*----- SIMPLE TO OVER-INSTRUMENTED -----*)

Fixpoint val_to_oival (v:val) : oival :=
  OIV_ nil
  match v with
    | V_Num n => OIV_Num n
    | V_Bool b => OIV_Bool b
    | V_Constr0 n => OIV_Constr0 n
    | V_Constr1 n v => OIV_Constr1 n (val_to_oival v)
    | V_Closure x e c => OIV_Closure x e (env_to_oienv c)
    | V_Couple v1 v2 => OIV_Couple (val_to_oival v1) (val_to_oival v2)
    | V_Rec_Closure f x e c => OIV_Rec_Closure f x e (env_to_oienv c)
  end

with env_to_oienv (c:env) : oienv :=
  match c with
    | Env_empty => OIEnv_empty
    | Env_cons x v c' => OIEnv_cons x (val_to_oival v) (env_to_oienv c')
  end.

Definition val_to_oitval (v:val) : oitval := OIV nil (val_to_oival v).

Fixpoint env_to_oitenv (c:env) : oitenv :=
  match c with
    | Env_empty => OITEnv_empty
    | Env_cons x v c' => OITEnv_cons x (val_to_oitval v) (env_to_oitenv c')
  end.

(*----- OVER-INSTRUMENTED TO SIMPLE -----*)

Fixpoint oival_to_val (u:oival) :=
  match u with
    | OIV_ d v => oival0_to_val v
  end

with oival0_to_val (v:oival0) :=
  match v with
    | OIV_Num n => V_Num n
    | OIV_Bool b => V_Bool b
    | OIV_Constr0 n => V_Constr0 n
    | OIV_Constr1 n u => V_Constr1 n (oival_to_val u)
    | OIV_Closure x e c => V_Closure x e (oienv_to_env c)
    | OIV_Couple u1 u2 => V_Couple (oival_to_val u1) (oival_to_val u2)
    | OIV_Rec_Closure f x e c => V_Rec_Closure f x e (oienv_to_env c)
  end

with oienv_to_env (c:oienv) :=
  match c with
    | OIEnv_empty => Env_empty
    | OIEnv_cons x u c' => Env_cons x (oival_to_val u) (oienv_to_env c')
  end.

Definition oitval_to_val (uu:oitval) :=
  match uu with
    | OIV td u => oival_to_val u
  end.

Fixpoint oitenv_to_env (c:oitenv) :=
  match c with
    | OITEnv_empty => Env_empty
    | OITEnv_cons x uu c' => Env_cons x (oitval_to_val uu) (oitenv_to_env c')
  end.

(*----- BETWEEN OVER-INSTRUMENTED WITH AND WITHOUT TERMINATION -----*)

Definition oival_to_oitval (u:oival) := OIV nil u.

Fixpoint oienv_to_oitenv (c:oienv) :=
  match c with
    | OIEnv_empty => OITEnv_empty
    | OIEnv_cons x u c' => OITEnv_cons x (oival_to_oitval u) (oienv_to_oitenv c')
  end.

Definition oitval_to_oival (uu:oitval) :=
  match uu with
    | OIV td u => u
  end.

Fixpoint oitenv_to_oienv (c:oitenv) :=
  match c with
    | OITEnv_empty => OIEnv_empty
    | OITEnv_cons x uu c' => OIEnv_cons x (oitval_to_oival uu) (oitenv_to_oienv c')
  end.


Generalizable All Variables.
Set Implicit Arguments.

Require Import Coq.Lists.List
        Coq.Strings.String
        Coq.Arith.Arith
        Fiat.Common.ilist
        Fiat.Common.ilist3.

Section i3list.

  (* Lists of elements whose types depend on an indexing set (CPDT's hlists).
     These lists are a convenient way to implement finite maps
     whose elements depend on their keys. The data structures used
     by our ADT notations uses these to implement notation-friendly
     method lookups.  *)

  Import Vectors.VectorDef.VectorNotations.

  Context {A : Type}. (* The indexing type. *)
  Context {B : A -> Type}. (* The type of indexed elements. *)
  Variable C : forall a, B a ->  Type. (* The type of doubly-indexed elements. *)

  Fixpoint i3list {n}
           {l : Vector.t A n}
    : ilist3 (B := B) l -> Type :=
    match l return ilist3 (B := B) l -> Type with
    | [] => fun _ => unit
    | a :: l' => fun il => @prim_prod (C (ilist3_hd il))
                                      (i3list (ilist3_tl il))
    end.

  Definition i3cons
             {a : A}
             {n}
             {l : Vector.t A n}
             {b : B a}
             {il : ilist3 l}
             (c : C b)
             (il3 : i3list il)
  : i3list (icons3 b il)
    := {| prim_fst := c; prim_snd := il3 |}.

  Definition i3nil : i3list inil3 := tt.

  (* Get the car of an i3list. *)
  Definition i3list_hd {n}
             (As : Vector.t A n)
             (Bs : ilist3 As)
             (i3l : i3list Bs) :
    match As return forall Bs : ilist3 As, i3list Bs -> Type with
    | a :: As' => fun Bs i3l => C (ilist3_hd Bs)
      | [] => fun _ _ => unit
    end Bs i3l :=
    match As as As' return
          forall Bs i3l,
          match As' return forall Bs : ilist3 As', i3list Bs -> Type with
          | a :: As' => fun Bs i3l => C (ilist3_hd Bs)
          | [] => fun _ _ => unit
          end Bs i3l with
    | [] => fun _ _ => tt
    | a :: As' => fun Bs il => prim_fst il
    end Bs i3l.

  (* Get the cdr of an i3list. *)
  Definition i3list_tl {n}
             (As : Vector.t A n)
             (Bs : ilist3 As)
             (i3l : i3list Bs) :
    match As return forall Bs : ilist3 As, i3list Bs -> Type with
    | a :: As' => fun Bs i3l => i3list (ilist3_tl Bs)
    | [] => fun _ _ => unit
    end Bs i3l :=
    match As as As' return
          forall Bs i3l,
          match As' return forall Bs : ilist3 As', i3list Bs -> Type with
          | a :: As' => fun Bs i3l => i3list (ilist3_tl Bs)
          | [] => fun _ _ => unit
          end Bs i3l with
    | [] => fun _ _ => tt
    | a :: As' => fun Bs il => prim_snd il
    end Bs i3l.

  Fixpoint i3th
           {m : nat}
           {As : Vector.t A m}
           {Bs : ilist3 As}
           (i3l : i3list Bs)
           (n : Fin.t m)
           {struct n}
    : C (ith3 Bs n) :=
    match n in Fin.t m return
          forall (As : Vector.t A m)
                 (Bs : ilist3 As),
            i3list Bs
            -> C (ith3 Bs n) with
    | Fin.F1 k =>
      fun As Bs i3l =>
        Vector.caseS (fun n As =>
                        forall (Bs : ilist3 As), i3list Bs
                                   -> C (ith3 Bs (@Fin.F1 n)))
                     (fun a' n' As' (Bs' : ilist3 (a' :: As')) i3l' => prim_fst i3l' ) As Bs i3l
    | Fin.FS k n'' =>
      fun As Bs i3l =>
        Vector_caseS' Fin.t
                      (fun n' As i =>
                        forall (Bs'' : ilist3 As),
                          i3list Bs''
                          -> C (ith3 Bs'' (@Fin.FS n' i)))
                     (fun a' n' As' n'' (Bs' : ilist3 (a' :: As')) i3l' => i3th (prim_snd i3l') n'')
                     As n'' Bs i3l
    end As Bs i3l.

End i3list.

Arguments i3cons [_ _ _ _ _ _ _ _] _ _.
Arguments i3nil [_ _ _].
Arguments i3th [_ _ _ _ _ _] _ _.

Section i3list_replace.

  (* Replacing an element of an indexed list. *)
  Variable A : Type. (* The indexing type. *)
  Variable B : A -> Type. (* The two types of indexed elements. *)
  Variable C : forall a, B a -> Type. (* The type of doubly-indexed elements. *)

  Import Vectors.VectorDef.VectorNotations.

  Fixpoint replace3_Index3
          {m : nat}
          {As : Vector.t A m}
          {Bs : ilist3 As}
          (i3l : i3list C Bs)
          (n : Fin.t m)
          (new_c : C (ith3 Bs n))
    : i3list C Bs :=
        match n in Fin.t m return
          forall (As : Vector.t A m)
                 (Bs : ilist3 As),
            i3list C Bs
            -> C (ith3 Bs n)
            -> i3list C Bs with
        | Fin.F1 k =>
          fun As Bs i3l new_c =>
            Vector.caseS (fun n As =>
                            forall (Bs : ilist3 As), i3list C Bs
                                                     -> C (ith3 Bs (@Fin.F1 n))
                                                     -> i3list C Bs)
                         (fun a' n' As' (Bs' : ilist3 (a' :: As')) i3l' new_c => i3cons new_c (prim_snd i3l') ) As Bs i3l new_c
    | Fin.FS k n'' =>
      fun As Bs i3l new_c =>
        Vector.caseS (fun n' As =>
                        forall (i : Fin.t n') (Bs'' : ilist3 As),
                          i3list C Bs''
                          -> C (ith3 Bs'' (@Fin.FS n' i))
                          -> i3list C Bs'')
                     (fun a' n' As' n'' (Bs' : ilist3 (a' :: As')) i3l' new_c => i3cons (prim_fst i3l') (replace3_Index3 (prim_snd i3l') n'' new_c))
                     As n'' Bs i3l new_c
        end As Bs i3l new_c.

  Lemma i3th_replace_Index_neq
    : forall {m : nat}
             {As : Vector.t A m}
             {Bs : ilist3 As}
             (i3l : i3list C Bs)
             (n n' : Fin.t m)
             (new_c : C (ith3 Bs n)),
      n <> n'
      -> i3th (replace3_Index3 i3l n new_c) n' =
         i3th i3l n'.
  Proof.
    induction As.
    - intros; inversion n.
    - intros; revert n' As Bs i3l new_c H IHAs; pattern n, n0.
      match goal with
        |- ?P n n0 => simpl; apply (@Fin.caseS P); clear n n0; simpl in *
      end.
      + intros n n'; pattern n, n';
        match goal with
          |- ?P n n' => simpl; apply (@Fin.caseS P); clear n n'; intros; simpl in *;
                        eauto; congruence
        end.
      + intros n p n'; revert p; pattern n, n';
        match goal with
          |- ?P n n' => simpl; apply (@Fin.caseS P); clear n n'; intros; simpl in *;
                        eauto
        end.
        eapply IHAs; congruence.
  Qed.

  Lemma i3th_replace_Index_eq
    : forall {m : nat}
             {As : Vector.t A m}
             {Bs : ilist3 As}
             (i3l : i3list C Bs)
             (n : Fin.t m)
             (new_c : C (ith3 Bs n)),
      i3th (replace3_Index3 i3l n new_c) n = new_c.
  Proof.
    induction As.
    - intros; inversion n.
    - intros; revert As Bs i3l new_c IHAs; pattern n, n0.
      match goal with
        |- ?P n n0 => simpl; apply (@Fin.caseS P); clear n n0; simpl in *; eauto
      end.
  Qed.

  (*Program Fixpoint replace_Index3'
           (n : nat)
           (As : list A)
           (Bs : ilist B As)
           (Cs : i3list C Bs)
           (new_c : Dep_Option_elim_P C (ith_error Bs n))
           {struct Cs} : i3list C Bs :=
    match n return
          Dep_Option_elim_P C (ith_error Bs n)
            -> i3list C Bs with
      | 0 => match Cs in i3list _ Bs return
                   Dep_Option_elim_P C (ith_error Bs 0)
                   -> i3list C Bs with
                 | i3nil Bs =>
                   fun _ => i3nil _ Bs
                 | i3cons a As' Bs' c i3l' =>
                   fun new_c =>
                     i3cons Bs' new_c i3l'
               end
      | S n => match Cs in i3list _ Bs return
                     Dep_Option_elim_P C (ith_error Bs (S n))
                     -> i3list C Bs with
                 | i3nil Bs => fun _ => i3nil _ Bs
                 | i3cons a As' Bs' c i3l' =>
                   fun new_c =>
                     i3cons Bs' c (@replace_Index3' n As' (ilist_tl Bs') i3l' new_c)
               end
    end new_c.

  Lemma i3th_replace_Index'_neq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i3list C Bs)
      (n' : nat)
      (new_c : Dep_Option_elim_P C (ith_error Bs n')),
      n <> n'
      -> i3th_error' (replace_Index3' n' Cs new_c) n =
         i3th_error' Cs n.
  Proof.
    induction n; simpl; destruct Cs; intros; icons_invert;
    simpl in *; auto;
    destruct n'; simpl; try congruence.
    unfold replace_Index3.
    eapply IHn; congruence.
  Qed.

  Lemma i3th_replace_Index'_eq
  : forall
      (n : nat)
      (As : list A)
      (Bs : ilist _ As)
      (Cs : i3list C Bs)
      (new_c : Dep_Option_elim_P C (ith_error Bs n)),
      i3th_error' (replace_Index3' n Cs new_c) n = new_c.
  Proof.
    induction n; destruct Cs; simpl; auto; intros;
    destruct new_c; eauto.
  Qed. *)

End i3list_replace.

  Lemma replace3_Index3_eq:
    forall (A : Type) (B : A -> Type) (C : forall a : A, B a -> Type)
           (m : nat) (As : Vector.t A m) (Bs : ilist3 As)
           (i3l : i3list C Bs) (n : Fin.t m),
      replace3_Index3 B C i3l n (i3th i3l n) = i3l.
  Proof.
    induction As.
    - intros; inversion n.
    - intros; revert As Bs i3l IHAs; pattern n, n0.
      match goal with
        |- ?P n n0 => simpl; apply (@Fin.caseS P); clear n n0; simpl in *; eauto
      end.
      + destruct i3l; simpl; reflexivity.
      + destruct i3l; simpl; intros.
        unfold i3cons; f_equal.
        eapply IHAs; eauto.
  Qed.

Lemma ilist3_eq_ith3
  : forall (A : Type) (B : A -> Type) C (m : nat) (As : Vector.t A m)
           (Bs : ilist3 As)
           (il il' : i3list (B := B) C Bs),
    (forall idx : Fin.t m, i3th il idx = i3th il' idx)
    -> il = il'.
Proof.
  induction As.
  - unfold ilist3; intros.
    destruct il; destruct il'; reflexivity.
  - intros.
    destruct il; destruct il'.
    f_equal; eauto.
    + apply (H (Fin.F1)).
    + eapply IHAs; intros.
      eapply (H (Fin.FS idx)).
Qed.


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 Functor.Functor.
From Categories Require Import Coq_Cats.Type_Cat.Type_Cat.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat.

(** The hom-functor is a functor that maps a pair of objects (a, b)
    (an object of the product category Cᵒᵖ×C) to the type of arrows
    from a to b. *)
Program Definition Hom_Func (C : Category) : ((C^op × C) --> Type_Cat)%functor :=
{|
  FO := fun x => Hom C (fst x) (snd x);
  FA := fun x y f => fun g => compose C (fst f) ((@compose (C^op) _ _ _) (snd f) g)
|}.