From iris.base_logic Require Import base_logic.
From stdpp Require fin_map_dom.
From iris.proofmode Require Export tactics.
Import uPred.

Section definition.
  Context `{Countable K}.
  Context {PROP : bi}.

  Definition big_sepSS(s : gset K) (Φ : K -> K -> PROP) : PROP:=
    [∗ set] x1 ∈ s, [∗ set] x2 ∈ s, Φ x1 x2.

  Definition big_sepSS_singleton(s : gset K) (x0: K) (Φ : K -> K -> PROP) : PROP:=
    if decide (x0 ∈ s) then
    (Φ x0 x0 ∗ ([∗ set] x ∈ (s∖ {[x0]}), Φ x0 x ∗ Φ x x0))%I
    else ([∗ set] x ∈ (s∖ {[x0]}), Φ x0 x ∗ Φ x x0)%I.

  Definition big_sepSS_except(s : gset K) (x0: K) (Φ : K -> K -> PROP) : PROP:=
    big_sepSS (s ∖ {[x0]}) Φ.

End definition.

Section lemmas.
  Context `{Countable K}.
  Context {PROP : bi}.
  Implicit Types s : gset K.
  Implicit Type Φ : (K -> K -> PROP).

  Lemma big_sepSS_union_singleton s (x:K) Φ:
    x ∉ s ->
    big_sepSS s Φ ∗ big_sepSS_singleton (s ∪ {[x]}) x Φ ⊢ big_sepSS (s ∪ {[x]}) Φ.
  Proof.
    iIntros (Hnin) "[SS single]".
    rewrite /big_sepSS.
    rewrite big_sepS_union.
    rewrite big_sepS_singleton.
    rewrite (big_sepS_proper (λ y, [∗ set] x2 ∈ (s ∪ {[x]}), Φ y x2)%I).
    2:{
      intros.
      iApply big_sepS_union.
      set_solver.
    }
    rewrite big_sepS_sep.
    iFrame "SS".
    rewrite /big_sepSS_singleton.
    rewrite 2?big_sepS_union.
    rewrite 2?big_sepS_singleton.
    rewrite (big_sepS_proper (λ y, [∗ set] y0 ∈ {[x]}, Φ y y0)%I).
    2:{
      intros.
      iApply big_sepS_singleton.
    }
    assert ((s ∪ {[x]}) ∖ {[x]} = s) as ->. set_solver.
    case_decide.
    rewrite big_sepS_sep.
    iDestruct ("single") as "[$ [$ $]]".
    set_solver.
    set_solver.
    set_solver.
  Qed.

  Lemma big_sepSS_difference_singleton s (x0:K) Φ:
    x0 ∈ s ->
    big_sepSS s Φ ⊢ big_sepSS_except s x0 Φ ∗ big_sepSS_singleton s x0 Φ.
  Proof.
    iIntros (Hin) "SS".
    rewrite /big_sepSS_except /big_sepSS.
    rewrite /big_sepSS_singleton.
    assert (s = s ∖ {[x0]} ∪ {[x0]}). rewrite difference_union_L. set_solver + Hin.
    rewrite H0 in Hin.
    rewrite H0.
    assert ((s ∖ {[x0]} ∪ {[x0]}) ∖ {[x0]} = s ∖ {[x0]}) as ->.
    set_solver +.
    rewrite big_sepS_union.
    rewrite big_sepS_singleton.
    rewrite big_sepS_union.
    rewrite big_sepS_singleton.
    rewrite (big_sepS_proper (λ y, [∗ set] x2 ∈ (s ∖ {[x0]} ∪ {[x0]}), Φ y x2)%I).
    2:{
      intros.
      iApply big_sepS_union.
      set_solver.
    }
    rewrite big_sepS_sep.
    rewrite (big_sepS_proper (λ y, [∗ set] y0 ∈ {[x0]}, Φ y y0)%I).
    2:{
      intros.
      iApply big_sepS_singleton.
    }
    case_decide.
    rewrite big_sepS_sep.
    iDestruct ("SS") as "(($&$)&$&$)".
    done.
    set_solver.
    set_solver.
  Qed.

  Lemma big_sepSS_sep s Φ Φ1 Φ2 :
    (∀ x y, Φ x y ⊣⊢ Φ1 x y ∗ Φ2 x y) ->
    big_sepSS s Φ ⊣⊢ big_sepSS s Φ1 ∗ big_sepSS s Φ2.
  Proof.
    intros.
    rewrite /big_sepSS.
    rewrite (big_sepS_proper (λ x1, [∗ set] x2 ∈ s, Φ x1 x2)%I).
    2:{
      intros.
      rewrite (big_sepS_proper (λ x2, Φ x x2)%I).
      2:{
        intros.
        apply H0.
      }
      iApply big_sepS_sep.
    }
    rewrite big_sepS_sep.
    done.
  Qed.

  Lemma big_sepSS_singletion_union s v v' Φ :
    v ∈ s ->
    big_sepSS_singleton (s ∖ {[v]}) v' Φ ∗ big_sepSS_singleton {[v]} v' Φ
    ⊣⊢ big_sepSS_singleton s v' Φ.
  Proof.
    intro.
    rewrite /big_sepSS_singleton.
    case_decide.
    case_decide;first set_solver.
    case_decide;last set_solver.
    rewrite -sep_assoc.
    rewrite -big_sepS_union.
    rewrite -difference_union_distr_l_L.
    assert ((s ∖ {[v]} ∪ {[v]}) = s) as ->.
    rewrite difference_union_L. set_solver.
    done.
    set_solver.
    case_decide.
    case_decide;last set_solver.
    rewrite sep_comm .
    rewrite -sep_assoc.
    rewrite -big_sepS_union.
    rewrite -difference_union_distr_l_L.
    assert (({[v]} ∪ s ∖ {[v]}) = s) as ->.
    rewrite union_comm_L. rewrite difference_union_L. set_solver.
    done.
    set_solver.
    case_decide. set_solver.
    rewrite -big_sepS_union.
    rewrite -difference_union_distr_l_L.
    assert ((s ∖ {[v]} ∪ {[v]}) = s) as ->.
    rewrite difference_union_L. set_solver.
    done.
    set_solver.
  Qed.

  Lemma big_sepSS_later (s : gset K) (Φ : K -> K -> PROP) `{!BiAffine PROP}:
    ▷ big_sepSS s Φ ⊣⊢ big_sepSS s (λ i j, ▷ (Φ i j)).
  Proof.
    rewrite /big_sepSS.
    rewrite (big_sepS_later (λ x1, [∗ set] x2 ∈ s, Φ x1 x2)%I s).
    iApply big_sepS_proper.
    intros. iApply big_sepS_later.
  Qed.

  Lemma big_sepSS_except_later (s : gset K) i (Φ : K -> K -> PROP) `{!BiAffine PROP}:
    ▷ big_sepSS_except s i Φ ⊣⊢ big_sepSS_except s i (λ i j, ▷ (Φ i j)).
  Proof.
    rewrite /big_sepSS_except.
    iApply big_sepSS_later.
  Qed.

  Lemma big_sepSS_singleton_later (s : gset K) i (Φ : K -> K -> PROP) `{!BiAffine PROP}:
    ▷ big_sepSS_singleton s i Φ ⊣⊢ big_sepSS_singleton s i (λ i j, ▷ (Φ i j)).
  Proof.
    rewrite /big_sepSS_singleton.
    case_decide.
    rewrite later_sep.
    rewrite big_sepS_later.
    iSplitL; iIntros "[$ ?]".
    iApply big_sepS_proper.
    intros. symmetry. iApply later_sep. done.
    iApply big_sepS_proper.
    intros. iApply later_sep. done.
    rewrite big_sepS_later.
    iApply big_sepS_proper.
    intros. iApply later_sep.
  Qed.

End lemmas.


From Undecidability.Shared.Libs.PSL Require Export Prelim EqDec.

Export ListNotations.
Notation "x 'el' A" := (In x A) (at level 70).
Notation "A <<= B" := (incl A B) (at level 70).
Notation "| A |" := (length A) (at level 65).
Definition equi X (A B : list X) : Prop := incl A B /\ incl B A.
Notation "A === B" := (equi A B) (at level 70).
Hint Unfold equi : core.

Hint Extern 4 =>
match goal with
|[ H: ?x el nil |- _ ] => destruct H
end : core.

(* ** Lists *)

(* Register additional simplification rules with autorewrite / simpl_list *)
(* Print Rewrite HintDb list. *)
Hint Rewrite <- app_assoc : list.
Hint Rewrite rev_app_distr map_app prod_length : list.

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

(* *** Decisions for lists *)

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

(* Certifying find *)

Lemma cfind X A (p: X -> Prop) (p_dec: forall x, dec (p x)) :
  {x | x el A /\ p x} + {forall x, x el A -> ~ p x}.
Proof.
  destruct (find (fun x => Dec (p x)) A) eqn:E.
  - apply find_some in E. firstorder.
  - right. intros. eapply find_none in E; eauto.
Qed.

Arguments cfind {X} A p {p_dec}.

Instance list_forall_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (forall x, x el A -> p x).
Proof.
  intros p_dec.
  destruct (find (fun x => Dec (~ p x)) A) eqn:Eq.
  - apply find_some in Eq as [H1 H0 %Dec_true]; right; auto.
  - left. intros x E. apply find_none with (x := x) in Eq. apply dec_DN; auto. auto.
Qed.

Instance list_exists_dec X A (p : X -> Prop) :
  (forall x, dec (p x)) -> dec (exists x, x el A /\ p x).
Proof.
  intros p_dec.
  destruct (find (fun x => Dec (p x)) A) eqn:Eq. (* New: eta expansion needed *)
  - apply find_some in Eq as [H0 H1 %Dec_true]. firstorder. (* New: Need firstorder here *)
  - right. intros [x [E F]]. apply find_none with (x := x) in Eq; auto. eauto. (* New: Why can't auto solve this? *)
Qed.

Lemma list_exists_DM X A  (p : X -> Prop) :
  (forall x, dec (p x)) ->
  ~ (forall x, x el A -> ~ p x) -> exists x, x el A /\ p x.
Proof.
  intros D E.
  destruct (find (fun x => Dec (p x)) A) eqn:Eq.
  + apply find_some in Eq as [? ?%Dec_true]. eauto.
  + exfalso. apply E. intros. apply find_none with (x := x) in Eq;  eauto.
Qed.

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

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

(* *** Membership

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

Hint Resolve in_eq in_nil in_cons in_or_app : core.

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

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

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

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

(* *** Disjointness *)

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

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

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

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

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

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

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

  Lemma disjoint_app A B C :
    disjoint (A ++ B) C <-> disjoint A C /\ disjoint B C.
  Proof.
    split.
    - intros D. split.
      + intros [x [E F]]. eauto 6.
      + intros [x [E F]]. eauto 6.
    - intros [D E] [x [F G]].
      apply in_app_iff in F as [F|F]; eauto.
  Qed.

End Membership.

Hint Resolve disjoint_nil disjoint_nil' : core.

(* *** Inclusion

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

Hint Resolve incl_refl incl_tl incl_cons incl_appl incl_appr incl_app : core.

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

Proof. intros x []. Qed.

Hint Resolve incl_nil : core.

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

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

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

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

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

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

  Proof. auto. Qed.

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

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

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

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

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

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

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

End Inclusion.

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

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

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

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

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

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

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

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

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

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

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

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

  Lemma equi_push x A :
    x el A -> A === x::A.
  Proof.
    auto.
  Qed.

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

  Proof.
    auto.
  Qed.

  Lemma equi_swap x y A:
    x::y::A === y::x::A.
  Proof.
    split; intros z; cbn; tauto.
  Qed.

  Lemma equi_shift x A B :
    x::A++B === A++x::B.
  Proof.
    split; intros y.
    - intros [D|D].
      + subst; auto.
      + apply in_app_iff in D as [D|D]; auto.
    - intros D. apply in_app_iff in D as [D|D].
      + auto.
      + destruct D; subst; auto.
  Qed.

  Lemma equi_rotate x A :
    x::A === A++[x].
  Proof.
    split; intros y; cbn.
    - intros [D|D]; subst; auto.
    - intros D. apply in_app_iff in D as [D|D].
      + auto.
      + apply in_sing in D. auto.
  Qed.

End Equi.

Lemma in_concat_iff A l (a:A) : a el concat l <-> exists l', a el l' /\ l' el l.
Proof.
  induction l; cbn.
  - intuition. now destruct H.
  - rewrite in_app_iff, IHl. firstorder subst. auto.
Qed.

Lemma app_comm_cons' (A : Type) (x y : list A) (a : A) :
  x ++ a :: y = (x ++ [a]) ++ y.
Proof. rewrite <- app_assoc. cbn. trivial. Qed.

(* skipn *)

Lemma skipn_nil (X : Type) (n : nat) : skipn n nil = @nil X.
Proof. destruct n; cbn; auto. Qed.

Lemma skipn_app (X : Type) (xs ys : list X) (n : nat) :
  n = (| xs |) ->
  skipn n (xs ++ ys) = ys.
Proof.
  intros ->. revert ys. induction xs; cbn; auto.
Qed.

Lemma skipn_length (X : Type) (n : nat) (xs : list X) :
  length (skipn n xs) = length xs - n.
Proof.
  revert xs. induction n; intros; cbn.
  - lia.
  - destruct xs; cbn; auto.
Qed.

(* Repeat *)

Lemma map_repeat (X Y : Type) (f : X -> Y) (n : nat) (a : X) :
  map f (repeat a n) = repeat (f a) n.
Proof. induction n; cbn in *; f_equal; auto. Qed.

Lemma repeat_add_app (X : Type) (m n : nat) (a : X) :
  repeat a (m + n) = repeat a m ++ repeat a n.
Proof. induction m; cbn; f_equal; auto. Qed.

Lemma repeat_S_cons (X : Type) (n : nat) (a : X) :
  a :: repeat a n = repeat a n ++ [a].
Proof.
  replace (a :: repeat a n) with (repeat a (S n)) by trivial. replace (S n) with (n+1) by lia.
  rewrite repeat_add_app. cbn. trivial.
Qed.

Lemma repeat_app_eq (X : Type) (m n : nat) (a : X) :
  repeat a n ++ repeat a m = repeat a m ++ repeat a n.
Proof. rewrite <- !repeat_add_app. f_equal. lia. Qed.

Lemma repeat_eq_iff (X : Type) (n : nat) (a : X) x :
  x = repeat a n <-> length x = n /\ forall y, y el x -> y = a.
Proof.
  split.
  {
    intros ->. split. apply repeat_length. apply repeat_spec.
  }
  {
    revert x. induction n; intros x (H1&H2); cbn in *.
    - destruct x; cbn in *; congruence.
    - destruct x; cbn in *; inv H1. f_equal.
      + apply H2. auto.
      + apply IHn. auto.
  }
Qed.

Lemma rev_repeat (X : Type) (n : nat) (a : X) :
  rev (repeat a n) = repeat a n.
Proof.
  apply repeat_eq_iff. split.
  - rewrite rev_length. rewrite repeat_length. auto.
  - intros y Hx % in_rev. eapply repeat_spec; eauto.
Qed.

Lemma concat_repeat_repeat (X : Type) (n m : nat) (a : X) :
  concat (repeat (repeat a n) m) = repeat a (m*n).
Proof.
  induction m as [ | m' IHm]; cbn.
  - auto.
  - rewrite repeat_add_app. f_equal. auto.
Qed.

Corollary skipn_repeat_add (X : Type) (n m : nat) (a : X) :
  skipn n (repeat a (n + m)) = repeat a m.
Proof.
  rewrite repeat_add_app. erewrite skipn_app; eauto. symmetry. apply repeat_length.
Qed.

Corollary skipn_repeat (X : Type) (n : nat) (a : X) :
  skipn n (repeat a n) = nil.
Proof.
  rewrite <- (app_nil_r (repeat a n)). erewrite skipn_app; eauto. symmetry. apply repeat_length.
Qed.

(* Facts about equality for [map] and [rev] *)
Lemma rev_eq_nil (Z: Type) (l: list Z) :
  rev l = nil -> l = nil.
Proof. intros. destruct l; cbn in *. reflexivity. symmetry in H. now apply app_cons_not_nil in H. Qed.

Lemma map_eq_nil (Y Z: Type) (f: Y->Z) (l: list Y) :
  map f l = nil -> l = nil.
Proof. intros. destruct l; cbn in *. reflexivity. congruence. Qed.

Lemma map_eq_nil' (Y Z: Type) (f: Y->Z) (l: list Y) :
  nil = map f l -> l = nil.
Proof. now intros H % eq_sym % map_eq_nil. Qed.

Lemma map_eq_cons (A B: Type) (f: A->B) (xs: list A) (y: B) (ys: list B) :
  map f xs = y :: ys ->
  exists x xs', xs = x :: xs' /\
          y = f x /\
          ys = map f xs'.
Proof. induction xs; intros H; cbn in *; inv H; eauto. Qed.

Lemma map_eq_cons' (A B: Type) (f: A -> B) (xs: list A) (y: B) (ys: list B) :
  y :: ys = map f xs ->
  exists x xs', xs = x :: xs' /\
          y = f x /\
          ys = map f xs'.
Proof. now intros H % eq_sym % map_eq_cons. Qed.

Lemma map_eq_app (A B: Type) (f: A -> B) (ls : list A) (xs ys : list B) :
  map f ls = xs ++ ys ->
  exists ls1 ls2, ls = ls1 ++ ls2 /\
             xs = map f ls1 /\
             ys = map f ls2.
Proof.
  revert xs ys. induction ls; intros; cbn in *.
  - symmetry in H. apply app_eq_nil in H as (->&->). exists nil, nil. cbn. tauto.
  - destruct xs; cbn in *.
    + exists nil. eexists. repeat split. cbn. now subst.
    + inv H. specialize IHls with (1 := H2) as (ls1&ls2&->&->&->).
      repeat econstructor. 2: instantiate (1 := a :: ls1). all: reflexivity.
Qed.

Lemma rev_eq_cons (A: Type) (ls: list A) (x : A) (xs: list A) :
  rev ls = x :: xs ->
  ls = rev xs ++ [x].
Proof. intros H. rewrite <- rev_involutive at 1. rewrite H. cbn. reflexivity. Qed.

(* Injectivity of [map], if the function is injective *)
Lemma map_injective (X Y: Type) (f: X -> Y) :
  (forall x y, f x = f y -> x = y) ->
  forall xs ys, map f xs = map f ys -> xs = ys.
Proof.
  intros HInj. hnf. intros x1. induction x1 as [ | x x1' IH]; intros; cbn in *.
  - now apply map_eq_nil' in H.
  - now apply map_eq_cons' in H as (l1&l2&->&->%HInj&->%IH).
Qed.

Instance map_ext_proper A B: Proper (@ pointwise_relation A B (@eq B) ==> (@eq (list A)) ==> (@eq (list B))) (@map A B).
Proof.
  intros f f' Hf a ? <-. induction a;cbn;congruence.
Qed.

(* ** Lemmas about [hd], [tl] and [removelast] *)

Lemma tl_map (A B: Type) (f: A -> B) (xs : list A) :
  tl (map f xs) = map f (tl xs).
Proof. now destruct xs; cbn. Qed.

(* Analogous to [removelast_app] *)

Lemma tl_app (A: Type) (xs ys : list A) :
  xs <> nil ->
  tl (xs ++ ys) = tl xs ++ ys.
Proof. destruct xs; cbn; congruence. Qed.

Lemma tl_rev (A: Type) (xs : list A) :
  tl (rev xs) = rev (removelast xs).
Proof.
  induction xs; cbn; auto.
  destruct xs; cbn in *; auto.
  rewrite tl_app; cbn in *.
  - now rewrite IHxs.
  - intros (H1&H2) % app_eq_nil; inv H2.
Qed.

Lemma hd_map (A B: Type) (f: A -> B) (xs : list A) (a : A) :
  hd (f a) (map f xs) = f (hd a xs).
Proof. destruct xs; cbn; auto. Qed.

Lemma hd_app (A: Type) (xs ys : list A) a :
  xs <> nil ->
  hd a (xs ++ ys) = hd a xs.
Proof. intros H. destruct xs; auto. now contradiction H. Qed.

Lemma hd_rev (A: Type) (xs : list A) (a : A) :
  hd a (rev xs) = last xs a.
Proof.
  induction xs; cbn; auto.
  destruct xs; cbn; auto.
  rewrite hd_app. now apply IHxs.
  intros (H1&H2)%app_eq_nil; inv H2.
Qed.


From Coqprime Require Import PocklingtonRefl.
Local Open Scope positive_scope.

Lemma primo115:
  prime  10492504530720708046338171434923129->
  prime  2224424442783039323682545799822955619261761489.
Proof.
intro H.
apply (Pocklington_refl
     (Ell_certif
      2224424442783039323682545799822955619261761489
      212001284943
      ((10492504530720708046338171434923129,1)::nil)
      0
      221184
      48
      576)
     ((Proof_certif _ H) :: nil)).
native_cast_no_check (refl_equal true).
Time Qed.


(* * Natural Deduction *)

From Undecidability.Synthetic Require Import Definitions DecidabilityFacts EnumerabilityFacts ListEnumerabilityFacts ReducibilityFacts.
From Undecidability.FOL Require Import Syntax.Facts Syntax.Theories Syntax.Asimpl.
From Undecidability.FOL Require Export Deduction.FragmentND.
From Undecidability Require Import Shared.ListAutomation.
Import ListAutomationNotations.
Import ListAutomationHints.
Import ListAutomationInstances.
Require Import Lia.
Require Import EqdepFacts.
Import FragmentSyntax.

Local Set Implicit Arguments.
Local Unset Strict Implicit.

#[local] Ltac comp := repeat (progress (cbn in *; autounfold in *)).

Section ND_def.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Context {ff : falsity_flag}.
  Context {p : peirce}.

  Lemma impl_prv A B phi :
    (rev B ++ A) ⊢ phi -> A ⊢ (B ==> phi).
  Proof.
    revert A; induction B; intros A; cbn; simpl_list; intros.
    - firstorder.
    - eapply II. now eapply IHB.
  Qed.

  Theorem Weak A B phi :
    A ⊢ phi -> A <<= B -> B ⊢ phi.
  Proof.
    intros H. revert B.
    induction H; intros B HB; try unshelve (solve [econstructor; auto with datatypes]); try now econstructor.
  Qed.

  Hint Constructors prv : core.

  Theorem subst_Weak A phi xi :
    A ⊢ phi -> [phi[xi] | phi ∈ A] ⊢ phi[xi].
  Proof.
    induction 1 in xi |-*; comp.
    1-7:eauto using in_map.
    - apply AllI. setoid_rewrite map_map in IHprv. erewrite map_map, map_ext.
      apply IHprv. intros ?. cbn. now rewrite up_form.
    - specialize (IHprv xi). apply AllE with (t := t`[xi]) in IHprv. rewrite subst_comp in *.
      erewrite subst_ext; try apply IHprv. intros [|]; cbn; trivial.
      unfold funcomp. now setoid_rewrite subst_term_shift.
  Qed.

  Definition cycle_shift n x :=
    if Dec (n = x) then $0 else $(S x).
  Lemma cycle_shift_shift n phi :
    bounded n phi -> phi[cycle_shift n] = phi[↑].
  Proof.
    intros H. apply (bounded_subst H). intros k. unfold cycle_shift. destruct (Dec _); trivial; lia.
  Qed.

  Lemma cycle_shift_subject n phi :
    bounded (S n) phi -> phi[$n..][cycle_shift n] = phi.
  Proof.
    intros H. erewrite subst_comp, (bounded_subst H), subst_id; trivial.
    intros []; cbn; unfold cycle_shift; destruct (Dec _); trivial; lia.
  Qed.

  Lemma nameless_equiv_all' A phi n :
    bounded_L n A -> bounded (S n) phi -> [f[↑] | f ∈ A] ⊢ phi <-> A ⊢ phi[$n..].
  Proof.
    intros H1 H2. split; intros H.
    - apply (subst_Weak ($n..)) in H. rewrite map_map in *.
      erewrite map_ext, map_id in H; try apply H. intros. apply subst_shift.
    - apply (subst_Weak (cycle_shift n)) in H. rewrite (map_ext_in _ (subst_form ↑)) in H.
      + now rewrite cycle_shift_subject in H.
      + intros psi HP. now apply cycle_shift_shift, H1.
  Qed.

  Lemma nameless_equiv_all A phi :
    { t : nat | map (subst_form ↑) A ⊢ phi <-> A ⊢ phi[$t..] }.
  Proof.
    destruct (find_bounded_L (phi::A)) as [n H].
    exists n. apply nameless_equiv_all'.
    - intros ? ?. apply H. auto.
    - eapply bounded_up; try apply H; auto.
  Qed.

  Lemma AllI_named (A : list form) (phi : form) :
    (forall t, A ⊢ phi[t..]) -> A ⊢ ∀phi.
  Proof.
    intros H. apply AllI.
    destruct (nameless_equiv_all A phi) as [t Ht].
    apply Ht, H.
  Qed.

  Lemma imps T phi psi :
    T ⊢ (phi → psi) <-> (phi :: T) ⊢ psi.
  Proof.
    split; try apply II.
    intros H. apply IE with phi; auto. apply (Weak H). auto.
  Qed.

  Lemma big_imps A B phi : (A ++ B) ⊢ phi <-> B ⊢ (impl A phi).
  Proof.
    induction A as [|psi A IH] in B,phi|-*; cbn; try tauto.
    split; intros Hprv.
    - apply II. apply IH. eapply Weak. 1: apply Hprv.
      intros x [->|[HA|HB]%in_app_iff]; apply in_app_iff.
      + right; now left.
      + now left.
      + right; now right.
    - eapply Weak. 1: apply (IH (psi::B)).
      + eapply IE. 1: eapply Weak; [apply Hprv|firstorder]. apply Ctx; now left.
      + intros x [HA|[->|HB]]%in_app_iff.
        * right. apply in_app_iff. now left.
        * now left.
        * right. apply in_app_iff. now right.
  Qed.

  Lemma big_imps_nil A phi : A ⊢ phi <-> [] ⊢ (impl A phi).
  Proof.
    specialize (big_imps A nil phi). rewrite <- (app_nil_end). easy.
  Qed.

  Lemma subst_forall_prv phi {N Gamma} :
    Gamma ⊢ (forall_times N phi) -> bounded N phi -> forall sigma, Gamma ⊢ phi[sigma].
  Proof.
    induction N in phi |-*; intros ?? sigma; cbn in *.
    - change sigma with (iter up 0 sigma).
      now rewrite (subst_bounded 0).
    - specialize (IHN (∀ phi) ).
      rewrite <-up_decompose.
      apply AllE. apply IHN. unfold forall_times.
      now rewrite <-iter_switch.
      now apply bounded_S_quant.
  Qed.

  Lemma prv_cut A B phi :
    A ⊢ phi -> (forall psi, psi el A -> B ⊢ psi) -> B ⊢ phi.
  Proof.
    induction A in phi |- *; intros H1 H2.
    - eapply Weak; eauto.
    - rewrite <- imps in H1. apply IHA in H1; auto. apply IE with a; trivial. now apply H2.
  Qed.

  Lemma prv_intu_peirce T φ : T ⊢I φ -> T ⊢ φ.
  Proof using.
    remember intu. induction 1. all: now eauto.
  Qed.

