Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From PLF Require Import Maps.
From Coq Require Import Bool.Bool.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Arith.PeanoNat. Import Nat.
From Coq Require Import Lia.
From PLF Require Export Imp.

From Coq Require Import Logic.FunctionalExtensionality.

Definition Assertion := state -> Prop.

Definition assert_implies (P Q : Assertion) : Prop := forall st,
  P st -> Q st.

Declare Scope hoare_spec_scope.
Notation "P ->> Q" := (assert_implies P Q)
                      (at level 80) : hoare_spec_scope.
Open Scope hoare_spec_scope.

Notation "P <<->> Q" :=
  (P ->> Q /\ Q ->> P) (at level 80) : hoare_spec_scope.

Definition Aexp : Type := state -> nat.
Definition assert_of_Prop (P : Prop) : Assertion := fun _ => P.
Definition Aexp_of_nat (n : nat) : Aexp := fun _ => n.
Definition Aexp_of_aexp (a : aexp) : Aexp := fun st => aeval st a.
Coercion assert_of_Prop : Sortclass >-> Assertion.
Coercion Aexp_of_nat : nat >-> Aexp.
Coercion Aexp_of_aexp : aexp >-> Aexp.
Add Printing Coercion Aexp_of_nat Aexp_of_aexp assert_of_Prop.
Arguments assert_of_Prop /.
Arguments Aexp_of_nat /.
Arguments Aexp_of_aexp /.
Add Printing Coercion Aexp_of_nat Aexp_of_aexp assert_of_Prop.
Declare Scope assertion_scope.
Bind Scope assertion_scope with Assertion.
Bind Scope assertion_scope with Aexp.
Delimit Scope assertion_scope with assertion.
Notation assert P := (P%assertion : Assertion).
Notation mkAexp a := (a%assertion : Aexp).
Notation "~ P" := (fun st => ~ assert P st) : assertion_scope.
Notation "P /\ Q" := (fun st => assert P st /\ assert Q st) : assertion_scope.
Notation "P \/ Q" := (fun st => assert P st \/ assert Q st) : assertion_scope.
Notation "P -> Q" := (fun st => assert P st -> assert Q st) : assertion_scope.
Notation "P <-> Q" := (fun st => assert P st <-> assert Q st) : assertion_scope.
Notation "a = b" := (fun st => mkAexp a st = mkAexp b st) : assertion_scope.
Notation "a <> b" := (fun st => mkAexp a st <> mkAexp b st) : assertion_scope.
Notation "a <= b" := (fun st => mkAexp a st <= mkAexp b st) : assertion_scope.
Notation "a < b" := (fun st => mkAexp a st < mkAexp b st) : assertion_scope.
Notation "a >= b" := (fun st => mkAexp a st >= mkAexp b st) : assertion_scope.
Notation "a > b" := (fun st => mkAexp a st > mkAexp b st) : assertion_scope.
Notation "a + b" := (fun st => mkAexp a st + mkAexp b st) : assertion_scope.
Notation "a - b" := (fun st => mkAexp a st - mkAexp b st) : assertion_scope.
Notation "a * b" := (fun st => mkAexp a st * mkAexp b st) : assertion_scope.

Definition ap {X} (f : nat -> X) (x : Aexp) :=
  fun st => f (x st).

Definition ap2 {X} (f : nat -> nat -> X) (x : Aexp) (y : Aexp) (st : state) :=
  f (x st) (y st).

Definition hoare_triple
	(P : Assertion) (c : com) (Q : Assertion) : Prop :=
	forall st st',
		st =[ c ]=> st' ->
		P st ->
		Q st'.

Notation "{{ P }} c {{ Q }}" :=
	(hoare_triple P c Q) (at level 90, c custom com at level 99) : hoare_spec_scope.

(** **** Exercise: 1 star, standard (hoare_post_true) *)
(* Prove that if Q holds in every state, then any triple with Q as its postcondition is valid. *)
Theorem hoare_post_true : forall (P Q : Assertion) c,
  (forall st, Q st) ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple.
  intros.
  apply H.
Qed.

(** **** Exercise: 1 star, standard (hoare_pre_false) *)
(* Prove that if P holds in no state, then any triple with P as its precondition is valid. *)
Theorem hoare_pre_false : forall (P Q : Assertion) c,
  (forall st, ~ (P st)) ->
  {{P}} c {{Q}}.
Proof.
  unfold hoare_triple, not. intros.
  apply H in H1. inversion H1.
Qed.

Theorem hoare_skip: forall P, {{ P }} skip {{ P }}.
Proof.
  unfold hoare_triple. intros.
  inversion H. subst. apply H0.
Qed.

Theorem hoare_seq :forall P Q R c1 c2,
     {{Q}} c2 {{R}} ->
     {{P}} c1 {{Q}} ->
     {{P}} c1; c2 {{R}}.
Proof.
  unfold hoare_triple. intros.
  inversion H1.
  apply H with st'0. apply H8. apply H0 with st. apply H5. apply H2.
Qed.

Definition assn_sub X a (P:Assertion) : Assertion :=
  fun (st : state) =>
    P (X !-> aeval st a ; st).

Notation "P [ X |-> a ]" := (assn_sub X a P)
  (at level 10, X at next level, a custom com).

Theorem hoare_asgn : forall Q X a,
  {{Q [X|-> a]}} X := a {{Q}}.
Proof.
  unfold assn_sub, hoare_triple.
  intros.
  inversion H. rewrite <- H5. apply H0.
Qed.

Example assn_sub_example :
  {{(X < 5) [X |-> X + 1]}}
    X := X + 1
  {{X < 5}}.
Proof.
  apply hoare_asgn.
Qed.

(** **** Exercise: 2 stars, standard, optional (hoare_asgn_examples1) *)
Example hoare_asgn_examples1 :
  exists P,
    {{ P }}
      X := 2 * X
    {{ X <= 10 }}.
Proof.
  exists ((X <= 10) [X |-> 2 * X]).
  simpl. apply hoare_asgn.
Qed.

(** **** Exercise: 2 stars, standard, optional (hoare_asgn_examples2) *)
Example hoare_asgn_examples2 :
  exists P,
    {{ P }}
      X := 3
    {{ 0 <= X /\ X <= 5 }}.
Proof.
  exists ((0 <= X /\ X <= 5) [X |-> 3]).
  simpl. apply hoare_asgn.
Qed.

(* The assignment rule looks backward to almost everyone the first time they see it.
If it still seems puzzling to you, it may help to think a little about alternative "forward" rules. Here is a seemingly natural one:

  	(hoare_asgn_wrong)
{{ True }} X := a {{ X = a }}

*)

(* a cannot be dependent on X; otherwise the proposition does not hold. *)
Definition hoare_asgn_wrong_example := {{ True }} X := X + 1 {{ X = X + 1}}.

Lemma hoare_asgn_fwd_helper : forall st X (n : nat),
  (X !-> st X; X !-> n; st) = st.
