Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  zNil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint len (len_arg0 : lst) : natural
           := match len_arg0 with
              | Nil => Zero
              | Cons x y => Succ (len y)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.

Theorem plus_comm: forall (n m: natural), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (len (qreva x y)) (plus (len x) (len y)).
Proof.
  induction x; induction y; simpl; try reflexivity.
  +
    rewrite plus_comm. simpl.
    rewrite IHx. simpl. lfind. Admitted.


Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.

(* First draft specs.  Not specifying that chunks are aligned. *)

Require Import VST.progs.malloc.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.
Local Open Scope Z.
Local Open Scope logic.

(* TODO
Initially I imagined the constants would be defined as
parameters (with suitable assumptions, e.g., BIGBLOCK
needs to be big enough for at least one chunk of the largest size,
because fill_bin unconditionally initializes the last chunk.
*)
Definition WORD: Z := 4. (* sizeof(size_t) 4 for 32bit Clight; 8 in clang *)
Definition ALIGN: Z := 2.
Definition BINS: Z := 8.
Parameter BIGBLOCK: Z.
Parameter BIGBLOCK_def:
  Int.repr BIGBLOCK = Int.mul (Int.shl (Int.repr 2) (Int.repr 16)) (Int.repr WORD).

Definition bin2sizeZ := fun b: Z => (Z.mul ((Z.mul (b+1) ALIGN)-1) WORD).

Definition size2binZ : Z -> Z := fun s =>
   if zlt (bin2sizeZ(BINS-1)) s then -1
   else (s+(Z.mul WORD (ALIGN-1))-1) / (Z.mul WORD ALIGN).

Eval compute in bin2sizeZ (BINS-1).
Example bin2sizeBINS: bin2sizeZ (BINS-1) = 60. Proof. reflexivity. Qed.

(* Hint Unfold WORD ALIGN : myDB.
auto with myDB
*)

(* Some sanity checks; may not be needed for code verification. *)

Lemma claim1: forall s,
0 <= s <= bin2sizeZ(BINS-1) -> s <= bin2sizeZ(size2binZ s).
Proof. intros.
unfold bin2sizeZ in *.
unfold size2binZ in *.
simpl in *.
assert (H1: bin2sizeZ 7 = 60). { apply bin2sizeBINS. }
rewrite H1.
unfold ALIGN, WORD.
destruct (zlt 60 s).
- simpl. omega.
- simpl.  auto with arith.
(* assert (H2: (((s + 4 - 1) / 8 + 1) * 2 - 1) * 4 = (((s + 3) / 8) * 8 + 4)) by algebra *)
admit.
Admitted.

Lemma claim2: forall s,
0 <= s <= bin2sizeZ(BINS-1) -> 0 <= size2binZ s < BINS.

Lemma claim3: forall s, 0 <= s <= bin2sizeZ(BINS-1)
    -> size2binZ(bin2sizeZ(size2binZ(s))) = size2binZ(s).

Lemma claim4: forall b,
0 <= b < BINS -> Z.rem (bin2sizeZ b + WORD) (Z.mul WORD ALIGN) = 0.

Lemma claim5: forall b,
0 <= b < BINS -> size2binZ(bin2sizeZ(b)) = b.
Proof.
  intros.
  unfold size2binZ.
  assert (H1: (bin2sizeZ (BINS - 1) >= (bin2sizeZ b)))
    by ( unfold bin2sizeZ; unfold WORD, ALIGN, BINS in *; omega).
  destruct (zlt (bin2sizeZ (BINS - 1)) (bin2sizeZ b)) as [H2|H2]. contradiction.
  unfold bin2sizeZ.
  clear H H1 H2.
  assert (H3:
     (((b + 1) * ALIGN - 1) * WORD + WORD * (ALIGN - 1) - 1) / (WORD * ALIGN)
     = (b*ALIGN*WORD + 2*ALIGN*WORD - 2*WORD -1)/(WORD*ALIGN)).
     { admit. (* algebra *) }
  rewrite H3; clear H3. unfold WORD, ALIGN, BINS. simpl.
  admit. (* algebra, including integer quotient *)
Admitted.

Definition sbrk_spec :=
(* like malloc without token;
and I removed the possibility of failure to streamline the proof of fill_bin *)
   DECLARE _sbrk
   WITH n:Z
   PRE [ 1%positive OF tuint ]
       PROP (0 <= n <= Int.max_unsigned)
       LOCAL (temp 1%positive (Vint (Int.repr n)))
       SEP ()
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP ( (* if eq_dec p nullval then emp else memory_block Tsh n p) *)
             memory_block Tsh n p).

