(** * ProofObjects: The Curry-Howard Correspondence *)

Set Warnings "-notation-overridden,-parsing".
From LF Require Export IndProp.

(** "_Algorithms are the computational content of proofs_."
    --Robert Harper *)

(** We have seen that Coq has mechanisms both for _programming_,
    using inductive data types like [nat] or [list] and functions over
    these types, and for _proving_ properties of these programs, using
    inductive propositions (like [ev]), implication, universal
    quantification, and the like.  So far, we have mostly treated
    these mechanisms as if they were quite separate, and for many
    purposes this is a good way to think.  But we have also seen hints
    that Coq's programming and proving facilities are closely related.
    For example, the keyword [Inductive] is used to declare both data
    types and propositions, and [->] is used both to describe the type
    of functions on data and logical implication.  This is not just a
    syntactic accident!  In fact, programs and proofs in Coq are
    almost the same thing.  In this chapter we will study how this
    works.

    We have already seen the fundamental idea: provability in Coq is
    represented by concrete _evidence_.  When we construct the proof
    of a basic proposition, we are actually building a tree of
    evidence, which can be thought of as a data structure.

    If the proposition is an implication like [A -> B], then its proof
    will be an evidence _transformer_: a recipe for converting
    evidence for A into evidence for B.  So at a fundamental level,
    proofs are simply programs that manipulate evidence. *)

(** Question: If evidence is data, what are propositions themselves?

    Answer: They are types! *)

(** Look again at the formal definition of the [ev] property.  *)

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