Proof.
  intros. unfold "!->". extensionality x'.
  destruct (X =? x')%string eqn : H.
  - apply String.eqb_eq in H. subst. trivial.
  - trivial.
Qed.

(* Note: !-> indicates update st X m  *)
Theorem hoare_asgn_fwd : forall m a P,
  {{ fun st => P st /\ st X = m }}
    X := a
  {{ fun st => P (X !-> m ; st) /\ st X = aeval (X !-> m ; st) a }}.
  (* X is evaluated with the previous state. *)
Proof.
  unfold hoare_triple. intros. destruct H0.
  inversion H. subst. rewrite hoare_asgn_fwd_helper. split; auto.
Qed.

(* If st' is obtainable from st, we are able to construct a state that could reverse to st. *)
Lemma hoare_asgn_fwd_exists_helper : forall st st' X a,
  st =[ X := a ]=> st' -> exists m, (X !-> m; st') = st.
Proof.
  intros.
  inversion H. subst.
  exists (st X). apply hoare_asgn_fwd_helper.
Qed.

Theorem hoare_asgn_fwd_exists :
  forall a P,
  {{fun st => P st}}
    X := a
  {{fun st => exists m, P (X !-> m ; st) /\
                st X = aeval (X !-> m ; st) a }}.
Proof.
  unfold hoare_triple. intros.
  inversion H. subst.
  destruct (hoare_asgn_fwd_exists_helper st (X !-> aeval st a; st) X a); auto.
  exists x. split; rewrite H1; auto.
Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  unfold assert_implies, hoare_triple. intros.
  apply H in H1; try apply H0 in H2; auto.
Qed.

Theorem hoare_consequence_post : forall (P Q Q' : Assertion) c,
  {{P}} c {{Q'}} ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  unfold assert_implies, hoare_triple. intros.
  apply H in H1; try apply H0 in H1; auto.
Qed.

Theorem hoare_consequence : forall (P P' Q Q' : Assertion) c,
  {{P'}} c {{Q'}} ->
  P ->> P' ->
  Q' ->> Q ->
  {{P}} c {{Q}}.
Proof.
  unfold assert_implies, hoare_triple. intros.
  apply H in H2. apply H1 in H2. auto. apply H0 in H3. auto.
Qed.

Hint Unfold assert_implies hoare_triple assn_sub t_update : core.
Hint Unfold assert_of_Prop Aexp_of_nat Aexp_of_aexp : core.

Example hoare_asgn_example1' :
  {{True}} X := 1 {{X = 1}}.
Proof.
  eapply hoare_consequence_pre.
  - eapply hoare_asgn.
  - auto.
Qed.

Example assn_sub_example2' :
  {{X < 4}}
    X := X + 1
  {{X < 5}}.
Proof.
  eapply hoare_consequence_pre.
  - apply hoare_asgn.
  - unfold "->>", assn_sub, "!->".
    intros. simpl in *. lia.
Qed.

(* A custom tactic for dealing with assignment. *)
Ltac assn_auto :=
  try auto; (* as in example 1, above *)
  try (unfold "->>", assn_sub, t_update;
       intros; simpl in *; lia). (* as in example 2 *)

Example assn_sub_ex1' :
  {{ X <= 5 }}
    X := 2 * X
  {{ X <= 10 }}.
Proof.
  eapply hoare_consequence_pre.
  - apply hoare_asgn.
  - assn_auto.
Qed.

Example assn_sub_ex2' :
  {{ 0 <= 3 /\ 3 <= 5 }}
    X := 3
  {{ 0 <= X /\ X <= 5 }}.
Proof.
  eapply hoare_consequence_pre.
  - apply hoare_asgn.
  - auto.
Qed.

Example hoare_asgn_example3 : forall (a : aexp) (n : nat),
  {{a = n}}
    X := a;
    skip
  {{X = n}}.
Proof.
  intros. eapply hoare_seq.
  - apply hoare_skip.
  - simpl. eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + auto.
Qed.

Example hoare_asgn_example4 :
  {{ True }}
    X := 1;
    Y := 2
  {{ X = 1 /\ Y = 2 }}.
Proof.
  apply hoare_seq with (Q := (X = 1)%assertion);
  (* The annotation %assertion is needed here to help Coq parse correctly. *)
  simpl; eapply hoare_consequence_pre; try apply hoare_asgn; auto.
Qed.

Definition swap_program : com :=
  <{
    Z := X ;
    X := Y ;
    Y := Z
  }>.

Theorem swap_exercise :
  {{X <= Y}}
    swap_program
  {{Y <= X}}.
Proof.
  unfold swap_program.
  eapply hoare_seq.
  - simpl. eapply hoare_seq; apply hoare_asgn.
  - simpl. eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + auto.
Qed.

(* Note that a is an arithmetic expression, so it can contain the identifier X.
   The key point is that X is modified.
*)
Theorem invalid_triple : ~ (
  forall (a : aexp) (n : nat),
  {{ a = n }}
    X := 3;
    Y := a
  {{ Y = n }}
).
Proof.
(* The thing is, if we follow the rule in the assumption, we have a conclusion that is
contradictory to the correct rule of inference. *)
  unfold hoare_triple, not. intros.
  specialize H with (a := X) (n := 1). simpl in H.
  (* Use the evaluation rules (E_Seq and E_Asgn) to show that Y has a different value y2
  in the same final state st' *)
  assert (H': (X !-> 1) =[ X := 3; Y := X ]=> (Y !-> 3; X !-> 3; X !-> 1)).
  - eapply E_Seq. apply E_Asgn. auto.
    apply E_Asgn. trivial.

  (* Use the (assumed) validity of the given hoare triple to derive a state st' in which Y has
  some value y1 *)
  - assert (H'' : 3 = 1).
    apply H in H'. apply H'. auto.

  discriminate H''.
Qed.

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Coercion bassn : bexp >-> Assertion.
Arguments bassn /.

Lemma bexp_eval_false : forall b st,
  beval st b = false -> ~ ((bassn b) st).
Proof.
  (* In fact, we can use congruence. *)
  intros. unfold not.
  induction b; simpl in *; intros; try rewrite H in H0; discriminate.
Qed.

Hint Resolve bexp_eval_false : core.

Theorem hoare_if : forall P Q (b : bexp) c1 c2,
  {{ P /\ b }} c1 {{ Q }} ->
  {{ P /\ ~b }} c2 {{ Q }} ->
  {{ P }} if b then c1 else c2 end {{ Q }}.
Proof.
  unfold hoare_triple. intros.
  inversion H1; subst; eauto.
Qed.

Ltac assn_auto' :=
  unfold "->>", assn_sub, t_update, bassn;
  intros; simpl in *;
  try rewrite -> eqb_eq in *; (* for equalities *)
  auto; try lia.

Example if_example'' :
  {{True}}
    if X = 0
      then Y := 2
      else Y := X + 1
    end
  {{X <= Y}}.
Proof.
  eapply hoare_if; eapply hoare_consequence_pre; try apply hoare_asgn; assn_auto'.
Qed.

(* For later proofs, it will help to extend assn_auto' to handle inequalities, too. *)
Ltac assn_auto'' :=
  unfold "->>", assn_sub, t_update, bassn;
  intros; simpl in *;
  try rewrite -> eqb_eq in *;
  try rewrite -> leb_le in *; (* for inequalities *)
  auto; try lia.

Theorem if_minus_plus :
  {{True}}
    if (X <= Y)
      then Z := Y - X
      else Y := X + Z
    end
  {{ Y = X + Z }}.
Proof.
  eapply hoare_if; eapply hoare_consequence_pre; try apply hoare_asgn; assn_auto''.
Qed.

Module If1.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CIf1 : bexp -> com -> com.

Notation "'if1' x 'then' y 'end'" :=
         (CIf1 x y)
         (in custom com at level 0, x custom com at level 99).
Notation "'skip'" :=
         CSkip
         (in custom com at level 0).
Notation "x := y" :=
         (CAsgn x y)
         (in custom com at level 0, x constr at level 0, y at level 85, no associativity).
Notation "x ; y" :=
         (CSeq x y)
         (in custom com at level 90, right associativity).
Notation "'if' x 'then' y 'else' z 'end'" :=
         (CIf x y z)
         (in custom com at level 89, x at level 99, y at level 99, z at level 99).
Notation "'while' x 'do' y 'end'" :=
         (CWhile x y)
         (in custom com at level 89, x at level 99, y at level 99).

Reserved Notation "st '=[' c ']=>' st'"
         (at level 40, c custom com at level 99, st constr, st' constr at next level).
Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      st =[ skip ]=> st
  | E_Asgn : forall st a1 n x,
      aeval st a1 = n ->
      st =[ x := a1 ]=> (x !-> n ; st)
  | E_Seq : forall c1 c2 st st' st'',
      st =[ c1 ]=> st' ->
      st' =[ c2 ]=> st'' ->
      st =[ c1 ; c2 ]=> st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      st =[ c1 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      st =[ c2 ]=> st' ->
      st =[ if b then c1 else c2 end ]=> st'
  | E_WhileFalse : forall b st c,
      beval st b = false ->
      st =[ while b do c end ]=> st
  | E_WhileTrue : forall st st' st'' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st' =[ while b do c end ]=> st'' ->
      st =[ while b do c end ]=> st''
  | E_If1True : forall st st' b c,
      beval st b = true ->
      st =[ c ]=> st' ->
      st =[ if1 b then c end ]=> st'
  | E_If1False : forall st b c,
      beval st b = false ->
      st =[ if1 b then c end ]=> st
  where "st =[ c ]=> st'" := (ceval c st st').

Hint Constructors ceval : core.

Example if1true_test : empty_st =[ if1 X = 0 then X := 1 end ]=> (X !-> 1).
Proof. eauto. Qed.

Example if1false_test : (X !-> 2) =[ if1 X = 0 then X := 1 end ]=> (X !-> 2).
Proof. eauto. Qed.

Definition hoare_triple (P : Assertion) (c : com) (Q : Assertion) : Prop :=
  forall st st', st =[ c ]=> st' -> P st -> Q st'.
Hint Unfold hoare_triple : core.

Notation "{{ P }} c {{ Q }}" := (hoare_triple P c Q)
                                (at level 90, c custom com at level 99)
                                : hoare_spec_scope.

Theorem hoare_if1: forall P Q (b:bexp) c,
  {{ P /\ b }} c {{Q}} ->
  (P /\ ~b)%assertion ->> Q ->
  {{P}} if1 b then c end {{Q}}.
Proof.
  unfold hoare_triple. intros. inversion H1. subst.
  - eauto.
  - subst. apply H0. split. apply H2. congruence.
Qed.

Theorem hoare_consequence_pre : forall (P P' Q : Assertion) c,
  {{P'}} c {{Q}} ->
  P ->> P' ->
  {{P}} c {{Q}}.
Proof.
  eauto.
Qed.
Theorem hoare_asgn : forall Q X a,
  {{Q [X |-> a]}} (X := a) {{Q}}.
Proof.
  intros Q X a st st' Heval HQ.
  inversion Heval; subst.
  auto.
Qed.

Example hoare_if1_good:
  {{ X + Y = Z }}
  if1 ~(Y = 0) then
    X := X + Y
  end
  {{ X = Z }}.
Proof.
  apply hoare_if1; simpl.
  - eapply hoare_consequence_pre. apply hoare_asgn. assn_auto.
  - assn_auto''. destruct H. apply eq_true_negb_classical in H0. apply beq_nat_true in H0.
    rewrite H0 in H. rewrite plus_0_r in H. auto.
Qed.

End If1.

Theorem hoare_while : forall P (b:bexp) c,
  {{P /\ b}} c {{P}} ->
  {{P}} while b do c end {{P /\ ~ b}}.
Proof.
  unfold hoare_triple. intros.
  (* We proceed by induction on Heval, because, in the "keep looping" case,
     its hypotheses talk about the whole loop instead of just c. The
     remember is used to keep the original command in the hypotheses;
     otherwise, it would be lost in the induction. By using inversion
     we clear away all the cases except those involving while. *)
  remember <{while b do c end}> as c' eqn : H'.
  induction H0; try inversion H'; subst; eauto.
Qed.

Example while_example :
  {{X <= 3}}
    while (X <= 2) do
      X := X + 1
    end
  {{X = 3}}.
Proof.
  eapply hoare_consequence_post.
  - simpl. apply hoare_while.
    eapply hoare_consequence_pre.
    + apply hoare_asgn.
    + assn_auto''.
  - assn_auto''.
Qed.

Theorem always_loop_hoare : forall Q,
  {{True}} while true do skip end {{Q}}.
Proof.
  intros.
  eapply hoare_consequence_post.
  - apply hoare_while. auto.
  - assn_auto''.
Qed.


Require Import stdpp.list.
Require Import ssreflect.
From Tweetnacl Require Import Libs.Export.
From Tweetnacl Require Import ListsOp.Export.
From Tweetnacl Require Import Mid.Prep_n.
Local Open Scope Z.

(* upd_Znth 0
                 (upd_Znth 31 (map (fun x : ℤ => Vint (Int.repr x)) (firstn 31 contents_n) ++ [Vundef])
                    (Vint
                       (Int.zero_ext 8
                          (Int.or (Int.and (Int.repr (Znth 31 contents_n 0)) (Int.repr 127)) (Int.repr 64)))))
                 (Vint
                    (cast_int_int I8 Unsigned
                       (Int.and (Int.repr (Znth 0 (firstn 31 contents_n) 0)) (Int.repr 248))))
 *)
(*
z = n
z[31]=(n[31]&127)|64;
z[0]&=248;
*)

Definition clamp (n : list Z) : list Z :=
  (* set last 3 bits to 0 *)
  let x := nth 0 n 0 in
  let x' := Z.land x 248 in
  (* set bit 255 to 0 and bit 254 to 1 *)
  let t := nth 31 n 0 in
  let t' := Z.lor (Z.land t 127) 64 in
  (* update the list *)
  let n' := upd_nth 31 n t' in
    upd_nth 0 n' x'.

Lemma clamp_bound : forall l,
    Forall (fun x => 0 <= x < Z.pow 2 8) l ->
    Forall (fun x => 0 <= x < Z.pow 2 8) (clamp l).
Proof.
move=> l HForall.
unfold clamp.
assert(HForall_inf_supp: Forall (λ x : ℤ, 0 ≤ x) l /\ Forall (λ x : ℤ, x < 2 ^ 8) l)
  by (split ; eapply Forall_impl ; eauto; intros ; simpl in H ; omega).
destruct HForall_inf_supp as [HForall_inf HForall_sup].
apply upd_nth_Forall.
apply upd_nth_Forall.
assumption.
rewrite Z.lor_land_distr_l ; simpl.
split.
apply Z.land_nonneg ; right ; omega.
change 127 with (Z.ones 7).
orewrite Z.land_ones.
assert(Z.lor (nth 31 l 0) 64 `mod` 2 ^ 7 < 2 ^ 7) by (apply Z_mod_lt; reflexivity).
assert(2 ^ 7 < 2 ^ 8) by reflexivity.
omega.
split.
apply Z.land_nonneg.
omega.
apply Z.log2_lt_cancel .
eapply Z.le_lt_trans.
apply Z.log2_land.
apply Forall_nth_d.
omega.
assumption.
omega.
apply Z.min_lt_iff.
right.
reflexivity.
Qed.

Lemma clamp_length : forall l,
  (length l = 32)%nat -> (length (clamp l) = 32)%nat.
Proof. move => l Hl ; rewrite /clamp ?upd_nth_length ; omega. Qed.

Lemma clamp_Zlength : forall l,
  Zlength l = 32 -> Zlength (clamp l) = 32.
Proof. convert_length_to_Zlength clamp_length. Qed.

Local Lemma upd_nth_Forall_bounds: forall l,
  Forall (λ x : ℤ, 0 ≤ x ∧ x < 2 ^ 8) l ->
  Forall (λ x : ℤ, 0 ≤ x ∧ x < 2 ^ 8)
  (upd_nth 0 (upd_nth 31 l (Z.lor (Z.land (nth 31 l 0) 127) 64)) (Z.land (nth 0 l 0) 248)).
Proof.
  intros l HBl.
  repeat apply upd_nth_Forall.
  assumption.
  all: split.
  2,4: apply Z.log2_lt_cancel.
  2: rewrite ?Z.log2_lor.
  2: apply Z.max_lub_lt.
  3: simpl.
  6: assert(Z.log2 (Z.land (nth 0 l 0) 248) ≤ Z.min (Z.log2 (nth 0 l 0)) (Z.log2 248)).
  2: assert(Z.log2 (Z.land (nth 31 l 0) 127) ≤ Z.min (Z.log2 (nth 31 l 0)) (Z.log2 127)).
  2,7: apply Z.log2_land.
  2,4: apply Forall_nth_d.
  3,5: eapply Forall_impl.
  3,5: apply HBl.
  3,4: intro ; simpl ; intro.
  12: assert(Z.log2 (Z.land (nth 0 l 0) 248) ≤ 7).
  8: assert(Z.log2 (Z.land (nth 31 l 0) 127) ≤ 6).
  8,13: simpl in H.
  8,9: eapply Z.min_glb_r.
  8,9: eassumption.
  8,12: simpl.
  1: apply Z.lor_nonneg ; split.
  1,12,14: apply Z.land_nonneg.
  all: try right ; omega.
Qed.

Lemma clamp_ZofList_eq : forall l,
  (length l = 32)%nat ->
  Forall (λ x : ℤ, 0 ≤ x ∧ x < 2 ^ 8) l ->
  Zclamp (ZofList 8 l) = ZofList 8 (clamp l).
Proof.
intros l Hl HBl.
rewrite /Zclamp /clamp.
replace (Z.land (Z.ones 255) (-8)) with (ZofList 8 [248;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;
Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;
Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;
Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;Z.ones 8;127]) => //.
replace (64 ≪ (31 * 8)) with (ZofList 8 [0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;0;64]) => //.
rewrite Zlist_and_ZofList => //.
rewrite Zlist_or_ZofList => //.
2: apply  Forall_Zlist_and => //.
2,3,4: repeat apply list.Forall_cons_2 ; compute ; go.
do 33 (destruct l ; tryfalse) => /=.
assert(HX: forall x, 0 <= x < 2^8 -> Z.land x (Z.ones 8) = x).
{
intros ; rewrite Z.land_ones ; try apply Z.mod_small ; omega.
}
repeat (apply list.Forall_cons_1 in HBl ; destruct HBl as [? HBl]).
repeat (rewrite HX ; [|assumption]).
repeat rewrite Z.lor_0_r.
reflexivity.
Qed.

Lemma clamp_ZofList_eq_Zlength : forall l,
  Zlength l = 32 ->
  Forall (λ x : ℤ, 0 ≤ x ∧ x < 2 ^ 8) l ->
  Zclamp (ZofList 8 l) = ZofList 8 (clamp l).
Proof. convert_length_to_Zlength clamp_ZofList_eq. Qed.

Local Close Scope Z.


Require Import Common PeanoNat List Lia.

Set Implicit Arguments.

Definition nil_dec {A}: forall l: list A, {l = nil} + {l <> nil}.
Proof.
  intros; destruct l; [left; reflexivity|right; discriminate].
Defined.

Definition ocons {A} (oa: option A) (l: list A) :=
  match oa with
  | Some a => a :: l
  | None => l
  end.
Infix "::>" := ocons (at level 0, right associativity).

Fixpoint oll {A} (ol: list (option A)) :=
  match ol with
  | nil => nil
  | oa :: ol' => oa ::> (oll ol')
  end.

Definition oapp {A} (l: list A) (ol: list (option A)) :=
  l ++ oll ol.

Definition o2l {A} (oa: option A): list A := ocons oa nil.
Definition ol2l {A} (oa: option (list A)): list A :=
  match oa with
  | Some l => l
  | None => nil
  end.

Fixpoint replicate {A} (a: A) (sz: nat): list A :=
  match sz with
  | O => []
  | S sz' => a :: replicate a sz'
  end.

Definition list_dec_eq_nil {A}: forall (l: list A), {l = nil} + {l <> nil}.
Proof.
  intros.
  destruct l.
  - left; reflexivity.
  - right; discriminate.
Defined.

Fixpoint lift_each {A} (l: list A): list (list A) :=
  match l with
  | nil => nil
  | a :: l' => [a] :: lift_each l'
  end.

Lemma ocons_app:
  forall {A} (oa: option A) l1 l2,
    ocons oa (l1 ++ l2) = ocons oa l1 ++ l2.
Proof.
  destruct oa as [a|]; simpl; intros; reflexivity.
Qed.

Lemma lift_each_app:
  forall {A} (l1 l2: list A),
    lift_each (l1 ++ l2) = lift_each l1 ++ lift_each l2.
Proof.
  induction l1; simpl; intros; auto.
  rewrite IHl1; reflexivity.
Qed.

Lemma lift_each_concat:
  forall {A} (l: list A),
    l = List.concat (lift_each l).
Proof.
  induction l; simpl; intros; auto.
  rewrite IHl at 1; reflexivity.
Qed.

Section SubDisjEquiv.
  Context {A: Type}.

  Definition SubList (l1 l2: list A) := forall e, In e l1 -> In e l2.
  Definition DisjList (l1 l2: list A) := forall e, ~ In e l1 \/ ~ In e l2.
  Definition EquivList (l1 l2: list A) := SubList l1 l2 /\ SubList l2 l1.

  Lemma SubList_nil: forall l, SubList nil l.
  Proof. unfold SubList; intros; inv H. Qed.

  Lemma SubList_nil_inv: forall l, SubList l nil -> l = nil.
  Proof.
    unfold SubList; intros; destruct l; auto.
    specialize (H a (or_introl eq_refl)); inv H.
  Qed.

  Lemma SubList_cons: forall a l1 l2, In a l2 -> SubList l1 l2 -> SubList (a :: l1) l2.
  Proof. unfold SubList; intros; inv H1; auto. Qed.

  Lemma SubList_cons_inv: forall a l1 l2, SubList (a :: l1) l2 -> In a l2 /\ SubList l1 l2.
  Proof. unfold SubList; intros; split; intuition. Qed.

  Lemma SubList_cons_right: forall a l1 l2, SubList l1 l2 -> SubList l1 (a :: l2).
  Proof. unfold SubList; intros; right; auto. Qed.

  Lemma SubList_forall:
    forall P l1,
      Forall P l1 ->
      forall l2, SubList l2 l1 -> Forall P l2.
  Proof.
    unfold SubList; intros.
    rewrite Forall_forall in H.
    rewrite Forall_forall; intros; auto.
  Qed.

  Lemma SubList_refl: forall l, SubList l l.
  Proof. unfold SubList; intros; auto. Qed.

  Lemma SubList_refl': forall l1 l2, l1 = l2 -> SubList l1 l2.
  Proof. intros; subst; apply SubList_refl. Qed.

  Lemma SubList_trans:
    forall l1 l2 l3, SubList l1 l2 -> SubList l2 l3 -> SubList l1 l3.
  Proof. unfold SubList; intros; auto. Qed.

  Lemma SubList_singleton:
    forall a1 a2, SubList [a1] [a2] -> a1 = a2.
  Proof.
    intros.
    specialize (H a1 (or_introl eq_refl)).
    firstorder.
  Qed.

  Lemma SubList_singleton_In:
    forall a l, SubList [a] l -> In a l.
  Proof.
    intros; firstorder.
  Qed.

  Lemma SubList_singleton_NoDup:
    forall l a,
      SubList l [a] -> NoDup l -> l = nil \/ l = [a].
  Proof.
    intros.
    destruct l; [auto|].
    right.
    apply SubList_cons_inv in H; dest.
    inv H0; dest_in.
    destruct l; [auto|].
    apply SubList_cons_inv in H1; dest.
    inv H5; dest_in.
    elim H4; left; reflexivity.
  Qed.

  Lemma SubList_app_1: forall l1 l2 l3, SubList l1 l2 -> SubList l1 (l2 ++ l3).
  Proof.
    unfold SubList; intros; apply in_or_app; left; auto.
  Qed.

  Lemma SubList_app_2: forall l1 l2 l3, SubList l1 l3 -> SubList l1 (l2 ++ l3).
  Proof.
    unfold SubList; intros; apply in_or_app; right; auto.
  Qed.

  Lemma SubList_app_3: forall l1 l2 l3, SubList l1 l3 -> SubList l2 l3 -> SubList (l1 ++ l2) l3.
  Proof.
    unfold SubList; intros.
    apply in_app_or in H1; destruct H1; intuition.
  Qed.

  Lemma SubList_app_4: forall l1 l2 l3, SubList (l1 ++ l2) l3 -> SubList l1 l3.
  Proof.
    unfold SubList; intros; apply H; apply in_or_app; left; auto.
  Qed.

  Lemma SubList_app_5: forall l1 l2 l3, SubList (l1 ++ l2) l3 -> SubList l2 l3.
  Proof.
    unfold SubList; intros; apply H; apply in_or_app; right; auto.
  Qed.

  Lemma SubList_app_6:
    forall l1 l2 l3 l4, SubList l1 l2 -> SubList l3 l4 -> SubList (l1 ++ l3) (l2 ++ l4).
  Proof.
    intros; apply SubList_app_3.
    - apply SubList_app_1; auto.
    - apply SubList_app_2; auto.
  Qed.

  Lemma SubList_app_7:
    forall l1 l2 l3, SubList (l1 ++ l2) l3 -> SubList l1 l3 /\ SubList l2 l3.
  Proof.
    intros; split.
    - eapply SubList_app_4; eauto.
    - eapply SubList_app_5; eauto.
  Qed.

  Lemma SubList_app_comm:
    forall l1 l2 l3, SubList l1 (l2 ++ l3) -> SubList l1 (l3 ++ l2).
  Proof.
    unfold SubList; intros.
    apply in_or_app.
    specialize (H e H0); apply in_app_or in H; intuition.
  Qed.

  Lemma SubList_app_idempotent:
    forall l1 l2, SubList l1 (l2 ++ l2) -> SubList l1 l2.
  Proof.
    unfold SubList; intros.
    specialize (H e H0).
    apply in_app_or in H; intuition.
  Qed.

  Definition subList_dec:
    forall (deceqA : forall x y: A, sumbool (x = y) (x <> y))
           l1 l2,
      {SubList l1 l2} + {~ SubList l1 l2}.
  Proof.
    induction l1; intros.
    - left; apply SubList_nil.
    - destruct (IHl1 l2).
      + destruct (in_dec deceqA a l2).
        * left; apply SubList_cons; assumption.
        * right; intro Hx; elim n.
          apply SubList_cons_inv in Hx.
          destruct Hx.
          assumption.
      + right; intro Hx; elim n.
        apply SubList_cons_inv in Hx.
        destruct Hx.
        assumption.
  Defined.

  Lemma EquivList_nil: EquivList nil nil.
  Proof. split; unfold SubList; intros; inv H. Qed.

  Lemma EquivList_nil_inv_1: forall l, EquivList l nil -> l = nil.
  Proof. intros; inv H; apply SubList_nil_inv; auto. Qed.

  Lemma EquivList_nil_inv_2: forall l, EquivList nil l -> l = nil.
  Proof. intros; inv H; apply SubList_nil_inv; auto. Qed.

  Lemma EquivList_cons:
    forall a1 a2 l1 l2,
      EquivList l1 l2 -> a1 = a2 -> EquivList (a1 :: l1) (a2 :: l2).
  Proof.
    intros; inv H; subst; split;
      try (apply SubList_cons; [left; auto|apply SubList_cons_right; auto]).
  Qed.

  Lemma EquivList_refl: forall l, EquivList l l.
  Proof. intros; split; apply SubList_refl. Qed.

  Lemma EquivList_comm: forall l1 l2, EquivList l1 l2 -> EquivList l2 l1.
  Proof. unfold EquivList; intros; dest; split; auto. Qed.

  Lemma EquivList_trans:
    forall l1 l2 l3, EquivList l1 l2 -> EquivList l2 l3 -> EquivList l1 l3.
  Proof. intros; inv H; inv H0; split; eapply SubList_trans; eauto. Qed.

  Lemma EquivList_app:
    forall l1 l2 l3 l4,
      EquivList l1 l2 -> EquivList l3 l4 ->
      EquivList (l1 ++ l3) (l2 ++ l4).
  Proof.
    unfold EquivList; intros; dest; split.
    - apply SubList_app_3.
      + apply SubList_app_1; auto.
      + apply SubList_app_2; auto.
    - apply SubList_app_3.
      + apply SubList_app_1; auto.
      + apply SubList_app_2; auto.
  Qed.

  Lemma EquivList_app_comm: forall l1 l2, EquivList (l1 ++ l2) (l2 ++ l1).
  Proof.
    unfold EquivList; intros; split.
    - apply SubList_app_3.
      + apply SubList_app_2, SubList_refl; auto.
      + apply SubList_app_1, SubList_refl; auto.
    - apply SubList_app_3.
      + apply SubList_app_2, SubList_refl; auto.
      + apply SubList_app_1, SubList_refl; auto.
  Qed.

  Lemma EquivList_app_idempotent:
    forall l1 l2, EquivList l1 (l2 ++ l2) -> EquivList l1 l2.
  Proof.
    unfold EquivList; intros; dest; split.
    - apply SubList_app_idempotent; auto.
    - eapply SubList_app_4; eauto.
  Qed.

  Lemma DisjList_spec_1:
    forall (deceqA: forall a1 a2: A, {a1 = a2} + {a1 <> a2})
           (l1 l2: list A),
      (forall a, In a l1 -> ~ In a l2) ->
      DisjList l1 l2.
  Proof.
    intros; red; intros.
    destruct (in_dec deceqA e l1); auto.
  Qed.

  Lemma DisjList_spec_2:
    forall (deceqA: forall a1 a2: A, {a1 = a2} + {a1 <> a2})
           (l1 l2: list A),
      (forall a, In a l2 -> ~ In a l1) ->
      DisjList l1 l2.
  Proof.
    intros; red; intros.
    destruct (in_dec deceqA e l2); auto.
  Qed.

  Lemma DisjList_false_spec:
    forall (deceqA : forall x y: A, sumbool (x = y) (x <> y))
           l1 l2,
      (forall a, In a l1 -> In a l2 -> False) ->
      DisjList l1 l2.
  Proof.
    intros; red; intros.
    destruct (in_dec deceqA e l1); auto.
    destruct (in_dec deceqA e l2); auto.
    exfalso; eauto.
  Qed.

  Lemma DisjList_nil_1: forall l, DisjList nil l.
  Proof. unfold DisjList; auto. Qed.

  Lemma DisjList_nil_2: forall l, DisjList l nil.
  Proof. unfold DisjList; auto. Qed.

  Lemma DisjList_cons:
    forall a l1 l2, DisjList (a :: l1) l2 ->
                    ~ In a l2 /\ DisjList l1 l2.
  Proof.
    unfold DisjList; intros.
    split.
    - specialize (H a); intuition.
    - intros; specialize (H e); intuition.
  Qed.

  Lemma DisjList_cons_inv:
    forall (deceqA : forall x y: A, sumbool (x = y) (x <> y))
           a l1 l2,
      DisjList l1 l2 -> ~ In a l2 -> DisjList (a :: l1) l2.
  Proof.
    unfold DisjList; intros.
    specialize (H e); destruct H; auto.
    destruct (deceqA a e); subst; auto.
    left; intro Hx; elim H.
    inv Hx; auto.
    exfalso; auto.
  Qed.

  Lemma DisjList_In_1:
    forall a l1 l2,
      DisjList l1 l2 -> In a l2 -> ~ In a l1.
  Proof.
    unfold DisjList; intros.
    specialize (H a); destruct H; auto.
  Qed.

  Lemma DisjList_In_2:
    forall a l1 l2,
      DisjList l1 l2 -> In a l1 -> ~ In a l2.
  Proof.
    unfold DisjList; intros.
    specialize (H a); destruct H; auto.
  Qed.

  Lemma DisjList_In_neq:
    forall a1 a2 l1 l2,
      DisjList l1 l2 -> In a1 l1 -> In a2 l2 -> a1 <> a2.
  Proof.
    unfold DisjList; intros.
    intro Hx; subst.
    specialize (H a2); destruct H; auto.
  Qed.

  Lemma DisjList_comm: forall l1 l2, DisjList l1 l2 -> DisjList l2 l1.
  Proof.
    intros. unfold DisjList in *. intros e. specialize (H e). intuition.
  Qed.

  Lemma DisjList_SubList: forall sl1 l1 l2, SubList sl1 l1 -> DisjList l1 l2 -> DisjList sl1 l2.
  Proof.
    intros. unfold SubList, DisjList in *. intros e.
    specialize (H e). specialize (H0 e). intuition.
  Qed.

  Lemma NoDup_DisjList:
    forall l1 l2,
      NoDup l1 -> NoDup l2 -> DisjList l1 l2 ->
      NoDup (l1 ++ l2).
  Proof.
    induction l1; simpl; intros; auto.
    inv H; constructor.
    - intro Hx; apply in_app_or in Hx; destruct Hx; [auto|].
      specialize (H1 a); destruct H1; auto.
      elim H1; simpl; tauto.
    - apply IHl1; auto.
      eapply DisjList_cons; eauto.
  Qed.

  Lemma DisjList_NoDup:
    forall (deceqA : forall x y: A, sumbool (x = y) (x <> y))
           l1 l2,
      NoDup (l1 ++ l2) -> DisjList l1 l2.
  Proof.
    induction l1; simpl; intros.
    - apply DisjList_nil_1.
    - inv H.
      apply DisjList_cons_inv; auto.
      intro Hx; elim H2.
      apply in_or_app; auto.
  Qed.

  Lemma DisjList_app_1: forall l1 l2 l3, DisjList l1 (l2 ++ l3) -> DisjList l1 l2.
  Proof.
    intros. unfold DisjList in *. intros e.
    destruct (H e); [left | right].
    - assumption.
    - intuition.
  Qed.

  Lemma DisjList_app_2: forall l1 l2 l3, DisjList l1 (l2 ++ l3) -> DisjList l1 l3.
  Proof.
    intros. unfold DisjList in *. intros e.
    destruct (H e); [left | right].
    - assumption.
    - intuition.
  Qed.

  Lemma DisjList_app_3:
    forall l1 l2 l3, DisjList (l1 ++ l2) l3 -> DisjList l1 l3 /\ DisjList l2 l3.
  Proof.
    intros; unfold DisjList in *; split.
    - intros; destruct (H e).
      + left; intuition.
      + right; intuition.
    - intros; destruct (H e).
      + left; intuition.
      + right; intuition.
  Qed.

  Lemma DisjList_app_4:
    forall l1 l2 l3,
      DisjList l1 l3 -> DisjList l2 l3 -> DisjList (l1 ++ l2) l3.
  Proof.
    intros; unfold DisjList in *; intros.
    specialize (H e); specialize (H0 e).
    destruct H; auto.
    destruct H0; auto.
    left; intro Hx.
    apply in_app_or in Hx; destruct Hx; auto.
  Qed.

  Lemma DisjList_singleton_1:
    forall (deceqA : forall x y: A, sumbool (x = y) (x <> y)) a1 l2,
      ~ In a1 l2 ->
      DisjList [a1] l2.
  Proof.
    unfold DisjList; intros.
    destruct (deceqA e a1); subst; firstorder.
  Qed.

  Lemma DisjList_singleton_2:
    forall (deceqA : forall x y: A, sumbool (x = y) (x <> y)) l1 a2,
      ~ In a2 l1 ->
      DisjList l1 [a2].
  Proof.
    unfold DisjList; intros.
    destruct (deceqA e a2); subst; firstorder.
  Qed.

  Lemma DisjList_singletons:
    forall (deceqA : forall x y: A, sumbool (x = y) (x <> y)) a1 a2,
      a1 <> a2 -> DisjList [a1] [a2].
  Proof.
    unfold DisjList; intros.
    destruct (deceqA e a1); subst; firstorder.
  Qed.

End SubDisjEquiv.

Lemma SubList_map: forall {A B} (l1 l2: list A) (f: A -> B),
                     SubList l1 l2 -> SubList (map f l1) (map f l2).
Proof.
  induction l1; intros; simpl; unfold SubList in *; intros; inv H0.
  - apply in_map; apply H; left; reflexivity.
  - apply IHl1; auto.
    intros; specialize (H e0); apply H; right; assumption.
Qed.

Lemma DisjList_map:
  forall {A B} (f: A -> B) (l1 l2: list A),
    DisjList (map f l1) (map f l2) ->
    DisjList l1 l2.
Proof.
  unfold DisjList; intros.
  specialize (H (f e)); destruct H.
  - left; intro Hx; elim H; apply in_map; assumption.
  - right; intro Hx; elim H; apply in_map; assumption.
Qed.

Section Removal.
  Context {A: Type}.
  Hypothesis (eq_dec: forall x y: A, {x = y} + {x <> y}).

  Fixpoint removeOnce (a: A) (l: list A) :=
    match l with
    | nil => nil
    | h :: t => if eq_dec a h then t else h :: removeOnce a t
    end.

  Fixpoint removeL (l1 l2: list A) :=
    match l2 with
    | nil => l1
    | h :: t => removeL (removeOnce h l1) t
    end.

  Lemma removeOnce_nil:
    forall a, removeOnce a [a] = nil.
  Proof.
    intros; simpl.
    destruct (eq_dec a a); auto.
    elim n; reflexivity.
  Qed.

  Lemma removeL_nil:
    forall l, removeL l l = nil.
  Proof.
    induction l; simpl; intros; [reflexivity|].
    destruct (eq_dec a a); auto.
    elim n; reflexivity.
  Qed.

  Lemma removeOnce_In_1:
    forall a1 a2,
      a1 <> a2 ->
      forall l,
        In a1 l ->
        In a1 (removeOnce a2 l).
  Proof.
    induction l; simpl; intros; auto.
    destruct H0; subst.
    - destruct (eq_dec a2 a1); subst.
      + elim H; reflexivity.
      + left; reflexivity.
    - destruct (eq_dec a2 a); subst; auto.
      right; auto.
  Qed.

  Lemma removeOnce_In_2:
    forall a1 a2 l,
      In a1 (removeOnce a2 l) ->
      In a1 l.
  Proof.
    induction l; simpl; intros; auto.
    destruct (eq_dec a2 a); subst; auto.
    inv H; auto.
  Qed.

  Lemma removeOnce_NoDup:
    forall a l,
      NoDup l -> NoDup (removeOnce a l).
  Proof.
    induction l; simpl; intros; auto.
    inv H; destruct (eq_dec a a0); auto.
    constructor; auto.
    intro Hx; elim H2.
    eapply removeOnce_In_2; eauto.
  Qed.

  Lemma removeOnce_In_NoDup:
    forall a1 a2 l,
      NoDup l -> In a1 (removeOnce a2 l) ->
      a1 <> a2 /\ In a1 l.
  Proof.
    induction l; simpl; intros; auto.
    inv H.
    destruct (eq_dec a2 a); [subst|].
    - split; [|auto].
      intro Hx; subst; auto.
    - inv H0; auto.
      specialize (IHl H4 H); dest; auto.
  Qed.

  Lemma removeL_In_1:
    forall a l2 l1,
      In a l1 -> ~ In a l2 ->
      In a (removeL l1 l2).
  Proof.
    induction l2; simpl; intros; auto.
    apply IHl2; try (firstorder; fail).
    apply removeOnce_In_1; auto.
  Qed.

  Lemma removeL_In_2:
    forall a l2 l1,
      In a (removeL l1 l2) ->
      In a l1.
  Proof.
    induction l2; simpl; intros; auto.
    specialize (IHl2 _ H).
    eapply removeOnce_In_2; eauto.
  Qed.

  Lemma forall_removeOnce:
    forall a l P,
      Forall P l ->
      Forall P (removeOnce a l).
  Proof.
    induction l; simpl; intros; auto.
    inv H.
    destruct (eq_dec a a0); auto.
  Qed.

  Lemma forall_removeL:
    forall l2 l1 P,
      Forall P l1 ->
      Forall P (removeL l1 l2).
  Proof.
    induction l2; simpl; intros; auto.
    apply IHl2.
    apply forall_removeOnce.
    auto.
  Qed.

  Lemma removeOnce_app_1:
    forall a (l1 l2: list A),
      In a l1 ->
      removeOnce a (l1 ++ l2) =
      removeOnce a l1 ++ l2.
  Proof.
    induction l1; simpl; intros; [elim H|].
    destruct H; subst.
    - destruct (eq_dec a a); auto.
      elim n; reflexivity.
    - destruct (eq_dec a a0); auto.
      rewrite IHl1 by assumption.
      reflexivity.
  Qed.

  Lemma removeOnce_app_2:
    forall a (l1 l2: list A),
      ~ In a l1 ->
      removeOnce a (l1 ++ l2) =
      l1 ++ removeOnce a l2.
  Proof.
    induction l1; simpl; intros; auto.
    destruct (eq_dec a a0); subst.
    - elim H; left; reflexivity.
    - rewrite IHl1; [reflexivity|].
      intro Hx; elim H; auto.
  Qed.

  Lemma removeOnce_SubList_1:
    forall l1 l2,
      SubList l1 l2 ->
      forall a,
        ~ In a l1 ->
        SubList l1 (removeOnce a l2).
  Proof.
    unfold SubList; intros.
    destruct (eq_dec a e); subst.
    - elim H0; assumption.
    - apply removeOnce_In_1; auto.
  Qed.

  Lemma removeOnce_SubList_2:
    forall a l2,
      SubList (removeOnce a l2) l2.
  Proof.
    unfold SubList; intros.
    eapply removeOnce_In_2; eauto.
  Qed.

  Lemma removeOnce_SubList_3:
    forall a l2,
      SubList l2 (a :: removeOnce a l2).
  Proof.
    unfold SubList; intros.
    destruct (eq_dec a e); subst.
    - intuition.
    - right; apply removeOnce_In_1; auto.
  Qed.

  Lemma removeOnce_length:
    forall a l,
      In a l ->
      length l > 0 /\ length (removeOnce a l) = length l - 1.
  Proof.
    induction l; simpl; intros; [exfalso; auto|].
    destruct H; subst.
    - destruct (eq_dec a a); [clear e|exfalso; auto].
      split; lia.
    - destruct (eq_dec a a0); [subst|].
      + split; lia.
      + simpl.
        specialize (IHl H); destruct IHl.
        split; lia.
  Qed.

  Lemma removeL_SubList_1:
    forall l1 l2,
      SubList l1 l2 ->
      forall l3,
        DisjList l1 l3 ->
        SubList l1 (removeL l2 l3).
  Proof.
    intros.
    generalize dependent l2.
    generalize dependent l1.
    induction l3; simpl; intros; auto.
    apply DisjList_comm, DisjList_cons in H0; dest.
    apply DisjList_comm in H1.
    apply IHl3; auto.
    apply removeOnce_SubList_1; auto.
  Qed.

  Lemma removeL_SubList_2:
    forall l1 l2,
      SubList (removeL l1 l2) l1.
  Proof.
    intros.
    generalize dependent l1.
    induction l2; simpl; intros.
    - apply SubList_refl.
    - eapply SubList_trans.
      + eapply IHl2.
      + apply removeOnce_SubList_2.
  Qed.

  Lemma removeL_SubList_3:
    forall l1 l2,
      SubList l1 (l2 ++ removeL l1 l2).
  Proof.
    intros.
    generalize dependent l1.
    induction l2; simpl; intros.
    - apply SubList_refl.
    - specialize (IHl2 (removeOnce a l1)).
      eapply SubList_trans.
      + apply removeOnce_SubList_3 with (a:= a).
      + apply SubList_cons.
        * intuition.
        * apply SubList_cons_right; auto.
  Qed.

  Lemma removeL_DisjList:
    forall l1 l2 l3,
      DisjList l1 l3 ->
      DisjList (removeL l1 l2) l3.
  Proof.
    intros.
    eapply DisjList_SubList.
    - apply removeL_SubList_2.
    - assumption.
  Qed.

  Lemma removeL_app_1:
    forall (l1 l2 l3: list A),
      removeL l1 (l2 ++ l3) =
      removeL (removeL l1 l2) l3.
  Proof.
    intros.
    generalize dependent l1.
    generalize dependent l3.
    induction l2; simpl; intros; auto.
  Qed.

  Lemma removeL_app_2:
    forall (l1 l2: list A),
      removeL (l1 ++ l2) l1 = l2.
  Proof.
    induction l1; simpl; intros; auto.
    destruct (eq_dec a a); auto.
    elim n; reflexivity.
  Qed.

  Lemma removeL_app_3:
    forall (l1 l2 l3: list A),
      SubList l3 l1 -> NoDup l3 ->
      removeL (l1 ++ l2) l3 =
      removeL l1 l3 ++ l2.
  Proof.
    intros.
    generalize dependent l2.
    generalize dependent l1.
    induction l3; simpl; intros; auto.
    apply SubList_cons_inv in H; dest.
    inv H0.
    rewrite <-IHl3.
    - rewrite removeOnce_app_1 by assumption.
      reflexivity.
    - assumption.
    - apply removeOnce_SubList_1; assumption.
  Qed.

  Lemma removeL_app_4:
    forall (l1 l2 l3: list A),
      DisjList l1 l3 ->
      removeL (l1 ++ l2) l3 =
      l1 ++ removeL l2 l3.
  Proof.
    intros.
    generalize dependent l2.
    generalize dependent l1.
    induction l3; simpl; intros; auto.
    apply DisjList_comm, DisjList_cons in H; dest.
    apply DisjList_comm in H0.
    rewrite removeOnce_app_2; auto.
  Qed.

  Lemma removeL_In_NoDup:
    forall a l2 l1,
      NoDup l1 -> In a (removeL l1 l2) ->
      ~ In a l2 /\ In a l1.
  Proof.
    induction l2; simpl; intros; auto.
    specialize (IHl2 _ (removeOnce_NoDup a0 H) H0); dest.
    split.
    - intro Hx; destruct Hx; subst; auto.
      apply removeOnce_In_NoDup in H2; [|assumption].
      dest; auto.
    - apply removeOnce_In_NoDup in H2; [|assumption].
      dest; auto.
  Qed.

End Removal.

Lemma SubList_NoDup_removeL_nil:
  forall {A} (eq_dec: forall x y: A, {x = y} + {x <> y})
         (l1 l2: list A),
    SubList l2 l1 -> NoDup l2 ->
    removeL eq_dec l2 l1 = nil.
Proof.
  induction l1; simpl; intros;
    [apply SubList_nil_inv in H; auto|].
  eapply IHl1; [|apply removeOnce_NoDup; assumption].
  clear IHl1.
  generalize dependent l1.
  induction l2; simpl; intros; [apply SubList_nil|].
  destruct (eq_dec a a0); subst.
  - apply SubList_cons_inv in H; dest.
    red; intros.
    pose proof (H1 _ H2).
    inv H3; auto.
    exfalso; inv H0; auto.
  - apply SubList_cons.
    + apply SubList_cons_inv in H; dest.
      inv H; [exfalso; auto|auto].
    + eapply IHl2.
      * inv H0; auto.
      * apply SubList_cons_inv in H; dest; auto.
Qed.

Lemma SubList_NoDup_length_eq_removeL_nil:
  forall {A} (eq_dec: forall x y: A, {x = y} + {x <> y})
         (l1 l2: list A),
    SubList l1 l2 -> NoDup l1 ->
    length l1 = length l2 ->
    removeL eq_dec l2 l1 = nil.
Proof.
  induction l1; simpl; intros;
    [destruct l2; [reflexivity|discriminate]|].
  apply SubList_cons_inv in H; dest; inv H0.
  destruct l2; [exfalso; auto|].
  inv H1.
  destruct (eq_dec a0 a).
  - subst; simpl; destruct (eq_dec a a) as [Heq|Hneq]; [clear Heq|exfalso; auto].
    eapply IHl1; eauto.
    red; intros; specialize (H2 _ H0).
    inv H2; intuition.
  - inv H; [exfalso; auto|].
    simpl; destruct (eq_dec a a0) as [Heq|Hneq]; [exfalso; auto|clear Hneq].
    eapply IHl1.
    + red; intros; specialize (H2 _ H).
      inv H2; [left; reflexivity|].
      right; eapply removeOnce_In_1.
      * intro Hx; subst; auto.
      * assumption.
    + assumption.
    + simpl; pose proof (removeOnce_length eq_dec _ _ H0); dest.
      lia.
Qed.

Section SSubList.
  Context {A: Type}.

  Inductive SSubList: list A -> list A -> Prop :=
  | SSLnil: SSubList nil nil
  | SSLcons1:
      forall l1 l2 a,
        SSubList l1 l2 ->
        SSubList l1 (a :: l2)
  | SSLcons2:
      forall l1 l2 a,
        SSubList l1 l2 ->
        SSubList (a :: l1) (a :: l2).

  Lemma SSubList_refl:
    forall l, SSubList l l.
  Proof.
    induction l; simpl; intros.
    - constructor.
    - eapply SSLcons2; auto.
  Qed.

  Lemma SSubList_app_1:
    forall l1 l2,
      SSubList l2 (l1 ++ l2).
  Proof.
    induction l1; simpl; intros.
    - apply SSubList_refl.
    - eapply SSLcons1; auto.
  Qed.

  Lemma SSubList_app_2:
    forall l1 l2,
      SSubList l1 l2 ->
      forall l3,
        SSubList (l1 ++ l3) (l2 ++ l3).
  Proof.
    induction 1; simpl; intros.
    - apply SSubList_refl.
    - apply SSLcons1; auto.
    - apply SSLcons2; auto.
  Qed.

  Lemma SSubList_SubList:
    forall l1 l2,
      SSubList l1 l2 -> SubList l1 l2.
  Proof.
    induction 1; simpl; intros.
    - apply SubList_nil.
    - apply SubList_cons_right; auto.
    - apply SubList_cons.
      + left; reflexivity.
      + apply SubList_cons_right; auto.
  Qed.

  Lemma SSubList_removeOnce_1:
    forall (eq_dec: forall x y: A, {x = y} + {x <> y}) l1 l2,
      SSubList l1 l2 ->
      forall a,
        SSubList (removeOnce eq_dec a l1) l2.
  Proof.
    induction 1; simpl; intros.
    - apply SSubList_refl.
    - apply SSLcons1; auto.
    - destruct (eq_dec a0 a); subst.
      + apply SSLcons1; auto.
      + apply SSLcons2; auto.
  Qed.

  Lemma SSubList_removeOnce_2:
    forall (eq_dec: forall x y: A, {x = y} + {x <> y}) l1 l2,
      SSubList l1 l2 ->
      forall a,
        SSubList (removeOnce eq_dec a l1) (removeOnce eq_dec a l2).
  Proof.
    induction 1; simpl; intros.
    - apply SSubList_refl.
    - destruct (eq_dec a0 a); subst.
      + apply SSubList_removeOnce_1; auto.
      + apply SSLcons1; auto.
    - destruct (eq_dec a0 a); subst; auto.
      apply SSLcons2; auto.
  Qed.

  Lemma SSubList_removeL_1:
    forall (eq_dec: forall x y: A, {x = y} + {x <> y}) l1 l2,
      SSubList l1 l2 ->
      forall l3,
        SSubList (removeL eq_dec l1 l3) l2.
  Proof.
    intros.
    generalize dependent l2.
    generalize dependent l1.
    induction l3; simpl; intros; auto.
    apply IHl3.
    apply SSubList_removeOnce_1; auto.
  Qed.

  Lemma SSubList_removeL_2:
    forall (eq_dec: forall x y: A, {x = y} + {x <> y}) l1 l2,
      SSubList l1 l2 ->
      forall l3,
        SSubList (removeL eq_dec l1 l3) (removeL eq_dec l2 l3).
  Proof.
    intros.
    generalize dependent l2.
    generalize dependent l1.
    induction l3; simpl; intros; auto.
    apply IHl3.
    apply SSubList_removeOnce_2; auto.
  Qed.

End SSubList.

Section Distribution.
  Context {A: Type}.

  Inductive Distribution: list A -> list A -> list A -> Prop :=
  | DistrNil: Distribution nil nil nil
  | DistrL:
      forall l ll1 ll2 rl a,
        Distribution l (ll1 ++ ll2) rl ->
        Distribution (a :: l) (ll1 ++ a :: ll2) rl
  | DistrR:
      forall l ll rl1 rl2 a,
        Distribution l ll (rl1 ++ rl2) ->
        Distribution (a :: l) ll (rl1 ++ a :: rl2).

  Lemma distribution_left:
    forall l, Distribution l l nil.
  Proof.
    induction l; simpl; intros.
    - constructor; auto.
    - change (a :: l) with ([] ++ a :: l) at 2.
      constructor; auto.
  Qed.

  Lemma distribution_right:
    forall l, Distribution l nil l.
  Proof.
    induction l; simpl; intros.
    - constructor; auto.
    - change (a :: l) with ([] ++ a :: l) at 2.
      constructor; auto.
  Qed.

  Lemma distribution_add_left_head:
    forall l1 l2 dl1 dl2,
      Distribution (l1 ++ l2) dl1 dl2 ->
      forall a,
        Distribution (l1 ++ a :: l2) (a :: dl1) dl2.
  Proof.
    induction l1; simpl; intros.
    - change (a :: dl1) with ([] ++ a :: dl1).
      constructor; auto.
    - inv H.
      + change (a0 :: ll1 ++ a :: ll2) with ((a0 :: ll1) ++ a :: ll2).
        apply DistrL.
        simpl; auto.
      + apply DistrR; auto.
  Qed.

  Lemma distribution_add_right_head:
    forall l1 l2 dl1 dl2,
      Distribution (l1 ++ l2) dl1 dl2 ->
      forall a,
        Distribution (l1 ++ a :: l2) dl1 (a :: dl2).
  Proof.
    induction l1; simpl; intros.
    - change (a :: dl2) with ([] ++ a :: dl2).
      constructor; auto.
    - inv H.
      + apply DistrL; auto.
      + change (a0 :: rl1 ++ a :: rl2) with ((a0 :: rl1) ++ a :: rl2).
        apply DistrR.
        simpl; auto.
  Qed.

End Distribution.

(** [caseDec], a case statement by decidability *)

Fixpoint caseDec {A B} (dec: forall a1 a2: A, {a1 = a2} + {a1 <> a2})
         (a: A) (def: B) (cs: list (A * B)) :=
  match cs with
  | List.nil => def
  | List.cons (ca, cp) cs' =>
    if dec a ca then cp else caseDec dec a def cs'
  end.

Declare Scope cases_scope.

Module CaseNotations.
  Notation "x : t" := (x, t) (at level 90, only parsing): cases_scope.
  Notation "|! xt" := (List.cons xt List.nil) (at level 95, only parsing): cases_scope.
  Notation "| xt1 | xt2 | .. | xtn" :=
    (List.cons xt1 (List.cons xt2 .. (List.cons xtn List.nil) ..))
      (at level 95, only parsing): cases_scope.
  Delimit Scope cases_scope with cases.
  Notation "'match' 'case' X 'on' DEC 'default' DEF 'with' CS 'end'" :=
    (caseDec DEC X DEF CS%cases) (only parsing).
End CaseNotations.

Lemma caseDec_head_eq:
  forall {A B} (eq_dec: forall a1 a2: A, {a1 = a2} + {a1 <> a2})
         k (df: B) hd tl,
    k = fst hd ->
    caseDec eq_dec k df (hd :: tl) = snd hd.
Proof.
  intros; subst.
  destruct hd as [hk hv]; simpl.
  find_if_inside; [reflexivity|exfalso; auto].
Qed.

Lemma caseDec_head_neq:
  forall {A B} (eq_dec: forall a1 a2: A, {a1 = a2} + {a1 <> a2})
         k (df: B) hd tl,
    k <> fst hd ->
    caseDec eq_dec k df (hd :: tl) = caseDec eq_dec k df tl.
Proof.
  intros; subst.
  destruct hd as [hk hv]; simpl.
  find_if_inside; [exfalso; auto|reflexivity].
Qed.

Ltac disc_caseDec Hcd :=
  repeat
    (first [rewrite caseDec_head_eq in Hcd by reflexivity
           |rewrite caseDec_head_neq in Hcd by discriminate]);
  simpl in Hcd.

Ltac solve_caseDec :=
  repeat
    (first [rewrite caseDec_head_eq by reflexivity
           |rewrite caseDec_head_neq by discriminate]);
  simpl.

(** Utility lemmas for general lists *)

Lemma tl_In:
  forall {A} (a: A) (l: list A),
    In a (tl l) ->
    In a l.
Proof.
  intros.
  destruct l; [elim H|simpl in H].
  right; assumption.
Qed.

Lemma tl_app:
  forall {A} (l1 l2: list A),
    l1 <> nil -> tl (l1 ++ l2) = (tl l1) ++ l2.
Proof.
  destruct l1; intuition idtac.
Qed.

Lemma cons_app:
  forall {A} (a: A) (l: list A),
    a :: l = (a :: nil) ++ l.
Proof.
  reflexivity.
Qed.

Lemma app_eq_compare:
  forall {A} (l m n o: list A),
    l ++ m = n ++ o ->
    exists p, (l = n ++ p /\ o = p ++ m) \/
              (n = l ++ p /\ m = p ++ o).
Proof.
  induction l; simpl; intros.
  - subst; eexists; right; eauto.
  - destruct n as [|b n].
    + simpl in *; subst.
      eexists; left; eauto.
    + simpl in H; inv H.
      specialize (IHl _ _ _ H2).
      destruct IHl as [p ?]; destruct H; dest; subst; [|eauto].
      eexists; left; split; reflexivity.
Qed.

Lemma Forall_app:
  forall {A} (l1 l2: list A) P,
    Forall P l1 -> Forall P l2 -> Forall P (l1 ++ l2).
Proof.
  induction l1; simpl; intros; auto.
  inv H; constructor; auto.
Qed.

Lemma Forall_app_inv:
  forall {A} (l1 l2: list A) P,
    Forall P (l1 ++ l2) -> Forall P l1 /\ Forall P l2.
Proof.
  induction l1; simpl; intros; auto.
  inv H; specialize (IHl1 _ _ H3); dest; auto.
Qed.

Lemma Forall_remove:
  forall {A} dec P (a: A) (l: list A),
    Forall P l -> Forall P (remove dec a l).
Proof.
  induction l; simpl; intros; auto.
  inv H; destruct (dec a a0); auto.
Qed.

Lemma Forall_filter:
  forall {A} P f (l: list A),
    Forall P l -> Forall P (filter f l).
Proof.
  induction l; simpl; intros; auto.
  inv H.
  destruct (f a); auto.
Qed.

Lemma filter_app:
  forall {A} f (l1 l2: list A),
    filter f (l1 ++ l2) = filter f l1 ++ filter f l2.
Proof.
  induction l1; simpl; intros; [reflexivity|].
  rewrite IHl1; destruct (f a); auto.
Qed.

Lemma in_remove:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y})
         (a x: A) (l: list A),
    In a (remove eq_dec x l) -> In a l.
Proof.
  induction l; simpl; intros; auto.
  destruct (eq_dec _ _); subst; auto.
  destruct H; auto.
Qed.

Lemma in_remove_neq:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y})
         (a x: A) (l: list A),
    In a l -> a <> x -> In a (remove eq_dec x l).
Proof.
  induction l; simpl; intros; auto.
  destruct (eq_dec _ _); subst.
  - destruct H; [exfalso; auto|].
    apply IHl; auto.
  - destruct H; subst.
    + left; reflexivity.
    + right; apply IHl; auto.
Qed.

Lemma remove_cons:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y})
         (a: A) (l: list A),
    remove eq_dec a (a :: l) = remove eq_dec a l.
Proof.
  intros; simpl.
  destruct (eq_dec _ _); auto.
  elim n; auto.
Qed.

Lemma remove_SubList:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y})
         (a: A) (l: list A),
    SubList (remove eq_dec a l) l.
Proof.
  unfold SubList; intros.
  eapply in_remove; eassumption.
Qed.

Lemma map_id:
  forall {A} (l: list A), map id l = l.
Proof.
  induction l; simpl; auto.
  rewrite IHl; reflexivity.
Qed.

Lemma map_trans:
  forall {A B C} (l: list A) (p: A -> B) (q: B -> C),
    map q (map p l) = map (fun a => q (p a)) l.
Proof.
  induction l; simpl; intros; auto.
  rewrite IHl; reflexivity.
Qed.

Lemma concat_In:
  forall {A} (a: A) (ll: list (list A)),
    In a (List.concat ll) ->
    exists l, In l ll /\ In a l.
Proof.
  induction ll; simpl; intros; [exfalso; auto|].
  apply in_app_or in H; destruct H; eauto.
  specialize (IHll H); dest; eauto.
Qed.

Lemma concat_SubList:
  forall {A} (l: list A) (ll: list (list A)),
    In l ll -> SubList l (List.concat ll).
Proof.
  induction ll; simpl; intros; [exfalso; auto|].
  destruct H; subst.
  - apply SubList_app_1, SubList_refl.
  - apply SubList_app_2; auto.
Qed.

Lemma concat_DisjList:
  forall {A} (l1: list A) (ll2: list (list A)),
    (forall l2, In l2 ll2 -> DisjList l1 l2) ->
    DisjList l1 (List.concat ll2).
Proof.
  induction ll2; simpl; intros; [apply DisjList_nil_2|].
  apply DisjList_comm, DisjList_app_4; apply DisjList_comm; auto.
Qed.

Lemma concat_NoDup:
  forall {A} (ll: list (list A)),
    (forall l, In l ll -> NoDup l) ->
    (forall n1 l1 n2 l2,
        n1 <> n2 ->
        nth_error ll n1 = Some l1 ->
        nth_error ll n2 = Some l2 ->
        DisjList l1 l2) ->
    NoDup (List.concat ll).
Proof.
  induction ll; simpl; intros; [constructor|].
  apply NoDup_DisjList; auto.
  - apply IHll; auto.
    intros; apply H0 with (n1:= S n1) (n2:= S n2); auto.
  - apply concat_DisjList.
    intros; apply In_nth_error in H1; destruct H1 as [n2 ?].
    apply H0 with (n1:= O) (n2:= S n2); auto.
Qed.

Lemma concat_map_In:
  forall {A} (a: A) l,
    In a l ->
    forall {B} (f: A -> B) (g: A -> list B),
      (forall a, In (f a) (g a)) ->
      In (f a) (List.concat (map g l)).
Proof.
  induction l; simpl; intros; auto.
  destruct H; subst.
  - apply in_or_app; left; auto.
  - apply in_or_app; right; auto.
Qed.

Lemma NoDup_app_comm:
  forall {A} (l1 l2: list A),
    NoDup (l2 ++ l1) ->
    NoDup (l1 ++ l2).
Proof.
  induction l1; simpl; intros.
  - rewrite app_nil_r in H; auto.
  - constructor.
    + apply NoDup_remove_2 in H.
      intro Hx; elim H; clear H.
      apply in_or_app; apply in_app_or in Hx.
      destruct Hx; auto.
    + apply IHl1.
      eapply NoDup_remove_1; eauto.
Qed.

Lemma NoDup_app_weakening_1:
  forall {A} (l1 l2: list A),
    NoDup (l1 ++ l2) ->
    NoDup l1.
Proof.
  induction l1; simpl; intros; [constructor|].
  inv H; constructor; eauto.
  intro Hx; elim H2.
  apply in_or_app; auto.
Qed.

Lemma NoDup_app_weakening_2:
  forall {A} (l1 l2: list A),
    NoDup (l1 ++ l2) ->
    NoDup l2.
Proof.
  intros.
  apply NoDup_app_comm in H.
  eauto using NoDup_app_weakening_1.
Qed.

Lemma NoDup_filter:
  forall {A} (l: list A),
    NoDup l ->
    forall f,
      NoDup (filter f l).
Proof.
  induction l; simpl; intros; [constructor|].
  inv H.
  destruct (f a); auto.
  constructor; auto.
  intro Hx; elim H2.
  apply filter_In in Hx; dest; auto.
Qed.

Lemma NoDup_map_filter:
  forall {A B} (l: list A) (p: A -> B) (f: A -> bool),
    NoDup (map p l) ->
    NoDup (map p (filter f l)).
Proof.
  induction l; simpl; intros; [constructor|].
  inv H.
  destruct (f a); simpl; auto.
  constructor; auto.
  intro Hx; elim H2; clear -Hx.
  induction l; [elim Hx|].
  simpl in *.
  destruct (f a0); auto.
  inv Hx; auto.
Qed.

Lemma NoDup_map_In:
  forall {A B} (p: A -> B) (l: list A),
    NoDup (map p l) ->
    forall a1 a2,
      In a1 l -> In a2 l ->
      p a1 = p a2 ->
      a1 = a2.
Proof.
  induction l; simpl; intros; [elim H0|].
  inv H.
  destruct H0, H1; subst; auto.
  - rewrite H2 in H5; elim H5.
    apply in_map; auto.
  - rewrite <-H2 in H5; elim H5.
    apply in_map; auto.
Qed.

Lemma in_app_or_4:
  forall {A} (a: A) (l1 l2 l3 l4: list A),
    In a ((l1 ++ l2) ++ (l3 ++ l4)) ->
    In a (l1 ++ l3) \/ In a (l2 ++ l4).
Proof.
  intros.
  apply in_app_or in H; destruct H.
  - apply in_app_or in H; destruct H.
    + left; apply in_or_app; auto.
    + right; apply in_or_app; auto.
  - apply in_app_or in H; destruct H.
    + left; apply in_or_app; auto.
    + right; apply in_or_app; auto.
Qed.

Lemma NoDup_app_comm_4:
  forall {A} (deceqA: forall x y : A, {x = y} + {x <> y})
         (l1 l2 l3 l4: list A),
    NoDup ((l1 ++ l2) ++ (l3 ++ l4)) ->
    NoDup ((l1 ++ l3) ++ (l2 ++ l4)).
Proof.
  intros.
  rewrite app_assoc in *.
  pose proof (DisjList_NoDup deceqA _ _ H).
  pose proof (NoDup_app_weakening_1 _ _ H).
  pose proof (NoDup_app_weakening_2 _ _ H).
  apply NoDup_DisjList; auto.
  - rewrite <-app_assoc in *.
    pose proof (DisjList_NoDup deceqA _ _ H1).
    pose proof (NoDup_app_weakening_1 _ _ H1).
    pose proof (NoDup_app_weakening_2 _ _ H1).
    apply NoDup_DisjList; auto.
    + apply NoDup_app_comm; assumption.
    + pose proof (DisjList_app_1 _ _ H3).
      pose proof (DisjList_app_2 _ _ H3).
      apply DisjList_comm, DisjList_app_4; apply DisjList_comm; assumption.
  - pose proof (DisjList_app_1 _ _ (DisjList_comm H0)).
    pose proof (DisjList_app_2 _ _ (DisjList_comm H0)).
    pose proof (DisjList_app_1 _ _ H3).
    pose proof (DisjList_app_2 _ _ H3).
    repeat apply DisjList_app_4; apply DisjList_comm; assumption.
Qed.

Lemma NoDup_app_comm_combine:
  forall {A} (deceqA: forall x y : A, {x = y} + {x <> y})
         (ll1 ll2: list (list A)),
    List.length ll1 = List.length ll2 ->
    NoDup (List.concat ll1 ++ List.concat ll2) ->
    NoDup (List.concat (map (fun ee => fst ee ++ snd ee) (List.combine ll1 ll2))).
Proof.
  induction ll1 as [|l1 ll1]; simpl; intros; [constructor|].
  destruct ll2 as [|l2 ll2]; [discriminate|].
  inv H.
  simpl in H0.
  apply (NoDup_app_comm_4 deceqA) in H0.
  pose proof (DisjList_NoDup deceqA _ _ H0).
  pose proof (NoDup_app_weakening_1 _ _ H0).
  pose proof (NoDup_app_weakening_2 _ _ H0).
  simpl; apply NoDup_DisjList; auto.
  apply concat_DisjList.
  intros l ?.
  apply in_map_iff in H4; destruct H4 as [[rl1 rl2] [? ?]].
  simpl in *; subst.
  eapply DisjList_comm, DisjList_SubList; [|apply DisjList_comm; eassumption].

  clear -H5.
  apply SubList_app_3.
  - apply SubList_app_1.
    apply in_combine_l in H5.
    apply concat_SubList; auto.
  - apply SubList_app_2.
    apply in_combine_r in H5.
    apply concat_SubList; auto.
Qed.

Corollary NoDup_app_comm_6:
  forall {A} (deceqA: forall x y : A, {x = y} + {x <> y})
         (l1 l2 l3 l4 l5 l6: list A),
    NoDup ((l1 ++ l3 ++ l5) ++ (l2 ++ l4 ++ l6)) ->
    NoDup ((l1 ++ l2) ++ (l3 ++ l4) ++ (l5 ++ l6)).
Proof.
  intros.
  pose proof (@NoDup_app_comm_combine
                _ deceqA [l1; l3; l5] [l2; l4; l6] eq_refl).
  simpl in H0; repeat rewrite app_nil_r in H0.
  apply H0; auto.
Qed.

Fixpoint noDup {A} (eq_dec : forall x y : A, {x = y} + {x <> y})
         (l: list A) :=
  match l with
  | nil => nil
  | a :: l' => if in_dec eq_dec a l' then noDup eq_dec l' else a :: noDup eq_dec l'
  end.

Lemma noDup_In:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y}) (a: A) (l: list A),
    In a (noDup eq_dec l) -> In a l.
Proof.
  induction l; simpl; intros; auto.
  destruct (in_dec eq_dec a0 l); auto.
  inv H; auto.
Qed.

Lemma noDup_NoDup:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y}) (l: list A),
    NoDup (noDup eq_dec l).
