(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

(* A denotational semantics for computations that relates every computation to a denotation. *)

Set Implicit Arguments.

Require Export fcf.Comp.
Require Export fcf.Rat.
Require Import fcf.Fold.
Require Import List.
Require Import fcf.Blist.
Require Import Omega.
Require Import fcf.StdNat.
Require Import fcf.NotationV1.

Local Open Scope list_scope.
Local Open Scope rat_scope.

Ltac simp_in_support :=
  unfold setLet in *;
  match goal with
    | [H : In _ (getSupport (Bind _ _)) |- _ ] =>
      apply getSupport_Bind_In in H; destruct_exists; intuition
    | [H : In _ (getSupport (if ?t then _ else _)) |- _ ] => let x := fresh "x" in remember t as x; destruct x
    | [H : In _ (getSupport (ret _)) |- _ ] => apply getSupport_In_Ret in H; try pairInv; subst
(*     | [H : false = inRange _ _ |- _] => symmetry in H *)
    | [H : true = negb ?t |- _ ] => let x := fresh "x" in remember t as x; destruct x; simpl in H; try discriminate
  end.

(* evalDist is a denotational semantics that produces a distribution instead of a value. *)

Definition Distribution(A : Set) := A -> Rat.

Definition indicator(A : Set)(P : A -> bool) :=
  fun a => if (P a) then rat1 else rat0.

Fixpoint evalDist(A : Set)(c : Comp A) : Distribution A :=
  match c with
    | Ret eqd a => fun a' => if (eqd a a') then 1 else 0
    | Bind c1 c2 => fun a =>
      sumList (getSupport c1) (fun b => (evalDist c1 b) * (evalDist (c2 b) a))
    | Rnd n => fun v => 1 / (expnat 2 n)
    | Repeat c P => fun a => (indicator P a) * (ratInverse (sumList (filter P (getSupport c)) (evalDist c))) * (evalDist c a)
  end.

Definition dist_sem_eq(A : Set)(c1 c2 : Comp A) :=
  forall a, (evalDist c1 a) == (evalDist c2 a).

Definition Support(A : Set)(ls : list A)(d : Distribution A) :=
  NoDup ls /\
  (forall a, In a ls <-> ~((d a) == 0)).

Lemma getSupport_NoDup : forall (A : Set)(c : Comp A),
  NoDup (getSupport c).

  destruct c; intuition; simpl in *.

  econstructor.
  apply in_nil.
  econstructor.

  eapply getUnique_NoDup.

  eapply getAllBvectors_NoDup.

  eapply filter_NoDup.
  eapply getSupport_NoDup.

Qed.

Lemma filter_not_In : forall (A : Set)(ls : list A)(P : A -> bool) a,
                        (~In a ls) \/ P a = false <->
                        ~In a (filter P ls).

    intuition.
    eapply H1.
    eapply filter_In; eauto.
    assert (P a = true -> False).
    intuition.
    congruence.
    eapply H.
    eapply filter_In; eauto.

    case_eq (P a); intuition.
    left.
    intuition.
    eapply H.
    eapply filter_In; eauto.

Qed.

Theorem getSupport_In_evalDist : forall (A : Set)(c : Comp A)(a : A),
  In a (getSupport c) <-> ~(evalDist c a == 0).

  induction c; simpl in *; intuition.
  subst.
  destruct (e a0 a0).
  eapply rat1_ne_rat0.
  trivial.
  congruence.

  destruct (e a a0); subst.
  intuition.
  right.
  intuition.

  apply in_getUnique_if in H0.
  apply in_flatten in H0.

  destruct H0.
  intuition.
  apply in_map_iff in H2.
  destruct H2.
  intuition.

  eapply sumList_0 in H1; eauto.
  apply ratMult_0 in H1; intuition.
  eapply IHc; eauto.
  subst.
  eapply H; eauto.

  apply (in_getUnique (flatten (map (fun b : B => getSupport (c0 b)) (getSupport c)))).
  apply in_flatten.
  apply sumList_nz in H0.
  destruct H0.
  intuition.
  apply ratMult_nz in H2.
  intuition.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eapply H1.
  eapply H.
  eauto.

  eapply in_getAllBvectors.

  apply ratMult_0 in H0.
  intuition.
  apply ratMult_0 in H1.
  intuition.
  unfold indicator in *.
  case_eq (b a); intuition.
  rewrite H1 in H0.
  eapply rat1_ne_rat0.
  trivial.

  eapply filter_not_In.
  eauto.
  eauto.

  eapply ratInverse_nz; eauto.
  eapply IHc.
  eapply filter_In.
  eauto.
  trivial.

  apply ratMult_nz in H.
  intuition.
  apply ratMult_nz in H0.
  intuition.
  unfold indicator in *.
  case_eq (b a); intuition;
  rewrite H0 in H.
  eapply filter_In.
  intuition.
  eapply IHc.
  trivial.
  exfalso.
  intuition.

Qed.

Theorem getSupport_not_In_evalDist : forall (A : Set)(c : Comp A)(a : A),
  ~In a (getSupport c) <-> (evalDist c a == 0).

  intuition.

  Theorem getSupport_not_In_evalDist_h : forall (A : Set)(c : Comp A)(a : A),
  ~In a (getSupport c) -> (evalDist c a == 0).

    induction c; intuition; simpl in *.
    intuition.
    destruct (e a a0); subst;
    intuition.

    eapply sumList_0.
    intuition.
    eapply ratMult_0.
    right.
    eapply H.
    intuition.
    eapply H0.
    eapply (in_getUnique (flatten (map (fun b : B => getSupport (c0 b)) (getSupport c)))).
    eapply in_flatten.
    exists (getSupport (c0 a0)).
    intuition.
    eapply in_map_iff.
    exists a0.
    intuition.

    exfalso.
    eapply H.
    eapply in_getAllBvectors.

    apply filter_not_In in H.
    intuition.

    eapply ratMult_0.
    right.
    eauto.

    eapply ratMult_0.
    left.
    unfold indicator.
    rewrite H0.
    rewrite ratMult_0_l.
    intuition.

  Qed.

  eapply getSupport_not_In_evalDist_h.
  intuition.

  eapply getSupport_In_evalDist; eauto.

Qed.

Theorem getSupport_correct : forall (A : Set)(c : Comp A),
  Support (getSupport c)(evalDist c).

  intuition.
  econstructor.
  eapply getSupport_NoDup.

  apply getSupport_In_evalDist.

Qed.

(* We use evalDist as the probability measure.  Instead of supplying an event on the return type, we expect the computation to test for the occurrence of the event.  *)
Notation "'Pr' [ c  ] " := (evalDist c true) (at level 20).

Lemma evalDist_sum_bind_eq : forall (A B : Set)(eqdb : eq_dec B)(eqda : eq_dec A)(c1 : Comp B)(c2 : B -> Comp A),
  sumList (getSupport (Bind c1 c2)) (evalDist (Bind c1 c2)) ==
  sumList (getSupport c1) (fun b => evalDist c1 b * (sumList (getSupport (c2 b)) (evalDist (c2 b)))).

  intuition. simpl.
  eapply eqRat_trans.
  eapply sumList_comm.
  eapply sumList_body_eq; intuition.

  eapply eqRat_trans.
  eapply sumList_factor_constant_l.
  eapply ratMult_eqRat_compat; intuition.

  eapply eqRat_symm.
  eapply sumList_subset; intuition.
  eapply getSupport_NoDup.
  eapply getUnique_NoDup.
  eapply (in_getUnique (flatten (map (fun b : B => getSupport (c2 b)) (getSupport c1)))).
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eauto.
  eauto.

  eapply getSupport_not_In_evalDist.
  eauto.
Qed.

(*
Lemma evalDist_sum_repeat_eq : forall (A : Set)(eqda : eq_dec A)(c : Comp A) P,
  let scale := (ratInverse (sumList (filter P (getSupport c)) (evalDist c))) in
  sumList (getSupport (Repeat c P)) (evalDist (Repeat c P)) ==
  sumList (filter P (getSupport c1)) (fun b => scale * evalDist c1 b * (sumList (getSupport (c2 b)) (evalDist (c2 b)))).

  intuition. simpl.
  eapply eqRat_trans.
  eapply sumList_comm.
  eapply sumList_body_eq; intuition.

  eapply eqRat_trans.
  eapply sumList_factor_constant_l.
  eapply ratMult_eqRat_compat; intuition.

  eapply eqRat_symm.
  eapply sumList_subset; intuition.
  eapply getSupport_NoDup.
  eapply getUnique_NoDup.
  eapply in_getUnique.
  eapply in_flatten.
  econstructor.
  split.
  eapply in_map_iff.
  econstructor.
  split.
  eapply eq_refl.
  eauto.
  eauto.

  eapply getSupport_not_In_evalDist.
  eauto.

Qed.
*)

Lemma ratInverse_scale_sum_1 : forall (A : Set)(ls : list A)(f : A -> Rat),
  (forall a, In a ls -> ~f a == 0) ->
  length ls > O ->
  sumList ls (fun a => (ratInverse (sumList ls f)) * (f a)) == 1.

  intuition.
  rewrite sumList_factor_constant_l.
  eapply ratInverse_prod_1.
  intuition.
  destruct ls; simpl in *.
  omega.
  eapply sumList_0 in H1.
  eapply H.
  eauto.
  eauto.
  simpl.
  eauto.

Qed.

Lemma evalDist_lossless : forall (A : Set)(c : Comp A),
  well_formed_comp c ->
  sumList (getSupport c) (evalDist c) == 1.

  induction 1; intuition; simpl in *.
  unfold sumList; simpl in *.
  destruct (pf a a); intuition.
  rewrite <- ratAdd_0_l.
  intuition.

  eapply eqRat_trans.
  apply evalDist_sum_bind_eq.
  eapply comp_eq_dec; eauto.
  eapply bind_eq_dec; eauto.
  eapply eqRat_trans.
  eapply sumList_body_eq.
  intuition.
  apply ratMult_eqRat_compat.
  apply eqRat_refl.
  apply H1.
  trivial.
  eapply eqRat_trans.
  eapply sumList_body_eq; intuition.
  apply ratMult_1_r.
  trivial.

  rewrite sumList_body_const.
  rewrite getAllBvectors_length.
  rewrite <- ratMult_num_den.
  rewrite mult_1_l.
  eapply num_dem_same_rat1.

  rewrite posnatMult_1_r.
  unfold posnatToNat, natToPosnat.
  trivial.

  eapply eqRat_trans.
  eapply sumList_body_eq.
  intuition.
  eapply ratMult_eqRat_compat.
  assert (P a = true).
  eapply filter_In; eauto.
  unfold indicator.
  rewrite H2.
  eapply ratMult_1_l.
  eapply eqRat_refl.
  eapply ratInverse_scale_sum_1.
  intuition.
  eapply getSupport_In_evalDist.
  eapply filter_In.
  eapply H1.
  trivial.
  destruct (filter P (getSupport c)); simpl in *; intuition.

Qed.

Lemma sumList_filter_evalDist_le_1 : forall (A : Set)(c : Comp A)(P : A -> bool) a,
  well_formed_comp c ->
  In a (filter P (getSupport c)) ->
  1 <= sumList (filter (fun a' => negb (P a')) (getSupport c)) (evalDist c) ->
  False.

  intuition.
  assert (sumList (filter (fun a0 : A => negb (P a0)) (getSupport c)) (evalDist c) == 1).
  eapply leRat_impl_eqRat; trivial.
  eapply leRat_trans.
  eapply sumList_filter_le.
  rewrite evalDist_lossless.
  intuition.
  trivial.

  rewrite <- evalDist_lossless in H2; eauto.
  rewrite (sumList_filter_partition P (getSupport c)) in H2.
  symmetry in H2.
  rewrite ratAdd_comm in H2.
  apply ratAdd_arg_0 in H2.
  eapply sumList_0 in H2; eauto.
  eapply getSupport_In_evalDist.
  eapply filter_In; eauto.
  trivial.
Qed.

Theorem sumList_support_bool :
  forall (c : Comp bool),
    sumList (getSupport c) (evalDist c) ==
    evalDist c true + evalDist c false.

  intuition.
  rewrite (sumList_filter_partition (eqb true)).
  eapply ratAdd_eqRat_compat.

  destruct (eq_Rat_dec (Pr[c]) 0).
  rewrite e.
  eapply sumList_0.
  intuition.
  apply filter_In in H.
  intuition.
  rewrite eqb_leibniz in H1.
  subst.
  trivial.

  eapply sumList_exactly_one.
  eapply filter_NoDup.
  eapply getSupport_NoDup.
  eapply filter_In.
  intuition.
  eapply getSupport_In_evalDist.
  intuition.
  eapply eqb_leibniz.
  trivial.
  intuition.
  eapply filter_In in H.
  intuition.
  rewrite eqb_leibniz in H2.
  subst.
  intuition.

  destruct (eq_Rat_dec (evalDist c false) 0).
  rewrite e.
  eapply sumList_0.
  intuition.
  eapply filter_In in H.
  intuition.
  destruct a.
  rewrite eqb_refl in H1.
  simpl in *.
  discriminate.
  trivial.

  eapply sumList_exactly_one.
  eapply filter_NoDup.
  eapply getSupport_NoDup.
  eapply filter_In.
  intuition.
  eapply getSupport_In_evalDist.
  intuition.
  case_eq (eqb true false); intuition.
  rewrite eqb_leibniz in H.
  discriminate.

  intuition.
  eapply filter_In in H.
  intuition.
  destruct b.
  rewrite eqb_refl in H2.
  simpl in *.
  discriminate.
  intuition.
Qed.

Lemma evalDist_sum_le_1 : forall (A : Set)(c : Comp A),
  sumList (getSupport c) (evalDist c) <= 1.

  induction c; intuition; simpl in *.
  unfold sumList; simpl in *.
  destruct (e a a); intuition.
  rewrite <- ratAdd_0_l.
  intuition.

  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  apply evalDist_sum_bind_eq.
  eapply comp_eq_dec; eauto.
  eapply bind_eq_dec; eauto.
  eapply leRat_trans.
  eapply sumList_le.
  intuition.
  apply ratMult_leRat_compat.
  apply leRat_refl.
  apply H.
  eapply leRat_trans.
  eapply sumList_le; intuition.
  eapply eqRat_impl_leRat.
  eapply ratMult_1_r.
  trivial.

  rewrite sumList_body_const.
  rewrite getAllBvectors_length.
  rewrite <- ratMult_num_den.
  rewrite mult_1_l.
  eapply eqRat_impl_leRat.
  eapply num_dem_same_rat1.

  rewrite posnatMult_1_r.
  unfold posnatToNat, natToPosnat.
  trivial.

  destruct (gt_dec (length (filter b (getSupport c))) 0).

  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply sumList_body_eq.
  intuition.
  eapply ratMult_eqRat_compat.
  assert (b a = true).
  eapply filter_In; eauto.

  unfold indicator.
  rewrite H0.
  eapply ratMult_1_l.
  eapply eqRat_refl.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply ratInverse_scale_sum_1.
  intuition.
  eapply getSupport_In_evalDist.
  eapply filter_In.
  eapply H.
  trivial.
  trivial.
  intuition.

  destruct (filter b (getSupport c)); simpl in *.
  unfold sumList.
  simpl.
  eapply rat0_le_all.

  omega.
Qed.

