From Coq Require Import ssreflect ssrfun ssrbool.

From Equations Require Import Equations.

From stdpp Require Import base pmap gmap fin_maps finite.
From MatchingLogic Require Import Syntax Utils.stdpp_ext.

Require Import String.

Section named.
  Context
    {Σ : Signature}
  .

  Inductive NamedPattern : Set :=
  | npatt_evar (x : evar)
  | npatt_svar (X : svar)
  | npatt_sym (sigma : symbols)
  | npatt_app (phi1 phi2 : NamedPattern)
  | npatt_bott
  | npatt_imp (phi1 phi2 : NamedPattern)
  | npatt_exists (x : evar) (phi : NamedPattern)
  | npatt_mu (X : svar) (phi : NamedPattern)
  .

Fixpoint nsize' (p : NamedPattern) : nat :=
  match p with
  | npatt_app ls rs => 1 + (nsize' ls) + (nsize' rs)
  | npatt_imp ls rs => 1 + (nsize' ls) + (nsize' rs)
  | npatt_exists _ p' => 1 + nsize' p'
  | npatt_mu _ p' => 1 + nsize' p'
  | _ => 1
  end.

  #[global]
  Instance NamedPattern_eqdec : EqDecision NamedPattern.
  Proof. solve_decision. Defined.

  #[global]
  Instance NamedPattern_countable (sc : Countable symbols) : Countable NamedPattern.