Proof.
  induction l; simpl; intros; [constructor|].
  destruct (in_dec eq_dec a l); auto.
  constructor; auto.
  intro Hx; elim n; eapply noDup_In; eauto.
Qed.

Lemma hd_error_In:
  forall {A} (l: list A) v,
    hd_error l = Some v ->
    In v l.
Proof.
  induction l; simpl; intros; [discriminate|].
  inv H; auto.
Qed.

Lemma hd_error_Some_app:
  forall {A} (l1: list A) v,
    hd_error l1 = Some v ->
    forall l2,
      hd_error (l1 ++ l2) = Some v.
Proof.
  destruct l1; intros; [discriminate|].
  simpl in H; inv H.
  reflexivity.
Qed.

Lemma map_nth_error_inv:
  forall {A B} (f: A -> B) (n: nat) (l: list A) (b: B),
    nth_error (map f l) n = Some b ->
    exists a, f a = b /\ nth_error l n = Some a.
Proof.
  induction n; simpl; intros.
  - destruct (map f l) eqn:Hml; [discriminate|].
    inv H.
    destruct l; [discriminate|].
    simpl in Hml; inv Hml; eauto.
  - destruct (map f l) eqn:Hml; [discriminate|].
    destruct l; [discriminate|].
    simpl in Hml; inv Hml; eauto.