End ND_def.

Local Hint Constructors prv : core.

(* ** Rudimentary tactics for ND manipulations *)

Ltac subsimpl_in H :=
  rewrite ?up_term, ?subst_term_shift in H.

Ltac subsimpl :=
  rewrite ?up_term, ?subst_term_shift.

Ltac assert1 H :=
  match goal with |- (?phi :: ?T) ⊢ _ => assert (H : (phi :: T) ⊢ phi) by auto end.

Ltac assert2 H :=
  match goal with |- (?phi :: ?psi :: ?T) ⊢ _ => assert (H : (phi :: psi :: T) ⊢ psi) by auto end.

Ltac assert3 H :=
  match goal with |- (?phi :: ?psi :: ?theta :: ?T) ⊢ _ => assert (H : (phi :: psi :: theta :: T) ⊢ theta) by auto end.

Ltac assert4 H :=
  match goal with |- (?f :: ?phi :: ?psi :: ?theta :: ?T) ⊢ _ => assert (H : (f :: phi :: psi :: theta :: T) ⊢ theta) by auto end.

Ltac prv_all x :=
  apply AllI; edestruct (@nameless_equiv_all) as [x ->]; cbn; subsimpl.

(* ** Custom induction principle *)
Lemma prv_ind_full {Σ_funcs : funcs_signature} {Σ_preds : preds_signature} :
  forall P : peirce -> list (form falsity_on) -> (form falsity_on) -> Prop,
    (forall (p : peirce) (A : list form) (phi psi : form),
        (phi :: A) ⊢ psi -> P p (phi :: A) psi -> P p A (phi → psi)) ->
    (forall (p : peirce) (A : list form) (phi psi : form),
        A ⊢ (phi → psi) -> P p A (phi → psi) -> A ⊢ phi -> P p A phi -> P p A psi) ->
    (forall (p : peirce) (A : list form) (phi : form),
        (map (subst_form ↑) A) ⊢ phi -> P p (map (subst_form ↑) A) phi -> P p A (∀ phi)) ->
    (forall (p : peirce) (A : list form) (t : term) (phi : form),
        A ⊢ (∀ phi) -> P p A (∀ phi) -> P p A (phi[t..])) ->
    (forall (p : peirce) (A : list form) (phi : form), A ⊢ ⊥ -> P p A ⊥ -> P p A phi) ->
    (forall (p : peirce) (A : list form) (phi : form), phi el A -> P p A phi) ->
    (forall (A : list form) (phi psi : form), P class A (((phi → psi) → phi) → phi)) ->
    forall (p : peirce) (l : list form) (f14 : form), l ⊢ f14 -> P p l f14.
