(* BEGIN FIX *)
Require Import Coq.Strings.String.

Inductive aexp : Type :=
  | ANum (n : nat)
  | AVar (x : string)
  | APlus (a a' : aexp)
  | AMult (a a' : aexp).

Definition state : Type := string -> nat.

Fixpoint aeval (e : aexp)(s : state) : nat := match e with
  | ANum n => n
  | AVar x => s x
  | APlus a a' => aeval a s + aeval a' s
  | AMult a a' => aeval a s * aeval a' s
  end.

Inductive zart : aexp -> Prop :=
  | szam (n : nat) : zart (ANum n)
  | osszeg (a a' : aexp)(az : zart a)
           (a'z : zart a') : zart (APlus a a')
  | szorzat (a a' : aexp)(az : zart a)
            (a'z : zart a') : zart (AMult a a').

Example pl1 : zart (APlus (ANum 3) (ANum 4)).
(* END FIX *)
apply osszeg; apply szam. Qed.

(* BEGIN FIX *)
Example pl3 : zart (APlus (ANum 3)
                          (AMult (ANum 1) (ANum 2))).
(* END FIX *)
apply osszeg. apply szam. apply szorzat; apply szam. Qed.

(* BEGIN FIX *)
Theorem zartEval (e : aexp)(s s' : state)(p : zart e) :
  aeval e s = aeval e s'.
(* p-n vegezz indukciot! *)
(* END FIX *)
induction p. simpl. reflexivity. simpl. rewrite -> IHp1. rewrite -> IHp2. reflexivity.
simpl. rewrite -> IHp1. rewrite -> IHp2. reflexivity. Qed.

(* BEGIN FIX *)
(* ez a fuggveny az osszes valtozot 0-ra csereli *)
Fixpoint lezar (e : aexp) : aexp :=
(* END FIX *)
  match e with
  | ANum n => ANum n
  | AVar x => ANum 0
  | APlus a a' => APlus (lezar a) (lezar a')
  | AMult a a' => AMult(lezar a) (lezar a')
end.

(* BEGIN FIX *)
Lemma lezarZart (e : aexp) : zart (lezar e).
(* END FIX *)
induction e; simpl. apply szam. apply szam. apply osszeg. apply IHe1. apply IHe2. apply szorzat.
apply IHe1. apply IHe2. Qed.

(* BEGIN FIX *)
Lemma ugyanaz (e : aexp)(p : zart e) : lezar e = e.
(* END FIX *)
induction p. simpl. reflexivity. simpl. rewrite -> IHp1. rewrite -> IHp2. reflexivity.
simpl. rewrite -> IHp1. rewrite -> IHp2. reflexivity. Qed.

(* BEGIN FIX *)
Lemma szemantikaUgyanaz (e : aexp)(s : state) :
  aeval (lezar e) s = aeval e (fun _ => 0).
(* END FIX *)
induction e; simpl; try (reflexivity); rewrite -> IHe1; rewrite IHe2; reflexivity. Qed.


From VLSM.Lib Require Import Itauto.
From stdpp Require Import prelude.
From VLSM.Lib Require Import Preamble.

(** * Finite set utility definitions and lemmas *)

Section sec_fin_set.

Context
  `{FinSet A C}.

Section sec_general.

Lemma elements_subseteq (X Y : C) :
  X ⊆ Y -> elements X ⊆ elements Y.
Proof. by set_solver. Qed.

Lemma union_size_ge_size1
  (X Y : C) :
  size (X ∪ Y) >= size X.
Proof.
  apply subseteq_size.
  apply subseteq_union.
  by set_solver.
Qed.

Lemma union_size_ge_size2
  (X Y : C) :
  size (X ∪ Y) >= size Y.
Proof.
  apply subseteq_size.
  apply subseteq_union.
  by set_solver.
Qed.

Lemma union_size_ge_average
  (X Y : C) :
  2 * size (X ∪ Y) >= size X + size Y.
Proof.
  specialize (union_size_ge_size1 X Y) as Hx.
  specialize (union_size_ge_size2 X Y) as Hy.
  by lia.
Qed.

Lemma difference_size_le_self
  (X Y : C) :
  size (X ∖  Y) <= size X.
Proof.
  apply subseteq_size.
  apply elem_of_subseteq.
  intros x Hx.
  apply elem_of_difference in Hx.
  by itauto.
Qed.

Lemma union_size_le_sum
  (X Y : C) :
  size (X ∪ Y) <= size X + size Y.
Proof.
  specialize (size_union_alt X Y) as Halt.
  rewrite Halt.
  specialize (difference_size_le_self Y X).
  by lia.
Qed.

Lemma intersection_size1
  (X Y : C) :
  size (X ∩ Y) <= size X.
Proof.
  apply (subseteq_size (X ∩ Y) X).
  by set_solver.
Qed.

Lemma intersection_size2
  (X Y : C) :
  size (X ∩ Y) <= size Y.
Proof.
  apply (subseteq_size (X ∩ Y) Y).
  by set_solver.
Qed.

Lemma difference_size_subset
  (X Y : C)
  (Hsub : Y ⊆ X) :
  (Z.of_nat (size (X ∖ Y)) = Z.of_nat (size X) - Z.of_nat (size Y))%Z.
Proof.
  assert (Htemp : Y ∪ (X ∖ Y) ≡ X).
  {
    apply set_equiv_equivalence.
    intros a.
    split; intros Ha.
    - by set_solver.
    - destruct (@decide (a ∈ Y)).
      apply elem_of_dec_slow.
      + by apply elem_of_union; left; itauto.
      + by apply elem_of_union; right; set_solver.
  }
  assert (Htemp2 : size Y + size (X ∖ Y) = size X).
  {
    specialize (size_union Y (X ∖ Y)) as Hun.
    spec Hun.
    {
      apply elem_of_disjoint.
      intros a Ha Ha2.
      apply elem_of_difference in Ha2.
      by itauto.
    }
    rewrite Htemp in Hun.
    by itauto.
  }
  by lia.
Qed.

Lemma difference_with_intersection
  (X Y : C) :
  X ∖ Y ≡ X ∖ (X ∩ Y).
Proof.
  by set_solver.
Qed.

Lemma difference_size
  (X Y : C) :
  (Z.of_nat (size (X ∖ Y)) = Z.of_nat (size X) - Z.of_nat (size (X ∩ Y)))%Z.
Proof.
  rewrite difference_with_intersection.
  specialize (difference_size_subset X (X ∩ Y)) as Hdif.
  by set_solver.
Qed.

Lemma difference_size_ge_disjoint_case
  (X Y : C) :
  size (X ∖ Y) >= size X - size Y.
Proof.
  specialize (difference_size X Y).
  specialize (intersection_size2 X Y).
  by lia.
Qed.

Lemma list_to_set_size
  (l : list A) :
  size (list_to_set l (C := C)) <= length l.
Proof.
  induction l; cbn.
  - by rewrite size_empty; lia.
  - specialize (union_size_le_sum ({[ a ]}) (list_to_set l)) as Hun_size.
    by rewrite size_singleton in Hun_size; lia.
Qed.

End sec_general.

Section sec_filter.

Context
  (P P2 : A -> Prop)
  `{!forall x, Decision (P x)}
  `{!forall x, Decision (P2 x)}
  (X Y : C).

Lemma filter_subset
  (Hsub : X ⊆ Y) :
  filter P X ⊆ filter P Y.
Proof.
  intros a HaX.
  apply elem_of_filter in HaX.
  apply elem_of_filter.
  by set_solver.
Qed.

Lemma filter_subprop
  (Hsub : forall a, (P a -> P2 a)) :
  filter P X ⊆ filter P2 X.
Proof.
  intros a HaP.
  apply elem_of_filter in HaP.
  apply elem_of_filter.
  by itauto.
Qed.

End sec_filter.

End sec_fin_set.

Section sec_map.

Context
  `{FinSet A C}
  `{FinSet B D}.

Lemma set_map_subset
  (f : A -> B)
  (X Y : C)
  (Hsub : X ⊆ Y) :
  set_map (D := D) f X ⊆ set_map (D := D) f Y.
Proof.
  intros a Ha.
  apply elem_of_map in Ha.
  apply elem_of_map.
  by firstorder.
Qed.

Lemma set_map_size_upper_bound
  (f : A -> B)
  (X : C) :
  size (set_map (D := D) f X) <= size X.
Proof.
  unfold set_map.
  remember (f <$> elements X) as fX.
  set (x := size (list_to_set _)).
  cut (x <= length fX); [| by apply list_to_set_size].
  enough (length fX = size X) by lia.
  unfold size, set_size.
  simpl; subst fX.
  by apply fmap_length.
Qed.

Lemma elem_of_set_map_inj (f : A -> B) `{!Inj (=) (=) f} (a : A) (X : C) :
  f a ∈@{D} fin_sets.set_map f X <-> a ∈ X.
Proof.
  intros; rewrite elem_of_map.
  split; [| by eexists].
  intros (_v & HeqAv & H_v).
  eapply inj in HeqAv; [| done].
  by subst.
Qed.

Lemma set_map_id (X : C) : X ≡ set_map id X.
Proof. by set_solver. Qed.

End sec_map.


(***
 * Oqarina
 * Copyright 2021 Carnegie Mellon University.
 *
 * NO WARRANTY. THIS CARNEGIE MELLON UNIVERSITY AND SOFTWARE ENGINEERING
 * INSTITUTE MATERIAL IS FURNISHED ON AN "AS-IS" BASIS. CARNEGIE MELLON
 * UNIVERSITY MAKES NO WARRANTIES OF ANY KIND, EITHER EXPRESSED OR
 * IMPLIED, AS TO ANY MATTER INCLUDING, BUT NOT LIMITED TO, WARRANTY OF
 * FITNESS FOR PURPOSE OR MERCHANTABILITY, EXCLUSIVITY, OR RESULTS
 * OBTAINED FROM USE OF THE MATERIAL. CARNEGIE MELLON UNIVERSITY DOES NOT
 * MAKE ANY WARRANTY OF ANY KIND WITH RESPECT TO FREEDOM FROM PATENT,
 * TRADEMARK, OR COPYRIGHT INFRINGEMENT.
 *
 * Released under a BSD (SEI)-style license, please see license.txt or
 * contact permission@sei.cmu.edu for full terms.
 *
 * [DISTRIBUTION STATEMENT A] This material has been approved for public
 * release and unlimited distribution.  Please see Copyright notice for
 * non-US Government use and distribution.
 *
 * This Software includes and/or makes use of the following Third-Party
 * Software subject to its own license:
 *
 * 1. Coq theorem prover (https://github.com/coq/coq/blob/master/LICENSE)
 * Copyright 2021 INRIA.
 *
 * 2. Coq JSON (https://github.com/liyishuai/coq-json/blob/comrade/LICENSE)
 * Copyright 2021 Yishuai Li.
 *
 * DM21-0762
***)

(*| .. coq:: none |*)
Require Import PeanoNat.
Require Import Lia.
(*| .. coq:: |*)

(*|
Strong Induction Principle
==========================

Coq generates general induction principles. In some cases, we need a strong induction princple that is introduced in this section.

|*)

(*| .. coq:: none |*)
Section StrongInduction.
(*| .. coq:: |*)

(*|
.. index:: strong induction, CoqExt; strong induction (tactic)

Let's assume we have a proposition indexed by a natural number and the stronger inductive hypothesis :coq:`IH`. |*)

Variable P : nat -> Prop.
Hypothesis IH : forall m, (forall n, n < m -> P n) -> P m.

(*| A direct result is that :coq:`P (0)` always holds. |*)

Lemma P0 : P 0.
Proof.
    apply IH; intros.
    inversion H.
Qed.

(*| We prove a strong hypothesis first, then the final result. |*)

Lemma strong_induction_leq : forall n,
    (forall m, m <= n -> P m).
Proof.
    induction n ; intros.
    - inversion H. apply P0.
    - inversion H.
        + apply IH. intros. apply le_S_n in H1. apply IHn. apply H1.
        + apply IHn. apply H1.
Qed.

Theorem strong_induction : forall n, P n.
Proof.
    intros.
    induction n.
    - apply P0.
    - apply IH. intros.
      apply le_S_n in H.
      eapply strong_induction_leq.
      apply H.
  Qed.

(*| .. coq:: none |*)
End StrongInduction.
(*| .. coq:: |*)

(*| Here is the new strong induction principle we obtain: |*)

Check strong_induction.
(* strong_induction
	 : forall P : nat -> Prop,
       (forall m : nat, (forall n : nat, n < m -> P n) -> P m) ->
       forall n : nat, P n *)

(*| We provide the tactic :coq:`strong induction` to use this new principle in our proofs. |*)

Tactic Notation "strong" "induction" ident(n) :=
    induction n using strong_induction.


Require Import String.
Require Import DProp.Tactics.
Require Import List.
Import List.ListNotations.

(** * Syntax *)
Inductive sentence : Set :=
| p_top : sentence
| p_var : nat -> sentence
| p_conj : sentence -> sentence -> sentence
| p_neg : sentence -> sentence.

(** We ask Coq to infer that equality of sentences is decidable *)
Scheme Equality for sentence.
Check sentence_eq_dec. (* : : forall x y : sentence, {x = y} + {x <> y} *)

(** We'll give names to a few of the variables for convenience... *)
(* Notation "[ n ]" := (p_var n). *)
Notation "'P'" := (p_var 0).
Notation "'Q'" := (p_var 1).
Notation "'R'" := (p_var 2).

(** ... and set up some pleasant notations. Notice some of these
    notations define new connectives, like disjunction, in terms of
    simpler ones.

    These notations use Unicode. Proof General and CoqIDE both support
    quick Unicode entry by typing TeX-like strings, see

   - #Coqide information (See "Using Unicode symbols")# *)
(**
   - #Company Coq#

*)
Notation "⊤" := (p_top). (* \top *)
Notation "x ∧ y" := (p_conj x y) (at level 50). (* \land or \wedge *)
Notation "¬ x" := (p_neg x) (at level 10). (* \neg *)
Notation "⊥" := (¬ ⊤). (* \bot *)
Notation "x ∨ y" := (¬ (¬ x ∧ ¬ y)) (at level 50). (* \lor or \vee *)
Notation "x ⇒ y" := (¬ x ∨ y) (at level 70). (* \Rightarrow *)

(** Next we define the semantics of our language. We want to translate
    sentences into Coq-level propositions, i.e. elements of type
    [Prop]. You might expect to use [bool] here instead. Both choices
    "work," but using [Prop] is more general and more natural for the
    metatheory we build here today, and ultimately it better captures
    the idea that a semantics maps object-level propositions into
    host-level propositions. Further information about this topic is
    provided below.  *)

(** A valuation might also be called an _interpretation_ or a _model_,
    especially in the context of higher-order logics.

    Notice that we require a valuation to come with a proof that the
    propositional symbols of our language are mapped to propositions
    for which the excluded middle is provable (or taken as an
    axiom). This is necessary for our logic to be sound, which is
    discussed in the section on proof theory.

*)
Class valuation : Type :=
  { val : nat -> Prop
  ; excluded_middle : forall n, val n \/ ~ (val n)
  }.

(** This coercion tells Coq that we can use a [valuation] as a
    function [nat -> Prop] by using its [val] field, for convenience. *)
Coercion val : valuation >-> Funclass.

(** * Model theory *)

(** We define a recursive function, [denotation], which translates
    sentences to "actual" propositions, meaning types whose sort is [Prop].

    Another good name for this function could be "is_true" or "translation."
    Notice that any valuation [v] defines a subset [denotation v] of sentences,
    namely the "true" ones.
*)
Fixpoint denotation (v : valuation) (s : sentence) : Prop :=
  match s with
  | p_top => True
  | p_var x => val x
  | p_conj s1 s2 => denotation v s1 /\ denotation v s2
  | p_neg s1 => not (denotation v s1)
  end.

(** Hereafter we let [denotation] take the valuation as an implicit
    argument. This follows common mathematical practice in which one
    generally assumes some valuation is clear from the context.
*)
Arguments denotation {v} s.

Notation "⟦ ϕ ⟧" := (denotation ϕ). (* \llbracket and \rrbracket *)

(** The law of excluded middle extends to the entire language straightforwardly. *)
Lemma full_lem : forall {v : valuation}, forall ϕ, ⟦ ϕ ⟧ \/ ⟦ ¬ ϕ ⟧.
Proof.
  intros v ϕ. induction ϕ.
  - simpl. intuition.
  - exact (excluded_middle n).
  - simpl. intuition.
  - simpl. intuition.
Qed.

(** This tactic splits a (Coq-level) proof into two cases: one in
    which ϕ is true and one in which it is false. *)
Ltac lem ϕ := destruct (full_lem ϕ).

(** Sample usage of the [lem] tactic. *)
Goal forall ϕ, forall v : valuation, ⟦ ϕ ⟧ \/ ⟦ ¬ ϕ ⟧.
Proof.
  intros.
  lem ϕ.
  - left. auto.
  - right. auto.
Qed.

(** In this file, we're not very interested in individual valuations. Instead,
    we would like to define a notion of "truth" which abstracts over the valuation,
    capturing the idea that a sentence is true under every possible interpretation.
*)
Definition tautology (ϕ : sentence) := forall v : valuation, ⟦ ϕ ⟧.

(** The universal quantifier---the dependent product---can be thought
    of as a kind of infinite conjunction asserting the truth of ϕ
    under _every_ interpretation. *)

(** But we aren't just interested in tautologies. Often we want to
    restrict our attention to only those valuations which make certain
    pre-chosen sentences true. We develop this idea now.  *)

(** A set of sentences is _satisfied_ or _modeled_ by a valuation if
    all of its elements are true under that valuation. Elements of [Γ]
    may also be called "axioms." *)
Definition models (v : valuation) (Γ : list sentence) : Prop :=
  forall ϕ, List.In ϕ Γ -> ⟦ ϕ ⟧.

(** A valuation that models Γ is called a model, unsurprisingly. *)
Definition model Γ := { v : valuation | models v Γ }.

(** A set of axioms _entails_ a sentence when that sentence is true
    under all valuations that also satisfy the axioms, i.e. all
    models. This relation also known as _semantic consequence_ or
    _logical consequence_.

    We might also read this definition as a restricted variant of
    [tautology] that intersects only over that subset of valuations
    which satisfy Γ. This property is sometimes known as being /valid/
    for Γ (but this word is sometimes used differently). When we
    formalize our proof system, the most ideal outcome is that the
    provable formulas are precisely the valid ones. *)
Definition entails (Γ : list sentence) (ϕ : sentence) :=
  forall v, models v Γ -> ⟦ ϕ ⟧.

Notation "Γ ⊧ ϕ" := (entails Γ ϕ) (at level 70).

Hint Unfold tautology : dp.
Hint Unfold models : dp.
Hint Unfold entails : dp.

(** Use the following tactic to quickly get rid unfold many definitions. *)
Tactic Notation "unf" := (repeat autounfold with dp in *).

(** Exercise 1 (easy): Prove that a sentence is a tautology if and
    only if it is entailed by the empty set of axioms.

    Note: This is almost true by definition, but formalizing logics in
   Coq often means proving such "obvious" facts. *)
Theorem exercise1 : forall ϕ, tautology ϕ <-> nil ⊧ ϕ.
Proof.
Admitted.

(** Exercise 2 (easy): Prove the following tautology.

 *)
Theorem exercise2 : forall ϕ : sentence, tautology (ϕ ∨ ¬ ϕ).
Proof.
Admitted.

(** Exercise 3 (medium): Have we formalized implication correctly?
    Check our work by proving if [x ⇒ y] is true and [x] is true, then
    [y] is true.

    Hint: Use the [lem] tactic to do case analysis on [Q]. You may
    want to [Unset Printing Notations]. *)
Theorem exercise3 : forall (v : valuation), ⟦ P ⇒ Q ⟧ /\ ⟦ P ⟧ -> ⟦ Q ⟧.
Proof.
Admitted.

(** Logically equivalent formulas are those which have the same
    denotation under every interpretation. Since we are interpreting
    into [Prop], rather than [bool], we define this notion using
    biconditionality (at the Coq level) rather than equality of
    boolean values, but the idea is the same. *)
Definition equivalent ϕ ψ := forall (v : valuation), ⟦ ϕ ⟧ <-> ⟦ ψ ⟧.

  (** Exercise 4 (easy): Prove that [P] and [P ∧ ⊤] are semantically
  equivalent.  *)
Theorem exercise4 : equivalent P (P ∧ ⊤).
Proof.
Admitted.

 (** Exercise [5] (medium): Prove that [P] and [P ∨ ¬ ⊤] are
     semantically equivalent.  Use [lem P]. *)
Theorem exercise5 : equivalent P (P ∨ ¬ ⊤).
Proof.
Admitted.

 (** Exercise 6 (hard): Why did the last exercise require law of
     excluded middle, when Coq trivially proves the following
     intuitionistic tautology? Can you prove (with pen and paper, not
     in Coq) that the last exercise cannot be completed without LEM?
     *)
Goal forall p : Prop, p <-> (p \/ ~ True).
  tauto.
Qed.

(** * Proof theory

    This section explores basic proof theory. The goal is to define a
    particular syntactical notion called "proof," where each proof is
    associated with a formula called its "conclusion." Formulas with
    proofs are "theorems." Later, our primary goal will be to show
    that a formula ϕ is entailed by Γ precisely if there is a proof
    with conclusion ϕ using only axioms from Γ, i.e. the theorems are
    exactly the valid statements. (Many logics do not have this strong
    property, but propositional logic does.)  *)

(** The following proof system is a natural deduction, which is
    essentially the type system of the simply typed lambda
    calculus. However, we are not formalizing lambda terms here, only
    the type inhabitation property itself. To be precise, you might
    call this a version of natural deduction with localized
    hypotheses, but without proof objects.

    The distinguishing feature of natural deduction is that each
    logical connective is defined by introduction and elimination
    rules. Another common system is a "sequent calculus," which looks
    visually similar but is subtly different. A sequent calculus would
    better highlight the symmetries of logic and lend itself better to
    automated proof search and inversion lemmas (discussed briefly in
    the section on incompleteness). *)

Reserved Notation "Γ ⊢ ϕ" (at level 90).
Inductive provable (Γ : list sentence) : sentence -> Prop :=
| j_var : forall ϕ, List.In ϕ Γ -> Γ ⊢ ϕ
| j_conj_intro : forall ϕ ψ, Γ ⊢ ϕ -> Γ ⊢ ψ -> Γ ⊢ ϕ ∧ ψ
| j_conj_elim1 : forall ϕ ψ, Γ ⊢ ϕ ∧ ψ -> Γ ⊢ ϕ
| j_conj_elim2 : forall ϕ ψ, Γ ⊢ ϕ ∧ ψ -> Γ ⊢ ψ
| j_neg_intro : forall ϕ, ϕ :: Γ ⊢ ⊥ -> Γ ⊢ ¬ ϕ
| j_neg_elim : forall ϕ ψ, Γ ⊢ ϕ -> Γ ⊢ ¬ ϕ -> Γ ⊢ ψ
| j_raa: forall ϕ, (¬ ϕ :: Γ ⊢ ¬ ⊤) -> Γ ⊢ ϕ
| j_top_intro : Γ ⊢ ⊤
where "Γ ⊢ ϕ" := (provable Γ ϕ).

(** The next two lemmas are fundamental properties of most logics.
    Substitution shows that provable hypotheses are
    redundant. Weakening says unused hypotheses are okay and plays an
    important role in proving substitution. *)
Lemma weakening : forall Γ1 Γ2 Γ3 ϕ,
    Γ1 ++ Γ2 ⊢ ϕ ->
    Γ1 ++ Γ3 ++ Γ2 ⊢ ϕ.
Proof.
  intros ? ? ? ? Hϕ.
  remember (Γ1 ++ Γ2) as Γ.
  generalize dependent Γ1.
  induction Hϕ; intros; subst.
  - apply j_var.
    rewrite ?List.in_app_iff in *.
    intuition.
  - apply j_conj_intro; auto.
  - eapply j_conj_elim1. eauto.
  - eapply j_conj_elim2. eauto.
  - eapply j_neg_intro.
    specialize (IHHϕ (ϕ :: Γ1)). simpl in *. auto.
  - eapply j_neg_elim. eapply IHHϕ1; reflexivity. auto.
  - eapply j_raa. specialize (IHHϕ (¬ ϕ :: Γ1)).
    simpl in *. eauto.
  - apply j_top_intro.
Qed.

(** To picture substitution, imagine a natural deduction derivation D
    that uses of ψ using hypotheses from Γ1, Γ2, and ϕ. Given a
    natural deduction derivation E of ϕ, picture "moving up" the tree
    of D and finding all leaves that introduce the axiom ϕ, and
    replace them with E. Through Curry-Howard, this is essentially
    function evaluation. *)
Lemma substitution : forall Γ1 ϕ Γ2 ψ,
    Γ1 ++ (ϕ :: Γ2) ⊢ ψ ->
    Γ2 ⊢ ϕ ->
    Γ1 ++ Γ2 ⊢ ψ.
Proof.
  intros ? ? ? ? J1 J2.
  remember (List.app Γ1 (ϕ :: Γ2)).
  generalize dependent Γ1.
  induction J1; intros Γ1 Eq; subst.
  - destruct (sentence_eq_dec ϕ ϕ0).
    { (* Equal *)
      subst.
      replace (Γ1 ++ Γ2) with (nil ++ Γ1 ++ Γ2) by (rewrite app_nil_l; auto).
      apply weakening. rewrite app_nil_l. auto. }
    { (* Unequal *)
      apply j_var.
      rewrite ?List.in_app_iff in *.
      destruct H; try tauto.
      inversion H; subst. contradiction. tauto. }
  - apply j_conj_intro; auto.
  - eapply j_conj_elim1; auto.
  - eapply j_conj_elim2; auto.
  - apply j_neg_intro. specialize (IHJ1 (ϕ0 :: Γ1)). simpl in *. eauto.
  - apply j_neg_elim with (ϕ := ϕ0); auto.
  - apply j_raa.
    specialize (IHJ1 (¬ ϕ0 :: Γ1)). simpl in *. eauto.
  - apply j_top_intro.
Qed.

(** * Relating proofs to truths*)

(** The following exercise is mostly straightforward but
    requires a good grasp on the definitions in play. By unfolding the
    definitions, we see that soundness is a computation with two inputs:
    - a "proofs" of a "proposition"
    - a model of the axioms Γ
    and the output is exactly a (Coq-level) proof of the (Coq-level) proposition
    which interprets the "proposition" in that model!
 *)

(** Exercise 7 (medium/hard): Prove that all sentences provable from Γ
    are logically entailed by Γ.

    The negation introduction and reductio ad absurdum cases may
    require some pen-and-paper thinking. You will certainly need to
    use the [lem] tactic at some point. *)
Theorem soundness : forall Γ ϕ, (Γ ⊢ ϕ) -> Γ ⊧ ϕ.
Proof.
Admitted.

(** Our next theorem is the converse of soundness, known as semantic
    completeness. It states that logically valid sentences have
    proofs. There is another notion of completeness ("syntactical
    (in)completeness") discussed later. It is sometimes clear from
    context which notion of completeness one has in mind, since
    well-known logics have equally well-known completeness properties,
    but this can also be a source of confusion to newcomers. The
    reader is advised to be very careful when reading discussions of
    this topic on the internet, which are frequently confusing and
    often simply incorrect.

    Many logics do not have semantic completeness. Fortunately,
    propositional logic is one of the logics with this
    property. Unfortunately, proving this is difficult, even for such
    a simple system. In fact, that we won't even try to prove it in
    Coq. You are encouraged to attempt it to find where the difficulty
    lies.

    Why should this be hard to prove? Consider the premise: In all
    valuations satisfying every sentence of Γ, ϕ is true. This quite
    abstract condition is a statement about truth tables. If we read
    the statement of completeness as the type of a constructive proof
    in Coq, we find a challenging problem: "Given the fact that all
    rows of a truth table that happen to satisfy each formula in Γ
    also satisfy ϕ, find a natural deduction derivation of ϕ."

    Notice the premise gives us almost no information about ϕ, not
    even its basic structure. The sentences of Γ may also be very
    complex, perhaps more complex than ϕ, so they don't necessary tell
    us anything about ϕ's subformulas. In fact, while ϕ may be true
    under every Γ-satisfying valuation, each Γ-satisfying row of the
    truth table might make ϕ true "for different reasons," so to speak
    (try some examples). Where do we get started?

    Nonetheless, this theorem is true, and can even be proved
    constructively. For now, we admit it without proof.  *)
Theorem completeness :  forall Γ ϕ, Γ ⊧ ϕ -> Γ ⊢ ϕ.
Proof.
  intros Γ ϕ.
  intros mod.
  unf.
  (* ????????????????????????????? *)
Admitted.

  (** Exercise 8 (easy? hard?): Attempt to prove the following: "There
  is a sentence of propositional logic that is neither provable nor
  disprovable from the empty set of axioms."

  Use the formula [P] (a simple propositional variable) as ϕ.  Attempt
  to prove this by induction on the derivation of P. A template has been provided.
  What happens?
 *)
Theorem syntactical_incompleteness : exists ϕ, not (nil ⊢ ϕ) /\ not (nil ⊢ ¬ ϕ).
Proof.
  exists P.
  split; intro J.
  - Case "P is not provable".
  (** We want to scrutinize the supposed derivation of [P].
      If we just do [induction J], Coq will automatically generalize over the context and conclusion P,
      as if were trying to show there are no proofs of anything. To avoid this silly behavior,
      we tell Coq to remember both the conclusion P and the emptiness of the context.
      We also discharge trivial cases instantly. *)
    Ltac cleanup := repeat match goal with | H : _ |- _ => specialize (H eq_refl) end.
    remember nil as empty; remember P as conc;
      induction J; subst; cleanup.
    + SCase "j_var".
      (* for you to finish *)
      admit.
    + SCase "j_conj_intro".
      (* contradiction, the conclusions don't match *)
      inversion Heqconc.
    + SCase "j_conj_elim1".
      (* Why doesn't the induction hypothesis apply?
         What happens if you try [inversion] on the [J]? Why?
       *)
      admit.
    + SCase "j_conj_elim2".
      (* Same story as above. *)
      admit.
    + SCase "j_neg_intro".
      (* contradiction, the conclusions don't match *)
      inversion Heqconc.
    + SCase "j_neg_elim".
      (* Why doesn't the induction hypothesis apply?
         What happens if you try [inversion] on the [J]? Why?
       *)
      admit.
    + SCase "j_raa".
      (* Why doesn't the induction hypothesis apply?
         What happens if you try [inversion] on the [J]? Why?
       *)
      admit.
    + SCase "j_top_intro".
      (* contradiction, the conclusions don't match *)
      inversion Heqconc.
  - Case "~ P is not provable".
    remember nil as empty; remember (¬ P) as conc;
    induction J; subst; cleanup.
    + SCase "j_var".
      (* for you to finish *)
      admit.
    + SCase "j_conj_intro".
      (* contradiction, the conclusions don't match *)
      inversion Heqconc.
    + SCase "j_conj_elim1".
      (* What happens if you try [inversion] on the [J]? Why?
       *)
      admit.
    + SCase "j_conj_elim2".
      (* Same story as above. *)
      admit.
    + SCase "j_neg_intro".
      inversion Heqconc. subst; clear Heqconc.
      (* What happens if you try [inversion] on the [J]? Why? *)
      admit.
    + SCase "j_neg_elim".
      (* What happens if you try [inversion] on the [J]? Why?
       *)
      admit.
    + SCase "j_raa".
      (* What happens if you try [inversion] on the [J]? Why?
       *)
      admit.
    + SCase "j_top_intro".
      (* contradiction, the conclusions don't match *)
      inversion Heqconc.
Abort.

(** Exercise 9 (easy):
    What do the hard cases above have in common? (Hint: Look at the
    names of the rules that caused us difficulty.).
*)

(** The theorem above seems obvious, but it is hard to show by
    examining proof trees. The trouble is that in each elimination
    rule, we cannot be confident that the rule used to prove the
    hypothesis is a corresponding introduction rule. Indeed, it might not
    be: Perhaps we prove [P] by proving [P /\ Q], and perhaps to prove
    /that/ we use reductio ad absurdum (for example). Can you
    rule this out?

    Although implication is not defined primitively, it is an
    illustrative example: Perhaps we prove [P] by showing [Q ⇒ P] and
    [Q]. How can we rule this out? Fundamentally we need a
    _cut-elimination_ theorem, specifically the corollary of a
    canonical form lemma (or inversion lemma). This would justify a
    more controlled case analysis by showing, without loss of
    generality, that we may assume proofs are of a particularly simple
    form.

    We won't prove this hard theorem here. Instead, we can show the
    above theorem by using soundness: We cannot prove [P] because it
    is not true in all models!  *)

Definition vtrue : valuation :=
  {| val := fun n => True ; excluded_middle := ltac:(intuition) |}.

Definition vfalse : valuation :=
  {| val := fun n => False ; excluded_middle := ltac:(intuition) |}.

(** Exercise 10 (medium): Prove the following statement using
    the two constant valuations defined above. *)
Theorem syntactical_incompleteness : exists ϕ, not (nil ⊢ ϕ) /\ not (nil ⊢ ¬ ϕ).
Proof.
Admitted.

(** * Commentary *)

(** ** Understanding Incompleteness

    So how can we understand Gödel's incompleteness theorem?

    Let's imagine starting over at the beginning. Suppose instead of
    formalizing propositional logic, we allowed propositions to vary
    over tuples of /terms/, as well as introducing quantifiers. This
    would be first-order logic (FOL).

    Formalizing the syntax is not particularly hard (albeit
    tedious). The semantics are also straightforward: The valuation
    primarily consists of a type [D] called the /domain/, with
    constants mapped to terms of [D], and functions denoting Coq-level
    functions over D. Finally, relations will denote subsets of D
    (e.g., binary relations are of type [D -> D -> Prop].

    The proof rules are also not too complicated: To prove a
    universally quantified sentence, give a natural deduction proof of
    the body after substitution by a fresh variable known as a
    /parameter/. Existentials are proved by proving the body for an
    arbitrary closed term.

    It turns out, this logic is also complete: if ϕ is true in all
    models satisfying Γ, there is a natural deduction proof of ϕ using
    the set Γ as axioms. This is Gödel's completeness theorem. First
    order logic is essentially the strongest logic that can have this
    property, as provability (as a semi-decidable property) is too
    weak to properly capture the semantics of higher logics.

    Finally, instead of considering an arbitrary Γ, consider a
    particular set of sentences called the /Peano axioms/. (This set
    is actually infinite due to the induction schema, so we would need
    to tweak our definitions to handle this.) This combination of
    first-order logic with a fixed set Γ of Peano axioms is
    first-order Peano arithmetic. Coq's natural numbers type [nat] is a
    model of this theory, but one can show there are other models.  *)
    (** Gödel proved the following fact (actually, Gödel's theorem is
    significantly more general. But the following is a corollary.):
    There is a sentence ϕ of the language which is: *)
(**
    - True, in the sense that it is true when interpreted into the model given by
      [nat].
    - Unprovable: There is no natural deduction derivation of
      this sentence.

    Since Gödel also proved first-order logic is complete, as an
    instant corollary we see ϕ is:
    - invalid: There are models in Coq of first-order Peano
      arithmetic in which the sentence is not true.
    *)
(** This last fact is somewhat of a coincidence. Gödel's
    incompleteness theorem applies equally to say, second-order
    arithmetic. That theory also has a (different!) sentence which is
    true when interpreted into Coq's [nat] type, but unprovable in this
    theory. However, this sentence is valid because second order
    arithmetic has only one model, [nat], in which the sentence is true.
    *)

(** ** Why is incompleteness important? Or is it?

    Clearly, syntactical incompleteness is not generally
    surprising. For instance

     - Coq is incomplete because it neither
       proves nor disproves LEM
     - Group theory is incomplete because it
       neither proves nor disproves the commutativity property
     - Propositional logic is incomplete because it neither proves nor
       disproves any atomic propositional symbol P *)

(** It is somewhat surprising that Peano arithmetic is incomplete,
       because it is not at all obvious which properties of [nat] are
       being left out. What else can we add? But it's still not
       terribly hard to understand, either.  *)

(** But Gödel's theorem says a lot more than this, because the real
    theorem proves that **any** theory of natural numbers is
    incomplete, provided: *)
(**
   - we can recognize valid proofs when we see them
   - the theory can prove basic facts (things which can be proved without
     even using induction) *)
(** Surely it is reasonable to say Gödel's theorem proves the
    incompleteness of any reasonable number theory. It is the
    _fundamental inability to ever form a complete number theory_
    which is so surprising.

    Furthermore, some additional logic from Gödel proves that such a theory
    cannot prove its own consistency. But why do we care? After all,
    if we don't trust a logic, then we would never trust such a proof
    of consistency in the first place. The answer is simple: Because
    if arithmetic can't prove the consistency of itself, obviously it
    could never prove the consistency of all of mathematics! This
    effectively invalidates Hilbert's program to "finitize" mathematics. *)

(** ** Does this mean natural numbers can't be defined?

    Not in any mathematical sense. Coq can prove the uniqueness of [nat]
    with some ease. ZFC (set theory) can also prove that there is a
    set, omega, with the properties of natural numbers which is unique
    up to ordinal isomorphism. If we upgrade first-order Peano
    arithmetic to its second-order version, both Coq and ZFC (etc.)
    prove that there is exactly one type/set that can model this
    theory, so the valid first-order statements of second-order Peano
    arithmeitic are precisely the "true" facts about natural numbers
    (that are definable in first-order logic). Unfortunately, this
    instantly proves second-order logic lacks the completeness
    property of first-order logic, since the provable sentences of
    second-order P.A. must be a strict subset of the true ones.

    And so provided you are willing to work within a powerful theory
    like Coq, there is absolutely a unique "thing" called the natural
    numbers. It just happens that there will be some sentence of our
    logic that we cannot prove, even though it is true if you
    interpret your metalogic as a formal theory (inside some other
    theory).  *)

(** ** Interpreting into Prop and bool

    You might expect that we would translate propositional logic into
    [bool] instead. This would work for most purposes, and might better
    align with your normal intuition for propositional logic, but
    there are several reasons to prefer translation into [Prop] over [bool]:
 *)
(**
    1.) Due to Coq's constructive nature, we can only write functions
    of type [sentence -> bool] that we can compute. This means we can only
    describe computable models in Coq, which rules out much of
    mathematics if you extend this to higher-order logics. In the best
    case scenario, this is just an artificial limitation on which
    individual models we can define in Coq. In some scenarios, it
    might limit what we can prove about the metatheory, since we can't
    describe uncomputable counterexamples, for example.
 *)
(**
    2.) Ultimately a semantics **must** map object-level propositions
    into meta-level propositions, since [ X ⊧ ϕ ] is a proposition in
    the host logic--that's the whole point. If we used a boolean
    valued semantics in Coq, the notion [X ⊧ ϕ] must be understood as
    the Coq-level proposition [⟦ ϕ ⟧ = 1] (for valuations satisfying
    [X]), which means our boolean-semantics must be composed with the
    function [fun b : bool => b = true : bool -> Prop]. Again, this "works," but it
    is somewhat awkward for some purposes in Coq.

    A [bool]-valued semantics might be preferred if we want to compute
    with propositional logic (such as to model circuits), but our
    perspective is that [Prop]-valued interpretations are the more
    general approach, and more illuminating when understanding the
    relationship between the host and guest logics. This approach is
    called algebraic semantics, and with propositional logic it means
    our valuatons can be any Boolean-algebra homomorphism. Using [bool]
    is then a kind of degenerate case.

    How is our approach more general? Consider that ⟦ p → p ⟧ is a
    propositional tautology, and accordingly [⟦ p ⟧ → ⟦ p ⟧] is
    provable in Coq no matter what [ Prop ] we assign to [p], even if
    that proposition is not itself provable in Coq. This illustrates
    that the soundness of propositional logic does not depend on the
    fact that we often study computable models of this logic.

    However, there are some caveats to the algebraic approach in Coq:

    1. We must assume LEM, or at least assume (or prove) this property
    for every valuation we consider in order to have soundness. This
    is a result of interpreting propositional logic into a
    constructive logic.

    2. If we want to "count" valuations (common when thinking about
    circuits), the right notion of equivalence between two valuations
    is that two interpretations yield equi-provable sentences in
    Coq. Different valuations are rarely literally equal.

*)


 (* We define what a ring ideal is, show that they yield congruences,
 define what a kernel is, and show that kernels are ideal. *)
Require Import
  Coq.setoid_ring.Ring MathClasses.interfaces.abstract_algebra MathClasses.theory.rings.
Require Export
   MathClasses.theory.ring_congruence.

(* Require ua_congruence varieties.rings. *)

Class RingIdeal A (P : A → Prop) `{Ring A} : Prop :=
  { ideal_proper :> Proper ((=) ==> iff) P
  ; ideal_NonEmpty :> NonEmpty (sig P)
  ; ideal_closed_plus_negate : ∀ x y, P x → P y → P (x - y)
  ; ideal_closed_mult_r : ∀ x y, P x → P (x * y)
  ; ideal_closed_mult_l: ∀ x y, P y → P (x * y) }.

Notation Factor A P := (Quotient A (λ x y, P (x - y))).

Section ideal_congruence.
  Context `{ideal : RingIdeal A P}.
  Add Ring A2 : (rings.stdlib_ring_theory A).

  (* If P is an ideal, we can easily derive some further closedness properties: *)
  Hint Resolve (ideal_closed_plus_negate) (ideal_closed_mult_l) (ideal_closed_mult_r).

  Lemma ideal_closed_0 : P 0.
  Proof. destruct ideal_NonEmpty as [[x Px]]. rewrite <-(plus_negate_r x). intuition. Qed.
  Hint Resolve ideal_closed_0.

  Lemma ideal_closed_negate x : P x → P (-x).
  Proof. intros. rewrite <- rings.plus_0_l. intuition. Qed.
  Hint Resolve ideal_closed_negate.

  Lemma ideal_closed_plus x y : P x → P y → P (x + y).
  Proof. intros. assert (x + y = -(-x + -y)) as E by ring. rewrite E. intuition. Qed.
  Hint Resolve ideal_closed_plus.

  Global Instance: RingCongruence A (λ x y, P (x - y)).
  Proof.
    split.
        constructor.
          intros x. now rewrite plus_negate_r.
         intros x y E. rewrite negate_swap_r. intuition.
        intros x y z E1 E2. mc_setoid_replace (x - z) with ((x - y) + (y - z)) by ring. intuition.
       intros ?? E. now rewrite E, plus_negate_r.
      intros x1 x2 E1 y1 y2 E2.
      mc_setoid_replace (x1 + y1 - (x2 + y2)) with ((x1 - x2) + (y1 - y2)) by ring. intuition.
     intros x1 x2 E1 y1 y2 E2.
     mc_setoid_replace (x1 * y1 - (x2 * y2)) with ((x1 - x2) * y1 + x2 * (y1 - y2)) by ring. intuition.
    intros x1 x2 E.
    mc_setoid_replace (-x1 - - x2) with (-(x1 - x2)) by ring. intuition.
  Qed.

  Lemma factor_ring_eq (x y : Factor A P) : x = y ↔ P ('x - 'y).
  Proof. intuition. Qed.

  Lemma factor_ring_eq_0 (x y : Factor A P) : x = 0 ↔ P ('x).
  Proof.
    transitivity (P ('x - cast (Factor A P) A 0)).
     intuition.
    apply ideal_proper. unfold cast. simpl. ring.
  Qed.

(*
  Let hint := rings.encode_operations R.

  Instance: Congruence rings.sig (λ _, congr_equiv).
  Proof. constructor; intros; apply _. Qed.
*)
End ideal_congruence.

Section kernel_is_ideal.
  Context `{Ring A} `{Ring B} `{f : A → B} `{!SemiRing_Morphism f}.

  Add Ring A3 : (rings.stdlib_ring_theory A).
  Add Ring B3 : (rings.stdlib_ring_theory B).

  Definition kernel : A → Prop := (= 0) ∘ f.

  Global Instance: RingIdeal A kernel.
  Proof with ring.
   unfold kernel, compose, flip.
   split.
       intros ? ? E. now rewrite E.
      split. exists (0:A). apply preserves_0.
     intros ?? E E'. rewrite preserves_plus, preserves_negate, E, E'...
    intros ?? E. rewrite preserves_mult, E...
   intros ?? E. rewrite preserves_mult, E...
  Qed.
End kernel_is_ideal.


(* The following lemma from Div2 is useful:
   ind_0_1_SS : forall P : nat -> Prop,
      P 0 -> P 1 ->
        (forall n : nat, P n -> P (S (S n))) ->
          forall n : nat, P n *)

From Coq Require Import Arith Div2 Lia PeanoNat.

Fixpoint div_mod2 (n : nat) : (nat * bool) :=
  match n with
  | 0 => (0, false)
  | 1 => (0, true)
  | S (S n) => let (a, b) := div_mod2 n in (S a, b)
  end.

Lemma dd n: exists m,  n = 2 * m \/ n = 1 + 2 * m.
Proof.
  intros.
  induction n.
  exists 0.
  lia.
  destruct IHn.
  destruct H.
  exists x.
  lia.
  exists (S x).
  lia.
Qed.

Lemma div_spec1 n: div_mod2(2 * n) = (n, false).
Proof.
  induction n.
  easy.
  simpl.
  replace (n + S (n + 0)) with (S (2 * n)) by lia.
  rewrite IHn.
  easy.
Qed.

Lemma div_spec2 n: div_mod2(1 + 2 * n) = (n, true).
Proof.
  induction n.
  easy.
  simpl.
  replace (n + S (n + 0)) with (1 + 2 * n) by lia.
  rewrite IHn.
  easy.
Qed.

Lemma dind: forall (P : nat -> Prop),
    P 0 ->
    (forall n, P n ->  P (2 * n)) ->
    (forall n, P n -> P (1 + 2 * n))
    -> forall n, P n.
Proof.
  intros P P0 P2 PS2 n.
  induction n using lt_wf_ind.
  destruct (dd n) as [m [Hd | Hd]]; subst.
  destruct m.
  simpl.
  exact P0.
  apply P2.
  apply H.
  lia.
  apply PS2.
  apply H.
  lia.
Qed.

Fixpoint pow_sqr_aux (k b e : nat) : nat :=
  match k, e with
  | 0, _ => 1
  | _, 0 => 1
  | S k, _ => match div_mod2 e with
              | (e', false) => pow_sqr_aux k (b * b) e'
              | (e', true) => b * pow_sqr_aux k (b * b) e'
              end
  end.

Definition pow_sqr (b e : nat) : nat := pow_sqr_aux e b e.

Theorem pow_eq (b e : nat) : pow_sqr b e = b ^ e.
Proof.
  revert b.
  induction e using dind; intros.
  reflexivity.
  unfold pow_sqr, pow_sqr_aux.
  destruct e.
  simpl.
  reflexivity.
  replace (2 * S e) with (S (S (2 * e))) by lia.
  replace (S (S (2 * e))) with (2 * S e) by lia.
  rewrite div_spec1.
  destruct (div_mod2 (S e)).
  destruct b0.
  replace (e + S (e + 0)) with (1 + 2 * e) by lia.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * Finite sets library *)

(** This module proves many properties of finite sets that
    are consequences of the axiomatization in [FsetInterface]
    Contrary to the functor in [FsetProperties] it uses
    sets operations instead of predicates over sets, i.e.
    [mem x s=true] instead of [In x s],
    [equal s s'=true] instead of [Equal s s'], etc. *)

Require Import MSetProperties Zerob Sumbool Omega DecidableTypeEx.

Module WEqPropertiesOn (Import E:DecidableType)(M:WSetsOn E).
Module Import MP := WPropertiesOn E M.
Import FM Dec.F.
Import M.

Definition Add := MP.Add.

Section BasicProperties.

(** Some old specifications written with boolean equalities. *)

Variable s s' s'': t.
Variable x y z : elt.

Lemma mem_eq:
  E.eq x y -> mem x s=mem y s.
Proof.
intro H; rewrite H; auto.
Qed.

Lemma equal_mem_1:
  (forall a, mem a s=mem a s') -> equal s s'=true.
Proof.
intros; apply equal_1; unfold Equal; intros.
do 2 rewrite mem_iff; rewrite H; tauto.
Qed.

Lemma equal_mem_2:
  equal s s'=true -> forall a, mem a s=mem a s'.
Proof.
intros; rewrite (equal_2 H); auto.
Qed.

Lemma subset_mem_1:
  (forall a, mem a s=true->mem a s'=true) -> subset s s'=true.
Proof.
intros; apply subset_1; unfold Subset; intros a.
do 2 rewrite mem_iff; auto.
Qed.

Lemma subset_mem_2:
  subset s s'=true -> forall a, mem a s=true -> mem a s'=true.
Proof.
intros H a; do 2 rewrite <- mem_iff; apply subset_2; auto.
Qed.

Lemma empty_mem: mem x empty=false.
Proof.
rewrite <- not_mem_iff; auto with set.
Qed.

Lemma is_empty_equal_empty: is_empty s = equal s empty.
Proof.
apply bool_1; split; intros.
auto with set.
rewrite <- is_empty_iff; auto with set.
Qed.

Lemma choose_mem_1: choose s=Some x -> mem x s=true.
Proof.
auto with set.
Qed.

Lemma choose_mem_2: choose s=None -> is_empty s=true.
Proof.
auto with set.
Qed.

Lemma add_mem_1: mem x (add x s)=true.
Proof.
auto with set relations.
Qed.

Lemma add_mem_2: ~E.eq x y -> mem y (add x s)=mem y s.
Proof.
apply add_neq_b.
Qed.

Lemma remove_mem_1: mem x (remove x s)=false.
Proof.
rewrite <- not_mem_iff; auto with set relations.
Qed.

Lemma remove_mem_2: ~E.eq x y -> mem y (remove x s)=mem y s.
Proof.
apply remove_neq_b.
Qed.

Lemma singleton_equal_add:
  equal (singleton x) (add x empty)=true.
Proof.
rewrite (singleton_equal_add x); auto with set.
Qed.

Lemma union_mem:
  mem x (union s s')=mem x s || mem x s'.
Proof.
apply union_b.
Qed.

Lemma inter_mem:
  mem x (inter s s')=mem x s && mem x s'.
Proof.
apply inter_b.
Qed.

Lemma diff_mem:
  mem x (diff s s')=mem x s && negb (mem x s').
Proof.
apply diff_b.
Qed.

(** properties of [mem] *)

Lemma mem_3 : ~In x s -> mem x s=false.
Proof.
intros; rewrite <- not_mem_iff; auto.
Qed.

Lemma mem_4 : mem x s=false -> ~In x s.
Proof.
intros; rewrite not_mem_iff; auto.
Qed.

(** Properties of [equal] *)

Lemma equal_refl: equal s s=true.
Proof.
auto with set.
Qed.

Lemma equal_sym: equal s s'=equal s' s.
Proof.
intros; apply bool_1; do 2 rewrite <- equal_iff; intuition.
Qed.

Lemma equal_trans:
 equal s s'=true -> equal s' s''=true -> equal s s''=true.
Proof.
intros; rewrite (equal_2 H); auto.
Qed.

Lemma equal_equal:
 equal s s'=true -> equal s s''=equal s' s''.
Proof.
intros; rewrite (equal_2 H); auto.
Qed.

Lemma equal_cardinal:
 equal s s'=true -> cardinal s=cardinal s'.
Proof.
auto with set.
Qed.

(* Properties of [subset] *)

Lemma subset_refl: subset s s=true.
Proof.
auto with set.
Qed.

Lemma subset_antisym:
 subset s s'=true -> subset s' s=true -> equal s s'=true.
Proof.
auto with set.
Qed.

Lemma subset_trans:
 subset s s'=true -> subset s' s''=true -> subset s s''=true.
Proof.
do 3 rewrite <- subset_iff; intros.
apply subset_trans with s'; auto.
Qed.

Lemma subset_equal:
 equal s s'=true -> subset s s'=true.
Proof.
auto with set.
Qed.

(** Properties of [choose] *)

Lemma choose_mem_3:
 is_empty s=false -> {x:elt|choose s=Some x /\ mem x s=true}.
Proof.
intros.
generalize (@choose_1 s) (@choose_2 s).
destruct (choose s);intros.
exists e;auto with set.
generalize (H1 (eq_refl None)); clear H1.
intros; rewrite (is_empty_1 H1) in H; discriminate.
Qed.

Lemma choose_mem_4: choose empty=None.
Proof.
generalize (@choose_1 empty).
case (@choose empty);intros;auto.
elim (@empty_1 e); auto.
Qed.

(** Properties of [add] *)

Lemma add_mem_3:
 mem y s=true -> mem y (add x s)=true.
Proof.
auto with set.
Qed.

Lemma add_equal:
 mem x s=true -> equal (add x s) s=true.
Proof.
auto with set.
Qed.

(** Properties of [remove] *)

Lemma remove_mem_3:
 mem y (remove x s)=true -> mem y s=true.
Proof.
rewrite remove_b; intros H;destruct (andb_prop _ _ H); auto.
Qed.

Lemma remove_equal:
 mem x s=false -> equal (remove x s) s=true.
Proof.
intros; apply equal_1; apply remove_equal.
rewrite not_mem_iff; auto.
Qed.

Lemma add_remove:
 mem x s=true -> equal (add x (remove x s)) s=true.
Proof.
intros; apply equal_1; apply add_remove; auto with set.
Qed.

Lemma remove_add:
 mem x s=false -> equal (remove x (add x s)) s=true.
Proof.
intros; apply equal_1; apply remove_add; auto.
rewrite not_mem_iff; auto.
Qed.

(** Properties of [is_empty] *)

Lemma is_empty_cardinal: is_empty s = zerob (cardinal s).
Proof.
intros; apply bool_1; split; intros.
rewrite MP.cardinal_1; simpl; auto with set.
assert (cardinal s = 0) by (apply zerob_true_elim; auto).
auto with set.
Qed.

(** Properties of [singleton] *)

Lemma singleton_mem_1: mem x (singleton x)=true.
Proof.
auto with set relations.
Qed.

Lemma singleton_mem_2: ~E.eq x y -> mem y (singleton x)=false.
Proof.
intros; rewrite singleton_b.
unfold eqb; destruct (E.eq_dec x y); intuition.
Qed.

Lemma singleton_mem_3: mem y (singleton x)=true -> E.eq x y.
Proof.
intros; apply singleton_1; auto with set.
Qed.

(** Properties of [union] *)

Lemma union_sym:
 equal (union s s') (union s' s)=true.
Proof.
auto with set.
Qed.

Lemma union_subset_equal:
 subset s s'=true -> equal (union s s') s'=true.
Proof.
auto with set.
Qed.

Lemma union_equal_1:
 equal s s'=true-> equal (union s s'') (union s' s'')=true.
Proof.
auto with set.
Qed.

Lemma union_equal_2:
 equal s' s''=true-> equal (union s s') (union s s'')=true.
Proof.
auto with set.
Qed.

Lemma union_assoc:
 equal (union (union s s') s'') (union s (union s' s''))=true.
Proof.
auto with set.
Qed.

Lemma add_union_singleton:
 equal (add x s) (union (singleton x) s)=true.
Proof.
auto with set.
Qed.

Lemma union_add:
 equal (union (add x s) s') (add x (union s s'))=true.
Proof.
auto with set.
Qed.

(* caracterisation of [union] via [subset] *)

Lemma union_subset_1: subset s (union s s')=true.
Proof.
auto with set.
Qed.

Lemma union_subset_2: subset s' (union s s')=true.
Proof.
auto with set.
Qed.

Lemma union_subset_3:
 subset s s''=true -> subset s' s''=true ->
  subset (union s s') s''=true.
Proof.
intros; apply subset_1; apply union_subset_3; auto with set.
Qed.

(** Properties of [inter] *)

Lemma inter_sym: equal (inter s s') (inter s' s)=true.
Proof.
auto with set.
Qed.

Lemma inter_subset_equal:
 subset s s'=true -> equal (inter s s') s=true.
Proof.
auto with set.
Qed.

Lemma inter_equal_1:
 equal s s'=true -> equal (inter s s'') (inter s' s'')=true.
Proof.
auto with set.
Qed.

Lemma inter_equal_2:
 equal s' s''=true -> equal (inter s s') (inter s s'')=true.
Proof.
auto with set.
Qed.

Lemma inter_assoc:
 equal (inter (inter s s') s'') (inter s (inter s' s''))=true.
Proof.
auto with set.
Qed.

Lemma union_inter_1:
 equal (inter (union s s') s'') (union (inter s s'') (inter s' s''))=true.
Proof.
auto with set.
Qed.

Lemma union_inter_2:
 equal (union (inter s s') s'') (inter (union s s'') (union s' s''))=true.
Proof.
auto with set.
Qed.

Lemma inter_add_1: mem x s'=true ->
 equal (inter (add x s) s') (add x (inter s s'))=true.
Proof.
auto with set.
Qed.

Lemma inter_add_2: mem x s'=false ->
 equal (inter (add x s) s') (inter s s')=true.
Proof.
intros; apply equal_1; apply inter_add_2.
rewrite not_mem_iff; auto.
Qed.

(* caracterisation of [union] via [subset] *)

Lemma inter_subset_1: subset (inter s s') s=true.
Proof.
auto with set.
Qed.

Lemma inter_subset_2: subset (inter s s') s'=true.
Proof.
auto with set.
Qed.

Lemma inter_subset_3:
 subset s'' s=true -> subset s'' s'=true ->
  subset s'' (inter s s')=true.
Proof.
intros; apply subset_1; apply inter_subset_3; auto with set.
Qed.

(** Properties of [diff] *)

Lemma diff_subset: subset (diff s s') s=true.
Proof.
auto with set.
Qed.

Lemma diff_subset_equal:
 subset s s'=true -> equal (diff s s') empty=true.
Proof.
auto with set.
Qed.

Lemma remove_inter_singleton:
 equal (remove x s) (diff s (singleton x))=true.
Proof.
auto with set.
Qed.

Lemma diff_inter_empty:
 equal (inter (diff s s') (inter s s')) empty=true.
Proof.
auto with set.
Qed.

Lemma diff_inter_all:
 equal (union (diff s s') (inter s s')) s=true.
Proof.
auto with set.
Qed.

End BasicProperties.

Hint Immediate empty_mem is_empty_equal_empty add_mem_1
   remove_mem_1 singleton_equal_add union_mem inter_mem
   diff_mem equal_sym add_remove remove_add : set.
Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1
   choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal
   subset_refl subset_equal subset_antisym
   add_mem_3 add_equal remove_mem_3 remove_equal : set.

(** General recursion principle *)

Lemma set_rec:  forall (P:t->Type),
 (forall s s', equal s s'=true -> P s -> P s') ->
 (forall s x, mem x s=false -> P s -> P (add x s)) ->
 P empty -> forall s, P s.
Proof.
intros.
apply set_induction; auto; intros.
apply X with empty; auto with set.
apply X with (add x s0); auto with set.
apply equal_1; intro a; rewrite add_iff; rewrite (H0 a); tauto.
apply X0; auto with set; apply mem_3; auto.
Qed.

(** Properties of [fold] *)

Lemma exclusive_set : forall s s' x,
 ~(In x s/\In x s') <-> mem x s && mem x s'=false.
Proof.
intros; do 2 rewrite mem_iff.
destruct (mem x s); destruct (mem x s'); intuition.
Qed.

Section Fold.
Variables (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA).
Variables (f:elt->A->A)(Comp:Proper (E.eq==>eqA==>eqA) f)(Ass:transpose eqA f).
Variables (i:A).
Variables (s s':t)(x:elt).

Lemma fold_empty: (fold f empty i) = i.
Proof.
apply fold_empty; auto.
Qed.

Lemma fold_equal:
 equal s s'=true -> eqA (fold f s i) (fold f s' i).
Proof.
intros; apply fold_equal with (eqA:=eqA); auto with set.
Qed.

Lemma fold_add:
 mem x s=false -> eqA (fold f (add x s) i) (f x (fold f s i)).
Proof.
intros; apply fold_add with (eqA:=eqA); auto.
rewrite not_mem_iff; auto.
Qed.

Lemma add_fold:
  mem x s=true -> eqA (fold f (add x s) i) (fold f s i).
Proof.
intros; apply add_fold with (eqA:=eqA); auto with set.
Qed.

Lemma remove_fold_1:
 mem x s=true -> eqA (f x (fold f (remove x s) i)) (fold f s i).
Proof.
intros; apply remove_fold_1 with (eqA:=eqA); auto with set.
Qed.

Lemma remove_fold_2:
 mem x s=false -> eqA (fold f (remove x s) i) (fold f s i).
Proof.
intros; apply remove_fold_2 with (eqA:=eqA); auto.
rewrite not_mem_iff; auto.
Qed.

Lemma fold_union:
 (forall x, mem x s && mem x s'=false) ->
 eqA (fold f (union s s') i) (fold f s (fold f s' i)).
Proof.
intros; apply fold_union with (eqA:=eqA); auto.
intros; rewrite exclusive_set; auto.
Qed.

End Fold.

(** Properties of [cardinal] *)

Lemma add_cardinal_1:
 forall s x, mem x s=true -> cardinal (add x s)=cardinal s.
Proof.
auto with set.
Qed.

Lemma add_cardinal_2:
 forall s x, mem x s=false -> cardinal (add x s)=S (cardinal s).
Proof.
intros; apply add_cardinal_2; auto.
rewrite not_mem_iff; auto.
Qed.

Lemma remove_cardinal_1:
 forall s x, mem x s=true -> S (cardinal (remove x s))=cardinal s.
Proof.
intros; apply remove_cardinal_1; auto with set.
Qed.

Lemma remove_cardinal_2:
 forall s x, mem x s=false -> cardinal (remove x s)=cardinal s.
Proof.
intros; apply Equal_cardinal; apply equal_2; auto with set.
Qed.

Lemma union_cardinal:
 forall s s', (forall x, mem x s && mem x s'=false) ->
 cardinal (union s s')=cardinal s+cardinal s'.
Proof.
intros; apply union_cardinal; auto; intros.
rewrite exclusive_set; auto.
Qed.

Lemma subset_cardinal:
 forall s s', subset s s'=true -> cardinal s<=cardinal s'.
Proof.
intros; apply subset_cardinal; auto with set.
Qed.

Section Bool.

(** Properties of [filter] *)

Variable f:elt->bool.
Variable Comp: Proper (E.eq==>Logic.eq) f.

Let Comp' : Proper (E.eq==>Logic.eq) (fun x =>negb (f x)).
Proof.
repeat red; intros; f_equal; auto.
Qed.

Lemma filter_mem: forall s x, mem x (filter f s)=mem x s && f x.
Proof.
intros; apply filter_b; auto.
Qed.

Lemma for_all_filter:
 forall s, for_all f s=is_empty (filter (fun x => negb (f x)) s).
Proof.
intros; apply bool_1; split; intros.
apply is_empty_1.
unfold Empty; intros.
rewrite filter_iff; auto.
red; destruct 1.
rewrite <- (@for_all_iff s f) in H; auto.
rewrite (H a H0) in H1; discriminate.
apply for_all_1; auto; red; intros.
revert H; rewrite <- is_empty_iff.
unfold Empty; intro H; generalize (H x); clear H.
rewrite filter_iff; auto.
destruct (f x); auto.
Qed.

Lemma exists_filter :
 forall s, exists_ f s=negb (is_empty (filter f s)).
Proof.
intros; apply bool_1; split; intros.
destruct (exists_2 Comp H) as (a,(Ha1,Ha2)).
apply bool_6.
red; intros; apply (@is_empty_2 _ H0 a); auto with set.
generalize (@choose_1 (filter f s)) (@choose_2 (filter f s)).
destruct (choose (filter f s)).
intros H0 _; apply exists_1; auto.
exists e; generalize (H0 e); rewrite filter_iff; auto.
intros _ H0.
rewrite (is_empty_1 (H0 (eq_refl None))) in H; auto; discriminate.
Qed.

Lemma partition_filter_1:
 forall s, equal (fst (partition f s)) (filter f s)=true.
Proof.
auto with set.
Qed.

Lemma partition_filter_2:
 forall s, equal (snd (partition f s)) (filter (fun x => negb (f x)) s)=true.
Proof.
auto with set.
Qed.

Lemma filter_add_1 : forall s x, f x = true ->
 filter f (add x s) [=] add x (filter f s).
Proof.
red; intros; set_iff; do 2 (rewrite filter_iff; auto); set_iff.
intuition.
rewrite <- H; apply Comp; auto with relations.
Qed.

Lemma filter_add_2 : forall s x, f x = false ->
 filter f (add x s) [=] filter f s.
Proof.
red; intros; do 2 (rewrite filter_iff; auto); set_iff.
intuition.
assert (f x = f a) by (apply Comp; auto).
rewrite H in H1; rewrite H2 in H1; discriminate.
Qed.

Lemma add_filter_1 : forall s s' x,
 f x=true -> (Add x s s') -> (Add x (filter f s) (filter f s')).
Proof.
unfold Add, MP.Add; intros.
repeat rewrite filter_iff; auto.
rewrite H0; clear H0.
intuition.
setoid_replace y with x; auto with relations.
Qed.

Lemma add_filter_2 : forall s s' x,
 f x=false -> (Add x s s') -> filter f s [=] filter f s'.
Proof.
unfold Add, MP.Add, Equal; intros.
repeat rewrite filter_iff; auto.
rewrite H0; clear H0.
intuition.
setoid_replace x with a in H; auto. congruence.
Qed.

Lemma union_filter: forall f g,
  Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
  forall s, union (filter f s) (filter g s) [=] filter (fun x=>orb (f x) (g x)) s.
Proof.
clear Comp' Comp f.
intros.
assert (Proper (E.eq==>Logic.eq) (fun x => orb (f x) (g x))).
  repeat red; intros.
  rewrite (H x y H1);  rewrite (H0 x y H1); auto.
unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto.
assert (f a || g a = true <-> f a = true \/ g a = true).
  split; auto with bool.
  intro H3; destruct (orb_prop _ _ H3); auto.
tauto.
Qed.

Lemma filter_union: forall s s', filter f (union s s') [=] union (filter f s) (filter f s').
Proof.
unfold Equal; intros; set_iff; repeat rewrite filter_iff; auto; set_iff; tauto.
Qed.

(** Properties of [for_all] *)

Lemma for_all_mem_1: forall s,
 (forall x, (mem x s)=true->(f x)=true) -> (for_all f s)=true.
Proof.
intros.
rewrite for_all_filter; auto.
rewrite is_empty_equal_empty.
apply equal_mem_1;intros.
rewrite filter_b; auto.
rewrite empty_mem.
generalize (H a); case (mem a s);intros;auto.
rewrite H0;auto.
Qed.

Lemma for_all_mem_2: forall s,
 (for_all f s)=true -> forall x,(mem x s)=true -> (f x)=true.
Proof.
intros.
rewrite for_all_filter in H; auto.
rewrite is_empty_equal_empty in H.
generalize (equal_mem_2 _ _ H x).
rewrite filter_b; auto.
rewrite empty_mem.
rewrite H0; simpl;intros.
rewrite <- negb_false_iff; auto.
Qed.

Lemma for_all_mem_3:
 forall s x,(mem x s)=true -> (f x)=false -> (for_all f s)=false.
Proof.
intros.
apply (bool_eq_ind (for_all f s));intros;auto.
rewrite for_all_filter in H1; auto.
rewrite is_empty_equal_empty in H1.
generalize (equal_mem_2 _ _ H1 x).
rewrite filter_b; auto.
rewrite empty_mem.
rewrite H.
rewrite H0.
simpl;auto.
Qed.

Lemma for_all_mem_4:
 forall s, for_all f s=false -> {x:elt | mem x s=true /\ f x=false}.
Proof.
intros.
rewrite for_all_filter in H; auto.
destruct (choose_mem_3 _ H) as (x,(H0,H1));intros.
exists x.
rewrite filter_b in H1; auto.
elim (andb_prop _ _ H1).
split;auto.
rewrite <- negb_true_iff; auto.
Qed.

(** Properties of [exists] *)

Lemma for_all_exists:
 forall s, exists_ f s = negb (for_all (fun x =>negb (f x)) s).
Proof.
intros.
rewrite for_all_b; auto.
rewrite exists_b; auto.
induction (elements s); simpl; auto.
destruct (f a); simpl; auto.
Qed.

End Bool.
Section Bool'.

Variable f:elt->bool.
Variable Comp: Proper (E.eq==>Logic.eq) f.

Let Comp' : Proper (E.eq==>Logic.eq) (fun x => negb (f x)).
Proof.
repeat red; intros; f_equal; auto.
Qed.

Lemma exists_mem_1:
 forall s, (forall x, mem x s=true->f x=false) -> exists_ f s=false.
Proof.
intros.
rewrite for_all_exists; auto.
rewrite for_all_mem_1;auto with bool.
intros;generalize (H x H0);intros.
rewrite negb_true_iff; auto.
Qed.

Lemma exists_mem_2:
 forall s, exists_ f s=false -> forall x, mem x s=true -> f x=false.
Proof.
intros.
rewrite for_all_exists in H; auto.
rewrite negb_false_iff in H.
rewrite <- negb_true_iff.
apply for_all_mem_2 with (2:=H); auto.
Qed.

Lemma exists_mem_3:
 forall s x, mem x s=true -> f x=true -> exists_ f s=true.
Proof.
intros.
rewrite for_all_exists; auto.
rewrite negb_true_iff.
apply for_all_mem_3 with x;auto.
rewrite negb_false_iff; auto.
Qed.

Lemma exists_mem_4:
 forall s, exists_ f s=true -> {x:elt | (mem x s)=true /\ (f x)=true}.
Proof.
intros.
rewrite for_all_exists in H; auto.
rewrite negb_true_iff in H.
destruct (@for_all_mem_4 (fun x =>negb (f x)) Comp' s) as (x,[]); auto.
exists x;split;auto.
rewrite <-negb_false_iff; auto.
Qed.

End Bool'.

Section Sum.

(** Adding a valuation function on all elements of a set. *)

Definition sum (f:elt -> nat)(s:t) := fold (fun x => plus (f x)) s 0.
Notation compat_opL := (Proper (E.eq==>Logic.eq==>Logic.eq)).
Notation transposeL := (transpose Logic.eq).

Lemma sum_plus :
  forall f g,
  Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
    forall s, sum (fun x =>f x+g x) s = sum f s + sum g s.
Proof.
unfold sum.
intros f g Hf Hg.
assert (fc : compat_opL (fun x:elt =>plus (f x))) by
 (repeat red; intros; rewrite Hf; auto).
assert (ft : transposeL (fun x:elt =>plus (f x))) by (red; intros; omega).
assert (gc : compat_opL (fun x:elt => plus (g x))) by
 (repeat red; intros; rewrite Hg; auto).
assert (gt : transposeL (fun x:elt =>plus (g x))) by (red; intros; omega).
assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))) by
  (repeat red; intros; rewrite Hf,Hg; auto).
assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))) by (red; intros; omega).
intros s;pattern s; apply set_rec.
intros.
rewrite <- (fold_equal _ _ _ _ fc ft 0 _ _ H).
rewrite <- (fold_equal _ _ _ _ gc gt 0 _ _ H).
rewrite <- (fold_equal _ _ _ _ fgc fgt 0 _ _ H); auto.
intros. do 3 (rewrite fold_add; auto with *).
do 3 rewrite fold_empty;auto.
Qed.

Lemma sum_filter : forall f : elt -> bool, Proper (E.eq==>Logic.eq) f ->
  forall s, (sum (fun x => if f x then 1 else 0) s) = (cardinal (filter f s)).
Proof.
unfold sum; intros f Hf.
assert (st : Equivalence (@Logic.eq nat)) by (split; congruence).
assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))) by
 (repeat red; intros; rewrite Hf; auto).
assert (ct : transposeL (fun x => plus (if f x then 1 else 0))) by
 (red; intros; omega).
intros s;pattern s; apply set_rec.
intros.
change elt with E.t.
rewrite <- (fold_equal _ _ st _ cc ct 0 _ _ H).
apply equal_2 in H; rewrite <- H, <-H0; auto.
intros; rewrite (fold_add _ _ st _ cc ct); auto.
generalize (@add_filter_1 f Hf s0 (add x s0) x) (@add_filter_2 f Hf s0 (add x s0) x) .
assert (~ In x (filter f s0)).
 intro H1; rewrite (mem_1 (filter_1 Hf H1)) in H; discriminate H.
case (f x); simpl; intros.
rewrite (MP.cardinal_2 H1 (H2 (eq_refl true) (MP.Add_add s0 x))); auto.
rewrite <- (MP.Equal_cardinal (H3 (eq_refl false) (MP.Add_add s0 x))); auto.
intros; rewrite fold_empty;auto.
rewrite MP.cardinal_1; auto.
unfold Empty; intros.
rewrite filter_iff; auto; set_iff; tauto.
Qed.

Lemma fold_compat :
  forall (A:Type)(eqA:A->A->Prop)(st:Equivalence eqA)
  (f g:elt->A->A),
  Proper (E.eq==>eqA==>eqA) f -> transpose eqA f ->
  Proper (E.eq==>eqA==>eqA) g -> transpose eqA g ->
  forall (i:A)(s:t),(forall x:elt, (In x s) -> forall y, (eqA (f x y) (g x y))) ->
  (eqA (fold f s i) (fold g s i)).
Proof.
intros A eqA st f g fc ft gc gt i.
intro s; pattern s; apply set_rec; intros.
transitivity (fold f s0 i).
apply fold_equal with (eqA:=eqA); auto.
rewrite equal_sym; auto.
transitivity (fold g s0 i).
apply H0; intros; apply H1; auto with set.
elim  (equal_2 H x); auto with set; intros.
apply fold_equal with (eqA:=eqA); auto with set.
transitivity (f x (fold f s0 i)).
apply fold_add with (eqA:=eqA); auto with set.
transitivity (g x (fold f s0 i)); auto with set relations.
transitivity (g x (fold g s0 i)); auto with set relations.
apply gc; auto with set relations.
symmetry; apply fold_add with (eqA:=eqA); auto.
do 2 rewrite fold_empty; reflexivity.
Qed.

Lemma sum_compat :
  forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g ->
  forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s.
intros.
unfold sum; apply (@fold_compat _ (@Logic.eq nat));
 repeat red; auto with *.
Qed.

End Sum.

End WEqPropertiesOn.

(** Now comes variants for self-contained weak sets and for full sets.
    For these variants, only one argument is necessary. Thanks to
    the subtyping [WS<=S], the [EqProperties] functor which is meant to be
    used on modules [(M:S)] can simply be an alias of [WEqProperties]. *)

Module WEqProperties (M:WSets) := WEqPropertiesOn M.E M.
Module EqProperties := WEqProperties.


Require Import Unicode.Utf8.

Open Scope type_scope.
Definition relation (X : Type) (Y : Type) := X → Y → Type.

Definition transition (X : Type) := X → X → Type.

Definition strong_bisim (A B : Type) (fa : transition A) (fb : transition B) (R : relation A B) :
  Type := ∀ a b, R a b →
         (∀ a', fa a a' → {b' : B & fb b b' * R a' b'})
       * (∀ b', fb b b' → {a' : A & fa a a' * R a' b'}).

Inductive refl_trans_clos {X} (f : transition X) : transition X :=
  | t_refl (x : X) : refl_trans_clos f x x
  | t_step (x y z : X) : f x y → refl_trans_clos f y z → refl_trans_clos f x z.

Lemma t_step2 {X} : ∀ (f : transition X) (x y z : X), f y z → refl_trans_clos f x y →
  refl_trans_clos f x z.
intros f x y z H H0. induction H0. apply t_step with (y:=z). assumption. apply t_refl. apply
IHrefl_trans_clos in H. apply (t_step f x y z); assumption. Qed.

Lemma refl_trans_clos_app {X} : ∀ (f : transition X) (x y z : X),
  refl_trans_clos f x y → refl_trans_clos f y z → refl_trans_clos f x z.
intros f x y z H H0. induction H. auto. apply IHrefl_trans_clos in H0. rename y into Y. apply
t_step with (y:=Y); auto. Qed.

(* p and q are bisimilar *)
(*Notation "p '~' q" := (∃ fp fq R, strong_bisim p q fp fq R) (at level 30). *)

Definition partial_function {X Y: Type} (R: relation X Y) :=
  ∀ (x : X) (y1 y2 : Y), R x y1 → R x y2 → y1 = y2.

Definition total_function {X Y: Type} (R: relation X Y) :=
  (∀ x:X, {y:Y & R x y}) * partial_function R.

Definition surjective {X Y: Type} (f : X → Y) : Type :=
  ∀ y:Y, ∃ x:X, f x = y.

Definition injective {X Y : Type} (f : X → Y) : Type :=
  ∀ a b: X, f a = f b → a = b.

Definition bijective {X Y : Type} (f : X → Y) : Type :=
  injective f * surjective f.

Definition reflexive {X : Type} (R: relation X X) :=
  ∀ a : X, R a a.

Definition symmetric {X : Type} (R: relation X X) :=
  ∀ a b : X, (R a b) → (R b a).

Definition antisymmetric {X: Type} (R: relation X X) :=
  ∀ a b : X, (R a b) → (R b a) → a = b.

Definition transitive {X: Type} (R: relation X X) :=
  ∀ a b c : X, (R a b) → (R b c) → (R a c).

Definition equivalence {X:Type} (R: relation X X) :=
  reflexive R * symmetric R * transitive R.

Definition partial_order {X:Type} (R: relation X X) :=
  reflexive R * antisymmetric R * transitive R.

(* Examples *)

Inductive next_nat (n : nat) : nat → Prop :=
    | succ : next_nat n (S n).

(*
Lemma next_nat_le : ∀ m n, refl_trans_clos next_nat m n ↔ le m n.
intros. split. intros. induction H. auto. inversion H. subst. apply le_S in
IHrefl_trans_clos. apply le_S_n. assumption. intros. induction H. apply t_refl.
apply t_step2 with (y:=m0). apply succ. auto. Qed.

(* simple bisimulation *)
Theorem bisim_next_nat_eq : strong_bisim nat nat next_nat next_nat eq.
Proof. unfold strong_bisim. intros. subst. split. intros. apply ex_intro with a'.
split; auto. intros. apply ex_intro with b'. split; auto. Qed.

*)


Inductive na: Type :=
  |O
  |S (n:na).

Fixpoint plus (n m:na):na :=
  match n with
  |O => m
  |S n' => S (plus n' m)
end.

Fixpoint square (n:na):na :=
  match n with
  |O => O
  |S n' => plus (square n') (plus n' n)
end.

Compute square(S(S(O))).


(* ea *)

Inductive Boole : Set :=
  | igaz : Boole
  | hamis : Boole.

Print Boole_ind.

Definition Boole_Or (b1:Boole) (b2:Boole) : Boole :=
  match b1 with
    | igaz => match b2 with
                | igaz => igaz
                | hamis => igaz
              end
    | hamis => match b2 with
                | igaz => igaz
                | hamis => hamis
              end
  end.

Notation "x 'vagy' y" := (Boole_Or x y) (at level 20) : type_scope.

Check igaz vagy hamis.

Eval compute in (igaz vagy hamis).

Definition Boole_And (b1 : Boole) (b2: Boole) : Boole :=
  match b1 with
    | igaz => match b2 with | igaz => igaz | hamis => hamis end
    | hamis => match b2 with | igaz => hamis | hamis => hamis end end.

Notation "x 'es' y" := (Boole_And x y) (at level 20) : type_scope.

Definition Boole_Not (b : Boole) : Boole :=
  match b with
    | igaz => hamis
    | hamis => igaz
  end.

Notation "'nem' x" := (Boole_Not x) (at level 20) : type_scope.

Definition Boole_Imp (x : Boole) (y: Boole) : Boole :=
  match x with
    | igaz => match y with
                | igaz => igaz
                | hamis => hamis
              end
    | hamis => match y with
                | igaz => igaz
                | hamis => igaz
              end
  end.

Notation "x 'imp' y" := (Boole_Imp x y) (at level 20) : type_scope.

Definition Boole_Iff (x : Boole) (y: Boole) : Boole :=
  match x with
    | igaz => match y with
                | igaz => igaz
                | hamis => hamis
              end
    | hamis => match y with
                | igaz => hamis
                | hamis => igaz
              end
  end.

Notation "x 'acsa' y" := (Boole_Iff x y) (at level 20) : type_scope.

(* hf 1 *)

Theorem hf_1a : (forall x y : Boole, (x imp y) = ((nem x) vagy y)).
Proof.
  intros.
  apply Boole_ind with (P:=fun x => (x imp y) = ((nem x) vagy y)).
  unfold Boole_Imp.
  unfold Boole_Not.
  unfold Boole_Or.
  reflexivity.
  unfold Boole_Imp.
  unfold Boole_Not.
  unfold Boole_Or.
  reflexivity.
  Show Proof.
Qed.

Theorem hf_1b : (forall x y : Boole, (x imp y) acsa ((nem x) vagy y) = igaz).
Proof.
  intros.
  apply Boole_ind with (P:=fun x => (x imp y) acsa ((nem x) vagy y) = igaz).
  apply Boole_ind with (P:=fun y => (igaz imp y) acsa ((nem igaz) vagy y) = igaz).
  unfold Boole_Iff.
  unfold Boole_Not.
  unfold Boole_Imp.
  unfold Boole_Or.
  reflexivity.
  unfold Boole_Iff.
  unfold Boole_Not.
  unfold Boole_Imp.
  unfold Boole_Or.
  reflexivity.
  apply Boole_ind with (P:=fun y => (hamis imp y) acsa ((nem hamis) vagy y) = igaz).
  unfold Boole_Iff.
  unfold Boole_Not.
  unfold Boole_Imp.
  unfold Boole_Or.
  reflexivity.
  unfold Boole_Iff.
  unfold Boole_Not.
  unfold Boole_Imp.
  unfold Boole_Or.
  reflexivity.
  Show Proof.
Qed.

(* hf 2 *)

Theorem hf_2 : (forall x y : Boole, ((nem x) es (nem y)) = nem (x vagy y)).
Proof.
  intros.
  apply Boole_ind with (P:=fun x => ((nem x) es (nem y)) = nem (x vagy y)).
  apply Boole_ind with (P:=fun y => (nem igaz) es (nem y) = nem (igaz vagy y)).
  unfold Boole_Not.
  unfold Boole_And.
  unfold Boole_Or.
  reflexivity.
  unfold Boole_Not.
  unfold Boole_And.
  unfold Boole_Or.
  reflexivity.
  apply Boole_ind with (P:=fun y => (nem hamis) es (nem y) = nem (hamis vagy y)).
  unfold Boole_Not.
  unfold Boole_And.
  unfold Boole_Or.
  reflexivity.
  unfold Boole_Not.
  unfold Boole_And.
  unfold Boole_Or.
  reflexivity.
  Show Proof.
Qed.


Set Implicit Arguments.

CoInductive LList (A:Type) : Type :=
  | LNil : LList A
  | LCons : A -> LList A -> LList A.

Arguments LNil {A}.

CoInductive Infinite {A:Type} : LList A -> Prop :=
    Infinite_LCons :
      forall (a:A) (l:LList A), Infinite l -> Infinite (LCons a l).

#[export] Hint Constructors Infinite: llists.

Definition Infinite_ok {A: Type} (X:LList A -> Prop) : Prop :=
  forall l:LList A,
    X l ->  exists a : A, exists l' : LList A, l = LCons a l' /\ X l'.

Definition Infinite1 {A: Type} (l:LList A) :=
   exists X : LList A -> Prop, Infinite_ok X /\ X l.

Lemma ok_LNil {A: Type}:
 forall X:LList A -> Prop, Infinite_ok X -> ~ X LNil.
Proof.
 unfold Infinite_ok.
 intros X H H0;  case (H LNil).
 - assumption.
 - intros x H1; case H1; intros x0 H2; case H2; discriminate 1.
Qed.

Lemma ok_LCons {A: Type} :
  forall  (X:LList A -> Prop) (a:A) (l:LList A),
   Infinite_ok X -> X (LCons a l) -> X l.
Proof.
 intros  X a l H H0; case (H (LCons a l)).
 -  assumption.
 -  simple destruct 1; intros x0 H2; case H2; injection 1.
    simple destruct 1; auto.
Qed.

Lemma Infinite1_LNil {A: Type} :  ~ Infinite1 (LNil (A:=A)).
Proof.
 intros  H; destruct H as [X [H1 H2]].
 now apply (ok_LNil H1).
Qed.

Lemma Infinite1_LCons  {A: Type} :
 forall  (a:A) (l:LList A), Infinite1 (LCons a l) -> Infinite1 l.
Proof.
 intros  a l H.
 case H; intros X HX; case HX; intros H1 H2; clear HX.
  exists (fun u:LList A =>  exists b : A, X (LCons b u)); split.
 -  unfold Infinite_ok in |- *.
    intros l0 [b Hb].
    assert (H4 : X l0) by apply (ok_LCons _ _  H1 Hb);eauto.
    case (H1 l0 H4);  intros x [l' [el' Hl']].
    exists x, l'; split; try assumption.
    exists x; rewrite <- el'; auto.
-  exists a; auto.
Qed.

(* equivalence between both definitions of infinity *)

Lemma Inf_Inf1 {A : Type} : forall l:LList A, Infinite l -> Infinite1 l.
Proof.
 intros l ;  exists (Infinite (A:=A)).
 split; try assumption.
 unfold Infinite_ok in |- *.
 simple destruct l0.
 -  inversion 1.
 - inversion_clear 1.
   exists a; exists l1; auto.
Qed.

Lemma Inf1_Inf {A : Type}: forall l:LList A, Infinite1 l -> Infinite l.
Proof.
 cofix Inf1_Inf.
 simple destruct l.
 - intro H;  case (Infinite1_LNil H).
 -  intros a l0 H0;  generalize (Infinite1_LCons H0); constructor.
    now apply Inf1_Inf.
Qed.


Require Import ZArith Znumtheory.
Open Scope Z.

Definition Square (n : Z) := Z.sqrt n * Z.sqrt n = n.

Definition task := forall n m, 1 <= n -> 1 <= m -> rel_prime n m -> Square (n * m) -> Square n.


(** Calculation of the simple arithmetic language. *)

Require Import Tactics.
Require Export Memory.
Module Arith (mem : Memory).
Import mem.

(** * Syntax *)

Inductive Expr : Set :=
| Val : nat -> Expr
| Add : Expr -> Expr -> Expr.

(** * Semantics *)

Fixpoint eval (x: Expr) : nat :=
  match x with
    | Val n => n
    | Add x1 x2 => eval x1 + eval x2
  end.

(** * Compiler *)

Inductive Code : Set :=
| LOAD : nat -> Code -> Code
| ADD : adr -> Code -> Code
| STORE : adr -> Code -> Code
| HALT : Code.

Fixpoint comp' (x : Expr) (r : adr) (c : Code) : Code :=
  match x with
  | Val n => LOAD n c
  | Add x1 x2 => comp' x1 r (STORE r (comp' x2 (next r) (ADD r c)))
  end.

Definition comp (x : Expr) : Code := comp' x first HALT.

(** * Virtual Machine *)

Definition Memory : Type := Mem.
Definition Acc : Type := nat.

Definition State : Type := (Code * Memory * Acc)%type.

Reserved Notation "x ==> y" (at level 80, no associativity).
Inductive VM : State -> State -> Prop :=
| vm_load n c m a : (LOAD n c , m, a) ==> (c , m, n)
| vm_add c r m a : (ADD r c, m, a) ==> (c, free r m, get r m + a)
| vm_store c r m a : (STORE r c, m, a) ==> (c, set r a m, a)
where "x ==> y" := (VM x y).

(** * Calculation *)

(** Boilerplate to import calculation tactics *)

Module VM <: Preorder.
Definition State := State.
Definition VM := VM.
End VM.
Module VMCalc := Calculation VM.
Import VMCalc.

(** Specification of the compiler *)

Theorem spec x r c a m :
  isFreeFrom r m ->
  (comp' x r c, m, a) =>> (c , m, eval x).

(** Setup the induction proof *)

Proof.
  intros.
  generalize dependent c.
  generalize dependent m.
  generalize dependent r.
  generalize dependent a.
  induction x;intros.

(** Calculation of the compiler *)

(** - [x = Val n]: *)

  begin
  (c, m, n).
  <== { apply vm_load }
  (LOAD n c, m, a).
  [].

(** - [x = Add x1 x2]: *)

  begin
    (c, m, eval x1 + eval x2).
  = {rewrite isFreeFrom_free, get_set}
    (c, free r (set r (eval x1) m), get r (set r (eval x1) m)  + eval x2).
  <== {apply vm_add}
    (ADD r c, set r (eval x1) m, eval x2).
  <<= {apply IHx2; auto using isFreeFrom_set}
    (comp' x2 (next r) (ADD r c), set r (eval x1) m, eval x1).
  <== {apply vm_store}
    (STORE r (comp' x2 (next r) (ADD r c)), m, eval x1).
  <<= { apply IHx1}
    (comp' x1 r (STORE r (comp' x2 (next r) (ADD r c))), m, a).
  [].
Qed.

(** * Soundness *)

(** Since the VM is defined as a small step operational semantics, we
have to prove that the VM is deterministic and does not get stuck in
order to derive soundness from the above theorem. *)

Lemma determ_vm : determ VM.
  intros C C1 C2 V. induction V; intro V'; inversion V'; subst; reflexivity.
Qed.

Theorem sound x a C : (comp x, empty, a) =>>! C -> C = (HALT , empty, eval x).
Proof.
  intros.
  pose (spec x first HALT) as H'. unfold comp in *. pose (determ_trc determ_vm) as D.
  unfold determ in D. eapply D. apply H. split. apply H'. apply isFreeFrom_first. intro Contra. destruct Contra.
  inversion H0.
Qed.

End Arith.


Require Export D.

(** **** Problem #3 : 2 stars (boolean functions) *)
(** Use the tactics you have learned so far to prove the following
    theorem about boolean functions. *)

Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
	intros. rewrite -> H. rewrite -> H. destruct b. reflexivity. reflexivity.
Qed.


(** 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 (lf1 : natural) (y : natural) (x : natural) (lf2 : natural)
  : natural := plus (Succ Zero) y.


(* Exercise 49 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_049 : (A -> (B -> ~A)) -> ~A \/ ~B.
Proof.
imp_i a1.
dis_e (A \/ ~A) a2 a2.
LEM.
dis_e (B \/ ~B) a3 a3.
LEM.
dis_i1.
imp_e B.
imp_e A.
hyp a1.
hyp a2.
hyp a3.
dis_i2.
hyp a3.
dis_i1.
hyp a2.
Qed.