Qed.

Lemma count_occ_app:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y})
         (a: A) (l1 l2: list A),
    count_occ eq_dec (l1 ++ l2) a =
    count_occ eq_dec l1 a + count_occ eq_dec l2 a.
Proof.
  induction l1; simpl; intros; auto.
  destruct (eq_dec a0 a); subst; auto.
  rewrite IHl1; reflexivity.
Qed.

Lemma count_occ_removeOnce_eq:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y})
         (a: A) (l: list A),
    In a l ->
    S (count_occ eq_dec (removeOnce eq_dec a l) a) =
    count_occ eq_dec l a.
Proof.
  induction l; simpl; intros; [exfalso; auto|].
  destruct (eq_dec a a0); subst.
  - destruct (eq_dec a0 a0); [reflexivity|exfalso; auto].
  - simpl.
    destruct (eq_dec a0 a); [exfalso; auto|].
    destruct H; [exfalso; auto|].
    auto.
Qed.

Lemma count_occ_removeOnce_neq:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y})
         (ra a: A) (l: list A),
    a <> ra ->
    count_occ eq_dec (removeOnce eq_dec ra l) a =
    count_occ eq_dec l a.
Proof.
  induction l; simpl; intros; [reflexivity|].
  destruct (eq_dec ra a0); subst.
  - destruct (eq_dec a0 a); auto.
    exfalso; auto.
  - simpl.
    destruct (eq_dec a0 a); subst; auto.
