(** Example from Ernst-Murray CAV 2019, done without locks, using
value-dependent classifications libary. *)
From iris.base_logic Require Import invariants.
From iris_ni.logrel Require Import types.
From iris_ni.program_logic Require Import dwp heap_lang_lifting.
From iris.proofmode Require Import proofmode.
From iris.heap_lang Require Import lang proofmode.
From iris_ni.proofmode Require Import dwp_tactics.
From iris_ni.logrel Require Import interp.
From iris_ni.examples Require Import value_dep par various.
(* examples.various is required for the oneshot algebra *)

Definition thread1 : val :=
  rec: "loop" "out" "rec" :=
    (if: ~ is_classified "rec"
     then "out" <- read_dep "rec"
     else #());;
    "loop" "out" "rec".

Definition thread2 : val :=
  λ: "rec", declassify "rec" #0.

Definition prog : val := λ: "data" "out",
  let: "rec" := (ref #true, ref "data") in
  thread1 "out" "rec" ||| thread2 "rec".

Section proof.
  Context `{!heapDG Σ, !valueDepG Σ, !spawnG Σ, !oneshotG Σ}.

  (* The invariant guarantees the monotonicity of the declassification. *)
  Definition glinv γ γs :=
    (∃ α, classification γ α (1/2) ∗
     ((pending γs ∗ ⌜α = High⌝) ∨ (shot γs ∗ ⌜α = Low⌝)))%I.

  Definition N := nroot.@"blabla".

  (* We verify that the thread that does the "dumping out" in a loop is secure,
    under the monotonicity assumption. *)
  Lemma thread1_spec γ γs out1 rec1 out2 rec2 ξ :
    ⟦ tref (tint Low) ⟧ ξ out1 out2 -∗
    value_dependent γ (tint Low) ξ rec1 rec2 -∗
    inv N (glinv γ γs) -∗
    DWP thread1 out1 rec1 & thread1 out2 rec2 : ⟦ tunit ⟧ ξ.
  Proof.
    iIntros "#Hout #Hvd #Hinv".
    iLöb as "IH". dwp_rec. dwp_pures.
    dwp_bind (is_classified _) (is_classified _).
    iApply (is_classified_spec with "Hvd").
    iIntros (α b) "Ha".
    iInv N as (β) "[>Hc Hi]" "Hcl".
    iDestruct (classification_auth_agree with "Ha Hc") as %<-.
    iFrame "Ha". iDestruct "Hi" as ">[[Htok %]|[#Htok %]]"; simplify_eq/=.
    - iMod ("Hcl" with "[Htok Hc]") as "_".
      { iNext. iExists _. iFrame. iLeft. eauto with iFrame. }
      iModIntro. iIntros (Hfoo). assert (b = true) as ->.
      { destruct b; naive_solver. }
      iSimpl. dwp_pures. iApply "IH".
    - iMod ("Hcl" with "[Htok Hc]") as "_".
      { iNext. iExists _. iFrame. iRight. eauto with iFrame. }
      iModIntro. iIntros (Hfoo). destruct b.
      { iSimpl. dwp_pures. iApply "IH". }
      dwp_pures. iApply (logrel_seq with "[-IH] IH").
      dwp_bind (read_dep _) (read_dep _).
      iApply (read_spec with "Hvd").
      iIntros (α v1 v2) "Ha #Hv".
      iInv N as (β) "[>Hc Hi]" "Hcl".
      iDestruct "Hi" as ">[[Htok2 %]|[_ %]]"; simplify_eq/=.
      { iExFalso. iApply (shot_not_pending with "Htok Htok2"). }
      iDestruct (classification_auth_agree with "Ha Hc") as %->.
      iFrame "Ha".
      iMod ("Hcl" with "[Htok Hc]") as "_".
      { iNext. iExists _. iFrame. iRight. eauto with iFrame. }
      iModIntro.
      iApply logrel_store; first (by solve_ndisj); iApply dwp_value; eauto with iFrame.
  Qed.

  Lemma thread2_spec γ γs rec1 rec2 ξ :
    value_dependent γ (tint Low) ξ rec1 rec2 -∗
    inv N (glinv γ γs) -∗
    classification γ High (1/2) -∗
    DWP thread2 rec1 & thread2 rec2 : ⟦ tunit ⟧ ξ.
  Proof.
    iIntros "#Hvd #Hinv Hc2".
    dwp_rec.
    iApply (declassify_spec with "Hvd [] Hc2").
    { rewrite !interp_eq. iExists 0,0. by eauto. }
    iSimpl. iIntros "Ha Hc2".
    iInv N as (α') "[>Hc1 >Hi]" "Hcl".
    iDestruct (classification_auth_agree with "Ha Hc1") as %<-.
    iCombine "Hc1 Hc2" as "Hc".
    iMod (classification_update Low with "Ha Hc") as "[$ [Hc1 Hc2]]".
    iDestruct "Hi" as "[[Htok %]|[Htok %]]"; simplify_eq/=.
    iMod (shoot with "Htok") as "Htok".
    iMod ("Hcl" with "[-Hc2]") as "_".
    { iNext. iExists _. iFrame. eauto with iFrame. }
    iModIntro. iFrame "Hc2". iIntros "Hc2". eauto.
  Qed.

  Lemma proof out1 out2 dat1 dat2 ξ :
    ⟦ tref (tint Low) ⟧ ξ out1 out2 -∗
    ⟦ tint High ⟧ ξ dat1 dat2 -∗
    DWP (prog dat1 out1) & (prog dat2 out2) : ⟦ tprod tunit tunit ⟧ ξ.
  Proof.
    iIntros "#Hout #Hdat".
    dwp_rec. dwp_pures.

    dwp_bind (ref _)%E (ref _)%E.
    iApply dwp_alloc. iIntros (rd1 rd2) "Hrd1 Hrd2". iNext.

    dwp_bind (ref _)%E (ref _)%E.
    iApply dwp_alloc. iIntros (is_classified1 is_classified2) "Hc1 Hc2". iNext.

    iMod (make_value_dependent (tint Low) with "Hrd1 Hrd2 Hc1 Hc2 []")
      as (γ) "[#Hvd Hc]".
    { simpl. rewrite left_id. iExact "Hdat". }
    iClear "Hdat". iDestruct "Hc" as "[Hc1 Hc2]".
    dwp_pures.
    iMod new_pending as (γs) "Hpend".

    iMod (inv_alloc N _ (glinv γ γs) with "[-Hc2]") as "#Hinv".
    { iNext. iExists _. iFrame. iLeft. eauto with iFrame. }

    iApply (dwp_par (⟦ tunit ⟧ ξ) (⟦ tunit ⟧ ξ) with "[] [Hc2]").
    - (* Thread 1 *) iApply (thread1_spec with "Hout Hvd Hinv").
    - (* Thread 2 *) iApply (thread2_spec with "Hvd Hinv Hc2").
    - (* Finally *)
      iIntros (???? [-> ->] [-> ->]).
      iNext. iExists _,_,_,_; eauto with iFrame.
  Qed.

End proof.


Require Import TestSuite.admit.
Require Coq.Vectors.Fin.
Require Coq.Vectors.Vector.

Local Generalizable All Variables.
Set Implicit Arguments.

Arguments Fin.F1 : clear implicits.

Lemma fin_0_absurd : notT (Fin.t 0).
Proof. hnf. apply Fin.case0. Qed.

Axiom admit : forall {A}, A.

Fixpoint lower {n:nat} (p:Fin.t (S n)) {struct p} :
  forall (i:Fin.t (S n)), option (Fin.t n)
  := match p in Fin.t (S n1)
           return Fin.t (S n1) -> option (Fin.t n1)
     with
       | @Fin.F1 n1 =>
         fun (i:Fin.t (S n1)) =>
           match i in Fin.t (S n2) return option (Fin.t n2) with
             | @Fin.F1 n2 => None
             | @Fin.FS n2 i2 => Some i2
           end
       | @Fin.FS n1 p1 =>
         fun (i:Fin.t (S n1)) =>
           match i in Fin.t (S n2) return Fin.t n2 -> option (Fin.t n2) with
             | @Fin.F1 n2 =>
               match n2 as n3 return Fin.t n3 -> option (Fin.t n3) with
                 | 0 => fun p2 => False_rect _ (fin_0_absurd p2)
                 | S n3 => fun p2 => Some (Fin.F1 n3)
               end
             | @Fin.FS n2 i2 =>
               match n2 as n3 return Fin.t n3 -> Fin.t n3 -> option (Fin.t n3) with
                 | 0 => fun i3 p3 => False_rect _ (fin_0_absurd p3)
                 | S n3 => fun (i3 p3:Fin.t (S n3)) =>
                             option_map (@Fin.FS _) admit
               end i2
           end p1
     end.

Lemma lower_ind (P: forall n (p i:Fin.t (S n)), option (Fin.t n) -> Prop)
      (c11 : forall n, P n (Fin.F1 n) (Fin.F1 n) None)
      (c1S : forall n (i:Fin.t n), P n (Fin.F1 n) (Fin.FS i) (Some i))
      (cS1 : forall n (p:Fin.t (S n)),
               P (S n) (Fin.FS p) (Fin.F1 (S n)) (Some (Fin.F1 n)))
      (cSSS : forall n (p i:Fin.t (S n)) (i':Fin.t n)
                     (Elow:lower p i = Some i'),
                P n p i (Some i') ->
                P (S n) (Fin.FS p) (Fin.FS i) (Some (Fin.FS i')))
      (cSSN : forall n (p i:Fin.t (S n))
                (Elow:lower p i = None),
                P n p i None ->
                P (S n) (Fin.FS p) (Fin.FS i) None) :
  forall n (p i:Fin.t (S n)), P n p i (lower p i).
Proof.
  fix lower_ind 2. intros n p.
  refine (match p as p1 in Fin.t (S n1)
                return forall (i1:Fin.t (S n1)), P n1 p1 i1 (lower p1 i1)
          with
            | @Fin.F1 n1 => _
            | @Fin.FS n1 p1 => _
          end); clear n p.
  { revert n1. refine (@Fin.caseS _ _ _); cbn; intros.
    apply c11. apply c1S. }
  { intros i1. revert p1.
    pattern n1, i1; refine (@Fin.caseS _ _ _ _ _);
    clear n1 i1;
    (intros [|n] i; [refine (False_rect _ (fin_0_absurd i)) | cbn ]).
    { apply cS1. }
    { intros p. pose proof (admit : P n p i (lower p i)) as H.
      destruct (lower p i) eqn:E.
      { admit; assumption. }
      { cbn. apply admit; assumption. } } }
Qed.

Section squeeze.
  Context {A:Type} (x:A).
  Notation vec := (Vector.t A).

  Fixpoint squeeze {n} (v:vec n) (i:Fin.t (S n)) {struct i} : vec (S n) :=
    match i in Fin.t (S _n) return vec _n -> vec (S _n)
    with
      | @Fin.F1 n' => fun v' => Vector.cons _ x _ v'
      | @Fin.FS n' i' =>
        fun v' =>
          match n' as _n return vec _n -> Fin.t _n -> vec (S _n)
          with
            | 0 => fun u i' => False_rect _ (fin_0_absurd i')
            | S m =>
              fun (u:vec (S m)) =>
                match u in Vector.t _ (S _m)
                      return Fin.t (S _m) -> vec (S (S _m))
                with
                  | Vector.nil _ => tt
                  | Vector.cons _ h _ u' =>
                    fun j' => Vector.cons _ h _ admit (* (squeeze u' j') *)
                end
          end v' i'
    end v.
End squeeze.

Require Import Program.
Lemma squeeze_nth (A:Type) (x:A) (n:nat) (v:Vector.t A n) p i :
  Vector.nth (squeeze x v p) i = match lower p i with
                                   | Some j => Vector.nth v j
                                   | None => x
                                 end.
Proof.
  (* alternatively: [functional induction (lower p i) using lower_ind] *)
  revert v. pattern n, p, i, (lower p i).
  refine (@lower_ind _ _ _ _ _ _ n p i);
    intros; cbn; auto.

  (*** Fails here with "Conversion test raised an anomaly" ***)
  revert v.
  admit.
  admit.
  admit.
Qed.


(*
  Author(s):
    Hizbullah Abdul Aziz Jabbar (1)
    Andrej Dudenhefner (2)
    Dominique Larchey-Wendling (3)
  Affiliation(s):
    (1) Saarland University, Saarbrücken, Germany
    (2) TU Dortmund University, Dortmund, Germany
    (3) LORIA -- CNRS
*)

(*
  Decidability Results(s):
    Decidability of Reversible FRACTRAN Halting (Halt_REV_FRACTRAN_dec)
*)

Require Import Undecidability.Synthetic.Definitions.

Require Import Undecidability.FRACTRAN.FRACTRAN.
From Undecidability.FRACTRAN.Deciders Require
  Halt_REV_FRACTRAN_dec.

(* Decidability of Reversible FRACTRAN Halting *)
Theorem Halt_REV_FRACTRAN_dec : decidable Halt_REV_FRACTRAN.
Proof.
  exists Halt_REV_FRACTRAN_dec.decide.
  exact Halt_REV_FRACTRAN_dec.decide_spec.
Qed.

Check Halt_REV_FRACTRAN_dec.


Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Tactics.Consider.
Require Import ExtLib.Tactics.

Require Import MirrorCore.TypesI.
Require Import MirrorCore.Lambda.Expr.
Require Import MirrorCore.Lambda.Ptrns.
Require Import MirrorCore.Views.Ptrns.
Require Import MirrorCore.Views.FuncView.
Require Import MirrorCore.Reify.ReifyClass.

Set Implicit Arguments.
Set Strict Implicit.
Set Maximal Implicit Insertion.
Set Universe Polymorphism.

Inductive list_func (typ : Set) : Set :=
| pNil : typ -> list_func typ
| pCons : typ -> list_func typ.

Section ListFuncInst.
  Context {typ : Set} {RType_typ : RType typ}.
  Context {func : Set}.
  Context {Heq : RelDec (@eq typ)} {HC : RelDec_Correct Heq}.

  Context {Typ2_tyArr : Typ2 _ RFun}.
  Context {Typ1_tyList : Typ1 _ list}.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ Typ2_tyArr.
  Let tyList : typ -> typ := @typ1 _ _ _ _.

  Definition typeof_list_func lf :=
    match lf with
    | pNil t => Some (tyList t)
    | pCons t => Some (tyArr t (tyArr (tyList t) (tyList t)))
    end.

  Definition list_func_eq (a b : list_func typ) : option bool :=
    match a , b with
    | pNil t1, pNil t2 => Some (t1 ?[ eq ] t2)
    | pCons t1, pCons t2 => Some (t1 ?[ eq ] t2)
    | _, _ => None
    end.

  Global Instance RelDec_list_func : RelDec (@eq (list_func typ)) :=
  { rel_dec a b := match list_func_eq a b with
    	  	   | Some b => b
    		   | None => false
    		   end }.

  Definition nilR t : typD (tyList t) := castR id (list (typD t)) nil.
  Definition consR t : typD (tyArr t (tyArr (tyList t) (tyList t))) :=
    castR id (RFun (typD t) (RFun (list (typD t)) (list (typD t)))) cons.

  Definition list_func_symD lf :=
    match lf as lf return match typeof_list_func lf return Type with
			  | Some t => typD t
			  | None => unit
			  end with
    | pNil t => nilR t
    | pCons t => consR t
    end.

  Global Instance RSym_ListFunc : SymI.RSym (list_func typ) :=
  { typeof_sym := typeof_list_func
  ; symD := list_func_symD
  ; sym_eqb := list_func_eq
  }.

  Global Instance RSymOk_ListFunc : SymI.RSymOk RSym_ListFunc.
  Proof.
    split; intros.
    destruct a, b; simpl; try apply I.
    + consider (t ?[ eq ] t0); intuition congruence.
    + consider (t ?[ eq ] t0); intuition congruence.
  Qed.

End ListFuncInst.

Section MakeList.
  Context {typ func : Set} {FV : PartialView func (list_func typ)}.

  Definition fNil t := f_insert (pNil t).
  Definition fCons t := f_insert (pCons t).

  Definition mkNil t : expr typ func := Inj (fNil t).
  Definition mkCons (t : typ) (x xs : expr typ func) :=
    App (App (Inj (fCons t)) x) xs.

  Definition fptrnNil {T : Type} (p : Ptrns.ptrn typ T)
  : ptrn (list_func typ) T :=
    fun f U good bad =>
      match f with
        | pNil t => p t U good (fun x => bad f)
        | _ => bad f
      end.

  Definition fptrnCons {T : Type} (p : Ptrns.ptrn typ T)
  : ptrn (list_func typ) T :=
    fun f U good bad =>
      match f with
        | pCons t => p t U good (fun x => bad f)
        | _ => bad f
      end.

  Global Instance fptrnNil_ok {T : Type} {p : ptrn typ T} {Hok : ptrn_ok p}
  : ptrn_ok (fptrnNil p).
  Proof.
    red; intros.
    destruct x; simpl; [destruct (Hok t) |].
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
    { right; unfold Fails; reflexivity. }
  Qed.

  Global Instance fptrnCons_ok {T : Type} {p : ptrn typ T} {Hok : ptrn_ok p}
  : ptrn_ok (fptrnCons p).
  Proof.
    red; intros.
    destruct x; simpl; [|destruct (Hok t)].
    { right; unfold Fails; reflexivity. }
    { left. destruct H; exists x. revert H. compute; intros.
      rewrite H. reflexivity. }
    { right; unfold Fails in *; intros; simpl; rewrite H; reflexivity. }
  Qed.

  Lemma Succeeds_fptrnNil {T : Type} (f : list_func typ)
        (p : ptrn typ T) (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnNil p) res)
  : exists t, Succeeds t p res /\ f = pNil t.
  Proof.
    unfold Succeeds, fptrnNil in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok t).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t; split; [assumption | reflexivity].
  Qed.

  Lemma Succeeds_fptrnCons {T : Type} (f : list_func typ) (p : ptrn typ T)
        (res : T)
        {pok : ptrn_ok p} (H : Succeeds f (fptrnCons p) res)
  : exists t, Succeeds t p res /\ f = pCons t.
  Proof.
    unfold Succeeds, fptrnCons in H.
    unfold ptrn_ok in pok.
    specialize (H (option T) Some (fun _ => None)).
    destruct f; try congruence.
    specialize (pok t).
    destruct pok; [|rewrite H0 in H; congruence].
    destruct H0.
    rewrite H0 in H; inv_all; subst.
    exists t; split; [assumption | reflexivity].
  Qed.

(*
  Global Instance fptrnNil_SucceedsE {T : Type} {f : list_func typ}
         {p : ptrn typ T} {res : T} {pok : ptrn_ok p}
  : SucceedsE f (fptrnNil p) res :=
  { s_result := exists t, Succeeds t p res /\ f = pNil t
  ; s_elim := @Succeeds_fptrnNil T f p res pok
  }.

  Global Instance fptrnCons_SucceedsE {T : Type} {f : list_func typ}
         {p : ptrn typ T} {res : T} {pok : ptrn_ok p}
  : SucceedsE f (fptrnCons p) res :=
  { s_result := exists t, Succeeds t p res /\ f = pCons t
  ; s_elim := @Succeeds_fptrnCons T f p res pok
  }.
*)

End MakeList.

Section PtrnList.
  Context {typ func : Set} {RType_typ : RType typ}.
  Context {FV : PartialView func (list_func typ)}.

(* Putting this in the previous sectioun caused universe inconsistencies
  when calling '@mkNil typ func' in JavaFunc (with typ and func instantiated) *)

  Definition ptrnNil@{V R L} {T : Type@{V}}
             (p : ptrn@{Set V R L} typ T) : ptrn@{Set V R L} (expr typ func) T :=
    inj@{V R L} (ptrn_view _ (fptrnNil p)).

  Definition ptrnCons@{V R L} {A : Type@{V}} {B : Type@{V}} {T : Type@{V}}
             (p : ptrn@{Set V R L} typ T)
             (a : ptrn@{Set V R L} (expr typ func) A)
             (b : ptrn@{Set V R L} (expr typ func) B)
  : ptrn@{Set V R L} (expr typ func) (T * A * B) :=
    app (app (inj (ptrn_view _ (fptrnCons p))) a) b.

  Definition list_cases@{T Z} {T : Type@{T}}
             (do_nil : typ -> T)
             (do_cons : typ -> expr typ func -> expr typ func -> T)
             (do_default : T)
  : expr typ func -> T :=
    run_ptrn@{Set T T Z}
        (Ptrns.por
           (Ptrns.pmap@{Set Set T T Z} do_nil (ptrnNil Ptrns.get))
           (Ptrns.pmap (fun t_x_xs =>
                        let '(t,x,xs) := t_x_xs in
                        do_cons t x xs) (ptrnCons Ptrns.get Ptrns.get Ptrns.get)))
      do_default.

End PtrnList.

Section ReifyList.

  Polymorphic Context {typ func : Set} {FV : PartialView func (list_func typ)}.
  Polymorphic Context {t : Reify typ}.

  Polymorphic Definition reify_nil : Command (expr typ func) :=
    CPattern (ls := (typ : Type)::nil)
             (RApp (RExact (@nil)) (RGet 0 RIgnore))
             (fun (x : function (CCall (reify_scheme typ))) => mkNil x).

  Polymorphic Definition reify_cons : Command (expr typ func) :=
    CPattern (ls := (typ:Type)::nil)
             (RApp (RExact (@cons)) (RGet 0 RIgnore))
             (fun (x : function (CCall (reify_scheme typ))) => Inj (fCons x)).

  Polymorphic Definition reify_list : Command (expr typ func) :=
    CFirst (reify_nil :: reify_cons :: nil).

End ReifyList.

Arguments reify_list _ _ {_ _}.


(* NIZK Proof System - Type 3 pairings defintions and properties by Rémi Bazin *)

Load Fp.

(* Bilinear groups and a few constants *)
Inductive G1 : Set :=
  | ConstrG1 : Fp -> G1.
Inductive G2 : Set :=
  | ConstrG2 : Fp -> G2.
Inductive GT : Set :=
  | ConstrGT : Fp -> GT.

Delimit Scope G1_scope with G1.
Delimit Scope G2_scope with G2.
Delimit Scope GT_scope with GT.

Definition G1_O : G1 := ConstrG1 Fp_0.
Definition G2_O : G2 := ConstrG2 Fp_0.
Definition GT_1 : GT := ConstrGT Fp_0.

(* Group operations *)

Definition addG1 (a b:G1) : G1 :=
  match a with | ConstrG1 va =>
    match b with | ConstrG1 vb =>
      ConstrG1 (addFp va vb)
    end
  end
.
Infix "+" := addG1 : G1_scope.

Definition multG1 (a:Fp) (b:G1) : G1 :=
  match b with | ConstrG1 vb =>
    ConstrG1 (multFp a vb)
  end
.
Infix "*" := multG1 : G1_scope.

Definition addG2 (a b:G2) : G2 :=
  match a with | ConstrG2 va =>
    match b with | ConstrG2 vb =>
      ConstrG2 (addFp va vb)
    end
  end
.
Infix "+" := addG2 : G2_scope.

Definition multG2 (a:Fp) (b:G2) : G2 :=
  match b with | ConstrG2 vb =>
    ConstrG2 (multFp a vb)
  end
.
Infix "*" := multG2 : G2_scope.

Definition multGT (a b:GT) : GT :=
  match a with | ConstrGT va =>
    match b with | ConstrGT vb =>
      ConstrGT (addFp va vb)
    end
  end
.
Infix "*" := multGT : GT_scope.

Definition powGT (a:GT) (b:Fp) : GT :=
  match a with | ConstrGT va =>
    ConstrGT (multFp va b)
  end
.
Infix "^" := powGT : GT_scope.

Definition pairing (a:G1) (b:G2) : GT :=
  match a with | ConstrG1 va =>
    match b with | ConstrG2 vb =>
      ConstrGT (multFp va vb)
    end
  end
.

(* Mathematical structure properties *)

Theorem G1_O_well_formed : Is_zero G1 addG1 G1_O.
Proof.
  unfold Is_zero.
  intro.
  admit. (* TODO *)
Qed.

Theorem G1_well_formed : (Is_Fp_isomorphic G1 addG1 p).
Proof.
  admit. (* TODO *)
Qed.

Theorem G2_well_formed : (Is_Fp_isomorphic G2 addG2 p).
Proof.
  admit. (* TODO *)
Qed.

Theorem GT_well_formed : (Is_Fp_isomorphic GT multGT p).
Proof.
  admit. (* TODO *)
Qed.

Theorem pairing_bilinear_l : forall (a:G1) (b:G2) (i:Fp),
  pairing (i * a)%G1 b = ((pairing a b) ^ i)%GT.
Proof.
  intros.
  case a, b.
  unfold pairing, multG1, powGT.
  admit. (* TODO *)
Qed.

Theorem pairing_bilinear_r : forall (a:G1) (b:G2) (j:Fp),
  pairing a (j * b)%G2 = ((pairing a b) ^ j)%GT.
Proof.
  admit. (* TODO *)
Qed.

Theorem pairing_bilinear : forall (a:G1) (b:G2) (i j:Fp),
  pairing (i * a)%G1 (j * b)%G2 = ((pairing a b) ^ (i * j)%Fp)%GT.
Proof.
  admit. (* TODO *)
Qed.


(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(** * Notations for [Coq.Lists.ListSet] using the [EqDec] class.

TODO: switch to using MSets in lieu of ListSet.
*)
(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(* [Coq.Classes.EquivDec] is Coq 8.3 only *)
Require Import Coq.Lists.ListSet.
Require Import Coq.Classes.EquivDec.

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
Notation "\{}"          := (empty_set _)
    : listset_scope.

Notation "\{ x }"       := (set_add equiv_dec x (empty_set _))
    : listset_scope.

Notation "x \a ys"      := (set_add equiv_dec x ys)
    (at level 37, right associativity) : listset_scope.

Notation "xs \u ys"     := (set_union equiv_dec xs ys)
    (at level 37, right associativity) : listset_scope.

Notation "xs \n ys"     := (set_inter equiv_dec xs ys)
    (at level 36, right associativity) : listset_scope.

Notation "xs \\ ys"     := (set_diff equiv_dec xs ys)
    (at level 34, left associativity) : listset_scope.

Notation "xs \- y"      := (set_remove equiv_dec y xs)
    (at level 34, left associativity) : listset_scope.

Notation "x \in xs"     := (set_In x xs)
    (at level 39) : listset_scope.

Notation "x \notin xs"  := (~ set_In x xs)
    (at level 39) : listset_scope.
    (* Beware of unfolding issues with [not]. *)

Delimit Scope listset_scope with set.
Bind Scope listset_scope with set.
Open Scope listset_scope.

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(*
Definition Equal xs ys           := forall x:A, set_In x xs <-> set_In x ys.
Definition Subset xs ys          := forall x:A, set_In x xs -> set_In x ys.
Definition Inhab xs              := exists x:A, set_In x xs.
Definition Empty xs              := forall x:A, ~ set_In x xs.
Definition Disjoint xs ys        := forall x:A, ~ set_In x (xs \n ys).
Definition Forall (P:A->Prop) xs := forall x:A, set_In x xs -> P x.
Definition Exists (P:A->Prop) xs := exists x:A, set_In x xs /\ P x.

Notation "xs [=] ys" := (Equal xs ys)
    (at level 70, no associativity) : listset_scope.
Notation "xs [<=] ys" := (Subset xs ys)
    (at level 70, no associativity) : listset_scope.
Notation "xs \c ys" := (Subset xs ys)
    (at level 38) : listset_scope.

Theorem set_In_classical
    : forall {A : Type} (eq_dec : forall x y : A, {x = y} + {x <> y})
    (x : A) (xs : set A), ~~set_In x xs -> set_In x xs.
Proof.
  intros A eq_dec x xs; induction xs as [|x0 xs0 IHxs0]; intro H;
    [ apply H; intro H0; apply H0
    | destruct (eq_dec x x0) as [L|R];
      [ left; congruence
      | right; apply IHxs0; intro H0; apply H; intro H1; destruct H1;
        [ apply R; congruence
        | apply H0; assumption ] ] ].
Qed.
Hint Resolve set_In_classical :sets.
*)

(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *)
(* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ fin. *)


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal2.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_2  := ( Cons (Succ Zero)         (Cons (Succ (Succ Zero)) (Cons (Succ (Succ Zero)) Nil))).
Definition lfind_example_3  := ( Cons (Succ Zero)         (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil))).
Definition lfind_example_4  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_5  := ( Cons (Succ Zero)         (Cons (Succ (Succ (Succ (Succ Zero))))            (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_6  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_7  := ( Cons Zero Nil).
Definition lfind_example_8  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_9  := ( Cons (Succ Zero) Nil).
Definition lfind_example_10  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal2_theorem0_41_lem2/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 .


Require Import VST.floyd.proofauto.

Section IsEmptyLemmas.

  Context {inf: Z}.

  (* isEmpty and lemmas about it *)

  Definition isEmpty (priq : list Z) : val :=
    fold_right
      (fun h acc =>
         if (Z_lt_dec h (inf + 1)) then Vzero else acc)
      Vone priq.

  Lemma isEmpty_in: forall l target,
      In target l ->
      target < inf + 1 ->
      isEmpty l = Vzero.
  Proof.
    intros. induction l.
    1: exfalso; apply (in_nil H).
    unfold isEmpty. rewrite fold_right_cons.
    destruct (Z_lt_dec a (inf+1)); trivial.
    simpl in H; simpl; destruct H.
    1: rewrite H in n; exfalso; lia.
    clear n a. specialize (IHl H).
    unfold isEmpty in IHl. trivial.
  Qed.

  Lemma isEmpty_in': forall l,
      (exists i, In i l /\ i < (inf + 1)) <->
      isEmpty l = Vzero.
  Proof.
    split; intros.
    - destruct H as [? [? ?]]. induction l.
      1: exfalso; apply (in_nil H).
      unfold isEmpty. rewrite fold_right_cons.
      destruct (Z_lt_dec a (inf+1)); trivial.
      simpl in H; simpl; destruct H.
      1: rewrite H in n; exfalso; lia.
      clear n a. specialize (IHl H).
      unfold isEmpty in IHl. trivial.
    - induction l.
      1: inversion H.
      simpl in H. destruct (Z_lt_dec a (inf+1)).
      + exists a. split; simpl; [left|]; trivial.
      + destruct (IHl H) as [? [? ?]].
        exists x. split; [apply in_cons|]; assumption.
  Qed.

  Lemma isEmptyTwoCases: forall l,
      isEmpty l = Vone \/ isEmpty l = Vzero.
  Proof.
    intros. induction l. 1: simpl; left; trivial.
    destruct IHl; simpl; destruct (Z_lt_dec a (inf+1));
      (try now left); now right.
  Qed.

  Lemma isEmptyMeansInf: forall l,
      isEmpty l = Vone <->
      Forall (fun x => x > inf) l.
  Proof.
    intros.
    split; intros.
    - induction l; trivial. simpl in H.
      destruct (Z_lt_dec a (inf+1)); [inversion H|].
      specialize (IHl H). apply Forall_cons; trivial. lia.
    - induction l; trivial. simpl.
      destruct (Z_lt_dec a (inf+1)).
      2: { apply IHl.
           rewrite Forall_forall; intros.
           rewrite Forall_forall in H. simpl in H.
           apply H. right; trivial.
      }
      exfalso.
      rewrite Forall_forall in H.
      assert (In a (a :: l)) by (apply in_eq).
      specialize (H _ H0). lia.
  Qed.

  Lemma isEmpty_Vone_app: forall l1 l2,
      isEmpty (l1 ++ l2) = Vone <->
      isEmpty l1 = Vone /\ isEmpty l2 = Vone.
  Proof.
    intros. split; intros.
    - repeat rewrite isEmptyMeansInf, Forall_forall in *;
        split; intros; apply H, in_or_app;
          [left | right]; trivial.
    - repeat rewrite isEmptyMeansInf, Forall_forall in *.
      destruct H. intros.
      apply in_app_or in H1; destruct H1;
        [apply H | apply H0]; trivial.
  Qed.

End IsEmptyLemmas.


Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Strings.String.
Require Import maps.
Require Import imp.
Require Import smallstep.
Require Import stlc.

(*レコードの形式化*)
(*
前の非形式的定義

構文:
       t ::=                          項:
           | {i1=t1, ..., in=tn}         レコード
           | t.i                         射影
           | ...

       v ::=                          値:
           | ...
           | {i1=v1, ..., in=vn}         レコード値

       T ::=                          型:
           | ...
           | {i1:T1, ..., in:Tn}         レコード型
簡約:
                               ti ==> ti'
  -------------------------------------------------------------------- (ST_Rcd)
  {i1=v1, ..., im=vm, in=tn, ...} ==> {i1=v1, ..., im=vm, in=tn', ...}

                                 t1 ==> t1'
                               --------------                        (ST_Proj1)
                               t1.i ==> t1'.i

                          -------------------------                (ST_ProjRcd)
                          {..., i=vi, ...}.i ==> vi
型付け:
               Gamma |- t1 : T1     ...     Gamma |- tn : Tn
             --------------------------------------------------         (T_Rcd)
             Gamma |- {i1=t1, ..., in=tn} : {i1:T1, ..., in:Tn}

                       Gamma |- t : {..., i:Ti, ...}
                       -----------------------------                   (T_Proj)
                             Gamma |- t.i : Ti
*)

Module STLCExtendedRecords.

Module FirstTry.
Definition alist (X : Type) := list (string * X).

Inductive ty : Type :=
  | Base : string -> ty
  | Arrow : ty -> ty -> ty
  | TRcd : (alist ty) -> ty.
(*tyの情報がないので失敗する*)

(* Check ty_ind.
   ====>
    ty_ind :
      forall P : ty -> Prop,
        (forall i : id, P (Base i)) ->
        (forall t : ty, P t -> forall t0 : ty, P t0
                            -> P (Arrow t t0)) ->
        (forall a : alist ty, P (TRcd a)) ->    (* ??? *)
        forall t : ty, P t
*)

End FirstTry.

(*
 Coq 標準のlist型の代わりに、型の構文にリストのコンストラクタ（"nil"と"cons"）を本質的に含めてしまうという方法
 *)
Inductive ty : Type :=
  | Base : string -> ty
  | Arrow : ty -> ty -> ty
  | RNil : ty
  | RCons : string -> ty -> ty -> ty.

Inductive tm : Type :=
  | var : string -> tm
  | app : tm -> tm -> tm
  | abs : string -> ty -> tm -> tm

  | rproj : tm -> string -> tm
  | trnil : tm
  | rcons : string -> tm -> tm -> tm.

Open Scope string_scope.

Notation a := "a".
Notation f := "f".
Notation g := "g".
Notation l := "l".
Notation A := (Base "A").
Notation B := (Base "B").
Notation k := "k".
Notation i1 := "i1".
Notation i2 := "i2".

(*以下の型を可能にしてしまう*)
Definition weird_type := RCons X A B.
(*「後部」は実際にはレコード型ではない*)

(*型チェックを入れる*)
(*record_tyが再帰になってない＝一番外側のものだけを判定する*)
Inductive record_ty : ty -> Prop :=
  | RTnil :
        record_ty RNil
  | RTcons : forall i T1 T2,
        record_ty (RCons i T1 T2).

Inductive well_formed_ty : ty -> Prop :=
  | wfBase : forall i,
        well_formed_ty (Base i)
  | wfArrow : forall T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        well_formed_ty (Arrow T1 T2)
  | wfRNil :
        well_formed_ty RNil
  | wfRCons : forall i T1 T2,
        well_formed_ty T1 ->
        well_formed_ty T2 ->
        record_ty T2 ->
        well_formed_ty (RCons i T1 T2).

Hint Constructors record_ty well_formed_ty.

Inductive record_tm : tm -> Prop :=
  | rtnil :
        record_tm trnil
  | rtcons : forall i t1 t2,
        record_tm (rcons i t1 t2).

Hint Constructors record_tm.

(*置換*)
Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | var y => if eqb_string x y then s else t
  | abs y T t1 => abs y T
                     (if eqb_string x y then t1 else (subst x s t1))
  | app t1 t2 => app (subst x s t1) (subst x s t2)
  | rproj t1 i => rproj (subst x s t1) i
  | trnil => trnil
  | rcons i t1 tr1 => rcons i (subst x s t1) (subst x s tr1)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(*簡約*)
(*レコードがvalueになるのはフィールドがすべてvalueの時*)
Inductive value : tm -> Prop :=
  | v_abs : forall x T11 t12,
      value (abs x T11 t12)
  | v_rnil : value trnil
  | v_rcons : forall i v1 vr,
      value v1 ->
      value vr ->
      value (rcons i v1 vr).

(*レコードから取り出す関数*)
Fixpoint tlookup (i:string) (tr:tm) : option tm :=
  match tr with
  | rcons i' t tr' => if eqb_string i i' then Some t else tlookup i tr'
  | _ => None
  end.

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T11 t12 v2,
         value v2 ->
         (app (abs x T11 t12) v2) --> ([x:=v2]t12)
  | ST_App1 : forall t1 t1' t2,
         t1 --> t1' ->
         (app t1 t2) --> (app t1' t2)
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 --> t2' ->
         (app v1 t2) --> (app v1 t2')
  | ST_Proj1 : forall t1 t1' i,
        t1 --> t1' ->
        (rproj t1 i) --> (rproj t1' i)
  | ST_ProjRcd : forall tr i vi,
        value tr ->
        tlookup i tr = Some vi ->
        (rproj tr i) --> vi
  | ST_Rcd_Head : forall i t1 t1' tr2,
        t1 --> t1' ->
        (rcons i t1 tr2) --> (rcons i t1' tr2)
  | ST_Rcd_Tail : forall i v1 tr2 tr2',
        value v1 ->
        tr2 --> tr2' ->
        (rcons i v1 tr2) --> (rcons i v1 tr2')

where "t1 '-->' t2" := (step t1 t2).

Notation multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Hint Constructors step.

(*型付け*)
Fixpoint Tlookup (i:string) (Tr:ty) : option ty :=
  match Tr with
  | RCons i' T Tr' =>
      if eqb_string i i' then Some T else Tlookup i Tr'
  | _ => None
  end.

Definition context := partial_map ty.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      well_formed_ty T ->
      Gamma |- (var x) \in T
  | T_Abs : forall Gamma x T11 T12 t12,
      well_formed_ty T11 ->
      (update Gamma x T11) |- t12 \in T12 ->
      Gamma |- (abs x T11 t12) \in (Arrow T11 T12)
  | T_App : forall T1 T2 Gamma t1 t2,
      Gamma |- t1 \in (Arrow T1 T2) ->
      Gamma |- t2 \in T1 ->
      Gamma |- (app t1 t2) \in T2

  | T_Proj : forall Gamma i t Ti Tr,
      Gamma |- t \in Tr ->
      Tlookup i Tr = Some Ti ->
      Gamma |- (rproj t i) \in Ti
  | T_RNil : forall Gamma,
      Gamma |- trnil \in RNil
  | T_RCons : forall Gamma i t T tr Tr,
      Gamma |- t \in T ->
      Gamma |- tr \in Tr ->
      record_ty Tr ->
      record_tm tr ->
      Gamma |- (rcons i t tr) \in (RCons i T Tr)

where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(*練習問題*)
Lemma typing_example_2 :
  empty |-
    (app (abs a (RCons i1 (Arrow A A)
                      (RCons i2 (Arrow B B)
                       RNil))
              (rproj (var a) i2))
            (rcons i1 (abs a A (var a))
            (rcons i2 (abs a B (var a))
             trnil))) \in
    (Arrow B B).
Proof.
  eapply T_App. eapply T_Abs. apply wfRCons. apply wfArrow; apply wfBase.
  apply wfRCons. apply wfArrow; apply wfBase. apply wfRNil. apply RTnil.
  apply RTcons.

  eapply T_Proj. apply T_Var. constructor.
  apply wfRCons. apply wfArrow; apply wfBase.
  apply wfRCons. apply wfArrow; apply wfBase.
  apply wfRNil. apply RTnil.
  apply RTcons.
  reflexivity.

  eapply T_RCons.
  apply T_Abs. apply wfBase.
  apply T_Var. reflexivity. apply wfBase.
  apply T_RCons. apply T_Abs. apply wfBase. apply T_Var. reflexivity. apply wfBase.
  apply T_RNil. apply RTnil. constructor.
  apply RTcons. constructor.
Qed.

Example typing_nonexample :
  ~ exists T,
      (update empty a (RCons i2 (Arrow A A)
                                RNil)) |-
               (rcons i1 (abs a B (var a)) (var a)) \in
               T.
Proof.
  intro H. inversion H. inversion H0; subst. inversion H9.
Qed.

(*型付けの性質*)
(*進行と保存の証明は本質的に同じ、補題が必要になる*)

Lemma wf_rcd_lookup : forall i T Ti,
  well_formed_ty T ->
  Tlookup i T = Some Ti ->
  well_formed_ty Ti.
Proof with eauto.
  intros i T.
  induction T; intros; try solve_by_invert.
  -
    inversion H. subst. unfold Tlookup in H0.
    destruct (eqb_string i s)...
    inversion H0. subst... Qed.

Lemma step_preserves_record_tm : forall tr tr',
  record_tm tr ->
  tr --> tr' ->
  record_tm tr'.
Proof.
  intros tr tr' Hrt Hstp.
  inversion Hrt; subst; inversion Hstp; subst; auto.
Qed.

Lemma has_type__wf : forall Gamma t T,
  Gamma |- t \in T -> well_formed_ty T.
Proof with eauto.
  intros Gamma t T Htyp.
  induction Htyp...
  -
    inversion IHHtyp1...
  -
    eapply wf_rcd_lookup...
Qed.

Lemma lookup_field_in_value : forall v T i Ti,
  value v ->
  empty |- v \in T ->
  Tlookup i T = Some Ti ->
  exists ti, tlookup i v = Some ti /\ empty |- ti \in Ti.
Proof with eauto.
  intros v T i Ti Hval Htyp Hget.
  remember (@empty ty) as Gamma.
  induction Htyp; subst; try solve_by_invert...
  -
    simpl in Hget. simpl. destruct (eqb_string i i0).
    +
      simpl. inversion Hget. subst.
      exists t...
    +
      destruct IHHtyp2 as [vi [Hgeti Htypi]]...
      inversion Hval... Qed.

Theorem progress : forall t T,
     empty |- t \in T ->
     value t \/ exists t', t --> t'.
Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  generalize dependent HeqGamma.
  induction Ht; intros HeqGamma; subst.
  -

    inversion H.
  -

    left... constructor.
  -

    right.
    destruct IHHt1; subst...
    +
      destruct IHHt2; subst...
      *

        inversion H; subst; try solve_by_invert.
        exists ([x:=t2]t12)...
      *

        destruct H0 as [t2' Hstp]. exists (app t1 t2')...
    +

      destruct H as [t1' Hstp]. exists (app t1' t2)...
  -

    right. destruct IHHt...
    +

      destruct (lookup_field_in_value _ _ _ _ H0 Ht H)
        as [ti [Hlkup _]].
      exists ti...
    +

      destruct H0 as [t' Hstp]. exists (rproj t' i)...
  -

    left... constructor.
  -

    destruct IHHt1...
    +
      destruct IHHt2; try reflexivity.
      *

        left... constructor...
      *

        right. destruct H2 as [tr' Hstp].
        exists (rcons i t tr')...
    +

      right. destruct H1 as [t' Hstp].
      exists (rcons i t' tr)... Qed.

(*コンテキスト不変性*)
Inductive appears_free_in : string -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (var x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (app t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (app t1 t2)
  | afi_abs : forall x y T11 t12,
        y <> x ->
        appears_free_in x t12 ->
        appears_free_in x (abs y T11 t12)
  | afi_proj : forall x t i,
     appears_free_in x t ->
     appears_free_in x (rproj t i)
  | afi_rhead : forall x i ti tr,
      appears_free_in x ti ->
      appears_free_in x (rcons i ti tr)
  | afi_rtail : forall x i ti tr,
      appears_free_in x tr ->
      appears_free_in x (rcons i ti tr).

Hint Constructors appears_free_in.

Lemma context_invariance : forall Gamma Gamma' t S,
     Gamma |- t \in S ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     Gamma' |- t \in S.
Proof with eauto.
  intros. generalize dependent Gamma'.
  induction H;
    intros Gamma' Heqv...
  -
    apply T_Var... rewrite <- Heqv...
  -
    apply T_Abs... apply IHhas_type. intros y Hafi.
    unfold update, t_update. destruct (eqb_stringP x y)...
  -
    apply T_App with T1...
  -
    apply T_RCons... Qed.

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   Gamma |- t \in T ->
   exists T', Gamma x = Some T'.
Proof with eauto.
  intros x t T Gamma Hafi Htyp.
  induction Htyp; inversion Hafi; subst...
  -
    destruct IHHtyp as [T' Hctx]... exists T'.
    unfold update, t_update in Hctx.
    rewrite false_eqb_string in Hctx...
Qed.

(*保存*)

Lemma substitution_preserves_typing : forall Gamma x U v t S,
     (update Gamma x U) |- t \in S ->
     empty |- v \in U ->
     Gamma |- ([x:=v]t) \in S.
Proof with eauto.
  intros Gamma x U v t S Htypt Htypv.
  generalize dependent Gamma. generalize dependent S.
  induction t;
    intros S Gamma Htypt; simpl; inversion Htypt; subst...
  -
    simpl. rename s into y.
    unfold update, t_update in H0.
    destruct (eqb_stringP x y) as [Hxy|Hxy].
    +

      subst.
      inversion H0; subst. clear H0.
      eapply context_invariance...
      intros x Hcontra.
      destruct (free_in_context _ _ S empty Hcontra)
        as [T' HT']...
      inversion HT'.
    +

      apply T_Var...
  -
    rename s into y. rename t into T11.
    apply T_Abs...
    destruct (eqb_stringP x y) as [Hxy|Hxy].
    +

      eapply context_invariance...
      subst.
      intros x Hafi. unfold update, t_update.
      destruct (eqb_string y x)...
    +

      apply IHt. eapply context_invariance...
      intros z Hafi. unfold update, t_update.
      destruct (eqb_stringP y z)...
      subst. rewrite false_eqb_string...
  -
    apply T_RCons... inversion H7; subst; simpl...
Qed.

Theorem preservation : forall t t' T,
     empty |- t \in T ->
     t --> t' ->
     empty |- t' \in T.
Proof with eauto.
  intros t t' T HT.
  remember (@empty ty) as Gamma. generalize dependent HeqGamma.
  generalize dependent t'.
  induction HT;
    intros t' HeqGamma HE; subst; inversion HE; subst...
  -

    inversion HE; subst...
    +

      apply substitution_preserves_typing with T1...
      inversion HT1...
  -

    destruct (lookup_field_in_value _ _ _ _ H2 HT H)
      as [vi [Hget Htyp]].
    rewrite H4 in Hget. inversion Hget. subst...
  -

    apply T_RCons... eapply step_preserves_record_tm...
Qed.

End STLCExtendedRecords.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* In a connected graph, each vertex is bound by a path to each other.  *)
(* We define first a connected, then prove this property.               *)

(* The following notion is defined :                                    *)
(*      - Connected : defined upon a set of vertices and a set of arcs, *)
(*              constructors : C_isolated, C_leaf, C_edge, C_eq.        *)

Require Export Graphs.

Section CONNECTED.

Variable A:Type.
Variable eq_a_dec: forall x y : A, {x = y} + {x <> y}.

Inductive Connected : (@V_set A) -> (@A_set A) -> Type :=
  | C_isolated : forall x : Vertex, Connected (V_single x) (@A_empty A)
  | C_leaf :
      forall (v : V_set) (a : A_set) (co : Connected v a) (x y : Vertex),
      v x ->
      ~ v y -> Connected (V_union (V_single y) v) (A_union (E_set x y) a)
  | C_edge :
      forall (v : V_set) (a : A_set) (co : Connected v a) (x y : Vertex),
      v x ->
      v y ->
      x <> y ->
      ~ a (A_ends x y) ->
      ~ a (A_ends y x) -> Connected v (A_union (E_set x y) a)
  | C_eq :
      forall (v v' : V_set) (a a' : A_set),
      v = v' -> a = a' -> Connected v a -> Connected v' a'.

Lemma Connected_not_empty :
 forall (v : V_set) (a : A_set), Connected v a -> v <> (@V_empty A).
Proof.
        intros v a c; elim c; red in |- *; intros.
        elim (V_empty_nothing x); fold (@V_empty A) in |- *; rewrite <- H;
         apply V_in_single.
        elim (V_empty_nothing y); fold (@V_empty A) in |- *; rewrite <- H0;
         apply V_in_left; apply V_in_single.

        elim H; trivial.

        elim H; rewrite e; trivial.
Qed.

Lemma Connected_Isa_Graph :
 forall (v : V_set) (a : A_set), Connected v a -> Graph v a.
Proof.
        intros v a c; elim c; intros.
        apply G_eq with (v := V_union (V_single x) (@V_empty A)) (a := (@A_empty A)).
        autounfold.
        rewrite V_union_commut; apply V_union_neutral.

        trivial.

        apply G_vertex.
        exact (@G_empty A).

        compute in |- *. tauto.

        apply G_edge; intros.
        apply G_vertex; trivial.

        apply V_in_right; trivial.

        apply V_in_left; apply V_in_single.

        red in |- *; intros; elim n; rewrite <- H; trivial.

        red in |- *; intros; elim n; apply (G_ina_inv2 _ _ X _ _ H).

        red in |- *; intros; elim n; apply (G_ina_inv1 _ _ X _ _ H).

        apply G_edge; trivial.

        apply G_eq with (v := v0) (a := a0); auto.
Qed.

Lemma C_v_dec :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Vertex),
 {v x} + {~ v x}.
Proof.
        intros; generalize (Connected_Isa_Graph v a c); intros g.
        apply (G_v_dec eq_a_dec v a g x).
Qed.

Lemma C_a_dec :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Arc),
 {a x} + {~ a x}.
Proof.
        intros; generalize (Connected_Isa_Graph v a c); intros g.
        apply (G_a_dec eq_a_dec v a g x).
Qed.

Lemma C_ina_inv1 :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 a (A_ends x y) -> v x.
Proof.
        intros; apply (G_ina_inv1 v a (Connected_Isa_Graph v a c) x y H).
Qed.

Lemma C_ina_inv2 :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 a (A_ends x y) -> v y.
Proof.
        intros; apply (G_ina_inv2 v a (Connected_Isa_Graph v a c) x y H).
Qed.

End CONNECTED.

Implicit Arguments Connected [A].

Require Export Paths.

Section CONNECTED_BY_EDGES.

Variable A:Type.
Variable eq_a_dec: forall x y : A, {x = y} + {x <> y}.

Remark V_included_union' : forall E F : @V_set A, V_included F (V_union E F).
Proof.
        intros; autounfold; rewrite V_union_commut; apply V_included_union.
Qed.

Remark A_included_union' : forall E F : @A_set A, A_included F (A_union E F).
Proof.
        intros; repeat autounfold; rewrite A_union_commut; apply A_included_union.
Qed.

Lemma Connected_walk :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 v x -> v y -> {vl : V_list &  {el : @E_list A &  Walk v a x y vl el}}.
Proof.
        intros v a c; elim c; intros.
        split with V_nil; split with E_nil.
        inversion H.
        rewrite H1 in H0; inversion H0.
        apply W_null.
        apply V_in_single.

        case (V_union_single_dec eq_a_dec _ _ _ n H);
         case (V_union_single_dec eq_a_dec _ _ _ n H0); intros.
        split with V_nil; split with E_nil.
        rewrite <- e; rewrite <- e0; apply W_null.
        apply V_in_left; apply V_in_single.

        elim (X x y0 v1 v2); intros.
        split with (x :: x1); elim p; intros.
        split with (E_ends y x :: x2); rewrite <- e; apply W_step.
        apply
         (Walk_subgraph v0 (V_union (V_single y) v0) a0
            (A_union (E_set x y) a0) x y0 x1 x2 p0).
        apply V_included_union'.

        apply A_included_union'.

        apply V_in_left; apply V_in_single.

        apply A_in_left; apply E_left.

        elim (X x0 x v2 v1); intros.
        split with (x1 ++ y0 :: V_nil); elim p; intros.
        split with (x2 ++ E_ends x y0 :: E_nil);
         apply Walk_append with (y := x).
        apply
         (Walk_subgraph _ (V_union (V_single y) v0) _
            (A_union (E_set x y) a0) _ _ _ _ p0).
        apply V_included_union'.

        apply A_included_union'.

        apply W_step.
        apply W_null.
        rewrite e; apply V_in_left; apply V_in_single.

        apply V_in_right; trivial.

        rewrite e; apply A_in_left; apply E_right.

        elim (X x0 y0 v3 v2); intros.
        split with x1; elim p; intros.
        split with x2;
         apply
          (Walk_subgraph _ (V_union (V_single y) v0) _
             (A_union (E_set x y) a0) _ _ _ _ p0).
        apply V_included_union'.

        apply A_included_union'.

        elim (X x0 y0 H H0); intros.
        split with x1; elim p; intros.
        split with x2;
         apply (Walk_subgraph _ v0 _ (A_union (E_set x y) a0) _ _ _ _ p0).
        unfold V_included, Included, Ensembles.Included in |- *; auto.

        apply A_included_union'.

        elim (X x y); intros.
        split with x0; elim p; intros.
        split with x1; apply Walk_eq with (v := v0) (a := a0); auto.

        rewrite e; trivial.

        rewrite e; trivial.
Qed.

Lemma Connected_path :
 forall (v : V_set) (a : A_set) (g : Connected v a) (x y : Vertex),
 v x -> v y -> {vl : V_list &  {el : @E_list A &  Path v a x y vl el}}.
Proof.
        intros; elim (Connected_walk v a g x y H H0); intros.
        elim p; intros.
        apply (Walk_to_path eq_a_dec v a x y x0 x1 p0).
Qed.

End CONNECTED_BY_EDGES.

Implicit Arguments C_ina_inv2 [A].
Implicit Arguments C_ina_inv1 [A].

Section INVERSION_CONNECTED.

Variable A:Type.
Variable eq_a_dec: forall x y : A, {x = y} + {x <> y}.

Lemma C_minus_isolated :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Vertex),
 v x ->
 (forall y : Vertex, ~ a (A_ends x y)) -> v = V_single x /\ a = @A_empty A.
Proof.
        intros v a c; elim c; intros.
        inversion H; auto.

        case (V_union_single_dec eq_a_dec _ _ _ n H0); intros.
        elim (H1 x); rewrite e; apply A_in_left; apply E_left.

        generalize (A_not_in_union _ _ _ H1); intros.
        generalize (H x0 v2 H2); intros; decompose [and] H3.
        elim (H1 y); rewrite H4 in v1; inversion v1; apply A_in_left;
         apply E_right.

        generalize (A_not_in_union _ _ _ H1); intros.
        generalize (H x0 H0 H2); intros; decompose [and] H3.
        rewrite H4 in v1; inversion v1; rewrite H4 in v2; inversion v2.
        elim n; rewrite <- H6; trivial.

        rewrite <- e; rewrite <- e0; apply H.
        rewrite e; trivial.

        rewrite e0; trivial.
Qed.

Lemma C_minus_isolated_left :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Vertex),
 v x -> (forall y : @Vertex A, ~ a (A_ends x y)) -> v = V_single x.
Proof.
        intros; elim (C_minus_isolated v a c x); auto.
Qed.

Lemma C_minus_isolated_right :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x : Vertex),
 v x -> (forall y : Vertex, ~ a (A_ends x y)) -> a = @A_empty A.
Proof.
        intros; elim (C_minus_isolated v a c x); auto.
Qed.

Lemma C_pendant_isolated :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y z : Vertex),
 ~ v y ->
 (forall t : Vertex, A_union (E_set x y) a (A_ends z t) -> t = y) ->
 forall t : @Vertex A, ~ a (A_ends z t).
Proof.
        intros; red in |- *; intros; elim H.
        generalize (H0 t); intros.
        rewrite <- H2.
        apply (C_ina_inv2 _ _ c _ _ H1).

        apply A_in_right; trivial.
Qed.

Lemma E_pendant_quasi_isolated :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 v y ->
 ~ a (A_ends y x) ->
 (forall z : @Vertex A, A_union (E_set x y) a (A_ends y z) -> z = x) ->
 v = V_single y.
Proof.
        intros; apply (C_minus_isolated_left _ _ c y H).
        red in |- *; intros; elim H0; rewrite <- (H1 y0).
        trivial.

        apply A_in_right; trivial.
Qed.

Lemma E_not_eq_traversal_pendant :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y x' y' : Vertex),
 v x ->
 v y ->
 x <> y ->
 ~ a (A_ends x y) ->
 ~ a (A_ends y x) ->
 v x' ->
 v y' ->
 (forall z : @Vertex A, A_union (E_set x y) a (A_ends y' z) -> z = x') ->
 E_set x y <> E_set x' y'.
Proof.
        intros; red in |- *; intros.
        generalize H6; rewrite H7; intros.
        generalize (E_eq_not_in' _ _ _ _ _ _ H2 H3 H7); intros.
        generalize (E_pendant_quasi_isolated _ _ c x' y' H5 H9 H8); intros.
        elim H1.
        rewrite H10 in H; inversion H.
        rewrite H10 in H0; inversion H0.
        rewrite <- H11; trivial.
Qed.

Lemma C_minus_pendant :
 forall (v : V_set) (a : A_set) (c : Connected v a) (x y : Vertex),
 v x ->
 v y ->
 (forall z : @Vertex A, a (A_ends y z) -> z = x) ->
 forall (v' : V_set) (a' : A_set),
 ~ v' y ->
 v = V_union (V_single y) v' ->
 ~ a' (A_ends x y) ->
 ~ a' (A_ends y x) -> a = A_union (E_set x y) a' -> Connected v' a'.
Proof.
        intros v a c; elim c; intros.
        elim (A_empty_nothing (A_ends x0 y)).
        fold (@A_empty A) in |- *; rewrite H6; apply A_in_left; apply E_right.

        case (V_union_single_dec eq_a_dec _ _ _ n H0); intros.
        apply C_eq with (v := v0) (a := a0).
        apply (V_union_inversion (V_single y)).
        apply V_single_disjoint; trivial.

        rewrite e; apply V_single_disjoint; trivial.

        rewrite <- e in H3; trivial.

        generalize (H1 x); rewrite e; intros.
        apply (A_union_inversion (E_set x y)).
        apply E_set_disjoint; red in |- *; intros.
        elim n; apply (C_ina_inv2 _ _ co _ _ H8).

        elim n; apply (C_ina_inv1 _ _ co _ _ H8).

        rewrite e; rewrite H7.
        apply E_set_disjoint; trivial.

        apply A_in_left; apply E_left.

        fold (Union (@Arc A)) (@A_union A) in |- *; rewrite H6; rewrite e; rewrite H7.
        trivial.

        apply A_in_left; apply E_left.

        trivial.

        case (V_union_single_dec eq_a_dec _ _ _ n H); intros.
        rewrite <- e in H1;
         generalize (C_pendant_isolated _ _ co x y y0 n H1);
         intros.
        generalize (C_minus_isolated _ _ co y0 v2 H7); intros.
        decompose [and] H8.
        apply C_eq with (v := V_single y) (a := @A_empty A).
        symmetry  in |- *; apply (V_union_single_single v' y y0).
        red in |- *; intros Heq; elim n; rewrite Heq; trivial.

        trivial.

        rewrite H9 in H3; trivial.

        apply (A_union_edge_edge a0 a' x0 y0).
        trivial.

        trivial.

        trivial.

        rewrite <- H6.
        rewrite H9 in v1; inversion v1.
        rewrite e; apply A_union_eq.
        apply E_set_eq.

        trivial.

        apply C_isolated.

        apply
         C_eq
          with
            (v := V_union (V_single y) (V_inter v0 v'))
            (a := A_union (E_set x y) (A_inter a0 a')).
        apply (V_union_single_inter y y0).
        trivial.

        red in |- *; intros Heq; elim n; rewrite Heq; trivial.

        trivial.

        apply (A_union_single_inter x y x0 y0).
        red in |- *; intros; elim n; apply (C_ina_inv2 _ _ co _ _ H7).

        red in |- *; intros; elim n; apply (C_ina_inv1 _ _ co _ _ H7).

        apply E_set_diff2.
        red in |- *; intros Heq; elim n; rewrite Heq; trivial.

        red in |- *; intros Heq; elim n; rewrite Heq; trivial.

        trivial.

        apply C_leaf.
        apply (X x0 y0 v3 v2).
        intros; apply (H1 z).
        apply A_in_right; trivial.

        red in |- *; intros Hi; elim H2; inversion Hi; trivial.

        symmetry in |- *; autounfold; rewrite V_inter_commut;
         apply (V_union_single_inter y0 y).
        trivial.

        red in |- *; intros Heq; elim n; rewrite <- Heq; trivial.

        auto.

        unfold A_inter in |- *.
        rewrite (A_inter_commut a0 a'); apply A_not_inter; trivial.

        unfold A_inter in |- *.
        rewrite (A_inter_commut a0 a'); apply A_not_inter; trivial.

        repeat autounfold;
        rewrite A_inter_commut; symmetry  in |- *;
         apply (A_union_single_inter x0 y0 x y).
        trivial.

        trivial.

        apply E_set_diff4; red in |- *; intros Heq; elim n; rewrite Heq;
         trivial.

        auto.

        apply V_in_inter.
        trivial.

        case (V_union_single_dec eq_a_dec y0 x v'); intros.
        trivial.

        rewrite <- H3; apply V_in_right; trivial.

        elim n; rewrite (H1 y).
        trivial.

        rewrite e; apply A_in_left; apply E_right.

        trivial.

        red in |- *; intros Hi; elim n; inversion Hi; trivial.

        generalize
         (E_not_eq_traversal_pendant _ _ co x y x0 y0 v1 v2 n n0 n1 H H0 H1);
         intros.
        apply C_eq with (v := v') (a := A_union (E_set x y) (A_inter a0 a')).
        trivial.

        apply (A_union_single_inter x y x0 y0); trivial.

        apply C_edge.
        apply (X x0 y0 H H0).
        intros; apply H1; apply A_in_right; trivial.

        trivial.

        trivial.

        unfold A_inter in |- *.
        rewrite (A_inter_commut a0 a'); apply A_not_inter; trivial.

        unfold A_inter in |- *.
        rewrite (A_inter_commut a0 a'); apply A_not_inter; trivial.

        repeat autounfold.
        rewrite A_inter_commut; symmetry  in |- *;
         apply (A_union_single_inter x0 y0 x y); auto.

        rewrite H3 in v1; inversion v1.
        elim H7; inversion H8.
        rewrite <- (H1 y).
        apply E_set_eq.

        rewrite H10; apply A_in_left; apply E_right.

        trivial.

        rewrite H3 in v2; inversion v2.
        elim H7; inversion H8.
        rewrite <- (H1 x).
        trivial.

        rewrite H10; apply A_in_left; apply E_left.

        trivial.

        trivial.

        apply A_not_inter; trivial.

        apply A_not_inter; trivial.

        apply (X x y).
        rewrite e; trivial.

        rewrite e; trivial.

        rewrite e0; trivial.

        trivial.

        rewrite e; trivial.

        trivial.

        trivial.

        rewrite e0; trivial.
Qed.

End INVERSION_CONNECTED.

Implicit Arguments Connected_not_empty [A].
Implicit Arguments C_minus_isolated_left [A].
Implicit Arguments C_minus_isolated_right [A].
Implicit Arguments C_minus_pendant [A].


(***********************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team    *)
(* <O___,, *        INRIA-Rocquencourt  &  LRI-CNRS-Orsay              *)
(*   \VV/  *************************************************************)
(*    //   *      This file is distributed under the terms of the      *)
(*         *       GNU Lesser General Public License Version 2.1       *)
(***********************************************************************)

(* $Id: FSetWeakList.v 12641 2010-01-07 15:32:52Z letouzey $ *)

(** * Finite sets library *)

(** This file proposes an implementation of the non-dependant
    interface [FSetInterface.WS] using lists without redundancy. *)

Require Import FSetInterface.
Set Implicit Arguments.
Unset Strict Implicit.

(** This is just a compatibility layer, the real implementation
    is now in [MSetWeakList] *)

Require Equalities FSetCompat MSetWeakList.

Module Make (X: DecidableType) <: WS with Module E := X.
 Module E := X.
 Module X' := Equalities.Update_DT X.
 Module MSet := MSetWeakList.Make X'.
 Include FSetCompat.Backport_WSets X MSet.
End Make.


From mathcomp Require Import
     all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * StateMonad
      This file contains the standard definition of a state-monad.

**)

Definition State (s a : Type) : Type := s -> (a * s).

Definition get  {s : Type} : State s s := fun i => (i, i).
Definition gets {s a : Type} (f : s -> a) : State s a := fun s => (f s, s).
Definition put  {s : Type} x : State s unit := fun _ => (tt, x).
Definition modify {s : Type} (f : s -> s) : State s unit := fun i => (tt, f i).
Definition pure {s a : Type} : a -> State s a := fun x st => (x, st).

Definition bind {s a b : Type} (m1 : State s a) (f :(a -> State s b)) : State s b :=
  fun st => match m1 st with
         | (x, st') => f x st'
         end.

Arguments bind _ _/.
Arguments pure _/.

Notation "m >>= f" := (bind m f) (at level 43, left associativity).

Notation "X <- A ; B" := (A >>= (fun X => B)) (at level 81, right associativity, only parsing).

Notation "A ;; B" := (A >>= (fun _ => B)) (at level 81, right associativity, only parsing).


Require Import Bush.

Set Universe Polymorphism.

Unset Positivity Checking.
CoInductive Obama (A : Type) : Type :=
{
  hd : A;
  tl : Obama (Obama A);
}.

Arguments hd {A} _.
Arguments tl {A} _.

CoInductive sim' {A : Type} (b1 b2 : Obama A) : Type :=
{
  hds : hd b1 = hd b2;
  tls : sim' (tl b1) (tl b2);
}.

CoInductive Forall {A : Type} (P : A -> Type) (b : Obama A) : Type :=
{
  Forall_hd : P (hd b);
  Forall_tl : Forall (Forall P) (tl b);
}.

CoInductive Forall2 {A B : Type} (P : A -> B -> Type) (b1 : Obama A) (b2 : Obama B) : Type :=
{
  Forall2_hd : P (hd b1) (hd b2);
  Forall2_tl : Forall2 (Forall2 P) (tl b1) (tl b2);
}.

Definition sim {A : Type} (b1 b2 : Obama A) : Type :=
  Forall2 eq b1 b2.

Inductive Exists {A : Type} (P : A -> Type) (b : Obama A) : Type :=
| Ex_hd : P (hd b) -> Exists P b
| Ex_tl : Exists (Exists P) (tl b) -> Exists P b.

Inductive Exists2 {A B : Type} (R : A -> B -> Type) (b1 : Obama A) (b2 : Obama B) : Type :=
| Ex2_hd : R (hd b1) (hd b2) -> Exists2 R b1 b2
| Ex2_tl : Exists2 (Exists2 R) (tl b1) (tl b2) -> Exists2 R b1 b2.

#[global] Hint Constructors Exists Exists2 : core.

Definition Elem {A : Type} (x : A) (b : Obama A) : Type :=
  Exists (fun y => x = y) b.

Definition ObamaNeq {A : Type} (b1 b2 : Obama A) : Type :=
  Exists2 (fun x y => x <> y) b1 b2.

Inductive Dup {A : Type} (b : Obama A) : Prop :=
| Dup_hd : Exists (Exists (fun y => y = hd b)) (tl b) -> Dup b
| Dup_tl : Exists Dup (tl b) -> Dup b.
Set Positivity Checking.

(* TODO: to raczej nie powinno być induktywne... *)

Inductive SubObama : forall {A B : Type}, Obama A -> Obama B -> Type :=
| SubObama_hds :
    forall {A : Type} (b1 b2 : Obama A),
      hd b1 = hd b2 -> SubObama (tl b1) (tl b2) -> SubObama b1 b2
| SubObama_hd :
    forall {A : Type} (b1 : Obama A) (b2 : Obama (Obama A)),
      SubObama b1 (hd b2) -> SubObama b1 b2
| SubObama_tl :
    forall {A : Type} (b1 b2 : Obama A),
      SubObama b1 (tl b2) -> SubObama b1 b2.

Inductive DirectSubterm : forall {A B : Type}, A -> B -> Type :=
| DS_hd :
    forall {A : Type} (b : Obama A),
      DirectSubterm (hd b) b
| DS_tl :
    forall {A : Type} (b : Obama A),
      DirectSubterm (tl b) b.

Inductive Subterm : forall {A B : Type}, Obama A -> Obama B -> Type :=
| Subterm_step :
    forall {A B : Type} (b1 : Obama A) (b2 : Obama B),
      DirectSubterm b1 b2 -> Subterm b1 b2
| Subterm_trans :
    forall {A B C : Type} (b1 : Obama A) (b2 : Obama B) (b3 : Obama C),
      DirectSubterm b1 b2 -> Subterm b2 b3 -> Subterm b1 b3.

Inductive Swap : forall {A B : Type}, B -> Obama A -> B -> Obama A -> Type :=
| Swap_hdtl :
    forall {A : Type} (x : A) (b : Obama A),
      Swap x b (hd b) {| hd := x; tl := tl b; |}
| Swap_hd :
    forall {A : Type} (x y : A) (b : Obama (Obama A)) (r : Obama A),
      Swap x (hd b) y r -> Swap x b y {| hd := r; tl := tl b; |}
| Swap_tl :
    forall {A : Type} (x y : A) (b : Obama A) (r : Obama (Obama A)),
      Swap x (tl b) y r -> Swap x b y {| hd := hd b; tl := r; |}.

Fail Inductive Permutation : forall {A : Type}, Obama A -> Obama A -> Type :=
| Permutation_refl :
    forall {A : Type} (b : Obama A), Permutation b b
| Permutation_step :
    forall {A : Type} (x y : A) (b1 b2 b2' b3 : Obama A),
      Swap (hd b1) b1 y b1' -> Permutation {| hd := y; tl := tl b1'; |} b2 -> Permutation b1 b3.
Set Positivity Checking.

Axiom sim_eq :
  forall {A : Type} (b1 b2 : Obama A), sim b1 b2 -> b1 = b2.

Unset Guard Checking.

Definition Obama_corec :
  forall
    {A : Type} {F : Type -> Type}
    (hd' : forall A : Type, F A -> A) (tl' : forall A : Type, F A -> F (F A)),
      F A -> Obama A.
Proof.
  cofix CH.
  intros A F hd' tl' x.
  constructor.
    exact (hd' _ x).
    specialize (CH A F hd' tl' x). apply CH.
Admitted.

Lemma Obama_coiter :
  forall
    (A : Type)
    (hd : forall D : Type, D -> A)
    (tl : forall (D : Type) (F : Type -> Type), F D -> F (F D)),
      forall D : Type, D -> Obama A.
Proof.
  cofix CH.
  intros A hd tl D d.
  constructor.
    exact (hd _ d).
    apply tl. apply (CH A hd tl D d).
Defined.

CoFixpoint map {A B : Type} (f : A -> B) (b : Obama A) : Obama B :=
{|
  hd := f (hd b);
  tl := map (map f) (tl b);
|}.

CoFixpoint zipWith
  {A B C : Type} (f : A -> B -> C)
  (s1 : Obama A) (s2 : Obama B) : Obama C :=
{|
  hd := f (hd s1) (hd s2);
  tl := zipWith (zipWith f) (tl s1) (tl s2);
|}.

Definition unzip
  {A B : Type} (s : Obama (A * B)) : Obama A * Obama B :=
    (map fst s, map snd s).

CoFixpoint repeat {A : Type} (x : A) : Obama A :=
{|
  hd := x;
  tl := repeat (repeat x);
|}.

CoFixpoint iterate {A : Type} (f : A -> A) (x : A) : Obama A :=
{|
  hd := x;
  tl := iterate (map f) (iterate f x);
|}.

Fixpoint nth' {A B : Type} (n : Bush A) (b : Obama B) : B :=
match n with
| Leaf => hd b
| Node _ b' => hd (nth' b' (tl b))
end.

Definition nth (n : Bush unit) {A : Type} (b : Obama A) : A :=
  nth' n b.

Fixpoint Obama_to_the (n : nat) (A : Type) : Type :=
match n with
| 0 => A
| S n' => Obama_to_the n' (Obama A)
end.

Fixpoint nth2 {A : Type} (n : nat) (b : Obama A) {struct n} : Obama_to_the n A :=
match n with
| 0 => hd b
| S n' => nth2 n' (tl b)
end.

CoFixpoint from (n : nat) : Obama nat :=
{|
  hd := n;
  tl := map from (from (S n));
|}.

CoFixpoint diagonal {A : Type} (s : Obama (Obama A)) : Obama A :=
{|
  hd := hd (hd s);
  tl := diagonal (tl s);
|}.

(* Definition Obama' (A : Type) : Type :=
  {X : Type & X * (X -> A) * (X -> X)}%type.
 *)

(* Lemma Obama'_Obama {A : Type} (s : Obama' A) : Obama A.
Proof.
Defined.

Definition Obama_Obama' {A : Type} (s : Obama A) : Obama' A.
Proof.
Defined.
 *)

(* Lemma Obamas :
  forall (A : Type) (s : Obama A),
    sim (Obama'_Obama (Obama_Obama' s)) s.
Proof.
Abort.

Lemma Obamas' :
  forall (A : Type) (s : Obama' A),
    Obama_Obama' (Obama'_Obama s) = s.
Proof.
Abort.
 *)

Lemma Forall2_refl :
  forall
    {A : Type} {R : A -> A -> Type}
    (Rrefl : forall x : A, R x x)
    (x : Obama A),
      Forall2 R x x.
Proof.
  cofix CH.
  constructor.
    apply Rrefl.
    apply CH. apply CH. assumption.
Admitted.

Lemma sim_refl :
  forall (A : Type) (s : Obama A), sim s s.
Proof.
  intros. apply Forall2_refl. reflexivity.
Qed.

Lemma Forall2_sym :
  forall
    {A : Type} (R : A -> A -> Type)
    (Rsym : forall x y : A, R x y -> R y x)
    (b1 b2 : Obama A),
      Forall2 R b1 b2 -> Forall2 R b2 b1.
Proof.
  cofix CH.
  destruct 2 as [hds tls].
  constructor.
    apply Rsym. assumption.
    apply CH.
      apply CH. assumption.
      assumption.
Admitted.

Lemma sim_sym :
  forall (A : Type) (s1 s2 : Obama A),
    sim s1 s2 -> sim s2 s1.
Proof.
  intros. apply Forall2_sym.
    apply eq_sym.
    exact H.
Qed.

Lemma Forall2_trans :
  forall
    {A : Type} {R : A -> A -> Type}
    (Rtrans : forall x y z : A, R x y -> R y z -> R x z)
    (x y z : Obama A),
      Forall2 R x y -> Forall2 R y z -> Forall2 R x z.
Proof.
  cofix CH.
  destruct 2 as [x_hds x_tls], 1 as [y_hds y_tls].
  constructor.
    eapply Rtrans; eassumption.
    eapply CH.
      apply CH. assumption.
      eassumption.
      eassumption.
Admitted.

Lemma sim_trans :
  forall (A : Type) (s1 s2 s3 : Obama A),
    sim s1 s2 -> sim s2 s3 -> sim s1 s3.
Proof.
  intros.
  eapply Forall2_trans.
    apply eq_trans.
    eassumption.
    eassumption.
Qed.

Lemma eq_sim :
  forall {A : Type} (b1 b2 : Obama A), b1 = b2 -> sim b1 b2.
Proof.
  intros A b1 b2 [].
  apply sim_refl.
Qed.

Lemma map_id :
  forall (A : Type) (s : Obama A), sim (map (@id A) s) s.
Proof.
  cofix CH.
  constructor; cbn.
    reflexivity.
Abort.

Lemma Forall2_map_map :
  forall
    {A B C : Type} (R : C -> C -> Type)
    (f : A -> B) (g : B -> C)
    (s : Obama A),
      Forall2 R (map g (map f s)) (map (fun x => g (f x)) s).
Proof.
  cofix CH.
  constructor.
    cbn. admit.
    apply CH.
Admitted.

Lemma map_map :
  forall (A B C : Type) (f : A -> B) (g : B -> C) (s : Obama A),
    sim (map g (map f s)) (map (fun x => g (f x)) s).
Proof.
  intros. apply Forall2_map_map.
Qed.

Lemma unzip_zipWith :
  forall {A B : Type} (s : Obama (A * B)),
    sim
      (zipWith pair (fst (unzip s)) (snd (unzip s)))
      s.
Proof.
  cofix CH.
  constructor; cbn.
    destruct s as [[ha hb] s']; cbn. reflexivity.
    apply CH.
Abort.

(* TODO *) Lemma zipWith_unzip :
  forall {A B : Type} (sa : Obama A) (sb : Obama B),
    let s' := unzip (zipWith pair sa sb) in
      sim (fst s') sa * sim (snd s') sb.
Proof.
  split; cbn.
    revert sa sb. cofix CH. intros. constructor; cbn.
      reflexivity.
      apply CH.
    revert sa sb. cofix CH. intros. constructor; cbn.
      reflexivity.
      apply CH.
Abort.


Set Implicit Arguments.

Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.
From PromisingLib Require Import Axioms.

From PromisingLib Require Import Event.

Require Import FoldN.
Require Import Knowledge.

Require Import ITreeLangNotations.
Require Import ITreeLang.

Section DATA.

  Lemma inter_comm:
    forall s1 s2, IdentSet.eq (IdentSet.inter s1 s2) (IdentSet.inter s2 s1).
  Proof.
    ii. split.
    - i. eapply IdentSet.inter_spec in H. des. eapply IdentSet.inter_spec. auto.
    - i. eapply IdentSet.inter_spec in H. des. eapply IdentSet.inter_spec. auto.
  Qed.

  Lemma inter_assoc:
    forall s1 s2 s3, IdentSet.eq (IdentSet.inter s1 (IdentSet.inter s2 s3)) (IdentSet.inter (IdentSet.inter s1 s2) s3).
  Proof.
    ii. split.
    - i. eapply IdentSet.inter_spec in H. des. eapply IdentSet.inter_spec in H0. des.
      eapply IdentSet.inter_spec. split; auto. eapply IdentSet.inter_spec. auto.
    - i. eapply IdentSet.inter_spec in H. des. eapply IdentSet.inter_spec in H. des.
      eapply IdentSet.inter_spec. split; auto. eapply IdentSet.inter_spec. auto.
  Qed.

  Lemma inter_idem:
    forall s, IdentSet.eq (IdentSet.inter s s) s.
  Proof.
    ii. split.
    - i. eapply IdentSet.inter_spec in H. des; auto.
    - i. eapply IdentSet.inter_spec. auto.
  Qed.

  Lemma Subset_spec:
    forall s1 s2, IdentSet.Subset s1 s2 <-> IdentSet.eq s1 (IdentSet.inter s1 s2).
  Proof.
    ii. split; ii.
    - eapply IdentSet.Facts.In_s_m in H. split; ii.
      + eapply IdentSet.inter_spec. eauto.
      + eapply IdentSet.inter_spec in H0. des; auto.
      + auto.
    - eapply IdentSet.eq_leibniz in H. rewrite H in H0. eapply IdentSet.inter_spec in H0. des; auto.
  Qed.

  Definition IdentSetML :=
    @MLattice.mk_mlattice
      IdentSet.t IdentSet.eq IdentSet.eq_equiv IdentSet.eq_leibniz
      IdentSet.inter inter_comm inter_assoc inter_idem
      IdentSet.Subset Subset_spec.

  Definition bot := IdentSet.empty.
  Lemma bot_spec:
    forall s, IdentSet.Subset bot s.
  Proof.
    i. hexploit IdentSet.empty_spec. ii. unfold IdentSet.Empty in H. eapply H in H0. clarify.
  Qed.

End DATA.

Section ANALYSIS.

  (**
  Simple read-read forwarding:

  x =* l (read na); ... y =* l (read na);
  ->
  x =* l (read na); ... y = x (assign);

  Ordering:
  for insts in ...,

                      RR
  na               :  O
  rel(at write)    :  O
  acq(at read)     :  X
  rel-acq          :  X
  syscall          :  X

   **)

  Definition distl {T} l1 l2 (v1 v2: T) := if (Loc.eqb l1 l2) then v1 else v2.

  Definition RRfwd_load (ul: Loc.t) x o : Loc.t -> (local_update IdentSet.t) :=
    fun l t =>
      if (Ordering.le o Ordering.na)
      then distl ul l (IdentSet.add x t) (IdentSet.remove x t)
      else
        if (Ordering.le o Ordering.strong_relaxed)
        then distl ul l bot (IdentSet.remove x t)
        else bot.

  Definition RRfwd_write (ul: Loc.t) : Loc.t -> (local_update IdentSet.t) :=
    fun l t =>
      distl ul l bot t.

  Definition RRfwd_fence_r o : Loc.t -> (local_update IdentSet.t) :=
    fun _ t =>
      if (Ordering.le o Ordering.strong_relaxed)
      then t
      else bot.

  Definition RRfwd_fence_w o : Loc.t -> (local_update IdentSet.t) :=
    fun _ t =>
      if (Ordering.le o Ordering.acqrel)
      then t
      else bot.

  Definition RRfwd_assign x : Loc.t -> (local_update IdentSet.t) :=
    fun _ t => IdentSet.remove x t.

  Definition RRfwd_inst (i: Inst.t) : Loc.t -> (local_update IdentSet.t) :=
    fun l t =>
      match i with
      | Inst.skip => t
      | Inst.assign x e => (RRfwd_assign x) l t

      | Inst.load x ul o => (RRfwd_load ul x o) l t
      | Inst.store ul _ o => (RRfwd_write ul) l t

      (* same as load + store *)
      | Inst.update x ul rmw or ow =>
        let ut0 := (RRfwd_load ul x or) l t in
        let ut1 := (RRfwd_write ul) l ut0 in
        ut1

      | Inst.fence or ow =>
        let ut0 := (RRfwd_fence_r or) l t in
        let ut1 := (RRfwd_fence_w ow) l ut0 in
        ut1

      | Inst.syscall x es => bot
      | Inst.abort => t
      | Inst.choose x => (RRfwd_assign x) l t
      end
  .

  Definition N : nat := 1.

  Fixpoint RRfwd_block (b: block): Loc.t -> (local_update IdentSet.t) :=
    fun p d =>
      match b with
      | nil => d
      | cons hd tl =>
        match hd with
        | inst i =>
          let d0 := RRfwd_inst i p d in
          RRfwd_block tl p d0

        | ite _ b1 b2 =>
          let d1 := RRfwd_block b1 p d in
          let d2 := RRfwd_block b2 p d in
          let d3 := IdentSet.inter d1 d2 in
          RRfwd_block tl p d3

        | while _ wb =>
          let f := (RRfwd_block wb p) in
          let fp := fold_n f (S N) in
          let d0 := IdentSet.inter d (fp d) in
          RRfwd_block tl p d0
        end
      end.

End ANALYSIS.

Section ALG.

  Definition RRfwd_opt_inst (mp: GD IdentSet.t Loc.t) (i: Inst.t) : Inst.t :=
    match i with
    | Inst.load x l o =>
      match (IdentSet.choose (mp l)), o with
      | Some y, Ordering.na => (Inst.assign x (Inst.expr_var y))
      | _, _ => i
      end
    | _ => i
    end
  .

  Let GD := GD IdentSet.t Loc.t.
  Let inst_gd (i: Inst.t) : GD -> GD := mk_global (RRfwd_inst i).
  Let block_gd (b: block): GD -> GD := mk_global (RRfwd_block b).
  Let meet2 : GD -> GD -> GD := fun gd1 gd2 => (fun p => IdentSet.inter (gd1 p) (gd2 p)).

  Fixpoint RRfwd_opt_block (data: GD) (blk: block) : GD * block :=
    match blk with
    | nil => (data, blk)
    | cons hd tl =>
      match hd with
      | inst i =>
        let i1 := RRfwd_opt_inst data i in
        let data1 := inst_gd i data in
        let '(data2, tl1) := RRfwd_opt_block data1 tl in
        (data2, cons i1 tl1)

      | ite cond blk1 blk2 =>
        let '(data1, ublk1) := RRfwd_opt_block data blk1 in
        let '(data2, ublk2) := RRfwd_opt_block data blk2 in
        let data3 := meet2 data1 data2 in
        let '(data4, tl1) := RRfwd_opt_block data3 tl in
        (data4, cons (ite cond ublk1 ublk2) tl1)

      | while cond wb =>
        let f := (block_gd wb) in
        let fp := fold_n f (S N) in
        let data1 := meet2 data (fp data) in
        let '(_, wb1) := RRfwd_opt_block data1 wb in
        let '(data2, tl1) := RRfwd_opt_block data1 tl in
        (data2, cons (while cond wb1) tl1)

      end
    end.

  Let bot2 : GD := fun _ => bot.

  Definition RRfwd_opt_alg : block -> block :=
    fun code => snd (RRfwd_opt_block bot2 code).

End ALG.

Section Test.

  Import ITreeLangNotations.
  Import BinNums.

  Local Open Scope expr_scope.
  Local Open Scope inst_scope.
  Local Open Scope stmt_scope.
  Local Open Scope block_scope.

  Definition loc1 : Loc.t := xH.
  Definition loc2 : Loc.t := xO xH.
  Definition loc3 : Loc.t := xI xH.

  Definition a : Ident.t := xH.
  Definition b : Ident.t := Ident.succ a.
  Definition c : Ident.t := Ident.succ b.
  Definition d : Ident.t := Ident.succ c.

  Definition test0 : block :=
    { loc1 *=# (5: Const.t) Ordering.na;
      c =#* loc1 Ordering.na;
      a =# (1: Const.t);
      b =#* loc1 Ordering.na
    }
  .
  Definition test0' : block :=
    { loc1 *=# (5: Const.t) Ordering.na;
      c =#* loc1 Ordering.na;
      a =# (1: Const.t);
      b =# c
    }
  .
  Goal (RRfwd_opt_alg test0) = test0'.
  Proof. ss. Qed.

  Definition test1 : block :=
    { loc1 *=# (5: Const.t) Ordering.na;
      c =#* loc1 Ordering.na;
      while# (1: Const.t) do#
      { a =# (1: Const.t);
        b =#* loc1 Ordering.na
      }
      end#
    }
  .
  Definition test1' : block :=
    { loc1 *=# (5: Const.t) Ordering.na;
      c =#* loc1 Ordering.na;
      while# (1: Const.t) do#
      { a =# (1: Const.t);
        b =# c
      }
      end#
    }
  .
  Goal (RRfwd_opt_alg test1) = test1'.
  Proof. ss. Qed.

  Definition test2 : block :=
    { loc1 *=# (5: Const.t) Ordering.na;
      a =#* loc1 Ordering.na;
      if# a
      then# { a =# (1: Const.t);
              b =#* loc1 Ordering.na
            }
      else# { b =#* loc1 Ordering.na; }
      fi#;
      c =#* loc1 Ordering.na
    }
  .
  Definition test2' : block :=
    { loc1 *=# (5: Const.t) Ordering.na;
      a =#* loc1 Ordering.na;
      if# a
      then# { a =# (1: Const.t);
              b =#* loc1 Ordering.na
            }
      else# { b =# a; }
      fi#;
      c =# b
    }
  .
  Goal (RRfwd_opt_alg test2) = test2'.
  Proof. ss. Qed.

  Definition test3 : block :=
    { loc1 *=# (5: Const.t) Ordering.na;
      a =#* loc1 Ordering.na;
      b =#* loc1 Ordering.na;
      c =#* loc1 Ordering.na
    }
  .
  Definition test3' : block :=
    { loc1 *=# (5: Const.t) Ordering.na;
      a =#* loc1 Ordering.na;
      b =# a;
      c =# a
    }
  .
  Goal (RRfwd_opt_alg test3) = test3'.
  Proof. ss. Qed.

End Test.


Require Import Coq.ZArith.ZArith.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.Syntax.
Require Import compiler.Pipeline.
Require Import compiler.MMIO.
Require Import compiler.NaiveRiscvWordProperties.
Require Import coqutil.Map.SortedListWord.
Require Import coqutil.Map.Z_keyed_SortedListMap.
Require Import coqutil.Word.Bitwidth32.
Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Bedrock.End2End.X25519.Field25519.
Require Import Crypto.Bedrock.Field.Synthesis.New.UnsaturatedSolinas.
Require Import Crypto.Bedrock.Specs.Field.
Require Import Crypto.Bedrock.Field.Interface.Compilation2.
Require Import Crypto.Bedrock.Group.ScalarMult.MontgomeryLadder.
Require Import Crypto.Bedrock.End2End.X25519.MontgomeryLadder.

Local Arguments map.rep: clear implicits.

Definition f_rel_pos : Z := ltac:(
  let y := eval vm_compute in (List.find (fun '(name, pos) => String.eqb name "montladder") montladder_finfo) in
  match y with Some (_, ?pos) => exact pos end).

Local Instance mem : map.map (word.rep (width:=32)) Init.Byte.byte := SortedListWord.map _ _.
Local Existing Instance BW32.

(* Postcondition extracted from spec_of_montladder *)
Definition montladder_post (pOUT pK pU : word.rep (word:=Naive.word32))
          (Kbytes : list Byte.byte) (K : Z)
          (U : F (Field.M_pos (FieldParameters:=field_parameters)))
          (OUT : F (Field.M_pos (FieldParameters:=field_parameters)))
          (R : map.rep word.rep Init.Byte.byte mem -> Prop)
          (tr : Semantics.trace) :
  Semantics.trace -> map.rep _ _ mem -> list (word.rep (word:=Naive.word32)) -> Prop :=
   (fun (tr' : Semantics.trace)
        (mem' : map.rep word.rep Init.Byte.byte mem)
        (rets : list word.rep) =>
      rets = [] /\
      tr' = tr /\
      (FElem
         (BW:=BW32)
         (field_representaton:=field_representation n s c)
         (Some Field.tight_bounds) pOUT
         (montladder_gallina Field.M_pos Field.a24 (Z.to_nat (Z.log2 Curve25519.order)) K U)
         ⋆ Array.array ptsto (word.of_Z 1) pK Kbytes
         ⋆ FElem (BW:=BW32)
                 (field_representaton:=field_representation n s c)
                 (Some Field.tight_bounds) pU U ⋆ R)%sep
        mem').

Local Instance Registers : map.map Z (@word.rep 32 Naive.word32)
  := Zkeyed_map _.

Require Import riscv.Spec.Decode.

(* TODO: does something like this already exist? *)
(* when the function name being called is not first in the list of functions,
   peel off non-matching names *)
Local Ltac prepare_call_step :=
  lazymatch goal with
  | |- ?call (?f :: ?funcs) ?fname ?t ?m ?args ?post =>
    assert_fails (unify (fst f) fname);
    let H := fresh in
    assert (call funcs fname t m args post) as H;
    [ | remember funcs; rewrite (surjective_pairing f);
        cbn [WeakestPrecondition.call WeakestPrecondition.call_body ];
        lazymatch goal with |- context[if (String.eqb ?x ?y) then _ else _] =>
          let x' := (eval vm_compute in x) in change x with x';
          let y' := (eval vm_compute in y) in change y with y';
          destr (String.eqb x' y'); [ congruence | ]
        end; exact H ]
  end.
Local Ltac prepare_call := repeat prepare_call_step.

(* TODO: move to Spec.Field? *)
Section Generic.
  Context {width : Z} {BW : Bitwidth width} {word : word width}
          {mem : map.map word.rep (Init.Byte.byte : Type)}
          {locals : map.map string (word.rep (word:=word))}
          {ext_spec : Semantics.ExtSpec}
          {field_parameters : FieldParameters}
          {field_representation : FieldRepresentation}.

  Lemma peel_func_binop
      {name} (op : BinOp name) funcs0 funcs :
    fst funcs0 <> name ->
    spec_of_BinOp op funcs ->
    spec_of_BinOp op (funcs0 :: funcs).
  Proof.
    cbv [spec_of_BinOp binop_spec]; intros.
    cbn [WeakestPrecondition.call WeakestPrecondition.call_body ].
    destruct funcs0; cbn [fst snd] in *.
    lazymatch goal with |- context[if (String.eqb ?x ?y) then _ else _] =>
      destr (String.eqb x y); [ congruence | ]
    end.
    eauto.
  Qed.

  Lemma peel_func_unop
      {name} (op : UnOp name) funcs0 funcs :
    fst funcs0 <> name ->
    spec_of_UnOp op funcs ->
    spec_of_UnOp op (funcs0 :: funcs).
  Proof.
    cbv [spec_of_UnOp unop_spec]; intros.
    cbn [WeakestPrecondition.call WeakestPrecondition.call_body ].
    destruct funcs0; cbn [fst snd] in *.
    lazymatch goal with |- context[if (String.eqb ?x ?y) then _ else _] =>
      destr (String.eqb x y); [ congruence | ]
    end.
    eauto.
  Qed.

End Generic.

Local Instance naive_word_riscv_ok :
  RiscvWordProperties.word.riscv_ok Naive.word32 := naive_word_riscv_ok 5.

Lemma link_montladder : spec_of_montladder funcs.
Proof.
    unfold spec_of_montladder, ScalarMult.MontgomeryLadder.spec_of_montladder.
    unfold funcs.
    (* montladder is not at the front of the function list; remove everything
       that doesn't match the name *)
    prepare_call.
    (* use montladder correctness proof *)
    rewrite montladder_defn.
    eapply @montladder_correct; try (typeclasses eauto).
    { apply Signature.field_representation_ok.
      apply UnsaturatedSolinas.relax_valid. }
    { reflexivity. }
    { cbv [Core.__rupicola_program_marker]. tauto. }
    { exact I. }
    { eapply CSwap.cswap_body_correct; [|exact I].
      unfold field_representation, Signature.field_representation, Representation.frep; cbn; unfold n; cbv; trivial. }
    { eapply fe25519_copy_correct. }
    { eapply fe25519_from_word_correct. }
    {
      cbv [LadderStep.spec_of_ladderstep]; intros.
      prepare_call. rewrite ladderstep_defn.
      eapply @LadderStep.ladderstep_correct; try (typeclasses eauto).
      { apply Signature.field_representation_ok.
        apply UnsaturatedSolinas.relax_valid. }
      { cbv [Core.__rupicola_program_marker]; tauto. }
      { repeat (apply peel_func_binop; [ lazy; congruence | ]).
        apply fe25519_mul_correct. }
      { repeat (apply peel_func_binop; [ lazy; congruence | ]).
        apply fe25519_add_correct. }
      { repeat (apply peel_func_binop; [ lazy; congruence | ]).
        apply fe25519_sub_correct. }
      { repeat (apply peel_func_binop; [ lazy; congruence | ]).
        apply fe25519_square_correct. }
      { repeat (apply peel_func_binop; [ lazy; congruence | ]).
        apply fe25519_scmula24_correct. }
      { ecancel_assumption. } }
    { repeat (apply peel_func_unop; [ lazy; congruence | ]).
      unshelve eapply AdditionChains.fe25519_inv_correct_exp; try exact I.
      { unshelve eapply Signature.field_representation_ok, UnsaturatedSolinas.relax_valid. }
      { repeat (apply peel_func_binop; [ lazy; congruence | ]).
        apply fe25519_square_correct. }
      { repeat (apply peel_func_binop; [ lazy; congruence | ]).
        apply fe25519_mul_correct. } }
    { repeat (apply peel_func_unop; [ lazy; congruence | ]).
      apply fe25519_mul_correct. }
Qed.

Lemma montladder_compiles_correctly :
  forall (t : Semantics.trace)
         (mH : map.rep word.rep Init.Byte.byte mem)
         (pOUT pK pU : word.rep) (out_bound : option Field.bounds)
         (OUT U: F Field.M_pos) (Kbytes : list Byte.byte) (K : Z)
         (initial : MetricRiscvMachine)
         (stack_lo stack_hi ret_addr p_funcs : word.rep)
         (R Rdata Rexec : map.rep word.rep Init.Byte.byte mem -> Prop),
         LittleEndianList.le_combine Kbytes = K ->
         length Kbytes = 32%nat ->
         (FElem (BW:=BW32)
                (field_representaton:=field_representation n s c)
                out_bound pOUT OUT
          ⋆ Array.array ptsto (word.of_Z 1) pK Kbytes
          ⋆  FElem (BW:=BW32)
                   (field_representaton:=field_representation n s c)
                   (Some Field.tight_bounds) pU U
          ⋆ R)%sep mH ->
         montladder_stack_size <=
         word.unsigned (word.sub stack_hi stack_lo) /
         SeparationLogic.bytes_per_word ->
         word.unsigned (word.sub stack_hi stack_lo)
         mod SeparationLogic.bytes_per_word = 0 ->
         getPc (getMachine initial) = word.add p_funcs (word.of_Z f_rel_pos) ->
         map.get (getRegs (getMachine initial)) RegisterNames.ra =
         Some ret_addr ->
         word.unsigned ret_addr mod 4 = 0 ->
         LowerPipeline.arg_regs_contain (getRegs (getMachine initial)) [pOUT; pK; pU] ->
         getLog (getMachine initial) = t ->
         LowerPipeline.machine_ok p_funcs stack_lo stack_hi montladder_insns
           mH Rdata Rexec initial ->
         FlatToRiscvCommon.runsTo initial
           (fun final : MetricRiscvMachine =>
            exists
              (mH' : map.rep word.rep Init.Byte.byte mem)
            (retvals : list word.rep),
              LowerPipeline.arg_regs_contain (getRegs (getMachine final)) retvals /\
              montladder_post pOUT pK pU Kbytes K U OUT R t
                 (getLog (getMachine final)) mH' retvals /\
              map.only_differ (getRegs (getMachine initial))
                              reg_class.caller_saved
                              (getRegs (getMachine final)) /\
              getPc (getMachine final) = ret_addr /\
              LowerPipeline.machine_ok p_funcs stack_lo stack_hi
                montladder_insns mH' Rdata Rexec final).
Proof.
  intros.
  eapply (compiler_correct_wp
            (ext_spec:=FE310CSemantics.ext_spec)
            (string_keyed_map := SortedListString.map)
            (string_keyed_map_ok := SortedListString.ok))
    with (fname:="montladder"%string).
  all:cbn [montladder fst snd].

  (* fill in easy subgoals that instantiate evars *)
  all:lazymatch goal with
      | |- compile _ _ = Success _ =>
        rewrite montladder_compiler_result_ok;
        transitivity (Success (montladder_insns,
                               montladder_finfo,
                               montladder_stack_size));
        [ | reflexivity ]; reflexivity
      | _ => idtac
      end.
  all:lazymatch goal with
      | |- getPc (getMachine _) = _ => eassumption
      | |- getLog (getMachine _) = _ => eassumption
      | |- map.get (getRegs (getMachine _)) _ = Some _ => eassumption
      | |- LowerPipeline.arg_regs_contain _ _ => eassumption
      | |- context [LowerPipeline.machine_ok] => eassumption
      | |- map.get _ "montladder"%string = Some _ => reflexivity
      | _ => idtac
      end.

  (* solve remaining goals one by one *)
  { eapply (compile_ext_call_correct (funname_env_ok:=SortedListString.ok)). }
  { intros. cbv [compile_ext_call compile_interact].
    repeat (destruct_one_match; try reflexivity). }
  { vm_compute. reflexivity. }
  { lazy. repeat constructor; cbn [In]; intuition idtac; congruence. }
  { eapply link_montladder.
    ssplit; try eassumption; [ ].
    lazymatch goal with H : length Kbytes = _ |- _ => rewrite H end.
    lazy; congruence. }
  { assumption. }
  { assumption. }
  { assumption. }
Qed.

(* Print Assumptions montladder_compiles_correctly. *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall O E Eprime U A B C : Universe, ((wd_ U O /\ (wd_ U E /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ O U /\ (wd_ O Eprime /\ (wd_ U Eprime /\ (wd_ A O /\ (wd_ B O /\ (col_ O E U /\ (col_ O E A /\ (col_ O E B /\ col_ O E C))))))))))))) -> col_ O U C)).
Proof.
  time tac.
Qed.

End FOFProblem.