From Coq Require Import ssreflect ssrfun ssrbool.

From Coq Require Import Btauto.

From stdpp Require Import countable infinite.
From stdpp Require Import pmap gmap mapset fin_sets propset.
Require Import stdpp_ext.

Require Import extralibrary.

From MatchingLogic Require Export
    Signature.

(* TODO have different type for element variable and for set variable index *)
Definition db_index := nat.

(* begin snippet Pattern *)
Inductive Pattern {Σ : Signature} : Set :=
| patt_free_evar (x : evar)
| patt_free_svar (x : svar)
| patt_bound_evar (n : db_index)
| patt_bound_svar (n : db_index)
| patt_sym (sigma : symbols) :  Pattern
| patt_app (phi1 phi2 : Pattern)
| patt_bott
| patt_imp (phi1 phi2 : Pattern)
| patt_exists (phi : Pattern)
| patt_mu (phi : Pattern)
.
(* end snippet Pattern *)

Global
Instance Pattern_eqdec {Σ : Signature} : EqDecision Pattern.
Proof. solve_decision. Defined.

Global Instance Pattern_countable {Σ : Signature} (sc : Countable symbols) : Countable Pattern.
Proof.
  set (enc :=
         fix go p : gen_tree (unit
                              + ((@symbols (@ml_symbols Σ))
                                 + (((@evar variables) + db_index)
                                    + ((@svar variables) + db_index))))%type :=
           match p with
           | patt_bott => GenLeaf (inl ())
           | patt_sym s => GenLeaf (inr (inl s))
           | patt_free_evar x => GenLeaf (inr (inr (inl (inl x))))
           | patt_free_svar X => GenLeaf (inr (inr (inr (inl X))))
           | patt_bound_evar n => GenLeaf (inr (inr (inl (inr n))))
           | patt_bound_svar n => GenLeaf (inr (inr (inr (inr n))))
           | patt_app p1 p2 => GenNode 0 [go p1; go p2]
           | patt_imp p1 p2 => GenNode 1 [go p1; go p2]
           | patt_exists p' => GenNode 2 [go p']
           | patt_mu p' => GenNode 3 [go p']
           end
      ).

  set (dec :=
         fix go (p : gen_tree (unit
                              + ((@symbols (@ml_symbols Σ))
                                 + (((@evar variables) + db_index)
                                    + ((@svar variables) + db_index))))%type) : Pattern :=
           match p with
           | GenLeaf (inl ()) => patt_bott
           | GenLeaf (inr (inl s)) => patt_sym s
           | GenLeaf (inr (inr (inl (inl x)))) => patt_free_evar x
           | GenLeaf (inr (inr (inr (inl X)))) => patt_free_svar X
           | GenLeaf (inr (inr (inl (inr n)))) => patt_bound_evar n
           | GenLeaf (inr (inr (inr (inr n)))) => patt_bound_svar n
           | GenNode 0 [p1; p2] => patt_app (go p1) (go p2)
           | GenNode 1 [p1; p2] => patt_imp (go p1) (go p2)
           | GenNode 2 [p'] => patt_exists (go p')
           | GenNode 3 [p'] => patt_mu (go p')
           | _ => patt_bott (* dummy *)
           end
      ).

  refine (inj_countable' enc dec _).
  intros x.
  induction x; simpl; congruence.
Defined.

Definition Theory {Σ : Signature} := propset Pattern.

Section syntax.
    Context {Σ : Signature}.

Fixpoint size (p : Pattern) : nat :=
    match p with
    | patt_app ls rs => 1 + (size ls) + (size rs)
    | patt_imp ls rs => 1 + (size ls) + (size rs)
    | patt_exists p' => 1 + size p'
    | patt_mu p' => 1 + size p'
    | _ => 0
    end.

Fixpoint size' (p : Pattern) : nat :=
    match p with
    | patt_app ls rs => 1 + (size' ls) + (size' rs)
    | patt_imp ls rs => 1 + (size' ls) + (size' rs)
    | patt_exists p' => 1 + size' p'
    | patt_mu p' => 1 + size' p'
    | _ => 1
    end.

  (** The free names of a type are defined as follow.  Notice the
  [exists] and [mu] cases: they do not bind any name. *)

  Definition EVarSet := gset evar.
  Definition SVarSet := gset svar.

  Fixpoint free_evars (phi : Pattern)
    : EVarSet :=
    match phi with
    | patt_free_evar x => singleton x
    | patt_free_svar X => empty
    | patt_bound_evar x => empty
    | patt_bound_svar X => empty
    | patt_sym sigma => empty
    | patt_app phi1 phi2 => union (free_evars phi1) (free_evars phi2)
    | patt_bott => empty
    | patt_imp phi1 phi2 => union (free_evars phi1) (free_evars phi2)
    | patt_exists phi => free_evars phi
    | patt_mu phi => free_evars phi
    end.

  Fixpoint free_svars (phi : Pattern)
    : SVarSet :=
    match phi with
    | patt_free_evar x => empty
    | patt_free_svar X => singleton X
    | patt_bound_evar x => empty
    | patt_bound_svar X => empty
    | patt_sym sigma => empty
    | patt_app phi1 phi2 => union (free_svars phi1) (free_svars phi2)
    | patt_bott => empty
    | patt_imp phi1 phi2 => union (free_svars phi1) (free_svars phi2)
    | patt_exists phi => free_svars phi
    | patt_mu phi => free_svars phi
    end.

  Definition free_evars_of_list l : EVarSet :=
    union_list (map free_evars l).

  Lemma free_evars_of_list_foldr :
    forall l g,
      free_evars (foldr patt_imp g l) =
      free_evars g ∪ free_evars_of_list l.
  Proof.
    induction l; intro g; set_solver.
  Qed.

  (* for bound set variables *)
  Fixpoint no_negative_occurrence_db_b (dbi : db_index) (ϕ : Pattern) : bool :=
    match ϕ with
    | patt_free_evar _ | patt_free_svar _ | patt_bound_evar _ | patt_sym _ | patt_bott => true
    | patt_bound_svar n => true
    | patt_app ϕ₁ ϕ₂ => no_negative_occurrence_db_b dbi ϕ₁ && no_negative_occurrence_db_b dbi ϕ₂
    | patt_imp ϕ₁ ϕ₂ => no_positive_occurrence_db_b dbi ϕ₁ && no_negative_occurrence_db_b dbi ϕ₂
    | patt_exists ϕ' => no_negative_occurrence_db_b dbi ϕ'
    | patt_mu ϕ' => no_negative_occurrence_db_b (S dbi) ϕ'
    end
  with
  no_positive_occurrence_db_b (dbi : db_index) (ϕ : Pattern) : bool :=
    match ϕ with
    | patt_free_evar _ | patt_free_svar _ | patt_bound_evar _ | patt_sym _ | patt_bott => true
    | patt_bound_svar n => if decide (n = dbi) is left _ then false else true
    | patt_app ϕ₁ ϕ₂ => no_positive_occurrence_db_b dbi ϕ₁ && no_positive_occurrence_db_b dbi ϕ₂
    | patt_imp ϕ₁ ϕ₂ => no_negative_occurrence_db_b dbi ϕ₁ && no_positive_occurrence_db_b dbi ϕ₂
    | patt_exists ϕ' => no_positive_occurrence_db_b dbi ϕ'
    | patt_mu ϕ' => no_positive_occurrence_db_b (S dbi) ϕ'
    end.

  (* for free element variables *)
  Fixpoint evar_has_positive_occurrence (x : evar) (ϕ : Pattern) : bool :=
    match ϕ with
    | patt_free_evar x' => if decide (x = x') is left _ then true else false
    | patt_free_svar _ | patt_bound_evar _ | patt_bound_svar _ | patt_sym _ | patt_bott => false
    | patt_app ϕ₁ ϕ₂ => evar_has_positive_occurrence x ϕ₁ || evar_has_positive_occurrence x ϕ₂
    | patt_imp ϕ₁ ϕ₂ => evar_has_negative_occurrence x ϕ₁ || evar_has_positive_occurrence x ϕ₂
    | patt_exists ϕ' => evar_has_positive_occurrence x ϕ'
    | patt_mu ϕ' => evar_has_positive_occurrence x ϕ'
    end
  with
  evar_has_negative_occurrence (x : evar) (ϕ : Pattern) : bool :=
    match ϕ with
    | patt_free_evar _ | patt_free_svar _ | patt_bound_evar _ | patt_bound_svar _ | patt_sym _ | patt_bott => false
    | patt_app ϕ₁ ϕ₂ => evar_has_negative_occurrence x ϕ₁ || evar_has_negative_occurrence x ϕ₂
    | patt_imp ϕ₁ ϕ₂ => evar_has_positive_occurrence x ϕ₁ || evar_has_negative_occurrence x ϕ₂
    | patt_exists ϕ' => evar_has_negative_occurrence x ϕ'
    | patt_mu ϕ' => evar_has_negative_occurrence x ϕ'
    end.

  (* for free set variables *)
  Fixpoint svar_has_positive_occurrence (X : svar) (ϕ : Pattern) : bool :=
    match ϕ with
    | patt_free_svar X' => if decide (X = X') is left _ then true else false
    | patt_free_evar _ | patt_bound_evar _ | patt_bound_svar _ | patt_sym _ | patt_bott => false
    | patt_app ϕ₁ ϕ₂ => svar_has_positive_occurrence X ϕ₁ || svar_has_positive_occurrence X ϕ₂
    | patt_imp ϕ₁ ϕ₂ => svar_has_negative_occurrence X ϕ₁ || svar_has_positive_occurrence X ϕ₂
    | patt_exists ϕ' => svar_has_positive_occurrence X ϕ'
    | patt_mu ϕ' => svar_has_positive_occurrence X ϕ'
    end
  with
  svar_has_negative_occurrence (X : svar) (ϕ : Pattern) : bool :=
    match ϕ with
    | patt_free_evar _ | patt_free_svar _ | patt_bound_evar _ | patt_bound_svar _ | patt_sym _ | patt_bott => false
    | patt_app ϕ₁ ϕ₂ => svar_has_negative_occurrence X ϕ₁ || svar_has_negative_occurrence X ϕ₂
    | patt_imp ϕ₁ ϕ₂ => svar_has_positive_occurrence X ϕ₁ || svar_has_negative_occurrence X ϕ₂
    | patt_exists ϕ' => svar_has_negative_occurrence X ϕ'
    | patt_mu ϕ' => svar_has_negative_occurrence X ϕ'
    end.

  Fixpoint well_formed_positive (phi : Pattern) : bool :=
    match phi with
    | patt_free_evar _ => true
    | patt_free_svar _ => true
    | patt_bound_evar _ => true
    | patt_bound_svar _ => true
    | patt_sym _ => true
    | patt_app psi1 psi2 => well_formed_positive psi1 && well_formed_positive psi2
    | patt_bott => true
    | patt_imp psi1 psi2 => well_formed_positive psi1 && well_formed_positive psi2
    | patt_exists psi => well_formed_positive psi
    | patt_mu psi => no_negative_occurrence_db_b 0 psi && well_formed_positive psi
    end.

  Fixpoint well_formed_closed_mu_aux (phi : Pattern) (max_ind_svar : db_index) : bool :=
    match phi with
    | patt_free_evar _ => true
    | patt_free_svar _ => true
    | patt_bound_evar n => true
    | patt_bound_svar n => if decide (n < max_ind_svar) is left _ then true else false
    | patt_sym _ => true
    | patt_app psi1 psi2 => well_formed_closed_mu_aux psi1 max_ind_svar &&
                            well_formed_closed_mu_aux psi2 max_ind_svar
    | patt_bott => true
    | patt_imp psi1 psi2 => well_formed_closed_mu_aux psi1 max_ind_svar &&
                            well_formed_closed_mu_aux psi2 max_ind_svar
    | patt_exists psi => well_formed_closed_mu_aux psi max_ind_svar
    | patt_mu psi => well_formed_closed_mu_aux psi (S max_ind_svar)
    end.

  Fixpoint well_formed_closed_ex_aux (phi : Pattern) (max_ind_evar : db_index) : bool :=
    match phi with
    | patt_free_evar _ => true
    | patt_free_svar _ => true
    | patt_bound_evar n => if decide (n < max_ind_evar) is left _ then true else false
    | patt_bound_svar n => true
    | patt_sym _ => true
    | patt_app psi1 psi2 => well_formed_closed_ex_aux psi1 max_ind_evar &&
                            well_formed_closed_ex_aux psi2 max_ind_evar
    | patt_bott => true
    | patt_imp psi1 psi2 => well_formed_closed_ex_aux psi1 max_ind_evar &&
                            well_formed_closed_ex_aux psi2 max_ind_evar
    | patt_exists psi => well_formed_closed_ex_aux psi (S max_ind_evar)
    | patt_mu psi => well_formed_closed_ex_aux psi max_ind_evar
    end.

  Definition well_formed_closed (phi : Pattern) : bool
    := well_formed_closed_mu_aux phi 0 && well_formed_closed_ex_aux phi 0.

  Lemma well_formed_closed_ex_aux_ind (phi : Pattern) (ind_evar1 ind_evar2 : db_index) :
    ind_evar1 <= ind_evar2 ->
    well_formed_closed_ex_aux phi ind_evar1 = true->
    well_formed_closed_ex_aux phi ind_evar2 = true.
  Proof.
    intros H H0.
    generalize dependent ind_evar1. generalize dependent ind_evar2.
    induction phi; intros ind_evar_2 ind_evar_1 Heqevar H;
      simpl in *; repeat case_match; try (naive_bsolver lia); auto.
    eapply IHphi. 2: eassumption. lia.
  Qed.

  Lemma well_formed_closed_mu_aux_ind (phi : Pattern) (ind_svar1 ind_svar2 : db_index) :
    ind_svar1 <= ind_svar2  ->
    well_formed_closed_mu_aux phi ind_svar1 = true ->
    well_formed_closed_mu_aux phi ind_svar2 = true.
  Proof.
    intros H H1.
    generalize dependent ind_svar1. generalize dependent ind_svar2.
    induction phi; intros ind_svar_2 ind_svar_1 Hleqsvar;
      simpl in *; repeat case_match; try (naive_bsolver lia); auto.
    eapply IHphi. lia.
  Qed.

  Definition well_formed (phi : Pattern) := well_formed_positive phi && well_formed_closed phi.

  Lemma well_formed_bott:
    well_formed patt_bott.
  Proof. reflexivity. Qed.

  Lemma well_formed_sym s:
    well_formed (patt_sym s).
  Proof. reflexivity. Qed.

Lemma well_formed_imp ϕ₁ ϕ₂:
  well_formed ϕ₁ = true ->
  well_formed ϕ₂ = true ->
  well_formed (patt_imp ϕ₁ ϕ₂) = true.