Qed.

Lemma count_occ_removeL:
  forall {A} (eq_dec : forall x y : A, {x = y} + {x <> y})
         (a: A) (rl l: list A),
    SubList rl l -> NoDup rl ->
    count_occ eq_dec (removeL eq_dec l rl) a +
    count_occ eq_dec rl a =
    count_occ eq_dec l a.
Proof.
  induction rl; simpl; intros; [lia|].
  apply SubList_cons_inv in H; dest.
  inv H0.
  destruct (eq_dec a0 a); subst.
  - rewrite Nat.add_succ_r.
    rewrite IHrl.
    + apply count_occ_removeOnce_eq; auto.
    + apply removeOnce_SubList_1; auto.
    + assumption.
  - rewrite IHrl.
    + apply count_occ_removeOnce_neq; auto.
    + apply removeOnce_SubList_1; auto.
    + assumption.
Qed.

(** Some other ways of induction for lists *)

Lemma list_picker:
  forall (A: Type) (P: list A -> Prop) (f: P nil)
         (Q0: A -> Prop) (Q1: A -> Prop)
         (f0: forall l, Forall Q0 l -> P l)
         (f1: forall a l0 l1,
             Forall Q0 l0 -> Q1 a ->
             P (l0 ++ l1) -> P (l0 ++ a :: l1)),
  forall l, Forall (fun a => Q0 a \/ Q1 a) l ->
            (Forall Q0 l \/
             exists a l0 l1, l = l0 ++ a :: l1 /\ Forall Q0 l0 /\ Q1 a).
