(** * Well-founded relation on [reachable] *)
Require Import Fiat.Parsers.ContextFreeGrammar.Core Fiat.Parsers.Reachable.OnlyLast.Reachable.
Require Import Fiat.Parsers.BaseTypes.

Section rel.
  Context {Char} {HSLM : StringLikeMin Char} {predata : @parser_computational_predataT Char} {G : grammar Char}.

  Section size.
    Context {ch : Char} {valid : nonterminals_listT}.
    Definition size_of_reachable_from_item'
               (size_of_reachable_from_productions : forall {pats}, reachable_from_productions G ch valid pats -> nat)
               {it} (p : reachable_from_item G ch valid it) : nat
      := match p with
           | ReachableTerminal _ _ => 0
           | ReachableNonTerminal _ _ p' => S (size_of_reachable_from_productions p')
         end.

    Fixpoint size_of_reachable_from_productions {pats} (p : reachable_from_productions G ch valid pats) : nat
      := match p with
           | ReachableHead _ _ p' => S (size_of_reachable_from_production p')
           | ReachableTail _ _ p' => S (size_of_reachable_from_productions p')
         end
    with size_of_reachable_from_production {pat} (p : reachable_from_production G ch valid pat) : nat
         := match p with
              | ReachableProductionHead _ _ _ p' => S (size_of_reachable_from_item' (@size_of_reachable_from_productions) p')
              | ReachableProductionTail _ _ p' => S (size_of_reachable_from_production p')
            end.

    Definition size_of_reachable_from_item
               {it} (p : reachable_from_item G ch valid it) : nat
      := @size_of_reachable_from_item' (@size_of_reachable_from_productions) it p.
  End size.
End rel.


Require Import Coq.Lists.List.
Require Import Logic.LogicGenerator.Utils.
Require Import Logic.LogicGenerator.ConfigLang.

Import ListNotations.

Definition how_connectives :=
  [primitive_connective impp
  ;primitive_connective andp
  ;primitive_connective orp
  ;primitive_connective falsep
  ;FROM_andp_impp_TO_iffp
  ;FROM_falsep_impp_TO_negp
  ;FROM_falsep_impp_TO_truep
  ;FROM_impp_TO_multi_imp
  ;FROM_empty_set_TO_empty_context
  ].

Definition how_judgements :=
  [primitive_judgement derivable
  ;FROM_derivable_TO_provable
  ].

Definition transparent_names: list parameter :=
  [].

Definition primitive_rule_classes :=
  [ derivitive_OF_basic_setting
  ; derivitive_OF_impp
  ; derivitive_OF_propositional_connectives
  ; GEN_provable_FROM_derivable
  ].


From Undecidability.FOL Require Import Semantics.FiniteTarski.Full.
From Undecidability.FOL Require Import Syntax.Facts Semantics.Tarski.FullFacts Syntax.BinSig.
From Undecidability.SeparationLogic Require Import MSL.

From Undecidability.Shared Require Import Dec.
Require Import Undecidability.Synthetic.DecidabilityFacts.
Require Import List.

Set Default Goal Selector "!".

#[local] Notation "x 'el' L" := (In x L) (at level 70).
#[local] Notation "[ s | p ∈ A ]" := (map (fun p => s) A) (p pattern).

