From Coq Require Import Arith NArith Lia.
Require Import Nibble Instructions List2 Logic2.

(** This is N(i, w) defined in (141), quite close to the paper. *)
Definition paper_next_valid_instruction_position (i: N) (b: byte)
:= let push1  := N_of_byte (byte_of_instruction (PUSH  1 eq_refl)) in
   let push32 := N_of_byte (byte_of_instruction (PUSH 32 eq_refl)) in
   let w := N_of_byte b in
   (if ((push1 <=? w)  &&  (w <=? push32))%bool
     then i + w - push1 + 2
     else i + 1)%N.

(** This is a nicer equivalent of the previous function. *)
Definition next_valid_instruction_position (i: N) (b: byte)
:= (i + match instruction_of_byte b with
        | Some (PUSH n _) => n + 1
        | _               => 1
        end)%N.

Lemma next_valid_instruction_position_ok (i: N) (b: byte):
  next_valid_instruction_position i b = paper_next_valid_instruction_position i b.
Proof.
unfold paper_next_valid_instruction_position.
match goal with
|- _ = if ?cond then (i + ?a - ?b + ?c)%N else (i + 1)%N =>
    replace (if cond then (i + a - b + c)%N else (i + 1)%N)
      with  (i + if cond then a - b + c else 1)%N
end.
2:{
  remember (andb _ _) as cond. destruct cond.
  repeat (rewrite N.add_sub_assoc || rewrite N.add_assoc). 1-3: trivial.
  symmetry in Heqcond.
  apply Bool.andb_true_iff in Heqcond.
  apply N.leb_le. tauto.
}
unfold next_valid_instruction_position.
f_equal.
(* this is stupid, we need an is_push test *)
destruct b as (b7, b6, b5, b4, b3, b2, b1, b0).
destruct b7; destruct b6; destruct b5; destruct b4;
destruct b3; destruct b2; destruct b1; destruct b0; trivial.
Qed.

Lemma next_valid_instruction_position_bound (i: N) (b: byte):
  (i + 1 <= next_valid_instruction_position i b)%N.
Proof.
unfold next_valid_instruction_position.
destruct (instruction_of_byte b) as [op|]; try destruct op; try apply N.le_refl.
lia.
Qed.

(**
   This is as close to D_J(c, i) defined in (140) as feasible,
   however, fuel had to be introduced to satisfy Coq's termination check.
 *)
Fixpoint paper_valid_jump_destinations_from (code: list byte)
                                             (i: N)
                                             (fuel: nat)
: list N
:= match fuel with
   | O => nil
   | S remaining_fuel =>
      match List.nth_error code (N.to_nat i) with
      | None => nil
      | Some b =>
         let tail := paper_valid_jump_destinations_from
                       code
                       (next_valid_instruction_position i b)
                       remaining_fuel
         in if (N_of_byte b =? N_of_byte (byte_of_instruction JUMPDEST))%N
                then i :: tail
                else tail
      end
   end.

Local Lemma valid_jump_destinations_from_2_helper
                (code: list byte)
                (i: N)
                (b: byte)
                (code_tail: list byte)
                (ok: code_tail = List.skipn (N.to_nat i) code):
  let next := next_valid_instruction_position i b in
  List.skipn (N.to_nat (next - i)) code_tail = List.skipn (N.to_nat next) code.
Proof.
subst. intro. unfold next_valid_instruction_position in next.
rewrite skipn_skipn.
f_equal. subst next.
rewrite N.add_comm.
rewrite<- N.add_sub_assoc by apply N.le_refl.
rewrite N.sub_diag.
rewrite N.add_0_r.
symmetry. apply N2Nat.inj_add.
Qed.

(* This version carries around the code tail so that it doesn't have to count from the start. *)
Local Fixpoint valid_jump_destinations_from_2 (code: list byte)
                                                (i: N)
                                                (fuel: nat)
                                                (code_tail: list byte)
                                                (ok: code_tail = List.skipn (N.to_nat i) code)
: list N
:= match fuel with
   | O => nil
   | S remaining_fuel =>
      match List.hd_error code_tail with
      | None => nil
      | Some b =>
         let next := next_valid_instruction_position i b in
         let tail := valid_jump_destinations_from_2
                       code
                       next
                       remaining_fuel
                       (List.skipn (N.to_nat (next - i)) code_tail)
                       (valid_jump_destinations_from_2_helper code i b code_tail ok)
         in if (N_of_byte b =? N_of_byte (byte_of_instruction JUMPDEST))%N
                then (i :: tail)%list
                else tail
      end
   end.

Local Lemma valid_jump_destinations_from_2_ok (code: list byte)
                                                (i: N)
                                                (fuel: nat)
                                                (code_tail: list byte)
                                                (ok: code_tail = List.skipn (N.to_nat i) code):
  paper_valid_jump_destinations_from code i fuel
   =
  valid_jump_destinations_from_2 code i fuel code_tail ok.
Proof.
revert ok. revert code_tail. revert i code.
induction fuel. { easy. }
intros. cbn.
subst code_tail. rewrite<- List2.nth_hd_skipn.
destruct (List.nth_error code (N.to_nat i)). 2:{ trivial. }
destruct (N_of_byte b =? _)%N; now rewrite<- IHfuel.
Qed.

(* This version replaces hd_error with a match and also drops [code] and [ok] parameters. *)
Local Fixpoint valid_jump_destinations_from_3 (code_tail: list byte)
                                                (i: N)
                                                (fuel: nat)
: list N
:= match fuel with
   | O => nil
   | S remaining_fuel =>
      match code_tail with
      | nil => nil
      | (b :: _)%list =>
         let next := next_valid_instruction_position i b in
         let tail := valid_jump_destinations_from_3
                       (List.skipn (N.to_nat (next - i)) code_tail)
                       next
                       remaining_fuel
         in if (N_of_byte b =? N_of_byte (byte_of_instruction JUMPDEST))%N
                then (i :: tail)%list
                else tail
      end
   end.

Local Lemma valid_jump_destinations_from_3_ok (code: list byte)
                                               (i: N)
                                               (fuel: nat)
                                               (code_tail: list byte)
                                               (ok: code_tail = List.skipn (N.to_nat i) code):
  valid_jump_destinations_from_3 code_tail i fuel
   =
  valid_jump_destinations_from_2 code i fuel code_tail ok.
Proof.
revert code i code_tail ok.
induction fuel. { easy. }
intros. cbn.
destruct code_tail; cbn. { trivial. }
destruct (N_of_byte b =? _)%N; now rewrite<- IHfuel.
Qed.

(* This version gets rid of the fuel and does skipping by itself. *)
Local Fixpoint valid_jump_destinations_from_4 (code: list byte) (current: N) (next_valid: N)
: list N
:= match code with
   | nil => nil
   | (h :: t)%list =>
        if (current <? next_valid)%N
           then valid_jump_destinations_from_4 t (current + 1)%N next_valid
           else
             let tail := valid_jump_destinations_from_4 t
                                                        (current + 1)%N
                                                        (next_valid_instruction_position current h)
             in if (N_of_byte h =? N_of_byte (byte_of_instruction JUMPDEST))%N
                  then (current :: tail)%list
                  else tail
  end.

Local Lemma valid_jump_destinations_from_4_skips (code: list byte) (current: N) (next_valid: N)
                                                  (ok: (current <= next_valid)%N):
  valid_jump_destinations_from_4 code current next_valid
   =
  valid_jump_destinations_from_4 (List.skipn (N.to_nat (next_valid - current)) code)
                                 next_valid
                                 next_valid.
Proof.
remember (N.to_nat (next_valid - current)) as k.
assert(K: next_valid = (current + N.of_nat k)%N) by lia.
clear Heqk ok. subst next_valid.
revert code current.
induction k; intros. { cbn. now repeat rewrite N.add_0_r. }
destruct code; cbn. { trivial. }
replace (current <? current + N.pos (Pos.of_succ_nat k))%N with true.
2:{
  symmetry.
  apply N.ltb_lt.
  lia.
}
replace (current + N.pos (Pos.of_succ_nat k))%N with (current + 1 + N.of_nat k)%N by lia.
apply IHk.
Qed.

Local Lemma valid_jump_destinations_from_4_ok (code: list byte)
                                               (i: N)
                                               (fuel: nat)
                                               (EnoughFuel: (length code < fuel)%nat):
  valid_jump_destinations_from_4 code i i
   =
  valid_jump_destinations_from_3 code i fuel.
Proof.
revert code EnoughFuel i.
induction fuel; intros. { now apply Nat.nlt_0_r in EnoughFuel. }
cbn. destruct code. { easy. }
cbn.
replace (i <? i)%N with false.
2:{ symmetry. apply (b_false (N.ltb_lt _ _)). apply N.lt_irrefl. }
replace (valid_jump_destinations_from_4 code (i + 1) (next_valid_instruction_position i b))
  with (valid_jump_destinations_from_3
        (List.skipn (N.to_nat (next_valid_instruction_position i b - i)) (b :: code))
        (next_valid_instruction_position i b) fuel).
{ trivial. }
assert (B := next_valid_instruction_position_bound i b).
rewrite valid_jump_destinations_from_4_skips by assumption.
symmetry. rewrite IHfuel.
{
  replace (N.to_nat (next_valid_instruction_position i b - i))
     with (S ((N.to_nat (next_valid_instruction_position i b - (i + 1))))) by lia.
  now rewrite List.skipn_cons.
}
rewrite List.skipn_length.
cbn in EnoughFuel.
lia.
Qed.


Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import Lia.
Require Import EquivDec.
From sflib Require Import sflib.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.

Set Implicit Arguments.

Module Time.
  Include Nat.

  Definition pred_opt (ts:t): option t :=
    match ts with
    | O => None
    | S n => Some n
    end.

  (* Definition le (a b:t) := a <= b. *)
  Definition join (a b:t) := max a b.
  Definition bot: t := 0.

  Global Program Instance order: orderC join bot.
  Next Obligation. unfold join. lia. Qed.
  Next Obligation. unfold join. lia. Qed.
  Next Obligation. eauto using Max.max_assoc. Qed.
  Next Obligation. eauto using Max.max_comm. Qed.
  Next Obligation. unfold join. lia. Qed.
  Next Obligation. unfold bot. lia. Qed.

  Global Instance eqdec: EqDec t eq := nat_eq_eqdec.
End Time.


Require Coq.Logic.Classical_Prop.
Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.euclidean_defs.
Require Import ProofCheckingEuclid.lemma_onray_shared_initial_point.
Require Import ProofCheckingEuclid.lemma_s_conga.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_equalangleshelper :
	forall A B C a b c p q,
	CongA A B C a b c ->
	OnRay b a p ->
	OnRay b c q ->
	CongA A B C p b q.
Proof.
	intros A B C a b c p q.
	intros CongA_ABC_abc.
	intros OnRay_ba_p.
	intros OnRay_bc_q.

	destruct CongA_ABC_abc as (U & V & u & v & OnRay_BA_U & OnRay_BC_V & OnRay_ba_u & OnRay_bc_v & Cong_BU_bu & Cong_BV_bv & Cong_UV_uv & nCol_A_B_C).

	pose proof (lemma_onray_shared_initial_point _ _ _ _ OnRay_ba_p OnRay_ba_u) as OnRay_bp_u.
	pose proof (lemma_onray_shared_initial_point _ _ _ _ OnRay_bc_q OnRay_bc_v) as OnRay_bq_v.

	pose proof (
		lemma_s_conga
		A B C p b q
		_ _ _ _
		OnRay_BA_U
		OnRay_BC_V
		OnRay_bp_u
		OnRay_bq_v
		Cong_BU_bu
		Cong_BV_bv
		Cong_UV_uv
		nCol_A_B_C
	) as CongA_ABC_pbq.

	exact CongA_ABC_pbq.
Qed.

End Euclid.


Require Import Ensembles Relations.
Set Implicit Arguments.
Implicit Arguments In [U].

Definition var := nat.
Inductive formula : Set :=
| Atom : var -> formula
| Bot : formula
| And : formula -> formula -> formula
| Or : formula -> formula -> formula
| Imp : formula -> formula -> formula.
Infix "'->" := Imp (at level 70, right associativity).
Infix "'\/" := Or (at level 60).
Infix "'/\" := And (at level 50).
Coercion Atom : var >-> formula.

Inductive provable : Ensemble formula -> formula -> Prop :=
| By_axiom : forall fs f, In fs f -> provable fs f
| By_K : forall fs f g, provable fs (f '-> g '-> f)
| By_S : forall fs f g h,
  provable fs ((f '-> g '-> h) '-> (f '-> g) '-> (f '-> h))