Proof.
  induction l; simpl; intros; auto.
  inv H; destruct H2.
  - specialize (IHl H3).
    destruct IHl.
    + left; constructor; auto.
    + destruct H0 as [a0 [l0 [l1 ?]]]; dest; subst.
      right; exists a0, (a :: l0), l1.
      repeat split; auto.
  - right; exists a, nil, l; repeat split; auto.
Qed.

Lemma list_ind_pick:
  forall (A: Type) (P: list A -> Prop) (f: P nil)
         (Q0: A -> Prop) (Q1: A -> Prop)
         (f0: forall l, Forall Q0 l -> P l)
         (f1: forall a l0 l1,
             Forall Q0 l0 -> Q1 a ->
             P (l0 ++ l1) -> P (l0 ++ a :: l1)),
  forall l, Forall (fun a => Q0 a \/ Q1 a) l -> P l.
Proof.
  intros.
  remember (List.length l) as n.
  generalize dependent l.

  induction n; intros;
    [apply eq_sym, length_zero_iff_nil in Heqn; subst; auto|].

  pose proof H.
  eapply list_picker in H0; eauto.
  destruct H0; auto.
  destruct H0 as [a0 [l0 [l1 ?]]]; dest; subst.
  eapply f1; eauto.
  eapply IHn.
  - apply Forall_app_inv in H; dest; inv H0.
    apply Forall_app; auto.
  - rewrite app_length in Heqn; simpl in Heqn.
    rewrite app_length; lia.