Definition bin2size_spec :=
 DECLARE _bin2size
  WITH b: Z
  PRE [ _b OF tint ]
     PROP( 0 <= b <= Int.max_signed )
     LOCAL (temp _b (Vint (Int.repr b))) SEP ()
  POST [ tuint ]
     PROP() LOCAL(temp ret_temp (Vint (Int.repr (bin2sizeZ b)))) SEP ().

Definition size2bin_spec :=
 DECLARE _size2bin
  WITH s: Z
  PRE [ _s OF tuint ]    (* Vlong? *)
     PROP( 0 <= s <= Int.max_unsigned )
     LOCAL (temp _s (Vint (Int.repr s))) SEP ()
  POST [ tint ]
     PROP() LOCAL(temp ret_temp (Vint (Int.repr (size2binZ s)))) SEP ().

(* malloc token, which accounts for the size field and padding.
 * n is the size requested
 * Unfolding the definition reveals the stored size value and the
 * actual size of the block.
 * Note that offset_val is in bytes, not like C pointer arith. *)
Definition malloc_token' (sh: share) (n: Z) (p: val): mpred :=
   data_at Tsh tuint (offset_val (- WORD) p) (Vint (Int.repr n))
 * memory_block Tsh ((bin2sizeZ(size2binZ(n)) - n)) (offset_val n p).

Lemma malloc_token'_valid_pointer:
  forall sh n p, malloc_token' sh n p |-- valid_pointer p.