Proof.
  intros. specialize (@prv_ind _ _ (fun ff => match ff with falsity_on => P | _ => (fun _ _ _ => True) end)). intros H'.
  apply H' with (ff := falsity_on); clear H'. all: intros; try destruct ff; trivial. all: intuition eauto 2.
Qed.

(* ** Enumerability of proofs *)

Section Enumerability.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.

  Variable list_Funcs : nat -> list syms.
  Hypothesis enum_Funcs' : list_enumerator__T list_Funcs syms.

  Variable list_Preds : nat -> list preds.
  Hypothesis enum_Preds' : list_enumerator__T list_Preds preds.

  Hypothesis eq_dec_Funcs : eq_dec syms.
  Hypothesis eq_dec_Preds : eq_dec preds.

  Instance eqdec_binop : eq_dec binop.
  Proof.
    intros x y. unfold dec. decide equality.
  Qed.

  Instance eqdec_quantop : eq_dec quantop.
  Proof.
    intros x y. unfold dec. decide equality.
  Qed.

  Definition list_binop (n : nat) := [Impl].

  Instance enum_binop :
    list_enumerator__T list_binop binop.
  Proof.
    intros []; exists 0; cbn; tauto.
  Qed.

  Definition list_quantop (n : nat) := [All].

  Instance enum_quantop :
    list_enumerator__T list_quantop quantop.
  Proof.
    intros []; exists 0; cbn; tauto.
  Qed.

  Lemma enumT_binop :
    enumerable__T binop.
  Proof.
    apply enum_enumT. exists list_binop. apply enum_binop.
  Qed.

  Lemma enumT_quantop :
    enumerable__T quantop.
  Proof.
    apply enum_enumT. exists list_quantop. apply enum_quantop.
  Qed.

  Instance enum_term' :
    list_enumerator__T (L_term _) term :=
    enum_term _.

  Instance enum_form' {ff : falsity_flag} :
    list_enumerator__T (L_form _ _ _ _) form :=
    enum_form _ _ _ _.

  Fixpoint L_ded {p : peirce} {b : falsity_flag} (A : list form) (n : nat) : list form :=
    match n with
    | 0 => A
    | S n =>   L_ded A n ++
    (* II *)   concat ([ [ phi → psi | psi ∈ L_ded (phi :: A) n ] | phi ∈ L_T form n ]) ++
    (* IE *)   [ psi | (phi, psi) ∈ (L_ded A n × L_T form n) , (phi → psi el L_ded A n) ] ++
    (* AllI *) [ ∀ phi | phi ∈ L_ded (map (subst_form ↑) A) n ] ++
    (* AllE *) [ phi[t..] | (phi, t) ∈ (L_T form n × L_T term n), (∀ phi) el L_ded A n ] ++
    (* Exp *)  (match b with falsity_on => fun A =>
                [ phi | phi ∈ L_T form n, ⊥ el @L_ded _ falsity_on A n ]
                | _ => fun _ => nil end A) ++
    (* Pc *)   (if p then
                [ (((phi → psi) → phi) → phi) | (pair phi psi) ∈ (L_T form n × L_T form n) ]
                else nil)
    end.

  Opaque in_dec.

  Lemma enum_prv {p : peirce} {b : falsity_flag} A :
    list_enumerator (L_ded A) (prv A).
  Proof with try (eapply cum_ge'; eauto; lia).
    split.
    - rename x into phi. induction 1; try congruence; subst.
      + destruct IHprv as [m1], (el_T phi) as [m2]. exists (1 + m1 + m2). cbn. in_app 2.
        eapply in_concat. eexists. split. 1: eapply in_map.
        2: eapply in_map. 1:idtac... idtac...
      + destruct IHprv1 as [m1], IHprv2 as [m2], (el_T psi) as [m3]; eauto.
        exists (1 + m1 + m2 + m3).
        cbn. in_app 3. in_collect (phi, psi)...
      + destruct IHprv as [m]. exists (1 + m). cbn. in_app 4. in_collect phi...
      + destruct IHprv as [m1], (el_T t) as [m2], (el_T phi) as [m3]. exists (1 + m1 + m2 + m3).
        cbn. in_app 5. in_collect (phi, t)...
      + destruct IHprv as [m1], (el_T phi) as [m2]. exists (1 + m1 + m2). cbn. in_app 6. in_collect phi...
      + now exists 0.
      + destruct (el_T phi) as [m1], (el_T psi) as [m2]. exists (1 + m1 + m2). cbn. in_app 7. in_collect (phi, psi)...
    - intros [m H]; induction m in A, x, H |-*; cbn in *.
      + now apply Ctx.
      + repeat invert_list_in.
        * eauto.
        * eapply II; eauto.
        * eapply IE; eapply IHm; eauto.
        * eapply AllI; eapply IHm; eauto.
        * eapply AllE; eapply IHm; eauto.
        * destruct b; repeat invert_list_in. eapply Exp, IHm; eauto.
        * destruct p; repeat invert_list_in. eapply Pc.
  Qed.

  Fixpoint L_con `{falsity_flag} (L : nat -> list form) (n : nat) : list (list form) :=
    match n with
    | 0 => [ nil ]
    | S n => L_con L n ++ [ phi :: A | (pair phi A) ∈ (L n × L_con L n) ]
    end.

  Lemma enum_el X (p : X -> Prop) L x :
    list_enumerator L p -> p x -> exists m, x el L m.
  Proof.
    firstorder.
  Qed.
  Arguments enum_el {X p L} x _ _.

  Lemma enum_p X (p : X -> Prop) L x m :
    list_enumerator L p -> x el L m -> p x.
  Proof.
    firstorder.
  Qed.

  Definition containsL `{falsity_flag} A (T : form -> Prop) :=
    forall psi, psi el A -> T psi.

  Lemma enum_containsL `{falsity_flag} T L :
    cumulative L -> list_enumerator L T -> list_enumerator (L_con L) (fun A => containsL A T).
  Proof with try (eapply cum_ge'; eauto; lia).
    intros HL He. split.
    - induction x as [| phi A]; intros HT.
      + exists 0. firstorder.
      + destruct IHA as [m1], (enum_el phi He) as [m2]. 1,2,3: firstorder.
        exists (1 + m1 + m2). cbn. in_app 2. in_collect (phi, A)...
    - intros [m]. induction m in x, H0 |-*; cbn in *.
      + destruct H0 as [<- | []]. firstorder.
      + repeat invert_list_in.
        1: now apply IHm. apply IHm in H1. apply (enum_p He) in H0. unfold containsL in *. firstorder congruence.
  Qed.

  Fixpoint L_tded {p : peirce} {b : falsity_flag} (L : nat -> list form) (n : nat) : list form :=
    match n with
    | 0 => nil
    | S n => L_tded L n ++ concat ([ L_ded A n | A ∈ L_con L n ])
    end.

  Lemma enum_tprv {p : peirce} {b : falsity_flag} T L :
    list_enumerator L T -> list_enumerator (L_tded (cumul L)) (tprv T).
  Proof with try (eapply cum_ge'; eauto; lia).
    intros He.
    assert (HL : list_enumerator (cumul L) T) by now apply list_enumerator_to_cumul.
    split.
    - intros (A & [m1] % (enum_el A (@enum_containsL _ _ (cumul L) (to_cumul_cumulative L) HL)) & [m2] % (enum_el x (enum_prv A))).
      exists (1 + m1 + m2). cbn. in_app 2. eapply in_concat. eexists. split. in_collect A... idtac...
    - intros [m]. induction m in x, H |-*; cbn in *. 1: contradiction. repeat invert_list_in. 1: now eapply IHm.
      exists x1; split.
      + eapply (enum_p (enum_containsL (to_cumul_cumulative L) HL)); eauto.
      + eapply (enum_p (enum_prv x1)); eassumption.
  Qed.

End Enumerability.

Section TheoryManipulation.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {p : peirce} {ff : falsity_flag}.
  Context {HF : eq_dec syms} {HP : eq_dec preds}.
  Lemma prv_T_impl T phi psi :
    (T ⋄ phi) ⊢T psi -> T ⊢T (phi → psi).
  Proof using HF HP ff p Σ_funcs Σ_preds.
    intros (A & HA1 & HA2). exists (remove (dec_form _ _ _ _) phi A); split.
    - intros f [[] % HA1 Hf2] % in_remove; subst; intuition.
    - eapply II, Weak. 1: apply HA2. transitivity (phi :: A). 1: eauto. intros a [-> | Ha].
      + now left.
      + destruct (dec_form _ _ _ _ a phi) as [->|Hr]. 1:now left.
        right. now eapply in_in_remove.
  Qed.

  Lemma prv_T_remove T phi psi :
    T ⊢T phi -> T ⋄ phi ⊢T psi -> T ⊢T psi.
  Proof using HF HP ff p Σ_funcs Σ_preds.
    intros (A & HA1 & HA2) (B & HB1 & HB2) % prv_T_impl.
    use_theory (A ++ B).
    - now intros psi1 [H1|H2]%in_app_iff; [apply HA1 | apply HB1].
    - eapply IE; eapply Weak. 1,3: eassumption.
      all: intros x Hx; apply in_app_iff; eauto.
  Qed.

  Lemma prv_T_comp T phi psi xi :
    T ⋄ phi ⊢T xi -> T ⋄ psi ⊢T phi -> T ⋄ psi ⊢T xi.
  Proof using HF HP.
    intros (A & HA1 & HA2) % prv_T_impl (B & HB1 & HB2) % prv_T_impl.
    use_theory (psi :: A ++ B).
    - now intros psi1 [->|[H1|H2]%in_app_iff]; [now right | |]; left; [apply HA1 | apply HB1].
    - eapply IE. 1: eapply Weak. 1: apply HA2. 2: eapply IE.
      2-3: eapply Weak. 2: eapply HB2. 3: apply (@Ctx _ _ _ _ (psi::nil)); now left.
      + intros a Ha; right; apply in_app_iff; now left.
      + intros b Hb; right; apply in_app_iff; now right.
      + intros x [->|[]]; now left.
  Qed.

  Lemma elem_prv T phi :
    phi ∈ T -> T ⊢T phi.
  Proof.
    intros ?. use_theory [phi]. 2:apply Ctx; now left.
    intros psi [->|[]]. apply H.
  Qed.

  Lemma Weak_T T1 T2 phi :
    T1 ⊢T phi -> T1 ⊑ T2 -> T2 ⊢T phi.
  Proof.
    intros (A & HA1 & HA2) HT2. exists A. split. 2:easy. intros psi H; now apply HT2, HA1.
  Qed.
End TheoryManipulation.

Section Closedness.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Context {p : peirce} {ff : falsity_flag}.

  Definition capture_subs n x := $(x + n).

  Lemma capture_extract n A phi :
    A ⊢ subst_form (capture_subs n) (capture All n phi) -> A ⊢ subst_form (capture_subs 0) phi.
  Proof.
    induction n; comp; intuition. apply IHn. apply (AllE (var n)) in H. rewrite subst_comp in H.
    erewrite subst_ext. 1: apply H. intros [| x]; unfold capture_subs; cbn; f_equal; lia.
  Qed.

  Context {Funcs_eq_dec : eq_dec Σ_funcs}.
  Context {Preds_eq_dec : eq_dec Σ_preds}.

  Lemma close_extract A phi :
    A ⊢ close All phi -> A ⊢ phi.
  Proof.
    intros H. assert (Hclosed : closed (close All phi)) by apply close_closed.
    unfold close in *. destruct (find_bounded phi) as [n Hn]; cbn in *.
    erewrite <- subst_id with (sigma := fun x => $x) in H.
    erewrite (@bounded_subst _ _ _ _ _ _ _ (capture_subs n)) in H.
    2: exact Hclosed. 3:easy. 2: lia.
    apply capture_extract in H. rewrite subst_id in H; intuition. unfold capture_subs. f_equal. lia.
  Qed.

End Closedness.

Section DNFacts.

  Context {Σ_funcs : funcs_signature}.
  Context {Σ_preds : preds_signature}.
  Lemma DN A phi: A ⊢C (¬ (¬ phi)) -> A ⊢C phi.
  Proof.
    intros H. eapply IE. 1: apply Pc. eapply II.
    apply Exp. eapply IE. 2: apply Ctx; now left.
    eapply Weak. 1: apply H. intros a Ha; now right.
  Qed.
  Lemma DN_into {p:peirce} A phi: A ⊢ phi -> A ⊢ (¬ (¬ phi)).
  Proof.
    intros H. apply II. eapply IE. 1: apply Ctx; now left. eapply Weak; [apply H|].
    firstorder.
  Qed.

  Lemma XMc A (phi chi : form) : (phi::A) ⊢C chi -> ((¬ phi)::A) ⊢C chi -> A ⊢C chi.
  Proof.
    intros HA HB. eapply IE with ((phi → chi) → (¬phi → chi) → chi).
    - eapply II. eapply IE. 1: eapply IE. 1: apply Ctx; now left.
      1-2: eapply Weak; [eapply II|]. 1: apply HA. 2: apply HB. 1-2: intros a Ha; now right.
    - eapply DN. apply II. eapply IE. 1: apply Ctx; now left. eapply II. eapply II.
      eapply IE. 1: apply Ctx; now left.
      eapply II. eapply IE. 1: apply Ctx; do 3 right; now left. do 2 eapply II.
      eapply IE. 1: apply Ctx; right; now left.
      apply Ctx; now eauto.
  Qed.

  Lemma DN_T T phi : T ⊢TC (¬¬phi) -> T ⊢TC phi.
  Proof.
    intros (A & HT & HA). exists A. split; [apply HT|now apply DN].
  Qed.

End DNFacts.

Section RefutationComp.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.
  Context {HF : eq_dec Σ_funcs} {HP : eq_dec Σ_preds}.

  Lemma refutation_prv T phi :
    T ⊢TC phi <-> (T ⋄ ¬ phi) ⊢TC ⊥.
  Proof using HF HP.
    split.
    - intros (A & HA1 & HA2). use_theory (¬ phi :: A).
      + intros psi [<-|Ha]. 1: now right. left. now apply HA1.
      + eapply IE. 1: apply Ctx; now left. eapply Weak. 1: apply HA2. intros a Ha; now right.
    - intros (A & HA1 & HA2) % prv_T_impl. use_theory A. now apply DN.
  Qed.
End RefutationComp.

Section FlagsTransport.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.
  Context {p : peirce}.
  Context {ff : falsity_flag}.

  Lemma prv_transport_to_falsity  A phi :
    A ⊢ phi -> (map to_falsity A) ⊢ (to_falsity phi).
  Proof.
    intros H; induction H.
    - cbn. apply II. apply IHprv.
    - cbn. eapply IE. 1: now apply IHprv1. now apply IHprv2.
    - cbn. apply AllI. rewrite map_map in *.
      erewrite map_ext. 1: now apply IHprv.
      intros a. rewrite <- ! subst_falsity_id.
      rewrite subst_falsity_comm. now cbn.
    - rewrite <- subst_falsity_id.
      change (⊥) with (⊥[t..]). rewrite <- subst_falsity_comm.
      apply AllE. rewrite subst_falsity_id. now apply IHprv.
    - apply Exp. apply IHprv.
    - apply Ctx. now apply in_map.
    - apply Pc.
  Qed.

  Lemma prv_transport_to_class A phi :
    A ⊢ phi -> A ⊢C phi.
  Proof.
    induction 1.
    - now apply II.
    - eapply IE. 1: apply IHprv1. easy.
    - now apply AllI.
    - now apply AllE.
    - now apply Exp.
    - now apply Ctx.
    - apply Pc.
  Qed.
(*
  Ltac resolve_existT :=
    inversion 1; subst;
    repeat match goal with
             H : existT _ _ _ = existT _ _ _ |- _ => try apply Eqdep_dec.inj_pair2_eq_dec in H; [|try decide equality]
           end.

  Lemma prv_transport_from_falsity'
    {ff1 ff2 : falsity_flag}
    A' (phi' : @form _ _ _ ff2)
    A (phi : @form _ _ _ ff1)
    (Heqn : ff2 = falsity_on) : A' ⊢ phi' -> match ff2
      as ff return list (@form _ _ _ ff) -> @form _ _ _ ff -> Prop
      with falsity_off => fun A' phi' => False
         | falsity_on => fun A' phi' => A' = map to_falsity A -> phi' = to_falsity phi -> A ⊢ phi
    end A' phi'.
  Proof.
    induction 1 in A,phi,Heqn|-*; try (destruct ff; try congruence); intros HeqA Heqphi.
    - destruct phi as [|t1 t2|ff [] phi psi'|ff [] phi]; cbn in Heqphi; try congruence.
      apply II. apply IHprv. 1:easy. cbn. f_equal. 2: easy.
      all: injection Heqphi; intros He1 He2.
      all: apply Eqdep_dec.inj_pair2_eq_dec in He1; [|decide equality].
      all: apply Eqdep_dec.inj_pair2_eq_dec in He2; [|decide equality].
      all: congruence.
    - eapply IE. *)
End FlagsTransport.

Section NegativeTranslation.
  Context {Σ_funcs : funcs_signature} {Σ_preds : preds_signature}.

  Fixpoint negative_translation {ff:falsity_flag} (phi : @form _ _ _ ff) : @form _ _ _ falsity_on := match phi with
    falsity => falsity
  | atom P v => ¬¬(atom P v)
  | bin Impl phi psi => (negative_translation phi) → (negative_translation psi)
  | quant All phi => ∀ (negative_translation phi)
  end.

  Lemma nt_impl {ff:falsity_flag} A phi : negative_translation (impl A phi) = impl (map negative_translation A) (negative_translation phi).
  Proof.
    induction A as [|psi A IH]; cbn; congruence.
  Qed.

  Lemma nt_subst {ff:falsity_flag} phi σ : negative_translation (phi[σ]) = (negative_translation phi)[σ].
  Proof.
    induction phi as [| |?[]|?[]] in σ|-*; try easy.
    - cbn. now rewrite IHphi1, IHphi2.
    - cbn. now rewrite IHphi.
  Qed.

  Lemma nt_dn_float' {p:peirce} {ff:falsity_flag} A phi:
   A ⊢ ((¬¬negative_translation phi) → negative_translation phi).
  Proof.
  revert A. induction phi as [| |?[]|?[]]; intros A; cbn.
  - apply II. eapply IE. 1: apply Ctx; now left. apply II. apply Ctx; now left.
  - apply II. apply II. eapply IE. 1: apply Ctx; right; now left.
    apply II. eapply IE. 1: apply Ctx; now left. apply Ctx; right; now left.
  - apply II. apply II. eapply IE. 1: apply IHphi2. apply II.
    eapply IE. 1: apply Ctx; right; right; now left. apply II.
    eapply IE. 1: apply Ctx; right; now left.
    eapply IE. 1: apply Ctx; now left.
    apply Ctx; right; right; now left.
  - apply II. apply AllI. cbn. eapply IE. 1: apply IHphi.
    apply II. eapply IE. 1: apply Ctx; right; now left.
    apply II. eapply IE. 1: apply Ctx; right; now left.
    assert ((negative_translation phi)[up ↑][$0..] = negative_translation phi) as <- by now asimpl.
    apply AllE. apply Ctx; left; now asimpl.
  Qed.

  Lemma nt_dn_float {p:peirce} {ff:falsity_flag} A phi :
    A ⊢ (¬¬negative_translation phi) -> A ⊢ negative_translation phi.
  Proof.
    intros H. eapply IE. 1: apply nt_dn_float'. easy.
  Qed.

  Lemma nt_peirce {p:peirce} {ff:falsity_flag} A phi psi:
    A ⊢ negative_translation (((phi → psi) → phi) → phi).
  Proof.
    cbn. apply II.
    apply nt_dn_float.
    apply II. eapply IE. 1: apply Ctx; now left.
    eapply IE. 1: apply Ctx; right; now left.
    apply II. apply Exp. eapply IE. 1: apply Ctx; right; now left.
    apply Ctx. now left.
  Qed.

  Lemma nt_Cprv_to_Iprv {p1 : peirce} {ff:falsity_flag} A phi :
    A ⊢C phi -> (map negative_translation A) ⊢ (negative_translation phi).
  Proof.
    remember class as p2. induction 1; cbn in *.
    all: try specialize (IHprv Heqp2).
    all: try specialize (IHprv1 Heqp2).
    all: try specialize (IHprv2 Heqp2).
    - eapply II. now apply IHprv.
    - eapply IE. 1: apply IHprv1. apply IHprv2.
    - eapply AllI. rewrite map_map in *. erewrite map_ext. 1: apply IHprv.
      intros a; cbn. now rewrite nt_subst.
    - rewrite nt_subst. eapply AllE. apply IHprv.
    - eapply Exp. apply IHprv.
    - eapply Ctx. now apply in_map.
    - apply nt_peirce.
  Qed.

  Lemma nt_Cprv_equiv A phi :
    A ⊢C phi <-> A ⊢C (negative_translation phi).
  Proof.
    revert A. induction phi as [| |[]|[]] using form_ind_falsity; intros A; cbn; split; intros Hprv.
    - easy.
    - easy.
    - eapply DN_into. easy.
    - eapply DN. easy.
    - apply II. apply IHphi2. eapply IE. 1: eapply Weak; [apply Hprv|firstorder].
      apply IHphi1. apply Ctx; now left.
    - apply II. apply IHphi2. eapply IE. 1: eapply Weak; [apply Hprv|firstorder].
      apply IHphi1. apply Ctx; now left.
    - apply (subst_Weak ↑) in Hprv. asimpl in Hprv.
      eapply (AllE $0) in Hprv. asimpl in Hprv.
      apply AllI. apply IHphi. apply Hprv.
    - apply (subst_Weak ↑) in Hprv. asimpl in Hprv.
      eapply (AllE $0) in Hprv. asimpl in Hprv.
      apply AllI. apply IHphi. apply Hprv.
  Qed.

  Lemma nt_bounded {ff:falsity_flag} n phi : bounded n phi -> bounded n (negative_translation phi).
  Proof.
    induction 1; cbn.
    - solve_bounds. now econstructor.
    - destruct binop. now solve_bounds.
    - destruct quantop. now solve_bounds.
    - solve_bounds.
  Qed.

  #[local] Existing Instance falsity_on.
  Lemma nt_correct A phi:
    (map negative_translation A) ⊢I negative_translation phi -> A ⊢C phi.
  Proof.
    intros H.
    apply big_imps_nil. apply nt_Cprv_equiv.
    eapply prv_transport_to_class.
    rewrite nt_impl. apply big_imps_nil in H. apply H.
  Qed.

  Lemma nt_correct_theory T phi:
    (tmap negative_translation T) ⊢TI negative_translation phi -> T ⊢TC phi.
  Proof.
    intros (? & (A & -> & HA1) % tmap_contains_L & HA2 % nt_correct).
    now exists A.
  Qed.

End NegativeTranslation.


From Undecidability.L Require Export Util.L_facts Tactics.Extract.
Require Import Undecidability.Shared.Libs.PSL.Bijection String.

(* * Correctness and time bounds *)

(* Typeclass for registering types *)

(* Encodable is in GenEncode *)

Class encInj (X : Type) `(R : encodable X) :=
  inj_enc : injective (X:=X) enc (* encoding is injective *).

Hint Mode encInj - + : typeclass_instances. (* treat argument as input and force evar-freeness*)

(* ** Correctness *)

(* Definition of the valid types for extraction *)

Inductive TT : Type -> Type :=
  TyB t (R : encodable t) : TT t
| TyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2)
  : TT (t1 -> t2).