| By_proj1 : forall fs f g, provable fs (f '/\ g '-> f)
| By_proj2 : forall fs f g, provable fs (f '/\ g '-> g)
| By_conj : forall fs f g, provable fs (f '-> g '-> f '/\ g)
| By_in1 : forall fs f g, provable fs (f '-> f '\/ g)
| By_in2 : forall fs f g, provable fs (g '-> f '\/ g)
| By_case : forall fs f g h,
  provable fs ((f '-> h) '-> (g '-> h) '-> (f '\/ g '-> h))
| By_exfalso : forall fs f, provable fs (Bot '-> f)
| By_MP : forall fs f g,
  provable fs (f '-> g) -> provable fs f -> provable fs g.

Hint Constructors provable.

Module Type KRIPKE_MODEL.
  Parameter W : Type.
  Parameter R : relation W.
  Axiom R_refl : reflexive _ R.
  Axiom R_trans : transitive _ R.
  Parameter V : W -> var -> Prop.
  Axiom monotone : forall x y p, V x p -> R x y -> V y p.
End KRIPKE_MODEL.

Module Kripke_Semantics (K : KRIPKE_MODEL).
  Export K.

  Fixpoint satisfies x f :=
    match f with
      | Atom p => V x p
      | Bot => False
      | And f f' => satisfies x f /\ satisfies x f'
      | Or f f' => satisfies x f \/ satisfies x f'
      | Imp f f' => forall y, R x y -> satisfies y f -> satisfies y f'
    end.

  Hint Resolve R_refl R_trans monotone.
  Lemma hereditary : forall x y f,
    satisfies x f -> R x y -> satisfies y f.
    induction f; simpl; intuition eauto.
  Qed.

  Theorem soundness : forall fs f x,
    provable fs f -> (forall g, In fs g -> satisfies x g) -> satisfies x f.
    induction 1; simpl; intuition; eauto using hereditary.
  Qed.
End Kripke_Semantics.

Lemma deduction_theorem' : forall fs fs' f g,
  provable fs' g -> fs' = Add _ fs f -> provable fs (f '-> g).
  induction 1; intro; subst; [| eauto ..].
  inversion H; try inversion H0; subst; eauto.
  Existential 1 := Bot.
  Existential 1 := Bot.
  Existential 1 := Bot.
Qed.

Lemma deduction_theorem : forall fs f g,
  provable (Add _ fs f) g -> provable fs (f '-> g).
  eauto using deduction_theorem'.
Qed.

Lemma weakening : forall fs f g, provable fs f -> provable (Add _ fs g) f.
  induction 1; solve [repeat constructor; auto | eauto].
Qed.

Hint Constructors Union Singleton.
Hint Extern 1 (provable (Add _ _ _) _) => unfold Add.

Lemma converse_deduction_theorem :
  forall fs f g, provable fs (f '-> g) -> provable (Add _ fs f) g.
  intros; apply (@By_MP _ f g); auto using weakening.
Qed.

Module Canonical_Model <: KRIPKE_MODEL.
  Definition prime fs :=
    forall f g, provable fs (f '\/ g) -> provable fs f \/ provable fs g.
  Definition consistent fs := ~provable fs Bot.

  Definition W := { T : Ensemble formula | prime T /\ consistent T }.

  Definition R (x y : W) :=
    forall f, provable (proj1_sig x) f -> provable (proj1_sig y) f.
  Hint Unfold R Included.
  Lemma R_refl : forall x, R x x.
    auto.
  Qed.
  Lemma R_trans : forall x y z, R x y -> R y z -> R x z.
    auto.
  Qed.
  Definition V (x : W) (p : var) := provable (proj1_sig x) p.
  Hint Unfold V.
  Lemma monotone : forall x y p, V x p -> R x y -> V y p.
    intuition.
  Qed.
End Canonical_Model.

Module Canonical_Model_facts.
  Module M := Kripke_Semantics Canonical_Model.

  Import M.

  Hint Unfold R.

  Axiom prime_lemma : forall fs f,
    (forall x : W, (forall g, provable fs g -> provable (proj1_sig x) g) ->
      provable (proj1_sig x) f) ->
    provable fs f.

  Ltac destruct_iff :=
    match goal with
      [ H : forall _, _ <-> _ |- _] =>
      pose proof (fun x => proj1 (H x));
        pose proof (fun x => proj2 (H x));
          clear H
    end.

  Lemma equivalence : forall f x, provable (proj1_sig x) f <-> satisfies x f.
    induction f;
      intro x; destruct x as [T [? ?]];
        simpl in *; intuition;
          repeat destruct_iff; eauto 3.

    assert (provable T f1 /\ provable T f2) by firstorder.
    intuition; eauto.

    assert (provable T f1 \/ provable T f2) by auto; intuition.

    assert (provable T f1) by firstorder.
    eauto.

    assert (provable T f2) by firstorder.
    eauto.

    eauto.

    apply deduction_theorem.
    apply prime_lemma.
    auto 8 using weakening.
  Qed.

  Hint Resolve (fun f x => proj1 (equivalence f x)).
  Hint Resolve (fun f x => proj2 (equivalence f x)).

  Theorem completeness : forall fs f,
    (forall T, (forall g, In fs g -> satisfies T g) -> satisfies T f) ->
    provable fs f.
    auto 7 using prime_lemma.
  Qed.
End Canonical_Model_facts.


Require Export Iron.Language.SystemF2Cap.Type.Exp.
Require Export Iron.Language.SystemF2Cap.Type.Relation.WfT.
Require Export Iron.Language.SystemF2Cap.Type.Relation.FreeT.

(*******************************************************************)
(* Lift type indices that are at least a certain depth. *)
Fixpoint liftTT (n: nat) (d: nat) (tt: ty) : ty :=
 match tt with
 |  TVar ix
 => match nat_compare ix d with
    | Lt => tt
    | _  => TVar (ix + n)
    end

 |  TForall k t    => TForall k (liftTT n (S d) t)
 |  TApp t1 t2     => TApp      (liftTT n d t1) (liftTT n d t2)
 |  TSum t1 t2     => TSum      (liftTT n d t1) (liftTT n d t2)
 |  TBot k         => TBot  k

 |  TCon0 tc       => TCon0 tc
 |  TCon1 tc t1    => TCon1 tc  (liftTT n d t1)
 |  TCon2 tc t1 t2 => TCon2 tc  (liftTT n d t1) (liftTT n d t2)
 |  TCap  _        => tt
 end.
Hint Unfold liftTT.

(********************************************************************)
Lemma liftTT_TVar_exists
 : forall n d n1
 , exists n2, liftTT n d (TVar n1) = liftTT n d (TVar n2).
Proof.
 intros.
 unfold liftTT. exists n1. snorm.
Qed.

Lemma liftTT_TVar_not_zero
 : forall t
 , liftTT 1 0 t <> TVar 0.
Proof.
 intros.
 destruct t;
  try (solve [unfold not; snorm; inverts H; omega]);
  try (solve [unfold not; snorm; nope]).
Qed.
Hint Resolve liftTT_TVar_not_zero.

Lemma liftTT_TVar_not_succ
 : forall t d
 ,             t <> TVar d
 -> liftTT 1 0 t <> TVar (S d).
Proof.
 intros. gen d.
 destruct t; intros;
   try (solve [simpl; congruence]).

 - Case "TVar".
   unfold liftTT.
   snorm.
   + subst. congruence.
   + unfold not. intros.
     inverts H0. omega.
   + congruence.
Qed.
Hint Resolve liftTT_TVar_not_succ.

Lemma liftTT_TVar_above
 :  forall n i d
 ,  d > i
 -> liftTT n d (TVar i) = TVar i.
Proof.
 snorm; omega.
Qed.
Hint Resolve liftTT_TVar_above.

Lemma liftTT_isTVar_true
 :  forall n i t d
 ,  d > i
 -> IsTVar i (liftTT n d t)
 -> IsTVar i t.
Proof.
 intros.
  destruct t;
   try (solve [simpl; auto]).

 - Case "TVar".
   apply isTVar_form in H0.
   snorm; inverts H0; unfold IsTVar; snorm;
    rewrite beq_nat_true_iff; omega.
Qed.
Hint Resolve liftTT_isTVar_true.

Lemma liftTT_TCap
 :  forall n d t tc
 ,  liftTT n d t = TCap tc
 -> t            = TCap tc.
Proof.
 intros.
 destruct t; simpl in *; nope.
  snorm; nope.
Qed.

Lemma liftTT_wfT
 :  forall kn t d
 ,  WfT kn t
 -> WfT (S kn) (liftTT 1 d t).
Proof.
 intros. gen kn d.
 induction t; intros; inverts H; snorm.
Qed.
Hint Resolve liftTT_wfT.

Lemma liftTT_zero
 :  forall d t
 ,  liftTT 0 d t = t.
Proof.
 intros. gen d. lift_burn t.
Qed.
Hint Resolve liftTT_zero.
Hint Rewrite liftTT_zero : global.

Lemma liftTT_comm
 :  forall n m d t
 ,  liftTT n d (liftTT m d t)
 =  liftTT m d (liftTT n d t).
Proof.
 intros. gen d. lift_burn t.
Qed.
Hint Resolve liftTT_comm.

Lemma liftTT_succ
 :  forall n m d t
 ,  liftTT (S n) d (liftTT m     d t)
 =  liftTT n     d (liftTT (S m) d t).
Proof.
 intros. gen d m n. lift_burn t.
Qed.
Hint Resolve liftTT_succ.
Hint Rewrite liftTT_succ : global.

Lemma liftTT_plus
 : forall n m d t
 , liftTT (n + m) d t
 = liftTT n d (liftTT m d t).
Proof.
 intros. gen n d.
 induction m; intros.
 - rewrite liftTT_zero; burn.
 - rrwrite (n + S m = S n + m).
   rewrite IHm.
   rewrite liftTT_succ.
   auto.
Qed.
Hint Resolve liftTT_plus.
Hint Rewrite liftTT_plus : global.

Lemma liftTT_wfT_1
 :  forall t n ix
 ,  WfT n t
 -> liftTT 1 (n + ix) t = t.
Proof.
 intros. gen n ix.
 induction t; intros; inverts H; burn;
  try (solve [snorm; rewritess; burn]).

 - Case "TForall".
   snorm. f_equal.
   spec IHt H1.
   rrwrite (S (n + ix) = S n + ix).
   burn.
Qed.
Hint Resolve liftTT_wfT_1.

Lemma liftTT_closedT_id_1
 :  forall t d
 ,  ClosedT t
 -> liftTT 1 d t = t.
Proof.
 intros.
 rrwrite (d = d + 0). eauto.
Qed.
Hint Resolve liftTT_closedT_id_1.

Lemma liftTT_closedT_10
 :  forall t
 ,  ClosedT t
 -> ClosedT (liftTT 1 0 t).
Proof.
 intros.
 rrwrite (0 = 0 + 0).
 rewrite liftTT_wfT_1; auto.
Qed.
Hint Resolve liftTT_closedT_10.

(* Changing the order of lifting.
   We build this up in stages.
   Start out by only allow lifting by a single place for both
   applications. Then allow lifting by multiple places in the first
   application, then multiple places in both.
*)
Lemma liftTT_liftTT_11
 :  forall d d' t
 ,  liftTT 1 (1 + (d + d')) (liftTT 1 d t)
 =  liftTT 1 d              (liftTT 1 (d + d') t).
Proof.
 intros. gen d d'.
 induction t; intros.

 - Case "TVar".
   repeat (lift_cases; unfold liftTT); try f_equal; try omega; burn.

 - Case "TForall".
   snorm.
   rrwrite (S (d + d') = (S d) + d').
   rewritess. snorm.

 - Case "TApp".
   snorm; rewritess; auto.

 - Case "TCon".
   snorm; rewritess; auto.

 - Case "TBot".
   snorm; rewritess; auto.

 - Case "TCon0".
   snorm; rewritess; auto.

 - Case "TCon1".
   snorm; rewritess; auto.

 - Case "TCon2".
   snorm; rewritess; auto.

 - Case "TCap".
   snorm; rewritess; auto.
Qed.

Lemma liftTT_liftTT_1
 :  forall n1 m1 n2 t
 ,  liftTT m1   n1 (liftTT 1 (n2 + n1) t)
 =  liftTT 1 (m1 + n2 + n1) (liftTT m1 n1 t).
Proof.
 intros. gen n1 m1 n2 t.
 induction m1; intros; simpl.
  burn.

  rrwrite (S m1 = 1 + m1).
  rewrite liftTT_plus.
  rewritess.
  rrwrite (m1 + n2 + n1 = n1 + (m1 + n2)) by omega.
  rewrite <- liftTT_liftTT_11.
  burn.
Qed.

Lemma liftTT_liftTT
 :  forall m1 n1 m2 n2 t
 ,  liftTT m2 (m1 + n2 + n1) (liftTT m1 n1 t)
 =  liftTT m1 n1 (liftTT m2 (n2 + n1) t).
Proof.
 intros. gen n1 m1 n2 t.
 induction m2; intros.
  burn.
  rrwrite (S m2 = 1 + m2).
  rewrite liftTT_plus.
  rewrite IHm2.
  rewrite <- liftTT_liftTT_1.
  burn.
Qed.
Hint Rewrite liftTT_liftTT : global.

Lemma liftTT_liftTT_Sd
 : forall n d t
 , liftTT n (S d) (liftTT 1 0 t)
 = liftTT 1 0     (liftTT n d t).
Proof.
 intros.
 lets D: liftTT_liftTT 1 0 n d t.
 simpl in D.
 rrwrite (d + 0 = d) in D.
 auto.
Qed.
Hint Rewrite liftTT_liftTT_Sd : global.

Lemma liftTT_map_liftTT
 :  forall m1 n1 m2 n2 ts
 ,  map (liftTT m1 n1) (map (liftTT m2 (n2 + n1)) ts)
 =  map (liftTT m2 (m1 + n2 + n1)) (map (liftTT m1 n1) ts).
Proof.
 induction ts; simpl; f_equal; norm; auto.
Qed.

Lemma liftTT_freeT
 : forall d t
 , ~(FreeT d (liftTT 1 d t)).
Proof.
 intros. gen d.
 induction t; snorm; firstorder.
Qed.
Hint Resolve liftTT_freeT.


Require Import Arith.
Require Import Program.
Require Import Compare_dec.

Set Implicit Arguments.

(******************************************************************************)

Inductive variable : nat -> Set :=
| var : forall g i, i < g -> variable g.

Inductive type : nat -> Set :=
| ty_var    : forall g, variable g -> type g
| ty_arr    : forall g, type g -> type g -> type g
| ty_forall : forall g, type (S g) -> type g.

Definition shift_var : forall g c,
  variable (c + g) -> variable (c + 1 + g).
intros g c v. inversion v. subst.
destruct (le_lt_dec c i).
 apply var with (i:=S i). rewrite (plus_comm c 1). simpl. apply lt_n_S. assumption.
 apply var with (i:=i). rewrite <- plus_assoc. simpl. rewrite <- plus_Snm_nSm. apply le_S. assumption.
Defined.

Definition shift (g : nat) (c : nat) :
  type (c + g) -> type (c + 1 + g).
intros.
set (g':=c+g) in *. set (e:=refl_equal g' : g' = c+g). generalize g' H c e. clear g' H c e. intros g' H.
induction H; intros; subst.
 (* ty_var *)
 apply ty_var. apply shift_var. apply v.
 (* ty_arr *)
 apply ty_arr.
  apply IHtype1. reflexivity.
  apply IHtype2. reflexivity.
 (* ty_forall *)
 apply ty_forall.
  change (S (c + 1 + g)) with ((S c) + 1 + g).
  apply IHtype. reflexivity.
Defined.

Definition shift1 : forall g, type g -> type (S g).
intros.
change (S g) with (0 + 1 + g).
apply shift with (c:=0). apply H.
Defined.

Definition subst_var (g c d : nat) (v : variable d) :
 d = c + 1 + g ->
 type (c + g) -> type (c + g).
intros. destruct v. subst.
destruct (lt_eq_lt_dec i c) as [[X|X]|X].
 apply ty_var. apply var with (i:=i). apply lt_plus_trans. assumption.
 apply H0.
 destruct (O_or_S i) as [[i' i_eq_Si'] | i_eq_0].
  apply ty_var. apply var with (i:=i'). subst. rewrite (plus_comm c 1) in l. simpl in l. apply lt_S_n. assumption.
  elimtype False. subst. inversion X.
Defined.

Definition subst (g : nat) (c : nat) :
  type (c + g) ->
  type (c + 1 + g) ->
  type (c + g).
intros. dependent induction H0.
 (* ty_var *)
 apply subst_var with (d:=c + 1 + g). assumption. reflexivity. assumption.
 (* ty_arr *)
 apply ty_arr.
  apply IHtype1. apply H.
  apply IHtype2. apply H.
 (* ty_forall *)
 apply ty_forall.
 apply IHtype with (c0:=S c). apply shift1. apply H. reflexivity.
Defined.

Definition type_subst1 : forall g, type (S g) -> type g -> type g.
intros.
change g with (0 + g).
apply subst. apply H0. apply H.
Defined.


Section MinimalPropositionalLogic.

Axiom P : Prop.
Axiom Q : Prop.
Axiom R : Prop.
Axiom T : Prop.

Theorem ImplicationsAreTransitive : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intro H0.
  intro H1.
  intro p.
  apply H1.
  apply H0.
  assumption.
Qed.

Section AssumptionExample.

Hypothesis H : P -> Q -> R.

Lemma L1 : P -> Q -> R.
Proof.
  assumption.
Qed.

End AssumptionExample.

Theorem ApplyExample : (Q -> R -> T) -> (P -> Q) -> P -> R -> T.
Proof.
  intros H1 H2 p.
  apply H1.
  exact (H2 p).
Qed.

(*
Theorem ImplicationIsDistributive : (forall A B C : Prop, (A -> (A -> B -> C) -> (A -> B) -> (B -> C))).
Proof.
  intro A.
  intro B.
  intro C.
  intro a.
  intro H1.
  intro H2.
  intro H3.
  apply H1.
  assumption.
  apply H3.
Qed.

*)

Theorem ImplicationIsDistributive : ((P -> Q -> R) -> (P -> Q) -> (P -> R)).
Proof.
  intros H1 H2 p.
  apply H1.
  assumption.
  exact (H2 p).
Qed.

Section ExamplesCh3Section3.

Lemma Identity : (P -> P).
Proof.
  intro p.
  exact p.
Qed.

Lemma IdentityImplication : ((P -> P) -> (P -> P)).
Proof.
  intro H0.
  exact H0.
Qed.

Lemma ImplicationIsTransitive : ((P -> Q) -> (Q -> R) -> P -> R).
Proof.
  intro H1.
  intro H2.
  intro p.
  apply H2.
  exact (H1 p).
Qed.

Lemma ImplicationPer : ((P -> Q -> R) -> (Q -> P -> R)).
Proof.
  intro H1.
  intro H2.
  intro p.
  apply H1.
  - assumption.
  - apply H2.
Qed.

Lemma IgnoreQ : ((P -> R) -> P -> Q -> R).
Proof.
  intro H1.
  intro H2.
  intro H3.
  apply H1.
  apply H2.
Qed.

Lemma DeltaImplication : ((P -> Q) -> (P -> P -> Q)).
Proof.
  intro H1.
  intro H2.
  intro H3.
  apply H1.
  apply H2.
Qed.

Lemma DeltaImplicationReverse : ((P -> P -> Q) -> P -> Q).
Proof.
  intro H1.
  intro H2.
  apply H1.
  assumption.
  assumption.
Qed.

Lemma Diamond : ((P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T).
Proof.
  intro H1.
  intro H2.
  intro H3.
  intro H4.
  apply H3.
  apply H1.
  apply H4.
  apply H2.
  assumption.
Qed.

Lemma WeakPeirce : (((((P -> Q) -> P) -> P) -> Q) -> Q).
Proof.
  intro H1.
  apply H1.
  intro H2.
  apply H2.
  intro H3.
  apply H1.
  intro H4.
  assumption.
Qed.

End ExamplesCh3Section3.

Theorem ModusPonens : ((P -> Q) -> P -> Q).
Proof.
  intros.
  rename H into H1.
  apply H1.
  assumption.
Qed.

(* TODO: Complete
Theorem ModusTollens : ((P -> Q) -> ~Q -> ~P).
Proof.
  intros.
*)

Section ProofOfTripleImplication.

Hypothesis H : (((P -> Q) -> Q) -> Q).
Hypothesis p : P.

Lemma Rem : ((P -> Q) -> Q).
Proof (fun H0: (P -> Q) => H0 p).

Theorem TripleImplication : Q.
Proof (H Rem).

End ProofOfTripleImplication.

Print TripleImplication.

Print Rem.

Theorem ThenExample : (P -> Q -> (P -> Q -> R) -> R).
Proof.
  intros p q H1.
  apply H1; assumption.
Qed.

Theorem TripleImplicationOneShot : ((((P -> Q) -> Q) -> Q) -> P -> Q).
Proof.
  intros H p; apply H; intro H0; apply H0; assumption.
Qed.

Theorem ComposeExample : ((P -> Q -> R) -> (P -> Q) -> (P -> R)).
Proof.
  intros H1 H2 p.
  apply H1; [assumption | apply H2; assumption].
Qed.

Lemma L3 : ((P -> Q) -> (P -> R) -> (P -> Q -> R -> T) -> P -> T).
Proof.
  intros H1 H2 H3 p.
  apply H3; [idtac | apply H1 | apply H2]; assumption.
Qed.

Theorem ThenFailExample : ((P -> Q) -> (P -> Q)).
Proof.
  intro H; apply H; fail.
Qed.

Section SectionForCutExample.

Hypothesis (H1 : P -> Q)
           (H2 : Q -> R)
           (H3 : (P -> R) -> T -> Q)
           (H4 : (P -> R) -> T).

Theorem CutExample : Q.
Proof.
  cut (P -> R).
  intro H5.
  apply H3.
  assumption.
  apply H4; assumption.
  intro H6.
  apply H2.
  apply H1.
  assumption.
Qed.

Print CutExample.

Theorem CutWithoutCutExample : Q.
Proof.
  apply H3.
  intro H5.
  apply H2.
  apply H1.
  assumption.
  apply H4.
  intro H5.
  apply H2.
  apply H1.
  assumption.
Qed.

End SectionForCutExample.

End MinimalPropositionalLogic.

Print ImplicationIsDistributive.

Section UsingImplicationIsDistributive.

Variables (P1 P2 P3 : Prop).

(* Not working

Check (ImplicationIsDistributive P1 P2 P3).

*)

Theorem Exercise5P5 : (forall A B C D : Set, A = C \/ B = C \/ C = C \/ D = C).
Proof.
  intro A.
  intro B.
  intro C.
  intro D.
  right.
  right.
  left.
  reflexivity.
Qed.

Theorem ModusTollens : (forall P Q : Prop, (P -> Q) -> ~Q -> ~P).
Proof.
  intro P.
  intro Q.
  intro H.
  unfold not.
  apply (ImplicationTransitivity).
  exact (H).
Qed.


Require Import Coq.Reals.Reals.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Reals.ROrderedType.
Require Import Lists.List.
Import ListNotations.
Open Scope R_scope.

From HYDLA Require Export Partial.

Definition Inf := None : option R.

(* see https://coq.inria.fr/library/Coq.Reals.ROrderedType.html#Reqb *)
Definition Rleb r1 r2 := if Rle_dec r1 r2 then true else false.
Definition Rltb r1 r2 := if Rlt_dec r1 r2 then true else false.
Definition Rgeb r1 r2 := if Rge_dec r1 r2 then true else false.
Definition Rgtb r1 r2 := if Rgt_dec r1 r2 then true else false.
Example test_Rleb1: forall r1 r2 : R, r1 <= r2 <-> Rleb r1 r2 = true.
Proof.
  intros.
  split.
  - intros.
    unfold Rleb.
    destruct (Rle_dec r1 r2).
    + trivial.
    + apply Rnot_le_gt in n.
      apply Rgt_lt in n.
      apply Rle_lt_trans with (r3:=r1) in H.
      * apply Rlt_irrefl in H.
        inversion H.
      * trivial.
  - unfold Rleb.
    destruct (Rle_dec r1 r2).
    + trivial.
    + intros.
      discriminate H. Qed.
Example test_Rleb2: forall r1 r2 : R, r1 > r2 <-> Rleb r1 r2 = false.
Proof.
  intros.
  split.
  - intros.
    unfold Rleb.
    destruct (Rle_dec r1 r2).
    + apply Rgt_lt in H.
      apply Rle_lt_trans with (r3:=r1) in r.
      * apply Rlt_irrefl in r.
        inversion r.
      * trivial.
    + trivial.
  - unfold Rleb.
    destruct (Rle_dec r1 r2).
    + intros.
      discriminate H.
    + intros.
      apply Rnot_le_lt in n.
      trivial. Qed.
Example test_Rltb1: forall r1 r2 : R, r1 < r2 <-> Rltb r1 r2 = true.
Proof.
  intros.
  split.
  - intros.
    unfold Rltb.
    destruct (Rlt_dec r1 r2).
    + trivial.
    + apply Rnot_lt_ge in n.
      apply Rge_le in n.
      apply Rlt_le_trans with (r3:=r1) in H.
      * apply Rlt_irrefl in H.
        inversion H.
      * trivial.
  - unfold Rltb.
    destruct (Rlt_dec r1 r2).
    + intros.
      trivial.
    + intros.
      discriminate H. Qed.
Example test_Rltb2: forall r1 r2 : R, r1 >= r2 <-> Rltb r1 r2 = false.
Proof.
  intros.
  split.
  - intros.
    unfold Rltb.
    destruct (Rlt_dec r1 r2).
    + apply Rge_le in H.
      apply Rlt_le_trans with(r3:=r1) in r.
      * apply Rlt_irrefl in r.
        inversion r.
      * trivial.
    + trivial.
  - intros.
    unfold Rltb in H.
    destruct (Rlt_dec r1 r2).
    + inversion H.
    + apply Rnot_lt_ge in n.
      trivial. Qed.
Example test_Reqb1: forall r1 r2 : R, r1 = r2 <-> Reqb r1 r2 = true.
Proof.
  intros.
  split.
  - intros.
    unfold Reqb.
    destruct (Req_dec r1 r2).
    + trivial.
    + rewrite H in n.
      apply Rdichotomy in n.
      generalize n.
      intros [A|B].
      * apply Rlt_irrefl in A.
        inversion A.
      * apply Rgt_irrefl in B.
        inversion B.
  - unfold Reqb.
    destruct (Req_dec r1 r2).
    + trivial.
    + intros.
      discriminate H. Qed.
Example test_Reqb2: forall r1 r2 : R, r1 <> r2 <-> Reqb r1 r2 = false.
Proof.
  intros.
  split.
  - intros.
    apply Rdichotomy in H.
    generalize H.
    intros [A|B].
    + unfold Reqb.
      destruct (Req_dec r1 r2).
      * rewrite e in A.
        apply Rlt_irrefl in A.
        inversion A.
      * trivial.
    + unfold Reqb.
      destruct (Req_dec r1 r2).
      * rewrite e in B.
        apply Rgt_irrefl in B.
        inversion B.
      * trivial.
  - unfold Reqb.
    destruct (Req_dec r1 r2).
    + intros.
      discriminate H.
    + trivial. Qed.

(* update value of m at x with v, i.e. m(x):=v *)
Definition update_pt (m : partial) (x : option R) (v : option R) :=
  fun y =>
    match x with
    | Some x' => if Reqb x' y then v else m y
    | None => m y
    end.
Notation "x '|-->' v ';' m" := (update_pt m x v)
  (at level 100, v at next level, right associativity).
Notation "x '|-->' v" := (update_pt empty x v)
  (at level 100).
Example test_update_pt1: (Some 0 |--> Some 10) 0 = Some 10.
Proof.
  simpl.
  destruct (Reqb 0 0) eqn:E.
  - trivial.
  - unfold Reqb in E.
    destruct (Req_dec 0 0).
    + discriminate E.
    + apply Rdichotomy in n.
      generalize n.
      intros [A|B].
      * apply Rlt_irrefl in A.
        inversion A.
      * apply Rgt_irrefl in B.
        inversion B. Qed.
Example test_update_pt2: (Some 0 |--> Some 10) 1 = None.
Proof.
  simpl.
  destruct (Reqb 0 1) eqn:E.
  - apply test_Reqb1 in E.
    apply eq01_False in E.
    destruct E.
  - unfold empty.
    trivial. Qed.

(* update m in open interval (begt, endt) by m' *)
Definition update_in (m : partial) (m' : partial) (begt : option R) (endt : option R) : partial :=
  fun x' =>
    match (begt, endt) with
    | (Some begt', Some endt') => if andb (Rltb begt' x') (Rltb x' endt') then m' x' else m x'
    | (Some begt', Inf) => if Rltb begt' x' then m' x' else m x'
    | (_, _) => m x'
    end.
Notation "n '|_(' begt ',' endt ')' ';' m" := (update_in m n begt endt)
  (at level 100, right associativity).
Notation "n '|_(' begt ',' endt ')'" := (update_in empty n begt endt)
  (at level 100).
Example test_update_in1: (fun x => Some x)|_(Some 0, Some 2) 1 = Some 1.
Proof.
  unfold update_in.
  simpl.
  destruct (Rltb 0 1) eqn:E1.
  - simpl.
    destruct (Rltb 1 2) eqn:E2.
    + trivial.
    + unfold Rltb in E2.
      destruct (Rlt_dec 1 2).
      * inversion E2.
      * apply Rnot_lt_le in n.
        apply le21_False in n.
        destruct n.
  - simpl.
    unfold Rltb in E1.
    destruct (Rlt_dec 0 1).
    + discriminate E1.
    + apply Rnot_lt_ge in n.
      apply Rge_le in n.
      apply le10_False in n.
      destruct n. Qed.
Example test_update_in2: (fun x => Some x)|_(Some 0, Some 2) 2 = None.
Proof.
  unfold update_in.
  unfold Rltb.
  destruct (Rlt_dec 2 2).
  - apply Rlt_irrefl in r.
    destruct r.
  - destruct (Rlt_dec 0 2).
    + unfold empty. reflexivity.
    + unfold empty. reflexivity. Qed.

Inductive phase : Type := pp (v : option R) | ip (m : partial) (begt : option R) (endt : option R).
Definition trajectory : Type := list phase.
(* the def of trajectory dosen't request alternation of PP and IP, *)
(* so validation might be needed *)

(* entry point is valid, not valid2 *)
Require Import Coq.funind.Recdef.
(* TODO: check continuity on ip *)
Function valid2 (tr : trajectory) {measure length tr} : Prop :=
  match tr with
  | [pp _; ip _ begt endt] => lt begt endt \/ endt = Inf
  | pp _ :: ip _ begt1 endt1 :: pp v2 :: ip m2 begt2 endt2 :: tr'
      => (lt begt1 endt1 \/ endt1 = Inf) /\ endt1 = begt2 /\ valid2 (pp v2 :: ip m2 begt2 endt2 :: tr')
  | _ => False
  end.
Proof.
  intros.
  simpl.
  repeat apply lt_n_S.
  apply lt_n_SSn. Qed.
Definition valid (tr : trajectory) : Prop :=
  match tr with
  | (pp v) :: (ip m (Some t) endt) :: tr' => t = 0 /\ valid2 tr
  | _ => False
  end.
Example test_valid1: valid [pp (Some 0) ; ip (fun x => Some x) (Some 0) Inf].
Proof.
  unfold valid.
  split.
  - trivial.
  - rewrite valid2_equation.
    right.
    trivial. Qed.
Example test_valid2:
  valid [pp (Some 0) ; ip (fun x => Some(2*x)) (Some 0) (Some 1) ; pp (Some 2) ; ip (fun x => Some x) (Some 1) Inf].
Proof.
  unfold valid.
  split.
  - trivial.
  - rewrite valid2_equation.
    split.
    + unfold lt.
      left.
      apply Rlt_0_1.
    + split.
      * trivial.
      * rewrite valid2_equation.
        right.
        trivial. Qed.
Example test_not_valid1: ~ valid [pp (Some 0) ; pp (Some 0)].
Proof.
  unfold valid.
  intro.
  destruct H. Qed.
Example test_not_valid2: ~ valid [pp (Some 0) ; ip (fun x => Some x) (Some 1) Inf].
Proof.
  unfold valid.
  intros [A B].
  symmetry in A.
  apply eq01_False in A.
  destruct A. Qed.
Example test_not_valid3: ~ valid [pp (Some 0) ; ip (fun x => Some x) (Some 0) (Some (-1))].
Proof.
  unfold valid.
  rewrite valid2_equation.
  unfold lt.
  intros [A B].
  destruct B.
  - apply Rlt_le_trans with (r3:=0) in H.
    + apply Rlt_irrefl in H.
      destruct H.
    + left.
      apply Rplus_lt_reg_l with (r:=1).
      rewrite Rplus_opp_r.
      rewrite Rplus_0_r.
      apply Rlt_0_1.
  - inversion H. Qed.
Example test_not_valid4: ~ valid [pp (Some 0) ; ip (fun x => Some x) (Some 0) (Some 1); pp (Some 0) ; ip (fun x => Some x) (Some 0) (Some 1)].
Proof.
  unfold valid.
  rewrite valid2_equation.
  intros [A [B [C D]]].
  - inversion C.
    symmetry in H0.
    apply eq01_False in H0.
    destruct H0. Qed.

(* convert trajectory to partial *)
Fixpoint tr2partial (tr : trajectory) : partial :=
  match tr with
  | [] => empty
  | (pp v) :: (ip m begt endt) :: tr' => (begt |--> v ; m|_(begt, endt) ; (tr2partial tr'))
  | _ => empty
  end.
Example test_tr2partial1: tr2partial [pp (Some 0) ; ip (fun x => Some x) (Some 0) Inf] 1 = Some 1.
Proof.
  unfold tr2partial.
  unfold update_pt.
  unfold update_in.
  unfold Inf.
  unfold Reqb.
  destruct (Req_dec 0 1).
  - apply eq01_False in e.
    destruct e.
  - unfold Rltb.
    destruct (Rlt_dec 0 1).
    + trivial.
    + apply Rnot_lt_le in n0.
      apply le10_False in n0.
      destruct n0. Qed.
Example test_tr2partial2: tr2partial [pp (Some 0) ; ip (fun x => Some x) (Some 0) Inf] (-1) = None.
Proof.
  unfold tr2partial.
  unfold update_pt.
  unfold update_in.
  unfold Inf.
  unfold Reqb.
  destruct (Req_dec 0 (-1)).
  - apply eq0m1_False in e.
    destruct e.
  - unfold Rltb.
    destruct (Rlt_dec 0 (-1)).
    + apply Rplus_lt_compat_r with (r:=1) in r.
      assert (0 + 1 = 1). { ring. } rewrite H in r.
      assert (-1 + 1 = 0). { ring. } rewrite H0 in r.
      apply Rlt_le in r.
      apply le10_False in r.
      destruct r.
    + unfold empty.
      trivial. Qed.


(** * Induction: Proof by Induction *)

(** Before getting started, we need to import all of our
    definitions from the previous chapter: *)

Add LoadPath "/Users/Josh/Downloads/software foundations/lf/".
Require Export Basics.

(** For the [Require Export] to work, you first need to use
    [coqc] to compile [Basics.v] into [Basics.vo].  This is like
    making a .class file from a .java file, or a .o file from a .c
    file.  There are two ways to do it:

     - In CoqIDE:

         Open [Basics.v].  In the "Compile" menu, click on "Compile
         Buffer".

     - From the command line: Either

         [make Basics.vo]

       (assuming you've downloaded the whole LF directory and have a
       working 'make' command) or

         [coqc Basics.v]

       (which should work from any terminal window).

   If you have trouble (e.g., if you get complaints about missing
   identifiers later in the file), it may be because the "load path"
   for Coq is not set up correctly.  The [Print LoadPath.] command may
   be helpful in sorting out such issues.

   In particular, if you see a message like

      [Compiled library Foo makes inconsistent assumptions over library
      Coq.Init.Bar]

   you should check whether you have multiple installations of Coq on
   your machine.  If so, it may be that commands (like [coqc]) that you
   execute in a terminal window are getting a different version of Coq
   than commands executed by Proof General or CoqIDE. *)
(* ################################################################# *)
(** * Proof by Induction *)

(** We proved in the last chapter that [0] is a neutral element
    for [+] on the left, using an easy argument based on
    simplification.  We also observed that proving the fact that it is
    also a neutral element on the _right_... *)

Theorem plus_n_O_firsttry : forall n:nat,
  n = n + 0.

(** ... can't be done in the same simple way.  Just applying
  [reflexivity] doesn't work, since the [n] in [n + 0] is an arbitrary
  unknown number, so the [match] in the definition of [+] can't be
  simplified.  *)

Proof.
  intros n.
  simpl. (* Does nothing! *)
Abort.

(** And reasoning by cases using [destruct n] doesn't get us much
    further: the branch of the case analysis where we assume [n = 0]
    goes through fine, but in the branch where [n = S n'] for some [n'] we
    get stuck in exactly the same way. *)

Theorem plus_n_O_secondtry : forall n:nat,
  n = n + 0.
Proof.
  intros n. destruct n as [| n'].
  - (* n = 0 *)
    reflexivity. (* so far so good... *)
  - (* n = S n' *)
    simpl.       (* ...but here we are stuck again *)
Abort.

(** We could use [destruct n'] to get one step further, but,
    since [n] can be arbitrarily large, if we just go on like this
    we'll never finish. *)

(** To prove interesting facts about numbers, lists, and other
    inductively defined sets, we usually need a more powerful
    reasoning principle: _induction_.

    Recall (from high school, a discrete math course, etc.) the
    _principle of induction over natural numbers_: If [P(n)] is some
    proposition involving a natural number [n] and we want to show
    that [P] holds for all numbers [n], we can reason like this:
         - show that [P(O)] holds;
         - show that, for any [n'], if [P(n')] holds, then so does
           [P(S n')];
         - conclude that [P(n)] holds for all [n].

    In Coq, the steps are the same: we begin with the goal of proving
    [P(n)] for all [n] and break it down (by applying the [induction]
    tactic) into two separate subgoals: one where we must show [P(O)]
    and another where we must show [P(n') -> P(S n')].  Here's how
    this works for the theorem at hand: *)

Theorem plus_n_O : forall n:nat, n = n + 0.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)    reflexivity.
  - (* n = S n' *) simpl. rewrite <- IHn'. reflexivity.  Qed.

(** Like [destruct], the [induction] tactic takes an [as...]
    clause that specifies the names of the variables to be introduced
    in the subgoals.  Since there are two subgoals, the [as...] clause
    has two parts, separated by [|].  (Strictly speaking, we can omit
    the [as...] clause and Coq will choose names for us.  In practice,
    this is a bad idea, as Coq's automatic choices tend to be
    confusing.)

    In the first subgoal, [n] is replaced by [0].  No new variables
    are introduced (so the first part of the [as...] is empty), and
    the goal becomes [0 = 0 + 0], which follows by simplification.

    In the second subgoal, [n] is replaced by [S n'], and the
    assumption [n' + 0 = n'] is added to the context with the name
    [IHn'] (i.e., the Induction Hypothesis for [n']).  These two names
    are specified in the second part of the [as...] clause.  The goal
    in this case becomes [S n' = (S n') + 0], which simplifies to
    [S n' = S (n' + 0)], which in turn follows from [IHn']. *)

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n. induction n as [| n' IHn'].
  - (* n = 0 *)
    simpl. reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** (The use of the [intros] tactic in these proofs is actually
    redundant.  When applied to a goal that contains quantified
    variables, the [induction] tactic will automatically move them
    into the context as needed.) *)

(** **** Exercise: 2 stars, recommended (basic_induction)  *)
(** Prove the following using induction. You might need previously
    proven results. *)

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite -> IHn'. reflexivity. Qed.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  induction n as [| n' IHn'].
  - simpl. reflexivity.
- intros m. simpl. rewrite <- IHn'. reflexivity. Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  induction n as [| n' IHn'].
  - intros m. simpl. rewrite <- plus_n_O. reflexivity.
  - intros m. simpl. rewrite <- plus_n_Sm. rewrite <- IHn'.
    reflexivity. Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  induction n as [| n' IHn'].
  - reflexivity.
  - intros m p. simpl. rewrite -> IHn'. reflexivity. Qed.
(** [] *)

(** **** Exercise: 2 stars (double_plus)  *)
(** Consider the following function, which doubles its argument: *)

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

(** Use induction to prove this simple fact about [double]: *)

Lemma double_plus : forall n, double n = n + n .
Proof.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite -> IHn'. rewrite -> plus_n_Sm. reflexivity. Qed.

(** **** Exercise: 2 stars, optional (evenb_S)  *)
(** One inconvenient aspect of our definition of [evenb n] is the
    recursive call on [n - 2]. This makes proofs about [evenb n]
    harder when done by induction on [n], since we may need an
    induction hypothesis about [n - 2]. The following lemma gives an
    alternative characterization of [evenb (S n)] that works better
    with induction: *)

Theorem evenb_S : forall n : nat,
  evenb (S n) = negb (evenb n).
Proof.
  intros n. induction n as [| n' IHn'].
  - reflexivity.
  - rewrite -> IHn'. rewrite -> negb_involutive. reflexivity. Qed.

(** **** Exercise: 1 star (destruct_induction)  *)
(** Briefly explain the difference between the tactics [destruct]
    and [induction].

Destruct breaks down a goal into cases. It does not introduce an
Inductive hypothesis. Induction breaks a goal into 2 cases, the base
case and inductive case.

*)
(** [] *)

(* ################################################################# *)
(** * Proofs Within Proofs *)

(** In Coq, as in informal mathematics, large proofs are often
    broken into a sequence of theorems, with later proofs referring to
    earlier theorems.  But sometimes a proof will require some
    miscellaneous fact that is too trivial and of too little general
    interest to bother giving it its own top-level name.  In such
    cases, it is convenient to be able to simply state and prove the
    needed "sub-theorem" right at the point where it is used.  The
    [assert] tactic allows us to do this.  For example, our earlier
    proof of the [mult_0_plus] theorem referred to a previous theorem
    named [plus_O_n].  We could instead use [assert] to state and
    prove [plus_O_n] in-line: *)

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n). { reflexivity. }
  rewrite -> H.
  reflexivity.  Qed.

(** The [assert] tactic introduces two sub-goals.  The first is
    the assertion itself; by prefixing it with [H:] we name the
    assertion [H].  (We can also name the assertion with [as] just as
    we did above with [destruct] and [induction], i.e., [assert (0 + n
    = n) as H].)  Note that we surround the proof of this assertion
    with curly braces [{ ... }], both for readability and so that,
    when using Coq interactively, we can see more easily when we have
    finished this sub-proof.  The second goal is the same as the one
    at the point where we invoke [assert] except that, in the context,
    we now have the assumption [H] that [0 + n = n].  That is,
    [assert] generates one subgoal where we must prove the asserted
    fact and a second subgoal where we can use the asserted fact to
    make progress on whatever we were trying to prove in the first
    place. *)

(** Another example of [assert]... *)

(** For example, suppose we want to prove that [(n + m) + (p + q)
    = (m + n) + (p + q)]. The only difference between the two sides of
    the [=] is that the arguments [m] and [n] to the first inner [+]
    are swapped, so it seems we should be able to use the
    commutativity of addition ([plus_comm]) to rewrite one into the
    other.  However, the [rewrite] tactic is not very smart about
    _where_ it applies the rewrite.  There are three uses of [+] here,
    and it turns out that doing [rewrite -> plus_comm] will affect
    only the _outer_ one... *)

Theorem plus_rearrange_firsttry : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  (* We just need to swap (n + m) for (m + n)... seems
     like plus_comm should do the trick! *)
  rewrite -> plus_comm.
  (* Doesn't work...Coq rewrote the wrong plus! *)
Abort.

(** To use [plus_comm] at the point where we need it, we can introduce
    a local lemma stating that [n + m = m + n] (for the particular [m]
    and [n] that we are talking about here), prove this lemma using
    [plus_comm], and then use it to do the desired rewrite. *)

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
  { rewrite -> plus_comm. reflexivity. }
  rewrite -> H. reflexivity.  Qed.

(* ################################################################# *)
(** * Formal vs. Informal Proof *)

(** "_Informal proofs are algorithms; formal proofs are code_." *)

(** What constitutes a successful proof of a mathematical claim?
    The question has challenged philosophers for millennia, but a
    rough and ready definition could be this: A proof of a
    mathematical proposition [P] is a written (or spoken) text that
    instills in the reader or hearer the certainty that [P] is true --
    an unassailable argument for the truth of [P].  That is, a proof
    is an act of communication.

    Acts of communication may involve different sorts of readers.  On
    one hand, the "reader" can be a program like Coq, in which case
    the "belief" that is instilled is that [P] can be mechanically
    derived from a certain set of formal logical rules, and the proof
    is a recipe that guides the program in checking this fact.  Such
    recipes are _formal_ proofs.

    Alternatively, the reader can be a human being, in which case the
    proof will be written in English or some other natural language,
    and will thus necessarily be _informal_.  Here, the criteria for
    success are less clearly specified.  A "valid" proof is one that
    makes the reader believe [P].  But the same proof may be read by
    many different readers, some of whom may be convinced by a
    particular way of phrasing the argument, while others may not be.
    Some readers may be particularly pedantic, inexperienced, or just
    plain thick-headed; the only way to convince them will be to make
    the argument in painstaking detail.  But other readers, more
    familiar in the area, may find all this detail so overwhelming
    that they lose the overall thread; all they want is to be told the
    main ideas, since it is easier for them to fill in the details for
    themselves than to wade through a written presentation of them.
    Ultimately, there is no universal standard, because there is no
    single way of writing an informal proof that is guaranteed to
    convince every conceivable reader.

    In practice, however, mathematicians have developed a rich set of
    conventions and idioms for writing about complex mathematical
    objects that -- at least within a certain community -- make
    communication fairly reliable.  The conventions of this stylized
    form of communication give a fairly clear standard for judging
    proofs good or bad.

    Because we are using Coq in this course, we will be working
    heavily with formal proofs.  But this doesn't mean we can
    completely forget about informal ones!  Formal proofs are useful
    in many ways, but they are _not_ very efficient ways of
    communicating ideas between human beings. *)

(** For example, here is a proof that addition is associative: *)

Theorem plus_assoc' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof. intros n m p. induction n as [| n' IHn']. reflexivity.
  simpl. rewrite -> IHn'. reflexivity.  Qed.

(** Coq is perfectly happy with this.  For a human, however, it
    is difficult to make much sense of it.  We can use comments and
    bullets to show the structure a little more clearly... *)

Theorem plus_assoc'' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n' IHn'].
  - (* n = 0 *)
    reflexivity.
  - (* n = S n' *)
    simpl. rewrite -> IHn'. reflexivity.   Qed.

(** ... and if you're used to Coq you may be able to step
    through the tactics one after the other in your mind and imagine
    the state of the context and goal stack at each point, but if the
    proof were even a little bit more complicated this would be next
    to impossible.

    A (pedantic) mathematician might write the proof something like
    this: *)

(** - _Theorem_: For any [n], [m] and [p],

      n + (m + p) = (n + m) + p.

    _Proof_: By induction on [n].

    - First, suppose [n = 0].  We must show

        0 + (m + p) = (0 + m) + p.

      This follows directly from the definition of [+].

    - Next, suppose [n = S n'], where

        n' + (m + p) = (n' + m) + p.

      We must show

        (S n') + (m + p) = ((S n') + m) + p.

      By the definition of [+], this follows from

        S (n' + (m + p)) = S ((n' + m) + p),

      which is immediate from the induction hypothesis.  _Qed_. *)

(** The overall form of the proof is basically similar, and of
    course this is no accident: Coq has been designed so that its
    [induction] tactic generates the same sub-goals, in the same
    order, as the bullet points that a mathematician would write.  But
    there are significant differences of detail: the formal proof is
    much more explicit in some ways (e.g., the use of [reflexivity])
    but much less explicit in others (in particular, the "proof state"
    at any given point in the Coq proof is completely implicit,
    whereas the informal proof reminds the reader several times where
    things stand). *)

(** **** Exercise: 2 stars, advanced, recommended (plus_comm_informal)  *)
(** Translate your solution for [plus_comm] into an informal proof:

    Theorem: Addition is commutative.

    Proof:

    let m, n be natural numbers.
    we will induct on n.
    - First, suppose n = 0. We must show 0 + m = m + 0

      0 + m = m = m + 0

    - Second, suppose n = S n' where n' + m = m + n'
      We must show n + m = m + n
      S n' + m = m + S n'
      which by definition of addition implies
      S (n' + m) = S (m + n')
      which by the inductive hypothesis implies
      S (n' + m) = S(n' + m)
      Thus we conclude Addition is commutative.
*)
(** [] *)

(** **** Exercise: 2 stars, optional (beq_nat_refl_informal)  *)
(** Write an informal proof of the following theorem, using the
    informal proof of [plus_assoc] as a model.  Don't just
    paraphrase the Coq tactics into English!

    Theorem: [true = beq_nat n n] for any [n].

    Proof: By Induction
    - First 0 = 0 by definition.
    - Second given n = S (n') and n' = n'
      we need to show n = n
      by the inductive hypothesis
      n - 1 = n - 1
      add 1 to both sides
      n = n
      Qed.

[] *)

(* ################################################################# *)
(** * More Exercises *)

(** **** Exercise: 3 stars, recommended (mult_comm)  *)
(** Use [assert] to help prove this theorem.  You shouldn't need to
    use induction on [plus_swap]. *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  intros n m p.
  (* Local associativity *)
  assert (H1: n + (m + p) = (n + m) + p).
  {rewrite -> plus_assoc. reflexivity. }
  rewrite -> H1.
  (* Local commutitivity *)
  assert (H2: n + m = m + n).
  {rewrite -> plus_comm. reflexivity. }
  rewrite -> H2.
  (* associativity *)
  rewrite -> plus_assoc. reflexivity. Qed.

(** Now prove commutativity of multiplication.  (You will probably
    need to define and prove a separate subsidiary theorem to be used
    in the proof of this one.  You may find that [plus_swap] comes in
    handy.) *)

Theorem mult_1_r : forall p: nat, p * 1 = p.
Proof.
  induction p as [| p' IHp'].
  - reflexivity.
  - simpl. rewrite -> IHp'. reflexivity. Qed.

Lemma mult_n_Sm : forall m n : nat,
    n * (S m) = n + n * m.
Proof.
  intros n m. induction m.
  - reflexivity.
  - simpl. rewrite -> IHm. rewrite -> plus_swap. reflexivity.
Qed.

Theorem mult_comm : forall m n : nat,
  m * n = n * m.
Proof.
  induction n as [n|n' IHn'].
  - simpl. rewrite -> mult_0_r. reflexivity.
  - simpl. rewrite -> mult_n_Sm. rewrite -> IHn'.
    rewrite -> plus_comm. reflexivity. Qed.

(** [] *)

(** **** Exercise: 3 stars, optional (more_exercises)  *)
(** Take a piece of paper.  For each of the following theorems, first
    _think_ about whether (a) it can be proved using only
    simplification and rewriting, (b) it also requires case
    analysis ([destruct]), or (c) it also requires induction.  Write
    down your prediction.  Then fill in the proof.  (There is no need
    to turn in your piece of paper; this is just to encourage you to
    reflect before you hack!) *)

Check leb.

Theorem leb_refl : forall n:nat,
  true = leb n n.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem zero_nbeq_S : forall n:nat,
  beq_nat 0 (S n) = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem plus_ble_compat_l : forall n m p : nat,
  leb n m = true -> leb (p + n) (p + m) = true.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem S_nbeq_0 : forall n:nat,
  beq_nat (S n) 0 = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem mult_1_l : forall n:nat, 1 * n = n.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem all3_spec : forall b c : bool,
    orb
      (andb b c)
      (orb (negb b)
               (negb c))
  = true.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  (* FILL IN HERE *) Admitted.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (beq_nat_refl)  *)
(** Prove the following theorem.  (Putting the [true] on the left-hand
    side of the equality may look odd, but this is how the theorem is
    stated in the Coq standard library, so we follow suit.  Rewriting
    works equally well in either direction, so we will have no problem
    using the theorem no matter which way we state it.) *)

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  induction n as [| n' IHn'].
  - reflexivity.
  - simpl. rewrite <- IHn'. reflexivity. Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (plus_swap')  *)
(** The [replace] tactic allows you to specify a particular subterm to
   rewrite and what you want it rewritten to: [replace (t) with (u)]
   replaces (all copies of) expression [t] in the goal by expression
   [u], and generates [t = u] as an additional subgoal. This is often
   useful when a plain [rewrite] acts on the wrong part of the goal.

   Use the [replace] tactic to do a proof of [plus_swap'], just like
   [plus_swap] but without needing [assert (n + m = m + n)]. *)

Theorem plus_swap' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 3 stars, recommended (binary_commute)  *)
(** Recall the [incr] and [bin_to_nat] functions that you
    wrote for the [binary] exercise in the [Basics] chapter.  Prove
    that the following diagram commutes:

                            incr
              bin ----------------------> bin
               |                           |
    bin_to_nat |                           |  bin_to_nat
               |                           |
               v                           v
              nat ----------------------> nat
                             S

    That is, incrementing a binary number and then converting it to
    a (unary) natural number yields the same result as first converting
    it to a natural number and then incrementing.
    Name your theorem [bin_to_nat_pres_incr] ("pres" for "preserves").

    Before you start working on this exercise, copy the definitions
    from your solution to the [binary] exercise here so that this file
    can be graded on its own.  If you want to change your original
    definitions to make the property easier to prove, feel free to
    do so! *)

(* FILL IN HERE *)
(** [] *)

(** **** Exercise: 5 stars, advanced (binary_inverse)  *)
(** This exercise is a continuation of the previous exercise about
    binary numbers.  You will need your definitions and theorems from
    there to complete this one; please copy them to this file to make
    it self contained for grading.

    (a) First, write a function to convert natural numbers to binary
        numbers.  Then prove that starting with any natural number,
        converting to binary, then converting back yields the same
        natural number you started with.

    (b) You might naturally think that we should also prove the
        opposite direction: that starting with a binary number,
        converting to a natural, and then back to binary yields the
        same number we started with.  However, this is not true!
        Explain what the problem is.

    (c) Define a "direct" normalization function -- i.e., a function
        [normalize] from binary numbers to binary numbers such that,
        for any binary number b, converting to a natural and then back
        to binary yields [(normalize b)].  Prove it.  (Warning: This
        part is tricky!)

    Again, feel free to change your earlier definitions if this helps
    here. *)

(* FILL IN HERE *)
(** [] *)

(** $Date: 2017-10-09 14:36:24 -0400 (Mon, 09 Oct 2017) $ *)


Require Export TopologicalSpaces.
Require Export Continuity.
Require Export SubspaceTopology.

Section continuous_factorization.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.
Variable S:Ensemble (point_set Y).
Hypothesis f_cont: continuous f.
Hypothesis f_img: forall x:point_set X, In S (f x).

Definition continuous_factorization :
  point_set X -> point_set (SubspaceTopology S) :=
  fun x:point_set X => exist _ (f x) (f_img x).

Lemma factorization_is_continuous:
  continuous continuous_factorization.
Proof.
red; intros.
destruct (subspace_topology_topology _ _ V H) as [V' []].
rewrite H1.
rewrite <- inverse_image_composition.
simpl.
assert (inverse_image (fun x:point_set X => f x) V' =
        inverse_image f V').
apply Extensionality_Ensembles; split; red; intros.
destruct H2; constructor; trivial.
destruct H2; constructor; trivial.
rewrite H2.
apply f_cont; trivial.
Qed.

End continuous_factorization.

Arguments continuous_factorization {X} {Y}.

Section continuous_surj_factorization.

Variable X Y:TopologicalSpace.
Variable f:point_set X -> point_set Y.
Hypothesis f_cont: continuous f.

Definition continuous_surj_factorization :
  point_set X -> point_set (SubspaceTopology (Im Full_set f)).
apply continuous_factorization with f.
intros.
exists x.
constructor.
trivial.
Defined.

Lemma continuous_surj_factorization_is_surjective:
  surjective continuous_surj_factorization.
Proof.
red; intros.
destruct y.
destruct i.
exists x.
unfold continuous_surj_factorization.
unfold continuous_factorization.
pose proof (e).
symmetry in H.
destruct H.
f_equal.
f_equal.
apply proof_irrelevance.
apply proof_irrelevance.
Qed.

Lemma continuous_surj_factorization_is_continuous:
  continuous continuous_surj_factorization.
Proof.
apply factorization_is_continuous.
exact f_cont.
Qed.

End continuous_surj_factorization.

Arguments continuous_surj_factorization {X} {Y}.


Require Import init.

Require Export linear_base.
Require Export linear_combination.
Require Import set.
Require Import unordered_list.

#[universes(template)]
Record Subspace U V `{Plus V, Zero V, ScalarMult U V} := make_subspace {
    subspace_set : V → Prop;
    subspace_zero : subspace_set 0;
    subspace_plus : ∀ a b, subspace_set a → subspace_set b → subspace_set (a+b);
    subspace_scalar : ∀ a v, subspace_set v → subspace_set (a · v);
}.
Arguments make_subspace {U V H H0 H1}.
Arguments subspace_set {U V H H0 H1}.
Arguments subspace_zero {U V H H0 H1}.
Arguments subspace_plus {U V H H0 H1}.
Arguments subspace_scalar {U V H H0 H1}.

(* begin hide *)
Section Subspace.

Context {U V} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    UM : Mult U,
    UO : One U,
    @PlusComm U UP,
    @PlusLid U UP UZ,
    @PlusLinv U UP UZ UN,

    VP : Plus V,
    VZ : Zero V,
    VN : Neg V,
    @PlusComm V VP,
    @PlusAssoc V VP,
    @PlusLid V VP VZ,
    @PlusLinv V VP VZ VN,

    SM : ScalarMult U V,
    @ScalarComp U V UM SM,
    @ScalarId U V UO SM,
    @ScalarLdist U V VP SM,
    @ScalarRdist U V UP VP SM
}.

(* end hide *)
Theorem subspace_eq : ∀ S1 S2 : Subspace U V, subspace_set S1 = subspace_set S2
    → S1 = S2.
Proof.
    intros [S1 S1_zero S1_plus S1_scalar] [S2 S2_zero S2_plus S2_scalar] eq.
    cbn in eq.
    subst S2.
    rewrite (proof_irrelevance S2_zero S1_zero).
    rewrite (proof_irrelevance S2_plus S1_plus).
    rewrite (proof_irrelevance S2_scalar S1_scalar).
    reflexivity.
Qed.

Variable S : Subspace U V.

Theorem subspace_neg : ∀ v, subspace_set S v → subspace_set S (-v).
Proof.
    intros v v_in.
    rewrite <- scalar_neg_one.
    apply subspace_scalar.
    exact v_in.
Qed.

Instance subspace_plus_class : Plus (set_type (subspace_set S)) := {
    plus a b := [[a|] + [b|] | subspace_plus S [a|] [b|] [|a] [|b]]
}.
Instance subspace_zero_class : Zero (set_type (subspace_set S)) := {
    zero := [0|subspace_zero S]
}.
Instance subspace_neg_class : Neg (set_type (subspace_set S)) := {
    neg a := [-[a|] | subspace_neg [a|] [|a]]
}.
Program Instance subspace_plus_comm : PlusComm (set_type (subspace_set S)).
Next Obligation.
    apply set_type_eq; cbn.
    apply plus_comm.
Qed.
Program Instance subspace_plus_assoc : PlusAssoc (set_type (subspace_set S)).
Next Obligation.
    apply set_type_eq; cbn.
    apply plus_assoc.
Qed.
Program Instance subspace_plus_lid : PlusLid (set_type (subspace_set S)).
Next Obligation.
    apply set_type_eq; cbn.
    apply plus_lid.
Qed.
Program Instance subspace_plus_linv : PlusLinv (set_type (subspace_set S)).
Next Obligation.
    apply set_type_eq; cbn.
    apply plus_linv.
Qed.
Instance subspace_scalar_class : ScalarMult U (set_type (subspace_set S)) := {
    scalar_mult a v := [a · [v|] | subspace_scalar S a [v|] [|v]]
}.
Program Instance subspace_scalar_comp : ScalarComp U (set_type (subspace_set S)).
Next Obligation.
    apply set_type_eq; cbn.
    apply scalar_comp.
Qed.
Program Instance subspace_scalar_id : ScalarId U (set_type (subspace_set S)).
Next Obligation.
    apply set_type_eq; cbn.
    apply scalar_id.
Qed.
Program Instance subspace_scalar_ldist : ScalarLdist U (set_type (subspace_set S)).
Next Obligation.
    apply set_type_eq; cbn.
    apply scalar_ldist.
Qed.
Program Instance subspace_scalar_rdist : ScalarRdist U (set_type (subspace_set S)).
Next Obligation.
    apply set_type_eq; cbn.
    apply scalar_rdist.
Qed.

(* begin hide *)
End Subspace.

Section QuotientSpace.

Context {U V} `{
    UP : Plus U,
    UZ : Zero U,
    UN : Neg U,
    UM : Mult U,
    UO : One U,
    @PlusComm U UP,
    @PlusLid U UP UZ,
    @PlusLinv U UP UZ UN,

    VP : Plus V,
    VZ : Zero V,
    VN : Neg V,
    @PlusComm V VP,
    @PlusAssoc V VP,
    @PlusLid V VP VZ,
    @PlusLinv V VP VZ VN,

    SM : ScalarMult U V,
    @ScalarComp U V UM SM,
    @ScalarId U V UO SM,
    @ScalarLdist U V VP SM,
    @ScalarRdist U V UP VP SM
}.
(* end hide *)
Variable S : Subspace U V.

Theorem subspace_linear_combination :
    ∀ l, linear_list_in (subspace_set S) l →
    subspace_set S (linear_combination l).
Proof.
    intros [l l_unique] Sl.
    unfold linear_list_in in Sl.
    unfold linear_combination; cbn in *.
    clear l_unique.
    induction l using ulist_induction.
    -   cbn.
        rewrite ulist_image_end, ulist_sum_end.
        apply subspace_zero.
    -   rewrite ulist_image_add, ulist_sum_add.
        rewrite ulist_prop_add in Sl.
        apply subspace_plus.
        +   apply subspace_scalar.
            apply Sl.
        +   apply IHl.
            apply Sl.
Qed.

Let subspace_eq a b := subspace_set S (a - b).
(** Declaring this in algebra_scope is a bit of a hack to allow us to redefine
it later.
*)
(* begin show *)
Local Infix "~" := subspace_eq : algebra_scope.
(* end show *)

Lemma subspace_eq_reflexive : ∀ a, a ~ a.
Proof.
    intros a.
    unfold subspace_eq.
    rewrite plus_rinv.
    apply subspace_zero.
Qed.
Instance subspace_eq_reflexive_class : Reflexive _ := {
    refl := subspace_eq_reflexive
}.

Lemma subspace_eq_symmetric : ∀ a b, a ~ b → b ~ a.
Proof.
    unfold subspace_eq.
    intros a b ab.
    apply subspace_neg in ab.
    rewrite neg_plus in ab.
    rewrite neg_neg in ab.
    rewrite plus_comm in ab.
    exact ab.
Qed.
Instance subspace_eq_symmetric_class : Symmetric _ := {
    sym := subspace_eq_symmetric
}.

Lemma subspace_eq_transitive : ∀ a b c, a ~ b → b ~ c → a ~ c.
Proof.
    unfold subspace_eq.
    intros a b c ab bc.
    pose proof (subspace_plus S _ _ ab bc) as eq.
    rewrite plus_assoc in eq.
    rewrite plus_rlinv in eq.
    exact eq.
Qed.
Instance subspace_eq_transitive_class : Transitive _ := {
    trans := subspace_eq_transitive
}.

Definition subspace_equiv := make_equiv _ subspace_eq_reflexive_class
    subspace_eq_symmetric_class subspace_eq_transitive_class.

Definition quotient_space := equiv_type subspace_equiv.

(* begin show *)
Local Infix "~" := (eq_equal subspace_equiv).
(* end show *)

Lemma qspace_plus_wd : ∀ a b c d, a ~ b → c ~ d → a + c ~ b + d.
Proof.
    unfold eq_equal; cbn.
    unfold subspace_eq.
    intros a b c d ab cd.
    pose proof (subspace_plus S _ _ ab cd) as eq.
    rewrite <- plus_assoc in eq.
    rewrite (plus_assoc (-b)) in eq.
    rewrite (plus_comm (-b)) in eq.
    rewrite <- plus_assoc in eq.
    rewrite plus_assoc in eq.
    rewrite <- neg_plus in eq.
    exact eq.
Qed.

Instance quotient_space_plus : Plus quotient_space := {
    plus := binary_op (binary_self_wd qspace_plus_wd)
}.

Lemma qspace_plus_assoc : ∀ a b c, a + (b + c) = (a + b) + c.
Proof.
    intros a b c.
    equiv_get_value a b c.
    unfold plus; equiv_simpl.
    apply f_equal.
    apply plus_assoc.
Qed.
Instance quotient_space_plus_assoc : PlusAssoc quotient_space := {
    plus_assoc := qspace_plus_assoc
}.

Lemma qspace_plus_comm : ∀ a b, a + b = b + a.
Proof.
    intros a b.
    equiv_get_value a b.
    unfold plus; equiv_simpl.
    apply f_equal.
    apply plus_comm.
Qed.
Instance quotient_space_plus_comm : PlusComm quotient_space := {
    plus_comm := qspace_plus_comm
}.

Instance quotient_space_zero : Zero quotient_space := {
    zero := to_equiv subspace_equiv 0
}.

Lemma qspace_plus_lid : ∀ a, 0 + a = a.
Proof.
    intros a.
    equiv_get_value a.
    unfold zero, plus; equiv_simpl.
    apply f_equal.
    apply plus_lid.
Qed.
Instance quotient_space_plus_lid : PlusLid quotient_space := {
    plus_lid := qspace_plus_lid
}.

Lemma qspace_neg_wd : ∀ a b, a ~ b → -a ~ -b.
Proof.
    unfold eq_equal; cbn.
    unfold subspace_eq.
    intros a b eq.
    apply subspace_neg in eq.
    rewrite neg_plus in eq.
    exact eq.
Qed.
Instance quotient_space_neg : Neg quotient_space := {
    neg := unary_op (unary_self_wd qspace_neg_wd)
}.

Lemma qspace_plus_linv : ∀ a, -a + a = 0.
Proof.
    intros a.
    equiv_get_value a.
    unfold neg, plus, zero; equiv_simpl.
    rewrite plus_linv.
    reflexivity.
Qed.
Instance quotient_space_plus_linv : PlusLinv quotient_space := {
    plus_linv := qspace_plus_linv
}.

Lemma qspace_scalar_wd : ∀ c u v, u ~ v → c · u ~ c · v.
Proof.
    unfold eq_equal; cbn.
    unfold subspace_eq.
    intros c u v eq.
    apply (subspace_scalar S c) in eq.
    rewrite scalar_ldist in eq.
    rewrite scalar_rneg in eq.
    exact eq.
Qed.
Instance quotient_space_scalar_mult : ScalarMult U quotient_space := {
    scalar_mult c := unary_op (unary_self_wd (qspace_scalar_wd c))
}.

Lemma qspace_scalar_comp : ∀ a b v, a · (b · v) = (a * b) · v.
Proof.
    intros a b v.
    equiv_get_value v.
    unfold scalar_mult; equiv_simpl.
    rewrite scalar_comp.
    reflexivity.
Qed.
Instance quotient_space_scalar_comp : ScalarComp _ _ := {
    scalar_comp := qspace_scalar_comp
}.

Lemma qspace_scalar_id : ∀ v, 1 · v = v.
Proof.
    intros v.
    equiv_get_value v.
    unfold scalar_mult; equiv_simpl.
    rewrite scalar_id.
    reflexivity.
Qed.
Instance quotient_space_scalar_id : ScalarId _ _ := {
    scalar_id := qspace_scalar_id
}.

Lemma qspace_scalar_ldist : ∀ a u v, a · (u + v) = a · u + a · v.
Proof.
    intros a u v.
    equiv_get_value u v.
    unfold scalar_mult, plus; equiv_simpl.
    rewrite scalar_ldist.
    reflexivity.
Qed.
Instance quotient_space_scalar_ldist : ScalarLdist _ _ := {
    scalar_ldist := qspace_scalar_ldist
}.

Lemma qspace_scalar_rdist : ∀ a b v, (a + b) · v = a · v + b · v.
Proof.
    intros a b v.
    equiv_get_value v.
    unfold scalar_mult, plus at 2; equiv_simpl.
    rewrite scalar_rdist.
    reflexivity.
Qed.
Instance quotient_space_scalar_rdist : ScalarRdist _ _ := {
    scalar_rdist := qspace_scalar_rdist
}.
(* begin hide *)

End QuotientSpace.
(* end hide *)


(* infotheo (c) AIST. R. Affeldt, M. Hagiwara, J. Senizergues. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial ssralg finset fingroup finalg matrix.
Require Import Reals Fourier.
Require Import Reals_ext ssr_ext ssralg_ext Rssr log2 Rbigop proba entropy ln_facts.
Require Import arg_rmax num_occ types jtypes divergence conditional_divergence entropy.
Require Import channel_code channel.

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

Local Open Scope channel_code_scope.
Local Open Scope channel_scope.
Local Open Scope entropy_scope.
Local Open Scope tuple_ext_scope.
Local Open Scope reals_ext_scope.

Section scha_def.

Variables B A M : finType.
Variable n : nat.

(** Decoding success rate: *)

Definition scha (W : `Ch_1(A, B)) (c : code A B M n) := 1 - echa(W , c).

End scha_def.

Notation "scha( W , C )" := (scha W C) (at level 50) : channel_code_scope.

Section scha_facts.

Variables B A M : finType.
Hypothesis Mnot0 : (0 < #|M|)%nat.
Variable n : nat.

Lemma scha_pos (W : `Ch_1(A, B)) (c : code A B M n) : 0 <= scha(W, c).
Proof. rewrite /scha; by apply Rge_le, Rge_minus, Rle_ge, echa1. Qed.

(** Expression of the success rate of decoding: *)

Lemma success_decode (W : `Ch_1(A, B)) (c : code A B M n) :
  scha(W, c) = 1 / INR #|M| *
    \rsum_(m : M) \rsum_(tb | dec c tb == Some m) (W ``^ n (| enc c m)) tb.
Proof.
set rhs := \rsum_(m | _ ) _.
have {rhs}-> : rhs = \rsum_(m | m \in M)
  (1 - Pr (W ``^ n (| enc c m)) [set y | dec c y != Some m ]).
  apply eq_bigr => i Hi.
  transitivity (1 - Pr (W ``^ n (|(enc c) i)) (~: [set y | (dec c) y == Some i])).
    rewrite -Pr_to_cplt.
    apply eq_bigl => t /=.
    by rewrite inE.
  f_equal.
  apply eq_bigl => tb /=.
  by rewrite in_setC !inE.
set rhs := \rsum_(m | _ ) _.
have {rhs}-> : rhs = INR #|M|
  - \rsum_(m | m \in M) Pr (W ``^ n (| enc c m)) [set y | dec c y != Some m ].
  rewrite /rhs {rhs} big_split /= big_const iter_Rplus mulR1.
  set lhs := \rsum_(m | _ ) _.
  set rhs := \rsum_(m | _ ) _.
  suff : lhs = - rhs by move=> ->; field.
  by rewrite /rhs /lhs {rhs lhs} (big_morph _ morph_Ropp Ropp_0).
rewrite Rmult_minus_distr_l /Rdiv -mulRA -Rinv_l_sym; last first.
  apply not_0_INR => abs.
  move: (Mnot0); by rewrite abs.
by rewrite mul1R.
Qed.

End scha_facts.

Local Open Scope types_scope.
Local Open Scope divergence_scope.
Local Open Scope set_scope.

Section typed_success_decomp_sect.

Variables A B M : finType.
Variable W : `Ch_1*(A, B).
Hypothesis Mnot0 : (0 < #|M|)%nat.

Variable n' : nat.
Let n := n'.+1.
Variable P : P_ n ( A ).

(** Bound of the success rate of decoding for typed codes
   using conditional divergence: *)

Definition success_factor (tc : typed_code B M P) (V : P_ n (A , B)) :=
  exp2 (- INR n * `H(V | P)) / INR #|M| *
  \rsum_ (m : M) INR #| (V.-shell (tuple_of_row (enc tc m ))) :&:
                        (@tuple_of_row B n @: ((dec tc) @^-1: [set Some m])) |.

Let Anot0 : (0 < #|A|)%nat. Proof. by case: W. Qed.

Let Bnot0 : (0 < #|B|)%nat.
Proof.
case/card_gt0P : Anot0 => a _; exact (dist_support_not_empty (W a)).
Qed.

Lemma typed_success (tc : typed_code B M P) : scha(W, tc) =
  \rsum_ (V | V \in \nu^{B}(P)) exp_cdiv P V W * success_factor tc V.
Proof.
rewrite success_decode // /Rdiv mul1R; f_equal.
symmetry.
transitivity (/ INR #|M| * \rsum_(m : M) \rsum_(V | V \in \nu^{B}(P))
    exp_cdiv P V W * INR #| V.-shell (tuple_of_row (enc tc m)) :&:
                            (@tuple_of_row B n @: (dec tc @^-1: [set Some m])) | *
    exp2 (- INR n * `H(V | P))).
  rewrite exchange_big /= big_distrr /=.
  apply eq_bigr => V _.
  rewrite /success_factor !mulRA -(mulRC (/ INR #|M|)) -!mulRA; f_equal.
  symmetry; rewrite -big_distrl /= -big_distrr /= -mulRA; f_equal.
  by rewrite mulRC.
f_equal.
apply eq_bigr=> m _.
rewrite (reindex_onto (@row_of_tuple B n) (@tuple_of_row B n)); last first.
  move=> i Hi; by rewrite tuple_of_rowK.
rewrite (sum_tuples_ctypes (typed_prop tc m)) //.
apply eq_bigr=> V HV.
rewrite -mulRA mulRC -mulRA -iter_Rplus_Rmult -big_const.
apply eq_big => tb.
- rewrite inE row_of_tupleK eqxx andbT.
  f_equal.
  apply/imsetP/idP.
    case=> v H ->; rewrite tuple_of_rowK.
    by rewrite 2!inE in H.
  move=> Hm.
  exists (row_of_tuple tb); last by rewrite row_of_tupleK.
  by rewrite !inE.
- rewrite in_set.
  move=> /andP [Htb _].
  rewrite mulRC -(@dmc_exp_cdiv_cond_entropy _ _ _ _ _ _ _ (row_of_tuple tb) (typed_prop tc m) HV) //.
  by rewrite row_of_tupleK.
Qed.

End typed_success_decomp_sect.

Section typed_success_factor_bound_sect.

Variables A B M : finType.
Hypothesis Mnot0 : (0 < #|M|)%nat.

Variable n' : nat.
Let n := n'.+1.
Variable V : P_ n ( A , B ).
Variable P : P_ n ( A ).

(** * Bound of the success rate of decoding for typed codes *)

Definition success_factor_bound :=
  exp2(- INR n * +| log (INR #|M|) / INR n - `I(P ; V) |).

Variable tc : typed_code B M P.
Hypothesis Vctyp : V \in \nu^{B}(P).

Lemma success_factor_bound_part1 : success_factor tc V <= 1.
Proof.
apply (Rmult_le_reg_l (INR #|M|)); first by apply lt_0_INR; apply/ltP.
rewrite /success_factor /Rdiv -(mulRC (/ INR #|M|)) 2!mulRA Rinv_r; last first.
  apply not_0_INR => /eqP; apply/negP; by rewrite -lt0n.
rewrite mul1R -iter_Rplus_Rmult -big_const /=.
rewrite (_ : \rsum_(m | m \in M ) 1 = \rsum_(m : M) 1); last by apply eq_bigl.
rewrite big_distrr /=.
apply: Rle_big_P_f_g => m _.
rewrite Ropp_mult_distr_l_reverse exp2_Ropp.
apply (Rmult_le_reg_l (exp2 (INR n * `H( V | P)))); first by apply exp2_pos.
rewrite mulRA Rinv_r; last by apply exp2_not_0.
rewrite mulR1 mul1R.
apply (Rle_trans _ (INR #| V.-shell (tuple_of_row (enc tc m)) |) _); last first.
  apply card_shelled_tuples => //.
  by apply typed_prop.
  case: (jtype.c V) => _ Anot0.
  case/card_gt0P : (Anot0) => a _.
  by move: (dist_support_not_empty (V a)) => Bnot0.
apply le_INR; apply/leP.
apply subset_leq_card.
apply/setIidPl/setP => tb.
by rewrite in_set in_set andbC andbA andbb.
Qed.

Let partition_pre_image : {set set_of_finType [finType of n.-tuple B]} :=
  [set T_{ `tO( V ) } :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m])) |
   m in M & [exists y, y \in T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m]))]].

Let trivIset_pre_image : trivIset partition_pre_image.
Proof.
apply/trivIsetP => /= E F.
case/imsetP => m _ Em.
case/imsetP => l _ El diffEF.
have m_l : m != l by apply/negP => /eqP abs; move: diffEF; apply/negPn/negPn; subst.
rewrite disjoints_subset; apply/subsetP => y; subst E F; rewrite !in_set => /andP [H1 /eqP H2].
rewrite H1 andTb.
move/eqP in H2.
case/imsetP : H2 => y1 Hy1 yy1.
apply/imsetP; case => y2 Hy2 yy2.
rewrite !inE in Hy1.
rewrite !inE in Hy2.
subst y.
move/tuple_of_row_inj : yy2 => ?; subst y2.
rewrite (eqP Hy1) in Hy2.
case/eqP : Hy2 => ?; subst l.
by rewrite eqxx in m_l.
Qed.

Let cover_pre_image : cover partition_pre_image =
  \bigcup_(m : M) (T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m]))).
Proof.
apply/setP => tb.
case/boolP : (tb \in cover partition_pre_image) => Hcase.
- symmetry; case/bigcupP: Hcase => E.
  rewrite /partition_pre_image; case/imsetP => m _ Em ; subst E => Hcase.
  apply/bigcupP; by exists m.
- symmetry.
  apply/negP => abs; move: Hcase; apply/negP/negPn.
  case/bigcupP : abs => m _ H.
  rewrite /cover /partition_pre_image.
  apply/bigcupP; exists (T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m]))) => //.
  apply/imsetP; exists m => //.
  rewrite in_set; apply/andP; split => //.
  apply/existsP; by exists tb.
Qed.

Lemma success_factor_bound_part2 :
  success_factor tc V <=  exp2(INR n * `I(P ; V)) / INR #|M|.
Proof.
rewrite /success_factor -mulRA (mulRC (/ INR #|M|)) !mulRA.
apply Rmult_le_compat_r; first by apply Rlt_le, Rinv_0_lt_compat, lt_0_INR; apply/ltP.
rewrite /mut_info /Rminus addRC addRA.
rewrite (_ : - `H(P , V) + `H P = - `H( V | P )); last by rewrite /cond_entropy; field.
rewrite mulRDr Ropp_mult_distr_r_reverse -Ropp_mult_distr_l_reverse exp2_plus.
apply Rmult_le_compat_l; first by apply Rlt_le, exp2_pos.
rewrite -(@big_morph _ _ _ 0 _ O _ morph_plus_INR Logic.eq_refl).
apply (Rle_trans _ (INR #| T_{`tO( V )} |)); last first.
  rewrite -output_type_out_entropy //; by apply card_typed_tuples.
apply le_INR; apply/leP.
apply: (@leq_trans (\sum_m #| T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some m]))|)).
- apply leq_sum => m _.
  by apply subset_leq_card, setSI, shell_subset_output_type.
- set lhs := \sum_ _ _.
  rewrite (_ : lhs = #|\bigcup_(i : M) (T_{`tO( V )} :&: (@tuple_of_row B n @: (dec tc @^-1: [set Some i]))) | ); last first.
    subst lhs.
    rewrite -cover_pre_image.
    move: trivIset_pre_image ; rewrite /trivIset => /eqP => <-.
    rewrite big_imset /= ; last first.
      move=> m l _.
      rewrite in_set; case/existsP => tb Htb.
      move/setP/(_ tb); rewrite Htb; move: Htb.
      rewrite in_set => /andP [_ Hl].
      rewrite in_set => /andP [_ Hm].
      apply Some_inj.
      move: Hl Hm.
      case/imsetP => v1 Hv1 ->.
      case/imsetP => v2 Hv2.
      move/tuple_of_row_inj => ?; subst v2.
      rewrite !inE in Hv1, Hv2.
      by rewrite -(eqP Hv1) -(eqP Hv2).
    symmetry; rewrite big_mkcond /=.
    apply eq_bigr => m _.
    case : ifP => //; rewrite in_set => /negbT H.
    symmetry; apply/eqP/negPn/negP => abs ; move: H.
    apply/negP/negPn/existsP/card_gt0P; by rewrite lt0n.
  apply subset_leq_card; apply/subsetP => tb.
  case/bigcupP => m _.
  by rewrite in_set => /andP [H _].
Qed.

Lemma success_factor_ub :
  success_factor tc V <= success_factor_bound.
Proof.
rewrite /success_factor_bound.
apply Rmax_case.
- rewrite mulR0 exp2_0; by apply success_factor_bound_part1.
- apply (Rle_trans _ (exp2(INR n * `I(P ; V)) / INR #|M|)); last first.
  + apply Req_le; symmetry.
    rewrite /Rminus mulRDr mulRC.
    rewrite Rmult_opp_opp -mulRA Ropp_mult_distr_r_reverse Rinv_l; last first.
      apply not_0_INR => /eqP; by apply/negP.
    rewrite Ropp_mult_distr_r_reverse mulR1 exp2_plus mulRC /Rdiv; f_equal.
    rewrite exp2_Ropp exp2_log //.
    apply lt_0_INR; by apply/ltP.
  + by apply success_factor_bound_part2.
Qed.

End typed_success_factor_bound_sect.

Section typed_success_bound_sect.

Variables A B M : finType.
Variable W : `Ch_1*(A, B).
Hypothesis Mnot0 : (0 < #|M|)%nat.

Variable n' : nat.
Let n := n'.+1.
Variable P : P_ n ( A ).
Variable tc : typed_code B M P.

Let Anot0 : (0 < #|A|)%nat.
Proof.
by case: (W) => _ Anot0.
Qed.

Let Bnot0 : (0 < #|B|)%nat.
Proof.
case/card_gt0P : Anot0 => a _.
by move: (dist_support_not_empty (W a)) => Bnot0.
Qed.

Let V0 : P_ n (A, B).
Proof.
move: (jtype_not_empty n Anot0 Bnot0) => H.
exact (enum_val (Ordinal H)).
Qed.

Let exp_cdiv_bound := fun V => exp_cdiv P V W * success_factor_bound M V P.

(** Bound of the success rate of decoding for typed codes
   using mutual information: *)

Lemma typed_success_bound :
  let Vmax := arg_rmax V0 [pred V | V \in \nu^{B}(P)] exp_cdiv_bound in
  scha(W, tc) <= (INR n.+1)^(#|A| * #|B|) * exp_cdiv_bound Vmax.
Proof.
move=> Vmax.
rewrite (typed_success W Mnot0 tc).
apply (Rle_trans _ ( \rsum_(V|V \in \nu^{B}(P)) exp_cdiv P V W *
  exp2 (- INR n *  +| log (INR #|M|) * / INR n - `I(P ; V) |))).
  apply: Rle_big_P_f_g => V HV.
  rewrite -mulRA; apply Rmult_le_compat_l.
    rewrite /exp_cdiv.
    case : ifP => _.
    by apply Rlt_le, exp2_pos.
    by apply Rle_refl.
  rewrite /success_factor mulRA.
  apply: success_factor_ub => //.
apply (Rle_trans _ (\rsum_(V | V \in \nu^{B}(P)) exp_cdiv P Vmax W *
                    exp2 (- INR n * +| log (INR #|M|) * / INR n - `I(P ; Vmax)|))).
  apply: Rle_big_P_f_g => V HV.
  move: (@arg_rmax2 [finType of (P_ n (A, B))] V0 [pred V | V \in \nu^{B}(P) ]
                    (fun V => exp_cdiv P V W * success_factor_bound M V P)).
  apply => //; by exists V.
rewrite big_const iter_Rplus_Rmult /success_factor_bound.
apply Rmult_le_compat_r.
- apply Rmult_le_pos.
  + rewrite /exp_cdiv; case : ifP => _; by [apply Rlt_le, exp2_pos | apply Rle_refl].
  + by apply Rlt_le, exp2_pos.
- rewrite INR_pow_expn; apply le_INR; apply/leP.
  by apply card_nu.
Qed.

End typed_success_bound_sect.

Section success_bound_sect.

Variables A B M : finType.
Variable W : `Ch_1*(A, B).
Hypothesis Mnot0 : (0 < #|M|)%nat.

Variable n' : nat.
Let n := n'.+1.
Variable c : code A B M n.

Lemma Anot0 : (0 < #|A|)%nat.
Proof.
by case: (W) => _ Anot0.
Qed.

Let P0 : P_ n ( A ).
Proof.
move: (type_not_empty n' Anot0) => H.
exact (enum_val (Ordinal H)).
Defined.

Local Open Scope num_occ_scope.

(** * Bound of the success rate of decoding *)

Lemma success_bound :
  let Pmax := arg_rmax P0 predT (fun P => scha(W, P.-typed_code c)) in
  scha(W, c) <= (INR n.+1) ^ #|A| * scha(W, Pmax.-typed_code c).
Proof.
move=> Pmax.
apply (Rle_trans _ (INR #| P_ n ( A ) | * scha W (Pmax.-typed_code c))); last first.
  apply Rmult_le_compat_r; first by apply scha_pos.
  rewrite INR_pow_expn; apply le_INR; apply/leP.
  exact: (type_counting A n).
apply (Rle_trans _ (\rsum_(P : P_ n ( A )) scha W (P.-typed_code c))); last first.
  rewrite (_ : INR #| P_ n ( A ) | * scha W (Pmax.-typed_code c) =
             \rsum_(P : P_ n ( A )) scha W (Pmax.-typed_code c)); last first.
    by rewrite big_const iter_Rplus_Rmult.
  apply: Rle_big_P_f_g => P _.
  apply: (@arg_rmax2 _ P0 xpredT (fun P1 : P_ n (A) => scha(W, P1.-typed_code c))).
  by exists P.
  reflexivity.
rewrite success_decode // -(sum_messages_types c).
rewrite /Rdiv mul1R (big_morph _ (morph_mulRDr _) (mulR0 _)).
apply: Rle_big_P_f_g => P _.
apply (Rmult_le_reg_l (INR #|M|)).
  apply lt_0_INR; by apply/ltP.
rewrite mulRA Rinv_r; last first.
  apply not_0_INR => /eqP; apply/negP; by rewrite -lt0n.
rewrite mul1R success_decode //.
rewrite /Rdiv mul1R mulRA Rinv_r; last first.
  apply not_0_INR => /eqP; apply/negP; by rewrite -lt0n.
rewrite mul1R.
apply (Rle_trans _ (\rsum_(m | m \in enc_pre_img c P)
                     \rsum_(y | (dec (P.-typed_code c)) y == Some m)
                     (W ``^ n (|(enc (P.-typed_code c)) m)) y)).
  apply: Rle_big_P_f_g => m Hm.
  apply Req_le, eq_big => tb // _.
  rewrite inE in Hm.
  by rewrite /tcode /= ffunE Hm.
- apply: Rle_big_f_X_Y => m //.
  apply: Rle_big_0_P_g => tb _; by apply Rle0f.
Qed.

End success_bound_sect.


Require Import Bool ZArith.

Open Scope Z_scope.

Ltac app :=
  match goal with
    | [H0 : ?a, H1 : ?a -> ?b |- _] => apply H1 in H0
  end.

Inductive iexpr : Set :=
| IConst : Z -> iexpr
| IVar : Z -> iexpr
| IAdd : iexpr -> iexpr -> iexpr
| IMul : iexpr -> iexpr -> iexpr.

Fixpoint sameIVar (i j : iexpr) : bool :=
  match i with
    | IVar v1 =>
      match j with
        | IVar v2 =>
          match Z.compare v1 v2 with
            | Eq => true
            | _ => false
          end
        | _ => false
      end
    | _ => false
  end.

Fixpoint sameIConst (i j : iexpr) : bool :=
  match i with
    | IConst v1 =>
      match j with
        | IConst v2 =>
          match Z.compare v1 v2 with
            | Eq => true
            | _ => false
          end
        | _ => false
      end
    | _ => false
  end.

Fixpoint iexprEq (i j : iexpr) : bool :=
  match i with
    | IAdd il ir =>
      match j with
        | IAdd jl jr =>
          (iexprEq il jl) && (iexprEq ir jr)
        | _ => false
      end
    | IMul il ir =>
      match j with
        | IMul jl jr => (iexprEq il jl) && (iexprEq ir jr)
        | _ => false
      end
    | IConst _ => sameIConst i j
    | IVar _ => sameIVar i j
  end.

Fixpoint isConst (i : iexpr) : bool :=
  match i with
    | IConst _ => true
    | _ => false
  end.

Fixpoint constVal (i : iexpr) : option Z :=
  match i with
    | IConst c => Some c
    | _ => None
  end.

Fixpoint isSome (A : Type) (v : option A) : bool :=
  match v with
    | Some _ => true
    | None => false
  end.

Theorem isSome_imp_v :
  forall (A : Type) (v : option A),
    isSome A v = true ->
    exists b : A, v = Some b.
Proof.
  intros; destruct v; [eapply ex_intro; reflexivity | discriminate].
Qed.

Fixpoint optionApply (A B : Type) (f : A -> A -> B) (l r : option A) : option B :=
  match l with
    | Some a =>
      match r with
        | Some b => Some (f a b)
        | _ => None
      end
    | None => None
  end.

Theorem optionApply_on_somes :
  forall (A B : Type) (f : A -> A -> B) (l r : option A),
    isSome A l = true ->
    isSome A r = true ->
    exists (a b : A), optionApply A B f l r = Some (f a b).
Proof.
  intros; pose proof isSome_imp_v as H1;

  apply H1 in H0;
  inversion H0 as [m0 Hm0];
  rewrite -> Hm0;

  apply H1 in H;
  inversion H as [m Hm];
  rewrite -> Hm;

  simpl;
  repeat (eapply ex_intro); reflexivity.
Qed.

Fixpoint constValRec (i : iexpr) : option Z :=
  match i with
    | IConst a => Some a
    | IVar _ => None
    | IAdd l r =>
      let lc := constValRec l in
      let rc := constValRec r in
      optionApply Z Z Z.add lc rc
    | IMul l r =>
      let lc := constValRec l in
      let rc := constValRec r in
      optionApply Z Z Z.mul lc rc
  end.

Theorem constValRec_on_const_gives_const :
  forall i : iexpr, isConst i = true -> constValRec i = constVal i.
Proof.
  intros; destruct i; solve [trivial | simpl; discriminate].
Qed.

Fixpoint allConstants (i : iexpr) : bool :=
  match i with
    | IConst _ => true
    | IVar _ => false
    | IAdd l r => andb (allConstants l) (allConstants r)
    | IMul l r => andb (allConstants l) (allConstants r)
  end.

Theorem allConstants_add_consts :
  forall i j : iexpr,
    allConstants (IAdd i j) = true ->
    (allConstants i = true /\ allConstants j = true).
Proof.
  intros; simpl allConstants in H;
  apply andb_true_iff in H; apply H.
Qed.

Theorem allConstants_mul_consts :
  forall i j : iexpr,
    allConstants (IMul i j) = true ->
    (allConstants i = true /\ allConstants j = true).
Proof.
  intros; simpl allConstants in H;
  apply andb_true_iff in H; apply H.
Qed.

Ltac startInduction n :=
  intros; induction n; trivial.

Theorem constValRec_works_on_allConstants :
  forall i : iexpr, allConstants i = true -> isSome Z (constValRec i) = true.
Proof.
  let start := startInduction i;
               apply allConstants_add_consts in H;
               inversion H as [Hl Hr];
               pose proof optionApply_on_somes as A in
  let finish := do 3 app; trivial;
                inversion Hl as [a Ha]; inversion Ha as [b Hb];
                simpl; rewrite -> Hb; trivial in
  let s1 := specialize (A Z Z Z.add (constValRec i1) (constValRec i2)) in
  let s2 := specialize (A Z Z Z.mul (constValRec i1) (constValRec i2)) in
  start; [s1; finish | s2; finish].
Qed.

Theorem constValRec_on_sum_of_consts :
  forall i j : iexpr,
    (exists a : Z, constValRec (IAdd i j) = Some a) ->
    ((exists b : Z, constValRec i = Some b) /\
     (exists c : Z, constValRec j = Some c)).
Proof.
  intros; inversion H as [m Hm]; simpl constValRec in Hm;
  destruct (constValRec i); destruct (constValRec j);
  split; first [discriminate | eapply ex_intro; trivial].
Qed.

Theorem constValRec_on_prod_of_consts :
  forall i j : iexpr,
    (exists a : Z, constValRec (IMul i j) = Some a) ->
    ((exists b : Z, constValRec i = Some b) /\
     (exists c : Z, constValRec j = Some c)).
Proof.
  intros; inversion H as [m Hm]; simpl constValRec in Hm;
  destruct (constValRec i); destruct (constValRec j);
  split; first [discriminate | eapply ex_intro; trivial].
Qed.

Theorem constValRec_works_imp_allConstants :
  forall i : iexpr, isSome Z (constValRec i) = true -> allConstants i = true.
Proof.
  let t := specialize (S i1 i2);
           apply isSome_imp_v in H;
           apply S in H; inversion H as [Hl Hr];
           inversion Hl as [m Hm]; inversion Hr as [n Hn];
           simpl allConstants;
           rewrite -> Hm in IHi1; simpl isSome in IHi1;
           rewrite -> Hn in IHi2; simpl isSome in IHi2;
           intuition in
   let p1 := pose proof constValRec_on_sum_of_consts as S in
   let p2 := pose proof constValRec_on_prod_of_consts as S in
   startInduction i; [p1; t | p2; t].
Qed.

Theorem constValRec_works_iff_allConstants :
  forall i : iexpr, isSome Z (constValRec i) = true <-> allConstants i = true.
Proof.
  intros; unfold iff;
  split; [apply constValRec_works_imp_allConstants |
          apply constValRec_works_on_allConstants].
Qed.

Fixpoint tryFoldConstantsRec (i : iexpr) : iexpr :=
  match constValRec i with
    | Some c => IConst c
    | None => i
  end.


(*
MacBook-Air:~ billw$ /Applications/CoqIDE_8.4pl5.app/Contents/Resources/bin/coqtop
Welcome to Coq 8.4pl5 (October 2014)

Coq < Require Import Classical.

Coq < Section Exercise_24.

Coq < Goal forall m n o p:Prop, (((m /\ n) \/ (o /\ p)) /\ ((n \/ o) -> ~p)) -> n.
1 subgoal

  ============================
   forall m n o p : Prop, (m /\ n \/ o /\ p) /\ (n \/ o -> ~ p) -> n

Unnamed_thm < intros.
1 subgoal

  m : Prop
  n : Prop
  o : Prop
  p : Prop
  H : (m /\ n \/ o /\ p) /\ (n \/ o -> ~ p)
  ============================
   n

Unnamed_thm < elim H.
1 subgoal

  m : Prop
  n : Prop
  o : Prop
  p : Prop
  H : (m /\ n \/ o /\ p) /\ (n \/ o -> ~ p)
  ============================
   m /\ n \/ o /\ p -> (n \/ o -> ~ p) -> n

Unnamed_thm < intro.
1 subgoal

  m : Prop
  n : Prop
  o : Prop
  p : Prop
  H : (m /\ n \/ o /\ p) /\ (n \/ o -> ~ p)
  H0 : m /\ n \/ o /\ p
  ============================
   (n \/ o -> ~ p) -> n

Unnamed_thm < intro.
1 subgoal

  m : Prop
  n : Prop
  o : Prop
  p : Prop
  H : (m /\ n \/ o /\ p) /\ (n \/ o -> ~ p)
  H0 : m /\ n \/ o /\ p
  H1 : n \/ o -> ~ p
  ============================
   n

Unnamed_thm < tauto.
No more subgoals.

Unnamed_thm < Qed.
intros.
elim H.
intro.
intro.
tauto.

Unnamed_thm is defined

Coq <

*)

Require Import Classical.
Section Exercise_24.
Goal forall m n o p:Prop, (((m /\ n) \/ (o /\ p)) /\ ((n \/ o) -> ~p)) -> n.
intros.
elim H.
intro.
intro.
 tauto.
 Qed.