Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.Red.
Require Import MirrorCore.Lambda.ExprLift.
Require Import MirrorCore.TypesI.

Require Import ExtLib.Core.RelDec.

Require Import MirrorCharge.SetoidRewrite.Base.
Require Import MirrorCharge.ModularFunc.ILogicFunc.
Require Import MirrorCharge.ModularFunc.BILogicFunc.
Require Import MirrorCharge.AutoSetoidRewrite.

Require Import Charge.Logics.BILogic.
Require Import Charge.Logics.ILogic.

Section BILPullQuant.
  Context {typ func : Type} {HIL : ILogicFunc typ func} {HBIL : BILogicFunc typ func}.
  Context {RType_typ : RType typ}.
  Context {RelDec_func : RelDec (@eq (expr typ func))}.

  Let Rbase := expr typ func.

  Variable rg_eq : typ -> expr typ func.

  Definition rw_under_exists (t : typ) (l : typ) (rw : rewriter _) :=
    rw_under (RGinj (rg_eq t))
             (fun e rvars rg => rg_fmap (mkExists t l) (rw e rvars rg)).

  Definition bil_match_plus_l (rw : rewriter _)
             (e : expr typ func) (rvars : list (RG (expr typ func))) (rg : RG Rbase) : m (expr typ func) :=
  match e with
    | App (App a (App b (Abs _ P))) Q =>
      let Q' := lift 0 1 Q in
      match bilogicS (typ := typ) (func := expr typ func) a, ilogicS b with
      	| Some (bilf_star _), Some (ilf_exists t l) =>
	      rg_plus
	      (rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGflip (RGinj (fEntails l))))
	        (fun _ => rw_under_exists t l rw (mkStar l P Q') rvars rg))
	      (rg_bind (unifyRG (@rel_dec (expr typ func) _ _) rg (RGinj (fEntails l)))
	        (fun _ => rw_under_exists t l rw (mkStar l P Q') rvars rg))
	    | _, _ => rg_fail
	  end
	| _ => rg_fail
  end.

Definition bil_match_plus_r (rw : rewriter _) (e : expr typ func)
           (rvars : list (RG (expr typ func))) (rg : RG Rbase) : m (expr typ func) :=
  match e with
   | App (App a P) (App b (Abs _ Q)) =>
   	 let P' := lift 0 1 P in
     match bilogicS a, ilogicS b with
       | Some (bilf_star _), Some (ilf_exists t l) =>
	      rg_plus
	        (rg_bind
	          (unifyRG (@rel_dec (expr typ func) _ _ ) rg (RGinj (fEntails l)))
	            (fun _ => rw_under_exists t l rw (mkStar l P' Q) rvars rg))
  	        (rg_bind
	          (unifyRG (@rel_dec (expr typ func) _ _) rg (RGflip (RGinj (fEntails l))))
	            (fun _ => rw_under_exists t l rw (mkStar l P' Q) rvars rg))
	   | _, _ => rg_fail
	 end
   | _ => rg_fail
 end.

Definition bil_match_plus := sr_combineK bil_match_plus_l bil_match_plus_r.

End BILPullQuant.


Require Import Nat.
Require Import String.
Require Import List.
Require Import Coq.Init.Datatypes PArray.
From mathcomp Require Import all_ssreflect all_algebra.

Set Implicit Arguments.

(********************************************************)

(* Syntax of language *)

(********************************************************)

(* Value *)

Definition value := nat.

(* Operators *)
Inductive bop : Type :=
| plus : bop
| minus : bop.

(* Boolean Operators *)
Inductive bool_op : Type :=
| equal : bool_op
| less_than : bool_op
| greater_than : bool_op.

Definition varr := string.
Definition var  := string.

(* Expressions *)
Inductive expr : Type :=
| Evar : var -> expr (* variable *)
| Ebop : bop -> expr -> expr -> expr (* operation *).
(*| Edeclassify: expr -> expr (* declassify *).*)

(* Boolean Expressions *)
Inductive bexpr : Type :=
| Ebool : bool_op -> expr -> expr -> bexpr.

Inductive arr_access : Type :=
| AA : varr -> expr -> arr_access (* a[e] *).

Definition declassify := bool.

(* Instructions *)
Inductive instr : Type :=
| Iempty : instr
| Iassgn : var -> declassify -> expr -> instr (* assignemnt x := e *)
| Iload : var -> declassify -> arr_access -> instr (* x := a[e] *)
| Istore : arr_access -> declassify -> expr -> instr  (* a[e] := e *)
| Iif : bexpr -> seq instr -> seq instr -> instr (* conditional if b i i *).

Definition cmd := seq instr.

Definition map (A:Type) := string -> A.

Definition get_map {A:Type} (m:map A) (x:string) := m x.

(*Parameter update_map : forall {A:Type}, map A -> string -> A -> map A.*)

Definition update_map {A:Type} (m:map A) x v : map A :=
  fun y => if String.eqb x y then v else m y.

(* Register map *)
(* Maps registers to values *)
Definition regmap : Type := map value.

(* Signature of Array *)
Module Array.
   Parameter t : Type.
   Parameter get : t -> value -> value.
   Parameter set : t -> nat -> value -> t.
   Parameter get_length : t -> nat.
   Parameter get_index : t -> value -> nat.
End Array.

(* Memory *)
Definition mem : Type := map Array.t.

(* State with no speculation *)
Record state_sf := State_sf {
  scmd_sf : cmd;
  rmap_sf : regmap;
  mmap_sf  : mem
}.

Definition eval_bop (o:bop) (v:value) (v':value) : value :=
  match o with
  | plus => v + v'
  | minus => v - v'
  end.

Definition eval_bool_op (o:bool_op) (v:value) (v':value) : bool :=
  match o with
  | equal => v == v'
  | less_than => v < v'
  | greater_than => v > v'
  end.

(* Semantic of expressions *)
Fixpoint sem_expr (s:state_sf) (e:expr) : value :=
  match e with
  | Evar x => (rmap_sf s) x
  | Ebop o e e' => eval_bop o (sem_expr s e) (sem_expr s e')
  end.

Definition update_mem (m:mem) (a:varr) (n:nat) (v:value) :=
   let t := m a in
   let t' := Array.set t n v in
   update_map m a t'.

Definition update_rmap (r:regmap) (x:var) (v:value) :=
   update_map r x v.

Definition in_bound (m:mem) (a:varr) (i:nat) :=
  let av := m a in
  let n := Array.get_length av in
  if i <= n then true else false.

(* Leakages *)
Inductive leakage : Type :=
| Lbool : bool -> leakage
| Lindex : nat -> leakage
| Ldeclassify : option value -> leakage
| Lempty : leakage.

(* Semantics of instructions without speculation *)
(* Small-step semantics (Single step for one instruction -- It produces seq of leakage *)
(* Extraction of declassify from leakage will give seq of option value *)
Inductive sem_instr : state_sf -> seq leakage -> state_sf -> Prop :=
| Iempty_sem : forall s c,
  s.(scmd_sf) = Iempty :: c ->
  sem_instr s
  [::]
  {| scmd_sf := c;
     rmap_sf := s.(rmap_sf);
     mmap_sf := s.(mmap_sf) |}
| Iassgn_sem : forall s x d e c, (* x := 0 *)
  s.(scmd_sf) = Iassgn x d e :: c ->
  sem_instr s
  (if d then [:: Ldeclassify (Some (sem_expr s e))] else [:: Lempty])
  {| scmd_sf := c;
     rmap_sf := update_rmap s.(rmap_sf) x (sem_expr s e);
     mmap_sf := s.(mmap_sf) |}
(*| Iif_sem_true : forall s i1 i2 bop e1 e2,
  s.(stmt) = Iif (Ebool bop e1 e2) i1 i2 ->
  eval_bool_op bop (sem_expr s e1) (sem_expr s e2) = true ->
  sem_instr s (Lbool true) (with_stmt s i1)
| Iif_sem_false : forall s i1 i2 bop e1 e2,
  s.(stmt) = Iif (Ebool bop e1 e2) i1 i2 ->
  eval_bool_op bop (sem_expr s e1) (sem_expr s e2) = false ->
  sem_instr s (Lbool false) (with_stmt s i2)*)
| Iif_sem : forall s i1 i2 bop e1 e2 c,
  s.(scmd_sf) = Iif (Ebool bop e1 e2) i1 i2 :: c ->
  sem_instr s
  [:: (Lbool (eval_bool_op bop (sem_expr s e1) (sem_expr s e2)))]
  {| scmd_sf := (if (eval_bool_op bop (sem_expr s e1) (sem_expr s e2)) then i1 else i2) ++ c;
     rmap_sf := s.(rmap_sf);
     mmap_sf := s.(mmap_sf) |}
| Iload_sem : forall s x d a e c,
  s.(scmd_sf) = Iload x d (AA a e) :: c ->
  sem_instr s
  (if d then [:: Lindex (sem_expr s e); Ldeclassify (Some (Array.get (s.(mmap_sf) a) (sem_expr s e)))] else [:: Lindex (sem_expr s e)])
  {| scmd_sf := c;
     rmap_sf := update_rmap s.(rmap_sf) x (Array.get (s.(mmap_sf) a) (sem_expr s e));
     mmap_sf := s.(mmap_sf)|}
| Istore_sem : forall s a e d e' c,
  s.(scmd_sf) = Istore (AA a e) d e' :: c ->
  sem_instr s
  (if d then [:: Lindex (sem_expr s e); Ldeclassify (Some (sem_expr s e'))] else [:: Lindex (sem_expr s e)])
  {| scmd_sf := c;
     rmap_sf := s.(rmap_sf);
     mmap_sf := update_mem s.(mmap_sf) a (sem_expr s e) (sem_expr s e') |}.

(* Multi step for instructions without spec *)
Inductive multi_step : state_sf -> seq (seq leakage) -> nat -> state_sf -> Prop :=
| sem_empty : forall s, multi_step s nil 0 s
| sem_seq : forall s l s' l' s'' n,
  sem_instr s l s' ->
  multi_step s' l' n s'' ->
  multi_step s (l :: l') (n + 1) s''.

Definition final_state (s:state_sf) : bool :=
match s.(scmd_sf) with
| [::] => true
| _ => false
end.

(*Fixpoint inbound_instr (s:state_sf) (si:instr) {struct si}: Prop :=
match si with
| Iassgn x e => True
| Iload x (AA a e) => in_bound s.(mmap_sf) a (sem_expr s e) = true
| Istore (AA a e) e' => in_bound s.(mmap_sf) a (sem_expr s e) = true
| Iif b i i' => True
| Iseq i i' => inbound_instr s i /\ inbound_instr s i'
| Iempty => True
end.

Definition inbound_state (s:state_sf) : Prop :=
let si := s.(stmt_sf) in
inbound_instr s si.*)

Definition safe_state (s:state_sf) :=
final_state s = true \/ exists l s', sem_instr s l s'.


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 conj20synthconj5_hyp: forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus lv0 lv2) (mult lv2 (Succ lv1))) ->  (@eq natural (Succ (plus lv0 (plus lv1 lv2))) (plus (mult lv2 (plus Zero (Succ lv1))) (plus Zero (Succ lv1)))).
Admitted.
QuickChick conj20synthconj5_hyp.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


Require Import Iron.Language.SystemF.SubstTypeType.
Require Export Iron.Language.SystemF.KiJudge.
Require Export Iron.Language.SystemF.TyEnv.
Require Export Iron.Language.SystemF.Exp.

(* Type judgement assigns a type to an expression. *)
Inductive TYPE : kienv -> tyenv -> exp -> ty -> Prop :=
 | TYVar
   :  forall i ke te t
   ,  get i te = Some t
   -> KIND ke t  KStar
   -> TYPE ke te (XVar i) t

 | TYLam
   :  forall ke te x12 t11 t12
   ,  KIND ke t11 KStar
   -> TYPE ke (te :> t11)  x12            t12
   -> TYPE ke  te         (XLam t11 x12) (TFun t11 t12)

 | TYApp
   :  forall ke te x1 x2 t11 t12
   ,  TYPE ke te x1 (TFun t11 t12)
   -> TYPE ke te x2 t11
   -> TYPE ke te (XApp x1 x2) t12

 | TYLAM
   :  forall ke te x1 t1
   ,  TYPE (ke :> KStar) (liftTE 0 te) x1        t1
   -> TYPE ke            te           (XLAM x1) (TForall t1)

 | TYAPP
   :  forall ke te x1 t1 t2
   ,  TYPE ke te x1 (TForall t1)
   -> KIND ke t2 KStar
   -> TYPE ke te (XAPP x1 t2) (substTT 0 t2 t1).

Hint Constructors TYPE.

(* The type produced by a type judgement is well kinded. *)
Theorem type_kind
 :  forall ke te x t
 ,  TYPE ke te x t
 -> KIND ke t KStar.
Proof.
 intros. gen ke te t.
 induction x; intros; inverts H; eauto.

 Case "XAPP".
  apply IHx in H4. inverts H4.
  eapply subst_type_type; eauto.

 Case "XLam".
  eapply IHx1 in H4. inverts H4. auto.
Qed.

(* A well typed expression is well formed. *)
Theorem type_wfX
 :  forall ke te x t
 ,  TYPE ke te x t
 -> wfX  ke te x.
Proof.
 intros. gen ke te t.
 induction x; intros; simpl.

 Case "XVar".
  inverts H. eauto.

 Case "XLAM".
  inverts H.
  apply IHx in H3. eauto.

 Case "XAPP".
  inverts H.
  lets D: IHx H4. split.
   auto. eapply kind_wfT. eauto.

 Case "XLam".
  inverts H.
  apply IHx in H6.
  apply kind_wfT in H4. auto.

 Case "XApp".
  inverts H.
  apply IHx1 in H4.
  apply IHx2 in H6.
   auto.
Qed.
Hint Resolve type_wfX.

(********************************************************************)
(* Weakening the kind environment of a type judgement.
   We can insert a new kind into the kind environment of a type
   judgement, provided we lift existing references to kinds higher
   than this in the stack over the new one.
   References to existing elements of the kind environment may
   appear in the type environment, expression, as well as the
   resulting type -- so we must lift all of them.
 *)
Lemma type_kienv_insert
 :  forall ix ke te x1 t1 k2
 ,  TYPE ke                 te             x1             t1
 -> TYPE (insert ix k2 ke) (liftTE ix te) (liftTX ix x1) (liftTT ix t1).
Proof.
 intros. gen ix ke te t1 k2.
 induction x1; intros; inverts H; simpl; eauto.

 Case "XVar".
  apply TYVar.
  apply get_map. auto.
  apply liftTT_insert. auto.

 Case "XLAM".
  eapply TYLAM.
  rewrite insert_rewind.
   rewrite (liftTE_liftTE 0 ix).
   apply IHx1. auto.

 Case "XAPP".
  rewrite (liftTT_substTT' 0 ix). simpl.
  eapply TYAPP.
  eapply (IHx1 ix) in H4. simpl in H4. eauto.
  apply liftTT_insert. auto.

 Case "XLam".
  apply TYLam.
   apply liftTT_insert. auto.
   assert ( liftTE ix te :> liftTT ix t
          = liftTE ix (te :> t)). auto. rewrite H. clear H.
   apply IHx1. auto.

 Case "XApp".
  eapply TYApp.
   eapply IHx1_1 in H4. simpl in H4. eauto.
   eapply IHx1_2 in H6. eauto.
Qed.

Lemma type_kienv_weaken
 :  forall ke te x1 t1 k2
 ,  TYPE ke         te            x1            t1
 -> TYPE (ke :> k2) (liftTE 0 te) (liftTX 0 x1) (liftTT 0 t1).
Proof.
 intros.
 assert (ke :> k2 = insert 0 k2 ke).
  destruct ke; auto. rewrite H0.
  apply type_kienv_insert. auto.
Qed.

(********************************************************************)
(* Weakening the type environment of a type judgement.
   We can insert a new type into the type environment of a type
   judgement, provided we lift existing references to types higher
   than this in the stack over the new one.
 *)
Lemma type_tyenv_insert
 :  forall ke te ix x1 t1 t2
 ,  TYPE ke  te                x1            t1
 -> TYPE ke (insert ix t2 te) (liftXX ix x1) t1.
Proof.
 intros. gen ix ke te t1 t2.
 induction x1; intros; simpl; inverts H; eauto.

 Case "XVar".
  lift_cases; intros; auto.

 Case "XLAM".
  apply TYLAM. simpl.
  assert ( liftTE 0 (insert ix t2 te)
         = insert ix (liftTT 0 t2) (liftTE 0 te)).
   unfold liftTE. rewrite map_insert. auto.
  rewrite H.
  apply IHx1. auto.

 Case "XLam".
  eapply TYLam.
   auto.
   rewrite insert_rewind. apply IHx1. auto.
Qed.

Lemma type_tyenv_weaken
 :  forall ke te x1 t1 t2
 ,  TYPE ke  te         x1           t1
 -> TYPE ke (te :> t2) (liftXX 0 x1) t1.
Proof.
 intros.
 assert (te :> t2 = insert 0 t2 te).
  destruct te; auto. rewrite H0.
  apply type_tyenv_insert. auto.
Qed.


Require Import List Classical FunctionalExtensionality ExtensionalityFacts ChoiceFacts Wellfounded FinFun Fin.
Import ListNotations.

Tactic Notation "spec" hyp(H) :=
  match type of H with
    ?a -> _ => let H1 := fresh in (assert (H1: a); [|generalize (H H1); clear H H1; intro H])
  end.
Tactic Notation "spec" hyp(H) constr(a) :=
  (generalize (H a); clear H; intro H).
Tactic Notation "spec" hyp(H) constr(a) constr(b) :=
  (generalize (H a b); clear H; intro H).

(* **************** *)
(* **** Axioms **** *)
(* **************** *)

Axiom choice : FunctionalChoice.

Axiom choice' : FunctionalRelReification.

(* ************************************************* *)
(* **** Dependent finite injectivity playground **** *)
(* ************************************************* *)

Definition is_finite {X : Type} (P : X -> Prop) : Prop :=
  exists L : list X, forall (x : X), In x L <-> P x.

Definition is_finite_dep {X : Type} (P : X -> Prop) : Prop :=
  exists L : list {x | P x}, forall (dep_x : {x | P x}), In dep_x L.

Definition injective {X Y : Type} (P : X -> Prop) (Q : Y -> Prop) (f : {x | P x}  -> {y | Q y})
  := @Injective {x | P x} {y | Q y} f.

Theorem inj_finite {X Y : Type} :
  forall (P : X -> Prop) (Q : Y -> Prop) (f : {x | P x}  -> {y | Q y}),
    inhabited {x | P x} ->
    injective P Q f ->
    is_finite_dep Q ->
    is_finite_dep P.
Proof.
  intros P Q f H_witness H_inj H_Q_fin.
  unfold injective, Injective in H_inj.
  (* Every y either is reachable by some x or not reachable by any x *)
  (* This is the preamble to choice *)
  assert (H_frel : forall y, exists x, f x = y \/ forall x', f x' <> y).
  { intro y. destruct (classic (exists x, f x = y)).
    destruct H as [x H].
    exists x; left; assumption.
    destruct H_witness as [x0].
    exists x0. right. intros x_absurd H_absurd.
    apply H. exists x_absurd. assumption. }
  (* Using choice to get the actual function from Y -> X *)
  apply choice in H_frel.
  destruct H_frel as [g Hfrel].
  destruct H_Q_fin as [L H_Q_fin].
  exists (map g L).
  intro sig_x.
  spec H_Q_fin (f sig_x).
  apply (in_map g L (f sig_x)) in H_Q_fin.
  replace (g (f sig_x)) with sig_x in H_Q_fin.
  assumption.
  assert (forall x, exists y, f x = y).
  { intro x. exists (f x). reflexivity. }
  spec H sig_x.
  destruct H as [y H].
  rewrite H.
  spec Hfrel y.
  destruct Hfrel as [Hyes | Habsurd].
  unfold injective, Injective in H_inj.
  spec H_inj sig_x (g y).
  assert (f sig_x = f (g y)).
  { rewrite H; rewrite Hyes; reflexivity. }
  spec H_inj H0; assumption.
  spec Habsurd sig_x.
  contradiction.
Qed.

(* This relies on law of excluded middle *)
Lemma all_reachable {X Y : Type} :
  forall (P : X -> Prop) (Q : Y -> Prop) (f : {x | P x}  -> {y | Q y}),
    inhabited {x | P x} ->
    forall y : {y | Q y},
    exists x : {x | P x},
      f x = y \/
      forall x' : {x | P x},
        f x' <> y.
Proof.
  intros P Q f H_witness y.
  destruct (classic (exists x, f x = y)).
  destruct H as [x H].
  exists x; left; assumption.
  destruct H_witness as [x0].
  exists x0. right. intros x_absurd H_absurd.
  apply H. exists x_absurd. assumption.
Qed.

Lemma about_non_unique {X Y : Type} :
  forall (P : X -> Prop) (Q : Y -> Prop) (f : {x | P x} -> {y | Q y}),
  forall y : {y | Q y},
    injective P Q f ->
    ~ (exists! x : {x | P x},
      f x = y)
  <-> ((exists x1 x2 : {x | P x},
         f x1 = y /\ f x2 = y /\ x1 <> x2)
     \/ (forall x : {x | P x}, f x <> y)).
Proof.
  intros P Q f y H_inj.
  split; intro H.
  - destruct (classic (exists x, f x = y)).
    + destruct H0 as [x H0].
      exfalso. destruct H. exists x. split.
      exact H0. intros. spec H_inj x x'. apply H_inj.
      subst y. symmetry; assumption.
    + right. intros x. intro not.
      apply H0. exists x. assumption.
  - destruct H.
    + destruct H as [x1 [x2 [H1 [H2 Hneq]]]].
      intro not. unfold unique in not.
      destruct not.
      destruct H.
      spec H0 x1 H1.
      spec H_inj x2 x. subst y.
      rewrite <- H2 in H.
      symmetry in H. spec H_inj H.
      subst x. symmetry in H_inj. contradiction.
    + intro not. destruct not. spec H x.
      destruct H0. contradiction.
Qed.

Definition reachable {X Y : Type} (P : X -> Prop) (Q : Y -> Prop) (f : {x | P x} -> {y | Q y}) :=
  fun (dep_x : {x | P x}) (dep_y : {y | Q y}) => f dep_x = dep_y.

Definition surjective {X Y : Type} (P : X -> Prop) (Q : Y -> Prop)  (f : {x | P x}  -> {y | Q y}) :=
  forall (y : {y | Q y}), exists x : {x | P x}, f x = y.

Lemma all_reachable_uniqlo {X Y : Type} :
  forall (P : X -> Prop) (Q : Y -> Prop) (f : {x | P x}  -> {y | Q y}),
    injective P Q f ->
    surjective P Q f ->
    forall y : {y | Q y},
    exists! x : {x | P x},
      f x = y.
Proof.
  intros P Q f H_inj H_surj y.
  spec H_surj y. destruct H_surj as [x ?].
  exists x. split. assumption.
  intros. eapply H_inj; eauto. congruence.
Qed.

Theorem inj_surj_finite {X Y : Type} :
  forall (P : X -> Prop) (Q : Y -> Prop) (f : {x | P x}  -> {y | Q y}),
    injective P Q f ->
    surjective P Q f ->
    is_finite_dep Q ->
    is_finite_dep P.
Proof.
  intros P Q f H_inj H_surj H_Q_fin.
  (* Using definite description to get the actual function from Y -> X *)
  assert (H_choice := choice' _ _ _ (all_reachable_uniqlo P Q f H_inj H_surj)).
  destruct H_choice as [g H_choice].
  (* Either g is the inverse or there is something wrong with our input *)
  destruct H_Q_fin as [L H_Q_fin] (* L contains all elements of dependent y *).
  (* The witness P list we need is constructed using choice-given g *)
  exists (map g L).
  intro sig_x.
  spec H_choice (f sig_x).
  spec H_inj (g (f sig_x)) sig_x.
  spec H_inj H_choice.
  rewrite <- H_inj.
  apply in_map.
  spec H_Q_fin (f sig_x). assumption.
Qed.

Definition get_hd {X : Type} :
  forall (P: X -> Prop) (L: list X) (hd : X) (tl : list X)
    (Hfin: forall x, In x L -> P x) (Heq : hd :: tl = L),
    {x | P x}.
Proof.
  intros P L hd tl Hfin Heq;
    rewrite <- Heq in Hfin.
  exists hd. spec Hfin hd (in_eq hd tl); apply Hfin; assumption.
Defined.

Definition rest_fin {X : Type} :
  forall (P: X -> Prop) (L: list X) (hd : X) (tl : list X)
    (Hfin: forall x, In x L -> P x) (Heq : hd :: tl  = L),
  forall x, In x tl -> P x.
Proof.
  intros P L hd tl Hfin Heq x H.
  rewrite <- Heq in Hfin.
  apply (in_cons hd x tl) in H.
  spec Hfin x H; apply Hfin; assumption.
Defined.

(* Aha! I fully understand how this piece of magic works now *)
Fixpoint build_dep_impl_list
         {X : Type}
         (P : X -> Prop)
         (L : list X)
         (Hfin : forall x, In x L -> P x) : list {x | P x} :=
  match L as l return ((l = L) -> list {x | P x}) with
  | nil =>
    fun _ => nil
  | a :: al =>
    fun h => cons (get_hd P L a al Hfin h)
               (build_dep_impl_list P al (rest_fin P L a al Hfin h))
  end (eq_refl L).
Print exist.

Fixpoint build_dep_impl_list' {X: Type} (P: X -> Prop) (L: list X)
         (Hfin: forall x, In x L -> P x): list {x | P x} :=
  match L as l return (l = L -> list {x | P x}) with
  | nil => fun _ => nil
  | hd :: tl =>
    fun h => cons (eq_rect (hd :: tl) _
                        (fun Hfin0 : forall x, In x (hd :: tl) -> P x =>
                           exist _ hd (Hfin0 hd (in_eq hd tl))) L h Hfin)
               (build_dep_impl_list' P tl (rest_fin P L hd tl Hfin h))
  end (eq_refl L).

Lemma build_dep_preserves_elements {X : Type} : forall (P : X -> Prop) (L : list X) (Hfin : forall x, In x L -> P x),
    map (fun dep_x => proj1_sig dep_x) (build_dep_impl_list P L Hfin) = L.
Proof.
  intros P l Hfin.
  induction l as [|hd tl IHl].
  - reflexivity.
  - simpl.
    assert (map (fun dep_x : {x : X | P x} => proj1_sig dep_x)
                (build_dep_impl_list P tl (rest_fin P (hd :: tl) hd tl Hfin eq_refl))
            = tl) by intuition.
    rewrite IHl; reflexivity.
Qed.

Lemma in_map_inv {A B : Type} :
  forall (f : A -> B) (l : list A) (x : A),
    Injective f -> In (f x) (map f l) -> In x l.
Proof.
  intros f l x' H_inj H_map.
  unfold Injective in H_inj.
  apply (in_map_iff f l (f x')) in H_map.
  destruct H_map as [x [Heq H_in]].
  spec H_inj x x'.
  spec H_inj Heq; rewrite <- H_inj; assumption.
Qed.

Lemma proj1_sig_injective {X : Type} :
    forall (P : X -> Prop)
      (x1 x2 : X) (H1 : P x1) (H2 : P x2),
      (exist P x1 H1) = (exist P x2 H2) <-> x1 = x2.
Proof.
  intros P x1 x2 H1 H2; split.
  - intro H_eq_dep.
    apply eq_sig_fst in H_eq_dep; assumption.
  - intro H_eq.
    subst. assert (H1 = H2) by eapply proof_irrelevance.
    rewrite H. reflexivity.
Qed.

Lemma proj1_sig_inj {X : Type} :
  forall (P : X -> Prop),
    Injective (fun (x : {x | P x}) => proj1_sig x).
Proof.
  intro P; unfold Injective.
  intros x1 x2 H_eq.
  destruct x1 as [x1 about_x1];
    destruct x2 as [x2 about_x2].
  assert (H_useful := proj1_sig_injective P x1 x2 about_x1 about_x2).
  apply H_useful.
  assumption.
Qed.

Lemma inj_in_map_iff :
  forall {X : Type} (P : X -> Prop) (f : {x | P x} -> X) (L : list {x | P x})
  (x : {x | P x}),
    In (proj1_sig x) (map (fun x => proj1_sig x) L) <-> In x L.
Proof.
  intros X P f L x; split; intro H.
  - assert (H_useful := in_map_inv (fun x => proj1_sig x) L x).
    spec H_useful (proj1_sig_inj P).
    apply H_useful; exact H.
  - assert (H_useful := in_map (fun x => proj1_sig x) L x).
    spec H_useful H.
    exact H_useful.
Qed.

(** The key results! **)
Theorem list_to_dep_list : forall {X : Type} (P : X -> Prop),
    is_finite P -> is_finite_dep P.
Proof.
  intros X P H_fin.
  destruct H_fin as [L H_fin].
  assert (forall x, In x L -> P x) by (intros; now apply H_fin).
  exists (build_dep_impl_list P L H).
  intros dep_x.
  destruct dep_x as [x about_x].
  spec H_fin x.
  destruct H_fin.
  spec H1 about_x.
  assert (H_useful := build_dep_preserves_elements P L H).
  assert (H_useful' := in_map_inv (fun x => proj1_sig x) (build_dep_impl_list P L H)).
  spec H_useful' (exist (fun x0 : X => P x0) x about_x).
  apply H_useful'.
  intros x0 x1 H_eq.
  destruct x0, x1. simpl in H_eq.
  apply proj1_sig_inj. exact H_eq.
  rewrite H_useful.
  simpl; exact H1.
Qed.

Theorem dep_list_to_list : forall {X : Type} (P : X -> Prop),
    is_finite_dep P -> is_finite P.
Proof.
  intros X P H_fin_dep.
  destruct H_fin_dep as [L H_fin_dep].
  exists (map (fun x => proj1_sig x) L).
  intro x; split; intro H.
  - rewrite in_map_iff in H.
    destruct H as [dep_x [H_eq H_in]].
    spec H_fin_dep dep_x.
    rewrite <- H_eq.
    destruct dep_x as [dep_x about_dep_x].
    unfold proj1_sig; exact about_dep_x.
  - spec H_fin_dep (exist P x H).
    assert (H_useful := inj_in_map_iff P (fun x => proj1_sig x) L).
    spec H_useful (exist P x H). destruct H_useful as [_ right]; spec right H_fin_dep.
    assumption.
Qed.

Theorem is_finite_equiv : forall {X : Type} (P : X -> Prop),
    is_finite_dep P <-> is_finite P.
Proof.
  intros X P; split.
  exact (dep_list_to_list P).
  exact (list_to_dep_list P).
Qed.

(* The subset of list L which satisfies P is finite *)
Lemma p_in_list_finite {X : Type} : forall (P : X -> Prop) (L : list X),
    is_finite (fun l => P l /\ In l L).
Proof.
  intros P LS.
  induction LS as [|new_x old_xes IHL].
  + (* In the base case, the candidate list is empty,
     so the finite list is also empty *)
    exists nil.
    intros x; split.
    intro H_in; split. inversion H_in. exact H_in.
    intro H; destruct H as [_ H_mem]; exact H_mem.
  + (* In the inductive step, the candidate list grows by one x,
       and the new finite list must include it if it satisfies P *)
    destruct IHL as [L' IHL].
    destruct (classic (P new_x)).
    ++ (* When new_x satisfies P *)
      exists (new_x :: L').
      intros x; split; intros H_in.
      +++ apply in_inv in H_in;
            destruct H_in as [H_eq | H_in].
          split. rewrite H_eq in H; assumption.
          rewrite <- H_eq; apply in_eq.
          split. spec IHL x; destruct IHL as [left _];
                   spec left H_in. destruct left; assumption.
          apply in_cons.
          spec IHL x; destruct IHL as [left _].
          spec left H_in; destruct left; assumption.
      +++ destruct H_in.
          apply in_inv in H1.
          destruct H1. rewrite H1; apply in_eq.
          apply in_cons. spec IHL x.
          destruct IHL as [_ IHL].
          apply IHL; split; assumption.
    ++ (* When new_x doesn't satisfy P, toss it out *)
      exists L'.
      intro x; split; intros H_in.
      +++ split. spec IHL x; destruct IHL as [IHL _];
            spec IHL H_in; destruct IHL; assumption.
          apply in_cons.
          spec IHL x; destruct IHL as [IHL _];
            spec IHL H_in; destruct IHL; assumption.
      +++ destruct H_in as [H_P H_in].
          apply in_inv in H_in.
          destruct H_in as [H_absurd | H_in].
          subst x; contradiction.
          spec IHL x. apply IHL; split; assumption.
Qed.

Lemma finite_conj {X : Type} : forall (P : X -> Prop) (Q : X -> X -> Prop),
    is_finite (fun l => P l) ->
    (forall L, is_finite (fun l => P l /\ Q L l)).
Proof.
  intros P Q H_fin L.
  destruct H_fin as [ls H_fin].
  assert (H_useful := p_in_list_finite (Q L) ls).
  destruct H_useful as [LS H_useful].
  exists LS.
  intro l; spec H_fin l; spec H_useful l; split; intro H.
  - split;
    apply H_useful in H; destruct H as [H_Q H_in];
    apply H_fin in H_in; assumption.
  - destruct H as [H_P H_Q].
    apply H_fin in H_P.
    apply H_useful; split; assumption.
Qed.

Lemma finite_conj_dep {X : Type} : forall (P : X -> Prop) (Q : X -> X -> Prop),
    is_finite (fun l => P l) ->
    (forall (x : X), P x -> forall x', Q x x' -> P x') ->
    (forall (L : {l | P l}), is_finite (fun l => Q (proj1_sig L) l)).
Proof.
  intros P Q H_fin H_deriv L_dep.
  assert (H_useful := finite_conj P Q H_fin).
  destruct L_dep as [L_dep about_L_dep].
  spec H_useful L_dep.
  destruct H_useful as [LS H_useful].
  exists LS.
  intro x; split; intro H.
  spec H_useful x.
  apply H_useful. assumption.
  apply H_useful. split. simpl in *.
  spec H_deriv L_dep about_L_dep.
  spec H_deriv x H. assumption.
  simpl; assumption.
Qed.

Lemma finite_conj_undep {X : Type} : forall (P : X -> Prop) (Q : X -> X -> Prop),
    is_finite (fun l => P l) ->
    (forall (x : X), P x -> forall x', Q x x' -> P x') ->
    (forall (x : X), P x -> is_finite (fun l => Q x l)).
Proof.
  intros P Q H_fin H_deriv x H_P.
  assert (H_useful := finite_conj_dep P Q H_fin H_deriv).
  spec H_useful (exist P x H_P).
  destruct H_useful as [LS H_useful].
  exists LS.
  assumption.
Qed.


From hahn Require Import Hahn.

Require Import Setoid.

Set Implicit Arguments.

Definition eq_dom {A B} (s : A -> Prop) (f g : A -> B) :=
  forall (x: A) (SX: s x), f x = g x.

#[global]
Hint Unfold eq_dom : unfolderDb.

Lemma eq_dom_union {A B} (s s' : A -> Prop) (f g : A -> B):
  eq_dom (s ∪₁ s') f g <-> eq_dom s f g /\ eq_dom s' f g.
Proof.
  split.
  { ins. unfold eq_dom in *.
    splits; ins; apply (H x); basic_solver. }
  intros [Hs Hs'].
  unfold eq_dom in *. ins.
  unfold set_union in SX.
  desf; basic_solver.
Qed.

Lemma eq_dom_full_eq {A B} (f g : A -> B) (EQD : eq_dom (fun _ => True) f g) :
  f = g.
Proof. apply functional_extensionality. ins. by apply EQD. Qed.

Lemma doma_eqv {A} (s : A -> Prop) (r : relation A): doma (⦗s⦘ ⨾ r) s.
Proof. apply doma_helper. basic_solver. Qed.

Lemma seq_eqv_inter_ll {A} S (r r' : relation A) :
  (⦗S⦘ ⨾ r) ∩ r' ≡ ⦗S⦘ ⨾ r ∩ r'.
Proof.
basic_solver.
Qed.

Lemma seq_eqv_inter_lr {A} S (r r' : relation A) :
  (r ⨾ ⦗S⦘) ∩ r' ≡ r ∩ r' ⨾ ⦗S⦘.
Proof.
basic_solver.
Qed.

Lemma id_inter {A} (s s' : A -> Prop) : ⦗s ∩₁ s'⦘ ≡ ⦗s⦘ ⨾ ⦗s'⦘.
Proof.
basic_solver.
Qed.

Lemma cr_seq {A} (r r' : relation A) : r^? ⨾ r' ≡ r' ∪ r ⨾ r'.
Proof. split; basic_solver 5. Qed.

Lemma seq_eqv_minus_lr :
forall (A : Type) (S : A -> Prop) (r r' : relation A),
(r ⨾ ⦗S⦘) \ r' ≡ (r \ r') ⨾ ⦗S⦘.
Proof.
basic_solver 21.
Qed.

Lemma seq_eqv_minus_ll :
forall (A : Type) (S : A -> Prop) (r r' : relation A),
(⦗S⦘ ⨾ r) \ r' ≡ ⦗S⦘ ⨾ (r \ r').
Proof.
basic_solver 21.
Qed.

Lemma path_union A (r1 r2: relation A) : (r1 ∪ r2)⁺ ⊆ r1⁺ ∪ (r1＊ ⨾ r2)⁺ ⨾ r1＊.
Proof.
apply inclusion_t_ind_right.
unionL; [vauto|].
by rewrite rtE; rewrite <- !ct_step; basic_solver 12.
relsf; unionL.
- by unionR left; rewrite ct_unit.
- by rewrite !seqA; rewrite <- ct_end; basic_solver 12.
- rewrite (ct_step (r1⁺ ⨾ r2)).
  rewrite <- inclusion_t_rt at 1; basic_solver 22.
- rewrite !seqA, inclusion_t_rt at 1.
  rewrite <- (ct_end (r1＊ ⨾ r2)); basic_solver 12.
Qed.

Lemma path_union1 A (r1 r2: relation A) : (r1 ∪ r2)⁺ ⊆ r2⁺ ∪ r2＊ ⨾ (r1 ∪ r1 ⨾ r2⁺)⁺.
Proof.
apply inclusion_t_ind_right.
unionL; [|vauto].
by rewrite rtE; rewrite <- !ct_step; basic_solver 12.
relsf; unionL; rewrite ?seqA.
- unionR right.
  arewrite (r2⁺ ⊆ r2＊); hahn_frame.
  rewrite <- !ct_step; basic_solver 12.
- by arewrite (r1 ⊆ (r1 ∪ r1 ⨾ r2⁺)＊) at 3; relsf.
- arewrite (r2⁺ ⊆ r2＊) at 1.
  rewrite <- ct_end; basic_solver.
- unionR right.
  rewrite ct_end, !seqA.
  arewrite ((r1 ∪ r1 ⨾ r2⁺) ⨾ r2 ⊆ (r1 ∪ r1 ⨾ r2⁺)).
  relsf; unionL.
  * rewrite <- !ct_step; basic_solver 12.
  * rewrite !seqA.
    arewrite (r2⁺ ⊆ r2＊) at 1.
    rewrite <- ct_end; basic_solver.
  * relsf.
Qed.

Lemma path_union2 A (r1 r2: relation A) :
  (r1 ∪ r2)⁺ ⊆ r1⁺ ∪ r2⁺ ⨾ r1＊ ∪ r2＊ ⨾ (r1⁺ ⨾ r2⁺)⁺ ⨾ r1＊.
Proof.
rewrite path_union1; unionL.
basic_solver 12.
rewrite path_union.
relsf.
unionL.
basic_solver 12.
arewrite (r1＊ ⨾ r1 ⊆ r1⁺).
basic_solver 12.
Qed.

Lemma acyclic_union A (r1 r2: relation A) (R1: acyclic r1) (FF: acyclic (r2 ⨾ r1＊)):
  acyclic (r1 ∪ r2).
Proof.
unfold acyclic; ins; rewrite path_union.
apply irreflexive_union; split; auto.
rewrite irreflexive_seqC.
rewrite ct_begin, !seqA; relsf.
rewrite <- seqA; rewrite <- ct_begin.
by rewrite acyclic_seqC in FF.
Qed.

Lemma acyclic_union1 A (r1 r2: relation A) (R1: acyclic r1)
(R2: acyclic r2)
(FF: acyclic (r1⁺ ⨾ r2⁺)):
  acyclic (r1 ∪ r2).
Proof.
unfold acyclic; ins; rewrite path_union.
apply irreflexive_union; split; auto.
rewrite irreflexive_seqC.
rewrite ct_begin, !seqA; relsf.
rewrite <- seqA, <- ct_begin.
rewrite rtE; relsf.
rewrite path_union.
apply irreflexive_union; split; auto.
rewrite irreflexive_seqC.
rewrite ct_begin, !seqA; relsf.
rewrite <- !seqA, <- ct_begin.
apply acyclic_rotl.
rewrite <- seqA, <- ct_begin.
by apply acyclic_rotl.
Qed.

Lemma seq_minus_transitive :
  forall (A : Type) (r r1 r2 : relation A), transitive r -> r1 ⨾ r2 \ r ⊆
(r1 \ r) ⨾  r2 ∪ (r1 ∩ r) ⨾  (r2 \ r).
Proof.
unfolder; ins; desf.
destruct (classic (r x z)); [|eauto].
right; eexists; splits; try edone; intro; eauto.
Qed.

Lemma ct_minus_transitive :
  forall (A : Type) (r r1: relation A), transitive r -> r1⁺ \ r ⊆
(r1 ∩ r)＊ ⨾  (r1 \ r) ⨾  r1＊.
Proof.
ins.
arewrite (r1 ⊆ (r1 ∩ r) ∪ (r1 \ r)) at 1.
by unfolder; ins; desf; tauto.
rewrite path_ut_first, minus_union_l.
unionL.
by arewrite (r1 ∩ r ⊆ r); relsf.
arewrite ((r1 ∩ r) ∪ (r1 \ r) ⊆ r1) at 1.
basic_solver 12.
Qed.

Lemma restr_eqv_def {A} (cond : A -> Prop) (r : relation A) :
  restr_rel cond r ≡ ⦗cond⦘ ⨾ r ⨾ ⦗cond⦘.
Proof.
basic_solver.
Qed.

Lemma restr_full {A} (r : relation A) :
  restr_rel (fun _ : A => True) r ≡ r.
Proof. basic_solver. Qed.

Lemma dom_rel_ext (A: Type) (r1 r2: relation A):
dom_rel (r1 ⨾ r2^?) ≡₁ dom_rel r1.
Proof.
basic_solver 10.
Qed.
(*
Lemma dom_rel_helper (A: Type) (r1 r2: relation A) S (IN: r1 ⊆ r2):
dom_rel (r1 ⨾ ⦗fun x => dom_rel (r2 ⨾ ⦗eq x⦘) ⊆₁ S⦘) ⊆₁ S.
Proof.
basic_solver 10.
Qed.*)

Lemma dom_rel_eqv_dom_rel {A} (r r' : relation A):
  dom_rel (r ⨾ ⦗dom_rel r'⦘) ≡₁ dom_rel (r ⨾ r').
Proof.
basic_solver 42.
Qed.

Lemma dom_rel_eqv_codom_rel {A} (r r' : relation A):
  dom_rel (r ⨾ ⦗codom_rel r'⦘) ≡₁ dom_rel (r ⨾ r'^{-1}).
Proof.
basic_solver 42.
Qed.

Lemma dom_rel_fun_alt {A} (r : relation A) w :
  (fun a => r a w) ≡₁ dom_rel (r ⨾ ⦗ eq w ⦘).
Proof.
basic_solver 10.
Qed.

Lemma dom_rel_helper {A} (r : relation A) d (IN:  dom_rel r ⊆₁ d) : r ≡ ⦗d⦘ ⨾ r.
Proof.
unfolder in *; basic_solver.
Qed.

Lemma dom_rel_helper_in {A} (r : relation A) d (IN:  dom_rel r ⊆₁ d) : r ⊆ ⦗d⦘ ⨾ r.
Proof.
unfolder in *; basic_solver.
Qed.

Lemma cr_helper {A} (r r' : relation A) d (H: r ⨾ ⦗d⦘ ⊆ ⦗d⦘ ⨾ r') : r^? ⨾ ⦗d⦘ ⊆ ⦗d⦘ ⨾ r'^? .
Proof.
rewrite crE; relsf.
rewrite H; basic_solver 20.
Qed.

Lemma acyc_simple_helper (A:Type) (r1 r2: relation A):
acyclic (r1 ∪ r2) -> acyclic (r1⨾ r2).
Proof.
ins.
arewrite (r1 ⊆ r1 ∪ r2).
arewrite (r2 ⊆ r1 ∪ r2) at 2.
rewrite (ct_step (r1 ∪ r2)).
rewrite inclusion_t_rt at 1.
relsf.
red; rels.
Qed.

Tactic Notation "rotate" int_or_var(i) := do i (
 rewrite <- ?seqA; (apply irreflexive_seqC || apply acyclic_seqC); rewrite ?seqA).
Tactic Notation "rotate" := rotate 1.

(******************************************************************************)
(** ** Adjacency (new file in hahn?)  *)
(******************************************************************************)

Definition adjacent A (rel: relation A) a b :=
  ⟪ LA_ac : forall c, rel b c -> rel a c ⟫ /\
  ⟪ LA_ca : forall c, rel c b -> rel^? c a ⟫ /\
  ⟪ LA_cb : forall c, rel c a -> rel c b ⟫ /\
  ⟪ LA_bc : forall c, rel a c -> rel^? b c ⟫.

Definition adjacentW A (rel: relation A) a b :=
  ⟪ LA_ac : forall c, rel b c -> rel a c ⟫ /\
  ⟪ LA_cb : forall c, rel c a -> rel c b ⟫.

Lemma adjacent_weaken A (rel: relation A) a b :
  adjacent rel a b -> adjacentW rel a b.
Proof. unfold adjacent, adjacentW; intuition. Qed.

Lemma immediate_adjacent A (r: relation A) (dom: A -> Prop)
  (STOT1: ⦗dom⦘ ⨾ r ⨾ r^{-1} ⊆ r^? ∪ r^{-1})
  (STOT2: r^{-1} ⨾ ⦗dom⦘ ⨾ r ⊆ r^? ∪ r^{-1})
  (T: transitive r) (IRR: irreflexive r):
⦗dom⦘ ⨾ immediate r ≡ ⦗dom⦘ ⨾ (adjacent r ∩ r).
Proof.
unfold adjacent; unfolder in *; ins.
split; splits; desf; ins; try done.
1, 3: by eauto with hahn.
assert (AA: dom x /\ (exists z : A, r x z /\ r c z) ) by eauto.
by specialize (STOT1 x c AA) ; desf; [auto|exfalso; eauto |econs].
assert (AA: (exists z : A, r z y /\ dom z /\ r z c) ) by eauto.
by specialize (STOT2 y c AA) ; desf; [auto|econs | exfalso; eauto].
apply LA_bc in R1; apply LA_ca in R2; desf; eapply IRR, T; eauto.
Qed.

Lemma adjacent_uniqe1 A (r: relation A) (ACYC: acyclic r):
  forall a b c : A,  r a b ->  r a c -> adjacent r a b -> adjacent r a c -> b = c.
Proof.
ins; unfold adjacent in *; desc.
assert (r^? b c) by eauto.
assert (r^? c b) by eauto.
unfolder in *; desf.
by exfalso; eapply ACYC; eapply t_trans; econs; eauto.
Qed.

Lemma adjacent_uniqe2 A (r: relation A) (ACYC: acyclic r):
  forall a b c : A,  r b a ->  r c a -> adjacent r b a -> adjacent r c a -> b = c.
Proof.
ins; unfold adjacent in *; desc.
assert (r^? b c) by eauto.
assert (r^? c b) by eauto.
unfolder in *; desf.
by exfalso; eapply ACYC; eapply t_trans; econs; eauto.
Qed.

(******************************************************************************)
(** ** dom_cond  *)
(******************************************************************************)

  Definition dom_cond (A: Type) (r: relation A) s := (fun e => dom_rel (r ⨾ ⦗ eq e ⦘) ⊆₁ s).

Add Parametric Morphism A : (@dom_cond A) with signature
  inclusion --> set_subset ==> set_subset as dom_cond_mori.
Proof.
ins. unfold dom_cond.
red; ins.
by rewrite H, <- H0.
Qed.

Add Parametric Morphism A : (@dom_cond A) with signature
  same_relation ==> set_equiv ==> set_equiv as dom_cond_more.
Proof.
unfold dom_cond; unfolder; ins; splits; ins; desf; eauto 10.
Qed.

  Lemma dom_cond_elim {A} r (s : A -> Prop) : r ⨾ ⦗dom_cond r s⦘ ⊆ ⦗s⦘ ⨾ r.
  Proof.
    unfold dom_cond; basic_solver 12.
  Qed.

  Lemma dom_cond_elim1 {A} r1 r2 (s : A -> Prop) (IN: r1 ⊆ r2) :
    r1 ⨾ ⦗dom_cond r2 s⦘ ⊆ ⦗s⦘ ⨾ r1.
  Proof. unfold dom_cond; basic_solver 21. Qed.

  Lemma dom_cond_elim2 {A} r (s s' : A -> Prop) :
    s' ∩₁ dom_cond r s ⊆₁ dom_cond (⦗ s' ⦘ ⨾ r) s.
  Proof. unfold dom_cond. basic_solver 12. Qed.

  Lemma dom_cond_union {A} r1 r2 (s : A -> Prop) :
    dom_cond (r1 ∪ r2) s ≡₁ dom_cond r1 s ∩₁ dom_cond r2 s.
  Proof. unfold dom_cond; split; basic_solver 21. Qed.

  Lemma dom_cond_in {A} r r1 (s t : A -> Prop) :
    r ⨾ ⦗t⦘ ⊆ ⦗s⦘ ⨾ r1 -> t ⊆₁ dom_cond r s.
  Proof.
    unfold dom_cond; unfolder; ins; desf.
   splits; eauto; eapply H; eauto.
  Qed.

(******************************************************************************)
(** ** ifthenelse  *)
(******************************************************************************)

Definition ifthenelse T K L (c : {K} + {L}) (x y : T) :=
  if c then x else y.

Definition ifthenelse_b T (c : bool) (x y : T) :=
  if c then x else y.

Add Parametric Morphism {A} (K : Prop) (L : Prop) (c : {K} + {L}) :
  (@ifthenelse (A -> Prop) K L c) with signature
    set_equiv ==>
    set_equiv ==>
    set_equiv as ifthenelse_more.
Proof. intros; unfold ifthenelse; desf. Qed.

Add Parametric Morphism {A} (c : bool) :
  (@ifthenelse_b (A -> Prop) c) with signature
    set_equiv ==>
    set_equiv ==>
    set_equiv as ifthenelse_b_more.
Proof. intros; unfold ifthenelse_b; desf. Qed.

Lemma ite_alt {A} K L (c : {K} + {L}) (x y : A -> Prop) :
  (if c then x else y) ≡₁ ifthenelse c x y.
Proof. rels. Qed.

Lemma iteb_alt {A} (c : bool) (x y : A -> Prop) :
  (if c then x else y) ≡₁ ifthenelse_b c x y.
Proof. rels. Qed.

Lemma ite_union_t {A} K L (c : {K} + {L}) (x y z : A -> Prop) :
  ifthenelse c (x ∪₁ y) z ≡₁ ifthenelse c x z ∪₁ ifthenelse c y z.
Proof. by rewrite <- !ite_alt; destruct c; [|rewrite set_unionK]. Qed.

(******************************************************************************)
(** **   *)
(******************************************************************************)

Lemma rewrite_helper (A: Type) (r: relation A) (S S': A -> Prop)
(IN: r ⨾ ⦗S⦘ ⊆ ⦗S'⦘ ⨾ r) :
r ⨾ ⦗S⦘ ≡ ⦗S'⦘ ⨾ r ⨾ ⦗S⦘.
Proof.
split; [| basic_solver].
arewrite (⦗S⦘ ⊆ ⦗S⦘ ⨾ ⦗S⦘) at 1.
basic_solver.
sin_rewrite IN.
basic_solver 12.
Qed.

  Lemma eq_predicate {A} (P : A -> Prop) a (H : P a): eq a ⊆₁ P.
  Proof. by intros x H'; subst. Qed.

  Add Parametric Morphism A : (@doma A) with signature
      same_relation ==> set_equiv ==> iff as doma_more.
  Proof.
    ins; split; ins; intros x' y' H';
      apply H0; eapply H1; eauto; apply H; eauto.
  Qed.

  Add Parametric Morphism A : (@domb A) with signature
      same_relation ==> set_equiv ==> iff as domb_more.
  Proof.
    ins; split; ins; intros x' y' H';
      apply H0; eapply H1; eauto; apply H; eauto.
  Qed.

Lemma ind_helper {A} (r r': relation A) (D1 D2: A -> Prop) (ACYC: acyclic r) :
r^* ⨾ ⦗D1⦘ ⊆ ⦗D2⦘ ⨾ r'^* -> r^+ ⨾ ⦗D1⦘ ⊆ ⦗D2⦘ ⨾ r'^+.
Proof.
rewrite !rtE; unfolder; ins; desf.
specialize (H x y); desf.
assert (D2 x /\ (x = y /\ True \/ r'⁺ x y)) by tauto; desf.
exfalso; eapply ACYC; edone.
Qed.


(** This file implements [IsHomomorphism] and [IsIsomorphism].
    It developes basic algebra homomorphisms and isomorphims. The main
    theorem in this file is the [path_isomorphism] theorem, which
    states that there is a path between isomorphic algebras. *)

Require Export HoTTClasses.interfaces.ua_setalgebra.

Require Import
  HoTT.Basics.Equivalences
  HoTT.Basics.PathGroupoids
  HoTT.Types.Forall
  HoTT.Types.Arrow
  HoTT.Types.Universe
  HoTT.Types.Record
  HoTT.Types.Sigma
  HoTT.Fibrations
  HoTT.HProp
  HoTT.HSet
  HoTT.Tactics.

Import algebra_notations ne_list.notations.

Section is_homomorphism.
  Context {σ} {A B : Algebra σ} (f : ∀ (s : Sort σ), A s → B s).

(** The family of functions [f] above is [OpPreserving α β] with
    respect to operations [α : A s1 → A s2 → ... → A sn → A t] and
    [β : B s1 → B s2 → ... → B sn → B t] if

    <<
      f t (α x1 x2 ... xn) = β (f s1 x1) (f s2 x2) ... (f sn xn)
    >>
*)

  Fixpoint OpPreserving {w : SymbolType σ}
    : Operation A w → Operation B w → Type
    := match w with
       | [:s:] => λ α β, f s α = β
       | s ::: y => λ α β, ∀ (x : A s), OpPreserving (α x) (β (f s x))
       end.

  Global Instance trunc_oppreserving `{Funext} {n : trunc_index}
    `{!IsTruncAlgebra n.+1 B} {w : SymbolType σ}
    (α : Operation A w) (β : Operation B w)
    : IsTrunc n (OpPreserving α β).
  Proof.
    induction w; exact _.
  Qed.

(** The family of functions [f : ∀ (s : Sort σ), A s → B s] above is
    a homomorphism if for each function symbol [u : Symbol σ], it is
    [OpPreserving (u^^A) (u^^B)] with respect to the algebra
    operations [u^^A] and [u^^B] corresponding to [u]. *)

  Class IsHomomorphism : Type
    := oppreserving_hom : ∀ (u : Symbol σ), OpPreserving (u^^A) (u^^B).

  Global Instance trunc_is_homomorphism `{Funext} {n : trunc_index}
    `{!IsTruncAlgebra n.+1 B}
    : IsTrunc n IsHomomorphism.
  Proof.
    apply trunc_forall.
  Qed.
End is_homomorphism.

Record Homomorphism {σ} {A B : Algebra σ} : Type := BuildHomomorphism
  { def_hom : ∀ (s : Sort σ), A s → B s
  ; is_homomorphism_hom : IsHomomorphism def_hom }.

Arguments Homomorphism {σ}.

Arguments BuildHomomorphism {σ A B} def_hom {is_homomorphism_hom}.

(** We the implicit coercion from [Homomorphism A B] to the family
    of functions [∀ s, A s → B s]. *)

Global Coercion def_hom : Homomorphism >-> Funclass.

Global Existing Instance is_homomorphism_hom.

Lemma apD10_homomorphism {σ} {A B : Algebra σ} {f g : Homomorphism A B}
  : f = g → ∀ s, f s == g s.
Proof.
  intro p. by destruct p.
Defined.

Definition SigHomomorphism {σ} (A B : Algebra σ) : Type :=
  { def_hom : ∀ s, A s → B s | IsHomomorphism def_hom }.

Lemma issig_homomorphism {σ} (A B : Algebra σ)
  : SigHomomorphism A B <~> Homomorphism A B.
Proof.
  unfold SigHomomorphism.
  issig (@BuildHomomorphism σ A B) (@def_hom σ A B)
    (@is_homomorphism_hom σ A B).
Defined.

Global Instance trunc_homomorphism `{Funext} {σ} {A B : Algebra σ}
  {n : trunc_index} `{!IsTruncAlgebra n B}
  : IsTrunc n (Homomorphism A B).
Proof.
  apply (trunc_equiv _ (issig_homomorphism A B)).
Qed.

(** To find a path between two homomorphisms [f g : Homomorphism A B]
    it suffices to find a path between the defining families of
    functions and the [is_homomorphism_hom] witnesses. *)

Lemma path_homomorphism {σ} {A B : Algebra σ} (f g : Homomorphism A B)
  (p : def_hom f = def_hom g)
  (q : p#(is_homomorphism_hom f) = is_homomorphism_hom g)
  : f = g.
Proof.
  destruct f, g. simpl in *. by path_induction.
Defined.

(** To find a path between two homomorphisms [f g : Homomorphism A B]
    it suffices to find a path between the defining families of
    functions if [IsHSetAlgebra B]. *)

Lemma path_hset_homomorphism `{Funext} {σ} {A B : Algebra σ}
  `{!IsHSetAlgebra B} (f g : Homomorphism A B)
  (p : def_hom f = def_hom g)
  : f = g.
Proof.
  apply (path_homomorphism f g p). apply path_ishprop.
Defined.

(** A family of functions [f : ∀ s, A s → B s] is an isomorphism if it is
    a homomorphism, and for each [s : Sort σ], [f s] is an equivalence. *)

(* We make [IsHomomorphism] an argument here, rather than a field, so
   having both [f : Homomorphism A B] and [X : IsIsomorphism f] in
   context does not result in having two proofs of [IsHomomorphism f]
   in context. *)

Class IsIsomorphism {σ : Signature} {A B : Algebra σ}
  (f : ∀ s, A s → B s) `{!IsHomomorphism f}
  := isequiv_isomorphism : ∀ (s : Sort σ), IsEquiv (f s).

Global Existing Instance isequiv_isomorphism.

Definition equiv_isomorphism {σ : Signature} {A B : Algebra σ}
  (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f}
  : ∀ (s : Sort σ), A s <~> B s.
Proof.
  intro s. rapply (BuildEquiv _ _ (f s)).
Defined.

Global Instance hprop_is_isomorphism `{Funext} {σ : Signature}
  {A B : Algebra σ} (f : ∀ s, A s → B s) `{!IsHomomorphism f}
  : IsHProp (IsIsomorphism f).
Proof.
  apply trunc_forall.
Qed.

(** Let [f : ∀ s, A s → B s] be a homomorphism. The following
    section proves that [f] is "OpPreserving" with respect to
    uncurried algebra operations in the sense that

    <<
      f t (α (x1,x2,...,xn,tt)) = β (f s1 x1,f s2 x1,...,f sn xn,tt)
    >>

    for all [(x1,x2,...,xn,tt) : FamilyProd A [s1;s2;...;sn]], where
    [α] and [β] are uncurried algebra operations in [A] and [B]
    respectively.
*)

Section homomorphism_ap_operation.
  Context {σ : Signature} {A B : Algebra σ}.

  Lemma path_oppreserving_ap_operation (f : ∀ s, A s → B s)
    {w : SymbolType σ} (a : FamilyProd A (dom_symboltype w))
    (α : Operation A w) (β : Operation B w) (P : OpPreserving f α β)
    : f (cod_symboltype w) (ap_operation α a)
      = ap_operation β (map_family_prod f a).
  Proof.
    induction w.
    - assumption.
    - destruct a as [x a]. apply IHw. apply P.
  Defined.

(** A homomorphism [f : ∀ s, A s → B s] satisfies

    <<
      f t (α (a1, a2, ..., an, tt))
      = β (f s1 a1, f s2 a2, ..., f sn an, tt)
    >>

    where [(a1, a2, ..., an, tt) : FamilyProd A [s1; s2; ...; sn]] and
    [α], [β] uncurried versions of [u^^A], [u^^B] respectively. *)

  Lemma path_homomorphism_ap_operation (f : ∀ s, A s → B s)
    `{!IsHomomorphism f}
    : ∀ (u : Symbol σ) (a : FamilyProd A (dom_symboltype (σ u))),
      f (cod_symboltype (σ u)) (ap_operation (u^^A) a)
      = ap_operation (u^^B) (map_family_prod f a).
  Proof.
    intros u a. by apply path_oppreserving_ap_operation.
  Defined.
End homomorphism_ap_operation.

(** The next section shows that the family of identity functions,
    [λ s x, x] is an isomorphism. *)

Section hom_id.
  Context {σ} (A : Algebra σ).

  Global Instance is_homomorphism_id
    : IsHomomorphism (λ s (x : A s), x).
  Proof.
    intro u. generalize (u^^A). intro w. induction (σ u).
    - reflexivity.
    - now intro x.
  Defined.

  Global Instance is_isomorphism_id
    : IsIsomorphism (λ s (x : A s), x).
  Proof.
    intro s. exact _.
  Qed.

  Definition hom_id : Homomorphism A A
    := BuildHomomorphism (λ s x, x).

End hom_id.

(** Suppose [f : ∀ s, A s → B s] is an isomorphism. The following
    section shows that the family of inverse functions, [λ s, (f s)^-1]
    is an isomorphism. *)

Section hom_inv.
  Context
    {σ} {A B : Algebra σ}
    (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f}.

  Global Instance is_homomorphism_inv : IsHomomorphism (λ s, (f s)^-1).
  Proof.
   intro u.
   generalize (u^^A) (u^^B) (oppreserving_hom f u).
   intros a b P.
   induction (σ u).
   - destruct P. apply (eissect (f t)).
   - intro. apply IHs.
     exact (transport (λ y, OpPreserving f _ (b y))
              (eisretr (f t) x) (P (_^-1 x))).
  Defined.

  Global Instance is_isomorphism_inv : IsIsomorphism (λ s, (f s)^-1).
  Proof.
    intro s. exact _.
  Qed.

  Definition hom_inv : Homomorphism B A
    := BuildHomomorphism (λ s, (f s)^-1).

End hom_inv.

(** Let [f : ∀ s, A s → B s] and [g : ∀ s, B s → C s]. The
    next section shows that composition given by [λ (s : Sort σ),
    g s o f s] is again a homomorphism. If both [f] and [g] are
    isomorphisms, then the composition is an isomorphism. *)

Section hom_compose.
  Context {σ} {A B C : Algebra σ}.

  Lemma oppreserving_compose (g : ∀ s, B s → C s) `{!IsHomomorphism g}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f} {w : SymbolType σ}
    (α : Operation A w) (β : Operation B w) (γ : Operation C w)
    (G : OpPreserving g β γ) (F : OpPreserving f α β)
    : OpPreserving (λ s, g s o f s) α γ.
  Proof.
    induction w; simpl in *.
    - by path_induction.
    - intro x. now apply (IHw _ (β (f _ x))).
  Defined.

  Global Instance is_homomorphism_compose
    (g : ∀ s, B s → C s) `{!IsHomomorphism g}
    (f : ∀ s, A s → B s) `{!IsHomomorphism f}
    : IsHomomorphism (λ s, g s o f s).
  Proof.
    intro u.
    by apply (oppreserving_compose g f (u^^A) (u^^B) (u^^C)).
  Defined.

  Global Instance is_isomorphism_compose
    (g : ∀ s, B s → C s) `{IsIsomorphism σ B C g}
    (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f}
    : IsIsomorphism (λ s, g s o f s).
  Proof.
    intro s. apply isequiv_compose.
  Qed.

  Definition hom_compose
    (g : Homomorphism B C) (f : Homomorphism A B)
    : Homomorphism A C
    := BuildHomomorphism (λ s, g s o f s).

End hom_compose.

(** The following section shows that there is a path between
    isomorphic algebras. *)

Section path_isomorphism.
  Context `{Univalence} {σ : Signature} {A B : Algebra σ}.

(** Let [F G : I → Type]. If [f : ∀ (i:I), F i <~> G i] is a family of
    equivalences, then by function extensionality composed with
    univalence there is a path [F = G]. *)

  Local Notation path_equiv_family f
    := (path_forall _ _ (λ i, path_universe (f i))).

(** Given a family of equivalences [f : ∀ (s : Sort σ), A s <~> B s]
    which is [OpPreserving f α β] with respect to algebra operations

    <<
      α : A s1 → A s2 → ... → A sn → A t
      β : B s1 → B s2 → ... → B sn → B t
    >>

    By transporting [α] along the path [path_equiv_family f] we
    find a path from the transported operation [α] to [β]. *)

  Lemma path_operations_equiv {w : SymbolType σ}
    (α : Operation A w) (β : Operation B w)
    (f : ∀ (s : Sort σ), A s <~> B s) (P : OpPreserving f α β)
    : transport (λ C : Carriers σ, Operation C w)
        (path_equiv_family f) α
      = β.
  Proof.
    induction w; simpl in *.
    - transport_path_forall_hammer.
      exact (ap10 (transport_idmap_path_universe (f t)) α @ P).
    - funext y.
      transport_path_forall_hammer.
      rewrite transport_forall_constant.
      rewrite transport_arrow_toconst.
      rewrite (transport_path_universe_V (f t)).
      apply IHw.
      specialize (P ((f t)^-1 y)).
      by rewrite (eisretr (f t) y) in P.
  Qed.

(** Suppose [u : Symbol σ] is a function symbol. Recall that
    [u^^A] is notation for [operations A u : Operation A (σ u)]. This
    is the algebra operation corresponding to function symbol [u]. *)

(** An isomorphism [f : ∀ s, A s → B s] induces a family of
    equivalences [e : ∀ (s : Sort σ), A s <~> B s]. Let [u : Symbol σ]
    be a function symbol. Since [f] is a homomorphism, the induced
    family of equivalences [e] satisfies [OpPreserving e (u^^A) (u^^B)].
    By [path_operations_equiv] above, we can then transport [u^^A] along
    the path [path_equiv_family e] and obtain a path to [u^^B]. *)

  Lemma path_operations_isomorphism (f : ∀ s, A s → B s)
    `{IsIsomorphism σ A B f} (u : Symbol σ)
    : transport (λ C : Carriers σ, Operation C (σ u))
        (path_equiv_family (equiv_isomorphism f)) (u^^A)
      = u^^B.
  Proof.
    by apply path_operations_equiv.
  Defined.

(** If there is an isomorphism [f : ∀ s, A s → B s] then [A = B]. *)

  Theorem path_isomorphism (f : ∀ s, A s → B s) `{IsIsomorphism σ A B f}
    : A = B.
  Proof.
    apply (path_algebra _ _ (path_equiv_family (equiv_isomorphism f))).
(* Make the last part abstract because it relies on [path_operations_equiv],
   which is opaque. In cases where the involved algebras are set algebras,
   then this part is a mere proposition. *)
    abstract (
      funext u;
      exact (transport_forall_constant _ _ u
             @ path_operations_isomorphism f u)).
  Defined.
End path_isomorphism.


From Hammer Require Import Hammer.

Set Implicit Arguments.

Require Export Classical.
Require Export Description.
Require Import ChoiceFacts.

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

Theorem excluded_middle_informative : forall P:Prop, {P} + {~ P}.
Proof. hammer_hook "ClassicalDescription" "ClassicalDescription.excluded_middle_informative".
apply
(constructive_definite_descr_excluded_middle
constructive_definite_description classic).
Qed.

Theorem classical_definite_description :
forall (A : Type) (P : A->Prop), inhabited A ->
{ x : A | (exists! x : A, P x) -> P x }.
Proof. hammer_hook "ClassicalDescription" "ClassicalDescription.classical_definite_description".
intros A P i.
destruct (excluded_middle_informative (exists! x, P x)) as [Hex|HnonP].
apply constructive_definite_description with (P:= fun x => (exists! x : A, P x) -> P x).
destruct Hex as (x,(Hx,Huni)).
exists x; split.
intros _; exact Hx.
firstorder.
exists i; tauto.
Qed.

Definition iota (A : Type) (i:inhabited A) (P : A->Prop) : A
:= proj1_sig (classical_definite_description P i).

Definition iota_spec (A : Type) (i:inhabited A) (P : A->Prop) :
(exists! x:A, P x) -> P (iota i P)
:= proj2_sig (classical_definite_description P i).

Theorem dependent_unique_choice :
forall (A:Type) (B:A -> Type) (R:forall x:A, B x -> Prop),
(forall x:A, exists! y : B x, R x y) ->
(exists f : (forall x:A, B x), forall x:A, R x (f x)).
Proof. hammer_hook "ClassicalDescription" "ClassicalDescription.dependent_unique_choice".
intros A B R H.
assert (Hexuni:forall x, exists! y, R x y).
intro x. apply H.
exists (fun x => proj1_sig (constructive_definite_description (R x) (Hexuni x))).
intro x.
apply (proj2_sig (constructive_definite_description (R x) (Hexuni x))).
Qed.

Theorem unique_choice :
forall (A B:Type) (R:A -> B -> Prop),
(forall x:A,  exists! y : B, R x y) ->
(exists f : A -> B, forall x:A, R x (f x)).
Proof. hammer_hook "ClassicalDescription" "ClassicalDescription.unique_choice".
intros A B.
apply dependent_unique_choice with (B:=fun _:A => B).
Qed.

Unset Implicit Arguments.

Definition dependent_description := dependent_unique_choice.
Definition description := unique_choice.


Load LFindLoad.
From lfind Require Import LFind.
Require Import Arith.

                    From adtind Require Import goal82.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons Zero Nil).
Definition lfind_example_2  := ( Cons Zero (Cons Zero (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_3  := ( Cons Zero Nil).
Definition lfind_example_4  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_5  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_6  := ( Cons Zero Nil).
Definition lfind_example_7  := ( Cons Zero Nil).
Definition lfind_example_8  := ( Cons Zero         (Cons Zero            (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ Zero) Nil)))).
Definition lfind_example_9  := ( Cons Zero Nil).
Definition lfind_example_10  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_11  := ( Cons (Succ (Succ Zero)) (Cons (Succ (Succ (Succ Zero))) Nil)).
Definition lfind_example_12  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_13  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_14  := ( Cons Zero Nil).
Definition lfind_example_15  := ( Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil))).
Definition lfind_example_16  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_17  := ( Cons (Succ Zero) Nil).
Definition lfind_example_18  := ( Cons (Succ (Succ (Succ Zero)))         (Cons (Succ (Succ Zero)) (Cons Zero Nil))).
Definition lfind_example_19  := ( Cons (Succ Zero) Nil).
Definition lfind_example_20  := ( Cons Zero (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero Nil)))).
Definition lfind_example_21  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_22  := ( Cons Zero         (Cons Zero            (Cons (Succ (Succ (Succ (Succ (Succ Zero)))))               (Cons Zero (Cons Zero Nil))))).
Definition lfind_example_23  := ( Cons (Succ Zero) Nil).
Definition lfind_example_24  := ( Cons (Succ Zero) Nil).
Definition lfind_example_25  := ( Cons Zero         (Cons (Succ Zero)            (Cons (Succ Zero)               (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))))).
Definition lfind_example_26  := ( Cons (Succ Zero) (Cons (Succ Zero) Nil)).
Definition lfind_example_27  := ( Cons (Succ Zero) Nil).
Definition lfind_example_28  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_29  := ( Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil)).
Definition lfind_example_30  := ( Cons (Succ (Succ Zero)) (Cons Zero Nil)).
Definition lfind_example_31  := ( Cons (Succ (Succ (Succ Zero))) Nil).
Definition lfind_example_32  := ( Cons Zero (Cons (Succ Zero) (Cons Zero (Cons (Succ Zero) Nil)))).
Definition lfind_example_33  := ( Cons Zero Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal82_theorem0_74_rev_append/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 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 lfind_example_26 lfind_example_27 lfind_example_28 lfind_example_29 lfind_example_30 lfind_example_31 lfind_example_32 lfind_example_33 .


(** ** Enumerability *)

(** This file contains definition and facts regarding synthetic enumerability
    from the Coq Library of Undecidability Proofs. *)

Require Import Util.
Require Import ListLib.
Require Import Decidable.

Require Import ConstructiveEpsilon.
Require Import List Lia.
Import ListNotations.

Definition enumerator {X} (f : nat -> option X) (P : X -> Prop) : Prop := forall x, P x <-> exists n, f n = Some x.
Definition enumerable {X} (P : X -> Prop) : Prop := exists f : nat -> option X, enumerator f P.
Definition enumerator__T' X f := forall x : X, exists n : nat, f n = Some x.
Notation enumerator__T f X := (enumerator__T' X f).
Definition enumerable__T X := exists f : nat -> option X, enumerator__T f X.

Definition list_enumerator__T' X f := forall x : X, exists n : nat, In x (f n).
Notation list_enumerator__T f X := (list_enumerator__T' X f).
Definition list_enumerable__T X := exists f : nat -> list X, list_enumerator__T f X.
Definition inf_list_enumerable__T X := { f : nat -> list X | list_enumerator__T f X }.

(** My Lemmas *)

Lemma enumerable_ext X (p1 p2 : X -> Prop) :
  (forall x, p1 x <-> p2 x) -> enumerable p1 -> enumerable p2.
Proof.
  intros H [f Hf]. exists f. firstorder.
Qed.

Lemma enumerable_conj X (p q : X -> Prop) :
  eq_dec X -> enumerable p -> enumerable q -> enumerable (fun x => p x /\ q x).
Proof.
  intros EX [f Ef] [g Eg].
  exists (fun n => match f (pi1 n) with
                    | Some x => match g (pi2 n) with
                                 |  Some x' => if EX x x' then Some x else None
                                 | _ => None
                                 end
                    | _ => None
                    end).
  intros x. split.
  - intros [H1 H2]. specialize (Ef x) as [Ef _]; specialize (Eg x) as [Eg _].
    destruct (Ef H1) as [n1 Hf], (Eg H2) as [n2 Hg].
    exists (embed (n1, n2)). rewrite pi1_correct, Hf, pi2_correct, Hg.
    destruct (EX x x); congruence.
  - intros [n H]. split.
    + apply Ef. exists (pi1 n). destruct (f (pi1 n)), (g (pi2 n)).
      destruct (EX x0 x1); congruence. all: congruence.
    + apply Eg. exists (pi2 n). destruct (f (pi1 n)), (g (pi2 n)).
      destruct (EX x0 x1); congruence. all: congruence.
Qed.

Lemma enumerable_decidable X (p : X -> Prop) :
  enumerable__T X -> decidable p -> enumerable p.
Proof.
  intros [f Hf] [g Hg].
  exists (fun n => match f n with Some x => if g x then Some x else None | None => None end).
  intros x. split.
  - intros H%Hg. destruct (Hf x) as [n H1]. exists n. now rewrite H1, H.
  - intros [n H]. destruct f. destruct g eqn:H1. apply Hg. all: congruence.
Qed.

Lemma enumerable__T_pair X Y :
  enumerable__T X -> enumerable__T Y -> enumerable__T (X * Y).
Proof.
  intros [f Hf] [g Hg].
  exists (fun n => match f (pi1 n), g (pi2 n) with
                    | Some x, Some y => Some (x, y)
                    | _, _ => None
                   end).
  intros [x y]. specialize (Hf x) as [n1 H1]; specialize (Hg y) as [n2 H2].
  exists (embed (n1, n2)). now rewrite pi1_correct, H1, pi2_correct, H2.
Qed.

Lemma enumerable_comp X Y (p : Y -> Prop) (f : X -> Y) :
  enumerable p -> enumerable__T X -> eq_dec Y -> enumerable (fun x => p (f x)).
Proof.
  intros [g Hg] [h Hh] E.
  exists (fun n => match g (pi1 n), h (pi2 n) with
                    | Some y, Some x => if E (f x) y then Some x else None
                    | _, _ => None
                   end).
  intros x. split.
  - intros H. specialize (Hg (f x)) as [Hg _]; specialize (Hh x) as [n2 Hh].
    specialize (Hg H) as [n1 Hg]. exists (embed (n1, n2)).
    rewrite pi1_correct, Hg, pi2_correct, Hh. destruct (E (f x)); congruence.
  - intros [n H]. destruct (g (pi1 n)) eqn:H1, (h (pi2 n)) eqn:H2.
    destruct (E (f x0) y) eqn:H3. all: try congruence. apply Hg. exists (pi1 n).
    congruence.
Qed.

Theorem weakPost X (p : X -> Prop) :
  eq_dec X -> ldecidable p -> enumerable p -> enumerable (fun x => ~ p x) -> decidable p.
Proof.
  intros E Hl [f Hf] [g Hg].
  apply decidable_if. intros x.
  assert (exists n, f n = Some x \/ g n = Some x) as H by (destruct (Hl x); firstorder).
  assert (forall n, dec (f n = Some x)) as H1. {
    intros. destruct (f n). destruct (E x0 x) as [->|].
    now left. all: right; congruence. }
  assert (forall n, dec (g n = Some x)) as H2. {
    intros. destruct (g n). destruct (E x0 x) as [->|].
    now left. all: right; congruence. }
  edestruct constructive_indefinite_ground_description_nat_Acc as [n H'].
  2: apply H.
  - intros n. destruct (H1 n) as [->|], (H2 n) as [->|]. 1-2: tauto.
    now left; right. right. intros []; firstorder.
  - destruct (H1 n). firstorder. destruct (H2 n); firstorder.
Qed.

Theorem Post :
  MP <-> (forall X (p : X -> Prop), eq_dec X -> enumerable p -> enumerable (fun x => ~ p x) -> decidable p).
Proof.
  split.
  - intros mp X p E H1 H2. apply weakPost; try easy.
    destruct H1 as [f Hf], H2 as [g Hg].
    intros x. specialize (Hf x); specialize (Hg x).
    pose (h n := match f n, g n with
                  | Some x', None => if E x x' then true else false
                  | None, Some x' => if E x x' then true else false
                  | Some x1, Some x2 => if E x x1 then true else
                                        if E x x2 then true else false
                  | None, None => false
                end).
    enough (exists n, h n = true) as [n H]. {
      unfold h in H. destruct (f n) eqn:H1, (g n) eqn:H2; try congruence;
      destruct (E x x0) as [<-|]; try congruence.
      2: destruct (E x x1) as [<-|]; try congruence.
      all: firstorder. }
    apply mp. intros H.
    assert (~~(p x \/ ~ p x)) as H1 by tauto. apply H1; clear H1. intros [H1|H1].
    + apply H. apply Hf in H1 as [n H1]. exists n. unfold h.
      destruct (f n) eqn:H2, (g n) eqn:H3; try congruence;
      destruct (E x x0); congruence.
    + apply H. apply Hg in H1 as [n H1]. exists n. unfold h.
      destruct (f n) eqn:H2, (g n) eqn:H3; try congruence;
      destruct (E x x0); try congruence. destruct (E x x1); congruence.
  - intros H1 f H2. enough (decidable (fun _ : nat => tsat f)) as [d H].
    { specialize (H 0). destruct (d 0). tauto. exfalso. apply H2. now intros ?%H. }
    apply H1.
    + unfold eq_dec, dec. decide equality.
    + exists (fun n => if f (pi1 n) then Some (pi2 n) else None). intros n. split.
      * intros [n' H]. exists (embed (n', n)). now rewrite pi1_correct, pi2_correct, H.
      * intros [n' H]. destruct (f (pi1 n')) eqn:H3. now exists (pi1 n'). easy.
    + exists (fun _ => None). intros n. split. now intros H. now intros [_ ?].
Qed.

(** List enumerator Lemmas *)

Definition cumulative {X} (L: nat -> list X) :=
  forall n, exists A, L (S n) = L n ++ A.
Global Hint Extern 0 (cumulative _) => intros ?; cbn; eauto : core.

Lemma cum_ge {X} {L: nat -> list X} {n m} :
  cumulative L -> m >= n -> exists A, L m = L n ++ A.
Proof.
  induction 2 as [|m _ IH].
  - exists nil. now rewrite app_nil_r.
  - destruct (H m) as (A&->), IH as [B ->].
    exists (B ++ A). now rewrite app_assoc.
Qed.

Lemma cum_ge' {X} {L: nat -> list X} {x n m} :
  cumulative L -> In x (L n) -> m >= n -> In x (L m).
Proof.
  intros ? H [A ->] % (cum_ge (L := L)). apply in_app_iff. eauto. eauto.
Qed.

Definition list_enumerator {X} (L: nat -> list X) (p : X -> Prop) :=
  forall x, p x <-> exists m, In x (L m).
Definition list_enumerable {X} (p : X -> Prop) :=
  exists L, list_enumerator L p.

Section enumerator_list_enumerator.

  Variable X : Type.
  Variable p : X -> Prop.
  Variables (e : nat -> option X).

  Let T (n : nat) : list X := match e n with Some x => [x] | None => [] end.

  Lemma enumerator_to_list_enumerator : forall x, (exists n, e n = Some x) <-> (exists n, In x (T n)).
  Proof.
    split; intros [n H].
    - exists n. unfold T. rewrite H. firstorder.
    - unfold T in *. destruct (e n) eqn:E. inversion H; subst. eauto. inversion H0. inversion H.
  Qed.
End enumerator_list_enumerator.

Lemma enumerable_list_enumerable {X} {p : X -> Prop} :
  enumerable p -> list_enumerable p.
Proof.
  intros [f Hf]. eexists.
  unfold list_enumerator.
  intros x. rewrite <- enumerator_to_list_enumerator.
  eapply Hf.
Qed.

Lemma enumerable__T_list_enumerable {X} :
  enumerable__T X -> list_enumerable__T X.
Proof.
  intros [f Hf]. eexists.
  unfold list_enumerator.
  intros x. rewrite <- enumerator_to_list_enumerator.
  eapply Hf.
Qed.

Section enumerator_list_enumerator.

  Variable X : Type.
  Variables (T : nat -> list X).

  Let e (n : nat) : option X :=
    let (n, m) := unembed n in
    nth_error (T n) m.

  Lemma list_enumerator_to_enumerator : forall x, (exists n, e n = Some x) <-> (exists n, In x (T n)).
  Proof.
    split; intros [k H].
    - unfold e in *.
      destruct (unembed k) as (n, m).
      exists n. eapply (nth_error_In _ _ H).
    - unfold e in *.
      eapply In_nth_error in H as [m].
      exists (embed (k, m)). now rewrite unembed_embed, H.
  Qed.
End enumerator_list_enumerator.

Lemma list_enumerator_enumerator {X} {p : X -> Prop} {T} :
  list_enumerator T p -> enumerator (fun n => let (n, m) := unembed n in
    nth_error (T n) m) p.
Proof.
  unfold list_enumerator.
  intros H x. rewrite list_enumerator_to_enumerator. eauto.
Qed.

Lemma list_enumerable_enumerable {X} {p : X -> Prop} :
  list_enumerable p -> enumerable p.
Proof.
  intros [T HT]. eexists.
  unfold list_enumerator.
  intros x. rewrite list_enumerator_to_enumerator.
  eapply HT.
Qed.

Lemma list_enumerable__T_enumerable {X} :
  list_enumerable__T X -> enumerable__T X.
Proof.
  intros [T HT]. eexists.
  unfold list_enumerator.
  intros x. rewrite list_enumerator_to_enumerator.
  eapply HT.
Qed.

Lemma enum_enum {X} {p : X -> Prop} :
  enumerable p <-> list_enumerable p.
Proof.
  split.
  apply enumerable_list_enumerable.
  apply list_enumerable_enumerable.
Qed.

Lemma enum_enumT {X} :
  enumerable__T X <-> list_enumerable__T X.
Proof.
  split.
  eapply enumerable__T_list_enumerable.
  eapply list_enumerable__T_enumerable.
Qed.

Definition to_cumul {X} (L : nat -> list X) := fix f n :=
  match n with 0 => [] | S n => f n ++ L n end.

Lemma to_cumul_cumulative {X} (L : nat -> list X) :
  cumulative (to_cumul L).
Proof.
  eauto.
Qed.

Lemma to_cumul_spec {X} (L : nat -> list X) x :
  (exists n, In x (L n)) <-> exists n, In x (to_cumul L n).
Proof.
  split.
  - intros [n H].
    exists (S n). cbn. eapply in_app_iff. eauto.
  - intros [n H].
    induction n; cbn in *.
    + inversion H.
    + eapply in_app_iff in H as [H | H]; eauto.
Qed.

Lemma cumul_In {X} (L : nat -> list X) x n :
  In x (L n) -> In x (to_cumul L (S n)).
Proof.
  intros H. cbn. eapply in_app_iff. eauto.
Qed.

Lemma In_cumul {X} (L : nat -> list X) x n :
  In x (to_cumul L n) -> exists n, In x (L n).
Proof.
  intros H. eapply to_cumul_spec. eauto.
Qed.

Global Hint Resolve cumul_In In_cumul : core.

Lemma list_enumerator_to_cumul {X} {p : X -> Prop} {L} :
  list_enumerator L p -> list_enumerator (to_cumul L) p.
Proof.
  unfold list_enumerator.
  intros. rewrite H.
  eapply to_cumul_spec.
Qed.

Lemma cumul_spec__T {X} {L} :
  list_enumerator__T L X -> list_enumerator__T (to_cumul L) X.
Proof.
  unfold list_enumerator__T.
  intros. now rewrite <- to_cumul_spec.
Qed.

Lemma cumul_spec {X} {L} {p : X -> Prop} :
  list_enumerator L p -> list_enumerator (to_cumul L) p.
Proof.
  unfold list_enumerator.
  intros. now rewrite <- to_cumul_spec.
Qed.

Notation cumul := (to_cumul).

Section L_list_def.
  Context {X : Type}.
  Variable (L : nat -> list X).

Fixpoint L_list (n : nat) : list (list X) :=
  match n
  with
  | 0 => [ [] ]
  | S n => L_list n ++ [ x :: L | (x,L) ∈ (cumul L n × L_list n) ]
  end.
End L_list_def.

Lemma L_list_cumulative {X} L : cumulative (@L_list X L).
Proof.
  intros ?; cbn; eauto.
Qed.

Lemma enumerator__T_list {X} L :
  list_enumerator__T L X -> list_enumerator__T (L_list L) (list X).
Proof.
  intros H l.
  induction l.
  - exists 0. cbn. eauto.
  - destruct IHl as [n IH].
    destruct (cumul_spec__T H a) as [m ?].
    exists (1 + n + m). cbn. intros. in_app 2.
    in_collect (a,l).
    all: eapply cum_ge'; eauto using L_list_cumulative; lia.
Qed.

Lemma enumerable_list {X} : list_enumerable__T X -> list_enumerable__T (list X).
Proof.
  intros [L H].
  eexists. now eapply enumerator__T_list.
Qed.
Global Hint Extern 4 => match goal with [H : list_enumerator _ ?p |- ?p _ ] => eapply H end : core.

(* Lemma enumerable_conj X (p q : X -> Prop) :
  discrete X -> enumerable p -> enumerable q -> enumerable (fun x => p x /\ q x).
Proof.
  intros [] % discrete_iff [Lp] % enumerable_list_enumerable [Lq] % enumerable_list_enumerable.
  eapply list_enumerable_enumerable.
  exists (fix f n := match n with 0 => [] | S n => f n ++ [ x | x ∈ cumul Lp n, x el cumul Lq n] end).
  intros. split.
  + intros []. eapply (cumul_spec H) in H1 as [m1]. eapply (cumul_spec H0) in H2 as [m2].
    exists (1 + m1 + m2). cbn. in_app 2. in_collect x.
    eapply cum_ge'; eauto. lia.
    eapply cum_ge'; eauto. lia.
  + intros [m]. induction m.
    * inv H1.
    * inv_collect; eauto.
Qed. *)

Lemma projection X Y (p : X * Y -> Prop) :
  enumerable p -> enumerable (fun x => exists y, p (x,y)).
Proof.
  intros [f].
  exists (fun n => match f n with Some (x, y) => Some x | None => None end).
  intros; split.
  - intros [y ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
  - intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inversion H0.
    exists y. eapply H. rewrite <- H2. eauto.
Qed.

Lemma projection' X Y (p : X * Y -> Prop) :
  enumerable p -> enumerable (fun y => exists x, p (x,y)).
Proof.
  intros [f].
  exists (fun n => match f n with Some (x, y) => Some y | None => None end).
  intros y; split.
  - intros [x ?]. eapply H in H0 as [n]. exists n. now rewrite H0.
  - intros [n ?]. destruct (f n) as [ [] | ] eqn:E; inversion H0.
    exists x. eapply H. rewrite <- H2. eauto.
Qed.

Definition L_T {X : Type} {f : nat -> list X} {H : list_enumerator__T f X} : nat -> list X.
Proof.
  exact (cumul f).
Defined.
Arguments L_T _ {_ _} _, {_ _ _}.

Global Hint Unfold L_T : core.
Global Hint Resolve cumul_In : core.

Existing Class list_enumerator__T'.
Existing Class enumerator__T'.

Definition el_T {X} {f} `{list_enumerator__T f X} : list_enumerator__T L_T X.
Proof.
  now eapply cumul_spec__T.
Defined.
Existing Instance enumerator__T_list.

Instance enumerator__T_to_list {X} {f} :
  list_enumerator__T f X -> enumerator__T (fun n => let (n, m) := unembed n in nth_error (f n) m) X | 100.
Proof.
  intros H x. eapply list_enumerator_to_enumerator in H. exact H.
Qed.

Instance enumerator__T_of_list {X} {f} :
  enumerator__T f X -> list_enumerator__T (fun n => match f n with Some x => [x] | None => [] end) X | 100.
Proof.
  intros H x. eapply enumerator_to_list_enumerator. eauto.
Qed.

Existing Class inf_list_enumerable__T.

Instance inf_to_enumerator {X} :
  forall H : inf_list_enumerable__T X, list_enumerator__T (proj1_sig H) X | 100.
Proof.
  intros [? H]. eapply H.
Defined.

Global Hint Unfold enumerable list_enumerable : core.

Global Hint Resolve enumerable_list_enumerable
     list_enumerable_enumerable : core.

Lemma enumerable_enum {X} {p : X -> Prop} :
  enumerable p <-> list_enumerable p.
Proof.
  split; eauto.
Qed.

Lemma enumerable_disj X (p q : X -> Prop) :
enumerable p -> enumerable q -> enumerable (fun x => p x \/ q x).
Proof.
  intros [Lp H] % enumerable_enum [Lq H0] % enumerable_enum.
  eapply enumerable_enum.
  exists (fix f n := match n with 0 => [] | S n => f n ++ [ x | x ∈ Lp n] ++ [ y | y ∈ Lq n] end).
  intros x. split.
  - intros [H1 | H1].
    * eapply H in H1 as [m]. exists (1 + m). cbn. in_app 2. in_collect x. eauto.
    * eapply H0 in H1 as [m]. exists (1 + m). cbn. in_app 3. in_collect x. eauto.
  - intros [m]. induction m.
    * inversion H1.
    * inv_collect;
      unfold list_enumerator in *; firstorder.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


(***************************************************************************)
(*   This is part of FA_Completeness, it is distributed under the terms    *)
(*           of the GNU Lesser General Public License version 3            *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*           Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.              *)
(***************************************************************************)

Require Import t4.
Require Export R_sup.

Definition AccumulationPoint e E :=
  ∀ x, x > O -> ∃ y, y ∈ (e|-x) /\ y ∈ E /\ y <> e.
Definition AccumulationPoint' e E :=
  ∀ x, x > O -> ~ fin /{ z | z ∈ (e|-x) /\ z ∈ E /}.

Inductive Relcond A e x y :=
  | Relcond_intro : x ∈ A -> |x - e| = y -> Relcond A e x y.

Corollary Cor_acc : ∀ e E, AccumulationPoint e E ->
  AccumulationPoint' e E.
Proof.
  assert (∀ e E, (AccumulationPoint e E) ->
  ∀ b, b > O -> ~ fin /{ z | z ∈ (e|-b) /\ z ∈ E /\ z <> e /}).
  { intros; red in H; intro.
    apply H in H0.
    set (R1:=/{ z | z ∈ (e|-b) /\ z ∈ E /\ z <> e /}).
    set (R:=/{ z | ∃ r, r ∈ R1 /\ r <> e /\ z = | r - e | /}).
    assert (Surjection R1 R (Relcond R1 e)).
    { repeat split; intros; try apply conj; try red; intros.
      - destruct H2, H3; auto. subst y; auto.
      - exists (|x - e|). constructor; auto.
      - destruct H2, H2, H2, H3; exists x; constructor; auto.
      - destruct H2, i, H2, H2; tauto.
      - destruct H2, i, H2, H2; tauto.
      - destruct H2, i; tauto.
      - destruct H2, i; tauto.
      - destruct H2, i, H2, H2, H2, H3; exists x; repeat split; auto. }
    assert (fin R).
    { destruct H1 as [N [f H1]]; pose proof (comp H1 H2); red; eauto. }
    assert (No_Empty R).
    { destruct H0, H0, H0, H0, H4.
      red; exists (|x - e|); constructor; exists x; repeat split; auto. }
    destruct (FinMin _ H3 H4) as [m H5], H5, H5, H5, H5, H7.
    pose proof (Ab8' _ _ H7); apply H in H9.
    destruct H9, H9, H9, H9, H10, H5, H5, H5, H5.
    subst m; pose proof (conj H5 H14).
    apply Ab1'' in H8; pose proof (conj H9 H11). apply Ab1'' in H15.
    assert (|x0 - e| ∈ R).
    { constructor; exists x0; split; auto; constructor; split; auto.
      constructor; apply Ab1''; eapply Theorem171; eauto. }
    apply H6 in H16; LEGR H16 H15. }
  red; intros; intro. eapply H in H1; eauto; apply H1.
  eapply Fin_Included; eauto.
  red; intros; destruct H3; constructor; tauto.
Qed.

Inductive fin1 (r :Real) x y :=
  | fin1_intro : ILT_N x 2 -> y = r -> fin1 r x y.

Corollary Cor_acc' : ∀ e E, AccumulationPoint' e E
  -> AccumulationPoint e E.
Proof.
  intros; red; intros; pose proof H0; apply H in H0; Absurd;
  elim H0. destruct (classic (e ∈ E)) as [H3 | H3].
  - exists 2, (fin1 e); repeat apply conj; try red; intros.
    + destruct H4, H5; subst y; auto.
    + destruct H4; exists e; constructor; auto.
    + destruct H4, H4; exists 1; constructor; auto.
      * apply Nlt_S_. * Absurd; elim H2; eauto.
    + destruct H4; constructor; auto.
    + destruct H4; constructor; subst y; split; auto.
      constructor; split; try apply Pl_R; auto.
      apply Theorem188_1 with (Θ:= x); Simpl_R; apply Pl_R; auto.
  - assert (/{ z | z∈(e|-x) /\ z∈E /} = /{ z | z∈(e|-x) /\ z∈E /\ z<>e /}).
    { apply ens_ext; split; intros; destruct H4; constructor.
      - destruct H4; split; [| split]; auto; intro; subst x0; tauto.
      - destruct H4, H5; auto. } rewrite H4.
     apply Fin_Empty; intro; destruct H5, H5; apply H2; eauto.
Qed.

Axiom constructive_indefinite_description :
  ∀ {A : Type} {P : A->Prop},
    (∃ x, P x) -> { x : A | P x }.

Definition Cid {A : Type} {P : A->Prop} (l: ∃ x, P x) :=
  constructive_indefinite_description l.

Inductive RRtoR A B x y : Prop :=
  | RRtoR_intro: x ∈ A -> y ∈ B -> y ∈ (Fst x | Snd x) ->
  RRtoR A B x y .

Theorem APT : ∀ E x y, x < y -> ~ fin E -> Bounddown_Ens x E ->
  Boundup_Ens y E -> ∃ e, AccumulationPoint e E.
Proof.
  assert (∀ E, ~ (∃ e, AccumulationPoint e E) ->
     ∀ z, ∃ δ, δ > O /\ (∀ w, w ∈ (z|-δ) /\ w ∈ E -> w = z)) as G.
  { intros; Absurd; elim H. exists z; red; intros.
    Absurd; elim H0. exists x; split; intros; auto.
    destruct H3; Absurd. elim H2; eauto. }
  intros; red in H1, H2; Absurd. pose proof (G E H3).
  set (Gete p :=(proj1_sig (Cid (H4 p))) ).
  assert (∀ x, Gete x > O).
  { intros; unfold Gete; destruct (Cid (H4 x0)); simpl proj1_sig; tauto. }
  assert (G1: ∀ x y, y > O -> x - y < x + y). { apply Pl_R'. }
  set (R:= /{ r | ∃ x, r = (rr (x-(Gete x)) (x+(Gete x)) (G1 x _ (H5 x))) /}).
  assert (OpenCover x y R).
  { red; split; auto; intros.
    exists (z|-(Gete z)); split; constructor; intros.
    - exists (rr (z-(Gete z)) (z+(Gete z)) (G1 z _ (H5 z))).
      split; simpl; auto; constructor; eauto.
    - split; try apply Pl_R; auto.
      apply Theorem188_1 with (Θ:=Gete z); Simpl_R; apply Pl_R; auto. }
  apply FinCoverT in H6; destruct H6 as [H6 [h1 H7]], H7, H8.
  set (g:=(RRtoR /{ z | z ∈ h1 /\
  (∃ r, r ∈ E /\ r ∈ (Fst z | Snd z))/} E)).
  assert (Surjection /{ z | z ∈ h1 /\
  (∃ r, r ∈ E /\ r ∈ (Fst z | Snd z))/} E g).
  { red; repeat split; try red; intros.
    - destruct H10, H10, H11, H11, H10, H11.
      apply H7 in H10; destruct H10, H10 as [r1 H10].
      clear H11; subst x0; simpl in *; unfold Gete in *.
      destruct (Cid (H4 r1)); simpl proj1_sig in *; destruct a.
      apply (Theorem165 _ r1 _); auto; symmetry; auto.
    - destruct H10, H10, H11 as [r [H11 H12]].
      exists r; constructor; auto.  constructor; split; auto; eauto.
    - assert (y0 ∈ [x | y]). { constructor; split; auto. }
      destruct H9; apply H12 in H11.
      destruct H11 as [R1 [H11 H13]], H11, H11 as [rr1 [H11 H14]].
      subst R1; destruct H13; pose proof H11.
      apply H7 in H11; destruct H11, H11 as [r1 H11].
      exists rr1; constructor; auto; constructor; auto.
      split; auto; exists y0; repeat split; tauto.
    - destruct H10, H10; tauto.
    - destruct H10; eauto. - destruct H10; auto. }
  assert (fin /{ z | z ∈ h1 /\ (∃ r, r ∈ E /\ r ∈ (Fst z | Snd z))/}).
  { apply Fin_Included with (B:=h1); auto.
    red; intros; destruct H11; tauto. }
  destruct H11 as [N [f H11]]; elim H0.
  pose proof (comp H11 H10). red. eauto.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List Permutation.

Require Import tacs rel_utils list_utils.

Require Import tree proof.

Require Import formula relevant_contract sequent_rules.
Require Import mini_HI mini_LI1 mini_LI2 sem_cut_adm.

Set Implicit Arguments.

Theorem LI1_cf_LI1 : LI1_cf_proof inc1 LI1_proof.
Proof.
  induction 1 as [ | | ? ? ? ? ? ? H | ? ? ? ? H | ? ? ? ? H ] using LI1_cf_proof_rect.
  apply LI1_rule_id.
  apply LI1_rule_r; trivial.
  apply LI1_rule_l with (1 := H); trivial.
  apply LI1_rule_cntr with (1 := H); trivial.
  apply LI1_rule_weak with (1 := H); trivial.
Qed.

Local Hint Resolve LI1_rule_id perm_skip perm_swap : core.

Local Notation "HI--" := HI_proof.
Local Notation "x 'LI1-' y" := (LI1_proof (x,y)) (at level 70, no associativity).
Local Notation "x 'LI1cf-' y" := (LI1_cf_proof (x,y)) (at level 70, no associativity).
Local Notation "x 'LI2-' y" := (LI2_proof (x,y)) (at level 70, no associativity).

Theorem HI_LI1 A : HI-- A -> nil LI1- A.
Proof.
  induction 1 as [ A | A B C | A B _ IH1 _ IH2 ].

  do 2 apply LI1_rule_r.
  apply LI1_rule_weak with (A::nil) B; auto.

  do 3 apply LI1_rule_r.
  apply LI1_rule_cntr with (A %> B :: A %> B %> C :: nil) A; auto.
  apply LI1_rule_l with (A :: nil) (A :: A %> B %> C :: nil) A B; simpl; auto.
  apply perm_trans with (2 := perm_swap _ _ _); auto.
  apply LI1_rule_l with (A :: nil) (B :: nil) A (B %> C); simpl; auto.
  apply perm_trans with (1 := perm_swap _ _ _); auto.
  apply perm_trans with (2 := perm_swap _ _ _); auto.
  apply LI1_rule_l with (B :: nil) (nil) B C; simpl; auto.

  apply LI1_rule_cut with (2 := IH2) (de := nil); auto.
  apply LI1_rule_cut with (2 := IH1) (de := A :: nil); auto.
  apply LI1_rule_l with (A :: nil) nil A B; simpl; auto.
Qed.

Section LI1_HI.

  Let LI1_HR_rec : forall s, LI1_proof s -> HI_proof (fst s %%> snd s).
  Proof.
    induction 1 as [
                   |
                   | ga de th A B C H1 H3 H4
                   | de th A B H1 H3
                   | de th A B H1 H3
                   | ga de th A B H1 H2 H3 ] using LI1_proof_rect; simpl in * |- *.

    (* rule_id *)

    apply HI_I.

    (* rule_r *)

    auto.

    (* rule_l *)

    apply Permutation_sym in H1.
    apply HI_proof_perm with (1 := H1).
    simpl; rewrite list_Form_to_Form_app.
    revert H4; apply HI_list_Form_to_Form_HI_proof.
    assert (B %> C :: A %> B :: ga ~p A %> B :: ga ++ B %> C :: nil) as H4.
      apply perm_trans with (1 := perm_swap _ _ _), perm_skip,
            Permutation_app_comm with (l := _ :: nil).
    apply HI_proof_perm with (a := C) in H4.
    simpl in H4; rewrite list_Form_to_Form_app in H4; auto.
    simpl; revert H3; apply HI_list_Form_to_Form_HI_proof.
    clear H1 H4.
    generalize (HI_B A B C).
    apply HI_proof_perm with (l := _ :: _ :: _ :: nil)
                             (m := _ :: _ :: _ :: nil).
    apply perm_trans with (1 := perm_swap _ _ _),
          perm_trans with (2 := perm_swap _ _ _); auto.

    (* rule_cntr *)

    apply HI_proof_perm with (1 := Permutation_sym H1).
    revert H3; apply HI_proof_contract.

    (* rule_weak *)

    apply HI_proof_perm with (1 := Permutation_sym H1).
    revert H3; apply HI_proof_weak.

    (* rule_cut *)

    apply Permutation_sym in H1.
    apply HI_proof_perm with (1 := H1).
    simpl; rewrite list_Form_to_Form_app.
    revert H3; apply HI_list_Form_to_Form_HI_proof.
    assert (A %> B :: ga ~p ga ++ A %> B :: nil) as E.
      apply Permutation_sym, Permutation_app_comm.
    apply HI_proof_perm with (a := B) in E.
    simpl in E; rewrite list_Form_to_Form_app in E; auto.
    simpl; revert H2; apply HI_list_Form_to_Form_HI_proof.
    apply in_HI_MP with (1 := HI_C _ _ _), HI_I.
  Qed.

  Theorem LI1_HI A : nil LI1- A -> HI-- A.
  Proof. apply LI1_HR_rec. Qed.

  Theorem LI1_cf_HI A : nil LI1cf- A -> HI-- A.
  Proof.
    intro; apply LI1_HI, LI1_cf_LI1; auto.
  Qed.

End LI1_HI.

Section LI2_HI.

  Let LI2_imp_HI_rec : forall s, LI2_proof s -> HI_proof (fst s %%> snd s).
  Proof.
    induction 1 as [ | | ga th A B C H1 H2 H3 ] using LI2_proof_rect.

    simpl.
    apply HI_proof_perm with (A::ga++de).
    apply Permutation_cons_app; auto.
    simpl; apply HI_proof_weakening, HI_I.

    auto.

    simpl in *.
    apply HI_proof_perm with (1 := Permutation_sym H1).
    simpl; clear th H1.
    apply HI_list_Form_to_Form_HI_proof with (1 := HI_SI _ _) in H2.
    apply HI_list_Form_to_Form_HI_proof with (1 := HI_C _ _ _) in H3.
    revert H2; apply HI_list_MP.
    revert H3; apply HI_list_Form_to_Form_HI_proof.
    apply in_HI_S.
  Qed.

  Theorem LI2_HI A : nil LI2- A -> HI-- A.
  Proof. apply LI2_imp_HI_rec. Qed.

End LI2_HI.

Theorem LI1_cf_LI2 : LI1_cf_bprovable inc2 LI2_bprovable.
Proof.
  intros n c.
  induction 1 as [ n A
                 | n ga A B H1
                 | n ga de th A B C H1 H2 H3
                 | n ga th A B H1 H2
                 | n ga th A B H1 H2 ] using LI1_cf_bprovable_ind.

  apply LI2_b_ax with (l := nil).

  apply LI2_b_imp_r; auto.

  apply LI2_b_imp_l with (ga++de) A B; auto.
  revert H3; apply LI2_incl.
  intros ? [ ? | ? ]; right; [ left | right]; auto; apply in_or_app; auto.
  revert H2; apply LI2_incl.
  intros ? ?; right; apply in_or_app; auto.

  apply LI2_bprovable_mono with n; auto.
  revert H2; apply LI2_incl.
  intros d Hd; apply Permutation_in with (1 := Permutation_sym H1).
  destruct Hd as [ ? | [ ? | ? ] ]; [ left | left | right ]; auto.

  apply LI2_bprovable_mono with n; auto.
  revert H2; apply LI2_incl.
  intros d Hd; apply Permutation_in with (1 := Permutation_sym H1).
  right; auto.
Qed.

Theorem HI_LI2 A : HI-- A -> exists t, proof LI2_rules (nil,A) t.
Proof.
  intros H.
  apply HI_LI1, inhabits, LI1_cut_admissibility in H.
  destruct H as (n & t & Ht).
  destruct (@LI1_cf_LI2 n (nil,A)) as (t' & Ht').
  exists t; auto.
  exists t'; apply Ht'.
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.


Require Import compcert.lib.Coqlib.
Require Import List. Import ListNotations.
Require Import VST.floyd.functional_base.
Require Import hmacdrbg.DRBG_functions.
Require Import hmacdrbg.HMAC_DRBG_algorithms.

Require Import sha.general_lemmas.
Require Import sha.hmac_pure_lemmas.

Lemma HMAC_DRBG_generate_helper_Z_any_prop_fst:
  forall (P: list byte -> Prop) HMAC key v z,
    0 <= z ->
    P v ->
    (forall x y, P (HMAC x y)) ->
    P (fst (HMAC_DRBG_generate_helper_Z HMAC key v z)).
Proof.
  intros P HMAC key v z Hz Hv H.
  remember (z/32) as n.
  rewrite <- (Z2Nat.id n) in Heqn by (subst; apply (Z_div_pos z 32); lia).
  generalize dependent z.
  induction (Z.to_nat n); intros.
  {
    rewrite (Z_div_mod_eq_full z 32).
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    rewrite <- Heqn.
    change (Z.of_nat 0) with 0.
    change (32 * 0 + z mod 32) with (z mod 32).
    change (Z.of_nat 32) with 32.
    remember (0 >=? z mod 32) as zero_geb_z; destruct zero_geb_z.
    auto.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    remember (0 >=? z mod 32 - 32) as zero_geb_z_minus_32; destruct zero_geb_z_minus_32.
    apply H.
    {
      rewrite Z.geb_leb in Heqzero_geb_z_minus_32.
      symmetry in Heqzero_geb_z_minus_32; apply Z.leb_gt in Heqzero_geb_z_minus_32.
      pose proof (Z_mod_lt z 32); lia.
    }
  }
  {
    rewrite (Z_div_mod_eq_full z 32).
    rewrite <- Heqn.
    assert (Hn: 32 * Z.of_nat (S n0) + z mod 32 = 32 * Z.of_nat n0 + z mod 32 + 32).
    {
      rewrite Nat2Z.inj_succ.
      rewrite <- Zmult_succ_r_reverse.
      lia.
    }
    rewrite Hn.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    destruct (0 >=? 32 * Z.of_nat n0 + z mod 32 + 32); auto.
    change (Z.of_nat 32) with 32.
    replace (32 * Z.of_nat n0 + z mod 32 + 32 - 32) with (32 * Z.of_nat n0 + z mod 32) by lia.
    remember (HMAC_DRBG_generate_helper_Z HMAC key v
               (32 * Z.of_nat n0 + z mod 32)) as result; destruct result.
    simpl.
    apply H.
  }
Qed.

Lemma HMAC_DRBG_generate_helper_Z_incremental_fst:
  forall HMAC key v z v',
    0 <= z ->
    v' = fst (HMAC_DRBG_generate_helper_Z HMAC key v z) ->
    HMAC v' key = fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32)).
Proof.
  intros HMAC key v z v' Hz H.
  remember (z/32) as n.
  rewrite <- (Z2Nat.id n) in Heqn by (subst; apply (Z_div_pos z 32); lia).
  assert (Hf: 0 >=? z + 32 = false).
  {
    assert (0 < z + 32) by lia.
    rewrite Z.geb_leb.
    apply Z.leb_gt; lia.
  }
  rewrite HMAC_DRBG_generate_helper_Z_equation.
  rewrite Hf.
  remember (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32)) as result; destruct result.
  simpl.
  replace l with (fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
  change (Z.of_nat 32) with 32.
  replace (z + 32 - 32) with z by lia.
  rewrite H.
  reflexivity.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_incremental_snd:
  forall HMAC key v z v',
    0 <= z ->
    v' = fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32)) ->
    snd (HMAC_DRBG_generate_helper_Z HMAC key v z) ++ v' = snd (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32)).
Proof.
  intros HMAC key v z v' Hz H.
  remember (z/32) as n.
  rewrite <- (Z2Nat.id n) in Heqn by (subst; apply (Z_div_pos z 32); lia).
  assert (Hf: 0 >=? z + 32 = false).
  {
    assert (0 < z + 32) by lia.
    rewrite Z.geb_leb.
    apply Z.leb_gt; lia.
  }
  remember (HMAC_DRBG_generate_helper_Z HMAC key v z) as saved;
    rewrite HMAC_DRBG_generate_helper_Z_equation; subst saved.
  rewrite Hf.
  remember (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32)) as result; destruct result.
  simpl.
  replace l with (fst (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
  replace l0 with (snd (HMAC_DRBG_generate_helper_Z HMAC key v (z + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
  change (Z.of_nat 32) with 32.
  replace (z + 32 - 32) with z by lia.
  rewrite H.
  erewrite <- HMAC_DRBG_generate_helper_Z_incremental_fst; eauto.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_Zlength_fst:
  forall HMAC key v z,
    0 <= z ->
    Zlength v = 32 ->
    (forall x y, Zlength (HMAC x y) = 32) ->
    Zlength (fst (HMAC_DRBG_generate_helper_Z HMAC key v z)) = 32.
Proof.
  apply HMAC_DRBG_generate_helper_Z_any_prop_fst.
Qed.

Lemma HMAC_DRBG_generate_helper_Z_Zlength_snd:
  forall HMAC key v z,
    0 <= z ->
    (forall x y, Zlength (HMAC x y) = 32) ->
    (exists n, z = n * 32) ->
    Zlength (snd (HMAC_DRBG_generate_helper_Z HMAC key v z)) = z.
Proof.
  intros HMAC key v z Hz Hlength Hn.
  destruct Hn as [n Hn].
  rewrite <- (Z2Nat.id n) in Hn by lia.
  generalize dependent z. revert Hlength.
  induction (Z.to_nat n); intros.
  {
    change (Z.of_nat 0) with 0 in Hn.
    change (0 * 32) with 0 in Hn.
    subst.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    reflexivity.
  }
  {
    assert (Hn': z = Z.of_nat n0 * 32 + 32).
    {
      rewrite Nat2Z.inj_succ in Hn.
      rewrite <- Zmult_succ_l_reverse in Hn.
      auto.
    }
    clear Hn.
    rename Hn' into Hn.
    subst z.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf: 0 >=? Z.of_nat n0 * 32 + 32 = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; lia.
    }
    rewrite Hf.
    remember (HMAC_DRBG_generate_helper_Z HMAC key v
               (Z.of_nat n0 * 32 + 32 - Z.of_nat 32)) as result; destruct result.
    simpl.
    rewrite Zlength_correct.
    rewrite app_length.
    rewrite Nat2Z.inj_add.
    do 2 rewrite <- Zlength_correct.
    rewrite Hlength.
    replace l0 with (snd (HMAC_DRBG_generate_helper_Z HMAC key v
                (Z.of_nat n0 * 32 + 32 - Z.of_nat 32))) by (rewrite <- Heqresult; auto).
    change (Z.of_nat 32) with 32.
    rewrite IHn0; auto; lia.
  }
Qed.

Lemma HMAC_DRBG_generate_helper_Z_incremental_equiv:
  forall HMAC key v z incr,
    0 <= z ->
    0 < incr <= 32 ->
    (exists n, z = n * 32) ->
    HMAC_DRBG_generate_helper_Z HMAC key v (z + incr) = HMAC_DRBG_generate_helper_Z HMAC key v (z + 32).
Proof.
  intros HMAC key v z incr Hz Hlength Hn.
  destruct Hn as [n Hn].
  rewrite <- (Z2Nat.id n) in Hn by lia.
  generalize dependent z.
  induction (Z.to_nat n); intros.
  {
    (* base case *)
    change ((Z.of_nat 0) * 32) with 0 in Hn.
    subst z; simpl.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf: 0 >=? incr = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; lia.
    }
    rewrite Hf.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf2: 0 >=? incr - Z.of_nat 32 = true).
    {
      change (Z.of_nat 32) with 32.
      rewrite Z.geb_leb.
      apply Z.leb_le; lia.
    }
    rewrite Hf2.
    reflexivity.
  }
  {
    (* inductive case *)
    assert (Hn': z = Z.of_nat n0 * 32 + 32).
    {
      rewrite Nat2Z.inj_succ in Hn.
      rewrite <- Zmult_succ_l_reverse in Hn.
      auto.
    }
    clear Hn; rename Hn' into Hn.
    subst z.
    rewrite HMAC_DRBG_generate_helper_Z_equation.
    assert (Hf: 0 >=? Z.of_nat n0 * 32 + 32 + incr = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; lia.
    }
    rewrite Hf.
    change (Z.of_nat 32) with 32.
    replace (Z.of_nat n0 * 32 + 32 + incr - 32) with (Z.of_nat n0 * 32 + incr) by lia.
    rewrite IHn0; try lia.
    remember (let (v0, rest) :=
        HMAC_DRBG_generate_helper_Z HMAC key v (Z.of_nat n0 * 32 + 32) in
    (HMAC v0 key, rest ++ HMAC v0 key)) as saved; rewrite HMAC_DRBG_generate_helper_Z_equation; subst saved.
    assert (Hf2: 0 >=? Z.of_nat n0 * 32 + 32 + 32 = false).
    {
      rewrite Z.geb_leb.
      apply Z.leb_gt; lia.
    }
    rewrite Hf2.
    change (Z.of_nat 32) with 32.
    replace (Z.of_nat n0 * 32 + 32 + 32 - 32) with (Z.of_nat n0 * 32 + 32) by lia.
    reflexivity.
  }
Qed.


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

(* TODO : change this to field once field isomorphism happens *)
Definition freeze :
  { freeze : feBW_tight -> feBW_limbwidths
  | forall a, phiBW_limbwidths (freeze a) = phiBW_tight a }.
Proof.
  Set Ltac Profiling.
  Time synthesize_freeze ().
  Show Ltac Profile.
Time Defined.

Print Assumptions freeze.