Proof.
  unfold well_formed. unfold well_formed_closed. simpl.
  intros H1 H2.
  destruct_and!.
  split_and!; auto.
Qed.

Lemma well_formed_app ϕ₁ ϕ₂:
  well_formed ϕ₁ = true ->
  well_formed ϕ₂ = true ->
  well_formed (patt_app ϕ₁ ϕ₂) = true.
Proof.
  unfold well_formed,well_formed_closed.
  naive_bsolver.
Qed.

Lemma well_formed_ex_app ϕ₁ ϕ₂:
  well_formed (patt_exists ϕ₁) = true ->
  well_formed (patt_exists ϕ₂) = true ->
  well_formed (patt_exists (patt_app ϕ₁ ϕ₂)) = true.
Proof.
  unfold well_formed,well_formed_closed.
  naive_bsolver.
Qed.

Lemma well_formed_impl_well_formed_ex ϕ:
  well_formed ϕ = true ->
  well_formed (patt_exists ϕ) = true.
Proof.
  unfold well_formed,well_formed_closed.
  intros. destruct_and!. split_and!; auto.
  eapply well_formed_closed_ex_aux_ind in H2. simpl. eassumption. lia.
Qed.

  (* TODO: why is this Private? It can be useful for not only 0 dbi *)
  Lemma Private_wfc_impl_no_neg_pos_occ psi maxsvar dbi:
    well_formed_closed_mu_aux psi maxsvar = true ->
    maxsvar <= dbi ->
    no_negative_occurrence_db_b dbi psi = true
    /\ no_positive_occurrence_db_b dbi psi = true.
  Proof.
    move: dbi maxsvar.
    induction psi; intros dbi maxsvar Hwfc Hleq; simpl; auto; cbn.
    - split.
      { auto. }
      simpl in Hwfc.
      unfold no_positive_occurrence_db_b.
      repeat case_match; auto.
      subst. lia.
    - split.
      + simpl in Hwfc.
        destruct_and!.
        unfold no_negative_occurrence_db_b.
        split_and!; naive_bsolver auto.
      + simpl in Hwfc.
        destruct_and!.
        unfold no_positive_occurrence_db_b.
        split_and!; naive_bsolver auto.
    - split.
      + simpl in Hwfc.
        destruct_and!. split_and!; naive_bsolver auto.
      + simpl in Hwfc.
        destruct_and!. split_and!; naive_bsolver auto.
    - simpl in Hwfc.
      split_and!; naive_bsolver auto.
    - simpl in Hwfc.
      split_and!; eapply IHpsi.
      1,3: eassumption. all: lia.
  Qed.

  Corollary wfc_impl_no_neg_occ psi dbi:
    well_formed_closed_mu_aux psi 0 = true ->
    no_negative_occurrence_db_b dbi psi = true.
  Proof.
    intros H.
    unfold well_formed_closed in H.
    pose proof (HX := Private_wfc_impl_no_neg_pos_occ).
    specialize (HX psi 0 dbi H).
    simpl in HX.
    specialize (HX ltac:(lia)).
    destruct HX as [HX1 HX2].
    apply HX1.
  Qed.

  Corollary wfc_impl_no_pos_occ psi dbi:
    well_formed_closed_mu_aux psi 0 = true ->
    no_positive_occurrence_db_b dbi psi = true.
  Proof.
    intros H.
    unfold well_formed_closed in H.
    pose proof (HX := Private_wfc_impl_no_neg_pos_occ).
    specialize (HX psi 0 dbi H).
    simpl in HX.
    specialize (HX ltac:(lia)).
    destruct HX as [HX1 HX2].
    apply HX2.
  Qed.

  Lemma well_formed_app_1 : forall (phi1 phi2 : Pattern),
      well_formed (patt_app phi1 phi2) -> well_formed phi1.
  Proof.
    unfold well_formed. simpl. intros phi1 phi2 H.
    apply andb_true_iff in H as [Hpos Hclos].
    apply andb_true_iff in Hclos as [Hcl1 Hcl2]. simpl in Hcl1, Hcl2.
    apply andb_true_iff in Hpos as [Hpos1 Hpos2].
    apply andb_true_iff in Hcl1 as [Hcl11 Hcl12].
    apply andb_true_iff in Hcl2 as [Hcl21 Hcl22].
    rewrite -> Hpos1. unfold well_formed_closed. simpl.
    now rewrite -> Hcl11, -> Hcl21.
  Qed.

  Lemma well_formed_app_2 : forall (phi1 phi2 : Pattern),
      well_formed (patt_app phi1 phi2) -> well_formed phi2.
  Proof.
    unfold well_formed. simpl. intros phi1 phi2 H.
    apply andb_true_iff in H as [Hpos Hclos].
    apply andb_true_iff in Hclos as [Hcl1 Hcl2]. simpl in Hcl1, Hcl2.
    apply andb_true_iff in Hpos as [Hpos1 Hpos2].
    apply andb_true_iff in Hcl1 as [Hcl11 Hcl12].
    apply andb_true_iff in Hcl2 as [Hcl21 Hcl22].
    rewrite -> Hpos2. unfold well_formed_closed. simpl.
    now rewrite -> Hcl12, -> Hcl22.
  Qed.

  Lemma free_svars_exists : forall (ϕ : Pattern),
    free_svars (patt_exists ϕ) = free_svars ϕ.
  Proof. done. Qed.

  Lemma wfc_impl_no_neg_pos_occ p m:
    well_formed_closed_mu_aux p m ->
    (no_negative_occurrence_db_b m p && no_positive_occurrence_db_b m p) = true.
  Proof.
    intros H.
    move: m H.
    induction p; intros m H; simpl; simpl in H; cbn; auto.
    - repeat case_match; try reflexivity; try lia. congruence.
    - apply andb_prop in H. destruct H as [H1 H2].
      specialize (IHp1 m H1). specialize (IHp2 m H2).
      destruct_and!. split_and!; assumption.
    - apply andb_prop in H. destruct H as [H1 H2].
      specialize (IHp1 m H1). specialize (IHp2 m H2).
      destruct_and!. split_and!; assumption.
  Qed.

  Fixpoint mu_free (p : Pattern) : bool :=
  match p with
   | patt_free_evar x => true
   | patt_free_svar x => true
   | patt_bound_evar n => true
   | patt_bound_svar n => true
   | patt_sym sigma => true
   | patt_app phi1 phi2 => mu_free phi1 && mu_free phi2
   | patt_bott => true
   | patt_imp phi1 phi2 => mu_free phi1 && mu_free phi2
   | patt_exists phi => mu_free phi
   | patt_mu phi => false
  end.

  (* Fragment of matching logic without set variables and mu *)
  Fixpoint set_free (p : Pattern) : bool :=
  match p with
   | patt_free_evar x => true
   | patt_free_svar x => false
   | patt_bound_evar n => true
   | patt_bound_svar n => false
   | patt_sym sigma => true
   | patt_app phi1 phi2 => set_free phi1 && set_free phi2
   | patt_bott => true
   | patt_imp phi1 phi2 => set_free phi1 && set_free phi2
   | patt_exists phi => set_free phi
   | patt_mu phi => false
  end.

  Lemma set_free_implies_mu_free p:
    set_free p = true -> mu_free p = true.
  Proof.
    intros H.
    induction p; simpl in *; destruct_and?; split_and?; auto.
  Qed.

  Theorem mu_free_wfp φ :
    mu_free φ -> well_formed_positive φ.
  Proof.
    induction φ; intros Hmf; simpl; auto.
    all: simpl in Hmf; destruct_and!; rewrite -> IHφ1, -> IHφ2; auto.
  Qed.

  Lemma wf_imp_wfc ϕ:
    well_formed ϕ -> well_formed_closed ϕ.
  Proof.
    intros H. apply andb_prop in H. tauto.
  Qed.

  Definition evar_is_fresh_in x ϕ := x ∉ free_evars ϕ.
  Definition svar_is_fresh_in x ϕ := x ∉ free_svars ϕ.

  (** This function is used for linear contexts *)
  Fixpoint count_evar_occurrences (x : evar) (p : Pattern) :=
    match p with
    | patt_free_evar x' => if decide (x' = x) is left _ then 1 else 0
    | patt_free_svar _ => 0
    | patt_bound_evar _ => 0
    | patt_bound_svar _ => 0
    | patt_sym _ => 0
    | patt_app phi1 phi2 => count_evar_occurrences x phi1 + count_evar_occurrences x phi2
    | patt_bott => 0
    | patt_imp phi1 phi2 => count_evar_occurrences x phi1 + count_evar_occurrences x phi2
    | patt_exists phi' => count_evar_occurrences x phi'
    | patt_mu phi' => count_evar_occurrences x phi'
    end.

  Lemma count_evar_occurrences_0 (x : evar) (p : Pattern) :
    x ∉ free_evars p <->
    count_evar_occurrences x p = 0.
  Proof.
    split.
    {
    intros H.
    induction p; simpl in H; simpl; auto.
    - apply not_elem_of_singleton_1 in H.
      destruct (decide (x0 = x)). subst. contradiction. reflexivity.
    - apply not_elem_of_union in H. destruct H as [H1 H2].
      rewrite IHp1; [assumption|].
      rewrite IHp2; [assumption|].
      reflexivity.
    - apply not_elem_of_union in H. destruct H as [H1 H2].
      rewrite IHp1; [assumption|].
      rewrite IHp2; [assumption|].
      reflexivity.
    }
    {
      intros H.
      induction p; simpl in H; simpl; auto.
      2-5, 7: set_solver.
      - destruct (decide (x0 = x)); set_solver.
      - apply plus_is_O in H as [H0 H1]. set_solver.
      - apply plus_is_O in H as [H0 H1]. set_solver.
    }
  Qed.

  Lemma count_evar_occurrences_not_0 (x : evar) (p : Pattern) :
    x ∈ free_evars p <->
    count_evar_occurrences x p > 0.
  Proof.
    split.
    {
    intros H.
    induction p; simpl in H; simpl; auto.
    2-5, 7: set_solver.
    - destruct decide. lia. set_solver.
    - apply elem_of_union in H as [H | H].
      + apply IHp1 in H. lia.
      + apply IHp2 in H. lia.
    - apply elem_of_union in H as [H | H].
      + apply IHp1 in H. lia.
      + apply IHp2 in H. lia.
    }
    {
      intros H.
      induction p; simpl in H; simpl; auto.
      2-5, 7: lia.
      - destruct (decide (x0 = x)). set_solver. lia.
      - assert (count_evar_occurrences x p1 > 0 ∨ count_evar_occurrences x p2 > 0) by lia.
        set_solver.
      - assert (count_evar_occurrences x p1 > 0 ∨ count_evar_occurrences x p2 > 0) by lia.
      set_solver.
    }
  Qed.

End syntax.

Lemma well_formed_app_proj1 {Σ : Signature} p q:
  well_formed (patt_app p q) ->
  well_formed p.
Proof.
  intros H.
  unfold well_formed,well_formed_closed in *. simpl in *.
  destruct_and!.
  unfold well_formed,well_formed_closed. split_and!; assumption.
Qed.

Lemma well_formed_app_proj2 {Σ : Signature} p q:
  well_formed (patt_app p q) ->
  well_formed q.
Proof.
  intros H.
  unfold well_formed,well_formed_closed in *. simpl in *.
  destruct_and!.
  unfold well_formed,well_formed_closed. split_and!; assumption.
Qed.

Lemma well_formed_imp_proj1 {Σ : Signature} p q:
  well_formed (patt_imp p q) ->
  well_formed p.
Proof.
  intros H.
  unfold well_formed,well_formed_closed in *. simpl in *.
  destruct_and!.
  unfold well_formed,well_formed_closed. split_and!; assumption.
Qed.

Lemma well_formed_imp_proj2 {Σ : Signature} p q:
  well_formed (patt_imp p q) ->
  well_formed q.
Proof.
  intros H.
  unfold well_formed,well_formed_closed in *. simpl in *.
  destruct_and!.
  unfold well_formed,well_formed_closed. split_and!; assumption.
Qed.

Definition well_formed_xy {Σ : Signature} (x y : nat) (ϕ : Pattern) : bool :=
  well_formed_positive ϕ &&
  well_formed_closed_ex_aux ϕ x &&
  well_formed_closed_mu_aux ϕ y
.

Lemma wfxy00_wf {Σ : Signature} (ϕ : Pattern) :
  well_formed_xy 0 0 ϕ = well_formed ϕ.
Proof.
  unfold well_formed,well_formed_closed,well_formed_xy.
  simpl.
  rewrite -andb_assoc.
  rewrite [well_formed_closed_mu_aux _ _ && well_formed_closed_ex_aux _ _]andb_comm.
  reflexivity.
Qed.

Lemma wf_wfxy00 {Σ : Signature} (ϕ : Pattern) :
  well_formed ϕ = well_formed_xy 0 0 ϕ
.
Proof. rewrite wfxy00_wf. reflexivity. Qed.

Lemma wf_wfxy00_compose {Σ : Signature} (ϕ : Pattern) :
  well_formed_xy 0 0 ϕ = true ->
  well_formed ϕ = true
.
Proof.
  intros H. rewrite wf_wfxy00. exact H.
Qed.

Lemma wf_wfxy00_decompose {Σ : Signature} (ϕ : Pattern) :
  well_formed ϕ = true ->
  well_formed_xy 0 0 ϕ = true
.
Proof.
  intros H. rewrite -wf_wfxy00. exact H.
Qed.

Definition lwf_xy {Σ : Signature} (x y : nat) (l : list Pattern)
  := fold_right andb true (map (well_formed_xy x y) l).

Definition lwf_positive {Σ : Signature} (l : list Pattern)
  := fold_right andb true (map well_formed_positive l).

Definition lwf_cmu {Σ : Signature} n (l : list Pattern)
  := fold_right andb true (map (fun p => well_formed_closed_mu_aux p n) l).

Definition lwf_cex {Σ : Signature} n (l : list Pattern)
  := fold_right andb true (map (fun p => well_formed_closed_ex_aux p n) l).

Definition wf {Σ : Signature} (l : list Pattern) := fold_right andb true (map well_formed l).

Lemma wf_lwf_xy {Σ : Signature} (l : list Pattern) :
  wf l = lwf_xy 0 0 l
.
Proof.
  unfold wf, lwf_xy.
  induction l; simpl.
  { reflexivity. }
  {
    rewrite IHl.
    rewrite -wfxy00_wf.
    reflexivity.
  }
Qed.

Lemma wf_lwf_xy_compose {Σ : Signature} (l : list Pattern) :
  lwf_xy 0 0 l = true ->
  wf l = true
.
Proof.
  intros H. rewrite wf_lwf_xy. exact H.
Qed.