Lemma evalDist_le_1 : forall (A : Set)(c : Comp A) a,
  evalDist c a <= 1.

  intuition.
  eapply leRat_trans.
  Focus 2.
  eapply (@evalDist_sum_le_1 _ c).
  pose proof (comp_EqDec c).
  destruct (in_dec (EqDec_dec _) a (getSupport c)).
  eapply leRat_trans.
  Focus 2.
  eapply eqRat_impl_leRat.
  symmetry.
  rewrite (sumList_partition (eqb a)).
  eapply ratAdd_eqRat_compat.
  eapply sumList_exactly_one.
  eapply getSupport_NoDup.
  eauto.
  intuition.
  case_eq (eqb a b); intuition.
  exfalso.
  eapply H1.
  eapply eqb_leibniz.
  trivial.
  eapply ratMult_0_r.
  eapply eqRat_refl.

  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply ratAdd_0_r.
  eapply ratAdd_leRat_compat.
  rewrite eqb_refl.

  eapply leRat_trans.
  Focus 2.
  eapply eqRat_impl_leRat.
  symmetry.
  eapply ratMult_1_r.
  intuition.

  eapply rat0_le_all.

  apply getSupport_not_In_evalDist in n.
  rewrite n.
  eapply rat0_le_all.
Qed.

Theorem evalDist_complement :
  forall (c : Comp bool),
    well_formed_comp c ->
    evalDist c false == ratSubtract 1 (Pr[c]).

  intuition.
  eapply (@ratAdd_add_same_l _ (Pr[c])).
  rewrite ratSubtract_ratAdd_inverse_2.
  rewrite <- sumList_support_bool.
  eapply evalDist_lossless.
  trivial.

  eapply evalDist_le_1.
Qed.

Theorem evalDist_le_1_gen :
  forall (A : Set)(eqd : EqDec A)(c : Comp A)(ls : list A),
    NoDup ls ->
    sumList ls (evalDist c) <= 1.

  intuition.
  eapply leRat_trans.
  eapply eqRat_impl_leRat.
  eapply (sumList_filter_partition (fun a => if (in_dec (EqDec_dec _) a (getSupport c)) then true else false)).

  eapply leRat_trans.
  Focus 2.
  eapply eqRat_impl_leRat.
  symmetry.
  eapply ratAdd_0_r.
  eapply ratAdd_leRat_compat.

  eapply leRat_trans.
  eapply sumList_subset_le.
  intuition.
  eapply filter_NoDup.
  trivial.
  eapply (getSupport_NoDup c).
  intuition.
  eapply filter_In in H0.
  intuition.
  destruct (in_dec (EqDec_dec eqd) a (getSupport c)); intuition.
  discriminate.
  eapply evalDist_sum_le_1.

  eapply eqRat_impl_leRat.
  eapply sumList_0.
  intuition.
  eapply filter_In in H0.
  intuition.
  destruct (in_dec (EqDec_dec eqd) a (getSupport c)).
  simpl in *.
  discriminate.
  eapply getSupport_not_In_evalDist.
  trivial.

Qed.

Theorem evalDist_1_0 :
  forall (A : Set){eqd : EqDec A}(c : Comp A) a,
    well_formed_comp c ->
    evalDist c a == 1 ->
      (forall b, b <> a -> evalDist c b == 0).

  intuition.
  eapply leRat_impl_eqRat.

  eapply (leRat_ratAdd_same_r (evalDist c a)).
  eapply leRat_trans.
  Focus 2.
  eapply eqRat_impl_leRat.
  rewrite H0.
  eapply ratAdd_0_l.

  assert ( evalDist c b + evalDist c a ==
    sumList (a :: b :: nil)%list (evalDist c)).
  repeat rewrite sumList_cons.
  rewrite ratAdd_comm.
  eapply ratAdd_eqRat_compat; intuition.
  rewrite ratAdd_0_r at 1.
  eapply ratAdd_eqRat_compat; intuition.
  unfold sumList; simpl; intuition.

  rewrite H2.
  eapply evalDist_le_1_gen; intuition.
  econstructor.
  simpl; intuition.
  econstructor; simpl; intuition.
  econstructor.

  eapply rat0_le_all.

Qed.

Local Open Scope comp_scope.

Theorem EqDec_pair_l
  : forall (A B : Set)(eqd : EqDec (A * B))(b : B),
    EqDec A.

  intuition.
  exists (fun a1 a2 => eqb (a1, b) (a2, b)).
  intuition.
  rewrite eqb_leibniz in H.
  inversion H; intuition.
  subst.
  eapply eqb_refl.
Qed.