Lemma malloc_token'_precise:
  forall sh n p, predicates_sl.precise (malloc_token' sh n p).

(* linked list, for free blocks.
p points to a linked list of len blocks, each of sz bytes,
of the form (sz,nxt,_) with link nxt, terminated at r.
Using nat for ease of termination check, at cost of Z conversions.
*)
Fixpoint mmlist (sz: Z) (len: nat) (p: val) (r: val): mpred :=
 match len with
 | O => !! (ptr_eq p r) && emp
 | (S n) => EX q:val, !! is_pointer_or_null q &&
            data_at Tsh tuint (offset_val (-WORD) p) (Vint(Int.repr sz))
          * data_at Tsh (tptr tvoid) p q
          * memory_block Tsh (sz - WORD) (offset_val WORD p)
          * mmlist sz n q r
 end.

(* module invariant:
Each element of array points to a null-terminated list of right size blocks.

This version folds over index list, which makes it easy to express the
block size per bin; it may facilitate per-index update.
*)
Definition mm_inv (arr: val): mpred :=
  EX bins: list val, EX lens: list nat,
  !! (Zlength bins = BINS /\ Zlength lens = BINS)  &&
  data_at Tsh (tarray (tptr tvoid) BINS) bins arr
  * fold_right (fun (i: nat) => fun (mp: mpred) =>
     (mmlist (bin2sizeZ (Z.of_nat i)) (nth i lens O) (nth i bins nullval) nullval) * mp )
    emp
    (seq 0 (Z.to_nat BINS)).

(* copy of malloc_spec' from floyd library, with mm_inv added *)
Definition malloc_spec'' :=
   DECLARE _malloc
   WITH n:Z, bin:val
   PRE [ 1%positive OF tuint ]
       PROP (0 <= n <= Int.max_unsigned)
       LOCAL (temp 1%positive (Vint (Int.repr n)); gvar _bin bin)
       SEP ( mm_inv bin )
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP ( mm_inv bin;
             if eq_dec p nullval then emp
             else (malloc_token Tsh n p * memory_block Tsh n p)).

Definition free_spec'' := (* copy from floyd lib, with mm_inv added *)
   DECLARE _free
   WITH p:_, n:_, bin:_
   PRE [ 1%positive OF tptr tvoid ]
       PROP ()
       LOCAL (temp 1%positive p; gvar _bin bin)
       SEP (malloc_token Tsh n p; memory_block Tsh n p; mm_inv bin)
    POST [ Tvoid ]
       PROP ()
       LOCAL ()
       SEP (mm_inv bin).

Definition malloc_small_spec :=
   DECLARE _malloc_small
   WITH n:Z, bin:_
   PRE [ 1%positive OF tuint ]
       PROP (0 <= n <= bin2sizeZ(BINS-1))
       LOCAL (temp 1%positive (Vint (Int.repr n)); gvar _bin bin)
       SEP ( mm_inv bin )
    POST [ tptr tvoid ] EX p:_,
       PROP ()
       LOCAL (temp ret_temp p)
       SEP ( mm_inv bin;
            if eq_dec p nullval then emp
            else (malloc_token' Tsh n p * memory_block Tsh n p)).

Definition free_small_spec :=
   DECLARE _free_small
   WITH p:_, n:_, s:_
   PRE [ 1%positive OF tptr tvoid, 2%positive OF tint ]
       PROP ( n = s )
       LOCAL (temp 1%positive p; temp 2%positive (Vint (Int.repr s)))
       SEP (malloc_token' Tsh n p; memory_block Tsh n p)
    POST [ tvoid ]
       PROP ()
       LOCAL ()
       SEP ().

Definition fill_bin_spec :=
 DECLARE _fill_bin
  WITH b: _
  PRE [ _b OF tint ]
     PROP(0 <= b < BINS) LOCAL (temp _b (Vint (Int.repr b))) SEP ()
  POST [ (tptr tvoid) ] EX p:_, EX len:Z,
     PROP( len > 0 )
     LOCAL(temp ret_temp p)
     SEP ( mmlist (bin2sizeZ b) (Z.to_nat len) p nullval ).

Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ]  main_post prog nil u.

Definition Gprog : funspecs :=
 ltac:(with_library prog [
   sbrk_spec; bin2size_spec; size2bin_spec; fill_bin_spec;
   malloc_small_spec; free_small_spec; malloc_spec''; free_spec'';
   main_spec]).

Lemma body_bin2size: semax_body Vprog Gprog f_bin2size bin2size_spec.
Proof. start_function. forward. Qed.

Lemma body_size2bin: semax_body Vprog Gprog f_size2bin size2bin_spec.
Proof. start_function.
forward_call (BINS-1).
assert (BINS - 1 <= Int.max_signed ). {  admit. (* TODO how prove this? *) }
split. unfold BINS. omega.  assumption.
forward_if(PROP() LOCAL() SEP (FF)). (* FF because join point unreachable: both branches return *)
- (* then *)
forward. entailer!.  f_equal. rewrite Int.neg_repr.
assert (H1: size2binZ s = -1). {
  unfold size2binZ; simpl. destruct (zlt (bin2sizeZ 7)). reflexivity. contradiction. }
rewrite -> H1. reflexivity.
- (* else *)
forward.  entailer!. f_equal.
assert (H1: Int.divu (Int.repr (s + (4 - 1))) (Int.repr (4 * 2)) = Int.repr (size2binZ s) ).
   { admit. } (* TODO divu property and def of size2binZ *)
rewrite -> H1. reflexivity.
- (* fi *)
intros.  unfold overridePost. if_tac.
go_lowerx.
entailer.
apply ENTAIL_refl.
(* done here *)
Admitted.

(* note to Andrew: forward_for wouldn't work until we added True to the Prop in the following.*)
Definition fill_bin_dummy (b:Z) (p:val) (qNs:val*Z*Z) :=
  PROP(True)LOCAL(temp _q (let '(q, _, _) := qNs in q);
         temp _p p;
         temp _s (Vint (Int.repr (let '(_,_,s) := qNs in s)));
         temp _b (Vint (Int.repr b)))
  SEP().

Definition fill_bin_Inv (b:Z) (p:val) (qNs:val*Z*Z) :=
(*  EX N:Z, EX s:Z, *)
  PROPx (let '(q,N,s) := qNs in
        [s = bin2sizeZ b; 0 <= N; s + N*(WORD+s) <= BIGBLOCK])
  (LOCALx ([temp _q (let '(q,N,s):=qNs in q);
         temp _p p;
         temp _s (Vint (Int.repr (let '(q,N,s):=qNs in s)));
         temp _b (Vint (Int.repr b))])
  (SEPx ( let '(q,N,s):=qNs in
         [mmlist s (Z.to_nat N) (offset_val s p) q;
          memory_block Tsh (BIGBLOCK-(s+N*(WORD+s))) q] ))).

Definition fill_bin_preIncr (b:Z) (p:val) (qNs:val*Z*Z) :=
(*  EX N:Z, EX s:Z,
William suggests localizing the lets so tactic pattern-matches may work *)
  PROP ( let '(q,N,s) := qNs in
         s = bin2sizeZ b /\ 0 <= N /\ s + N*(WORD+s) <= BIGBLOCK )
  LOCAL (temp _q (let '(q,_,_) := qNs in q);
         temp _p p;
         temp _s (Vint (Int.repr (let '(_,_,s) := qNs in s)));
         temp _b (Vint (Int.repr b)))
  SEP (  let '(q,N,s) := qNs in
         mmlist s (Z.to_nat N) (offset_val s p) q
         * memory_block Tsh (BIGBLOCK - (s+N*(WORD+s)) - (WORD+s)) (offset_val (WORD+s) q)
         * data_at Tsh tuint (Vint (Int.repr s)) q (* size *)
         * data_at Tsh (tptr tvoid) (offset_val (WORD+s) q) (offset_val WORD q) (* next *)
         * memory_block Tsh (s-WORD-WORD) (offset_val (WORD+WORD) q) (* rest of block *) ).

Lemma body_fill_bin: semax_body Vprog Gprog f_fill_bin fill_bin_spec.
Proof.
start_function.
forward_call (b).
- unfold BINS in H. (* trivial arith but layers of definition *) admit.
- forward_call (BIGBLOCK).
  * entailer!. repeat f_equal. rewrite -> BIGBLOCK_def. auto.
  * (* trivial arith but layers of defs *) admit.
  * Intros p.

  check_Delta;
  repeat simple apply seq_assoc1;
  lazymatch type of (fill_bin_Inv b p) with
  | _ -> environ -> mpred => idtac
  | _ => fail "Invariant (first argument to forward_for) must have type (_ -> environ -> mpred)"
  end;
  lazymatch type of (fill_bin_preIncr b p) with
  | _ -> environ -> mpred => idtac
  | _ => fail "PreInc (second argument to forward_for) must have type (_ -> environ -> mpred)"
  end.
apply -> seq_assoc;
      apply semax_seq' with (exp (fill_bin_Inv b p)); abbreviate_semax.
      Focus 2.
      eapply semax_seq.

repeat  match goal with P := @abbreviate ret_assert _ |- semax _ _ _ ?P' =>
                         constr_eq P P'; unfold abbreviate in P; subst P
           end.
 match goal with |- semax _ _ (Sloop (Ssequence (Sifthenelse _ Sskip Sbreak) ?body) _) _ =>
   (tryif unify (no_breaks body) true
          then idtac
      else fail "Since there is a break in the loop body, you need to supply an explicit postcondition using the 3-argument form of forward_for.");
   eapply semax_for_3g2 with (PQR:=(fill_bin_preIncr b p)) (*
        [ reflexivity
        |intro
        | intro ;
          match goal with |- ENTAIL ?Delta, ?Pre |-- local (`(eq _) (eval_expr ?e)) =>
            do_compute_expr1 Delta Pre e;
            match goal with v := _ : val , H: ENTAIL _ , _ |-- _ |- _ => subst v; apply H end
          end
        | intro; let HRE := fresh in
            apply semax_extract_PROP; intro HRE;
            repeat (apply semax_extract_PROP; fancy_intro true);
            do_repr_inj HRE
        | intro; let HRE := fresh in
            apply semax_extract_PROP; intro HRE;
            repeat (apply semax_extract_PROP; fancy_intro true);
            do_repr_inj HRE
        ]    *)
  end.
  reflexivity.
  intro.
  admit.
  intro.
  match goal with |- ENTAIL ?Delta, ?Pre |-- local (`(eq _) (eval_expr ?e)) =>
            do_compute_expr1 Delta Pre e end.
            match goal with v := _ : val , H: ENTAIL _ , _ |-- _ |- _ => subst v; apply H end
          end.
        forward_for2 (fill_bin_Inv b p) (fill_bin_preIncr b p) .

      [  | eapply semax_seq;
         [ forward_for2 (fill_bin_Inv b p) (fill_bin_preIncr b p)
          | abbreviate_semax;
            apply extract_exists_pre; intro;
            let HRE := fresh in
            apply semax_extract_PROP; intro HRE;
            repeat (apply semax_extract_PROP; fancy_intro true);
            do_repr_inj HRE]
   ].
     lazymatch goal with
  | |- semax _ _ (Ssequence (Sfor _ _ _ _) _) _ =>
      apply -> seq_assoc;
      apply semax_seq' with (exp (fill_bin_Inv b p)); abbreviate_semax;
      [  | eapply semax_seq;
         [ forward_for2 (fill_bin_Inv b p) (fill_bin_preIncr b p)
          | abbreviate_semax;
            apply extract_exists_pre; intro;
            let HRE := fresh in
            apply semax_extract_PROP; intro HRE;
            repeat (apply semax_extract_PROP; fancy_intro true);
            do_repr_inj HRE]
   ]
  | |- semax _ _ (Sfor _ _ _ _) ?Post =>
      apply semax_seq' with (exp (fill_bin_Inv b p)); abbreviate_semax; idtac "Hi"
(*      [  | forward_for3 (fill_bin_Inv b p) (fill_bin_preIncr b p) Post]*)
  | |- semax _ _ (Sloop (Ssequence (Sifthenelse _ Sskip Sbreak) _) _) ?Post =>
     apply semax_pre with (exp (fill_bin_Inv b p));
      [  | forward_for3 (fill_bin_Inv b p) (fill_bin_preIncr b p) Post]
  | |- semax _ _ (Sloop (Ssequence (Sifthenelse _ Sskip Sbreak) _) _) _ =>
     apply semax_pre with (exp (fill_bin_Inv b p));
      [ unfold_function_derives_right | forward_for2 (fill_bin_Inv b p) (fill_bin_preIncr b p) ]
  | |- _ => fail "forward_for2x cannot recognize the loop"
  end.

    (* forward_for (fill_bin_dummy b p) (fill_bin_dummy b p) *)
    forward_for (fill_bin_Inv b p) (fill_bin_preIncr b p).
    + (* initializer establishes invar *)
      forward.
      Exists (p, 0, (bin2sizeZ b)).
      entailer!.  unfold fill_bin_Inv. unfold mmlist. simpl.  (* TODO arith wrong in invar? *) admit.
    + (* definedness of loop guard *) entailer!.  ++ admit. ++ admit.
    + (* body preserves *)
      Intros. (* to flatten SEP clause; only worked when I distributed the lets finely in fill_bin_Inv *)
      (* forward fails, needs props about casts *)
admit.
    + (* loop increment - same problem *) admit.
    + (* after the loop WORKING HERE *)
      Intros.
      forward.

Admitted.

(*
TODO use freezer to frame over the loop (waste before the list): memory_block Tsh s p
*)

(* TODO likely lemmas for malloc_small?
Adding or removing at the head preserves mmlist (just unfold def,
increment or decrement the length witness).
If bin[i] is null then assigning an mmlist preserves mm_inv
(induct on indices to get to i).
*)
Lemma body_malloc_small:  semax_body Vprog Gprog f_malloc_small malloc_small_spec.
Proof.
start_function.
freeze [0] MMinv.
forward_call (n).
(* WORKING HERE *)

Lemma body_free_small:  semax_body Vprog Gprog f_free_small free_small_spec.

(* TODO Complete implementation of malloc and free,
   and an interesting main, before verifying these. *)

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_size2bin.
semax_func_cons body_bin2size.
semax_func_cons body_fill_bin.
semax_func_cons body_malloc_small.
semax_func_cons body_free_small.
semax_func_cons body_malloc.
semax_func_cons body_free.
semax_func_cons body_main.
Qed.


Require Import Setoid.
Require Import Arith.Peano_dec.
Require Import ClassicalRealizability.Kbase.

Definition 𝔹 b := ∀Z, Z 0 → Z 1 → Z b.
Definition Bool := ∀Z, Z → Z → Z.
Definition Ktrue := λ"x" λ"y" "y".
Definition Kfalse := λ"x" λ"y" "x".

Lemma 𝔹_Bool_subtype : forall b, 𝔹 b ⊆ Bool.
Proof. unfold 𝔹, Bool. intro b. apply sub_Forall_add. intro Z. intros π Hπ. now exists (fun _ => Z). Qed.

Lemma Ktrue_realizer : forall e, Ktrue↓e ⊩ 𝔹 1.
Proof. unfold 𝔹. Ksolve. Qed.

Lemma Kfalse_realizer : forall e, Kfalse↓e ⊩ 𝔹 0.
Proof. unfold 𝔹. Ksolve. Qed.

(** **  Specification of Booleans  **)

(** ***  True-like booleans  **)

Theorem specification_true_like_easy : forall t, (forall u v π, t ★ u·v·π ≻ v ★ π) -> t ⊩ 𝔹 1.
Proof. intros t Ht. unfold 𝔹. Kmove. eapply anti_evaluation. apply Ht. Kmove. Qed.

Section Spec_True_like.
  Variables (u v : Λ) (π : Π).
  Hypothesis Hpole : forall p, p ∈ ⫫ <-> p ⪰ v ★ π.

  Theorem specification_true_like : forall t, t ⊩ 𝔹 1 -> t ★ u·v·π ≻ v ★ π.
  Proof.
  intros t Ht. apply redeq_red. intro Habs. inversion Habs. eelim non_confusion2. eassumption.
  rewrite <- Hpole. apply Ht. exists (fun n => if eq_nat_dec n 0 then ⊤ else dot π). simpl. Ksolve.
  Ksolve. rewrite Hpole. left. compute in Hπ. now subst.
  Qed.
End Spec_True_like.

(** ***  False-like booleans  **)

Theorem specification_false_like_easy : forall t, (forall u v π, t ★ u·v·π ≻ u ★ π) -> t ⊩ 𝔹 0.
Proof. intros t Ht. unfold 𝔹. Kmove. eapply anti_evaluation. apply Ht. Kmove. Qed.

Section Spec_False_like.
  Variables (u v : Λ) (π : Π).
  Hypothesis Hpole : forall p, p ∈ ⫫ <-> p ⪰ u ★ π.

  Theorem specification_false_like : forall t, t ⊩ 𝔹 0 -> t ★ u·v·π ≻ u ★ π.
  Proof.
  intros t Ht. apply redeq_red. intro Habs. inversion Habs. eelim non_confusion2. eassumption.
  rewrite <- Hpole. apply Ht. exists (fun n => if eq_nat_dec n 0 then dot π else ⊤). simpl. Ksolve.
  Ksolve. rewrite Hpole. left. compute in Hπ. now subst.
  Qed.
End Spec_False_like.

(** ***  General type Bool  **)

Theorem specification_Bool_easy : forall t,
  (forall u v π, t ★ u·v·π ≻ u ★ π \/ t ★ u·v·π ≻ v ★ π) -> t ⊩ Bool.
Proof.
intros t Ht. unfold Bool. Ksolve.
destruct (Ht t0 t1 π) as [Hred | Hred]; eapply anti_evaluation; now apply Hred || Ksolve.
Qed.

Section Spec_Bool.
  Variables (u v : Λ) (π : Π).
  Hypothesis Hpole : forall p, p ∈ ⫫ <-> p ⪰ u ★ π \/ p ⪰ v ★ π.

  Theorem specification_Bool : forall t, t ⊩ Bool -> t ★ u·v·π ≻ u ★ π \/ t ★ u·v·π ≻ v ★ π.
  Proof.
  intros t Ht.
  setoid_replace (t ★ u·v·π ≻ u ★ π) with (t ★ u·v·π ⪰ u ★ π).
  setoid_replace (t ★ u·v·π ≻ v ★ π) with (t ★ u·v·π ⪰ v ★ π).
  rewrite <- Hpole. apply Ht. exists (dot π). Ksolve.
  Ksolve. compute in Hπ. subst. rewrite Hpole. now do 2 left.
  Ksolve. compute in Hπ. subst. rewrite Hpole. now right; left.
  unfold redeq. intuition. inversion H0. eelim non_confusion2. eassumption.
  unfold redeq. intuition. inversion H0. eelim non_confusion2. eassumption.
  Qed.
End Spec_Bool.


From Tweetnacl.Libs Require Import Export.
From Tweetnacl.Libs Require Import HeadTailRec.

Require Import ssreflect.
From Tweetnacl.Libs Require Import Export.
From Tweetnacl.Libs Require Import HeadTailRec.
From Tweetnacl.Gen Require Import AMZubSqSel.
From Tweetnacl.Gen Require Import ABCDEF.
From Tweetnacl.Gen Require Import step_gen.

From Tweetnacl.Gen Require Import abstract_fn_rev.
From Tweetnacl.Gen Require Import abstract_rec.
From Tweetnacl.Gen Require Import abstract_rec_rev.

Require Import ssreflect.

Section EquivFnRec.

Open Scope Z.

Context {T : Type}.
Context {T' : Type}.
Context {Mod : T -> T}.
Context {O : Ops T T' Mod}.

Theorem abstract_fn_rev_eq : forall m p z a b c d e f x,
  0 <= m ->
  0 <= p ->
  m <= p + 1 ->
  abstract_rec_rev (Z.to_nat m) (Z.to_nat p) z a b c d e f x =
  abstract_fn_rev m p z a b c d e f x.
Proof.
  intros m p z a b c d e f x Hm.
  gen p z a b c d e f x.
  pattern m.
  eapply natlike_ind.
  - intros; rewrite abstract_fn_rev_equation Zle_imp_le_bool ; try omega ; reflexivity.
  - clear Hm m; intros m Hm IHm p z a b c d e f x Hp Hmpp.
    sort. (* sort the hypothesises *)
  assert(Hmp: m <= p + 1) by omega.
  change (Z.succ m) with (m + 1).
  replace (Z.to_nat (m + 1)) with (S (Z.to_nat m)).
  2:   rewrite Z2Nat.inj_add ; try replace (Z.to_nat 1) with 1%nat by reflexivity ; omega.
  rewrite abstract_fn_rev_equation /abstract_fn_rev_n.
  2: omega. simpl.
  remember (abstract_rec_rev (Z.to_nat m) (Z.to_nat p) z a b c d e f x) as k ; destruct k as (((((a0,b0),c0),d0),e0),f0).
  replace (m + 1 - 1) with m by omega.
  remember (abstract_fn_rev m p z a b c d e f x) as k' ; destruct k' as (((((a0',b0'),c0'),d0'),e0'),f0').
  assert((a0, b0, c0, d0, e0, f0) = (a0', b0', c0', d0', e0', f0')).
  rewrite Heqk' Heqk.
  apply IHm ; omega.
  inversion H ; subst.
  replace (m + 1 <=? 0) with false.
  do 7 f_equal ; rewrite -Z2Nat.inj_sub ; try omega ; apply Z2Nat.id; omega.
  symmetry.
  apply Z.leb_gt.
  omega.
Qed.

Close Scope Z.

(* Theorem not needed but still cool to have *)
Theorem abstract_rec_rev_eq : forall n z a b c d e f x,
  abstract_rec (S n) z a b c d e f x = abstract_rec_rev (S n) n z a b c d e f x.
Proof.
intros.
rewrite abstract_rec_equiv_rec_fn abstract_rec_rev_equiv_rec_fn_S_n.
apply Tail_Head_equiv.
Qed.

End EquivFnRec.


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'.


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.


(** ** 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.