Lemma wf_lwf_xy_decompose {Σ : Signature} (l : list Pattern) :
  wf l = true ->
  lwf_xy 0 0 l = true
.
Proof.
  intros H. rewrite -wf_lwf_xy. exact H.
Qed.

Lemma wf_corr {Σ : Signature} (l : list Pattern) :
  wf l = lwf_positive l && lwf_cmu 0 l && lwf_cex 0 l
.
Proof.
  unfold wf,lwf_positive,lwf_cmu,lwf_cex,well_formed,well_formed_closed.
  induction l; simpl.
  { reflexivity. }
  {
    rewrite IHl.
    btauto.
  }
Qed.

Lemma lwf_xy_decompose {Σ : Signature} (x y : nat) (l : list Pattern) :
  lwf_xy x y l = lwf_positive l && lwf_cmu y l && lwf_cex x l
.
Proof.
  unfold lwf_xy,lwf_positive,lwf_cmu,lwf_cex,well_formed_xy.
  induction l; simpl.
  { reflexivity. }
  {
    rewrite IHl. simpl.
    btauto.
  }
Qed.

Lemma lwf_xy_cons
  {Σ : Signature} (m n : nat) (x : Pattern) (xs : list Pattern)
  :
  lwf_xy m n (x::xs) = well_formed_xy m n x && lwf_xy m n xs
.
Proof. reflexivity. Qed.

Lemma lwf_xy_cons_compose
  {Σ : Signature} (m n : nat) (x : Pattern) (xs : list Pattern)
  :
  well_formed_xy m n x = true /\ lwf_xy m n xs = true ->
  lwf_xy m n (x::xs) = true
.
Proof.
  intros H.
  rewrite lwf_xy_cons.
  destruct H as [H1 H2].
  rewrite H1 H2.
  reflexivity.
Qed.

Lemma lwf_xy_cons_decompose
  {Σ : Signature} (m n : nat) (x : Pattern) (xs : list Pattern)
  :
  lwf_xy m n (x::xs) = true ->
  well_formed_xy m n x = true /\ lwf_xy m n xs = true
.
Proof.
  intros H.
  rewrite lwf_xy_cons in H.
  destruct_and!.
  split; assumption.
Qed.

Lemma lwf_positive_cons
  {Σ : Signature} (x : Pattern) (xs : list Pattern)
  :
  lwf_positive (x::xs) = well_formed_positive x && lwf_positive xs
.
Proof. reflexivity. Qed.

Lemma lwf_cmu_cons
  {Σ : Signature} (n : nat) (x : Pattern) (xs : list Pattern)
  :
  lwf_cmu n (x::xs) = well_formed_closed_mu_aux x n && lwf_cmu n xs
.
Proof. reflexivity. Qed.

Lemma lwf_cex_cons
  {Σ : Signature} (n : nat) (x : Pattern) (xs : list Pattern)
  :
  lwf_cex n (x::xs) = well_formed_closed_ex_aux x n && lwf_cex n xs
.
Proof. reflexivity. Qed.

Lemma lwf_xy_app
  {Σ : Signature} (m n : nat) (xs ys : list Pattern)
  :
  lwf_xy m n (xs ++ ys) = lwf_xy m n xs && lwf_xy m n ys
.
Proof.
  induction xs; simpl.
  { reflexivity. }
  { rewrite 2!lwf_xy_cons. rewrite IHxs. btauto. }
Qed.

Lemma lwf_xy_app_compose
  {Σ : Signature} (m n : nat) (xs ys : list Pattern)
  :
  lwf_xy m n xs = true /\ lwf_xy m n ys = true ->
  lwf_xy m n (xs ++ ys) = true
.
Proof.
  intros H.
  rewrite lwf_xy_app.
  destruct H as [H1 H2].
  rewrite H1 H2.
  reflexivity.
Qed.

Lemma lwf_xy_app_decompose
  {Σ : Signature} (m n : nat) (xs ys : list Pattern)
  :
  lwf_xy m n (xs ++ ys) = true ->
  lwf_xy m n xs = true /\ lwf_xy m n ys = true
.
Proof.
  intros H.
  rewrite lwf_xy_app in H.
  destruct_and!.
  split; assumption.
Qed.

Lemma lwf_positive_app
  {Σ : Signature} (xs ys : list Pattern)
  :
  lwf_positive (xs++ys) = lwf_positive xs && lwf_positive ys
.
Proof.
  induction xs; simpl.
  { reflexivity. }
  { rewrite 2!lwf_positive_cons. rewrite IHxs. btauto. }
Qed.

Lemma lwf_cmu_app
  {Σ : Signature} (n : nat) (xs ys : list Pattern)
  :
  lwf_cmu n (xs++ys) = lwf_cmu n xs && lwf_cmu n ys
.
Proof.
  induction xs; simpl.
  { reflexivity. }
  { rewrite 2!lwf_cmu_cons. rewrite IHxs. btauto. }
Qed.

Lemma lwf_cex_app
  {Σ : Signature} (n : nat) (xs ys : list Pattern)
  :
  lwf_cex n (xs++ys) = lwf_cex n xs && lwf_cex n ys
.
Proof.
  induction xs; simpl.
  { reflexivity. }
  { rewrite 2!lwf_cex_cons. rewrite IHxs. btauto. }
Qed.

(* TODO: maybe generalize to any connective? *)
Lemma well_formed_foldr {Σ : Signature} g xs :
  well_formed g = true ->
  wf xs = true ->
  well_formed (foldr patt_imp g xs) = true.
Proof.
  intros wfg wfxs.
  induction xs.
  - simpl. exact wfg.
  - simpl. unfold wf in wfxs. simpl in wfxs.
    apply andb_prop in wfxs. destruct wfxs.
    apply well_formed_imp.
    { assumption. }
    { apply IHxs. assumption. }
Qed.

Lemma wf_take {Σ : Signature} n xs :
  wf xs = true ->
  wf (take n xs) = true.
Proof.
  unfold wf. intros H.
  rewrite map_take.
  rewrite foldr_andb_true_take; auto.
Qed.

Lemma wf_drop {Σ : Signature} n xs:
  wf xs = true ->
  wf (drop n xs) = true.
Proof.
  unfold wf. intros H.
  rewrite map_drop.
  rewrite foldr_andb_true_drop; auto.
Qed.

Lemma wf_insert {Σ : Signature} n p xs:
  wf xs = true ->
  well_formed p = true ->
  wf (<[n := p]> xs) = true.
Proof.
  intros wfxs wfp.
  move: xs wfxs.
  induction n; intros xs wfxs; destruct xs; simpl; auto.
  - unfold wf in wfxs. simpl in wfxs. apply andb_prop in wfxs.
    destruct wfxs as [wfp0 wfxs].
    unfold wf. simpl. rewrite wfp. rewrite wfxs.
    reflexivity.
  - unfold wf in wfxs. simpl in wfxs. apply andb_prop in wfxs.
    destruct wfxs as [wfp0 wfxs].
    unfold wf. simpl.
    unfold wf in IHn.
    rewrite wfp0.
    rewrite IHn; auto.
Qed.

Lemma wf_tail' {Σ : Signature} p xs:
  wf (p :: xs) = true ->
  wf xs = true.
Proof.
  unfold wf. intros H. simpl in H. apply andb_prop in H. rewrite (proj2 H). reflexivity.
Qed.

Lemma wf_cons {Σ : Signature} x xs:
  well_formed x = true ->
  wf xs = true ->
  wf (x :: xs) = true.
Proof.
  intros wfx wfxs.
  unfold wf. simpl. rewrite wfx.
  unfold wf in wfxs. rewrite wfxs.
  reflexivity.
Qed.

 Lemma wf_app {Σ : Signature} xs ys:
  wf xs = true ->
  wf ys = true ->
  wf (xs ++ ys) = true.
Proof.
  intros wfxs wfys.
  unfold wf in *.
  rewrite map_app.
  rewrite foldr_app.
  rewrite wfys.
  rewrite wfxs.
  reflexivity.
Qed.

(* TODO move somewhere else *)
Lemma wfapp_proj_1 {Σ : Signature} l₁ l₂:
wf (l₁ ++ l₂) = true ->
wf l₁ = true.
Proof.
intros H.
apply (wf_take (length l₁)) in H.
rewrite take_app in H.
exact H.
Qed.

Lemma wfapp_proj_2 {Σ : Signature} l₁ l₂:
wf (l₁ ++ l₂) = true ->
wf l₂ = true.
Proof.
intros H.
apply (wf_drop (length l₁)) in H.
rewrite drop_app in H.
exact H.
Qed.

Lemma wfl₁hl₂_proj_l₁ {Σ : Signature} l₁ h l₂:
wf (l₁ ++ h :: l₂) ->
wf l₁.
Proof.
apply wfapp_proj_1.
Qed.

Lemma wfl₁hl₂_proj_h {Σ : Signature} l₁ h l₂:
wf (l₁ ++ h :: l₂) ->
well_formed h.
Proof.
intros H. apply wfapp_proj_2 in H. unfold wf in H.
simpl in H. apply andb_prop in H as [H1 H2].
exact H1.
Qed.

Lemma wfl₁hl₂_proj_l₂ {Σ : Signature} l₁ h l₂:
wf (l₁ ++ h :: l₂) ->
wf l₂.
Proof.
intros H. apply wfapp_proj_2 in H. unfold wf in H.
simpl in H. apply andb_prop in H as [H1 H2].
exact H2.
Qed.

Lemma wfl₁hl₂_proj_l₁l₂ {Σ : Signature} l₁ h l₂:
wf (l₁ ++ h :: l₂) ->
wf (l₁ ++ l₂).
Proof.
intros H.
pose proof (wfl₁hl₂_proj_l₁ _ _ _ H).
pose proof (wfl₁hl₂_proj_l₂ _ _ _ H).
apply wf_app; assumption.
Qed.

Definition wfPattern {Σ : Signature} := {p : Pattern | well_formed p = true}.

Global Instance wfPattern_eqdec {Σ : Signature} : EqDecision wfPattern.
Proof.
  solve_decision.
Defined.

Global Instance wfPattern_countable {Σ : Signature} : Countable wfPattern.
Proof.
  apply countable_sig.
  solve_decision.
Defined.

Global Instance Pattern_infinite {Σ : Signature} :
  Infinite Pattern.
Proof.
  apply inj_infinite with
    (f := patt_free_evar)
    (g := fun p => (match p with patt_free_evar x => Some x | _ => None end) ).
  intros x. reflexivity.
Defined.

Global Instance wfPattern_infinite {Σ : Signature} :
  Infinite wfPattern.
Proof.
  apply inj_infinite with
    (f := fun x => exist (fun p : Pattern => well_formed p = true) (patt_free_evar x) erefl)
    (g := fun wp => (match proj1_sig wp with patt_free_evar x => Some x | _ => None end) ).
  intros x. reflexivity.
Defined.


(* Proof of Theorem 2 from the paper *)

Require Import Graph.
Require Import Tree.
Require Import Coq.Program.Basics.

Set Implicit Arguments.

(* Definition of unravelling. *)

Definition unravelM {A C} (e : Env (Tree C) A) : GraphM C A -> Tree C :=
  ufoldM e (fun x => In x).

Definition unravel {C} : Graph C -> Tree C :=
  unravelM (Empty (zero _)).

(* Lemma detailing how unravelling affects let bindings. *)

Lemma unravelM_let {C A} {b : GraphM C A} {s e} :
  unravelM e (Let b s) = unravelM (Extend (unravelM e b) e) s.
Proof.
  reflexivity.
Qed.

(* Monadic version of Theorem 2. *)

Theorem ufoldM_fold {R C A} (alg : Alg C R) (g : GraphM C A)
(e : Env (Tree C) A) :
  ufoldM (emap (fold alg) e) alg g = fold alg (unravelM e g).
Proof.
  unfold ufoldM.
  intros. generalize dependent A. induction g using Graph_ind'; intros; simpl.
  simpl. rewrite cmap_cmap. unfold compose. simpl. f_equal.
  cmap_eq. apply H.

  apply emap_lookup.

  rewrite IHg1 by assumption. rewrite unravelM_let. simpl. rewrite <- IHg2.
  reflexivity.
Qed.

(* Theorem 2. *)

Theorem ufold_fold {R C} (alg : Alg C R) (g : Graph C):
  ufold alg  g = fold alg (unravel g).
Proof.
  unfold ufold, unravel. rewrite <- ufoldM_fold. simpl. repeat f_equal. symmetry.
  apply zero_unique.
Qed.

(* Some convenience lemmas that detail how unravelling works on [letx]
and [var]. *)

Lemma unravelM_letx {C A} {b : GraphM C A} {s e} :
  unravelM e (letx b s) = unravelM (Extend (unravelM e b) e) (s _ tt).
Proof.
  reflexivity.
Qed.

Lemma unravelM_var {C A e v} (x : unit) :
  unravelM (Extend v e) (var (C := C) (A := A :> unit) x) = v.
Proof.
  unfold var. unfold compose. simpl. unfold unravelM. unfold ufoldM. simpl. destruct x. reflexivity.
Qed.


(*|
############################################################################
Why Coq doesn't allow inversion, destruct, etc. when the goal is a ``Type``?
############################################################################

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

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

When ``refine``\ ing a program, I tried to end proof by ``inversion``
on a ``False`` hypothesis when **the goal was a** ``Type``. Here is a
reduced version of the proof I tried to do.
|*)

Lemma strange1 : forall T : Type, 0 > 0 -> T.
  intros T H.
  Fail inversion H. (* .fails *) (* Coq refuses inversion on 'H : 0 > 0' *)

(*| Coq complained |*)

  Fail inversion H. (* .unfold .messages *)
Abort. (* .none *)

(*|
However, since I do nothing with ``T``, it shouldn't matter, ... or?

I got rid of the ``T`` like this, and the proof went through:
|*)

Lemma ex_falso : forall T : Type, False -> T.
  inversion 1.
Qed.

Lemma strange2 : forall T : Type, 0 > 0 -> T.
  intros T H.
  apply ex_falso. (* this changes the goal to 'False' *)
  inversion H.
Qed.

(*|
What is the reason Coq complained? Is it just a deficiency in
``inversion``, ``destruct``, etc.?

----

**A:** An enlightening discussion at the coq-club mailing list:
https://sympa.inria.fr/sympa/arc/coq-club/2014-12/msg00036.html
|*)