Proof.
  set (enc :=
         fix go p : gen_tree (unit
                              + ((@symbols (@ml_symbols Σ))
                                 + (((@evar variables))
                                    + ((@svar variables)))))%type :=
           match p with
           | npatt_bott => GenLeaf (inl ())
           | npatt_sym s => GenLeaf (inr (inl s))
           | npatt_evar x => GenLeaf (inr (inr (inl x)))
           | npatt_svar X => GenLeaf (inr (inr (inr X)))
           | npatt_app p1 p2 => GenNode 0 [go p1; go p2]
           | npatt_imp p1 p2 => GenNode 1 [go p1; go p2]
           | npatt_exists x p' => GenNode 2 [GenLeaf (inr (inr (inl x))); go p']
           | npatt_mu X p' => GenNode 3 [GenLeaf (inr (inr (inr X))); go p']
           end
      ).

  set (dec :=
         fix go (p : gen_tree (unit
                              + ((@symbols (@ml_symbols Σ))
                                 + (((@evar variables) )
                                    + ((@svar variables)))))%type) : NamedPattern :=
           match p with
           | GenLeaf (inl ()) => npatt_bott
           | GenLeaf (inr (inl s)) => npatt_sym s
           | GenLeaf (inr (inr (inl x))) => npatt_evar x
           | GenLeaf (inr (inr (inr X))) => npatt_svar X
           | GenNode 0 [p1; p2] => npatt_app (go p1) (go p2)
           | GenNode 1 [p1; p2] => npatt_imp (go p1) (go p2)
           | GenNode 2 [nx; p'] =>
            match (go nx) with
            | npatt_evar x => npatt_exists x (go p')
            | _ => npatt_bott (* dummy *)
            end
           | GenNode 3 [nX; p']  =>
            match (go nX) with
            | npatt_svar X => npatt_mu X (go p')
            | _ => npatt_bott (* dummy *)
            end
           | _ => npatt_bott (* dummy *)
           end
      ).

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

  Definition EVarMap := gmap db_index evar.
  Definition SVarMap := gmap db_index svar.

  Fixpoint named_free_evars (phi : NamedPattern) : EVarSet :=
    match phi with
    | npatt_evar x => singleton x
    | npatt_svar X => empty
    | npatt_sym sigma => empty
    | npatt_app phi1 phi2 => union (named_free_evars phi1) (named_free_evars phi2)
    | npatt_bott => empty
    | npatt_imp phi1 phi2 => union (named_free_evars phi1) (named_free_evars phi2)
    | npatt_exists x phi => difference (named_free_evars phi) (singleton x)
    | npatt_mu X phi => named_free_evars phi
    end.

  Fixpoint named_free_svars (phi : NamedPattern) : SVarSet :=
    match phi with
    | npatt_evar x => empty
    | npatt_svar X => singleton X
    | npatt_sym sigma => empty
    | npatt_app phi1 phi2 => union (named_free_svars phi1) (named_free_svars phi2)
    | npatt_bott => empty
    | npatt_imp phi1 phi2 => union (named_free_svars phi1) (named_free_svars phi2)
    | npatt_exists x phi => named_free_svars phi
    | npatt_mu X phi => difference (named_free_svars phi) (singleton X)
    end.

    Fixpoint named_evars (phi : NamedPattern) : EVarSet :=
    match phi with
    | npatt_evar x => singleton x
    | npatt_svar X => empty
    | npatt_sym sigma => empty
    | npatt_app phi1 phi2 => union (named_evars phi1) (named_evars phi2)
    | npatt_bott => empty
    | npatt_imp phi1 phi2 => union (named_evars phi1) (named_evars phi2)
    | npatt_exists x phi => union (named_evars phi) (singleton x)
    | npatt_mu X phi => named_evars phi
    end.

  Fixpoint named_svars (phi : NamedPattern) : SVarSet :=
    match phi with
    | npatt_evar x => empty
    | npatt_svar X => singleton X
    | npatt_sym sigma => empty
    | npatt_app phi1 phi2 => union (named_svars phi1) (named_svars phi2)
    | npatt_bott => empty
    | npatt_imp phi1 phi2 => union (named_svars phi1) (named_svars phi2)
    | npatt_exists x phi => named_svars phi
    | npatt_mu X phi => union (named_svars phi) (singleton X)
    end.

  Lemma named_free_evars_subseteq_named_evars ϕ:
    named_free_evars ϕ ⊆ named_evars ϕ.
  Proof.
    induction ϕ; cbn; set_solver.
  Qed.

  Lemma named_free_svars_subseteq_named_svars ϕ:
    named_free_svars ϕ ⊆ named_svars ϕ.
  Proof.
    induction ϕ; cbn; set_solver.
  Qed.

  CoInductive EVarGen := mkEvarGen {
    eg_get : gset evar -> evar ;
    eg_get_correct : forall evs, eg_get evs ∉ evs ;
    eg_next : gset evar -> EVarGen ;
  }.

  Program CoFixpoint default_EVarGen avoid : EVarGen := {|
    eg_get := fun evs => evar_fresh (elements (avoid ∪ evs)) ;
    eg_next := fun evs => default_EVarGen (avoid ∪ evs) ;
  |}.
  Next Obligation.
    intros avoid evs. simpl.
    assert (H: evar_fresh (elements (avoid ∪ evs)) ∉ (avoid ∪ evs)).
    {
      apply set_evar_fresh_is_fresh'.
    }
    set_solver.
  Qed.

  CoInductive SVarGen := mkSvarGen {
    sg_get : gset svar -> svar ;
    sg_get_correct : forall svs, sg_get svs ∉ svs ;
    sg_next : gset svar -> SVarGen ;
  }.

  Program CoFixpoint default_SVarGen avoid : SVarGen := {|
    sg_get := fun svs => svar_fresh (elements (avoid ∪ svs)) ;
    sg_next := fun svs => default_SVarGen (avoid ∪ svs) ;
  |}.
  Next Obligation.
    intros avoid svs. simpl.
    assert (H: svar_fresh (elements (avoid ∪ svs)) ∉ (avoid ∪ svs)).
    {
      apply set_svar_fresh_is_fresh'.
    }
    set_solver.
  Qed.

  Definition eg_getf (eg : EVarGen) (ϕ : NamedPattern) : evar
    := eg_get eg (named_free_evars ϕ)
  .

  Lemma eg_getf_correct (eg : EVarGen) (ϕ : NamedPattern) :
    (eg_getf eg ϕ) ∉ (named_free_evars ϕ)
  .
  Proof.
    apply eg_get_correct.
  Qed.

  Definition eg_nextf (eg : EVarGen) (ϕ : NamedPattern) : EVarGen
    := eg_next eg (named_free_evars ϕ)
  .

  Definition sg_getf (sg : SVarGen) (ϕ : NamedPattern) : svar
    := sg_get sg (named_free_svars ϕ)
  .

  Lemma sg_getf_correct (sg : SVarGen) (ϕ : NamedPattern) :
    (sg_getf sg ϕ) ∉ (named_free_svars ϕ)
  .
  Proof.
    apply sg_get_correct.
  Qed.

  Definition sg_nextf (sg : SVarGen) (ϕ : NamedPattern) : SVarGen
    := sg_next sg (named_free_svars ϕ)
  .

  (* phi[y/x] *)
  Fixpoint rename_free_evar (phi : NamedPattern) (y x : evar) : NamedPattern :=
  match phi with
  | npatt_evar x' => if decide (x = x') is left _ then npatt_evar y else npatt_evar x'
  | npatt_svar X => npatt_svar X
  | npatt_sym sigma => npatt_sym sigma
  | npatt_app phi1 phi2 => npatt_app (rename_free_evar phi1 y x)
                                     (rename_free_evar phi2 y x)
  | npatt_bott => npatt_bott
  | npatt_imp phi1 phi2 => npatt_imp (rename_free_evar phi1 y x)
                                     (rename_free_evar phi2 y x)
  | npatt_exists x' phi'
    => match (decide (x = x')) with
       | left _ => npatt_exists x' phi' (* no-op *)
       | right _ => (
          npatt_exists x' (rename_free_evar phi' y x)
         )
       end
  | npatt_mu X phi'
    => npatt_mu X (rename_free_evar phi' y x)
  end.

  Lemma nsize'_rename_free_evar (ϕ : NamedPattern) (y x : evar) :
    nsize' (rename_free_evar ϕ y x) = nsize' ϕ
  .
  Proof.
    induction ϕ; cbn; repeat case_match; cbn; try reflexivity; lia.
  Qed.

  Lemma rename_free_evar_id (ϕ : NamedPattern) (y x : evar) :
    x ∉ named_free_evars ϕ ->
    rename_free_evar ϕ y x = ϕ
  .
  Proof.
    move: y x.
    induction ϕ; cbn; intros y x' H; try reflexivity.
    {
      destruct (decide (x' = x)).
      { subst. exfalso. set_solver. }
      { reflexivity. }
    }
    {
      rewrite IHϕ1. set_solver.
      rewrite IHϕ2. set_solver.
      reflexivity.
    }
    {
      rewrite IHϕ1. set_solver.
      rewrite IHϕ2. set_solver.
      reflexivity.
    }
    {
      destruct (decide (x' = x));[reflexivity|].
      rewrite IHϕ. set_solver. reflexivity.
    }
    {
      rewrite IHϕ. assumption. reflexivity.
    }
  Qed.

  Lemma rename_free_evar_chain (ϕ : NamedPattern) (z y x : evar) :
    y ∉ named_evars ϕ ->
    rename_free_evar (rename_free_evar ϕ y x) z y
    = rename_free_evar ϕ z x.
  Proof.
    move: z y x.
    remember (nsize' ϕ) as sz.
    assert (Hsz: nsize' ϕ <= sz) by lia.
    clear Heqsz.
    move: ϕ Hsz.
    induction sz; intros ϕ Hsz.
    { destruct ϕ; cbn in Hsz; lia. }
    destruct ϕ; intros z y x' Hfry; cbn in Hsz; cbn in Hfry; cbn; try reflexivity.
    {
      destruct (decide (x' = x)).
      { subst. cbn. rewrite decide_eq_same. reflexivity. }
      { cbn. destruct (decide (y = x));[|reflexivity].
        subst. cbn in Hfry. exfalso. clear -Hfry. set_solver.
      }
    }
    {
      rewrite IHsz.
      { lia. }
      { set_solver. }
      rewrite IHsz.
      { lia. }
      { set_solver. }
      reflexivity.
    }
    {
      rewrite IHsz.
      { lia. }
      { set_solver. }
      rewrite IHsz.
      { lia. }
      { set_solver. }
      reflexivity.
    }
    {
      destruct (decide (x' = x)).
      {
        subst. cbn.
        destruct (decide (y = x));[reflexivity|].
        cbn.
        rewrite rename_free_evar_id.
        {
          pose proof (named_free_evars_subseteq_named_evars ϕ).
          set_solver.
        }
        reflexivity.
      }
      {
        cbn.
        destruct (decide (y = x)).
        { subst. exfalso. clear -Hfry. set_solver. }
        {
          rewrite IHsz.
          { lia. }
          { set_solver. }
          reflexivity.
        }
      }
    }
    {
      rewrite IHsz.
      { lia. }
      { assumption. }
      reflexivity.
    }
  Qed.

  (* phi[Y/X] *)
  Fixpoint rename_free_svar (phi : NamedPattern) (Y X : svar) : NamedPattern :=
  match phi with
  | npatt_svar X' => if decide (X = X') is left _ then npatt_svar Y else npatt_svar X'
  | npatt_evar x => npatt_evar x
  | npatt_sym sigma => npatt_sym sigma
  | npatt_app phi1 phi2 => npatt_app (rename_free_svar phi1 Y X)
                                     (rename_free_svar phi2 Y X)
  | npatt_bott => npatt_bott
  | npatt_imp phi1 phi2 => npatt_imp (rename_free_svar phi1 Y X)
                                     (rename_free_svar phi2 Y X)
  | npatt_mu X' phi'
    => match (decide (X = X')) with
       | left _ => npatt_mu X' phi' (* no-op *)
       | right _ => (
          npatt_mu X' (rename_free_svar phi' Y X)
         )
       end
  | npatt_exists x phi'
    => npatt_exists x (rename_free_svar phi' Y X)
  end.

  Lemma nsize'_rename_free_svar (ϕ : NamedPattern) (Y X : svar) :
    nsize' (rename_free_svar ϕ Y X) = nsize' ϕ
  .
  Proof.
    induction ϕ; cbn; repeat case_match; cbn; try reflexivity; lia.
  Qed.

  Lemma rename_free_svar_id (ϕ : NamedPattern) (Y X : svar) :
    X ∉ named_free_svars ϕ ->
    rename_free_svar ϕ Y X = ϕ
  .
  Proof.
    move: Y X.
    induction ϕ; cbn; intros Y X' H; try reflexivity.
    {
      destruct (decide (X' = X)).
      { subst. exfalso. set_solver. }
      { reflexivity. }
    }
    {
      rewrite IHϕ1. set_solver.
      rewrite IHϕ2. set_solver.
      reflexivity.
    }
    {
      rewrite IHϕ1. set_solver.
      rewrite IHϕ2. set_solver.
      reflexivity.
    }
    {
      rewrite IHϕ. assumption. reflexivity.
    }
    {
      destruct (decide (X' = X));[reflexivity|].
      rewrite IHϕ. set_solver. reflexivity.
    }
  Qed.

  Lemma rename_free_svar_chain (ϕ : NamedPattern) (Z Y X : svar) :
    Y ∉ named_svars ϕ ->
    rename_free_svar (rename_free_svar ϕ Y X) Z Y
    = rename_free_svar ϕ Z X.
  Proof.
    move: Z Y X.
    remember (nsize' ϕ) as sz.
    assert (Hsz: nsize' ϕ <= sz) by lia.
    clear Heqsz.
    move: ϕ Hsz.
    induction sz; intros ϕ Hsz.
    { destruct ϕ; cbn in Hsz; lia. }
    destruct ϕ; intros Z Y X' HfrY; cbn in Hsz; cbn in HfrY; cbn; try reflexivity.
    {
      destruct (decide (X' = X)).
      { subst. cbn. rewrite decide_eq_same. reflexivity. }
      { cbn. destruct (decide (Y = X));[|reflexivity].
        subst. cbn in HfrY. exfalso. clear -HfrY. set_solver.
      }
    }
    {
      rewrite IHsz.
      { lia. }
      { set_solver. }
      rewrite IHsz.
      { lia. }
      { set_solver. }
      reflexivity.
    }
    {
      rewrite IHsz.
      { lia. }
      { set_solver. }
      rewrite IHsz.
      { lia. }
      { set_solver. }
      reflexivity.
    }
    {
      rewrite IHsz.
      { lia. }
      { assumption. }
      reflexivity.
    }
    {
      destruct (decide (X' = X)).
      {
        subst. cbn.
        destruct (decide (Y = X));[reflexivity|].
        cbn.
        rewrite rename_free_svar_id.
        {
          pose proof (named_free_svars_subseteq_named_svars ϕ).
          set_solver.
        }
        reflexivity.
      }
      {
        cbn.
        destruct (decide (Y = X)).
        { subst. exfalso. clear -HfrY. set_solver. }
        {
          rewrite IHsz.
          { lia. }
          { set_solver. }
          reflexivity.
        }
      }
    }
  Qed.

  Equations? named_evar_subst'
    (eg : EVarGen) (sg : SVarGen) (ϕ ψ : NamedPattern) (x : evar) : NamedPattern
    by wf (nsize' ϕ) lt :=
    named_evar_subst' eg sg (npatt_evar x') ψ x with (decide (x = x')) => {
      | left _ := ψ
      | right _ := npatt_evar x'
    } ;
    named_evar_subst' eg sg (npatt_bott) _ _ := npatt_bott ;
    named_evar_subst' eg sg (npatt_svar X) _ _ := npatt_svar X ;
    named_evar_subst' eg sg (npatt_sym s) _ _ := npatt_sym s ;
    named_evar_subst' eg sg (npatt_imp phi1 phi2) ψ x :=
      npatt_imp (named_evar_subst' eg sg phi1 ψ x)
                (named_evar_subst' eg sg phi2 ψ x) ;
    named_evar_subst' eg sg (npatt_app phi1 phi2) ψ x :=
      npatt_app (named_evar_subst' eg sg phi1 ψ x)
                (named_evar_subst' eg sg phi2 ψ x) ;
    named_evar_subst' eg sg (npatt_exists x' ϕ') ψ x with (decide (x = x')) => {
      | right _ := npatt_exists x' ϕ'
      | left _ with (decide (x' ∈ named_free_evars ψ)) => {
        | right _ := npatt_exists x' (named_evar_subst' eg sg ϕ' ψ x)
        | left _ :=
          let avoid := union (named_free_evars ψ) (named_free_evars ϕ') in
          let fresh_x := eg_get eg avoid in
          let renamed_ϕ' := rename_free_evar ϕ' fresh_x x' in
          npatt_exists fresh_x (named_evar_subst' eg sg renamed_ϕ' ψ x)
      }
    } ;
    named_evar_subst' eg sg (npatt_mu X' ϕ') ψ x
    with (decide (X' ∈ named_free_svars ψ)) => {
      | right _ := npatt_mu X' (named_evar_subst' eg sg ϕ' ψ x)
      | left _ :=
        let Avoid := union (named_free_svars ψ) (named_free_svars ϕ') in
        let fresh_X := sg_get sg Avoid in
        let renamed_ϕ' := rename_free_svar ϕ' fresh_X X' in
        npatt_mu fresh_X (named_evar_subst' eg sg renamed_ϕ' ψ x)
    }.
    Proof.
      all: cbn; try lia.
      { unfold renamed_ϕ'. rewrite nsize'_rename_free_evar. lia. }
      { unfold renamed_ϕ'. rewrite nsize'_rename_free_svar. lia. }
    Qed.

  Equations? named_svar_subst'
    (eg : EVarGen) (sg : SVarGen) (ϕ ψ : NamedPattern) (X : svar) : NamedPattern
    by wf (nsize' ϕ) lt :=
    named_svar_subst' eg sg (npatt_svar X') ψ X with (decide (X = X')) => {
      | left _ := ψ
      | right _ := npatt_svar X'
    } ;
    named_svar_subst' eg sg (npatt_bott) _ _ := npatt_bott ;
    named_svar_subst' eg sg (npatt_evar x) _ _ := npatt_evar x ;
    named_svar_subst' eg sg (npatt_sym s) _ _ := npatt_sym s ;
    named_svar_subst' eg sg (npatt_imp phi1 phi2) ψ X :=
      npatt_imp (named_svar_subst' eg sg phi1 ψ X)
                (named_svar_subst' eg sg phi2 ψ X) ;
    named_svar_subst' eg sg (npatt_app phi1 phi2) ψ X :=
      npatt_app (named_svar_subst' eg sg phi1 ψ X)
                (named_svar_subst' eg sg phi2 ψ X) ;
    named_svar_subst' eg sg (npatt_exists x' ϕ') ψ X
    with (decide (x' ∈ named_free_evars ψ)) => {
      | right _ := npatt_exists x' (named_svar_subst' eg sg ϕ' ψ X)
      | left _ :=
        let avoid := union (named_free_evars ψ) (named_free_evars ϕ') in
        let fresh_x := eg_get eg avoid in
        let renamed_ϕ' := rename_free_evar ϕ' fresh_x x' in
        npatt_exists fresh_x (named_svar_subst' eg sg renamed_ϕ' ψ X)
    };
    named_svar_subst' eg sg (npatt_mu X' ϕ') ψ X with (decide (X = X')) => {
      | right _ := npatt_mu X' ϕ'
      | left _ with (decide (X' ∈ named_free_svars ψ)) => {
        | right _ := npatt_mu X' (named_svar_subst' eg sg ϕ' ψ X)
        | left _ :=
          let Avoid := union (named_free_svars ψ) (named_free_svars ϕ') in
          let fresh_X := sg_get sg Avoid in
          let renamed_ϕ' := rename_free_svar ϕ' fresh_X X' in
          npatt_mu fresh_X (named_svar_subst' eg sg renamed_ϕ' ψ X)
      }
    } .
    Proof.
      all: cbn; try lia.
      { unfold renamed_ϕ'. rewrite nsize'_rename_free_evar. lia. }
      { unfold renamed_ϕ'. rewrite nsize'_rename_free_svar. lia. }
    Qed.

  Definition named_evar_subst
    (phi psi : NamedPattern) (x : evar) : NamedPattern
    := named_evar_subst' (default_EVarGen ∅) (default_SVarGen ∅) phi psi x
  .

  Definition named_svar_subst
    (phi psi : NamedPattern) (X : svar) : NamedPattern
    := named_svar_subst' (default_EVarGen ∅) (default_SVarGen ∅) phi psi X
  .

  (* Derived named operators *)
  Definition npatt_not (phi : NamedPattern) := npatt_imp phi npatt_bott.
  Definition npatt_or  (l r : NamedPattern) := npatt_imp (npatt_not l) r.
  Definition npatt_and (l r : NamedPattern) :=
    npatt_not (npatt_or (npatt_not l) (npatt_not r)).
  Definition npatt_top := (npatt_not npatt_bott).
  Definition npatt_iff (l r : NamedPattern) :=
    npatt_and (npatt_imp l r) (npatt_imp r l).
  Definition npatt_forall (phi : NamedPattern) (x : evar) :=
    npatt_not (npatt_exists x (npatt_not phi)).
  Definition npatt_nu (phi : NamedPattern) (X : svar) :=
    npatt_not (npatt_mu X (npatt_not (named_svar_subst phi (npatt_not (npatt_svar X)) X))).

  Check @kmap.
  (* TODO: use kmap. Check kmap. *)
  Definition evm_incr (evm : EVarMap) : EVarMap :=
    kmap S evm.

  Definition svm_incr (svm : SVarMap) : SVarMap :=
    kmap S svm.

  Definition incr_one_evar (phi : Pattern) : Pattern :=
    match phi with
    | patt_bound_evar n => patt_bound_evar (S n)
    | x => x
    end.

  Definition incr_one_svar (phi : Pattern) : Pattern :=
    match phi with
    | patt_bound_svar n => patt_bound_svar (S n)
    | x => x
    end.

  Definition cache_incr_evar (cache : gmap Pattern NamedPattern) : gmap Pattern NamedPattern :=
    kmap incr_one_evar cache.

  Definition cache_incr_svar (cache : gmap Pattern NamedPattern) : gmap Pattern NamedPattern :=
    kmap incr_one_svar cache.

  Definition evm_fresh (evm : EVarMap) (ϕ : Pattern) : evar
    := evar_fresh (elements (free_evars ϕ ∪ (list_to_set (map snd (map_to_list evm))))).

  Definition evs_fresh (evs : EVarSet) (ϕ : Pattern) : evar
    := evar_fresh (elements (free_evars ϕ ∪ evs)).

  Definition svm_fresh (svm : SVarMap) (ϕ : Pattern) : svar
    := svar_fresh (elements (free_svars ϕ ∪ (list_to_set (map snd (map_to_list svm))))).

  Definition svs_fresh (svs : SVarSet) (ϕ : Pattern) : svar
    := svar_fresh (elements (free_svars ϕ ∪ svs)).

  Fixpoint to_NamedPattern' (ϕ : Pattern) (evm : EVarMap) (svm : SVarMap)
    : NamedPattern * EVarMap * SVarMap :=
    match ϕ with
    | patt_free_evar x => (npatt_evar x, evm, svm)
    | patt_free_svar X => (npatt_svar X, evm, svm)
    | patt_bound_evar n =>
      (if (evm !! n) is Some x then npatt_evar x else npatt_bott, evm, svm)
    | patt_bound_svar n =>
      (if (svm !! n) is Some X then npatt_svar X else npatt_bott, evm, svm)
    | patt_sym s => (npatt_sym s, evm, svm)
    | patt_app phi1 phi2 =>
      let: (nphi1, evm', svm') := to_NamedPattern' phi1 evm svm in
      let: (nphi2, evm'', svm'') := to_NamedPattern' phi2 evm' svm' in
      (npatt_app nphi1 nphi2, evm'', svm'')
    | patt_bott => (npatt_bott, evm, svm)
    | patt_imp phi1 phi2 =>
      let: (nphi1, evm', svm') := to_NamedPattern' phi1 evm svm in
      let: (nphi2, evm'', svm'') := to_NamedPattern' phi2 evm' svm' in
      (npatt_imp nphi1 nphi2, evm'', svm'')
    | patt_exists phi =>
      let: x := evm_fresh evm phi in
      let: evm_ex := <[0:=x]>(evm_incr evm) in
      let: (nphi, evm', svm') := to_NamedPattern' phi evm_ex svm in
      (npatt_exists x nphi, evm, svm)
    | patt_mu phi =>
      let: X := svm_fresh svm phi in
      let: svm_ex := <[0:=X]>(svm_incr svm) in
      let: (nphi, evm', svm') := to_NamedPattern' phi evm svm_ex in
      (npatt_mu X nphi, evm, svm)
    end.

  Definition to_NamedPattern (ϕ : Pattern) : NamedPattern :=
    (to_NamedPattern' ϕ ∅ ∅).1.1.

  Definition not_contain_bound_evar_0 ϕ : Prop := ~~ bevar_occur ϕ 0.
  Definition not_contain_bound_svar_0 ϕ : Prop := ~~ bsvar_occur ϕ 0.

  Definition CacheEntry := (Pattern * NamedPattern)%type.

  Definition is_bound_evar (ϕ : Pattern) : Prop := exists b, ϕ = patt_bound_evar b.

  Global Instance is_bound_evar_dec (ϕ : Pattern) : Decision (is_bound_evar ϕ).
  Proof.
    unfold Decision; destruct ϕ; simpl;
      try solve[right; intros [b Hcontra]; inversion Hcontra].
    left. exists n. reflexivity.
  Defined.

  Definition is_bound_evar_entry (ϕnϕ : CacheEntry) : Prop := is_bound_evar (fst ϕnϕ).

  Global Instance is_bound_evar_entry_dec (ce : CacheEntry) : Decision (is_bound_evar_entry ce).
  Proof.
    destruct ce as [ϕ nϕ].
    destruct (decide (is_bound_evar ϕ)) as [L|R].
    - left. destruct L as [dbi Hdbi]. subst ϕ. exists dbi. reflexivity.
    - right. intros Hcontra. inversion Hcontra. simpl in H. subst ϕ.
      apply R. exists x. reflexivity.
  Defined.

  Definition is_bound_svar (ϕ : Pattern) : Prop := exists b, ϕ = patt_bound_svar b.

  Global Instance is_bound_svar_dec (ϕ : Pattern) : Decision (is_bound_svar ϕ).
  Proof.
    unfold Decision; destruct ϕ; simpl;
      try solve[right; intros [b Hcontra]; inversion Hcontra].
    left. exists n. reflexivity.
  Defined.

  Definition is_bound_svar_entry (ϕnϕ : CacheEntry) : Prop := is_bound_svar (fst ϕnϕ).

  Global Instance is_bound_svar_entry_dec (ce : CacheEntry) : Decision (is_bound_svar_entry ce).
  Proof.
    destruct ce as [ϕ nϕ].
    destruct (decide (is_bound_svar ϕ)) as [L|R].
    - left. destruct L as [dbi Hdbi]. subst ϕ. exists dbi. reflexivity.
    - right. intros Hcontra. inversion Hcontra. simpl in H. subst ϕ.
      apply R. exists x. reflexivity.
  Defined.

  Definition keep_bound_evars (cache : gmap Pattern NamedPattern) :=
    filter is_bound_evar_entry cache.

  Definition remove_bound_evars (cache : gmap Pattern NamedPattern) :=
    filter (fun e => ~ is_bound_evar_entry e) cache.

  Definition keep_bound_svars (cache : gmap Pattern NamedPattern) :=
    filter is_bound_svar_entry cache.

  Definition remove_bound_svars (cache : gmap Pattern NamedPattern) :=
    filter (fun e => ~ is_bound_svar_entry e) cache.

  (* pre: all dangling variables of [\phi] are in [cache].  *)
  Fixpoint to_NamedPattern2'
           (ϕ : Pattern)
           (cache : gmap Pattern NamedPattern)
           (used_evars : EVarSet)
           (used_svars : SVarSet)
    : (NamedPattern * (gmap Pattern NamedPattern) * EVarSet * SVarSet)%type :=
    if cache !! ϕ is Some ψ
    then (ψ, cache, used_evars, used_svars)
    else
      let: (ψ, cache', used_evars', used_svars') :=
         match ϕ return (NamedPattern * (gmap Pattern NamedPattern) * EVarSet * SVarSet)%type with
         | patt_bott
           => (npatt_bott, cache, used_evars, used_svars)
         | patt_bound_evar n (* never happens - it is always in cache *)
         | patt_bound_svar n (* the same *)
           => (npatt_bott, cache, used_evars, used_svars)
         | patt_free_evar x
           => (npatt_evar x, cache, used_evars, used_svars)
         | patt_free_svar X
           => (npatt_svar X, cache, used_evars, used_svars)
         | patt_sym s
           => (npatt_sym s, cache, used_evars, used_svars)
         | patt_imp ϕ₁ ϕ₂
           => let: (nϕ₁, cache', used_evars', used_svars')
                 := to_NamedPattern2' ϕ₁ cache used_evars used_svars in
              let: (nϕ₂, cache'', used_evars'', used_svars'')
                 := to_NamedPattern2' ϕ₂ cache' used_evars' used_svars' in
              ((npatt_imp nϕ₁ nϕ₂), cache'', used_evars'', used_svars'')
         | patt_app ϕ₁ ϕ₂
           => let: (nϕ₁, cache', used_evars', used_svars')
                 := to_NamedPattern2' ϕ₁ cache used_evars used_svars in
              let: (nϕ₂, cache'', used_evars'', used_svars'')
                 := to_NamedPattern2' ϕ₂ cache' used_evars' used_svars' in
              ((npatt_app nϕ₁ nϕ₂), cache'', used_evars'', used_svars'')
         | patt_exists phi
           => let: x := evs_fresh used_evars phi in
              let: used_evars_ex := used_evars ∪ {[x]} in
              let: cache_ex := <[patt_bound_evar 0:=npatt_evar x]>(cache_incr_evar cache) in
              let: (nphi, cache', used_evars', used_svars')
                := to_NamedPattern2' phi cache_ex used_evars_ex used_svars in
              let: cache'' := (remove_bound_evars cache') ∪ (keep_bound_evars cache) in
              (npatt_exists x nphi, cache'', used_evars', used_svars)
         | patt_mu phi
           => let: X := svs_fresh used_svars phi in
              let: used_svars_ex := used_svars ∪ {[X]} in
              let: cache_ex := <[patt_bound_svar 0:=npatt_svar X]>(cache_incr_svar cache) in
              let: (nphi, cache', used_evars', used_svars')
                := to_NamedPattern2' phi cache_ex used_evars used_svars_ex in
              let: cache'' := (remove_bound_svars cache') ∪ (keep_bound_svars cache) in
              (npatt_mu X nphi, cache'', used_evars', used_svars)
         end
      in
      (ψ, <[ϕ:=ψ]>cache', used_evars', used_svars).

  Definition to_NamedPattern2 (ϕ : Pattern) : NamedPattern :=
    (to_NamedPattern2' ϕ gmap_empty ∅ ∅).1.1.1.

  Fixpoint named_no_negative_occurrence (X : svar) (ϕ : NamedPattern) : bool :=
    match ϕ with
    | npatt_evar _ | npatt_sym _ | npatt_bott => true
    | npatt_svar Y => true
    | npatt_app ϕ₁ ϕ₂ => named_no_negative_occurrence X ϕ₁ && named_no_negative_occurrence X ϕ₂
    | npatt_imp ϕ₁ ϕ₂ => named_no_positive_occurrence X ϕ₁ && named_no_negative_occurrence X ϕ₂
    | npatt_exists _ ϕ' => named_no_negative_occurrence X ϕ'
    | npatt_mu _ ϕ' => named_no_negative_occurrence X ϕ'
    end
  with
  named_no_positive_occurrence (X : svar) (ϕ : NamedPattern) : bool :=
    match ϕ with
    | npatt_evar _ | npatt_sym _ | npatt_bott => true
    | npatt_svar Y => negb (if decide (X = Y) is left _ then true else false)
    | npatt_app ϕ₁ ϕ₂ => named_no_positive_occurrence X ϕ₁ && named_no_positive_occurrence X ϕ₂
    | npatt_imp ϕ₁ ϕ₂ => named_no_negative_occurrence X ϕ₁ && named_no_positive_occurrence X ϕ₂
    | npatt_exists _ ϕ' => named_no_positive_occurrence X ϕ'
    | npatt_mu _ ϕ' => named_no_positive_occurrence X ϕ'
    end.

  Definition SVarMap_injective_prop (svm : SVarMap) : Prop :=
    forall dbi1 dbi2 X1 X2, svm !! dbi1 = Some X1 -> svm !! dbi2 = Some X2 ->
                            X1 = X2 -> dbi1 = dbi2.

  (* This is very suspicious. *)
  Lemma to_NamedPattern'_SVarMap_injective (evm : EVarMap) (svm : SVarMap) (ϕ : Pattern):
    SVarMap_injective_prop svm ->
    SVarMap_injective_prop (to_NamedPattern' ϕ evm svm).2.
  Proof.
    intros Hinj.
    move: evm svm Hinj.
    induction ϕ; intros evm svm Hinj; simpl; auto.
    - remember (to_NamedPattern' ϕ1 evm svm) as tonϕ1.
      destruct tonϕ1 as [[nphi1 evm'] svm'].
      remember (to_NamedPattern' ϕ2 evm' svm') as tonϕ2.
      destruct tonϕ2 as [[nphi2 evm''] svm''].
      simpl.
      apply (f_equal snd) in Heqtonϕ2. simpl in Heqtonϕ2. subst svm''. apply IHϕ2.
      apply (f_equal snd) in Heqtonϕ1. simpl in Heqtonϕ1. subst svm'. apply IHϕ1.
      exact Hinj.
    - remember (to_NamedPattern' ϕ1 evm svm) as tonϕ1.
      destruct tonϕ1 as [[nphi1 evm'] svm'].
      remember (to_NamedPattern' ϕ2 evm' svm') as tonϕ2.
      destruct tonϕ2 as [[nphi2 evm''] svm''].
      simpl.
      apply (f_equal snd) in Heqtonϕ2. simpl in Heqtonϕ2. subst svm''. apply IHϕ2.
      apply (f_equal snd) in Heqtonϕ1. simpl in Heqtonϕ1. subst svm'. apply IHϕ1.
      exact Hinj.
    - remember (to_NamedPattern' ϕ (<[0:=evm_fresh evm ϕ]> (evm_incr evm)) svm) as tonϕ.
      destruct tonϕ as [[nphi evm'] svm'].
      simpl.
      exact Hinj.
    - remember (to_NamedPattern' ϕ evm (<[0:=svm_fresh svm ϕ]> (svm_incr svm))) as tonϕ.
      destruct tonϕ as [[nphi evm'] svm'].
      simpl.
      apply Hinj.
  Qed.

  Lemma to_NamedPattern'_occurrence
        (evm : EVarMap) (svm : SVarMap) (X : svar) (dbi : db_index) (ϕ : Pattern):
    SVarMap_injective_prop svm ->
    svm !! dbi = Some X ->
    svar_is_fresh_in X ϕ ->
    named_no_negative_occurrence X (to_NamedPattern' ϕ evm svm).1.1 = no_negative_occurrence_db_b dbi ϕ
    /\ named_no_positive_occurrence X (to_NamedPattern' ϕ evm svm).1.1 = no_positive_occurrence_db_b dbi ϕ.
  Proof.
    intros Hinj Hdbi Hfresh.
    move: evm svm Hinj Hdbi.
    induction ϕ; intros evm svm Hinj Hdbi.
    - unfold no_negative_occurrence_db_b, no_positive_occurrence_db_b; simpl.
      split; reflexivity.
    - unfold no_negative_occurrence_db_b, no_positive_occurrence_db_b; simpl.
      split; [reflexivity|]. unfold svar_is_fresh_in in Hfresh. simpl in Hfresh.
      apply not_elem_of_singleton_1 in Hfresh.
      destruct (decide (X = x)); [contradiction|].
      reflexivity.
    - unfold no_negative_occurrence_db_b, no_positive_occurrence_db_b; simpl.
      destruct (evm !! n); simpl; split; reflexivity.
    - unfold no_negative_occurrence_db_b, no_positive_occurrence_db_b; simpl.
      destruct (decide (n = dbi)).
      + subst. rewrite Hdbi. simpl. split; [reflexivity|].
        destruct (decide (X = X)); [|contradiction].
        simpl.
        reflexivity.
      + pose proof (Hneq := n0).
        apply Nat.eqb_neq in n0.
        remember (svm !! n) as svm_n.
        destruct svm_n; split; try reflexivity.
        simpl.
        symmetry in Heqsvm_n.
        specialize (Hinj n dbi s X Heqsvm_n Hdbi).
        unfold not in Hneq.
        destruct (decide (X = s)); auto.
    - unfold no_negative_occurrence_db_b, no_positive_occurrence_db_b; simpl.
      split; reflexivity.
    - feed specialize IHϕ1.
      { eapply svar_is_fresh_in_app_l. apply Hfresh. }
      feed specialize IHϕ2.
      { eapply svar_is_fresh_in_app_r. apply Hfresh. }
      clear Hfresh.

      simpl.
      remember (to_NamedPattern' ϕ1 evm svm) as tnϕ1.
      destruct tnϕ1 as [[nphi1 evm'] svm'].
      remember (to_NamedPattern' ϕ2 evm' svm') as tnϕ2.
      destruct tnϕ2 as [[nphi2 evm''] svm''].
      simpl.

      (* For some reason, simpl did not simplify this. So we unfold and fold manually. *)
      unfold no_negative_occurrence_db_b.
      fold (no_negative_occurrence_db_b dbi ϕ1).
      fold (no_negative_occurrence_db_b dbi ϕ2).

      (* The same. *)
      unfold no_positive_occurrence_db_b.
      fold (no_positive_occurrence_db_b dbi ϕ1).
      fold (no_positive_occurrence_db_b dbi ϕ2).

      pose proof (IHϕ10 := IHϕ1 evm svm Hinj Hdbi).
      rewrite -Heqtnϕ1 in IHϕ10. simpl in IHϕ10. destruct IHϕ10 as [IHϕ11 IHϕ12].

      (* TODO: prove that a call to [to_NamedPattern'] preserves injectivity. *)
      (*
      pose proof (IHϕ20 := IHϕ2 evm' svm' Hinj Hdbi).

      rewrite -Heqtnϕ2 in IHϕ20.
      destruct IHϕ20 as [IHϕ21 IHϕ22].

      (* simpl in , IHϕ21, IHϕ22. *)
      simpl in IHϕ11, IHϕ12.
      rewrite IHϕ11 IHϕ12.
      rewrite -Heqtnϕ2 in IHϕ21.
       *)
  Abort.

  Fixpoint named_well_formed_positive (phi : NamedPattern) : bool :=
    match phi with
    | npatt_evar _ => true
    | npatt_svar _ => true
    | npatt_sym _ => true
    | npatt_app psi1 psi2 => named_well_formed_positive psi1 && named_well_formed_positive psi2
    | npatt_bott => true
    | npatt_imp psi1 psi2 => named_well_formed_positive psi1 && named_well_formed_positive psi2
    | npatt_exists _ psi => named_well_formed_positive psi
    | npatt_mu X psi => named_no_negative_occurrence X psi && named_well_formed_positive psi
    end.

  Definition named_well_formed := named_well_formed_positive.

  Inductive Named_Application_context : Type :=
  | nbox
  | nctx_app_l (cc : Named_Application_context) (p : NamedPattern) (Prf : named_well_formed p)
  | nctx_app_r (p : NamedPattern) (cc : Named_Application_context) (Prf : named_well_formed p)
  .

  Fixpoint named_subst_ctx (C : Named_Application_context) (p : NamedPattern)
    : NamedPattern :=
    match C with
    | nbox => p
    | @nctx_app_l C' p' prf => npatt_app (named_subst_ctx C' p) p'
    | @nctx_app_r p' C' prf => npatt_app p' (named_subst_ctx C' p)
    end.

(*
  Print well_formed_positive.

  Inductive NML_proof_system (theory : propset NamedPattern) :
    NamedPattern -> Set :=

  (* Hypothesis *)
  | hypothesis (axiom : Pattern) :
      well_formed axiom ->
      (axiom ∈ theory) -> theory ⊢ axiom

  (* FOL reasoning *)
  (* Propositional tautology *)
  | P1 (phi psi : Pattern) :
      well_formed phi -> well_formed psi ->
      theory ⊢ (phi ---> (psi ---> phi))
  | P2 (phi psi xi : Pattern) :
      well_formed phi -> well_formed psi -> well_formed xi ->
      theory ⊢ ((phi ---> (psi ---> xi)) ---> ((phi ---> psi) ---> (phi ---> xi)))
  | P3 (phi : Pattern) :
      well_formed phi ->
      theory ⊢ (((phi ---> Bot) ---> Bot) ---> phi)

  (* Modus ponens *)
  | Modus_ponens (phi1 phi2 : Pattern) :
      well_formed phi1 -> well_formed (phi1 ---> phi2) ->
      theory ⊢ phi1 ->
      theory ⊢ (phi1 ---> phi2) ->
      theory ⊢ phi2

  (* Existential quantifier *)
  | Ex_quan (phi : Pattern) (y : evar) :
      theory ⊢ (instantiate (patt_exists phi) (patt_free_evar y) ---> (patt_exists phi))

  (* Existential generalization *)
  | Ex_gen (phi1 phi2 : Pattern) (x : evar) :
      well_formed phi1 -> well_formed phi2 ->
      theory ⊢ (phi1 ---> phi2) ->
      x ∉ (free_evars phi2) ->
      theory ⊢ (exists_quantify x phi1 ---> phi2)

  (* Frame reasoning *)
  (* Propagation bottom *)
  | Prop_bott_left (phi : Pattern) :
      well_formed phi ->
      theory ⊢ (patt_bott $ phi ---> patt_bott)

  | Prop_bott_right (phi : Pattern) :
      well_formed phi ->
      theory ⊢ (phi $ patt_bott ---> patt_bott)

  (* Propagation disjunction *)
  | Prop_disj_left (phi1 phi2 psi : Pattern) :
      well_formed phi1 -> well_formed phi2 -> well_formed psi ->
      theory ⊢ (((phi1 or phi2) $ psi) ---> ((phi1 $ psi) or (phi2 $ psi)))

  | Prop_disj_right (phi1 phi2 psi : Pattern) :
      well_formed phi1 -> well_formed phi2 -> well_formed psi ->
      theory ⊢ ((psi $ (phi1 or phi2)) ---> ((psi $ phi1) or (psi $ phi2)))

  (* Propagation exist *)
  | Prop_ex_left (phi psi : Pattern) :
      well_formed (ex , phi) -> well_formed psi ->
      theory ⊢ (((ex , phi) $ psi) ---> (ex , phi $ psi))

  | Prop_ex_right (phi psi : Pattern) :
      well_formed (ex , phi) -> well_formed psi ->
      theory ⊢ ((psi $ (ex , phi)) ---> (ex , psi $ phi))

  (* Framing *)
  | Framing_left (phi1 phi2 psi : Pattern) :
      theory ⊢ (phi1 ---> phi2) ->
      theory ⊢ ((phi1 $ psi) ---> (phi2 $ psi))

  | Framing_right (phi1 phi2 psi : Pattern) :
      theory ⊢ (phi1 ---> phi2) ->
      theory ⊢ ((psi $ phi1) ---> (psi $ phi2))

  (* Fixpoint reasoning *)
  (* Set Variable Substitution *)
  | Svar_subst (phi psi : Pattern) (X : svar) :
      well_formed phi -> well_formed psi ->
      theory ⊢ phi -> theory ⊢ (free_svar_subst phi psi X)

  (* Pre-Fixpoint *)
  | Pre_fixp (phi : Pattern) :
      theory ⊢ (instantiate (patt_mu phi) (patt_mu phi) ---> (patt_mu phi))

  (* Knaster-Tarski *)
  | Knaster_tarski (phi psi : Pattern) :
      theory ⊢ ((instantiate (patt_mu phi) psi) ---> psi) ->
      theory ⊢ ((@patt_mu signature phi) ---> psi)

  (* Technical rules *)
  (* Existence *)
  | Existence : theory ⊢ (ex , patt_bound_evar 0)

  (* Singleton *)
  | Singleton_ctx (C1 C2 : Application_context) (phi : Pattern) (x : evar) :
      theory ⊢ (¬ ((subst_ctx C1 (patt_free_evar x and phi)) and
                   (subst_ctx C2 (patt_free_evar x and (¬ phi)))))

  where "theory ⊢ pattern" := (ML_proof_system theory pattern).

*)

End named.

Section named_test.

  Definition StringMLVariables : MLVariables :=
    {| evar := string;
       svar := string;
    |}.

  Inductive Symbols : Set := a.
  Instance Symbols_dec : EqDecision Symbols.
  Proof.
    unfold EqDecision. intros x y. unfold Decision.
    repeat decide equality.
  Defined.

  #[local]
  Program Instance Symbols_fin : Finite Symbols
  := {|
    enum := [a];
  |}.
  Next Obligation.
    repeat constructor; set_solver.
  Qed.
  Next Obligation.
    intros []. set_solver.
  Qed.

  Definition sig : Signature :=
    {| variables := StringMLVariables;
       ml_symbols := {|
         symbols := Symbols;
         sym_eqdec := Symbols_dec;
       |} ;
    |}.

  (* Consider the following pattern in locally nameless representation:
       ex, ex, 0 ---> ex, 0
     When we convert this to a named pattern, we want to maintain the invariant
     that identical subterms are equivalent using normal equalty. Specifically,
     the `ex, 0` terms appearing on both sides of the implication should be
     converted to identical named patterns. However, when we convert the above
     pattern using `to_NamedPattern`, we get
       ex x0, ex x1, x1 ---> ex x0, x0
     Now, we have no identical subterms on both sides of the implication.
     However, using `to_Named_Pattern2` on the same initial pattern, we get
       ex x0, ex x1, x1 ---> ex x1, x1
     This time, we maintain the identical subterm invariant.
     This example is shown below, along with an analogous version for mu patterns.
  *)
  Definition phi_ex1 := (@patt_exists sig (patt_exists (patt_bound_evar 0))).
  Definition phi_ex2 := (@patt_exists sig (patt_bound_evar 0)).
  Definition phi_ex := (patt_imp phi_ex1 phi_ex2).
  Compute to_NamedPattern phi_ex.
  Compute to_NamedPattern2 phi_ex.

  Compute to_NamedPattern2 (@patt_mu sig (patt_mu (patt_bound_svar 1))).

  Compute to_NamedPattern2 (@patt_mu sig (patt_imp (patt_mu (patt_bound_svar 1)) (patt_bound_svar 0))).

  Definition phi_mu1 := (@patt_mu sig (patt_mu (patt_bound_svar 0))).
  Definition phi_mu2 := (@patt_mu sig (patt_bound_svar 0)).
  Definition phi_mu := (patt_imp phi_mu1 phi_mu2).
  Compute to_NamedPattern phi_mu.
  Compute to_NamedPattern2 phi_mu.

End named_test.


From ASUB Require Import core util.
From MetaCoq.Template Require Import utils All.
Import ListNotations MonadNotation Nat.

(* Inductive ty : Type := *)
(* | var_ty : nat -> ty *)
(* | arr : ty -> ty -> ty *)
(* | allt : ty -> ty.  *)

MetaCoq Quote Definition nat_q := nat.

Definition ty_i : one_inductive_entry :=
{|
  mind_entry_typename := "ty";
  mind_entry_arity := tSort Universe.type0;
  mind_entry_consnames := ["var_ty"; "att"; "allt"];
  mind_entry_lc := [mkArr nat_q [tRel 1]; mkArr (tRel 0) [tRel 1; tRel 2]; mkArr (tRel 0) [tRel 1]];
|}.

Definition ty_mi : mutual_inductive_entry :=
{|
  mind_entry_record := None;
  mind_entry_finite := Finite;
  mind_entry_params := [];
  mind_entry_inds := [ty_i];
  mind_entry_universes := Monomorphic_entry (LevelSet.empty, ConstraintSet.empty);
  mind_entry_template := false;
  mind_entry_variance := None;
  mind_entry_private := None;
|}.

(* MetaCoq Unquote Inductive ty_mi. *)
(* MetaCoq Quote Definition ty_q := ty. *)

(* Inductive tm : Type := *)
(*   | app : tm -> tm -> tm *)
(*   | tapp : tm -> ty -> tm *)
(*   | vt : vl -> tm *)
(* with vl : Type := *)
(*   | var_vl : nat -> vl *)
(*   | lam : ty -> tm -> vl *)
(*   | tlam : tm -> vl. *)

Definition tm_i (ty_q: term): one_inductive_entry :=
{|
  mind_entry_typename := "tm";
  mind_entry_arity := tSort Universe.type0;
  mind_entry_consnames := ["app"; "tapp"; "vt"];
  mind_entry_lc := [mkArr (tRel 1) [tRel 2; tRel 3]; mkArr (tRel 1) [ty_q; tRel 3]; mkArr (tRel 0) [tRel 2]];
|}.

Definition vl_i (ty_q: term): one_inductive_entry :=
{|
  mind_entry_typename := "vl";
  mind_entry_arity := tSort Universe.type0;
  mind_entry_consnames := ["var_vl"; "lam"; "tlam"];
  mind_entry_lc := [mkArr nat_q [tRel 1]; mkArr ty_q [tRel 2; tRel 2]; mkArr (tRel 1) [tRel 1]];
|}.

Definition tmvl_mi (ty_q: term) : mutual_inductive_entry :=
{|
  mind_entry_record := None;
  mind_entry_finite := Finite;
  mind_entry_params := [];
  mind_entry_inds := [tm_i ty_q; vl_i ty_q];
  mind_entry_universes := Monomorphic_entry (LevelSet.empty, ConstraintSet.empty);
  mind_entry_template := false;
  mind_entry_variance := None;
  mind_entry_private := None;
|}.

(* MetaCoq Unquote Inductive tmvl_mi. *)

(* MetaCoq Quote Definition tm_q := tm. *)
(* MetaCoq Quote Definition vl_q := vl. *)

Definition getInductiveRef (q:qualid) :=
  kn <- tmLocate1 q;;
  match kn with
  | IndRef ind => tmReturn (tInd ind [])
  | _ => tmFail "not an inductive"
  end.

Definition mkInds : TemplateMonad unit :=
  tmMkInductive ty_mi;;
  ty_q <- getInductiveRef "ty";;
  tmMkInductive (tmvl_mi ty_q);;
  tmReturn tt.

MetaCoq Run mkInds.

From MetaCoq.PCUIC Require PCUICAst.

Module dominate.

  Definition test_i : one_inductive_entry :=
    {|
    mind_entry_typename := "T";
    mind_entry_arity := tSort Universe.type0;
    mind_entry_consnames := ["C"];
    mind_entry_lc := [tProd {| binder_name := BasicAst.nNamed "X"; binder_relevance:= BasicAst.Relevant |} (tSort Universe.type0) (tRel 0) ];
    |}.

  Definition test_mi : mutual_inductive_entry :=
    {|
    mind_entry_record := None;
    mind_entry_finite := Finite;
    mind_entry_params := [];
    mind_entry_inds := [test_i];
    mind_entry_universes := Monomorphic_entry (LevelSet.empty, ConstraintSet.empty);
    mind_entry_template := false;
    mind_entry_variance := None;
    mind_entry_private := None;
    |}.

  Fail MetaCoq Unquote Inductive test_mi.
End dominate.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import machine_int.
Require Import mips_cmd.
Local Open Scope mips_cmd_scope.
Import expr_m.

Definition multi_double_u k a i tmp prev next :=
  addiu i r0 zero16 ;
  addiu prev r0 zero16 ;
  While (bne i k) {{
    lwxs tmp i a ;
    srl next tmp thirtyone5 ;
    sll tmp tmp one5 ;
    cmd_or tmp tmp prev ;
    addiu prev next zero16 ;
    sll next i two5 ;
    addu next a next ;
    sw tmp zero16 next ;
    addiu i i one16 }}.


From CoqMTL Require Import Control.All.
From CoqMTL Require Import Control.Monad.Class.All.

From CoqMTL Require Import Misc.Monoid.

(** [RWS W R S] is a monad which models a computation that can access
    a read-only environment, a write-only log and a single cell of
    read-write memory.

    Note that, somewhat contrary to the name, the order of arguments
    is first the log type [W], then the environment type [R] and finally
    the state type [S]. *)
Definition RWS (W : Monoid) (R S A : Type) : Type :=
  R -> S -> A * S * W.

(** We can map over such a computation by running it and applying a function
    to the result while passing along the state and log it produced. *)
Definition fmap_RWS
  {W : Monoid} {R S A B : Type}
  (f : A -> B) (m : RWS W R S A) : RWS W R S B :=
    fun r s =>
      let
        '(a, s', w) := m r s
      in
        (f a, s', w).

#[global] Hint Unfold fmap_RWS : CoqMTL.

#[refine]
#[export]
Instance Functor_RWS (W : Monoid) (R S : Type) : Functor (RWS W R S) :=
{
  fmap := @fmap_RWS W R S;
}.
Proof. all: unfold compose; monad. Defined.

(** We can inject a value into this monad without touching the state or
    writing to the log. *)
Definition pure_RWS {W : Monoid} {R S A : Type} (x : A) : RWS W R S A :=
  fun _ s => (x, s, neutr).

(** We can apply a computation to another computation by running them in
    order, applying the result function to the argument, passing along
    the state of the argument and concatenating the logs. *)
Definition ap_RWS
  {W : Monoid} {R S A B : Type}
  (mf : RWS W R S (A -> B)) (mx : RWS W R S A) : RWS W R S B :=
    fun r s =>
      let '(f, sf, wf) := mf r s in
      let '(x, sx, wx) := mx r sf in (f x, sx, op wf wx).

#[global] Hint Unfold pure_RWS ap_RWS : CoqMTL.

#[refine]
#[export]
Instance Applicative_RWS
  (W : Monoid) (R S : Type) : Applicative (RWS W R S) :=
{
  is_functor := Functor_RWS W R S;
  pure := @pure_RWS W R S;
  ap := @ap_RWS W R S;
}.
Proof. all: monad. Defined.

(** [Reader] and [Writer] have a commutative [ap], but [State] does not,
    so neither does [RWS]. *)
Lemma RWS_not_CommutativeApplicative :
  ~ (forall (W : Monoid) (R S : Type),
      CommutativeApplicative _ (Applicative_RWS W R S)).
Proof.
  intro. destruct (H (Monoid_list_app bool) unit unit).
  unfold RWS in ap_comm.
  specialize (ap_comm nat nat nat (fun _ => id)
    (fun _ _ => (42, tt, [true; false]))
    (fun _ _ => (43, tt, [false; true]))).
  compute in ap_comm. do 2 apply (f_equal (fun f => f tt)) in ap_comm.
  inv ap_comm.
Qed.

(** None of its components is [Alternative], so [RWS] is neither. *)
Lemma RWS_not_Alternative :
  forall (W : Monoid) (R S : Type),
    R -> S -> Alternative (RWS W R S) -> False.
Proof.
  destruct 3. destruct (aempty False) as [[f _] _]; assumption.
Qed.

(** We can sequence two computations by running them in order,
    applying the function to the argument, passing along the
    state of the argument and concatenating the logs. *)
Definition bind_RWS
  {W : Monoid} {R S A B : Type}
  (mx : RWS W R S A) (mf : A -> RWS W R S B) : RWS W R S B :=
    fun r s =>
      let '(x, sx, wx) := mx r s in
      let '(b, sb, wb) := mf x r sx in (b, sb, op wx wb).

#[global] Hint Unfold bind_RWS : CoqMTL.

#[refine]
#[export]
Instance Monad_RWS
  (W : Monoid) (R S : Type) : Monad (RWS W R S) :=
{
  is_applicative := Applicative_RWS W R S;
  bind := @bind_RWS W R S;
}.
Proof. all: monad. Defined.

(** [RWS W R S] has instances corresponding to all three of its effects. *)

#[refine]
#[export]
Instance MonadReader_RWS
  (W : Monoid) (R S : Type)
  : MonadReader R (RWS W R S) (Monad_RWS W R S) :=
{
  ask := fun r s => (r, s, neutr);
}.
Proof. hs. Defined.

#[refine]
#[export]
Instance MonadWriter_RWS
  (W : Monoid) (R S : Type) : MonadWriter W (RWS W R S) (Monad_RWS W R S) :=
{
  tell := fun w => fun r s => (tt, s, w);
  listen :=
    fun A m => fun r s =>
      let '(a, s, w) := m r s in (a, w, s, neutr);
}.
Proof. all: hs; monad. Defined.

#[refine]
#[export]
Instance MonadState_RWS
  (W : Monoid) (R S : Type) : MonadState S (RWS W R S) (Monad_RWS W R S) :=
{
  get := fun _ (s : S) => (s, s, neutr);
  put := fun s : S => fun _ _ => (tt, s, neutr);
}.
Proof. all: monad. Defined.


(* TODO: try to prove LEM for Set.
*)

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

(** Diaconescu showed that the Axiom of Choice entails Excluded-Middle
   in topoi [[Diaconescu75]]. Lacas and Werner adapted the proof to show
   that the axiom of choice in equivalence classes entails
   Excluded-Middle in Type Theory [[LacasWerner99]].

   Three variants of Diaconescu's result in type theory are shown below.

   A. A proof that the relational form of the Axiom of Choice +
      Extensionality for Predicates entails Excluded-Middle (by Hugo
      Herbelin)

   B. A proof that the relational form of the Axiom of Choice + Proof
      Irrelevance entails Excluded-Middle for Equality Statements (by
      Benjamin Werner)

   C. A proof that extensional Hilbert epsilon's description operator
      entails excluded-middle (taken from Bell [[Bell93]])

   See also [[Carlström04]] for a discussion of the connection between the
   Extensional Axiom of Choice and Excluded-Middle

   [[Diaconescu75]] Radu Diaconescu, Axiom of Choice and Complementation,
   in Proceedings of AMS, vol 51, pp 176-178, 1975.

   [[LacasWerner99]] Samuel Lacas, Benjamin Werner, Which Choices imply
   the excluded middle?, preprint, 1999.

   [[Bell93]] John L. Bell, Hilbert's epsilon operator and classical
   logic, Journal of Philosophical Logic, 22: 1-18, 1993

   [[Carlström04]] Jesper Carlström, EM + Ext_ + AC_int is equivalent
   to AC_ext, Mathematical Logic Quaterly, vol 50(3), pp 236-240, 2004.
*)
Require ClassicalFacts ChoiceFacts.

(**********************************************************************)
(** * Pred. Ext. + Rel. Axiom of Choice -> Excluded-Middle       *)

Section PredExt_RelChoice_imp_EM.

(** The axiom of extensionality for predicates *)

Definition PredicateExtensionality :=
  forall P Q:bool -> Prop, (forall b:bool, P b <-> Q b) -> P = Q.

(** From predicate extensionality we get propositional extensionality
   hence proof-irrelevance *)

Import ClassicalFacts.

Variable pred_extensionality : PredicateExtensionality.

Lemma prop_ext : forall A B:Prop, (A <-> B) -> A = B.
Proof.
  intros A B H.
  change ((fun _ => A) true = (fun _ => B) true).
  rewrite
   pred_extensionality with (P := fun _:bool => A) (Q := fun _:bool => B).
    reflexivity.
    intros _; exact H.
Qed.

Lemma proof_irrel : forall (A:Prop) (a1 a2:A), a1 = a2.
Proof.
  apply (ext_prop_dep_proof_irrel_cic prop_ext).
Qed.

(** From proof-irrelevance and relational choice, we get guarded
   relational choice *)

Import ChoiceFacts.

Variable rel_choice : RelationalChoice.

Lemma guarded_rel_choice : GuardedRelationalChoice.
Proof.
 apply
  (rel_choice_and_proof_irrel_imp_guarded_rel_choice rel_choice proof_irrel).
Qed.

(** The form of choice we need: there is a functional relation which chooses
    an element in any non empty subset of bool *)

Import Bool.

Lemma AC_bool_subset_to_bool :
  exists R : (bool -> Prop) -> bool -> Prop,
   (forall P:bool -> Prop,
      (exists b : bool, P b) ->
       exists b : bool, P b /\ R P b /\ (forall b':bool, R P b' -> b = b')).
Proof.
  destruct (guarded_rel_choice _ _
   (fun Q:bool -> Prop =>  exists y : _, Q y)
   (fun (Q:bool -> Prop) (y:bool) => Q y)) as (R,(HRsub,HR)).
    exact (fun _ H => H).
  exists R; intros P HP.
  destruct (HR P HP) as (y,(Hy,Huni)).
  exists y; firstorder.
Qed.

(** The proof of the excluded middle *)
(** Remark: P could have been in Set or Type *)

Theorem pred_ext_and_rel_choice_imp_EM : forall P:Set, P + (P->False).
Proof.
intro P.

(* first we exhibit the choice functional relation R *)
destruct AC_bool_subset_to_bool as [R H].

set (class_of_true := fun b => b = true \/ P).
set (class_of_false := fun b => b = false \/ P).

(* the actual "decision": is (R class_of_true) = true or false? *)
destruct (H class_of_true) as [b0 [H0 [H0' H0'']]].
exists true; left; reflexivity.
destruct H0.

(* the actual "decision": is (R class_of_false) = true or false? *)
destruct (H class_of_false) as [b1 [H1 [H1' H1'']]].
exists false; left; reflexivity.
destruct H1.

(* case where P is false: (R class_of_true)=true /\ (R class_of_false)=false *)
right.
intro HP.
assert (Hequiv : forall b:bool, class_of_true b <-> class_of_false b).
intro b; split.
unfold class_of_false; right; assumption.
unfold class_of_true; right; assumption.
assert (Heq : class_of_true = class_of_false).
apply pred_extensionality with (1 := Hequiv).
apply diff_true_false.
rewrite <- H0.
rewrite <- H1.
rewrite <- H0''. reflexivity.
rewrite Heq.
assumption.

(* cases where P is true *)
left; assumption.
left; assumption.

Qed.

End PredExt_RelChoice_imp_EM.

(**********************************************************************)
(** * Proof-Irrel. + Rel. Axiom of Choice -> Excl.-Middle for Equality *)

(** This is an adaptation of Diaconescu's theorem, exploiting the
    form of extensionality provided by proof-irrelevance *)

Section ProofIrrel_RelChoice_imp_EqEM.

Import ChoiceFacts.

Variable rel_choice : RelationalChoice.

Variable proof_irrelevance : forall P:Prop , forall x y:P, x=y.

(** Let [a1] and [a2] be two elements in some type [A] *)

Variable A :Type.
Variables a1 a2 : A.

(** We build the subset [A'] of [A] made of [a1] and [a2] *)

Definition A' := @sigT A (fun x => x=a1 \/ x=a2).

Definition a1':A'.
exists a1 ; auto.
Defined.

Definition a2':A'.
exists a2 ; auto.
Defined.

(** By proof-irrelevance, projection is a retraction *)

Lemma projT1_injective : a1=a2 -> a1'=a2'.
Proof.
  intro Heq ; unfold a1', a2', A'.
  rewrite Heq.
  replace (or_introl (a2=a2) (eq_refl a2))
     with (or_intror (a2=a2) (eq_refl a2)).
  reflexivity.
  apply proof_irrelevance.
Qed.

(** But from the actual proofs of being in [A'], we can assert in the
    proof-irrelevant world the existence of relevant boolean witnesses *)

Lemma decide : forall x:A', exists y:bool ,
  (projT1 x = a1 /\ y = true ) \/ (projT1 x = a2 /\ y = false).
Proof.
  intros [a [Ha1|Ha2]]; [exists true | exists false]; auto.
Qed.

(** Thanks to the axiom of choice, the boolean witnesses move from the
    propositional world to the relevant world *)

Theorem proof_irrel_rel_choice_imp_eq_dec : a1=a2 \/ ~a1=a2.
Proof.
  destruct
    (rel_choice A' bool
       (fun x y =>  projT1 x = a1 /\ y = true \/ projT1 x = a2 /\ y = false))
    as (R,(HRsub,HR)).
    apply decide.
  destruct (HR a1') as (b1,(Ha1'b1,_Huni1)).
  destruct (HRsub a1' b1 Ha1'b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2') as (b2,(Ha2'b2,Huni2)).
  destruct (HRsub a2' b2 Ha2'b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2.
    rewrite (projT1_injective H) in Ha1'b1.
    assert (false = true) by auto using Huni2.
    discriminate.
  left; assumption.
Qed.

(** An alternative more concise proof can be done by directly using
    the guarded relational choice *)

Declare Implicit Tactic auto.

Lemma proof_irrel_rel_choice_imp_eq_dec' : a1=a2 \/ ~a1=a2.
Proof.
  assert (decide: forall x:A, x=a1 \/ x=a2 ->
                exists y:bool, x=a1 /\ y=true \/ x=a2 /\ y=false).
    intros a [Ha1|Ha2]; [exists true | exists false]; auto.
  assert (guarded_rel_choice :=
          rel_choice_and_proof_irrel_imp_guarded_rel_choice
	  rel_choice
	  proof_irrelevance).
  destruct
    (guarded_rel_choice A bool
      (fun x => x=a1 \/ x=a2)
      (fun x y => x=a1 /\ y=true \/ x=a2 /\ y=false))
      as (R,(HRsub,HR)).
      apply decide.
  destruct (HR a1) as (b1,(Ha1b1,_Huni1)). left; reflexivity.
  destruct (HRsub a1 b1 Ha1b1) as [(_, Hb1true)|(Ha1a2, _Hb1false)].
  destruct (HR a2) as (b2,(Ha2b2,Huni2)). right; reflexivity.
  destruct (HRsub a2 b2 Ha2b2) as [(Ha2a1, _Hb2true)|(_, Hb2false)].
    left; symmetry; assumption.
    right; intro H.
    subst b1; subst b2; subst a1.
    assert (false = true) by auto using Huni2, Ha1b1.
    discriminate.
  left; assumption.
Qed.

End ProofIrrel_RelChoice_imp_EqEM.

(**********************************************************************)
(** * Extensional Hilbert's epsilon description operator -> Excluded-Middle *)

(** Proof sketch from Bell [[Bell93]] (with thanks to P. Castéran) *)

Local Notation inhabited A := A (only parsing).

Section ExtensionalEpsilon_imp_EM.

Variable epsilon : forall A : Type, inhabited A -> (A -> Prop) -> A.

Hypothesis epsilon_spec :
  forall (A:Type) (i:inhabited A) (P:A->Prop),
  (exists x, P x) -> P (epsilon A i P).

Hypothesis epsilon_extensionality :
  forall (A:Type) (i:inhabited A) (P Q:A->Prop),
  (forall a, P a <-> Q a) -> epsilon A i P = epsilon A i Q.

Local Notation eps := (epsilon bool true) (only parsing).

Theorem extensional_epsilon_imp_EM : forall P:Prop, P \/ ~ P.
Proof.
  intro P.
  pose (B := fun y => y=false \/ P).
  pose (C := fun y => y=true  \/ P).
  assert (B (eps B)) as [Hfalse|HP]
    by (apply epsilon_spec; exists false; left; reflexivity).
  assert (C (eps C)) as [Htrue|HP]
    by (apply epsilon_spec; exists true; left; reflexivity).
    right; intro HP.
    assert (forall y, B y <-> C y) by (intro y; split; intro; right; assumption).
    rewrite epsilon_extensionality with (1:=H) in Hfalse.
    rewrite Htrue in Hfalse.
    discriminate.
  auto.
  auto.
Qed.

End ExtensionalEpsilon_imp_EM.


Set Warnings "-notation-overridden".

Require Import Category.Lib.
Require Export Category.Theory.Functor.
Require Export Category.Functor.Diagonal.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

Corollary Diagonal_Unique `(C : Category) {D : Category} (d : D) :
  Diagonal C d ≈[Cat] Const d ∘[Cat] one.
Proof. exists (fun _ => iso_id); simpl; intros; cat. Qed.


Require Import Streams Ascii String.
Require Import Show Functor Monad Llist.

Variable IO : Type -> Type.
Variable io_return : forall {A : Type}, A -> IO A.
Variable io_bind : forall {A : Type}, IO A ->
  forall {B:Type}, (A -> IO B) -> IO B.

Axiom io_1 : forall A (a : IO A), a = io_bind a (@io_return A).
Axiom io_2 : forall A (a : A) B (f : A -> IO B),
      f a = io_bind (io_return a) f.
Axiom io_3 : forall A (ma : IO A) B f C (g : B -> IO C),
      io_bind ma (fun x => io_bind (f x) g) = io_bind (io_bind ma f) g.
Axiom io_aux : forall A B (f g : A -> IO B) m,
  (forall x, f x = g x) -> io_bind m f = io_bind m g.

Instance IOMonad : Monad IO := {
  return_ := @io_return
  ; bind := @io_bind
  ; right_unit := io_1
  ; left_unit := io_2
  ; associativity := io_3
}.

Instance FunctorIO : Functor IO := {
  fmap A B f m := m >>= (fun x => return_ (f x))
}.
Proof.
 intros A B C f g x.
 unfold Basics.compose. simpl.
 rewrite <- io_3.
 apply io_aux. intro a. rewrite <- io_2. reflexivity.
Defined.

Variable ocaml_string : Set.
Variable implode : string -> ocaml_string.
Variable explode : ocaml_string -> string.
Variable get_lines_aux : IO (llist ocaml_string).
Variable print_aux : ocaml_string -> IO unit.
Variable println_aux : ocaml_string -> IO unit.

Definition print {A : Set} {s : Show A} (x : A) : IO unit :=
  print_aux (implode (show x)).
Definition println {A : Set} {s : Show A} (x : A) : IO unit :=
  println_aux (implode (show x)).
Definition get_lines : IO (llist string) :=
  fmap (Llist.map explode) get_lines_aux.


Require Import VerdiRaft.Raft.

Section TraceUtil.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition has_key (c : clientId) (i : nat) (e : entry) :=
    match e with
      | mkEntry _ c' i' _ _ _ => andb (if clientId_eq_dec c c' then true else false) (Nat.eqb i i')
    end.

  Definition key_in_output_list (client : clientId) (id : nat) (os : list raft_output) :=
    exists o,
      In (ClientResponse client id o) os.

  Definition is_client_response_with_key (client : clientId) (id : nat) (out : raft_output) : bool :=
    match out with
      | ClientResponse c i _ => andb (if clientId_eq_dec client c then true else false) (Nat.eqb id i)
      | NotLeader _ _ => false
    end.

  Definition key_in_output_list_dec (client : clientId) (id : nat) (os : list raft_output) :
    {key_in_output_list client id os} + {~ key_in_output_list client id os}.
  Proof using.
    unfold key_in_output_list.
    destruct (find (is_client_response_with_key client id) os) eqn:?.
    - find_apply_lem_hyp find_some. break_and.
      unfold is_client_response_with_key in *. break_match; try discriminate.
      subst. do_bool. break_and. break_if; try discriminate. do_bool. subst. left. eauto.
    - right. intro. break_exists.
      eapply find_none in H; eauto. unfold is_client_response_with_key in *.
      find_apply_lem_hyp Bool.andb_false_elim.
      intuition; try break_if; do_bool; congruence.
  Qed.

  Definition key_in_output_trace (client : clientId) (id : nat)
             (tr : list (name * (raft_input + list raft_output))) : Prop :=
    exists os h,
      In (h, inr os) tr /\
      key_in_output_list client id os.

  Definition key_in_output_trace_dec (client : clientId) (id : nat) :
    forall tr : list (name * (raft_input + list raft_output)),
      {key_in_output_trace client id tr} + {~ key_in_output_trace client id tr}.
  Proof using.
    unfold key_in_output_trace.
    intros.
    destruct (find (fun p => match snd p with
                               | inr l => match find (is_client_response_with_key client id) l with
                                            | Some x => true
                                            | None => false
                                          end
                               | _ => false
                             end) tr) eqn:?.
    - find_apply_lem_hyp find_some. break_and.
      repeat break_match; try discriminate.
      find_apply_lem_hyp find_some. break_and.
      unfold is_client_response_with_key, key_in_output_list in *.
      break_match; try discriminate. do_bool. break_and. do_bool. break_if; try discriminate. subst.
      left. exists l, (fst p).
      find_reverse_rewrite. rewrite <- surjective_pairing.
      intuition eauto.
    - right. intro. break_exists. break_and.
      find_eapply_lem_hyp find_none; eauto.
      simpl in *. break_match; try discriminate.
      unfold key_in_output_list in *. break_exists.
      find_eapply_lem_hyp find_none; eauto.
      simpl in *. find_apply_lem_hyp Bool.andb_false_elim.
      intuition; try break_if; (do_bool; congruence).
  Qed.

  Definition in_output_list (client : clientId) (id : nat) (o : output) (os : list raft_output) :=
    In (ClientResponse client id o) os.

  Definition is_client_response (client : clientId) (id : nat) (o : output) (out : raft_output) : bool :=
    match out with
      | ClientResponse c i o' => andb (andb (if clientId_eq_dec client c then true else false) (Nat.eqb id i))
                                     (if output_eq_dec o o' then true else false)
      | NotLeader _ _ => false
    end.

  Definition in_output_list_dec (client : clientId) (id : nat) (o : output) (os : list raft_output) :
    {in_output_list client id o os} + {~ in_output_list client id o os}.
  Proof using raft_params.
    unfold in_output_list.
    destruct (find (is_client_response client id o) os) eqn:?.
    - find_apply_lem_hyp find_some. break_and.
      unfold is_client_response in *. break_match; try discriminate.
      subst. do_bool. break_and. break_if; try congruence.
      break_if; try discriminate.
      repeat (do_bool; intuition). subst. intuition.
    - right. intro. break_exists.
      eapply find_none in H; eauto. unfold is_client_response in *.
      find_apply_lem_hyp Bool.andb_false_elim.
      repeat (do_bool; intuition); try break_if; try congruence.
  Qed.

  Definition in_output_trace (client : clientId) (id : nat) (o : output)
             (tr : list (name * (raft_input + list raft_output))) : Prop :=
    exists os h,
      In (h, inr os) tr /\
      in_output_list client id o os.

  Definition in_input_trace (client : clientId) (id : nat) (i : input)
             (tr : list (name * (raft_input + list raft_output))) : Prop :=
      exists h,
        In (h, inl (ClientRequest client id i)) tr.

  Definition is_output_with_key (client : clientId) (id : nat)
             (trace_entry : (name * (raft_input + list raft_output))) :=
    match trace_entry with
      | (_, inr os) => if key_in_output_list_dec client id os then true else false
      | _ => false
    end.

  Definition is_input_with_key (client : clientId) (id: nat)
             (trace_entry : (name * (raft_input + list raft_output))) :=
    match trace_entry with
      | (_, inl (ClientRequest c i _)) => andb (if clientId_eq_dec client c then true else false) (Nat.eqb id i)
      | _ => false
    end.
End TraceUtil.


Require Import
        Fiat.Common.ilist
        Fiat.Common.SumType
        Fiat.Common.IterateBoundedIndex
        Fiat.Narcissus.Common.Specs.

Require Import
        Coq.Sets.Ensembles
        Bedrock.Word.

Section SumType.

  Context {B : Type}.
  Context {cache : Cache}.
  Context {cacheAddNat : CacheAdd cache nat}.
  Context {monoid : Monoid B}.
  Context {monoidUnit : MonoidUnitOpt monoid bool}.

  Definition format_SumType {m}
             (types : Vector.t Type m)
             (formatrs : ilist (B := fun T => T -> CacheFormat -> Comp (B * CacheFormat)) types)
             (st : SumType types)
    : CacheFormat -> Comp (B * CacheFormat) :=
    ith formatrs (SumType_index types st) (SumType_proj types st).

  Definition encode_SumType {m}
             (types : Vector.t Type m)
             (formatrs : ilist (B := fun T => T -> CacheFormat -> (B * CacheFormat)) types)
             (st : SumType types)
    : CacheFormat -> (B * CacheFormat) :=
    ith formatrs (SumType_index types st) (SumType_proj types st).

  Lemma refine_format_SumType {m}
        (types : Vector.t Type m)
        (formats : ilist (B := fun T => T -> CacheFormat -> Comp (B * CacheFormat)) types)
        (encoders : ilist (B := fun T => T -> CacheFormat -> (B * CacheFormat)) types)
        (st : SumType types)
        (ce : CacheFormat)
    :
      Iterate_Ensemble_BoundedIndex'
        (fun idx => forall a ce,
             refine (ith formats idx a ce)
                    (ret (ith encoders idx a ce)))
      -> refine (format_SumType types formats st ce) (ret (encode_SumType types encoders st ce)).
  Proof.
    intros.
    unfold format_SumType, encode_SumType; simpl.
    remember (SumType_proj types st); clear Heqn.
    revert n ce; pattern (SumType_index types st).
    eapply Iterate_Ensemble_equiv'.
    apply H.
  Qed.

  Definition decode_SumType {m}
             (types : Vector.t Type m)
             (decoders : ilist (B := fun T => B -> CacheDecode -> Hopefully (T * B * CacheDecode)) types)
             (idx : Fin.t m)
             (b : B)
             (cd : CacheDecode)
    : Hopefully (SumType types * B * CacheDecode) :=
    `(a, b', cd') <- ith decoders idx b cd;
      Ok (inj_SumType types idx a, b', cd').

  Lemma tri_proj_eq {A C D} : forall a c d (acd : A * C * D),
      a = fst (fst acd)
      -> c = snd (fst acd)
      -> d = snd acd
      -> acd = ((a, c), d).
  Proof.
    intros; subst; intuition.
  Qed.

  Theorem SumType_decode_correct' {m}
          {P}
          (types : Vector.t Type m)
          (formatrs : ilist (B := fun T => T -> CacheFormat ->
                                           Comp (B * CacheFormat)) types)
          (decoders : ilist (B := fun T => B -> CacheDecode -> Hopefully (T * B * CacheDecode)) types)
          (invariants : forall idx, Vector.nth types idx -> Prop)
          (cache_invariants : forall idx, (CacheDecode -> Prop) -> Prop)
          (formatrs_decoders_correct : forall idx,
              cache_inv_Property P (cache_invariants idx)
              -> CorrectDecoder
                monoid
                (fun st => invariants idx st)
                (fun st => invariants idx st)
                eq
                (ith formatrs idx)
                (ith decoders idx)
                P (ith formatrs idx))
          idx
    :
      cache_inv_Property P (fun P => forall idx, cache_invariants idx P)
      -> CorrectDecoder monoid (fun st => SumType_index types st = idx /\ invariants _ (SumType_proj types st))
                        (fun st => SumType_index types st = idx /\ invariants _ (SumType_proj types st))
                        eq
                        (format_SumType types formatrs)
                        (decode_SumType types decoders idx)
                        P
                        (format_SumType types formatrs).
  Proof.
    split;
      revert types formatrs decoders invariants formatrs_decoders_correct;
      unfold CorrectDecoder, format_SumType, decode_SumType.
    { intros; intuition.
      unfold id in *;
      eapply (proj1 (formatrs_decoders_correct _ (H _))) in H2; eauto;
        destruct_ex; intuition.
      subst; setoid_rewrite H2; simpl.
      eexists _, _; intuition eauto.
      repeat f_equal.
      unfold id; rewrite inj_SumType_proj_inverse; reflexivity.
      unfold id; rewrite inj_SumType_proj_inverse; eauto.
    }
    { intros.
      destruct (ith decoders idx t env') as [ [ [? ?] ? ] | ] eqn : ? ;
        simpl in *; try discriminate; injections.
      eapply (proj2 (formatrs_decoders_correct idx (H _))) in Heqh;
        eauto; destruct Heqh as [? [? ?] ]; destruct_ex; intuition; subst.
      eexists _, _; intuition eauto; unfold id in *; eauto;
        try rewrite index_SumType_inj_inverse; eauto.
      - unfold id; pattern (SumType_index types (inj_SumType types idx n)),
        (SumType_proj types (inj_SumType types idx n)).
        eapply SumType_proj_inj; eauto.
      - unfold id;
          pattern (SumType_index types (inj_SumType types idx n)),
          (SumType_proj types (inj_SumType types idx n)).
        eapply SumType_proj_inj; eauto.
    }
  Qed.

  Theorem SumType_decode_correct {m}
          {P}
          (types : Vector.t Type m)
          (formatrs : ilist (B := fun T => T -> CacheFormat ->
                                           Comp (B * CacheFormat)) types)
          (decoders : ilist (B := fun T => B -> CacheDecode -> Hopefully (T * B * CacheDecode)) types)
          (invariants : ilist (B := fun T => Ensemble T) types)
          (cache_invariants : Vector.t (Ensemble (CacheDecode -> Prop)) m)
          (formatrs_decoders_correct :
             Iterate_Ensemble_BoundedIndex (fun idx =>
              cache_inv_Property P (Vector.nth cache_invariants idx)
              -> CorrectDecoder
                monoid
                (ith invariants idx)
                (ith invariants idx)
                eq
                (ith formatrs idx)
                (ith decoders idx)
                P
                (ith formatrs idx)))
          idx
    :
      cache_inv_Property P (fun P => Iterate_Ensemble_BoundedIndex (fun idx => Vector.nth cache_invariants idx P))
      -> CorrectDecoder monoid
                        (fun st => SumType_index types st = idx /\ (ith invariants) _ (SumType_proj types st))
                        (fun st => SumType_index types st = idx /\ (ith invariants) _ (SumType_proj types st))
                        eq
                          (format_SumType types formatrs)
                          (decode_SumType types decoders idx)
                          P
                          (format_SumType types formatrs).
  Proof.
    intros; eapply SumType_decode_correct'; eauto.
    intros.
    eapply Iterate_Ensemble_BoundedIndex_equiv in formatrs_decoders_correct; eauto.
    unfold cache_inv_Property in *; intros;
      eapply Iterate_Ensemble_BoundedIndex_equiv in H; eauto.
  Qed.

End SumType.

Arguments SumType : simpl never.