Require Import Notations.
Require Import Coq.Lists.List.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Numbers.NatInt.NZMul.
Require Import Coq.Structures.OrdersFacts.
Require Import Wf.
Require Import Lexicographic_Product.
Require Import Inverse_Image.
Import ListNotations.

(* notation for type level existential quantifier *)
Notation "'existsT' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'existsT' '/ ' x .. y , '/ ' p ']'")
  : type_scope.

Section genericTermination.

(* generic notion of a judgement *)
Variable Judgement : Type.
Variable final: Judgement -> Prop.
Hypothesis final_dec: forall j : Judgement, (final j) + (not (final j)).

(* generic well-founded relation on a type *)
Variable WFO : Type.
Variable wfo: WFO -> WFO -> Prop.
Hypothesis wfo_wf: well_founded wfo.

(* the `measure' function *)
Variable m: { j: Judgement | not (final j) } -> WFO.

(* 'make non-final judgement' - pairs a judgement with evidence that it is non-final *)
Definition mk_nfj: forall j: Judgement, forall e: not (final j), { j : Judgement | not (final j) }.
  intros j e. exists j. assumption.
Defined.

(* generic rule - a relation on two judgements *)
Definition Rule := Judgement -> Judgement -> Prop.

(* property 1: the measure always decreases  *)
Definition dec (Rules : list Rule) : Type :=
  forall r, In r Rules ->
  forall p c : Judgement, r p c ->
  forall ep : not (final p),
  forall ec : not (final c),
  wfo (m (mk_nfj c ec )) (m (mk_nfj p ep)).

(* property 2: for every non-final judgement, there is a rule which may be applied *)
Definition app (Rules : list Rule) : Type :=
  forall p : Judgement, not (final  p) ->
  existsT r, existsT c, (In r Rules * r p c).

(* the type of proofs *)
Inductive Pf (a : Judgement) (Rules : list Rule) : Judgement -> Type :=
  ax : forall j : Judgement, j = a -> Pf a Rules j
  | mkp: forall c : Judgement,
  forall r : Rule, In r Rules ->
  forall b : Judgement, r b c ->
  Pf a Rules b ->
  Pf a Rules c.

(* lemma specifying when and how a proof may be 'extended' *)
Lemma extend:
  forall Rules : list Rule,
  dec Rules ->
  app Rules ->
  forall a b : Judgement,
  forall eb: not (final b),
  Pf a Rules b ->
  existsT c : Judgement,
    (Pf a Rules c) *
    (forall ec: not (final c), wfo (m (mk_nfj c ec)) (m (mk_nfj b eb))).
Proof.
  intros Rules Hdec Happ a b eb Pab.
  unfold dec in Hdec.
  unfold app in Happ.
  specialize Happ with b.
  destruct Happ as [r Happ]. assumption.
  destruct Happ as [c [Happ1 Happ2]].
  specialize (Hdec r Happ1 b c Happ2).
  exists c.
  split.
  apply (mkp a Rules c r Happ1 b Happ2 Pab).
  intro ec.
  specialize (Hdec eb ec).
  assumption.
Defined.

(* auxiliary termination theorem *)
Theorem termination_aux : forall Rules : list Rule,
  dec Rules ->
  app Rules ->
  forall n: WFO,
  forall a b : Judgement,
  forall eb:  not (final b),
  m (mk_nfj b eb) = n ->
  Pf a Rules b ->
  (existsT c : Judgement, final c * Pf a Rules c).
Proof.
  intros Rules Hdec Happ n.
  induction n as [w IH] using (well_founded_induction_type wfo_wf).
  intros a b eb Hmb Hab.
  assert (Hex : existsT c : Judgement,
    (Pf a Rules c) *
    (forall ec: not (final c), wfo (m (mk_nfj c ec)) (m (mk_nfj b eb)))).
  apply (extend Rules Hdec Happ a b eb Hab).
  destruct Hex as [c [Hex1 Hex2]].
  destruct (final_dec c) as [f | nf].
  (* c is final *)
  exists c. split. assumption. assumption.
  (* c is non-final *)
  specialize (Hex2 nf).
  rewrite <- Hmb in IH.
  destruct (IH (m (mk_nfj c nf)) Hex2 a c nf) as [j Hj].
  reflexivity.
  assumption.
  exists j.
  assumption.
Defined.

(* the main theorem *)
Corollary termination:  forall Rules : list Rule,
  dec Rules ->
  app Rules ->
  forall a : Judgement,
  (existsT c : Judgement, final c * Pf a Rules c).
Proof.
  intros Rules Hdec Happ a.
  destruct (final_dec a) as [f | ea].
  exists a.
  split.
  assumption.
  apply (ax a).
  reflexivity.
  apply (termination_aux Rules Hdec Happ (m (mk_nfj a ea)) a a ea).
  reflexivity.
  apply (ax a).
  reflexivity.
Defined.

End genericTermination.
Section STV.

(* lists with pairwise distinct candidates *)
Inductive PD  {A: Type} : list A -> Prop :=
   PDe :  PD  ( nil)
 | PDc :  forall a:A,forall l: list A, PD l /\ ~(In a l) -> (PD  (cons a l)).

Variable cand: Type.
Variable cand_all: list cand.
Hypothesis cand_pd: PD cand_all.
Hypothesis cand_finite: forall c, In c cand_all.
Hypothesis cand_eq_dec: forall c d:cand, {c=d} + {c<>d}.

(* a ballot is a list of candidates *)
Definition ballot := list cand.
Check ballot.

Variable bt : list ballot.
Variable qu : nat.
Variable s : nat.

(* intermediate and final states in vote counting *)
Inductive STV_Judgement :=
   state:                     (** intermediate states **)
       list ballot            (* uncounted votes *)
     * (cand -> list ballot)  (* assignment of counted votes to first pref candidate *)
     * { tally : (cand -> nat) | forall c, tally c <= qu }          (* tally *)
     * (list cand)            (* hopeful cands still in the running *)
     * { elected: list cand | length  elected <= s}           (* elected cands no longer in the running *)
     -> STV_Judgement
  | winners:                  (** final state **)
    list cand -> STV_Judgement.        (* election winners *)

Definition STV_final (a : STV_Judgement) : Prop :=
   exists w, a = winners w.

Lemma final_dec: forall j : STV_Judgement, (STV_final j) + (not (STV_final j)).
Proof.
  intro j. destruct j.
  right.
  unfold STV_final.
  unfold not. intro H.
  destruct H.
  discriminate.
  left.
  unfold STV_final.
  exists l.
  reflexivity.
Defined.

(* Rules *)
Definition STV_Rule := STV_Judgement -> STV_Judgement -> Prop.

(* the new tally is the old tally with c's votes incremented by one *)
Definition inc (c:cand) (t: cand -> nat) (nt: cand -> nat) : Prop :=
  (nt c = t c + 1)%nat /\  forall d, d <> c -> nt d = t d.

(* the new assignment is the old assignment with ballot b added for candidate c *)
Definition add (c:cand) (b:ballot) (a: cand -> list ballot) (na: cand -> list ballot) : Prop :=
  na c = b::(a c) /\  forall d, d <> c -> na d = a d.

(* l and nl are equal except that nl additionally contaeqe x *)
Definition eqe {A: Type} (x:A) (l: list A) (nl: list A) : Prop :=
  exists l1 l2: list A, l = l1 ++ l2 /\ nl = l1 ++ [x] ++ l2.

(* l contains x and replacing x with y in l yields nl *)
Definition rep {A:Type} (x y: A) (l nl: list A) :=
  exists l1 l2: list A, l = l1 ++ [x] ++ l2 /\ nl = l1 ++ [y] ++ l2.

(* remove one occurrence of a candidate from a list *)
Fixpoint remc (c: cand) (l: list cand) :=
  match l with
    nil => nil
  | cons l0 ls => if (cand_eq_dec c l0) then ls else cons l0 (remc c ls)
  end.

Lemma remc_ok : forall c:cand, forall l:list cand, In c l -> eqe c (remc c l) l.
Proof.
  intros c l. induction l as [| l0 ls IHls].
  intro i. contradict i.
  intro i.
  assert (H: {l0=c} + {l0<>c}) by apply (cand_eq_dec l0 c).
  destruct H as [l0eqc | l0neqc ].
  replace (remc c (l0::ls)) with ls.
  unfold eqe.
  exists ([]: list cand). exists ls. split.
  auto. replace c with l0. auto.
  replace c with l0. unfold remc. destruct (cand_eq_dec l0 l0). trivial.
  contradict n. trivial.
  (* we must have that In c ls *)
  assert (Hin: l0 = c \/ In c ls) by apply (in_inv i).
  destruct Hin as [l0eqc | Hin ].
  contradict l0neqc. assumption.
  (* apply IH *)
  assert (eqe c (remc c ls) ls) by apply (IHls Hin).
  unfold eqe in H.
  replace (remc c (l0::ls)) with (l0::(remc c ls)).
  destruct H as [l1 H]. destruct H as [l2 H]. destruct H as [lft rgt].
  unfold eqe.
  exists (l0::l1). exists l2.
  split.
  transitivity (l0::(l1++l2)). congruence. auto.
  transitivity (l0::(l1 ++ [c] ++ l2)). congruence. auto.
  unfold remc.
  destruct (cand_eq_dec c l0). contradict l0neqc. symmetry. assumption. trivial.
Qed.

(* increment tally for cand by one *)
Definition inct (c:cand) (t: cand -> nat) : cand -> nat :=
  fun d => if (cand_eq_dec c d) then (S(t d))%nat else (t d).

Lemma inct_ok: forall c:cand, forall t: cand -> nat, inc c t (inct c t).
Proof.
  intros. unfold inc. split.
  Functional Scheme inct_ind := Induction for inct Sort Prop.
  functional induction  (inct c t c). omega.
  assert False. apply (_x). trivial. elim H.
  intros d ass.
  functional induction (inct c t d).
  assert False. apply ass. trivial. elim H. trivial.
Qed.

(* add ballot to vote assignment  for cand *)
Definition adda (c:cand) (b:ballot) (a: cand -> list ballot) : cand -> list ballot :=
  fun d => if (cand_eq_dec c d) then (b::(a d)) else (a d).

Lemma adda_ok : forall c: cand, forall b: ballot, forall a: cand -> list ballot, add c b a (adda c b a).
Proof.
  intros. unfold adda. unfold add. destruct (cand_eq_dec c c). split. trivial.
  intros d ass. destruct (cand_eq_dec c d).  contradict ass. auto. trivial.
  split. contradict n. trivial. contradict n. trivial.
Qed.

(* prefixing is one way of conjoining *)
Lemma ins_hd {A: Type}: forall c: A, forall l: list A, eqe c l (c::l).
  Proof.
  intros c l.
  unfold eqe.
  exists ([]: list A). exists l. split.
  auto. auto.
Qed.
Notation " x 'With' p " := (exist _ x p) (at level 20).

Lemma tly_qu : forall t :{ tally : (cand -> nat) | forall c, tally c <= qu },
   forall c, (proj1_sig t) c < qu ->
  (forall d, inct c (proj1_sig t) d <= qu).
Proof.
  intros t c H1 d.
  assert (inc c (proj1_sig t) (inct c (proj1_sig t))).
  apply inct_ok.
  unfold inc in H.
  destruct H as [H2 H3].
  destruct (cand_eq_dec c d).
  subst. rewrite -> H2. intuition.
  specialize (H3 d).
  assert (d<>c). apply not_eq_sym. assumption.
  specialize (H3 H).
  rewrite -> H3.
  destruct t. simpl.
  simpl in H1, H2, H3.
  specialize (l d).
  assumption.
Qed.

Lemma eq_tly: forall c, forall t: cand-> nat, (forall d : cand, t d <= qu) -> qu <= t c -> t c = qu.
Proof.
  intros c t H1 H2.
  specialize H1 with c. intuition.
Qed.

Definition c1 (p: STV_Judgement) (c: STV_Judgement) : Prop :=
  exists u nu a na t nt h e f fs,          (** count one vote **)
    let 'tl With tp := t in
    let 'ntl With ntp := nt in
  p = state (u, a, t, h, e ) /\          (* if we are counting votes *)
  eqe (f::fs) nu u /\                           (* and del'ing a vote with 1st pref f yields new list of uncounteds *)
  In f h /\                                     (* and f is a hopeful *)
  tl f < qu /\                                    (* and this isn't surplus *)
  add f (f::fs) a na /\                         (* and the new assignment records the vote for f *)
  inc f tl ntl /\                                 (* and the new tally increments the votes for f by one *)
  c = state (nu, na, nt, h, e).        (* we continue with updated tally and assignment *)

Lemma el_length_cons : forall l: list cand, forall d: cand, length l < s ->  length (d::l) <= s.
Proof.
  intros l d H. simpl. auto.
Qed.

Definition el (p: STV_Judgement) (c: STV_Judgement) : Prop :=
  exists u a t h nh ne d e,                (** elect a candidate **)
    let 'els With elp := e in                (*  e and ne are sigma-types: {l : list cand | length l <= s } *)
    let 'nels With nelp := ne in
  p = state (u, a, t, h, e) /\           (* if we have an uncounted vote with 1st preference f *)
  In d h /\                                     (* and d is a hopeful *)
  (proj1_sig t) (d) = qu /\                                 (* and d has enough votes *)
  length els < s /\                              (* and there are still unfilled seats *)
  eqe d nh h /\                                 (* and f has been removed from the new list of hopefuls *)
  eqe d els nels /\                     (* and del'ing d from the new elected cands gives old elected *)
  c = state (u, a, t, nh, ne).            (* then proceed with updated  hopefuls and elected cands *)

Definition tv (p: STV_Judgement) (c: STV_Judgement) : Prop :=
  exists u nu a t h e f fs,                (** transfer vote **)
  p = state (u, a, t, h, e) /\           (* if we are counting votes *)
  ~(In f h) /\                                  (* and f no longer in the running *)
  rep (f::fs) fs u nu /\                        (* and the uncounted votes are updated by deleting first pref f from a vote *)
 c = state (nu, a, t, h, e).            (* we continue with updated set of uncounted votes *)

Definition ey (p: STV_Judgement) (c: STV_Judgement) : Prop :=
  exists u nu  a t h e,                    (** empty vote **)
  p = state (u, a, t, h, e) /\           (* if we are counting votes *)
  eqe [] nu u /\                                (* and an empty vote is removed from uncounted votes *)
  c = state (nu, a, t, h, e).             (* continue with updated set of uncounted votes *)

Definition tl (p: STV_Judgement) (c: STV_Judgement) : Prop :=
  exists u a t h nh e d,                           (** transfer least **)
  p = state ([], a, t, h, e) /\                      (* if we have no uncounted votes *)
  length (proj1_sig e) + length h > s /\   (* and there are still too many candidates *)
  In d h  /\                                              (* and candidate d is still hopeful *)
  (forall e, In e h-> (proj1_sig t) d <= (proj1_sig t) e) /\   (* but all others have more votes *)
  eqe d nh h /\                                       (* and d has been removed from the new list of hopefuls *)
  u = a(d) /\                                            (* we transfer d's votes by marking them as uncounted *)
  c = state (u, a, t,nh, e).                       (* and continue in this new state *)

Definition hw (p: STV_Judgement) (c: STV_Judgement) : Prop :=
  exists w u a t h e,                      (** hopefuls win **)
  p = state (u, a, t, h, e) /\           (* if at any time *)
  length (proj1_sig e) + length h <= s /\                   (* we have more hopefuls and electeds  than seats *)
  w = (proj1_sig e) ++ h /\                                 (* and the winning candidates are their union *)
  c = winners (w).                      (* the elected cands and the remaining hopefuls are declared winners *)

Definition ew (p: STV_Judgement) (c: STV_Judgement) : Prop :=
  exists w u a t h e,                      (** elected win **)
  p = state (u, a, t, h, e) /\           (* if at any time *)
  length (proj1_sig e) = s /\          (* we have as many elected candidates as setas *)
  w = (proj1_sig e) /\                    (* and the winners are precisely the electeds *)
  c = winners w.                         (* they are declared the winners *)

(* list of rules for STV *)
Definition STV : list STV_Rule := [ c1; el; tv; ey; tl; hw; ew ].

(* lexicographic order is well-founded *)
(* from http://comments.gmane.org/gmane.science.mathematics.logic.coq.club/2554 *)
Definition STV_WFO := nat * (nat * nat).

Definition dep2 := sigT (A:= nat) (fun a => nat).
Definition dep3 := sigT (A:= nat) (fun a => dep2).

Definition mk2  : nat * nat -> dep2.
 intros (p,q).
 exists p.
 exact q.
 Defined.

Definition mk3 : nat * (nat * nat) -> dep3.
 intros (n, p_q).
 exists n.
 exact (mk2 p_q).
Defined.

Definition lt_pq :dep2->dep2->Prop :=
     (lexprod nat (fun a => nat) Peano.lt (fun a:nat =>Peano.lt)).
Definition lt_npq : dep3 -> dep3 -> Prop :=
     (lexprod nat (fun a => dep2) Peano.lt (fun a:nat =>lt_pq)).

Lemma wf_lexprod : well_founded lt_npq.
 unfold lt_npq;apply wf_lexprod.
 apply lt_wf.
 intro n.
 unfold lt_pq;apply wf_lexprod.
 apply lt_wf.
 intro m; apply lt_wf.
Qed.

Definition STV_wfo : STV_WFO -> STV_WFO -> Prop := (fun x y : nat * (nat * nat) =>
 lt_npq (mk3 x) (mk3 y)).

Lemma STV_wfo_wf : well_founded STV_wfo.
  unfold STV_wfo.
 apply wf_inverse_image.
 apply wf_lexprod.
Qed.

(* defining the measure *)

(* sum of lengths *)
Fixpoint sum_len {A: Type} (l: list (list A)) : nat := match l with
| [] => 0
| x::xs => (length x + sum_len xs)%nat
end.

(* sum of lengths is a homomorphism *)
Lemma sum_len_hom {A: Type} (l1 l2: list (list A)) : sum_len (l1 ++ l2) = (sum_len l1 + sum_len l2)%nat.
Proof.
  induction l1 as [|x xs IHxs].
  simpl. reflexivity.
  simpl. rewrite -> IHxs. rewrite -> Plus.plus_assoc. reflexivity.
Qed.

Lemma sum_len_dec {A: Type} (l1 l2: list (list A)) (x: A) (xs : list A) :
  sum_len (l1 ++ [xs] ++ l2) < sum_len (l1 ++ [x::xs] ++ l2).
Proof.
  rewrite -> ?sum_len_hom.  simpl.
   omega.
Qed.

(* measure *)
Definition STV_m: { j: STV_Judgement | not (STV_final j) } -> STV_WFO.
  intro H.
  destruct H as [j ej].
  destruct j.
  destruct p as [[[[u a] t] h] e].
  split.
  exact (length h).
  split.
  exact (length u).
  exact (sum_len u).
  contradiction ej.
  unfold STV_final.
  exists l.
  reflexivity.
Defined.

(* the lexicographic order is defined as intended *)
Lemma wfo_aux:  forall a b c a' b' c' : nat,
  (lt_npq (mk3 (a, (b, c))) (mk3 (a', (b', c'))) <->
    (a < a' \/
    (a = a' /\ b < b' \/
    (a = a' /\ b = b' /\ c < c')))).
Proof.
  intros. split. unfold lt_npq. unfold mk3. simpl. intro H. inversion H. subst.
  (* case 1st component are below one another *)
  auto.
  (* case 1st components are equal *)
  unfold lt_pq in H1. inversion H1. subst. auto.
  (* case 1st and 2nd components are equal and 3rd are below one another *)
  subst. auto.
  (* right-to-left direction *)
  intro H. destruct H.
  (* case 1st components are below one another *)
  unfold lt_npq. apply left_lex. assumption.
  destruct H.
  (* case 1st components are equal and 2nd components are below one another *)
  destruct H as [H1 H2]. subst. apply right_lex. apply left_lex. assumption.
  (* case 1st and 2nd components are identical, and 3rd components are below one another *)
  destruct H as [H1 H2]. subst. apply right_lex.  destruct H2 as [H1 H2]. subst. apply right_lex. assumption.
Qed.

(* we can find a candidate with least no of first prefs *)
Lemma list_min : forall A:Type, forall l: list A, forall f: A -> nat,
   (l = []) + (existsT m:A, (In m l /\ (forall b:A, In b l ->f m <= f b))).
Proof.
  intros.
  induction l as [ | l ls ].
  left. trivial.
  destruct IHls.
  right.
  exists l. split.
  apply (in_eq l ls). intros b ass.
  assert (l = b \/ In b ls).
  apply (in_inv ass). destruct H. replace l with b. apply (le_n (f b)). replace ls with ([] : list A) in H.
  contradict H.
  right. destruct s0. destruct a.
  assert ( {f x <= (f l)}  + {(f l) <= (f x)}).
  apply (le_ge_dec (f x) (f l)). destruct H1.
  (* x is the minimum *)
  exists x. split.
  apply (in_cons l x ls). assumption. intros b ass.
  assert (l = b \/ In b ls).
  apply (in_inv ass).
  destruct H1. replace b with l. assumption.
  apply (H0  b H1).
  (* l is the minimum *)
  exists l. split.
  apply (in_eq l ls).
  intros b ass.
  assert (l = b \/ In b ls). apply (in_inv ass). destruct H1.
  replace l with b. apply (le_n (f b)).
  transitivity (f x). assumption. apply (H0 b). assumption.
Defined.

(* proof of app property: a rule can always be applied to a non-final judgement *)
Lemma app_STV : app STV_Judgement STV_final STV.
Proof.
  unfold app.
  intros p Hnf.
  destruct p.
  destruct p as [[[[u a] t] h] e].
  destruct u.
  (* case u = [] *)
  destruct (le_lt_dec (length (proj1_sig e) + length h) s).
    (* case length e + length h <= s *)
  exists hw.
  exists (winners ((proj1_sig e) ++ h)).
  split. unfold STV.
  simpl. intuition.
  unfold hw.
  exists ((proj1_sig e) ++ h); exists []; exists a; exists t; exists h; exists e.
  split. reflexivity.
  split. assumption.
  split. reflexivity.
  reflexivity.
    (* case length e + length h > s *)
  destruct h.
      (* case h = [] *)
  contradict l. destruct e. intro H. simpl in H. intuition.
      (* case h = (c :: h) *)
  exists tl.
  assert (min: ((c::h)= []) + (existsT d, (In d (c :: h) /\ (forall e, In e (c :: h) -> (proj1_sig t) d <= (proj1_sig t) e)))).
  apply list_min .
  destruct min as [emp | non_emp].
  symmetry in emp.
  assert ([] <> (c :: h)).
  apply nil_cons.
  contradiction.
  destruct non_emp as [d [Hin Hmin]].
  exists (state (a d, a, t, remc d (c :: h), e)).
  split. unfold STV.
  intuition.
  unfold tl.
  exists (a d); exists a; exists t; exists (c :: h); exists (remc d (c :: h)); exists e; exists d.
  split. reflexivity.
  split. assumption.
  split. assumption.
  split. assumption.
  split. apply (remc_ok d (c :: h) Hin).
  split. reflexivity.
  reflexivity.
  (* case u <> [] *)
  destruct b.
    (* case b = [] *)
  exists ey.
  exists (state (u, a, t, h, e)).
  split.
  unfold STV. intuition.
  unfold ey.
  exists ([] :: u); exists u; exists a; exists t; exists h; exists e.
  split. reflexivity.
  split. apply (ins_hd [] u).
  reflexivity.
  (* case b <> [] *)
  destruct (in_dec cand_eq_dec c h).
    (* case In c h *)
  destruct (le_lt_dec qu ((proj1_sig t) c)).
      (* case t c >= qu *)
  destruct (le_lt_dec s (length (proj1_sig e))).
        (* case.length e >= s *)
  exists ew.
  exists (winners (proj1_sig e)).
  split. unfold STV.
  simpl. intuition.
  unfold ew.
  exists (proj1_sig e); exists ((c :: b) :: u); exists a; exists t; exists h; exists e.
  split. reflexivity.
  split. destruct e. simpl in l0. simpl. intuition.
  split. reflexivity.
  reflexivity.
        (* case.length e < s *)
  exists el.
  exists (state (((c :: b) :: u), a, t, (remc c h), (@exist (list cand) (fun l => length l <= s) (c :: (proj1_sig e)) (el_length_cons (proj1_sig e) c l0)))).
  split. unfold STV.
  simpl. intuition.
  unfold el.
  exists ((c :: b) :: u). exists a; exists t. exists h;
  exists (remc c h).
  pose (nel := c::(proj1_sig e)).
  pose (nep := el_length_cons (proj1_sig e) c l0).
  pose (ne := @exist (list cand) (fun l => length l <= s) nel nep).
  exists ne. exists c. exists e.
  remember e as e0. destruct e0.
  simpl.
  split. reflexivity.
  split. assumption.
  split. destruct t. simpl. simpl in l.
  apply (eq_tly c x0 l2). assumption.
  split. simpl in l0. assumption.
  split. apply (remc_ok c h i).
  split. unfold nel. unfold eqe. exists []. exists x. simpl. split. reflexivity. reflexivity.
  unfold ne. unfold nel. simpl.
  reflexivity.
      (* case t c < qu *)
  exists c1.
  exists (state (u, (adda c (c :: b) a), (@exist (cand -> nat) (fun tl => (forall c0, tl c0 <= qu)) (inct c (proj1_sig t)) (tly_qu t c l)), h, e)).
  split. unfold STV.
  simpl. intuition.
  unfold c1.
  exists ((c :: b) :: u); exists u; exists a; exists (adda c (c :: b) a).
  exists t.
  exists (@exist (cand -> nat) (fun tl => (forall c, tl c <= qu)) (inct c (proj1_sig t)) (tly_qu t c l)).
   exists h; exists e; exists c; exists b.
  destruct t.
  split. reflexivity.
  split. apply (ins_hd (c :: b) u).
  split. assumption.
  split. assumption.
  split. apply (adda_ok c (c :: b) a).
  split. apply (inct_ok c x).
  reflexivity.
    (* case ~ In c h *)
  exists tv.
  exists (state ((b :: u), a, t, h, e)).
  split. unfold STV.
  simpl. intuition.
  unfold tv.
  exists ((c :: b) :: u); exists (b :: u); exists a; exists t; exists h; exists e; exists c; exists b.
  split. reflexivity.
  split. assumption.
  split. unfold rep.
  exists []; exists u.
  split. simpl. reflexivity.
  simpl. reflexivity.
  reflexivity.
  (* final judgement *)
  contradiction Hnf.
  unfold STV_final.
  exists l.
  reflexivity.
Qed.

(* proof of dec property : when a rule is applied, the measure decreases *)
(* proof is done rule by rule *)
Lemma dec_STV_c1 : forall p c : STV_Judgement,
c1 p c -> forall (ep : ~ STV_final p) (ec : ~ STV_final c),
STV_wfo (STV_m (mk_nfj STV_Judgement STV_final c ec))
  (STV_m (mk_nfj STV_Judgement STV_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p. destruct p as [[[[u1 a1] t1] h1] e1].
  destruct c. destruct p as  [[[[u2 a2] t2] h2] e2].
  (* non final judgements *)
  unfold STV_m.
  simpl.
  unfold STV_wfo.
  rewrite -> wfo_aux.
  right. left.
  unfold c1 in Hr.
  destruct Hr as [u [nu [a [na [t [nt [h [e [f [fs H]]]]]]]]]].
  destruct t. destruct nt.
  destruct H as [Heq1 [Heqe [Hin [Ht [Hadd [Hinc Heq2]]]]]].
  inversion Heq1.
  inversion Heq2.
  split. reflexivity.
  unfold eqe in Heqe.
  destruct Heqe as [l1 [l2 [Heqe1 Heqe2]]].
  rewrite -> Heqe1, Heqe2.
  rewrite -> app_length. rewrite -> app_length. rewrite -> app_length.
  intuition.
  (* final jugements *)
  unfold STV_final in ec.
  contradict ec.
  exists l. reflexivity.
  unfold STV_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_STV_tv : forall p c : STV_Judgement,
tv p c -> forall (ep : ~ STV_final p) (ec : ~ STV_final c),
STV_wfo (STV_m (mk_nfj STV_Judgement STV_final c ec))
  (STV_m (mk_nfj STV_Judgement STV_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p. destruct p as [[[[u1 a1] t1] h1] e1].
  destruct c. destruct p as  [[[[u2 a2] t2] h2] e2].
  (* non final judgements *)
  unfold STV_m. simpl.
  unfold STV_wfo.
  rewrite -> wfo_aux.
  right. right.
  unfold tv in Hr.
  destruct Hr as [u [nu [a [t [h [e [f [fs H]]]]]]]].
  destruct H as [Heq1 [Hin [Hrep Heq2]]].
  inversion Heq1. inversion Heq2. subst.
  split.
  reflexivity.
  split.
  unfold rep in Hrep.
  destruct Hrep as [l1 [l2 [Hrep1 Hrep2]]].
  rewrite -> Hrep1, Hrep2.
  rewrite -> app_length. rewrite -> app_length. rewrite -> app_length.
  intuition.
  unfold rep in Hrep.
  destruct Hrep as [l1 [l2 [Hrep1 Hrep2]]].
  rewrite -> Hrep1, Hrep2.
  apply sum_len_dec.
  unfold STV_final in ec. contradict ec.
  exists l. reflexivity.
  unfold STV_final in ep. contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_STV_el : forall p c : STV_Judgement,
el p c -> forall (ep : ~ STV_final p) (ec : ~ STV_final c),
STV_wfo (STV_m (mk_nfj STV_Judgement STV_final c ec))
  (STV_m (mk_nfj STV_Judgement STV_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p. destruct p as [[[[u1 a1] t1] h1] e1].
  destruct c. destruct p as  [[[[u2 a2] t2] h2] e2].
  (* non final judgements *)
  unfold STV_m. simpl.
  unfold STV_wfo.
  rewrite -> wfo_aux.
  left.
  unfold el in Hr.
  destruct Hr as [u [a [t [h [nh [e [ne [d H]]]]]]]].
  destruct d.
  destruct e.
  destruct H as [Heq1 [Hin [Hq [Hl [Hh [He Heq2]]]]]].
  inversion Heq1.
  inversion Heq2.
  unfold eqe in Hh.
  destruct Hh as [l1 [l2 [Hh1 Hh2]]].
  rewrite -> Hh1, Hh2.
  rewrite -> app_length. rewrite -> app_length. rewrite -> app_length.
  intuition.
  (* final jugements *)
  unfold STV_final in ec.
  contradict ec.
  exists l. reflexivity.
  unfold STV_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_STV_ey : forall p c : STV_Judgement,
ey p c -> forall (ep : ~ STV_final p) (ec : ~ STV_final c),
STV_wfo (STV_m (mk_nfj STV_Judgement STV_final c ec))
  (STV_m (mk_nfj STV_Judgement STV_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p. destruct p as [[[[u1 a1] t1] h1] e1].
  destruct c. destruct p as  [[[[u2 a2] t2] h2] e2].
  (* non final judgements *)
  unfold STV_m. simpl.
  unfold STV_wfo.
  rewrite -> wfo_aux.
  right. left.
  unfold ey in Hr.
  destruct Hr as [u [nu [a [t [h [e H]]]]]].
  destruct H as [Heq1 [Heqe Heq2]].
  inversion Heq1.
  inversion Heq2.
  split. reflexivity.
  unfold eqe in Heqe.
  destruct Heqe as [l1 [l2 [Heqe1 Heqe2]]].
  rewrite -> Heqe1, Heqe2.
  rewrite -> app_length. rewrite -> app_length. rewrite -> app_length.
  intuition.
  (* final jugements *)
  unfold STV_final in ec.
  contradict ec.
  exists l. reflexivity.
  unfold STV_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_STV_tl : forall p c : STV_Judgement,
tl p c -> forall (ep : ~ STV_final p) (ec : ~ STV_final c),
STV_wfo (STV_m (mk_nfj STV_Judgement STV_final c ec))
  (STV_m (mk_nfj STV_Judgement STV_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p. destruct p as [[[[u1 a1] t1] h1] e1].
  destruct c. destruct p as  [[[[u2 a2] t2] h2] e2].
  (* non final judgements *)
  unfold STV_m. simpl.
  unfold STV_wfo.
  rewrite -> wfo_aux.
  left.
  unfold tl in Hr.
  destruct Hr as [u [a [t [h [nh [e [d H]]]]]]].
  destruct H as [Heq1 [Hl [Hin [Ht [Heqe [Ha Heq2]]]]]].
  inversion Heq1.
  inversion Heq2.
  unfold eqe in Heqe.
  destruct Heqe as [l1 [l2 [Heqe1 Heqe2]]].
  rewrite -> Heqe1, Heqe2.
  rewrite -> app_length. rewrite -> app_length. rewrite -> app_length.
  intuition.
  (* final jugements *)
  unfold STV_final in ec.
  contradict ec.
  exists l. reflexivity.
  unfold STV_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_STV_hw : forall p c : STV_Judgement,
hw p c -> forall (ep : ~ STV_final p) (ec : ~ STV_final c),
STV_wfo (STV_m (mk_nfj STV_Judgement STV_final c ec))
  (STV_m (mk_nfj STV_Judgement STV_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p. destruct p as [[[[u1 a1] t1] h1] e1].
  destruct c. destruct p as  [[[[u2 a2] t2] h2] e2].
  unfold hw in Hr.
  destruct Hr as [w [u [a [t [h [e H]]]]]].
  destruct H as [Heq1 [Hl [Hw Heq2]]].
  inversion Heq2.
  unfold STV_final in ec.
  contradict ec.
  exists l. reflexivity.
  (* final jugements *)
  unfold STV_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_STV_ew : forall p c : STV_Judgement,
ew p c -> forall (ep : ~ STV_final p) (ec : ~ STV_final c),
STV_wfo (STV_m (mk_nfj STV_Judgement STV_final c ec))
  (STV_m (mk_nfj STV_Judgement STV_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p. destruct p as [[[[u1 a1] t1] h1] e1].
  destruct c. destruct p as  [[[[u2 a2] t2] h2] e2].
  unfold ew in Hr.
  destruct Hr as [w [u [a [t [h [e H]]]]]].
  destruct H as [Heq1 [Hl [Hw Heq2]]].
  inversion Heq2.
  unfold STV_final in ec.
  contradict ec.
  exists l. reflexivity.
  (* final jugements *)
  unfold STV_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

(* proof of dec property *)
Lemma dec_STV : dec STV_Judgement STV_final STV_WFO STV_wfo STV_m STV.
Proof.
  unfold dec.
  intros r Hin p c Hr ep ec.
  destruct Hin.
  rewrite <- H in Hr.
  apply (dec_STV_c1).
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_STV_el.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_STV_tv.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_STV_ey.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_STV_tl.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_STV_hw.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_STV_ew.
  assumption.
  destruct H.
Qed.

End STV.

Section candidates.
(* our candidates *)
Inductive cand := Alice | Bob | Charlie | Deliah.
Definition cand_all := [Alice; Bob; Charlie; Deliah].

(* everything below here is independent of the definition of cand *)
(* as long as cand is an inductive type with nullary constructors *)
(* only and all_cands mentions all of them *)

Lemma cand_pd: PD cand_all.
Proof.
  repeat apply PDc
    || split
    || (repeat apply PDe
        || unfold In
        || tauto
        || (intro H; discriminate H; clear H)
        || (intro H; elim H; clear H)).
Qed.

Lemma cand_finite: forall c, In c cand_all.
Proof.
  unfold cand_all; intro a; repeat induction a || (unfold In; tauto).
Qed.

Lemma  cand_eq_dec : forall c d : cand, {c = d} + {c <> d}.
Proof.
  intros a b;
  repeat induction a;
    repeat (induction b) || (right; discriminate) ||(left; trivial).
Defined.

End candidates.

Definition STV_termination :=
  termination (STV_Judgement cand qu s) (STV_final cand qu s) (final_dec cand qu s) STV_WFO
  STV_wfo STV_wfo_wf (STV_m cand qu s) (STV cand qu s) (dec_STV cand qu s)
  (app_STV cand cand_eq_dec qu s).

Extraction Language Haskell.
Extraction "/tmp/STV_generic.hs" STV_termination.


From iris.proofmode Require Export tactics.
From iris.program_logic Require Export weakestpre total_weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
Set Default Proof Using "Type".

Inductive tree :=
  | leaf : Z → tree
  | node : tree → tree → tree.

Fixpoint is_tree `{!heapG Σ} (v : val) (t : tree) : iProp Σ :=
  match t with
  | leaf n => ⌜v = InjLV #n⌝
  | node tl tr =>
     ∃ (ll lr : loc) (vl vr : val),
       ⌜v = InjRV (#ll,#lr)⌝ ∗ ll ↦ vl ∗ is_tree vl tl ∗ lr ↦ vr ∗ is_tree vr tr
  end%I.

Fixpoint sum (t : tree) : Z :=
  match t with
  | leaf n => n
  | node tl tr => sum tl + sum tr
  end.

Definition sum_loop : val :=
  rec: "sum_loop" "t" "l" :=
    match: "t" with
      InjL "n" => "l" <- "n" + !"l"
    | InjR "tt" => "sum_loop" !(Fst "tt") "l" ;; "sum_loop" !(Snd "tt") "l"
    end.

Definition sum' : val := λ: "t",
  let: "l" := ref #0 in
  sum_loop "t" "l";;
  !"l".

Lemma sum_loop_wp `{!heapG Σ} v t l (n : Z) :
  [[{ l ↦ #n ∗ is_tree v t }]]
    sum_loop v #l
  [[{ RET #(); l ↦ #(sum t + n) ∗ is_tree v t }]].
Proof.
  iIntros (Φ) "[Hl Ht] HΦ".
  iInduction t as [n'|tl ? tr] "IH" forall (v l n Φ); simpl; wp_rec; wp_let.
  - iDestruct "Ht" as "%"; subst.
    wp_load. wp_store.
    by iApply ("HΦ" with "[$Hl]").
  - iDestruct "Ht" as (ll lr vl vr ->) "(Hll & Htl & Hlr & Htr)".
    wp_load. wp_apply ("IH" with "Hl Htl"). iIntros "[Hl Htl]".
    wp_load. wp_apply ("IH1" with "Hl Htr"). iIntros "[Hl Htr]".
    iApply "HΦ". iSplitL "Hl".
    { by replace (sum tl + sum tr + n)%Z with (sum tr + (sum tl + n))%Z by lia. }
    iExists ll, lr, vl, vr. by iFrame.
Qed.

Lemma sum_wp `{!heapG Σ} v t :
  [[{ is_tree v t }]] sum' v [[{ RET #(sum t); is_tree v t }]].
Proof.
  iIntros (Φ) "Ht HΦ". rewrite /sum' /=.
  wp_lam. wp_alloc l as "Hl".
  wp_smart_apply (sum_loop_wp with "[$Hl $Ht]").
  rewrite Z.add_0_r.
  iIntros "[Hl Ht]". wp_load. by iApply "HΦ".
Qed.


Require Export NFA.

Section DFA.

Context {State Symbol : Type}.
Hypothesis State_eq_dec : forall (x1 x2:State), { x1 = x2 } + { x1 <> x2 }.
Hypothesis Symbol_eq_dec : forall (x1 x2:Symbol), { x1 = x2 } + { x1 <> x2 }.
Variable nfa : @NFA State Symbol.
Definition transitionf := transitionf State_eq_dec Symbol_eq_dec nfa.
Definition ext_transitionf := ext_transitionf State_eq_dec Symbol_eq_dec nfa.

Definition start_singleton :=
  (exists q, In q (start_states nfa)) /\
  forall q1 q2, In q1 (start_states nfa) -> In q2 (start_states nfa) -> q1 = q2.

Definition transitionf_det :=
  forall q a q1 q2,
  let s := transitionf [q] a in
  In q1 s -> In q2 s -> q1 = q2.

Definition is_dfa := start_singleton /\ transitionf_det.

(** Lemmas for Brzozowski proof: **)

(* The extended transitions are deterministic *)
Lemma ext_transitionf_det q w q1 q2 :
  transitionf_det ->
  let s := ext_transitionf [q] w in
  In q1 s -> In q2 s -> q1 = q2.
Proof.
  unfold ext_transitionf, transitionf_det.
  intros H H0 H1;
  generalize dependent q2;
  generalize dependent q1;
  generalize dependent q;
  induction w as [|a w IH];
  intros q q1 H0 q2 H1.
  destruct H0, H1; subst; try contradiction; intuition.
  simpl in H0, H1.
  apply ext_transitionf_singleton in H0, H1.
  destruct H0 as [q0 [H0 H2]]; destruct H1 as [q0' [H1 H3]].
  assert (q0' = q0).
  apply H with q a.
  1,2: intuition.
  subst.
  apply IH with q0; intuition.
Qed.

(* All start states are equal *)
Lemma ext_transitionf_start_singleton q1 w q2 :
  start_singleton -> In q1 (start_states nfa) ->
  In q2 (ext_transitionf (start_states nfa) w) ->
  In q2 (ext_transitionf [q1] w).
Proof.
  intros [_ H] H0 H1.
  induction (start_states nfa) as [|q l IH].
  contradiction.
  assert (q1 = q).
  apply H; intuition.
  destruct H0; subst. {
    replace (q1 :: l) with ([q1] ++ l) in H1.
    apply in_ext_transitionf_app in H1; destruct H1.
    1,3: intuition.
    apply IH.
    intros qA qB H3 H4.
    apply H.
    1-2,4: intuition.
    apply ext_transitionf_not_nil in H0.
    destruct H0 as [q' H0].
    assert (q1 = q').
    2: subst.
    apply H.
    1-3: intuition.
  }
  replace (q :: l) with ([q] ++ l) in H1.
  apply in_ext_transitionf_app in H1; destruct H1.
  1,3: intuition.
  apply IH.
  intros qA qB H3 H4.
  apply H.
  1-4: intuition.
Qed.

End DFA.


Require Import BinNat.
Require Import Bool.Bool.
Require Import Lia.

From Proyecto Require Export Defs_Patricia.
From Proyecto Require Export Defs_Misc.
From Proyecto Require Export Props_Bin.
From Proyecto Require Export Props_Misc.

(* Después de insertar en un árbol, es no vacío. *)
Lemma insert_non_empty: forall c k x t, insert c k x t <> empty.
Proof.
intros.
destruct t.
+ simpl.
  discriminate.
+ simpl.
  destruct (N.eqb n k).
  - discriminate.
  - unfold join.
    * destruct (zeroBit k (branchingBit k n)).
      ++ discriminate.
      ++ discriminate.
+ simpl.
  - destruct (matchPrefix k n n0).
    * destruct (zeroBit k n0).
      ++ discriminate.
      ++ discriminate.
    * unfold join.
      destruct (zeroBit k (branchingBit k n)).
      ++ discriminate.
      ++ discriminate.
Qed.

(* Las hojas son correctas. *)
Lemma correct_leaf: forall j y, correct (leaf j y).
Proof.
intros.
assert(insert fst j y empty = leaf j y).
+ simpl.
  trivial.
+ rewrite <- H.
  constructor.
  constructor.
Qed.

(* Si en un árbol que no contiene a k, inserto (k, x), entonces buscar k me
 * da x *)
Theorem lookup_after_insert: forall (c: nat -> nat -> nat) (k: N)
                                    (x: nat) (p: patriciaTree),
lookup k p = None -> lookup k (insert c k x p) = Some x.
Proof.
intros.
induction p.
+ simpl.
  assert ((k =? k)%N = true).
  - apply bin_eq.
  - rewrite H0.
    trivial.
+ simpl.
  destruct (N.eqb n k) eqn:equality.
  - simpl in H.
    rewrite equality in H.
    inversion H.
  - unfold join.
    destruct (zeroBit k (branchingBit k n)) eqn:zero.
    * simpl.
      rewrite obvious_matchP.
      simpl.
      rewrite zero.
      rewrite bin_eq.
      trivial.
    * simpl.
      rewrite obvious_matchP.
      simpl.
      rewrite zero.
      rewrite bin_eq.
      trivial.
+ simpl.
  destruct (matchPrefix k n n0) eqn:pre.
  - destruct (zeroBit k n0) eqn:zero.
    * simpl.
      rewrite pre.
      simpl.
      rewrite zero.
      apply IHp1.
      simpl in H.
      rewrite pre in H.
      simpl in H.
      rewrite zero in H.
      trivial.
    * simpl.
      rewrite pre.
      simpl.
      rewrite zero.
      apply IHp2.
      simpl in H.
      rewrite pre in H.
      simpl in H.
      rewrite zero in H.
      trivial.
  - unfold join.
    destruct (zeroBit k (branchingBit k n)) eqn:zero.
    * simpl.
      rewrite obvious_matchP.
      simpl.
      rewrite zero.
      rewrite bin_eq.
      trivial.
    * simpl.
      rewrite obvious_matchP.
      simpl.
      rewrite zero.
      rewrite bin_eq.
      trivial.
Qed.

(* Si en un árbol que contiene a k, inserto (k, x) bajo la función f,
 * entonces buscar k me da f(lo que había en k, x) *)
Theorem lookup_after_insert_function: forall (c: nat -> nat -> nat) (k: N)
                                      (x y: nat) (p: patriciaTree),
lookup k p = Some y -> lookup k (insert c k x p) = Some (c x y).
Proof.
intros.
induction p.
+ simpl in H.
  inversion H.
+ simpl.
  destruct (N.eqb n k) eqn:equal.
  * simpl.
    rewrite bin_eq.
    simpl in H.
    rewrite equal in H.
    inversion H.
    trivial.
  * unfold join.
    destruct (zeroBit k (branchingBit k n)) eqn:zero.
    - simpl in H.
      rewrite equal in H.
      inversion H.
    - simpl in H.
      rewrite equal in H.
      inversion H.
+ simpl in H.
  destruct (matchPrefix k n n0) eqn:prefix.
  * simpl.
    rewrite prefix.
    destruct (zeroBit k n0) eqn:zero.
    - simpl.
      rewrite prefix.
      simpl.
      rewrite zero.
      apply IHp1.
      simpl in H.
      trivial.
    - simpl.
      rewrite prefix.
      simpl.
      rewrite zero.
      apply IHp2.
      simpl in H.
      trivial.
  * simpl in H.
    inversion H.
Qed.

(* Después de insertar, el tamaño se incrementa en 1. *)
Theorem insert_size: forall t c x y, lookup x t = None -> sizeP (insert c x y t) = S (sizeP t).
Proof.
induction t.
+ intros.
  reflexivity.
+ intros.
  simpl.
  destruct (N.eqb n x) eqn:Equal.
  - simpl in H.
    rewrite Equal in H.
    inversion H.
  - unfold join.
    * destruct (zeroBit x (branchingBit x n)) eqn:Zero.
      ++ reflexivity.
      ++ reflexivity.
+ intros.
  simpl.
  destruct (matchPrefix x n n0) eqn:Prefix.
  - simpl in H.
    rewrite Prefix in H.
    simpl in H.
    destruct (zeroBit x n0) eqn:Zero.
    * simpl.
      rewrite IHt1.
      ++ reflexivity.
      ++ trivial.
    * simpl.
      rewrite IHt2.
      ++ lia.
      ++ trivial.
  - unfold join.
    destruct (zeroBit x (branchingBit x n)) eqn:Zero.
    * simpl.
      trivial.
    * simpl.
      lia.
Qed.

(* Correcto de un árbol implica hijos correctos. *)
Theorem correct_children: forall t, correct t -> correct (left t) /\ correct (right t).
Proof.
intros.
induction H.
+ split; constructor.
+ split.
  - destruct t eqn:T.
    * simpl.
      constructor.
    * simpl.
      destruct (N.eqb n k) eqn:Equal.
      ++ simpl; constructor.
      ++ unfold join.
         destruct (zeroBit k (branchingBit k n)) eqn:Zero.
         -- simpl.
            apply correct_leaf.
         -- simpl.
            apply correct_leaf.
    * simpl.
      destruct (matchPrefix k n n0) eqn:Prefix.
      ++ destruct (zeroBit k n0) eqn:Zero.
         -- simpl.
            destruct IHcorrect.
            simpl in H0.
            constructor.
            trivial.
         -- simpl.
            destruct IHcorrect.
            simpl in H0.
            trivial.
      ++ unfold join.
         destruct (zeroBit k (branchingBit k n)) eqn:Zero.
         -- simpl.
            apply correct_leaf.
         -- simpl.
            trivial.
  - destruct t eqn:T.
    * simpl.
      constructor.
    * simpl.
      destruct (N.eqb n k) eqn:Equal.
      ++ simpl; constructor.
      ++ unfold join.
         destruct (zeroBit k (branchingBit k n)) eqn:Zero.
         -- simpl.
            apply correct_leaf.
         -- simpl.
            apply correct_leaf.
    * simpl.
      destruct (matchPrefix k n n0) eqn:Prefix.
      ++ destruct (zeroBit k n0) eqn:Zero.
         -- simpl.
            destruct IHcorrect.
            simpl in H1.
            trivial.
         -- simpl.
            destruct IHcorrect.
            simpl in H1.
            constructor;trivial.
      ++ unfold join.
         destruct (zeroBit k (branchingBit k n)) eqn:Zero.
         -- simpl.
            trivial.
         -- simpl.
            apply correct_leaf.
Qed.

(* Si en un árbol que no contiene a k, inserto (k, x), entonces buscar k me
 * da x *)
Theorem lookup2_after_insert_none: forall (c: nat -> nat -> nat) (k k0: N)
                                    (x: nat) (p: patriciaTree),
lookup2 k p = None -> k <> k0 -> lookup2 k (insert c k0 x p) = None.
Proof.
induction p.
+ intros.
  simpl.
  destruct (N.eqb k0 k) eqn:Equal.
  - apply eqb_eq in Equal.
    rewrite Equal in H0; contradiction.
  - trivial.
+ intros.
  simpl.
  destruct (N.eqb n k0) eqn:Equal.
  - apply eqb_eq in Equal.
    simpl.
    destruct (N.eqb k0 k) eqn:Equal2; trivial.
    apply eqb_eq in Equal2.
    intuition.
  - unfold join.
    destruct (zeroBit k0 (branchingBit k0 n)) eqn:Zero.
    * simpl.
      destruct (zeroBit k (branchingBit k0 n)) eqn:Zero2.
      ++ destruct (N.eqb k0 k) eqn:Equal2; trivial.
         apply eqb_eq in Equal2.
         intuition.
      ++ destruct (N.eqb n k) eqn:Equal2; trivial.
         apply eqb_eq in Equal2.
         rewrite Equal2 in H.
         simpl in H.
         rewrite bin_eq in H.
         inversion H.
    * simpl.
      destruct (zeroBit k (branchingBit k0 n)) eqn:Zero2.
      ++ destruct (N.eqb n k) eqn:Equal2;trivial.
         apply eqb_eq in Equal2.
         rewrite Equal2 in H.
         simpl in H.
         rewrite bin_eq in H.
         inversion H.
      ++ destruct (N.eqb k0 k) eqn:Equal2; trivial.
         apply eqb_eq in Equal2.
         intuition.
+ intros.
  simpl.
  destruct (matchPrefix k0 n n0) eqn:Prefix.
  - destruct (zeroBit k0 n0) eqn:Zero.
    * simpl.
      destruct (zeroBit k n0) eqn:Zero2.
      ++ apply IHp1; trivial.
         simpl in H.
         rewrite Zero2 in H.
         trivial.
      ++ simpl in H.
         rewrite Zero2 in  H.
         trivial.
    * simpl.
      destruct (zeroBit k n0) eqn:Zero2.
      ++ simpl in H.
         rewrite Zero2 in H.
         trivial.
      ++ apply IHp2; trivial.
         simpl in H.
         rewrite Zero2 in H.
         trivial.
  - unfold join.
    destruct (zeroBit k0 (branchingBit k0 n)) eqn:Zero.
    * simpl.
      destruct (zeroBit k (branchingBit k0 n)) eqn:Zero2.
      ++ destruct (N.eqb k0 k) eqn:Equal; trivial.
         apply eqb_eq in Equal.
         intuition.
      ++ destruct (zeroBit k n0) eqn:Zero3.
         -- simpl in H.
            rewrite Zero3 in H.
            trivial.
         -- simpl in H; rewrite Zero3 in H; trivial.
    * simpl.
      destruct (zeroBit k (branchingBit k0 n)) eqn:Zero2.
      ++ destruct (zeroBit k n0) eqn:Zero3;simpl in H; rewrite Zero3 in H; trivial.
      ++ destruct (N.eqb k0 k) eqn:Equal; trivial.
         apply eqb_eq in Equal.
         intuition.
Qed.

(* lookup después de insert y lookup2 después de insert dan lo mismo en
   árboles correctos *)
Lemma lookup_insert_eq: forall p k c x y, lookup k p = lookup2 k p -> lookup k (insert c x y p) = lookup2 k (insert c x y p).
Proof.
induction p.
+ intros.
  reflexivity.
+ intros.
  simpl.
  destruct (N.eqb n x) eqn:Equal.
  - reflexivity.
  - unfold join.
    * destruct (zeroBit x (branchingBit x n)) eqn:Zero.
      ++ simpl.
         destruct (matchPrefix k (mask x (branchingBit x n)) (branchingBit x n)) eqn:Prefix.
         -- reflexivity.
         -- simpl.
            destruct (zeroBit k (branchingBit x n)) eqn:Zero2.
            ** destruct (N.eqb x k) eqn:Equal2.
               +++ apply eqb_eq in Equal2.
                   rewrite Equal2 in Prefix; rewrite obvious_matchP in Prefix; inversion Prefix.
               +++ trivial.
            ** destruct (N.eqb n k) eqn:Equal2.
               +++ apply eqb_eq in Equal2; rewrite Equal2 in Prefix; rewrite obvious_matchP2 in Prefix; inversion Prefix.
               +++ trivial.
      ++ simpl.
         destruct (matchPrefix k (mask x (branchingBit x n)) (branchingBit x n)) eqn:Prefix.
         -- reflexivity.
         -- simpl; destruct (zeroBit k (branchingBit x n)) eqn:Zero2.
            ** destruct (N.eqb n k) eqn:Equal2; trivial.
               apply eqb_eq in Equal2; rewrite Equal2 in Prefix; rewrite obvious_matchP2 in Prefix; inversion Prefix.
            ** destruct (N.eqb x k) eqn:Equal2; trivial.
               apply eqb_eq in Equal2; rewrite Equal2 in Prefix; rewrite obvious_matchP in Prefix; inversion Prefix.
+ intros.
  simpl.
  destruct (matchPrefix x n n0) eqn:Prefix; trivial.
  - destruct (zeroBit x n0) eqn:Zero; trivial.
    * simpl.
      destruct (matchPrefix k n n0) eqn:Prefix2; simpl; trivial.
      ++ destruct (zeroBit k n0) eqn:Zero2.
         -- simpl in H.
            rewrite Prefix2 in H; simpl in H.
            rewrite Zero2 in H; simpl in H.
            apply IHp1; trivial.
         -- simpl in H.
            rewrite Prefix2 in H; simpl in H.
            rewrite Zero2 in H; simpl in H.
            trivial.
      ++ destruct (zeroBit k n0) eqn:Zero2.
         -- simpl in H.
            rewrite Prefix2 in H; simpl in H.
            rewrite Zero2 in H; simpl in H.
            destruct (eq_dec k x).
            ** rewrite e in Prefix2; rewrite Prefix2 in Prefix; inversion Prefix.
            ** assert (lookup2 k (insert c x y p1) = None).
               +++ apply lookup2_after_insert_none.
                   --- intuition.
                   --- trivial.
               +++ intuition.
         -- simpl in H.
            rewrite Prefix2 in H; simpl in H.
            rewrite Zero2 in H; simpl in H.
            trivial.
    * simpl.
      destruct (matchPrefix k n n0) eqn:Prefix2.
      ++ simpl.
         destruct (zeroBit k n0) eqn:Zero2.
         -- simpl in H.
            rewrite Zero2 in H; simpl in H.
            rewrite Prefix2 in H; simpl in H.
            trivial.
         -- apply IHp2.
            simpl in H.
            rewrite Zero2 in H; simpl in H.
            rewrite Prefix2 in H; simpl in H.
            trivial.
      ++ simpl.
         destruct (zeroBit k n0) eqn:Zero2.
         -- simpl in H.
            rewrite Zero2 in H; simpl in H.
            rewrite Prefix2 in H; simpl in H.
            trivial.
         -- assert (lookup2 k (insert c x y p2) = None).
            ** apply lookup2_after_insert_none.
               +++ simpl in H.
                   rewrite Zero2 in H; simpl in H.
                   rewrite Prefix2 in H; simpl in H.
                   rewrite H; trivial.
               +++ intro.
                   rewrite H0 in Prefix2; rewrite Prefix in Prefix2; inversion Prefix2.
            ** rewrite H0; trivial.
  - unfold join.
    destruct (zeroBit x (branchingBit x n)) eqn:Zero.
    * simpl.
      ++ destruct (matchPrefix k (mask x (branchingBit x n)) (branchingBit x n)) eqn:Prefix2.
         -- simpl.
            destruct (zeroBit k (branchingBit x n)) eqn:Zero2; trivial.
         -- simpl.
            destruct (zeroBit k (branchingBit x n)) eqn:Zero2.
            ** destruct (N.eqb x k) eqn:Equal; trivial.
               apply eqb_eq in Equal; rewrite Equal in Prefix2; rewrite obvious_matchP in Prefix2; inversion Prefix2.
            ** destruct (zeroBit k n0) eqn:Zero3.
               +++ simpl in H.
                   destruct (eq_dec k x).
                   --- rewrite <- e in Zero; rewrite <- e in Zero2; rewrite Zero in Zero2; inversion Zero2.
                   --- destruct (matchPrefix k n n0) eqn:Prefix3.
                       *** simpl in H.
                           assert (matchPrefix x n n0 = true).
                           ++++ apply (very_specific k x n n0).
                                split; trivial.
                           ++++ rewrite Prefix in H0; inversion H0.
                       *** simpl in H.
                           rewrite Zero3 in H.
                           trivial.
               +++ simpl in H.
                   destruct (matchPrefix k n n0) eqn:Prefix3.
                   --- simpl in H.
                       assert (matchPrefix x n n0 = true).
                       *** apply (very_specific k x n n0).
                           split; trivial.
                       *** rewrite Prefix in H0; inversion H0.
                   --- simpl in H.
                       rewrite Zero3 in H.
                       trivial.
    * simpl.
      destruct (matchPrefix k (mask x (branchingBit x n)) (branchingBit x n)) eqn:Prefix2.
      ++ simpl.
         destruct (zeroBit k (branchingBit x n)) eqn:Zero2.
         -- destruct (matchPrefix k n n0) eqn:Prefix3.
            ** simpl.
               simpl in H.
               rewrite Prefix3 in H.
               simpl in H.
               trivial.
            ** simpl.
               simpl in H.
               rewrite Prefix3 in H.
               simpl in H.
               trivial.
         -- trivial.
      ++ simpl.
         simpl in H.
         destruct (matchPrefix k n n0) eqn:Prefix3.
         -- simpl in H.
            destruct (zeroBit k (branchingBit x n)) eqn:Zero2.
            ** assert (matchPrefix x n n0 = true).
               +++ apply (very_specific k x n n0).
                   split; trivial.
               +++ rewrite Prefix in H0; inversion H0.
            ** destruct (N.eqb x k) eqn: Equal;trivial.
               apply eqb_eq in Equal; rewrite Equal in Prefix2; rewrite obvious_matchP in Prefix2; inversion Prefix2.
         -- simpl in H.
            destruct (zeroBit k (branchingBit x n)) eqn:Zero2; trivial.
            destruct (N.eqb x k) eqn:Equal; trivial.
            apply eqb_eq in Equal; rewrite Equal in Prefix2; rewrite obvious_matchP in Prefix2; inversion Prefix2.
Qed.

(* lookup y lookup2 son equivalentes en un árbol correcto. *)
Theorem lookup_eq: forall t k, correct t -> lookup k t = lookup2 k t.
Proof.
intros.
destruct H.
+ reflexivity.
+ apply lookup_insert_eq.
  trivial.
Qed.


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

Require Import Arith Omega.

Require Import bar.

Set Implicit Arguments.

Tactic Notation "eq" "goal" "with" hyp(H) :=
  match goal with |- ?b => match type of H with ?t => replace b with t; auto end end.

Theorem nat_rev_ind (P : nat -> Prop) (HP : forall n, P (S n) -> P n) x y : x <= y -> P y -> P x.
Proof. induction 1; auto. Qed.

Reserved Notation "f ↑ n" (at level 1, left associativity).

Fixpoint iter X (f : X -> X) n x :=
  match n with
    | 0 => x
    | S n => f (f↑n x)
  end
where "f ↑ n" := (@iter _ f n).

Section th_min.

  Variables (X : Type) (eqdec : forall x y : X, { x = y } + { x <> y }).

  Infix "=?" := eqdec (at level 70).

  Variable (f : X -> X) (x0 : X)
           (Hx0 : exists τ, 0 < τ /\ f↑τ x0 = f↑(2*τ) x0).

  Theorem th_min : { τ | 0 < τ /\ f↑τ x0 = f↑(2*τ) x0 }.
  Proof.
    apply Constructive_Epsilon; trivial.
    intros n.
    destruct (le_lt_dec n 0) as [ | H ]; [right; omega | ].
    destruct (eqdec (f↑n x0) (f↑(2*n) x0)); tauto.
  Qed.

End th_min.

Extraction Inline bar_rect.
Extraction Inline Constructive_Epsilon.
Recursive Extraction th_min.


Require Import Basics Types Pointed.Core Pointed.pEquiv.

(** * Pointed sections of pointed maps *)

Local Open Scope pointed_scope.

(* The type of pointed sections of a pointed map. *)
Definition pSect {A B : pType} (f : A ->* B)
  := { s : B ->* A & f o* s ==* pmap_idmap }.

Definition issig_psect { A B : pType } (f : A ->* B)
  : { s : B -> A & { p : s pt = pt
                        & { H : f o s == idmap
                                & H pt = ap f p @ (point_eq f) } } }
  <~> pSect f.
Proof.
  transitivity
    {s : B -> A & {p : s pt = pt
                      & {H : f o s == idmap
                             & H pt = ap f p @ (point_eq f) @ 1 }}}.
  2: make_equiv.
  do 3 (nrapply equiv_functor_sigma_id; intro).
  rapply equiv_concat_r.
  exact (concat_p1 _)^.
Defined.

(** Any pointed equivalence over [A] induces an equivalence between pointed sections. *)
Definition equiv_pequiv_pslice_psect `{Funext} {A B C : pType}
  (f : B ->* A) (g : C ->* A) (t : B <~>* C) (h : f ==* g o* t)
  : pSect f <~> pSect g.
Proof.
  srapply equiv_functor_sigma'.
  1: exact (equiv_pequiv_postcompose t).
  intro s; cbn.
  apply equiv_phomotopy_concat_l.
  refine ((pmap_compose_assoc _ _ _)^* @* _).
  apply pmap_prewhisker.
  exact h^*.
Defined.

(** Pointed sections of [psnd : A * B ->* B] correspond to pointed maps [B ->* A]. *)
Definition equiv_psect_psnd `{Funext} {A B : pType}
  : pSect (@psnd A B) <~> (B ->* A).
Proof.
  unfold pSect.
  transitivity {s : (B ->* A) * (B ->* B) & snd s ==* pmap_idmap}.
  { snrefine (equiv_functor_sigma'
                (equiv_pprod_coind (pfam_const A) (pfam_const B))^-1%equiv _).
    cbn. intro s.
    apply equiv_phomotopy_concat_l.
    srapply Build_pHomotopy.
    1: reflexivity.
    cbn.
    apply moveL_pV.
    exact (concat_1p _ @ concat_p1 _). }
  snrefine (_ oE equiv_functor_sigma_id (fun s => equiv_path_pforall _ _)).
  snrefine (_ oE (equiv_functor_sigma_pb (equiv_sigma_prod0 _ _))^-1%equiv); cbn.
  refine (_ oE (equiv_sigma_assoc _ _)^-1%equiv).
  rapply equiv_sigma_contr.
Defined.


From mathcomp Require Import all_ssreflect.
From rlzrs Require Import all_rlzrs.
From metric Require Import reals.
Require Import all_cs_base classical_mach.
Require Import Reals Psatz FunctionalExtensionality ClassicalChoice.
From Interval Require Import Interval_specific_ops Interval_bigint_carrier.
From Interval Require Import Interval_interval_float_full Interval_interval.
From Interval Require Import Interval_xreal.
Import BigN BigZ.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Local Open Scope Z_scope.
Import QArith.
Local Open Scope R_scope.

Module SFBI2 := SpecificFloat BigIntRadix2.
Module I := FloatIntervalFull SFBI2.

Notation D:= SFBI2.type.
Notation mant := BigIntRadix2.smantissa_type.
Notation xpnt := BigIntRadix2.exponent_type.
Notation ID := (Interval_interval_float.f_interval SFBI2.type).
Notation "x '\contained_in' I" := (Interval_interval.contains (I.convert I) (Xreal x)) (at level 2).
Coercion I.convert: ID >-> Interval_interval.interval.
Notation D2R := I.T.toR.
Coercion I.T.toR: D >-> R.
Notation lower := I.lower.
Notation upper := I.upper.
Notation diam I := (I.upper I - I.lower I).
Notation bounded := I.bounded.
Notation I0 := (I.fromZ 0).

Lemma add_correct_R prec x y I J:
	x \contained_in I -> y \contained_in J -> (x + y) \contained_in (I.add prec I J).
Proof.
intros.
replace (Xreal (x + y)) with (Xadd (Xreal x) (Xreal y)) by trivial.
by apply I.add_correct.
Qed.

Lemma mul_correct_R prec x y I J:
	x \contained_in I -> y \contained_in J -> (x * y) \contained_in (I.mul prec I J).
Proof.
intros.
replace (Xreal (x * y)) with (Xmul (Xreal x) (Xreal y)) by trivial.
by apply I.mul_correct.
Qed.

Definition rep_R : (nat -> ID) ->> R:= make_mf (
  fun I x => (forall n,  x \contained_in (I n))
  /\
  forall n, exists N, forall k, (N <= k)%nat -> bounded (I k)
                                                /\
                                                diam (I k) <= /2 ^ n).

Lemma D2R_SFBI2toX m e: SFBI2.toX (Float m e) = Xreal (D2R (Float m e)).
Proof.
rewrite /D2R/proj_val/=/SFBI2.toX/=/Interval_definitions.FtoX/=.
by case: BigIntRadix2.mantissa_sign (Float m e) => //.
Qed.

Lemma D2R_Float (m e: bigZ):
  D2R (Float m e) = IZR [m]%bigZ * powerRZ 2 [e]%bigZ.
Proof.
rewrite /D2R /SFBI2.toX /SFBI2.toF/=.
case: (BigIntRadix2.mantissa_sign m) (BigIntRadix2.mantissa_sign_correct m);
  rewrite /BigIntRadix2.MtoZ /=.
	by move => ->; lra.
move => s p' [-> [p]].
rewrite /BigIntRadix2.EtoZ /BigIntRadix2.MtoP => -> {p'}.
move: [e]%bigZ => {e} [ | e | e ] /=;
  rewrite ?Z.pow_pos_fold ?mult_IZR ?pow_IZR ?positive_nat_Z;
  case: s => //;
  lra.
Qed.

Lemma powerRZ2_neg_pos n: powerRZ 2 (-Z.of_nat n) = /2^n.
Proof.
by rewrite powerRZ_neg; try lra; rewrite Interval_missing.pow_powerRZ powerRZ_inv.
Qed.

Lemma rep_R_sur: rep_R \is_cototal.
Proof.
move => x.
exists (fun n => I.bnd
	(Float (BigZ.BigZ.of_Z (Int_part (x * (2 ^ n)))) (BigZ.BigZ.of_Z (-Z.of_nat n)))
	(Float (BigZ.BigZ.of_Z (up (x * (2 ^ n)))) (BigZ.BigZ.of_Z (-Z.of_nat n)))).
split => n/=.
	have bi:= base_Int_part (x * 2^n); have lt:= pow_lt 2 n; have arc:= archimed (x * 2 ^ n).
	rewrite !D2R_SFBI2toX;	split; rewrite D2R_Float !BigZ.spec_of_Z powerRZ2_neg_pos.
		by apply (Rmult_le_reg_r (2 ^ n)); try lra; rewrite Rmult_assoc Rinv_l; lra.
	by apply (Rmult_le_reg_r (2 ^ n)); try lra; rewrite Rmult_assoc Rinv_l; lra.
exists n.+1 => k ineq; split => //.
have bi:= base_Int_part (x * 2^k); have ltn1:= pow_lt 2 n.+1; have arc:= archimed (x * 2 ^ k).
have ltk:= pow_lt 2 k; have ltn2:= pow_lt 2 n; have eq: 2 ^ k * /2 ^k = 1 by rewrite Rinv_r; lra.
have /=exp: /2 ^ k <= /2 ^ n.+1.
	apply Rinv_le_contravar; try lra.
	by apply Rle_pow; try lra; apply /leP.
rewrite !D2R_Float !BigZ.spec_of_Z powerRZ2_neg_pos.
rewrite -Raux.Rmult_minus_distr_r.
rewrite -[/2 ^ n]Rmult_1_l -(Rinv_r 2); try lra.
rewrite Rmult_assoc -Rinv_mult_distr; try lra.
apply Rmult_le_compat; try lra.
by apply /Rlt_le/Rinv_0_lt_compat; lra.
Qed.

Lemma Float_to_R m e:
	D2R (Float (BigZ.of_Z m) (BigZ.of_Z e)) = IZR m * powerRZ 2 e.
Proof. by rewrite D2R_Float !BigZ.spec_of_Z. Qed.

Lemma nFnan eps: 0 < D2R eps -> ~ eps = Fnan.
Proof. by case: eps; first by rewrite /D2R/=; lra. Qed.

Lemma rep_R_sing: rep_R \is_singlevalued.
Proof.
move => In x x' [xeIn convIn] [x'eIn _].
apply cond_eq => e eg0.
have [n [_ ineq]]:= accf_tpmn eg0.
have [N prop]:= convIn n.
have ineq': (N <= N)%nat by trivial.
have [Ibnd dI]:= (prop N ineq').
move: xeIn (xeIn N) => _ xeIn.
move: x'eIn (x'eIn N) => _ x'eIn.
apply/ Rle_lt_trans; last by apply ineq.
case: (In N) Ibnd dI xeIn x'eIn => // l u/=.
case: u; first by case: l.
by case: l => // um ue lm le; rewrite !D2R_SFBI2toX; split_Rabs; lra.
Qed.

Lemma ID_count: ID \is_countable.
Proof.
Admitted.

Definition Iall:= @Interval_interval_float.Ibnd D Fnan Fnan.

Definition IR:= make_cs 0%nat Iall nat_count ID_count rep_R_sur rep_R_sing.

Definition nat2p n := SFBI2.PtoP (Pos.of_nat n).

Lemma SFBI2_add_correct: forall (mode: Interval_definitions.rounding_mode) (p: xpnt) (e e':xpnt) (m m':mant),
    D2R (SFBI2.add mode p (Float e m) (Float e' m')) = Interval_definitions.round SFBI2.radix mode (SFBI2.prec p) (D2R (Float e m) + (D2R (Float e' m'))).
Proof.
move => mode p e e' m m'.
have := SFBI2.add_correct mode p (Float e m) (Float e' m').
rewrite !D2R_SFBI2toX.
rewrite /Xadd/Interval_definitions.Xround/Xbind/SFBI2.toX.
rewrite /Interval_definitions.FtoX.
by case E: (SFBI2.toF (SFBI2.add mode p (Float e m) (Float e' m'))) => //; move =>  [<-]; rewrite /D2R/proj_val/SFBI2.toX/Interval_definitions.FtoX E.
Qed.

Lemma add_error I J n m p:
  bounded I -> diam I <= /2^n -> bounded J -> diam J <= /2^m ->
  bounded (I.add (nat2p p) I J)
  /\
  diam (I.add (nat2p p) I J) <= /2 ^ n + /2 ^ m + /2 ^ p.
Proof.
case: I => //; case => //lIe lIm; case => //uIe uIm _ ineq; rewrite /= in ineq.
case: J => //; case => //lJe lJm; case => //uJe uJm _ ineq'; rewrite /= in ineq'.
split; first admit.
rewrite /upper /lower !SFBI2_add_correct /=.
Admitted.

Definition Rplus_rlzrf (phi: names (IR \*_cs IR)) (n: queries IR):= I.add (nat2p n) (lprj phi n) (rprj phi n).

Definition Rplus_rlzr: questions (IR \*_cs IR) ->> questions IR := F2MF Rplus_rlzrf.

Lemma Rplus_rlzr_spec : Rplus_rlzr \realizes (F2MF (fun xy => Rplus xy.1 xy.2)).
Proof.
rewrite F2MF_rlzr_F2MF => phi [x y] [/=[xephin convx] [yephin convy]].
split => n; first by apply/add_correct_R; [apply xephin | apply yephin].
have [N Nprp]:= convx n.+2.
have [M Mprp]:= convy n.+2.
exists (maxn n.+1 (maxn M N)) => k ineq.
have [ | bndl dml]:= Nprp k.
	apply/leq_trans; first exact: (leq_maxr M N).
	by apply/leq_trans; first exact: (leq_maxr n.+1 (maxn M N)).
have [ | bndr dmr]:= Mprp k.
	apply/leq_trans; first exact: (leq_maxl M N).
	by apply/leq_trans; first exact: (leq_maxr n.+1 (maxn M N)).
rewrite /Rplus_rlzr/Rplus_rlzrf; split.
admit.
have npg0: 0 < 2 ^ n.+1.
	admit.
have /=exp: /2 ^ k <= /2 * /2 ^ n.
	admit.
apply /Rle_trans; first by apply (@add_error (lprj phi k) (rprj phi k) n.+2 n.+2 k).
have ng0: 0 < 2^n by apply pow_lt; lra.
by rewrite /= !Rinv_mult_distr; try lra.
Admitted.


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

Require Import Omega.

Require Import utils recalg ra_rel ra_bs ra_ca.
Require Import recursor minimizer.

Set Implicit Arguments.

Section soundness_and_completeness.

  (* By induction on the ra_ca predicate *)

  Lemma ra_ca_inc_bs k (f : recalg k) v x : (exists n, [f;v] -[n>> x) -> [f;v] ~~> x.
  Proof.
    intros (n & H); revert H.
    induction 1 as [ n v | v | v
                   | k v p
                   | k i f gj v n w q x H1 IH1 H2 IH2
                   | k f g v n x H1 IH2
                   | k f g v n p x q y H1 IH1 H2 IH2
                   | k f v p n w q H1 IH1 H2 IH2 ]; try (constructor; auto; fail).
    apply in_ra_bs_comp with w; auto.
    apply in_ra_bs_rec_S with x; auto.
    apply in_ra_bs_min with w; auto.
  Qed.

  (* By induction on the ra_bs predicate *)

  Lemma ra_bs_inc_rel k (f : recalg k) v x : [f;v] ~~> x -> [|f|] v x.
  Proof.
    induction 1 as [ n v | v | v
                   | k v p
                   | k i f gj v w x H1 IH1 H2 IH2
                   | k f g v n x H1 IH2
                   | k f g v n x y H1 IH1 H2 IH2
                   | k f v n w H1 IH1 H2 IH2 ]; try reflexivity.
    exists w; split; auto; intros; rewrite vec_pos_set; auto.
    red; unfold s_rec; simpl; auto.
    rewrite ra_rel_fix_rec in IH1 |- *; unfold s_rec in IH1 |- *.
    simpl in IH1 |- *; exists x; auto.
    rewrite ra_rel_fix_min; unfold s_min; split; auto.
    intros y Hy.
    exists (vec_get w _ Hy).
    generalize (IH1 (nat2pos Hy)).
    rewrite pos2nat_nat2pos.
    eqgoal; do 2 f_equal.
    apply vec_get_pos_eq.
    rewrite pos2nat_nat2pos; auto.
  Qed.

  (* By induction on f *)

  Lemma ra_rel_inc_ca k (f : recalg k) v x : [|f|] v x -> exists n, [f;v] -[n>> x.
  Proof.
    revert v x; induction f as [ k n | | | k p | k i f gj Hf Hgj
                               | k f g Hf Hg
                               | ]; intros v x.
    rewrite ra_rel_fix_cst; unfold s_cst; intros []; exists 1; constructor.
    rewrite ra_rel_fix_zero; unfold s_zero; intro; subst; exists 1; constructor.
    rewrite ra_rel_fix_succ; unfold s_succ; intro; subst; exists 1; constructor.
    rewrite ra_rel_fix_proj; unfold s_proj; intros []; exists 1; constructor.

    rewrite ra_rel_fix_comp; unfold s_comp; intros (w & H1 & H2).
    apply Hf in H1; destruct H1 as (n & H1).
    assert (forall p, exists n, [vec_pos gj p;v] -[n>> vec_pos w p) as H3.
      intros p; specialize (H2 p); rewrite vec_pos_map in H2; auto.
    apply vec_reif in H3.
    destruct H3 as (m & Hm).
    exists (1+n+vec_sum m).
    apply in_ra_ca_comp with (2 := H1); auto.

    rewrite ra_rel_fix_rec; unfold s_rec.
    rewrite (vec_head_tail v); simpl; generalize (vec_head v) (vec_tail v).
    clear v; intros i v.
    revert x; induction i as [ | i IHi ]; intros x; simpl.
    intros H; apply Hf in H; destruct H as (n & Hn); exists (S n); constructor; auto.
    intros (y & H1 & H2).
    apply IHi in H1; destruct H1 as (n & Hn).
    apply Hg in H2; destruct H2 as (m & Hm).
    exists (1+n+m); apply in_ra_ca_rec_S with (1 := Hn); auto.

    rewrite ra_rel_fix_min; unfold s_min; intros (H1 & H2).
    assert (forall (p : pos x), exists r, [|f|] (pos2nat p##v) (S r)) as H3.
      intros p; apply (H2 _ (pos2nat_prop p)).
    apply vec_reif in H3.
    destruct H3 as (w & Hw).
    assert (forall p, exists n, [f;pos2nat p##v] -[n>> S (vec_pos w p)) as H3.
      intros p; apply IHf, Hw.
    apply vec_reif in H3.
    destruct H3 as (m & Hm).
    apply IHf in H1.
    destruct H1 as (n & Hn).
    exists (1+n+vec_sum m).
    apply in_ra_ca_min with (1 := Hm); auto.
  Qed.

  (** Hence, there is a correspondance between the relational semantics
      and the bigstep semantics of recalg.
   **)

  Hint Resolve ra_ca_inc_bs ra_bs_inc_rel ra_rel_inc_ca.

  Theorem ra_bs_correct k (f : recalg k) v x : [|f|] v x <-> [f;v] ~~> x.
  Proof. split; auto. Qed.

  Theorem ra_ca_correct k (f : recalg k) v x : [|f|] v x <-> exists n, [f;v] -[n>> x.
  Proof. split; auto. Qed.

End soundness_and_completeness.


Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Require Import path choice fintype tuple finset ssralg poly polydiv.

(* Standard stuff to make Coq behave the way SSReflect wants *)
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensives.

(* Import necessary theory about rings and polynomial division *)
Import GRing.Theory Pdiv.Ring Pdiv.CommonRing Pdiv.RingMonic.

(* Open the correct scope so that 0, 1, + and * are interpreted correctly *)
Open Scope ring_scope.

(* Open a section *)
Section karatsuba.

(* Let R be a commutative ring, i.e. a structure where we have 0, 1, + and *
   that behave the way we expect and where multiplication is commutative *)
Variable R : comRingType.

(* Make p and q always have type polynomial over R so that we don't have to
   write it everywhere *)
Implicit Types p q : {poly R}.

(* Splitting of polynomials defined using polynomial division.
   rdivp is division and rmodp is modulus. *)
Definition split_poly n p := (rdivp p 'X^n, rmodp p 'X^n).

(* Main property of split_poly *)
Lemma split_polyP n p : p = (split_poly n p).1 * 'X^n + (split_poly n p).2.
Proof.
  by rewrite /split_poly -rdivp_eq // monicE lead_coefXn.
Qed.

Lemma div_mod_poly n p : p = rdivp p 'X^n * 'X^n + rmodp p 'X^n.
Proof.
  by apply rdivp_eq; rewrite monicE lead_coefXn.
Qed.

(* Recursive part of karatsuba multiplication. Parametrize by a natural number
   to make Coq realize that the code always terminate (this means that induction
   should be done on n in the correctness proof). *)
Fixpoint karatsuba_rec (n : nat) p q := match n with
  | 0%N   => p * q
  | n'.+1 =>
      let sp := size p in let sq := size q in
      if (sp <= 2) || (sq <= 2) then p * q else
        let m       := minn sp./2 sq./2 in
        let (p1,p2) := split_poly m p in
        let (q1,q2) := split_poly m q in
        let p1q1    := karatsuba_rec n' p1 q1 in
        let p2q2    := karatsuba_rec n' p2 q2 in
        let p12     := p1 + p2 in
        let q12     := q1 + q2 in
        let p12q12  := karatsuba_rec n' p12 q12 in
        p1q1 * 'X^(2 * m) + (p12q12 - p1q1 - p2q2) * 'X^m + p2q2
  end.

(* The final karatsuba function calls the recursive part with a "large enough
   number", i.e. the maximum of the degrees of the polynomials *)
Definition karatsuba p q := karatsuba_rec (maxn (size p) (size q)) p q.

Lemma karatsuba_split : forall p q,
  rdivp (R:=R) p 'X^(minn (size p)./2 (size q)./2) *
  rdivp (R:=R) q 'X^(minn (size p)./2 (size q)./2) *
  'X^(2 * minn (size p)./2 (size q)./2) +
  ((rdivp (R:=R) p 'X^(minn (size p)./2 (size q)./2) +
    rmodp (R:=R) p 'X^(minn (size p)./2 (size q)./2)) *
  (rdivp (R:=R) q 'X^(minn (size p)./2 (size q)./2) +
    rmodp (R:=R) q 'X^(minn (size p)./2 (size q)./2)) -
  rdivp (R:=R) p 'X^(minn (size p)./2 (size q)./2) *
  rdivp (R:=R) q 'X^(minn (size p)./2 (size q)./2) -
  rmodp (R:=R) p 'X^(minn (size p)./2 (size q)./2) *
  rmodp (R:=R) q 'X^(minn (size p)./2 (size q)./2)) *
  'X^(minn (size p)./2 (size q)./2) +
  rmodp (R:=R) p 'X^(minn (size p)./2 (size q)./2) *
  rmodp (R:=R) q 'X^(minn (size p)./2 (size q)./2) = p * q.
Proof.
  move=> p q.
  set d := minn (size p)./2 (size q)./2.

  set p1 := rdivp (R:=R) p 'X^d.
  set p2 := rmodp (R:=R) p 'X^d.
  set q1 := rdivp (R:=R) q 'X^d.
  set q2 := rmodp (R:=R) q 'X^d.

  have -> : ((p1 + p2) * (q1 + q2) = p1 * q1 + p1 * q2 + (p2 * q1 + p2 * q2))
    by rewrite mulrDl ?mulrDr.

  rewrite -?addrA.

  have -> : (p2 * q2 + (- (p1 * q1) - p2 * q2) = - (p1 * q1))
    by rewrite addrC -?addrA addNr addr0.

  have -> : (p1 * q1 + (p1 * q2 + (p2 * q1 - p1 * q1)) = p1 * q2 + p2 * q1)
    by rewrite addrC -?addrA addNr addr0 addrC.

  have -> : (p1 * q1 * 'X^(2 * d) = p1 * q1 * 'X^d * 'X^d)
    by rewrite mul2n -addnn exprD mulrA.

  rewrite ?addrA -mulrDl ?addrA.

  have extractp: (forall (a b c : {poly R}), a * b * 'X^d + a * c = a * (b * 'X^d + c)).
    by move=> a b c; rewrite -mulrA -mulrDr.
  rewrite extractp.

  rewrite -div_mod_poly.

  rewrite mulrDl -addrA extractp -div_mod_poly.
  by rewrite -mulrA (mulrC q 'X^d) mulrA -mulrDl -div_mod_poly.
Qed.

(* Correctness of the recursive part *)
Lemma karatsuba_recP : forall n p q, karatsuba_rec n p q = p * q.
Proof.
(* Some hints:

- The proof should be by induction on n.
- To handle the "if-then-else" do "case: ifP".
- It might be very useful to use the "set" tactic in order to make the goal
  more readable (i.e. to hide all rdivp and rmodp).
- As usual Search and looking in the files (ssralg.v and poly.v) is the way to
  find all the necessary lemmas.
*)
  by elim=> [ // | n IH p q ]; rewrite //= ?IH karatsuba_split; case: ifP.
Qed.

(* Correctness of karatsuba *)
Lemma karatsubaP p q : karatsuba p q = p * q.
Proof.
(* This proof should be very very easy now that you have proved the recursive
   part correct *)
  exact: karatsuba_recP.
Qed.

End karatsuba.


(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 9 *)

Require Import Frap.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu)
 * Ben Sherman (sherman@csail.mit.edu)
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

Set Implicit Arguments.

(** Data Abstraction via Contextual Equivalence *)

(* Here's a typical student reaction to the content on type systems from a
 * course like this one:
 *   "Yeah, it's good to prove that programs don't crash, but it's so much more
 *   exciting to prove that programs actually return correct answers, and we've
 *   seen plenty of techniques for that already (and will see more in the rest
 *   of the course).  Can we get this type-system stuff over with so we can move
 *   on to the _important_ stuff?"
 *
 * However, it turns out that type systems are very handy for formalizing a very
 * thorough kind of correctness condition for code libraries!  In particular,
 * let's return to _abstract data types_, which we first studied in Pset 4,
 * where we define a formal _interface_ for a data structure and prove that some
 * _implementation_ satisfies the interface.  Recall that Pset 4 asked you to
 * prove a selection of algebraic laws for some implementation.  But how do we
 * know that we picked the right set of laws?  What if we could show that the
 * laws were somehow _complete_ for the interface, prescribing _all possible
 * behaviors_ of the abstract data type?
 *
 * The concept of _contextual equivalence_ formalizes that idea in a general
 * way.  Say we have a simple _reference implementation_ of an abstract data
 * type, and we also have a more fancy, optimized implementation.  Consider all
 * possible _client code_ that imports a library for this data structure.  It
 * doesn't known which of the two it will be linked with; it must work for both.
 * The two libraries are _contextually equivalent_ if no client code can tell
 * them apart, so, say, the client code computes the same answer regardless.
 *
 * It is crucial to formalize the library interface with a type, so that we can
 * constraint which client programs are valid.  That's exactly what we do in
 * this pset, in addition to introducing a method for proving contextual
 * equivalence. *)

(** * Language syntax, semantics, and typing *)

(* Here's our base language, which only uses features familiar from the last
 * pset and class examples. *)

Inductive exp  :=
(* First, the basic STLC ingredients *)
| Var (x : var)
| Abs (x : var) (e1 : exp)
| App (e1 e2 : exp)
(* Constants and basic arithmetic *)
| Const (n : nat)
| Add (e1 e2 : exp)
(* And pairs; they're less general than tuples in the previous problem set. *)
| Pair (e1 e2 : exp)
| Fst (e : exp)
| Snd (e : exp).

Inductive value : exp -> Prop :=
| VAbs : forall x e1, value (Abs x e1)
| VConst : forall n, value (Const n)
| VPair : forall e1 e2, value e1 -> value e2 -> value (Pair e1 e2).

Hint Constructors value.
Hint Extern 1 (value _) => constructor.

(* Syntax of types *)
Inductive type :=
| Nat
| Fun (dom ran : type)
| Prod (t1 t2 : type)
(* We have a new type, called [AbsT], representing the abstract type.  When
 * implementing a certain data structure, we don't want to expose how it is
 * implemented by giving actual types of the implementation.  Instead, we just
 * claim that the implementation satisfies an abstract type.  Clients use it
 * without knowing the actual implementation, while the implementer should check
 * the type without any abstraction. *)
| AbsT.

(* Fancy notations *)
Coercion Var : var >-> exp.
Notation "\ x , e" := (Abs x e) (at level 51).
Infix "@" := App (at level 49, left associativity).
Coercion Const : nat >-> exp.
Infix "^+^" := Add (at level 50).
Notation "@( e1 , e2 )" := (Pair e1 e2) (at level 51).

Infix "-->" := Fun (at level 60, right associativity).
Notation "t1 ^*^ t2" := (Prod t1 t2) (at level 61).

(** A target ADT: simple counters *)
(* We want to prove that two simple counter implementations are
 * _contextually equivalent_, using a logical relation.  Below we can see two
 * implementations: [counter_impl1] is just using a single number to count.
 * Note that the counter exposes two distinct methods for incrementing its
 * value.  They should do the same work from the perspective of the external
 * world.  [counter_impl2] makes each increment method increment a different
 * private number, storing the two numbers within a pair. *)

Definition counter_type : type :=
  (AbsT ^*^ (* The internal counter value is abstracted; clients cannot use this
             * value.  In Java terms, think of this type part as a private
             * field. *)
  (AbsT --> Nat ^*^  (* Method to get the actual counter value *)
  (AbsT --> AbsT ^*^ (* Method to increase the counter value *)
   AbsT --> AbsT))). (* Second method to increase the counter value *)

(* Here's the simple reference implementation. *)
Definition counter_val1 := Const 0.
Definition counter_get1 := \"x", "x".
Definition counter_inc11 := \"x", "x" ^+^ 1.
Definition counter_inc21 := \"x", "x" ^+^ 1.
Definition counter_impl1 :=
  @(counter_val1, @(counter_get1, @(counter_inc11, counter_inc21))).

(* And here's the more convoluted two-counter version. *)
Definition counter_val2 := @(0, 0).
Definition counter_get2 := \"xy", (Fst "xy") ^+^ (Snd "xy").
Definition counter_inc12 := \"xy", @( (Fst "xy") ^+^ 1, Snd "xy" ).
Definition counter_inc22 := \"xy", @( Fst "xy", (Snd "xy") ^+^ 1 ).
Definition counter_impl2 :=
  @(counter_val2, @(counter_get2, @(counter_inc12, counter_inc22))).

(* Intuitively, client code can't distinguish these two versions, if it doesn't
 * know how the abstract type is implemented.  In this pset, we will work up to
 * proving that property for this example, in the process developing formal
 * machinery also applicable to many related examples.  (And all of this
 * generalizes to fancier languages with more expressive typing, though the
 * details are out of scope for the assignment.) *)

(* Some routine definitions again! They should should now be very familiar, so
 * it's safe for you to skim through quickly. But it is recommended to pay
 * attention to the typing rules, since now there is a new concept with
 * _abstract types_. *)

Fixpoint subst (e1 : exp) (x : var) (e2 : exp) : exp :=
  match e2 with
  | Var y => if y ==v x then e1 else Var y
  | Abs y e => Abs y (if y ==v x then e else subst e1 x e)
  | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
  | Const n => Const n
  | Add e1' e2' => Add (subst e1 x e1') (subst e1 x e2')
  | Pair e1' e2' => Pair (subst e1 x e1') (subst e1 x e2')
  | Fst e => Fst (subst e1 x e)
  | Snd e => Snd (subst e1 x e)
  end.

(* We use a big-step semantics for this problem set. *)
Inductive eval : exp -> exp -> Prop :=
| BigAbs : forall x e,
    eval (Abs x e) (Abs x e)
| BigApp : forall e1 x e1' e2 v2 v,
    eval e1 (Abs x e1') ->
    eval e2 v2 ->
    eval (subst v2 x e1') v ->
    eval (App e1 e2) v
| BigConst : forall n,
    eval (Const n) (Const n)
| BigAdd : forall e1 e2 n1 n2,
    eval e1 (Const n1) ->
    eval e2 (Const n2) ->
    eval (Add e1 e2) (Const (n1 + n2))
| BigPair : forall e1 e2 v1 v2,
    eval e1 v1 ->
    eval e2 v2 ->
    eval (Pair e1 e2) (Pair v1 v2)
| BigFst : forall e v1 v2,
    eval e (Pair v1 v2) ->
    eval (Fst e) v1
| BigSnd : forall e v1 v2,
    eval e (Pair v1 v2) ->
    eval (Snd e) v2.

Hint Constructors eval.

(* Here is an expression-typing relation with a single abstract type.  Clients
 * use [hasty] with the first argument as [None], where the actual type is not
 * exposed.  On the contrary, the implementation side uses [hasty] with the
 * first argument as [Some abst], where [abst] is the actual type used to
 * implement the data structure. *)
Inductive hasty : option type -> fmap var type -> exp -> type -> Prop :=
| HtVar : forall abs G x t,
    G $? x = Some t ->
    hasty abs G (Var x) t

(* Now there are two typing rules for [Abs]. The first one is as usual, but
 * requires argument type not equal to [AbsT]. It is for ensuring that [G]
 * always stores the actual type information, not the abstract one. *)
| HtAbs : forall abs G x e1 t1 t2,
    hasty abs (G $+ (x, t1)) e1 t2 ->
    t1 <> AbsT ->
    hasty abs G (Abs x e1) (Fun t1 t2)
(* The second typing rule for [Abs] is for the case when the argument has an
 * abstract type [AbsT]. In this case, we store the actual type by referring to
 * [Some abst]. *)
| HtAbsAbs : forall abst G x e1 t2,
    hasty (Some abst) (G $+ (x, abst)) e1 t2 ->
    hasty (Some abst) G (Abs x e1) (Fun AbsT t2)

(* Then the next few rules are standard, with [abs] threaded through. *)
| HtApp : forall abs G e1 e2 t1 t2,
    hasty abs G e1 (Fun t1 t2) ->
    hasty abs G e2 t1 ->
    hasty abs G (App e1 e2) t2
| HtConst : forall abs G n,
    hasty abs G (Const n) Nat
| HtAdd : forall abs G e1 e2,
    hasty abs G e1 Nat ->
    hasty abs G e2 Nat ->
    hasty abs G (Add e1 e2) Nat
| HtPair : forall abs G e1 e2 t1 t2,
    hasty abs G e1 t1 ->
    hasty abs G e2 t2 ->
    hasty abs G (Pair e1 e2) (Prod t1 t2)
| HtFst : forall abs G e t1 t2,
    hasty abs G e (Prod t1 t2) ->
    hasty abs G (Fst e) t1
| HtSnd : forall abs G e t1 t2,
    hasty abs G e (Prod t1 t2) ->
    hasty abs G (Snd e) t2

(* Finally, one more rule for the abstract type.  [AbsT] can be instantiated to
 * the actual type only if the actual type is provided, meaning this typing
 * rule is for the implementer. *)
| HtAbsT1 : forall abst G e,
    hasty (Some abst) G e abst ->
    hasty (Some abst) G e AbsT.

Hint Constructors hasty.

(** * Logical relation *)

(* How can we prove that two expressions are contextually equivalent?  That is,
 * how can we show that no well-typed client program could tell them apart?
 * Reasoning explicitly about every possible client program would be a lot of
 * work!  Instead, here's a fun idea from the literature, _logical relations_,
 * that gives a straightforward condition where we avoid reasoning about client
 * programs explicitly.  The key distinguishing property of logical relations is
 * that they are defined by recursion on type structure, helping explain why use
 * of a type system is so critical to the approach. *)

Section LogicalRel.
  Variables (abst1 abst2 : type)
            (value_rel_abs: exp -> exp -> Prop).
  (* The relation is parameterized over two different implementation types for
   * the abstract type, along with a primitive relation for saying when two
   * "private field" values for the two sides should be considered to represent
   * the same abstract value. *)

  (* This relation says when two expressions are equivalent at some type.  It is
   * parameterized on the relation to use to compare two *values* at a type. *)
  Definition exp_rel' (v_rel: type -> exp -> exp -> Prop)
             (t: type) (e1 e2: exp): Prop :=
    (* First, the two expressions really have the claimed type, in the
     * corresponding implementations of the abstract type. *)
    hasty (Some abst1) $0 e1 t /\ hasty (Some abst2) $0 e2 t /\

    (* Then, both evaluate to values that are themselves related. *)
    exists v1 v2, eval e1 v1 /\ eval e2 v2 /\
                  v_rel t v1 v2.

  (* Now we go methodically through the types, explaining what equivalence means
   * for each one. *)
  Fixpoint value_rel (t: type) (e1 e2: exp) : Prop :=
    match t with
    | Nat =>
      (* An easy case: numbers are equivalent when equal. *)
      match e1, e2 with
      | Const n1, Const n2 => n1 = n2
      | _, _ => False
      end

    | Prod t1 t2 =>
      (* Another pretty easy case: equivalent pairs have equivalent
       * components. *)
      match e1, e2 with
      | Pair v11 v12, Pair v21 v22 =>
        value_rel t1 v11 v21 /\ value_rel t2 v12 v22
      | _, _ => False
      end

    | AbsT =>
      (* The abstract type picks up whatever [value_rel_abs] relation we
       * chose, additionally requiring that the two expressions are
       * well-typed. *)
      hasty (Some abst1) $0 e1 AbsT /\
      hasty (Some abst2) $0 e2 AbsT /\
      value_rel_abs e1 e2

    | Fun t' t'' =>
      (* Now the signature case of logical relations: "the two functions map
       * equivalent inputs to equivalent outputs." *)
      match e1, e2 with
      | Abs x1 e1', Abs x2 e2' =>
        hasty (Some abst1) $0 e1 t /\ hasty (Some abst2) $0 e2 t /\
        forall v1 v2, (* <-- These are the two equivalent inputs! *)
          hasty (Some abst1) $0 v1 t' -> hasty (Some abst2) $0 v2 t' ->
          value_rel t' v1 v2 (* ...and this hypothesis says so. *) ->
          exp_rel' value_rel t'' (subst v1 x1 e1') (subst v2 x2 e2')
                   (* These substitution results are the equivalent outputs. *)
      | _, _ => False
      end
    end.

  Definition exp_rel := exp_rel' value_rel.

  (* We also need to argue for equivalence of terms with free variables.
   * This relation formalizes it in terms of typing contexts [G].
   * Basically it says: "two expressions with free variables are equivalent iff
   * we get equivalent expressions by substituting equivalent values for all the
   * free variables." *)
  Definition g_rel (G: fmap var type) (g1 g2: fmap var exp) : Prop :=
    forall x,
      (* Any variable in [G] is mapped to equivalent values. *)
      (forall t,
          G $? x = Some t ->
          exists v1 v2, g1 $? x = Some v1 /\ g2 $? x = Some v2 /\ value_rel t v1 v2) /\

      (* Any variable _not_ in [G] is mapped to nothing. *)
      (G $? x = None -> g1 $? x = None /\ g2 $? x = None).

  (* Here we define substitution for several variables at once. *)
  Fixpoint substs (g : fmap var exp) (e : exp) : exp :=
    match e with
    | Var y =>
      match g $? y with
      | Some v => v
      | _ => Var y
      end
    | Abs y e' => Abs y (substs (g $- y) e')
    | App e' e'' => App (substs g e') (substs g e'')
    | Const n => Const n
    | Add e' e'' => Add (substs g e') (substs g e'')
    | Pair e' e'' => Pair (substs g e') (substs g e'')
    | Fst e' => Fst (substs g e')
    | Snd e' => Snd (substs g e')
    end.

  (* Finally, the most general logical relation, for expressions that are
   * allowed to contain free variables *)
  Definition logical_rel (G: fmap var type) (e1 e2: exp) (t: type) :=
    hasty (Some abst1) G e1 t /\ hasty (Some abst2) G e2 t /\
    forall g1 g2,
      g_rel G g1 g2 ->
      exp_rel t (substs g1 e1) (substs g2 e2).
End LogicalRel.

(** * Returning to the example of counters *)

(* Let's demonstrate this machinery by proving that our two counter
 * implementations inhabit the appropriate logical relation.  We'll use this
 * relation to capture when the "private fields" on the two sides are
 * equivalent. *)
Inductive value_rel_counters : exp -> exp -> Prop :=
| Vrc : forall c inc dec,
    c = inc + dec ->
    value_rel_counters c (@(inc, dec)).

Hint Constructors value_rel_counters.

Hint Extern 1 (_ $? _ = Some _) => simplify; reflexivity.

(* And here's how we prove the relation. *)
Theorem counter_impls_related:
  value_rel Nat (Nat ^*^ Nat) value_rel_counters
            counter_type counter_impl1 counter_impl2.
Proof.
  (* We unfold some symbols and reveal a type-specialized notion of
   * equivalence! *)
  simplify.
  (* Here we see a giant conjunction. Most of the conjuncts are
   * typing requirements, which are easy to discharge either with [eauto]
   * or by applying constructors. *)
  propositional; eauto 15;
    try solve[apply HtAbsAbs; eauto 10]; try solve[repeat constructor].
  (* The three remaining conjuncts are conditions on the three methods of
   * the counter.
   *)
  - (* First is the "get" method.  We have that the two sides have equivalent
     * private-field values, and we must show that the two "get" methods will
     * therefore return equivalent results. *)
    invert H4. constructor. constructor. eauto 10.
    split.  eauto 10.
    do 2 eexists. split.
    repeat constructor. split.
    repeat econstructor.
    constructor.
  - (* Next is the "inc1" method. *)
    invert H4. constructor. constructor. eauto 10.
    split.  eauto 10.
    do 2 eexists. split.
    repeat constructor. split.
    repeat econstructor.
    constructor. eauto 10.
    split. eauto 10. constructor. linear_arithmetic.
  - (* Finally, the "inc2" method. *)
    invert H4. constructor. constructor. eauto 10.
    split.  eauto 10.
    do 2 eexists. split.
    repeat constructor. split.
    repeat econstructor.
    constructor. eauto 10.
    split. eauto 10. constructor. linear_arithmetic.
Qed.

(* Believe it or not, that condition implies contextual equivalence of the two
 * implementations... but we'll need to spend the rest of the pset proving it.
 * ;-)  We should at least prove a more general theorem that applies to many
 * other abstract data types, too. *)

Module Type S.
  (* We ask you to prove the "fundamental property" of the logical relation. It
   * seems very weak (every value is related to itself?  sounds obvious,
   * right?), but it's actually strong enough to prove the contextual equality.
   * According to the definition of [logical_rel], [G] can be regarded as a
   * "placeholder" to substitute two values in the logical relation, where the
   * values may differ! *)
  Axiom logical_rel_fundamental:
    forall abst1 abst2 (value_rel_abs: exp -> exp -> Prop),
      (forall v1 v2, value_rel_abs v1 v2 -> value v1 /\ value v2) ->
      abst1 <> AbsT ->
      abst2 <> AbsT ->
      forall e G t,
        hasty None G e t ->
        logical_rel abst1 abst2 value_rel_abs G e e t.

  (* The following corollary should be quite easy to prove, using
   * [logical_rel_fundamental]. *)
  Axiom counter_impls_equiv:
    forall x e,
      hasty None ($0 $+ (x, counter_type)) e Nat ->
      exists n : nat,
        eval (subst counter_impl1 x e) n /\ eval (subst counter_impl2 x e) n.
End S.

(** We provide some lemmas which may help you prove the theorems. *)

Lemma value_eval : forall v, value v -> eval v v.
Proof.
  induct 1; eauto.
Qed.

Hint Resolve value_eval.

Lemma eval_value : forall e v, eval e v -> value v.
Proof.
  induct 1; eauto.
  - invert IHeval; eauto.
  - invert IHeval; eauto.
Qed.

Hint Resolve eval_value.

Hint Extern 1 (_ <> _) => equality.

(* [adds] is a binary operation for [fmap]s, doing a merge between two maps
 * where the second map takes priority for a common key. It should be useful
 * for merging two type environments.
 *)
Section Adds.

  Definition adds {A B} (m1 m2: fmap A B) :=
    merge (fun v1 v2 => match v2 with
                        | Some _ => v2
                        | _ => v1
                        end) m1 m2.

  Lemma adds_empty1:
    forall {B} (m: fmap var B), adds $0 m = m.
  Proof.
    intros; unfold adds.
    rewrite merge_empty1; auto.
    intros; cases x; auto.
  Qed.

  Lemma adds_empty2:
    forall {B} (m: fmap var B), adds m $0 = m.
  Proof.
    intros; unfold adds.
    rewrite merge_empty2; auto.
  Qed.

  Lemma adds_add:
    forall {B} (m1 m2: fmap var B) x v,
      adds m1 m2 $+ (x, v) = adds m1 (m2 $+ (x, v)).
  Proof.
    intros; apply fmap_ext; intros.
    cases (x ==v k); subst; simplify.
    - unfold adds; rewrite lookup_merge; simplify; auto.
    - unfold adds; rewrite lookup_merge; simplify; auto.
  Qed.

  Lemma adds_add2:
    forall {B} (m: fmap var B) x v,
      adds ($0 $+ (x, v)) (m $- x) = m $+ (x, v).
  Proof.
    intros; apply fmap_ext; intros.
    cases (x ==v k); subst; simplify.
    - unfold adds; rewrite lookup_merge; simplify; auto.
    - unfold adds; rewrite lookup_merge; simplify.
      cases (m $? k); equality.
  Qed.

  Lemma adds_remove:
    forall {B} (m1 m2: fmap var B) x v,
      adds (m1 $+ (x, v)) (m2 $- x) = adds m1 (m2 $+ (x, v)).
  Proof.
    intros; apply fmap_ext; intros.
    unfold adds; rewrite 2! lookup_merge.
    cases (x ==v k); subst; simplify; auto.
  Qed.

End Adds.

(* Some facts about [hasty] *)
Section HasTyFacts.

  Lemma hasty_Nat_value:
    forall abst G e,
      hasty abst G e Nat ->
      value e ->
      exists n, e = Const n.
  Proof.
    induct 1; simplify; eauto;
      try match goal with
          | [H: value _ |- _] => invert H
          end.
  Qed.

  (* Note that a different type [t1'] is used when the type information is
   * stored.  It's due to the type instantiation that [hasty] does. *)
  Lemma hasty_Fun_value:
    forall abst G e t1 t2,
      hasty abst G e (Fun t1 t2) ->
      value e ->
      exists x1 t1' e2,
        e = Abs x1 e2 /\ hasty abst (G $+ (x1, t1')) e2 t2.
  Proof.
    induct 1; simplify; eauto;
      try match goal with
          | [H: value _ |- _] => invert H
          end.
  Qed.

  Lemma hasty_Prod_value:
    forall abst G e t1 t2,
      hasty abst G e (Prod t1 t2) ->
      value e ->
      exists e1 e2,
        e = @(e1, e2) /\ hasty abst G e1 t1 /\ hasty abst G e2 t2.
  Proof.
    induct 1; simplify; eauto;
      try match goal with
          | [H: value _ |- _] => invert H
          end.
  Qed.

  Lemma hasty_weakening:
    forall abst G e t,
      hasty abst G e t ->
      forall G',
        (forall x t, G $? x = Some t -> G' $? x = Some t) ->
        hasty abst G' e t.
  Proof.
    induct 1; simplify; eauto.
    - constructor; auto.
      apply IHhasty; intros.
      cases (x ==v x0); simplify; propositional; auto.
    - apply HtAbsAbs.
      apply IHhasty; intros.
      cases (x ==v x0); simplify; propositional; auto.
  Qed.

  Corollary hasty_weakening_empty:
    forall abst e t,
      hasty abst $0 e t ->
      forall G,
        hasty abst G e t.
  Proof.
    intros; apply hasty_weakening with (G:= $0); auto.
  Qed.

  Lemma hasty_weakening_abst:
    forall G e t, hasty None G e t ->
                  forall abst,
                    hasty (Some abst) G e t.
  Proof.
    induct 1; simplify; eauto.
  Qed.

  (* Closedness of expressions.
   * [e] is closed iff it does not have any free variables.
   * We define a more general version that uses argument [vs] to express which
   * free variables are allowed. *)
  Fixpoint closed (e: exp) (vs: set var) :=
    match e with
    | Var x => x \in vs
    | Abs x e' => closed e' (vs \cup {x})
    | App e' e'' => closed e' vs /\ closed e'' vs
    | Const _ => True
    | Add e' e'' => closed e' vs /\ closed e'' vs
    | Pair e' e'' => closed e' vs /\ closed e'' vs
    | Fst e' => closed e' vs
    | Snd e' => closed e' vs
    end.

  (* When [e] is type-checked, then it's closed. *)
  Lemma hasty_closed:
    forall abst G e t,
      hasty abst G e t ->
      closed e (dom G).
  Proof.
    induct 1; simplify; eauto.
    eapply lookup_Some_dom; eauto.
  Qed.

  (* When [e] is closed, then it's not affected by substitutions. *)
  Lemma closed_subst:
    forall e (G: fmap var type),
      closed e (dom G) ->
      forall v x,
        G $? x = None ->
        subst v x e = e.
  Proof.
    induct e; simplify; try (propositional; f_equal; eauto; fail).
    - cases (x ==v x0); subst; propositional.
      apply lookup_None_dom in H0; propositional.
    - cases (x ==v x0); subst; propositional.
      f_equal.
      apply IHe with (G:= G $+ (x, Nat)); simplify; auto.
  Qed.

  (* Here's a special case of the above, for truly closed expressions. *)
  Lemma value_hasty_closed:
    forall e abst t,
      hasty abst $0 e t ->
      forall x v,
        subst v x e = e.
  Proof.
    intros.
    apply closed_subst with (G := $0).
    - eapply hasty_closed. eauto.
    - simplify; equality.
  Qed.

End HasTyFacts.

Hint Immediate hasty_weakening hasty_weakening_abst.

(* Some facts about [substs] *)
Section Substs.

  Lemma substs_empty:
    forall e, substs $0 e = e.
  Proof.
    induct e; simplify; eauto; try (f_equal; auto).
    replace (empty string exp $- x) with (empty string exp); auto.
    clear IHe; apply fmap_ext; simplify.
    cases (x ==v k); subst; simplify; equality.
  Qed.

  Lemma substs_single:
    forall x v e,
      substs ($0 $+ (x, v)) e = subst v x e.
  Proof.
    induct e; simplify; eauto; try (f_equal; auto).
    - cases (x ==v x0); subst; simplify.
      + cases (x0 ==v x0); equality.
      + cases (x0 ==v x); equality.
    - cases (x ==v x0); subst; simplify.
      + cases (x0 ==v x0); try equality.
        rewrite <-substs_empty.
        f_equal.
        apply fmap_ext; simplify.
        cases (x0 ==v k); subst; simplify; equality.
      + cases (x0 ==v x); subst; simplify; try equality.
        replace ($0 $+ (x, v) $- x0) with ($0 $+ (x, v)); auto.
        apply fmap_ext; simplify.
        cases (x ==v k); subst; simplify; try equality.
        cases (x0 ==v k); subst; simplify; try equality.
  Qed.

End Substs.

(* Some facts about logical relations *)
Section LogicalRelFacts.
  Variables (abst1 abst2 : type)
            (value_rel_abs: exp -> exp -> Prop).
  Hypotheses (Hvr: forall v1 v2, value_rel_abs v1 v2 -> value v1 /\ value v2).

  Lemma value_rel_value:
    forall t v1 v2,
      value_rel abst1 abst2 value_rel_abs t v1 v2 ->
      value v1 /\ value v2.
  Proof.
    induct t.
    - simplify.
      cases v1; try invert H.
      cases v2; try invert H.
      auto.
    - simplify.
      cases v1; try invert H.
      cases v2; try invert H.
      auto.
    - simplify.
      cases v1; try invert H.
      cases v2; try invert H.
      specialize (IHt1 _ _ H0).
      specialize (IHt2 _ _ H1).
      first_order; constructor; auto.
    - first_order.
  Qed.

  Lemma value_rel_hasty:
    forall t v1 v2,
      value_rel abst1 abst2 value_rel_abs t v1 v2 ->
      hasty (Some abst1) $0 v1 t /\ hasty (Some abst2) $0 v2 t.
  Proof.
    induct t; simplify; auto.
    - cases v1; try invert H.
      cases v2; try invert H.
      auto.
    - cases v1; try invert H.
      cases v2; try invert H.
      propositional; subst.
    - cases v1; try invert H.
      cases v2; try invert H.
      specialize (IHt1 _ _ H0).
      specialize (IHt2 _ _ H1).
      first_order; constructor; auto.
    - first_order.
  Qed.

  Lemma value_rel_implies_exp_rel:
    forall t v1 v2,
      value_rel abst1 abst2 value_rel_abs t v1 v2 ->
      exp_rel abst1 abst2 value_rel_abs t v1 v2.
  Proof.
    unfold exp_rel, exp_rel'; intros; repeat split.
    - apply value_rel_hasty in H; propositional.
    - apply value_rel_hasty in H; propositional.
    - exists v1, v2; repeat split; auto.
      + apply value_rel_value in H.
        apply value_eval; propositional.
      + apply value_rel_value in H.
        apply value_eval; propositional.
  Qed.

End LogicalRelFacts.