(*|
Answer (Arthur Azevedo De Amorim)
*********************************

I had never seen this issue before, but it makes sense, although one
could probably argue that it is a bug in ``inversion``.

This problem is due to the fact that ``inversion`` is implemented by
case analysis. In Coq's logic, one cannot *in general* perform case
analysis on a *logical* hypothesis (i.e., something whose type is a
``Prop``) if the result is something of computational nature (i.e., if
the sort of the type of the thing being returned is a ``Type``). One
reason for this is that the designers of Coq wanted to make it
possible to erase proof arguments from programs when extracting them
into code in a sound way: thus, one is only allowed to do case
analysis on a hypothesis to produce something computational if the
thing being destructed cannot alter the result. This includes:

1. Propositions with no constructors, such as ``False``.
2. Propositions with only one constructor, as long as that constructor
   takes no arguments of computational nature. This includes ``True``,
   ``Acc`` (the accessibility predicated used for doing well-founded
   recursion), but excludes the existential quantifier ``ex``.

As you noticed, however, it is possible to circumvent that rule by
converting some proposition you want to use for producing your result
to another one you can do case analysis on directly. Thus, if you have
a contradictory assumption, like in your case, you can first use it to
prove ``False`` (which is allowed, since ``False`` is a ``Prop``), and
*then* eliminating ``False`` to produce your result (which is allowed
by the above rules).

In your example, ``inversion`` is being too conservative by giving up
just because it cannot do case analysis on something of type ``0 < 0``
in that context. It is true that it can't do case analysis on it
directly by the rules of the logic, as explained above; however, one
could think of making a slightly smarter implementation of
``inversion`` that recognizes that we are eliminating a contradictory
hypothesis and adds ``False`` as an intermediate step, just like you
did. Unfortunately, it seems that we need to do this trick by hand to
make it work.
|*)

(*|
Answer (stop-cran)
******************

In addition to Arthur's answer, there is a workaround using
`constructive_definite_description
<https://coq.github.io/doc/master/stdlib/Coq.Logic.Description.html#constructive_definite_description>`__
axiom. Using this axiom in a function would not allow to perform
calculations and extract code from it, but it still could be used in
other proofs:
|*)

Reset Initial. (* .none *)
From Coq Require Import Description.

Definition strange1 : forall T : Type, 0 > 0 -> T.
  intros T H.
  assert (exists! t : T, True) as H0 by inversion H.
  apply constructive_definite_description in H0.
  destruct H0 as [x ?].
  exact x.
Defined.

(*| Or same function without proof editing mode: |*)

Definition strange2 (T : Type) (H : 0 > 0) : T :=
  proj1_sig (constructive_definite_description (fun _ => True) ltac:(inversion H)).

(*|
Also there's a stronger axiom `constructive_indefinite_description
<https://coq.github.io/doc/master/stdlib/Coq.Logic.IndefiniteDescription.html#constructive_indefinite_description>`__
that converts a proposition ``exists x : T, P x`` (without uniqueness)
into a corresponding sigma-type ``{x : T | P x}``.
|*)


Definition xx:=  forall (T:Type) (t1 t2:T), bool.

(* Print xx_R. *)

Definition xx_Rb :=
fun f₁ f₂ : forall T : Type, T -> T -> bool =>
forall (T₁ T₂ : Type) (T_R : T₁ -> T₂ -> Type) (t1₁ : T₁) (t1₂ : T₂),
T_R t1₁ t1₂ ->
forall (t2₁ : T₁) (t2₂ : T₂), T_R t2₁ t2₂ -> (f₁ T₁ t1₁ t2₁) = (f₂ T₂ t1₂ t2₂).

Definition xx1:=  forall (T:Type) (t:T), bool.

(*
Declare ML Module "paramcoq".
(* Print xx1_R. *)
Parametricity Recursive bool.

Definition xx1_Rb :=
fun f₁ f₂ : forall T : Type, T ->  bool =>
forall (T₁ T₂ : Type) (T_R : T₁ -> T₂ -> Prop) (t₁ : T₁) (t₂ : T₂),
T_R t₁ t₂ ->
bool_R (f₁ T₁ t₁) (f₂ T₂ t₂).
*)

Definition xxp:=  forall (T:Type) (t:T), Prop.

(** P is a proposition := P:Prop
Props are treated just like types. Thus, it is not surprising that
their translatins are relations.
Props P1 and P2 are related if there is a relation between P1 and P2.
This makes sense if we treat P1 and P2 as types. But if we treat
them as logical propositions,the fact that there is a relation between P1
and P2 carries no useful information -- we can always cook up a relation between
any two props/types.
Also, take a look at [Prop] and [bool]
 *)

Definition xxp_Rp :=
fun f1 f2 : forall T : Type, T -> Prop =>
forall (T₁ T₂ : Type) (T_R : T₁ -> T₂ -> Prop) (t₁ : T₁) (t₂ : T₂),
T_R t₁ t₂ -> f1 T₁ t₁ -> f2 T₂ t₂ -> Prop.

Definition xxp_Riff :=
fun f₁ f₂ : forall T : Type, T ->  Prop =>
forall (T₁ T₂ : Type) (T_R : T₁ -> T₂ -> Prop) (t₁ : T₁) (t₂ : T₂),
  T_R t₁ t₂ -> (f₁ T₁ t₁) <-> (f₂ T₂ t₂).

Definition PP:= Prop.

Definition Prop_R :=  fun P1 P2 : Prop => P1 -> P2 -> Prop.

Definition xxp_Rbad := fun (T:Type) (t:T) => forall (t2:T), t=t2.

(* only totality on T is needed in this example *)
Definition xxpb:=  forall (T:Type)  (f:T->bool), Prop.

Definition xxpbBad :=  fun  (T:Type) (f:T->bool) => forall (x:T), f x = true.

Definition goodP {P1 P2: Prop} (R : P1 -> P2 -> Prop) := P1 <-> P2 /\ (forall (x:P1) (y:P2), R x y).

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Definition pred (n:nat) : nat :=
  match n with
  | O  => O
  | S n => n
  end.

 (*
Locate well_founded.
Print Acc.
 seems to allow singletons
*)

(*
Declare ML Module "paramcoq".
Parametricity Recursive True.
Parametricity Recursive False.
Print True_R.
Print False_R.
*)

Inductive True_R : True -> True -> Prop :=  True_R_I_R : True_R I I.
Inductive False_R : False -> False -> Prop := .

Definition isZero (n:nat) : Prop :=
  match n with
  | O  => True
  | S _ => False
  end.

(*
Parametricity Recursive xx.
Parametricity Recursive xx1.
(* Check (eq_refl : xx1_Rb = xx1_R). *)
Parametricity Recursive xxp.
Parametricity Recursive PP.

Parametricity Recursive nat.
Parametricity Recursive pred.
Parametricity Recursive largeElim.
 *)