Qed.

Lemma list_not_nil_exists_tail:
  forall (A: Type) (l: list A),
    l <> nil ->
    exists l' a, l = l' ++ [a].
Proof.
  induction l; intros; [elim H; reflexivity|].
  destruct l as [|a' l'].
  - exists nil, a; reflexivity.
  - specialize (IHl (ltac:(discriminate))).
    destruct IHl as [rl [ra ?]].
    exists (a :: rl), ra.
    rewrite H0.
    reflexivity.
Qed.

Lemma list_ind_rev:
  forall (A: Type) (P: list A -> Prop) (f: P nil)
         (f0: forall a l, P l -> P (l ++ [a])),
  forall l, P l.
Proof.
  intros.
  remember (List.length l) as n.
  generalize dependent l.

  induction n; intros;
    [apply eq_sym, length_zero_iff_nil in Heqn; subst; auto|].

  destruct l; [inv Heqn|].
  pose proof (@list_not_nil_exists_tail _ (a :: l) (ltac:(discriminate))).
  destruct H as [rl [ra ?]]; rewrite H; rewrite H in Heqn.

  apply f0.
  apply IHn.
  rewrite app_length in Heqn; simpl in Heqn.
  lia.
Qed.

Fixpoint nat_seq_rev (n: nat) :=
  match n with
  | O => O :: nil
  | S n' => n :: nat_seq_rev n'
  end.

Lemma nat_seq_rev_not_in:
  forall n m,
    n < m -> ~ In m (nat_seq_rev n).
Proof.
  induction n; simpl; intros; [lia|].
  intro Hx; destruct Hx; [lia|].
  generalize H0; apply IHn.
  lia.
Qed.

Lemma nat_seq_rev_NoDup:
  forall n, NoDup (nat_seq_rev n).
Proof.
  induction n; simpl; intros.
  - repeat constructor; intro; dest_in.
  - constructor; auto.
    apply nat_seq_rev_not_in; lia.
Qed.

(** Tactics for solving predicates of constant lists *)

Ltac solve_not_in :=
  intro; dest_in; discriminate.

Ltac solve_SubList :=
  red; intros; dest_in; simpl; tauto.

Ltac solve_DisjList dec :=
  match goal with
  | [ |- DisjList ?ll ?rl] =>
    let e := fresh "e" in
    red; intro e;
    destruct (in_dec dec e ll); [right|auto];
    dest_in; solve_not_in
  end.

Ltac solve_NoDup :=
  simpl; repeat constructor; solve_not_in.


From Hammer Require Import Hammer.

From Topology Require Export FilterLimits.
From Topology Require Export Nets.

Section net_tail_filter.

Variable X:TopologicalSpace.
Variable J:DirectedSet.
Variable x:Net J X.
Hypothesis J_nonempty: inhabited (DS_set J).

Definition net_tail (j:DS_set J) :=
Im [ i:DS_set J | DS_ord j i ] x.

Definition tail_filter_basis : Family (point_set X) :=
Im Full_set net_tail.

Definition tail_filter : Filter (point_set X).
refine (Build_Filter_from_basis tail_filter_basis _ _ _).
destruct J_nonempty as [j].
exists (net_tail j).
exists j; trivial.
constructor.
intro.
inversion H as [j].
assert (In Empty_set (x j)).
rewrite H1.
exists j; trivial.
constructor.
apply preord_refl; apply DS_ord_cond.
destruct H3.

intros.
destruct H.
destruct H0.
destruct (DS_join_cond x0 x1) as [k []].
exists (net_tail k); split.
exists k; trivial.
constructor.
red; intros.
constructor.
destruct H5 as [i0].
destruct H5.
rewrite H1.
exists i0; trivial.
constructor.
apply preord_trans with k; trivial.
apply DS_ord_cond.
destruct H5 as [i0].
destruct H5.
rewrite H2.
exists i0; trivial.
constructor.
apply preord_trans with k; trivial.
apply DS_ord_cond.
Defined.

Lemma net_limit_impl_tail_filter_limit: forall x0:point_set X,
net_limit x x0 -> filter_limit tail_filter x0.
Proof. hammer_hook "FiltersAndNets" "FiltersAndNets.net_limit_impl_tail_filter_limit".
intros.
red; intros.
red; intros U ?.
destruct H0.
destruct H0 as [V []].
destruct H0.
pose proof (H V H0 H2).
destruct H3 as [j0].
apply filter_upward_closed with (net_tail j0).
constructor.
exists (net_tail j0).
split.
exists j0; trivial.
constructor.
auto with sets.
intros y ?.
apply H1.
destruct H4 as [j].
rewrite H5.
apply H3.
destruct H4; assumption.
Qed.

Lemma tail_filter_limit_impl_net_limit: forall x0:point_set X,
filter_limit tail_filter x0 -> net_limit x x0.
Proof. hammer_hook "FiltersAndNets" "FiltersAndNets.tail_filter_limit_impl_net_limit".
intros.
intros U ? ?.
assert (In (filter_family tail_filter) U).
apply H.
constructor.
apply open_neighborhood_is_neighborhood.
split; trivial.
destruct H2.
destruct H2 as [T []].
destruct H2 as [j0].
exists j0.
intros.
apply H3.
rewrite H4.
exists j; trivial.
constructor; assumption.
Qed.

