Require Import List.
Require Import Arith.

Ltac caseEq f :=
  generalize (refl_equal f); pattern f at -1; case f.

Inductive cmp : Set := Less : cmp | Equal : cmp | Greater : cmp.

Fixpoint three_way_compare (n m:nat) {struct n} : cmp :=
  match n, m with
  | O, O => Equal
  | 0, S _ => Less
  | S _, 0 => Greater
  | S n', S m' => three_way_compare n' m'
  end.

Fixpoint
  update_primes (k:nat) (l: list (nat*nat)) {struct l} : list (nat*nat)*bool :=
  match l with
  | nil => (nil,false)
  | (p,n)::tl =>
    let (l',b) := update_primes k tl in
    match three_way_compare k n with
    | Less => ((p, n)::l', b)
    | Equal => ((p, n+p)::l', true)
    | Greater => ((p, n+p)::l', b)
    end
  end.

Fixpoint prime_sieve (n:nat) : list (nat*nat) :=
  match n with
  | O => nil
  | 1 => nil
  | S k' =>
    let (l', b) := update_primes (S k')(prime_sieve k') in
    if b then l' else ((S k', 2*S k')::l')
  end.

Definition prime_fun (n:nat) : bool :=
  match prime_sieve n with
  | nil => false
  | (p,q)::tl =>
    match three_way_compare p n with
    | Equal => true
    | _ => false
    end
  end.

(* The rest of the file shows that we can prove interesting facts
   about our function using only the notions that have been introduced
   in the book up to chapter 6.  However, an expert user would rather
   also rely on notions that are introduced later, like the inductive
   properties found in chapter 8. *)

Definition divides (p n:nat) := exists q:nat, n = p*q.

Definition prime (n:nat) :=
  (n<>0/\n<>1)/\~(exists k:nat, 1 < k < n /\ divides k n).

Definition all_list(P:nat->nat->Prop) (l:list(nat*nat)):=
 forall (l1 l2:list(nat*nat))(p n:nat),
   l = l1++(p, n)::l2 -> (P p n).

Definition all_first_less_than (k:nat) :=
 all_list (fun p n:nat => p < k).

Definition all_first_prime :=
 all_list (fun p n:nat => prime p).

Definition all_intervals (k:nat) :=
 all_list (fun p n:nat => n-p<k<=n).

Definition all_multiples :=
 all_list (fun p n:nat => exists q:nat, n=p*q).

Definition all_greater_than_one :=
 all_list (fun p n => 1 < p).

Definition all_prime_in_first (k:nat)(l:list (nat*nat)) :=
 forall n:nat, 0 < n < k -> prime n ->
  (exists l1: list (nat*nat),
    (exists l2: list (nat*nat),
      (exists p: nat, l= l1++(n,p)::l2))).

(* A theorem that should be in the general libraries. *)

Theorem mult_lt_reg_l :
  forall m n p, m * n < m * p -> n < p.
Proof.
 intros m n; elim n.
 intros p; case p.
 repeat (rewrite mult_comm; simpl); auto.
 auto with arith.
 intros n' Hrec p; case p.
 rewrite <- (mult_comm 0); simpl; intros Hlt; elim (lt_n_O (m*S n'));auto.
 intros p'; repeat rewrite <- mult_n_Sm.
 repeat rewrite <- (plus_comm m).
 intros Hlt; assert (Hlt' : m*n' < m* p').
 apply plus_lt_reg_l with m; auto.
 auto with arith.
Qed.

(* Now come the proofs around three_way_compare. *)

Theorem three_way_compare_Less1 :
  forall n m:nat, three_way_compare n m = Less -> n < m.
Proof.
 intros n; elim n; simpl; auto with arith.
 intros m; case m; simpl; auto with arith.
 intros; discriminate.
 intros n0 Hrec m; case m; simpl; auto with arith.
 intros; discriminate.
Qed.

Theorem three_way_compare_Less2 :
  forall n m:nat, n < m -> three_way_compare n m = Less.
Proof.
 intros n; elim n; simpl.
 intros m; case m; simpl; auto.
 intros Hlt_absurd; elim (lt_irrefl 0); assumption.
 intros n0 Hrec m; case m; simpl; auto.
 intros Hlt_absurd; elim (lt_asym (S n0) 0); auto with arith.
 auto with arith.
Qed.

Theorem three_way_compare_Equal1 :
  forall n m:nat, three_way_compare n m = Equal -> n=m.
Proof.
 intros n; elim n.
 intros m; case m; simpl;auto.
 intros; discriminate.
 intros n0 Hrec m; case m; simpl; auto.
 intros; discriminate.
Qed.

Theorem three_way_compare_Equal2 :
  forall n, three_way_compare n n = Equal.
Proof.
 intros n; elim n; simpl; auto.
Qed.

Theorem three_way_compare_Greater1 :
  forall n m:nat, three_way_compare n m = Greater -> m < n.
Proof.
 intros n; elim n; simpl; auto with arith.
 intros m; case m; simpl; auto with arith.
 intros; discriminate.
 intros; discriminate.
 intros n0 Hrec m; case m; simpl; auto with arith.
Qed.

Theorem three_way_compare_Greater2 :
  forall n m:nat, m < n -> three_way_compare n m = Greater.
Proof.
 intros n; elim n; simpl.
 intros m; case m; simpl; auto.
 intros Hlt_absurd; elim (lt_irrefl 0); assumption.
 intros n0 Hlt_absurd; elim (lt_asym (S n0) 0); auto with arith.
 intros n0 Hrec m; case m; simpl; auto with arith.
Qed.

(* A bunch of generic proofs about the all_list predicate. *)

Theorem all_list_transmit :
 forall (P:nat->nat->Prop)(p:nat*nat)(l:list(nat*nat)),
   all_list P (p::l)-> all_list P l.
Proof.
 intros P fst_elem l H l1 l2 p n Heq.
 unfold all_list in H.
 apply H with (fst_elem::l1) l2; rewrite Heq; auto.
Qed.

Theorem all_list_add :
 forall (P:nat->nat->Prop)(l:list(nat*nat))(p n:nat),
 P p n -> all_list P l -> all_list P ((p,n)::l).
Proof.
 intros P l p n Hp Hal l1; case l1.
 intros l2 p' n' Heq; injection Heq; intros Hl Hn' Hp';
 rewrite <- Hn'; rewrite <- Hp'; auto.

 simpl; clear l1; intros fst_elem l1 l2 p' n' Heq; injection Heq;
 intros Hl Hfst; apply (Hal l1 l2); assumption.
Qed.

Theorem absurd_decompose_list :
 forall (A:Set) (l1 l2:list A) (p:A), nil = l1++p::l2 -> False.
Proof.
 intros A l1; case l1; simpl; intros; discriminate.
Qed.

Theorem all_list_nil :
 forall (P:nat->nat->Prop),
  all_list P nil.
Proof.
 intros P l1 l2 p n Heq; elim (absurd_decompose_list _ _ _ _ Heq).
Qed.

(* As corollaries, we get transmission theorems for the main predicates. *)

Theorem all_intervals_transmit :
 forall (k:nat)(p:nat*nat)(l: list(nat*nat)),
  all_intervals k (p::l) -> all_intervals k l.
Proof.
 intros k; exact (all_list_transmit (fun p n => n-p<k<=n)).
Qed.

Theorem all_multiples_transmit :
 forall (p:nat*nat)(l: list(nat*nat)),
  all_multiples (p::l) -> all_multiples l.
Proof.
 exact (all_list_transmit (fun p n => exists q:nat, n=p*q)).
Qed.

Theorem all_greater_than_one_transmit :
 forall (p:nat*nat)(l: list(nat*nat)),
  all_greater_than_one (p::l) -> all_greater_than_one l.
Proof.
 exact (all_list_transmit (fun p n => 1<p)).
Qed.

Theorem all_first_prime_transmit :
 forall (p:nat*nat)(l:list(nat*nat)),
  all_first_prime(p::l) -> all_first_prime l.
Proof.
 exact (all_list_transmit (fun p n => prime p)).
Qed.

Theorem all_first_less_than_transmit :
 forall k (p:nat*nat)(l: list(nat*nat)),
  all_first_less_than k (p::l) -> all_first_less_than k l.
Proof.
 intros k; exact (all_list_transmit (fun p n => p < k)).
Qed.

(* Theorems about invariants in update_primes *)
Theorem update_primes_all_list_invariant :
 forall (P:nat->nat->nat->Prop),
 (forall k p n:nat, k = n -> P k p n -> P k p (n+p))->
 (forall k p n:nat, n < k -> P k p n -> P k p (n+p))->
 forall (k:nat)(l l':list(nat*nat))(b:bool),
  all_list (P k) l ->
  update_primes k l = (l',b) -> all_list (P k) l'.
Proof.
 intros P Hp2 Hp3 k l; elim l.
 simpl; intros Hal l' b Hup; injection Hup; intros Hb Hl';
 rewrite <- Hl'; apply (all_list_nil (P k)).

 simpl; intros (p, n) l0 Hrec l' b Hal;
 caseEq (update_primes k l0); intros l'0 b0 Hup0.
 caseEq (three_way_compare k n); intros Htwc Hup; injection Hup;
 intros Hb Hl'; rewrite <- Hl';
 generalize (Hal nil l0 p n (refl_equal _)); intros HPkpn;
 generalize (Hrec l'0 b0 (all_list_transmit (P k) (p,n) l0 Hal) Hup0);
 intros Hal'; apply all_list_add; auto.

 apply Hp2;[apply three_way_compare_Equal1;auto| auto].
 apply Hp3;[apply three_way_compare_Greater1;auto| auto].
Qed.

(* Now a few proofs about divides and prime *)

Theorem divides_dec_aux :
  forall k n p:nat, n <= k -> divides p n \/ ~divides p n.
Proof.
 intros k; elim k.
 intros n p Hle; left; exists 0; rewrite mult_comm; simpl;
 symmetry; apply le_n_O_eq; auto.

 intros k' Hrec n p Hlt; elim (le_lt_or_eq n (S k')).
 auto with arith.

 intros Heq; rewrite Heq.
 case p.
 right; intros (q, Heq').
 discriminate Heq'.

 intros p'.
 caseEq (three_way_compare (S p') (S k')); intros Htwc.

 assert (S p' < S k').
 apply three_way_compare_Less1; auto.

 elim (Hrec (minus (S k') (S p')) (S p')).
 intros (q, Heq'); left; exists (S q).
 rewrite (le_plus_minus (S p') (S k')).
 rewrite Heq'.
 repeat rewrite (mult_comm (S p')).
 reflexivity.
 auto with arith.

 intros Hndiv; right; intros Hdiv.
 apply Hndiv.
 elim Hdiv.
 intros q; case q.
 rewrite mult_comm;  simpl; intros; discriminate.
 intros q' Heq'; exists q'.
 apply plus_reg_l with (S p').
 rewrite le_plus_minus_r.
 rewrite Heq'.
 rewrite plus_comm; rewrite mult_n_Sm; reflexivity.
 auto with arith.

 simpl.
 apply le_minus.

 assert (H:S p' = S k').
 apply three_way_compare_Equal1; auto.
 left; exists 1; rewrite H.
 auto with arith.

 assert (Hlt': S k' < S p').
 apply three_way_compare_Greater1; auto.
 right; intros Hdiv; elim Hdiv; intros q; case q.
 rewrite mult_comm; simpl; intros; discriminate.
 intros q' Heq'; elim (lt_not_le _ _ Hlt').
 rewrite Heq'.
 rewrite mult_comm; simpl; auto with arith.

 trivial.
Qed.

Theorem eq_nat_or :
 forall n m:nat, n=m \/ ~n=m.
Proof.
 intros n; elim n.
 intros m; case m.
 left; auto.
 right; auto.
 intros n' Hrec m; case m.
 right; auto with arith.
 intros m'; elim (Hrec m').
 left; auto with arith.
 right; auto with arith.
Qed.

Theorem prime_dec_aux :
 forall n k:nat,
  (n=0\/n=1)\/
  (exists p:nat, 1<p<k /\ (exists q:nat, n=p*q))\/
  ((n<>0/\n<>1)/\~(exists p:nat, 1<p<k/\ (exists q:nat, n=p*q))).
Proof.
 intros n; elim (eq_nat_or n 1).
 auto.
 intros Hnneq1.
 elim (eq_nat_or n 0).
 auto.
 intros Hnneq0 k; elim k.
 right; right; split.
 auto.
 intros (p, ((_,Hlt0), (q, Heq))).
 elim (lt_n_O p); auto.
 intros k'; case k'.
 intros; right; right; split.
 auto.
 intros (p, ((Hpgt1, Hplt1),_)).
 elim (lt_irrefl 1); apply lt_trans with p;auto.
 intros k''; case k''.
 intros; right; right; split; auto; intros (p, ((Hpgt1, Hplt2),_)).
 elim (lt_irrefl p); apply le_lt_trans with 1; auto with arith.
 intros k''' Hrec; case (divides_dec_aux n n (S (S k'''))).
 auto with arith.
 intros Hdiv; right; left; exists (S (S k''')); repeat split; auto with arith.
 intros Hndiv; elim Hrec.
 auto.

 intros Hrec'; elim Hrec'.
 intros (p, ((Hpgt1, Hplt), Hex)); right; left; exists p; repeat split;
   auto with arith.
 intros (_, Hnodiv); right; right; split; auto;
   intros (p, ((Hpgt1, Hplt), Hex)).
 assert (Hple : p <= S (S k''')).
 auto with arith.
 elim (le_lt_or_eq _ _ Hple).
 intros Hplt'.
 elim Hnodiv; exists p; repeat split; auto with arith.
 intros Hpeq.
 elim Hndiv; rewrite <- Hpeq; exact Hex.
Qed.

Theorem prime_dec :
 forall n:nat, (n=0\/n=1)\/(exists p:nat, 1<p<n /\ (exists q:nat, n=p*q))\/
  prime n.
Proof.
 intros n; exact (prime_dec_aux n n).
Qed.

Theorem div_by_prime_aux :
 forall k:nat, forall n:nat, n <= k ->
 1 < n -> (exists p:nat, 1 < p < n /\ (exists q : nat, n=p*q)) ->
 (exists p:nat, 1 < p < n /\ (prime p) /\ (exists q:nat, n=p*q)).
Proof.
 intros k; elim k.
 intros n Hle Hlt Hn.
 elim (lt_asym 1 0).
 apply lt_le_trans with n; assumption.
 auto with arith.
 intros k' Hrec n Hle Hlt Hn.
 elim (le_lt_or_eq n (S k')).
 intros Hle'; apply Hrec; auto with arith.

 elim Hn; intros p ((Hpgt1, Hpltn),(q,Heq)).
 intros HneqSk'.
 elim (prime_dec p).

 intros Hpeq0or1; elim Hpeq0or1.
 intros Hpeq0.
 rewrite Hpeq0 in Hpgt1; elim (lt_n_O 1); assumption.
 intros Hpeq1.
 rewrite Hpeq1 in Hpgt1; elim (lt_irrefl 1); assumption.
 intros Hpdec; elim Hpdec.
 intros Hexp.
 elim (Hrec p); auto with arith.
 intros p' ((Hp'gt1,Hp'ltp), (Hpr,(q', Heq'))).
 exists p'.
 split;[split|split]; auto with arith.
 apply lt_trans with p; auto with arith.
 exists (q' * q).
 rewrite mult_assoc.
 rewrite Heq; rewrite Heq'; trivial.

 unfold lt in Hpltn.
 rewrite HneqSk' in Hpltn; auto with arith.

 exists p;split;[split|split]; auto with arith.
 exists q; auto with arith.

 trivial.
Qed.

Theorem div_by_prime :
 forall n:nat, 1 < n -> (exists p:nat, 1 < p < n /\ (exists q : nat, n=p*q)) ->
 (exists p:nat, 1 < p < n /\ (prime p) /\ (exists q:nat, n=p*q)).
Proof.
 intros n; apply (div_by_prime_aux n n).
 auto with arith.
Qed.

(* Now, theorems about update_primes. *)

Theorem update_primes_true_aux :
  forall (k:nat) (l1 l2 l3 l4: list(nat*nat))(b:bool),
    update_primes k l1 = (l2, true) ->
    update_primes k (l3++l1) = (l4, b) -> b=true.
Proof.
 intros k l1 l2 l3; elim l3.
 simpl; intros l4 b Heq1; rewrite Heq1; intros Heq2; injection Heq2; auto.

 simpl; intros (p,n) l; case (update_primes k (l++l1)).
 intros l4 b Hrec l4' b'; case (three_way_compare k n).
 intros Heq1 Heq2; injection Heq2.
 intros Heq3 Heq4; rewrite <- Heq3; apply Hrec with l4; auto.
 intros Heq1 Heq2; injection Heq2; auto.
 intros Heq1 Heq2; injection Heq2.
 intros Heq3 Heq4; rewrite <- Heq3; apply Hrec with l4; auto.
Qed.

Theorem update_primes_true_imp_div :
  forall (k:nat)(l: list (nat*nat)),
    all_first_less_than k l ->
    all_multiples l ->
    all_greater_than_one l ->
    forall l1, update_primes k l = (l1, true) ->
      (exists p:nat, 1< p < k /\ (exists q:nat, k = p*q)).
Proof.
 intros k l; elim l.
 simpl; intros; discriminate.
 intros (p,n) l0 Hrec Haf Ham Hal l1; simpl.
 caseEq (update_primes k l0).
 intros l2 b Hup; caseEq (three_way_compare k n).
 intros Htwc Heq; injection Heq; intros Hb Hl1.
 rewrite Hb in Hup; apply Hrec with l2.
 apply all_first_less_than_transmit with (p,n); auto.
 apply all_multiples_transmit with (p,n); auto.
 apply all_greater_than_one_transmit with (p,n); auto.
 auto.
 intros Htwc Heq; generalize (three_way_compare_Equal1 _ _ Htwc).
 intros Hk.
 exists p.
 split.
 split.
 unfold all_greater_than_one in Hal;
  apply Hal with (nil (A:=nat*nat)) l0 n; auto.
 unfold all_first_less_than in Haf;
  apply Haf with (nil (A:=nat*nat)) l0 n; auto.
 unfold all_multiples in Ham.
 rewrite Hk; apply Ham with (nil (A:=nat*nat)) l0; auto.
 intros Htwc Heq; injection Heq; intros Hb Hl1.
 rewrite Hb in Hup; apply Hrec with l2.
 apply all_first_less_than_transmit with (p,n); auto.
 apply all_multiples_transmit with (p,n); auto.
 apply all_greater_than_one_transmit with (p,n); auto.
 auto.
Qed.

Theorem interval_eq :
 forall p q q', p*q'-p < p*q <= p*q' -> q=q'.
Proof.
 intros p; case p.
 simpl; intros q q' (Hlt, Hle); elim (lt_irrefl 0);assumption.

 intros p' q q' (Hlt, Hle).
 apply le_antisym.
 apply mult_S_le_reg_l with p'; auto.
 assert (Hlt' : (q' - 1)*S p' < S p' * q).
 rewrite mult_minus_distr_r.
 rewrite mult_1_l.
 rewrite (mult_comm q').
 assumption.
 rewrite (mult_comm (q' - 1)) in Hlt'.
 generalize (mult_lt_reg_l _ _ _ Hlt').
 case q'; simpl.
 auto with arith.
 intros n; rewrite <- minus_n_O.
 auto with arith.
Qed.

Theorem update_primes_false_imp_prime :
 forall k l l1,
   1 < k ->
   all_multiples l ->
   all_intervals k l ->
   all_prime_in_first k l ->
   update_primes k l = (l1,false) -> prime k.
Proof.
 intros k l l1 Hkgt1 Ham Hai Hap Heq.
 elim (prime_dec k); auto.
 intros Hkeq0or1;elim Hkeq0or1.
 intros Hkeq0.
 rewrite Hkeq0 in Hkgt1; elim (lt_n_O 1); assumption.
 intros Hkeq1; rewrite Hkeq1 in Hkgt1; elim (lt_irrefl 1); assumption.
 intros Hpdec; elim Hpdec.
 intros Hexdiv.
 generalize (div_by_prime _ Hkgt1 Hexdiv).
  intros (p, ((Hpgt1,Hpltk), (Hpr, Hex))).
 elim (Hap p); auto.
 intros l'1 (l2, (n, Heq')).
 elim Hex; intros q Heq''.
 assert (Hint: n - p < k <= n).
 unfold all_intervals in Hai.
 apply Hai with l'1 l2.
 auto.
 assert (Hmult : (exists q':nat, n = p*q')).
 unfold all_multiples in Ham.
 apply Ham with l'1 l2.
 auto.
 elim Hmult; intros q' Heq3.
 assert (Heq4: q=q').

 apply interval_eq with p.
 rewrite <- Heq3.
 rewrite <- Heq''.
 assumption.

 cut (false = true).
 intros;discriminate.
 caseEq (update_primes k ((p,n)::l2)).
 intros l3 b Hup.
 generalize (update_primes_true_aux k ((p,n)::l2) l3 l'1 l1 false).
 intros H; apply H.
 generalize Hup.
 simpl.
 case (update_primes k l2).
 intros l5 b2.
 rewrite Heq''; rewrite Heq3; rewrite Heq4.
 rewrite three_way_compare_Equal2.
 intros Heq5; injection Heq5; intros Heq6 Heq7; rewrite Heq6;rewrite Heq7;
 auto with arith.
 rewrite <- Heq'.
 assumption.
 auto with arith.
 trivial.

Qed.

(* We can now prove that all properties are invariant. *)

Theorem update_primes_all_multiples :
  forall k l l' b,
    all_multiples l ->
       update_primes k l = (l', b) -> all_multiples l'.
Proof.
 apply (update_primes_all_list_invariant (fun k p n => exists q:nat, n=p*q));
 try (intros k p n Hcomp (q, Heq);exists (S q);rewrite Heq;
 rewrite <- mult_n_Sm; reflexivity).
Qed.

Theorem update_primes_all_first_less_than :
 forall k l l' b,
 all_first_less_than k l ->
 update_primes k l = (l',b) ->
 all_first_less_than k l'.
Proof.
 apply (update_primes_all_list_invariant (fun k p n => p < k)); auto.
Qed.

Theorem update_primes_all_greater_than_one :
 forall k l l' b,
  all_greater_than_one l ->
  update_primes k l = (l',b) ->
  all_greater_than_one l'.
Proof.
 apply (update_primes_all_list_invariant (fun k p n => 1 < p)); auto.
Qed.

Theorem update_primes_all_first_prime :
 forall k l l' b,
  all_first_prime l -> update_primes k l = (l',b) -> all_first_prime l'.
Proof.
 apply (update_primes_all_list_invariant (fun k p n => prime p)); auto.
Qed.

Theorem update_primes_all_intervals :
 forall (k:nat)(l:list(nat*nat)),
   all_intervals k l -> all_greater_than_one l ->
   forall l' b, update_primes k l = (l',b) -> all_intervals (S k) l'.
Proof.
 intros k l; elim l.
 simpl; intros Hai Hal l' b Hup; injection Hup; intros Hb Hl'; rewrite <- Hl'.
 intros l1 l2 n p Heq; elim (absurd_decompose_list _ _ _ _ Heq).

 simpl; intros (p, n) l0 Hrec Hai Hal l' b;
 caseEq (update_primes k l0); intros l'0 b0 Hup0 Hup l1.
 case l1.

 unfold all_intervals in Hai.
 caseEq (three_way_compare k n); simpl; intros Htwc l2 p' n' Heq;
 rewrite Htwc in Hup; injection Hup; intros Hb Hl';
 rewrite <- Hl' in Heq; injection Heq; intros Hl2 Hn' Hp';
 rewrite <- Hp'; rewrite <- Hn';
 generalize (Hai nil l0 p n (refl_equal _));
 intros (Hlt, Hle);split;
 (generalize (three_way_compare_Less1 _ _ Htwc) ||
  generalize (three_way_compare_Equal1 _ _ Htwc) ||
  generalize (three_way_compare_Greater1 _ _ Htwc)); auto with arith.

 intros Heq2; rewrite Heq2; rewrite plus_comm; rewrite minus_plus;
 auto with arith.

 intros Heq2; rewrite Heq2; unfold all_greater_than_one in Hal;
 generalize (Hal nil l0 p n (refl_equal _)); intros Hpgt1.
 pattern n at 1; rewrite plus_n_O; rewrite plus_n_Sm;
 apply plus_le_compat; auto with arith.

 rewrite plus_comm; rewrite minus_plus; auto with arith.
 generalize (Hal nil l0 p n (refl_equal _)); intros Hpgt1.
 intros Hkltn; pattern k at 1; rewrite plus_n_O; rewrite plus_n_Sm;
 apply plus_le_compat; auto with arith.

 generalize (all_intervals_transmit _ _ _ Hai); intros Hai'.
 generalize (all_greater_than_one_transmit _ _ Hal); intros Hal'.

 simpl; clear l1; intros fst_elem l1 l2 p' n' Heq; generalize Hup;
 rewrite Heq.

 case (three_way_compare k n); intros Hup'; injection Hup';
 intros Hb Hl' _; apply (Hrec Hai' Hal' l'0 b0 Hup0 l1 l2); assumption.
Qed.

Theorem all_first_less_than_S :
 forall k l, all_first_less_than k l -> all_first_less_than (S k) l.
Proof.
 intros k l; elim l.
 intros Haf l1 l2 p n Heq; elim (absurd_decompose_list _ _ _ _ Heq).

 intros (p,n) l0 Hrec Haf l1.
 case l1.
 intros l2 p' n' Heq;
 generalize (Haf nil l2 p' n' Heq); intros Hpltk.
 auto with arith.

 simpl; clear l1; intros fst_elem l1 l2 p' n' Heq.
 injection Heq; intros;
 apply (Hrec (all_first_less_than_transmit _ _ _ Haf) l1 l2 p' n');
 assumption.
Qed.

Theorem all_intervals_add :
 forall (l:list(nat*nat))(k p n:nat),
  n-p < k <= n ->
  all_intervals k l ->
  all_intervals k ((p,n)::l).
Proof.
 intros l k p n Hint Hai l1; case l1.
 intros l2 p' n' Heq; injection Heq; intros Hl Hn' Hp';
 rewrite <- Hn'; rewrite <- Hp'; auto.

  simpl; clear l1; intros fst_elem l1 l2 p' n' Heq; injection Heq;
 intros Hl Hfst; apply (Hai l1 l2); assumption.
Qed.

Theorem all_first_prime_add :
 forall (l:list(nat*nat))(p n:nat),
  prime p ->
  all_first_prime l -> all_first_prime ((p,n)::l).
Proof.
 intros l p n Hlt Haf l1; case l1.
 intros l2 p' n' Heq; injection Heq; intros Hl Hn' Hp';
 rewrite <- Hp'; assumption.

 simpl; clear l1; intros fst_elem l1 l2 p' n' Heq; injection Heq;
 intros Hl Hfst; apply (Haf l1 l2 p' n' Hl).
Qed.

Theorem all_multiples_add :
 forall l n p,
  (exists q:nat, n=p*q)->
  all_multiples l ->
  all_multiples ((p,n)::l).
Proof.
 intros l n p Hdiv Ham l1; case l1.
 simpl; intros l2 p' n' Heq; injection Heq;
 intros Hl2 Hn' Hp'; rewrite <- Hn'; rewrite <- Hp';
 assumption.

 clear l1; simpl; intros fst_elem l1 l2 p' n' Heq; injection Heq;
 intros Hl Hfst; apply (Ham l1 l2); assumption.
Qed.

Theorem all_greater_than_one_add :
 forall l n p,
  1 < p -> all_greater_than_one l ->
  all_greater_than_one ((p,n)::l).
Proof.
 intros l n p Hlt Hal  l1; case l1.
 simpl; intros l2 p' n' Heq; injection Heq;
 intros Hl2 Hn' Hp'; rewrite <- Hp';
 assumption.

 clear l1; simpl; intros fst_elem l1 l2 p' n' Heq; injection Heq;
 intros Hl Hfst; apply (Hal l1 l2 p' n'); assumption.
Qed.

Fixpoint same_first (l1 l2:list(nat*nat)) {struct l1} : bool :=
  match l1, l2 with
    nil, nil => true
  | ((a, _)::l'1), ((b, _)::l'2) =>
    match three_way_compare a b with
    | Equal => same_first l'1 l'2
    | _ => false
    end
  | _, _ => false
  end.

Theorem update_primes_same_first :
 forall k l l' b,
   update_primes k l = (l', b) ->
   forall l1 l2 p n,
   l = l1++(p,n)::l2 ->
   (exists l'1 : list(nat*nat),
     (exists l'2 : list(nat*nat),
       (exists n': nat,
         l'=l'1++(p,n')::l'2))).
Proof.
 intros k l; elim l.
 intros l' b Hup l1 l2 p n Heq; elim (absurd_decompose_list _ _ _ _ Heq).

 intros (p,n) l0 Hrec l' b.
 simpl; caseEq (update_primes k l0); intros l'0 b0 Hup'.

 case (three_way_compare k n); intros Hup; injection Hup;
 intros Hb Hl'; intros l1; (case l1; [simpl; intros l2 p0 n0 Heq;
 injection Heq; intros Hl2 Hn0 Hp0; rewrite <- Hl'; rewrite <- Hp0;
 exists (nil (A:=nat*nat)); exists l'0 |
 clear l1; simpl; intros fst_elem l1 l2 p0 n0 Heq; injection Heq;
 intros Hl0 Hfst_elem; rewrite <- Hl';
 elim (Hrec l'0 b0 Hup' l1 l2 p0 n0 Hl0); intros l'1 (l'2, (n', Heq2));
 rewrite Heq2]).

 exists n; reflexivity.
 exists ((p,n)::l'1); exists l'2; exists n'; reflexivity.
 exists (n+p); reflexivity.
 exists ((p,n+p)::l'1); exists l'2; exists n'; reflexivity.
 exists (n+p); reflexivity.
 exists ((p,n+p)::l'1); exists l'2; exists n'; reflexivity.
Qed.

Theorem update_primes_all_prime_in_first :
 forall k l l' b,
  all_prime_in_first k l ->
  update_primes k l = (l', b) ->
  all_prime_in_first k l'.
Proof.
 intros k l l' b Hap Hup p Hplek Hpr.
 elim (Hap p Hplek Hpr); intros l'1 (l'2, (n', Heq)).
 apply (update_primes_same_first k l l' b Hup l'1 l'2 p n' Heq).
Qed.

Theorem prime_sieve_invariant :
 forall k l,
   prime_sieve (S k)=l ->
   all_first_less_than (S (S k)) l /\
   all_first_prime l /\
   all_prime_in_first (S (S k)) l /\
   all_intervals (S (S k)) l /\
   all_multiples l /\
   all_greater_than_one l.
Proof.
intros k; elim k.
  simpl; intros l Hl; rewrite <- Hl; clear Hl l.
  split;[idtac | split; [idtac | split;[idtac|split;[idtac|split]]]];
    try (intros l1 l2 p n Heq; elim (absurd_decompose_list _ _ _ _ Heq)).
intros n Hle1 ((Hnneq0, Hnneq1),_); elim Hnneq1.
elim Hle1; intros; apply (le_antisym n 1); auto with arith.

intros k' Hrec l Hps.
 change ((let (l', b) :=
   update_primes (S (S k')) (prime_sieve (S k')) in
   if b then l' else (S (S k'), 2*S (S k'))::l') = l) in Hps.
caseEq (update_primes (S (S k')) (prime_sieve (S k'))); intros l' b Heq.
generalize (Hrec (prime_sieve (S k'))); intros Hrec'.
assert (Hal: all_first_less_than (S (S k')) l').
apply update_primes_all_first_less_than with (prime_sieve (S k')) b; auto.
intuition.
assert (Hafp: all_first_prime l').
apply update_primes_all_first_prime
  with (S (S k')) (prime_sieve (S k')) b; auto.
intuition.
assert (Hapf: all_prime_in_first (S (S k')) l').
apply update_primes_all_prime_in_first with (prime_sieve (S k')) b; auto.
intuition.
assert (Hai : all_intervals (S (S (S k'))) l').
apply update_primes_all_intervals with (prime_sieve (S k')) b; auto.
intuition.
intuition.
assert (Ham : all_multiples l').
apply update_primes_all_multiples
  with (S (S k')) (prime_sieve (S k')) b; auto.
intuition.
assert (Ha1 : all_greater_than_one l').
apply update_primes_all_greater_than_one with (S (S k')) (prime_sieve (S k')) b; auto.
intuition.

caseEq b; intros Heqb; rewrite Heqb in Heq; rewrite Heq in Hps.
rewrite <- Hps.
split;[idtac|split;[idtac|split;[idtac|split;[idtac|split;[idtac|idtac]]]]];
 auto.
apply all_first_less_than_S; assumption.
unfold all_prime_in_first.
intros n Hint Hpr; unfold all_prime_in_first in Hapf; apply Hapf; auto.
split.
intuition.
elim Hint.
intros Hngt0 Hnlek.
elim (le_lt_or_eq _ _ Hnlek).
auto with arith; fail.
intros Hn'; injection Hn'.
intros Hn; rewrite Hn in Hpr; elim Hpr.
intros _ Hnex; elim Hnex.
unfold divides.
apply update_primes_true_imp_div with (prime_sieve (S k')) l'.
intuition.
intuition.
intuition.
auto.

split.

intros l1; case l1.
simpl; intros l2 p n; rewrite <- Hps; intros Heq2;injection Heq2.
intros Hl2 Hn Hp; rewrite <- Hp; auto with arith.
intros fst_elem l'1 l2 p n; simpl; rewrite <- Hps; intros Heq2;
injection Heq2; intros Hl' Hfst_elem.
assert (Hal' : all_first_less_than (S (S (S k'))) l').
apply all_first_less_than_S; auto.
apply (Hal' l'1 l2 p n); auto.

split.
rewrite <- Hps; apply all_first_prime_add; auto.
apply update_primes_false_imp_prime with (prime_sieve (S k')) l';
 try tauto.
auto with arith.

split.
rewrite <- Hps.
intros n (Hpos, Hle) Hpr.
elim (le_lt_or_eq _ _ Hle).
intros Hlt; elim (Hapf n); auto with arith.
intros l'1 (l'2, (p, Heq2));
exists ((S (S k'), 2*S(S k'))::l'1); exists l'2; exists p.
rewrite Heq2;reflexivity.
intros Hn'; injection Hn'; intros Hn.
exists (nil (A:=nat*nat)); exists l'; exists (2*S (S k')).
rewrite Hn;reflexivity.

split.
rewrite <- Hps; apply all_intervals_add; auto with arith.
split.
simpl.
rewrite minus_plus.
rewrite <- plus_n_O.
auto with arith.
simpl.
repeat rewrite <- plus_n_Sm.
auto with arith.

split.
rewrite <- Hps; apply all_multiples_add; auto with arith.
exists 2; rewrite (mult_comm 2); reflexivity.

rewrite <- Hps.
apply all_greater_than_one_add; auto with arith.
Qed.

Theorem prime_fun_sound :
 forall k, prime_fun k = true -> prime k.
Proof.
 intros k0; case k0.
 simpl; intros; discriminate.
 intros k; unfold prime_fun.
 caseEq (prime_sieve (S k)).

 intros; discriminate.
 intros (p,n) l Heq; caseEq (three_way_compare p (S k));
 try(intros; discriminate; fail).
 intros Htwc _.

 assert (Hap:all_first_prime ((p,n)::l)).
 generalize (prime_sieve_invariant k ((p,n)::l) Heq); intuition.
 rewrite <- (three_way_compare_Equal1 _ _ Htwc).
 apply (Hap nil l p n); auto.
Qed.

Theorem prime_fun_complete :
 forall k, prime k -> prime_fun k = true.
Proof.
 intros k; case k.
 intros ((Hneq0, Hneq1),Hnex); elim Hneq0; auto.
 intros k'; case k'.
 intros ((Hneq0, Hneq1),Hnex); elim Hneq1; auto.
 intros k'' ((_,_),Hnex).
 unfold prime_fun.

 assert (Hps: prime_sieve (S (S k'')) =
              let (l',b) := (update_primes (S (S k'')) (prime_sieve (S k'')))
              in
              if b then l' else ((S (S k''), 2*S (S k''))::l')).
 auto.
 rewrite Hps.

 caseEq  (update_primes (S (S k'')) (prime_sieve (S k''))).
 intros l' b; case b; intros Hup.
 elim Hnex.
 unfold divides.
 generalize (prime_sieve_invariant k'' (prime_sieve (S k''))); intros Hinv.
 apply (update_primes_true_imp_div (S (S k'')) (prime_sieve (S k''))) with l';
 intuition.

 rewrite (three_way_compare_Equal2 (S (S k''))); auto.
Qed.


From mathcomp Require Import ssreflect.
From Category.Base Require Import Logic Category Functor NatTran.

Program Definition DiscreteCat (A : Type) : Category :=
  {|
    Obj := A;
    Hom := fun x y => x = y;
  |}.

Lemma DiscreteCat_Hom_eq :
  forall {A : Type},
  forall {X Y : Obj (DiscreteCat A)},
  forall (f g : Hom X Y), f = g.
Proof.
  move => A X Y.
  unfold Hom.
  simpl.
  move => f g.
  exact: p_proof_irrelevance.
Qed.

Definition Cat0 := DiscreteCat False.

Definition Cat1 := DiscreteCat True.
Definition Cat1Obj : Obj Cat1 := I.

Lemma Cat1Obj_eq :
  forall (X Y : Obj Cat1), X = Y.
Proof.
  case.
  case.
  reflexivity.
Qed.

Lemma Cat1Hom_eq :
  forall {X Y : Obj Cat1} (f g : Hom X Y), f = g.
Proof.
  move => X Y f g.
  exact: DiscreteCat_Hom_eq.
Qed.


Require Import Setoid ProofIrrelevance FunctionalExtensionality Ensembles.
Require Import Common Notations.

Set Implicit Arguments.

(**
   An equivalence class is a non-empty set of all values
   which are all equivalent to some particular value.
*)

Local Ltac specialize_with tac fin_tac :=
  match goal with
    | [ x : ?T, H : forall _ : ?T, _ |- _ ] => specialize (H x); tac; specialize_with tac fin_tac
    | _ => fin_tac
  end.

Section EquivalenceClass.
  Variable value : Type.
  Variable equiv : value -> value -> Prop.
  (* [E] is an equivalence class if it is non-empty and if all it consists
     of all values that are equivalent to some particular value.
     Because the equivalence relation is transitive, we can encode
     this without picking a representative element by requiring that
     for every member of the class, the class consists of exactly the
     values equivalent to that member. *)
  Record EquivalenceClass := {
    InClass : value -> Prop;

    ClassInhabited : exists v, InClass v;

    ClassEquivalent : relation value := equiv;
    ClassEquivalent_refl : Reflexive ClassEquivalent;
    ClassEquivalent_sym : Symmetric ClassEquivalent;
    ClassEquivalent_trans : Transitive ClassEquivalent;

    ClassElementsEquivalent : forall v, InClass v -> forall v', InClass v' -> ClassEquivalent v v';
    ClassContainsEquivalent : forall v, InClass v -> forall v', ClassEquivalent v v' -> InClass v'
  }.
End EquivalenceClass.

Add Parametric Relation value equiv (E : @EquivalenceClass value equiv) : _ (ClassEquivalent E)
  reflexivity proved by (@ClassEquivalent_refl _ _ _)
  symmetry proved by (@ClassEquivalent_sym _ _ _)
  transitivity proved by (@ClassEquivalent_trans _ _ _)
    as ClassEquivalent_rel.

Add Parametric Morphism value equiv (E : @EquivalenceClass value equiv) : (InClass E)
  with signature equiv ==> iff
    as InClass_mor.
  intros x y eqv; split; intro inc;
    eapply ClassContainsEquivalent; eauto; try symmetry; eauto.
Qed.

Section equiv.
  Variable value : Type.
  Variable equiv : value -> value -> Prop.

  Hypothesis equiv_Equivalence : Equivalence equiv.

  Local Add Parametric Relation : _ equiv
    reflexivity proved by (Equivalence.equiv_reflexive _)
    symmetry proved by (Equivalence.equiv_symmetric _)
    transitivity proved by (Equivalence.equiv_transitive _)
      as equiv_equiv_rel.

  Local Infix "~=" := equiv (at level 70).

  Local Ltac simpl_equiv := hnf; intros; trivial;
    repeat match goal with
             | _ => solve [ reflexivity ]
             | _ => solve [ symmetry; trivial ]
             | _ => solve [ etransitivity; eauto ]
             | _ => solve [ symmetry; etransitivity; eauto ]
             | _ => solve [ etransitivity; eauto; symmetry; eauto ]
             | [ H : equiv _ _ -> False |- _ ] => contradict H; trivial
             | [ H : ~ equiv _ _ |- _ ] => contradict H; trivial
           end.

  (* The equivalence [classOf] a particular [value] is defined by the proposition that
     the elements are equivalent to that [value]. *)
  Definition classOf (v : value) : EquivalenceClass equiv.
    exists (fun v' => v ~= v');
      abstract (
        repeat esplit; unfold InClass in *;
          simpl_equiv
      ).
  Defined.

  Lemma classOf_refl : forall v, InClass (classOf v) v.
    compute; intro; reflexivity.
  Qed.

  (* Two equivalence classes are the same if they share all values *)
  Definition sameClass (C C' : EquivalenceClass equiv) := forall v, (InClass C v <-> InClass C' v).

  Definition disjointClasses (C C' : EquivalenceClass equiv) := forall v, ~InClass C v \/ ~InClass C' v.

  Definition differentClasses (C C' : EquivalenceClass equiv) := exists v,
    (InClass C v /\ ~InClass C' v) \/
    (~InClass C v /\ InClass C' v).

  Definition notDisjointClasses (C C' : EquivalenceClass equiv) := exists v, InClass C v /\ InClass C' v.

  Definition notDisjointClasses' (C C' : EquivalenceClass equiv) := exists v v', InClass C v /\ InClass C' v' /\ equiv v v'.

  Lemma sameClass_refl (C : EquivalenceClass equiv) : sameClass C C.
    clear equiv_Equivalence; firstorder.
  Qed.

  Lemma sameClass_sym (C C' : EquivalenceClass equiv) : sameClass C C' -> sameClass C' C.
    clear equiv_Equivalence; firstorder.
  Qed.

  Lemma sameClass_trans (C C' C'' : EquivalenceClass equiv) : sameClass C C' -> sameClass C' C'' -> sameClass C C''.
    clear equiv_Equivalence; firstorder.
  Qed.

  Lemma sameClass_eq (C C' : EquivalenceClass equiv) : (sameClass C C') -> (C = C').
    clear equiv_Equivalence; intro H.
    cut (InClass C = InClass C');
      destruct C, C'; simpl;
        intros;
          unfold sameClass in *;
            subst;
              split_iff;
              f_equal; try apply proof_irrelevance;
                apply Extensionality_Ensembles;
                  hnf; split; hnf; simpl;
                    firstorder.
  Qed.

  Lemma eq_sameClass (C C' : EquivalenceClass equiv) : C = C' -> sameClass C C'.
    intro; subst; apply sameClass_refl.
  Qed.

  Global Add Parametric Morphism : classOf
    with signature equiv ==> eq
      as classOf_mor.
    intros x y eqv;
      apply sameClass_eq; compute in *; intros; split; intros; simpl_equiv.
  Qed.

  Lemma classOf_eq x y : classOf x = classOf y <-> equiv x y.
    split; intro H; try apply classOf_mor; trivial.
    pose (classOf_refl x).
    pose (classOf_refl y).
    rewrite H in *;
      compute in *;
        simpl_equiv.
  Qed.

  Lemma disjointClasses_differentClasses (C C' : EquivalenceClass equiv) : (disjointClasses C C') -> (differentClasses C C').
    clear equiv_Equivalence; unfold differentClasses, disjointClasses; intro H.
    pose (ClassInhabited C) as H'; destruct H' as [ x H' ].
    exists x; specialize (H x); tauto.
  Qed.

  Lemma notDisjointClasses_sameClass (C C' : EquivalenceClass equiv) : (notDisjointClasses C C') -> (sameClass C C').
    clear equiv_Equivalence; unfold notDisjointClasses, sameClass; intro H; destruct H as [ x [ H0 H1 ] ]; intro v; split; intros;
      match goal with
        | [ H0 : InClass ?C ?x, H1 : InClass ?C ?y |- InClass ?C' ?x ]
          => let H := fresh in
            assert (H : equiv x y) by (apply (ClassElementsEquivalent C); assumption);
              rewrite H; assumption
      end.
  Qed.

  Lemma notDisjointClasses_eq (C C' : EquivalenceClass equiv) : (notDisjointClasses C C') -> C = C'.
    clear equiv_Equivalence; intro; apply sameClass_eq; apply notDisjointClasses_sameClass; assumption.
  Qed.

  Lemma EquivalenceClass_forall_equiv__eq (C C' : EquivalenceClass equiv) :
    (forall v v', (InClass C v \/ InClass C' v') -> (InClass C v /\ InClass C' v' <-> equiv v v')) ->
    C' = C.
    clear equiv_Equivalence; intro H. apply sameClass_eq; unfold sameClass; intro v.
    assert (equiv v v) by reflexivity; firstorder.
  Qed.

  Lemma EquivalenceClass_forall__eq (C C' : EquivalenceClass equiv) :
    (forall v, InClass C v <-> InClass C' v) ->
    C' = C.
    clear equiv_Equivalence; intro H. apply sameClass_eq; unfold sameClass;
    firstorder.
  Qed.
End equiv.

Add Parametric Relation value equiv : _ (@sameClass value equiv)
  reflexivity proved by (@sameClass_refl _ _)
  symmetry proved by (@sameClass_sym _ _)
  transitivity proved by (@sameClass_trans _ _)
    as sameClass_mor.

Section InClass_classOf.
  Variable value : Type.
  Variable equiv : value -> value -> Prop.
  Variable C : EquivalenceClass equiv.

  Lemma InClass_classOf_eq eqv v : InClass C v -> C = classOf eqv v.
    intro H.
    apply sameClass_eq.
    pose (classOf eqv v).
    pose (classOf_refl eqv v).
    pose (@ClassContainsEquivalent _ equiv).
    pose (@ClassElementsEquivalent _ equiv).
    specialize_all_ways.
    intro; split; intro;
      eauto.
  Qed.

  Let C_Equivalence : Equivalence equiv
    := {| Equivalence_Reflexive := ClassEquivalent_refl C;
          Equivalence_Symmetric := ClassEquivalent_sym C;
          Equivalence_Transitive := ClassEquivalent_trans C |}.

  Definition InClass_classOf_eq' : forall v, InClass C v -> C = classOf C_Equivalence v
    := InClass_classOf_eq C_Equivalence.
End InClass_classOf.

Ltac create_classOf_InClass :=
  repeat match goal with
           | [ H : InClass (@classOf ?v ?e ?eq ?val) _ |- _ ] => unique_pose (@classOf_refl v e eq val)
           | [ |- InClass (@classOf ?v ?e ?eq ?val) _ ] => unique_pose (@classOf_refl v e eq val)
         end.

Ltac replace_InClass := create_classOf_InClass;
  repeat match goal with
           | [ H : InClass ?C ?x, H' : InClass ?C ?x' |- _ ] => unique_pose (ClassElementsEquivalent C _ H _ H');
             try (clear H' || clear H) (* try, in case both appear in the conclusion *)
           | [ H : InClass ?C ?x |- InClass ?C ?x' ] => apply (ClassContainsEquivalent C x H x')
           | [ |- exists v : ?T, @?G v ] =>
             match G with
               | appcontext[InClass ?C ?v] => fail 1 (* [?v] cannot be the same as [v] above, so we fail *)
               | appcontext[InClass ?C _] => (* match an [InClass] expression that references a variable not scoped outside.
                                                This is a kludge to get the correct InClass, which matches the [exists]. *)
                 let v := fresh in let H := fresh in
                   destruct (ClassInhabited C) as [ v H ]; exists v
             end
           | [ |- _ /\ _ ] => split; intros; create_classOf_InClass
         end.

Ltac InClass2classOf eqv :=
  repeat match goal with
           | [ H : InClass ?C ?x |- _ ] =>
             apply (@InClass_classOf_eq _ _ C eqv _) in H
         end.

Ltac InClass2classOf' :=
  repeat match goal with
           | [ H : InClass ?C ?x |- _ ] =>
             apply (@InClass_classOf_eq' _ _ C _) in H
         end.

Hint Extern 1 (@eq (EquivalenceClass _ _) _ _) => apply EquivalenceClass_forall__eq; replace_InClass.

Ltac clear_InClass' :=
  repeat match goal with
           | [ |- context[InClass] ] => fail 1
           | [ H : InClass _ _ |- _ ] => clear H
         end.

Ltac clear_InClass := replace_InClass; clear_InClass'.

Section apply1.
  Variable value0 : Type.
  Variable equiv0 : value0 -> value0 -> Prop.

  Variable value' : Type.
  Variable equiv' : value' -> value' -> Prop.

  Variable f : value0 -> value'.
  Hypothesis f_mor : forall v v', equiv0 v v' -> equiv' (f v) (f v').
  Variable E0 : EquivalenceClass equiv0.

  Local Add Parametric Relation : _ equiv0
    reflexivity proved by (ClassEquivalent_refl E0)
    symmetry proved by (ClassEquivalent_sym E0)
    transitivity proved by (ClassEquivalent_trans E0)
      as apply_equiv_rel.

  Hypothesis equiv'_Equivalence : Equivalence equiv'.

  Local Add Parametric Relation : _ equiv'
    reflexivity proved by (Equivalence.equiv_reflexive _)
    symmetry proved by (Equivalence.equiv_symmetric _)
    transitivity proved by (Equivalence.equiv_transitive _)
      as apply_equiv'_rel.

  Hint Resolve f_mor.

  Definition apply_to_class : EquivalenceClass equiv'.
    refine {| InClass := (fun v => exists v0, InClass E0 v0 /\ equiv' v (f v0)) |};
    intros;
    abstract (solve [ reflexivity
                    | abstract (symmetry; assumption)
                    | abstract (etransitivity; eauto)
                    | destruct (ClassInhabited E0) as [ v0 ]; exists (f v0); eexists; split; eauto; apply f_mor; reflexivity
                    | destruct_hypotheses; repeat esplit; clear_InClass; repeat_subst_mor_of_type value'; try apply f_mor;
                      solve [ reflexivity
                            | assumption
                            | abstract (etransitivity; eauto) ]
                    ]).
  Defined.

  Lemma apply_to_class_f_inj : forall v, InClass E0 v -> InClass apply_to_class (f v).
    compute; firstorder.
  Qed.

  Lemma apply_to_class_f_surj : forall v, InClass apply_to_class v -> exists v', equiv' v (f v') /\ InClass E0 v'.
    compute; firstorder.
  Qed.
End apply1.

Hint Resolve apply_to_class_f_inj.

Lemma apply_to_classOf value0 equiv0 equiv0_eqv value' equiv' equiv'_eqv f f_mor e0 :
  @apply_to_class value0 equiv0 value' equiv' f f_mor
  (@classOf _ _ equiv0_eqv e0)
  equiv'_eqv
  = @classOf _ _ equiv'_eqv (f e0).
Proof.
  apply EquivalenceClass_forall__eq; intros; split; intros;
    hnf in *; destruct_hypotheses; replace_InClass; repeat_subst_mor_of_type value'; eauto; reflexivity.
Qed.

Section apply2.
  Variable value0 : Type.
  Variable equiv0 : value0 -> value0 -> Prop.

  Variable value1 : Type.
  Variable equiv1 : value1 -> value1 -> Prop.

  Variable value' : Type.
  Variable equiv' : value' -> value' -> Prop.

  Hypothesis equiv'_Equivalence : Equivalence equiv'.

  Local Add Parametric Relation : _ equiv'
    reflexivity proved by (Equivalence.equiv_reflexive _)
    symmetry proved by (Equivalence.equiv_symmetric _)
    transitivity proved by (Equivalence.equiv_transitive _)
      as apply2_equiv'_rel.

  Variable f : value0 -> value1 -> value'.
  Hypothesis f_mor : forall v0 v0', equiv0 v0 v0' -> forall v1 v1', equiv1 v1 v1' -> equiv' (f v0 v1) (f v0' v1').

  Variable E0 : EquivalenceClass equiv0.
  Variable E1 : EquivalenceClass equiv1.

  Local Add Parametric Relation : _ equiv0
    reflexivity proved by (@ClassEquivalent_refl _ _ E0)
    symmetry proved by (@ClassEquivalent_sym _ _ E0)
    transitivity proved by (@ClassEquivalent_trans _ _ E0)
      as apply2_equiv0_rel.

  Local Add Parametric Relation : _ equiv1
    reflexivity proved by (@ClassEquivalent_refl _ _ E1)
    symmetry proved by (@ClassEquivalent_sym _ _ E1)
    transitivity proved by (@ClassEquivalent_trans _ _ E1)
      as apply2_equiv1_rel.

  Definition apply2_to_class : EquivalenceClass equiv'.
    refine {| InClass := (fun v => exists v0 v1, InClass E0 v0 /\ InClass E1 v1 /\ equiv' v (f v0 v1)) |};
      abstract (
        intros;
          solve [ reflexivity || (symmetry; assumption) || (etransitivity; eauto) ] ||
            solve [
              destruct (ClassInhabited E0) as [ v0 ], (ClassInhabited E1) as [ v1 ]; exists (f v0 v1); repeat esplit;
              eauto; apply f_mor; reflexivity
            ] ||
            solve [
              destruct_hypotheses; repeat esplit; clear_InClass; repeat_subst_mor_of_type value'; try apply f_mor;
                reflexivity || assumption || etransitivity; eauto
            ]
    ).
  Defined.

  Lemma apply2_to_class_f_inj : forall v0 v1, InClass E0 v0 -> InClass E1 v1 -> InClass apply2_to_class (f v0 v1).
    compute; firstorder.
  Qed.

  Lemma apply2_to_class_f_surj : forall v, InClass apply2_to_class v -> exists v0 v1, equiv' v (f v0 v1) /\ InClass E0 v0 /\ InClass E1 v1.
    compute; firstorder.
  Qed.
End apply2.

Hint Resolve apply2_to_class_f_inj.

Lemma apply2_to_classOf
  value0 equiv0 equiv0_eqv
  value1 equiv1 equiv1_eqv
  value' equiv' equiv'_eqv
  f f_mor e0 e1 :
  @apply2_to_class value0 equiv0 value1 equiv1 value' equiv'
  equiv'_eqv
  f f_mor
  (@classOf _ _ equiv0_eqv e0)
  (@classOf _ _ equiv1_eqv e1)
  = @classOf _ _ equiv'_eqv (f e0 e1).
Proof.
  apply EquivalenceClass_forall__eq; intros; split; intros;
    hnf in *; destruct_hypotheses;
      repeat (clear_InClass; eexists; repeat split);
        clear_InClass;
        repeat_subst_mor_of_type value';
        hnf in *;
          try apply f_mor;
            eauto; reflexivity || (symmetry; assumption).
Qed.

Section description.
  (** Can be imported from Coq.Logic.ClassicalDescription,
      Coq.Logic.ClassicalEpsilon, Coq.Logic.ConstructiveEpsilon,
      Coq.Logic.Epsilon, Coq.Logic.IndefiniteDescription, or, for the
      axiom, Coq.Logic.Description *)

  Hypothesis constructive_definite_description :
    forall (A : Type) (P : A->Prop),
      (exists! x, P x) -> { x : A | P x }.

  Variable T : Type.

  Definition EquivalenceClass_eq_lift
  : EquivalenceClass (@eq T) -> T.
    intro x.
    cut (exists! u, InClass x u).
    - apply constructive_definite_description.
    - destruct (ClassInhabited x) as [u H].
      exists u.
      abstract (
          split; [ exact H
                 | intros; apply (ClassElementsEquivalent x); assumption ]
        ).
  Defined.

  Definition EquivalenceClass_eq_proj
  : T -> EquivalenceClass (@eq T).
    apply classOf; abstract typeclasses eauto.
  Defined.

  Lemma EquivalenceClass_eq_iso1
  : forall x, EquivalenceClass_eq_lift (EquivalenceClass_eq_proj x) = x.
    intros.
    expand.
    match goal with
      | [ |- appcontext[match ?E with _ => _ end] ] => case E
    end.
    intros; subst; reflexivity.
  Qed.

  Lemma EquivalenceClass_eq_iso2
  : forall x, EquivalenceClass_eq_proj (EquivalenceClass_eq_lift x) = x.
    intros.
    apply sameClass_eq; simpl.
    split;
      intros;
      simpl in *;
      subst;
      hnf;
      unfold EquivalenceClass_eq_lift;
      repeat match goal with
               | [ |- appcontext[match ?E with _ => _ end] ] => case E; simpl; intros
             end;
      subst;
      intuition.
    apply (ClassElementsEquivalent x); assumption.
  Qed.
End description.


(** * RIS.algebra : algebraic structures. *)
(* Set Implicit Arguments. *)
(* Unset Strict Implicit. *)
(* Unset Printing Implicit Defensive. *)

Require Import tools.

(** * Definitions *)
Section algebra.
  (** Let [A] be some type equipped with an equivalence relation [⩵] and a partial order [≦]. *)
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).

  (** We introduce some notations. *)
  Class Un := un : A.
  Notation " 𝟭 " := un.

  Class Zero := zero : A.
  Notation " 𝟬 " := zero.

  Class Product := prod : A -> A -> A.
  Infix " ⋅ " := prod (at level 40).

  Class ParProduct := par : A -> A -> A.
  Infix " ∥ " := par (at level 42).

  Class Join := join : A -> A -> A.
  Infix " ∪ " := join (at level 45).

  Class Star := star : A -> A.
  Notation " e ⋆ " := (star e) (at level 35).

  (** ** Basic properties *)
  Class Associative (prod : A -> A -> A) :=
    associative : (forall a b c : A, prod a (prod b c) ⩵ prod (prod a b) c).
  Class Commutative (prod : A -> A -> A) :=
    commutative : (forall a b : A, prod a b ⩵ prod b a).
  Class Idempotent (prod : A -> A -> A) :=
    idempotent : (forall a : A, prod a a ⩵ a).
  Class Unit (prod : A -> A -> A) (unit : A) :=
    {
      left_unit : forall a : A, prod unit a ⩵ a;
      right_unit : forall a : A, prod a unit ⩵ a
    }.
  Class Absorbing (prod : A -> A -> A) (z : A) :=
    {
      left_absorbing : forall a : A, prod z a ⩵ z;
      right_absorbing : forall a : A, prod a z ⩵ z
    }.

  (** ** Basic structures *)
  Class Monoid (prod : A -> A -> A) (unit : A) :=
    {
      mon_congr :> Proper (eqA ==> eqA ==> eqA) prod;
      mon_assoc :> Associative prod;
      mon_unit :> Unit prod unit;
    }.

  Class BiMonoid (prod : A -> A -> A) (par : A -> A -> A) (unit : A) :=
    {
      bimon_seq :> Monoid prod unit;
      bimon_par :> Monoid par unit;
      bimon_comm :> Commutative par
    }.

  Class Semilattice (join : A -> A -> A) :=
    {
      lat_congr :> Proper (eqA ==> eqA ==> eqA) join;
      lat_assoc :> Associative join;
      lat_comm :> Commutative join;
      lat_idem :> Idempotent join;
    }.

  Class Lattice (m j : A -> A -> A) :=
    {
      lat_meet_congr :> Proper (eqA ==> eqA ==> eqA) m;
      lat_meet_assoc :> Associative m;
      lat_meet_comm :> Commutative m;
      lat_join_congr :> Proper (eqA ==> eqA ==> eqA) j;
      lat_join_assoc :> Associative j;
      lat_join_comm :> Commutative j;
      lat_join_meet : forall a b, j a (m a b) ⩵ a;
      lat_meet_join : forall a b, m a (j a b) ⩵ a;
    }.

  Class SemiRing (prod add : A -> A -> A) (u z : A) :=
    {
      semiring_prod :> Monoid prod u;
      semiring_add :> Monoid add z;
      semiring_comm :> Commutative add;
      semiring_zero :> Absorbing prod z;
      semiring_left_distr : forall a b c, prod a (add b c) ⩵ add (prod a b) (prod a c);
      semiring_right_distr : forall a b c, prod (add a b) c ⩵ add (prod a c) (prod b c);
    }.

  Class BiSemiRing (prod par add : A -> A -> A) (u z : A) :=
    {
      bisemiring_bimon :> BiMonoid prod par u;
      bisemiring_add :> Monoid add z;
      bisemiring_comm :> Commutative add;
      bisemiring_zero_seq :> Absorbing prod z;
      bisemiring_zero_par :> Absorbing par z;
      bisemiring_left_distr : forall a b c, prod a (add b c) ⩵ add (prod a b) (prod a c);
      bisemiring_right_distr : forall a b c, prod (add a b) c ⩵ add (prod a c) (prod b c);
      bisemiring_par_distr : forall a b c, par a (add b c) ⩵ add (par a b) (par a c);
    }.

  (** ** Join semi-lattices *)
  Section order.
    Context {j : Join}.
    Context {S : Semilattice join}.

    Definition leqA : relation A := (fun x y => y ⩵ x ∪ y).
    Infix " ≦ " := leqA (at level 80).

    Global Instance preA : PreOrder leqA.
    Proof.
      destruct S as [p ass comm id];unfold leqA.
      split.
      - intro x;symmetry;apply id.
      - intros x y z e1 e2.
        rewrite e2 at 2.
        rewrite (ass x y z),<- e1.
        apply e2.
    Qed.

    Global Instance partialA : PartialOrder eqA leqA.
    Proof.
      destruct S as [p ass comm id].
      intros x y;unfold Basics.flip,leqA;split.
      - intros E;split.
        + rewrite E,(id y);reflexivity.
        + rewrite E;symmetry;apply id.
      - intros (E1&E2).
        rewrite E1.
        rewrite E2 at 1.
        apply comm.
    Qed.

    Lemma refactor e f g h : (e ∪ f) ∪ (g ∪ h) ⩵ (e ∪ g) ∪ (f ∪ h).
    Proof.
      rewrite (lat_assoc (e∪f) g h).
      rewrite <- (lat_assoc e f g).
      rewrite (@lat_comm _ S f g).
      rewrite (lat_assoc e g f).
      rewrite (lat_assoc (e∪g) f h).
      reflexivity.
    Qed.

    Global Instance proper_join_inf : Proper (leqA ==> leqA ==> leqA) join.
    Proof.
      intros x y I x' y' I';unfold leqA in *.
      rewrite I,I' at 1;apply refactor.
    Qed.

    Lemma inf_cup_left a b : a ≦ a ∪ b.
    Proof. unfold leqA; rewrite (lat_assoc _ _ _),(lat_idem _);reflexivity. Qed.

    Lemma inf_cup_right a b : b ≦ a ∪ b.
    Proof. rewrite (lat_comm a b);apply inf_cup_left. Qed.

    Lemma inf_join_inf a b c : a ≦ c -> b ≦ c -> a ∪ b ≦ c.
    Proof. intros;rewrite <- (lat_idem c); apply proper_join_inf;assumption. Qed.

    Context {z : Zero} {u : Unit join zero}.

    Lemma zero_minimal x : zero ≦ x.
    Proof. unfold leqA;symmetry ;apply left_unit. Qed.

  End order.

  Infix " ≦ " := leqA (at level 80).

  (** ** Kleene algebra and Boolean algebra *)
  Class KleeneAlgebra (j: Join) (p: Product) (z: Zero) (u:Un) (s:Star) :=
    {
      ka_star_congr :> Proper (eqA ==> eqA) star;
      ka_semiring :> SemiRing prod join un zero;
      ka_idem :> Idempotent join;
      ka_star_unfold : forall a, 𝟭 ∪ a ⋅ a ⋆ ≦ a⋆ ;
      ka_star_left_ind : forall a b, a ⋅ b ≦ b -> a ⋆ ⋅ b ≦ b;
      ka_star_right_ind : forall a b, a ⋅ b ≦ a -> a ⋅ b ⋆ ≦ a;
    }.

  Class BiKleeneAlgebra
        (j: Join) (seq: Product) (par : ParProduct) (z: Zero) (u:Un) (s:Star) :=
    {
      bika_star_congr :> Proper (eqA ==> eqA) star;
      bika_semiring :> BiSemiRing prod par join un zero;
      bika_idem :> Idempotent join;
      bika_star_unfold : forall a, 𝟭 ∪ a ⋅ a ⋆ ≦ a⋆ ;
      bika_star_left_ind : forall a b, a ⋅ b ≦ b -> a ⋆ ⋅ b ≦ b;
      bika_star_right_ind : forall a b, a ⋅ b ≦ a -> a ⋅ b ⋆ ≦ a;
    }.

  Class BooleanAlgebra (t f : A) (n : A -> A) (c d: A -> A -> A) :=
    {
      proper_c :> Proper (eqA ==> eqA ==> eqA) c;
      proper_d :> Proper (eqA ==> eqA ==> eqA) d;
      proper_n :> Proper (eqA ==> eqA) n;
      ba_conj_comm :> Commutative c;
      ba_disj_comm :> Commutative d;
      ba_true : forall a, c a t ⩵ a;
      ba_false : forall a, d a f ⩵ a;
      ba_conj_disj : forall x y z, c x (d y z) ⩵ d (c x y) (c x z);
      ba_disj_conj : forall x y z, d x (c y z) ⩵ c (d x y) (d x z);
      ba_neg_conj : forall a, c a (n a) ⩵ f;
      ba_neg_disj : forall a, d a (n a) ⩵ t;
    }.

End algebra.
Arguments Zero: clear implicits.
Arguments Un: clear implicits.
Arguments Product: clear implicits.
Arguments ParProduct: clear implicits.
Arguments Join: clear implicits.
Arguments Star: clear implicits.
Notation " 𝟭 " := un.
Notation " 𝟬 " := zero.
Infix " ⋅ " := prod (at level 40).
Infix " ∥ " := par (at level 42).
Infix " ∪ " := join (at level 45).
Notation " e ⋆ " := (star e) (at level 35).

Class Box A := box : A -> A.
Notation " ▢ " := box.

Arguments Monoid : clear implicits.
Arguments BiMonoid : clear implicits.
Arguments KleeneAlgebra : clear implicits.
Arguments KleeneAlgebra A eqA {j p z u s}.
Arguments SemiRing : clear implicits.
Arguments BiKleeneAlgebra : clear implicits.
Arguments BiKleeneAlgebra A eqA {j seq par z u s}.
Arguments BiSemiRing : clear implicits.
Arguments Semilattice : clear implicits.
Arguments BooleanAlgebra : clear implicits.
Arguments BooleanAlgebra {A} eqA t f n c d.
Arguments leqA : clear implicits.
Arguments leqA {A} eqA {j}.

(** * Facts about boolean algebra *)
Section booleanAlgebra.
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).
  Context {top bot : A} {neg : A -> A} {conj disj : A -> A -> A}.
  Context `{BooleanAlgebra A eqA top bot neg conj disj}.

  Notation " ⊤ " := top.
  Notation " ⊥ " := bot.
  Notation " ¬ " := neg.
  Infix " ∧ " := conj (at level 40).
  Infix " ∨ " := disj (at level 45).

  (** When we defined boolean algebra before, we relied on
  Huntington's 1904 axiomatization, which differs from the usual way
  they are defined, but is much more concise. We now show that this
  axiomatization indeed implies all the properties we expect of a
  boolean algebra. The following subsection is a straightforward
  adaptation of the proofs detailed on the wikipedia page of boolean
  algebra:
  #en.wikipedia.org/wiki/Boolean_algebra_(structure)#.*)

  (** ** Elementary properties *)
  Lemma UId1 o : (forall x, x ∨ o ⩵ x) -> o ⩵ ⊥.
  Proof.
    intros hyp.
    rewrite <- (ba_false o).
    rewrite (ba_disj_comm _ _).
    apply hyp.
  Qed.

  Lemma Idm1 x : x ∨ x ⩵ x.
  Proof.
    rewrite <- (ba_true (x∨x)),<-(ba_neg_disj x).
    rewrite <- ba_disj_conj,ba_neg_conj.
    apply ba_false.
  Qed.

  Lemma Bnd1 x : x ∨ ⊤ ⩵ ⊤.
  Proof.
    rewrite <- (ba_true (x∨⊤)),(ba_conj_comm _ _).
    rewrite <- (ba_neg_disj x) at 1.
    rewrite <- ba_disj_conj,ba_true.
    apply ba_neg_disj.
  Qed.

  Lemma Abs1 x y : x ∨ (x ∧ y) ⩵ x.
  Proof.
    rewrite <- (ba_true x) at 1.
    rewrite <- ba_conj_disj,(ba_disj_comm _ _),Bnd1.
    apply ba_true.
  Qed.

  Lemma UId2 o : (forall x, x ∧ o ⩵ x) -> o ⩵ ⊤.
  Proof.
    intros hyp.
    rewrite <- (ba_true o).
    rewrite (ba_conj_comm _ _).
    apply hyp.
  Qed.

  Lemma Idm2 x : x ∧ x ⩵ x.
  Proof.
    rewrite <- (ba_false (x∧x)),<-(ba_neg_conj x).
    rewrite <- ba_conj_disj,ba_neg_disj.
    apply ba_true.
  Qed.

  Lemma Bnd2 x : x ∧ ⊥ ⩵ ⊥.
  Proof.
    rewrite <- (ba_false (x∧⊥)),(ba_disj_comm _ _).
    rewrite <- (ba_neg_conj x) at 1.
    rewrite <- ba_conj_disj,ba_false.
    apply ba_neg_conj.
  Qed.

  Lemma Abs2 x y : x ∧ (x ∨ y) ⩵ x.
  Proof.
    rewrite <- (ba_false x) at 1.
    rewrite <- ba_disj_conj,(ba_conj_comm _ _),Bnd2.
    apply ba_false.
  Qed.

  Lemma UNg x x' : x ∨ x' ⩵ ⊤ -> x ∧ x' ⩵ ⊥ -> x' ⩵ ¬ x.
  Proof.
    intros h1 h2.
    rewrite <- (ba_true x'),<-(ba_neg_disj x),ba_conj_disj,(ba_conj_comm x' _),(ba_conj_comm x' _).
    rewrite h2.
    rewrite <- (ba_neg_conj x),(ba_conj_comm _ _),<-ba_conj_disj.
    rewrite h1.
    apply ba_true.
  Qed.

  Lemma DNg x : ¬(¬ x) ⩵ x.
  Proof.
    symmetry;apply UNg.
    - rewrite (ba_disj_comm _ _);apply ba_neg_disj.
    - rewrite (ba_conj_comm _ _);apply ba_neg_conj.
  Qed.

  Lemma A1 x y : x ∨ (¬ x ∨ y) ⩵ ⊤.
  Proof.
    rewrite <- (ba_true (x∨_)),(ba_conj_comm _ _),<-(ba_neg_disj x).
    rewrite <- ba_disj_conj.
    rewrite Abs2;reflexivity.
  Qed.

  Lemma A2 x y : x ∧ (¬ x ∧ y) ⩵ ⊥.
  Proof.
    rewrite <- (ba_false (x∧_)),(ba_disj_comm _ _),<-(ba_neg_conj x).
    rewrite <- ba_conj_disj.
    rewrite Abs1;reflexivity.
  Qed.

  Lemma B1 x y : (x ∨ y)∨(¬x∧¬y)⩵⊤.
  Proof.
    rewrite ba_disj_conj.
    rewrite (ba_disj_comm _ (¬x)), (ba_disj_comm _ (¬y)).
    rewrite (ba_disj_comm x y) at 2.
    rewrite <- (DNg x) at 2.
    rewrite <- (DNg y) at 3.
    repeat rewrite A1.
    apply ba_true.
  Qed.

  Lemma B2 x y : (x ∧ y)∧(¬x∨¬y)⩵⊥.
  Proof.
    rewrite ba_conj_disj.
    rewrite (ba_conj_comm _ (¬x)), (ba_conj_comm _ (¬y)).
    rewrite (ba_conj_comm x y) at 2.
    rewrite <- (DNg x) at 2.
    rewrite <- (DNg y) at 3.
    repeat rewrite A2.
    apply ba_false.
  Qed.

  Lemma C1 x y : (x ∨ y)∧ (¬x∧¬y)⩵⊥.
  Proof.
    rewrite (ba_conj_comm (x∨_) _),ba_conj_disj.
    rewrite (ba_conj_comm _ x),(ba_conj_comm _ y).
    rewrite (ba_conj_comm _ (¬y)) at 2.
    repeat rewrite A2.
    apply ba_false.
  Qed.

  Lemma C2 x y : (x ∧ y)∨ (¬x∨¬y)⩵⊤.
  Proof.
    rewrite (ba_disj_comm (x∧_) _),ba_disj_conj.
    rewrite (ba_disj_comm _ x),(ba_disj_comm _ y).
    rewrite (ba_disj_comm _ (¬y)) at 2.
    repeat rewrite A1.
    apply ba_true.
  Qed.

  Lemma DMg1 x y : ¬ (x∨y) ⩵ ¬ x ∧ ¬ y.
  Proof.
    symmetry;apply UNg.
    - apply B1.
    - apply C1.
  Qed.

  Lemma DMg2 x y : ¬ (x∧y) ⩵ ¬ x ∨ ¬ y.
  Proof.
    symmetry;apply UNg.
    - apply C2.
    - apply B2.
  Qed.

  Lemma D1 x y z : (x∨(y∨z))∨¬x⩵⊤.
  Proof.
    rewrite (ba_disj_comm _ (¬x)).
    rewrite <- (DNg x) at 2.
    apply A1.
  Qed.

  Lemma D2 x y z : (x∧(y∧z))∧¬x⩵⊥.
  Proof.
    rewrite (ba_conj_comm _ (¬x)).
    rewrite <- (DNg x) at 2.
    apply A2.
  Qed.

  Lemma E1 x y z : y∧(x∨(y∨z))⩵ y.
  Proof.
    rewrite ba_conj_disj,Abs2,(ba_disj_comm _).
    apply Abs1.
  Qed.

  Lemma E2 x y z : y∨(x∧(y∧z))⩵ y.
  Proof.
    rewrite ba_disj_conj,Abs1,(ba_conj_comm _).
    apply Abs2.
  Qed.

  Lemma F1 x y z : (x∨(y∨z))∨¬y ⩵ ⊤.
  Proof.
    rewrite (ba_disj_comm _ (¬ _)).
    rewrite <- ba_true,(ba_conj_comm _ _),<-(ba_neg_disj y) at 1.
    rewrite (ba_disj_comm y),<-ba_disj_conj,E1,(ba_disj_comm _ y).
    apply ba_neg_disj.
  Qed.

  Lemma F2 x y z : (x∧(y∧z))∧¬y ⩵ ⊥.
  Proof.
    rewrite (ba_conj_comm _ (¬ _)).
    rewrite <- ba_false,(ba_disj_comm _ _),<-(ba_neg_conj y) at 1.
    rewrite (ba_conj_comm y),<-ba_conj_disj,E2,(ba_conj_comm _ y).
    apply ba_neg_conj.
  Qed.

  Lemma G1 x y z : (x ∨(y∨z))∨¬z⩵⊤.
  Proof. rewrite (ba_disj_comm y z);apply F1. Qed.

  Lemma G2 x y z : (x ∧(y∧z))∧¬z⩵⊥.
  Proof. rewrite (ba_conj_comm y z);apply F2. Qed.

  Lemma H1 x y z : ¬ ((x∨y)∨z)∧x⩵⊥.
  Proof.
    rewrite DMg1,DMg1.
    rewrite (ba_conj_comm _).
    rewrite <- ba_false,(ba_disj_comm _).
    rewrite <- (ba_neg_conj x) at 1.
    rewrite <- ba_conj_disj,(ba_conj_comm _ (¬z)),E2.
    apply ba_neg_conj.
  Qed.

  Lemma H2 x y z : ¬ ((x∧y)∧z)∨x⩵⊤.
  Proof.
    rewrite DMg2,DMg2.
    rewrite (ba_disj_comm _).
    rewrite <- ba_true,(ba_conj_comm _).
    rewrite <- (ba_neg_disj x) at 1.
    rewrite <- ba_disj_conj,(ba_disj_comm _ (¬z)),E1.
    apply ba_neg_disj.
  Qed.

  Lemma I1 x y z : ¬ ((x∨y)∨z)∧y⩵⊥.
  Proof. rewrite (ba_disj_comm x y);apply H1. Qed.

  Lemma I2 x y z : ¬ ((x∧y)∧z)∨y⩵⊤.
  Proof. rewrite (ba_conj_comm x y);apply H2. Qed.

  Lemma J1 x y z : ¬((x∨y)∨z)∧z⩵⊥.
  Proof. rewrite DMg1,(ba_conj_comm _),(ba_conj_comm (¬ _));apply A2. Qed.

  Lemma J2 x y z : ¬((x∧y)∧z)∨z⩵⊤.
  Proof. rewrite DMg2,(ba_disj_comm _),(ba_disj_comm (¬ _));apply A1. Qed.

  Lemma K1 x y z : (x∨(y∨z))∨¬((x∨y)∨z)⩵⊤.
  Proof.
    repeat rewrite DMg1.
    repeat rewrite ba_disj_conj.
    rewrite D1,F1,G1.
    repeat rewrite ba_true;reflexivity.
  Qed.

  Lemma K2 x y z : (x∧(y∧z))∧¬((x∧y)∧z)⩵⊥.
  Proof.
    repeat rewrite DMg2.
    repeat rewrite ba_conj_disj.
    rewrite D2,F2,G2.
    repeat rewrite ba_false;reflexivity.
  Qed.

  Lemma L1 x y z : (x∨(y∨z))∧¬((x∨y)∨z) ⩵ ⊥.
  Proof.
    rewrite (ba_conj_comm _).
    repeat rewrite ba_conj_disj.
    rewrite H1,I1,J1.
    repeat rewrite ba_false;reflexivity.
  Qed.

  Lemma L2 x y z : (x∧(y∧z))∨¬((x∧y)∧z) ⩵ ⊤.
  Proof.
    rewrite (ba_disj_comm _).
    repeat rewrite ba_disj_conj.
    rewrite H2,I2,J2.
    repeat rewrite ba_true;reflexivity.
  Qed.

  Lemma Ass1 x y z : x∨(y∨z)⩵(x∨y)∨z.
  Proof.
    rewrite <- (DNg ((x∨y)∨z));apply UNg.
    - rewrite (ba_disj_comm _);apply K1.
    - rewrite (ba_conj_comm _);apply L1.
  Qed.

  Lemma Ass2 x y z : x∧(y∧z)⩵(x∧y)∧z.
  Proof.
    rewrite <- (DNg ((x∧y)∧z));apply UNg.
    - rewrite (ba_disj_comm _);apply L2.
    - rewrite (ba_conj_comm _);apply K2.
  Qed.

  (** ** Boolean algebra as other structures*)
  Global Instance BooleanAlgebra_Join_Lattice : @Lattice A eqA conj disj.
  Proof.
    split.
    - apply H.
    - intros x y z;apply Ass2.
    - apply ba_conj_comm.
    - apply H.
    - intros x y z;apply Ass1.
    - apply ba_disj_comm.
    - apply Abs1.
    - apply Abs2.
  Qed.

  Global Instance BooleanAlgebra_Join_Semilattice : Semilattice A eqA disj.
  Proof.
    split.
    - apply H.
    - apply lat_join_assoc.
    - apply lat_join_comm.
    - intros a;apply Idm1.
  Qed.

  Global Instance BooleanAlgebra_Meet_Semilattice : Semilattice A eqA conj.
  Proof.
    split.
    - apply H.
    - apply lat_meet_assoc.
    - apply lat_meet_comm.
    - intros a;apply Idm2.
  Qed.

  Global Instance BooleanAlgebra_Meet_Monoid : @Monoid A eqA conj top.
  Proof.
    split.
    - apply H.
    - apply lat_meet_assoc.
    - split.
      + intro a;etransitivity;[apply lat_meet_comm|apply ba_true].
      + apply ba_true.
  Qed.

  Global Instance BooleanAlgebra_Join_Monoid : @Monoid A eqA disj bot.
  Proof.
    split.
    - apply H.
    - apply lat_join_assoc.
    - split.
      + intro a;etransitivity;[apply lat_join_comm|apply ba_false].
      + apply ba_false.
  Qed.

  Global Instance BooleanAlgebra_Semiring : SemiRing A eqA conj disj top bot.
  Proof.
    split.
    - eapply BooleanAlgebra_Meet_Monoid;eassumption.
    - eapply BooleanAlgebra_Join_Monoid;eassumption.
    - apply lat_join_comm.
    - split.
      + intros a;rewrite (ba_conj_comm _);apply Bnd2.
      + intros a;apply Bnd2.
    - apply ba_conj_disj.
    - intros x y z;rewrite (ba_conj_comm _),ba_conj_disj.
      repeat rewrite (ba_conj_comm z);reflexivity.
  Qed.

End booleanAlgebra.
(** * Sums *)
Section sums.
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).

  Context {j: Join A}{z: Zero A}.
  Context {j_mon : Monoid A eqA join zero}.
  Context {j_comm : @Commutative A eqA join}.
  Context {j_idem : @Idempotent A eqA join}.

  Infix " ≦ " := (leqA eqA) (at level 80).
  Instance semi_lat : Semilattice A eqA join.
  Proof.
    split;auto.
    - apply mon_congr.
    - apply mon_assoc.
  Qed.

  Definition Σ l := fold_right (fun e f => join e f) zero l.

  Lemma Σ_app L M : Σ L ∪ Σ M ⩵ Σ (L++M).
  Proof.
    induction L;simpl;[|rewrite <- IHL].
    - apply left_unit.
    - symmetry;apply mon_assoc.
  Qed.

  Lemma Σ_incl L M : L ⊆ M -> Σ L ≦ Σ M.
  Proof.
    intro I;unfold leqA;rewrite Σ_app;revert M I;induction L;intros M I.
    - reflexivity.
    - simpl;rewrite <- IHL by (rewrite <- I;intro;simpl;tauto).
      assert (Ia : a ∈ M) by (apply I;now left).
      clear I L IHL.
      induction M as [|e L].
      + simpl in *;tauto.
      + simpl;destruct Ia as [->|Ia];simpl.
        * rewrite (mon_assoc _ _ _),(j_idem _);reflexivity.
        * rewrite IHL at 1 by assumption.
          rewrite (mon_assoc _ _ _),(j_comm e a),(mon_assoc _ _ _);reflexivity.
  Qed.

  Global Instance Σ_equivalent : Proper (@equivalent _ ==> eqA) Σ.
  Proof.
    intros l1 l2 E.
    apply antisymmetry;apply Σ_incl;rewrite E;reflexivity.
  Qed.

  Lemma Σ_bigger e L : e ∈ L -> e ≦ Σ L.
  Proof.
     intro I;transitivity (Σ [e]).
     - simpl;apply inf_cup_left.
     - apply Σ_incl;intros ? [<-|F];simpl in *;tauto.
  Qed.

  Lemma Σ_bounded e L : (forall f, f ∈ L -> f ≦ e) <-> Σ L ≦ e.
  Proof.
    split.
    - induction L;simpl;intro I.
      + apply zero_minimal.
      + rewrite IHL by (intros ? ?;apply I;now right).
        rewrite (I a) by now left.
        rewrite (j_idem e);reflexivity.
    - intros E f If.
      rewrite <- E;apply Σ_bigger,If.
  Qed.
End sums.

(** * Products *)
Section prods.
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).

  Context {m : Product A}{u: Un A}.
  Context {j_mon : Monoid A eqA prod un}.

  Definition Π l := fold_right (fun e f => e ⋅ f) 𝟭 l.

  Lemma Π_app L M : Π L ⋅ Π M ⩵ Π (L++M).
  Proof.
    induction L;simpl;[|rewrite <- IHL].
    - apply left_unit.
    - symmetry;apply mon_assoc.
  Qed.

  Fixpoint Power (β : A) n :=
    match n with
    | 0 => 𝟭
    | S n => β ⋅ Power β n
    end.
  Infix " ^ " := Power.

  Global Instance Power_proper :
    Proper (eqA ==> eq ==> eqA) Power.
  Proof.
    intros a b E n _ <-;induction n;simpl.
    - reflexivity.
    - rewrite IHn,E;reflexivity.
  Qed.

  Lemma Power_last a n : a ^ (S n) ⩵ a ^ n ⋅ a.
  Proof.
    induction n;simpl.
    - rewrite left_unit,right_unit;reflexivity.
    - rewrite IHn,(mon_assoc _),IHn;reflexivity.
  Qed.

  Lemma Power_add a x y : a ^ (x + y) ⩵ a ^ x ⋅ a ^ y.
  Proof.
    induction x;simpl.
    - rewrite left_unit;reflexivity.
    - rewrite IHx;apply mon_assoc.
  Qed.
End prods.
Infix " ^ " := Power.

(** * Parallel Products *)
Section parprods.
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).

  Context {m : ParProduct A}{u: Un A}.
  Context {j_mon : Monoid A eqA par un}.

  Definition ParΠ l := fold_right (fun e f => e ∥ f) 𝟭 l.
  Notation " ! " := ParΠ.

  Lemma ParΠ_app L M : ! L ∥ ! M ⩵ ! (L++M).
  Proof.
    induction L;simpl;[|rewrite <- IHL].
    - apply left_unit.
    - symmetry;apply mon_assoc.
  Qed.

End parprods.
Notation " ! " := ParΠ.

Section idempotent_semirings.
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).

  Context {j: Join A}{p: Product A}{z: Zero A}{u:Un A}.
  Context {sr: SemiRing A eqA prod join un zero}.
  Context {idj: @Idempotent A eqA join}.

  Infix " ≦ " := (leqA eqA) (at level 80).

  Global Instance proper_prod_inf : Proper (leqA eqA ==> leqA eqA ==> leqA eqA) prod.
  Proof.
    intros e f I e' f' I'.
    unfold leqA in *.
    rewrite I' at 1.
    rewrite semiring_left_distr.
    rewrite I at 1.
    rewrite semiring_right_distr.
    rewrite <- (mon_assoc _ _ _).
    rewrite <- semiring_left_distr.
    rewrite <- I'.
    reflexivity.
  Qed.

  Instance join_semilattice : Semilattice A eqA join.
  Proof. split;apply sr||apply idj. Qed.

  Lemma Σ_distr_l e L : e ⋅ Σ L ⩵ Σ (map (prod e) L).
  Proof.
    induction L;simpl.
    - apply right_absorbing.
    - rewrite <- IHL,semiring_left_distr;reflexivity.
  Qed.

  Lemma Σ_distr_r e L : Σ L ⋅ e ⩵ Σ (map (fun f => f ⋅ e) L).
  Proof.
    induction L;simpl.
    - apply left_absorbing.
    - rewrite <- IHL,semiring_right_distr;reflexivity.
  Qed.

End idempotent_semirings.

(** * Kleene algebras *)
Section ka_facts.
  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).

  Context {j: Join A}{p: Product A}{z: Zero A}{u:Un A}{s:Star A}.
  Context {ka: KleeneAlgebra A eqA}.

  Infix " ≦ " := (leqA eqA) (at level 80).

  Global Instance ka_join_semilattice : Semilattice A eqA join:= join_semilattice.

  Lemma ka_star_unfold_eq a : a⋆ ⩵ 𝟭 ∪ a ⋅ a ⋆.
  Proof.
    apply antisymmetry.
    - etransitivity;[|apply ka_star_left_ind with (a0:=a)].
      + rewrite (semiring_left_distr _ _ _).
        rewrite right_unit.
        apply inf_cup_left.
      + rewrite (semiring_left_distr _ _ _).
        rewrite right_unit.
        apply inf_join_inf.
        * rewrite <- inf_cup_right.
          rewrite <- ka_star_unfold.
          rewrite (semiring_left_distr _ _ _).
          rewrite <- inf_cup_left.
          rewrite right_unit.
          reflexivity.
        * rewrite <- ka_star_unfold at 2.
          rewrite <- inf_cup_right.
          rewrite (semiring_left_distr _ _ _).
          rewrite <- inf_cup_right.
          reflexivity.
    - apply ka_star_unfold.
  Qed.

  Lemma ka_star_dup a : a ⋆ ⋅ a ⋆ ⩵ a ⋆.
  Proof.
    apply antisymmetry.
    - apply ka_star_left_ind.
      rewrite ka_star_unfold_eq at 2.
      apply inf_cup_right.
    - rewrite ka_star_unfold_eq at 1.
      apply inf_join_inf.
      + rewrite ka_star_unfold_eq.
        rewrite (semiring_left_distr _ _ _).
        rewrite (semiring_right_distr _ _ _).
        rewrite <- inf_cup_left.
        rewrite <- inf_cup_left.
        rewrite left_unit.
        reflexivity.
      + apply proper_prod_inf;[|reflexivity].
        rewrite ka_star_unfold_eq.
        rewrite <- inf_cup_right.
        rewrite ka_star_unfold_eq.
        rewrite (semiring_left_distr _ _ _).
        rewrite <- inf_cup_left.
        rewrite right_unit.
        reflexivity.
  Qed.

  Lemma one_inf_star e : 𝟭 ≦ e⋆.
  Proof. rewrite ka_star_unfold_eq;apply inf_cup_left. Qed.

  Lemma star_incr e : e ≦ e⋆.
  Proof. rewrite ka_star_unfold_eq, <- one_inf_star,right_unit;apply inf_cup_right. Qed.

  Global Instance proper_star_inf : Proper (leqA eqA ==> leqA eqA) star.
  Proof.
    intros e f I.
    transitivity (e⋆⋅𝟭);[rewrite right_unit;reflexivity|].
    rewrite (one_inf_star f).
    apply ka_star_left_ind.
    rewrite I,(star_incr f),ka_star_dup at 1;reflexivity.
  Qed.

  Lemma ka_star_star a : a⋆ ⩵ (a ⋆)⋆.
  Proof.
    apply antisymmetry.
    - apply proper_star_inf.
      rewrite ka_star_unfold_eq.
      rewrite <- inf_cup_right.
      rewrite ka_star_unfold_eq.
      rewrite (semiring_left_distr _ _ _).
      rewrite right_unit.
      apply inf_cup_left.
    - rewrite ka_star_unfold_eq at 1.
      apply inf_join_inf.
      + rewrite ka_star_unfold_eq.
        apply inf_cup_left.
      + apply ka_star_right_ind.
        rewrite ka_star_dup.
        reflexivity.
  Qed.

  Lemma ka_star_unfold_right a : 𝟭 ∪ a⋆ ⋅ a ≦ a⋆.
  Proof.
    apply inf_join_inf.
    - rewrite ka_star_unfold_eq.
      apply inf_cup_left.
    - rewrite <- ka_star_dup at 2.
      apply proper_prod_inf.
      + reflexivity.
      + rewrite ka_star_unfold_eq,ka_star_unfold_eq.
        rewrite semiring_left_distr,right_unit.
        rewrite <- inf_cup_right.
        apply inf_cup_left.
  Qed.

  Lemma star_join e f : (e ∪ f)⋆ ⩵ e ⋆ ∪ f⋆⋅(e⋅f⋆)⋆.
  Proof.
    apply antisymmetry.
    - transitivity ((e ∪ f) ⋆ ⋅ un);[rewrite right_unit;reflexivity|].
      transitivity ((e ∪ f) ⋆ ⋅ (e ⋆ ∪ f ⋆ ⋅ (e ⋅ f ⋆) ⋆)).
      + apply proper_prod_inf;[reflexivity|].
        etransitivity;[|apply inf_cup_left].
        apply one_inf_star.
      + apply ka_star_left_ind.
        rewrite semiring_left_distr.
        repeat rewrite semiring_right_distr.
        repeat apply inf_join_inf.
        * etransitivity;[|apply inf_cup_left].
          rewrite (star_incr e) at 1.
          rewrite ka_star_dup;reflexivity.
        * etransitivity;[|apply inf_cup_right].
          apply proper_prod_inf;[apply star_incr|].
          rewrite <- (one_inf_star f),right_unit;reflexivity.
        * etransitivity;[|apply inf_cup_right].
          rewrite <- (one_inf_star f) at 3;rewrite left_unit.
          rewrite <- (ka_star_dup (e⋅f⋆)) at 2.
          rewrite <- (star_incr (e⋅f⋆)) at 2.
          rewrite (mon_assoc _ _ _).
          reflexivity.
        * etransitivity;[|apply inf_cup_right].
          rewrite (mon_assoc _ _ _).
          apply proper_prod_inf;[|reflexivity].
          rewrite (star_incr f) at 1;rewrite ka_star_dup;reflexivity.
    - apply inf_join_inf.
      + apply proper_star_inf,inf_cup_left.
      + rewrite <- (ka_star_dup (e∪f)).
        apply proper_prod_inf;[apply proper_star_inf,inf_cup_right|].
        rewrite (ka_star_star (e∪f)).
        apply proper_star_inf.
        rewrite <- (ka_star_dup (e∪f)).
        apply proper_prod_inf;[|apply proper_star_inf,inf_cup_right].
        rewrite <- star_incr;apply inf_cup_left.
  Qed.

  Lemma un_star : un⋆ ⩵ un.
  Proof.
    apply antisymmetry.
    - transitivity (un⋆⋅un);[rewrite right_unit;reflexivity|].
      apply ka_star_left_ind;rewrite left_unit;reflexivity.
    - apply star_incr.
  Qed.

  Lemma star_switch_side e : e⋆⋅e ⩵ e⋅ e⋆.
  Proof.
    apply antisymmetry.
    - transitivity (e⋆⋅e⋅e⋆).
      + rewrite <- one_inf_star at 3.
        rewrite right_unit;reflexivity.
      + rewrite <- (mon_assoc _ _ _).
        apply ka_star_left_ind.
        rewrite (star_incr e) at 2.
        rewrite ka_star_dup;reflexivity.
    - transitivity (e⋆⋅e⋅e⋆).
      + rewrite <- one_inf_star at 2.
        rewrite left_unit;reflexivity.
      + apply ka_star_right_ind.
        rewrite (star_incr e) at 2.
        rewrite ka_star_dup;reflexivity.
  Qed.

  Lemma ka_star_mid_split e : e⋆⋅e⋅e⋆ ≦ e⋆.
  Proof.
    etransitivity;[apply proper_prod_inf;[apply proper_prod_inf;
                                          [reflexivity|apply star_incr]|reflexivity]|].
    cut ((e ⋆ ⋅ e ⋆) ⋅ e ⋆ ⩵ e ⋆);[intros ->;reflexivity|].
    repeat rewrite ka_star_dup;reflexivity.
  Qed.

  Lemma ka_zero_star :  𝟬 ⋆ ⩵ 𝟭.
  Proof.
    apply antisymmetry.
    - transitivity (𝟬 ⋆ ⋅ 𝟭).
      + rewrite right_unit;reflexivity.
      + apply ka_star_left_ind.
        rewrite left_absorbing;apply zero_minimal.
    - apply one_inf_star.
  Qed.

End ka_facts.

Section bisemiring_is_semiring.
  Context {A} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.
  Context {s p j : A -> A -> A} {u z : A}.
  Context {bsr : BiSemiRing A eqA s p j u z}.
  Lemma bisemiring_is_semiring : SemiRing A eqA s j u z.
  Proof.
    split.
    - apply bimon_seq.
    - apply bisemiring_add.
    - apply bisemiring_comm.
    - apply bisemiring_zero_seq.
    - apply bisemiring_left_distr.
    - apply bisemiring_right_distr.
  Qed.
  Lemma bisemiring_is_semiring_par : SemiRing A eqA p j u z.
  Proof.
    split.
    - apply bimon_par.
    - apply bisemiring_add.
    - apply bisemiring_comm.
    - apply bisemiring_zero_par.
    - apply bisemiring_par_distr.
    - intros.
      rewrite (bimon_comm (j a b)),bisemiring_par_distr.
      rewrite (bimon_comm c a), (bimon_comm c b).
      reflexivity.
  Qed.
End bisemiring_is_semiring.

Section bika_is_ka.
  Context {A} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.
  Context `{BiKleeneAlgebra A eqA}.
  Lemma bika_is_ka : KleeneAlgebra A eqA.
  Proof.
    split.
    - apply bika_star_congr.
    - eapply bisemiring_is_semiring.
      Unshelve.
      + exact par.
      + exact bika_semiring.
    - apply bika_idem.
    - apply H.
    - apply H.
    - apply H.
  Qed.
End bika_is_ka.

Section powerset_biKA.
  Context {A} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " ⩵ " := eqA (at level 80).

  Context `{Product A}`{ParProduct A}`{Un A}.
  Context {bimon: BiMonoid A eqA prod par un}.

  Definition SetBiKA := {f : A -> Prop | Proper (eqA ==> iff) f}.

  Definition member u (a : SetBiKA) := (proj1_sig a u).
  Infix " ∊ " := member (at level 80).

  Global Instance SetBiKA_eq : SemEquiv SetBiKA :=
    fun a b => forall u, u ∊ a <-> u ∊ b.
  Global Instance SetBiKA_inf : SemSmaller SetBiKA :=
    fun a b => forall u, u ∊ a -> u ∊ b.

  Global Instance member_Proper : Proper (eqA ==> sequiv ==> iff) member.
  Proof.
    intros u v E a b E'.
    transitivity (v ∊ a).
    - apply (proj2_sig a),E.
    - apply E'.
  Qed.

  Global Instance SetBiKA_eq_equiv : Equivalence sequiv.
  Proof.
    split.
    - intros (a,?) w;tauto.
    - intros (a,?) (b,?) E w;symmetry;apply E.
    - intros (a,?) (b,?) (c,?) E1 E2 w;rewrite (E1 _),(E2 _);reflexivity.
  Qed.

  Global Instance SetBiKA_inf_preorder : PreOrder ssmaller.
  Proof.
    split.
    - intros a w;tauto.
    - intros a b c E1 E2 w h;apply (E2 _),(E1 _),h.
  Qed.
  Global Instance SetBiKA_inf_partialorder : PartialOrder sequiv ssmaller.
  Proof.
    intros a b;unfold Basics.flip;split.
    - intros E;split;intros w h;apply E,h.
    - intros (h1&h2) w;split;[apply h1|apply h2].
  Qed.

  Lemma prod_internal (a b: SetBiKA) :
    Proper (eqA ==> iff) (fun w => exists u1 u2, w ⩵ u1 ⋅ u2 /\ u1 ∊ a /\ u2 ∊ b).
  Proof.
    intros u1 u2 E;split;intros (v1&v2&E'&I1&I2);exists v1,v2;repeat split;auto.
    - rewrite <-E;auto.
    - rewrite E;auto.
  Qed.
  Lemma par_internal (a b: SetBiKA) :
    Proper (eqA ==> iff) (fun w => exists u1 u2, w ⩵ u1 ∥ u2 /\ u1 ∊ a /\ u2 ∊ b).
  Proof.
    intros u1 u2 E;split;intros (v1&v2&E'&I1&I2);exists v1,v2;repeat split;auto.
    - rewrite <-E;auto.
    - rewrite E;auto.
  Qed.
  Lemma join_internal (a b: SetBiKA) :
    Proper (eqA ==> iff) (fun w => w ∊ a \/ w ∊ b).
  Proof.
    intros u v E.
    destruct a as (a&Pa),b as (b&Pb);simpl.
    rewrite (Pa _ _ E),(Pb _ _ E);reflexivity.
  Qed.
  Lemma un_internal : Proper (eqA ==> iff) (fun w => w ⩵ 𝟭).
  Proof. intros u v E;rewrite E;reflexivity. Qed.

  Lemma zero_internal : Proper (eqA ==> iff) (fun _ => False).
  Proof. intros ? ? ?;reflexivity. Qed.

  Global Instance SetBiKAProd : Product SetBiKA :=
    fun a b =>
      exist _ (fun w => exists u1 u2, w ⩵ u1 ⋅ u2 /\ u1 ∊ a /\ u2 ∊ b)
            (prod_internal a b).

  Global Instance SetBiKAPar : ParProduct SetBiKA :=
    fun a b =>
      exist _ (fun w => exists u1 u2, w ⩵ u1 ∥ u2 /\ u1 ∊ a /\ u2 ∊ b)
            (par_internal a b).

  Global Instance SetBiKAJoin : Join SetBiKA :=
    fun a b => exist _ (fun u => u ∊ a \/ u ∊ b) (join_internal a b).
  Global Instance SetBiKAUn : Un SetBiKA :=
    exist _ (fun u => u ⩵ 𝟭) un_internal.
  Global Instance SetBiKAZero : Zero SetBiKA :=
    exist _ (fun _ => False) zero_internal.

  Lemma star_internal a : Proper (eqA ==> iff) (fun u => exists n, u ∊ (a ^ n)).
  Proof. intros u1 u2 E;split;intros (n&I);exists n;apply (proj2_sig (a^n) _ _ E),I. Qed.

  Global Instance SetBiKAStar : Star SetBiKA :=
    fun a => exist _ (fun u => exists n, u ∊ (a ^ n)) (star_internal a).

  Global Instance SetBiKA_bisemiring : BiSemiRing SetBiKA sequiv prod par join un zero.
  Proof.
    split.
    - split.
      + split.
        * intros (a,?) (b,?) E (a',?) (b',?) E' w;split.
          -- intros (u1&u2&Eu&E1&E2);exists u1,u2.
             apply E in E1;apply E' in E2;tauto.
          -- intros (u1&u2&Eu&E1&E2);exists u1,u2.
             apply E in E1;apply E' in E2;tauto.
        * intros a b c w;split.
          -- intros (u1&?&E1&I1&u2&u3&E2&I2&I3).
             exists (u1⋅u2),u3;repeat split;auto.
             ++ rewrite E1,E2;apply mon_assoc.
             ++ exists u1,u2;repeat split;auto.
                reflexivity.
          -- intros (?&u3&E1&(u1&u2&E2&I1&I2)&I3).
             exists u1,(u2⋅u3);repeat split;auto.
             ++ rewrite E1,E2;symmetry;apply mon_assoc.
             ++ exists u2,u3;repeat split;auto.
                reflexivity.
        * split;intros a w;split.
          -- intros (u1&u2&E1&E2&I).
             eapply (proj2_sig a);[|eauto].
             rewrite E1,E2,left_unit;reflexivity.
          -- intros I;exists 𝟭,w.
             repeat split;auto.
             ++ rewrite left_unit;reflexivity.
             ++ simpl;reflexivity.
          -- intros (u1&u2&E1&I&E2).
             eapply (proj2_sig a);[|eauto].
             rewrite E1,E2,right_unit;reflexivity.
          -- intros I;exists w,(𝟭:A).
             repeat split;auto.
             ++ rewrite right_unit;reflexivity.
             ++ simpl;reflexivity.
      + split.
        * intros a b E a' b' E' w;split.
          -- intros (u1&u2&Eu&E1&E2);exists u1,u2.
             apply E in E1;apply E' in E2;tauto.
          -- intros (u1&u2&Eu&E1&E2);exists u1,u2.
             apply E in E1;apply E' in E2;tauto.
        * intros a b c w;split.
          -- intros (u1&?&E1&I1&u2&u3&E2&I2&I3).
             exists (u1∥u2),u3;repeat split;auto.
             ++ rewrite E1,E2;apply mon_assoc.
             ++ exists u1,u2;repeat split;auto.
                reflexivity.
          -- intros (?&u3&E1&(u1&u2&E2&I1&I2)&I3).
             exists u1,(u2∥u3);repeat split;auto.
             ++ rewrite E1,E2;symmetry;apply mon_assoc.
             ++ exists u2,u3;repeat split;auto.
                reflexivity.
      * split;intros a w;split.
          -- intros (u1&u2&E1&E2&I).
             eapply (proj2_sig a);[|eauto].
             rewrite E1,E2,left_unit;reflexivity.
          -- intros I;exists 𝟭,w.
             repeat split;auto.
             ++ rewrite left_unit;reflexivity.
             ++ simpl;reflexivity.
          -- intros (u1&u2&E1&I&E2).
             eapply (proj2_sig a);[|eauto].
             rewrite E1,E2,right_unit;reflexivity.
          -- intros I;exists w,(𝟭:A).
             repeat split;auto.
             ++ rewrite right_unit;reflexivity.
             ++ simpl;reflexivity.
      + intros a b w;split;intros (u1&u2&->&I1&I2);rewrite (bimon_comm _);exists u2,u1;
          repeat split;auto||reflexivity.
    - split.
      + intros a b E a' b' E' w;split;intros [I|I];(left;apply E,I)||(right;apply E',I).
      + intros a b c w;unfold join,SetBiKAJoin;simpl;tauto.
      + split;intros a w;unfold join,SetBiKAJoin,zero,SetBiKAZero;simpl;tauto.
    - intros a b w;unfold join,SetBiKAJoin;simpl;tauto.
    - split;intros a w;unfold prod,SetBiKAProd,zero,SetBiKAZero;simpl;firstorder.
    - split;intros a w;unfold par,SetBiKAPar,zero,SetBiKAZero;simpl;firstorder.
    - intros a b c w;split.
      + intros (u1&u2&->&I1&[I2|I2]);[left|right];exists u1,u2;repeat split;auto||reflexivity.
      + intros [(u1&u2&->&I1&I2)|(u1&u2&->&I1&I2)];exists u1,u2;
          repeat split;reflexivity||auto;[left|right];auto.
    - intros a b c w;split.
      + intros (u1&u2&->&[I1|I1]&I2);[left|right];exists u1,u2;repeat split;auto||reflexivity.
      + intros [(u1&u2&->&I1&I2)|(u1&u2&->&I1&I2)];exists u1,u2;
          repeat split;reflexivity||auto;[left|right];auto.
    - intros a b c w;split.
      + intros (u1&u2&->&I1&[I2|I2]);[left|right];exists u1,u2;repeat split;auto||reflexivity.
      + intros [(u1&u2&->&I1&I2)|(u1&u2&->&I1&I2)];exists u1,u2;
          repeat split;reflexivity||auto;[left|right];auto.
  Qed.

  Global Instance SetBiKA_biKA : BiKleeneAlgebra SetBiKA sequiv.
  Proof.
    split.
    - intros a b E w;split;intros (n&I);exists n.
      + rewrite <- E;assumption.
      + rewrite E;assumption.
    - apply SetBiKA_bisemiring.
    - intros a w;unfold join,SetBiKAJoin;simpl;tauto.
    - intros a w;split;[intros I;right;auto|intros [I|I];[|apply I]].
      destruct I as [->|(u1&u2&->&I1&n&I2)].
      + exists 0;simpl;reflexivity.
      + exists (S n),u1,u2;repeat split;auto||reflexivity.
    - intros a b E w;split;[intros I;right;auto|intros [I|I];[|apply I]].
      destruct I as (u1&u2&->&(n&I1)&I2).
      revert u1 u2 I1 I2;induction n;intros u1 u2 I1 I2.
      + rewrite I1,left_unit;auto.
      + destruct I1 as (v1&v2&->&I1&I1').
        rewrite <- (mon_assoc _).
        apply E;left;exists v1,(v2⋅u2);repeat split;auto||reflexivity.
    - intros a b E w;split;[intros I;right;auto|intros [I|I];[|apply I]].
      destruct I as (u1&u2&->&I1&n&I2).
      revert u1 u2 I1 I2;induction n;intros u1 u2 I1 I2.
      + rewrite I2,right_unit;auto.
      + rewrite Power_last in I2;destruct I2 as (v1&v2&->&I2&I2').
        rewrite (mon_assoc _).
        apply E;left;exists (u1⋅v1),v2;repeat split;auto||reflexivity.
  Qed.

  Lemma SetBiKA_inf_is_impl a b : leqA sequiv a b <-> a ≲ b.
  Proof.
    unfold leqA;split.
    - intros -> w I;left;auto.
    - intros I w;split.
      + intro I';right;auto.
      + intros [I'|I'].
        * apply I,I'.
        * auto.
  Qed.

  (** * Finite elements *)

  Definition mem (L : list A) := fun x => exists y, y ∈ L /\ y ⩵ x.

  Lemma list_internal L : Proper (eqA ==> iff) (mem L).
  Proof.
    intros x y E;split;intros (z&Iz&Ez);exists z;rewrite Ez at 2;rewrite E;
      split;assumption||reflexivity.
  Qed.

  Definition lift L : SetBiKA := exist _ (mem L) (list_internal L).

  Notation " ⟨ L ⟩ " := (lift L).

  Global Instance infLang : SemSmaller (list A) :=
    fun L M => forall x, x ∈ L -> exists y, y ∈ M /\ y ⩵ x.

  Global Instance eqLang : SemEquiv (list A) :=
    fun L M => L ≲ M /\ M ≲ L.

  Global Instance infLang_PreOrder : PreOrder ssmaller.
  Proof.
    split.
    - intros L x I;exists x;split;assumption||reflexivity.
    - intros L M N E1 E2 x I.
      apply E1 in I as (y&I&E).
      setoid_rewrite <-E.
      apply E2,I.
  Qed.
  Global Instance eqLang_Equiv : Equivalence sequiv.
  Proof.
    repeat split.
    - reflexivity.
    - reflexivity.
    - destruct H4;tauto.
    - destruct H4;tauto.
    - transitivity y;[apply H4|apply H5].
    - transitivity y;[apply H5|apply H4].
  Qed.
  Global Instance infLang_PartialOrder : PartialOrder sequiv ssmaller.
  Proof. repeat split;apply H4. Qed.

  Lemma lift_iso l m : l ≃ m <-> ⟨l⟩ ≃ ⟨m⟩.
  Proof.
    split.
    - intros (h1&h2);intro x;unfold member;simpl;unfold mem.
      split;intros (y&Iy&Ey);setoid_rewrite <- Ey;[apply h1|apply h2];apply Iy.
    - intros h;split;intros x Ix;apply h;exists x;split;assumption||reflexivity.
  Qed.

  Global Instance prod_list : Product (list A) := (@lift_prod A prod).
  Global Instance par_list : ParProduct (list A) := (@lift_prod A par).
  Global Instance join_list : Join (list A) := (@app A).
  Global Instance unit_list : Un (list A) := [𝟭].
  Global Instance zero_list : Zero (list A) := [].

  Lemma prod_list_eq l m : ⟨l ⋅ m⟩ ≃ ⟨l⟩⋅⟨m⟩.
  Proof.
    intro a;split.
    - intros (b&Ib&<-);unfold prod,prod_list in Ib.
      apply lift_prod_spec in Ib as (b1&b2&Ib1&Ib2&->).
      exists b1,b2;repeat split.
      + reflexivity.
      + exists b1;split;assumption||reflexivity.
      + exists b2;split;assumption||reflexivity.
    - intros (a1&a2&->&(b1&I1&<-)&b2&I2&<-).
      exists (b1⋅b2);split;[apply lift_prod_spec;exists b1,b2;tauto|reflexivity].
  Qed.

  Lemma par_list_eq l m : ⟨l ∥ m⟩ ≃ ⟨l⟩∥⟨m⟩.
  Proof.
    intro a;split.
    - intros (b&Ib&<-);unfold par,par_list in Ib.
      apply lift_prod_spec in Ib as (b1&b2&Ib1&Ib2&->).
      exists b1,b2;repeat split.
      + reflexivity.
      + exists b1;split;assumption||reflexivity.
      + exists b2;split;assumption||reflexivity.
    - intros (a1&a2&->&(b1&I1&<-)&b2&I2&<-).
      exists (b1∥b2);split;[apply lift_prod_spec;exists b1,b2;tauto|reflexivity].
  Qed.

  Lemma join_list_eq l m : ⟨l∪m⟩ ≃ ⟨l⟩∪⟨m⟩.
  Proof.
    intro a;split.
    - intros (b&Ib&<-).
      apply in_app_iff in Ib as [Ib|Ib];[left|right];exists b;split;assumption||reflexivity.
    - intros [I|I];destruct I as (b&Ib&<-);exists b;split;try reflexivity;
        apply in_app_iff;[left|right];assumption.
  Qed.

  Lemma unit_list_eq : ⟨𝟭⟩ ≃ 𝟭.
  Proof.
    intro a;split.
    - intros (b&[<-|F]&<-).
      + simpl;reflexivity.
      + simpl in F;tauto.
    - intros ->;exists 𝟭;split;[left|];reflexivity.
  Qed.

  Lemma zero_list_eq : ⟨𝟬⟩ ≃ 𝟬.
  Proof. intros a;split;simpl;unfold mem;simpl;firstorder. Qed.

  Global Instance ListBiSemiRing_bisemiring :
    BiSemiRing (list A) sequiv prod par join un zero.
  Proof.
    split.
    - split.
      + split.
        * intros x y E1 z t E2.
          rewrite lift_iso in *;repeat rewrite prod_list_eq.
          rewrite E1,E2;reflexivity.
        * intros x y z.
          rewrite lift_iso in *;repeat rewrite prod_list_eq.
          apply mon_assoc.
        * split;intro x;apply lift_iso;rewrite prod_list_eq,unit_list_eq.
          -- apply left_unit.
          -- apply right_unit.
      + split.
        * intros x y E1 z t E2.
          rewrite lift_iso in *;repeat rewrite par_list_eq.
          rewrite E1,E2;reflexivity.
        * intros x y z.
          rewrite lift_iso in *;repeat rewrite par_list_eq.
          apply mon_assoc.
        * split;intro x;apply lift_iso;rewrite par_list_eq,unit_list_eq.
          -- apply left_unit.
          -- apply right_unit.
      + intros x y;rewrite lift_iso in *;repeat rewrite par_list_eq;apply bimon_comm.
    - split.
      * intros x y E1 z t E2.
        rewrite lift_iso in *;repeat rewrite join_list_eq.
        rewrite E1,E2;reflexivity.
      * intros x y z.
        rewrite lift_iso in *;repeat rewrite join_list_eq.
        apply mon_assoc.
      * split;intro x;apply lift_iso;rewrite join_list_eq,zero_list_eq.
        -- apply left_unit.
        -- apply right_unit.
    - intros x y;apply lift_iso;repeat rewrite join_list_eq;apply bisemiring_comm.
    - split;intro x;apply lift_iso;rewrite prod_list_eq,zero_list_eq.
      + apply left_absorbing.
      + apply right_absorbing.
    - split;intro x;apply lift_iso;rewrite par_list_eq,zero_list_eq.
      + apply left_absorbing.
      + apply right_absorbing.
    - intros x y z;apply lift_iso;repeat rewrite prod_list_eq||rewrite join_list_eq.
      apply bisemiring_left_distr.
    - intros x y z;apply lift_iso;repeat rewrite prod_list_eq||rewrite join_list_eq.
      apply bisemiring_right_distr.
    - intros x y z;apply lift_iso;repeat rewrite par_list_eq||rewrite join_list_eq.
      apply bisemiring_par_distr.
  Qed.

  Global Instance ListBiSemiRing_idempotent : @Idempotent _ sequiv join.
  Proof. intros x;apply lift_iso;repeat rewrite join_list_eq;apply bika_idem. Qed.

End powerset_biKA.
Arguments SetBiKA : clear implicits.
Infix " ∊ " := member (at level 80).

Section morph.

  Context {A : Type} {eqA: relation A}.
  Context {equivA : @Equivalence A eqA}.

  Infix " =A " := eqA (at level 80).

  Context {joinA: Join A}{seqA: Product A}{parA:ParProduct A}{zA: Zero A}{uA:Un A}
          {sA:Star A}.

  Context {B : Type} {eqB: relation B}.
  Context {equivB : @Equivalence B eqB}.

  Infix " =B " := eqB (at level 80).

  Context {joinB: Join B}{seqB: Product B}{parB:ParProduct B}{zB: Zero B}{uB:Un B}
          {sB:Star B}.

  Class biKA_morph (g : A -> B) :=
    {
      morph_eq : Proper (eqA ==> eqB) g;
      morph_1 : g 𝟭 =B 𝟭;
      morph_0 : g 𝟬 =B 𝟬;
      morph_prod : forall b1 b2, g (b1 ⋅ b2) =B g b1 ⋅ g b2;
      morph_par : forall b1 b2, g (b1 ∥ b2) =B g b1 ∥ g b2;
      morph_join : forall b1 b2, g (b1 ∪ b2) =B g b1 ∪ g b2;
      morph_star : forall b, g (b⋆) =B g b⋆;
    }.
End morph.

Arguments biKA_morph : clear implicits.
Arguments biKA_morph {A} eqA {joinA seqA parA zA uA sA B} eqB {joinB seqB parB zB uB sB} g.

(* Section iso_biKA. *)
(*   Context {A : Type} {eqA: relation A}. *)
(*   Context {equivA : @Equivalence A eqA}. *)

(*   Infix " =A " := eqA (at level 80). *)

(*   Context {j: Join A}{seq: Product A}{par:ParProduct A}{z: Zero A}{u:Un A}{s:Star A}. *)
(*   Context {biKA: BiKleeneAlgebra A eqA}. *)

(*   Context {B : Type} {eqB: relation B}. *)
(*   Context {equivB : @Equivalence B eqB}. *)

(*   Infix " =B " := eqB (at level 80). *)

(*   Context {joinB: Join B}{seqB: Product B}{parB:ParProduct B}{zB: Zero B}{uB:Un B} *)
(*           {sB:Star B}. *)

(*   Context {f : A -> B} {g : B -> A}. *)
(*   Hypothesis fg : forall b, f (g b) =B b. *)
(*   Hypothesis gf : forall a, g (f a) =A a. *)

(*   Hypothesis g_morph : biKA_morph eqB eqA g. *)
(*   Hypothesis f_morph : biKA_morph eqA eqB f. *)

(*   Theorem BiKA_B : BiKleeneAlgebra B eqB. *)
(*   Proof. *)
(*     split. *)
(*     - intros b1 b2 E. *)
(*       etransitivity;[|apply fg]. *)
(*       etransitivity;[symmetry;apply fg|]. *)
(*       apply morph_eq. *)
(*       repeat rewrite morph_star. *)
(*       apply morph_eq in E;rewrite E;reflexivity. *)
(*     - repeat split. *)
(*       + intros b1 b2 E1 b1' b2' E2. *)
(*         etransitivity;[|apply fg]. *)
(*         etransitivity;[symmetry;apply fg|]. *)
(*         apply morph_eq. *)
(*         repeat rewrite morph_prod. *)
(*         apply morph_eq in E1;apply morph_eq in E2. *)
(*         destruct biKA. *)
(*         destruct bika_semiring0. *)
(*         destruct bisemiring_bimon0. *)
(*         destruct bimon_seq0. *)
(*         apply mon_congr0;auto. *)
(*       +  *)

(*         apply mon_congr. *)
(*         reflexivity. *)

(* Lemma iso_biKA   : *)
(*   () -> *)
(*   (forall a, g (f a) eqA a) -> *)
(*    -> *)
(*   (forall b1 b2, . *)


From Hammer Require Import Hammer.

Require Export Coq.Lists.List.
From VFA Require Import Perm.

Fixpoint select (x: nat) (l: list nat) : nat * list nat :=
match l with
|  nil => (x, nil)
|  h::t => if x <=? h
then let (j, l') := select x t in (j, h::l')
else let (j,l') := select h t in (j, x::l')
end.

Fixpoint selsort l n {struct n} :=
match l, n with
| x::r, S n' => let (y,r') := select x r
in y :: selsort r' n'
| nil, _ => nil
| _::_, O => nil
end.

Example out_of_gas: selsort [3;1;4;1;5] 3 <> [1;1;3;4;5].
Proof. hammer_hook "Selection" "Selection.out_of_gas".
simpl.
intro. inversion H.
Qed.

Example too_much_gas: selsort [3;1;4;1;5] 10 = [1;1;3;4;5].
Proof. hammer_hook "Selection" "Selection.too_much_gas".
simpl.
auto.
Qed.

Definition selection_sort l := selsort l (length l).

Example sort_pi: selection_sort [3;1;4;1;5;9;2;6;5;3;5] = [1;1;2;3;3;4;5;5;5;6;9].
Proof. hammer_hook "Selection" "Selection.sort_pi".
unfold selection_sort.
simpl.
reflexivity.
Qed.

Inductive sorted: list nat -> Prop :=
| sorted_nil: sorted nil
| sorted_1: forall i, sorted (i::nil)
| sorted_cons: forall i j l, i <= j -> sorted (j::l) -> sorted (i::j::l).

Definition is_a_sorting_algorithm (f: list nat -> list nat) :=
forall al, Permutation al (f al) /\ sorted (f al).

Definition selection_sort_correct : Prop :=
is_a_sorting_algorithm selection_sort.

Lemma select_perm: forall x l,
let (y,r) := select x l in
Permutation (x::l) (y::r).
Proof. hammer_hook "Selection" "Selection.select_perm".

intros x l; revert x.
induction l; intros; simpl in *.
Admitted.

Lemma selsort_perm:
forall n,
forall l, length l = n -> Permutation l (selsort l n).
Proof. hammer_hook "Selection" "Selection.selsort_perm".

Admitted.

Theorem selection_sort_perm:
forall l, Permutation l (selection_sort l).
Proof. hammer_hook "Selection" "Selection.selection_sort_perm".
Admitted.

Lemma select_smallest_aux:
forall x al y bl,
Forall (fun z => y <= z) bl ->
select x al = (y,bl) ->
y <= x.
Proof. hammer_hook "Selection" "Selection.select_smallest_aux".

Admitted.

Theorem select_smallest:
forall x al y bl, select x al = (y,bl) ->
Forall (fun z => y <= z) bl.
Proof. hammer_hook "Selection" "Selection.select_smallest".
intros x al; revert x; induction al; intros; simpl in *.
admit.
bdestruct (x <=? a).
*
destruct (select x al) eqn:?H.
Admitted.

Lemma selection_sort_sorted_aux:
forall  y bl,
sorted (selsort bl (length bl)) ->
Forall (fun z : nat => y <= z) bl ->
sorted (y :: selsort bl (length bl)).
Proof. hammer_hook "Selection" "Selection.selection_sort_sorted_aux".

Admitted.

Theorem selection_sort_sorted: forall al, sorted (selection_sort al).
Proof. hammer_hook "Selection" "Selection.selection_sort_sorted".
intros.
unfold selection_sort.

Admitted.

Theorem selection_sort_is_correct: selection_sort_correct.
Proof. hammer_hook "Selection" "Selection.selection_sort_is_correct".
split. apply selection_sort_perm. apply selection_sort_sorted.
Qed.

Require Import Recdef.

Function selsort' l {measure length l} :=
match l with
| x::r => let (y,r') := select x r
in y :: selsort' r'
| nil => nil
end.

Proof.
intros.
pose proof (select_perm x r).
rewrite teq0 in H.
apply Permutation_length in H.
simpl in *; omega.
Defined.

Lemma selsort'_perm:
forall n,
forall l, length l = n -> Permutation l (selsort' l).
Proof. hammer_hook "Selection" "Selection.selsort'_perm".

Admitted.

Eval compute in selsort' [3;1;4;1;5;9;2;6;5].