Inductive nat_R : nat -> nat -> Set :=
| O_R : nat_R O O
| S_R : forall n n' : nat, nat_R n n' -> nat_R (S n) (S n').

Definition pred_R (n n' : nat) (n_R : nat_R n n')
 : nat_R (pred n) (pred n') :=
match n_R with
| O_R => O_R
| S_R n n' n_R => n_R
end.

Definition isTrue_R (n n' : nat) (n_R : nat_R n n')
 : (isZero n) -> (isZero n') -> Prop :=
match n_R with
| O_R => True_R
| S_R _ _ _ => False_R
end.

(*
Require Import ReflParam.paramDirect ReflParam.indType.
*)

Require Import String.
Open Scope string_scope.

Require Import List.
Import ListNotations.

(*
Run TemplateProgram (genParamInd [] true true "Top.paper.nat").
*)

Module Ded.
Fixpoint nat_R (n n' : nat) : Prop :=
match n,n' with
| O, O => True
| S m, S m' => nat_R m m'
| _,_ => False
end.

Definition O_R : nat_R O O := I.

Definition S_R (n n' : nat) (n_R : nat_R n n')
 : nat_R (S n) (S n') := n_R.

Require Import Coq.Unicode.Utf8.
Definition pred_R (n n' : nat) (n_R: nat_R n n')
 : nat_R (pred n) (pred n') :=
(match n, n'
  return (nat_R n n') -> nat_R (pred n) (pred n')
  with
| O, O => λ (n_R: nat_R O O), O_R
| S m, S m' => λ (m_R: nat_R (S m) (S m')), m_R
| _, _ => λ n_R, False_rect _ n_R
end) n_R.

Definition isTrue_R (n n' : nat) (n_R : nat_R n n')
 : (isZero n) -> (isZero n') -> Prop  :=
(match n,n'
  return forall (n_R:nat_R n n'),
    (isZero n) -> (isZero n') -> Prop
  with
| O,O => fun _ => True_R
| S _, S _ => fun _ => False_R
| _,_ => fun n_R => False_rect _ n_R
end) n_R.

End Ded.

Inductive Vec (T: Set): forall (m: nat), Set :=
| nilV: Vec T O
| consV: forall (n: nat), T -> Vec T n -> Vec T (S n).

(*
Parametricity Recursive Vec.
Print Vec_R.
*)

Inductive Vec_R (T T' : Set) (T_R : T -> T' -> Prop)
  : forall (m m' : nat) (m_R : nat_R m m') (v : Vec T m) (v' : Vec T' m'), Prop :=
| nilV_R : Vec_R T T' T_R O O O_R (nilV T) (nilV T')
| consV_R : forall (n n' : nat) (n_R : nat_R n n') (t : T) (t' : T'),
  T_R t t' -> forall (vn : Vec T n) (vn' : Vec T' n'),
  Vec_R T T' T_R n n' n_R vn vn' ->
  Vec_R T T' T_R (S n) (S n') (S_R n n' n_R) (consV T n t vn) (consV T' n' t' vn').

Module DedV.
Arguments nilV {T}.
Arguments consV {T} n _ _.
Notation nat_R := Ded.nat_R.

Fixpoint Vec_R (T T' : Set) (T_R : T ->  T' -> Prop)
  (m m' : nat) (m_R : nat_R m m') (v : Vec T m) (v' : Vec T' m') : Prop :=
match v,v' with
| nilV, nilV => True
| consV n t vn, consV n' t' vn' =>
  {n_R : nat_R n n' | T_R t t' /\ Vec_R T T' T_R n n' n_R vn vn'}
| _, _ => False
end.

End DedV.

Require Import Coq.Unicode.Utf8.

Module DedVC.
Notation nat_R := Ded.nat_R.
Notation O_R := Ded.O_R.
Notation S_R := Ded.S_R.

Fixpoint Vec_R (T T' : Set) (T_R : T ->  T' -> Prop)
  (m m' : nat) (m_R : nat_R m m') (v : Vec T m) (v' : Vec T' m') : Prop :=
(match v,v' with
| nilV, nilV => λ m_R, m_R = O_R
| consV n t vn, consV n' t' vn' => λ m_R,
  {n_R : nat_R n n' & T_R t t' /\ Vec_R T T' T_R n n' n_R vn vn' /\ m_R = (S_R n n' n_R)}
| _, _ => λ _ , False
end) m_R.

End DedVC.

Print Vec_rect.

(*
Inductive depInd (A I : Set) (B: I-> Set) (f: A-> I) (g: forall i, B i): forall (i:I) (b:B i), Set :=
dind : forall (a:A), depInd A I B f g (f a) (g (f a)).
*)

Inductive depInd : forall (n:nat) (v:Vec nat n), Set :=
dind : forall (vv : Vec nat O), depInd O vv.

Definition depIndRec (P : ∀ (n : nat) (v : Vec nat n) (d: depInd n v), Set)
(f : ∀ vv : Vec nat O, P O vv (dind vv)) (n : nat) (v : Vec nat n) (d : depInd n v) : P n v d:=
match d  with
| dind x => f x
end.

(*
Run TemplateProgram (genParamInd [] true true "Top.paper.Vec").
Run TemplateProgram (genParamInd [] true true "Top.paper.depInd").

Run TemplateProgram (mkIndEnv "indTransEnv"
  ["Top.paper.Vec"; "Top.paper.nat"; "Top.paper.depInd"]).

Run TemplateProgram (genParam indTransEnv false true "depInd_recs").
*)

Module DedM.
(*
Notation nat_R := Top_paper_nat_pmtcty_RR0.
Notation Vec_R := Top_paper_Vec_pmtcty_RR0.
Notation depInd_R := Top_paper_depInd_pmtcty_RR0.
Notation depInd_indicesReq := Top_paper_depInd_pmtcty_RR0_indices.
Print Top_paper_depInd_pmtcty_RR0.
Print Top_paper_depInd_pmtcty_RR0_constr_0 .
Goal False.
set (f:= depInd_recs_pmtcty_RR).
unfold depInd_recs_pmtcty_RR in f.
unfold Top_paper_depInd_pmtcty_RR0_constr_0_inv in f.
Arguments existT {A} {P} x p.

Definition xx (P : ∀ (n : nat) (v : Vec nat n), depInd n v → Set)
     (P₂ : ∀ (n₂ : nat) (v₂ : Vec nat n₂), depInd n₂ v₂ → Set)
     (P_R : ∀ (n n₂ : nat) (n_R : nat_R n n₂) (v : Vec nat n) (v₂ : Vec nat n₂)
            (v_R : Vec_R nat nat nat_R n n₂ n_R v v₂) (H : depInd n v)
            (H0 : depInd n₂ v₂), depInd_R n n₂ n_R v v₂ v_R H H0 → P n v H → P₂ n₂ v₂ H0 → Prop)
     (f : ∀ vv : Vec nat O, P O vv (dind vv)) (f₂ : ∀ vv₂ : Vec nat O, P₂ O vv₂ (dind vv₂))
     (f_R : ∀ (vv vv₂ : Vec nat O)
            (vv_R : Vec_R nat nat nat_R O O Top_paper_nat_pmtcty_RR0_constr_0 vv vv₂),
            P_R O O Top_paper_nat_pmtcty_RR0_constr_0 vv vv₂ vv_R (dind vv)
              (dind vv₂) (Top_paper_depInd_pmtcty_RR0_constr_0 vv vv₂ vv_R)
              (f vv) (f₂ vv₂)) (n n₂ : nat) (n_R : nat_R n n₂) (v : Vec nat n)
     (v₂ : Vec nat n₂) (v_R : Vec_R nat nat nat_R n n₂ n_R v v₂) (d : depInd n v)
     (d₂ : depInd n₂ v₂) (d_R : depInd_R n n₂ n_R v v₂ v_R d d₂) :=
     match
       d as d0 in (depInd n0 v0)
       return
         (∀ (n0_R : nat_R n0 n₂) (v0_R : Vec_R nat nat nat_R n0 n₂ n0_R v0 v₂)
          (d0_R : depInd_R n0 n₂ n0_R v0 v₂ v0_R d0 d₂),
          P_R n0 n₂ n0_R v0 v₂ v0_R d0 d₂ d0_R
            match d0 as d1 in (depInd n1 v1) return (P n1 v1 d1) with
            | dind x => f x
            end
            match d₂ as d0₂ in (depInd n0₂ v0₂) return (P₂ n0₂ v0₂ d0₂) with
            | dind x₂ => f₂ x₂
            end)
     with
     | dind x =>
         match
           d₂ as d0₂ in (depInd n0₂ v0₂)
           return
             (∀ (n0_R : nat_R O n0₂) (v0_R : Vec_R nat nat nat_R O n0₂ n0_R x v0₂)
              (d0_R : depInd_R O n0₂ n0_R x v0₂ v0_R (dind x) d0₂),
              P_R O n0₂ n0_R x v0₂ v0_R (dind x) d0₂ d0_R (f x)
                match d0₂ as d0₂0 in (depInd n0₂0 v0₂0) return (P₂ n0₂0 v0₂0 d0₂0) with
                | dind x₂ => f₂ x₂
                end)
         with
         | dind x₂ =>
             λ (n0_R : nat_R O O) (v0_R : Vec_R nat nat nat_R O O n0_R x x₂)
             (d0_R : depInd_R O O n0_R x x₂ v0_R (dind x) (dind x₂)),
             let
               (vv_R, sigt_R) as sigt_R
                return (P_R O O n0_R x x₂ v0_R (dind x) (dind x₂) sigt_R (f x) (f₂ x₂)) :=
               d0_R in
             match
               sigt_R as sigt_R0 in (depInd_indicesReq _ _ _ _ _ _ n_R0 v_R0)
               return
                 (P_R O O n_R0 x x₂ v_R0 (dind x) (dind x₂) (existT vv_R sigt_R0) (f x) (f₂ x₂))
             with
             | Top_paper_depInd_pmtcty_RR0_indicesc _ _ _ _ _ _ => f_R x x₂ vv_R
             end
         end
     end n_R v_R d_R.

Abort.
*)
Notation nat_R := Ded.nat_R.
Notation Vec_R := DedV.Vec_R.
Notation O_R := Ded.O_R.

Inductive depInd_indicesReq (n n' : nat)  (n_R : nat_R n n') (v : Vec nat n) (v' : Vec nat n')
(v_R : Vec_R nat nat nat_R n n' n_R v v'): forall (n_Ri: nat_R n n') (v_Ri: Vec_R nat nat nat_R n n' n_Ri v v'), Prop :=
depInd_refl :  depInd_indicesReq n n' n_R v v' v_R n_R v_R.

Require Import SquiggleEq.UsefulTypes.

Arguments transport {T} {a} {b} P eq pa.

(*
Fixpoint depInd_R (n n' : nat) (n_R : nat_R n n') (v : Vec nat n) (v' : Vec nat n')
  (b_R : Vec_R nat nat nat_R n n' n_R v v') (m : depInd n v) (m' : depInd n' v'): Prop :=
(match m,m' with
| dind vv, dind vv' => λ (n_R0 : nat_R O O) (v_R0 : Vec_R nat nat nat_R O O n_R0 vv vv'),
  {vv_R : Vec_R nat nat nat_R O O O_R vv vv' &
       {p: n_R0 = O_R & transport (fun (n_R2: nat_R O O) => Vec_R nat nat nat_R O O n_R2 vv vv') p v_R0 = vv_R}}
end) n_R b_R.
*)
Fixpoint depInd_R (n n' : nat) (n_R : nat_R n n') (v : Vec nat n) (v' : Vec nat n')
(v_R : Vec_R nat nat nat_R n n' n_R v v') (m : depInd n v) (m' : depInd n' v'): Prop :=
(match m,m' with
| dind vv, dind vv' => λ (n_R : nat_R O O) (v_R : Vec_R nat nat nat_R O O n_R vv vv'),
  {vv_R : Vec_R nat nat nat_R O O O_R vv vv' & depInd_indicesReq O O O_R vv vv' vv_R n_R v_R}
end) n_R v_R.

Print depInd_rect.

Definition  dind_R  (vv vv₂ : Vec nat O) (vv_R : Vec_R nat nat nat_R O O O_R vv vv₂)
: depInd_R O O O_R vv vv₂ vv_R (dind vv) (dind vv₂) := existT _ vv_R (depInd_refl O O O_R vv vv₂ vv_R).

Arguments existT {A} {P} x p.

(* Notation " x , p |)" := (@existT _ _ x p) (at level 20). *)

Definition xxr (P : ∀ (n : nat) (v : Vec nat n), depInd n v → Set)
 (P' : ∀ (n' : nat) (v' : Vec nat n'), depInd n' v' → Set)
 (P_R : ∀ (n n' : nat) (n_R : nat_R n n') (v : Vec nat n) (v' : Vec nat n')
           (v_R : Vec_R nat nat nat_R n n' n_R v v') (d : depInd n v)
            (d' : depInd n' v') (d_R : depInd_R n n' n_R v v' v_R d d'), P n v d → P' n' v' d' → Prop)
 (f : ∀ vv : Vec nat O, P O vv (dind vv)) (f' : ∀ vv' : Vec nat O, P' O vv' (dind vv'))
 (f_R : ∀ (vv vv' : Vec nat O) (vv_R : Vec_R nat nat nat_R O O O_R vv vv'),
            P_R O O O_R vv vv' vv_R (dind vv) (dind vv') (dind_R vv vv' vv_R) (f vv) (f' vv'))
 (n n' : nat) (n_R : nat_R n n') (v : Vec nat n) (v' : Vec nat n')
 (v_R : Vec_R nat nat nat_R n n' n_R v v') (d : depInd n v)
 (d' : depInd n' v') (d_R : depInd_R n n' n_R v v' v_R d d') :
 P_R _ _ n_R _ _ v_R _ _ d_R (depIndRec _ f _ _  d) (depIndRec _ f' _ _  d') :=
match d
       as d0 in (depInd n0 v0)
       return
         (∀ (n0_R : nat_R n0 n') (v0_R : Vec_R nat nat nat_R n0 n' n0_R v0 v')
          (d0_R : depInd_R n0 n' n0_R v0 v' v0_R d0 d'),
          P_R n0 n' n0_R v0 v' v0_R d0 d' d0_R
            match d0 as d1 in (depInd n1 v1) return (P n1 v1 d1) with
            | dind x => f x
            end
            match d' as d0' in (depInd n0' v0') return (P' n0' v0' d0') with
            | dind x' => f' x'
            end)

with
| dind x =>
  match d'

 as d0' in (depInd n0' v0')
           return
             (∀ (n0_R : nat_R O n0') (v0_R : Vec_R nat nat nat_R O n0' n0_R x v0')
              (d0_R : depInd_R O n0' n0_R x v0' v0_R (dind x) d0'),
              P_R O n0' n0_R x v0' v0_R (dind x) d0' d0_R (f x)
                match d0' as d0'0 in (depInd n0'0 v0'0) return (P' n0'0 v0'0 d0'0) with
                | dind x' => f' x'
                end)

  with
  | dind x' =>
   λ (nn_R : nat_R O O) (vv_R : Vec_R nat nat nat_R O O nn_R x x')
    (dd_R : depInd_R O O nn_R x x' vv_R (dind x) (dind x')),
    match dd_R with
    | existT x_R pdeq =>

      (match pdeq as sigt_R0 in (depInd_indicesReq _ _ _ _ _ _ n_R0 v_R0)
       return (P_R O O n_R0 x x' v_R0 (dind x) (dind x') (existT x_R sigt_R0) (f x) (f' x'))

       with
       | depInd_refl _ _ _ _ _ _ => (f_R x x' x_R):
          (P_R O O O_R x x' x_R (dind x) (dind x') (dind_R x x' x_R) (f x) (f' x'))
       end):
       (P_R O O nn_R x x' vv_R (dind x) (dind x') (existT x_R pdeq) (f x) (f' x'))
    end
  end
end n_R v_R d_R.
End DedM.

(* not that this does not even mention the relation *)

Definition CompleteRel  {A A' : Prop} (R : A -> A' -> Prop) : Prop := (forall (a : A) (a' : A'), R a a').

Definition IffProps {A A' : Prop} (R : A -> A' -> Prop) : Prop := (A <-> A').

Definition TProp :=
 λ (A A': Prop), {R : A -> A' -> Prop & IffProps R /\ CompleteRel R}.

Definition OneToOne  {A B : Type} (R : A -> B -> Prop) : Prop :=
(forall (a:A) (b1 b2: B), R a b1 -> R a b2 ->  b1=b2) /\ (forall (b:B) (a1 a2: A), R a1 b -> R a2 b ->  a1=a2).

Definition Total {A B : Set} (R: A -> B -> Prop) : Type :=
(forall (a:A), {b:B & (R a b)}) * (forall (b:B), {a:A & (R a b)}).

Definition PNone := λ (T:Set) (f:T->nat) (a b :T) , (f a = f b).
Definition PTot := λ (T:Set) (f:T->nat), forall (t:T), f t = O.
Definition POne := λ (T:Set) (f:nat->T), f O = f (S O).
Module Proofs.
(* Parametricity Recursive PNone. *)
Axiom natRSimpl: forall n1 n2, nat_R n1 n2 -> n1=n2.
Lemma PNone (T₁ T₂ : Set) (T_R : T₁ → T₂ → Set) (f₁ : T₁ → nat) (f₂ : T₂ → nat)
(f_R : ∀ (H : T₁) (H0 : T₂), T_R H H0 → nat_R (f₁ H) (f₂ H0))
(a₁ : T₁) (a₂ : T₂) (a_R : T_R a₁ a₂) (b₁ : T₁) (b₂ : T₂)
(b_R : T_R b₁ b₂):
(PNone T₁ f₁ a₁ b₁) <-> (PNone T₂ f₂ a₂ b₂).
Proof.
  unfold PNone. apply f_R in a_R. apply f_R in b_R.
  apply natRSimpl in a_R.
  apply natRSimpl in b_R.
  rewrite a_R, b_R. reflexivity.
Qed.
End Proofs.
Infix "×" := prod (at level 40).

Definition TSet : forall A A', Type :=
λ (A A': Set), {R : A -> A' -> Prop & Total R × OneToOne R}.

(*
Definition BRPi A A' A_R B B':=
  forall (a:A) (a':A'), A_R a a' -> BestRel (B a) (B' a').
*)

Definition irrelevant  {A A' : Set} (R : A -> A' -> Set)  := forall (a:A) (a':A') (p1 p2: R a a'), p1 = p2.

Print le.

Inductive le (n : nat) : nat -> Prop :=
|le_n : le n n
|le_S : forall m : nat, le n m -> le n (S m).

Inductive IWP (I A : Set) (B : A -> Set) (AI : A -> I)  (BI : forall (a : A), B a -> I) : forall (i:I), Prop :=
iwp : forall (a : A) (node : forall b : B a, IWP I A B AI BI (BI a b)), IWP I A B AI BI (AI a).

(*
Parametricity Recursive IWP.
Print IWP_R.
*)

Inductive IWP_R (I₁ I₂ : Set) (I_R : I₁ → I₂ → Prop) (A₁ A₂ : Set)
(A_R : A₁ → A₂ → Prop) (B₁ : A₁ → Set) (B₂ : A₂ → Set)
(B_R : ∀ (H : A₁) (H0 : A₂), A_R H H0 → B₁ H → B₂ H0 → Prop)
(AI₁ : A₁ → I₁) (AI₂ : A₂ → I₂)
(AI_R : ∀ (H : A₁) (H0 : A₂), A_R H H0 → I_R (AI₁ H) (AI₂ H0))
(BI₁ : ∀ a : A₁, B₁ a → I₁) (BI₂ : ∀ a : A₂, B₂ a → I₂)
(BI_R : ∀ (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂) (H : B₁ a₁)
        (H0 : B₂ a₂), B_R a₁ a₂ a_R H H0 → I_R (BI₁ a₁ H) (BI₂ a₂ H0))
  : ∀ (i₁ : I₁) (i₂ : I₂), I_R i₁ i₂ → IWP I₁ A₁ B₁ AI₁ BI₁ i₁ → IWP I₂ A₂ B₂ AI₂ BI₂ i₂ → Prop :=

|iwp_R : ∀ (a₁ : A₁) (a₂ : A₂) (a_R : A_R a₁ a₂)
                  (node₁ : ∀ b : B₁ a₁, IWP I₁ A₁ B₁ AI₁ BI₁ (BI₁ a₁ b))
                  (node₂ : ∀ b : B₂ a₂, IWP I₂ A₂ B₂ AI₂ BI₂ (BI₂ a₂ b)),
                  (∀ (b₁ : B₁ a₁) (b₂ : B₂ a₂) (b_R : B_R a₁ a₂ a_R b₁ b₂),
                   IWP_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                     (BI₁ a₁ b₁) (BI₂ a₂ b₂) (BI_R a₁ a₂ a_R b₁ b₂ b_R)
                     (node₁ b₁) (node₂ b₂))
                  → IWP_R I₁ I₂ I_R A₁ A₂ A_R B₁ B₂ B_R AI₁ AI₂ AI_R BI₁ BI₂ BI_R
                      (AI₁ a₁) (AI₂ a₂) (AI_R a₁ a₂ a_R)
                      (iwp I₁ A₁ B₁ AI₁ BI₁ a₁ node₁)
                      (iwp I₂ A₂ B₂ AI₂ BI₂ a₂ node₂).

Scheme IRP_indd := Induction for IWP Sort Prop.

Lemma IWP_R_complete_simpl
(I I' : Set) (I_R : I -> I' -> Prop) (A A' : Set) (A_R : A -> A' -> Prop)
(B : A -> Set) (B' : A' -> Set)
(B_R : forall (H : A) (H0 : A'), A_R H H0 -> B H -> B' H0 -> Prop)
(AI : A -> I) (AI' : A' -> I')
(AI_R : forall (H : A) (H0 : A'), A_R H H0 -> I_R (AI H) (AI' H0))
(BI : forall a : A, B a -> I) (BI' : forall a : A', B' a -> I')
(BI_R : forall (a : A) (a' : A') (a_R : A_R a a') (H : B a) (H0 : B' a'),
        B_R a a' a_R H H0 -> I_R (BI a H) (BI' a' H0))
 (i : I) (i' : I') (i_R : I_R i i')
(* extra*)
(I_R_iso : OneToOne I_R) (*total Hetero not needed*)
(A_R_tot : Total A_R) (* TotalHeteroRel implies TotalHeteroRelP *)
(B_R_tot : forall (a : A) (a' : A') (a_R : A_R a a'), Total (B_R _ _ a_R))
(x : IWP I A B AI BI i)
:
(IWP I' A' B' AI' BI' i')
/\ (forall y : IWP I' A' B' AI' BI' i', IWP_R I I' I_R A A' A_R B B' B_R AI AI' AI_R BI BI' BI_R i i' i_R x y).
Proof.
  revert i_R.
  revert i'.
  induction x  as [a node Hb]  using IRP_indd.
  pose proof (fst A_R_tot a) as Haa.
  destruct Haa as [a' a_R].
  intros.
  pose proof (AI_R _ _ a_R) as ir2.
  pose proof (proj1 I_R_iso _ _ _ i_R ir2) as Hir2.
  subst. clear ir2.
  evar ( c2 : IWP I' A' B' AI' BI' (AI' a')).
  Unshelve. Focus 2.
     constructor.
     intros b₂.
     pose proof (snd (B_R_tot _ _ a_R) b₂) as b1.
     destruct b1 as [b1 br].
     apply Hb with (b:=b1). apply BI_R with (a_R:=a_R). exact br.
  (* the above is the same as iff *)

  split;[exact c2|].
Check
(
∀ y : IWP I' A' B' AI' BI' (AI' a'),
  IWP_R I I' I_R A A' A_R B B' B_R AI AI' AI_R BI BI' BI_R (AI a) (AI' a') i_R (iwp I A B AI BI a node) y
).
Abort.
(*
(*

regexp replace

(([A-Za-z0-9_])*)\\_R

with

\\trel{$1}

*)

(*
Lemma Prop_Set {A₁ A₂: Prop} (R : A₁ -> A₂ -> Prop):
  Total R <-> (IffProps R /\ CompleteRel R).
*)

Require Import ReflParam.PiTypeR.
Section OneCounter.
Let A:=bool.
Let B:=bool.
Let AR := fun (a1 a2: bool) => True. (* total but not one to one *)
Let BR := fun (a1 a2: bool) => a1=a2. (* total and one to one *)
Let fbad (b:bool) := b. (* violates the "quotient" *)
Let RF := R_Fun AR BR.

Lemma notTotal : forall fbad',  (RF fbad fbad') -> False.
Proof.
  intros f Hc.
  unfold RF, R_Fun, common.R_Pi, AR, BR, fbad in Hc.
  pose proof (Hc true true I) as H1.
  pose proof (Hc false true I) as H2.
  congruence.
Qed.
End OneCounter.

Definition counterF  :=
λ (A B:Set), A -> B.

(* Parametricity Recursive counterF. *)
(* Print Top_o_paper_o_counterF_R. *)

Definition counterFR :=
λ (A₁ A₂ : Set) (A_R : A₁ → A₂ → Prop) (B₁ B₂ : Set) (B_R : B₁ → B₂ → Prop)
(H : A₁ → B₁) (H0 : A₂ → B₂), ∀ (H1 : A₁) (H2 : A₂), A_R H1 H2 → B_R (H H1) (H0 H2).

Definition counterFRS :=
λ (A A' : Set) (A_R : A → A' → Prop) (B B' : Set) (B_R : B → B' → Prop)
(f : A → B) (f' : A' → B'), ∀ (a : A) (a' : A'), A_R a a' → B_R (f a) (f' a').

Check (eq_refl:counterFRS=counterFR).

Axiom functional_extensionality_dep :
forall {A:Type} {B : A -> Type}, forall (f g : forall x : A, B x), (forall x, f x = g x) -> f = g.

Notation π₁ := projT1.

Definition IsoRel :=
 λ (A A': Set), {A_R : A -> A' -> Prop & (Total A_R) × (OneToOne A_R)}.

Definition TotalHalf {A A' : Set} (A_R: A -> A' -> Prop) : Type := forall (a:A), {a':A' & (A_R a a')}.

Definition anyRelPi {A A' :Set} (A_R: A -> A' -> Prop) {B: A -> Set} {B': A' -> Set}
  (B_R: forall a a', A_R a a' -> (B a) -> (B' a') -> Prop) (f: forall a, B a) (f': forall a', B' a')
  : Prop := forall a a' (a_R: A_R a a'), B_R _ _ a_R (f a) (f' a').

Lemma totalPiHalf: forall {A A' :Set} (A_R: IsoRel A A') {B: A -> Set} {B': A' -> Set}
  (B_R: forall a a', (π₁ A_R) a a' -> (B a) -> (B' a') -> Prop)
  (BTot : forall a a' (a_R:(π₁ A_R) a a'), TotalHalf (B_R _ _ a_R)), TotalHalf (anyRelPi (π₁ A_R) B_R).
Proof.
Abort.

Inductive IWT (I A : Set) (B : A -> Set) (AI : A -> I)  (BI : forall (a : A), B a -> I) : forall (i:I), Set :=
iwt : forall (a : A) (node : forall b : B a, IWT I A B AI BI (BI a b)), IWT I A B AI BI (AI a).

Definition IWTind :=
fun (I A : Set) (B : A -> Set) (AI : A -> I) (BI : forall a : A, B a -> I)
  (P : forall i : I, IWT I A B AI BI i -> Set)
  (f : forall (a : A) (lim : forall b : B a, IWT I A B AI BI (BI a b)),
       (forall b : B a, P (BI a b) (lim b)) -> P (AI a) (iwt I A B AI BI a lim)) =>
fix F (i : I) (i0 : IWT I A B AI BI i) {struct i0} : P i i0 :=
  match i0 as i2 in (IWT _ _ _ _ _ i1) return (P i1 i2) with
  | iwt _ _ _ _ _ a lim => f a lim (fun b : B a => F (BI a b) (lim b))
  end.

Definition LHS :=
fun (I A : Set) (B : A -> Set) (AI : A -> I)  (BI : forall (a : A), B a -> I)
  (P : forall i : I, IWT I A B AI BI i -> Set)
  (f : forall (a : A) (lim : forall b : B a, IWT I A B AI BI (BI a b)),
       (forall b : B a, P (BI a b) (lim b)) -> P (AI a) (iwt I A B AI BI a lim))
  (a:A)
  (lim: forall b : B a, IWT I A B AI BI (BI a b)) =>
  IWTind _ _ _ _ _ _ f _ (iwt _ _ _ _ _ a lim).

Definition RHS :=
fun (I A : Set) (B : A -> Set) (AI : A -> I)  (BI : forall (a : A), B a -> I)
  (P : forall i : I, IWT I A B AI BI i -> Set)
  (f : forall (a : A) (lim : forall b : B a, IWT I A B AI BI (BI a b)),
       (forall b : B a, P (BI a b) (lim b)) -> P (AI a) (iwt I A B AI BI a lim))
  (a:A)
  (lim: forall b : B a, IWT I A B AI BI (BI a b)) =>
  f a lim (fun b : B a => IWTind _ _ _ _ _ _ f (BI a b) (lim b)).

(*
Definttion oneSigmaIWT (I A : Set) (B : A -> Set) (AI : A -> I)  (BI : forall (a : A), B a -> I) :Set :=
{ i2: I & IWT }.
*)

Lemma inj_pair2: forall (U : Type) (P : U -> Type) (p : U) (x y : P p), existT p x = existT p y -> x = y.
Abort.

Definition mkIsoRel (A A' : Set) (A_R: A -> A' -> Prop) (A_Rtot: Total A_R) (A_Rone: OneToOne A_R) : IsoRel A A'.
Abort.

Definition projRel (A A' : Set) (A_RG : IsoRel A A') : A -> A' -> Prop.
Abort.

Inductive  Monad : forall (A:Set), Set := ret : Monad nat.

(*
Parametricity Recursive ID.
Parametricity Recursive id.
Print Coq_o_Init_o_Datatypes_o_ID_R.
Print Coq_o_Init_o_Datatypes_o_id_R.
*)

Definition IDR :=
λ(f f': forall A : Type, A → A), forall (A A': Type) (Aᵣ: A → A' → Type) (a: A) (a': A'), Aᵣ a a' → Aᵣ (f A a) (f' A' a').

Definition id :=
λ (A : Type) (a : A), a.

Definition idR :=
λ(A A' : Type) (Aᵣ : A → A' → Type) (a: A) (a': A') (aᵣ : Aᵣ a a'), aᵣ.

Fixpoint zero (A : Type) (x : A) (p : x = x) {struct p}:= 0.

Inductive eqs {A : Set} (x : A) : forall (a:A), Prop :=
  eq_refls : eqs x x.

Inductive option (A : Set) : Set :=  Some : A -> option A | None : option A.
Arguments Some {A} _.
Arguments None {A}.

Infix "=" := eqs : type_scope.
Notation True := (true=true).
Notation False := (false=true).

Definition isNone {A:Set} (oa: option A) :=
  match oa with
  | Some _ => false
  | None => true
  end.
Infix "+" := sum:type_scope.
(*
Definition beq (b1 b2 : bool) := eqs bool b1 b2.
 *)

Open Scope nat_scope.

Section Squiggle4.
(* Variable V:Set. This interface is too abstract for exposing V *)
Variables (Tm BTm : Set).
Variable applyBtm: BTm -> Tm -> Tm.

Inductive TmKind :=
| elam (bt: BTm)
| eapp (f a: Tm)
| enum (n: nat)
| evar.

Variable tmKind:  Tm -> TmKind.

Fixpoint evaln (n:nat) (t:Tm): option Tm :=
match n with
| O => None | S n =>
  match (tmKind t) with
  | evar | elam _ | enum _ => Some t
  | eapp f a =>
    match evaln n f, evaln n a with
    | Some f, Some a =>
      match (tmKind f) with
      | elam bt => Some (applyBtm bt a)
      | _ => None
      end
    | _,_ => None
    end
  end
end.

(* just this would be an example. However, because it is not recursive,
 even tauto may be able to prove it. Even if we only show this on paper,
we should have a more complex (recursively defined undefined relation)
in the appendix *)
Definition divergesIff (tl tr:Tm) : Prop :=
 (forall (nsteps:nat), (isNone (evaln nsteps tl)) = true)
 <-> (forall (nsteps:nat), (isNone (evaln nsteps tr)) = true).

 (* need to eliminate the oneOne of Prop inductives and use PI *)
Fixpoint obsEq (k:nat) (tl tr:Tm): Prop :=
divergesIff tl tr /\ forall (nsteps:nat),
match k with | O => True | S k =>
 match evaln nsteps tl, evaln nsteps tr with
 |Some vl, Some vr =>
  match tmKind vl, tmKind vr with
  | enum nl , enum nr => nl = nr
  | elam btl , elam btr => forall (ta: Tm),
    obsEq k (applyBtm btl ta) (applyBtm btr ta)
  | eapp fl al , eapp fr ar =>
      obsEq k fl fr /\ obsEq k al ar
  | _,_ => False
  end
 |_, _  => True
 end
end.

Definition obseq (tl tr:Tm) := forall (k:nat), obsEq k tl tr.

Definition comb (A1 A2 :Set) (A_R: IsoRel A1 A2)
  (B1: A1 -> Set)
  (B2: A2 -> Set)
  (B_R: forall a1 a2, π₁ A_R a1 a2 -> IsoRel (B1 a1) (B2 a2)) :
  IsoRel (forall a : A1, B1 a) (forall a : A2, B2 a).
Proof.
exists  (fun (f1 : forall a : A1, B1 a) (f2 : forall a : A2, B2 a) =>
forall (a1 : A1) (a2 : A2) (p : π₁ A_R a1 a2), π₁ (B_R a1 a2 p) (f1 a1) (f2 a2)
).
Abort.

Definition  GoodProp :=
  forall (A1 A2 :Set) (A_R:  IsoRel A1 A2)
  (B1: A1 -> Prop)
  (B2: A2 -> Prop)
  (B_R: forall a1 a2,  π₁ A_R a1 a2 ->  IsoRel (B1 a1) (B2 a2)),
    IsoRel (forall a : A1, B1 a) (forall a : A2, B2 a).

End Squiggle4.

Variable TmKindAnyRel
     : forall Tm Tm₂ : Set,
       (Tm -> Tm₂ -> Prop) ->
       forall BTm BTm₂ : Set,
       (BTm -> BTm₂ -> Prop) -> TmKind Tm BTm -> TmKind Tm₂ BTm₂ -> Prop.

Definition obseqStrongIsoType :=
forall (Tm Tm₂ : Set) (Tmᵣ : Tm -> Tm₂ -> Prop)
  (Tmᵣtot: Total Tmᵣ)
  (BTm BTm₂ : Set) (BTmᵣ : BTm -> BTm₂ -> Prop)
  (applyBtm : BTm -> Tm -> Tm)
  (applyBtm₂ : BTm₂ -> Tm₂ -> Tm₂)
  (applyBtmᵣ : forall (b : BTm) (b₂ : BTm₂) (bᵣ: BTmᵣ b b₂)
                 (a : Tm) (a₂ : Tm₂) (aᵣ : Tmᵣ a a₂),
      Tmᵣ (applyBtm b a) (applyBtm₂ b₂ a₂))
  (tmKind : Tm -> TmKind Tm BTm)
  (tmKind₂ : Tm₂ -> TmKind Tm₂ BTm₂)
  (tmKindᵣ : forall (a : Tm) (a₂ : Tm₂) (aᵣ: Tmᵣ a a₂),
      TmKindAnyRel Tm Tm₂ Tmᵣ BTm BTm₂ BTmᵣ
                   (tmKind a)
                   (tmKind₂ a₂))
  (tl : Tm) (tl₂ : Tm₂) (tlᵣ: Tmᵣ tl tl₂)
  (tr : Tm) (tr₂ : Tm₂) (trᵣ: Tmᵣ tr tr₂),
     IsoRel (obseq Tm BTm applyBtm tmKind tl tr)
             (obseq Tm₂ BTm₂ applyBtm₂ tmKind₂ tl₂ tr₂).

Definition obseqWeakIsoType :=
(forall (Tm Tm₂ : Set) (Tm_R : IsoRel Tm Tm₂) (BTm BTm₂ : Set)
   (BTm_R : IsoRel BTm BTm₂) (applyBtm : BTm -> Tm -> Tm)
   (applyBtm₂ : BTm₂ -> Tm₂ -> Tm₂),
 (forall (a1 : BTm) (a2 : BTm₂),
   π₁ BTm_R a1 a2 ->
  forall (a3 : Tm) (a4 : Tm₂),
   π₁ Tm_R a3 a4 ->  π₁ Tm_R (applyBtm a1 a3) (applyBtm₂ a2 a4)) ->
 forall (tmKind : Tm -> TmKind Tm BTm) (tmKind₂ : Tm₂ -> TmKind Tm₂ BTm₂),
 (forall (a1 : Tm) (a2 : Tm₂),
   π₁ Tm_R a1 a2 ->
  TmKindAnyRel Tm Tm₂ ( π₁ Tm_R) BTm BTm₂ ( π₁ BTm_R)
    (tmKind a1) (tmKind₂ a2)) ->
 forall (tl : Tm) (tl₂ : Tm₂),
  π₁ Tm_R tl tl₂ ->
 forall (tr : Tm) (tr₂ : Tm₂),
  π₁ Tm_R tr tr₂ ->
 IsoRel (forall a : nat, obsEq Tm BTm applyBtm tmKind a tl tr)
   (forall a : nat, obsEq Tm₂ BTm₂ applyBtm₂ tmKind₂ a tl₂ tr₂)).

Set Universe Polymorphism.

Inductive list@{i} (A : Type@{i}) : Type@{i} :=
| nil : list A
| cons : A -> list A -> list A.

(*
Inductive list_R@{i} (A₁ A₂ : Type@{i})
  (A_R : A₁ -> A₂ -> Type@{i}) : list A₁ -> list A₂ -> Type@{i}
  :=.
*)
Fixpoint list_R@{i} (A: Type@{i}) (A₂ : Type@{i}) (A_R : A -> A₂ -> Type@{i})
(l : list@{i} A) (l₂ : list@{i} A₂) : Type@{i} :=
                                  True.

Lemma IsoRel_implies_iff (A B:Prop) (pb : IsoRel A B) : A <-> B.
Abort.


Require Import Sail2_values.
Require Import Sail2_operators.
Require Import Sail2_prompt_monad.
Require Import Sail2_prompt.
Require Import bbv.Word.
Require bbv.BinNotation.
Require Import Arith.
Require Import ZArith.
Require Import Omega.
Require Import Eqdep_dec.

Fixpoint cast_positive (T : positive -> Type) (p q : positive) : T p -> p = q -> T q.
refine (
match p, q with
| xH, xH => fun x _ => x
| xO p', xO q' => fun x e => cast_positive (fun x => T (xO x)) p' q' x _
| xI p', xI q' => fun x e => cast_positive (fun x => T (xI x)) p' q' x _
| _, _ => _
end); congruence.
Defined.

Definition cast_T {T : Z -> Type} {m n} : forall (x : T m) (eq : m = n), T n.
refine (match m,n with
| Z0, Z0 => fun x _ => x
| Zneg p1, Zneg p2 => fun x e => cast_positive (fun p => T (Zneg p)) p1 p2 x _
| Zpos p1, Zpos p2 => fun x e => cast_positive (fun p => T (Zpos p)) p1 p2 x _
| _,_ => _
end); congruence.
Defined.

Lemma cast_positive_refl : forall p T x (e : p = p),
  cast_positive T p p x e = x.
induction p.
* intros. simpl. rewrite IHp; auto.
* intros. simpl. rewrite IHp; auto.
* reflexivity.
Qed.

Lemma cast_T_refl {T : Z -> Type} {m} {H:m = m} (x : T m) : cast_T x H = x.
destruct m.
* reflexivity.
* simpl. rewrite cast_positive_refl. reflexivity.
* simpl. rewrite cast_positive_refl. reflexivity.
Qed.

Definition autocast {T : Z -> Type} {m n} (x : T m) `{H:ArithFact (m = n)} : T n :=
  cast_T x (use_ArithFact H).

Definition autocast_m {rv e m n} (x : monad rv (mword m) e) `{H:ArithFact (m = n)} : monad rv (mword n) e :=
  x >>= fun x => returnm (cast_T x (use_ArithFact H)).

Definition cast_word {m n} (x : Word.word m) (eq : m = n) : Word.word n :=
  DepEqNat.nat_cast _ eq x.

Lemma cast_word_refl {m} {H:m = m} (x : word m) : cast_word x H = x.
rewrite (UIP_refl_nat _ H).
apply nat_cast_same.
Qed.

Definition mword_of_nat {m} : Word.word m -> mword (Z.of_nat m).
refine (match m return word m -> mword (Z.of_nat m) with
| O => fun x => x
| S m' => fun x => nat_cast _ _ x
end).
rewrite SuccNat2Pos.id_succ.
reflexivity.
Defined.

Definition cast_to_mword {m n} (x : Word.word m) : Z.of_nat m = n -> mword n.
refine (match n return Z.of_nat m = n -> mword n with
| Z0 => fun _ => WO
| Zpos p => fun eq => cast_T (mword_of_nat x) eq
| Zneg p => _
end).
intro eq.
exfalso. destruct m; simpl in *; congruence.
Defined.

(*
(* Specialisation of operators to machine words *)

val access_vec_inc : forall 'a. Size 'a => mword 'a -> integer -> bitU*)
Definition access_vec_inc {a} : mword a -> Z -> bitU := access_mword_inc.

(*val access_vec_dec : forall 'a. Size 'a => mword 'a -> integer -> bitU*)
Definition access_vec_dec {a} : mword a -> Z -> bitU := access_mword_dec.

(*val update_vec_inc : forall 'a. Size 'a => mword 'a -> integer -> bitU -> mword 'a*)
(* TODO: probably ought to use a monadic version instead, but using bad default for
   type compatibility just now *)
Definition update_vec_inc {a} (w : mword a) i b : mword a :=
 opt_def w (update_mword_inc w i b).

(*val update_vec_dec : forall 'a. Size 'a => mword 'a -> integer -> bitU -> mword 'a*)
Definition update_vec_dec {a} (w : mword a) i b : mword a := opt_def w (update_mword_dec w i b).

Lemma subrange_lemma0 {n m o} `{ArithFact (0 <= o)} `{ArithFact (o <= m < n)} : (Z.to_nat o <= Z.to_nat m < Z.to_nat n)%nat.
intros.
unwrap_ArithFacts.
split.
+ apply Z2Nat.inj_le; omega.
+ apply Z2Nat.inj_lt; omega.
Qed.
Lemma subrange_lemma1 {n m o} : (o <= m < n -> n = m + 1 + (n - (m + 1)))%nat.
intros. omega.
Qed.
Lemma subrange_lemma2 {n m o} : (o <= m < n -> m+1 = o+(m-o+1))%nat.
omega.
Qed.
Lemma subrange_lemma3 {n m o} `{ArithFact (0 <= o)} `{ArithFact (o <= m < n)} :
  Z.of_nat (Z.to_nat m - Z.to_nat o + 1)%nat = m - o + 1.
unwrap_ArithFacts.
rewrite Nat2Z.inj_add.
rewrite Nat2Z.inj_sub.
repeat rewrite Z2Nat.id; try omega.
reflexivity.
apply Z2Nat.inj_le; omega.
Qed.

Definition subrange_vec_dec {n} (v : mword n) m o `{ArithFact (0 <= o)} `{ArithFact (o <= m < n)} : mword (m - o + 1) :=
  let n := Z.to_nat n in
  let m := Z.to_nat m in
  let o := Z.to_nat o in
  let prf : (o <= m < n)%nat := subrange_lemma0 in
  let w := get_word v in
  cast_to_mword (split2 o (m-o+1)
                        (cast_word (split1 (m+1) (n-(m+1)) (cast_word w (subrange_lemma1 prf)))
                                   (subrange_lemma2 prf))) subrange_lemma3.

Definition subrange_vec_inc {n} (v : mword n) m o `{ArithFact (0 <= m)} `{ArithFact (m <= o < n)} : mword (o - m + 1) := autocast (subrange_vec_dec v (n-1-m) (n-1-o)).

(* TODO: get rid of bogus default *)
Parameter dummy_vector : forall {n} `{ArithFact (n >= 0)}, mword n.

(*val update_subrange_vec_inc : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> integer -> mword 'b -> mword 'a*)
Definition update_subrange_vec_inc {a b} (v : mword a) i j (w : mword b) : mword a :=
  opt_def dummy_vector (of_bits (update_subrange_bv_inc v i j w)).

(*val update_subrange_vec_dec : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> integer -> mword 'b -> mword 'a*)
Definition update_subrange_vec_dec {a b} (v : mword a) i j (w : mword b) : mword a :=
  opt_def dummy_vector (of_bits (update_subrange_bv_dec v i j w)).

Lemma mword_nonneg {a} : mword a -> a >= 0.
destruct a;
auto using Z.le_ge, Zle_0_pos with zarith.
destruct 1.
Qed.

(*val extz_vec : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b*)
Definition extz_vec {a b} `{ArithFact (b >= a)} (n : Z) (v : mword a) : mword b.
refine (cast_to_mword (Word.zext (get_word v) (Z.to_nat (b - a))) _).
unwrap_ArithFacts.
assert (a >= 0). { apply mword_nonneg. assumption. }
rewrite <- Z2Nat.inj_add; try omega.
rewrite Zplus_minus.
apply Z2Nat.id.
auto with zarith.
Defined.

(*val exts_vec : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b*)
Definition exts_vec {a b} `{ArithFact (b >= a)} (n : Z) (v : mword a) : mword b.
refine (cast_to_mword (Word.sext (get_word v) (Z.to_nat (b - a))) _).
unwrap_ArithFacts.
assert (a >= 0). { apply mword_nonneg. assumption. }
rewrite <- Z2Nat.inj_add; try omega.
rewrite Zplus_minus.
apply Z2Nat.id.
auto with zarith.
Defined.

Definition zero_extend {a} (v : mword a) (n : Z) `{ArithFact (n >= a)} : mword n := extz_vec n v.

Definition sign_extend {a} (v : mword a) (n : Z) `{ArithFact (n >= a)} : mword n := exts_vec n v.

Definition zeros (n : Z) `{ArithFact (n >= 0)} : mword n.
refine (cast_to_mword (Word.wzero (Z.to_nat n)) _).
unwrap_ArithFacts.
apply Z2Nat.id.
auto with zarith.
Defined.

Lemma truncate_eq {m n} : m >= 0 -> m <= n -> (Z.to_nat n = Z.to_nat m + (Z.to_nat n - Z.to_nat m))%nat.
intros.
assert ((Z.to_nat m <= Z.to_nat n)%nat).
{ apply Z2Nat.inj_le; omega. }
omega.
Qed.
Lemma truncateLSB_eq {m n} : m >= 0 -> m <= n -> (Z.to_nat n = (Z.to_nat n - Z.to_nat m) + Z.to_nat m)%nat.
intros.
assert ((Z.to_nat m <= Z.to_nat n)%nat).
{ apply Z2Nat.inj_le; omega. }
omega.
Qed.

Definition vector_truncate {n} (v : mword n) (m : Z) `{ArithFact (m >= 0)} `{ArithFact (m <= n)} : mword m :=
  cast_to_mword (Word.split1 _ _ (cast_word (get_word v) (ltac:(unwrap_ArithFacts; apply truncate_eq; auto) : Z.to_nat n = Z.to_nat m + (Z.to_nat n - Z.to_nat m))%nat)) (ltac:(unwrap_ArithFacts; apply Z2Nat.id; omega) : Z.of_nat (Z.to_nat m) = m).

Definition vector_truncateLSB {n} (v : mword n) (m : Z) `{ArithFact (m >= 0)} `{ArithFact (m <= n)} : mword m :=
  cast_to_mword (Word.split2 _ _ (cast_word (get_word v) (ltac:(unwrap_ArithFacts; apply truncateLSB_eq; auto) : Z.to_nat n = (Z.to_nat n - Z.to_nat m) + Z.to_nat m)%nat)) (ltac:(unwrap_ArithFacts; apply Z2Nat.id; omega) : Z.of_nat (Z.to_nat m) = m).

Lemma concat_eq {a b} : a >= 0 -> b >= 0 -> Z.of_nat (Z.to_nat b + Z.to_nat a)%nat = a + b.
intros.
rewrite Nat2Z.inj_add.
rewrite Z2Nat.id; auto with zarith.
rewrite Z2Nat.id; auto with zarith.
Qed.

(*val concat_vec : forall 'a 'b 'c. Size 'a, Size 'b, Size 'c => mword 'a -> mword 'b -> mword 'c*)
Definition concat_vec {a b} (v : mword a) (w : mword b) : mword (a + b) :=
 cast_to_mword (Word.combine (get_word w) (get_word v)) (ltac:(solve [auto using concat_eq, mword_nonneg with zarith]) : Z.of_nat (Z.to_nat b + Z.to_nat a)%nat = a + b).

(*val cons_vec : forall 'a 'b 'c. Size 'a, Size 'b => bitU -> mword 'a -> mword 'b*)
(*Definition cons_vec {a b} : bitU -> mword a -> mword b := cons_bv.*)

(*val bool_of_vec : mword ty1 -> bitU
Definition bool_of_vec := bool_of_bv

val cast_unit_vec : bitU -> mword ty1
Definition cast_unit_vec := cast_unit_bv

val vec_of_bit : forall 'a. Size 'a => integer -> bitU -> mword 'a
Definition vec_of_bit := bv_of_bit*)

Require Import bbv.NatLib.

Lemma Npow2_pow {n} : (2 ^ (N.of_nat n) = Npow2 n)%N.
induction n.
* reflexivity.
* rewrite Nnat.Nat2N.inj_succ.
  rewrite N.pow_succ_r'.
  rewrite IHn.
  rewrite Npow2_S.
  rewrite Word.Nmul_two.
  reflexivity.
Qed.

Program Definition uint {a} (x : mword a) : {z : Z & ArithFact (0 <= z /\ z <= 2 ^ a - 1)} :=
 existT _ (Z.of_N (Word.wordToN (get_word x))) _.
Next Obligation.
constructor.
constructor.
* apply N2Z.is_nonneg.
* assert (2 ^ a - 1 = Z.of_N (2 ^ (Z.to_N a) - 1)). {
    rewrite N2Z.inj_sub.
    * rewrite N2Z.inj_pow.
      rewrite Z2N.id; auto.
      destruct a; auto with zarith. destruct x.
    * apply N.le_trans with (m := (2^0)%N); auto using N.le_refl.
      apply N.pow_le_mono_r.
      inversion 1.
      apply N.le_0_l.
  }
  rewrite H.
  apply N2Z.inj_le.
  rewrite N.sub_1_r.
  apply N.lt_le_pred.
  rewrite <- Z_nat_N.
  rewrite Npow2_pow.
  apply Word.wordToN_bound.
Defined.

Lemma Zpow_pow2 {n} : 2 ^ Z.of_nat n = Z.of_nat (pow2 n).
induction n.
* reflexivity.
* rewrite pow2_S_z.
  rewrite Nat2Z.inj_succ.
  rewrite Z.pow_succ_r; auto with zarith.
Qed.

Program Definition sint {a} `{ArithFact (a > 0)} (x : mword a) : {z : Z & ArithFact (-(2^(a-1)) <= z /\ z <= 2 ^ (a-1) - 1)} :=
  existT _ (Word.wordToZ (get_word x)) _.
Next Obligation.
destruct H.
destruct a; try inversion fact.
constructor.
generalize (get_word x).
rewrite <- positive_nat_Z.
destruct (Pos2Nat.is_succ p) as [n eq].
rewrite eq.
rewrite Nat2Z.id.
intro w.
destruct (Word.wordToZ_size' w) as [LO HI].
replace 1 with (Z.of_nat 1); auto.
rewrite <- Nat2Z.inj_sub; auto with arith.
simpl.
rewrite <- minus_n_O.
rewrite Zpow_pow2.
rewrite Z.sub_1_r.
rewrite <- Z.lt_le_pred.
auto.
Defined.

Definition sint0 {a} `{ArithFact (a >= 0)} (x : mword a) : Z :=
  if sumbool_of_bool (Z.eqb a 0) then 0 else projT1 (sint x).

Lemma length_list_pos : forall {A} {l:list A}, length_list l >= 0.
unfold length_list.
auto with zarith.
Qed.
Hint Resolve length_list_pos : sail.

Definition vec_of_bits (l:list bitU) : mword (length_list l) := opt_def dummy_vector (of_bits l).
(*

val msb : forall 'a. Size 'a => mword 'a -> bitU
Definition msb := most_significant

val int_of_vec : forall 'a. Size 'a => bool -> mword 'a -> integer
Definition int_of_vec := int_of_bv

val string_of_vec : forall 'a. Size 'a => mword 'a -> string*)
Definition string_of_bits {n} (w : mword n) : string := string_of_bv w.
Definition with_word' {n} (P : Type -> Type) : (forall n, Word.word n -> P (Word.word n)) -> mword n -> P (mword n) := fun f w => @with_word n _ (f (Z.to_nat n)) w.
Definition word_binop {n} (f : forall n, Word.word n -> Word.word n -> Word.word n) : mword n -> mword n -> mword n := with_word' (fun x => x -> x) f.
Definition word_unop {n} (f : forall n, Word.word n -> Word.word n) : mword n -> mword n := with_word' (fun x => x) f.

(*
val and_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a
val or_vec  : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a
val xor_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a
val not_vec : forall 'a. Size 'a => mword 'a -> mword 'a*)
Definition and_vec {n} : mword n -> mword n -> mword n := word_binop Word.wand.
Definition or_vec  {n} : mword n -> mword n -> mword n := word_binop Word.wor.
Definition xor_vec {n} : mword n -> mword n -> mword n := word_binop Word.wxor.
Definition not_vec {n} : mword n -> mword n := word_unop Word.wnot.

(*val add_vec   : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a
val sadd_vec  : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a
val sub_vec   : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a
val mult_vec  : forall 'a 'b. Size 'a, Size 'b => mword 'a -> mword 'a -> mword 'b
val smult_vec : forall 'a 'b. Size 'a, Size 'b => mword 'a -> mword 'a -> mword 'b*)
Definition add_vec   {n} : mword n -> mword n -> mword n := word_binop Word.wplus.
(*Definition sadd_vec  {n} : mword n -> mword n -> mword n := sadd_bv w.*)
Definition sub_vec   {n} : mword n -> mword n -> mword n := word_binop Word.wminus.
Definition mult_vec  {n m} `{ArithFact (m >= n)} (l : mword n) (r : mword n) : mword m :=
  word_binop Word.wmult (zero_extend l _) (zero_extend r _).
Definition mults_vec  {n m} `{ArithFact (m >= n)} (l : mword n) (r : mword n) : mword m :=
  word_binop Word.wmult (sign_extend l _) (sign_extend r _).

(*val add_vec_int   : forall 'a. Size 'a => mword 'a -> integer -> mword 'a
val sadd_vec_int  : forall 'a. Size 'a => mword 'a -> integer -> mword 'a
val sub_vec_int   : forall 'a. Size 'a => mword 'a -> integer -> mword 'a
val mult_vec_int  : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> mword 'b
val smult_vec_int : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> mword 'b*)
Definition add_vec_int   {a} (l : mword a) (r : Z) : mword a := arith_op_bv_int Z.add   false l r.
Definition sadd_vec_int  {a} (l : mword a) (r : Z) : mword a := arith_op_bv_int Z.add   true  l r.
Definition sub_vec_int   {a} (l : mword a) (r : Z) : mword a := arith_op_bv_int Z.sub   false l r.
(*Definition mult_vec_int  {a b} : mword a -> Z -> mword b := mult_bv_int.
Definition smult_vec_int {a b} : mword a -> Z -> mword b := smult_bv_int.*)

(*val add_int_vec   : forall 'a. Size 'a => integer -> mword 'a -> mword 'a
val sadd_int_vec  : forall 'a. Size 'a => integer -> mword 'a -> mword 'a
val sub_int_vec   : forall 'a. Size 'a => integer -> mword 'a -> mword 'a
val mult_int_vec  : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b
val smult_int_vec : forall 'a 'b. Size 'a, Size 'b => integer -> mword 'a -> mword 'b
Definition add_int_vec   := add_int_bv
Definition sadd_int_vec  := sadd_int_bv
Definition sub_int_vec   := sub_int_bv
Definition mult_int_vec  := mult_int_bv
Definition smult_int_vec := smult_int_bv

val add_vec_bit  : forall 'a. Size 'a => mword 'a -> bitU -> mword 'a
val sadd_vec_bit : forall 'a. Size 'a => mword 'a -> bitU -> mword 'a
val sub_vec_bit  : forall 'a. Size 'a => mword 'a -> bitU -> mword 'a
Definition add_vec_bit  := add_bv_bit
Definition sadd_vec_bit := sadd_bv_bit
Definition sub_vec_bit  := sub_bv_bit

val add_overflow_vec         : forall 'a. Size 'a => mword 'a -> mword 'a -> (mword 'a * bitU * bitU)
val add_overflow_vec_signed  : forall 'a. Size 'a => mword 'a -> mword 'a -> (mword 'a * bitU * bitU)
val sub_overflow_vec         : forall 'a. Size 'a => mword 'a -> mword 'a -> (mword 'a * bitU * bitU)
val sub_overflow_vec_signed  : forall 'a. Size 'a => mword 'a -> mword 'a -> (mword 'a * bitU * bitU)
val mult_overflow_vec        : forall 'a. Size 'a => mword 'a -> mword 'a -> (mword 'a * bitU * bitU)
val mult_overflow_vec_signed : forall 'a. Size 'a => mword 'a -> mword 'a -> (mword 'a * bitU * bitU)
Definition add_overflow_vec         := add_overflow_bv
Definition add_overflow_vec_signed  := add_overflow_bv_signed
Definition sub_overflow_vec         := sub_overflow_bv
Definition sub_overflow_vec_signed  := sub_overflow_bv_signed
Definition mult_overflow_vec        := mult_overflow_bv
Definition mult_overflow_vec_signed := mult_overflow_bv_signed

val add_overflow_vec_bit         : forall 'a. Size 'a => mword 'a -> bitU -> (mword 'a * bitU * bitU)
val add_overflow_vec_bit_signed  : forall 'a. Size 'a => mword 'a -> bitU -> (mword 'a * bitU * bitU)
val sub_overflow_vec_bit         : forall 'a. Size 'a => mword 'a -> bitU -> (mword 'a * bitU * bitU)
val sub_overflow_vec_bit_signed  : forall 'a. Size 'a => mword 'a -> bitU -> (mword 'a * bitU * bitU)
Definition add_overflow_vec_bit         := add_overflow_bv_bit
Definition add_overflow_vec_bit_signed  := add_overflow_bv_bit_signed
Definition sub_overflow_vec_bit         := sub_overflow_bv_bit
Definition sub_overflow_vec_bit_signed  := sub_overflow_bv_bit_signed

val shiftl       : forall 'a. Size 'a => mword 'a -> integer -> mword 'a
val shiftr       : forall 'a. Size 'a => mword 'a -> integer -> mword 'a
val arith_shiftr : forall 'a. Size 'a => mword 'a -> integer -> mword 'a
val rotl         : forall 'a. Size 'a => mword 'a -> integer -> mword 'a
val rotr         : forall 'a. Size 'a => mword 'a -> integer -> mword 'a*)
(* TODO: check/redefine behaviour on out-of-range n *)
Definition shiftl       {a} (v : mword a) n : mword a := with_word (P := id) (fun w => Word.wlshift' w (Z.to_nat n)) v.
Definition shiftr       {a} (v : mword a) n : mword a := with_word (P := id) (fun w => Word.wrshift' w (Z.to_nat n)) v.
Definition arith_shiftr {a} (v : mword a) n : mword a := with_word (P := id) (fun w => Word.wrshifta' w (Z.to_nat n)) v.
(*
Definition rotl         := rotl_bv
Definition rotr         := rotr_bv

val mod_vec         : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a
val quot_vec        : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a
val quot_vec_signed : forall 'a. Size 'a => mword 'a -> mword 'a -> mword 'a
Definition mod_vec         := mod_bv
Definition quot_vec        := quot_bv
Definition quot_vec_signed := quot_bv_signed

val mod_vec_int  : forall 'a. Size 'a => mword 'a -> integer -> mword 'a
val quot_vec_int : forall 'a. Size 'a => mword 'a -> integer -> mword 'a
Definition mod_vec_int  := mod_bv_int
Definition quot_vec_int := quot_bv_int

val replicate_bits : forall 'a 'b. Size 'a, Size 'b => mword 'a -> integer -> mword 'b*)
Fixpoint replicate_bits_aux {a} (w : Word.word a) (n : nat) : Word.word (n * a) :=
match n with
| O => Word.WO
| S m => Word.combine w (replicate_bits_aux w m)
end.
Lemma replicate_ok {n a} `{ArithFact (n >= 0)} `{ArithFact (a >= 0)} :
   Z.of_nat (Z.to_nat n * Z.to_nat a) = a * n.
destruct H. destruct H0.
rewrite <- Z2Nat.id; auto with zarith.
rewrite Z2Nat.inj_mul; auto with zarith.
rewrite Nat.mul_comm. reflexivity.
Qed.
Definition replicate_bits {a} (w : mword a) (n : Z) `{ArithFact (n >= 0)} : mword (a * n) :=
 cast_to_mword (replicate_bits_aux (get_word w) (Z.to_nat n)) replicate_ok.

(*val duplicate : forall 'a. Size 'a => bitU -> integer -> mword 'a
Definition duplicate := duplicate_bit_bv

val eq_vec    : forall 'a. Size 'a => mword 'a -> mword 'a -> bool
val neq_vec   : forall 'a. Size 'a => mword 'a -> mword 'a -> bool
val ult_vec   : forall 'a. Size 'a => mword 'a -> mword 'a -> bool
val slt_vec   : forall 'a. Size 'a => mword 'a -> mword 'a -> bool
val ugt_vec   : forall 'a. Size 'a => mword 'a -> mword 'a -> bool
val sgt_vec   : forall 'a. Size 'a => mword 'a -> mword 'a -> bool
val ulteq_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> bool
val slteq_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> bool
val ugteq_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> bool
val sgteq_vec : forall 'a. Size 'a => mword 'a -> mword 'a -> bool*)
Definition eq_vec  {n} (x : mword n) (y : mword n) : bool := Word.weqb (get_word x) (get_word y).
Definition neq_vec {n} (x : mword n) (y : mword n) : bool := negb (eq_vec x y).
(*Definition ult_vec   := ult_bv.
Definition slt_vec   := slt_bv.
Definition ugt_vec   := ugt_bv.
Definition sgt_vec   := sgt_bv.
Definition ulteq_vec := ulteq_bv.
Definition slteq_vec := slteq_bv.
Definition ugteq_vec := ugteq_bv.
Definition sgteq_vec := sgteq_bv.

*)

Definition eq_vec_dec {n} : forall (x y : mword n), {x = y} + {x <> y}.
refine (match n with
| Z0 => _
| Zpos m => _
| Zneg m => _
end).
* simpl. apply Word.weq.
* simpl. apply Word.weq.
* simpl. destruct x.
Defined.

Instance Decidable_eq_mword {n} : forall (x y : mword n), Decidable (x = y) :=
  Decidable_eq_from_dec eq_vec_dec.

Program Fixpoint reverse_endianness_word {n} (bits : word n) : word n :=
  match n with
  | S (S (S (S (S (S (S (S m))))))) =>
    combine
      (reverse_endianness_word (split2 8 m bits))
      (split1 8 m bits)
  | _ => bits
  end.
Next Obligation.
omega.
Qed.

Definition reverse_endianness {n} (bits : mword n) := with_word (P := id) reverse_endianness_word bits.

Definition get_slice_int {a} `{ArithFact (a >= 0)} : Z -> Z -> Z -> mword a := get_slice_int_bv.

Definition set_slice n m (v : mword n) x (w : mword m) : mword n :=
  update_subrange_vec_dec v (x + m - 1) x w.

Definition set_slice_int len n lo (v : mword len) : Z :=
  let hi := lo + len - 1 in
  (* We don't currently have a constraint on lo in the sail prelude, so let's
     avoid one here. *)
  if sumbool_of_bool (Z.gtb hi 0) then
    let bs : mword (hi + 1) := mword_of_int n in
    (int_of_mword true (update_subrange_vec_dec bs hi lo v))
  else n.

(* Variant of bitvector slicing for the ARM model with few constraints *)
Definition slice {m} (v : mword m) lo len `{ArithFact (0 <= len)} : mword len :=
  if sumbool_of_bool (orb (len =? 0) (lo <? 0))
  then zeros len
  else
    if sumbool_of_bool (lo + len - 1 >=? m)
    then if sumbool_of_bool (lo <? m)
         then zero_extend (subrange_vec_dec v (m - 1) lo) len
         else zeros len
    else autocast (subrange_vec_dec v (lo + len - 1) lo).

(*
Lemma slice_is_ok m (v : mword m) lo len
                  (H1 : 0 <= lo) (H2 : 0 < len) (H3: lo + len < m) :
  slice v lo len = autocast (subrange_vec_dec v (lo + len - 1) lo).
unfold slice.
destruct (sumbool_of_bool _).
* exfalso.
  unbool_comparisons.
  omega.
* destruct (sumbool_of_bool _).
  + exfalso.
    unbool_comparisons.
    omega.
  + f_equal.
    f_equal.
*)

Import ListNotations.
Definition count_leading_zeros {N : Z} (x : mword N) `{ArithFact (N >= 1)}
: {n : Z & ArithFact (0 <= n /\ n <= N)} :=
  let r : {n : Z & ArithFact (0 <= n /\ n <= N)} := build_ex N in
  foreach_Z_up 0 (N - 1) 1 r
    (fun i _ r =>
      (if ((eq_vec (vec_of_bits [access_vec_dec x i]  : mword 1) (vec_of_bits [B1]  : mword 1)))
       then build_ex
            (Z.sub (Z.sub (length_mword x) i) 1)
             : {n : Z & ArithFact (0 <= n /\ n <= N)}
       else r))
   .

Definition prerr_bits {a} (s : string) (bs : mword a) : unit := tt.
Definition print_bits {a} (s : string) (bs : mword a) : unit := tt.