Lemma net_cluster_point_impl_tail_filter_cluster_point:
forall x0:point_set X,
net_cluster_point x x0 -> filter_cluster_point tail_filter x0.
Proof. hammer_hook "FiltersAndNets" "FiltersAndNets.net_cluster_point_impl_tail_filter_cluster_point".
intros.
red; intros.
destruct H0.
destruct H0 as [T []].
destruct H0 as [j0].
apply meets_every_open_neighborhood_impl_closure.
intros.
pose proof (H U H3 H4).
destruct (H5 j0) as [j' []].
exists (x j').
constructor; trivial.
apply H1.
rewrite H2.
exists j'.
constructor; trivial.
reflexivity.
Qed.

Lemma tail_filter_cluster_point_impl_net_cluster_point:
forall x0:point_set X,
filter_cluster_point tail_filter x0 -> net_cluster_point x x0.
Proof. hammer_hook "FiltersAndNets" "FiltersAndNets.tail_filter_cluster_point_impl_net_cluster_point".
intros.
red; intros.
red; intros.
assert (In (closure (net_tail i)) x0).
apply H.
constructor.
exists (net_tail i).
split.
exists i; trivial.
constructor.
auto with sets.
pose proof (closure_impl_meets_every_open_neighborhood _ _ _ H2
U H0 H1).
destruct H3.
destruct H3.
destruct H3.
exists x1; split.
destruct H3; trivial.
rewrite <- H5; trivial.
Qed.

End net_tail_filter.

Arguments net_tail {X} {J}.
Arguments tail_filter {X} {J}.

Section filter_to_net.

Variable X:TopologicalSpace.
Variable F:Filter (point_set X).

Record filter_to_net_DS_set : Type := {
ftn_S : Ensemble (point_set X);
ftn_x : point_set X;
ftn_S_in_F : In (filter_family F) ftn_S;
ftn_x_in_S : In ftn_S ftn_x
}.

Definition filter_to_net_DS : DirectedSet.
refine (Build_DirectedSet filter_to_net_DS_set
(fun x1 x2:filter_to_net_DS_set =>
Included (ftn_S x2) (ftn_S x1)) _ _).
constructor.
red; intros.
auto with sets.
red; intros.
auto with sets.
intros.
destruct i.
destruct j.
assert (In (filter_family F) (Intersection ftn_S0 ftn_S1)).
apply filter_intersection; trivial.
assert (Inhabited (Intersection ftn_S0 ftn_S1)).
apply NNPP; red; intro.
assert (Intersection ftn_S0 ftn_S1 = Empty_set).
apply Extensionality_Ensembles; split; red; intros.
contradiction H0.
exists x; trivial.
destruct H1.
rewrite H1 in H.
contradiction (filter_empty _ F).
destruct H0 as [ftn_x'].
exists (Build_filter_to_net_DS_set
(Intersection ftn_S0 ftn_S1) ftn_x' H H0).
simpl.
split; auto with sets.
Defined.

Definition filter_to_net : Net filter_to_net_DS X :=
ftn_x.

Lemma filter_limit_impl_filter_to_net_limit: forall x0:point_set X,
filter_limit F x0 -> net_limit filter_to_net x0.
Proof. hammer_hook "FiltersAndNets" "FiltersAndNets.filter_limit_impl_filter_to_net_limit".
intros.
intros U ? ?.
assert (In (filter_family F) U).
apply H.
constructor.
apply open_neighborhood_is_neighborhood.
split; trivial.
exists (Build_filter_to_net_DS_set U x0 H2 H1).
destruct j.
simpl.
auto.
Qed.

Lemma filter_to_net_limit_impl_filter_limit: forall x0:point_set X,
net_limit filter_to_net x0 -> filter_limit F x0.
Proof. hammer_hook "FiltersAndNets" "FiltersAndNets.filter_to_net_limit_impl_filter_limit".
intros.
intros U ?.
destruct H0.
destruct H0 as [V []].
apply filter_upward_closed with V; trivial.
destruct H0.
destruct (H V H0 H2) as [[]].
apply filter_upward_closed with ftn_S0.
trivial.
red; intros.
pose proof (H3
(Build_filter_to_net_DS_set ftn_S0 x ftn_S_in_F0 H4)).
simpl in H5.
apply H5; auto with sets.
Qed.

Lemma filter_cluster_point_impl_filter_to_net_cluster_point:
forall x0:point_set X,
filter_cluster_point F x0 -> net_cluster_point filter_to_net x0.
Proof. hammer_hook "FiltersAndNets" "FiltersAndNets.filter_cluster_point_impl_filter_to_net_cluster_point".
intros.
red; intros.
red; intros.
destruct i.
pose proof (H ftn_S0 ftn_S_in_F0).
pose proof (closure_impl_meets_every_open_neighborhood _ _
_ H2 U H0 H1).
destruct H3.
destruct H3.
exists (Build_filter_to_net_DS_set ftn_S0 x ftn_S_in_F0 H3).
simpl.
split; auto with sets.
Qed.

Lemma filter_to_net_cluster_point_impl_filter_cluster_point:
forall x0:point_set X,
net_cluster_point filter_to_net x0 -> filter_cluster_point F x0.
Proof. hammer_hook "FiltersAndNets" "FiltersAndNets.filter_to_net_cluster_point_impl_filter_cluster_point".
intros.
red; intros.
apply meets_every_open_neighborhood_impl_closure; intros.
assert (Inhabited S).
apply NNPP; red; intro.
assert (S = Empty_set).
apply Extensionality_Ensembles; split; red; intros.
contradiction H3.
exists x; trivial.
destruct H4.
rewrite H4 in H0.
contradiction (filter_empty _ F).
destruct H3 as [y].
pose (j0 := Build_filter_to_net_DS_set S y H0 H3).
destruct (H U H1 H2 j0) as [j' []].
exists (filter_to_net j').
constructor; trivial.
destruct j'.
simpl.
simpl in H5.
simpl in H4.
auto.
Qed.

End filter_to_net.


Require Import Basics.
Require Import Types.
Require Import HSet.
Require Import HProp.
Require Import UnivalenceImpliesFunext.
Require Import TruncType.
Require Import HIT.epi.
Require Import HIT.Coeq.
Require Import Truncations.

Local Open Scope path_scope.

(** * Quotient of a Type by an hprop-valued Relation

We aim to model:
<<
Inductive Quotient R : Type :=
   | class_of R : A -> Quotient R
   | qglue : forall x y, (R x y) -> class_of R x = class_of R y
   | ishset_quotient : IsHSet (Quotient R)
>>
We do this by defining the quotient as a truncated coequalizer.

*)

Definition Quotient@{i j k} {A : Type@{i}} (R : Relation@{i j} A) : Type@{k}
  := Trunc@{k} 0 (Coeq@{k k}
    (fun x : sig@{k k} (fun a : A => sig (R a)) => x.1)
    (fun x : sig@{k k} (fun a : A => sig (R a)) => x.2.1)).

Definition class_of@{i j k} {A : Type@{i}} (R : Relation@{i j} A)
  : A -> Quotient@{i j k} R := tr o coeq.

Definition qglue@{i j k} {A : Type@{i}} {R : Relation@{i j} A}
  {x y : A}
  : R x y -> class_of@{i j k} R x = class_of R y
  := fun p => ap tr (cglue (x; y; p)).

Global Instance ishset_quotient {A : Type} (R : Relation A)
  : IsHSet (Quotient R) := _.

Definition Quotient_ind@{i j k l}
  {A : Type@{i}} (R : Relation@{i j} A)
  (P : Quotient@{i j k} R -> Type@{l}) {sP : forall x, IsHSet (P x)}
  (pclass : forall x, P (class_of R x))
  (peq : forall x y (H : R x y), qglue H # pclass x = pclass y)
  : forall q, P q.
Proof.
  eapply Trunc_ind, Coeq_ind.
  1: assumption.
  intros [a [b p]].
  refine (transport_compose _ _ _ _ @ _).
  apply peq.
Defined.

Definition Quotient_ind_beta_qglue@{i j k l}
  {A : Type@{i}} (R : Relation@{i j} A)
  (P : Quotient@{i j k} R -> Type@{l}) {sP : forall x, IsHSet (P x)}
  (pclass : forall x, P (class_of R x))
  (peq : forall x y (H : R x y), qglue H # pclass x = pclass y)
  (x y : A) (p : R x y)
  : apD (Quotient_ind@{i j k l} R P pclass peq) (qglue p) = peq x y p.
Proof.
  refine (apD_compose' tr _ _ @ _).
  refine (ap _ (Coeq_ind_beta_cglue _ _ _ _) @ _).
  apply concat_V_pp.
Defined.

Definition Quotient_rec@{i j k l}
  {A : Type@{i}} (R : Relation@{i j} A)
  (P : Type@{l}) `{IsHSet P} (pclass : A -> P)
  (peq : forall x y, R x y -> pclass x = pclass y)
  : Quotient@{i j k} R -> P.
Proof.
  eapply Trunc_rec, Coeq_rec.
  intros [a [b p]].
  by apply peq.
Defined.

Definition Quotient_rec_beta_qglue @{i j k l}
  {A : Type@{i}} (R : Relation@{i j} A)
  (P : Type@{l}) `{IsHSet P} (pclass : A -> P)
  (peq : forall x y, R x y -> pclass x = pclass y)
  (x y : A) (p : R x y)
  : ap (Quotient_rec@{i j k l} R P pclass peq) (qglue p) = peq x y p.
Proof.
  refine ((ap_compose tr _ _)^ @ _).
  serapply Coeq_rec_beta_cglue.
Defined.

Arguments Quotient : simpl never.
Arguments class_of : simpl never.
Arguments qglue : simpl never.
Arguments Quotient_ind_beta_qglue : simpl never.
Arguments Quotient_rec_beta_qglue : simpl never.

Notation "A / R" := (Quotient (A:=A) R).

Section Equiv.

  Context `{Univalence} {A : Type} (R : Relation A) `{is_mere_relation _ R}
    `{Transitive _ R} `{Symmetric _ R} `{Reflexive _ R}.

  (* The proposition of being in a given class in a quotient. *)
  Definition in_class : A / R -> A -> hProp.
  Proof.
    serapply Quotient_ind.
    { intros a b.
      exact (BuildhProp (R a b)). }
    intros x y p.
    refine (transport_const _ _ @ _).
    funext z.
    apply path_hprop.
    serapply equiv_iff_hprop; cbn.
    1: apply (transitivity (symmetry _ _ p)).
    apply (transitivity p).
  Defined.

  (* Quotient induction into a hprop. *)
  Definition Quotient_ind_hprop
    (P : A / R -> Type) `{forall x, IsHProp (P x)}
    (dclass : forall x, P (class_of R x)) : forall q, P q.
  Proof.
    serapply (Quotient_ind R P dclass).
    all: try (intro; apply trunc_succ).
    intros x y p.
    apply path_ishprop.
  Defined.

  (* Being in a class is decidable if the Relation is decidable. *)
  Global Instance decidable_in_class `{forall x y, Decidable (R x y)}
  : forall x a, Decidable (in_class x a).
  Proof.
    by serapply Quotient_ind_hprop.
  Defined.

  (* if x is in a class q, then the class of x is equal to q. *)
  Lemma path_in_class_of : forall q x, in_class q x -> q = class_of R x.
  Proof.
    serapply Quotient_ind.
    { intros x y p.
      apply (qglue p). }
    intros x y p.
    funext ? ?.
    apply hset_path2.
  Defined.

  Lemma related_quotient_paths : forall x y,
    class_of R x = class_of R y -> R x y.
  Proof.
    intros x y p.
    change (in_class (class_of R x) y).
    destruct p^.
    cbv; reflexivity.
  Defined.

  (** Thm 10.1.8 *)
  Theorem path_quotient : forall x y,
    R x y <~> (class_of R x = class_of R y).
  Proof.
    intros ??.
    apply equiv_iff_hprop.
    - apply qglue.
    - apply related_quotient_paths.
  Defined.

  Definition Quotient_rec2 `{Funext} {B : hSet} {dclass : A -> A -> B}
    {dequiv : forall x x', R x x' -> forall y y',
      R y y' -> dclass x y = dclass x' y'}
    : A / R -> A / R -> B.
  Proof.
    serapply Quotient_rec.
    { intro a.
      serapply Quotient_rec.
      { revert a.
        assumption. }
      by apply (dequiv a a). }
    intros x y p.
    apply path_forall.
    serapply Quotient_ind.
    { cbn; intro a.
      by apply dequiv. }
    intros a b q.
    apply path_ishprop.
  Defined.

  Definition Quotient_ind_hprop' (P : A / R -> Type)
    `{forall x, IsHProp (P (class_of _ x))}
    (dclass : forall x, P (class_of _ x)) : forall y, P y.
  Proof.
    apply Quotient_ind with dclass.
    { serapply Quotient_ind.
      1: intro; apply trunc_succ.
      intros ???; apply path_ishprop. }
    intros; apply path_ishprop.
  Defined.

  (** The map class_of : A -> A/R is a surjection. *)
  Global Instance issurj_class_of : IsSurjection (class_of R).
  Proof.
    apply BuildIsSurjection.
    serapply Quotient_ind_hprop.
    intro x.
    apply tr.
    by exists x.
  Defined.

  (* Universal property of quotient *)
  (* Lemma 6.10.3 *)
  Theorem equiv_quotient_ump (B : hSet)
    : (A / R -> B) <~> {f : A -> B & forall x y, R x y -> f x = f y}.
  Proof.
    serapply equiv_adjointify.
    + intro f.
      exists (compose f (class_of R)).
      intros; f_ap.
      by apply qglue.
    + intros [f H'].
      apply (Quotient_rec _ _ _ H').
    + intros [f Hf].
      by apply equiv_path_sigma_hprop.
    + intros f.
      apply path_forall.
      serapply Quotient_ind_hprop.
      reflexivity.
  Defined.

(** TODO: The equivalence with VVquotient [A//R].
  10.1.10.
    Equivalence Relations are effective and there is an equivalence [A/R<~>A//R].

    This will need propositional resizing if we don't want to raise the universe level.
*)
(**
  The theory of canonical quotients is developed by C.Cohen:
  http://perso.crans.org/cohen/work/quotients/
 *)

End Equiv.

Section Functoriality.

  (* TODO: Develop a notion of set with Relation and use that instead of manually adding Relation preserving conditions. *)

  Definition Quotient_functor
    {A : Type} (R : Relation A)
    {B : Type} (S : Relation B)
    (f : A -> B) (fresp : forall x y, R x y -> S (f x) (f y))
    : Quotient R -> Quotient S.
  Proof.
    refine (Quotient_rec R _ (class_of S o f) _).
    intros x y r.
    apply qglue, fresp, r.
  Defined.

  Definition Quotient_functor_idmap
    {A : Type} {R : Relation A}
    : Quotient_functor R R idmap (fun x y => idmap) == idmap.
  Proof.
    by serapply Quotient_ind_hprop.
  Defined.

  Definition Quotient_functor_compose
    {A : Type} {R : Relation A}
    {B : Type} {S : Relation B}
    {C : Type} {T : Relation C}
    (f : A -> B) (fresp : forall x y, R x y -> S (f x) (f y))
    (g : B -> C) (gresp : forall x y, S x y -> T (g x) (g y))
    : Quotient_functor R T (g o f) (fun x y => (gresp _ _) o (fresp x y))
    == Quotient_functor S T g gresp o Quotient_functor R S f fresp.
  Proof.
    by serapply Quotient_ind_hprop.
  Defined.

  Context {A : Type} (R : Relation A)
          {B : Type} (S : Relation B).

  Global Instance isequiv_quotient_functor (f : A -> B)
    (fresp : forall x y, R x y <-> S (f x) (f y)) `{IsEquiv _ _ f}
    : IsEquiv (Quotient_functor R S f (fun x y => fst (fresp x y))).
  Proof.
    serapply (isequiv_adjointify _ (Quotient_functor S R f^-1 _)).
    { intros u v s.
      apply (snd (fresp _ _)).
      abstract (do 2 rewrite eisretr; apply s). }
    all: serapply Quotient_ind.
    + intros b; simpl.
      apply ap, eisretr.
    + intros; apply path_ishprop.
    + intros a; simpl.
      apply ap, eissect.
    + intros; apply path_ishprop.
  Defined.

  Definition equiv_quotient_functor (f : A -> B) `{IsEquiv _ _ f}
    (fresp : forall x y, R x y <-> S (f x) (f y))
    : Quotient R <~> Quotient S
    := Build_Equiv _ _ (Quotient_functor R S f (fun x y => fst (fresp x y))) _.

  Definition equiv_quotient_functor' (f : A <~> B)
    (fresp : forall x y, R x y <-> S (f x) (f y))
    : Quotient R <~> Quotient S
    := equiv_quotient_functor f fresp.

End Functoriality.

Section Kernel.

  (* TODO: Properly annotate with universes *)

  (** ** Quotients of kernels of maps to sets give a surjection/mono factorization. *)

  Context `{Funext}.
  Universe i.

  (** A function we want to factor. *)
  Context {A : Type@{i}} {B : Type} `{IsHSet B} (f : A -> B).

  (** A mere Relation equivalent to its kernel. *)
  Context (R : Relation A)
          (is_ker : forall x y, f x = f y <~> R x y).

  Theorem quotient_kernel_factor
    : exists (C : Type@{i}) (e : A -> C) (m : C -> B),
      IsHSet C * IsSurjection e * IsEmbedding m * (f = m o e).
  Proof.
    exists (Quotient R).
    exists (class_of R).
    srefine (_;_).
    { apply Quotient_ind with f; try exact _.
      intros x y p.
      transitivity (f x).
      - apply transport_const.
      - exact ((is_ker x y)^-1 p). }
    repeat split; try exact _.
    intro u.
    apply hprop_allpath.
    intros [x q] [y p'].
    apply path_sigma_hprop; simpl.
    revert x y q p'.
    serapply Quotient_ind.
    2: intros; apply path_ishprop.
    intro a.
    serapply Quotient_ind.
    2: intros; apply path_ishprop.
    intros a' p p'.
    apply qglue, is_ker.
    exact (p @ p'^).
  Defined.

End Kernel.