(** encoding function following Cacagno, Yang, O'Hearn (2001) **)
#[local] Existing Instance falsity_on.
Fixpoint encode {ff : falsity_flag} (phi : form) : msp_form :=
  match phi with
  | falsity => mbot
  | atom _ v => let x := match Vector.hd v with var x => x | func f' _ => match f' with end end in
               let y := match Vector.hd (Vector.tl v) with var y => y | func f' _ => match f' with end end in
               mand (mex (mpointer (Some 0) (Some (S x)) (Some (S y))))
                    (mand (mpointer (Some x) None None) ((mpointer (Some y) None None)))
  | bin Impl phi psi => mimp (encode phi) (encode psi)
  | bin Conj phi psi => mand (encode phi) (encode psi)
  | bin Disj phi psi => mor (encode phi) (encode psi)
  | quant All phi => mall (mimp (mpointer (Some 0) None None) (encode phi))
  | quant Ex phi => mex (mand (mpointer (Some 0) None None) (encode phi))
  end.

Definition encode' (phi : form) : msp_form :=
  mand (mex (mpointer (Some 0) None None)) (encode phi).

(** backwards direction **)

Lemma map_hd X Y n (f : X -> Y) (v : Vector.t X (S n)) :
  Vector.hd (Vector.map f v) = f (Vector.hd v).
Proof.
  now apply (Vector.caseS' v).
Qed.

Lemma map_tl X Y n (f : X -> Y) (v : Vector.t X (S n)) :
  Vector.tl (Vector.map f v) = Vector.map f (Vector.tl v).
Proof.
  now apply (Vector.caseS' v).
Qed.

Lemma in_hd X n (v : Vector.t X (S n)) :
  Vector.In (Vector.hd v) v.
Proof.
  apply (Vector.caseS' v).
  intros. constructor.
Qed.

Lemma in_hd_tl X n (v : Vector.t X (S (S n))) :
  Vector.In (Vector.hd (Vector.tl v)) v.
Proof.
  apply (Vector.caseS' v). intros ? w.
  apply (Vector.caseS' w).
  constructor. constructor.
Qed.

Definition FV_term (t : term) : nat :=
  match t with
  | $n => n
  | func f v => match f with end
  end.

Fixpoint FV {ff : falsity_flag} (phi : form) : list nat :=
  match phi with
  | falsity => nil
  | atom _ v => map FV_term (Vector.to_list v)
  | bin b phi psi => (FV phi) ++ (FV psi)
  | quant q phi => [pred p | p ∈ filter (fun n : nat => if n then false else true) (FV phi)]
  end.

Lemma to_list_in X n (v : Vector.t X n) x :
  Vector.In x v -> x el Vector.to_list v.
Proof.
  induction v; cbn.
  - inversion 1.
  - inversion 1; subst; try now left.
    apply Eqdep_dec.inj_pair2_eq_dec in H3 as <-; try decide equality.
    right. apply IHv, H2.
Qed.

Lemma to_list_in' X n (v : Vector.t X n) x :
  x el Vector.to_list v -> Vector.In x v.
Proof.
  induction v; cbn.
  - inversion 1.
  - inversion 1; subst; try now left. right. apply IHv, H0.
Qed.

Section Backwards.

  Definition squash P {d : dec P} :=
    if Dec P then True else False.
  Arguments squash _ {_}.
  Lemma squash_iff P (d : dec P) :
    squash P <-> P.
  Proof.
    unfold squash. destruct Dec; tauto.
  Qed.

  Lemma squash_pure P (d : dec P) (H H' : squash P) :
    H = H'.
  Proof.
    remember (squash P) as S. unfold squash in HeqS.
    destruct Dec in HeqS; subst; try tauto. now destruct H, H'.
  Qed.

  Definition dom (h : heap) : Type :=
    { l | squash ((l, (None, None)) el h) }.

  Definition loc2dom {h : heap} {l} :
    (l, (None, None)) el h -> dom h.
  Proof.
    intros H. exists l. abstract (now apply squash_iff).
  Defined.

  Definition env (s : stack) (h : heap) (d0 : dom h) :
    nat -> dom h.
  Proof.
    intros n. destruct (s n) as [l |].
    - decide ((l, (None, None)) el h).
      + exact (loc2dom i).
      + exact d0.
    - exact d0.
  Defined.

  Instance model h :
    interp (dom h).
  Proof.
    split.
    - intros [].
    - intros [] v. exact (exists l, (l, (Some (proj1_sig (Vector.hd v)), Some (proj1_sig (Vector.hd (Vector.tl v))))) el h).
  Defined.

  Lemma dom_eq h (x y : dom h) :
    proj1_sig x = proj1_sig y -> x = y.
  Proof.
    destruct x as [x Hx], y as [y Hy]; cbn.
    intros ->. f_equal. apply squash_pure.
  Qed.

  Arguments env _ _ _ _ : clear implicits.
  Lemma update_stack_cons s h d0 d x :
    (d .: env s h d0) x = env (update_stack s (Some (proj1_sig d))) h d0 x.
  Proof.
    destruct x as [|x]; try reflexivity. cbn. destruct Dec.
    - destruct d. now apply dom_eq.
    - contradict n. eapply squash_iff, proj2_sig.
  Qed.

  Lemma reduction_backwards (s : stack) (h : heap) (d0 : dom h) phi :
    (forall x, x el FV phi -> exists l, s x = Some l /\ (l, (None, None)) el h) -> env s h d0 ⊨ phi <-> msp_sat s h (encode phi).
  Proof.
    induction phi in s |- *; try destruct P; try destruct b0; try destruct q; cbn; intros HV.
    - tauto.
    - rewrite map_tl, !map_hd. destruct (Vector.hd t) as [x|[]] eqn : Hx.
      destruct (Vector.hd (Vector.tl t)) as [y|[]] eqn : Hy. cbn. split.
      + intros [l Hl].
        destruct (HV x) as (l1 & H1 & H2).
        { apply in_map_iff. exists (Vector.hd t). split; try now rewrite Hx. apply to_list_in, in_hd. }
        destruct (HV y) as (l2 & H3 & H4).
        { apply in_map_iff. exists (Vector.hd (Vector.tl t)). split; try now rewrite Hy. apply to_list_in, in_hd_tl. }
        unfold env in Hl. rewrite H1, H3 in Hl. do 2 destruct Dec; try tauto. cbn in Hl. repeat split.
        * exists (Some l), l. split; trivial. now rewrite H1, H3.
        * now exists l1.
        * now exists l2.
     + intros [[v[l[-> Hl]]][[l1[H1 H2]][l2[H3 H4]]]]. exists l. unfold env. rewrite H1, H3.
       do 2 destruct Dec; try tauto. cbn. now rewrite <- H1, <- H3.
  - rewrite IHphi1, IHphi2; try tauto. all: intros x Hx; apply HV; apply in_app_iff; auto.
  - rewrite IHphi1, IHphi2; try tauto. all: intros x Hx; apply HV; apply in_app_iff; auto.
  - rewrite IHphi1, IHphi2; try tauto. all: intros x Hx; apply HV; apply in_app_iff; auto.
  - split; intros H.
    + intros [l|] [l'[H1 H2]]; try discriminate. injection H1. intros <-. apply IHphi.
      * intros [|x] Hx; try now exists l. apply HV. apply in_map_iff. exists (S x). split; trivial. now apply filter_In.
      * eapply sat_ext; try apply (H (loc2dom H2)). intros x. now rewrite update_stack_cons.
    + intros [l Hl]. assert (Hl' : (l, (None, None)) el h) by now eapply squash_iff. eapply sat_ext, IHphi, H; cbn.
      * apply update_stack_cons.
      * intros [|x] Hx; try now exists l. apply HV. apply in_map_iff. exists (S x). split; trivial. now apply filter_In.
      * exists l. split; trivial.
  - split; intros H.
    + destruct H as [[l Hl] H]. assert (Hl' : (l, (None, None)) el h) by now eapply squash_iff.
      exists (Some l). split; try now exists l. apply IHphi.
      * intros [|x] Hx; try now exists l. apply HV. apply in_map_iff. exists (S x). split; trivial. now apply filter_In.
      * eapply sat_ext; try apply H. intros x. now rewrite update_stack_cons.
    + destruct H as [[l|][[l'[H1 H2]] H]]; try discriminate. injection H1. intros <-.
      exists (loc2dom H2). eapply sat_ext, IHphi, H.
      * intros x. now erewrite update_stack_cons.
      * intros [|x] Hx; try now exists l. apply HV. apply in_map_iff. exists (S x). split; trivial. now apply filter_In.
  Qed.

  (* requirements *)

  Definition dom_cons {h} {a} :
    dom h -> dom (a::h).
  Proof.
    intros [x Hx]. exists x. apply squash_iff. right. now eapply squash_iff.
  Defined.

  Definition dom_list_cons {h} {a} (L : list (dom h)) :=
    map (@dom_cons h a) L.

  Program Fixpoint dom_list h : list (dom h) :=
    match h with
    | nil => nil
    | (l, (None, None))::h => (exist _ l _) :: (dom_list_cons (dom_list h))
    | _::h => (dom_list_cons (dom_list h))
    end.
  Next Obligation.
    apply squash_iff. now left.
  Qed.

  Lemma dom_listable h :
    listable (dom h).
  Proof.
    exists (dom_list h). intros x.
    induction h as [|[l[[l1|][l2|]]]]; cbn.
    - destruct x as [x Hx]. apply squash_iff in Hx. apply Hx.
    - destruct x as [x Hx]. pose proof (proj1 (squash_iff _) Hx) as [H|H]; try discriminate.
      apply in_map_iff. exists (loc2dom H). split; try apply IHh. now apply dom_eq.
    - destruct x as [x Hx]. pose proof (proj1 (squash_iff _) Hx) as [H|H]; try discriminate.
      apply in_map_iff. exists (loc2dom H). split; try apply IHh. now apply dom_eq.
    - destruct x as [x Hx]. pose proof (proj1 (squash_iff _) Hx) as [H|H]; try discriminate.
      apply in_map_iff. exists (loc2dom H). split; try apply IHh. now apply dom_eq.
    - destruct x as [x Hx]. pose proof (proj1 (squash_iff _) Hx) as [H|H].
      + left. apply dom_eq. cbn. congruence.
      + right. apply in_map_iff. exists (loc2dom H). split; try apply IHh. now apply dom_eq.
  Qed.

  Lemma dom_discrete h :
    discrete (dom h).
  Proof.
    apply discrete_iff. constructor. intros [x Hx] [y Hy]. decide (x = y) as [H|H].
    - left. now apply dom_eq.
    - right. now intros [=].
  Qed.

  Lemma pairlist_dec X Y (L : list (X * Y)) y :
    eq_dec X -> eq_dec Y -> dec (exists x, (x, y) el L).
  Proof.
    intros DX DY. induction L as [|[a b]].
    - right. firstorder.
    - destruct IHL as [H|H].
      + left. destruct H as [x Hx]. exists x. now right.
      + decide (y = b) as [->|Hy].
        * left. exists a. now left.
        * right. intros [x[Hx|Hx]].
          -- apply Hy. congruence.
          -- apply H. now exists x.
  Qed.

  Lemma model_dec (h : heap) :
    decidable (fun v => i_atom (interp:=model h) (P:=tt) v).
  Proof.
    apply decidable_iff. constructor. intros v. cbn.
    apply pairlist_dec; exact _.
  Qed.

End Backwards.

(** forwards direction **)

Section Forwards.

  Variable D : Type.
  Variable I : interp D.

  Variable LD : list D.
  Hypothesis LD_ex : forall d, d el LD.
  Hypothesis LD_nodup : NoDup LD.

  Hypothesis D_disc : forall d e : D, dec (d = e).

  Variable f : D * D -> bool.
  Hypothesis f_dec : forall v, i_atom (P:=tt) v <-> f (Vector.hd v, (Vector.hd (Vector.tl v))) = true.

  Fixpoint pos L (d : D) : nat :=
    match L with
    | nil => 0
    | e::L => if Dec (d = e) then 0 else S (pos L d)
    end.

  Definition enc_point (d : D) : nat :=
    pos LD d.

  Fixpoint sum n : nat :=
    match n with
    | 0 => 0
    | S n' => S n' + sum n'
    end.

  Definition enc_npair x y : nat :=
    y + sum (y + x).

  Definition enc_pair d e : nat :=
    enc_npair (enc_point d) (enc_point e) + S (length LD).

  Definition interp2heap : heap :=
    [(enc_point d, (None, None)) | d ∈ LD]
      ++ [(enc_pair d e, (Some (enc_point d), Some (enc_point e))) | (d, e) ∈ filter f (list_prod LD LD)].

  Definition env2stack (rho : nat -> D) : stack :=
    fun n => Some (enc_point (rho n)).

  Lemma pos_inj L d e :
    d el L -> e el L -> pos L d = pos L e -> d = e.
  Proof.
    induction L; cbn; try tauto. intros [->|Hd] [->|He].
    all: repeat destruct Dec; try tauto; try congruence.
    intros [=]. auto.
  Qed.

  Lemma enc_point_inj d e :
    enc_point d = enc_point e -> d = e.
  Proof using LD_ex.
    apply pos_inj; apply LD_ex.
  Qed.

  Lemma sp_eval_ext s s' E :
    (forall n, s n = s' n) -> sp_eval s E = sp_eval s' E.
  Proof.
    intros HS. destruct E as [x|]; cbn; auto.
  Qed.

  Lemma msp_sat_ext s s' h P :
    (forall n, s n = s' n) -> msp_sat s h P <-> msp_sat s' h P.
  Proof.
    induction P in s, s' |- *; intros HS; cbn.
    - now setoid_rewrite (sp_eval_ext _ HS).
    - tauto.
    - now rewrite (IHP1 s s'), (IHP2 s s').
    - now rewrite (IHP1 s s'), (IHP2 s s').
    - now rewrite (IHP1 s s'), (IHP2 s s').
    - split; intros H v. all: eapply IHP; try apply (H v). all: intros []; cbn; auto.
    - split; intros [v H]; exists v. all: eapply IHP; try apply H. all: intros []; cbn; auto.
  Qed.

  Lemma reduction_forwards rho phi :
    rho ⊨ phi <-> msp_sat (env2stack rho) interp2heap (encode phi).
  Proof using LD_ex f_dec.
    induction phi in rho |- *; try destruct P; try destruct b0; try destruct q; cbn.
    - tauto.
    - rewrite f_dec, map_tl, !map_hd.
      destruct (Vector.hd t) as [x|[]] eqn : Hx. destruct (Vector.hd (Vector.tl t)) as [y|[]] eqn : Hy.
      cbn. split.
      + pose (d := rho x). pose (e := rho y). intros H. repeat split.
        * exists (Some (enc_pair d e)), (enc_pair d e). split; trivial.
          apply in_app_iff. right. apply in_map_iff. exists (d, e). split; try reflexivity.
          apply filter_In. split; trivial. apply in_prod_iff. split; apply LD_ex.
        * exists (enc_point d). split; trivial. apply in_app_iff. left. apply in_map_iff. exists d; auto.
        * exists (enc_point e). split; trivial. apply in_app_iff. left. apply in_map_iff. exists e; auto.
      + intros [[v[l[-> Hl]]] _].
        apply in_app_iff in Hl as [Hl|Hl].
        * apply in_map_iff in Hl as [d [H1 H2]]. discriminate.
        * apply in_map_iff in Hl as [[d e] [H1 H2]]. apply filter_In in H2 as [_ H2].
          unfold env2stack in H1. injection H1. now intros -> % enc_point_inj -> % enc_point_inj _.
    - now rewrite IHphi1, IHphi2.
    - now rewrite IHphi1, IHphi2.
    - now rewrite IHphi1, IHphi2.
    - split; intros H.
      + intros [l|] [l'[H1 H2]]; try discriminate. injection H1. intros <-. clear H1.
        apply in_app_iff in H2 as [[d[[=] _]] % in_map_iff |[[][]] % in_map_iff]; try discriminate; subst.
        eapply msp_sat_ext; try apply IHphi, (H d). now intros [].
      + intros d. apply IHphi. eapply msp_sat_ext; try apply (H (Some (enc_point d))).
        * now intros [].
        * exists (enc_point d). split; trivial. apply in_app_iff. left. apply in_map_iff. exists d; auto.
    - split.
      + intros [d H]. exists (Some (enc_point d)). split.
        * exists (enc_point d). split; trivial. apply in_app_iff. left. apply in_map_iff. exists d; auto.
        * eapply msp_sat_ext; try apply IHphi, H. now intros [].
      + intros [v[[l [-> Hl]] H]].
        apply in_app_iff in Hl as [[d[[=] _]] % in_map_iff |[[][]] % in_map_iff]; try discriminate; subst.
        exists d. apply IHphi. eapply msp_sat_ext; try apply H. now intros [].
  Qed.

  (* requirements *)

  Lemma pos_bound L x :
    pos L x < S (length L).
  Proof.
    induction L; cbn.
    - lia.
    - decide (x = a); lia.
  Qed.

  Lemma enc_point_pair d d1 d2 :
    enc_point d <> enc_pair d1 d2.
  Proof.
    unfold enc_pair. assert (H : enc_point d < S (length LD)) by apply pos_bound. lia.
  Qed.

  Definition next xy : nat * nat :=
    match xy with
    | (0,y) => (S y, 0)
    | (S x, y) => (x, S y)
    end.

  Fixpoint decode n : nat * nat :=
    match n with
    | 0 => (0,0)
    | S n' => next (decode n')
    end.

  Fact decode_encode x y :
    decode (enc_npair x y) = (x, y).
  Proof.
    revert x y.
    enough (forall n x y, enc_npair x y = n -> decode n = (x, y)) by eauto.
    induction n as [|n IH]; intros x y; cbn.
    - destruct x, y; cbn.
      1: reflexivity. all: intros [=].
    - destruct y; cbn.
      + destruct x; cbn.
        * intros [=].
        * intros [= <-].
          rewrite (IH 0 x). 1: reflexivity.
          unfold enc_npair. replace (x + 0) with x by lia. reflexivity.
      + intros [= <-].
        rewrite (IH (S x) y). 1: reflexivity.
        unfold enc_npair. replace (y + S x) with (S y + x) by lia. reflexivity.
  Qed.

  Lemma enc_npair_inj n n' k k' :
    enc_npair n n' = enc_npair k k' -> (n, n') = (k, k').
  Proof.
    intros H. rewrite <- (decode_encode n n'), <- (decode_encode k k'). congruence.
  Qed.

  Lemma enc_pair_inj d d' e e' :
    enc_pair d d' = enc_pair e e' -> d = e /\ d' = e'.
  Proof using LD_ex.
    intros H. assert (((enc_point d), (enc_point d')) = ((enc_point e), (enc_point e'))) as [=].
    - apply enc_npair_inj. unfold enc_pair in H. lia.
    - split; now apply enc_point_inj.
  Qed.

  Lemma interp2heap_fun :
    functional interp2heap.
  Proof using LD_ex.
    intros l p p' [H|H] % in_app_iff [H'|H'] % in_app_iff.
    all: apply in_map_iff in H as [d [H1 H2]].
    all: apply in_map_iff in H' as [d' [H3 H4]].
    - congruence.
    - destruct d' as [d1 d2]. exfalso. apply (@enc_point_pair d d1 d2). congruence.
    - destruct d as [d1 d2]. exfalso. apply (@enc_point_pair d' d1 d2). congruence.
    - destruct d, d', p, p'. injection H1. injection H3. intros. subst. repeat f_equal.
      + eapply (@enc_pair_inj d d0 d1 d2). congruence.
      + eapply (@enc_pair_inj d d0 d1 d2). congruence.
  Qed.

  Lemma guarded (d : D) :
    exists (v : val) (l : nat), v = Some l /\ (l, (None, None)) el interp2heap.
  Proof using LD_ex.
    exists (Some (enc_point d)), (enc_point d). split; trivial.
    apply in_app_iff. left. apply in_map_iff. exists d; auto.
  Qed.

End Forwards.

(** reduction theorem **)

Require Import Undecidability.Synthetic.Definitions.
Import Vector.VectorNotations.

Lemma vec_inv1 {X} (v : Vector.t X 1) :
  v = [Vector.hd v].
Proof.
  apply (Vector.caseS' v). intros ?.
  now apply Vector.case0.
Qed.

Lemma vec_inv2 {X} (v : Vector.t X 2) :
  v = [Vector.hd v; Vector.hd (Vector.tl v)].
Proof.
  apply (Vector.caseS' v). intros x w.
  apply (Vector.caseS' w). intros ?.
  now apply Vector.case0.
Qed.

Lemma discrete_nodup X (L : list X) :
  eq_dec X -> { L' | NoDup L' /\ incl L L' }.
Proof.
  intros d. induction L.
  - exists nil. split; [|easy]. apply NoDup_nil.
  - destruct IHL as (L' & H1 & H2). decide (a el L') as [H|H].
    + exists L'. split; trivial. intros b. cbn. firstorder congruence.
    + exists (cons a L'). split; try now apply NoDup_cons.
    auto using incl_cons, in_eq, incl_tl.
Qed.

Theorem reduction' phi :
  incl (FV phi) nil -> FSATd phi <-> MSLSAT (encode' phi).
Proof.
  intros HV. split.
  - intros (D & M & rho & [L HL] & [H2] % discrete_iff & [f H3] & H4).
    pose (f' (p : D * D) := let (d, e) := p in f ([d; e])).
    destruct (@discrete_nodup D L H2) as [L'[HL1 HL2]].
    assert (HL2' : forall x, x el L') by auto.
    assert (H3' : forall v, i_atom (P:=tt) v <-> f' (Vector.hd v, Vector.hd (Vector.tl v)) = true).
    { intros v. unfold decider, reflects in H3. now rewrite (H3 v), (vec_inv2 v) at 1. }
    exists (@env2stack D L' H2 rho), (@interp2heap D L' H2 f'). split.
    + now eapply interp2heap_fun.
    + cbn. split; try now eapply reduction_forwards. apply guarded; trivial. exact (rho 0).
  - intros (s & h & _ & H). cbn in H. destruct H as [H' H]. destruct H' as (v & l & -> & Hl).
    exists (dom h), (model h), (@env s h (loc2dom Hl)). repeat split.
    + apply dom_listable.
    + apply dom_discrete.
    + intros [ ]. apply model_dec.
    + apply reduction_backwards; trivial. intros x Hx. destruct (HV x Hx).
Qed.

Lemma bounded_FV_term t n :
  bounded_t n t -> FV_term t < n.
Proof.
  induction 1; try destruct f; cbn. assumption.
Qed.

Lemma bounded_FV phi n :
  bounded n phi -> incl (FV phi) (seq 0 n).
Proof.
  induction 1; cbn.
  - intros x [t [<- Ht]] % in_map_iff.
    apply to_list_in', H, bounded_FV_term in Ht.
    apply in_seq. lia.
  - auto using incl_app.
  - intros x [t [<- Ht]] % in_map_iff. apply filter_In in Ht as [H1 H2].
    destruct t; try discriminate. apply IHbounded, in_seq in H1.
    cbn. apply in_seq. lia.
  - apply incl_nil_l.
Qed.

Theorem reduction :
  FSATdc ⪯ MSLSAT.
Proof.
  exists (fun phi => encode' (proj1_sig phi)). intros [phi H]; unfold FSATdc; cbn.
  apply reduction'. change nil with (seq 0 0). now apply bounded_FV.
Qed.


From iris.algebra Require Export base.
Set Default Proof Using "Type".
Set Primitive Projections.

(** This files defines (a shallow embedding of) the category of OFEs:
    Complete ordered families of equivalences. This is a cartesian closed
    category, and mathematically speaking, the entire development lives
    in this category. However, we will generally prefer to work with raw
    Coq functions plus some registered Proper instances for non-expansiveness.
    This makes writing such functions much easier. It turns out that it many
    cases, we do not even need non-expansiveness.
*)

(** Unbundeled version *)
Class Dist A := dist : nat → relation A.
Instance: Params (@dist) 3.
Notation "x ≡{ n }≡ y" := (dist n x y)
  (at level 70, n at next level, format "x  ≡{ n }≡  y").
Hint Extern 0 (_ ≡{_}≡ _) => reflexivity.
Hint Extern 0 (_ ≡{_}≡ _) => symmetry; assumption.
Notation NonExpansive f := (∀ n, Proper (dist n ==> dist n) f).
Notation NonExpansive2 f := (∀ n, Proper (dist n ==> dist n ==> dist n) f).

Tactic Notation "ofe_subst" ident(x) :=
  repeat match goal with
  | _ => progress simplify_eq/=
  | H:@dist ?A ?d ?n x _ |- _ => setoid_subst_aux (@dist A d n) x
  | H:@dist ?A ?d ?n _ x |- _ => symmetry in H;setoid_subst_aux (@dist A d n) x
  end.
Tactic Notation "ofe_subst" :=
  repeat match goal with
  | _ => progress simplify_eq/=
  | H:@dist ?A ?d ?n ?x _ |- _ => setoid_subst_aux (@dist A d n) x
  | H:@dist ?A ?d ?n _ ?x |- _ => symmetry in H;setoid_subst_aux (@dist A d n) x
  end.

Record OfeMixin A `{Equiv A, Dist A} := {
  mixin_equiv_dist x y : x ≡ y ↔ ∀ n, x ≡{n}≡ y;
  mixin_dist_equivalence n : Equivalence (dist n);
  mixin_dist_S n x y : x ≡{S n}≡ y → x ≡{n}≡ y
}.

(** Bundeled version *)
Structure ofeT := OfeT {
  ofe_car :> Type;
  ofe_equiv : Equiv ofe_car;
  ofe_dist : Dist ofe_car;
  ofe_mixin : OfeMixin ofe_car
}.
Arguments OfeT _ {_ _} _.
Add Printing Constructor ofeT.
Hint Extern 0 (Equiv _) => eapply (@ofe_equiv _) : typeclass_instances.
Hint Extern 0 (Dist _) => eapply (@ofe_dist _) : typeclass_instances.
Arguments ofe_car : simpl never.
Arguments ofe_equiv : simpl never.
Arguments ofe_dist : simpl never.
Arguments ofe_mixin : simpl never.

(** When declaring instances of subclasses of OFE (like CMRAs and unital CMRAs)
we need Coq to *infer* the canonical OFE instance of a given type and take the
mixin out of it. This makes sure we do not use two different OFE instances in
different places (see for example the constructors [CmraT] and [UcmraT] in the
file [cmra.v].)

In order to infer the OFE instance, we use the definition [ofe_mixin_of'] which
is inspired by the [clone] trick in ssreflect. It works as follows, when type
checking [@ofe_mixin_of' A ?Ac id] Coq faces a unification problem:

  ofe_car ?Ac  ~  A

which will resolve [?Ac] to the canonical OFE instance corresponding to [A]. The
definition [@ofe_mixin_of' A ?Ac id] will then provide the corresponding mixin.
Note that type checking of [ofe_mixin_of' A id] will fail when [A] does not have
a canonical OFE instance.

The notation [ofe_mixin_of A] that we define on top of [ofe_mixin_of' A id]
hides the [id] and normalizes the mixin to head normal form. The latter is to
ensure that we do not end up with redundant canonical projections to the mixin,
i.e. them all being of the shape [ofe_mixin_of' A id]. *)
Definition ofe_mixin_of' A {Ac : ofeT} (f : Ac → A) : OfeMixin Ac := ofe_mixin Ac.
Notation ofe_mixin_of A :=
  ltac:(let H := eval hnf in (ofe_mixin_of' A id) in exact H) (only parsing).

(** Lifting properties from the mixin *)
Section ofe_mixin.
  Context {A : ofeT}.
  Implicit Types x y : A.
  Lemma equiv_dist x y : x ≡ y ↔ ∀ n, x ≡{n}≡ y.
  Proof. apply (mixin_equiv_dist _ (ofe_mixin A)). Qed.
  Global Instance dist_equivalence n : Equivalence (@dist A _ n).
  Proof. apply (mixin_dist_equivalence _ (ofe_mixin A)). Qed.
  Lemma dist_S n x y : x ≡{S n}≡ y → x ≡{n}≡ y.
  Proof. apply (mixin_dist_S _ (ofe_mixin A)). Qed.
End ofe_mixin.

Hint Extern 1 (_ ≡{_}≡ _) => apply equiv_dist; assumption.

(** Discrete OFEs and discrete OFE elements *)
Class Discrete {A : ofeT} (x : A) := discrete y : x ≡{0}≡ y → x ≡ y.
Arguments discrete {_} _ {_} _ _.
Hint Mode Discrete + ! : typeclass_instances.
Instance: Params (@Discrete) 1.

Class OfeDiscrete (A : ofeT) := ofe_discrete_discrete (x : A) :> Discrete x.

(** OFEs with a completion *)
Record chain (A : ofeT) := {
  chain_car :> nat → A;
  chain_cauchy n i : n ≤ i → chain_car i ≡{n}≡ chain_car n
}.
Arguments chain_car {_} _ _.
Arguments chain_cauchy {_} _ _ _ _.

Program Definition chain_map {A B : ofeT} (f : A → B)
    `{!NonExpansive f} (c : chain A) : chain B :=
  {| chain_car n := f (c n) |}.
Next Obligation. by intros A B f Hf c n i ?; apply Hf, chain_cauchy. Qed.

Notation Compl A := (chain A%type → A).
Class Cofe (A : ofeT) := {
  compl : Compl A;
  conv_compl n c : compl c ≡{n}≡ c n;
}.
Arguments compl : simpl never.

Lemma compl_chain_map `{Cofe A, Cofe B} (f : A → B) c `(NonExpansive f) :
  compl (chain_map f c) ≡ f (compl c).
Proof. apply equiv_dist=>n. by rewrite !conv_compl. Qed.

Program Definition chain_const {A : ofeT} (a : A) : chain A :=
  {| chain_car n := a |}.
Next Obligation. by intros A a n i _. Qed.

Lemma compl_chain_const {A : ofeT} `{!Cofe A} (a : A) :
  compl (chain_const a) ≡ a.
Proof. apply equiv_dist=>n. by rewrite conv_compl. Qed.

(** General properties *)
Section ofe.
  Context {A : ofeT}.
  Implicit Types x y : A.
  Global Instance ofe_equivalence : Equivalence ((≡) : relation A).
  Proof.
    split.
    - by intros x; rewrite equiv_dist.
    - by intros x y; rewrite !equiv_dist.
    - by intros x y z; rewrite !equiv_dist; intros; trans y.
  Qed.
  Global Instance dist_ne n : Proper (dist n ==> dist n ==> iff) (@dist A _ n).
  Proof.
    intros x1 x2 ? y1 y2 ?; split; intros.
    - by trans x1; [|trans y1].
    - by trans x2; [|trans y2].
  Qed.
  Global Instance dist_proper n : Proper ((≡) ==> (≡) ==> iff) (@dist A _ n).
  Proof.
    by move => x1 x2 /equiv_dist Hx y1 y2 /equiv_dist Hy; rewrite (Hx n) (Hy n).
  Qed.
  Global Instance dist_proper_2 n x : Proper ((≡) ==> iff) (dist n x).
  Proof. by apply dist_proper. Qed.
  Global Instance Discrete_proper : Proper ((≡) ==> iff) (@Discrete A).
  Proof. intros x y Hxy. rewrite /Discrete. by setoid_rewrite Hxy. Qed.

  Lemma dist_le n n' x y : x ≡{n}≡ y → n' ≤ n → x ≡{n'}≡ y.
  Proof. induction 2; eauto using dist_S. Qed.
  Lemma dist_le' n n' x y : n' ≤ n → x ≡{n}≡ y → x ≡{n'}≡ y.
  Proof. intros; eauto using dist_le. Qed.
  Instance ne_proper {B : ofeT} (f : A → B) `{!NonExpansive f} :
    Proper ((≡) ==> (≡)) f | 100.
  Proof. by intros x1 x2; rewrite !equiv_dist; intros Hx n; rewrite (Hx n). Qed.
  Instance ne_proper_2 {B C : ofeT} (f : A → B → C) `{!NonExpansive2 f} :
    Proper ((≡) ==> (≡) ==> (≡)) f | 100.
  Proof.
     unfold Proper, respectful; setoid_rewrite equiv_dist.
     by intros x1 x2 Hx y1 y2 Hy n; rewrite (Hx n) (Hy n).
  Qed.

  Lemma conv_compl' `{Cofe A} n (c : chain A) : compl c ≡{n}≡ c (S n).
  Proof.
    transitivity (c n); first by apply conv_compl. symmetry.
    apply chain_cauchy. lia.
  Qed.

  Lemma discrete_iff n (x : A) `{!Discrete x} y : x ≡ y ↔ x ≡{n}≡ y.
  Proof.
    split; intros; auto. apply (discrete _), dist_le with n; auto with lia.
  Qed.
  Lemma discrete_iff_0 n (x : A) `{!Discrete x} y : x ≡{0}≡ y ↔ x ≡{n}≡ y.
  Proof. by rewrite -!discrete_iff. Qed.
End ofe.

(** Contractive functions *)
Definition dist_later `{Dist A} (n : nat) (x y : A) : Prop :=
  match n with 0 => True | S n => x ≡{n}≡ y end.
Arguments dist_later _ _ !_ _ _ /.

Global Instance dist_later_equivalence (A : ofeT) n : Equivalence (@dist_later A _ n).
Proof. destruct n as [|n]. by split. apply dist_equivalence. Qed.

Lemma dist_dist_later {A : ofeT} n (x y : A) : dist n x y → dist_later n x y.
Proof. intros Heq. destruct n; first done. exact: dist_S. Qed.

Lemma dist_later_dist {A : ofeT} n (x y : A) : dist_later (S n) x y → dist n x y.
Proof. done. Qed.

(* We don't actually need this lemma (as our tactics deal with this through
   other means), but technically speaking, this is the reason why
   pre-composing a non-expansive function to a contractive function
   preserves contractivity. *)
Lemma ne_dist_later {A B : ofeT} (f : A → B) :
  NonExpansive f → ∀ n, Proper (dist_later n ==> dist_later n) f.
Proof. intros Hf [|n]; last exact: Hf. hnf. by intros. Qed.

Notation Contractive f := (∀ n, Proper (dist_later n ==> dist n) f).

Instance const_contractive {A B : ofeT} (x : A) : Contractive (@const A B x).
Proof. by intros n y1 y2. Qed.

Section contractive.
  Local Set Default Proof Using "Type*".
  Context {A B : ofeT} (f : A → B) `{!Contractive f}.
  Implicit Types x y : A.

  Lemma contractive_0 x y : f x ≡{0}≡ f y.
  Proof. by apply (_ : Contractive f). Qed.
  Lemma contractive_S n x y : x ≡{n}≡ y → f x ≡{S n}≡ f y.
  Proof. intros. by apply (_ : Contractive f). Qed.

  Global Instance contractive_ne : NonExpansive f | 100.
  Proof. by intros n x y ?; apply dist_S, contractive_S. Qed.
  Global Instance contractive_proper : Proper ((≡) ==> (≡)) f | 100.
  Proof. apply (ne_proper _). Qed.
End contractive.

Ltac f_contractive :=
  match goal with
  | |- ?f _ ≡{_}≡ ?f _ => simple apply (_ : Proper (dist_later _ ==> _) f)
  | |- ?f _ _ ≡{_}≡ ?f _ _ => simple apply (_ : Proper (dist_later _ ==> _ ==> _) f)
  | |- ?f _ _ ≡{_}≡ ?f _ _ => simple apply (_ : Proper (_ ==> dist_later _ ==> _) f)
  end;
  try match goal with
  | |- @dist_later ?A _ ?n ?x ?y =>
         destruct n as [|n]; [exact I|change (@dist A _ n x y)]
  end;
  try simple apply reflexivity.

Ltac solve_contractive :=
  solve_proper_core ltac:(fun _ => first [f_contractive | f_equiv]).

(** Limit preserving predicates *)
Class LimitPreserving `{!Cofe A} (P : A → Prop) : Prop :=
  limit_preserving (c : chain A) : (∀ n, P (c n)) → P (compl c).
Hint Mode LimitPreserving + + ! : typeclass_instances.

Section limit_preserving.
  Context `{Cofe A}.
  (* These are not instances as they will never fire automatically...
     but they can still be helpful in proving things to be limit preserving. *)

  Lemma limit_preserving_ext (P Q : A → Prop) :
    (∀ x, P x ↔ Q x) → LimitPreserving P → LimitPreserving Q.
  Proof. intros HP Hlimit c ?. apply HP, Hlimit=> n; by apply HP. Qed.

  Global Instance limit_preserving_const (P : Prop) : LimitPreserving (λ _, P).
  Proof. intros c HP. apply (HP 0). Qed.

  Lemma limit_preserving_discrete (P : A → Prop) :
    Proper (dist 0 ==> impl) P → LimitPreserving P.
  Proof. intros PH c Hc. by rewrite (conv_compl 0). Qed.

  Lemma limit_preserving_and (P1 P2 : A → Prop) :
    LimitPreserving P1 → LimitPreserving P2 →
    LimitPreserving (λ x, P1 x ∧ P2 x).
  Proof. intros Hlim1 Hlim2 c Hc. split. apply Hlim1, Hc. apply Hlim2, Hc. Qed.

  Lemma limit_preserving_impl (P1 P2 : A → Prop) :
    Proper (dist 0 ==> impl) P1 → LimitPreserving P2 →
    LimitPreserving (λ x, P1 x → P2 x).
  Proof.
    intros Hlim1 Hlim2 c Hc HP1. apply Hlim2=> n; apply Hc.
    eapply Hlim1, HP1. apply dist_le with n; last lia. apply (conv_compl n).
  Qed.

  Lemma limit_preserving_forall {B} (P : B → A → Prop) :
    (∀ y, LimitPreserving (P y)) →
    LimitPreserving (λ x, ∀ y, P y x).
  Proof. intros Hlim c Hc y. by apply Hlim. Qed.
End limit_preserving.

(** Fixpoint *)
Program Definition fixpoint_chain {A : ofeT} `{Inhabited A} (f : A → A)
  `{!Contractive f} : chain A := {| chain_car i := Nat.iter (S i) f inhabitant |}.
Next Obligation.
  intros A ? f ? n.
  induction n as [|n IH]=> -[|i] //= ?; try lia.
  - apply (contractive_0 f).
  - apply (contractive_S f), IH; auto with lia.
Qed.

Program Definition fixpoint_def `{Cofe A, Inhabited A} (f : A → A)
  `{!Contractive f} : A := compl (fixpoint_chain f).
Definition fixpoint_aux : seal (@fixpoint_def). by eexists. Qed.
Definition fixpoint {A AC AiH} f {Hf} := fixpoint_aux.(unseal) A AC AiH f Hf.
Definition fixpoint_eq : @fixpoint = @fixpoint_def := fixpoint_aux.(seal_eq).

Section fixpoint.
  Context `{Cofe A, Inhabited A} (f : A → A) `{!Contractive f}.

  Lemma fixpoint_unfold : fixpoint f ≡ f (fixpoint f).
  Proof.
    apply equiv_dist=>n.
    rewrite fixpoint_eq /fixpoint_def (conv_compl n (fixpoint_chain f)) //.
    induction n as [|n IH]; simpl; eauto using contractive_0, contractive_S.
  Qed.

  Lemma fixpoint_unique (x : A) : x ≡ f x → x ≡ fixpoint f.
  Proof.
    rewrite !equiv_dist=> Hx n. induction n as [|n IH]; simpl in *.
    - rewrite Hx fixpoint_unfold; eauto using contractive_0.
    - rewrite Hx fixpoint_unfold. apply (contractive_S _), IH.
  Qed.

  Lemma fixpoint_ne (g : A → A) `{!Contractive g} n :
    (∀ z, f z ≡{n}≡ g z) → fixpoint f ≡{n}≡ fixpoint g.
  Proof.
    intros Hfg. rewrite fixpoint_eq /fixpoint_def
      (conv_compl n (fixpoint_chain f)) (conv_compl n (fixpoint_chain g)) /=.
    induction n as [|n IH]; simpl in *; [by rewrite !Hfg|].
    rewrite Hfg; apply contractive_S, IH; auto using dist_S.
  Qed.
  Lemma fixpoint_proper (g : A → A) `{!Contractive g} :
    (∀ x, f x ≡ g x) → fixpoint f ≡ fixpoint g.
  Proof. setoid_rewrite equiv_dist; naive_solver eauto using fixpoint_ne. Qed.

  Lemma fixpoint_ind (P : A → Prop) :
    Proper ((≡) ==> impl) P →
    (∃ x, P x) → (∀ x, P x → P (f x)) →
    LimitPreserving P →
    P (fixpoint f).
  Proof.
    intros ? [x Hx] Hincr Hlim. set (chcar i := Nat.iter (S i) f x).
    assert (Hcauch : ∀ n i : nat, n ≤ i → chcar i ≡{n}≡ chcar n).
    { intros n. rewrite /chcar. induction n as [|n IH]=> -[|i] //=;
        eauto using contractive_0, contractive_S with lia. }
    set (fp2 := compl {| chain_cauchy := Hcauch |}).
    assert (f fp2 ≡ fp2).
    { apply equiv_dist=>n. rewrite /fp2 (conv_compl n) /= /chcar.
      induction n as [|n IH]; simpl; eauto using contractive_0, contractive_S. }
    rewrite -(fixpoint_unique fp2) //.
    apply Hlim=> n /=. by apply Nat_iter_ind.
  Qed.
End fixpoint.

(** Fixpoint of f when f^k is contractive. **)
Definition fixpointK `{Cofe A, Inhabited A} k (f : A → A)
  `{!Contractive (Nat.iter k f)} := fixpoint (Nat.iter k f).

Section fixpointK.
  Local Set Default Proof Using "Type*".
  Context `{Cofe A, Inhabited A} (f : A → A) (k : nat).
  Context {f_contractive : Contractive (Nat.iter k f)} {f_ne : NonExpansive f}.
  (* Note than f_ne is crucial here:  there are functions f such that f^2 is contractive,
     but f is not non-expansive.
     Consider for example f: SPred → SPred (where SPred is "downclosed sets of natural numbers").
     Define f (using informative excluded middle) as follows:
     f(N) = N  (where N is the set of all natural numbers)
     f({0, ..., n}) = {0, ... n-1}  if n is even (so n-1 is at least -1, in which case we return the empty set)
     f({0, ..., n}) = {0, ..., n+2} if n is odd
     In other words, if we consider elements of SPred as ordinals, then we decreaste odd finite
     ordinals by 1 and increase even finite ordinals by 2.
     f is not non-expansive:  Consider f({0}) = ∅ and f({0,1}) = f({0,1,2,3}).
     The arguments are clearly 0-equal, but the results are not.

     Now consider g := f^2. We have
     g(N) = N
     g({0, ..., n}) = {0, ... n+1}  if n is even
     g({0, ..., n}) = {0, ..., n+4} if n is odd
     g is contractive.  All outputs contain 0, so they are all 0-equal.
     Now consider two n-equal inputs. We have to show that the outputs are n+1-equal.
     Either they both do not contain n in which case they have to be fully equal and
     hence so are the results.  Or else they both contain n, so the results will
     both contain n+1, so the results are n+1-equal.
   *)

  Let f_proper : Proper ((≡) ==> (≡)) f := ne_proper f.
  Local Existing Instance f_proper.

  Lemma fixpointK_unfold : fixpointK k f ≡ f (fixpointK k f).
  Proof.
    symmetry. rewrite /fixpointK. apply fixpoint_unique.
    by rewrite -Nat_iter_S_r Nat_iter_S -fixpoint_unfold.
  Qed.

  Lemma fixpointK_unique (x : A) : x ≡ f x → x ≡ fixpointK k f.
  Proof.
    intros Hf. apply fixpoint_unique. clear f_contractive.
    induction k as [|k' IH]=> //=. by rewrite -IH.
  Qed.

  Section fixpointK_ne.
    Context (g : A → A) `{g_contractive : !Contractive (Nat.iter k g)}.
    Context {g_ne : NonExpansive g}.

    Lemma fixpointK_ne n : (∀ z, f z ≡{n}≡ g z) → fixpointK k f ≡{n}≡ fixpointK k g.
    Proof.
      rewrite /fixpointK=> Hfg /=. apply fixpoint_ne=> z.
      clear f_contractive g_contractive.
      induction k as [|k' IH]=> //=. by rewrite IH Hfg.
    Qed.

    Lemma fixpointK_proper : (∀ z, f z ≡ g z) → fixpointK k f ≡ fixpointK k g.
    Proof. setoid_rewrite equiv_dist; naive_solver eauto using fixpointK_ne. Qed.
  End fixpointK_ne.

  Lemma fixpointK_ind (P : A → Prop) :
    Proper ((≡) ==> impl) P →
    (∃ x, P x) → (∀ x, P x → P (f x)) →
    LimitPreserving P →
    P (fixpointK k f).
  Proof.
    intros. rewrite /fixpointK. apply fixpoint_ind; eauto.
    intros; apply Nat_iter_ind; auto.
  Qed.
End fixpointK.

(** Mutual fixpoints *)
Section fixpointAB.
  Local Unset Default Proof Using.

  Context `{Cofe A, Cofe B, !Inhabited A, !Inhabited B}.
  Context (fA : A → B → A).
  Context (fB : A → B → B).
  Context `{∀ n, Proper (dist_later n ==> dist n ==> dist n) fA}.
  Context `{∀ n, Proper (dist_later n ==> dist_later n ==> dist n) fB}.

  Local Definition fixpoint_AB (x : A) : B := fixpoint (fB x).
  Local Instance fixpoint_AB_contractive : Contractive fixpoint_AB.
  Proof.
    intros n x x' Hx; rewrite /fixpoint_AB.
    apply fixpoint_ne=> y. by f_contractive.
  Qed.

  Local Definition fixpoint_AA (x : A) : A := fA x (fixpoint_AB x).
  Local Instance fixpoint_AA_contractive : Contractive fixpoint_AA.
  Proof. solve_contractive. Qed.

  Definition fixpoint_A : A := fixpoint fixpoint_AA.
  Definition fixpoint_B : B := fixpoint_AB fixpoint_A.

  Lemma fixpoint_A_unfold : fA fixpoint_A fixpoint_B ≡ fixpoint_A.
  Proof. by rewrite {2}/fixpoint_A (fixpoint_unfold _). Qed.
  Lemma fixpoint_B_unfold : fB fixpoint_A fixpoint_B ≡ fixpoint_B.
  Proof. by rewrite {2}/fixpoint_B /fixpoint_AB (fixpoint_unfold _). Qed.

  Instance: Proper ((≡) ==> (≡) ==> (≡)) fA.
  Proof.
    apply ne_proper_2=> n x x' ? y y' ?. f_contractive; auto using dist_S.
  Qed.
  Instance: Proper ((≡) ==> (≡) ==> (≡)) fB.
  Proof.
    apply ne_proper_2=> n x x' ? y y' ?. f_contractive; auto using dist_S.
  Qed.

  Lemma fixpoint_A_unique p q : fA p q ≡ p → fB p q ≡ q → p ≡ fixpoint_A.
  Proof.
    intros HfA HfB. rewrite -HfA. apply fixpoint_unique. rewrite /fixpoint_AA.
    f_equiv=> //. apply fixpoint_unique. by rewrite HfA HfB.
  Qed.
  Lemma fixpoint_B_unique p q : fA p q ≡ p → fB p q ≡ q → q ≡ fixpoint_B.
  Proof. intros. apply fixpoint_unique. by rewrite -fixpoint_A_unique. Qed.
End fixpointAB.

Section fixpointAB_ne.
  Context `{Cofe A, Cofe B, !Inhabited A, !Inhabited B}.
  Context (fA fA' : A → B → A).
  Context (fB fB' : A → B → B).
  Context `{∀ n, Proper (dist_later n ==> dist n ==> dist n) fA}.
  Context `{∀ n, Proper (dist_later n ==> dist n ==> dist n) fA'}.
  Context `{∀ n, Proper (dist_later n ==> dist_later n ==> dist n) fB}.
  Context `{∀ n, Proper (dist_later n ==> dist_later n ==> dist n) fB'}.

  Lemma fixpoint_A_ne n :
    (∀ x y, fA x y ≡{n}≡ fA' x y) → (∀ x y, fB x y ≡{n}≡ fB' x y) →
    fixpoint_A fA fB ≡{n}≡ fixpoint_A fA' fB'.
  Proof.
    intros HfA HfB. apply fixpoint_ne=> z.
    rewrite /fixpoint_AA /fixpoint_AB HfA. f_equiv. by apply fixpoint_ne.
  Qed.
  Lemma fixpoint_B_ne n :
    (∀ x y, fA x y ≡{n}≡ fA' x y) → (∀ x y, fB x y ≡{n}≡ fB' x y) →
    fixpoint_B fA fB ≡{n}≡ fixpoint_B fA' fB'.
  Proof.
    intros HfA HfB. apply fixpoint_ne=> z. rewrite HfB. f_contractive.
    apply fixpoint_A_ne; auto using dist_S.
  Qed.

  Lemma fixpoint_A_proper :
    (∀ x y, fA x y ≡ fA' x y) → (∀ x y, fB x y ≡ fB' x y) →
    fixpoint_A fA fB ≡ fixpoint_A fA' fB'.
  Proof. setoid_rewrite equiv_dist; naive_solver eauto using fixpoint_A_ne. Qed.
  Lemma fixpoint_B_proper :
    (∀ x y, fA x y ≡ fA' x y) → (∀ x y, fB x y ≡ fB' x y) →
    fixpoint_B fA fB ≡ fixpoint_B fA' fB'.
  Proof. setoid_rewrite equiv_dist; naive_solver eauto using fixpoint_B_ne. Qed.
End fixpointAB_ne.

(** Non-expansive function space *)
Record ofe_mor (A B : ofeT) : Type := CofeMor {
  ofe_mor_car :> A → B;
  ofe_mor_ne : NonExpansive ofe_mor_car
}.
Arguments CofeMor {_ _} _ {_}.
Add Printing Constructor ofe_mor.
Existing Instance ofe_mor_ne.

Notation "'λne' x .. y , t" :=
  (@CofeMor _ _ (λ x, .. (@CofeMor _ _ (λ y, t) _) ..) _)
  (at level 200, x binder, y binder, right associativity).

Section ofe_mor.
  Context {A B : ofeT}.
  Global Instance ofe_mor_proper (f : ofe_mor A B) : Proper ((≡) ==> (≡)) f.
  Proof. apply ne_proper, ofe_mor_ne. Qed.
  Instance ofe_mor_equiv : Equiv (ofe_mor A B) := λ f g, ∀ x, f x ≡ g x.
  Instance ofe_mor_dist : Dist (ofe_mor A B) := λ n f g, ∀ x, f x ≡{n}≡ g x.
  Definition ofe_mor_ofe_mixin : OfeMixin (ofe_mor A B).
  Proof.
    split.
    - intros f g; split; [intros Hfg n k; apply equiv_dist, Hfg|].
      intros Hfg k; apply equiv_dist=> n; apply Hfg.
    - intros n; split.
      + by intros f x.
      + by intros f g ? x.
      + by intros f g h ?? x; trans (g x).
    - by intros n f g ? x; apply dist_S.
  Qed.
  Canonical Structure ofe_morC := OfeT (ofe_mor A B) ofe_mor_ofe_mixin.

  Program Definition ofe_mor_chain (c : chain ofe_morC)
    (x : A) : chain B := {| chain_car n := c n x |}.
  Next Obligation. intros c x n i ?. by apply (chain_cauchy c). Qed.
  Program Definition ofe_mor_compl `{Cofe B} : Compl ofe_morC := λ c,
    {| ofe_mor_car x := compl (ofe_mor_chain c x) |}.
  Next Obligation.
    intros ? c n x y Hx. by rewrite (conv_compl n (ofe_mor_chain c x))
      (conv_compl n (ofe_mor_chain c y)) /= Hx.
  Qed.
  Global Program Instance ofe_mor_cofe `{Cofe B} : Cofe ofe_morC :=
    {| compl := ofe_mor_compl |}.
  Next Obligation.
    intros ? n c x; simpl.
    by rewrite (conv_compl n (ofe_mor_chain c x)) /=.
  Qed.

  Global Instance ofe_mor_car_ne :
    NonExpansive2 (@ofe_mor_car A B).
  Proof. intros n f g Hfg x y Hx; rewrite Hx; apply Hfg. Qed.
  Global Instance ofe_mor_car_proper :
    Proper ((≡) ==> (≡) ==> (≡)) (@ofe_mor_car A B) := ne_proper_2 _.
  Lemma ofe_mor_ext (f g : ofe_mor A B) : f ≡ g ↔ ∀ x, f x ≡ g x.
  Proof. done. Qed.
End ofe_mor.

Arguments ofe_morC : clear implicits.
Notation "A -n> B" :=
  (ofe_morC A B) (at level 99, B at level 200, right associativity).
Instance ofe_mor_inhabited {A B : ofeT} `{Inhabited B} :
  Inhabited (A -n> B) := populate (λne _, inhabitant).

(** Identity and composition and constant function *)
Definition cid {A} : A -n> A := CofeMor id.
Instance: Params (@cid) 1.
Definition cconst {A B : ofeT} (x : B) : A -n> B := CofeMor (const x).
Instance: Params (@cconst) 2.

Definition ccompose {A B C}
  (f : B -n> C) (g : A -n> B) : A -n> C := CofeMor (f ∘ g).
Instance: Params (@ccompose) 3.
Infix "◎" := ccompose (at level 40, left associativity).
Global Instance ccompose_ne {A B C} :
  NonExpansive2 (@ccompose A B C).
Proof. intros n ?? Hf g1 g2 Hg x. rewrite /= (Hg x) (Hf (g2 x)) //. Qed.

(* Function space maps *)
Definition ofe_mor_map {A A' B B'} (f : A' -n> A) (g : B -n> B')
  (h : A -n> B) : A' -n> B' := g ◎ h ◎ f.
Instance ofe_mor_map_ne {A A' B B'} n :
  Proper (dist n ==> dist n ==> dist n ==> dist n) (@ofe_mor_map A A' B B').
Proof. intros ??? ??? ???. by repeat apply ccompose_ne. Qed.

Definition ofe_morC_map {A A' B B'} (f : A' -n> A) (g : B -n> B') :
  (A -n> B) -n> (A' -n>  B') := CofeMor (ofe_mor_map f g).
Instance ofe_morC_map_ne {A A' B B'} :
  NonExpansive2 (@ofe_morC_map A A' B B').
Proof.
  intros n f f' Hf g g' Hg ?. rewrite /= /ofe_mor_map.
  by repeat apply ccompose_ne.
Qed.

(** unit *)
Section unit.
  Instance unit_dist : Dist unit := λ _ _ _, True.
  Definition unit_ofe_mixin : OfeMixin unit.
  Proof. by repeat split; try exists 0. Qed.
  Canonical Structure unitC : ofeT := OfeT unit unit_ofe_mixin.

  Global Program Instance unit_cofe : Cofe unitC := { compl x := () }.
  Next Obligation. by repeat split; try exists 0. Qed.

  Global Instance unit_ofe_discrete : OfeDiscrete unitC.
  Proof. done. Qed.
End unit.

(** Product *)
Section product.
  Context {A B : ofeT}.

  Instance prod_dist : Dist (A * B) := λ n, prod_relation (dist n) (dist n).
  Global Instance pair_ne :
    NonExpansive2 (@pair A B) := _.
  Global Instance fst_ne : NonExpansive (@fst A B) := _.
  Global Instance snd_ne : NonExpansive (@snd A B) := _.
  Definition prod_ofe_mixin : OfeMixin (A * B).
  Proof.
    split.
    - intros x y; unfold dist, prod_dist, equiv, prod_equiv, prod_relation.
      rewrite !equiv_dist; naive_solver.
    - apply _.
    - by intros n [x1 y1] [x2 y2] [??]; split; apply dist_S.
  Qed.
  Canonical Structure prodC : ofeT := OfeT (A * B) prod_ofe_mixin.

  Global Program Instance prod_cofe `{Cofe A, Cofe B} : Cofe prodC :=
    { compl c := (compl (chain_map fst c), compl (chain_map snd c)) }.
  Next Obligation.
    intros ?? n c; split. apply (conv_compl n (chain_map fst c)).
    apply (conv_compl n (chain_map snd c)).
  Qed.

  Global Instance prod_discrete (x : A * B) :
    Discrete (x.1) → Discrete (x.2) → Discrete x.
  Proof. by intros ???[??]; split; apply (discrete _). Qed.
  Global Instance prod_ofe_discrete :
    OfeDiscrete A → OfeDiscrete B → OfeDiscrete prodC.
  Proof. intros ?? [??]; apply _. Qed.
End product.

Arguments prodC : clear implicits.
Typeclasses Opaque prod_dist.

Instance prod_map_ne {A A' B B' : ofeT} n :
  Proper ((dist n ==> dist n) ==> (dist n ==> dist n) ==>
           dist n ==> dist n) (@prod_map A A' B B').
Proof. by intros f f' Hf g g' Hg ?? [??]; split; [apply Hf|apply Hg]. Qed.
Definition prodC_map {A A' B B'} (f : A -n> A') (g : B -n> B') :
  prodC A B -n> prodC A' B' := CofeMor (prod_map f g).
Instance prodC_map_ne {A A' B B'} :
  NonExpansive2 (@prodC_map A A' B B').
Proof. intros n f f' Hf g g' Hg [??]; split; [apply Hf|apply Hg]. Qed.

(** Functors *)
Structure cFunctor := CFunctor {
  cFunctor_car : ofeT → ofeT → ofeT;
  cFunctor_map {A1 A2 B1 B2} :
    ((A2 -n> A1) * (B1 -n> B2)) → cFunctor_car A1 B1 -n> cFunctor_car A2 B2;
  cFunctor_ne {A1 A2 B1 B2} :
    NonExpansive (@cFunctor_map A1 A2 B1 B2);
  cFunctor_id {A B : ofeT} (x : cFunctor_car A B) :
    cFunctor_map (cid,cid) x ≡ x;
  cFunctor_compose {A1 A2 A3 B1 B2 B3}
      (f : A2 -n> A1) (g : A3 -n> A2) (f' : B1 -n> B2) (g' : B2 -n> B3) x :
    cFunctor_map (f◎g, g'◎f') x ≡ cFunctor_map (g,g') (cFunctor_map (f,f') x)
}.
Existing Instance cFunctor_ne.
Instance: Params (@cFunctor_map) 5.

Delimit Scope cFunctor_scope with CF.
Bind Scope cFunctor_scope with cFunctor.

Class cFunctorContractive (F : cFunctor) :=
  cFunctor_contractive A1 A2 B1 B2 :> Contractive (@cFunctor_map F A1 A2 B1 B2).

Definition cFunctor_diag (F: cFunctor) (A: ofeT) : ofeT := cFunctor_car F A A.
Coercion cFunctor_diag : cFunctor >-> Funclass.

Program Definition constCF (B : ofeT) : cFunctor :=
  {| cFunctor_car A1 A2 := B; cFunctor_map A1 A2 B1 B2 f := cid |}.
Solve Obligations with done.
Coercion constCF : ofeT >-> cFunctor.

Instance constCF_contractive B : cFunctorContractive (constCF B).
Proof. rewrite /cFunctorContractive; apply _. Qed.

Program Definition idCF : cFunctor :=
  {| cFunctor_car A1 A2 := A2; cFunctor_map A1 A2 B1 B2 f := f.2 |}.
Solve Obligations with done.
Notation "∙" := idCF : cFunctor_scope.

Program Definition prodCF (F1 F2 : cFunctor) : cFunctor := {|
  cFunctor_car A B := prodC (cFunctor_car F1 A B) (cFunctor_car F2 A B);
  cFunctor_map A1 A2 B1 B2 fg :=
    prodC_map (cFunctor_map F1 fg) (cFunctor_map F2 fg)
|}.
Next Obligation.
  intros ?? A1 A2 B1 B2 n ???; by apply prodC_map_ne; apply cFunctor_ne.
Qed.
Next Obligation. by intros F1 F2 A B [??]; rewrite /= !cFunctor_id. Qed.
Next Obligation.
  intros F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [??]; simpl.
  by rewrite !cFunctor_compose.
Qed.
Notation "F1 * F2" := (prodCF F1%CF F2%CF) : cFunctor_scope.

Instance prodCF_contractive F1 F2 :
  cFunctorContractive F1 → cFunctorContractive F2 →
  cFunctorContractive (prodCF F1 F2).
Proof.
  intros ?? A1 A2 B1 B2 n ???;
    by apply prodC_map_ne; apply cFunctor_contractive.
Qed.

Program Definition ofe_morCF (F1 F2 : cFunctor) : cFunctor := {|
  cFunctor_car A B := cFunctor_car F1 B A -n> cFunctor_car F2 A B;
  cFunctor_map A1 A2 B1 B2 fg :=
    ofe_morC_map (cFunctor_map F1 (fg.2, fg.1)) (cFunctor_map F2 fg)
|}.
Next Obligation.
  intros F1 F2 A1 A2 B1 B2 n [f g] [f' g'] Hfg; simpl in *.
  apply ofe_morC_map_ne; apply cFunctor_ne; split; by apply Hfg.
Qed.
Next Obligation.
  intros F1 F2 A B [f ?] ?; simpl. rewrite /= !cFunctor_id.
  apply (ne_proper f). apply cFunctor_id.
Qed.
Next Obligation.
  intros F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [h ?] ?; simpl in *.
  rewrite -!cFunctor_compose. do 2 apply (ne_proper _). apply cFunctor_compose.
Qed.
Notation "F1 -n> F2" := (ofe_morCF F1%CF F2%CF) : cFunctor_scope.

Instance ofe_morCF_contractive F1 F2 :
  cFunctorContractive F1 → cFunctorContractive F2 →
  cFunctorContractive (ofe_morCF F1 F2).
Proof.
  intros ?? A1 A2 B1 B2 n [f g] [f' g'] Hfg; simpl in *.
  apply ofe_morC_map_ne; apply cFunctor_contractive; destruct n, Hfg; by split.
Qed.

(** Sum *)
Section sum.
  Context {A B : ofeT}.

  Instance sum_dist : Dist (A + B) := λ n, sum_relation (dist n) (dist n).
  Global Instance inl_ne : NonExpansive (@inl A B) := _.
  Global Instance inr_ne : NonExpansive (@inr A B) := _.
  Global Instance inl_ne_inj : Inj (dist n) (dist n) (@inl A B) := _.
  Global Instance inr_ne_inj : Inj (dist n) (dist n) (@inr A B) := _.

  Definition sum_ofe_mixin : OfeMixin (A + B).
  Proof.
    split.
    - intros x y; split=> Hx.
      + destruct Hx=> n; constructor; by apply equiv_dist.
      + destruct (Hx 0); constructor; apply equiv_dist=> n; by apply (inj _).
    - apply _.
    - destruct 1; constructor; by apply dist_S.
  Qed.
  Canonical Structure sumC : ofeT := OfeT (A + B) sum_ofe_mixin.

  Program Definition inl_chain (c : chain sumC) (a : A) : chain A :=
    {| chain_car n := match c n return _ with inl a' => a' | _ => a end |}.
  Next Obligation. intros c a n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
  Program Definition inr_chain (c : chain sumC) (b : B) : chain B :=
    {| chain_car n := match c n return _ with inr b' => b' | _ => b end |}.
  Next Obligation. intros c b n i ?; simpl. by destruct (chain_cauchy c n i). Qed.

  Definition sum_compl `{Cofe A, Cofe B} : Compl sumC := λ c,
    match c 0 with
    | inl a => inl (compl (inl_chain c a))
    | inr b => inr (compl (inr_chain c b))
    end.
  Global Program Instance sum_cofe `{Cofe A, Cofe B} : Cofe sumC :=
    { compl := sum_compl }.
  Next Obligation.
    intros ?? n c; rewrite /compl /sum_compl.
    feed inversion (chain_cauchy c 0 n); first by auto with lia; constructor.
    - rewrite (conv_compl n (inl_chain c _)) /=. destruct (c n); naive_solver.
    - rewrite (conv_compl n (inr_chain c _)) /=. destruct (c n); naive_solver.
  Qed.

  Global Instance inl_discrete (x : A) : Discrete x → Discrete (inl x).
  Proof. inversion_clear 2; constructor; by apply (discrete _). Qed.
  Global Instance inr_discrete (y : B) : Discrete y → Discrete (inr y).
  Proof. inversion_clear 2; constructor; by apply (discrete _). Qed.
  Global Instance sum_ofe_discrete :
    OfeDiscrete A → OfeDiscrete B → OfeDiscrete sumC.
  Proof. intros ?? [?|?]; apply _. Qed.
End sum.

Arguments sumC : clear implicits.
Typeclasses Opaque sum_dist.

Instance sum_map_ne {A A' B B' : ofeT} n :
  Proper ((dist n ==> dist n) ==> (dist n ==> dist n) ==>
           dist n ==> dist n) (@sum_map A A' B B').
Proof.
  intros f f' Hf g g' Hg ??; destruct 1; constructor; [by apply Hf|by apply Hg].
Qed.
Definition sumC_map {A A' B B'} (f : A -n> A') (g : B -n> B') :
  sumC A B -n> sumC A' B' := CofeMor (sum_map f g).
Instance sumC_map_ne {A A' B B'} :
  NonExpansive2 (@sumC_map A A' B B').
Proof. intros n f f' Hf g g' Hg [?|?]; constructor; [apply Hf|apply Hg]. Qed.

Program Definition sumCF (F1 F2 : cFunctor) : cFunctor := {|
  cFunctor_car A B := sumC (cFunctor_car F1 A B) (cFunctor_car F2 A B);
  cFunctor_map A1 A2 B1 B2 fg :=
    sumC_map (cFunctor_map F1 fg) (cFunctor_map F2 fg)
|}.
Next Obligation.
  intros ?? A1 A2 B1 B2 n ???; by apply sumC_map_ne; apply cFunctor_ne.
Qed.
Next Obligation. by intros F1 F2 A B [?|?]; rewrite /= !cFunctor_id. Qed.
Next Obligation.
  intros F1 F2 A1 A2 A3 B1 B2 B3 f g f' g' [?|?]; simpl;
    by rewrite !cFunctor_compose.
Qed.
Notation "F1 + F2" := (sumCF F1%CF F2%CF) : cFunctor_scope.

Instance sumCF_contractive F1 F2 :
  cFunctorContractive F1 → cFunctorContractive F2 →
  cFunctorContractive (sumCF F1 F2).
Proof.
  intros ?? A1 A2 B1 B2 n ???;
    by apply sumC_map_ne; apply cFunctor_contractive.
Qed.

(** Discrete OFE *)
Section discrete_ofe.
  Context `{Equiv A} (Heq : @Equivalence A (≡)).

  Instance discrete_dist : Dist A := λ n x y, x ≡ y.
  Definition discrete_ofe_mixin : OfeMixin A.
  Proof using Type*.
    split.
    - intros x y; split; [done|intros Hn; apply (Hn 0)].
    - done.
    - done.
  Qed.

  Global Instance discrete_ofe_discrete : OfeDiscrete (OfeT A discrete_ofe_mixin).
  Proof. by intros x y. Qed.

  Global Program Instance discrete_cofe : Cofe (OfeT A discrete_ofe_mixin) :=
    { compl c := c 0 }.
  Next Obligation.
    intros n c. rewrite /compl /=;
    symmetry; apply (chain_cauchy c 0 n). lia.
  Qed.
End discrete_ofe.

Notation discreteC A := (OfeT A (discrete_ofe_mixin _)).
Notation leibnizC A := (OfeT A (@discrete_ofe_mixin _ equivL _)).

(** In order to define a discrete CMRA with carrier [A] (in the file [cmra.v])
we need to determine the [Equivalence A] proof that was used to construct the
OFE instance of [A] (note that this proof is not the same as the one we obtain
via [ofe_equivalence]).

We obtain the proof of [Equivalence A] by inferring the canonical OFE mixin
using [ofe_mixin_of A], and then check whether it is indeed a discrete OFE. This
will fail if no OFE, or an OFE other than the discrete OFE, was registered. *)
Notation discrete_ofe_equivalence_of A := ltac:(
  match constr:(ofe_mixin_of A) with
  | discrete_ofe_mixin ?H => exact H
  end) (only parsing).

Instance leibnizC_leibniz A : LeibnizEquiv (leibnizC A).
Proof. by intros x y. Qed.

Canonical Structure boolC := leibnizC bool.
Canonical Structure natC := leibnizC nat.
Canonical Structure positiveC := leibnizC positive.
Canonical Structure NC := leibnizC N.
Canonical Structure ZC := leibnizC Z.

(* Option *)
Section option.
  Context {A : ofeT}.

  Instance option_dist : Dist (option A) := λ n, option_Forall2 (dist n).
  Lemma dist_option_Forall2 n mx my : mx ≡{n}≡ my ↔ option_Forall2 (dist n) mx my.
  Proof. done. Qed.

  Definition option_ofe_mixin : OfeMixin (option A).
  Proof.
    split.
    - intros mx my; split; [by destruct 1; constructor; apply equiv_dist|].
      intros Hxy; destruct (Hxy 0); constructor; apply equiv_dist.
      by intros n; feed inversion (Hxy n).
    - apply _.
    - destruct 1; constructor; by apply dist_S.
  Qed.
  Canonical Structure optionC := OfeT (option A) option_ofe_mixin.

  Program Definition option_chain (c : chain optionC) (x : A) : chain A :=
    {| chain_car n := default x (c n) |}.
  Next Obligation. intros c x n i ?; simpl. by destruct (chain_cauchy c n i). Qed.
  Definition option_compl `{Cofe A} : Compl optionC := λ c,
    match c 0 with Some x => Some (compl (option_chain c x)) | None => None end.
  Global Program Instance option_cofe `{Cofe A} : Cofe optionC :=
    { compl := option_compl }.
  Next Obligation.
    intros ? n c; rewrite /compl /option_compl.
    feed inversion (chain_cauchy c 0 n); auto with lia; [].
    constructor. rewrite (conv_compl n (option_chain c _)) /=.
    destruct (c n); naive_solver.
  Qed.

  Global Instance option_ofe_discrete : OfeDiscrete A → OfeDiscrete optionC.
  Proof. destruct 2; constructor; by apply (discrete _). Qed.

  Global Instance Some_ne : NonExpansive (@Some A).
  Proof. by constructor. Qed.
  Global Instance is_Some_ne n : Proper (dist n ==> iff) (@is_Some A).
  Proof. destruct 1; split; eauto. Qed.
  Global Instance Some_dist_inj : Inj (dist n) (dist n) (@Some A).
  Proof. by inversion_clear 1. Qed.
  Global Instance from_option_ne {B} (R : relation B) (f : A → B) n :
    Proper (dist n ==> R) f → Proper (R ==> dist n ==> R) (from_option f).
  Proof. destruct 3; simpl; auto. Qed.

  Global Instance None_discrete : Discrete (@None A).
  Proof. inversion_clear 1; constructor. Qed.
  Global Instance Some_discrete x : Discrete x → Discrete (Some x).
  Proof. by intros ?; inversion_clear 1; constructor; apply discrete. Qed.

  Lemma dist_None n mx : mx ≡{n}≡ None ↔ mx = None.
  Proof. split; [by inversion_clear 1|by intros ->]. Qed.
  Lemma dist_Some_inv_l n mx my x :
    mx ≡{n}≡ my → mx = Some x → ∃ y, my = Some y ∧ x ≡{n}≡ y.
  Proof. destruct 1; naive_solver. Qed.
  Lemma dist_Some_inv_r n mx my y :
    mx ≡{n}≡ my → my = Some y → ∃ x, mx = Some x ∧ x ≡{n}≡ y.
  Proof. destruct 1; naive_solver. Qed.
  Lemma dist_Some_inv_l' n my x : Some x ≡{n}≡ my → ∃ x', Some x' = my ∧ x ≡{n}≡ x'.
  Proof. intros ?%(dist_Some_inv_l _ _ _ x); naive_solver. Qed.
  Lemma dist_Some_inv_r' n mx y : mx ≡{n}≡ Some y → ∃ y', mx = Some y' ∧ y ≡{n}≡ y'.
  Proof. intros ?%(dist_Some_inv_r _ _ _ y); naive_solver. Qed.
End option.

Typeclasses Opaque option_dist.
Arguments optionC : clear implicits.

Instance option_fmap_ne {A B : ofeT} n:
  Proper ((dist n ==> dist n) ==> dist n ==> dist n) (@fmap option _ A B).
Proof. intros f f' Hf ?? []; constructor; auto. Qed.
Definition optionC_map {A B} (f : A -n> B) : optionC A -n> optionC B :=
  CofeMor (fmap f : optionC A → optionC B).
Instance optionC_map_ne A B : NonExpansive (@optionC_map A B).
Proof. by intros n f f' Hf []; constructor; apply Hf. Qed.

Program Definition optionCF (F : cFunctor) : cFunctor := {|
  cFunctor_car A B := optionC (cFunctor_car F A B);
  cFunctor_map A1 A2 B1 B2 fg := optionC_map (cFunctor_map F fg)
|}.
Next Obligation.
  by intros F A1 A2 B1 B2 n f g Hfg; apply optionC_map_ne, cFunctor_ne.
Qed.
Next Obligation.
  intros F A B x. rewrite /= -{2}(option_fmap_id x).
  apply option_fmap_equiv_ext=>y; apply cFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x. rewrite /= -option_fmap_compose.
  apply option_fmap_equiv_ext=>y; apply cFunctor_compose.
Qed.

Instance optionCF_contractive F :
  cFunctorContractive F → cFunctorContractive (optionCF F).
Proof.
  by intros ? A1 A2 B1 B2 n f g Hfg; apply optionC_map_ne, cFunctor_contractive.
Qed.

(** Later *)
Record later (A : Type) : Type := Next { later_car : A }.
Add Printing Constructor later.
Arguments Next {_} _.
Arguments later_car {_} _.
Instance: Params (@Next) 1.

Section later.
  Context {A : ofeT}.
  Instance later_equiv : Equiv (later A) := λ x y, later_car x ≡ later_car y.
  Instance later_dist : Dist (later A) := λ n x y,
    dist_later n (later_car x) (later_car y).
  Definition later_ofe_mixin : OfeMixin (later A).
  Proof.
    split.
    - intros x y; unfold equiv, later_equiv; rewrite !equiv_dist.
      split. intros Hxy [|n]; [done|apply Hxy]. intros Hxy n; apply (Hxy (S n)).
    - split; rewrite /dist /later_dist.
      + by intros [x].
      + by intros [x] [y].
      + by intros [x] [y] [z] ??; trans y.
    - intros [|n] [x] [y] ?; [done|]; rewrite /dist /later_dist; by apply dist_S.
  Qed.
  Canonical Structure laterC : ofeT := OfeT (later A) later_ofe_mixin.

  Program Definition later_chain (c : chain laterC) : chain A :=
    {| chain_car n := later_car (c (S n)) |}.
  Next Obligation. intros c n i ?; apply (chain_cauchy c (S n)); lia. Qed.
  Global Program Instance later_cofe `{Cofe A} : Cofe laterC :=
    { compl c := Next (compl (later_chain c)) }.
  Next Obligation.
    intros ? [|n] c; [done|by apply (conv_compl n (later_chain c))].
  Qed.

  Global Instance Next_contractive : Contractive (@Next A).
  Proof. by intros [|n] x y. Qed.
  Global Instance Later_inj n : Inj (dist n) (dist (S n)) (@Next A).
  Proof. by intros x y. Qed.

  Instance later_car_anti_contractive n :
    Proper (dist n ==> dist_later n) later_car.
  Proof. move=> [x] [y] /= Hxy. done. Qed.

  (* f is contractive iff it can factor into `Next` and a non-expansive function. *)
  Lemma contractive_alt {B : ofeT} (f : A → B) :
    Contractive f ↔ ∃ g : later A → B, NonExpansive g ∧ ∀ x, f x ≡ g (Next x).
  Proof.
    split.
    - intros Hf. exists (f ∘ later_car); split=> // n x y ?. by f_equiv.
    - intros (g&Hg&Hf) n x y Hxy. rewrite !Hf. by apply Hg.
  Qed.
End later.

Arguments laterC : clear implicits.

Definition later_map {A B} (f : A → B) (x : later A) : later B :=
  Next (f (later_car x)).
Instance later_map_ne {A B : ofeT} (f : A → B) n :
  Proper (dist (pred n) ==> dist (pred n)) f →
  Proper (dist n ==> dist n) (later_map f) | 0.
Proof. destruct n as [|n]; intros Hf [x] [y] ?; do 2 red; simpl; auto. Qed.
Lemma later_map_id {A} (x : later A) : later_map id x = x.
Proof. by destruct x. Qed.
Lemma later_map_compose {A B C} (f : A → B) (g : B → C) (x : later A) :
  later_map (g ∘ f) x = later_map g (later_map f x).
Proof. by destruct x. Qed.
Lemma later_map_ext {A B : ofeT} (f g : A → B) x :
  (∀ x, f x ≡ g x) → later_map f x ≡ later_map g x.
Proof. destruct x; intros Hf; apply Hf. Qed.
Definition laterC_map {A B} (f : A -n> B) : laterC A -n> laterC B :=
  CofeMor (later_map f).
Instance laterC_map_contractive (A B : ofeT) : Contractive (@laterC_map A B).
Proof. intros [|n] f g Hf n'; [done|]; apply Hf; lia. Qed.

Program Definition laterCF (F : cFunctor) : cFunctor := {|
  cFunctor_car A B := laterC (cFunctor_car F A B);
  cFunctor_map A1 A2 B1 B2 fg := laterC_map (cFunctor_map F fg)
|}.
Next Obligation.
  intros F A1 A2 B1 B2 n fg fg' ?.
  by apply (contractive_ne laterC_map), cFunctor_ne.
Qed.
Next Obligation.
  intros F A B x; simpl. rewrite -{2}(later_map_id x).
  apply later_map_ext=>y. by rewrite cFunctor_id.
Qed.
Next Obligation.
  intros F A1 A2 A3 B1 B2 B3 f g f' g' x; simpl. rewrite -later_map_compose.
  apply later_map_ext=>y; apply cFunctor_compose.
Qed.
Notation "▶ F"  := (laterCF F%CF) (at level 20, right associativity) : cFunctor_scope.

Instance laterCF_contractive F : cFunctorContractive (laterCF F).
Proof.
  intros A1 A2 B1 B2 n fg fg' Hfg. apply laterC_map_contractive.
  destruct n as [|n]; simpl in *; first done. apply cFunctor_ne, Hfg.
Qed.

(* Dependently-typed functions over a discrete domain *)
(* We make [ofe_fun] a definition so that we can register it as a canonical
structure. *)
Definition ofe_fun {A} (B : A → ofeT) := ∀ x : A, B x.

Section ofe_fun.
  Context {A : Type} {B : A → ofeT}.
  Implicit Types f g : ofe_fun B.

  Instance ofe_fun_equiv : Equiv (ofe_fun B) := λ f g, ∀ x, f x ≡ g x.
  Instance ofe_fun_dist : Dist (ofe_fun B) := λ n f g, ∀ x, f x ≡{n}≡ g x.
  Definition ofe_fun_ofe_mixin : OfeMixin (ofe_fun B).
  Proof.
    split.
    - intros f g; split; [intros Hfg n k; apply equiv_dist, Hfg|].
      intros Hfg k; apply equiv_dist=> n; apply Hfg.
    - intros n; split.
      + by intros f x.
      + by intros f g ? x.
      + by intros f g h ?? x; trans (g x).
    - by intros n f g ? x; apply dist_S.
  Qed.
  Canonical Structure ofe_funC := OfeT (ofe_fun B) ofe_fun_ofe_mixin.

  Program Definition ofe_fun_chain `(c : chain ofe_funC)
    (x : A) : chain (B x) := {| chain_car n := c n x |}.
  Next Obligation. intros c x n i ?. by apply (chain_cauchy c). Qed.
  Global Program Instance ofe_fun_cofe `{∀ x, Cofe (B x)} : Cofe ofe_funC :=
    { compl c x := compl (ofe_fun_chain c x) }.
  Next Obligation. intros ? n c x. apply (conv_compl n (ofe_fun_chain c x)). Qed.

  Global Instance ofe_fun_inhabited `{∀ x, Inhabited (B x)} : Inhabited ofe_funC :=
    populate (λ _, inhabitant).
  Global Instance ofe_fun_lookup_discrete `{EqDecision A} f x :
    Discrete f → Discrete (f x).
  Proof.
    intros Hf y ?.
    set (g x' := if decide (x = x') is left H then eq_rect _ B y _ H else f x').
    trans (g x).
    { apply Hf=> x'. unfold g. by destruct (decide _) as [[]|]. }
    unfold g. destruct (decide _) as [Hx|]; last done.
    by rewrite (proof_irrel Hx eq_refl).
  Qed.
End ofe_fun.

Arguments ofe_funC {_} _.
Notation "A -c> B" :=
  (@ofe_funC A (λ _, B)) (at level 99, B at level 200, right associativity).

Definition ofe_fun_map {A} {B1 B2 : A → ofeT} (f : ∀ x, B1 x → B2 x)
  (g : ofe_fun B1) : ofe_fun B2 := λ x, f _ (g x).

Lemma ofe_fun_map_ext {A} {B1 B2 : A → ofeT} (f1 f2 : ∀ x, B1 x → B2 x)
  (g : ofe_fun B1) :
  (∀ x, f1 x (g x) ≡ f2 x (g x)) → ofe_fun_map f1 g ≡ ofe_fun_map f2 g.
Proof. done. Qed.
Lemma ofe_fun_map_id {A} {B : A → ofeT} (g : ofe_fun B) :
  ofe_fun_map (λ _, id) g = g.
Proof. done. Qed.
Lemma ofe_fun_map_compose {A} {B1 B2 B3 : A → ofeT}
    (f1 : ∀ x, B1 x → B2 x) (f2 : ∀ x, B2 x → B3 x) (g : ofe_fun B1) :
  ofe_fun_map (λ x, f2 x ∘ f1 x) g = ofe_fun_map f2 (ofe_fun_map f1 g).
Proof. done. Qed.

Instance ofe_fun_map_ne {A} {B1 B2 : A → ofeT} (f : ∀ x, B1 x → B2 x) n :
  (∀ x, Proper (dist n ==> dist n) (f x)) →
  Proper (dist n ==> dist n) (ofe_fun_map f).
Proof. by intros ? y1 y2 Hy x; rewrite /ofe_fun_map (Hy x). Qed.

Definition ofe_funC_map {A} {B1 B2 : A → ofeT} (f : ofe_fun (λ x, B1 x -n> B2 x)) :
  ofe_funC B1 -n> ofe_funC B2 := CofeMor (ofe_fun_map f).
Instance ofe_funC_map_ne {A} {B1 B2 : A → ofeT} :
  NonExpansive (@ofe_funC_map A B1 B2).
Proof. intros n f1 f2 Hf g x; apply Hf. Qed.

Program Definition ofe_funCF {C} (F : C → cFunctor) : cFunctor := {|
  cFunctor_car A B := ofe_funC (λ c, cFunctor_car (F c) A B);
  cFunctor_map A1 A2 B1 B2 fg := ofe_funC_map (λ c, cFunctor_map (F c) fg)
|}.
Next Obligation.
  intros C F A1 A2 B1 B2 n ?? g. by apply ofe_funC_map_ne=>?; apply cFunctor_ne.
Qed.
Next Obligation.
  intros C F A B g; simpl. rewrite -{2}(ofe_fun_map_id g).
  apply ofe_fun_map_ext=> y; apply cFunctor_id.
Qed.
Next Obligation.
  intros C F A1 A2 A3 B1 B2 B3 f1 f2 f1' f2' g. rewrite /= -ofe_fun_map_compose.
  apply ofe_fun_map_ext=>y; apply cFunctor_compose.
Qed.

Notation "T -c> F" := (@ofe_funCF T%type (λ _, F%CF)) : cFunctor_scope.

Instance ofe_funCF_contractive {C} (F : C → cFunctor) :
  (∀ c, cFunctorContractive (F c)) → cFunctorContractive (ofe_funCF F).
Proof.
  intros ? A1 A2 B1 B2 n ?? g.
  by apply ofe_funC_map_ne=>c; apply cFunctor_contractive.
Qed.

(** Constructing isomorphic OFEs *)
Lemma iso_ofe_mixin {A : ofeT} `{Equiv B, Dist B} (g : B → A)
  (g_equiv : ∀ y1 y2, y1 ≡ y2 ↔ g y1 ≡ g y2)
  (g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2) : OfeMixin B.
Proof.
  split.
  - intros y1 y2. rewrite g_equiv. setoid_rewrite g_dist. apply equiv_dist.
  - split.
    + intros y. by apply g_dist.
    + intros y1 y2. by rewrite !g_dist.
    + intros y1 y2 y3. rewrite !g_dist. intros ??; etrans; eauto.
  - intros n y1 y2. rewrite !g_dist. apply dist_S.
Qed.

Section iso_cofe_subtype.
  Context {A B : ofeT} `{Cofe A} (P : A → Prop) (f : ∀ x, P x → B) (g : B → A).
  Context (g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2).
  Let Hgne : NonExpansive g.
  Proof. intros n y1 y2. apply g_dist. Qed.
  Existing Instance Hgne.
  Context (gf : ∀ x Hx, g (f x Hx) ≡ x).
  Context (Hlimit : ∀ c : chain B, P (compl (chain_map g c))).
  Program Definition iso_cofe_subtype : Cofe B :=
    {| compl c := f (compl (chain_map g c)) _ |}.
  Next Obligation. apply Hlimit. Qed.
  Next Obligation.
    intros n c; simpl. apply g_dist. by rewrite gf conv_compl.
  Qed.
End iso_cofe_subtype.

Lemma iso_cofe_subtype' {A B : ofeT} `{Cofe A}
  (P : A → Prop) (f : ∀ x, P x → B) (g : B → A)
  (Pg : ∀ y, P (g y))
  (g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2)
  (gf : ∀ x Hx, g (f x Hx) ≡ x)
  (Hlimit : LimitPreserving P) : Cofe B.
Proof. apply: (iso_cofe_subtype P f g)=> // c. apply Hlimit=> ?; apply Pg. Qed.

Definition iso_cofe {A B : ofeT} `{Cofe A} (f : A → B) (g : B → A)
  (g_dist : ∀ n y1 y2, y1 ≡{n}≡ y2 ↔ g y1 ≡{n}≡ g y2)
  (gf : ∀ x, g (f x) ≡ x) : Cofe B.
Proof. by apply (iso_cofe_subtype (λ _, True) (λ x _, f x) g). Qed.

(** Sigma *)
Section sigma.
  Context {A : ofeT} {P : A → Prop}.
  Implicit Types x : sig P.

  (* TODO: Find a better place for this Equiv instance. It also
     should not depend on A being an OFE. *)
  Instance sig_equiv : Equiv (sig P) := λ x1 x2, `x1 ≡ `x2.
  Instance sig_dist : Dist (sig P) := λ n x1 x2, `x1 ≡{n}≡ `x2.

  Definition sig_equiv_alt x y : x ≡ y ↔ `x ≡ `y := reflexivity _.
  Definition sig_dist_alt n x y : x ≡{n}≡ y ↔ `x ≡{n}≡ `y := reflexivity _.

  Lemma exist_ne n a1 a2 (H1 : P a1) (H2 : P a2) :
    a1 ≡{n}≡ a2 → a1 ↾ H1 ≡{n}≡ a2 ↾ H2.
  Proof. done. Qed.

  Global Instance proj1_sig_ne : NonExpansive (@proj1_sig _ P).
  Proof. by intros n [a Ha] [b Hb] ?. Qed.
  Definition sig_ofe_mixin : OfeMixin (sig P).
  Proof. by apply (iso_ofe_mixin proj1_sig). Qed.
  Canonical Structure sigC : ofeT := OfeT (sig P) sig_ofe_mixin.

  Global Instance sig_cofe `{Cofe A, !LimitPreserving P} : Cofe sigC.
  Proof. apply (iso_cofe_subtype' P (exist P) proj1_sig)=> //. by intros []. Qed.

  Global Instance sig_discrete (x : sig P) :  Discrete (`x) → Discrete x.
  Proof. intros ? y. rewrite sig_dist_alt sig_equiv_alt. apply (discrete _). Qed.
  Global Instance sig_ofe_discrete : OfeDiscrete A → OfeDiscrete sigC.
  Proof. intros ??. apply _. Qed.
End sigma.

Arguments sigC {_} _.


(** ** An experiment using extended recursion to define [Eval] *)

(**
    This file contains an attempt at using the extended induction principle
    for terms to define the [eval] function.  Since it recurses on the
    structure of terms, it doesn't need the notion of gas (until we add recursion).

   It works pretty well until we get to [tapp]: we can get [v1] and [v2] and
   turn [v2] into [(vabs x t gf)] but there's no way to evaluate [t]
   since there's no direct access to [eval].

   However, the [tabs x T t] branch has [ev_t] which is essentially [(eval t)].
   So what we want is to store ev_t in [vabs] instead of the raw term, [t].
   But the type of [ev_t] is [(valist -> nat -> ef_return)] which runs into the
   "Non strictly positive occurrence" prohibition because [valist] is to the left of
   an arrow.  Variations with [value] or [vbinding] to the left also don't work.
*)

Load Init.
Require Export SfLib.
Require Import LibTactics.

Require Export Common LDef.
Import Common LDef.

Inductive ef_return_g (Tr : Type) :  Type :=
  | efr_normal : Tr -> ef_return_g Tr
  | efr_nogas : ef_return_g Tr
  | efr_stuck : ef_return_g Tr.

Arguments efr_normal [Tr] _.
Arguments efr_nogas [Tr].
Arguments efr_stuck [Tr].

Inductive value : Type :=
  | vid : id -> value
  | vabs : id -> (valist -> nat -> ef_return_g value) -> valist -> value
  | vtrue : value
  | vfalse : value
  | vrcd : valist -> value
with vbinding : Type :=
  | vbF : id -> value -> vbinding
with valist : Type :=
  | vl_nil : valist
  | vl_cons : vbinding -> valist -> valist.

Definition ef_return := ef_return_g value.
Definition bf_return := ef_return_g vbinding.
Definition xf_return := ef_return_g valist.

Notation "'LETRT' x <== er1 'IN' er2"
   := (match er1 with
         | efr_normal x => er2
         | efr_nogas => efr_nogas
         | efr_stuck => efr_stuck
       end)
   (right associativity, at level 60).

Fixpoint alookup (x: id) (a: valist) : option value :=
  match a with
    | vl_nil => None
    | vl_cons (vbF y v) a' =>
        if eq_id_dec y x then (Some v) else (alookup x a')
    end.

Definition eval_tmf : tm -> valist -> nat -> ef_return :=
  tm_xrect
    (*P*)    (fun _ => valist -> nat -> ef_return)
    (*Q*)    (fun _ => valist -> nat -> bf_return)
    (*QL*)   (fun _ => valist -> nat -> xf_return)
    (* ttrue *) (fun _ _ => efr_normal vtrue)
    (* ttfalse *) (fun _ _ => efr_normal vfalse)
    (* tvar *) (fun x g n' =>
                  match alookup x g with
                    | Some v => efr_normal v
                    | None => efr_stuck
                  end)
    (* tabs *) (fun x T t ev_t g n' =>
                  efr_normal (vabs x (ev_t vl_nil) g))
    (* tapp *) (fun t1 ef_t1 t2 ef_t2 g n' =>
                  LETRT v1 <== ef_t1 g n' IN
                    LETRT v2 <== ef_t2 g n' IN
                      match v1 with
                        | vabs x tf te =>
                            tf (* (vl_cons (vbF x v2) te) *) n'
                        | _ => efr_stuck
                      end)
    (* trcd *) (fun Fs ef_Fs g n' =>
                  LETRT bs <== ef_Fs g n' IN efr_normal (vrcd bs))
    (* tproj *) (fun t ef_t x g n' =>
                  LETRT v <== ef_t g n' IN
                    match v with
                      | vrcd bs => match alookup x bs with
                                     | Some v => efr_normal v
                                     | _ => efr_stuck
                                   end
                      | _ => efr_stuck
                    end)
      (* tif *) (fun tb ef_tb tt ef_tt te ef_te g n' =>
                  LETRT vb <== ef_tb g n' IN
                    match vb with
                      | vtrue => ef_tt g n'
                      | vfalse => ef_te g n'
                      | _ => efr_stuck
                    end)
      (* tlet *) (fun F ef_F t2 ef_t2 g n' =>
                  LETRT b <== ef_F g n' IN
                    ef_t2 (vl_cons b g) n')
      (* Fv *) (fun x t ef_t g n' =>
                  LETRT v <== ef_t g n' IN
                    efr_normal (vbF x v))
      (* nil *) (fun _ _ => efr_normal vl_nil)
      (* cons *) (fun F ef_F Fs' ef_Fs' g n' =>
                  LETRT b <== ef_F g n' IN
                    LETRT bs' <== ef_Fs' g n' IN
                      efr_normal (vl_cons b bs')).

Fixpoint evalF (t : tm) (g : valist) (n : nat) : ef_return :=
  match n with
    | O => efr_nogas
    | S n' => eval_tmf t g n'
  end.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.
Require map.Map.
Require map.Occ.
Require map.MapInjection.

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Inductive array (a:Type) :=
  | mk_array : Z -> (map.Map.map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map.Map.map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (map.Map.get (elts a1) i).

(* Why3 assumption *)
Definition set {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (map.Map.set (elts a1) i v)).

(* Why3 assumption *)
Inductive sparse_array
  (a:Type) :=
  | mk_sparse_array : (array a) -> (array Z) -> (array Z) -> Z -> a ->
      sparse_array a.
Axiom sparse_array_WhyType : forall (a:Type) {a_WT:WhyType a},
  WhyType (sparse_array a).
Existing Instance sparse_array_WhyType.
Implicit Arguments mk_sparse_array [[a]].

(* Why3 assumption *)
Definition def {a:Type} {a_WT:WhyType a} (v:(sparse_array a)): a :=
  match v with
  | (mk_sparse_array x x1 x2 x3 x4) => x4
  end.

(* Why3 assumption *)
Definition card {a:Type} {a_WT:WhyType a} (v:(sparse_array a)): Z :=
  match v with
  | (mk_sparse_array x x1 x2 x3 x4) => x3
  end.

(* Why3 assumption *)
Definition back {a:Type} {a_WT:WhyType a} (v:(sparse_array a)): (array Z) :=
  match v with
  | (mk_sparse_array x x1 x2 x3 x4) => x2
  end.

(* Why3 assumption *)
Definition index {a:Type} {a_WT:WhyType a} (v:(sparse_array a)): (array Z) :=
  match v with
  | (mk_sparse_array x x1 x2 x3 x4) => x1
  end.

(* Why3 assumption *)
Definition values {a:Type} {a_WT:WhyType a} (v:(sparse_array a)): (array
  a) := match v with
  | (mk_sparse_array x x1 x2 x3 x4) => x
  end.

(* Why3 assumption *)
Definition is_elt {a:Type} {a_WT:WhyType a} (a1:(sparse_array a))
  (i:Z): Prop := ((0%Z <= (get (index a1) i))%Z /\ ((get (index a1)
  i) < (card a1))%Z) /\ ((get (back a1) (get (index a1) i)) = i).

Parameter value: forall {a:Type} {a_WT:WhyType a}, (sparse_array a) -> Z ->
  a.

Axiom value_def : forall {a:Type} {a_WT:WhyType a}, forall (a1:(sparse_array
  a)) (i:Z), ((is_elt a1 i) -> ((value a1 i) = (get (values a1) i))) /\
  ((~ (is_elt a1 i)) -> ((value a1 i) = (def a1))).

(* Why3 assumption *)
Definition length1 {a:Type} {a_WT:WhyType a} (a1:(sparse_array a)): Z :=
  (length (values a1)).

Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.99.1," timelimit 5; admit.

(* Why3 goal *)
Theorem permutation : forall {a:Type} {a_WT:WhyType a},
  forall (a1:(sparse_array a)), (((0%Z <= (card a1))%Z /\
  (((card a1) <= (length (values a1)))%Z /\
  ((length (values a1)) <= 1000%Z)%Z)) /\
  ((((length (values a1)) = (length (index a1))) /\
  ((length (index a1)) = (length (back a1)))) /\ forall (i:Z),
  ((0%Z <= i)%Z /\ (i < (card a1))%Z) -> (((0%Z <= (get (back a1) i))%Z /\
  ((get (back a1) i) < (length (values a1)))%Z) /\ ((get (index a1)
  (get (back a1) i)) = i)))) -> (((card a1) = (length1 a1)) -> forall (i:Z),
  ((0%Z <= i)%Z /\ (i < (length1 a1))%Z) -> (is_elt a1 i)).
(* Why3 intros a a_WT a1 ((h1,(h2,h3)),((h4,h5),h6)) h7 i (h8,h9). *)
intros a _a a1.
destruct a1 as ((n0, a_values), (n1, a_index), (n2, a_back), a_card, a_def); simpl.
unfold is_elt, length1, get; simpl.
intro H; decompose [and] H; clear H.
subst n1 n2.
intros. subst a_card.
assert (inj: MapInjection.injective a_back n0) by ae.
assert (rng: MapInjection.range a_back n0) by ae.
generalize (MapInjection.injective_surjective a_back n0 inj rng); intro surj.
destruct (surj i H1) as (j, (hj1, hj2)).
ae.
Admitted.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D P Cprime Dprime : Universe, ((wd_ A B /\ (wd_ C A /\ (wd_ C B /\ (wd_ D A /\ (wd_ D B /\ (wd_ C D /\ (wd_ A Cprime /\ (wd_ A Dprime /\ (wd_ Cprime P /\ (wd_ Dprime P /\ (wd_ A P /\ (wd_ B P /\ (wd_ D Dprime /\ (wd_ C Cprime /\ (col_ P A B /\ (col_ A B Cprime /\ (col_ A B Dprime /\ col_ C P D))))))))))))))))) -> col_ Cprime P Dprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^230 - 27
Base: 32
***)

Definition curve : CurveParameters :=
  {|
    sz := 8%nat;
    base := 32;
    bitwidth := 32;
    s := 2^230;
    c := [(1, 27)];
    carry_chains := None;

    a24 := None;
    coef_div_modulus := None;

    goldilocks := None;
    karatsuba := None;
    montgomery := true;
    freeze := Some false;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Coq.Lists.List.
Require Import veristar.variables veristar.datatypes.
Require Import compcert.Coqlib.
Require Import VST.veric.Coqlib2.
Require Import ZArith.

Require Import veristar.fresh.
Require Import veristar.veristar.
Require Import veristar.basic.

Definition oracle (ent: entailment) : bool :=
 match VeriStar.check_entailment ent with
 | VeriStar.Valid => true
 | VeriStar.C_example _ => false
 | VeriStar.Aborted _ _ => false
 end.

Bind Scope entail_scope with entailment.
Local Open Scope entail_scope.

Definition incon (a: assertion) : bool :=
   oracle (Entailment a
               (Assertion (Nequ Nil Nil :: nil)
                              match a with (Assertion _ sigma) => sigma end)).

Lemma eq_expr (e1 e2: expr) : {e1=e2}+{e1<>e2}.
Proof.
intros.
 destruct e1; destruct e2; auto; try  decide equality; apply Ident.eq_dec.
Defined.

Fixpoint exorcize (e: expr) (pi: list pn_atom) (sigma0 sigma: list space_atom) (nextv: var)
         : option (list assertion) :=
 match sigma with
 | nil => if incon (Assertion pi (rev sigma0)) then Some nil else None
 | Lseg f f' :: sigma1 =>
          if oracle (Entailment
                         (Assertion pi (rev sigma0 ++ (Lseg f f') :: sigma1))
                         (Assertion (Equ e f :: nil) (rev sigma0 ++ Lseg f f' :: sigma1)))
          then match exorcize e (Equ f f' :: pi)  (Lseg f f' :: sigma0) sigma1 nextv with
                   | Some l => Some (Assertion pi (Next e (Var nextv) :: Lseg (Var nextv) f' :: rev sigma0 ++ sigma1) ::l)
                   | None => None
                  end
          else exorcize e pi (Lseg f f' :: sigma0) sigma1 nextv
 | a :: sigma1 =>
          exorcize e pi (a :: sigma0) sigma1 nextv
 end.

Fixpoint isolate' (e: expr) (pi: list pn_atom) (sigma0 sigma: list space_atom) (nextv: var) (count: nat)
         : option (list assertion) :=
 match sigma with
 | nil => if  lt_dec count 2
              then None
              else if incon (Assertion (Equ e Nil :: pi) (rev sigma0))
                     then exorcize e pi nil (rev sigma0) nextv
                     else None
 | Next e1 e2 :: sigma1 =>
          if eq_expr e e1
          then Some [Assertion pi (Next e e2 :: rev sigma0 ++ sigma1)]
          else if oracle (Entailment
                         (Assertion pi (rev sigma0 ++ (Next e1 e2) :: sigma1))
                         (Assertion (Equ e e1 :: nil) (rev sigma0 ++ (Next e1 e2) :: sigma1)))
          then Some [Assertion pi (Next e e2 :: rev sigma0 ++ sigma1)]
          else isolate' e pi (Next e1 e2 :: sigma0) sigma1 nextv count
 | Lseg f f' :: sigma1 =>
          if oracle (Entailment
                         (Assertion pi (rev sigma0 ++ (Lseg f f') :: sigma1))
                         (Assertion (Equ e f :: Nequ f f' :: nil ) (rev sigma0 ++ (Lseg f f') :: sigma1)))
          then Some [Assertion pi (Next e (Var nextv) :: Lseg (Var nextv) f' :: rev sigma0 ++ sigma1)]
          else if oracle (Entailment
                         (Assertion pi (rev sigma0 ++ (Lseg f f') :: sigma1))
                         (Assertion (Equ e f :: nil) (rev sigma0 ++ (Lseg f f') :: sigma1)))
                 then isolate' e pi (Lseg f f' :: sigma0) sigma1 nextv (S count)
          else isolate' e pi (Lseg f f' :: sigma0) sigma1 nextv count
 end.

Definition isolate (e: expr) (P: assertion) (nextv: var) : option (list assertion) :=
 match P with Assertion pi sigma =>
  isolate' e pi nil sigma nextv 0
 end.


(** * Push-Button Synthesis of Montgomery Reduction *)
Require Import Coq.Strings.String.
Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Coq.derive.Derive.
Require Import Crypto.Util.ErrorT.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ZRange.
Require Import Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.ModInv.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Rewriter.Language.Language.
Require Import Crypto.Language.API.
Require Import Crypto.Stringification.Language.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.FancyMontgomeryReduction.
Require Import Crypto.BoundsPipeline.
Require Import Crypto.COperationSpecifications.
Require Import Crypto.Fancy.Compiler.
Require Import Crypto.PushButtonSynthesis.ReificationCache.
Require Import Crypto.PushButtonSynthesis.Primitives.
Require Import Crypto.PushButtonSynthesis.FancyMontgomeryReductionReificationCache.
Require Import Crypto.PushButtonSynthesis.InvertHighLow.
Import ListNotations.
Local Open Scope Z_scope. Local Open Scope list_scope. Local Open Scope bool_scope.

Import
  Language.Compilers
  Language.Wf.Compilers
  Stringification.Language.Compilers.
Import Compilers.API.

Import COperationSpecifications.Primitives.

Import COperationSpecifications.MontgomeryReduction.

Import Associational Positional FancyMontgomeryReduction.MontgomeryReduction.

Local Set Keyed Unification. (* needed for making [autorewrite] fast, c.f. COQBUG(https://github.com/coq/coq/issues/9283) *)

Local Opaque reified_montred_gen. (* needed for making [autorewrite] not take a very long time *)

Section rmontred.
  Context {output_language_api : ToString.OutputLanguageAPI}
          {static : static_opt}
          {internal_static : internal_static_opt}
          (N R N' : Z) (n : nat)
          (machine_wordsize : Z).

  Let value_range := r[0 ~> (2^machine_wordsize - 1)%Z]%zrange.
  Let flag_range := r[0 ~> 1]%zrange.
  Let bound := Some value_range.
  Let consts_list := [N; N'].
  Let R' := match Z.modinv R N with
            | Some R' => R'
            | None => 0
            end.

  Definition possible_values_of_machine_wordsize
    := [1; machine_wordsize / 2; machine_wordsize; 2 * machine_wordsize]%Z.
  Local Arguments possible_values_of_machine_wordsize / .

  Let possible_values := possible_values_of_machine_wordsize.

  Local Existing Instance default_language_naming_conventions.
  Local Instance widen_carry : widen_carry_opt := false.
  Local Instance widen_bytes : widen_bytes_opt := true.
  Local Instance only_signed : only_signed_opt := false.
  Local Instance no_select_size : no_select_size_opt := None.
  Local Instance split_mul_to : split_mul_to_opt := None.
  Local Instance split_multiret_to : split_multiret_to_opt := None.
  Local Instance unfold_value_barrier : unfold_value_barrier_opt := true.
  Local Instance assembly_hints_lines : assembly_hints_lines_opt := None.
  Local Instance low_level_rewriter_method : low_level_rewriter_method_opt := default_low_level_rewriter_method.

  Let fancy_args
    := (Some {| Pipeline.invert_low log2wordsize := invert_low log2wordsize consts_list;
                Pipeline.invert_high log2wordsize := invert_high log2wordsize consts_list;
                Pipeline.value_range := value_range;
                Pipeline.flag_range := flag_range |}).

  Lemma fancy_args_good
    : match fancy_args with
      | Some {| Pipeline.invert_low := il ; Pipeline.invert_high := ih |}
        => (forall s v v' : Z, il s v = Some v' -> v = Z.land v' (2^(s/2)-1))
           /\ (forall s v v' : Z, ih s v = Some v' -> v = Z.shiftr v' (s/2))
      | None => True
      end.
  Proof.
    cbv [fancy_args invert_low invert_high constant_to_scalar constant_to_scalar_single consts_list fold_right];
      split; intros; break_innermost_match_hyps; Z.ltb_to_lt; subst; congruence.
  Qed.
  Local Hint Extern 1 => apply fancy_args_good: typeclass_instances. (* This is a kludge *)

  (** Note: If you change the name or type signature of this
        function, you will need to update the code in CLI.v *)
  Definition check_args {T} (res : Pipeline.ErrorT T)
    : Pipeline.ErrorT T
    := fold_right
         (fun '(b, e) k => if b:bool then Error e else k)
         res
         [
            ((negb (1 <? R))%Z, Pipeline.Value_not_ltZ "R ≤ 1" 1 R);
            ((n =? 0)%nat, Pipeline.Values_not_provably_distinctZ "n = 0" (Z.of_nat n) 0);
            ((R' =? 0)%Z, Pipeline.No_modular_inverse "R⁻¹ mod N" R N);
            (negb ((R * R') mod N =? 1 mod N)%Z, Pipeline.Values_not_provably_equalZ "(R * R') mod N ≠ 1 mod N" ((R * R') mod N) (1 mod N));
            (negb ((N * N') mod R =? (-1) mod R)%Z, Pipeline.Values_not_provably_equalZ "(N * N') mod R ≠ (-1) mod R" ((N * N') mod R) ((-1) mod R));
            (negb (2 ^ machine_wordsize =? R)%Z, Pipeline.Values_not_provably_equalZ "2^machine_wordsize ≠ R" (2^machine_wordsize) R);
            ((negb (0 <? N))%Z, Pipeline.Value_not_ltZ "N ≤ 0" 0 N);
            ((negb (N <? R))%Z, Pipeline.Value_not_ltZ "R ≤ N" R N);
            ((negb (0 <=? N'))%Z, Pipeline.Value_not_leZ "N' < 0" 0 N');
            ((negb (N' <? R))%Z, Pipeline.Value_not_ltZ "R ≤ N'" R N');
            ((negb (2 <=? machine_wordsize))%Z, Pipeline.Value_not_leZ "machine_wordsize < 2" 2 machine_wordsize)].

  Local Arguments Z.mul !_ !_.
  Local Ltac prepare_use_curve_good _ :=
    let curve_good := lazymatch goal with | curve_good : check_args _ = Success _ |- _ => curve_good end in
    clear -curve_good;
    cbv [check_args] in curve_good |- *;
    cbn [fold_right] in curve_good |- *;
    repeat first [ match goal with
                   | [ H : context[match ?b with true => _ | false => _ end ] |- _ ] => destruct b eqn:?
                   end
                 | discriminate
                 | progress Reflect.reflect_hyps
                 | assumption
                 | apply conj
                 | progress destruct_head'_and ].

  Local Ltac use_curve_good_t :=
    repeat first [ assumption
                 | progress cbv [EquivModulo.Z.equiv_modulo]
                 | progress rewrite ?Z.mul_0_r, ?Pos.mul_1_r, ?Z.mul_1_r in *
                 | reflexivity
                 | lia
                 | progress cbn in *
                 | progress intros
                 | solve [ auto with zarith ]
                 | rewrite Z.log2_pow2 by use_curve_good_t ].

  Context (curve_good : check_args (Success tt) = Success tt).

  Lemma use_curve_good
    : 0 <= N < R
      /\ 0 <= N' < R
      /\ N <> 0
      /\ R > 1
      /\ EquivModulo.Z.equiv_modulo R (N * N') (-1)
      /\ EquivModulo.Z.equiv_modulo N (R * R') 1
      /\ n <> 0%nat
      /\ 2 <= machine_wordsize
      /\ 2 ^ machine_wordsize = R.
  Proof using curve_good.
    prepare_use_curve_good ().
    { use_curve_good_t. }
    { use_curve_good_t. }
    { use_curve_good_t. }
  Qed.

  Definition montred
    := Pipeline.BoundsPipeline
         false (* subst01 *)
         fancy_args (* fancy *)
         possible_values
         (reified_montred_gen
            @ GallinaReify.Reify N @ GallinaReify.Reify R @ GallinaReify.Reify N' @ GallinaReify.Reify machine_wordsize)
         (bound, (bound, tt))
         bound.

  Definition smontred (prefix : string)
    : string * (Pipeline.ErrorT (Pipeline.ExtendedSynthesisResult _))
    := Eval cbv beta in
        FromPipelineToString
          machine_wordsize prefix "montred" montred
          (fun _ _ _ => @nil string).

  Local Ltac solve_montred_preconditions :=
    repeat first [ lia
           | apply use_curve_good
           | progress (push_Zmod; pull_Zmod)
           | progress autorewrite with zsimplify_fast
           | rewrite Z.div_add' by lia
           | rewrite Z.div_small by lia
           | progress Z.rewrite_mod_small ].

  Local Strategy -100 [montred]. (* needed for making Qed not take forever *)
  Local Strategy -100 [montred' reified_montred_gen]. (* needed for making prove_correctness not take forever *)
  Lemma montred_correct res (Hres : montred = Success res)
    : montred_correct N R R' (API.Interp res).
  Proof using n curve_good.
    cbv [montred_correct]; intros.
    rewrite <- MontgomeryReduction.montred'_correct with (R:=R) (N':=N') (Zlog2R:=machine_wordsize) (n:=n) (lo:=lo) (hi:=hi) by solve_montred_preconditions.
    prove_correctness' ltac:(fun _ => idtac) use_curve_good.
    { cbv [ZRange.type.base.option.is_bounded_by ZRange.type.base.is_bounded_by bound is_bounded_by_bool value_range upper lower].
      rewrite Bool.andb_true_iff, !Z.leb_le. lia. }
    { cbv [ZRange.type.base.option.is_bounded_by ZRange.type.base.is_bounded_by bound is_bounded_by_bool value_range upper lower].
      rewrite Bool.andb_true_iff, !Z.leb_le. lia. }
  Qed.

  Lemma Wf_montred res (Hres : montred = Success res) : Wf res.
  Proof using Type. prove_pipeline_wf (). apply fancy_args_good. Qed.
End rmontred.

Module Export Hints.
  Hint Opaque
       montred
  : wf_op_cache.
  Hint Immediate
       Wf_montred
  : wf_op_cache.
End Hints.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery64_2e384m5x2e368m1_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.