Existing Class TT.
Existing Instance TyB.
Existing Instance TyArr.

Arguments TyB _ {_}.
Arguments TyArr {_} {_} _ _.

Hint Mode TT + : typeclass_instances. (* treat argument as input and force evar-freeness*)

Notation "! X" := (TyB X) (at level 69).
Notation "X ~> Y" := (TyArr X Y) (right associativity, at level 70).

Fixpoint computes {A} (tau : TT A) {struct tau}: A -> L.term -> Type :=
  match tau with
    !_ => fun x xInt => (xInt = enc x)
  | @TyArr A B tau1 tau2 =>
    fun f t_f  =>
      proc t_f * forall (a : A) t_a,
        computes tau1 a t_a
        ->  {v : term & (app t_f t_a >* v) * computes tau2 (f a) v}
  end%type.

Lemma computesProc t (ty : TT t) (f : t) fInt:
  computes ty f fInt -> proc fInt.
Proof.
  destruct ty.
  -intros ->. unfold enc. now destruct R.
  -now intros [? _].
Qed.

(* This is for a user to give an definition *)
Class computable X {ty : TT X} (x : X) : Type :=
  {
    ext : extracted x;
    extCorrect : computes ty x ext;
  }.

Global Arguments computable {X} {ty} x.
Global Arguments extCorrect {X} ty x {computable} : simpl never.
Global Arguments ext {X} {ty} x {computable} : simpl never.

Hint Mode computable + - +: typeclass_instances. (* treat argument as input and force evar-freeness*)
Hint Extern 4 (@extracted ?t ?f) => let ty := constr:(_ : TT t) in notypeclasses refine (ext (ty:=ty) f) : typeclass_instances.

Typeclasses Opaque ext.

Lemma proc_ext X (ty : TT X) (x : X) ( H : computable x) : proc (ext x).
Proof.
  unfold ext. destruct H. apply (computesProc extCorrect0).
Qed.

Instance reg_is_ext ty (R : encodable ty) (x : ty) : computable x.
Proof.
  exists (enc x). reflexivity.
Defined. (* because ? *)