(** Suppose we introduce an alternative pronunciation of "[:]".
    Instead of "has type," we can say "is a proof of."  For example,
    the second line in the definition of [ev] declares that [ev_0 : ev
    0].  Instead of "[ev_0] has type [ev 0]," we can say that "[ev_0]
    is a proof of [ev 0]." *)

(** This pun between types and propositions -- between [:] as "has type"
    and [:] as "is a proof of" or "is evidence for" -- is called the
    _Curry-Howard correspondence_.  It proposes a deep connection
    between the world of logic and the world of computation:

                 propositions  ~  types
                 proofs        ~  data values

    See [Wadler 2015] (in Bib.v) for a brief history and up-to-date
    exposition. *)

(** Many useful insights follow from this connection.  To begin with,
    it gives us a natural interpretation of the type of the [ev_SS]
    constructor: *)

Check ev_SS
  : forall n,
    ev n ->
    ev (S (S n)).

(** This can be read "[ev_SS] is a constructor that takes two
    arguments -- a number [n] and evidence for the proposition [ev
    n] -- and yields evidence for the proposition [ev (S (S n))]." *)

(** Now let's look again at a previous proof involving [ev]. *)

Theorem ev_4 : ev 4.
Proof.
  apply ev_SS. apply ev_SS. apply ev_0. Qed.

(** As with ordinary data values and functions, we can use the [Print]
    command to see the _proof object_ that results from this proof
    script. *)

Print ev_4.
(* ===> ev_4 = ev_SS 2 (ev_SS 0 ev_0)
     : ev 4  *)

(** Indeed, we can also write down this proof object _directly_,
    without the need for a separate proof script: *)

Check (ev_SS 2 (ev_SS 0 ev_0))
  : ev 4.

(** The expression [ev_SS 2 (ev_SS 0 ev_0)] can be thought of as
    instantiating the parameterized constructor [ev_SS] with the
    specific arguments [2] and [0] plus the corresponding proof
    objects for its premises [ev 2] and [ev 0].  Alternatively, we can
    think of [ev_SS] as a primitive "evidence constructor" that, when
    applied to a particular number, wants to be further applied to
    evidence that this number is even; its type,

      forall n, ev n -> ev (S (S n)),

    expresses this functionality, in the same way that the polymorphic
    type [forall X, list X] expresses the fact that the constructor
    [nil] can be thought of as a function from types to empty lists
    with elements of that type. *)

(** We saw in the [Logic] chapter that we can use function
    application syntax to instantiate universally quantified variables
    in lemmas, as well as to supply evidence for assumptions that
    these lemmas impose.  For instance: *)

Theorem ev_4': ev 4.
Proof.
  apply (ev_SS 2 (ev_SS 0 ev_0)).
Qed.

(* ################################################################# *)
(** * Proof Scripts *)

(** The _proof objects_ we've been discussing lie at the core of how
    Coq operates.  When Coq is following a proof script, what is
    happening internally is that it is gradually constructing a proof
    object -- a term whose type is the proposition being proved.  The
    tactics between [Proof] and [Qed] tell it how to build up a term
    of the required type.  To see this process in action, let's use
    the [Show Proof] command to display the current state of the proof
    tree at various points in the following tactic proof. *)

Theorem ev_4'' : ev 4.
Proof.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_SS.
  Show Proof.
  apply ev_0.
  Show Proof.
Qed.

(** At any given moment, Coq has constructed a term with a
    "hole" (indicated by [?Goal] here, and so on), and it knows what
    type of evidence is needed to fill this hole.

    Each hole corresponds to a subgoal, and the proof is
    finished when there are no more subgoals.  At this point, the
    evidence we've built is stored in the global context under the name
    given in the [Theorem] command. *)

(** Tactic proofs are useful and convenient, but they are not
    essential: in principle, we can always construct the required
    evidence by hand, as shown above. Then we can use [Definition]
    (rather than [Theorem]) to give a global name directly to this
    evidence. *)

Definition ev_4''' : ev 4 := ev_SS 2 (ev_SS 0 ev_0).

(** All these different ways of building the proof lead to exactly the
    same evidence being saved in the global environment. *)

Print ev_4.
(* ===> ev_4    =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'.
(* ===> ev_4'   =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4''.
(* ===> ev_4''  =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)
Print ev_4'''.
(* ===> ev_4''' =   ev_SS 2 (ev_SS 0 ev_0) : ev 4 *)

(** **** Exercise: 2 stars, standard (eight_is_even)

    Give a tactic proof and a proof object showing that [ev 8]. *)

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

Definition ev_8' : ev 8 := ev_SS _ (ev_SS _ (ev_SS _ (ev_SS _ ev_0))).

Print ev_8.
Print ev_8'.

(** [] *)

(* ################################################################# *)
(** * Quantifiers, Implications, Functions *)

(** In Coq's computational universe (where data structures and
    programs live), there are two sorts of values that have arrows in
    their types: _constructors_ introduced by [Inductive]ly defined
    data types, and _functions_.

    Similarly, in Coq's logical universe (where we carry out proofs),
    there are two ways of giving evidence for an implication:
    constructors introduced by [Inductive]ly defined propositions,
    and... functions! *)

(** For example, consider this statement: *)

Theorem ev_plus4 : forall n, ev n -> ev (4 + n).
Proof.
  intros n H. simpl.
  apply ev_SS.
  apply ev_SS.
  apply H.
Qed.

Print ev_plus4.

(** What is the proof object corresponding to [ev_plus4]?

    We're looking for an expression whose _type_ is [forall n, ev n ->
    ev (4 + n)] -- that is, a _function_ that takes two arguments (one
    number and a piece of evidence) and returns a piece of evidence!

    Here it is: *)

Definition ev_plus4' : forall n, ev n -> ev (4 + n) :=
  fun (n : nat) => fun (H : ev n) =>
    ev_SS (S (S n)) (ev_SS n H).

(** Recall that [fun n => blah] means "the function that, given [n],
    yields [blah]," and that Coq treats [4 + n] and [S (S (S (S n)))]
    as synonyms. Another equivalent way to write this definition is: *)

Definition ev_plus4'' (n : nat) (H : ev n)
                    : ev (4 + n) :=
  ev_SS (S (S n)) (ev_SS n H).

Check ev_plus4''
  : forall n : nat,
    ev n ->
    ev (4 + n).

(** When we view the proposition being proved by [ev_plus4] as a
    function type, one interesting point becomes apparent: The second
    argument's type, [ev n], mentions the _value_ of the first
    argument, [n].

    While such _dependent types_ are not found in conventional
    programming languages, they can be useful in programming too, as
    the recent flurry of activity in the functional programming
    community demonstrates. *)

(** Notice that both implication ([->]) and quantification ([forall])
    correspond to functions on evidence.  In fact, they are really the
    same thing: [->] is just a shorthand for a degenerate use of
    [forall] where there is no dependency, i.e., no need to give a
    name to the type on the left-hand side of the arrow:

           forall (x:nat), nat
        =  forall (_:nat), nat
        =  nat -> nat
*)

(** For example, consider this proposition: *)

Definition ev_plus2 : Prop :=
  forall n, forall (E : ev n), ev (n + 2).

(** A proof term inhabiting this proposition would be a function
    with two arguments: a number [n] and some evidence [E] that [n] is
    even.  But the name [E] for this evidence is not used in the rest
    of the statement of [ev_plus2], so it's a bit silly to bother
    making up a name for it.  We could write it like this instead,
    using the dummy identifier [_] in place of a real name: *)

Definition ev_plus2' : Prop :=
  forall n, forall (_ : ev n), ev (n + 2).

(** Or, equivalently, we can write it in a more familiar way: *)

Definition ev_plus2'' : Prop :=
  forall n, ev n -> ev (n + 2).

(** In general, "[P -> Q]" is just syntactic sugar for
    "[forall (_:P), Q]". *)

(* ################################################################# *)
(** * Programming with Tactics *)

(** If we can build proofs by giving explicit terms rather than
    executing tactic scripts, you may be wondering whether we can
    build _programs_ using _tactics_ rather than explicit terms.
    Naturally, the answer is yes! *)

Definition add1 : nat -> nat.
intro n.
Show Proof.
apply S.
Show Proof.
apply n. Defined.

Print add1.
(* ==>
    add1 = fun n : nat => S n
         : nat -> nat
*)

Compute add1 2.
(* ==> 3 : nat *)

(** Notice that we terminate the [Definition] with a [.] rather than
    with [:=] followed by a term.  This tells Coq to enter _proof
    scripting mode_ to build an object of type [nat -> nat].  Also, we
    terminate the proof with [Defined] rather than [Qed]; this makes
    the definition _transparent_ so that it can be used in computation
    like a normally-defined function.  ([Qed]-defined objects are
    opaque during computation.)

    This feature is mainly useful for writing functions with dependent
    types, which we won't explore much further in this book.  But it
    does illustrate the uniformity and orthogonality of the basic
    ideas in Coq. *)

(* ################################################################# *)
(** * Logical Connectives as Inductive Types *)

(** Inductive definitions are powerful enough to express most of the
    connectives we have seen so far.  Indeed, only universal
    quantification (with implication as a special case) is built into
    Coq; all the others are defined inductively.  We'll see these
    definitions in this section. *)

Module Props.

(* ================================================================= *)
(** ** Conjunction *)

(** To prove that [P /\ Q] holds, we must present evidence for both
    [P] and [Q].  Thus, it makes sense to define a proof object for [P
    /\ Q] as consisting of a pair of two proofs: one for [P] and
    another one for [Q]. This leads to the following definition. *)

Module And.

Inductive and (P Q : Prop) : Prop :=
| conj : P -> Q -> and P Q.

Arguments conj [P] [Q].

Notation "P /\ Q" := (and P Q) : type_scope.

(** Notice the similarity with the definition of the [prod] type,
    given in chapter [Poly]; the only difference is that [prod] takes
    [Type] arguments, whereas [and] takes [Prop] arguments. *)

Print prod.
(* ===>
   Inductive prod (X Y : Type) : Type :=
   | pair : X -> Y -> X * Y. *)

(** This similarity should clarify why [destruct] and [intros]
    patterns can be used on a conjunctive hypothesis.  Case analysis
    allows us to consider all possible ways in which [P /\ Q] was
    proved -- here just one (the [conj] constructor). *)

Theorem proj1' : forall P Q,
    P /\ Q -> P.
Proof.
  intros P Q HPQ.
  Show Proof.
  destruct HPQ as [HP HQ].
  Show Proof.
  apply HP.
  Show Proof.
Qed.

(** Similarly, the [split] tactic actually works for any inductively
    defined proposition with exactly one constructor.  In particular,
    it works for [and]: *)

Lemma and_comm : forall P Q : Prop, P /\ Q <-> Q /\ P.
Proof.
  intros P Q. split.
  Show Proof.
  - intros [HP HQ]. split.
    + apply HQ.
    + apply HP.
  - intros [HQ HP]. split.
    + apply HP.
    + apply HQ.
  Show Proof.
  Check Logic.conj.
Qed.

(* The proof object looks like below.
(fun P Q : Prop =>
 Logic.conj (fun H : P /\ Q => match H with
                               | conj HP HQ => conj HQ HP
                               end)
   (fun H : Q /\ P => match H with
                      | conj HQ HP => conj HP HQ
                      end))

Note that it was because the type of and_comm is actually
  (P /\ Q -> Q /\ P) /\ (Q /\ P -> P /\ Q)
 *)

End And.

(** This shows why the inductive definition of [and] can be
    manipulated by tactics as we've been doing.  We can also use it to
    build proofs directly, using pattern-matching.  For instance: *)

Definition and_comm'_aux P Q (H : P /\ Q) : Q /\ P :=
  match H with
  | conj HP HQ => conj HQ HP
  end.

Definition and_comm' P Q : P /\ Q <-> Q /\ P :=
  conj (and_comm'_aux P Q) (and_comm'_aux Q P).

(** **** Exercise: 2 stars, standard (conj_fact)

    Construct a proof object for the following proposition. *)

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  (fun p q r H1 H2 => conj (proj1 _ _ H1) (proj2 _ _ H2)).

(* full version *)
Definition conj_fact' : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  (fun p q r H1 H2 => conj (proj1 p q H1) (proj2 q r H2)).

(** [] *)

(* ================================================================= *)
(** ** Disjunction *)

(** The inductive definition of disjunction uses two constructors, one
    for each side of the disjunct: *)

Module Or.

Inductive or (P Q : Prop) : Prop :=
| or_introl : P -> or P Q
| or_intror : Q -> or P Q.

Arguments or_introl [P] [Q].
Arguments or_intror [P] [Q].

Notation "P \/ Q" := (or P Q) : type_scope.

(** This declaration explains the behavior of the [destruct] tactic on
    a disjunctive hypothesis, since the generated subgoals match the
    shape of the [or_introl] and [or_intror] constructors.

    Once again, we can also directly write proof objects for theorems
    involving [or], without resorting to tactics. *)

Definition inj_l : forall (P Q : Prop), P -> P \/ Q :=
  fun P Q HP => or_introl HP.

Theorem inj_l' : forall (P Q : Prop), P -> P \/ Q.
Proof.
  intros P Q HP. left. apply HP.
Qed.

Print inj_l.

Definition or_elim : forall (P Q R : Prop), (P \/ Q) -> (P -> R) -> (Q -> R) -> R :=
  fun P Q R HPQ HPR HQR =>
    match HPQ with
    | or_introl HP => HPR HP
    | or_intror HQ => HQR HQ
    end.

Theorem or_elim' : forall (P Q R : Prop), (P \/ Q) -> (P -> R) -> (Q -> R) -> R.
Proof.
  intros P Q R HPQ HPR HQR.
  destruct HPQ as [HP | HQ].
  - apply HPR. apply HP.
  - apply HQR. apply HQ.
Qed.

Print or_elim'.

End Or.

(** **** Exercise: 2 stars, standard (or_commut')

    Construct a proof object for the following proposition. *)

Definition or_commut' : forall P Q, P \/ Q -> Q \/ P :=
  fun P Q HPQ => match HPQ with
              | or_introl P => or_intror P
              | or_intror Q => or_introl Q
              end.

(** [] *)

(* ================================================================= *)
(** ** Existential Quantification *)

(** To give evidence for an existential quantifier, we package a
    witness [x] together with a proof that [x] satisfies the property
    [P]: *)

Module Ex.

Inductive ex {A : Type} (P : A -> Prop) : Prop :=
| ex_intro : forall x : A, P x -> ex P.

Inductive ex' {A : Type} (P : A -> Prop) : Prop :=
| ex_intro' (x : A) (H : P x) : ex' P.

Definition some_nat_is_even'' : @ex' nat ev :=
  @ex_intro' nat ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

Check ex_intro'.

Notation "'exists' x , p" :=
  (ex (fun x => p))
    (at level 200, right associativity) : type_scope.

End Ex.

(** This may benefit from a little unpacking.  The core definition is
    for a type former [ex] that can be used to build propositions of
    the form [ex P], where [P] itself is a _function_ from witness
    values in the type [A] to propositions.  The [ex_intro]
    constructor then offers a way of constructing evidence for [ex P],
    given a witness [x] and a proof of [P x].

    The notation in the standard library is a slight variant of
    the above, enabling syntactic forms such as [exists x y, P x y]. *)

(** The more familiar form [exists x, P x] desugars to an expression
    involving [ex]: *)

Check ex (fun n => ev n) : Prop.

(** Here's how to define an explicit proof object involving [ex]: *)

Definition some_nat_is_even : exists n, ev n :=
  ex_intro ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

Check ex_intro.
(* forall (A : Type) (P : A -> Prop) (x : A), P x -> exists y, P y *)

Check 4. (* nat *)
Check ev. (* nat -> Prop *)
Check (ev_SS 2 (ev_SS 0 ev_0)). (* ev 4 *)

(* Note that (A: Type) is omitted because it was marked optional.
   If we are to pass explicitly, we should put "nat" in there.
 *)

(** **** Exercise: 2 stars, standard (ex_ev_Sn)

    Construct a proof object for the following proposition. *)

Definition ex_ev_Sn : ex (fun n => ev (S n)) :=
  ex_intro (fun n => ev (S n)) 1 (ev_SS _ ev_0).
Print ex_ev_Sn.

(* ex_ev_Sn =
ex_intro (fun n : nat => ev (S n)) 1 (ev_SS 0 ev_0)
     : exists n : nat, ev (S n)
 *)

Definition ex_ev_Sn' : ex (fun n => ev (S n)).
Proof.
  exists 1. apply ev_SS. apply ev_0.
Qed.
Print ex_ev_Sn'.

(* ex_ev_Sn' =
ex_intro (fun n : nat => ev (S n)) 1 (ev_SS 0 ev_0)
     : exists n : nat, ev (S n)
 *)

(** [] *)

(* ================================================================= *)
(** ** [True] and [False] *)

(** The inductive definition of the [True] proposition is simple: *)

Inductive True : Prop :=
  | I : True.

(** It has one constructor (so every proof of [True] is the same, so
    being given a proof of [True] is not informative.) *)

(** **** Exercise: 1 star, standard (p_implies_true)

    Construct a proof object for the following proposition. *)

Definition p_implies_true : forall P, P -> True := (fun _P _HP => I).
Print p_implies_true.

(* p_implies_true = fun (_P : Type) (_ : _P) => I
     : forall P : Type, P -> True
 *)

Definition p_implies_true' : forall P, P -> True.
Proof.
  intro P. intro HP. apply I.
Qed.
Print p_implies_true'.

(* p_implies_true' = fun (P : Type) (_ : P) => I
     : forall P : Type, P -> True
 *)

(** [] *)

(** [False] is equally simple -- indeed, so simple it may look
    syntactically wrong at first glance! *)

Inductive False : Prop := .

(** That is, [False] is an inductive type with _no_ constructors --
    i.e., no way to build evidence for it. For example, there is
    no way to complete the following definition such that it
    succeeds (rather than fails). *)

Fail Definition contra : False :=
  0 = 1.

(** But it is possible to destruct [False] by pattern matching. There can
    be no patterns that match it, since it has no constructors.  So
    the pattern match also is so simple it may look syntactically
    wrong at first glance. *)

Definition false_implies_zero_eq_one : False -> 0 = 1 :=
  fun contra => match contra with end.

(** Since there are no branches to evaluate, the [match] expression
    can be considered to have any type we want, including [0 = 1].
    Indeed, it's impossible to ever cause the [match] to be evaluated,
    because we can never construct a value of type [False] to pass to
    the function. *)

(** **** Exercise: 1 star, standard (ex_falso_quodlibet')

    Construct a proof object for the following proposition. *)

Definition ex_falso_quodlibet' : forall P, False -> P :=
  fun p contra => match contra with end.

(** [] *)

End Props.

(* ################################################################# *)
(** * Equality *)

(** Even Coq's equality relation is not built in.  We can define
    it ourselves: *)

Module MyEquality.

Inductive eq {X:Type} : X -> X -> Prop :=
| eq_refl : forall x, eq x x.

Notation "x == y" := (eq x y)
                       (at level 70, no associativity)
                     : type_scope.

(** The way to think about this definition (which is just a slight
    variant of the standard library's) is that, given a set [X], it
    defines a _family_ of propositions "[x] is equal to [y]," indexed
    by pairs of values ([x] and [y]) from [X].  There is just one way
    of constructing evidence for members of this family: applying the
    constructor [eq_refl] to a type [X] and a single value [x : X],
    which yields evidence that [x] is equal to [x].

    Other types of the form [eq x y] where [x] and [y] are not the
    same are thus uninhabited. *)

(** We can use [eq_refl] to construct evidence that, for example, [2 =
    2].  Can we also use it to construct evidence that [1 + 1 = 2]?
    Yes, we can.  Indeed, it is the very same piece of evidence!

    The reason is that Coq treats as "the same" any two terms that are
    _convertible_ according to a simple set of computation rules.

    These rules, which are similar to those used by [Compute], include
    evaluation of function application, inlining of definitions, and
    simplification of [match]es.  *)

Lemma four: 2 + 2 == 1 + 3.
Proof.
  apply eq_refl.
Qed.

(** The [reflexivity] tactic that we have used to prove
    equalities up to now is essentially just shorthand for [apply
    eq_refl].

    In tactic-based proofs of equality, the conversion rules are
    normally hidden in uses of [simpl] (either explicit or implicit in
    other tactics such as [reflexivity]).

    But you can see them directly at work in the following explicit
    proof objects: *)

Definition four' : 2 + 2 == 1 + 3 :=
  eq_refl 4.

Definition singleton : forall (X:Type) (x:X), []++[x] == x::[]  :=
  fun (X:Type) (x:X) => eq_refl [x].

(** **** Exercise: 2 stars, standard (equality__leibniz_equality)

    The inductive definition of equality implies _Leibniz equality_:
    what we mean when we say "[x] and [y] are equal" is that every
    property on [P] that is true of [x] is also true of [y].  *)

Lemma equality__leibniz_equality : forall (X : Type) (x y: X),
  x == y -> forall P:X->Prop, P x -> P y.
Proof.
  intros. destruct H. apply H0.
Qed.

(* Trying to write a proof object for it *)

Fail Definition equality__leibniz_equality' : forall (X : Type) (x y: X),
    x == y -> forall P:X->Prop, P x -> P y :=
  fun X x y Heq HP HPx => match Heq with
                       | eq_refl x => _ (* I'm stuck *)
                       end.

Print equality__leibniz_equality.

(*
fun (X : Type) (x y : X) (H : x == y) (P : X -> Prop) (H0 : P x) =>
match H in (y0 == y1) return (P y0 -> P y1) with
| eq_refl x0 => fun H1 : P x0 => H1
end H0

 *)

(* So it seems like it's done using some intricate syntax that I
haven't learned yet. Let's move on anyway. *)

(** [] *)

(** **** Exercise: 3 stars, standard, optional (leibniz_equality__equality)

    Show that, in fact, the inductive definition of equality is
    _equivalent_ to Leibniz equality.  Hint: the proof is quite short;
    about all you need to do is to invent a clever property [P] to
    instantiate the antecedent.*)

Lemma leibniz_equality__equality : forall (X : Type) (x y: X),
  (forall P:X->Prop, P x -> P y) -> x == y.
Proof.
  intros.
  assert (Himp: x == x -> x == y).
  { apply H. }
  apply Himp. apply eq_refl.
Qed.

Definition leibniz_equality__equality' : forall (X : Type) (x y: X),
    (forall P:X->Prop, P x -> P y) -> x == y :=
  (fun X (x y : X) (H : forall P: X -> Prop, P x -> P y) =>
     (H (fun k => x == k)) (eq_refl x)
  ).

Print leibniz_equality__equality.

(** [] *)

End MyEquality.

(* ================================================================= *)
(** ** Inversion, Again *)

(** We've seen [inversion] used with both equality hypotheses and
    hypotheses about inductively defined propositions.  Now that we've
    seen that these are actually the same thing, we're in a position
    to take a closer look at how [inversion] behaves.

    In general, the [inversion] tactic...

    - takes a hypothesis [H] whose type [P] is inductively defined,
      and

    - for each constructor [C] in [P]'s definition,

      - generates a new subgoal in which we assume [H] was
        built with [C],

      - adds the arguments (premises) of [C] to the context of
        the subgoal as extra hypotheses,

      - matches the conclusion (result type) of [C] against the
        current goal and calculates a set of equalities that must
        hold in order for [C] to be applicable,

      - adds these equalities to the context (and, for convenience,
        rewrites them in the goal), and

      - if the equalities are not satisfiable (e.g., they involve
        things like [S n = O]), immediately solves the subgoal. *)

(** _Example_: If we invert a hypothesis built with [or], there are
    two constructors, so two subgoals get generated.  The
    conclusion (result type) of the constructor ([P \/ Q]) doesn't
    place any restrictions on the form of [P] or [Q], so we don't get
    any extra equalities in the context of the subgoal. *)

(** _Example_: If we invert a hypothesis built with [and], there is
    only one constructor, so only one subgoal gets generated.  Again,
    the conclusion (result type) of the constructor ([P /\ Q]) doesn't
    place any restrictions on the form of [P] or [Q], so we don't get
    any extra equalities in the context of the subgoal.  The
    constructor does have two arguments, though, and these can be seen
    in the context in the subgoal. *)

(** _Example_: If we invert a hypothesis built with [eq], there is
    again only one constructor, so only one subgoal gets generated.
    Now, though, the form of the [eq_refl] constructor does give us
    some extra information: it tells us that the two arguments to [eq]
    must be the same!  The [inversion] tactic adds this fact to the
    context. *)

(* ################################################################# *)
(** * The Coq Trusted Computing Base *)

(** One issue that arises with any automated proof assistant is
    "why trust it?": what if there is a bug in the implementation that
    renders all its reasoning suspect?

    While it is impossible to allay such concerns completely, the fact
    that Coq is based on the Curry-Howard correspondence gives it a
    strong foundation. Because propositions are just types and proofs
    are just terms, checking that an alleged proof of a proposition is
    valid just amounts to _type-checking_ the term.  Type checkers are
    relatively small and straightforward programs, so the "trusted
    computing base" for Coq -- the part of the code that we have to
    believe is operating correctly -- is small too.

    What must a typechecker do?  Its primary job is to make sure that
    in each function application the expected and actual argument
    types match, that the arms of a [match] expression are constructor
    patterns belonging to the inductive type being matched over and
    all arms of the [match] return the same type, and so on. *)

(** There are a few additional wrinkles:

    First, since Coq types can themselves be expressions, the checker
    must normalize these (by using the computation rules) before
    comparing them.

    Second, the checker must make sure that [match] expressions are
    _exhaustive_.  That is, there must be an arm for every possible
    constructor.  To see why, consider the following alleged proof
    object: *)

Fail Definition or_bogus : forall P Q, P \/ Q -> P :=
  fun (P Q : Prop) (A : P \/ Q) =>
    match A with
    | or_introl H => H
    end.

(** All the types here match correctly, but the [match] only
    considers one of the possible constructors for [or].  Coq's
    exhaustiveness check will reject this definition.

    Third, the checker must make sure that each recursive function
    terminates.  It does this using a syntactic check to make sure
    that each recursive call is on a subexpression of the original
    argument.  To see why this is essential, consider this alleged
    proof: *)

Fail Fixpoint infinite_loop {X : Type} (n : nat) {struct n} : X :=
  infinite_loop n.
Fail Definition falso : False := infinite_loop 0.

(** Recursive function [infinite_loop] purports to return a
    value of any type [X] that you would like.  (The [struct]
    annotation on the function tells Coq that it recurses on argument
    [n], not [X].)  Were Coq to allow [infinite_loop], then [falso]
    would be definable, thus giving evidence for [False].  So Coq rejects
    [infinite_loop]. *)

(** Note that the soundness of Coq depends only on the
    correctness of this typechecking engine, not on the tactic
    machinery.  If there is a bug in a tactic implementation (and this
    certainly does happen!), that tactic might construct an invalid
    proof term.  But when you type [Qed], Coq checks the term for
    validity from scratch.  Only theorems whose proofs pass the
    type-checker can be used in further proof developments.  *)

(* 2020-09-09 20:51 *)


(* chap 15.1 Proving Eveness *)

Require Import List.
Require Import Cpdt.CpdtTactics Cpdt.MoreSpecif.

Set Implicit Arguments.
Set Asymmetric Patterns.

Inductive isEven  : nat->Prop :=
| Even_O: isEven O
| Even_SS:forall n, isEven n->isEven (S (S n)).

Ltac prove_even:= repeat constructor.
Theorem even_256 : isEven 256.
  prove_even. Qed.
Theorem lt_2_1024 : 2<256.  (* it will be very slow *)
  prove_even. Qed.

Print lt_2_1024.
Print even_256.

Print partial.
Local Open Scope partial_scope.
Definition check_even: forall n:nat, [isEven n].
  Hint Constructors isEven.
  refine (fix F (n:nat):[isEven n]:=
            match n with
            | 0=>Yes
            | 1=>No
            | S (S n')=>Reduce (F n')
            end); auto.
Defined.

Definition partialOut (P:Prop) (x:[P]) :=
match x return (match x with
                | Proved _ =>P
                | Uncertain =>True
                end) with
| Proved pf => pf
| Uncertain => I
end.

Ltac prove_even_reflective:=
  match goal with
  | [ |- isEven ?N ]=> exact (partialOut (check_even N))
  end.

Theorem even_256' : isEven 256.
 prove_even_reflective. Qed.

Print even_256'.

Theorem even_255 : isEven 255.
Abort.

(* chap 15.2 *)

Theorem true_galore : (True /\ True) -> (True \/ (True /\ (True -> True))).
  tauto. Qed.
Print true_galore.

Inductive taut : Set :=
| TautTrue : taut
| TautAnd : taut->taut->taut
| TautOr: taut->taut->taut
| TautImp: taut ->taut ->taut.

Fixpoint tautDenote (t:taut) : Prop :=
  match t with
  | TautTrue => True
  | TautAnd t1 t2 => tautDenote t1 /\ tautDenote t2
  | TautOr t1 t2 => tautDenote t1 \/ tautDenote t2
  | TautImp t1 t2 => tautDenote t1 -> tautDenote t2
  end.

Theorem tautTrue : forall t, tautDenote t.
  induction t; crush. Qed.

Ltac tautReify P :=
  match P with
  | True => TautTrue
  | ?P1 /\ ?P2 =>
    let t1:= tautReify P1 in
    let t2:=tautReify P2 in
    constr:(TautAnd t1 t2)
  | ?P1 \/ ?P2 =>
    let t1:= tautReify P1 in
    let t2:= tautReify P2 in
    constr:(TautOr t1 t2)
  | ?P1 -> ?P2 =>
    let t1:= tautReify P1 in
    let t2:= tautReify P2 in
    constr:(TautImp t1 t2)
  end.

Ltac obvious :=
  match goal with
  | [ |- ?P ]=>
    let t:=tautReify P in
    exact (tautTrue t)
  end.

Lemma true_test1: True.
  exact (tautTrue TautTrue). Qed.
Print true_test1.
Theorem true_galore' : (True /\ True) -> (True \/ (True /\ (True -> True))).
  obvious. Qed.

Print true_galore'.

(* chap 15.3 *)

Section monoid.
  Variable A : Set.
  Variable e : A.
  Variable f : A->A->A.

  Infix "+" := f.
  Hypothesis assocc:forall a b c, (a+b)+c =a +(b+c).
  Hypothesis identl :forall a, e+a= a.
  Hypothesis identr: forall a, a+e=a.

  Inductive mexp:Set:=
  | Ident:mexp
  |Var :A -> mexp
  | Op : mexp ->mexp ->mexp.

  Fixpoint mdenote (me:mexp) : A:=
    match me with
    | Ident => e
    | Var v => v
    | Op me1 me2 => mdenote me1 + mdenote me2
    end.

  Fixpoint mIdenote (ls :list A): A:=
    match ls with
    | nil => e
    | x::ls'=> x+ mIdenote ls'
    end.

  Fixpoint flatten (me:mexp) :list A:=
    match me with
    | Ident => nil
    | Var x => x::nil
    | Op me1 me2 =>flatten me1++flatten me2
    end.

  Lemma flatten_correct': forall ml2 ml1,
      mIdenote ml1 + mIdenote ml2 = mIdenote (ml1++ml2).
    induction ml1; crush. Qed.

  Theorem flatten_correct : forall me, mdenote me = mIdenote (flatten me).
    Hint Resolve flatten_correct'.
    induction me; crush. Qed.

  Theorem monoid_reflect : forall me1 me2, mIdenote (flatten me1) =
                                      mIdenote (flatten me2) ->
                                      mdenote me1=mdenote me2.
    intros; repeat rewrite flatten_correct; assumption. Qed.

  Ltac reify me:=
    match me with
    | e => Ident
    | ?me1 + ?me2 =>
      let r1:= reify me1 in
      let r2:= reify me2 in
      constr:(Op r1 r2)
    | _ => constr:(Var me)
    end.

  Ltac monoid :=
    match goal with
    | [ |- ?me1 = ?me2 ]=>
      let r1:= reify me1 in
      let r2:= reify me2 in
      change (mdenote r1=mdenote r2);
      apply monoid_reflect; simpl
    end.

  Theorem t1:forall a b c d, a+b+c +d = a+ (b+c) +d.
    intros; monoid. reflexivity. Qed.

  Print t1.
End monoid.

Module test1. (* This module is a test for keyword `return` *)
  Inductive test:Type:=
    test1 | test2.
  Definition return_test (n:test) :=
    match n return (match n with
                    | test1 => Prop
                    | test2 => Type
                   end)  with
    | test1 => (forall x:nat , x >=0)
    | test2 => test
    end.
  Lemma test_test : return_test test1=(forall x:nat, x >= 0).
    reflexivity. Qed. Print test_test.
End test1.

(* chap 15.4 *)
Require Import Quote.

Inductive formula: Set:=
| Atomic :index->formula
| Truth: formula
| Falsehood : formula
| And : formula -> formula -> formula
| Or: formula -> formula -> formula
| Imp : formula -> formula -> formula.

Definition imp (P1 P2:Prop)  := P1->P2.
Infix "->" := imp (no associativity, at level 95).

Definition asgn := varmap Prop.
Fixpoint formulaDenote (atomics:asgn) (f:formula) :Prop:=
  match f with
  | Atomic v => varmap_find False v atomics
  | Truth => True
  | Falsehood => False
  | And f1 f2 => formulaDenote atomics f1 /\ formulaDenote atomics f2
  | Or f1 f2 => formulaDenote atomics f1 \/ formulaDenote atomics f2
  | Imp f1 f2 => formulaDenote atomics f1 -> formulaDenote atomics f2
  end.

Section my_tauto.
  Variable atomics : asgn.
  Definition holds (v:index)  := varmap_find False v atomics.
  Require Import ListSet.

  Definition index_eq : forall x y:index, {x = y}+{ x<> y}.
    decide equality.
  Defined.

  Definition add (s:set index) (v:index)  := set_add index_eq v s.
  Definition In_dec:forall v (s :set index), {In v s}+{~ In v s} .
    Local Open Scope specif_scope.

    intro; refine (fix F (s:set index) : {In v s}+{~ In v s}:=
                     match s with
                     | nil => No
                     | v'::s' => index_eq v' v || F s'
                     end); crush.
  Defined.

  Fixpoint allTrue (s:set index) :Prop:=
    match s with
    | nil => True
    | v::s' => holds v /\ allTrue s'
    end.

  Theorem allTrue_add : forall v s, allTrue s->
                               holds v->allTrue (add s v).
    induction s; crush; match goal with
                        | [ |- context[if ?E then _ else _]]=> destruct E
                        end; crush. Qed.

  Theorem allTrue_In : forall v s, allTrue s -> set_In v s ->
                              varmap_find False v atomics.
    induction s; crush. Qed.

  Hint Resolve allTrue_add allTrue_In.
  Local Open Scope partial_scope.

  Definition forward: forall (f :formula) (known:set index) (hyp:formula)
                        (cont: forall known', [allTrue known'->formulaDenote atomics f]),
      [allTrue known ->formulaDenote atomics hyp -> formulaDenote atomics f].
    refine (fix F (f:formula ) (known: set index) (hyp: formula)
                (cont : forall known', [allTrue known' -> formulaDenote atomics f])
            : [ allTrue known -> formulaDenote atomics hyp -> formulaDenote atomics f]:=
              match hyp with
              | Atomic v => Reduce (cont (add known v))
              | Truth => Reduce (cont known)
              | Falsehood  => Yes
              | And h1 h2 =>
                Reduce (F (Imp h2 f) known h1 (fun known' =>
                                                 Reduce (F f known' h2 cont)))
              | Or h1 h2 => F f known h1 cont && F f known h2 cont
              | Imp _ _ => Reduce (cont known)
              end); crush.
  Defined.

  Definition backward : forall (known : set index) (f : formula),
[allTrue known -> formulaDenote atomics f ].
refine (fix F (known : set index) (f : formula)
: [allTrue known -> formulaDenote atomics f ] :=
match f with
| Atomic v => Reduce (In_dec v known)
| Truth => Yes
| Falsehood => No
| And f1 f2 => F known f1 && F known f2
| Or f1 f2 => F known f1 || F known f2
| Imp f1 f2 => forward f2 known f1 (fun known' => F known' f2 )
end); crush; eauto.
  Defined.

  Definition my_tauto: forall f: formula, [formulaDenote atomics f].
    intro; refine (Reduce (backward nil f)) ;crush. Defined.

End my_tauto.

Ltac my_tauto:=
  repeat match goal with
         | [ |- forall x:?P, _ ]=>
           match type of P with
           | Prop => fail 1
           | _ => intro
           end
         end;
  quote formulaDenote;
  match goal with
  | [ |- formulaDenote ?m ?f] => exact (partialOut (my_tauto m f))
  end.

Theorem mt1 : True.
  my_tauto. Qed.

Print mt1.

Theorem mt2 : forall x y:nat, x= y -> x=y.
  intros.


From Coq Require Import
  Lia
  List
  ZArith.
From FunProofs.Lib Require Import
  Arith
  List
  Tactics.
From FunProofs.Lib Require Export
  AltMap
  Extrema
  Sum.

#[local] Open Scope Z.

Section Geom.
  Definition geom r n := map (fun x => Z.pow r (Z.of_nat x)) (seq 0 n).
  Definition tens := geom 10.

  Lemma geom_length r n : length (geom r n) = n.
  Proof. unfold geom; rewrite map_length, seq_length; auto. Qed.

  Lemma geom_mod r r' n b :
    b <> 0 ->
    r mod b = r' mod b ->
    map (fun x => x mod b) (geom r n) = map (fun x => x mod b) (geom r' n).
  Proof.
    unfold geom; intros.
    erewrite !map_map, map_ext; eauto.
    intros; apply pow_mod; lia.
  Qed.

  Lemma geom_one n : geom 1 n = repeat 1 n.
  Proof.
    unfold geom; induction n; cbn; auto.
    rewrite <- seq_shift, map_map, <- IHn.
    erewrite map_ext; auto.
    intros; rewrite !Z.pow_1_l; lia.
  Qed.

  Lemma geom_none n : geom (-1) n = altmap Z.opp (repeat 1 n).
  Proof.
    unfold geom; induction n; cbn; auto.
    rewrite <- seq_shift, map_map.
    erewrite map_ext with (g := fun x => _).
    2: intros; rewrite Nat2Z.inj_succ, Z.pow_succ_r by lia.
    2: rewrite Z.mul_comm, <- Z.opp_eq_mul_m1; eauto.
    rewrite <- map_map, IHn.
    clear IHn; induction n; cbn; auto.
    rewrite <- IHn; cbn; auto.
    rewrite map_map.
    erewrite map_ext with (g := fun x => x), map_id; auto using Z.opp_involutive.
  Qed.

  Lemma geom_zero' n : tl (geom 0 n) = repeat 0 (n - 1).
  Proof.
    unfold geom; induction n; cbn; auto.
    destruct n; auto; cbn -[Z.of_nat].
    replace (S n - 1)%nat with n in IHn by lia.
    rewrite <- seq_shift, map_map, <- IHn; cbn -[Z.of_nat].
    f_equal; apply map_ext_in; intros * Hin.
    apply in_seq in Hin; rewrite !Z.pow_0_l; lia.
  Qed.

  Corollary geom_zero n : (0 < n)%nat -> geom 0 n = 1 :: repeat 0 (n - 1).
  Proof. intros; rewrite <- geom_zero'; now destruct n. Qed.
End Geom.


(** Solutions to exercise sheet for lecture 2: Fundamentals of Coq.

Note that these are just suggestions for solutions and many of the
problems can have different solutions. Once you know how to prove
things in Coq you can try to prove that your solutions are equivalent
to the ones in this file.

Written by Anders Mörtberg.

*)
Require Import UniMath.Foundations.Preamble.
Require Import fundamentals_lecture.

Definition idfun : forall (A : UU), A -> A := fun (A : UU) (a : A) => a.

Definition const (A B : UU) (a : A) (b : B) : A := a.

(** * Booleans *)

Definition ifbool (A : UU) (x y : A) : bool -> A :=
  bool_rect (fun _ : bool => A) x y.

Definition negbool : bool -> bool :=
  ifbool bool false true.

Definition andbool (b : bool) : bool -> bool :=
  ifbool (bool -> bool) (idfun bool) (const bool bool false) b.

(** Exercise: define boolean or: *)

Definition orbool (b : bool) : bool -> bool :=
  ifbool (bool -> bool) (const bool bool true) (idfun bool) b.

Eval compute in orbool true true.     (* true *)
Eval compute in orbool true false.    (* true *)
Eval compute in orbool false true.    (* true *)
Eval compute in orbool false false.   (* false *)

(** * Natural numbers *)

Definition nat_rec (A : UU) (a : A) (f : nat -> A -> A) : nat -> A :=
  nat_rect (fun _ : nat => A) a f.

Definition even : nat -> bool := nat_rec bool true (fun _ b => negbool b).

(** Exercise: define a function odd that tests if a number is odd *)
Definition odd : nat -> bool :=
  nat_rec bool false (fun _ b => negbool b).

Eval compute in odd 24.   (* false *)
Eval compute in odd 19.   (* true *)

(** Exercise: define a notation "myif b then x else y" for "ifbool _ x y b"
and rewrite negbool and andbool using this notation. *)

Notation "'myif' b 'then' x 'else' y" := (ifbool _ x y b) (at level 1).

Definition negbool' (b : bool) : bool := myif b then false else true.

(* Check that negbool' uses ifbool by disabling printing of notations *)
Unset Printing Notations.
Print negbool'.
Set Printing Notations.

Eval compute in negbool' true.   (* false *)
Eval compute in negbool' false.  (* true *)

Definition andbool' (b1 b2 : bool) : bool :=
  myif b1 then b2 else false.

Eval compute in andbool true true.    (* true *)
Eval compute in andbool true false.   (* false *)
Eval compute in andbool false true.   (* false *)
Eval compute in andbool false false.  (* false *)

Definition add (m : nat) : nat -> nat := nat_rec nat m (fun _ y => S y).

Definition iter (A : UU) (a : A) (f : A → A) : nat → A :=
  nat_rec A a (λ _ y, f y).

Notation "f ̂ n" := (λ x, iter _ x f n) (at level 10).

Definition sub (m n : nat) : nat := pred ̂ n m.

(** Exercise: define addition using iter and S *)
Definition add' (m : nat) : nat → nat :=
  iter nat m S.

Eval compute in add' 4 9.   (* 13 *)

Definition is_zero : nat -> bool := nat_rec bool true (fun _ _ => false).

Definition eqnat (m n : nat) : bool :=
  andbool (is_zero (sub m n)) (is_zero (sub n m)).

Notation "m == n" := (eqnat m n) (at level 50).

(** Exercises: define <, >, ≤, ≥  *)

Definition ltnat (m n : nat) : bool := is_zero (sub (S m) n).

Notation "x < y" := (ltnat x y).

Eval compute in (2 < 3). (* true *)
Eval compute in (3 < 3). (* false *)
Eval compute in (4 < 3). (* false *)

Definition gtnat (m n : nat) : bool := n < m.

Notation "x > y" := (gtnat x y).

Eval compute in (2 > 3). (* false *)
Eval compute in (3 > 3). (* false *)
Eval compute in (4 > 3). (* true *)

Definition leqnat (m n : nat) : bool := orbool (m < n) (m == n).

Notation "x ≤ y" := (leqnat x y) (at level 10).

Eval compute in (2 ≤ 3). (* true *)
Eval compute in (3 ≤ 3). (* true *)
Eval compute in (4 ≤ 3). (* false *)

Definition geqnat (m n : nat) : bool := orbool (m > n) (m == n).

Notation "x ≥ y" := (geqnat x y) (at level 10).

Eval compute in (2 ≥ 3). (* false *)
Eval compute in (3 ≥ 3). (* true *)
Eval compute in (4 ≥ 3). (* true *)

Definition coprod_rec {A B C : UU} (f : A → C) (g : B → C) : A ⨿ B → C :=
  @coprod_rect A B (λ _, C) f g.

Definition Z : UU := coprod nat nat.

Notation "⊹ x" := (inl x) (at level 20).
Notation "─ x" := (inr x) (at level 40).

Definition Z1 : Z := ⊹ 1.
Definition Z0 : Z := ⊹ 0.
Definition Zn3 : Z := ─ 2.

Definition Zcase (A : UU) (fpos : nat → A) (fneg : nat → A) : Z → A :=
  coprod_rec fpos fneg.

Definition negate : Z → Z :=
  Zcase Z (λ x, ifbool Z Z0 (─ pred x) (is_zero x)) (λ x, ⊹ S x).

(* Exercise (harder): define addition for Z *)

Definition Zadd : Z -> Z -> Z :=
  Zcase (Z → Z)
        (λ posn : nat,
           Zcase Z
                 (λ posm : nat, ⊹ (posn + posm))
                 (λ negm : nat,
                    myif posn ≥ negm then ⊹ (posn - negm)
                                      else (─ (negm - posn))))
        (λ negn : nat,
           Zcase Z
                 (λ posm : nat,
                    myif posm ≥ negn then ⊹ (posm - negn)
                                      else (─ (negn - posm)))
                 (λ negm : nat, ─ (S negn + negm))).

(* This should satisfy *)
Eval compute in Zadd Z0 Z0.              (* ⊹ 0 *)
Eval compute in Zadd Z1 Z1.              (* ⊹ 2 *)
Eval compute in Zadd Z1 Zn3.             (* ─ 1 *) (* recall that negative numbers are off-by-one *)
Eval compute in Zadd Zn3 Z1.             (* ─ 1 *)
Eval compute in Zadd Zn3 Zn3.            (* ─ 5 *)
Eval compute in Zadd (Zadd Zn3 Zn3) Zn3. (* ─ 8 *)
Eval compute in Zadd Z0 (negate (Zn3)).  (* ⊹ 3 *)


Require Import ProofCheckingEuclid.euclidean_axioms.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_BCA.
Require Import ProofCheckingEuclid.lemma_collinear_ABC_BAC.

Section Euclid.

Context `{Ax1:euclidean_neutral}.

Lemma lemma_collinearorder :
	forall A B C,
	Col A B C ->
	Col B A C /\ Col B C A /\ Col C A B /\ Col A C B /\ Col C B A.
Proof.
	intros A B C.
	intros Col_A_B_C.

	pose proof (lemma_collinear_ABC_BCA _ _ _ Col_A_B_C) as Col_B_C_A.
	pose proof (lemma_collinear_ABC_BCA _ _ _ Col_B_C_A) as Col_C_A_B.
	pose proof (lemma_collinear_ABC_BAC _ _ _ Col_A_B_C) as Col_B_A_C.
	pose proof (lemma_collinear_ABC_BCA _ _ _ Col_B_A_C) as Col_A_C_B.
	pose proof (lemma_collinear_ABC_BCA _ _ _ Col_A_C_B) as Col_C_B_A.

	repeat split.
	exact Col_B_A_C.
	exact Col_B_C_A.
	exact Col_C_A_B.
	exact Col_A_C_B.
	exact Col_C_B_A.
Qed.

End Euclid.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import Lists.List.
Require Export Bnat.

(* written by zhanghui *)
Fixpoint list_append {A: Set} (l: list A) (a: A) : list A :=
  match l with
    | nil => cons a nil
    | cons x l' => cons x (list_append l' a)
  end.

Fixpoint list_none {A: Set} (n: nat) : list (option A) :=
  match n with
    | O => nil
    | S n => cons None (list_none n)
  end.

(* written by zhanghui *)
Fixpoint list_repeat {A: Set} (n : nat) (elem : A) : list A :=
  match n with
    | O => nil
    | S n' => cons elem (list_repeat n' elem)
  end.

Fixpoint list_get {A: Set} (l: list A) (i: nat) : option A :=
  match i, l with
    | O, cons a l' => Some a
    | S i', cons a l' => list_get l' i'
    | _, _ => None
  end.

Fixpoint list_set {A: Set} (l: list A) (i: nat) (a: A): option (list A) :=
  match i, l with
    | O, cons a' l' => Some (cons a l')
    | S i', cons a' l' =>
      match list_set l' i' a with
        | None => None
        | Some l'' => Some (cons a' l'')
      end
    | _, _ => None
  end.

Fixpoint list_find_aux {A:Set} (beq_a: A->A->bool) (l:list A) (a: A) (i: nat) : option nat :=
  match l with
    | nil => None
    | cons a' l' => match beq_a a a' with
                      | true => Some i
                      | false => list_find_aux beq_a l' a (S i)
                    end
  end.

Definition list_find {A:Set} (beq_a: A->A->bool) (l:list A) (a: A) : option nat :=
  list_find_aux beq_a l a O.

Fixpoint list_find_rev_aux {A:Set} (beq_a: A->A->bool) (l:list A) (a: A) (i: nat) : option nat :=
  match l with
    | nil => None
    | cons a' l' => match list_find_rev_aux beq_a l' a (S i) with
                      | Some i' => Some i'
                      | None => match beq_a a a' with
                                  | true => Some i
                                  | false => None
                                end
                    end
  end.

Definition list_find_rev {A:Set} (beq_a: A->A->bool) (l:list A) (a: A): option nat :=
  list_find_rev_aux beq_a l a O.

(* Eval compute in (list_find beq_nat (0::1::99::3::4::5::99::7::nil) 99). *)
(* Eval compute in (list_find_rev beq_nat (0::1::99::3::4::5::99::7::nil) 99). *)

Fixpoint list_find_min {A: Set} (l: list A) (pred: A -> A -> option bool) : option A :=
  match l with
    | nil => None
    | cons x nil => Some x
    | cons x l' =>
      match list_find_min l' pred with
        | None => None
        | Some m =>
          match pred x m with
            | None => None
            | Some b =>
              match b with
                | true => Some x
                | false => Some m
              end
          end
      end
  end.

Definition blt_nat_opt (n1 n2 : nat) : option bool :=
  Some (ble_nat n1 n2).

Definition test_list_1 := (11::22::33::44::55::88::66::77::88::9::nil).
Example list_find_min_test1 : list_find_min test_list_1 blt_nat_opt = Some 9.
Proof. reflexivity. Qed.

Definition list_find_min_index {A: Set} (l: list A) (pred_min: A -> A -> option bool)
           (pred_eq: A -> A -> bool): option nat :=
  match list_find_min l pred_min with
    | None => None
    | Some a =>
      list_find pred_eq l a
  end.

Example list_find_min_index_test1 : list_find_min_index test_list_1 blt_nat_opt beq_nat = Some 9.
Proof. reflexivity. Qed.

Fixpoint list_in {A: Set} (beq_a: A->A->bool) (l: list A) (a : A) : bool :=
  match l with
    | nil => false
    | cons a' l' => match beq_a a a' with
                      | true => true
                      | false => list_in beq_a l' a
                    end
  end.

Lemma list_set_length_preserv:
  forall {A: Set} (l:list A) i l' (a: A),
    blt_nat i (length l) = true
    -> list_set l i a = Some l'
    -> length l' = length l.
Proof.
  intro A.
  induction l; destruct i; simpl; intros.
    discriminate.
    discriminate.
  destruct l' as [ | a' l'].
  discriminate.
  inversion H0.
  subst a0 l'.
  simpl; trivial.
  destruct l' as [ | a' l'].
  destruct (list_set l i a0).
    inversion H0.
    discriminate.
  simpl.
  remember (list_set l i a0) as x.
  destruct x.
  inversion H0; subst.
  assert (length l' = length l).
    eapply IHl; eauto.
  auto with arith.
  discriminate.
Qed.


(** Experimental !!!! *)
(** This file is a draft !!! *)

(*
https://math-comp.github.io/htmldoc_1_14_0/mathcomp.ssreflect.choice.html

https://github.com/math-comp/math-comp/blob/master/mathcomp/ssreflect/order.v
 *)

From mathcomp Require Import all_ssreflect zify.
From Coq Require Import Logic.Eqdep_dec.
From hydras Require Import DecPreOrder ON_Generic  T1 E0.
From gaia Require Export ssete9.
Require Import T1Bridge.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**  Type [T1] vs generic trees *)

Fixpoint T12Tree (a: T1): GenTree.tree nat :=
  if a is cons b n c
  then GenTree.Node n [:: T12Tree b; T12Tree c]
  else GenTree.Leaf 0.

Fixpoint Tree2T1 (t: GenTree.tree nat): option T1 :=
  match t with
  | GenTree.Leaf 0 => Some zero
  | GenTree.Node n [:: t1; t2] =>
      match Tree2T1 t1, Tree2T1 t2 with
      | Some b, Some c => Some (cons b n c)
      | _, _ => None
      end
  | _ => None
  end.

Lemma TreeT1K : pcancel T12Tree Tree2T1.
Proof.
  elim => // t Ht n t0 Ht0 /=; by rewrite Ht0 Ht.
Qed.

(** to remove (useless) *)
Lemma  T12Tree_inj: injective T12Tree.
Proof.
  move => t1 t2 Heq.
  have H: Some t1 = Some t2 by rewrite -!TreeT1K Heq.
  by injection H.
Qed.

Definition T1mixin :
  Countable.mixin_of T1 := PcanCountMixin TreeT1K.

Canonical T1Choice :=
  Eval hnf in ChoiceType T1 (CountChoiceMixin T1mixin).

Example ex_pos: exists alpha: T1, zero != alpha.
Proof. exists (cons zero 0 zero) => //. Qed.

Example some_pos: T1 := xchoose ex_pos.

Example some_pos' : T1 := choose (fun p : T1 => zero != p)
                                 T1omega.

Goal (zero: T1Choice) != some_pos'.
  pose p a := (zero != a); move: (@chooseP _ p T1omega).
  rewrite /p /some_pos' => H; by apply: H.
Qed.

Compute  [eqType of T1].
(**    = EqType T1 (EqMixin (@T1eqP))
     : eqType *)

Compute  [choiceType of T1].

(**
   = Choice.Pack
         {|
           Choice.base := EqMixin (@T1eqP);
           Choice.mixin := PcanChoiceMixin (pcan_pickleK TreeT1K)
         |}
     : choiceType

*)

Definition T1_le_Mixin := leOrderMixin T1Choice.

Definition T1min a b := if T1lt a b then a else b.
Definition T1max a b := if T1lt a b then b else a.

Lemma T1ltE x y : T1lt x y = (y != x) && T1le x y.
Proof. by rewrite T1lt_neAle eq_sym. Qed.

Lemma T1minE x y : T1min x y = (if T1lt x y then x else y).
Proof. done. Qed.

Lemma T1maxE x y : T1max x y = (if T1lt x y then y else x).
Proof. done. Qed.

Lemma T1le_asym: ssrbool.antisymmetric T1le.
Proof. move => x y;  by rewrite -T1eq_le =>/eqP. Qed.

Definition T1leOrderMixin : leOrderMixin T1Choice :=
  LeOrderMixin T1ltE T1minE T1maxE T1le_asym T1le_trans T1le_total.

Canonical T1orderType :=
  @OrderOfChoiceType tt T1Choice T1leOrderMixin.

Goal @Order.le tt T1orderType T1omega T1omega.
by rewrite Order.POrderTheory.lexx.
Qed.

Check T1omega: T1orderType.

Goal ((T1omega:T1orderType) <= (T1omega:T1orderType))%O.
done.
Qed.

Notation "x <= y" := (@Order.le _ T1orderType  x y).

Notation "x < y" := (@Order.lt _ T1orderType  x y).

About Order.le.

Goal @Order.le tt T1orderType T1omega T1omega.
apply Order.POrderTheory.lexx.
Qed.
Import Order.POrderTheory.

Goal T1omega <= T1omega.
Set Printing All.
apply lexx.
Qed.

Goal T1omega < T1succ T1omega.
by [].
Qed.

Fail Goal  ~~ (<%O T1omega T1omega).

Goal  ~~ (<%O (T1omega:T1orderType) (T1omega:T1orderType)).
by cbn. Qed.

Goal ~~(T1omega < T1omega).
by cbn.
Qed.

Compute Order.POrder.sort T1orderType.
Goal ~~ @Order.lt tt (T1orderType) T1omega T1omega.
by cbn.
Qed.

Goal T1omega <= T1omega.
by [].
Qed.

Fail Goal Order.max T1omega T1omega == T1omega.

Print E0.

(* Check [subCountType of T1]. *)


Require Export vectors.
Require Import notations decidables Setoid Morphisms.

Definition matr A rows cols := fin rows -> fin cols -> A.
Definition matr_eq {A rows cols} (M1 M2: matr A rows cols) := forall i j, M1 i j = M2 i j.

Definition matr_row {A rows cols} (i: fin rows) (M: matr A rows cols): vect A cols := fun j => M i j.
Definition matr_col {A rows cols} (j: fin cols) (M: matr A rows cols): vect A rows := fun i => M i j.

Definition matr_transpose {A rows cols} (M: matr A rows cols): matr A cols rows := fun i j => M j i.

Definition remove_row {A rows cols} (num: fin (S rows)) (M: matr A (S rows) cols): matr A rows cols :=
 fun i j => if le_dec i.1 num.1 then M (le_to_fin (le_S _ _ i.2)) j else M (le_to_fin (Le.le_n_S _ _ i.2)) j.
Definition remove_col {A rows cols} (num: fin (S cols)) (M: matr A rows (S cols)): matr A rows cols :=
 fun i j => if le_dec j.1 num.1 then M i (le_to_fin (le_S _ _ j.2)) else M i (le_to_fin (Le.le_n_S _ _ j.2)).

Instance matr_eq_Equiv A n: Equivalence (vect_eq (A:=A) (n:=n)).
 split; unfold Reflexive, Symmetric, Transitive, matr_eq; congruence.
Qed.
Instance matr_row_Proper A rows cols i: Proper (matr_eq ==> vect_eq) (matr_row (A:=A) (rows:=rows) (cols:=cols) i).
 unfold Proper, respectful, matr_eq, vect_eq, matr_row; auto.
Qed.
Instance matr_col_Proper A rows cols i: Proper (matr_eq ==> vect_eq) (matr_col (A:=A) (rows:=rows) (cols:=cols) i).
 unfold Proper, respectful, matr_eq, vect_eq, matr_col; auto.
Qed.
Instance matr_transpose_Proper A rows cols: Proper (matr_eq ==> matr_eq) (matr_transpose (A:=A) (rows:=rows) (cols:=cols)).
 unfold Proper, respectful, matr_eq, matr_transpose; auto.
Qed.
Instance remove_row_Proper A rows cols num: Proper (matr_eq ==> matr_eq) (remove_row (A:=A) (rows:=rows) (cols:=cols) num).
 unfold Proper, respectful, matr_eq, remove_row; intros; repeat destruct le_dec; auto.
Qed.
Instance remove_col_Proper A rows cols num: Proper (matr_eq ==> matr_eq) (remove_col (A:=A) (rows:=rows) (cols:=cols) num).
 unfold Proper, respectful, matr_eq, remove_col; intros; repeat destruct le_dec; auto.
Qed.


From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat div seq.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** Implement an instance of equality type for the [seq] datatype *)

(** Take apart the following proof: *)
Lemma size_eq0 (T : eqType) (s : seq T) :
  (size s == 0) = (s == [::]).
Proof. exact: (sameP nilP eqP). Qed.

Lemma filter_all T (a : pred T) s :
  all a (filter a s).
Admitted.

Lemma filter_id T (a : pred T) s :
  filter a (filter a s) = filter a s.
Admitted.

Lemma all_count T (a : pred T) s :
  all a s = (count a s == size s).
Admitted.

Lemma all_predI T (a1 a2 : pred T) s :
  all (predI a1 a2) s = all a1 s && all a2 s.
Admitted.

Lemma allP (T : eqType) {a : pred T} {s : seq T} :
  reflect {in s, forall x, a x} (all a s).
(* Hint 1: *)
(* rewrite /prop_in1. *)

(* Hint 2a and 2b: *)
(* Check erefl : 1 \in [:: 3; 2; 1; 0] = true. *)
(* Check erefl : 42 \in [:: 3; 2; 1; 0] = false. *)
Admitted.

Lemma sub_find T (a1 a2 : pred T) s :
  subpred a1 a2 ->
  find a2 s <= find a1 s.
Admitted.

Lemma take_nseq T n m (x : T) : take n (nseq m x) = nseq (minn n m) x.
Admitted.

Lemma rev_nseq A n (x : A) : rev (nseq n x) = nseq n x.
Admitted.

(* Hint: use mapP *)
Lemma mem_map (T1 T2 : eqType) (f : T1 -> T2) x s :
  injective f ->
  (f x \in map f s) = (x \in s).
Admitted.

(* Double induction principle *)
Lemma seq_ind2 {S T} (P : seq S -> seq T -> Type) :
    P [::] [::] ->
    (forall x y s t, size s = size t -> P s t -> P (x :: s) (y :: t)) ->
  forall s t, size s = size t -> P s t.
Admitted.

(* Hint: use seq_ind2 to prove the following *)
Lemma rev_zip S T (s : seq S) (t : seq T) :
  size s = size t -> rev (zip s t) = zip (rev s) (rev t).
Admitted.

Lemma last_ind T (P : seq T -> Prop) :
  P [::] -> (forall s x, P s -> P (rcons s x)) -> forall s, P s.
Admitted.

(* Hint: use last_ind to prove the following *)
Lemma nth_rev T (x0 : T) n (s : seq T) :
  n < size s -> nth x0 (rev s) n = nth x0 s (size s - n.+1).
Admitted.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf3 : natural) (y : natural) (lf2 : natural) : natural :=
  mult (Succ y) lf3.


(** * 6.887 Formal Reasoning About Programs - Lab 4
    * Abstract Interpretation *)

Require Import Frap Imp.

(* Authors: Adam Chlipala (adamc@csail.mit.edu), Peng Wang (wangpeng@csail.mit.edu) *)

Set Implicit Arguments.

(* In lecture, we saw a very general abstract-interpretation framework, but it
 * had one important weakness (among others): it always ignores conditional
 * expressions, so we get significant imprecision in modeling "if" and "while."
 * This lab is all about
 * (1) extending the framework to analyze conditionals;
 * (2) extending the example even-odd interpretation for the new framework; and
 * (3) verifying a particular program automatically, where the old framework
 *     would fail because of precision loss. *)

(* FIRST, here's our old definition of an abstract interpretation.  In fact,
 * this fill is an already-compiling excerpt of the code from lecture, with some
 * comments indicating changes that we'd like you to make.  Your highly
 * strenuous first task is to uncomment the *two new record fields* below, which
 * provide the extra information for sound abstract interpretation of
 * conditionals. *)
Record absint := {
  Domain :> Set;
  (* We will represent concrete values (natural numbers) with this alternative,
   * abstract set.  This [:>] notation lets us treat any [absint] as its
   * [Domain], automatically.  See below for examples (e.g., return type of
   * [absint_interp]). *)
  Top : Domain;
  (* A universal (least informative) element, describing *all* concrete
   * values *)
  Constant : nat -> Domain;
  (* Most accurate representation of a constant *)
  Add : Domain -> Domain -> Domain;
  Subtract : Domain -> Domain -> Domain;
  Multiply : Domain -> Domain -> Domain;
  (* Abstract versions of arithmetic operators *)
  Join : Domain -> Domain -> Domain;
  (* Returns some new element that covers all cases of each of its inputs *)
  Represents : nat -> Domain -> Prop
  (* Which elements represent which numbers? *)

  (* UNCOMMENT THIS PART TO START THE LAB! *)
(*;
  (* Given our knowledge of a value, could it possibly be zero or nonzero? *)
  CouldBeZero : Domain -> bool;
  CouldBeNonzero : Domain -> bool
*)
}.

(* CHALLENGE #1: Add new algebraic laws to this soundness condition, sufficient
 * to enable you to prove the theorems from later challenges.  You may find
 * yourself returning here frequently as you work on those proofs, when you find
 * you need a new law! *)
Record absint_sound (a : absint) : Prop := {
  TopSound : forall n, a.(Represents) n a.(Top);

  ConstSound : forall n, a.(Represents) n (a.(Constant) n);

  AddSound : forall n na m ma, a.(Represents) n na
                               -> a.(Represents) m ma
                               -> a.(Represents) (n + m) (a.(Add) na ma);
  SubtractSound: forall n na m ma, a.(Represents) n na
                                   -> a.(Represents) m ma
                                   -> a.(Represents) (n - m) (a.(Subtract) na ma);
  MultiplySound : forall n na m ma, a.(Represents) n na
                                    -> a.(Represents) m ma
                                    -> a.(Represents) (n * m) (a.(Multiply) na ma);

  AddMonotone : forall na na' ma ma', (forall n, a.(Represents) n na -> a.(Represents) n na')
                                      -> (forall n, a.(Represents) n ma -> a.(Represents) n ma')
                                      -> (forall n, a.(Represents) n (a.(Add) na ma)
                                                    -> a.(Represents) n (a.(Add) na' ma'));
  SubtractMonotone : forall na na' ma ma', (forall n, a.(Represents) n na -> a.(Represents) n na')
                                           -> (forall n, a.(Represents) n ma -> a.(Represents) n ma')
                                           -> (forall n, a.(Represents) n (a.(Subtract) na ma)
                                                         -> a.(Represents) n (a.(Subtract) na' ma'));
  MultiplyMonotone : forall na na' ma ma', (forall n, a.(Represents) n na -> a.(Represents) n na')
                                           -> (forall n, a.(Represents) n ma -> a.(Represents) n ma')
                                           -> (forall n, a.(Represents) n (a.(Multiply) na ma)
                                                         -> a.(Represents) n (a.(Multiply) na' ma'));

  JoinSoundLeft : forall x y n, a.(Represents) n x
                                -> a.(Represents) n (a.(Join) x y);
  JoinSoundRight : forall x y n, a.(Represents) n y
                                 -> a.(Represents) n (a.(Join) x y)
}.

(* Let's ask [eauto] to try all of the above soundness rules automatically. *)
Hint Resolve TopSound ConstSound AddSound SubtractSound MultiplySound
     AddMonotone SubtractMonotone MultiplyMonotone
     JoinSoundLeft JoinSoundRight.

(** * Example: even-odd analysis *)

(* CHALLENGE #2: Extend this even-odd section to work with the new definition.
 * That is, both fill in the new record fields and prove that the extended
 * record is a sound abstract interpretation, starting from the proofs already
 * in place for the old version. *)

Inductive parity := Even | Odd | Either.

Definition isEven (n : nat) := exists k, n = k * 2.
Definition isOdd (n : nat) := exists k, n = k * 2 + 1.

(* BEGIN SPAN OF BORING THEOREMS ABOUT PARITY, WHICH WE WON'T EXPLAIN. *)

Theorem decide_parity : forall n, isEven n \/ isOdd n.
Proof.
  induct n; simplify; propositional.

  left; exists 0; linear_arithmetic.

  invert H.
  right.
  exists x; linear_arithmetic.

  invert H.
  left.
  exists (x + 1); linear_arithmetic.
Qed.

Theorem notEven_odd : forall n, ~isEven n -> isOdd n.
Proof.
  simplify.
  assert (isEven n \/ isOdd n).
  apply decide_parity.
  propositional.
Qed.

Theorem odd_notEven : forall n, isOdd n -> ~isEven n.
Proof.
  propositional.
  invert H.
  invert H0.
  linear_arithmetic.
Qed.

Theorem isEven_0 : isEven 0.
Proof.
  exists 0; linear_arithmetic.
Qed.

Theorem isEven_1 : ~isEven 1.
Proof.
  propositional; invert H; linear_arithmetic.
Qed.

Theorem isEven_S_Even : forall n, isEven n -> ~isEven (S n).
Proof.
  propositional; invert H; invert H0; linear_arithmetic.
Qed.

Theorem isEven_S_Odd : forall n, ~isEven n -> isEven (S n).
Proof.
  propositional.
  apply notEven_odd in H.
  invert H.
  exists (x + 1); linear_arithmetic.
Qed.

Hint Resolve isEven_0 isEven_1 isEven_S_Even isEven_S_Odd.

(* END SPAN OF BORING THEOREMS ABOUT PARITY. *)

(* Next, we are ready to implement the operators of the abstract
 * interpretation. *)

Definition parity_flip (p : parity) :=
  match p with
  | Even => Odd
  | Odd => Even
  | Either => Either
  end.

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

Definition parity_add (x y : parity) :=
  match x, y with
  | Even, Even => Even
  | Odd, Odd => Even
  | Even, Odd => Odd
  | Odd, Even => Odd
  | _, _ => Either
  end.

Definition parity_subtract (x y : parity) :=
  match x, y with
  | Even, Even => Even
  | _, _ => Either
  end.
(* Note subtleties with [Either]s above, to deal with underflow at zero! *)

Definition parity_multiply (x y : parity) :=
  match x, y with
  | Even, _ => Even
  | Odd, Odd => Odd
  | _, Even => Even
  | _, _ => Either
  end.

Definition parity_join (x y : parity) :=
  match x, y with
  | Even, Even => Even
  | Odd, Odd => Odd
  | _, _ => Either
  end.

(* What does it mean for a parity to classify a number correctly? *)
Inductive parity_rep : nat -> parity -> Prop :=
| PrEven : forall n,
  isEven n
  -> parity_rep n Even
| PrOdd : forall n,
  ~isEven n
  -> parity_rep n Odd
| PrEither : forall n,
  parity_rep n Either.

Hint Constructors parity_rep.

(* Putting it all together: *)
Definition parity_absint := {|
  Top := Either;
  Constant := parity_const;
  Add := parity_add;
  Subtract := parity_subtract;
  Multiply := parity_multiply;
  Join := parity_join;
  Represents := parity_rep
|}.

(* Now we prove soundness. *)

Lemma parity_const_sound : forall n,
  parity_rep n (parity_const n).
Proof.
  induct n; simplify; eauto.
  cases (parity_const n); simplify; eauto.
  invert IHn; eauto.
  invert IHn; eauto.
Qed.

Hint Resolve parity_const_sound.

Lemma even_not_odd :
  (forall n, parity_rep n Even -> parity_rep n Odd)
  -> False.
Proof.
  simplify.
  specialize (H 0).
  assert (parity_rep 0 Even) by eauto.
  apply H in H0.
  invert H0.
  apply H1.
  auto.
Qed.

Lemma odd_not_even :
  (forall n, parity_rep n Odd -> parity_rep n Even)
  -> False.
Proof.
  simplify.
  specialize (H 1).
  assert (parity_rep 1 Odd) by eauto.
  apply H in H0.
  invert H0.
  invert H1.
  linear_arithmetic.
Qed.

Hint Resolve even_not_odd odd_not_even.

Lemma parity_join_complete : forall n x y,
  parity_rep n (parity_join x y)
  -> parity_rep n x \/ parity_rep n y.
Proof.
  simplify; cases x; cases y; simplify; propositional.
  assert (isEven n \/ isOdd n) by apply decide_parity.
  propositional; eauto using odd_notEven.
  assert (isEven n \/ isOdd n) by apply decide_parity.
  propositional; eauto using odd_notEven.
Qed.

Hint Resolve parity_join_complete.

(* The final proof uses some automation that we won't explain, to descend down
 * to the hearts of the interesting cases. *)

Theorem parity_sound : absint_sound parity_absint.
Proof.
  constructor; simplify; eauto;
  repeat match goal with
         | [ H : parity_rep _ _ |- _ ] => invert H
         | [ H : ~isEven _ |- _ ] => apply notEven_odd in H; invert H
         | [ H : isEven _ |- _ ] => invert H
         | [ p : parity |- _ ] => cases p; simplify; try equality
         end; try solve [ exfalso; eauto ]; try (constructor; try apply odd_notEven).

  (* We finish up by instantiating all those existential quantifiers in uses of
   * [isEven] and [isOdd]. *)
  exists (x0 + x); ring.
  exists (x0 + x); ring.
  exists (x0 + x); ring.
  exists (x0 + x + 1); ring.
  exists (x - x0); linear_arithmetic.
  exists (x * x0 * 2); ring.
  exists ((x * 2 + 1) * x0); ring.
  exists (n * x); ring.
  exists ((x * 2 + 1) * x0); ring.
  exists (2 * x * x0 + x + x0); ring.
  exists (x * m); ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x; ring.
  exists x0; ring.
  exists x0; ring.
Qed.

(** * Interpreting expressions *)

(* Now we're back to the general framework.  Here's an unchanged expression
 * abstract interpreter and its proof.  Feel free to skip ahead to
 * "HERE NEXT." *)

Definition astate (a : absint) := fmap var a.

Fixpoint absint_interp (e : arith) a (s : astate a) : a :=
  match e with
  | Const n => a.(Constant) n
  | Var x => match s $? x with
             | None => a.(Top)
             | Some xa => xa
             end
  | Plus e1 e2 => a.(Add) (absint_interp e1 s) (absint_interp e2 s)
  | Minus e1 e2 => a.(Subtract) (absint_interp e1 s) (absint_interp e2 s)
  | Times e1 e2 => a.(Multiply) (absint_interp e1 s) (absint_interp e2 s)
  end.

Definition merge_astate a : astate a -> astate a -> astate a :=
  merge (fun x y =>
           match x with
           | None => None
           | Some x' =>
             match y with
             | None => None
             | Some y' => Some (a.(Join) x' y')
             end
           end).

Definition subsumed a (s1 s2 : astate a) :=
  forall x, match s1 $? x with
            | None => s2 $? x = None
            | Some xa1 =>
              forall xa2, s2 $? x = Some xa2
                          -> forall n, a.(Represents) n xa1
                                       -> a.(Represents) n xa2
            end.

Theorem subsumed_refl : forall a (s : astate a),
  subsumed s s.
Proof.
  unfold subsumed; simplify.
  cases (s $? x); equality.
Qed.

Hint Resolve subsumed_refl.

Lemma subsumed_use : forall a (s s' : astate a) x n t0 t,
  s $? x = Some t0
  -> subsumed s s'
  -> s' $? x = Some t
  -> Represents a n t0
  -> Represents a n t.
Proof.
  unfold subsumed; simplify.
  specialize (H0 x).
  rewrite H in H0.
  eauto.
Qed.

Lemma subsumed_use_empty : forall a (s s' : astate a) x n t0 t,
  s $? x = None
  -> subsumed s s'
  -> s' $? x = Some t
  -> Represents a n t0
  -> Represents a n t.
Proof.
  unfold subsumed; simplify.
  specialize (H0 x).
  rewrite H in H0.
  equality.
Qed.

Hint Resolve subsumed_use subsumed_use_empty.

Lemma subsumed_trans : forall a (s1 s2 s3 : astate a),
  subsumed s1 s2
  -> subsumed s2 s3
  -> subsumed s1 s3.
Proof.
  unfold subsumed; simplify.
  specialize (H x); specialize (H0 x).
  cases (s1 $? x); simplify.
  cases (s2 $? x); eauto.
  cases (s2 $? x); eauto.
  equality.
Qed.

Lemma subsumed_merge_left : forall a, absint_sound a
  -> forall s1 s2 : astate a,
    subsumed s1 (merge_astate s1 s2).
Proof.
  unfold subsumed, merge_astate; simplify.
  cases (s1 $? x); trivial.
  cases (s2 $? x); simplify; try equality.
  invert H0; eauto.
Qed.

Hint Resolve subsumed_merge_left.

Lemma subsumed_add : forall a, absint_sound a
  -> forall (s1 s2 : astate a) x v1 v2,
  subsumed s1 s2
  -> (forall n, a.(Represents) n v1 -> a.(Represents) n v2)
  -> subsumed (s1 $+ (x, v1)) (s2 $+ (x, v2)).
Proof.
  unfold subsumed; simplify.
  cases (x ==v x0); subst; simplify; eauto.
  invert H2; eauto.
  specialize (H0 x0); eauto.
Qed.

Hint Resolve subsumed_add.

Definition compatible a (s : astate a) (v : valuation) : Prop :=
  forall x xa, s $? x = Some xa
               -> exists n, v $? x = Some n
                            /\ a.(Represents) n xa.

Lemma compatible_add : forall a (s : astate a) v x na n,
  compatible s v
  -> a.(Represents) n na
  -> compatible (s $+ (x, na)) (v $+ (x, n)).
Proof.
  unfold compatible; simplify.
  cases (x ==v x0); simplify; eauto.
  invert H1; eauto.
Qed.

Hint Resolve compatible_add.

Theorem absint_interp_ok : forall a, absint_sound a
  -> forall (s : astate a) v e,
    compatible s v
    -> a.(Represents) (interp e v) (absint_interp e s).
Proof.
  induct e; simplify; eauto.
  cases (s $? x); auto.
  unfold compatible in H0.
  apply H0 in Heq.
  invert Heq.
  propositional.
  rewrite H2.
  assumption.
Qed.

Hint Resolve absint_interp_ok.

(** * Flow-sensitive analysis *)

Definition astates (a : absint) := fmap cmd (astate a).

(* HERE NEXT!  CHALLENGE #2: Extend the old command stepper to model
 * conditionals more precisely. *)

Fixpoint absint_step a (s : astate a) (c : cmd) (wrap : cmd -> cmd) : option (astates a) :=
  match c with
  | Skip => None
  | Assign x e => Some ($0 $+ (wrap Skip, s $+ (x, absint_interp e s)))
  | Sequence c1 c2 =>
    match absint_step s c1 (fun c => wrap (Sequence c c2)) with
    | None => Some ($0 $+ (wrap c2, s))
    | v => v
    end
  | If _ then_ else_ => Some ($0 $+ (wrap then_, s) $+ (wrap else_, s))
  | While e body => Some ($0 $+ (wrap Skip, s) $+ (wrap (Sequence body (While e body)), s))
  end.

(* CHALLENGE #3: Update all of the theorems and lemmas below to work in the new
 * world.  Only their proofs, not their statements, will need changes; and only
 * a few of them need updating at all.  We suggest optimistically powering
 * through with the existing proofs, getting Coq to tell you when changes are
 * needed.
 * One tactic hint: you will face many goals of the form [subsumeds s s'], for
 * more specific values of [s] and [s'].  When the structures of the two sides
 * match up well, repeated application of [subsumeds_add] and [subsumeds_empty]
 * finishes the proof, and [eauto] will even do all that for you.  Sometimes the
 * structures of the two sides don't match up well, but you can rewrite the goal
 * so that the match is obvious.  For instance, if you're starting at this goal:
 *   [subsumeds ($0 $+ (a, n)) ($0 $+ (a, n) $+ (b, m))]
 * It will be helpful to run:
 *   [replace ($0 $+ (a, n) $+ (b, m)) with ($0 $+ (b, m) $+ (a, n)) by maps_equal.]
 * Afterward, [eauto] can finish the subgoal! *)

Lemma command_equal : forall c1 c2 : cmd, sumbool (c1 = c2) (c1 <> c2).
Proof.
  repeat decide equality.
Qed.

Theorem absint_step_ok : forall a, absint_sound a
  -> forall (s : astate a) v, compatible s v
  -> forall c v' c', step (v, c) (v', c')
                     -> forall wrap, exists ss s', absint_step s c wrap = Some ss
                                                   /\ ss $? wrap c' = Some s'
                                                   /\ compatible s' v'.
Proof.
  induct 2; simplify.

  do 2 eexists; propositional.
  simplify; equality.
  eauto.

  eapply IHstep in H0; auto.
  invert H0.
  invert H2.
  propositional.
  rewrite H2.
  eauto.

  do 2 eexists; propositional.
  simplify; equality.
  assumption.

  do 2 eexists; propositional.
  cases (command_equal (wrap c') (wrap else_)).
  simplify; equality.
  simplify; equality.
  assumption.

  do 2 eexists; propositional.
  simplify; equality.
  assumption.

  do 2 eexists; propositional.
  simplify; equality.
  assumption.

  do 2 eexists; propositional.
  cases (command_equal (wrap Skip) (wrap (body;; while e loop body done))).
  simplify; equality.
  simplify; equality.
  assumption.
Qed.

Inductive abs_step a : astate a * cmd -> astate a * cmd -> Prop :=
| AbsStep : forall s c ss s' c',
  absint_step s c (fun x => x) = Some ss
  -> ss $? c' = Some s'
  -> abs_step (s, c) (s', c').

Hint Constructors abs_step.

Definition absint_trsys a (c : cmd) := {|
  Initial := {($0, c)};
  Step := abs_step (a := a)
|}.

Inductive Rabsint a : valuation * cmd -> astate a * cmd -> Prop :=
| RAbsint : forall v s c,
  compatible s v
  -> Rabsint (v, c) (s, c).

Hint Constructors abs_step Rabsint.

Theorem absint_simulates : forall a v c,
  absint_sound a
  -> simulates (Rabsint (a := a)) (trsys_of v c) (absint_trsys a c).
Proof.
  simplify.
  constructor; simplify.

  exists ($0, c); propositional.
  subst.
  constructor.
  unfold compatible.
  simplify.
  equality.

  invert H0.
  cases st1'.
  eapply absint_step_ok in H1; eauto.
  invert H1.
  invert H0.
  propositional.
  eauto.
Qed.

Definition merge_astates a : astates a -> astates a -> astates a :=
  merge (fun x y =>
           match x with
           | None => y
           | Some x' =>
             match y with
             | None => Some x'
             | Some y' => Some (merge_astate x' y')
             end
           end).

Inductive oneStepClosure a : astates a -> astates a -> Prop :=
| OscNil :
  oneStepClosure $0 $0
| OscCons : forall ss c s ss' ss'',
  oneStepClosure ss ss'
  -> match absint_step s c (fun x => x) with
     | None => ss'
     | Some ss'' => merge_astates ss'' ss'
     end = ss''
  -> oneStepClosure (ss $+ (c, s)) ss''.

Definition subsumeds a (ss1 ss2 : astates a) :=
  forall c s1, ss1 $? c = Some s1
               -> exists s2, ss2 $? c = Some s2
                             /\ subsumed s1 s2.

Theorem subsumeds_refl : forall a (ss : astates a),
  subsumeds ss ss.
Proof.
  unfold subsumeds; simplify; eauto.
Qed.

Hint Resolve subsumeds_refl.

Lemma subsumeds_add : forall a (ss1 ss2 : astates a) c s1 s2,
  subsumeds ss1 ss2
  -> subsumed s1 s2
  -> subsumeds (ss1 $+ (c, s1)) (ss2 $+ (c, s2)).
Proof.
  unfold subsumeds; simplify.
  cases (command_equal c c0); subst; simplify; eauto.
  invert H1; eauto.
Qed.

Hint Resolve subsumeds_add.

Lemma subsumeds_empty : forall a (ss : astates a),
  subsumeds $0 ss.
Proof.
  unfold subsumeds; simplify.
  equality.
Qed.

Lemma subsumeds_add_left : forall a (ss1 ss2 : astates a) c s,
  ss2 $? c = Some s
  -> subsumeds ss1 ss2
  -> subsumeds (ss1 $+ (c, s)) ss2.
Proof.
  unfold subsumeds; simplify.
  cases (command_equal c c0); subst; simplify; eauto.
  invert H1; eauto.
Qed.

Inductive interpret a : astates a -> astates a -> astates a -> Prop :=
| InterpretDone : forall ss1 any ss2,
  oneStepClosure ss1 ss2
  -> subsumeds ss2 ss1
  -> interpret ss1 any ss1
| InterpretStep : forall ss worklist ss' ss'',
  oneStepClosure worklist ss'
  -> interpret (merge_astates ss ss') ss' ss''
  -> interpret ss worklist ss''.

Lemma oneStepClosure_sound : forall a, absint_sound a
  -> forall ss ss' : astates a, oneStepClosure ss ss'
  -> forall c s s' c', ss $? c = Some s
                       -> abs_step (s, c) (s', c')
                          -> exists s'', ss' $? c' = Some s''
                                         /\ subsumed s' s''.
Proof.
  induct 2; simplify.

  equality.

  cases (command_equal c c0); subst; simplify.

  invert H2.
  invert H3.
  rewrite H5.
  unfold merge_astates; simplify.
  rewrite H7.
  cases (ss' $? c').
  eexists; propositional.
  unfold subsumed; simplify.
  unfold merge_astate; simplify.
  cases (s' $? x); try equality.
  cases (a0 $? x); simplify; try equality.
  invert H1; eauto.
  eauto.

  apply IHoneStepClosure in H3; auto.
  invert H3; propositional.
  cases (absint_step s c (fun x => x)); eauto.
  unfold merge_astates; simplify.
  rewrite H3.
  cases (a0 $? c'); eauto.
  eexists; propositional.
  unfold subsumed; simplify.
  unfold merge_astate; simplify.
  specialize (H4 x0).
  cases (s' $? x0).
  cases (a1 $? x0); try equality.
  cases (x $? x0); try equality.
  invert 1.
  eauto.

  rewrite H4.
  cases (a1 $? x0); equality.
Qed.

Lemma absint_step_monotone_None : forall a (s : astate a) c wrap,
    absint_step s c wrap = None
    -> forall s' : astate a, absint_step s' c wrap = None.
Proof.
  induct c; simplify; try equality.
  cases (absint_step s c1 (fun c => wrap (c;; c2))); equality.
Qed.

Lemma absint_interp_monotone : forall a, absint_sound a
  -> forall (s : astate a) e s' n,
    a.(Represents) n (absint_interp e s)
    -> subsumed s s'
    -> a.(Represents) n (absint_interp e s').
Proof.
  induct e; simplify; eauto.

  cases (s' $? x); eauto.
  cases (s $? x); eauto.
Qed.

Hint Resolve absint_interp_monotone.

Hint Resolve subsumeds_empty.

Lemma absint_step_monotone : forall a, absint_sound a
    -> forall (s : astate a) c wrap ss,
      absint_step s c wrap = Some ss
      -> forall s', subsumed s s'
                    -> exists ss', absint_step s' c wrap = Some ss'
                                   /\ subsumeds ss ss'.
Proof.
  induct c; simplify.

  equality.

  invert H0.
  eexists; propositional.
  eauto.
  apply subsumeds_add; eauto.

  cases (absint_step s c1 (fun c => wrap (c;; c2))).

  invert H0.
  eapply IHc1 in Heq; eauto.
  invert Heq; propositional.
  rewrite H2; eauto.

  invert H0.
  eapply absint_step_monotone_None in Heq; eauto.
  rewrite Heq; eauto.

  invert H0; eauto.

  invert H0; eauto.
Qed.

Lemma abs_step_monotone : forall a, absint_sound a
  -> forall (s : astate a) c s' c',
    abs_step (s, c) (s', c')
    -> forall s1, subsumed s s1
                  -> exists s1', abs_step (s1, c) (s1', c')
                                 /\ subsumed s' s1'.
Proof.
  invert 2; simplify.
  eapply absint_step_monotone in H4; eauto.
  invert H4; propositional.
  apply H3 in H6.
  invert H6; propositional; eauto.
Qed.

Lemma interpret_sound' : forall c a, absint_sound a
  -> forall ss worklist ss' : astates a, interpret ss worklist ss'
    -> ss $? c = Some $0
    -> invariantFor (absint_trsys a c) (fun p => exists s, ss' $? snd p = Some s
                                                           /\ subsumed (fst p) s).
Proof.
  induct 2; simplify; subst.

  apply invariant_induction; simplify; propositional; subst; simplify; eauto.

  invert H3; propositional.
  cases s.
  cases s'.
  simplify.
  eapply abs_step_monotone in H4; eauto.
  invert H4; propositional.
  eapply oneStepClosure_sound in H4; eauto.
  invert H4; propositional.
  eapply H1 in H4.
  invert H4; propositional.
  eauto using subsumed_trans.

  apply IHinterpret.
  unfold merge_astates; simplify.
  rewrite H2.
  cases (ss' $? c); trivial.
  unfold merge_astate; simplify; equality.
Qed.

Theorem interpret_sound : forall c a (ss : astates a),
  absint_sound a
  -> interpret ($0 $+ (c, $0)) ($0 $+ (c, $0)) ss
  -> invariantFor (absint_trsys a c) (fun p => exists s, ss $? snd p = Some s
                                                         /\ subsumed (fst p) s).
Proof.
  simplify.
  eapply interpret_sound'; eauto.
  simplify; equality.
Qed.

Ltac interpret_simpl := unfold merge_astates, merge_astate;
                       simplify; repeat simplify_map.
Ltac oneStepClosure := apply OscNil
                       || (eapply OscCons; [ oneStepClosure
                                           | interpret_simpl; reflexivity ]).
Ltac interpret1 := eapply InterpretStep; [ oneStepClosure | interpret_simpl ].
Ltac interpret_done := eapply InterpretDone; [ oneStepClosure
  | repeat (apply subsumeds_add_left || apply subsumeds_empty); (simplify; equality) ].

(** * Now, let's see a conditional-aware analysis in action! *)

(* CHALLENGE #4: Prove that this particular program only finishes in states
 * where ["b"] is even.  The old analysis wouldn't realize that one branch of
 * the final conditional is impossible. *)
Example loopomatic :=
  ("a" <- 1;;
   while "n" loop
     "a" <- "a" + 2 * "n";;
     "n" <- "n" - 1
   done;;
   when "a" then
     "b" <- 0
   else
     "b" <- 1
   done).

(* OK, so the main challenge here is waiting for Coq to finishing processing
 * proof scripts, since we've given you all the code. ;) *)

(* Now two lemmas that we prove to help the [simplify] tactic reduce uses of
 * [merge_astates]. *)

Lemma merge_astates_fok_parity : forall x : option (astate parity_absint),
  match x with Some x' => Some x' | None => None end = x.
Proof.
  simplify; cases x; equality.
Qed.

Lemma merge_astates_fok2_parity : forall x (y : option (astate parity_absint)),
    match y with
    | Some y' => Some (merge_astate x y')
    | None => Some x
    end = None -> False.
Proof.
  simplify; cases y; equality.
Qed.

Hint Resolve merge_astates_fok_parity merge_astates_fok2_parity.

(* Here's a utility theorem we used in lecture, too. *)
Lemma final_even : forall (s s' : astate parity_absint) v x,
  compatible s v
  -> subsumed s s'
  -> s' $? x = Some Even
  -> exists n, v $? x = Some n /\ isEven n.
Proof.
  unfold compatible, subsumed; simplify.
  specialize (H x); specialize (H0 x).
  cases (s $? x); simplify.

  rewrite Heq in *.
  assert (Some d = Some d) by equality.
  apply H in H2.
  first_order.

  eapply H0 in H1.
  invert H1.
  eauto.
  assumption.

  rewrite Heq in *.
  equality.
Qed.

Theorem loopomatic_even : forall v,
  invariantFor (trsys_of v loopomatic)
               (fun p => snd p = Skip
                         -> exists n, fst p $? "b" = Some n /\ isEven n).
Proof.
  simplify.
  eapply invariant_weaken.

  unfold loopomatic.
  eapply invariant_simulates.
  apply absint_simulates with (a := parity_absint).
  apply parity_sound.

  apply interpret_sound.
  apply parity_sound.

  (* The rest of this depends on your new interpreter being plugged in.
   * The exact number of iterations required below might vary, based on the
   * exact changes you make to the original framework. *)
(*
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret1.
  interpret_done.

  invert 1.
  first_order.
  invert H0; simplify.
  invert H1.
  eapply final_even; eauto; simplify; try equality.
Qed.
*)
Admitted.


(* Exercise 110 *)

Require Import BenB.

Variables A B C D : Prop.

(* de Morgan's disjunction law inverse *)

Theorem exercise_110 : (~A /\ ~B) -> ~(A \/ B).
Proof.
imp_i a1.
neg_i (1=1) a2.
dis_e (A \/ B) a3 a3.
hyp a2.
neg_e (A).
con_e1 (~B).
hyp a1.
hyp a3.
neg_e B.
con_e2 (~A).
hyp a1.
hyp a3.
lin_solve.
Qed.