(** * 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.


Require Export C12_Angles_Opposes.

Section SUPPLEMENTARY_ANGLES.

Definition Supplementary (alpha beta : AS) :=
exists A  : Point,  exists B  : Point,  exists C : Point,  exists D : Point,
	A <> C /\ Between B A D /\ Angle B A C = alpha /\ Angle C A D = beta.

Lemma SupplementaryCommut : forall alpha beta : AS,
	Supplementary alpha beta ->
	Supplementary beta alpha.
Proof.
	unfold Supplementary in |- *;
	 intros alpha beta (A, (B, (C, (D, (H0, (H1, (H2, H3))))))).
	exists A; exists D; exists C; exists B; intuition.
	 apply BetweenSym; trivial.
	 rewrite AngleSym.
	  trivial.
	  apply (BetweenDistinctBC _ _ _ H1).
	  trivial.
	 rewrite AngleSym.
	  trivial.
	  trivial.
	  apply (sym_not_eq (BetweenDistinctAB _ _ _ H1)).
Qed.

Lemma HalfLineBetweenBetween : forall A B C D : Point,
       	Between A C D ->
	HalfLine C A B ->
	Between B C D.
Proof.
	intros.
	apply BetweenSym; apply (BetweenHalfLineBetween D C A B).
	 apply BetweenSym; trivial.
	 trivial.
Qed.

Lemma SupplementBC : forall A B C D A' B' C' D' : Point,
	A <> C ->
	A' <> C' ->
	B <> C ->
	Between B A D ->
	Between B' A' D' ->
	Angle B A C = Angle B' A' C' ->
	Angle C A D = Angle C' A' D'.
Proof.
	intros A B C D A' B' C' D' dAC dA'C' dBC H0 H1 H2.
	assert (dAB := sym_not_eq (BetweenDistinctAB _ _ _ H0)).
	assert (dA'B' := sym_not_eq (BetweenDistinctAB _ _ _ H1)).
	destruct (ExistsHalfLineEquidistant A' B' A B dA'B' dAB) as (B'', (H3, H4)).
	destruct (ExistsHalfLineEquidistant A' C' A C dA'C' dAC) as (C'', (H5, H6)).
	assert (dAD := BetweenDistinctBC _ _ _ H0).
	assert (dA'D' := BetweenDistinctBC _ _ _ H1).
	destruct (ExistsHalfLineEquidistant A' D' A D dA'D' dAD) as (D'', (H7, H8)).
	rewrite (HalfLineAngleBC A' C' D' C'' D'' dA'C' dA'D' H5 H7).
	apply (CongruentSSS A C D A' C'' D'' dAC dAD (sym_eq H6) (sym_eq H8)).
	assert (dBD := sym_not_eq (BetweenDistinctCA _ _ _ H0)).
	assert (H9 : Distance B C = Distance B'' C'').
	 apply (CongruentSAS A B C A' B'' C'' dAB dAC (sym_eq H4) (sym_eq H6)).
	   rewrite H2; apply (HalfLineAngleBC A' B' C' B'' C'' dA'B' dA'C' H3 H5).
	 assert (H10 : Distance B D = Distance B'' D'').
	  rewrite <- (ChaslesBetween B A D H0).
	    rewrite (DistSym B A); rewrite <- H4.
	    rewrite <- H8; rewrite (DistSym A' B'').
	    apply ChaslesBetween.
	    apply (BetweenHalfLineBetween B'' A' D' D'').
	   apply (HalfLineBetweenBetween B'); trivial.
	   trivial.
	  apply (CongruentSAS B C D B'' C'' D'' dBC dBD H9 H10).
	    rewrite (HalfLineAngleC B C D A dBC dBD).
	   rewrite (HalfLineAngleC B'' C'' D'' A').
	    apply (CongruentSSS B C A B'' C'' A' dBC (sym_not_eq dAB) H9).
	     autoDistance.
	     autoDistance.
	    apply (EquiDistantDistinct B C B'' C'' dBC H9).
	    apply (EquiDistantDistinct B D B'' D'' dBD H10).
	    apply
	     (HalfLineSym B'' A' D''
	        (sym_not_eq (EquiDistantDistinct A B A' B'' dAB (sym_eq H4)))).
	      apply BetweenHalfLine.
	      apply (BetweenHalfLineBetween B'' A' D' D'').
	     apply (HalfLineBetweenBetween B'); trivial.
	     trivial.
	   apply (HalfLineSym B A D (sym_not_eq dAB)).
	     apply BetweenHalfLine; auto.
 Qed.

Lemma Supplement : forall A B C D A' B' C' D' : Point,
	A <> C ->
	A' <> C' ->
	Between B A D ->
	Between B' A' D' ->
	Angle B A C = Angle B' A' C' ->
	Angle C A D = Angle C' A' D'.
Proof.
	intros A B C D A' B' C' D' dAC dA'C' H0 H1 H2.
	assert (dAB := sym_not_eq (BetweenDistinctAB _ _ _ H0)).
	destruct (CentralSymetPoint A B dAB) as (B'', (H3, H4)).
	assert (dBB'' := BetweenDistinctBC A B B'' H4).
	destruct (Apart B B'' C dBB'').
	 apply (SupplementBC A B C D A' B' C' D' dAC dA'C' H H0 H1 H2).
	 apply (SupplementBC A B'' C D A' B' C' D' dAC dA'C' H).
	  apply (BetweenAssocRight B'' B A D (BetweenSym A B B'' H4) H0).
	  exact H1.
	  rewrite <- (HalfLineAngleB A B C B'' dAB dAC).
	   exact H2.
	   apply BetweenHalfLine; auto.
Qed.

Lemma SupplementaryEq : forall alpha beta gamma : AS,
	Supplementary alpha beta ->
	Supplementary alpha gamma ->
	beta = gamma.
Proof.
	unfold Supplementary in |- *;
	 intros alpha beta gamma (A, (B, (C, (D, (H0, (H1, (H2, H3)))))))
	  (A', (B', (C', (D', (H4, (H5, (H6, H7))))))).
	rewrite <- H3; rewrite <- H7.
	apply (Supplement A B C D A' B' C' D' H0 H4 H1 H5).
	subst; auto.
Qed.

Lemma OpposedAtVertex : forall A B C D E : Point,
	Between B A D ->
	Between C A E ->
	Angle B A C = Angle D A E.
Proof.
	intros.
	assert (dAB := sym_not_eq (BetweenDistinctAB _ _ _ H)).
	assert (dAC := sym_not_eq (BetweenDistinctAB _ _ _ H0)).
	rewrite (AngleSym A B C dAB dAC).
	assert (dAD := BetweenDistinctBC _ _ _ H).
	apply (Supplement A D C B A C D E dAC dAD).
	 apply BetweenSym; auto.
	 trivial.
	 apply AngleSym; auto.
Qed.

Lemma CongruentOpposedTriangles : forall A B C D I : Point,
	Between A I C ->
	Between B I D ->
	Distance I A = Distance I C ->
	Distance I B = Distance I D ->
	CongruentTriangles A I B C I D.
Proof.
	intros.
	apply CongruentTrianglesSASB.
	 trivial.
	 trivial.
	 apply OpposedAtVertex; trivial.
	 apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H).
	 apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H0).
Qed.

Lemma SupplementaryRec : forall A B C D : Point,
	Clockwise B A C ->
	Clockwise C A D ->
	Supplementary (Angle B A C) (Angle C A D) ->
	Between B A D.
Proof.
	intros.
	destruct H1 as (A', (B', (C', (D', (H1, (H2, (H3, H4))))))).
	destruct (ExistsHalfLineEquidistant A B A' B') as (B'', (H5, H6)).
	 autoDistinct.
	 apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H2).
	 destruct (ExistsHalfLineEquidistant A C A' C') as (C'', (H7, H8)).
	  autoDistinct.
	  trivial.
	  destruct (ExistsHalfLineEquidistant A D A' D') as (D'', (H9, H10)).
	   autoDistinct.
	   apply (BetweenDistinctBC _ _ _ H2).
	   destruct (ExistsBetweenEquidistant A B A' D') as (E, (H11, H12)).
	    autoDistinct.
	    apply (BetweenDistinctBC _ _ _ H2).
	    assert (CongruentStrictTriangles B'' A C'' B' A' C').
	     apply CongruentStrictTrianglesSASB.
	      trivial.
	      trivial.
	      rewrite H3; apply sym_eq; apply HalfLineAngleBC.
	       autoDistinct.
	       autoDistinct.
	       trivial.
	       trivial.
	      intro; elim (ClockwiseNotCollinear _ _ _ H).
	        apply CollinearBAC; apply (CollinearTrans A B'' B C).
	       apply (EquiDistantDistinct A' B' A B'').
	        apply sym_not_eq; apply (BetweenDistinctAB _ _ _ H2).
	        autoDistance.
	       apply CollinearACB; apply (HalfLineCollinear _ _ _ H5).
	       apply CollinearACB; apply (CollinearTrans A C'').
	        apply (EquiDistantDistinct A' C' A C''); auto.
	        apply CollinearACB; apply (HalfLineCollinear _ _ _ H7).
	        autoCollinear.
	     assert (CongruentStrictTriangles B'' E C'' B' D' C').
	      apply CongruentStrictTrianglesSASA.
	       rewrite <- (ChaslesBetween B'' A E).
	        rewrite (DistSym B'' A); rewrite H12; rewrite H6.
	          rewrite (DistSym A' B'); apply ChaslesBetween; auto.
	        apply BetweenSym; apply (BetweenHalfLineBetween E A B B''); trivial.
	       rewrite (DistSym B'' C''); rewrite (DistSym B' C').
	         apply (CongruentStrictTrianglesCA _ _ _ _ _ _ H13).
	       apply trans_eq with (y := Angle A B'' C'').
	        apply HalfLineAngleB.
	         intro; subst; canonize.
	           destruct (ClockwiseExists E A H2) as (F, H17).
	           elim (ClockwiseNotClockwise _ _ _ H17); auto.
	         intro; subst; elim (ClockwiseNotCollinear _ _ _ H).
	           apply CollinearBAC; apply (CollinearTrans A C'').
	          apply (EquiDistantDistinct A' C' A C''); auto.
	          apply CollinearACB; apply (HalfLineCollinear _ _ _ H5).
	          apply CollinearACB; apply (HalfLineCollinear _ _ _ H7).
	         apply HalfLineSym.
	          apply sym_not_eq; apply (HalfLineDistinct A B B'').
	           autoDistinct.
	           trivial.
	          apply BetweenHalfLine.
	            apply (HalfLineBetweenBetween B).
	           apply BetweenSym; trivial.
	           trivial.
	        apply trans_eq with (y := Angle A' B' C').
	         apply CongruentStrictTrianglesA; trivial.
	         apply HalfLineAngleB.
	          apply (BetweenDistinctAB _ _ _ H2).
	          intro; subst.
	            elim (ClockwiseNotCollinear _ _ _ H).
	            apply CollinearBAC; apply HalfLineCollinear.
	            apply NullAngleHalfLine.
	           autoDistinct.
	           autoDistinct.
	           rewrite <- H3; apply NullAngle.
	            trivial.
	            canonize.
	          apply BetweenHalfLine; trivial.
	       intro; destruct H13.
	         elim H15; apply (CollinearTrans B'' E).
	        intro; subst; canonize.
	          destruct (ClockwiseExists E A H2) as (F, H20).
	          elim (ClockwiseNotClockwise _ _ _ H20); auto.
	        apply CollinearBCA; apply (CollinearTrans A B).
	         autoDistinct.
	         apply (HalfLineCollinear _ _ _ H5).
	         apply CollinearBCA; apply (BetweenCollinear _ _ _ H11).
	        trivial.
	      assert (E = D'').
	       apply (SSSEqualCD C'' A).
	        clear H5 H2 H9; generalizeChange.
	          apply H15; apply ClockwiseCAB; apply H17; trivial.
	        clear H2 H5 H11; generalizeChangeSense.
	          apply H2; apply ClockwiseCAB; apply H9; autoClockwise.
	        apply trans_eq with (y := Distance C' D').
	         apply
	          (CongruentStrictTrianglesBC _ _ _ _ _ _
	             (CongruentStrictTrianglesACB _ _ _ _ _ _ H14)).
	         assert (CongruentStrictTriangles C'' A D'' C' A' D').
	          apply CongruentStrictTrianglesSASB.
	           trivial.
	           trivial.
	           rewrite H4; apply sym_eq; apply HalfLineAngleBC.
	            autoDistinct.
	            autoDistinct.
	            trivial.
	            trivial.
	           intro; elim (ClockwiseNotCollinear _ _ _ H0).
	             apply CollinearBAC; apply (CollinearTrans A C'').
	            apply (EquiDistantDistinct A' C'); auto.
	            apply CollinearACB; apply (HalfLineCollinear _ _ _ H7).
	            apply (CollinearTrans A D'').
	             apply (EquiDistantDistinct A' D').
	              apply (BetweenDistinctBC _ _ _ H2).
	              auto.
	             autoCollinear.
	             apply CollinearACB; apply (HalfLineCollinear _ _ _ H9).
	          apply sym_eq;
	           apply
	            (CongruentStrictTrianglesCA _ _ _ _ _ _
	               (CongruentStrictTrianglesCBA _ _ _ _ _ _ H15)).
	        autoDistance.
	       apply (BetweenHalfLineBetween B A D'').
	        subst; apply (BetweenSym _ _ _ H11).
	        apply HalfLineSym.
	         autoDistinct.
	         trivial.
Qed.

End SUPPLEMENTARY_ANGLES.


(**
Author: Niels van der Weide

Suppose, we have a set `X` with a binary operation `f : X → X → X`.
Since init elments for `f` are unique, the type of unit elements of `f` is a proposition.

This means we have two ways of defining a univalent category of sets with a unital binary operations:
1. We define it as a full subcategory of the category of sets with a binary operation
2. We use algebras of the signature describing sets with a binary operation and a unit, which satisfy the necessary axioms.
Note that in the first category the morphismms are all functions between sets which preserve the binary relation, while the morphisms in the second category must preserve the unit element as well.
As a consequence, the forgetful is full and faithful in the first construction, while in the second it is only faithful.

On the nLab, there are definitions which describe when functors forget properties and when functors forget stuff.
https://ncatlab.org/nlab/show/stuff%2C+structure%2C+property#definitions
With this terminology, we can argue why the first approach adds the unit as a property while in the second approach it is added as structure.
 *)
Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.Univalence.
Require Import UniMath.CategoryTheory.PrecategoryBinProduct.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Limits.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.
Require Import UniMath.CategoryTheory.limits.binproducts.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.
Require Import UniMath.CategoryTheory.DisplayedCats.Isos.
Require Import UniMath.CategoryTheory.DisplayedCats.Univalence.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Projection.

Local Open Scope cat.

(**
Let us start by defining sets with a binary operation on them.
To do so, we use algebras on the diagonal functor.
Let us repeat the diagonal.
After that, we show we have a univalent category of sets with a binary operation.
 *)
Definition diag
  : HSET ⟶ HSET.
Proof.
  exact (bindelta_functor HSET ∙ binproduct_functor BinProductsHSET).
Defined.

Definition binop_category
  : category.
Proof.
  simple refine (FunctorAlg diag).
Defined.

Definition is_univalent_binop
  : is_univalent binop_category.
Proof.
  exact (is_univalent_FunctorAlg is_univalent_HSET diag).
Defined.

Definition binop
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact binop_category.
  - exact is_univalent_binop.
Defined.

(**
In the remainder, we need some projections.
 *)
Section ProjectionsBinop.
  Variable (m : binop).

  Definition carrier
    : hSet
    := pr1 m.

  Definition operation
    : carrier → carrier → carrier
    := λ x y, pr2 m (x ,, y).
End ProjectionsBinop.

(**
Now we look at two ways of defining a category of sets with a binary operation and a unit.
The first way, is by using the full subcategory.
This gives rise to a univalent category since unit elements are unique.
 *)
Definition is_unit
           (m : binop)
           (e : carrier m)
  : UU
  := (∏ (x : carrier m), operation m x e = x)
     ×
     (∏ (x : carrier m), operation m e x = x).

Definition has_unit
           (m : binop)
  : UU
  := ∑ (e : carrier m), is_unit m e.

Definition isaprop_has_unit
           (m : binop)
  : isaprop (has_unit m).
Proof.
  use invproofirrelevance.
  intros e₁ e₂.
  use subtypePath.
  { intro ; apply isapropdirprod ; use impred ; intro ; apply setproperty. }
  exact (!(pr22 e₂ (pr1 e₁)) @ pr12 e₁ (pr1 e₂)).
Defined.

Definition unit_binop_property_disp_cat
  : disp_cat binop
  := disp_full_sub binop has_unit.

Definition unit_binop_property_cat
  : category
  := total_category unit_binop_property_disp_cat.

Definition is_univalent_property_unit_binop
  : is_univalent unit_binop_property_cat.
Proof.
  use is_univalent_total_category.
  - exact is_univalent_binop.
  - use disp_full_sub_univalent.
    exact isaprop_has_unit.
Defined.

Definition unit_binop_property
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact unit_binop_property_cat.
  - exact is_univalent_property_unit_binop.
Defined.

(**
To argue that the unit element is really added as a property, we look at the forgetful functor to sets with binary operations.
This functor only forgets the unit and, since the unit was added as a property, it is full and faithful.
Note that in this displayed category:
- the displayed objects form a proposition
- the displayed morphisms are contractible
 *)
Definition forget_unit_property_adds_properties
  : adds_properties unit_binop_property_disp_cat.
Proof.
  apply pr1_category_fully_faithful.
  intro ; intros.
  apply iscontrunit.
Defined.

(**
Next we show how to define sets with a binary operation and a unit where the unit is added as structure.
To do so, we use displayed categories.
To prove univalence of the total category, we use displayed univalence.
 *)
Definition point_disp_cat_ob_mor
  : disp_cat_ob_mor binop.
Proof.
  use make_disp_cat_ob_mor ; cbn.
  - exact (λ X, carrier X).
  - exact (λ X Y x y f, pr1 f x = y).
Defined.

Definition point_disp_cat_id_comp
  : disp_cat_id_comp binop point_disp_cat_ob_mor.
Proof.
  use tpair.
  - exact (λ _ _, idpath _).
  - exact (λ X Y Z f g x y z p q, maponpaths (pr1 g) p @ q).
Defined.

Definition point_disp_cat_data
  : disp_cat_data binop.
Proof.
  use tpair.
  - exact point_disp_cat_ob_mor.
  - exact point_disp_cat_id_comp.
Defined.

Definition point_disp_cat_laws
  : disp_cat_axioms binop point_disp_cat_data.
Proof.
  repeat split.
  - cbn ; intros ; apply setproperty.
  - cbn ; intros ; apply setproperty.
  - cbn ; intros ; apply setproperty.
  - cbn ; intros.
    apply isasetaprop.
    apply setproperty.
Qed.

Definition point_disp_cat
  : disp_cat binop.
Proof.
  use tpair.
  - exact point_disp_cat_data.
  - exact point_disp_cat_laws.
Defined.

Definition point_disp_cat_disp_univalent
  : is_univalent_disp point_disp_cat.
Proof.
  use is_univalent_disp_from_fibers.
  intros X x y.
  use isweq_iso.
  - intros f.
    exact (pr1 f).
  - intros e.
    induction e ; cbn.
    apply idpath.
  - intros e.
    use subtypePath.
    { intro ; apply isaprop_is_z_iso_disp. }
    cbn.
    induction (pr1 e).
    apply idpath.
Defined.

Definition pointed_binop_category
  : category
  := total_category point_disp_cat.

Definition pointed_binop
  : univalent_category.
Proof.
  simple refine (_ ,, _).
  - exact pointed_binop_category.
  - refine (is_univalent_total_category
              _
              point_disp_cat_disp_univalent).
    exact is_univalent_binop.
Defined.

(**
Some projections of sets with a binary operation and a point.
 *)
Section ProjectionsPointedBinop.
  Variable (m : pointed_binop).

  Definition pointed_carrier
    : hSet
    := pr11 m.

  Definition pointed_operation
    : pointed_carrier → pointed_carrier → pointed_carrier
    := λ x y, pr21 m (x ,, y).

  Definition point_of
    : pointed_carrier
    := pr2 m.
End ProjectionsPointedBinop.

(**
Up to now, we only added the element which represents the unit.
Beside that, we also need to add the necessary laws.
 *)
Definition is_unit_point
  : pointed_binop → UU
  := λ X, is_unit (pr1 X) (pr2 X).

Definition isaprop_is_unit_point
           (X : pointed_binop)
  : isaprop (is_unit_point X).
Proof.
  use isapropdirprod ; use impred ; intro ; apply setproperty.
Defined.

Definition unit_binop_structure_disp_cat
  : disp_cat binop
  := sigma_disp_cat (disp_full_sub pointed_binop is_unit_point).

Definition unit_binop_structure_cat
  : category
  := total_category unit_binop_structure_disp_cat.

Definition is_univalent_structure_unit_binop
  : is_univalent unit_binop_structure_cat.
Proof.
  use is_univalent_total_category.
  - apply binop.
  - apply is_univalent_disp_from_fibers.
    intros x xx yy.
    use isweqimplimpl.
    + intros f.
      use subtypePath.
      {
        intro ; apply isapropdirprod ; use impred ; intro ; apply setproperty.
      }
      exact (pr11 f).
    + apply isapropifcontr.
      apply isaprop_has_unit.
    + use invproofirrelevance.
      intros f g.
      use subtypePath.
      { intro ; apply isaprop_is_z_iso_disp. }
      use subtypePath.
      { intro ; apply isapropunit. }
      apply setproperty.
Defined.

Definition unit_binop_structure
  : univalent_category.
Proof.
  use make_univalent_category.
  - exact unit_binop_structure_cat.
  - exact is_univalent_structure_unit_binop.
Defined.

(**
We finish by arguing that the unit is indeed added structure for this construction.
To do so, we prove that the forgetful functor is faithful.
 *)
Definition forget_unit_structure_faithful
  : adds_structure unit_binop_structure_disp_cat.
Proof.
  intros m₁ m₂ f.
  apply pr1_category_faithful.
  intro ; intros ; simpl.
  use (@isaprop_total2 (make_hProp _ _) (λ _, make_hProp _ _)).
  - apply setproperty.
  - apply isapropunit.
Defined.

(**
We can also show that this forgetful functor isn't full.
This is because not every homomorphism between sets with binary operations preserve the unit element.
For that, we use the following example.
 *)
Definition nat_unit_binop_structure
  : unit_binop_structure.
Proof.
  simple refine ((natset ,, _) ,, _ ,, _) ; cbn.
  - exact (λ n, pr1 n + pr2 n).
  - exact 0.
  - split ; cbn.
    + apply natplusr0.
    + apply natplusl0.
Defined.

Definition bool_unit_binop_structure
  : unit_binop_structure.
Proof.
  simple refine ((boolset ,, _) ,, _ ,, _) ; cbn.
  - exact (λ b, orb (pr1 b) (pr2 b)).
  - exact false.
  - split ; cbn ; intro x ; induction x ; apply idpath.
Defined.

Definition nat_to_bool
  : nat → bool
  := λ _, true.

Definition nat_plus_to_bool_or
  : pr1_category _ nat_unit_binop_structure
    -->
    pr1_category _ bool_unit_binop_structure.
Proof.
  refine (nat_to_bool ,, _).
  use funextsec.
  intro x ; apply idpath.
Defined.

Definition unit_binop_structure_disp_cat_not_adds_properties
  : ¬(adds_properties unit_binop_structure_disp_cat).
Proof.
  intros H.
  induction H as [H₁ H₂].
  clear H₂.
  specialize (H₁ _ _ nat_plus_to_bool_or).
  revert H₁.
  use (@hinhuniv _ hfalse).
  intros H ; cbn.
  pose (pr121 H) as p.
  cbn in p.
  pose (eqtohomot (maponpaths pr1 (pr2 H)) 0) as q.
  cbn in q.
  pose (!q @ p) as r.
  unfold nat_to_bool in r.
  exact (nopathstruetofalse r).
Qed.

(**
Now let us look at the hlevels of the displayed objects and morphisms of this displayed category.
More specifically, both the type of displayed objects and the type of displayed morphisms form propositions.
 *)
Definition unit_binop_structure_disp_cat_mor_prop
  : locally_propositional unit_binop_structure_disp_cat.
Proof.
  apply disp_cat_is_locally_propositional.
  apply forget_unit_structure_faithful.
Defined.

Definition unit_binop_structure_disp_cat_mor_not_contr
  : ¬(locally_contractible unit_binop_structure_disp_cat).
Proof.
  intro H.
  apply unit_binop_structure_disp_cat_not_adds_properties.
  apply pr1_category_fully_faithful.
  exact H.
Defined.

Definition unit_binop_structure_disp_cat_ob_prop
           (X : binop)
  : isaprop (unit_binop_structure_disp_cat X).
Proof.
  apply isaprop_has_unit.
Defined.


(* CS 499 - Mechanized Reasoning about Programs *)
(* Copyright Northern Arizona University        *)
(* All rights reserved                          *)

Require Import Arith ZArith List String Relation_Operators.
Import ListNotations.

(** * Identifiers and Polymorphic States *)

Module Id.

  Inductive t := Id : nat -> t.

  Definition beq (id1 id2:t) : bool :=
    match (id1, id2) with
    | (Id n1, Id n2) => beq_nat n1 n2
    end.

  (** Properties of Id.beq: reflexivity, symmetry. *)

  Fact beq_refl: forall id, beq id id = true.
  Proof.
    intros id.
    destruct id as [ n ].
    unfold beq.
    symmetry.
    apply beq_nat_refl.
  Qed.

  Fact beq_sym: forall id1 id2, beq id1 id2 = beq id2 id1.
  Proof.
    intros id1 id2.
    destruct id1 as [ n1 ].
    destruct id2 as [ n2 ].
    unfold beq.
    now rewrite Nat.eqb_sym.
  Qed.

  Fact beq_eq: forall id1 id2,
      beq id1 id2 = true -> id1 = id2.
  Proof.
    intros [ id1 ] [ id2 ] H; unfold beq in *; simpl in *.
    apply beq_nat_true in H; now rewrite H.
  Qed.

End Id.

(** Natural numbers can be understood as identifiers *)
Coercion Id.Id: nat >-> Id.t.

(** In the module [State], [t A] is the type of a state, i.e.  a
    partial mapping from identifiers to values of type [A]. *)

Module State.

  Definition t := Id.t -> Z.

  Definition update (s:t)(x:Id.t)(v:Z) : t :=
    fun y => if Id.beq y x
          then v
          else s y.

End State.

(** * Arithmetic Expressions *)

Module Aexp.

  (** * The type of arithmetic expressions *)

  Inductive binary_op : Type :=
    Add | Mul | Sub.

  Inductive t : Type :=
  | Int: Z -> t
  | Var: Id.t -> t
  | Binop : binary_op -> t -> t -> t.

  Definition get_op (op: binary_op): Z->Z->Z :=
    match op with
    | Add => Z.add
    | Mul => Z.mul
    | Sub => Z.sub
    end.

  (** ** Evaluation of expressions *)
  Fixpoint A (a:Aexp.t) (s:Id.t -> Z) : Z :=
    match a with
    | Aexp.Int z => z
    | Aexp.Var id => s id
    | Aexp.Binop op a1 a2 => (Aexp.get_op op) (A a1 s) (A a2 s)
    end.

  Module Notations.

    (* Coercions *)
    Coercion Int : Z >-> t.
    Coercion Var : Id.t >-> t.

    (* Notations *)
    Notation "a0 + a1" := (Binop Add a0 a1).
    Notation "a0 - a1" := (Binop Sub a0 a1).
    Notation "a0 * a1" := (Binop Mul a0 a1).

  End Notations.

  (* Examples of expressions *)
  Module Ex_t.
    Import Notations.

    Definition x : Id.t := Id.Id 0.
    Definition y : Id.t := Id.Id 1.
    Definition z : Id.t := Id.Id 2.

    (* Warning: scope Z is not opened! *)
    Definition a0 : t := Binop Add x 1%Z.
    Definition a1 : t := Binop Add x 1.
    Print a0. (* 1%Z is considered as a numerical constant *)
    Print a1. (* 1 is considered as an identifier! *)

    Definition a2 : t := z - (x * (y + 1)).
  End Ex_t.

  (* Examples of evaluation *)
  Module Ex_A.
    Import Ex_t.

    Definition s :=
      fun z =>
        if Id.beq z x then 42%Z else
          if Id.beq z y then 0%Z else 0%Z.

    Example ex0 : A a0 s = 43%Z.
    Proof. simpl. trivial. Qed.

    Example ex1 : A a1 s = 42%Z.
    Proof. simpl. trivial. Qed.

    Example ex2 : A a2 s = 0%Z.
    Proof. simpl. trivial. Qed.

  End Ex_A.

  (** ** Free variables *)

  (* Instead of using a set of variables, we will use lists, and allow
     a variable to be present several times in the list. *)
  Fixpoint FV (a:t) : list Id.t :=
    match a with
    | Int z   => []
    | Var id  => [id]
    | Binop op a1 a2 => List.app (FV a1) (FV a2)
    end.

  Lemma lemma_1_12:
    forall (s s':State.t) (a:t),
      (forall x, In x (FV a) -> s x = s' x) ->
      A a s = A a s'.
  Proof.
    intros s s' a H.
    induction a as [ z | x | op a1 IH1 a2 IH2].
    - simpl. trivial.
    - simpl. apply H.
      simpl. left. reflexivity.
    - assert(A a1 s = A a1 s') as H1.
      {
        apply IH1.
        intros x Hx.
        apply H. simpl.
        apply in_or_app.
        left. assumption.
      }
      assert(A a2 s = A a2 s') as H2.
      {
        apply IH2.
        intros x Hx.
        apply H. simpl.
        apply in_or_app.
        right. assumption.
      }
      simpl.
      rewrite H1, H2.
      trivial.
  Qed.

  (** ** Substitution *)
  Fixpoint subst (a:t) (y:Id.t) (a0:t) : t :=
    match a with
    | Int z  =>  Int z
    | Var id =>  if Id.beq id y
                then a0
                else Var id
    | Binop op a1 a2 =>
      Binop op (subst a1 y a0) (subst a2 y a0)
    end.

  (** Lemma (Exercice) 1.14 (page 18) of Semantics with Applications
      is written as follows: A[a[y →a0]]s = A[a](s[y →A[a0]s]) for all
      states s.

      A direct ``translation'' one could think of in would be: forall
      s a a0 y, A (subst a y a0) s = A a (State.update s y (A a0 s)).

      However (A a0 s) has type option Z, whereas function
      State.update expect its third argument to be of type Z.

      Therefore the correct statement in Coq is as follows: *)
  Lemma lemma_1_14:
    forall (s:State.t)(a a0:t)(y:Id.t),
      A (subst a y a0) s = A a (State.update s y (A a0 s)).
  Proof.
    intros s a a0 y.
    induction a as [ z | x | op a1 IH1 a2 IH2 ].
    - trivial.
    - unfold State.update. simpl.
      destruct (Id.beq x y).
      + trivial.
      + trivial.
    - simpl.
      now rewrite IH1, IH2.
  Qed.

End Aexp.

(** * Boolean expressions *)

Module Bexp.

  (** ** Definition of boolean expressions *)
  Inductive cmp_op : Type :=
    Equal | LowerEq.

  Definition get_cmp (cmp: cmp_op) : Z -> Z -> bool :=
    match cmp with
    | Equal => Z.eqb
    | LowerEq => Z.leb
    end.

  Inductive t : Type :=
  | Bool: bool -> t      (* Constant: true or false *)
  | Neg: t -> t       (* negation of an expression *)
  | And: t -> t -> t   (* conjunction of two boolean expressions *)
  | Cmp: cmp_op -> Aexp.t -> Aexp.t -> t
                     (* comparison of two arithmetic expressions *)
  .

  (** ** Notations *)
  Module Notations.

    Coercion Bool : bool >-> t.
    Notation "! b":=(Neg b)(at level 70).
    Infix "&&" := And.
    Notation "a1 == a2" := (Cmp Equal a1 a2)(at level 70).
    Notation "a1 <= a2" := (Cmp LowerEq a1 a2)(at level 70).

  End Notations.

  (** ** Examples *)
  Module Ex_t.
    Import Aexp.Notations Notations Aexp.Ex_t.

    Definition b1 : t := true.
    Definition b2 : t := !(a1 == 0%Z).
    Definition b3 : t := (0%Z <= x) && (x <= y).

  End Ex_t.

  Fixpoint B (b:Bexp.t) (s:Id.t -> Z) : bool :=
  match b with
  | Bexp.Bool b => b
  | Bexp.Neg b  => negb(B b s)
  | Bexp.And b1 b2 => andb (B b1 s) (B b2 s)
  | Bexp.Cmp cmp a1 a2 => (Bexp.get_cmp  cmp) (Aexp.A a1 s) (Aexp.A a2 s)
  end.

  Module Ex_B.
    Import Ex_t Aexp.Ex_A.

    Fact f1 : B b1 s = true.
    Proof.  simpl. trivial. Qed.

    Fact f2 : B b2 s = true.
    Proof.  simpl. trivial. Qed.

    Fact f3 : B b3 s = false.
    Proof.  simpl. trivial. Qed.
  End Ex_B.

  (** ** Free variables *)
  Fixpoint FV (b:t) : list Id.t :=
    match b with
    | Bool b   => []
    | Neg b  => FV b
    | And b1 b2 =>
      List.app (FV b1) (FV b2)
    | Cmp _ a1 a2 =>
      List.app (Aexp.FV a1) (Aexp.FV a2)
    end.

  Module Ex_FV.
    Import Ex_t Aexp.Ex_t.

    Fact f1 : FV b1 = [].
    Proof. simpl. trivial. Qed.

    Fact f2 : FV b2 = [x;y].
    Proof. simpl. trivial. Qed.

    Fact f3 : FV b3 = [x;x;y].
    Proof. simpl. trivial. Qed.
  End Ex_FV.

  Lemma lemma_1_13:
    forall (s s':State.t) (b:t),
      (forall x, In x (FV b) -> s x = s' x) ->
      B b s = B b s'.
  Proof.
    intros s s' b Hstates.
    induction b as [ b | b IH | b1 IH1 b2 IH2 | cmp a1 a2 ]; simpl in *.
    - trivial.
    - rewrite IH; auto.
    - rewrite IH1, IH2; auto; intros; intuition.
    - assert(Aexp.A a1 s = Aexp.A a1 s') as H1
          by (apply Aexp.lemma_1_12;intros; intuition).
      assert(Aexp.A a2 s = Aexp.A a2 s') as H2
          by (apply Aexp.lemma_1_12;intros; intuition).
      now rewrite H1, H2.
  Qed.

  (** ** Substitution *)
  Fixpoint subst (b:t) (y:Id.t) (a:Aexp.t) : t :=
    match b with
    | Bool b => Bool b
    | Neg b => Neg(subst b y a)
    | And b1 b2 =>
      And (subst b1 y a) (subst b2 y a)
    | Cmp cmp a1 a2 =>
      Cmp cmp (Aexp.subst a1 y a) (Aexp.subst a2 y a)
    end.

  Lemma lemma_1_15:
    forall (s:State.t)(b:t)(a:Aexp.t)(y:Id.t),
      B (subst b y a) s = B b (State.update s y (Aexp.A a s)).
  Proof.
    intros s; induction b; intros a y; simpl in *.
    - trivial.
    - now rewrite IHb.
    - now rewrite IHb1, IHb2.
    - now repeat rewrite Aexp.lemma_1_14.
  Qed.

End  Bexp.

(** * Semantics as Relations *)

(** ** Syntax *)

Inductive stm : Type :=
| Skip : stm
| Assign : Id.t -> Aexp.t -> stm
| Seq : stm -> stm -> stm
| If : Bexp.t -> stm -> stm -> stm
| While: Bexp.t -> stm -> stm.

(** ** Natural Semantics *)

(** < S, s > -> s' *)
Inductive ns : stm -> State.t -> State.t -> Prop :=
| ns_skip:    (* < Skip, s > -> s *)
    forall s, ns Skip s s
| ns_assign:  (* < x := a, s > -> s[x|->A[x]s] *)
    forall (x:Id.t) (a:Aexp.t) (s:Id.t->Z),
      ns (Assign x a)
           s
           (State.update s x (Aexp.A a s))
| ns_comp:    (* < S1, s > -> s'   < S2, s'-> s"
                 -------------------------------
                       < S1;S2, s > -> s"        *)
    forall S1 S2 s s' s'',
      ns S1 s s' ->
      ns S2 s' s'' ->
      ns (Seq S1 S2) s s''
| ns_if_tt:  (* < S1 , s > -> s'      B[b]s = tt
                --------------------------------
                < if b then S1 else S2, s > -> s' *)
    forall b S1 S2 s s',
      Bexp.B b s = true ->
      ns S1 s s' ->
      ns (If b S1 S2) s s'
| ns_if_ff:  (* < S2 , s > -> s'      B[b]s = ff
                --------------------------------
                < if b then S1 else S2, s > -> s' *)
    forall b S1 S2 s s',
      Bexp.B b s = false ->
      ns S2 s s' ->
      ns (If b S1 S2) s s'
| ns_while_tt:
  (* B[b]s = tt  < S, s > -> s'  <while b do S, s'>->s"
     --------------------------------------------------
     <while b do S, s> -> s"                         *)
    forall b S s s' s'',
      Bexp.B b s = true ->
      ns S s s' ->
      ns (While b S) s' s'' ->
      ns (While b S) s s''
| ns_while_ff:
  (* B[b]s = ff
     -----------------------
     <while b do S, s> -> s                          *)
    forall b S s,
      Bexp.B b s = false ->
      ns (While b S) s s
.

(** ** Structural Operational Semantics *)

Inductive configuration : Type :=
| Rem : stm -> State.t -> configuration
| Fin : State.t -> configuration.

Inductive sos : stm -> State.t -> configuration -> Prop :=
| sos_skip:    (* < Skip, s > -> s *)
    forall s, sos Skip s (Fin s)
| sos_assign:  (* < x := a, s > -> s[x|->A[x]s] *)
    forall (x:Id.t) (a:Aexp.t) (s:Id.t->Z),
      sos (Assign x a)
          s
          (Fin (State.update s x (Aexp.A a s)))
| sos_comp1:
    forall S1 S2 s S1' s',
      sos S1 s (Rem S1' s') ->
      sos (Seq S1 S2) s (Rem (Seq S1' S2) s')
| sos_comp2:
    forall S1 S2 s s',
      sos S1 s (Fin s') ->
      sos (Seq S1 S2) s (Rem S2 s')
| sos_if_tt:
    forall S1 S2 b s,
      Bexp.B b s = true ->
      sos (If b S1 S2) s (Rem S1 s)
| sos_if_ff:
    forall S1 S2 b s,
      Bexp.B b s = false ->
      sos (If b S1 S2) s (Rem S2 s)
| sos_while:
    forall b S s,
      sos (While b S) s
          (Rem (If b (Seq S (While b S)) Skip) s)
.

(*********************** AM Language ***********************)

(* Evaluation Stack *)
Module Stack.

  Inductive A : Type :=
  | z : Z -> A
  | T: bool -> A.

  Definition t : Type := list A.

End Stack.

(** ** Syntax *)
(* Translated from page 68 in text, where c is represented using lists*)
Inductive inst: Type :=
| PUSH   : Z -> inst
| ADD    | MULT | SUB
| TRUE   | FALSE
| EQ     | LE
| AND    | NEG
| FETCH  : Id.t -> inst
| STORE  : Id.t -> inst
| NOOP   : inst
| BRANCH : list inst -> list inst -> inst
| LOOP   : list inst -> list inst -> inst.

(*  Definition of c based of page 68, c is a list of inst which is called code here *)
Definition code: Type := list inst.

(* Configuration has the form <c,e,s> where c is a sequence of inst,
    e is the stack, and s is the storage*)
Definition config : Type := ( code * Stack.t * State.t) .

(** ** Structural Operational Semantics *)
Inductive am : config -> config -> Prop :=
(*NOOP (skip)*)
| am_noop:
    forall (c:code) (e:Stack.t)(s:State.t),
      am  (NOOP::c, e, s)  (c , e, s)
(*PUSH*)
| am_push:
  forall  (n:Z) (c:code) (e:Stack.t)(s:State.t),
      am ((PUSH n)::c, e, s) (c, (Stack.z n)::e, s)

(* Z operations *)
| am_add:
  forall  (z1 z2:Z) (c:code) (s:State.t)  (e:Stack.t),
     am (ADD::c, (Stack.z z1)::(Stack.z z2)::e, s) (c, (Stack.z (Z.add z1 z2))::e, s)

| am_sub:
  forall (z1 z2: Z) (c:code) (s:State.t)  (e:Stack.t),
     am (SUB::c, (Stack.z z1)::(Stack.z z2)::e, s) (c, (Stack.z (Z.sub z1 z2))::e, s)

| am_mult:
  forall (z1 z2: Z) (c:code) (s:State.t)  (e:Stack.t),
     am (MULT::c, (Stack.z z1)::(Stack.z z2)::e, s) (c, (Stack.z (Z.mul z1 z2))::e, s)

(* TRUE and FALSE *)
| am_true:
    forall (c:code) (s:State.t) (e:Stack.t) (tt:bool),
       am (TRUE::c, e, s) (c, (Stack.T tt)::e, s)

| am_false:
    forall (c:code) (s:State.t) (e:Stack.t) (ff:bool),
       am (FALSE::c, e, s) (c, (Stack.T ff)::e, s)

(* EQ and LE *)
| am_eq :
  forall (c:code) (s:State.t) (e:Stack.t) (z1 z2: Z),
    am (EQ::c,e,s) (c, (Stack.T (Z.eqb z1 z2))::e, s)

| am_le :
  forall (c:code) (s:State.t) (e:Stack.t) (z1 z2: Z),
    am (LE::c,e,s) (c, (Stack.T (Z.leb z1 z2))::e, s)

(* AND *)
| am_and:
  forall (c:code) (s:State.t) (e:Stack.t) (t1 t2:bool),
    am (AND::c, e, s) (c,(Stack.T (andb t1 t2))::e,s)

(*NEG *)
|am_neg:
  forall  (c:code) (s:State.t) (e:Stack.t) (t:bool),
    am (NEG::c,(Stack.T t)::e,s) (c,(Stack.T (negb t))::e,s)

(*FETCH*)
| am_fetch:
    forall (c:code) (s:State.t) (e:Stack.t) (x:Id.t),
      am ((FETCH x)::c,e,s) (c, (Stack.z (s x))::e,s)

(*STORE*)
|am_store:
    forall (c:code) (s:State.t) (e:Stack.t) (x:Id.t) (z:Z),
      am ((STORE x)::c,(Stack.z z)::e,s) (c,e, (State.update s x z))

(*BRANCH*)
|am_branch_tt:
    forall (c c1 c2:code) (s:State.t) (e:Stack.t),
      am ((BRANCH c1 c2)::c, (Stack.T true)::e, s) (c1++c, e, s)

|am_branch_ff:
    forall (c c1 c2:code) (s:State.t) (e:Stack.t),
      am ((BRANCH c1 c2)::c, (Stack.T false)::e, s) (c2++c, e, s)

(* LOOP *)
|am_loop:
    forall (c c1 c2:code) (s:State.t) (e:Stack.t),
      am ((LOOP c1 c2)::c, e, s) ( c1++(BRANCH(c2++[(LOOP c1 c2)]) [NOOP])::c,e,s).

Module Examples.

  Definition x : Id.t := Id.Id 0.

  Definition s (y: Id.t) : Z :=
    if Id.beq y x
      then 3%Z
    else 0%Z.

   Example ex_4_1 :
      exists s',
      (clos_refl_trans_1n _ am) ( (PUSH 1%Z)::(FETCH x)::(ADD)::(STORE x)::[],[ ], s )
                                             ([],[],s') /\ s' x = 4%Z.
   Proof.
       repeat eexists.
       do 10  econstructor.
       simpl. reflexivity.
  Qed.

   Example ex_4_2:
          (clos_trans  _ am) ( [ LOOP [TRUE] [NOOP] ], [ ], s) ([ LOOP [TRUE] [NOOP] ], [ ], s).
      Proof.
          do 5 (econstructor; simpl).
      Qed.

    (** ** Exercise 4.4 *)

    (** First, we need to define what corresponds to ->k: *)
    Inductive am_k : nat -> (code*Stack.t*State.t) -> (code*Stack.t*State.t) -> Prop :=
    | am_O: forall config, am_k 0 config config
    | am_Sn: forall config config' config'' k,
        am config config' -> am_k k config' config'' -> am_k (S k) config config''.

    Lemma ex_4_4:
      forall k c1 e1 s c' e' s' c2 e2,
        am_k k (c1, e1, s) (c', e', s') ->
        am_k k (c1++c2, e1++e2, s) (c'++c2, e'++e2, s').
    Proof.
      induction e2.

    Notation am_star := (clos_refl_trans_1n  _ am).

  Lemma ex_4_4':
    forall c1 e1 s c' e' s' c2 e2,
      am_star (c1, e1, s) (c', e', s') ->
      am_star (c1++c2, e1++e2, s) (c'++c2, e'++e2, s').
  Proof.
  Admitted.
    Lemma ex_4_6:
      forall (c:code) (s:State.t) (e:Stack.t),
      exists c' s' e',
        (clos_refl_trans_1n _ am) (c,e,s) (c',e',s').
    Proof.
        repeat eexists.
        admit.
    Admitted.

(*Theorem 2.9 (page 41?)*) (*should do induction on derivation tree*)
(*show table 4.1 is determinisistc; use to prove there is only one
   computation sequence. (pg 73?)
Instead of taking am: prove for am; prove for reflex_trans am.*)

End Examples.


CoInductive conat : Set := O' | S' (n : conat).

CoFixpoint inf : conat := S' inf.

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

CoInductive bisim : conat -> conat -> Prop :=
  | OO : bisim O' O'
  | SS : forall n m : conat, bisim n m -> bisim (S' n) (S' m).

Notation "x == y" := (bisim x y) (at level 70).

Definition conat_u (n : conat) : conat := match n with
  | O' => O'
  | S' n' => S' n' end.

Lemma conat_unfold : forall n : conat, n = conat_u n.
Proof. destruct n; auto. Qed.

Theorem not_fin_then_inf : forall n : conat, ~ (exists m : nat, toCo m == n) -> (n == inf).
Proof.
  cofix CIH. intros. destruct n.
  - destruct H. exists 0. simpl. constructor.
  - rewrite (conat_unfold inf). simpl. constructor.
    apply CIH. intros [m contra]. apply H. exists (S m). simpl.
    constructor. apply contra.
Qed.


Inductive natprod : Type :=
  | pair : nat -> nat -> natprod.

Notation "( x , y )" := (pair x y).

Definition fst p : nat :=
  match p with | (x,_) => x end.

Definition snd p : nat :=
  match p with | (_,x) => x end.

Definition swap p : natprod :=
  match p with
  | (x,y) => (y,x)
  end.

Ltac pair_simple p := destruct p as [m n]; simpl; reflexivity.

Theorem surjective_pairing : forall p : natprod, p = (fst p, snd p).
Proof.
  intro p. pair_simple p.
Qed.

Theorem snd_fst_is_swap : forall p, swap p = (snd p, fst p).
Proof.
  intro p. pair_simple p.
Qed.

Theorem fst_swap_is_snd : forall p, fst (swap p) = snd p.
Proof.
  intro p. pair_simple p.
Qed.


Inductive N:Set:= (*this is a comment line*)
|zero: N
|succ:N->N.

Fixpoint plus (m n:N):=
match m with
| zero=>n
|succ m'=>succ(plus m' n)
end.

Lemma zero_identity: forall n,n=plus n zero.
Proof.
induction n.
auto.
simpl.
f_equal.
assumption.
Qed.