Lemma computesTyB (t:Type) (x:t) `{encodable t}: computes (TyB t) x (ext x).
Proof.
  unfold ext. now destruct R.
Qed.

Instance extApp' t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) (Hf : computable f) (Hx : computable x) : computable (f x).
Proof.
  destruct Hf, Hx.
  edestruct extCorrect0 as [? H].
  edestruct H as (?&?&?).
  eassumption.
  now eapply (@Build_computable _ _ _ x0).
Defined. (* because ? *)

Lemma extApp t1 t2 {tt1:TT t1} {tt2 : TT t2} (f: t1 -> t2) (x:t1) (Hf : computable f) (Hx : computable x) :
  app (ext f) (ext x) >* ext (f x).
Proof.
  unfold ext, extApp'.
  destruct Hf, Hx.
  destruct extCorrect0 as (? & correct0).
  destruct correct0 as (?&?&?). tauto.
Qed.

Lemma ext_is_enc t1 (R:encodable t1) (x: t1) (Hf : computable x) :
  @ext _ _ x Hf = enc x.
Proof.
  now destruct Hf.
Defined. (* because ? *)

Definition computesExp {t} (ty : TT t) (f:t) (s fExt : term) : Type :=
  eval s fExt * computes ty f fExt.

Lemma computesExpStart t1 (tt1 : TT t1) (f : t1) (fExt : term):
  proc fExt ->
  {v :term & computesExp tt1 f fExt v} ->  computes tt1 f fExt.
Proof.
  intros ? (?&?&?). replace fExt with x. tauto. apply unique_normal_forms. eapply e. eapply H. destruct e as [e ?]. now rewrite e.
Qed.

Lemma computesExpStep t1 t2 (tt1 : TT t1) (tt2 : TT t2) (f : t1 -> t2) (s:term) (fExt : term):
  eval s fExt -> closed s ->
  (forall (y : t1) (yExt : term), computes tt1 y yExt -> {v : term & computesExp tt2 (f y) (app s yExt) v}%type) ->
  computesExp (tt1 ~> tt2) f s fExt.
Proof.
  intros ? ? H. split. assumption. split. split. now rewrite <-H0. now destruct H0.
  intros ? ? exted.
  edestruct H as (v&?&?). eassumption.
  eexists v. split. rewrite H0 in e. now rewrite e. eauto.
Qed.

Lemma computesTyArr t1 t2 (tt1 : TT t1) (tt2 : TT t2) f fExt :
  proc fExt
  -> (forall (y : t1) (yExt : term),
        computes tt1 y yExt
        -> {v : term & eval (app fExt yExt) v * (proc v -> computes tt2 (f y) v)}%type)
  -> computes (tt1 ~> tt2) f fExt.
Proof.
  intros ? H'.
  split;[assumption|].
  intros y yExt yCorrect.
  edestruct H' as (?&(R&?) & H''). eassumption.
  eexists. split.
  eassumption.
  eapply H''.
  split. 2:assumption.
  rewrite <- R. apply app_closed. now destruct H. specialize (computesProc yCorrect) as []. easy.
Qed.

(* Extensional equality to extract similar functions without unsopported features (e.g. informative deciders) instead *)

Fixpoint extEq t {tt:TT t} : t -> t -> Prop:=
  match tt with
    TyB _ _ => eq
  | @TyArr t1 t2 tt1 tt2 => fun f f' => forall (x : t1), extEq (f x) (f' x)
  end.

Instance extEq_refl t (tt:TT t): Reflexive (extEq (tt:=tt)).
Proof.
  unfold Reflexive.
  induction tt;cbn.
  -reflexivity.
  -intros f x. eauto.
Qed.

Lemma computesExt X (tt : TT X) (x x' : X) s:
  extEq x x' -> computes tt x s -> computes tt x' s.
Proof.
  induction tt in x,x',s |-*;intros eq.
  -inv eq. tauto.
  -cbn in eq|-*. intros [H1 H2]. split. 1:tauto.
   intros y t exts.
   specialize (H2 y t exts) as (v&R&H2).
   exists v. split. 1:assumption.
   eapply IHtt2. 2:now eassumption.
   apply eq.
Qed.

Lemma computableExt X (tt : TT X) (x x' : X):
  extEq x x' -> computable x -> computable x'.
Proof.
  intros ? (s&?). exists s. eauto using computesExt.
Defined. (* because ? *)

(* register a datatype via an function to another, e.g. vectors as lists *)

Lemma registerAs X Y `{encodable X} (f:Y -> X) : encodable Y.
Proof.
  eexists (fun x => enc (f x)). now destruct H.
Defined.
Arguments registerAs {_ _ _} _.