Fixpoint evalDist_OC(A B C: Set)(c : OracleComp A B C): forall(S : Set), EqDec S -> (S -> A -> Comp (B * S)) -> S -> Comp (C * S) :=
  match c in (OracleComp A B C) return (forall(S : Set), EqDec S -> (S -> A -> Comp (B * S)) -> S -> Comp (C * S))
    with
    | @OC_Query A' B' a =>
      fun (S : Set)(eqds : EqDec S)(o : S -> A' -> Comp (B' * S))(s : S) =>
        o s a
    | @OC_Run A'' B'' C' A' B' S' eqds' eqda'' eqdb'' c' o' s' =>
      fun (S : Set)(eqds : EqDec S)(o : S -> A' -> Comp (B' * S))(s : S) =>
      p <-$ evalDist_OC c' (pair_EqDec eqds' eqds) (fun x y => p <-$ evalDist_OC (o' (fst x) y) _ o (snd x); ret (fst (fst p), (snd (fst p), snd p))) (s', s);
      Ret
      (EqDec_dec (pair_EqDec (pair_EqDec
        (oc_EqDec c' (fun x => fst (oc_base_exists (o' s' x) (fun y => fst (comp_base_exists (o s y))))) (fun x => EqDec_pair_l (oc_EqDec (o' s' x) (fun y => fst (comp_base_exists (o s y))) (fun y => EqDec_pair_l (comp_EqDec (o s y)) s)) s' ))
        _) _ ))
      (fst p, fst (snd p), snd (snd p))

    | @OC_Ret A' B' C' c =>
      fun (S : Set)(eqds : EqDec S)(o : S -> A' -> Comp (B' * S))(s : S) =>
      x <-$ c; Ret
      (EqDec_dec (pair_EqDec (comp_EqDec c) _ ))
      (x, s)
    | @OC_Bind A' B' C' C'' c' f' =>
      fun (S : Set)(eqds : EqDec S)(o : S -> A' -> Comp (B' * S))(s : S) =>
      [z, s'] <-$2 evalDist_OC c' _ o s;
      evalDist_OC (f' z) _ o s'
  end.

Coercion evalDist_OC : OracleComp >-> Funclass.

Inductive well_formed_oc : forall (A B C : Set), OracleComp A B C -> Prop :=
| well_formed_OC_Query :
  forall (A B : Set)(a : A),
    well_formed_oc (OC_Query B a)
| well_formed_OC_Run :
  forall (A B C A' B' S : Set)
  (eqds : EqDec S)(eqdb : EqDec B)(eqda : EqDec A)(c : OracleComp A B C)
  (o : S -> A -> OracleComp A' B' (B * S))(s : S),
  well_formed_oc c ->
  (forall s a, well_formed_oc (o s a)) ->
  well_formed_oc (OC_Run eqds eqdb eqda c o s)
| well_formed_OC_Ret :
  forall (A B C : Set)(c : Comp C),
      well_formed_comp c ->
      well_formed_oc (OC_Ret A B c)
| well_formed_OC_Bind :
  forall (A B C C' : Set)(c : OracleComp A B C)(f : C -> OracleComp A B C'),
    well_formed_oc c ->
    (forall c, well_formed_oc (f c)) ->
    well_formed_oc (OC_Bind c f).

Local Open Scope nat_scope.

Definition in_oc_support(A B C : Set)(x : C)(c : OracleComp A B C) :=
  exists (S : Set)(eqds : EqDec S)(o : S -> A -> Comp (B * S))(s s' : S),
    In (x, s') (getSupport (c _ _ o s)).

Inductive queries_at_most : forall (A B C : Set), OracleComp A B C -> nat -> Prop :=
| qam_Bind :
  forall (A B C C' : Set)(c : OracleComp A B C')(f : C' -> OracleComp A B C) q1 q2,
    queries_at_most c q1 ->
    (forall c',
      in_oc_support c' c ->
       queries_at_most (f c') q2) ->
    queries_at_most (OC_Bind c f) (q1 + q2)
| qam_Query :
  forall (A B : Set)(a : A),
  queries_at_most (OC_Query B a) 1
| qam_Ret :
  forall (A B C : Set)(c : Comp C),
    queries_at_most (OC_Ret A B c) 0
| qam_Run :
  forall (A A' B B' C S : Set)(eqds : EqDec S)(eqda : EqDec A)(eqdb : EqDec B)
    (c : OracleComp A B C)(oc : S -> A -> OracleComp A' B' (B * S)) s q1 q2,
    queries_at_most c q1 ->
    (forall s a, queries_at_most (oc s a) q2) ->
    queries_at_most (OC_Run _ _ _ c oc s) (q1 * q2)
| qam_le :
  forall (A B C : Set)(c : OracleComp A B C) q1 q2,
    queries_at_most c q1 ->
    q1 <= q2 ->
    queries_at_most c q2.


(** * Generation of Hoare proof obligations in partial correctness

 This file is part of the "Tutorial on Hoare Logic".
 For an introduction to this Coq library,
 see README #or index.html#.

 This file gives a syntactic definition of the weakest liberal precondition [wlp]
 introduced in ##[hoarelogicsemantics]##.
*)

Global Set Asymmetric Patterns.
Set Implicit Arguments.
Require Export hoarelogicsemantics.

Module PartialHoareLogic (HD: HoareLogicDefs).

Export HD.
Module HLD:=HD.

Definition sem_wp := wlp.

(** * Syntactic definition of the weakest liberal precondition.

 In the following, we show that this definition is logically
 equivalent to [wlp].
 *)
Fixpoint synt_wp (prog: ImpProg) : Pred -> Pred
 := fun post e =>
  match prog with
  | Iskip => post e
  | (Iset A x expr) => post (E.upd x (E.eval expr e) e)
  | (Iif cond p1 p2) =>
          ((E.eval cond e)=true -> (synt_wp p1 post e))
       /\ ((E.eval cond e)=false -> (synt_wp p2 post e))
  | (Iseq p1 p2) => synt_wp p1 (synt_wp p2 post) e
  | (Iwhile cond p) =>
        exists inv:Pred,
             (inv e)
          /\ (forall e', (inv e')
                  -> (E.eval cond e')=false -> (post e'))
          /\ (forall e', (inv e')
                  -> (E.eval cond e')=true -> (synt_wp p inv e'))
  end.

(** This property is also trivially satisfied by [wlp].
    We need it here to prove the soundness.
*)
Lemma synt_wp_monotonic:
  forall (p: ImpProg) (post1 post2: Pred),
   (post1 |= post2) -> (synt_wp p post1) |= (synt_wp p post2).
Proof.
  induction p; simpl; firstorder eauto with hoare.
Qed.

Global Hint Resolve synt_wp_monotonic: hoare.

(** * Soundness

    The proof of soundness proceeds by induction over the derivation
    [exec ... prog ...] in implicit hypothesis induced by [wlp] definition.

    Please, notice that coq performs the [exec_Iwhile] case alone (that's where
    monotonicity is used). Unfortunately, the case [exec_Iif] which seems
    trivial to a human is not discharged by Coq.
*)
Lemma wp_sound: forall prog post, synt_wp prog post |= prog{=post=}.
Proof.
 intros prog post e H0 e' H; generalize post H0; clear H0 post.
 elim H; clear H e' e prog; simpl; try ((firstorder eauto 20 with hoare); fail).
 (** - case [exec_Iif] *)
 intros e cond p1 p2 e'.
 case (E.eval cond e); simpl; firstorder auto.
Qed.

(** * Completeness

    The proof of completeness proceeds by induction over [prog] syntax.

    Please, notice that coq performs this proof almost alone. The only
    hint given here is the invariant.
*)
Lemma wp_complete: forall prog post, prog{=post=} |= (synt_wp prog post).
Proof.
 unfold wlp; intros prog; elim prog; clear prog; simpl;
 try ((firstorder auto with hoare); fail).
 (** - case [Iseq] *)
 eauto with hoare.
 (** - case [Iwhile]: I provide the invariant below *)
  intros.
  constructor 1 with (x:=wlp (Iwhile cond p) post).
  unfold wlp; intuition eauto 20 with hoare.
Qed.

(** * Combining the previous results with transitivity of [ |= ] *)

Global Hint Resolve wp_complete wp_sound: hoare.

Theorem soundness: forall pre p post, pre |= (synt_wp p post) -> pre |= p {=post=}.
Proof.
 auto with hoare.
Qed.

Theorem completeness: forall pre p post, pre |= p {=post=} -> pre |= (synt_wp p post).
Proof.
  intuition auto with hoare.
Qed.

End PartialHoareLogic.

(** "Tutorial on Hoare Logic" Library. Copyright 2007 Sylvain Boulme.

This file is distributed under the terms of the
 "GNU LESSER GENERAL PUBLIC LICENSE" version 3.
*)


Require Import Utf8.

(* Set definition *)
(* In this file, a set is represented by its
characteristic function. *)
Definition Ens {E : Type} := E -> Prop.
Definition In {E : Type} (A :@Ens E) (x:E) := A x.
Notation "x ∈ A" := (In A x) (at level 60).
Local Hint Unfold In.

(* Inclusion relation *)
Definition incl {E: Type} (A B: Ens) :=
  ∀ x: E, x ∈ A → x ∈ B.
Notation "A ⊆ B" := (incl A B) (at level 80).

(* Image of a set by a function *)
Definition im {E F: Type} (f: E → F) (A: Ens): Ens :=
  fun (y: F) => ∃ x, x ∈ A ∧ y = f x.

(* Inverse image of a set by a function *)
Definition pre {E F: Type} (f: E → F) (B: Ens): Ens :=
  fun (x: E) => f x ∈ B.

(* Injective function *)
Definition injective {E F: Type} (f: E -> F) :=
  ∀ (x x': E), f x = f x' → x = x'.

Theorem direct_inclusion :
  forall {E F: Type} (f: E → F),
    ∀ A, A ⊆ pre f (im f A).
Proof.
  intros E F f A. (* This automatically introduces four universal quantifiers, calling E, F, f and A the introduced objects. *)
  unfold incl.    (* Unfold the definition of inclusion. This is possible by matching A and B in the definition with A and pre (im A). *)
  intros x Hx.    (* introduction of universal quantifier and implication *)
  unfold pre.     (* unfolding the definition of pre. *)
  unfold In.      (* unfolding the definition of Im. *)
  unfold im.      (* unfolding the definition of Image *)
  exists x.       (* introduction of existential quantifier *)
  split; trivial. (* introduction of conjunction and resolving trivial goals *)
Qed.

Theorem reverse_inclusion :
  forall {E F: Type} (f: E -> F),
    injective f ->
      forall A, incl (pre f (im f A)) A.
Proof.
  intros.                     (* introduction of universal quantifiers and of implication *)
  unfold incl.                (* unfolding the definition of inclusion *)
  intros.                     (* introduction of universal quantifiers and of implication *)
  unfold pre, In in H0.       (* unfolding the definition of Preimage in hypothesis H0 *)
  unfold im in H0.            (* unfolding the definition of Image in hypothesis H0 *)
  destruct H0 as [x1 [Hx1 Heq]].      (* elimination of conjuction and of existential quantifier in H0 *)
  apply H in Heq.              (* unfolding the definition of injectivity in hypothesis H3 *)
  rewrite Heq.                 (* rewrite H3 in the conclusion *)
  assumption.                 (* resolve a trivial goal *)
Qed.


Require Export Iron.Language.SystemF2Effect.Type.Exp.
Require Export Iron.Language.SystemF2Effect.Type.Relation.KindT.
Require Export Iron.Language.SystemF2Effect.Type.Operator.LiftTT.

(********************************************************************)
(* Region identifier is not mentioned in the given type. *)
Fixpoint FreshT (p : nat) (tt : ty) : Prop :=
 match tt with
 | TVar _               => True
 | TForall k t          => FreshT p t
 | TApp t1 t2           => FreshT p t1 /\ FreshT p t2
 | TSum t1 t2           => FreshT p t1 /\ FreshT p t2
 | TBot _               => True
 | TCon0 _              => True
 | TCon1 tc t1          => FreshT p t1
 | TCon2 tc t1 t2       => FreshT p t1 /\ FreshT p t2
 | TCap (TyCapRegion n) => ~(n = p)
 end.

(********************************************************************)
Lemma freshT_kind
 :  forall ke sp t k p
 ,  ~(In (SRegion p) sp)
 -> KindT  ke sp t k
 -> FreshT p t.
Proof.
 intros; gen ke k.
 induction t; snorm; inverts_kind; eauto 2.
 - unfold not in H.
   have HP: (p = p0 \/ not (p = p0)).
   destruct HP; subst; auto.
Qed.
Hint Resolve freshT_kind.

Lemma freshT_liftTT
 :  forall p n d t
 ,  FreshT p t
 =  FreshT p (liftTT n d t).
Proof.
 intros. gen n d.
 induction t; intros; espread; snorm; espread; eauto.
Qed.
Hint Resolve freshT_liftTT.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup finalg matrix.
Require Import Reals Lra.
From mathcomp Require Import Rstruct.
Require Import ssrR Reals_ext logb Rbigop.
Require Import fdist proba entropy aep.

(******************************************************************************)
(*                            Typical Sequences                               *)
(*                                                                            *)
(* Definitions:                                                               *)
(*   `TS P n epsilon == epsilon-typical sequence of size n given an input     *)
(*                      distribution P                                        *)
(*   TS_0            == the typical sequence of index 0                       *)
(*                                                                            *)
(* Lemmas:                                                                    *)
(*   TS_sup           == the total number of typical sequences is             *)
(*                       upper-bounded by 2 ^ (k * (H P + e))                 *)
(*   set_typ_seq_not0 == for k big enough, the set of typical sequences is    *)
(*                       not empty                                            *)
(*   TS_inf           == the total number of typical sequences is             *)
(*                       lower-bounded by (1 - e) * 2 ^ (k * (H P - e))       *)
(*                       for k big enough                                     *)
(*                                                                            *)
(* For details, see Reynald Affeldt, Manabu Hagiwara, and Jonas Sénizergues.  *)
(* Formalization of Shannon's theorems. Journal of Automated Reasoning,       *)
(* 53(1):63--103, 2014                                                        *)
(******************************************************************************)

Declare Scope typ_seq_scope.
Reserved Notation "'`TS'".

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope R_scope.
Local Open Scope fdist_scope.
Local Open Scope proba_scope.
Local Open Scope entropy_scope.

Section typical_sequence_definition.

Variables (A : finType) (P : fdist A) (n : nat) (epsilon : R).

Definition typ_seq (t : 'rV[A]_n) :=
  exp2 (- n%:R * (`H P + epsilon)) <b= P `^ n t <b= exp2 (- n%:R * (`H P - epsilon)).

Definition set_typ_seq := [set ta | typ_seq ta].

End typical_sequence_definition.

Notation "'`TS'" := (set_typ_seq) : typ_seq_scope.

Local Open Scope typ_seq_scope.

Lemma set_typ_seq_incl A (P : fdist A) n epsilon : 0 <= epsilon -> forall r, 1 <= r ->
  `TS P n (epsilon / 3) \subset `TS P n epsilon.
Proof.
move=> e0 r r1.
apply/subsetP => /= x.
rewrite !inE /typ_seq => /andP[/leRP H2 /leRP H3] [:Htmp].
apply/andP; split; apply/leRP.
- apply/(leR_trans _ H2)/Exp_le_increasing => //.
  rewrite !mulNR leR_oppr oppRK; apply leR_wpmul2l; first exact/leR0n.
  apply/leR_add2l.
  abstract: Htmp.
  rewrite leR_pdivr_mulr; [apply leR_pmulr => //|]; lra.
- apply/(leR_trans H3)/Exp_le_increasing => //.
  rewrite !mulNR leR_oppr oppRK; apply leR_wpmul2l; first exact/leR0n.
  apply leR_add2l; rewrite leR_oppr oppRK; exact Htmp.
Qed.

Section typ_seq_prop.

Variables (A : finType) (P : fdist A) (epsilon : R) (n : nat).

Lemma TS_sup : #| `TS P n epsilon |%:R <= exp2 (n%:R * (`H P + epsilon)).
Proof.
suff Htmp : #| `TS P n epsilon |%:R * exp2 (- n%:R * (`H P + epsilon)) <= 1.
  by rewrite -(mulR1 (exp2 _)) mulRC -leR_pdivr_mulr // /Rdiv -exp2_Ropp -mulNR.
rewrite -(FDist.f1 (P `^ n)).
rewrite (_ : _ * _ = \sum_(x in `TS P n epsilon) (exp2 (- n%:R * (`H P + epsilon)))); last first.
  by rewrite big_const iter_addR.
by apply/leR_sumRl => //= i; rewrite inE; case/andP => /leRP.
Qed.

Lemma typ_seq_definition_equiv x : x \in `TS P n epsilon ->
  exp2 (- n%:R * (`H P + epsilon)) <= P `^ n x <= exp2 (- n%:R * (`H P - epsilon)).
Proof. by rewrite inE /typ_seq => /andP[? ?]; split; apply/leRP. Qed.

Lemma typ_seq_definition_equiv2 x : x \in `TS P n.+1 epsilon ->
  `H P - epsilon <= - (1 / n.+1%:R) * log (P `^ n.+1 x) <= `H P + epsilon.
Proof.
rewrite inE /typ_seq.
case/andP => H1 H2; split;
  apply/leRP; rewrite -(leR_pmul2l' n.+1%:R) ?ltR0n' //;
  rewrite div1R mulRA mulRN mulRV ?INR_eq0' // mulN1R; apply/leRP.
- rewrite leR_oppr.
  apply/(@Exp_le_inv 2) => //.
  rewrite LogK //; last by apply/(ltR_leR_trans (exp2_gt0 _)); apply/leRP: H1.
  apply/leRP; by rewrite -mulNR.
- rewrite leR_oppl.
  apply/(@Exp_le_inv 2) => //.
  rewrite LogK //; last by apply/(ltR_leR_trans (exp2_gt0 _)); apply/leRP: H1.
  apply/leRP; by rewrite -mulNR.
Qed.

End typ_seq_prop.

Section typ_seq_more_prop.

Variables (A : finType) (P : fdist A) (epsilon : R) (n : nat).

Hypothesis He : 0 < epsilon.

Lemma Pr_TS_1 : aep_bound P epsilon <= n.+1%:R ->
  1 - epsilon <= Pr (P `^ n.+1) (`TS P n.+1 epsilon).
Proof.
move=> k0_k.
have -> : Pr P `^ n.+1 (`TS P n.+1 epsilon) =
  Pr P `^ n.+1 [set i | (i \in `TS P n.+1 epsilon) && (0 <b P `^ n.+1 i)].
  congr Pr; apply/setP => /= t; rewrite !inE.
  apply/idP/andP => [H|]; [split => // | by case].
  case/andP : H => /leRP H _; exact/ltRP/(ltR_leR_trans (exp2_gt0 _) H).
set p := [set _ | _].
rewrite Pr_to_cplt leR_add2l leR_oppl oppRK.
have -> : Pr P `^ n.+1 (~: p) =
  Pr P `^ n.+1 [set x | P `^ n.+1 x == 0] +
  Pr P `^ n.+1 [set x | (0 <b P `^ n.+1 x) &&
                (`| - (1 / n.+1%:R) * log (P `^ n.+1 x) - `H P | >b epsilon)].
  have -> : ~: p =
    [set x | P `^ n.+1 x == 0 ] :|:
    [set x | (0 <b P `^ n.+1 x) &&
             (`| - (1 / n.+1%:R) * log (P `^ n.+1 x) - `H P | >b epsilon)].
    apply/setP => /= i; rewrite !inE negb_and orbC.
    apply/idP/idP => [/orP[/ltRP|]|].
    - by rewrite -fdist_gt0 => /negP; rewrite negbK => ->.
    - rewrite /typ_seq negb_and => /orP[|] LHS.
      + case/boolP : (P `^ n.+1 i == 0) => /= H1; first by [].
        have {}H1 : 0 < P `^ n.+1 i.
          apply/ltRP; rewrite ltR_neqAle' eq_sym H1; exact/leRP.
        apply/andP; split; first exact/ltRP.
        move: LHS; rewrite -ltRNge' => /ltRP/(@Log_increasing 2 _ _ Rlt_1_2 H1).
        rewrite /exp2 ExpK // mulRC mulRN -mulNR -ltR_pdivr_mulr; last exact/ltR0n.
        rewrite /Rdiv mulRC ltR_oppr => /ltRP; rewrite mulNR -ltR_subRL' => LHS.
        rewrite mul1R geR0_norm //; by move/ltRP : LHS; move/(ltR_trans He)/ltRW.
      + move: LHS; rewrite leRNgt' negbK => /ltRP LHS.
        apply/orP; right; apply/andP; split; first exact/ltRP/(ltR_trans (exp2_gt0 _) LHS).
        move/(@Log_increasing 2 _ _ Rlt_1_2 (exp2_gt0 _)) : LHS.
        rewrite /exp2 ExpK // mulRC mulRN -mulNR -ltR_pdivl_mulr; last exact/ltR0n.
        rewrite oppRD oppRK => LHS.
        have H2 : forall a b c, - a + b < c -> - c - a < - b by move=> *; lra.
        move/H2 in LHS.
        rewrite div1R mulRC mulRN -/(Rdiv _ _) leR0_norm.
        * apply/ltRP; by rewrite ltR_oppr.
        * apply: (leR_trans (ltRW LHS)); lra.
    - rewrite -negb_and; apply: contraTN.
      rewrite negb_or /typ_seq => /andP[H1 /andP[/leRP H2 /leRP H3]].
      apply/andP; split; first exact/gtR_eqF/ltRP.
      rewrite negb_and H1 /= -leRNgt'.
      move/(@Log_increasing_le 2 _ _ Rlt_1_2 (exp2_gt0 _)) : H2.
      rewrite /exp2 ExpK // mulRC mulRN -mulNR -leR_pdivl_mulr ?oppRD; last exact/ltR0n.
      move => H2.
      have /(_ _ _ _ H2) {}H2 : forall a b c, - a + - b <= c -> - c - a <= b.
        by move=> *; lra.
      move/ltRP in H1.
      move/(@Log_increasing_le 2 _ _ Rlt_1_2 H1) : H3.
      rewrite /exp2 ExpK //.
      rewrite mulRC mulRN -mulNR -leR_pdivr_mulr; last exact/ltR0n.
      rewrite oppRD oppRK div1R mulRC mulRN => H3.
      have /(_ _ _ _ H3) {}H3 : forall a b c, a <= - c + b -> - b <= - a - c.
        by move=> *; lra.
      rewrite leR_Rabsl; apply/andP; split; exact/leRP.
  rewrite Pr_union_disj // disjoints_subset; apply/subsetP => /= i.
  rewrite !inE /= => /eqP Hi; by rewrite negb_and Hi ltRR'.
rewrite {1}/Pr (eq_bigr (fun=> 0)); last by move=> /= v; rewrite inE => /eqP.
rewrite big_const iter_addR mulR0 add0R.
apply/(leR_trans _ (aep He k0_k))/Pr_incl/subsetP => /= t.
rewrite !inE /= => /andP[-> /= H3]; apply/ltRW'.
by rewrite /log_RV /= /scalel_RV /= mulRN -mulNR.
Qed.

Variable He1 : epsilon < 1.

Lemma set_typ_seq_not0 : aep_bound P epsilon <= n.+1%:R ->
  #| `TS P n.+1 epsilon | <> O.
Proof.
move/Pr_TS_1 => H.
case/boolP : (#| `TS P n.+1 epsilon | == O) => [|Heq]; last by apply/eqP.
rewrite cards_eq0 => /eqP Heq.
rewrite Heq Pr_set0 in H.
lra.
Qed.

Definition TS_0 (H : aep_bound P epsilon <= n.+1%:R) : [finType of 'rV[A]_n.+1].
apply (@enum_val _ (pred_of_set (`TS P n.+1 epsilon))).
have -> : #| `TS P n.+1 epsilon| = #| `TS P n.+1 epsilon|.-1.+1.
  rewrite prednK //.
  move/set_typ_seq_not0 in H.
  rewrite lt0n; by apply/eqP.
exact ord0.
Defined.

Lemma TS_0_is_typ_seq (k_k0 : aep_bound P epsilon <= n.+1%:R) :
  TS_0 k_k0 \in `TS P n.+1 epsilon.
Proof. rewrite /TS_0. apply/enum_valP. Qed.

Lemma TS_inf : aep_bound P epsilon <= n.+1%:R ->
  (1 - epsilon) * exp2 (n.+1%:R * (`H P - epsilon)) <= #| `TS P n.+1 epsilon |%:R.
Proof.
move=> k0_k.
have H1 : 1 - epsilon <= Pr (P `^ n.+1) (`TS P n.+1 epsilon) <= 1.
  split; by [apply Pr_TS_1 | apply Pr_1].
have H2 : (forall x, x \in `TS P n.+1 epsilon ->
  exp2 (- n.+1%:R * (`H P + epsilon)) <= P `^ n.+1 x <= exp2 (- n.+1%:R * (`H P - epsilon))).
  by move=> x; rewrite inE /typ_seq => /andP[/leRP ? /leRP].
move: (wolfowitz (exp2_gt0 _) (exp2_gt0 _) H1 H2).
by rewrite mulNR exp2_Ropp {1}/Rdiv invRK ?gtR_eqF //; case.
Qed.

End typ_seq_more_prop.


Require Import Ssreflect.ssreflect.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module Test.

Variable A : Type.

Theorem counterexample P : (exists x : A, ~P x) -> ~(forall x, P x).
Proof.
by case=>x H1 H2; apply: H1 (H2 x).
Qed.

Print counterexample.

End Test.


Inductive even : nat -> Prop :=
    | ev_0 : even 0
    | ev_SS : forall n, even n -> even (S (S n)).

Theorem ev_8 : even 8.
Proof.
apply ev_SS.
apply ev_SS.
apply ev_SS.
apply ev_SS.
apply ev_0.
Qed.


Require Import Frap.

Theorem another_important_theorem : length [1; 2; 3] = 1 + length [4; 5].
Proof.
  simplify.
  equality.
Qed.

Theorem length_concat : forall A (xs ys : list A), length (xs ++ ys) = length xs + length ys.
Proof.
  induct xs.
  induct ys.
  simplify.
  equality.

  simplify.
  equality.

  simplify.
  f_equal.
  rewrite IHxs.
  equality.
Qed.

Theorem length_rev : forall A (xs : list A), length xs = length (rev xs).
Proof.
  induct xs.
  simplify.
  equality.
  simplify.
  rewrite length_concat.
  simplify.
  linear_arithmetic.
Qed.


Require Import BinNums Nat List.
Require Import Omega.

Require Import LibUtils Isomorphism.
Import ListNotations.

Module Internal.
Inductive BinaryDigit
  := | bin_digit0 | bin_digit1.

Fixpoint pos_to_digits (p:positive) : list BinaryDigit
  := match p with
     | xI p' => bin_digit1 :: (pos_to_digits p')
     | xO p' => bin_digit0 :: (pos_to_digits p')
     | xH => [bin_digit1]
     end.

Definition N_to_digits (n:N) : list BinaryDigit
  := match n with
     | N0 => nil
     | Npos p => pos_to_digits p
     end.

Fixpoint digits_to_pos (l:list BinaryDigit) : positive
  := match l with
     | nil => xH
     | [ _ ] => xH
     | bin_digit0 :: l' => xO (digits_to_pos l')
     | bin_digit1 :: l' => xI (digits_to_pos l')
     end.

Fixpoint cleanup_zeros (l:list BinaryDigit) : list BinaryDigit
  := match l with
     | nil => nil
     | bin_digit0 :: l => cleanup_zeros l
     | _ => l
     end.

Definition fixup_trailing_zeros l
  := (rev (cleanup_zeros (rev l))).

Lemma cleanup_zeros_app_middle l1 l2 : cleanup_zeros (l1 ++ bin_digit1::l2) = (cleanup_zeros l1 ++ bin_digit1::l2).
Proof.
  revert l2.
  induction l1; simpl; trivial; intros.
  destruct a; eauto.
Qed.

Lemma fixup_trailing_zeros_app_middle l1 l2 : fixup_trailing_zeros (l1 ++ bin_digit1::l2) = (l1 ++ bin_digit1::fixup_trailing_zeros l2).
Proof.
 unfold fixup_trailing_zeros.
 rewrite rev_app_distr.
 simpl.
 rewrite app_ass; simpl.
 rewrite cleanup_zeros_app_middle.
 rewrite rev_app_distr.
 simpl.
 rewrite rev_involutive.
 rewrite <- app_assoc.
 simpl.
 reflexivity.
Qed.

Lemma fixup_trailing_zeros_end0 l1 : fixup_trailing_zeros (l1 ++ [bin_digit0]) = fixup_trailing_zeros l1.
Proof.
  unfold fixup_trailing_zeros.
  rewrite rev_app_distr.
  simpl; trivial.
Qed.

Lemma fixup_trailing_zeros_end1 l1 : fixup_trailing_zeros (l1 ++ [bin_digit1]) = l1 ++ [bin_digit1].
Proof.
  unfold fixup_trailing_zeros.
  rewrite rev_app_distr.
  simpl.
  rewrite rev_involutive.
  trivial.
Qed.

Definition digits_to_N (l:list BinaryDigit) : N
       := let l_clean := fixup_trailing_zeros l in
          match l_clean with
          | nil => N0
          | _ => Npos (digits_to_pos l_clean)
          end.

Lemma pos_to_digits_nnil p : pos_to_digits p <> nil.
Proof.
  destruct p; simpl; congruence.
Qed.

Definition canon_digits digits := { ld | digits = ld ++ [bin_digit1] }.

Lemma canon_digits_dec digits : canon_digits digits + {last digits bin_digit0 = bin_digit0}.
Proof.
  unfold canon_digits.
  induction digits; simpl.
  - right; trivial.
  - destruct IHdigits.
    + destruct s as [ld pf].
      left.
      rewrite pf.
      exists (a::ld); simpl.
      trivial.
    + destruct digits.
      * destruct a; simpl; [eauto | ].
        left; exists nil; simpl.
        trivial.
      * right; trivial.
Qed.

Lemma cleanup_zeros_form l :
  {l1 |
       l = l1 ++ cleanup_zeros l
       /\ (forall x, In x l1 -> x = bin_digit0)
       /\ (forall a l2, cleanup_zeros l = a::l2 -> a = bin_digit1)}.
Proof.
  induction l.
  - exists nil; simpl.
    intuition congruence.
  - destruct IHl as [l1 [H1 [H2 H3]]].
    destruct a.
    + exists (bin_digit0 :: l1).
      simpl.
      rewrite <- H1.
      intuition.
    + exists nil; simpl; intuition congruence.
Qed.

Lemma cleanup_zeros_zero digits :
  cleanup_zeros digits = nil <-> Forall (eq bin_digit0) digits.
Proof.
  rewrite Forall_forall.
  induction digits; simpl.
  - intuition.
  - destruct a; simpl.
    + intuition.
    + split; intros HH.
      * discriminate.
      * specialize (HH bin_digit1).
        { cut_to HH.
          - discriminate.
          - eauto.
        }
Qed.

Lemma fixup_trailing_zeros_canon digits :
  canon_digits (fixup_trailing_zeros digits) +
  {Forall (eq bin_digit0) digits}.
Proof.
  unfold canon_digits, fixup_trailing_zeros.
  case_eq (cleanup_zeros (rev digits)); intros eqq.
  - destruct (cleanup_zeros_zero (rev digits)).
    specialize (H eqq).
    right.
    rewrite Forall_forall in *.
    intros x xin.
    apply H.
    apply -> in_rev.
    trivial.
  - intros.
    destruct (cleanup_zeros_form (rev digits))
      as [l1 [H1 [H2 H3]]].
    left.
    rewrite (H3 _ _ H).
    simpl.
    eauto.
Qed.

Lemma fixup_trailing_zeros_canon_if digits :
  ~ Forall (eq bin_digit0) digits ->
  canon_digits (fixup_trailing_zeros digits).
Proof.
  intros.
  destruct (fixup_trailing_zeros_canon digits); tauto.
Qed.

Lemma fixup_trailing_zeros_of_canon digits :
  canon_digits digits ->
  fixup_trailing_zeros digits = digits.
Proof.
  intros [l leq].
  unfold fixup_trailing_zeros.
  rewrite leq.
  rewrite rev_app_distr.
  simpl.
  rewrite rev_involutive.
  reflexivity.
Qed.

Lemma Forall_rev {A} P (l:list A) : Forall P l <-> Forall P (rev l).
Proof.
  repeat rewrite Forall_forall.
  intuition.
  - eapply H.
    apply in_rev; trivial.
  - eapply H.
    apply in_rev; trivial.
    rewrite rev_involutive; trivial.
Qed.

Lemma fixup_trailing_zeros_zero digits :
  fixup_trailing_zeros digits = nil <-> Forall (eq bin_digit0) digits.
Proof.
  unfold fixup_trailing_zeros.
  split; intros.
  - assert (rr: rev (rev (cleanup_zeros (rev digits))) = rev []) by congruence.
    rewrite rev_involutive in rr.
    simpl in rr.
    apply cleanup_zeros_zero in rr.
    apply Forall_rev; trivial.
  - apply Forall_rev in H.
    apply cleanup_zeros_zero in H.
    rewrite H.
    reflexivity.
Qed.

Lemma pos_to_digits_canon p : canon_digits (pos_to_digits p).
Proof.
  induction p; simpl.
  - destruct IHp.
    rewrite e.
    exists (bin_digit1 :: x).
    reflexivity.
  - destruct IHp.
    rewrite e.
    exists (bin_digit0 :: x).
    reflexivity.
  - exists nil.
    reflexivity.
Qed.

Lemma digits_to_pos_to_digits p : digits_to_pos (pos_to_digits p) = p.
Proof.
  induction p; simpl.
  - rewrite IHp.
    generalize (pos_to_digits_nnil p).
    destruct (pos_to_digits p); intuition.
  - generalize (pos_to_digits_nnil p).
    rewrite IHp.
    destruct (pos_to_digits p); intuition.
  - trivial.
Qed.

Lemma digits_to_N_to_digits n : digits_to_N (N_to_digits n) = n.
Proof.
  destruct n; simpl; trivial.
  unfold digits_to_N.
  rewrite fixup_trailing_zeros_of_canon.
  - rewrite digits_to_pos_to_digits.
    generalize (pos_to_digits_nnil p).
    destruct (pos_to_digits p); intuition.
  - apply pos_to_digits_canon.
Qed.

Lemma cleanup_zeros_app_repeat l d : cleanup_zeros ((repeat bin_digit0 d) ++ l) = cleanup_zeros l.
Proof.
  induction d; simpl; trivial.
Qed.

Lemma repeat_plus_app  {A} (d:A) n1 n2 : repeat d (n1+n2) = repeat d n1 ++ repeat d n2.
Proof.
  revert n2.
  induction n1; simpl; trivial; intros.
  rewrite IHn1; trivial.
Qed.

Lemma repeat_rev {A} (d:A) n : rev (repeat d n) = repeat d n.
Proof.
  induction n; trivial.
  transitivity (repeat d (n + 1)).
  - rewrite repeat_plus_app.
    simpl.
    rewrite IHn.
    trivial.
  - f_equal.
    omega.
Qed.

Lemma fixup_trailing_zeros_app_repeat x d : fixup_trailing_zeros (x ++ repeat bin_digit0 d) = fixup_trailing_zeros x.
Proof.
 unfold fixup_trailing_zeros.
 rewrite rev_app_distr.
 rewrite repeat_rev.
 rewrite cleanup_zeros_app_repeat.
 trivial.
Qed.

Lemma digits_to_N_to_digits_rep n x : digits_to_N (N_to_digits n ++ repeat bin_digit0 x) = n.
Proof.
  unfold digits_to_N.
  rewrite fixup_trailing_zeros_app_repeat.
  apply digits_to_N_to_digits.
Qed.

Lemma digits_to_N_pos_to_digits_rep p x : digits_to_N (pos_to_digits p ++ repeat bin_digit0 x) = Npos p.
Proof.
  generalize (digits_to_N_to_digits_rep (Npos p) x).
  simpl; trivial.
Qed.

Lemma pos_to_digits_to_pos digits :
  canon_digits digits ->
  pos_to_digits (digits_to_pos digits) = digits.
Proof.
  induction digits; simpl.
  - intros [? ?].
    symmetry in e.
    apply app_eq_nil in e.
    destruct e.
    discriminate.
  - intros [ld eqq].
    destruct ld; simpl in eqq; inversion eqq; clear eqq.
    + reflexivity.
    + subst.
      cut_to IHdigits; [ | eauto].
      destruct b; simpl.
      * destruct (ld ++ [bin_digit1]); simpl in *; congruence.
      * destruct (ld ++ [bin_digit1]); simpl in *; congruence.
      * eexists; reflexivity.
Qed.

Lemma N_to_digits_to_N_fixup digits :
  N_to_digits (digits_to_N digits) = fixup_trailing_zeros digits.
Proof.
  intros.
  unfold N_to_digits, digits_to_N.
  generalize (fixup_trailing_zeros_canon digits); intros.
  destruct H.
  - destruct (fixup_trailing_zeros digits); trivial.
    apply pos_to_digits_to_pos; trivial.
  - apply fixup_trailing_zeros_zero in f.
    rewrite f; trivial.
Qed.

Lemma N_to_digits_to_N digits :
  canon_digits digits ->
  N_to_digits (digits_to_N digits) = digits.
Proof.
  intros.
  unfold N_to_digits, digits_to_N.
  rewrite fixup_trailing_zeros_of_canon by trivial.
  destruct digits; trivial.
  apply pos_to_digits_to_pos; trivial.
Qed.

Fixpoint interleave {A:Type} (l1 l2 : list A) {struct l1} : list A
  := match l1, l2 with
     | nil, l2 => l2
     | l1, nil => l1
     | x::l1', y::l2' => x::y::(interleave l1' l2')
     end.

Lemma interleave_length_eq {A:Type} (l1 l2 : list A) :
  length (interleave l1 l2) = length l1 + length l2.
Proof.
  revert l2.
  induction l1; destruct l2; simpl in *; trivial.
  - auto.
  - rewrite IHl1.
    omega.
Qed.

Fixpoint uninterleave {A:Type} (l : list A) : (list A*list A)
  := match l with
     | x::y::l' => let (l1,l2) := uninterleave l' in
                   (x::l1,y::l2)
     | _ => (nil, nil)
     end.

Lemma uninterleave_interleave {A:Type} (l1 l2:list A) :
  length l1 = length l2 ->
  (uninterleave (interleave l1 l2)) = (l1, l2).
Proof.
  revert l2.
  induction l1; destruct l2; simpl; trivial; intros eqq; try discriminate.
  inversion eqq; clear eqq.
  rewrite (IHl1 _ H0).
  trivial.
Qed.

Lemma uninterleave_unfold {A:Type} (l:list A) a b :
  (uninterleave (a::b::l)) = (a::(fst (uninterleave l)), b::(snd (uninterleave l))).
Proof.
  simpl.
  destruct (uninterleave l); simpl; trivial.
Qed.

Program Fixpoint EvenList_ind {A:Type} (P:list A->Prop)
    (pfnil:P nil)
    (pfconscons:forall a b l, P l -> P (a::b::l)) l {struct l} :
  Nat.Even (length l) -> P l
  := fun pfl =>
       match l with
       | nil => pfnil
       | x::y::l => pfconscons x y l (EvenList_ind P pfnil pfconscons l _)
       | _::_ => _
       end.
Next Obligation.
  destruct pfl as [n npf].
  simpl in npf.
  exists (n-1).
  destruct n; simpl; [omega | ].
  destruct n; simpl; [omega | ].
  simpl in npf.
  inversion npf.
  omega.
Qed.
Next Obligation.
  destruct (wildcard'0); simpl in *.
  - destruct pfl as [? ?]; omega.
  - elim (H _ _ _ (eq_refl _)).
Qed.

Lemma uninterleave_odd_skip {A:Type} (l:list A) a :
  Nat.Even (length l) ->
  (uninterleave (l ++ [a])) = uninterleave l.
Proof.
  intros pfeven.
  revert a.
  pattern l.
  revert l pfeven.
  apply EvenList_ind.
  - simpl; trivial.
  - intros.
    replace ((a :: b :: l) ++ [a0]) with (a :: b :: (l ++ [a0])) by reflexivity.
    repeat rewrite uninterleave_unfold.
    rewrite H.
    trivial.
Qed.

Lemma uninterleave_even_end {A:Type} (l:list A) a b :
  Nat.Even (length l) ->
  (uninterleave (l ++ [a;b])) = (fst (uninterleave l) ++ [a], snd (uninterleave l) ++ [b]).
Proof.
  intros pfeven.
  revert a b.
  pattern l.
  revert l pfeven.
  apply EvenList_ind.
  - simpl; trivial.
  - intros.
    replace ((a :: b :: l) ++ [a0; b0]) with (a :: b :: (l ++ [a0; b0])) by reflexivity.
    repeat rewrite uninterleave_unfold.
    rewrite H.
    trivial.
Qed.

Lemma interleave_uninterleave {A:Type} (l:list A) :
  Nat.Even (length l) ->
  (interleave (fst (uninterleave l)) (snd (uninterleave l))) = l.
Proof.
  revert l.
  apply EvenList_ind; simpl; trivial.
  intros.
  destruct (uninterleave l); simpl in *.
  congruence.
Qed.

Definition interleave_with_end_padding {A:Type} (l1:list A) (def1:A) (l2:list A) (def2:A) : list A
 := interleave (l1 ++ repeat def1 (length l2 - length l1)) (l2 ++ repeat def2 (length l1 - length l2)).

Lemma interleave_with_end_padding_ge {A:Type} (l1:list A) (def1:A) (l2:list A) (def2:A) :
  length l1 >= length l2 ->
  interleave_with_end_padding l1 def1 l2 def2 = interleave l1 (l2 ++ repeat def2 (length l1 - length l2)).
Proof.
  unfold interleave_with_end_padding.
  intros.
  f_equal.
  replace (length l2 - length l1) with 0 by omega.
  simpl.
  rewrite <- app_nil_end; trivial.
Qed.

Lemma interleave_with_end_padding_le {A:Type} (l1:list A) (def1:A) (l2:list A) (def2:A) :
  length l1 <= length l2 ->
  interleave_with_end_padding l1 def1 l2 def2 = interleave (l1 ++ repeat def1 (length l2 - length l1)) l2.
Proof.
  unfold interleave_with_end_padding.
  intros.
  f_equal.
  replace (length l1 - length l2) with 0 by omega.
  simpl.
  rewrite <- app_nil_end; trivial.
Qed.

Lemma interleave_with_end_padding_eq {A:Type} (l1:list A) (def1:A) (l2:list A) (def2:A) :
  length l1 = length l2 ->
  interleave_with_end_padding l1 def1 l2 def2 = interleave l1 l2.
Proof.
  intros.
  unfold interleave_with_end_padding.
  intros.
  replace (length l1 - length l2) with 0 by omega.
  replace (length l2 - length l1) with 0 by omega.
  simpl.
  repeat rewrite <- app_nil_end; trivial.
Qed.

Definition encode_digits_pair (x y : list BinaryDigit) : list BinaryDigit
  := interleave_with_end_padding x bin_digit0 y bin_digit0.

Definition decode_digits_pair (xy : list BinaryDigit) : (list BinaryDigit * list BinaryDigit)
  := uninterleave xy.

Definition encode_pair (x:N) (y:N) : N
  := digits_to_N (encode_digits_pair (N_to_digits x) (N_to_digits y)).

Definition make_even_digits digits
  := if Nat.even (length digits) then digits else (digits ++ [bin_digit0]).

Definition decode_pair_to_digits (xy:N) : (list BinaryDigit)*(list BinaryDigit)
  :=  let digits := N_to_digits xy in
       let digits' := make_even_digits digits in
       decode_digits_pair digits'.

Definition decode_pair (xy:N) : N*N
  := if N.eq_dec xy 0 then (0,0)%N else
       let xypair := decode_pair_to_digits xy in
       (digits_to_N (fst xypair), digits_to_N (snd xypair)).

(* Definition canon_digits digits := { ld | digits = ld ++ [bin_digit1] }. *)

Lemma decode_pair_to_digits_digits_to_N digits :
  canon_digits digits ->
  decode_pair_to_digits (digits_to_N digits) = uninterleave (make_even_digits digits).
Proof.
  intros canon.
  unfold decode_pair_to_digits.
  rewrite N_to_digits_to_N; trivial.
Qed.

Lemma interleave_in1 {A} (l1 l2:list A) :
  forall x,
  In x l1 ->
  In x (interleave l1 l2).
Proof.
  revert l2.
  induction l1; simpl.
  - intuition.
  - intros l2 x [eqq |inx].
    + subst.
      destruct l2; simpl; tauto.
    + destruct l2; simpl; eauto.
Qed.

Lemma interleave_in2 {A} (l1 l2:list A) :
  forall x,
  In x l2 ->
  In x (interleave l1 l2).
Proof.
  revert l2.
  induction l1; simpl.
  - intuition.
  - intros l2 x eqq.
    destruct l2; simpl in *; intuition eauto.
Qed.

Lemma in_interleave  {A} (l1 l2:list A) :
  forall x,
    In x (interleave l1 l2) ->
    In x l1 \/ In x l2.
Proof.
  revert l2.
  induction l1; simpl; [ eauto | ].
  destruct l2; simpl; [eauto | ].
  intuition subst.
  destruct (IHl1 _ _ H); tauto.
Qed.

Lemma interleave_with_end_padding_in1 {A} (l1 l2:list A) def1 def2:
  forall x,
  In x l1 ->
  In x (interleave_with_end_padding l1 def1 l2 def2).
Proof.
  unfold interleave_with_end_padding.
  intros.
  apply interleave_in1.
  rewrite in_app_iff.
  eauto.
Qed.

Lemma interleave_with_end_padding_in2 {A} (l1 l2:list A) def1 def2:
  forall x,
  In x l2 ->
  In x (interleave_with_end_padding l1 def1 l2 def2).
Proof.
  unfold interleave_with_end_padding.
  intros.
  apply interleave_in2.
  rewrite in_app_iff.
  eauto.
Qed.

Lemma in_interleave_with_end_padding {A} (l1 l2:list A) def1 def2:
  forall x,
    In x (interleave_with_end_padding l1 def1 l2 def2) ->
    In x l1 \/ In x l2 \/ x = def1 \/ x = def2.
Proof.
  Hint Resolve repeat_spec : list.
  intros.
  destruct (in_interleave _ _ x H)
  ; rewrite in_app_iff in *
  ; intuition eauto with list.
Qed.

Lemma encode_digits_pair0 l1 l2 :
  Forall (eq bin_digit0) (encode_digits_pair l1 l2) <->
  Forall (eq bin_digit0) l1 /\
  Forall (eq bin_digit0) l2.
Proof.
  unfold encode_digits_pair.
  repeat rewrite Forall_forall.
  split; intros HH.
  - intuition eauto using interleave_with_end_padding_in1,interleave_with_end_padding_in2.
  - intros ? inn.
    apply in_interleave_with_end_padding in inn.
    intuition eauto.
Qed.

Lemma N_to_digits0 n : Forall (eq bin_digit0) (N_to_digits n) <-> n = 0%N.
Proof.
  rewrite Forall_forall.
  destruct n; simpl; [tauto | ].
  split; intros.
  - specialize (H bin_digit1).
    destruct (pos_to_digits_canon p) as [? eqq].
    cut_to H; [discriminate | ].
    rewrite eqq, in_app_iff.
    simpl.
    eauto.
  - discriminate.
Qed.

Lemma digits_to_N_fixup_encode_0 n1 n2 :
  digits_to_N (encode_digits_pair (N_to_digits n1) (N_to_digits n2)) = 0%N ->
  n1 = 0%N /\ n2 = 0%N.
Proof.
  intros HH.
  unfold digits_to_N in HH.
  destruct (fixup_trailing_zeros_canon (encode_digits_pair (N_to_digits n1) (N_to_digits n2))).
  - destruct c as [? eqq].
    rewrite eqq in HH.
    unfold digits_to_N in HH.
    destruct x; simpl in *; discriminate.
  - apply encode_digits_pair0 in f.
    destruct f as [f1 f2].
    apply N_to_digits0 in f1.
    apply N_to_digits0 in f2.
    eauto.
Qed.

Lemma interleave_decompose {A} (digits1 digits2:list A) :
  digits1 <> nil ->
  length digits1 = length digits2 ->
 exists (l : list A),
    forall d1 d2 : A,
    interleave digits1 digits2 =
    l ++ [last digits1 d1; last digits2 d2].
Proof.
  revert digits2.
  induction digits1; [intuition | ].
  destruct digits2; simpl; intros; [discriminate | ].
  destruct digits1; simpl.
  - destruct digits2; simpl in *; [ | omega].
    exists nil; simpl; trivial.
  - destruct digits2; simpl in *; try discriminate.
    inversion H0.
    specialize (IHdigits1 (a2::digits2)).
    simpl in IHdigits1.
    destruct IHdigits1 as [l leq]
    ; intuition (try congruence).
    exists (a::a0::l).
    intros d1 d2.
    rewrite (leq d1 d2).
    simpl; trivial.
Qed.

Lemma last_app_nnil {A:Type} (l1 l2:list A) (d:A) :
  l2 <> nil ->
  last (l1 ++ l2) d = last l2 d.
Proof.
  intros.
  induction l1; simpl; trivial.
  rewrite IHl1.
  assert (l1 ++ l2 <> nil).
  { intros eqq. apply app_eq_nil in eqq. intuition. }
  destruct (l1 ++ l2); congruence.
Qed.

Lemma last_repeat_nzero {A:Type} (a:A) n d : n > 0 -> last (repeat a n) d = a.
Proof.
  induction n; [omega | ].
  simpl.
  destruct n; simpl in *; trivial.
  intuition.
Qed.

Lemma last_repeat_same {A:Type} (a:A) n : last (repeat a n) a = a.
Proof.
  destruct n.
  - reflexivity.
  - rewrite last_repeat_nzero; trivial.
    omega.
Qed.

Lemma interleave_with_end_padding_decompose_eq {A} (digits1:list A) defA digits2 defB :
  digits1 <> nil ->
  length digits1 = length digits2 ->
  exists l,
  forall d1 d2,
    interleave_with_end_padding digits1 defA digits2 defB = l ++ [last digits1 d1; last digits2 d2].
Proof.
  intros.
  rewrite interleave_with_end_padding_eq by omega.
  destruct (interleave_decompose digits1 digits2)
    as [l eql]; trivial.
  eauto.
Qed.

Lemma interleave_with_end_padding_decompose_gt {A} (digits1:list A) defA digits2 defB :
  length digits1 > length digits2 ->
  exists l,
  forall d,
    interleave_with_end_padding digits1 defA digits2 defB = l ++ [last digits1 d; defB].
Proof.
  intros.
  rewrite interleave_with_end_padding_ge by omega.
  destruct (interleave_decompose digits1 (digits2 ++ repeat defB (length digits1 - length digits2)))
    as [l eql].
  - destruct digits1; simpl in *; try congruence.
    omega.
  - rewrite app_length, repeat_length.
    omega.
  - exists l.
    intros d.
    rewrite (eql d defB); simpl.
    rewrite last_app_nnil.
    + rewrite last_repeat_same; trivial.
    + assert ((length digits1 - length digits2) <> 0) by omega.
      destruct (length digits1 - length digits2); simpl; intros; congruence.
Qed.

Lemma interleave_with_end_padding_decompose_lt {A} (digits1:list A) defA digits2 defB :
  length digits1 < length digits2 ->
  exists l,
  forall d,
    interleave_with_end_padding digits1 defA digits2 defB = l ++ [defA ; last digits2 d].
Proof.
  intros.
  rewrite interleave_with_end_padding_le by omega.
  destruct (interleave_decompose (digits1 ++ repeat defA (length digits2 - length digits1)) digits2)
           as [l eql].
  - intros ?; subst.
    destruct digits2; simpl in *.
    + omega.
    + destruct digits1; try discriminate.
  - rewrite app_length, repeat_length.
    omega.
  - exists l.
    intros d.
    rewrite (eql defA d); simpl.
    rewrite last_app_nnil.
    + rewrite last_repeat_same; trivial.
    + assert ((length digits2 - length digits1) <> 0) by omega.
      destruct (length digits2 - length digits1); simpl; intros; congruence.
Qed.

Lemma is_nil {A:Type} (l:list A) : {l = nil} + {l <> nil}.
Proof.
  destruct l.
  - left; trivial.
  - right; intro; discriminate.
Defined.

Lemma interleave_with_end_padding_Even {A:Type} (l1:list A) (def1:A) (l2:list A) (def2:A) :
  Nat.Even (length (interleave_with_end_padding l1 def1 l2 def2)).
Proof.
  unfold interleave_with_end_padding.
  rewrite interleave_length_eq.
  repeat rewrite app_length, repeat_length.
  destruct (Nat.lt_trichotomy (length l1) (length l2))
    as [nlt | [neq | ngt]].
  - exists (length l2); omega.
  - exists (length l2); omega.
  - exists (length l1); omega.
Qed.

Lemma interleave_with_end_padding_even {A:Type} (l1:list A) (def1:A) (l2:list A) (def2:A) :
  Nat.even (length (interleave_with_end_padding l1 def1 l2 def2)) = true.
Proof.
  apply Nat.even_spec.
  apply interleave_with_end_padding_Even.
Qed.

Lemma fixup_trailing_zeros_app_two x d : fixup_trailing_zeros (x ++ [d; bin_digit1]) = (x ++ [d; bin_digit1]).
Proof.
 unfold fixup_trailing_zeros.
 rewrite rev_app_distr.
 simpl.
 rewrite rev_involutive.
 rewrite <- app_assoc.
 simpl.
 reflexivity.
Qed.

Definition padded_interleave_result n1 n2 :
  n1 <> 0%N \/ n2 <> 0%N ->
  (exists l, (interleave_with_end_padding (N_to_digits n1) bin_digit0 (N_to_digits n2) bin_digit0) = l ++ [bin_digit1]) \/
  (exists l, (interleave_with_end_padding (N_to_digits n1) bin_digit0 (N_to_digits n2) bin_digit0) = l ++ [bin_digit1 ; bin_digit0]).
Proof.
  simpl.
  destruct (Nat.lt_trichotomy (length (N_to_digits n1)) (length (N_to_digits n2)))
           as [n1lt | [n1eq | n1gt]].
  - destruct (interleave_with_end_padding_decompose_lt (N_to_digits n1) bin_digit0 (N_to_digits n2) bin_digit0); trivial.
    destruct n2; simpl.
    + simpl in n1lt.
      omega.
    + specialize (H bin_digit0).
      destruct (pos_to_digits_canon p) as [l leq].
      simpl in *.
      rewrite leq in *.
      rewrite last_app_nnil in H by discriminate.
      simpl in H.
      left; exists (x++ [bin_digit0]).
      rewrite app_ass; simpl.
      eauto.
  - destruct n1; simpl in *.
    + destruct n2; simpl in n1eq.
      * intuition congruence.
      * intros.
        destruct p; simpl in *; discriminate.
    + destruct (interleave_with_end_padding_decompose_eq (pos_to_digits p) bin_digit0 (N_to_digits n2) bin_digit0); trivial.
      * apply pos_to_digits_nnil.
      * intros.
        rewrite (H bin_digit0 bin_digit0).
        left.
        exists (x ++ [last (pos_to_digits p) bin_digit0]).
        rewrite app_ass; simpl.
        { destruct n2.
          - destruct p; simpl in n1eq; discriminate.
          - simpl.
            destruct (pos_to_digits_canon p0) as [l leq].
            simpl in *.
            rewrite leq.
            rewrite last_app_nnil by discriminate.
            simpl.
            reflexivity.
        }
  - destruct (interleave_with_end_padding_decompose_gt (N_to_digits n1) bin_digit0 (N_to_digits n2) bin_digit0); trivial.
    destruct n1; simpl.
    + simpl in n1gt.
      omega.
    + specialize (H bin_digit0).
      destruct (pos_to_digits_canon p) as [l leq].
      simpl in *.
      rewrite leq in *.
      rewrite last_app_nnil in H by discriminate.
      simpl in H.
      eauto.
Qed.

Lemma make_even_digits_fixup_trailing_zeros n1 n2 :
(make_even_digits
   (fixup_trailing_zeros
      (interleave_with_end_padding (N_to_digits n1) bin_digit0 (N_to_digits n2) bin_digit0)))
= interleave_with_end_padding (N_to_digits n1) bin_digit0 (N_to_digits n2) bin_digit0.
Proof.
  generalize (interleave_with_end_padding_even (N_to_digits n1) bin_digit0 (N_to_digits n2) bin_digit0)
  ; intros is_even.
  assert (HH:n1 = 0%N /\ n2 = 0%N \/ (n1 <> 0%N \/ n2 <> 0%N)).
  { destruct n1; destruct n2; simpl; intuition congruence. }
  destruct HH.
  - destruct H; subst.
    reflexivity.
  - destruct (padded_interleave_result n1 n2) as [[l Hl] | [l Hl]]; trivial
    ; rewrite Hl in *.
    + rewrite fixup_trailing_zeros_end1.
      unfold make_even_digits.
      rewrite is_even; trivial.
    + generalize (fixup_trailing_zeros_end0 (l ++ [bin_digit1])); intros HH.
      rewrite app_ass in HH; simpl in HH.
      rewrite HH.
      rewrite fixup_trailing_zeros_end1.
      unfold make_even_digits.
      rewrite app_length in *.
      simpl in *.
      replace (length l + 2) with (S (S (length l))) in is_even by omega.
      rewrite Nat.even_succ_succ in is_even.
      replace (length l + 1) with (S (length l)) by omega.
      rewrite Nat.even_succ.
      rewrite <- Nat.negb_even.
      rewrite is_even.
      simpl.
      rewrite app_ass; simpl.
      reflexivity.
Qed.

Lemma decode_encode_pair (n1 n2:N) :
  decode_pair (encode_pair n1 n2) = (n1, n2).
Proof.
  unfold decode_pair, encode_pair.
  destruct (N.eq_dec (digits_to_N (encode_digits_pair (N_to_digits n1) (N_to_digits n2))) 0).
  - apply digits_to_N_fixup_encode_0 in e.
    intuition congruence.
  - unfold decode_pair_to_digits.
    rewrite N_to_digits_to_N_fixup.
    unfold encode_digits_pair.
    rewrite make_even_digits_fixup_trailing_zeros.
    unfold decode_digits_pair.
    unfold interleave_with_end_padding.
    rewrite uninterleave_interleave.
    + simpl.
      repeat rewrite digits_to_N_to_digits_rep.
      trivial.
    + repeat rewrite app_length.
      repeat rewrite repeat_length.
      omega.
Qed.

Lemma canon_digits_even_break digits :
  canon_digits digits ->
  Nat.even (length digits) = true ->
  { ld & {a | digits = ld ++ [a; bin_digit1] }}.
Proof.
  intros [l lpf] ev.
  rewrite lpf.
  assert (lcons: l <> nil).
  { intros ?; subst.
    simpl in *.
    discriminate.
  }
  destruct (exists_last lcons) as [x [a pf]].
  subst.
  rewrite app_ass; simpl.
  eauto.
Qed.

Lemma fixup_canon_uninterleave_even_snd digits :
  canon_digits digits ->
  Nat.even (length digits) = true ->
  fixup_trailing_zeros (snd (uninterleave digits)) = snd (uninterleave digits).
Proof.
  intros is_canon is_even.
  destruct (canon_digits_even_break digits is_canon is_even)
    as [l [a eqq]].
  rewrite eqq in *; simpl in *.
  rewrite uninterleave_even_end.
  - simpl.
    rewrite fixup_trailing_zeros_end1.
    trivial.
  - apply Nat.even_spec; trivial.
    rewrite app_length in is_even; simpl in is_even.
    replace (length l + 2) with (2 + length l) in is_even by omega.
    simpl in is_even; trivial.
Qed.

Lemma fixup_canon_uninterleave_odd_fst digits a :
  canon_digits digits ->
  Nat.even (length digits) = false ->
  fixup_trailing_zeros (fst (uninterleave (digits ++ [a]))) = fst (uninterleave (digits ++ [a])).
Proof.
  intros is_canon is_even.
  destruct is_canon as [a' eqq1].
  rewrite eqq1 in *.
  rewrite <- app_assoc.
  simpl.
  rewrite uninterleave_even_end.
  - simpl.
    rewrite fixup_trailing_zeros_end1; trivial.
  - apply Nat.even_spec.
    rewrite app_length in is_even.
    simpl in is_even.
    replace (length a' + 1) with (S (length a')) in is_even by omega.
    rewrite Nat.even_succ in is_even.
    rewrite <- Nat.negb_odd.
    rewrite is_even; reflexivity.
Qed.

Lemma uninterleave_length_eq_even {A} (l:list A) :
  Nat.even (length l) = true ->
  length (fst (uninterleave l)) = length (snd (uninterleave l)).
Proof.
  intros is_even.
  apply Nat.even_spec in is_even.
  revert l is_even.
  apply EvenList_ind; simpl; trivial.
  intros.
  destruct (uninterleave l); simpl in *.
  congruence.
Qed.

Lemma uninterleave_length_eq_odd {A} (l:list A) :
  Nat.odd (length l) = true ->
  length (fst (uninterleave l)) = length (snd (uninterleave l)).
Proof.
  intros is_odd.
  destruct l.
  - vm_compute in is_odd; discriminate.
  - simpl in is_odd.
    rewrite Nat.odd_succ in is_odd.
    destruct (@exists_last _ (a::l))
    as [l' [a' eqq]]; [simpl; congruence | ].
    rewrite eqq.
    assert (eqlen1:length (a :: l) = length (l' ++ [a'])) by congruence.
    rewrite app_length in eqlen1; simpl in eqlen1.
    assert (eqlen2:length l = length l') by omega.
    rewrite uninterleave_odd_skip.
    + apply uninterleave_length_eq_even; trivial.
      congruence.
    + apply Nat.even_spec; trivial.
      congruence.
Qed.

Lemma uninterleave_length_eq {A} (l:list A) :
  length (fst (uninterleave l)) = length (snd (uninterleave l)).
Proof.
  case_eq (Nat.even (length l)); intros is_even.
  - apply uninterleave_length_eq_even; trivial.
  - apply uninterleave_length_eq_odd; trivial.
    rewrite <- Nat.negb_even.
    rewrite is_even.
    reflexivity.
Qed.

Lemma cleanup_zeros_repeat_form l :
  exists n,
    l = repeat bin_digit0 n ++ cleanup_zeros l.
Proof.
  induction l; simpl.
  - exists 0.
    simpl; trivial.
  - destruct IHl as [n eqq].
    destruct a.
    + exists (S n); simpl.
      rewrite <- eqq.
      trivial.
    + exists 0.
      simpl; trivial.
Qed.

Lemma fixup_trailing_zeros_repeat_form l :
  exists n,
    l = fixup_trailing_zeros l ++ repeat bin_digit0 n.
Proof.
  destruct (cleanup_zeros_repeat_form (rev l)) as [n eqq].
  generalize (f_equal (@rev BinaryDigit) eqq); intros eqq2.
  rewrite rev_involutive in eqq2.
  rewrite rev_app_distr in eqq2.
  rewrite repeat_rev in eqq2.
  unfold fixup_trailing_zeros.
  eauto.
Qed.

Lemma interleave_with_end_padding_fixup_uninterleave_make_even digits :
  canon_digits digits ->
  (interleave_with_end_padding
     (fixup_trailing_zeros (fst (uninterleave (make_even_digits digits)))) bin_digit0
     (fixup_trailing_zeros (snd (uninterleave (make_even_digits digits)))) bin_digit0)
  = digits
  \/
  (interleave_with_end_padding
     (fixup_trailing_zeros (fst (uninterleave (make_even_digits digits)))) bin_digit0
     (fixup_trailing_zeros (snd (uninterleave (make_even_digits digits)))) bin_digit0)
  = digits ++ [bin_digit0].
Proof.
  intros is_canon.
  unfold make_even_digits.
  case_eq (Nat.even (length digits)); intros is_even.
  - left.
    rewrite fixup_canon_uninterleave_even_snd by trivial.
    destruct (fixup_trailing_zeros_repeat_form (fst (uninterleave digits)))
      as [n eqq].
    unfold interleave_with_end_padding.
    generalize (uninterleave_length_eq digits); intros leneqq.
    rewrite <- leneqq.
    replace ((length (fst (uninterleave digits)) - length (fixup_trailing_zeros (fst (uninterleave digits))))) with n.
    + rewrite <- eqq.
      replace ((length (fixup_trailing_zeros (fst (uninterleave digits))) - length (fst (uninterleave digits)))) with 0.
      * simpl.
        rewrite app_nil_r.
        apply interleave_uninterleave.
        apply Nat.even_spec.
        trivial.
      * rewrite eqq at 2.
        rewrite app_length.
        rewrite repeat_length.
        omega.
    + rewrite eqq at 1.
      rewrite app_length.
      rewrite repeat_length.
      omega.
  - right.
    rewrite fixup_canon_uninterleave_odd_fst by trivial.
    destruct (fixup_trailing_zeros_repeat_form (snd (uninterleave (digits ++ [bin_digit0]))))
      as [n eqq].
    unfold interleave_with_end_padding.
    generalize (uninterleave_length_eq (digits ++ [bin_digit0])); intros leneqq.
    rewrite leneqq.
      replace ((length (fixup_trailing_zeros (snd (uninterleave (digits ++ [bin_digit0])))) -
                length (snd (uninterleave (digits ++ [bin_digit0]))))) with
                                                                      0.
    + replace ((length (snd (uninterleave (digits ++ [bin_digit0]))) -
                length (fixup_trailing_zeros (snd (uninterleave (digits ++ [bin_digit0]))))))
        with n.
      * simpl.
        rewrite app_nil_r.
        rewrite <- eqq.
        rewrite interleave_uninterleave; trivial.
        apply Nat.even_spec.
        rewrite app_length.
        simpl.
        replace (length digits + 1) with (S (length digits)) by omega.
        rewrite Nat.even_succ.
        rewrite <- Nat.negb_even.
        rewrite is_even; reflexivity.
      * rewrite eqq at 1.
        rewrite app_length.
        rewrite repeat_length.
        omega.
    + rewrite eqq at 2.
      rewrite app_length.
      omega.
Qed.

Lemma interleave_with_end_padding_fixup_uninterleave_make_even_repeat digits :
  canon_digits digits ->
  exists n,
  (interleave_with_end_padding
     (fixup_trailing_zeros (fst (uninterleave (make_even_digits digits)))) bin_digit0
     (fixup_trailing_zeros (snd (uninterleave (make_even_digits digits)))) bin_digit0)
  = digits ++ repeat bin_digit0 n.
Proof.
  intros is_canon.
  destruct (interleave_with_end_padding_fixup_uninterleave_make_even digits is_canon).
  - exists 0.
    simpl.
    rewrite app_nil_r.
    eauto.
  - exists 1.
    simpl.
    eauto.
Qed.
Lemma encode_decode_pair (n:N) :
  encode_pair (fst (decode_pair n)) (snd (decode_pair n)) = n.
Proof.
  unfold decode_pair, encode_pair.
  destruct n.
  - reflexivity.
  - simpl.
    repeat rewrite N_to_digits_to_N_fixup.
    unfold decode_pair_to_digits.
    unfold decode_digits_pair.
    simpl.
    unfold encode_digits_pair.
    destruct (interleave_with_end_padding_fixup_uninterleave_make_even_repeat (pos_to_digits p))
    as [n neqq].
    + apply pos_to_digits_canon.
    + rewrite neqq.
      apply (digits_to_N_pos_to_digits_rep p n).
Qed.

End Internal.

Program Instance N_pair_encoder : Isomorphism (N*N) N
  := {
      iso_f '(x,y) := Internal.encode_pair x y ;
      iso_b xy := Internal.decode_pair xy
    }.
Next Obligation.
    generalize (@Internal.encode_decode_pair b); intros HH.
    destruct (Internal.decode_pair b); simpl in *.
    trivial.
Qed.
Next Obligation.
  apply Internal.decode_encode_pair.
Qed.

Global Instance pair_encoder {A} (iso:Isomorphism A N) : Isomorphism (A*A) A
  := Isomorphism_trans (Isomorphism_trans (Isomorphism_prod iso iso) N_pair_encoder) (Isomorphism_symm iso).

Global Instance nat_pair_encoder : Isomorphism (nat*nat) nat := pair_encoder nat_to_N_iso.


Theorem Ex034 (A B C D : Prop) : (A \/ ((B -> C) /\ D)) -> ((B \/ A) \/ (~C -> D)).
Proof.
  intros.
  destruct H.
  + left. right. exact H.
  + destruct H.
    right. intro. exact H0.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

This library is free software; you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or
(at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Coq.omega.Omega.
Require Import Rsequence_def Rsequence_base_facts Rsequence_cv_facts Rsequence_rewrite_facts.
Require Import Rpser_def Rpser_def_simpl.
Require Import MyRIneq MyNat Lra.

Open Scope R_scope.
Open Scope Rseq_scope.

(** * Rseq_sum properties *)

(** Basic properties *)

Lemma Rseq_sum_ext_strong : forall Un Vn n,
  (forall p, (p <= n)%nat -> Un p = Vn p) ->
  Rseq_sum Un n = Rseq_sum Vn n.
Proof.
intros Un Vn n ; induction n ; intro Heq.
 simpl ; apply Heq ; trivial.
 do 2 rewrite Rseq_sum_simpl ; rewrite IHn, Heq.
  reflexivity.
  trivial.
  intros ; apply Heq ; auto.
Qed.

Lemma Rseq_sum_ext : forall Un Vn,
  Un == Vn -> Rseq_sum Un == Rseq_sum Vn.
Proof.
intros Un Vn Heq n ; apply Rseq_sum_ext_strong ; trivial.
Qed.

Lemma Rseq_sum_scal_compat_l : forall (l : R) Un,
  Rseq_sum (l * Un) == l * (Rseq_sum Un).
Proof.
intros l Un n ; induction n.
 reflexivity.
 simpl ; rewrite IHn ;
  unfold Rseq_mult, Rseq_constant ;
  simpl ; ring.
Qed.

(** Compatibility with common operations *)

Lemma Rseq_sum_constant_compat: forall (l : R) n,
  (Rseq_sum l n = INR (S n) * l)%R.
Proof.
intros l n ; induction n.
 simpl ; symmetry ; apply Rmult_1_l.
 rewrite Rseq_sum_simpl, S_INR, IHn ; unfold Rseq_constant ; ring.
Qed.

Lemma Rseq_sum_scal_compat_r : forall (l : R) Un,
  Rseq_sum (Un * l) == Rseq_sum Un * l.
Proof.
intros l Un n ; induction n.
 reflexivity.
 simpl ; rewrite IHn ;
  unfold Rseq_mult, Rseq_constant ;
  simpl ; ring.
Qed.

Lemma Rseq_sum_opp_compat : forall Un,
  Rseq_sum (- Un) == - Rseq_sum Un.
Proof.
intros Un n ; induction n.
 reflexivity.
 simpl ; rewrite IHn ;
  unfold Rseq_opp ;
  simpl ; ring.
Qed.

Lemma Rseq_sum_plus_compat : forall Un Vn,
  Rseq_sum (Un + Vn) == Rseq_sum Un + Rseq_sum Vn.
Proof.
intros Un Vn n ; induction n.
 reflexivity.
 simpl ; rewrite IHn ;
  unfold Rseq_plus ; simpl ;
  ring.
Qed.

Lemma Rseq_sum_minus_compat : forall Un Vn,
  Rseq_sum (Un - Vn) == Rseq_sum Un - Rseq_sum Vn.
Proof.
intros Un Vn n ; rewrite Rseq_sum_ext with (Un - Vn) (Un + (- Vn)) _,
 Rseq_sum_plus_compat.
 unfold Rseq_plus, Rseq_minus ; rewrite Rseq_sum_opp_compat ; reflexivity.
 unfold Rseq_minus ; intro ; reflexivity.
Qed.

Lemma Rseq_sum_shift_compat : forall Un n,
  Rseq_sum (Rseq_shift Un) n = (Rseq_shift (Rseq_sum Un) n - Un O)%R.
Proof.
intros Un n ; induction n ;
 [| simpl ; rewrite IHn] ;
 unfold Rseq_shift, Rseq_minus ; simpl ; ring.
Qed.

Lemma Rseq_sum_shifts_compat : forall Un k n,
  Rseq_sum (Rseq_shifts Un (S k)) n = (Rseq_shifts (Rseq_sum Un) (S k) n - Rseq_sum Un k)%R.
Proof.
intros Un k n ; induction n.
 unfold Rseq_shifts, Rseq_minus ; simpl ; rewrite plus_0_r ; ring.
 simpl ; rewrite IHn ; unfold Rseq_minus, Rseq_shifts ;
  simpl ; rewrite <- (plus_n_Sm k n) ; simpl ; ring.
Qed.

Lemma Rseq_sum_split_compat : forall Un k n, (k < n)%nat ->
  (Rseq_sum Un n = Rseq_sum Un k + Rseq_sum (Rseq_shifts Un (S k)) (n - S k))%R.
Proof.
intros Un k n kltn ; rewrite Rseq_sum_shifts_compat ; ring_simplify.
 unfold Rseq_shifts ; rewrite le_plus_minus_r ; [reflexivity | omega].
Qed.

Lemma Rseq_sum_reindex_compat : forall Un n,
  Rseq_sum Un n = Rseq_sum (fun i => Un (n - i)%nat) n.
Proof.
intros Un n ; revert Un ; induction n ; intro Un.
 reflexivity.
 do 2 rewrite Rseq_sum_simpl.
 rewrite (IHn (fun i => Un (S n - i)%nat)), minus_diag.
 rewrite (Rseq_sum_ext_strong (fun i => Un (S n - (n - i))%nat) (Rseq_shift Un)).
 rewrite Rseq_sum_shift_compat ; unfold Rseq_shift ; simpl ; ring.
 intros m m_bd ; unfold Rseq_shift ; replace (S n - (n - m))%nat with (S m) by omega ;
 reflexivity.
Qed.

Lemma Rseq_prod_comm: forall An Bn, (An # Bn == Bn # An)%Rseq.
Proof.
intros An Bn n ; unfold Rseq_prod, Rseq_mult ;
 rewrite Rseq_sum_reindex_compat ; apply Rseq_sum_ext_strong ;
 intros p p_ub ; replace (n - (n - p))%nat with p by omega ;
 ring.
Qed.

Lemma Rseq_sum_prod_compat: forall An Bn n,
  Rseq_sum (An # Bn) n =
  Rseq_sum (fun i => (Rseq_sum Bn i) * An (n - i)%nat)%R n.
Proof.
intros An Bn n ; induction n.
 unfold Rseq_prod, Rseq_mult ; simpl ; apply Rmult_comm.
 transitivity (Rseq_sum ((fun i => (An i * (Rseq_sum Bn (n - i)%nat))%R) +
  (fun i => (An i * Bn (S (n - i))%nat))%R)%Rseq n + An (S n) * Bn O)%R.
 rewrite Rseq_sum_plus_compat, Rseq_sum_simpl, IHn ; unfold Rseq_plus ;
 rewrite Rplus_assoc ; apply Rplus_eq_compat.
 rewrite Rseq_sum_reindex_compat ; apply Rseq_sum_ext_strong ;
  intros p p_ub ; replace (n - (n - p))%nat with p by omega ; apply Rmult_comm.
 replace O with ((S n) - S n)%nat by omega ; unfold Rseq_prod ;
  rewrite Rseq_sum_simpl ; apply Rplus_eq_compat_r ; apply Rseq_sum_ext_strong ;
  intros p p_ub ; unfold Rseq_mult ; replace (S n - p)%nat with (S (n - p)) by omega ;
  reflexivity.
 transitivity (Rseq_sum (fun i => (An i * (Rseq_sum Bn (S n - i)))%R) (S n)).
 rewrite Rseq_sum_simpl, minus_diag ; apply Rplus_eq_compat ; [| trivial].
 apply Rseq_sum_ext_strong ; intros p p_ub ; unfold Rseq_plus ;
 replace (S n - p)%nat with (S (n - p)) by omega ; rewrite Rseq_sum_simpl ; ring.
 rewrite Rseq_sum_reindex_compat ; apply Rseq_sum_ext_strong ; intros p p_ub ;
 replace (S n - (S n - p))%nat with p by omega ; apply Rmult_comm.
Qed.

Lemma two_Sn : forall n, (2 * S n = S (S (2 * n)))%nat.
Proof.
intro n ; ring.
Qed.

Lemma Rseq_sum_zip_compat_odd : forall An Bn n,
  (Rseq_sum (Rseq_zip An Bn) (S (2 * n)) = Rseq_sum An n + Rseq_sum Bn n)%R.
Proof.
intros An Bn ; induction n.
 unfold Rseq_zip ; simpl.
  case (n_modulo_2 0) ; intros [p Hp] ; [| apply False_ind ; omega].
  case (n_modulo_2 1) ; intros [q Hq] ; [apply False_ind ; omega |].
  assert (Hp' : p = O) by omega ; assert (Hq' : q = O) by omega ; subst ; reflexivity.
 rewrite two_Sn ; do 2 rewrite Rseq_sum_simpl ; rewrite IHn ; do 2 rewrite Rseq_sum_simpl.
  repeat rewrite Rplus_assoc ; apply Rplus_eq_compat_l.
  rewrite (Rplus_comm (An (S n))), Rplus_assoc ; apply Rplus_eq_compat_l.
  rewrite Rplus_comm, <- two_Sn ; apply Rplus_eq_compat ; unfold Rseq_zip ;
   [ case (n_modulo_2 (S (2 * S n))) ; intros [p Hp] ; [apply False_ind ; omega |] |
     case (n_modulo_2 (2 * S n)) ; intros [p Hp] ; [| apply False_ind ; omega] ] ;
   assert (Hp' : p = S n) by omega ; subst ; reflexivity.
Qed.

Lemma Rseq_sum_zip_compat_even : forall An Bn n,
  (Rseq_sum (Rseq_zip An Bn) (2 * S n) = Rseq_sum An (S n) + Rseq_sum Bn n)%R.
Proof.
intros An Bn n ; rewrite two_Sn, Rseq_sum_simpl, Rseq_sum_zip_compat_odd,
 Rseq_sum_simpl, <- two_Sn ; unfold Rseq_zip.
 case (n_modulo_2 (2 * S n)) ; intros [p Hp] ; [| apply False_ind ; omega].
 assert (Hp' : p = S n) by omega ; subst ; ring.
Qed.

(** Compatibility with the orders *)

Lemma Rseq_sum_pos_strong : forall An n,
  (forall p, (p <= n)%nat -> 0 <= An p) ->
  0 <= Rseq_sum An n.
Proof.
intros An n ; induction n ; intro Hpos.
 simpl ; apply Hpos ; trivial.
 rewrite Rseq_sum_simpl ; apply Rplus_le_le_0_compat ;
 [apply IHn ; intros p p_bd |] ; apply Hpos ; omega.
Qed.

Lemma Rseq_sum_pos: forall An n,
 (forall n, 0 <= An n) ->  0 <= Rseq_sum An n.
Proof.
intros ; apply Rseq_sum_pos_strong ; trivial.
Qed.

Lemma Rseq_sum_le_compat_strong: forall An Bn n,
 (forall p, (p <= n)%nat -> An p <= Bn p) ->
 Rseq_sum An n <= Rseq_sum Bn n.
Proof.
intros An Bn n Hle ; induction n.
 simpl ; apply Hle ; trivial.
 simpl ; transitivity (Rseq_sum Bn n + An (S n))%R.
  apply Rplus_le_compat_r ; apply IHn ; auto.
  apply Rplus_le_compat_l ; apply Hle ; trivial.
Qed.

Lemma Rseq_sum_le_compat: forall An Bn n,
 (forall n, An n <= Bn n) -> Rseq_sum An n <= Rseq_sum Bn n.
Proof.
intros ; apply Rseq_sum_le_compat_strong ; trivial.
Qed.

Lemma Rseq_sum_lt_compat_strong: forall An Bn n,
 (forall p, (p <= n)%nat -> An p < Bn p) ->
 Rseq_sum An n < Rseq_sum Bn n.
Proof.
intros An Bn n Hlt ; induction n.
 simpl ; apply Hlt ; trivial.
 simpl ; transitivity (Rseq_sum Bn n + An (S n))%R.
  apply Rplus_lt_compat_r ; apply IHn ; auto.
  apply Rplus_lt_compat_l ; apply Hlt ; trivial.
Qed.

Lemma Rseq_sum_lt_compat: forall An Bn n,
 (forall n, An n < Bn n) -> Rseq_sum An n < Rseq_sum Bn n.
Proof.
intros ; apply Rseq_sum_lt_compat_strong ; trivial.
Qed.

Lemma Rseq_sum_triang: forall An n,
  Rabs (Rseq_sum An n) <= Rseq_sum (| An |) n.
Proof.
intros An n ; induction n.
 unfold Rseq_abs ; simpl ; reflexivity.
 do 2 rewrite Rseq_sum_simpl ; eapply Rle_trans ;
 [eapply Rabs_triang |] ; apply Rplus_le_compat ;
 [assumption | reflexivity].
Qed.

Lemma Rseq_sum_lower_bound : forall An n lb,
  (forall m, (m <= n)%nat -> lb <= An m) ->
  INR (S n) * lb <= Rseq_sum An n.
Proof.
intros An n lb HAn ; induction n.
 simpl ; rewrite Rmult_1_l ; apply HAn ; reflexivity.
 rewrite S_INR, Rmult_plus_distr_r, Rmult_1_l, Rseq_sum_simpl ;
  apply Rplus_le_compat ; [apply IHn | apply HAn ; reflexivity].
  intros m m_lb ; apply HAn ; omega.
Qed.

Lemma Rseq_sum_upper_bound : forall An n ub,
  (forall m, (m <= n)%nat -> An m <= ub) ->
  Rseq_sum An n <= INR (S n) * ub.
Proof.
intros An n ub HAn ; induction n.
 simpl ; rewrite Rmult_1_l ; apply HAn ; reflexivity.
 rewrite S_INR, Rmult_plus_distr_r, Rmult_1_l, Rseq_sum_simpl ;
  apply Rplus_le_compat ; [apply IHn | apply HAn ; reflexivity].
  intros m m_lb ; apply HAn ; omega.
Qed.

(** Convergence to infinity *)

Lemma Rseq_cv_pos_infty_criteria : forall An d, 0 < d ->
  (forall n, 0 <= An n) ->
  (forall M, exists N, (N >= M)%nat /\ d <= Rseq_sum (Rseq_shifts An M) (N - M)) ->
  Rseq_cv_pos_infty (Rseq_sum An).
Proof.
intros An d d_pos An_pos HAn.
 assert (HAn' : forall M, exists N, forall n, (N < n)%nat -> INR M * d <= Rseq_sum An n).
  intro M ; induction M.
   destruct (HAn O) as [N [_ HN]] ; exists N.
   intros n n_lb ; simpl ; rewrite Rmult_0_l.
    rewrite (Rseq_sum_split_compat _ _ _ n_lb) ; apply Rplus_le_le_0_compat.
     transitivity d.
      left ; assumption.
      rewrite (minus_n_O N) ;  erewrite Rseq_sum_ext ;
       [| symmetry ; eapply Rseq_shifts_0 ] ; assumption.
     apply Rseq_sum_pos ; intros ; apply An_pos.
    destruct IHM as [N HN] ; destruct (HAn (S (S N))) as [N' [N'_lb HN']] ; exists N' ;
     assert (N'_lb' : (S N < N')%nat) by omega.
    intros n n_lb ; rewrite S_INR, Rmult_plus_distr_r, Rmult_1_l,
     (Rseq_sum_split_compat _ _ _ n_lb), (Rseq_sum_split_compat _ _ _ N'_lb'),
     Rplus_assoc.
    apply Rplus_le_compat.
     apply HN ; auto.
     rewrite <- (Rplus_0_r d) ; apply Rplus_le_compat.
      apply HN'.
      apply Rseq_sum_pos ; intros ; apply An_pos.
 intro B ; pose (M := up (Rabs B / d)) ; destruct (archimed (Rabs B / d)) as [HB _].
  assert (M_pos : (0 <= M)%Z).
   apply le_IZR ; simpl ; eapply Rle_trans ; [| left ; eassumption].
   apply Rle_mult_inv_pos ; [apply Rabs_pos | assumption].
  destruct (IZN _ M_pos) as [M' HM'] ; destruct (HAn' M') as [N HN] ; exists (S N) ; intros n n_lb.
   apply Rlt_le_trans with (INR M' * d)%R ; [| apply HN ; omega].
   apply Rle_lt_trans with (Rabs B) ; [apply Rle_abs |].
   rewrite <- (Rmult_1_r (Rabs B)), <- (Rinv_l d), <- Rmult_assoc, INR_IZR_INZ, <- HM'.
   apply Rmult_lt_compat_r ; [assumption | apply HB].
   apply Rgt_not_eq ; assumption.
Qed.

Lemma Rseq_cv_neg_infty_criteria : forall An d, d < 0 ->
  (forall n, An n <= 0) ->
  (forall M, exists N, (N >= M)%nat /\ Rseq_sum (Rseq_shifts An M) (N - M) <= d) ->
  Rseq_cv_neg_infty (Rseq_sum An).
Proof.
intros An d d_neg An_neg HAn ; apply Rseq_cv_neg_infty_eq_compat with (- Rseq_sum (- An)).
 intro n ; unfold Rseq_opp at 1 ; rewrite Rseq_sum_opp_compat ; unfold Rseq_opp ;
 apply Ropp_involutive.
 apply Rseq_cv_pos_infty_opp_compat, Rseq_cv_pos_infty_criteria with (- d)%R.
  lra.
  intro n ; unfold Rseq_opp ; pose (An_neg n) ; lra.
  intro M ; destruct (HAn M) as [N [N_lb HN]] ; exists N ; split.
   assumption.
   rewrite Rseq_sum_ext with (Vn := - Rseq_shifts An M).
    rewrite Rseq_sum_opp_compat ; apply Ropp_le_contravar, HN.
    apply Rseq_shifts_opp_compat.
Qed.

(** Partition *)

Lemma Rseq_sum_even_odd_split : forall (An : Rseq) n,
  (Rseq_sum (fun i => An (2 * i)%nat) n +
  Rseq_sum (fun i => An (S (2 * i))%nat) n
  = Rseq_sum An (S (2 * n)))%R.
Proof.
intros An n ; induction n.
 reflexivity.
 replace (2 * (S n))%nat with (S (S (2 * n))) by ring.
 do 4 rewrite Rseq_sum_simpl.
 replace (2 * (S n))%nat with (S (S (2 * n))) by ring.
 rewrite <- IHn ; ring.
Qed.

Lemma Rseq_sum_even_odd_split' : forall An n,
  (Rseq_sum (fun i => An (2 * i)%nat) (S n) +
  Rseq_sum (fun i => An (S (2 * i))) n
  = Rseq_sum An (2 * (S n)))%R.
Proof.
intros An n ; replace (2 * S n)%nat with (S (S (2 * n))) by ring ;
 do 2 rewrite Rseq_sum_simpl ; rewrite <- Rseq_sum_even_odd_split ;
 replace (2 * S n)%nat with (S (S (2 * n))) by ring ; ring.
Qed.

(** * Rseq_pps : compatibility with common operations. *)

Section Rseq_pps_facts.

Lemma Rseq_pps_simpl : forall An x n,
  Rseq_pps An x (S n) = (Rseq_pps An x n + (An (S n) * pow x (S n)))%R.
Proof.
intros ; reflexivity.
Qed.

Lemma Rseq_pps_0_simpl : forall An n,
 Rseq_pps An 0 n = An O.
Proof.
intros An n ; induction n.
 unfold Rseq_pps, gt_pser, Rseq_mult ; simpl ;
  rewrite Rmult_1_r ; reflexivity.
 rewrite Rseq_pps_simpl, IHn, pow_i ; [ring | omega].
Qed.

Lemma Rseq_pps_O_simpl : forall An x,
  Rseq_pps An x O = An O.
Proof.
intros An x ; unfold Rseq_pps ; apply gt_pser_0.
Qed.

Lemma Rseq_pps_ext : forall An Bn x,
  (An == Bn)%Rseq ->
  (Rseq_pps An x == Rseq_pps Bn x)%Rseq.
Proof.
intros An Bn x Hext ; apply Rseq_sum_ext ;
 intro n ; unfold gt_pser, Rseq_mult ; rewrite Hext ;
 reflexivity.
Qed.

Lemma Rseq_pps_scal_compat_l : forall (l : R) An x,
  (Rseq_pps (l * An) x == l * Rseq_pps An x)%Rseq.
Proof.
intros l An x n ; unfold Rseq_pps ;
 rewrite Rseq_sum_ext with _ (l * (An * (pow x)))%Rseq _.
 apply Rseq_sum_scal_compat_l.
 clear ; intro n ; unfold gt_pser, Rseq_mult, Rseq_constant ;
  ring.
Qed.

Lemma Rseq_pps_scal_compat_r : forall (l : R) An x,
  (Rseq_pps (An * l) x == Rseq_pps An x * l)%Rseq.
Proof.
intros l An x n ; unfold Rseq_pps ;
 rewrite Rseq_sum_ext with _ ((An * (pow x)) * l)%Rseq _.
 apply Rseq_sum_scal_compat_r.
 clear ; intro n ; unfold gt_pser, Rseq_mult, Rseq_constant ;
  ring.
Qed.

Lemma Rseq_pps_opp_compat : forall An x,
  (Rseq_pps (- An) x == - Rseq_pps An x)%Rseq.
Proof.
intros An x n ; unfold Rseq_pps ;
 rewrite Rseq_sum_ext with _ (- (An * (pow x))) _.
 apply Rseq_sum_opp_compat.
 clear ; intro n ; unfold gt_pser, Rseq_mult, Rseq_opp ;
  ring.
Qed.

Lemma Rseq_pps_plus_compat : forall An Bn x,
  Rseq_pps (An + Bn) x == Rseq_pps An x + Rseq_pps Bn x.
Proof.
intros An Bn x n ; unfold Rseq_pps ;
 rewrite Rseq_sum_ext with _ ((An * (pow x)) + (Bn * (pow x))) _.
 apply Rseq_sum_plus_compat.
 clear ; intro n ; unfold gt_pser, Rseq_mult, Rseq_plus ;
  ring.
Qed.

Lemma Rseq_pps_abs_unfold : forall An x,
  Rseq_pps_abs An x == Rseq_pps (| An |) (Rabs x).
Proof.
intros An x ; apply Rseq_sum_ext ; apply gt_abs_pser_unfold.
Qed.

Lemma Rseq_pps_prod_unfold: forall An Bn x,
  Rseq_pps (An # Bn) x == Rseq_sum (gt_pser An x # (gt_pser Bn x)).
Proof.
intros An Bn x n ; induction n.
 unfold Rseq_pps, gt_pser, Rseq_prod, Rseq_mult ; simpl ; ring.
 rewrite Rseq_sum_simpl, Rseq_pps_simpl, IHn ; apply Rplus_eq_compat_l.
 etransitivity.
 symmetry ; eapply (Rseq_sum_scal_compat_r _ _ (S n)).
 apply Rseq_sum_ext_strong ; fold (pow x (S n)) ; intros p p_lb ;
 unfold gt_pser, Rseq_mult, Rseq_constant.
 replace (S n) with (p + (S n - p))%nat by omega ; rewrite pow_add ;
 replace (p + (S n - p) -p)%nat with (S n - p)%nat by omega ; ring.
Qed.

Lemma Rseq_pps_zip_compat_odd : forall An Bn x n,
  (Rseq_pps (Rseq_zip An Bn) x (S (2 * n)) =
  Rseq_pps An (x ^ 2) n + x * Rseq_pps Bn (x ^ 2) n)%R.
Proof.
intros An Bn x n ; unfold Rseq_pps ; erewrite Rseq_sum_ext ; [| eapply gt_pser_zip_compat] ;
 rewrite Rseq_sum_zip_compat_odd, Rseq_sum_scal_compat_l ; reflexivity.
Qed.

Lemma Rseq_pps_zip_compat_even : forall An Bn x n,
  (Rseq_pps (Rseq_zip An Bn) x (2 * S n) =
  Rseq_pps An (x ^ 2) (S n) + x * Rseq_pps Bn (x ^ 2) n)%R.
Proof.
intros An Bn x n ; unfold Rseq_pps ; erewrite Rseq_sum_ext ; [| eapply gt_pser_zip_compat] ;
 rewrite Rseq_sum_zip_compat_even, Rseq_sum_scal_compat_l ; reflexivity.
Qed.

Lemma unfold_Ropp : forall x, (- x = - 1 * x)%R.
Proof.
intros ; ring.
Qed.

Lemma Rseq_pps_alt_compat : forall An x,
  Rseq_pps (Rseq_alt An) x == Rseq_pps An (- x).
Proof.
intros An x n ; induction n.
 do 2 rewrite Rseq_pps_O_simpl ; unfold Rseq_alt, Rseq_mult, Rseq_pow ;
  apply Rmult_1_l.
 do 2 rewrite Rseq_pps_simpl ; rewrite IHn ; apply Rplus_eq_compat_l.
  unfold Rseq_alt, Rseq_mult, Rseq_pow ;
  rewrite (unfold_Ropp x), Rpow_mult_distr ; ring.
Qed.

(** * Rpser_abs, Rpser *)

Lemma Rpser_abs_unfold : forall An r l,
  Rpser_abs An r l <-> Rpser (| An |) (Rabs r) l.
Proof.
intros An r l ; split ; intro Hyp ; unfold Rpser, Rpser_abs ;
assert (tmp := Rseq_pps_abs_unfold An r) ; eapply Rseq_cv_eq_compat ;
eauto ; symmetry ; assumption.
Qed.

End Rseq_pps_facts.


(* This file presents Coq formalisation of
examples of proofs in higher-order Hereditary Harrop Clause logic with Cofix rule (CoHOHH)
given in the paper ``Structural Resolution: a framework for coinductive proof search
and proof construction in Horn Clause Logic''  by E.Komendantskaya, P.Johann, and M.Schmidt
*)

(*Coinductive Types and Corecursive Functions*)

Section Coinduction.

Variable A : Set.

CoInductive Stream : Set :=
    Cons : A -> Stream -> Stream.

CoInductive Streamnat : Set :=
    ConsStreamnat : nat -> Streamnat -> Streamnat.

Set Implicit Arguments.

(*----------------Decomposition lemmas--------------------------*)
(* the lemmas mimic lazy beta reduction on the corecursive functions *)

Definition Streamnat_decompose (s: Streamnat) : Streamnat :=
match s with
| ConsStreamnat n s' => ConsStreamnat n s'
end.

Theorem Snat_decomposition_lemma :
forall s, s = Streamnat_decompose s.
Proof.
intros; case s.
intros.
unfold Streamnat_decompose.
trivial.
Qed.

Ltac Snat_unfold term :=
apply trans_equal with (1 := Snat_decomposition_lemma term).

(*------------------------------------------*)

Section SuggestedAutomation.

(* This is the general tactic for automation of proofs by coinduction in Horn clause logic*)

Ltac LP_Coind  lp_cons :=
cofix H; try intros;
try rewrite Snat_decomposition_lemma; simpl;
try apply lp_cons;
try apply H.

(* Note the above tactic takes as an argument the name of the coinductive clause from the
coinductive logic program in question. *)

Section RegularProofs.
(*Proofs in Horn clause Logic for regular corecursion *)

(* Logic program zeros, computing the stream of 0: *)

CoInductive zeros:  Streamnat -> Prop :=
  | zeros_cons: forall (y: Streamnat), zeros y  -> zeros (ConsStreamnat 0 y).

(* First-order Definition of the stream in question *)

CoFixpoint zerostr : Streamnat :=
ConsStreamnat 0 (zerostr).

(* First-order coinductive lemma in Horn clause syntax, note the use of general tactic: *)

Lemma zerosQ: zeros (zerostr).
(*
cofix H.
rewrite Snat_decomposition_lemma. simpl.
apply zeros_cons.
apply H.*)
LP_Coind zeros_cons.
Qed.

(* A logic program query*)

Lemma zerosQ2: exists x, zeros x.
exists zerostr; apply zerosQ.
Qed.

Section IrregularProofs.

(*In this section, I am assuming one works with stream of natural numbers,
with usual pattern-matching available on both data structures -- nat and Streamnat *)

(*Below is our running example program from:*)

CoInductive from:  nat -> Streamnat -> Prop :=
  | from_cons: forall (x : nat) (y: Streamnat),  from (S x) y  -> from x (ConsStreamnat x y).

(* in LP, we make a query "from 0 y", which in Coq woudl mean exists y, from 0 y.
This will not work, as coinductive hypotheses cannot be formed with existentials
(i.e. in negative position). *)

(*So we need to provide the term for this existetial first*)

CoFixpoint fromstr (n:nat) : Streamnat :=
ConsStreamnat n (fromstr (S n)).

(* Because of the above definition, we need higher-order logic to
express the recursive scheme. It is no longer first-order Horn clause logic  *)

(*Now our LP query still cannot be proven directly by coinduction, we need a
more general form:

 The query  Lemma fromQ1: exists x, from 0 x. cannot be proven directly,
as "from 0 fromstr 0" will not give a
usable coinductive hypothesis.

This leads us to extend from Horn clauses to Hereditary Harrop clauses, to allow
universal quantification on the goals:
*)

Lemma fromQ: forall x, from x (fromstr x).
cofix H.
intros.
rewrite Snat_decomposition_lemma; simpl.
(*the above is just a forced pattern matching on stream*)
apply from_cons.
(*the above is one resolution step*)
apply H.
(*the last step applies coinductve hypothesis*)
Qed.

(* So the following goes through, using my general automated tactic instead of
the manual tactic application as above *)
Lemma fromQ2: forall x, from x (fromstr x).
LP_Coind from_cons.
Qed.

(*Essential thing to know in order to apply the tactic is the constructor of the coinductive type in question --
in LP terms it is the clause that defines the coinductive behaviour. *)

(*Now our initial LP query goes through as a particular case of more general lemma: *)
Lemma fromQ1: exists x, from 0 x.
exists (fromstr 0).
apply fromQ.
Qed.

(* Note that when reasoning with from, we did not need to know about
the inductive structure of nat.
 But we needed lazy beta-reduction (or case reasoning )
on constructor of Streamnat via Decomposition lemmas. *)

Section FibonacciLP.

(* Fibonacci, like from, requires second-order recursive scheme and on top,
Hereditary Harrop clause syntax and
inductive reasoning, too:. The three Horn clause of the logic
program Fibs are given below. *)

Inductive addp: nat -> nat -> nat -> Prop :=
| addp_0: forall y, addp 0 y y
| addp_S: forall x y z, addp x y z -> addp (S x) y (S z).

CoInductive fibs:  nat -> nat -> Streamnat -> Prop :=
  | fibs_cons: forall (x y : nat) (s: Streamnat),  (exists z, addp x y z  /\  fibs y z s)
                                           -> fibs x y  (ConsStreamnat x s).

(*For the above program, we may have a query in LP like exists x, fibs(0, s(0), x)?*)

(*So we need to provide the term for this existetial first*)

CoFixpoint fibstr (n m :nat) : Streamnat :=
ConsStreamnat n (fibstr m (n+m)).

(* Because of the above definition, we need higher-order logic to express the
recursive schemes  *)

(*Unlike the example of "from", we need reasoning "modulo some theory" above:
as n+m is pre-defined in the theory.
So, not only the use of natural numbers is important for pattern-matching on
inductive constructors,
but also the presence of some theory.*)

(*Now our LP query still cannot be proven directly by coinduction,
we need a more general form:  *)

(* The tactic LP_Coind fibs_cons. will no longer work, as essential here is reasoning on add,
natural numbers and modulo theory *)

Lemma fibQ: forall x y, fibs x y (fibstr x y).
cofix H.
intros x y.
rewrite Snat_decomposition_lemma; simpl.
(*the above is just a forced pattern matching on stream*)
apply fibs_cons.
(*the above is one resolution step. Up to this step, my old tactic works, but now
there is an existential proof for exists z : nat, add x y z /\ fibs y z (fibstr y (x + y))*)
exists (x+y).
apply conj.
(*apply nat_ind.*)
induction x.
simpl; apply addp_0.
simpl; apply addp_S.
apply IHx.
(*the above two lines take reasoning on add and nat*)
apply H.
(*the last step applies coinductve hypothesis*)
Qed.

(*So the tactic for more complex proof automation could  be:*)

Ltac LP_Coind2  lp_cons ipred icons1 icons2:=
cofix H; try intro x; try intro y;
try rewrite Snat_decomposition_lemma; simpl; try apply lp_cons;
repeat match goal with
| [ x: nat , y: nat  |- exists _ , _   ] => exists (x+y) end;
try apply conj;
repeat match goal with
| [ IHx: _ |- ipred ?x _  _ ] => try induction x; simpl; try apply icons1; try apply icons2; try apply IHx; auto end;
try apply H.

(*Testing the above tactic, all three previous lemmas are proven: *)
Lemma fibQ1: forall x y, fibs x y (fibstr x y).
LP_Coind2 fibs_cons addp addp_0 addp_S.
Qed.

Lemma zerosQ1: zeros (zerostr).
LP_Coind2 zeros_cons nat nat nat.
Qed.

Lemma fromQ4: forall x, from x (fromstr x).
LP_Coind2 from_cons nat nat nat.
Qed.

(*Now our initial LP query goes through as a particular case of more general lemma: *)
Lemma fromQ3: exists x, fibs 0 (S 0) x.
exists (fibstr 0 (S 0)).
apply fibQ.
Qed.