Lemma registerInjAs X Y R `{@encInj X R} (f:Y -> X) : injective f -> encInj (registerAs f).
Proof.
  unfold encInj.
  intros ? ? ? H'. eapply H0, @inj_enc. all:easy.
Defined. (* because ? *)

(* Support for extracting registerAs-ed functions *)

Fixpoint changeResType t1 t2 (tt1:TT t1) (tt2 : TT t2) : {t & TT t}:=
  match tt1 with
    TyB _ _ => existT _ t2 tt2
  | TyArr _ _ tt11 tt12 =>
    existT _ _ (TyArr tt11 (projT2 (changeResType tt12 tt2)))
  end.

Fixpoint resType t1 (tt1 : TT t1) : {t & encodable t} :=
  match tt1 with
    @TyB _ R => existT _ _ R
  | TyArr _ _ _ t2 => resType t2
  end.

Fixpoint insertCast t1 (tt1 : TT t1) Y (R: encodable Y) {struct tt1}:
  forall (cast : projT1 (resType tt1) -> Y) (f : t1), projT1 (changeResType tt1 (TyB Y)) :=
  match tt1 with
    TyB _ _ => fun cast x => cast x
  | TyArr _ _ tt11 tt12 => fun cast f x=> (insertCast (tt1:=tt12) R cast (f x))
  end.

Lemma cast_registeredAs t1 (tt1 : TT t1) Y (R: encodable Y) (cast : projT1 (resType tt1) -> Y) (f:t1) :
  projT2 (resType tt1) = registerAs cast ->
  computable (ty:=projT2 (changeResType tt1 (TyB Y))) (insertCast R cast f) ->
  computable f.
Proof.
  intros H (s&exts).
  exists s.
  induction tt1 in cast,f,H,s,exts |- *.
  -cbn in H,exts|-*;unfold enc in *. rewrite H. exact exts.
  -destruct exts as (?&exts). split. assumption.
   intros x s__x ext__x.
   specialize (exts x s__x ext__x) as (v &?&exts).
   exists v. split. tauto.
   eapply IHtt1_2. all:eassumption.
Qed.

Opaque computes.


Set Implicit Arguments.
Require Import List Omega std calculus higher_order_unification.
Import ListNotations.

(** * System Unification *)
Section SystemUnification.

  Variable (X: Const).

  Definition eq: Type := exp X * exp X.
  Definition eqs := list eq.

  Implicit Types (sigma: fin -> exp X) (e: eq) (E : eqs).

  Definition eq_typing  Gamma e A := Gamma ⊢ fst e : A /\ Gamma ⊢ snd e : A.

  Notation "Gamma ⊢₂ e : A" := (eq_typing Gamma e A) (at level 80, e at level 99).

  Reserved Notation  "Gamma ⊢₊₊ E : L" (at level 80, E at level 99).

  Inductive eqs_typing Gamma : eqs -> list type -> Prop :=
  | eqs_typing_nil: Gamma ⊢₊₊ nil : nil
  | eqs_typing_cons s t A E L: Gamma ⊢ s : A -> Gamma ⊢ t : A -> Gamma ⊢₊₊ E : L -> Gamma ⊢₊₊ ((s,t) :: E) : A :: L
  where  "Gamma ⊢₊₊ E : L" := (eqs_typing Gamma E L).

  Hint Constructors eqs_typing.

  Definition left_side E := map fst E.
  Definition right_side E := map snd E.

  Lemma left_typing Gamma E L: Gamma ⊢₊₊ E : L -> Gamma ⊢₊ left_side E : L.
  Proof. induction 1; cbn; eauto. Qed.
  Lemma right_typing Gamma E L: Gamma ⊢₊₊ E : L -> Gamma ⊢₊ right_side E : L.
  Proof. induction 1; cbn; eauto. Qed.

  Lemma typing_combine Gamma E L:
    Gamma ⊢₊ left_side E : L -> Gamma ⊢₊ right_side E : L -> Gamma ⊢₊₊ E : L.
  Proof.
    intros H1 H2; induction E in L, H1, H2 |-*; inv H1; inv H2; eauto.
    destruct a; eauto.
  Qed.

  Hint Resolve left_typing right_typing.

  Definition vars' (e: eq) := vars (fst e) ++ vars (snd e).
  Definition Vars' (E: list eq) := flat_map vars' E.

  Lemma Vars'_cons e E: Vars' (e :: E) = vars' e ++ Vars' E.
  Proof. reflexivity. Qed.

  Lemma Vars'_app E1 E2:
    Vars' (E1 ++ E2) = Vars' E1 ++ Vars' E2.
  Proof.
    unfold Vars'; now rewrite !flat_map_app.
  Qed.

  Hint Rewrite Vars'_cons Vars'_app : simplify.

  Definition subst_eq sigma e := let (s, t) := e in (sigma • s, sigma • t).

  Notation "sigma •₊₊ E" := (map (subst_eq sigma) E) (at level 69, right associativity).

  Lemma left_subst_eqs E sigma:
    left_side (sigma •₊₊ E) = sigma •₊ left_side E.
  Proof.
    unfold left_side; induction E as [| []]; cbn; congruence.
  Qed.

  Lemma right_subst_eqs E sigma:
    right_side (sigma •₊₊ E) = sigma •₊ right_side E.
  Proof.
    unfold right_side; induction E as [| []]; cbn; congruence.
  Qed.

  Hint Rewrite left_subst_eqs right_subst_eqs : simplify.

  Lemma equiv_eqs_pointwise sigma E:
    (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E) -> (forall s t, (s, t) ∈ E -> sigma • s ≡ sigma • t).
  Proof.
    induction E; cbn; intuition; subst.
    all: eapply equiv_lstep_cons_inv in H; intuition.
  Qed.

  Lemma equiv_pointwise_eqs sigma E:
    (forall s t, (s, t) ∈ E -> sigma • s ≡ sigma • t) ->
    (sigma •₊ left_side E) ≡₊ (sigma •₊ right_side E).
  Proof.
    induction E as [| [s t]]; cbn; intros; eauto; intuition.
    rewrite H; intuition.
    rewrite IHE; intuition.
  Qed.

  Lemma eqs_typing_preservation_subst Gamma E L Delta sigma:
      Gamma ⊢₊₊ E : L -> Delta ⊩ sigma : Gamma -> Delta ⊢₊₊ sigma •₊₊ E : L.
  Proof. induction 1; cbn; eauto. Qed.

  Definition all_terms (P: exp X -> Prop) (E: eqs) := forall s t, (s, t) ∈ E -> P s /\ P t.
  Definition all_eqs (P: exp X -> exp X -> Prop) (E: eqs) := forall s t, (s, t) ∈ E -> P s t.

  Lemma all_terms_cons P e E:
    all_terms P (e :: E) -> P (fst e) /\ P (snd e) /\ all_terms P E.
  Proof.
    destruct e as [s t]; intros H; cbn.
    specialize (H s t) as H'; cbn in H'; intuition.
    intros ???; eapply H; cbn; intuition.
  Qed.

  Lemma all_terms_cons_iff P e E:
    all_terms P (e :: E) <-> P (fst e) /\ P (snd e) /\ all_terms P E.
  Proof.
    unfold all_eqs; cbn; split.
    - eauto using all_terms_cons.
    - intros (? & ? & ?) ? ? [->|H']; firstorder.
  Qed.

  Hint Rewrite all_terms_cons_iff : simplify.

  Lemma all_terms_nil P: all_terms P nil.
  Proof. intros ??[]. Qed.

  Lemma all_terms_app P (E1 E2: eqs):
    all_terms P (E1 ++ E2) <-> all_terms P E1 /\ all_terms P E2.
  Proof.
    unfold all_eqs; split.
    - intros H; split; intros s t H'; eapply H; simplify; intuition.
    - intros [H1 H2] s t; simplify; intros [? % H1|? % H2]; intuition.
  Qed.

  Hint Rewrite all_terms_app : simplify.

  Class sysuni :=
  {
    Gammaᵤ'  : ctx;
    Eᵤ'  : eqs;
    Lᵤ'  : list type;
    Hᵤ' : Gammaᵤ' ⊢₊₊ Eᵤ' : Lᵤ';
  }.

  Definition SU (I: sysuni) :=
    exists (Delta: ctx) (sigma: fin -> exp X), Delta ⊩ sigma : Gammaᵤ' /\ (sigma •₊ left_side Eᵤ') ≡₊ (sigma •₊ right_side Eᵤ').

  Arguments SU: clear implicits.
  Hint Resolve @Hᵤ'.

  Definition linearize_terms (S: list (exp X)) :=
    lambda AppR (var 0) (renL shift S).

  Lemma linearize_terms_subst sigma S: sigma • linearize_terms S = linearize_terms (sigma •₊ S).
  Proof. unfold linearize_terms; asimpl.
         rewrite !map_map; asimpl.
         f_equal. f_equal. eapply map_ext.
         intros ?; now asimpl.
  Qed.

  Lemma linearize_terms_equiv S T:
    linearize_terms S ≡ linearize_terms T <-> S ≡₊ T.
  Proof.
    split.
    - intros [? % list_equiv_anti_ren _] % equiv_lam_elim % equiv_AppR_elim; eauto.
      unfold shift; intros ??; congruence.
    - unfold linearize_terms. now intros ->.
  Qed.

  Lemma linearize_terms_typing Gamma S L A:
    Gamma ⊢₊ S : L -> Gamma ⊢ linearize_terms S : (Arr (rev L) A) → A.
  Proof.
    intros H; econstructor; eapply AppR_typing with (L0 := L).
    eapply listtyping_preservation_under_renaming; eauto.
    intros x ?; cbn; eauto.
    econstructor; eauto; simplify; cbn; intuition.
  Qed.

  Lemma linearize_vars S:
    vars (linearize_terms S) === Vars S.
  Proof.
    split.
    - intros ? H % vars_varof. inv H. eapply varof_vars in H1.
      rewrite AppR_vars in H1. simplify in H1. cbn in H1; intuition.
      discriminate. eapply in_flat_map in H as [? []].
      mapinj. eapply vars_ren in H0 as []. intuition.
      injection H1 as ->. eapply in_flat_map. eexists; eauto.
    - intros x H. eapply varof_vars; econstructor; eapply vars_varof.
      rewrite AppR_vars; simplify; right.
      eapply in_flat_map in H as [y]; eapply in_flat_map; exists (ren shift y).
      intuition. now eapply ren_vars.
  Qed.

  Hint Resolve linearize_terms_typing.

  Global Program Instance uni_sysuni (I: uni X): sysuni :=
     { Gammaᵤ' := Gammaᵤ; Eᵤ' := [(sᵤ, tᵤ)]; Lᵤ' := [Aᵤ]; Hᵤ' := _; }.

   Global Program Instance sysuni_uni (I: sysuni): uni X :=
       {
         Gammaᵤ := Gammaᵤ';
         sᵤ := linearize_terms (left_side Eᵤ');
         tᵤ := linearize_terms (right_side Eᵤ');
         Aᵤ := (Arr (rev Lᵤ') alpha) → alpha;
         H1ᵤ := _;
         H2ᵤ := _;
       }.

   Lemma U_SU: U X ⪯ SU.
   Proof.
     exists (uni_sysuni); intros I.
     split; intros (Delta & sigma & H1 & H2); exists Delta; exists sigma; intuition.
     eapply equiv_pointwise_eqs; cbn; firstorder; injection H; intros; subst; eauto.
     eapply equiv_eqs_pointwise; cbn; eauto; cbn; intuition.
   Qed.

   Lemma SU_U: SU ⪯ U X.
   Proof.
     exists (sysuni_uni).
     intros I; split; intros (Delta & sigma & H1 & H2); exists Delta; exists sigma; destruct I; intuition;
       cbn [sᵤ tᵤ sysuni_uni] in *.
     now rewrite !linearize_terms_subst, linearize_terms_equiv.
     now rewrite <-linearize_terms_equiv, <-!linearize_terms_subst.
   Qed.

End SystemUnification.

Arguments SU : clear implicits.
Arguments sysuni : clear implicits.
Arguments Gammaᵤ' {_} {_}.
Arguments Eᵤ' {_} {_}.
Arguments Lᵤ' {_} {_}.

Notation "sigma •₊₊ E" := (map (subst_eq sigma) E) (at level 69, right associativity).
Notation  "Gamma ⊢₊₊ E : L" := (eqs_typing Gamma E L) (at level 80, E at level 99).
Notation "Gamma ⊢₂ e : A" := (eq_typing Gamma e A) (at level 80, e at level 99).

Hint Rewrite all_terms_cons_iff all_terms_app Vars'_app Vars'_cons: simplify.
Hint Resolve all_terms_nil.

(** ** Normalisation *)
Definition SNU {X: Const} (I: sysuni X) :=
  exists Delta sigma, Delta ⊩ sigma : Gammaᵤ' /\ (sigma •₊ left_side Eᵤ') ≡₊ (sigma •₊ right_side Eᵤ') /\
                 forall x, normal (sigma x).

Lemma SU_SNU X I: SU X I <-> SNU I.
Proof.
  split; intros (Delta & sigma & H1 & H2); [| exists Delta; exists sigma; intuition].
  eapply normalise_subst in H1 as (tau & H5 & H6 & H7).
  pose (theta x := if nth (@Gammaᵤ' _ I) x then tau x else var x).
  exists Delta. exists theta. intuition.
  + intros ???; unfold theta; rewrite H; eapply H7; eauto.
  + eapply equiv_pointwise_eqs; intros.
    eapply equiv_eqs_pointwise in H2; intros; eauto.
    rewrite subst_pointwise_equiv with (sigma0 := theta) (tau0 := sigma).
    rewrite subst_pointwise_equiv with (sigma0 := theta) (tau0 := sigma); eauto.
    all: intros ? ?; enough (x ∈ dom Gammaᵤ') as D;
      [domin D; unfold theta; rewrite D|]; eauto.
    all: eapply Vars_listtyping.
    2, 4: eapply in_flat_map; eexists; (intuition eauto).
    2: change t with (snd (s, t)); eapply in_map; eauto.
    2: change s with (fst (s, t)); eapply in_map; eauto.
    all: eauto using left_typing, right_typing, @Hᵤ'.
  + unfold theta; destruct nth eqn: ?; [|eauto].
    domin Heqo; eauto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj14synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 (plus lv1 lv2)) (plus lv2 (plus lv1 lv0))).
Admitted.
QuickChick conj14synthconj4.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj9eqsynthconj5 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus (mult lv0 lv1) lv1) (mult (Succ lv0) lv1)).
Admitted.
QuickChick conj9eqsynthconj5.


(** Copyright (c) 2015 Bill White **)
(** Distributed under the MIT/X11 software license **)
(** See http://www.opensource.org/licenses/mit-license.php **)

(** Blocks: Blocks are given by headers and deltas.
    We define types of block chains and block header chains.
    We leave the reward function, how 'hits' are checked and how targets are calculated as parameters.
    The block contains a ctree corresponding to sufficient information about the previous ledger
    to process the block (ctree_of_Block) obtained by grafting the information in the block delta
    to the information in the block header. All the transactions in the block (including the
    coinstake in the header) can be combined to give one large transaction (tx_of_Block).
    If the block is valid (valid_Block), then the combined transaction will be valid and supported.
    If we start from a valid genesis ledger and a block chain is built from valid blocks (valid_BlockChain),
    then we are guaranteed that the ending ledger is also valid (lastledgerroot_valid).
    Furthermore, we know precisely how many currency units are in the ledger as of
    a certain block height (lastledgerroot_sum_correct).
 **)

Require Export CTreeGrafting.

(*** Idea: keep up with how fast the past N blocks and use this to determine the current target. I'll use 6 blocks just as a concrete option here. ***)
Definition targetinfo : Type := prod nat (list nat).
Definition nexttargetinfo (ti : targetinfo) (tm : nat) : targetinfo :=
match ti with
| (prevtm,nil) => (tm,(tm - prevtm)::nil)
| (prevtm,c1::nil) => (tm,c1::(tm - prevtm)::nil)
| (prevtm,c2::c1::nil) => (tm,c2::c1::(tm - prevtm)::nil)
| (prevtm,c3::c2::c1::nil) => (tm,c3::c2::c1::(tm - prevtm)::nil)
| (prevtm,c4::c3::c2::c1::nil) => (tm,c4::c3::c2::c1::(tm - prevtm)::nil)
| (prevtm,c5::c4::c3::c2::c1::nil) => (tm,c5::c4::c3::c2::c1::(tm - prevtm)::nil)
| (prevtm,c6::c5::c4::c3::c2::c1::_) => (tm,c5::c4::c3::c2::c1::(tm - prevtm)::nil)
end.

Definition hashtargetinfo (ti:targetinfo) : hashval :=
let (n,ml) := ti in
hashpair (hashnat n) (hashlist (map hashnat ml)).

Definition targetinfo_timestamp (ti:targetinfo) : nat := fst ti.

Record BlockHeader : Type :=
  mkBlockHeader
    {
      prevblockhash : option hashval;
      newledgerroot : hashval;
      targetinfohash : hashval;
      timestamp : nat;
      stake : nat;
      stakeaddr : addr;
      stakeassetid : hashval;
      blocksignat : signat;
      prevledger : ctree 160
    }.

Record BlockDelta : Type :=
  mkBlockDelta
    {
      totalfees : nat;
      stakeoutput : list addr_preasset;
      prevledgergraft : cgraft;
      blockdelta_stxl : list sTx
    }.

Definition Block : Type :=
  prod BlockHeader BlockDelta.

Definition coinstake (b:Block) : Tx :=
  let (bh,bd) := b in
  ((stakeaddr bh,stakeassetid bh)::nil,stakeoutput bd).

Definition hitfun : Type  := option hashval -> nat -> nat -> nat -> addr -> Prop.

Definition targetfun : Type := targetinfo -> nat.

Definition hash_BlockHeader (bh:BlockHeader) : hashval :=
hashopair2 (prevblockhash bh) (hashlist (newledgerroot bh::targetinfohash bh::hashnat (timestamp bh)::hashnat (stake bh)::hashaddr (stakeaddr bh)::(stakeassetid bh)::nil)).

(*** A currency asset can be used to stake as long as it will not mature in the next 1000 blocks. (1000 is arbitrary, of course.) ***)
Definition not_close_to_mature : nat := 1000.

(*** The output from staking cannot be spent until 1000 blocks later. Again, 1000 is arbitrary here. ***)
Definition maturation_post_staking : nat := 1000.

Definition valid_BlockHeader (blockheight:nat) (check_hit : hitfun) (targetf : targetfun) (plr:hashval) (ti:targetinfo) (bh:BlockHeader) : Prop :=
  (timestamp bh > targetinfo_timestamp ti /\ hashtargetinfo ti = targetinfohash bh)
  /\
  check_signat (hash_BlockHeader bh) (blocksignat bh) (stakeaddr bh)
  /\
  check_hit (prevblockhash bh) (timestamp bh) (targetf ti) (stake bh) (stakeaddr bh)
  /\
  ctree_hashroot (prevledger bh) = plr
  /\
  (exists al m n,
     ctree_supports_asset (stakeassetid bh,((al,(m,n)),currency (stake bh))) (prevledger bh) (stakeaddr bh)
     /\
     n > blockheight + not_close_to_mature)
.

Fixpoint sTxs_allinputs (stxl : list sTx) : list addr_assetid :=
  match stxl with
    | ((inpl,_),s)::stxr => inpl ++ sTxs_allinputs stxr
    | nil => nil
  end.

Fixpoint sTxs_alloutputs (stxl : list sTx) : list addr_preasset :=
  match stxl with
    | ((_,outpl),s)::stxr => outpl ++ sTxs_alloutputs stxr
    | nil => nil
  end.

Lemma sTxs_allinputs_iff stxl alpha h :
  In (alpha,h) (sTxs_allinputs stxl) <-> exists tx, In_dom tx stxl /\ In (alpha,h) (tx_inputs tx).
induction stxl as [|[[inpl outpl] s] stxr IH]; split.
- simpl. tauto.
- intros [tx [H1 _]]. contradiction H1.
- simpl. intros H1. apply in_app_or in H1. destruct H1 as [H1|H1].
  + exists (inpl,outpl). simpl. tauto.
  + apply IH in H1. destruct H1 as [tx H2]. exists tx. tauto.
- intros [tx [[H1|H1] H2]].
  + simpl. apply in_or_app. left. rewrite H1 in H2. exact H2.
  + simpl. apply in_or_app. right. apply IH. exists tx. tauto.
Qed.

Lemma sTxs_alloutputs_iff stxl alpha u :
  In (alpha,u) (sTxs_alloutputs stxl) <-> exists tx, In_dom tx stxl /\ In (alpha,u) (tx_outputs tx).
induction stxl as [|[[inpl outpl] s] stxr IH]; split.
- simpl. tauto.
- intros [tx [H1 _]]. contradiction H1.
- simpl. intros H1. apply in_app_or in H1. destruct H1 as [H1|H1].
  + exists (inpl,outpl). simpl. tauto.
  + apply IH in H1. destruct H1 as [tx H2]. exists tx. tauto.
- intros [tx [[H1|H1] H2]].
  + simpl. apply in_or_app. left. rewrite H1 in H2. exact H2.
  + simpl. apply in_or_app. right. apply IH. exists tx. tauto.
Qed.

Definition ctree_of_Header (b:Block) : ctree 160 :=
  let (bh,bd) := b in
  prevledger bh.

Definition ctree_of_Block (b:Block) : ctree 160 :=
  let (bh,bd) := b in
  ctree_cgraft (prevledgergraft bd) (prevledger bh).

Definition timestamp_of_Block (b:Block) : nat :=
  let (bh,bd) := b in
  timestamp bh.

(*** One Tx combining all the Txs in the block, including the coinstake. ***)
Definition tx_of_Block (b:Block) : Tx :=
  let (bh,bd) := b in
  ((stakeaddr bh,stakeassetid bh)::sTxs_allinputs (blockdelta_stxl bd),stakeoutput bd ++ sTxs_alloutputs (blockdelta_stxl bd)).

Definition valid_Block (blockheight:nat) (rew:nat) (check_hit : hitfun) (targetf : targetfun) plr ti (b:Block) : Prop :=
  let (bh,bd) := b in
  (*** The header is valid. ***)
  valid_BlockHeader blockheight check_hit targetf plr ti bh
  /\
  (*** The asset staked must be one of the outputs. This is especially important if it's been loaned for staking.
        The other stake outputs must explicitly say that they cannot be spent until at least blockheight + maturation_post_staking. ***)
  (exists obl:obligation, exists i:nat,
     ctree_supports_asset (stakeassetid bh,(obl,currency (stake bh))) (prevledger bh) (stakeaddr bh)
     /\
     nth_error (stakeoutput bd) i = value (stakeaddr bh,(obl,currency (stake bh)))
     /\
     (forall alpha al m n u j, j <> i /\ nth_error (stakeoutput bd) j = value (alpha,((al,(m,n)),u)) -> n > blockheight + maturation_post_staking))
  /\
  (*** The addresses of the coinstake output are supported by the grafted ctree. ***)
  ((forall alpha ou, In (alpha,ou) (stakeoutput bd) -> ctree_supports_addr (ctree_of_Block (bh,bd)) alpha)
   /\
   (*** and the total output values match the declared stake and reward and fees ***)
   (asset_value_out (stakeoutput bd) = stake bh + rew + totalfees bd))
  /\
  (*** There are no duplicate transactions. ***)
  no_dups (blockdelta_stxl bd)
  /\
  (*** Each transaction in the delta has supported elaborated assets and has valid signatures. ***)
  (forall tx sl, In (tx,sl) (blockdelta_stxl bd) ->
                 exists einpl:list asset,
                   tx_signatures_valid blockheight einpl (tx,sl)
                   /\
                   (forall beta h, In (beta,h) (tx_inputs tx) -> exists a, In a einpl /\ assetid a = h /\ ctree_supports_asset a (ctree_of_Block (bh,bd)) beta))
  /\
  (*** Each transaction in the delta is valid. ***)
  (forall stx, In stx (blockdelta_stxl bd) -> tx_valid (fst stx))
  /\
  (*** No transaction has the stake asset as an input. ***)
  (forall tx, In_dom tx (blockdelta_stxl bd) -> ~ In (stakeaddr bh,stakeassetid bh) (tx_inputs tx))
  /\
  (*** No distinct transactions try to spend the same asset. ***)
  (forall tx1 sl1 tx2 sl2 alpha h,
     In (tx1,sl1) (blockdelta_stxl bd) ->
     In (tx2,sl2) (blockdelta_stxl bd) ->
     In (alpha,h) (tx_inputs tx1) ->
     In (alpha,h) (tx_inputs tx2) ->
     tx1 = tx2 /\ sl1 = sl2)
  /\
  (*** The cgraft is valid. ***)
  cgraft_valid (prevledgergraft bd)
  /\
  (*** Every transaction is supported by the grafted ctree with 0 reward. ***)
  (forall tx, In_dom tx (blockdelta_stxl bd)
              -> exists fee, ctree_supports_tx tx (ctree_of_Block (bh,bd)) fee 0)
  (*** The total inputs and outputs match up with the declared fee. ***)
  /\
  (exists utot:nat,
     ctree_asset_value_in (ctree_of_Block (bh,bd)) (sTxs_allinputs (blockdelta_stxl bd)) utot
     /\
     asset_value_out (sTxs_alloutputs (blockdelta_stxl bd)) + (totalfees bd) = utot)
  /\
  exists T:ctree 160,
    ctree_hashroot T = newledgerroot bh
    /\ tx_octree_trans (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) = Some T.

Inductive BlockChain : nat -> Type :=
| BlockChainGen : Block -> BlockChain 0
| BlockChainSucc n : BlockChain n -> Block -> BlockChain (S n).

Inductive BlockHeaderChain : nat -> Type :=
| BlockHeaderChainGen : BlockHeader -> BlockHeaderChain 0
| BlockHeaderChainSucc n : BlockHeaderChain n -> BlockHeader -> BlockHeaderChain (S n).

Fixpoint BlockChain_headers {n} (bc : BlockChain n) : BlockHeaderChain n :=
match bc with
| BlockChainGen (bh,_) => BlockHeaderChainGen bh
| BlockChainSucc n bc (bh,_) => BlockHeaderChainSucc n (BlockChain_headers bc) bh
end.

Definition lastledgerroot_of_BlockChain {n} (bc:BlockChain n) : hashval :=
match bc with
| BlockChainGen (bh,_) => newledgerroot bh
| BlockChainSucc n bc (bh,_) => newledgerroot bh
end.

Definition lastledgerroot_of_BlockHeaderChain {n} (bc:BlockHeaderChain n) : hashval :=
match bc with
| BlockHeaderChainGen bh => newledgerroot bh
| BlockHeaderChainSucc n bc bh => newledgerroot bh
end.

Fixpoint valid_BlockChain (rewfn:nat -> nat) (check_hit:hitfun) (targetf:targetfun) genlr genti ti {n} (bc : BlockChain n) : Prop :=
match bc with
| BlockChainGen b => valid_Block 0 (rewfn 0) check_hit targetf genlr genti b /\ ti = nexttargetinfo genti (timestamp_of_Block b)
| BlockChainSucc n bc b => exists ti', valid_BlockChain rewfn check_hit targetf genlr genti ti' bc /\ valid_Block (S n) (rewfn (S n)) check_hit targetf (lastledgerroot_of_BlockChain bc) ti' b /\ ti = nexttargetinfo ti' (timestamp_of_Block b)
end.

Fixpoint valid_BlockHeaderChain (check_hit:hitfun) (targetf:targetfun) genlr genti ti {n} (bc : BlockHeaderChain n) : Prop :=
match bc with
| BlockHeaderChainGen bh => valid_BlockHeader 0 check_hit targetf genlr genti bh /\ ti = nexttargetinfo genti (timestamp bh)
| BlockHeaderChainSucc n bc bh => exists ti', valid_BlockHeaderChain check_hit targetf genlr genti ti' bc /\ valid_BlockHeader (S n) check_hit targetf (lastledgerroot_of_BlockHeaderChain bc) ti' bh /\ ti = nexttargetinfo ti' (timestamp bh)
end.

Lemma tx_of_Block_valid blockheight rew check_hit targetf plr ti (b:Block) :
  valid_Block blockheight rew check_hit targetf plr ti b ->
  tx_valid (tx_of_Block b).
destruct b as [bh bd].
intros HvB. generalize HvB.
intros [[HvBaa [HvBab [HvBac [HvBad [HvBae HvBaf]]]]] [HvBag [HvBah [HvBb [HvBc [HvBd [HvBe [HvBf [HvBg [HvBh [HvBi HvBj]]]]]]]]]]].
split.
- simpl. discriminate.
- simpl. apply no_dups_cons.
  + intros H1. apply sTxs_allinputs_iff in H1.
    destruct H1 as [[inpl outpl] [H2 H3]].
    revert H2 H3. apply HvBe.
  + revert HvBb HvBd HvBf. unfold sTxs_allinputs. generalize (blockdelta_stxl bd).
    clear.
    (*** This could be made into a reasonable lemma instead of giving a double induction in a subproof. ***)
    induction l as [|[[inpl outpl] sl] txl IH].
    * simpl. intros H0 H1 H2. apply no_dups_nil.
    * { simpl. intros H0 H1 H2. apply no_dups_app.
        - assert (L1: (inpl, outpl, sl) = (inpl, outpl, sl) \/ In (inpl, outpl, sl) txl) by now left.
          destruct (H1 ((inpl,outpl),sl) L1) as [_ H1b].
          exact H1b.
        - apply IH.
          + inversion H0. assumption.
          + intros stx H3. apply H1. now right.
          + intros tx1 sl1 tx2 sl2 alpha h H3 H4. apply H2; now right.
        - revert H0 H2. clear.
          induction txl as [|[[inpl2 outpl2] sl2] txr IH]; intros H0 H2 [alpha h] H3.
          + simpl. tauto.
          + intros H4. apply in_app_or in H4.
            destruct H4 as [H4|H4].
            * inversion H0. apply H5. left.
              assert (L1: (inpl,outpl) = (inpl2,outpl2) /\ sl = sl2).
              { apply (H2 (inpl,outpl) sl (inpl2,outpl2) sl2 alpha h).
                - now left.
                - right. now left.
                - exact H3.
                - exact H4.
              }
              destruct L1 as [L1a L1b].
              rewrite L1a. rewrite L1b.
              reflexivity.
            * { revert H4. apply IH.
                - inversion H0. apply no_dups_cons.
                  + intros H6. apply H4. now right.
                  + inversion H5. assumption.
                - intros tx3 sl3 tx4 sl4 beta k H6 H7. apply H2.
                  + simpl. tauto.
                  + simpl. tauto.
                - exact H3.
              }
      }
Qed.

Lemma tx_of_Block_input_iff alpha h (b : Block) :
  In (alpha,h) (tx_inputs (tx_of_Block b))
  <->
  ((alpha = stakeaddr (fst b) /\ h = stakeassetid (fst b))
   \/
   exists tx sl, In (tx,sl) (blockdelta_stxl (snd b)) /\ In (alpha,h) (tx_inputs tx)).
destruct b as [bh bd]. simpl. split; intros [H1|H1].
- left. inversion H1. tauto.
- right. apply sTxs_allinputs_iff in H1.
  destruct H1 as [tx [H1 H2]]. apply In_In_dom_lem in H1.
  destruct H1 as [sl H1]. exists tx. exists sl. tauto.
- left. destruct H1 as [H2 H3]. congruence.
- right. apply sTxs_allinputs_iff. destruct H1 as [tx [sl [H1 H2]]].
  exists tx. split.
  + revert H1. apply In_In_dom_lem_2.
  + exact H2.
Qed.

Lemma tx_of_Block_output_iff alpha obju (b : Block) :
 In (alpha, obju) (tx_outputs (tx_of_Block b))
 <->
 (In (alpha, obju) (stakeoutput (snd b))
  \/
   exists tx sl, In (tx,sl) (blockdelta_stxl (snd b)) /\ In (alpha,obju) (tx_outputs tx)).
destruct b as [bh bd]. simpl. split; intros H1.
- apply in_app_or in H1. destruct H1 as [H1|H1].
  + now left.
  + right. apply sTxs_alloutputs_iff in H1.
    destruct H1 as [tx [H1 H2]]. apply In_In_dom_lem in H1.
    destruct H1 as [sl H1]. exists tx. exists sl. tauto.
- apply in_or_app. destruct H1 as [H1|H1].
  + now left.
  + right. apply sTxs_alloutputs_iff. destruct H1 as [tx [sl [H1 H2]]].
    exists tx. split.
    * revert H1. apply In_In_dom_lem_2.
    * exact H2.
Qed.

Opaque ctree_supports_addr.

(*** This lemma was pulled out from the main proof to help Coq process the main proof. ***)
Lemma tx_of_Block_supported_lem_1 blockheight rew (bh:BlockHeader) (bd:BlockDelta) utot :
  ctree_valid (ctree_of_Block (bh, bd)) ->
  subqc (prevledger bh) (ctree_of_Block (bh, bd)) ->
  (exists (al : list addr) (m n : nat),
     ctree_supports_asset
       (stakeassetid bh, (al, (m, n), currency (stake bh)))
       (prevledger bh) (stakeaddr bh) /\
     n > blockheight + not_close_to_mature) ->
  asset_value_out (stakeoutput bd) = stake bh + rew + totalfees bd ->
  asset_value_out (sTxs_alloutputs (blockdelta_stxl bd)) + totalfees bd = utot ->
  asset_value_out (tx_outputs (tx_of_Block (bh, bd))) + 0 =
  stake bh + utot + rew.
  intros HT Lsubqc HvBae H5 H3.
  simpl. rewrite asset_value_out_app.
  omega.
Qed.

Theorem tx_of_Block_supported blockheight rew check_hit targetf plr ti (b:Block) :
  ctree_valid (ctree_of_Block b) ->
  valid_Block blockheight rew check_hit targetf plr ti b ->
  ctree_supports_tx (tx_of_Block b) (ctree_of_Block b) 0 rew.
destruct b as [bh bd]. intros HT HvB. generalize HvB.
intros [[HvBaa [HvBab [HvBac [HvBad HvBae]]]] [HvBaf [HvBag [HvBb [HvBc [HvBd [HvBe [HvBf [HvBg [HvBh [HvBi HvBj]]]]]]]]]]].
generalize HvBag. intros [HvBag1 HvBag2].
assert (Lsubqc: subqc (prevledger bh) (ctree_of_Block (bh,bd))).
{ unfold ctree_of_Block. apply ctree_cgraft_subqc. exact HvBg. }
split.
- intros alpha obju H1.
  apply tx_of_Block_output_iff in H1.
  destruct H1 as [H1|[tx' [sl' [H2 H3]]]].
  + exact (HvBag1 alpha obju H1).
  + apply In_In_dom_lem_2 in H2.
    destruct (HvBh tx' H2) as [fee [H2a _]].
    revert H3. apply H2a.
- destruct HvBi as [utot [H2 H3]].
  exists (stake bh + utot).
  split.
  + change (ctree_asset_value_in (ctree_of_Block (bh, bd))
                                 ((stakeaddr bh, stakeassetid bh)
                                    :: sTxs_allinputs (blockdelta_stxl bd))
                                 (stake bh + utot)).
    destruct HvBae as [al [m [n [H4 H5]]]].
    apply ctree_asset_value_in_cons with (a := (stakeassetid bh,((al,(m,n)),currency (stake bh)))).
    * exact H2.
    * revert H4. apply subqc_supports_asset. exact Lsubqc.
    * reflexivity.
    * reflexivity.
  + revert HT Lsubqc HvBae HvBag2 H3.
    apply tx_of_Block_supported_lem_1.
Qed.

Definition ledgerroot_valid (h:hashval) : Prop :=
  ctree_valid (ctreeH 160 h).

Opaque tx_octree_trans.

Lemma ctree_hashroot_ctree_H {n} (h:hashval) :
  ctree_hashroot (ctreeH n h) = h.
destruct n; simpl; reflexivity.
Qed.

Opaque mtree_approx_fun_p.
Opaque ctree_mtree.
Opaque tx_of_Block.
Opaque mtree_hashroot.
Opaque ctree_hashroot.
Opaque ctree_cgraft.
Opaque cgraft_assoc.
Opaque subqm.

Lemma endledgerroot_plr_valid_lem1 lroot (bh:BlockHeader) bd (f:statefun) :
  mtree_approx_fun_p (ctree_mtree (ctreeH 160 lroot)) f ->
  ctree_hashroot (prevledger bh) = lroot ->
  cgraft_valid (prevledgergraft bd) ->
  mtree_approx_fun_p (ctree_mtree (ctree_of_Block (bh, bd))) f.
intros H1 H2 H3.
apply (mtree_hashroot_mtree_approx_fun_p (ctree_mtree (ctreeH 160 lroot))).
- change (mtree_hashroot (ctree_mtree (ctreeH 160 lroot)) =
          mtree_hashroot (ctree_mtree (ctree_of_Block (bh, bd)))).
  rewrite mtree_hashroot_ctree_hashroot.
  rewrite mtree_hashroot_ctree_hashroot.
  rewrite ctree_hashroot_ctree_H.
  unfold ctree_of_Block.
  assert (L1: subqc (prevledger bh) (ctree_cgraft (prevledgergraft bd) (prevledger bh))).
  { exact (ctree_cgraft_subqc (prevledgergraft bd) (prevledger bh) H3). }
  unfold subqc in L1.
  apply subqm_hashroot_eq in L1.
  rewrite mtree_hashroot_ctree_hashroot in L1.
  rewrite mtree_hashroot_ctree_hashroot in L1.
  rewrite H2 in L1.
  exact L1.
- exact H1.
Qed.

Theorem lastledgerroot_valid rewfn check_hit targetf genlr genti ti {n} (bc : BlockChain n) :
  ledgerroot_valid genlr ->
  valid_BlockChain rewfn check_hit targetf genlr genti ti bc ->
  ledgerroot_valid (lastledgerroot_of_BlockChain bc).
intros H1. revert ti. induction bc as [[bh bd]|n bc IH [bh bd]]; intros ti.
- intros H2. generalize H2. intros [[[H2aa [H2ab [H2ac [H2ad H2ae]]]] [H2af [H2ag [H2b [H2c [H2d [H2e [H2f [H2g [H2h [H2i H2j]]]]]]]]]]] Hti].
  assert (LT: ctree_valid (ctree_of_Block (bh,bd))).
  { unfold ctree_of_Block. apply ctree_valid_cgraft_valid.
    - revert H1. unfold ledgerroot_valid. unfold ctree_valid.
      apply mtree_hashroot_eq_valid.
      rewrite mtree_hashroot_ctree_hashroot.
      rewrite mtree_hashroot_ctree_hashroot.
      rewrite ctree_hashroot_ctree_H.
      f_equal. exact H2ad.
    - exact H2g.
  }
  destruct H2j as [T [H2ja H2jb]].
  change (ledgerroot_valid (newledgerroot bh)).
  rewrite <- H2ja.
  unfold ledgerroot_valid.
  unfold ctree_valid.
  assert (L1: octree_supports_tx (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) 0 (rewfn 0)).
  { destruct H2 as [H2x H2y].
    exact (tx_of_Block_supported 0 (rewfn 0) check_hit targetf _ _ (bh,bd) LT H2x).
  }
  apply (mtree_hashroot_eq_valid (ctree_mtree T)).
  + rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  + destruct H1 as [f [H1a H1b]].
    assert (LTf: octree_approx_fun_p (Some (ctree_of_Block (bh,bd))) f).
    { exact (endledgerroot_plr_valid_lem1 genlr bh bd f H1b H2ad H2g). }
    exists (tx_statefun_trans (tx_of_Block (bh,bd)) f). split.
    * { apply sf_tx_valid_thm with (fee := 0) (rew := (rewfn 0)).
        - exact H1a.
        - destruct H2 as [H2x H2y]. revert H2x. apply tx_of_Block_valid.
        - assert (L2: mtree_supports_tx (tx_of_Block (bh, bd))
                                        (octree_mtree (Some (ctree_of_Block (bh, bd)))) 0
                                        (rewfn 0)).
          { revert L1. apply octree_mtree_supports_tx. }
          apply mtree_supports_tx_statefun with (f := f) in L2.
          + exact L2.
          + destruct H1a as [_ [Hf2 _]]. exact Hf2.
          + unfold octree_approx_fun_p in LTf.
            exact LTf.
      }
    * { assert (L4: mtree_approx_fun_p (octree_mtree (Some T)) (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
        { rewrite <- H2jb.
          set (tx' := (tx_of_Block (bh,bd))).
          set (T' := (ctree_of_Block (bh,bd))).
          assert (L5: octree_approx_fun_p (tx_octree_trans tx' (Some T')) (tx_statefun_trans tx' f)).
          { apply (octree_approx_trans tx' (Some T') f 0 (rewfn 0)).
            - exact H1a.
            - unfold tx'. unfold T'. destruct H2 as [H2x H2y]. revert H2x. apply tx_of_Block_supported.
              exact LT.
            - unfold T'. exact LTf.
          }
          unfold octree_approx_fun_p in L5.
          exact L5.
        }
        unfold octree_mtree in L4.
        exact L4.
      }
- intros [ti' [H3 [H2 Hti]]].
  generalize H2.
  intros [[H2aa [H2ab [H2ac [H2ad H2ae]]]] [H2af [H2ag [H2b [H2c [H2d [H2e [H2f [H2g [H2h [H2i H2j]]]]]]]]]]].
  assert (LT: ctree_valid (ctree_of_Block (bh,bd))).
  { unfold ctree_of_Block. apply ctree_valid_cgraft_valid.
    - generalize (IH ti' H3). unfold ledgerroot_valid. unfold ctree_valid.
      apply mtree_hashroot_eq_valid.
      rewrite mtree_hashroot_ctree_hashroot.
      rewrite mtree_hashroot_ctree_hashroot.
      rewrite ctree_hashroot_ctree_H.
      f_equal. exact H2ad.
    - exact H2g.
  }
  destruct H2j as [T [H2ja H2jb]].
  change (ledgerroot_valid (newledgerroot bh)).
  rewrite <- H2ja.
  unfold ledgerroot_valid.
  unfold ctree_valid.
  assert (L1: octree_supports_tx (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) 0 (rewfn (S n))).
  { exact (tx_of_Block_supported (S n) (rewfn (S n)) check_hit targetf _ _ (bh,bd) LT H2). }
  apply (mtree_hashroot_eq_valid (ctree_mtree T)).
  + rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  + destruct (IH ti' H3) as [f [H1a H1b]].
    assert (LTf: octree_approx_fun_p (Some (ctree_of_Block (bh,bd))) f).
    { exact (endledgerroot_plr_valid_lem1 _ bh bd f H1b H2ad H2g). }
    exists (tx_statefun_trans (tx_of_Block (bh,bd)) f). split.
    * { apply sf_tx_valid_thm with (fee := 0) (rew := (rewfn (S n))).
        - exact H1a.
        - revert H2. apply tx_of_Block_valid.
        - assert (L2: mtree_supports_tx (tx_of_Block (bh, bd))
                                        (octree_mtree (Some (ctree_of_Block (bh, bd)))) 0
                                        (rewfn (S n))).
          { revert L1. apply octree_mtree_supports_tx. }
          apply mtree_supports_tx_statefun with (f := f) in L2.
          + exact L2.
          + destruct H1a as [_ [Hf2 _]]. exact Hf2.
          + unfold octree_approx_fun_p in LTf.
            exact LTf.
      }
    * { assert (L4: mtree_approx_fun_p (octree_mtree (Some T)) (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
        { rewrite <- H2jb.
          set (tx' := (tx_of_Block (bh,bd))).
          set (T' := (ctree_of_Block (bh,bd))).
          assert (L5: octree_approx_fun_p (tx_octree_trans tx' (Some T')) (tx_statefun_trans tx' f)).
          { apply (octree_approx_trans tx' (Some T') f 0 (rewfn (S n))).
            - exact H1a.
            - unfold tx'. unfold T'. revert H2. apply tx_of_Block_supported.
              exact LT.
            - unfold T'. exact LTf.
          }
          unfold octree_approx_fun_p in L5.
          exact L5.
        }
        unfold octree_mtree in L4.
        exact L4.
      }
Qed.

Fixpoint units_as_of_block (initdistr:nat) (rewfn:nat -> nat) (blockheight:nat) : nat :=
match blockheight with
| O => initdistr
| S n => units_as_of_block initdistr rewfn n + rewfn n
end.

Opaque sf_valid.
Opaque tx_statefun_trans.
Opaque tx_octree_trans.
Opaque mtree_approx_fun_p.

Theorem lastledgerroot_sum_correct initdistr al bl rewfn check_hit targetf genlr genti ti {n}
      (bc : BlockChain n) :
  ledgerroot_valid genlr ->
  octree_totalassets (Some (ctreeH 160 genlr)) al ->
  asset_value_sum al = initdistr ->
  valid_BlockChain rewfn check_hit targetf genlr genti ti bc ->
  octree_totalassets (Some (ctreeH 160 (lastledgerroot_of_BlockChain bc))) bl ->
  asset_value_sum bl = units_as_of_block initdistr rewfn (S n).
intros H1 H2 H3. revert bl ti.
induction bc as [[bh bd]|n bc IH [bh bd]].
- intros bl ti H4 H5.
  simpl. unfold valid_BlockChain in H4.
  generalize H4.
  intros [[[H4aa [H4ab [H4ac [H4ad H4ae]]]] [H4af [H4ag [H4b [H4c [H4d [H4e [H4f [H4g [H4h [H4i [T [HT1 HT2]]]]]]]]]]]]] Hti].
  assert (L0: ctree_hashroot (ctree_of_Block(bh,bd)) = genlr).
  { transitivity (ctree_hashroot (prevledger bh)).
    - unfold ctree_of_Block. symmetry.
      apply subqc_hashroot_eq. apply ctree_cgraft_subqc. exact H4g.
    - exact H4ad.
  }
  assert (L1: octree_valid (Some (ctree_of_Block (bh, bd)))).
  { unfold octree_valid. revert H1. unfold ledgerroot_valid. unfold ctree_valid.
    apply mtree_hashroot_eq_valid.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite L0.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  }
  assert (L2: tx_valid (tx_of_Block (bh, bd))).
  { destruct H4 as [H4x H4y]. revert H4x. apply tx_of_Block_valid. }
  assert (L3: octree_supports_tx (tx_of_Block (bh, bd)) (Some (ctree_of_Block (bh, bd))) 0 (rewfn 0)).
  { unfold octree_supports_tx.
    destruct H4 as [H4x H4y].
    revert L1 H4x. unfold octree_valid. apply tx_of_Block_supported.
  }
  generalize L1. intros [f [Hf HTf]].
  assert (L4: mtree_approx_fun_p (ctree_mtree (ctreeH 160 genlr)) f).
  { revert HTf. apply mtree_hashroot_mtree_approx_fun_p.
    rewrite mtree_hashroot_ctree_hashroot. rewrite L0.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  }
  assert (L5: octree_totalassets (Some (ctree_of_Block (bh, bd))) al).
  { unfold octree_totalassets. unfold octree_mtree.
    apply (mtree_approx_fun_p_totalassets _ _ _ HTf).
    revert H2. unfold octree_totalassets. unfold octree_mtree.
    revert L4. clear. apply mtree_approx_fun_p_totalassets.
  }
  assert (L6: octree_approx_fun_p
                (tx_octree_trans (tx_of_Block (bh, bd))
                                 (Some (ctree_of_Block (bh, bd))))
                (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
  { apply (octree_approx_trans (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) f 0 (rewfn 0) Hf L3).
    unfold octree_approx_fun_p. unfold octree_mtree.
    exact HTf.
  }
  assert (L7: octree_approx_fun_p (Some T) (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
  { unfold octree_approx_fun_p. rewrite <- HT2.
    exact L6.
  }
  assert (L8: octree_totalassets (tx_octree_trans (tx_of_Block (bh, bd)) (Some (ctree_of_Block (bh, bd)))) bl).
  { rewrite HT2.
    unfold octree_totalassets. unfold octree_mtree.
    apply (mtree_approx_fun_p_totalassets _ _ _ L7).
    revert H5.
    unfold octree_totalassets. unfold octree_mtree.
    apply mtree_approx_fun_p_totalassets.
    revert L7. unfold octree_approx_fun_p.
    apply mtree_hashroot_mtree_approx_fun_p.
    unfold octree_mtree.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    rewrite HT1. reflexivity.
  }
  generalize (octree_tx_asset_value_sum (Some (ctree_of_Block (bh,bd))) (tx_of_Block (bh,bd)) 0 (rewfn 0) al bl L1 L2 L3 L5 L8).
  rewrite H3.
  assert (L9: asset_value_sum bl + 0 = asset_value_sum bl).
  { clear. omega. }
  rewrite L9. exact (fun H => H).
- intros bl ti [ti' [H4 [H5 Hti]]] H6.
  generalize H5.
  intros [[H5aa [H5ab [H5ac [H5ad H5ae]]]] [H5af [H5ag [H5b [H5c [H5d [H5e [H5f [H5g [H5h [H5i [T [HT1 HT2]]]]]]]]]]]]].
  assert (Lplr: ledgerroot_valid (lastledgerroot_of_BlockChain bc)).
  { revert H1 H4. apply lastledgerroot_valid. }
  generalize Lplr. intros [f [Hf Hplrf]].
  assert (LIH: asset_value_sum (totalassets_ f) = units_as_of_block initdistr rewfn (S n)).
  { apply (IH (totalassets_ f) ti').
    - exact H4.
    - unfold octree_totalassets. unfold octree_mtree.
      apply (mtree_approx_fun_p_totalassets _ _ _ Hplrf).
      reflexivity.
  }
  change (asset_value_sum bl = units_as_of_block initdistr rewfn (S n) + rewfn (S n)).
  rewrite <- LIH.
  assert (L0: ctree_hashroot (ctree_of_Block(bh,bd)) = lastledgerroot_of_BlockChain bc).
  { transitivity (ctree_hashroot (prevledger bh)).
    - unfold ctree_of_Block. symmetry.
      apply subqc_hashroot_eq. apply ctree_cgraft_subqc. exact H5g.
    - exact H5ad.
  }
  assert (L1: octree_valid (Some (ctree_of_Block (bh, bd)))).
  { unfold octree_valid. revert Lplr. unfold ledgerroot_valid. unfold ctree_valid.
    apply mtree_hashroot_eq_valid.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite L0.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  }
  assert (L2: tx_valid (tx_of_Block (bh, bd))).
  { revert H5. apply tx_of_Block_valid. }
  assert (L3: octree_supports_tx (tx_of_Block (bh, bd)) (Some (ctree_of_Block (bh, bd))) 0 (rewfn (S n))).
  { unfold octree_supports_tx. revert L1 H5. unfold octree_valid. apply tx_of_Block_supported. }
  assert (L4: mtree_approx_fun_p (ctree_mtree (ctree_of_Block (bh,bd))) f).
  { revert Hplrf. apply mtree_hashroot_mtree_approx_fun_p.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot. rewrite L0.
    rewrite ctree_hashroot_ctree_H.
    reflexivity.
  }
  assert (L5: octree_totalassets (Some (ctree_of_Block (bh, bd))) (totalassets_ f)).
  { unfold octree_totalassets. unfold octree_mtree.
    apply (mtree_approx_fun_p_totalassets _ _ _ L4).
    reflexivity.
  }
  assert (L6: octree_approx_fun_p
                (tx_octree_trans (tx_of_Block (bh, bd))
                                 (Some (ctree_of_Block (bh, bd))))
                (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
  { apply (octree_approx_trans (tx_of_Block (bh,bd)) (Some (ctree_of_Block (bh,bd))) f 0 (rewfn (S n)) Hf L3).
    unfold octree_approx_fun_p. unfold octree_mtree.
    exact L4.
  }
  assert (L7: octree_approx_fun_p (Some T) (tx_statefun_trans (tx_of_Block (bh, bd)) f)).
  { unfold octree_approx_fun_p. rewrite <- HT2.
    exact L6.
  }
  assert (L8: octree_totalassets (tx_octree_trans (tx_of_Block (bh, bd)) (Some (ctree_of_Block (bh, bd)))) bl).
  { rewrite HT2.
    unfold octree_totalassets. unfold octree_mtree.
    apply (mtree_approx_fun_p_totalassets _ _ _ L7).
    revert H6.
    unfold octree_totalassets. unfold octree_mtree.
    apply mtree_approx_fun_p_totalassets.
    revert L7. unfold octree_approx_fun_p.
    apply mtree_hashroot_mtree_approx_fun_p.
    unfold octree_mtree.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite mtree_hashroot_ctree_hashroot.
    rewrite ctree_hashroot_ctree_H.
    rewrite HT1. reflexivity.
  }
  generalize (octree_tx_asset_value_sum (Some (ctree_of_Block (bh,bd))) (tx_of_Block (bh,bd)) 0 (rewfn (S n)) (totalassets_ f) bl L1 L2 L3 L5 L8).
  assert (L9: asset_value_sum bl + 0 = asset_value_sum bl).
  { clear. omega. }
  rewrite L9. exact (fun H => H).
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e450m2e225m1_18limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (add a b) = F.add (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


(*|
###########################################################
How to add variables introduced by set tactic to a Hint DB?
###########################################################

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

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

I want to use a Hint DB with variables introduced by ``set``. For
example,
|*)

Example foo : forall n : nat, n + n = n + n.
Proof.
  intro.
  set (m := n + n).
Abort. (* .none *)
Fail #[local] Hint Unfold m : core. (* .fails .unfold *)

(*| Is there any way to achieve this, or is it impossible? |*)

(*|
Answer
******

It's not possible to do this like you suggested because after you
finish ``foo`` with ``Qed`` the local variable ``m`` will be out of
scope, but hints go straight into some global database.

However, you can use the ``Section`` mechanism, as the hints declared
inside a section are *local* to that section:
|*)

Section LocalHints.
  Variable n : nat.
  Let m := n + n.
  Hint Unfold m.

  Example bar : m = m.
  Proof.
    autounfold with core.
    reflexivity.
  Qed.
End LocalHints.