Require Import Crypto.Util.Relations Crypto.Util.Notations.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.Tactics.DebugPrint.
Require Import Coq.Classes.RelationClasses Coq.Classes.Morphisms.
Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Ring Crypto.Algebra.IntegralDomain.
Require Coq.setoid_ring.Field_theory.

Section Field.
  Context {T eq zero one opp add mul sub inv div} `{@field T eq zero one opp add sub mul inv div}.
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Notation "0" := zero. Local Notation "1" := one.
  Local Infix "+" := add. Local Infix "*" := mul.

  Lemma right_multiplicative_inverse : forall x : T, ~ eq x zero -> eq (mul x (inv x)) one.
  Proof using Type*.
    intros. rewrite commutative. auto using left_multiplicative_inverse.
  Qed.

  Lemma left_inv_unique x ix : ix * x = one -> ix = inv x.
  Proof using Type*.
    intro Hix.
    assert (H0 : ix*x*inv x = inv x).
    - rewrite Hix, left_identity; reflexivity.
    - rewrite <-associative, right_multiplicative_inverse, right_identity in H0; trivial.
      intro eq_x_0. rewrite eq_x_0, Ring.mul_0_r in Hix.
      apply (zero_neq_one(eq:=eq)). assumption.
  Qed.
  Definition inv_unique := left_inv_unique.

  Lemma right_inv_unique x ix : x * ix = one -> ix = inv x.
  Proof using Type*. rewrite commutative. apply left_inv_unique. Qed.

  Lemma div_one x : div x one = x.
  Proof using Type*.
    rewrite field_div_definition.
    rewrite <-(inv_unique 1 1); apply monoid_is_right_identity.
  Qed.

  Lemma mul_cancel_l_iff : forall x y, y <> 0 ->
                                       (x * y = y <-> x = one).
  Proof using Type*.
    intros x y H0.
    split; intros H1.
    + rewrite <-(right_multiplicative_inverse y) by assumption.
      rewrite <-H1 at 1; rewrite <-associative.
      rewrite right_multiplicative_inverse by assumption.
      rewrite right_identity.
      reflexivity.
    + rewrite H1; apply left_identity.
  Qed.

  Lemma field_theory_for_stdlib_tactic : Field_theory.field_theory 0 1 add mul sub opp div inv eq.
  Proof using Type*.
    constructor.
    { apply Ring.ring_theory_for_stdlib_tactic. }
    { intro H01. symmetry in H01. auto using (zero_neq_one(eq:=eq)). }
    { apply field_div_definition. }
    { apply left_multiplicative_inverse. }
  Qed.

  Context {eq_dec:DecidableRel eq}.

  Global Instance is_mul_nonzero_nonzero : @is_zero_product_zero_factor T eq 0 mul.
  Proof using Type*.
    split. intros x y Hxy.
    eapply not_not; try typeclasses eauto; []; intuition idtac; eapply (zero_neq_one(eq:=eq)).
    transitivity ((inv y * (inv x * x)) * y).
    - rewrite <-!associative, Hxy, !Ring.mul_0_r; reflexivity.
    - rewrite left_multiplicative_inverse, right_identity, left_multiplicative_inverse by trivial.
      reflexivity.
  Qed.

  Global Instance integral_domain : @integral_domain T eq zero one opp add sub mul.
  Proof using Type*.
    split; auto using field_commutative_ring, field_is_zero_neq_one, is_mul_nonzero_nonzero.
  Qed.
End Field.

Section Homomorphism.
  Context {F EQ ZERO ONE OPP ADD MUL SUB INV DIV} `{@field F EQ ZERO ONE OPP ADD SUB MUL INV DIV}.
  Context {K eq zero one opp add mul sub inv div} `{@field K eq zero one opp add sub mul inv div}.
  Context {phi:F->K}.
  Local Infix "=" := eq. Local Infix "=" := eq : type_scope.
  Context `{@Ring.is_homomorphism F EQ ONE ADD MUL K eq one add mul phi}.

  Lemma homomorphism_multiplicative_inverse
    : forall x, not (EQ x ZERO)
                -> phi (INV x) = inv (phi x).
  Proof using Type*.
    intros.
    eapply inv_unique.
    rewrite <-Ring.homomorphism_mul.
    rewrite left_multiplicative_inverse; auto using Ring.homomorphism_one.
  Qed.

  Lemma homomorphism_multiplicative_inverse_complete
        { EQ_dec : DecidableRel EQ }
    : forall x, (EQ x ZERO -> phi (INV x) = inv (phi x))
                -> phi (INV x) = inv (phi x).
  Proof using Type*.
    intros x ?; destruct (dec (EQ x ZERO)); auto using homomorphism_multiplicative_inverse.
  Qed.

  Lemma homomorphism_div
    : forall x y, not (EQ y ZERO)
                  -> phi (DIV x y) = div (phi x) (phi y).
  Proof using Type*.
    intros. rewrite !field_div_definition.
    rewrite Ring.homomorphism_mul, homomorphism_multiplicative_inverse;
      (eauto || reflexivity).
  Qed.

  Lemma homomorphism_div_complete
        { EQ_dec : DecidableRel EQ }
    : forall x y, (EQ y ZERO -> phi (INV y) = inv (phi y))
                  -> phi (DIV x y) = div (phi x) (phi y).
  Proof using Type*.
    intros. rewrite !field_div_definition.
    rewrite Ring.homomorphism_mul, homomorphism_multiplicative_inverse_complete;
      (eauto || reflexivity).
  Qed.
End Homomorphism.

Section Homomorphism_rev.
  Context {F EQ ZERO ONE OPP ADD SUB MUL INV DIV} {fieldF:@field F EQ ZERO ONE OPP ADD SUB MUL INV DIV}.
  Context {H} {eq : H -> H -> Prop} {zero one : H} {opp : H -> H} {add sub mul : H -> H -> H} {inv : H -> H} {div : H -> H -> H}.
  Context {phi:F->H} {phi':H->F}.
  Local Infix "=" := EQ. Local Infix "=" := EQ : type_scope.
  Context (phi'_phi_id : forall A, phi' (phi A) = A)
          (phi'_eq : forall a b, EQ (phi' a) (phi' b) <-> eq a b)
          {phi'_zero : phi' zero = ZERO}
          {phi'_one : phi' one = ONE}
          {phi'_opp : forall a, phi' (opp a) = OPP (phi' a)}
          (phi'_add : forall a b, phi' (add a b) = ADD (phi' a) (phi' b))
          (phi'_sub : forall a b, phi' (sub a b) = SUB (phi' a) (phi' b))
          (phi'_mul : forall a b, phi' (mul a b) = MUL (phi' a) (phi' b))
          {phi'_inv : forall a, phi' (inv a) = INV (phi' a)}
          (phi'_div : forall a b, phi' (div a b) = DIV (phi' a) (phi' b)).

  Lemma field_and_homomorphism_from_redundant_representation
    : @field H eq zero one opp add sub mul inv div
      /\ @Ring.is_homomorphism F EQ ONE ADD MUL H eq one add mul phi
      /\ @Ring.is_homomorphism H eq one add mul F EQ ONE ADD MUL phi'.
  Proof using Type*.
    repeat match goal with
           | [ H : field |- _ ] => destruct H; try clear H
           | [ H : commutative_ring |- _ ] => destruct H; try clear H
           | [ H : ring |- _ ] => destruct H; try clear H
           | [ H : commutative_group |- _ ] => destruct H; try clear H
           | [ H : group |- _ ] => destruct H; try clear H
           | [ H : monoid |- _ ] => destruct H; try clear H
           | [ H : is_commutative |- _ ] => destruct H; try clear H
           | [ H : is_left_multiplicative_inverse |- _ ] => destruct H; try clear H
           | [ H : is_left_distributive |- _ ] => destruct H; try clear H
           | [ H : is_right_distributive |- _ ] => destruct H; try clear H
           | [ H : is_zero_neq_one |- _ ] => destruct H; try clear H
           | [ H : is_associative |- _ ] => destruct H; try clear H
           | [ H : is_left_identity |- _ ] => destruct H; try clear H
           | [ H : is_right_identity |- _ ] => destruct H; try clear H
           | [ H : Equivalence _ |- _ ] => destruct H; try clear H
           | [ H : is_left_inverse |- _ ] => destruct H; try clear H
           | [ H : is_right_inverse |- _ ] => destruct H; try clear H
           | _ => intro
           | _ => split
           | [ H : eq _ _ |- _ ] => apply phi'_eq in H
           | [ |- eq _ _ ] => apply phi'_eq
           | [ H : (~eq _ _)%type |- _ ] => pose proof (fun pf => H (proj1 (@phi'_eq _ _) pf)); clear H
           | [ H : EQ _ _ |- _ ] => rewrite H
           | _ => progress erewrite ?phi'_zero, ?phi'_one, ?phi'_opp, ?phi'_add, ?phi'_sub, ?phi'_mul, ?phi'_inv, ?phi'_div, ?phi'_phi_id by reflexivity
           | [ H : _ |- _ ] => progress erewrite ?phi'_zero, ?phi'_one, ?phi'_opp, ?phi'_add, ?phi'_sub, ?phi'_mul, ?phi'_inv, ?phi'_div, ?phi'_phi_id in H by reflexivity
           | _ => solve [ eauto ]
           end.
  Qed.
End Homomorphism_rev.

Ltac guess_field :=
  match goal with
  | |- ?eq _ _ =>  constr:(_:Hierarchy.field (eq:=eq))
  | |- not (?eq _ _) =>  constr:(_:Hierarchy.field (eq:=eq))
  | [H: ?eq _ _ |- _ ] =>  constr:(_:Hierarchy.field (eq:=eq))
  | [H: not (?eq _ _) |- _] =>  constr:(_:Hierarchy.field (eq:=eq))
  end.

Ltac goal_to_field_equality fld :=
  let eq := match type of fld with Hierarchy.field(eq:=?eq) => eq end in
  match goal with
  | [ |- eq _ _] => idtac
  | [ |- not (eq ?x ?y) ] => apply not_exfalso; intro; goal_to_field_equality fld
  | _ => exfalso;
         match goal with
         | H: not (eq _ _) |- _ => apply not_exfalso in H; apply H
         | _ => apply (field_is_zero_neq_one(field:=fld))
         end
  end.

Ltac inequalities_to_inverse_equations fld :=
  let eq := match type of fld with Hierarchy.field(eq:=?eq) => eq end in
  let zero := match type of fld with Hierarchy.field(zero:=?zero) => zero end in
  let div := match type of fld with Hierarchy.field(div:=?div) => div end in
  let sub := match type of fld with Hierarchy.field(sub:=?sub) => sub end in
  repeat match goal with
         | [H: not (eq _ _) |- _ ] =>
           lazymatch type of H with
           | not (eq ?d zero) =>
             unique pose proof (right_multiplicative_inverse(H:=fld) _ H)
           | not (eq zero ?d) =>
             unique pose proof (right_multiplicative_inverse(H:=fld) _ (symmetry(R:=fun a b => not (eq a b)) H))
           | not (eq ?x ?y) =>
             unique pose proof (right_multiplicative_inverse(H:=fld) _ (Ring.neq_sub_neq_zero _ _ H))
           end
         end.

Ltac unique_pose_implication pf :=
  let B := match type of pf with ?A -> ?B => B end in
  match goal with
             | [H:B|-_] => fail 1
             | _ => unique pose proof pf
  end.

Ltac inverses_to_conditional_equations fld :=
  let eq := match type of fld with Hierarchy.field(eq:=?eq) => eq end in
  let inv := match type of fld with Hierarchy.field(inv:=?inv) => inv end in
  repeat match goal with
         | |- context[inv ?d] =>
           unique_pose_implication constr:(right_multiplicative_inverse(H:=fld) d)
         | H: context[inv ?d] |- _ =>
           unique_pose_implication constr:(right_multiplicative_inverse(H:=fld) d)
         end.

Ltac clear_hypotheses_with_nonzero_requirements fld :=
  let eq := match type of fld with Hierarchy.field(eq:=?eq) => eq end in
  let zero := match type of fld with Hierarchy.field(zero:=?zero) => zero end in
  repeat match goal with
           [H: not (eq _ zero) -> _ |- _ ] => clear H
         end.

Ltac forward_nonzero fld solver_tac :=
  let eq := match type of fld with Hierarchy.field(eq:=?eq) => eq end in
  let zero := match type of fld with Hierarchy.field(zero:=?zero) => zero end in
  repeat match goal with
         | [H: not (eq ?x zero) -> _ |- _ ]
           => let H' := fresh in
              assert (H' : not (eq x zero)) by (clear_hypotheses_with_nonzero_requirements; solver_tac); specialize (H H')
         | [H: not (eq ?x zero) -> _ |- _ ]
           => let H' := fresh in
              assert (H' : not (eq x zero)) by (clear H; solver_tac); specialize (H H')
         end.

Ltac divisions_to_inverses fld :=
  rewrite ?(field_div_definition(field:=fld)) in *.

Ltac fsatz_solve_on fld :=
  goal_to_field_equality fld;
  forward_nonzero fld ltac:(fsatz_solve_on fld);
  nsatz;
  solve_debugfail ltac:(IntegralDomain.solve_constant_nonzero).

Ltac fsatz_solve :=
  let fld := guess_field in
  fsatz_solve_on fld.

Ltac fsatz_prepare_hyps_on fld :=
  divisions_to_inverses fld;
  inequalities_to_inverse_equations fld;
  inverses_to_conditional_equations fld;
  forward_nonzero fld ltac:(fsatz_solve_on fld).

Ltac fsatz_prepare_hyps :=
  let fld := guess_field in
  fsatz_prepare_hyps_on fld.

Ltac fsatz :=
  let fld := guess_field in
  fsatz_prepare_hyps_on fld;
  fsatz_solve_on fld.

Section FieldSquareRoot.
  Context {T eq zero one opp add mul sub inv div} `{@field T eq zero one opp add sub mul inv div} {eq_dec:DecidableRel eq}.
  Local Infix "=" := eq : type_scope. Local Notation "a <> b" := (not (a = b)) : type_scope.
  Local Infix "+" := add. Local Infix "*" := mul.
  Lemma only_two_square_roots_choice x y z : x * x = z -> y * y = z -> x = y \/ x = opp y.
  Proof using Type*.
    intros.
    setoid_rewrite <-sub_zero_iff.
    eapply zero_product_zero_factor.
    fsatz.
  Qed.
End FieldSquareRoot.


Require Export Props.

Set Asymmetric Patterns. (* compatibility for Coq 8.4 pattern match *)

Definition funny_prop1 := forall n, forall (E : ev n), ev (n+4).

Definition funny_prop1' := forall n, forall (_ : ev n), ev (n+4).

Definition funny_prop1'' := forall n, ev n -> ev (n+4).

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

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

Check conj.

Theorem and_example :
  (ev 0) /\ (ev 4).
Proof.
  apply conj.
  apply ev_0.
  apply ev_SS. apply ev_SS. apply ev_0. Qed.

Print and_example.

Theorem and_example' :
  (ev 0) /\ (ev 4).
Proof.
  split.
    Case "left".  apply ev_0.
    Case "right". apply ev_SS. apply ev_SS. apply ev_0. Qed.

Theorem proj1 : forall P Q : Prop,
                  P /\ Q -> P.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  apply HP. Qed.

(* 練習問題: ★, optional (proj2) *)

Theorem proj2 : forall P Q : Prop,
                  P /\ Q -> Q.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  apply HQ. Qed.
(* ☐ *)

Theorem and_commut : forall P Q : Prop,
                       P /\ Q -> Q /\ P.
Proof.
  intros P Q H.
  inversion H as [HP HQ].
  split.
  apply HQ.
  apply HP. Qed.

Print and_commut.

(*
練習問題: ★★ (and_assoc)

次の証明では、inversionが、入れ子構造になった命題H : P ∧ (Q ∧ R)をどのようにHP:
P, HQ : Q, HR : R に分解するか、という点に注意しなががら証明を完成させなさい。
 *)

Theorem and_assoc : forall P Q R : Prop,
                      P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R H.
  inversion H as [HP [HQ HR]].
  split. split.
  apply HP. apply HQ. apply HR.
Qed.
(* ☐ *)

(*
練習問題: ★★, recommended (even_ev)

今度は、前の章で棚上げしていた even と ev の等価性をが別の
方向から証明してみましょう。ここで左側のandは我々が実際に注
目すべきものです。右のandは帰納法の仮定となって帰納法による
証明に結びついていくことになるでしょう。なぜこれが必要とな
るかは、左側のandをそれ自身で証明しようとして、行き詰まって
みるとかるでしょう。
 *)

Theorem even_ev : forall n : nat,
  (even n -> ev n) /\ (even (S n) -> ev (S n)).
Proof.
  intro n.
  unfold even.
  induction n as [| n'].
  (* n = 0 *)
    simpl. split.
    intros eq. apply ev_0.
    intros eq. discriminate eq.
  (* n = S n' *)
    inversion IHn' as [Hn' HSn'].
    split.
    apply HSn'.
    simpl.
    intros eeqH.
    apply ev_SS.
    apply (Hn' eeqH).
Qed.
(* ☐ *)

(*
練習問題: ★★

次の命題の証明を示すオブジェクトを作成しなさい。
 *)

Definition conj_fact : forall P Q R, P /\ Q -> Q /\ R -> P /\ R :=
  fun (P Q R : Prop) H0 H1 =>
    match H0 with
      | conj HP0 HQ0 =>
        match H1 with
          | conj HQ1 HR1 => conj P R HP0 HR1
        end
    end.
(* ☐ *)

(* Iff （両含意） *)

Definition iff (P Q : Prop) := (P -> Q) /\ (Q -> P).

Notation "P <-> Q" := (iff P Q)
                      (at level 95, no associativity) : type_scope.

Theorem iff_implies : forall P Q : Prop,
  (P <-> Q) -> P -> Q.
Proof.
  intros P Q H.
  inversion H as [HAB HBA]. apply HAB. Qed.

Theorem iff_sym : forall P Q : Prop,
  (P <-> Q) -> (Q <-> P).
Proof.
  intros P Q H.
  inversion H as [HAB HBA].
  split.
    Case "->". apply HBA.
    Case "<-". apply HAB. Qed.

(* 練習問題: ★ (iff_properties)

上の、 ↔ が対称であることを示す証明 (iff_sym) を使い、それが反射的であること、推移的であることを証明しなさい
。
 *)

Theorem iff_refl : forall P : Prop,
  P <-> P.
Proof.
  intro P.
  split.
  intro P0. apply P0.
  intro P0. apply P0.
Qed.

Theorem iff_trans : forall P Q R : Prop,
  (P <-> Q) -> (Q <-> R) -> (P <-> R).
Proof.
  intros P Q R H0 H1.
  inversion H0 as [ HPQ HQP ].
  inversion H1 as [ HQR HRQ ].
  split.
  intro p. apply (HQR (HPQ p)).
  intro r. apply (HQP (HRQ r)).
Qed.

(*
ヒント: もしコンテキストに iff を含む仮定があれば、 inversion を使ってそれを二つの含意の式に分割することがで
きます。 (なぜそうできるのか考えてみましょう。)
 *)
(* ☐ *)

(*
練習問題: ★★ (MyProp_iff_ev)

ここまで、MyProp や ev がこれらの命題がある種の数値を特徴づける（偶数、などの）ことを見てきました。次の
MyProp n ↔ ev n が任意の nで成り立つことを証明しなさい。お遊びのつもりでかまわないので、その証明を、単純明快
な証明、タクティックを使わないにような証明に書き換えてください。（ヒント：以前に使用した定理をうまく使えば、
１行だけでかけるはずです！）
 *)
Definition MyProp_iff_ev : forall n, MyProp n <-> ev n :=
  fun (n : nat) => conj (MyProp n -> ev n) (ev n -> MyProp n) (ev_MyProp n) (MyProp_ev n).
(* ☐ *)

(*
Coqのいくつかのタクティックは、証明の際に低レベルな操作を避けるため iff を特別扱いします。特に rewrite を iff
に使うと、単なる等式以上のものとして扱ってくれます。
 *)

(* 論理和、選言（Disjunction、OR） *)

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

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

Check or_introl.

Check or_intror.

Theorem or_commut : forall P Q : Prop,
  P \/ Q -> Q \/ P.
Proof.
  intros P Q H.
  inversion H as [HP | HQ].
    Case "right". apply or_intror. apply HP.
    Case "left". apply or_introl. apply HQ. Qed.

Theorem or_commut' : forall P Q : Prop,
  P \/ Q -> Q \/ P.
Proof.
  intros P Q H.
  inversion H as [HP | HQ].
    Case "right". right. apply HP.
    Case "left". left. apply HQ. Qed.

(*
練習問題: ★★ optional (or_commut'')

or_commut の証明オブジェクトがどのようになるか、書き出してみてください。（ただし、定義済みの証明オブジェクト
を Print を使って見てみたりしないこと。）
 *)
Definition or_commut'' : forall P Q : Prop, P \/ Q -> Q \/ P :=
  fun (P Q : Prop) H =>
    match H with
      | or_introl HP => or_intror Q P HP
      | or_intror HQ => or_introl Q P HQ
    end.
(* ☐ *)

Theorem or_distributes_over_and_1 : forall P Q R : Prop,
  P \/ (Q /\ R) -> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R. intros H. inversion H as [HP | [HQ HR]].
    Case "left". split.
      SCase "left". left. apply HP.
      SCase "right". left. apply HP.
    Case "right". split.
      SCase "left". right. apply HQ.
      SCase "right". right. apply HR. Qed.

(*
練習問題: ★★, recommended (or_distributes_over_and_2)
 *)

Theorem or_distributes_over_and_2 : forall P Q R : Prop,
  (P \/ Q) /\ (P \/ R) -> P \/ (Q /\ R).
Proof.
  intros P Q R H.
  inversion H as [ [PH0 | QH] [PH1 | RH] ].
  left. apply PH0.
  left. apply PH0.
  left. apply PH1.
  right. split. apply QH. apply RH.
Qed.
(* ☐ *)

(*
練習問題: ★ (or_distributes_over_and)
 *)

Theorem or_distributes_over_and : forall P Q R : Prop,
  P \/ (Q /\ R) <-> (P \/ Q) /\ (P \/ R).
Proof.
  intros P Q R.
  split.
  (* -> *)
    intro H.
    inversion H as [ PH | [ QH RH ] ].
    (* P *)
      split.
      left. apply PH.
      left. apply PH.
    (* Q /\ R*)
      split.
      right. apply QH.
      right. apply RH.
  (* <- *)
    intro H.
    inversion H as [ [PH0 | QH] [PH1 | RH] ].
    left. apply PH0.
    left. apply PH0.
    left. apply PH1.
    right. split. apply QH. apply RH.
Qed.
(* ☐ *)

(* ∧ 、 ∨ のandb 、orb への関連付け *)

Theorem andb_true__and : forall b c,
  andb b c = true -> b = true /\ c = true.
Proof.
  intros b c H.
  destruct b.
    Case "b = true". destruct c.
      SCase "c = true". apply conj. reflexivity. reflexivity.
      SCase "c = false". inversion H.
    Case "b = false". inversion H. Qed.

Theorem and__andb_true : forall b c,
  b = true /\ c = true -> andb b c = true.
Proof.
  intros b c H.
  inversion H.
  rewrite H0. rewrite H1. reflexivity. Qed.

(*
練習問題: ★ (bool_prop)
 *)

Theorem andb_false : forall b c,
  andb b c = false -> b = false \/ c = false.
Proof.
  intros b c H.
  destruct b.
    destruct c.
    (* b = true, c = true *)
      simpl in H.
      inversion H.

    (* b = true, c = false *)
      right. reflexivity.

  (* b = false *)
    left. reflexivity.
Qed.

Theorem orb_true : forall b c,
  orb b c = true -> b = true \/ c = true.
Proof.
  intros b c H.
  destruct b.
    left. reflexivity.

    destruct c.
      right. reflexivity.

      simpl in H.
      inversion H.
Qed.

Theorem orb_false : forall b c,
  orb b c = false -> b = false /\ c = false.
Proof.
  intros b c H.
  destruct b.
    destruct c.
      simpl in H. inversion H.

      simpl in H. inversion H.

    destruct c.
      simpl in H. inversion H.

      split. reflexivity. reflexivity.
Qed.
(* ☐ *)

(* 偽であるということ *)

(* Inductive False : Prop := . *)
Check False_ind.

(*
練習問題: ★ (False_ind_principle)

「偽」に関する帰納的な公理を何か思いつくことができますか？
 *)

(* 帰納的な命題は無い? *)

(* ☐ *)

Theorem False_implies_nonsense :
  False -> 2 + 2 = 5.
Proof.
  intros contra.
  inversion contra. Qed.

Theorem nonsense_implies_False :
  2 + 2 = 5 -> False.
Proof.
  intros contra.
  inversion contra. Qed.

Theorem ex_falso_quodlibet : forall (P:Prop),
  False -> P.
Proof.
  intros P contra.
  inversion contra. Qed.

(* 真であるということ *)

(*
練習問題: ★★ (True_induction)

True を、帰納的な命題として定義しなさい。あなたの定義に対してCoqはどのような帰納的原理を生成してくれるでしょ
うか。（直観的には True はただ当たり前のように根拠を示される命題であるべきです。代わりに、帰納的原理から帰納
的な定義を逆にたどっていくほうが近道だと気づくかもしれません。）
 *)

Inductive MyTrue : Prop :=
| T : MyTrue.

Check MyTrue_ind.
Check True_ind.

(* ☐ *)

(* 否定 *)

Definition not (P:Prop) := P -> False.

Notation "~ x" := (not x) : type_scope.

Check not.

Theorem not_False :
  ~ False.
Proof.
  unfold not. intros H. inversion H. Qed.

Theorem contradiction_implies_anything : forall P Q : Prop,
  (P /\ ~ P) -> Q.
Proof.
  intros P Q H. inversion H as [HP HNA]. unfold not in HNA.
  apply HNA in HP. inversion HP. Qed.

Theorem double_neg : forall P : Prop,
  P -> ~~ P.
Proof.
  intros P H. unfold not. intros G. apply G. apply H. Qed.

(*
練習問題: ★★, recommended (double_neg_inf)

double_neg の非形式的な証明を書きなさい。:

Theorem: P implies ~~P, for any proposition P.
 *)

(* Proof: ☐ *)

(*
練習問題: ★★, recommended (contrapositive)
 *)

Theorem contrapositive : forall P Q : Prop,
  (P -> Q) -> (~ Q -> ~ P).
Proof.
  intros P Q f nq p.
  apply (nq (f p)).
Qed.
(* ☐ *)

(*
練習問題: ★ (not_both_true_and_false)
 *)

Theorem not_both_true_and_false : forall P : Prop,
  ~ (P /\ ~ P).
Proof.
  intros P H.
  inversion H as [ p np ].
  apply (np p).
Qed.
(* ☐ *)

Theorem five_not_even :
  ~ ev 5.
Proof.
  unfold not. intros Hev5. inversion Hev5 as [|n Hev3 Heqn].
  inversion Hev3 as [|n' Hev1 Heqn']. inversion Hev1. Qed.

(*
練習問題: ★ ev_not_ev_S

定理 five_not_even は、「５は偶数ではない」というようなとても当たり前の事実を確認するものです。今度はもう少し
面白い例です。
 *)

Theorem ev_not_ev_S : forall n,
  ev n -> ~ ev (S n).
Proof.
  unfold not. intros n H. induction H.
  (* ev_0 *)  intro H. inversion H.
  (* ev_SS *)
    intro H2.
    inversion H2 as [| n' evH ].
    apply (IHev evH).
Qed.
(* ☐ *)

(*
練習問題: ★ (informal_not_PNP)

命題 ∀ P : Prop, ~(P ∧ ~P) の形式的でない証明を（英語で）書きなさい。
 *)

(* ☐ *)

Theorem classic_double_neg : forall P : Prop,
  ~~ P -> P.
Proof.
  intros P H. unfold not in H.
  Admitted.

(*
練習問題: ★★★★★, optional (classical_axioms)

さらなる挑戦を求める人のために、 Coq'Art book (p. 123) から一つ練習問題を取り上げてみます。次の五つの文は、よ
く「古典論理の特性」と考えられているもの（Coqにビルトインされている構成的論理の対極にあるもの）です。これらを
Coqで証明することはできませんが、古典論理を使うことが必要なら、矛盾なく「証明されていない公理」として道具に加
えることができます。これら五つの命題が等価であることを証明しなさい。
 *)

Definition peirce := forall P Q: Prop,
  ((P->Q)->P)->P.
Definition classic := forall P:Prop,
  ~~ P -> P.
Definition excluded_middle := forall P:Prop,
  P \/ ~P.
Definition de_morgan_not_and_not := forall P Q:Prop,
  ~(~ P /\ ~ Q) -> P \/ Q.
Definition implies_to_or := forall P Q:Prop,
  (P -> Q)  -> (~ P \/ Q).

(* ☐ *)

(* 不等であるということ *)

Notation "x <> y" := (~ (x = y)) : type_scope.

Theorem not_false_then_true : forall b : bool,
  b <> false -> b = true.
Proof.
  intros b H. destruct b.
  Case "b = true". reflexivity.
  Case "b = false".
    unfold not in H.
    apply ex_falso_quodlibet.
    apply H. reflexivity. Qed.

(*
練習問題: ★★, recommended (not_eq_beq_false)
 *)

Lemma eq_nat_dec :
  forall n m : nat, S n <> S m -> n <> m.
Proof.
  intros n m H eq. apply H.
  rewrite <- eq. reflexivity.
Qed.

Theorem not_eq_beq_false : forall n n' : nat,
     n <> n' ->
     beq_nat n n' = false.
Proof.
  intros n m.
  generalize dependent n.
  induction m as [| m' ].
  (* m = 0 *)
    destruct n as [| n' ].
    (* n = 0 *)
      intros H.
      apply ex_falso_quodlibet. apply H.
      reflexivity.
    (* n = S n' *)
      intros H. reflexivity.
  (* m = S m' *)
    destruct n as [| n' ].
    (* n = 0 *) intros H. reflexivity.
    (* n = S n' *)
      intros H. simpl.
      apply IHm'.
      apply eq_nat_dec.
      exact H.
Qed.
(* ☐ *)

(*
練習問題: ★★, optional (beq_false_not_eq)
 *)

Lemma eq_nat_inc :
  forall n m : nat, n <> m -> S n <> S m.
Proof.
  intros n m H eq. apply H.
  inversion eq as [ eq' ]. reflexivity.
Qed.

Theorem beq_false_not_eq : forall n m,
  false = beq_nat n m -> n <> m.
Proof.
  intros n m.
  generalize dependent n.
  induction m as [| m' ].
  (* m = 0 *)
    destruct n as [| n' ].
    (* n = 0 *) simpl. intros eqH eq. discriminate eqH.
    (* n = S n' *) simpl. intros eqH eq. discriminate eq.
  (* m = S m' *)
    destruct n as [| n' ].
    (* n = 0 *)
      simpl. intros eqH eq. discriminate eq.
    (* n = S n' *)
      simpl. intros eqH. apply eq_nat_inc.
      apply IHm'. exact eqH.
Qed.
(* ☐ *)

(* 存在量化子 *)

Inductive ex (X:Type) (P : X -> Prop) : Prop :=
  ex_intro : forall (witness:X), P witness -> ex X P.

Definition some_nat_is_even : Prop :=
  ex nat ev.

Definition sine : some_nat_is_even :=
  ex_intro _ ev 4 (ev_SS 2 (ev_SS 0 ev_0)).

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

Example exists_example_1 : exists n, n + (n * n) = 6.
Proof.
  apply ex_intro with (witness:=2).
  reflexivity. Qed.

Example exists_example_1' : exists n, n + (n * n) = 6.
Proof.
  exists 2.
  reflexivity. Qed.

Theorem exists_example_2 :
  forall n, (exists m, n = 4 + m) -> (exists o, n = 2 + o).
Proof.
  intros n H.
  inversion H as [m Hm].
  exists (2 + m).
  apply Hm. Qed.

(*
練習問題: ★ (english_exists)

英語では、以下の命題は何を意味しているでしょうか？
      ex nat (fun n => ev (S n))

次の証明オブジェクトの定義を完成させなさい
 *)

Definition p : ex nat (fun n => ev (S n)) :=
  ex_intro _ (fun n => ev (S n)) 1 (ev_SS 0 ev_0).
(* ☐ *)

(*
練習問題: ★ (dist_not_exists)

"全ての x についてP が成り立つ" ということと " P を満たさない x は存在しない" というこ
とが等価であることを証明しなさい。
 *)

Theorem dist_not_exists : forall (X:Type) (P : X -> Prop),
  (forall x, P x) -> ~ (exists x, ~ P x).
Proof.
  intros X P PH NH.
  inversion NH as [x NP].
  apply NP. apply PH.
Qed.
(* ☐ *)

(*
練習問題: ★★★, optional (not_exists_dist)

一方、古典論理の「排中律（law of the excluded middle）」が必要とされる場合もあります。
 *)

Theorem not_exists_dist :
  excluded_middle ->
  forall (X:Type) (P : X -> Prop),
    ~ (exists x, ~ P x) -> (forall x, P x).
Proof.
  intros em X P NNP x.
  destruct (em (P x)) as [XP | NXP].
  (* P x *) exact XP.
  (* ~ P x *)
    apply ex_falso_quodlibet.
    apply NNP. exists x. exact NXP.
Qed.
(* ☐ *)

(*
練習問題: ★★ (dist_exists_or)

存在量化子が論理和において分配法則を満たすことを証明しなさい。
 *)

Theorem dist_exists_or : forall (X:Type) (P Q : X -> Prop),
  (exists x, P x \/ Q x) <-> (exists x, P x) \/ (exists x, Q x).
Proof.
  intros X P Q.
  split.

  (* -> *)
  intros ePorQ. inversion ePorQ as [ x orH ].
  destruct orH as [ PX | QX ].
  (* P x *) left.  exists x. exact PX.
  (* Q x *) right. exists x. exact QX.

  (* <- *)
  intros EPorEQ.
  destruct EPorEQ as [ EP | EQ ].

  (* P x *)
  inversion EP as [ x PX ].
  exists x. left.  exact PX.

  (* Q x *)
  inversion EQ as [ x QX ].
  exists x. right. exact QX.
Qed.
(* ☐ *)

(* 等しいということ（同値性） *)

Module MyEquality.

Inductive eq (X:Type) : X -> X -> Prop :=
  refl_equal : forall x, eq X x x.

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

Inductive eq' (X:Type) (x:X) : X -> Prop :=
  refl_equal' : eq' X x x.

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

(*
練習問題: ★★★, optional (two_defs_of_eq_coincide)

これら二つの定義が等価であることを確認しなさい。
 *)

Theorem two_defs_of_eq_coincide : forall (X:Type) (x y : X),
  x = y <-> x =' y.
Proof.
  intros X x y.
  split.

  (* -> *)
  intros eqH.
  inversion eqH as [ x' y' eqT ].
  apply refl_equal'.

  (* <- *)
  intros eqH.
  inversion eqH as [ eqT ].
  apply refl_equal.
Qed.
(* ☐ *)

Check eq'_ind.

Definition four : 2 + 2 = 1 + 3 :=
  refl_equal nat 4.
Definition singleton :
  forall (X:Set) (x:X), [] ++ [x] = x::[] :=
  fun (X:Set) (x:X) => refl_equal (list X) [x].

End MyEquality.

(* Inversion 再び *)

(* 命題としての関係 *)

Module LeFirstTry.

Inductive le : nat -> nat -> Prop :=
| le_n : forall n, le n n
| le_S : forall n m, (le n m) -> (le n (S m)).

End LeFirstTry.

Inductive le (n:nat) : nat -> Prop :=
| le_n : le n n
| le_S : forall m, (le n m) -> (le n (S m)).

Notation "m <= n" := (le m n).

Check le_ind.

Theorem test_le1 :
  3 <= 3.
Proof.
  apply le_n. Qed.

Theorem test_le2 :
  3 <= 6.
Proof.
  apply le_S. apply le_S. apply le_S. apply le_n. Qed.

Theorem test_le3 :
  ~ (2 <= 1).
Proof.
  intros H. inversion H. inversion H1. Qed.

Definition lt (n m:nat) := le (S n) m.

Notation "m < n" := (lt m n).

Inductive square_of : nat -> nat -> Prop :=
  sq : forall n:nat, square_of n (n * n).

Inductive next_nat (n:nat) : nat -> Prop :=
| nn : next_nat n (S n).

Inductive next_even (n:nat) : nat -> Prop :=
| ne_1 : ev (S n) -> next_even n (S n)
| ne_2 : ev (S (S n)) -> next_even n (S (S n)).

(*
練習問題: ★★, recommended (total_relation)

二つの自然数のペア同士の間に成り立つ帰納的な関係 total_relation を定義しなさ
い。
 *)

Lemma le_dec_R :
  forall {n m}, n <= S m -> n <= m \/ n = S m.
(* -> *)
Proof.
  intros n m H0.
  inversion H0 as [ eq | m' H1 eq ].
  (* le_n *) right. reflexivity.
  (* le_S *) left.  exact H1.
Qed.

Lemma le_dec_L :
  forall {n m}, n <= m \/ n = S m -> n <= S m.
(* <- *)
Proof.
  intros n m H.
  destruct H as [LE | EQ].
  (* le *) apply (le_S n m LE).
  (* eq *) rewrite <- EQ. apply le_n.
Qed.

Lemma le_dec :
  forall {n m}, n <= S m <-> n <= m \/ n = S m.
Proof.
  split. apply le_dec_R. apply le_dec_L.
Qed.

Lemma inc_le_trans :
  forall n m, n <= m <-> S n <= S m.
Proof.
  split.

  (* -> *)
  intros H.
  induction H as [ EQ | m' LE ].
  (* EQ *) apply le_n.
  (* LE *) apply le_S. apply IHLE.

  (* <- *)
    generalize dependent n.
    induction m as [| m'].
    (* m = 0 *)
      intros n H.
      inversion H as [eq | m' L].
      (* le_n *) apply le_n.
      (* le_S *) inversion L.

    (* m = S m' *)
      intros n H.
      destruct (le_dec_R H) as [ LE | EQ ].
      (* S n <= S m' *) apply le_S. apply IHm'. exact LE.
      (* S n = S (S m') *) inversion EQ as [ EQ1 ]. apply le_n.
Qed.

Lemma inc_le_trans_LR :
  forall n m, n <= m -> S n <= S m.
Proof.
  intros n m.
  destruct (inc_le_trans n m) as [ LR RL ].
  exact LR.
Qed.

Lemma inc_le_trans_RL :
  forall n m,  S n <= S m -> n <= m.
Proof.
  intros n m.
  destruct (inc_le_trans n m) as [ LR RL ].
  exact RL.
Qed.

Lemma logic_O_le_n :
  forall n, 0 <= n.
Proof.
  induction n as [| n'].
  apply le_n.
  apply le_S.
  apply IHn'.
Qed.

Inductive total_relation (R : nat -> nat -> Prop) (a b:nat) : Prop :=
  total_order : R a b \/ R b a -> total_relation R a b.

Theorem total_order_le :
  forall a b, total_relation le a b.
Proof.
  intros a b.
  apply total_order.
  generalize dependent b.
  induction a as [| a' IHa ].
  (* a = 0 *)
    intro b. left. induction b as [| b' IHb].
      (* b = 0 *)    apply le_n.
      (* b = S b' *) apply le_S. apply IHb.
  (* a = S a' *)
    intro b.
    destruct b as [| b'].
      (* b = 0 *)    right. apply logic_O_le_n.
      (* b = S b' *)
        destruct (IHa b') as [ ABH | BAH ]
        ; [ left | right ]
        ; apply inc_le_trans_LR
        ; [ (* a' <= b' *) exact ABH
          | (* b' <= a' *) exact BAH
          ].
Qed.
(* ☐ *)

(*
練習問題: ★★ (empty_relation)

自然数の間では決して成り立たない関係 empty_relation を帰納的に定義しなさい。
 *)

Inductive empty_relation (a b:nat) : Prop :=
  empty_relation_0 : S a = b /\ S b = a -> empty_relation a b.

(* ☐ *)

(*
練習問題: ★★★, recommended (R_provability)
 *)

Module R.

(*
次は三つや四つの値の間に成り立つ関係を同じように定義してみましょう。例えば、
次のような数値の三項関係が考えられます。

Inductive R : nat → nat → nat → Prop :=
   | c1 : R 0 0 0
   | c2 : ∀ m n o, R m n o → R (S m) n (S o)
   | c3 : ∀ m n o, R m n o → R m (S n) (S o)
   | c4 : ∀ m n o, R (S m) (S n) (S (S o)) → R m n o
   | c5 : ∀ m n o, R m n o → R n m o.
*)

Inductive R : nat -> nat -> nat -> Prop :=
| c1 : R 0 0 0
| c2 : forall m n o, R m n o -> R (S m) n (S o)
| c3 : forall m n o, R m n o -> R m (S n) (S o)
| c4 : forall m n o, R (S m) (S n) (S (S o)) -> R m n o
| c5 : forall m n o, R m n o -> R n m o.

(*
  * 次の命題のうち、この関係を満たすと証明できると言えるのはどれでしょうか。
      + R 1 1 2
      + R 2 2 6
 *)

(* R 1 1 2 *)
(* R 2 2 6 *)

(*
  * この関係 R の定義からコンストラクタ c5 を取り除くと、証明可能な命題の範囲
    はどのように変わるでしょうか？端的に（１文で）説明しなさい。
 *)
(*
  * この関係 R の定義からコンストラクタ c4 を取り除くと、証明可能な命題の範囲
    はどのように変わるでしょうか？端的に（１文で）説明しなさい。
 *)

(* ☐ *)

(*
練習問題: ★★★, optional (R_fact)

関係 R の、等値性に関する特性をあげ、それを証明しなさい。それは、もし R m n o
が true なら m についてどんなことが言えるでしょうか？ n や o についてはどうで
しょうか？その逆は？
 *)

Theorem m_plus_n_eq_o_left :
  forall m n o, R m n o -> m + n = o.
Proof.
  intros m n o H.
  induction H as [| m' n' o' H101 |  m' n' o' H011 |  m' n' o' H112 |  m' n' o' Hswap ].
  (* c1 *) reflexivity.
  (* c2 *) simpl. rewrite -> IHH101. reflexivity.
  (* c3 *) rewrite <- (plus_n_Sm m' n'). rewrite -> IHH011. reflexivity.
  (* c4 *)
    simpl in IHH112. rewrite <- (plus_n_Sm m' n') in IHH112.
    inversion IHH112. reflexivity.
  (* c5 *) rewrite -> plus_comm. apply IHHswap.
Qed.

Lemma m_plus_n_O' :
  forall m n, m + n = 0 -> m = 0.
Proof.
  destruct m as [| m'].
  (* m = 0 *) reflexivity.
  (* m = S m' *)
    intros n H.
    simpl in H. inversion H.
Qed.

Lemma m_plus_n_O :
  forall m n, m + n = 0 -> m = 0 /\ n = 0.
Proof.
  split.

  (* m = 0 *)
  apply (m_plus_n_O' m n).
  exact H.

  (* n = 0 *)
  rewrite -> (plus_comm m n) in H.
  apply (m_plus_n_O' n m).
  exact H.
Qed.

Theorem m_plus_n_eq_o_right :
  forall m n o, m + n = o -> R m n o.
Proof.
  intros m n o H.
  generalize dependent m.
  generalize dependent n.

  induction o as [| o'].
  (* o = 0 *)
    intros n m H.
    apply m_plus_n_O in H. inversion H.
    rewrite -> H0. rewrite -> H1.
    apply c1.

  (* o = S o' *)
    intros n m H.

    (* c2 *)
      destruct m as [| m'].
      (* m = 0*)
        destruct n as [| n'].
        (* n = 0 *) inversion H.
        (* n = S n'*)
        simpl in H. apply c3. apply (IHo' n' 0). inversion H. reflexivity.

      (* m = S m' *)
        apply c2. apply IHo'. simpl in H. inversion H. reflexivity.
Qed.

(* true なら -> 真なら *)

(* ☐ *)

End R.

(*
練習問題: ★★★, recommended (all_forallb)

リストに関する属性 all を定義しなさい。それは、型 X と属性 P : X → Prop をパ
ラメータとし、 all X P l が「リスト l の全ての要素が属性 P} を満たす」とする
ものです。
 *)

Inductive all (X : Type) (P : X -> Prop) : list X -> Prop :=
| all_nil  : all X P []
| all_cons : forall x xs, P x -> all X P xs -> all X P (x :: xs)
.

(*
Poly.v の練習問題 forall_exists_challenge に出てきた関数 forallb を思い出して
みましょう。

Fixpoint forallb {X : Type} (test : X → bool) (l : list X) : bool :=
  match l with
    | [] => true
    | x :: l' => andb (test x) (forallb test l')
  end.
 *)

(*
属性 all を使って関数 forallb の仕様を書き、それを満たすことを証明しなさい。
できるだけその仕様が厳格になるようにすること。

関数 forallb の重要な性質が、あなたの仕様から洩れている、ということはありませ
んか？
 *)

Theorem all_forallb :
  forall {X} (test : X -> bool) (xs : list X),
    forallb test xs = true <-> all X (fun x => test x = true) xs.
Proof.
  intros X test xs. split.

  (* -> *)
  induction xs as [| x xs'].
  (* [] *)  intros EQ. apply all_nil.
  (* x :: xs' *)
    simpl.
    intros EQ.
    destruct (test x) as [] eqn: TxH.
    (* true *)
      apply all_cons. apply TxH.
      apply IHxs'. apply EQ.
    (* false *) inversion EQ.

  (* <- *)
  induction xs as [| x xs'].
  (* [] *) reflexivity.
  (* x :: xs' *)
    intros H.
    inversion H as [| x0 xs0 P AP].
    simpl. rewrite -> P.
    apply IHxs'. apply AP.
Qed.

(* ☐ *)

(*
練習問題: ★★★★, optional (filter_challenge)

Coq の主な目的の一つは、プログラムが特定の仕様を満たしていることを証明するこ
とです。それがどういうことか、filter 関数の定義が仕様を満たすか証明してみまし
ょう。まず、その関数の仕様を非形式的に書き出してみます。

集合 X と関数 test: X→bool、リストl とその型 list X を想定する。さらに、l が
二つのリスト l1 と l2 が順序を維持したままマージされたもので、リスト l1 の要
素はすべて test を満たし、 l2 の要素はすべて満たさないとすると、filter test l
= l1 が成り立つ。

リスト l が l1 と l2 を順序を維持したままマージしたものである、とは、それが
l1 と l2 の要素をすべて含んでいて、しかも互いに入り組んではいても l1 、 l2 の
要素が同じ順序になっている、ということです。例えば、

    [1,4,6,2,3]

は、以下の二つを順序を維持したままマージしたものです。
    [1,6,2]

と、
    [4,3]

課題は、この仕様をCoq の定理の形に書き直し、それを証明することです。（ヒント
：まず、一つのりすとが二つのリストをマージしたものとなっている、ということを
示す定義を書く必要がありますが、これは帰納的な関係であって、 Fixpoint で書く
ようなものではありません。）
 *)

Inductive in_order_merge {X:Type} : list X -> list X -> list X -> Prop :=
| merge_nil : in_order_merge [] [] []
| merge_cons_L : forall (x:X) (l1 l2 l : list X),
                 in_order_merge l1 l2 l -> in_order_merge (x::l1) l2 (x::l)
| merge_cons_R : forall (x:X) (l1 l2 l : list X),
                 in_order_merge l1 l2 l -> in_order_merge l1 (x::l2) (x::l)
.

(*
集合 X と関数 test: X→bool、リストl とその型 list X を想定する。さらに、l が
二つのリスト l1 と l2 が順序を維持したままマージされたもので、リスト l1 の要
素はすべて test を満たし、 l2 の要素はすべて満たさないとすると、filter test l
= l1 が成り立つ。
 *)

Theorem filter_challenge :
  forall {X:Type} (test : X -> bool) (l l1 l2 : list X),
    in_order_merge l1 l2 l ->
    all X (fun x => test x = true) l1 ->
    all X (fun x => test x = false) l2 ->
    filter test l = l1.
Proof.
  intros X test.
  induction l as [| x xs] eqn: LEQ.
  (* [] *) intros l1 l2 M. inversion M. reflexivity.
  (* x :: xs*)
    intros l1 l2 M T F.
    inversion M as [| x0 xsL xsR xs0 ML E0 E1 E2 | x0 xsL xsR xs0 MR E0 E1 E2].
    (* L *)

    (* R *)
Admitted.
(* ☐ *)

(*
練習問題: ★★★★★, optional (filter_challenge_2)

filter の振る舞いに関する特性を別の切り口で表すとこうなります。「test の結果
が true なる要素だけでできた、リスト l のすべての部分リストの中で、filter
test l が最も長いリストである。」これを形式的に記述し、それを証明しなさい。
 *)
(* ☐ *)

(*
練習問題: ★★★★, optional (no_repeats)

次の、帰納的に定義された命題は、

Inductive appears_in {X:Type} (a:X) : list X → Prop :=
  | ai_here : ∀ l, appears_in a (a::l)
  | ai_later : ∀ b l, appears_in a l → appears_in a (b::l).

値 a がリスト l の要素として少なくとも一度は現れるということを言うための、精
確な方法を与えてくれます。

次の二つはappears_in に関するウォームアップ問題です。
 *)

Inductive appears_in {X:Type} (a:X) : list X -> Prop :=
  | ai_here : forall l, appears_in a (a::l)
  | ai_later : forall b l, appears_in a l -> appears_in a (b::l).

Lemma appears_in_app :
  forall {X:Type} (xs ys : list X) (x:X),
     appears_in x (xs ++ ys) -> appears_in x xs \/ appears_in x ys.
Proof.
Admitted.

Lemma app_appears_in :
  forall {X:Type} (xs ys : list X) (x:X),
    appears_in x xs \/ appears_in x ys -> appears_in x (xs ++ ys).
Proof.
Admitted.

(*
では、 appears_in を使って命題 disjoint X l1 l2 を定義してください。これは、
型 X の二つのリスト l1 、 l2 が共通の要素を持たない場合にのみ証明可能な命題で
す。

次は、 appears_in を使って帰納的な命題 no_repeats X l を定義してください。こ
れは, 型 X のリスト l の中のどの要素も、他の要素と異なっている場合のみ証明で
きるような命題です。例えば、 no_repeats nat [1,2,3,4] や no_repeats bool []
は証明可能ですが、 no_repeats nat [1,2,1] や no_repeats bool [true,true] は証
明できないようなものです。

最後に、disjoint、 no_repeats、 ++ （リストの結合）の三つを使った、何か面白い
定理を考えて、それを証明してください。
 *)

(* ☐ *)

(* 少し脱線: <= と < についてのさらなる事実 *)

(* 練習問題: ★★, optional (le_exercises) *)

Theorem O_le_n :
  forall n, 0 <= n.
Proof.
  induction n as [| n'].
  apply le_n.
  apply le_S.
  apply IHn'.
Qed.

Theorem n_le_m__Sn_le_Sm :
  forall n m, n <= m -> S n <= S m.
Proof.
  intros n m H.
  induction H as [EQ | m' LE].
  (* EQ *) apply le_n.
  (* LE *) apply le_S. apply IHLE.
Qed.

Theorem Sn_le_Sm__n_le_m :
  forall n m, S n <= S m -> n <= m.
Proof.
  intros n m. generalize dependent n.
  induction m as [| m'].
  (* m = 0 *)
    intros n H.
    inversion H as [eq | m' L].
    (* le_n *) apply le_n.
    (* le_S *) inversion L.

  (* m = S m' *)
    intros n H.
    destruct (le_dec_R H) as [LE | EQ].
    (* S n <= S m' *) apply le_S. apply IHm'. apply LE.
    (* S n = S (S m') *) inversion EQ as [ EQ1 ]. apply le_n.
Qed.

Theorem le_plus_l :
  forall a b, a <= a + b.
Proof.
  induction a as [| a'].
  (* a = 0 *) apply O_le_n.
  intro b.
  rewrite <- (plus_1_l a').
  rewrite <- (plus_assoc 1 a' b).
  simpl.
  apply n_le_m__Sn_le_Sm.
  apply IHa'.
Qed.

Theorem plus_lt :
  forall n1 n2 m,
    n1 + n2 < m -> n1 < m /\ n2 < m.
Proof.
  intros n1 n2 m.
  generalize dependent n2.
  generalize dependent n1.
  induction m as [| m'].
  (* m = 0 *) intros n1 n2 H. inversion H.
  (* m = S m' *)
    intros n1 n2 H.
    apply le_dec_R in H.
    destruct H as [LE | EQ].
    (* LE *)
    apply IHm' in LE.
    inversion LE as [n1H n2H].
    split.
      apply le_S. apply n1H.
      apply le_S. apply n2H.

    (* EQ *)
    rewrite <- EQ.
    split.
      apply n_le_m__Sn_le_Sm. apply le_plus_l.
      apply n_le_m__Sn_le_Sm. rewrite plus_comm. apply le_plus_l.
Qed.

Theorem lt_S :
  forall n m, n < m -> n < S m.
Proof.
  intros n m H. apply le_S. apply H.
Qed.

Theorem ble_nat_true :
  forall n m, ble_nat n m = true -> n <= m.
Proof.
  induction n as [| n'].
  (* n = 0 *) intros m H. apply O_le_n.
  (* n = S n' *)
    destruct m as [| m'].
    (* m = 0 *) intros H. inversion H.
    (* m = S m' *)
      simpl. intros H.
      apply n_le_m__Sn_le_Sm. apply IHn'.  apply H.
Qed.

Theorem ble_nat_n_Sn_false :
  forall n m,
    ble_nat n (S m) = false ->
    ble_nat n m = false.
Proof.
  intros n m.
  generalize dependent n.
  induction m as [| m'].
  (* m = 0 *)
    destruct n as [| n'].
    (* n = 0 *) simpl. intro H. inversion H.
    (* n = S n' *) simpl. intro H. reflexivity.

  (* m = S m' *)
    intros n H.
    destruct n as [| n'].
    (* n = 0 *) simpl in H. inversion H.
    (* n = S n' *)
      simpl. apply IHm'.
      simpl in H. apply H.
Qed.

Theorem ble_nat_false :
  forall n m,
    ble_nat n m = false -> ~(n <= m).
Proof.
  induction n as [| n'].
  (* n = 0 *)
    destruct m as [| m'].
    (* 0 *)   simpl. intro H. inversion H.
    (* S m'*) simpl. intro H. inversion H.
  (* n = S n' *)
    intros m H.
    destruct m as [| m'].
    (* 0 *) intro LE. inversion LE.
    (* S m' *)
      simpl in H.
      intro LE.
      apply Sn_le_Sm__n_le_m in LE.
      apply (IHn' m').
      apply H. apply LE.
Qed.
(* ☐ *)

(* 練習問題: ★★★, recommended (nostutter) *)

(*
述語の帰納的な定義を定式化できるようになるというのは、これから先の学習に必要なスキ
ルになってきます。

この練習問題は、何の力も借りず自力で解いてください。もし誰かの力を借りてしまった場
合は、そのことをコメントに書いておいてください。

同じ数値が連続して現れるリストを "stutters" （どもったリスト）と呼ぶことにします。
述語 "nostutter mylist" は、 mylist が「どもったリスト」でないことを意味しています
。nostutter の帰納的な定義を記述しなさい。（これは以前の練習問題に出てきた
no_repeats という述語とは異なるものです。リスト 1,4,1 は repeats ではありますが
stutter ではありません。）
 *)

Inductive nostutter: list nat -> Prop :=

.

(*
できた定義が、以下のテストを通過することを確認してください。通過できないものがあっ
たら、定義を修正してもかまいません。あなたの書いた定義が、正しくはあるけれど私の用
意した模範解答と異なっているかもしれません。その場合、このテストを通過するために別
の証明を用意する必要があります。

以下の Example にコメントとして提示された証明には、色々な種類の nostutter の定義に
対応できるようにするため、まだ説明していないタクティックがいくつか使用されています
。まずこれらのコメントをはずしただけの状態で確認できればいいのですが、もしそうした
いなら、これらの証明をもっと基本的なタクティックで書き換えて証明してもかまいません
。
 *)

Example test_nostutter_1: nostutter [3,1,4,1,5,6].
Admitted.

Example test_nostutter_2: nostutter [].
Admitted.

Example test_nostutter_3: nostutter [5].
Admitted.

Example test_nostutter_4: not (nostutter [3,1,1,4]).
Admitted.
(* ☐ *)

(* 練習問題: ★★★★, optional (pigeonhole principle) *)

(*
「鳩の巣定理（ "pigeonhole principle" ）」は、「数えるあげる」ということについての
基本的な事実を提示しています。「もし n 個の鳩の巣に n 個より多い数のものを入れよう
とするなら、どのような入れ方をしてもいくつかの鳩の巣には必ず一つ以上のものが入るこ
とになる。」というもので、この、数値に関する見るからに自明な事実を証明するにも、な
かなか自明とは言えない手段が必要になります。我々は既にそれを知っているのですが...

まず、補題を二つほど証明しておきます。（既に数値のリストについては証明済みのもので
すが、任意のリストについてはのものはまだないので）
 *)

Lemma app_length :
  forall {X:Type} (l1 l2 : list X),
    length (l1 ++ l2) = length l1 + length l2.
Proof.
Admitted.

Lemma appears_in_app_split :
  forall {X:Type} (x:X) (l:list X),
    appears_in x l ->
    exists l1, exists l2, l = l1 ++ (x::l2).
Proof.
Admitted.

(*
そして、述語 repeats の定義をします（以前の練習問題 no_repeats に類似したものです
）。それは repeats X l が、「 l の中に少なくとも一組の同じ要素（型 X の）を含む」
という主張となるようなものです。
 *)

Inductive repeats {X:Type} : list X -> Prop :=

.

(*
この「鳩の巣定理」を定式化する方法を一つ挙げておきましょう。リスト l2 が鳩の巣に貼
られたラベルの一覧を、リスト l1 はそのラベルの、アイテムへの割り当ての一覧を表して
いるとします。もしラベルよりも沢山のアイテムがあったならば、少なくとも二つのアイテ
ムに同じラベルが貼られていることになります。おそらくこの証明には「排中律（
excluded_middle ）」が必要になるでしょう。
 *)

Theorem pigeonhole_principle:
  forall {X:Type} (l1 l2:list X),
    excluded_middle ->
    (forall x, appears_in x l1 -> appears_in x l2) ->
    length l2 < length l1 ->
    repeats l1.
Proof. intros X l1. induction l1.
Admitted.
(* ☐ *)

(* 選択課題 *)

(* ∧ や ∨ のための帰納法の原理 *)

(* 練習問題: ★ (and_ind_principle) *)

(*
連言（ conjunction ）についての帰納法の原理を予想して、確認しなさい。
 *)

(* ☐ *)

(* 練習問題: ★ (or_ind_principle) *)

(*
選言（ disjunction ）についての帰納法の原理を予想して、確認しなさい。
 *)

(* ☐ *)

Check and_ind.

Inductive or' (P Q : Prop) : Prop :=
| or'_introl : P -> or' P Q
| or'_intror : Q -> or' P Q
.

Check or'_ind.

Definition nrect :=
fun (P : nat -> Type) (f : P 0)
    (f0 : forall n : nat, P n -> P(S n)) =>
  fix F (n : nat) : P n :=
  match n return (P n) with
    | 0 => f
    | S n0 => f0 n0 (F n0)
  end.

(* 帰納法のための明白な証明オブジェクト *)


(*************************************************************)
(*      This file is distributed under the terms of the      *)
(*      GNU Lesser General Public License Version 2.1        *)
(*************************************************************)
(*    Benjamin.Gregoire@inria.fr Laurent.Thery@inria.fr      *)
(*************************************************************)

(************************************************************************

    Definition of the Euler Totient function

*************************************************************************)
Require Import ZArith.
Require Export Znumtheory.
Require Import Tactic.
Require Export ZSum.

Open Scope Z_scope.

Definition phi n := Zsum 1 (n - 1) (fun x => if rel_prime_dec x n then 1 else 0).

Theorem phi_def_with_0:
  forall n, 1< n -> phi n = Zsum 0 (n - 1) (fun x => if rel_prime_dec x n then 1 else 0).
intros n H; rewrite Zsum_S_left; auto with zarith.
case (rel_prime_dec 0 n); intros H2.
contradict H2; apply not_rel_prime_0; auto.
rewrite Zplus_0_l; auto.
Qed.

Theorem phi_pos: forall n, 1 < n -> 0 < phi n.
intros n H; unfold phi.
case (Zle_lt_or_eq 2 n); auto with zarith; intros H1; subst.
rewrite Zsum_S_left; simpl; auto with zarith.
case (rel_prime_dec 1 n); intros H2.
apply Z.lt_le_trans with (1 + 0); auto with zarith.
apply Zplus_le_compat_l.
pattern 0 at 1; replace 0 with  ((1 + (n - 1) - 2) * 0); auto with zarith.
rewrite <- Zsum_c; auto with zarith.
apply Zsum_le; auto with zarith.
intros x H3;  case (rel_prime_dec x n); auto with zarith.
case H2; apply rel_prime_1; auto with zarith.
rewrite Zsum_nn.
case (rel_prime_dec (2 - 1) 2); auto with zarith.
intros H1; contradict H1; apply rel_prime_1; auto with zarith.
Qed.

Theorem phi_le_n_minus_1: forall n, 1 < n -> phi n <= n - 1.
intros n H; replace (n-1) with ((1 +  (n - 1) - 1) * 1); auto with zarith.
rewrite <- Zsum_c; auto with zarith.
unfold phi; apply Zsum_le; auto with zarith.
intros x H1; case (rel_prime_dec x n); auto with zarith.
Qed.

Theorem prime_phi_n_minus_1: forall n, prime n -> phi n = n - 1.
intros n H; replace (n-1) with ((1 +  (n - 1) - 1) * 1); auto with zarith.
assert (Hu: 1 <= n - 1).
assert (2 <= n); auto with zarith.
apply prime_ge_2; auto.
rewrite <- Zsum_c; auto with zarith; unfold phi; apply Zsum_ext; auto.
intros x  (H2, H3); case H; clear H; intros H H1.
generalize (H1 x); case (rel_prime_dec x n); auto with zarith.
intros H6 H7; contradict H6; apply H7; split; auto with zarith.
Qed.

Theorem phi_n_minus_1_prime: forall n, 1 < n -> phi n = n - 1 -> prime n.
intros n H H1; case (prime_dec n); auto; intros H2.
assert (H3: phi n < n - 1); auto with zarith.
replace (n-1) with ((1 +  (n - 1) - 1) * 1); auto with zarith.
assert (Hu: 1 <= n - 1); auto with zarith.
rewrite <- Zsum_c; auto with zarith; unfold phi; apply Zsum_lt; auto.
intros x _; case (rel_prime_dec x n); auto with zarith.
case not_prime_divide with n; auto.
intros x (H3, H4); exists x; repeat split; auto with zarith.
case (rel_prime_dec x n); auto with zarith.
intros H5; absurd (x = 1 \/ x = -1); auto with zarith.
case (Zis_gcd_unique  x n x 1); auto.
apply Zis_gcd_intro; auto; exists 1; auto with zarith.
contradict H3; rewrite H1; auto with zarith.
Qed.

Theorem phi_divide_prime: forall n, 1 < n -> (n - 1 | phi n) -> prime n.
intros n H1 H2; apply  phi_n_minus_1_prime; auto.
apply Zle_antisym.
apply phi_le_n_minus_1; auto.
apply Zdivide_le; auto; auto with zarith.
apply phi_pos; auto.
Qed.


Require Import Bool Arith List Cpdt.CpdtTactics.
Set Implicit Arguments.
Set Asymmetric Patterns.

Inductive binop : Set := Plus | Times.
Inductive exp : Type :=
| Const : nat -> exp
| Binop : binop -> exp -> exp -> exp.

Definition binopDenote (b : binop) : nat -> nat -> nat :=
  match b with
  | Plus => plus
  | Times => mult
  end.

Fixpoint expDenote (e : exp): nat :=
  match e with
  | Const n => n
  | Binop b e1 e2 => (binopDenote b) (expDenote e1) (expDenote e2)
  end.

Eval simpl in expDenote (Const 42).
Eval simpl in expDenote (Binop Times (Const 5) (Binop Plus (Const 2) (Const 3))).

Inductive instr : Set :=
| iConst : nat -> instr
| iBinop : binop -> instr.

Definition prog := list instr.
Definition stack := list nat.

Definition instrDenote (i : instr) (s : stack) : option stack :=
  match i with
  | iConst n => Some (n :: s)
  | iBinop b =>
    match s with
    | arg1 :: arg2 :: s' => Some ((binopDenote b) arg1 arg2 :: s')
    | _ => None
    end
  end.

Fixpoint progDenote (p : prog) (s : stack) : option stack :=
  match p with
  | nil => Some s
  | i :: p' =>
    match instrDenote i s with
      | None => None
      | Some s' => progDenote p' s'
    end
  end.

Fixpoint compile (e : exp) : prog :=
  match e with
  | Const n => iConst n :: nil
  | Binop b e1 e2 => compile e2 ++ compile e1 ++ iBinop b :: nil
  end.

Eval simpl in progDenote (compile (Binop Times (Binop Plus (Const 2) (Const 2)) (Const 7))) nil.

Theorem compile_correct : forall e, progDenote (compile e) nil = Some (expDenote e :: nil).
Abort.

Lemma compile_correct' : forall e p s,
    progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
  induction e.
  intros.
  unfold expDenote.
  unfold progDenote at 1.
  simpl.
  fold progDenote.
  reflexivity.
  intros.
  unfold compile.
  fold compile.
  unfold expDenote.
  fold expDenote.
  Check app_assoc_reverse.
  rewrite app_assoc_reverse.
  rewrite IHe2.
  rewrite app_assoc_reverse.
  rewrite IHe1.
  unfold progDenote at 1.
  simpl.
  fold progDenote.
  reflexivity.
Qed.

Lemma compile_crush : forall e p s,
    progDenote (compile e ++ p) s = progDenote p (expDenote e :: s).
  induction e; crush.
Qed.

Theorem compile_correct : forall e, progDenote (compile e) nil = Some (expDenote e :: nil).
  intros.
  Check app_nil_end.
  rewrite (app_nil_end (compile e)).
  rewrite compile_correct'.
  reflexivity.
Qed.

Inductive type : Set := Nat | Bool.

Inductive tbinop : type -> type -> type -> Set :=
| TPlus : tbinop Nat Nat Nat
| TTimes : tbinop Nat Nat Nat
| TEq : forall t, tbinop t t Bool
| TLt: tbinop Nat Nat Bool.

Inductive texp : type -> Set :=
| TNConst : nat -> texp Nat
| TBConst : bool -> texp Bool
| TBinop : forall t1 t2 t, tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t.

Definition typeDenote (t : type) : Set :=
  match t with
  | Nat => nat
  | Bool => bool
  end.

Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b with
  | TPlus => plus
  | TTimes => mult
  | TEq Nat => beq_nat
  | TEq Bool => eqb
  | TLt => leb
  end.

Fixpoint texpDenote t (e : texp t) : typeDenote t :=
  match e with
  | TNConst n => n
  | TBConst b => b
  | TBinop _ _ _ b e1 e2 => (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.

Eval simpl in texpDenote (TNConst 42).

Definition tstack := list type.

Inductive tinstr : tstack -> tstack -> Set :=
| TiNConst : forall s, nat -> tinstr s (Nat :: s)
| TiBConst : forall s, bool -> tinstr s (Bool :: s)
| TiBinop : forall arg1 arg2 res s,
    tbinop arg1 arg2 res -> tinstr (arg1 :: arg2 :: s)(res :: s).

Inductive tprog : tstack -> tstack -> Set :=
| TNil : forall s, tprog s s
| TCons : forall s1 s2 s3,
    tinstr s1 s2
    -> tprog s2 s3
    -> tprog s1 s3.

Fixpoint vstack (ts : tstack) : Set :=
  match ts with
  | nil => unit
  | t :: ts' => typeDenote t * vstack ts'
  end%type.

(*
Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
  | TiNConst _ n => fun s => (n, s)
  | TiBConst _ b => fun s => (b, s)
  | TiBinop _ _ _ _ b => fun s => let '(arg1, (arg2, s')) := s in
                                  ((tbinopDenote b) arg1, arg2, s')
  end.
 *)

Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
    | TiNConst _ n => fun s => (n, s)
    | TiBConst _ b => fun s => (b, s)
    | TiBinop _ _ _ _ b => fun s =>
      let '(arg1, (arg2, s')) := s in
        ((tbinopDenote b) arg1 arg2, s')
  end.

Fixpoint tprogDenote ts ts' (p : tprog ts ts') : vstack ts -> vstack ts' :=
  match p with
  | TNil _ => fun s => s
  | TCons _ _ _ i p' => fun s => tprogDenote p' (tinstrDenote i s)
  end.

Fixpoint tconcat ts ts' ts'' (p : tprog ts ts') : tprog ts' ts'' -> tprog ts ts'' :=
  match p with
  | TNil _ => fun p' => p'
  | TCons _ _ _ i p1 => fun p' => TCons i (tconcat p1 p')
  end.

Fixpoint tcompile t (e : texp t) (ts : tstack) : tprog ts (t :: ts) :=
  match e with
  | TNConst n => TCons (TiNConst _ n) (TNil _)
  | TBConst b => TCons (TiBConst _ b) (TNil _)
  | TBinop _ _ _ b e1 e2 => tconcat (tcompile e2 _)
                                    (tconcat (tcompile e1 _) (TCons (TiBinop _ b) (TNil _)))
  end.

Eval simpl in tprogDenote (tcompile (TNConst 42) nil) tt.


Require Import Arith Bool.

Set Implicit Arguments.

(** * Easy reflection example: evenness of [nat]s *)

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

Ltac prove_even :=
  repeat (apply Even_O || apply Even_SS).

Theorem even_256 : isEven 256.
  prove_even.
Qed.

Print even_256.

Fixpoint check_even (n : nat) : bool :=
  match n with
    | 0 => true
    | 1 => false
    | S (S n') => check_even n'
  end.

Hint Constructors isEven.

Lemma check_even_sound' : forall n, (check_even n = true -> isEven n)
  /\ (check_even (S n) = true -> isEven (S n)).
  induction n; simpl; intuition; discriminate.
Qed.

Theorem check_even_sound : forall n, check_even n = true -> isEven n.
  intros.
  generalize (check_even_sound' n); tauto.
Qed.

Ltac prove_even_reflective :=
  apply check_even_sound; reflexivity.

Theorem even_256' : isEven 256.
  prove_even_reflective.
Qed.

Print even_256'.

(** * Some support code: lists at sort Type *)

Section listT.
  Variable A : Type.

  Inductive listT : Type :=
    | nilT : listT
    | consT : A -> listT -> listT.
End listT.

Implicit Arguments nilT [A].

(** * A reflective tautology solver *)

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

Section interp_formula.
  Variable atomics : nat -> Prop.

  Fixpoint interp_formula (f : formula) : Prop :=
    match f with
      | Atomic n => atomics n
      | Truth => True
      | Falsehood => False
      | And f1 f2 => interp_formula f1 /\ interp_formula f2
      | Or f1 f2 => interp_formula f1 \/ interp_formula f2
      | Imp f1 f2 => interp_formula f1 -> interp_formula f2
    end.
End interp_formula.

Definition asgn := nat -> bool.

Definition add (f : asgn) (n : nat) :=
  fun n' =>
    if eq_nat_dec n' n
      then true
      else f n'.

Fixpoint forward (hyps : asgn) (hyp : formula) (cont : asgn -> bool) {struct hyp} : bool :=
  match hyp with
    | Atomic n => cont (add hyps n)
    | Truth => cont hyps
    | Falsehood => true
    | And hyp1 hyp2 => forward hyps hyp1 (fun hyps' => forward hyps' hyp2 cont)
    | Or hyp1 hyp2 => forward hyps hyp1 cont && forward hyps hyp2 cont
    | Imp _ _ => cont hyps
  end.

Fixpoint backward (hyps : asgn) (goal : formula) {struct goal} : bool :=
  match goal with
    | Atomic n => hyps n
    | Truth => true
    | Falsehood => false
    | And goal1 goal2 => backward hyps goal1 && backward hyps goal2
    | Or goal1 goal2 => backward hyps goal1 || backward hyps goal2
    | Imp hyp goal' => forward hyps hyp (fun hyps' => backward hyps' goal')
  end.

Ltac bool_simpl :=
  repeat (match goal with
	    | [ H : _ |- _ ] =>
	      (generalize (andb_prop _ _ H)
		|| generalize (orb_prop _ _ H));
	      clear H; intro H
	  end
  || apply andb_true_intro
    || apply orb_true_intro).

Ltac simplify := repeat progress (simpl; intuition eauto; bool_simpl).

Hint Extern 1 False => discriminate.

Section prove_sound.
  Variable atomics : nat -> Prop.

  Lemma add_sound : forall (hyps : asgn) (n : nat),
    (forall n' : nat, hyps n' = true -> atomics n')
    -> atomics n
    -> forall n'', add hyps n n'' = true
      -> atomics n''.
    intuition.
    unfold add in H1.
    destruct (eq_nat_dec n'' n); subst; intuition.
  Qed.

  Hint Resolve add_sound.

  Theorem forward_sound : forall (hyp : formula)
    (hyps : nat -> bool)
    (cont : (nat -> bool) -> bool),
    (forall n, hyps n = true -> atomics n)
    -> interp_formula atomics hyp
    -> forward hyps hyp cont = true
    -> exists hyps' : nat -> bool,
      (forall n, hyps' n = true -> atomics n)
      /\ cont hyps' = true.
    induction hyp; simplify; firstorder.
  Qed.

  Theorem backward_sound : forall (goal : formula)
    (hyps : nat -> bool),
    (forall n, hyps n = true -> atomics n)
    -> backward hyps goal = true
    -> interp_formula atomics goal.
    induction goal; simplify;
      generalize forward_sound; firstorder.
  Qed.

  Theorem prover : forall (goal : formula),
    backward (fun _ => false) goal = true
    -> interp_formula atomics goal.
    intros.
    apply (backward_sound goal (fun _ => false));
      simpl; intuition; discriminate.
  Qed.
End prove_sound.

Fixpoint listT_atomics (ps : listT Prop) : nat -> Prop :=
  match ps with
    | nilT => fun _ => True
    | consT P ps' => fun n =>
      match n with
	| O => P
	| S n' => listT_atomics ps' n'
      end
  end.

Theorem test1 : True.
  apply (prover (listT_atomics nilT) Truth).
  reflexivity.
Qed.

Theorem test2 : forall (P : Prop), P -> P.
  intro.
  apply (prover (listT_atomics (consT P nilT)) (Imp (Atomic 0) (Atomic 0))).
  reflexivity.
Qed.

Ltac add_atomic atomics P :=
  match atomics with
    | nilT => constr:(consT P nilT)
    | consT P _ => atomics
    | consT ?Q ?atomics' =>
      let atomics'' := add_atomic atomics' P in
	constr:(consT Q atomics'')
  end.

Ltac enum_atomics' atomics P :=
  match P with
    | True => atomics
    | False => atomics
    | ?Q1 /\ ?Q2 => enum_atomics' ltac:(enum_atomics' atomics Q1) Q2
    | ?Q1 \/ ?Q2 => enum_atomics' ltac:(enum_atomics' atomics Q1) Q2
    | ?Q1 -> ?Q2 => enum_atomics' ltac:(enum_atomics' atomics Q1) Q2
    | _ => add_atomic atomics P
  end.

Ltac enum_atomics := enum_atomics' (@nilT Prop).

Ltac find_atomic atomics P :=
  match atomics with
    | consT P _ => constr:O
    | consT _ ?atomics' =>
      let n := find_atomic atomics' P in
	constr:(S n)
  end.

Ltac formulaify atomics P :=
  match P with
    | True => constr:Truth
    | False => constr:Falsehood
    | ?Q1 /\ ?Q2 =>
      let f1 := formulaify atomics Q1
	with f2 := formulaify atomics Q2 in
	constr:(And f1 f2)
    | ?Q1 \/ ?Q2 =>
      let f1 := formulaify atomics Q1
	with f2 := formulaify atomics Q2 in
	constr:(Or f1 f2)
    | ?Q1 -> ?Q2 =>
      let f1 := formulaify atomics Q1
	with f2 := formulaify atomics Q2 in
	constr:(Imp f1 f2)
    | _ => let n := find_atomic atomics P in
      constr:(Atomic n)
  end.

Ltac prover :=
  match goal with
    | [ |- ?P ] =>
      let atomics := enum_atomics P in
	let f := formulaify atomics P in
	  apply (prover (listT_atomics atomics) f);
	    reflexivity
  end.

Theorem t1 : True.
  prover.
Qed.

Print t1.

Theorem t2 : 1 = 1 -> 1 = 1.
  prover.
Qed.

Print t2.

Theorem t3 : False -> 1 + 1 = 2.
  prover.
Qed.

Print t3.

Theorem t4 : forall x y, x > y -> x > y \/ y > x.
  do 2 intro; prover.
Qed.

Theorem t5 : forall x y z, x > y \/ x > z -> x > z \/ x > y.
  do 3 intro; prover.
Qed.

(** * A quick example using the 'quote' tactic *)

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'.

Fixpoint interp_formula' (atomics : varmap Prop) (f : formula') {struct f} : Prop :=
  match f with
    | Atomic' v => varmap_find True v atomics
    | Truth' => True
    | Falsehood' => False
    | And' f1 f2 => interp_formula' atomics f1 /\ interp_formula' atomics f2
    | Or' f1 f2 => interp_formula' atomics f1 \/ interp_formula' atomics f2
    | Imp' f1 f2 => interp_formula' atomics f1 -> interp_formula' atomics f2
  end.

Theorem t1' : True.
  quote interp_formula'.
Admitted.

Theorem t2' : True /\ True.
  quote interp_formula'.
Admitted.

Theorem t3' : forall x y, x > y \/ x <= y.
  do 2 intro.
  quote interp_formula'.
Admitted.

Theorem t4' : True -> True.
  quote interp_formula'.
Admitted.


Require Import Nijn.Prelude.

Declare Scope signature.
Open Scope signature.

(** * Definition of simple types in an AFS *)

(** Notational convention: we use [B] for the collection of base types, and simple types are named [A, A1, ...] *)

Inductive ty (B : Type) : Type :=
| Base : B -> ty B
| Fun : ty B -> ty B -> ty B.

Arguments Base {_} _.
Arguments Fun {_} _ _.
Notation "A ⟶ B" := (Fun A B) (at level 70, right associativity) : signature.

(** ** Decidable equality of types *)

(** Lemmata on equality of the constructors *)
Proposition Base_nequal
            {B : Type}
            {b1 b2 : B}
            (p : b1 <> b2)
  : Base b1 <> Base b2.
Proof.
  intro q.
  inversion q.
  contradiction.
Qed.

Proposition Base_not_Fun
            {B : Type}
            {A1 A2 : ty B}
            {b : B}
  : Base b <> (A1 ⟶ A2).
Proof.
  discriminate.
Qed.

Proposition Fun_not_Base
            {B : Type}
            {A1 A2 : ty B}
            {b : B}
  : (A1 ⟶ A2) <> Base b.
Proof.
  discriminate.
Qed.

Proposition eq_Fun
            {B : Type}
            {A1 A2 A3 A4 : ty B}
            (p : A1 = A3)
            (q : A2 = A4)
  : (A1 ⟶ A2) = (A3 ⟶ A4).
Proof.
  subst.
  reflexivity.
Qed.

Proposition neq_Fun₁
            {B : Type}
            {A1 A2 A3 A4 : ty B}
            (p : A1 <> A3)
  : (A1 ⟶ A2) <> (A3 ⟶ A4).
Proof.
  intro q.
  inversion q.
  contradiction.
Qed.

Proposition neq_Fun₂
            {B : Type}
            {A1 A2 A3 A4 : ty B}
            (p : A2 <> A4)
  : (A1 ⟶ A2) <> (A3 ⟶ A4).
Proof.
  intro q.
  inversion q.
  contradiction.
Qed.

(** The function that decides equality *)
Fixpoint dec_eq_Ty
         {B : Type}
         `{decEq B}
         (A1 A2 : ty B)
  : dec (A1 = A2)
  := match A1 , A2 with
     | Base b1 , Base b2 =>
       match dec_eq b1 b2 with
       | Yes p => Yes (f_equal Base p)
       | No p => No (Base_nequal p)
       end
     | A1 ⟶ A2 , A3 ⟶ A4 =>
       match dec_eq_Ty A1 A3 with
       | Yes p =>
         match dec_eq_Ty A2 A4 with
         | Yes q => Yes (eq_Fun p q)
         | No q => No (neq_Fun₂ q)
         end
       | No p => No (neq_Fun₁ p)
       end
     | _ ⟶ _ , Base _ => No Fun_not_Base
     | Base _ , _ ⟶ _ => No Base_not_Fun
     end.

Global Instance decEq_Ty
       {B : Type}
       `{decEq B}
  : decEq (ty B)
  := {| dec_eq := dec_eq_Ty |}.


Require Export projective_plane_inst.

Module Export uniq := (uniqueness_axioms AbstractProjectivePlane).

Lemma Incid_property :
forall A B C D : Point,
A <> B ->
forall L1 L2: Line,
  Incid A L1 -> Incid B L1 -> Incid C L1 ->
  Incid A L2 -> Incid B L2 -> Incid D L2 ->
  exists L3 : Line,
    (Incid A L3)/\(Incid B L3)/\(Incid C L3)/\(Incid D L3).
intros A B C D.
intros Hdistincts.
intros D1 D2.
intros HAD1 HBD1 HCD1 HAD2 HBD2 HDD2.
intuition.
elim (a1_exist A B).
intros L1 HL1.
cut ((D1=L1)/\(D2=L1)).
intros (HD1,HD2).
exists L1.
pattern L1 at 1 2 3; rewrite <-HD1.
rewrite <- HD2.
intuition.
split.
apply (a1_unique A B);intuition.
apply (a1_unique A B);intuition.
Qed.

Theorem c :
  (exists A:Point,exists B:Point,exists C:Point,exists D:Point, dist4 A B C D) ->
  (exists M:Point,exists N:Point,exists P:Point,exists l:Line,
    dist3 M N P/\Incid M l/\Incid N l/\Incid P l).
intros.
elim H;clear H.
intros A.
intros Ha.
elim Ha;clear Ha.
intros B.
intros Hb.
elim Hb;clear Hb.
intros C.
intros Hc.
elim Hc;clear Hc.
intros D.
intros H.

generalize(a1_exist A B).
intros Hl1;elim Hl1; clear Hl1.
intros l1 Hl1.
assert(A <> B).
unfold dist4 in H.
tauto.
elim (incid_dec C l1).
intros HCl1.
exists A.
exists B.
exists C.
exists l1.
unfold dist3.
unfold dist4 in H.
tauto.
intros HCl1.
elim (incid_dec D l1).
intros HDl1.
exists A.
exists B.
exists D.
exists l1.
unfold dist3.
unfold dist4 in H.
tauto.
intros HDl1.

generalize(a1_exist C D).
intros Hl2;elim Hl2; clear Hl2.
intros l2 Hl2.
intros.
assert(C <> D).
unfold dist4 in H.
tauto.
elim (incid_dec A l2).
intros HAl2.
exists C.
exists D.
exists A.
exists l2.
unfold dist3.
unfold dist4 in *.
intuition. (* tauto failed ??? *)
intros HAl2.
elim (incid_dec B l2).
intros HBl2.
exists C.
exists D.
exists B.
exists l2.
unfold dist3.
unfold dist4 in *.
solve [intuition].
intros HBl2.
generalize (a2_exist l1 l2).
intros HI.
assert (l1 <> l2).
intros Hl1l2.
subst l1.
apply HAl2.
tauto.
elim HI; clear HI; intros I HI.
exists I.
exists C.
exists D.
exists l2.
unfold dist3.
unfold dist4 in H.
split.
split.
intros HIC.
subst I.
tauto.
split.
intros HID.
subst I.
tauto.
tauto.
tauto.
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 (lf2 : natural) (x : natural) (lf1 : natural) (y : natural)
  : natural := mult x y.


Require Import init.

Require Export topology_base.
Require Import topology_basis.
Require Import topology_axioms.
Require Import topology_subspace.
Require Import nat.

(* begin hide *)
Section ClosureInterior.

Local Open Scope set_scope.
(* end hide *)
Definition closure {U} `{Topology U} A := ⋂ (λ S, closed S ∧ A ⊆ S).
Definition interior {U} `{Topology U} A := ⋃ (λ S, open S ∧ S ⊆ A).

(* begin hide *)
Context {U} `{Topology U}.
(* end hide *)
Theorem closure_closed : ∀ A, closed (closure A).
Proof.
    intros A.
    apply inter_closed.
    intros S [S_closed sub].
    exact S_closed.
Qed.

Theorem interior_open : ∀ A, open (interior A).
Proof.
    intros A.
    apply union_open.
    intros S [S_open sub].
    exact S_open.
Qed.

Theorem closure_sub : ∀ A, A ⊆ closure A.
Proof.
    intros A x Ax S [S_closed sub].
    apply sub.
    exact Ax.
Qed.

Theorem interior_sub : ∀ A, interior A ⊆ A.
Proof.
    intros A x [S [[S_open sub] Sx]].
    apply sub.
    exact Sx.
Qed.

Theorem in_closure : ∀ x A,
    (closure A) x ↔ (∀ S, open S → S x → intersects A S).
Proof.
    intros x A.
    split.
    -   intros A'x S S_open Sx eq.
        apply (A'x (𝐂 S)); try exact Sx.
        split.
        +   unfold closed.
            rewrite compl_compl.
            exact S_open.
        +   intros y Ay.
            classic_contradiction Sy.
            assert ((A ∩ S) y) as contr.
            {
                split; try exact Ay.
                unfold 𝐂 in Sy.
                rewrite not_not in Sy.
                exact Sy.
            }
            rewrite eq in contr.
            exact contr.
    -   intros all_S.
        intros B [B_closed sub].
        classic_contradiction Bx.
        assert (open (𝐂 B)) as B'_open by exact B_closed.
        specialize (all_S (𝐂 B) B_closed Bx).
        unfold intersects in all_S.
        apply all_S.
        apply empty_eq.
        intros y [Ay B'y].
        apply sub in Ay.
        contradiction.
Qed.

Theorem closed_if_closure : ∀ A, closed A ↔ A = closure A.
Proof.
    intros A.
    split.
    -   intros A_closed.
        apply predicate_ext; intros x; split.
        +   intros Ax.
            apply closure_sub.
            exact Ax.
        +   intros Ax.
            specialize (Ax A (make_and A_closed (refl _))).
            exact Ax.
    -   intros eq; rewrite eq.
        apply closure_closed.
Qed.

Theorem open_if_interior : ∀ A, open A ↔ A = interior A.
Proof.
    intros A.
    split.
    -   intros A_open.
        apply predicate_ext; intros x; split.
        +   intros Ax.
            exists A.
            repeat split.
            *   exact A_open.
            *   apply refl.
            *   exact Ax.
        +   intros [S [[S_open sub] Sx]].
            apply sub.
            exact Sx.
    -   intros eq; rewrite eq.
        apply interior_open.
Qed.

Theorem closure_eq_if_closed : ∀ A, closed A → A = closure A.
Proof.
    intros A.
    apply closed_if_closure.
Qed.

Theorem closure_sub_closure : ∀ A B, A ⊆ B → closure A ⊆ closure B.
Proof.
    intros A B AB x Ax.
    intros C [C_closed BC].
    exact (Ax C (make_and C_closed (trans AB BC))).
Qed.

(* begin hide *)
End ClosureInterior.

Section SubspaceClosure.

Context {U} `{Topology U}.

Existing Instance subspace_topology.
(* end hide *)
Theorem subspace_closure : ∀ X A, A ⊆ X →
    closure (to_set_type X A) = to_set_type X (closure A).
Proof.
    intros X A sub.
    apply antisym.
    -   assert (closed (to_set_type X (closure A))) as AX_closed.
        {
            rewrite to_set_type_inter.
            apply (subspace_inter_closed _ _ (closure A)).
            -   apply closure_closed.
            -   reflexivity.
        }
        assert (to_set_type X A ⊆ to_set_type X (closure A)) as sub2.
        {
            apply to_set_type_sub.
            apply closure_sub.
        }
        intros x Ax.
        apply Ax; cbn.
        split; assumption.
    -   pose proof (closure_closed (to_set_type X A)) as A'_closed.
        pose proof (from_set_type_sub_X X (closure (to_set_type X A)))
            as A_sub.
        rewrite <- to_from_set_type in A'_closed.
        apply (subspace_closed_inter _ _ A_sub) in A'_closed.
        destruct A'_closed as [B [B_closed A_eq]].
        assert (A ⊆ B) as sub2.
        {
            assert (A ⊆ (from_set_type (closure (to_set_type X A)))) as sub2.
            {
                apply to_from_set_type_sub.
                -   exact sub.
                -   apply closure_sub.
            }
            apply (trans sub2).
            rewrite A_eq.
            apply inter_lsub.
        }
        assert (closure A ⊆ B) as sub3.
        {
            intros x Ax.
            apply Ax.
            split.
            -   exact B_closed.
            -   exact sub2.
        }
        rewrite <- to_from_set_type.
        rewrite A_eq.
        intros [x Xx] Ax.
        split.
        +   apply sub3.
            exact Ax.
        +   exact Xx.
Qed.

(* begin hide *)
End SubspaceClosure.

Section ClosureBasis.

Context {U} `{TopologyBasis U}.
(* end hide *)
Theorem basis_in_closure : ∀ x A,
    (closure A) x ↔ ∀ B, top_basis B → B x → intersects A B.
Proof.
    intros x A.
    split.
    -   intros Ax B B_basis Bx.
        rewrite in_closure in Ax.
        exact (Ax B (basis_open _ B_basis) Bx).
    -   intros all_B A' [A'_closed sub].
        classic_contradiction Ax.
        unfold closed in A'_closed.
        rewrite <- (compl_compl A') in Ax.
        unfold 𝐂 in Ax at 1.
        rewrite not_not in Ax.
        unfold open in A'_closed; cbn in A'_closed.
        specialize (A'_closed x Ax) as [B [B_basis [Bx B_sub]]].
        specialize (all_B B B_basis Bx).
        apply all_B.
        apply empty_eq.
        intros y [Ay By].
        apply B_sub in By.
        apply sub in Ay.
        contradiction.
Qed.

(* begin hide *)
End ClosureBasis.

(* end hide *)
Section ClosureHausdorff.

(* begin hide *)
Local Open Scope card_scope.
Local Open Scope set_scope.
(* end hide *)
Context {U} `{HausdorffSpace U}.

Theorem point_closed : ∀ x, closed ❴x❵.
Proof.
    intros x.
    rewrite closed_if_closure.
    apply (antisym (op := subset)).
    -   apply closure_sub.
    -   intros y y_closure.
        apply singleton_eq.
        classic_contradiction contr.
        pose proof (hausdorff_space x y contr)
            as [S1 [S2 [S1_open [S2_open [S1x [S2y S1S2]]]]]].
        rewrite in_closure in y_closure.
        specialize (y_closure S2 S2_open S2y).
        assert ((S1 ∩ S2) x) as x_in.
        {
            split; try exact S1x.
            apply empty_neq in y_closure.
            destruct y_closure as [x' [x'_eq S2x']].
            rewrite singleton_eq in x'_eq; subst.
            exact S2x'.
        }
        unfold disjoint in S1S2.
        rewrite S1S2 in x_in.
        contradiction x_in.
Qed.

Theorem finite_point_closed : ∀ A, finite (|set_type A|) → closed A.
Proof.
    intros A A_fin.
    apply fin_nat_ex in A_fin as [n A_fin].
    revert A A_fin.
    nat_induction n.
    -   intros.
        apply zero_is_empty in A_fin.
        rewrite A_fin.
        apply empty_closed.
    -   intros A A_fin.
        assert (set_type A) as [x Ax].
        {
            clear - A_fin.
            classic_contradiction contr.
            rewrite <- card_0_false in contr.
            rewrite contr in A_fin.
            apply nat_to_card_eq in A_fin.
            inversion A_fin.
        }
        symmetry in A_fin.
        pose proof (card_plus_one_nat A n [x|Ax] A_fin) as A'_fin; cbn in *.
        remember (A - ❴x❵) as A'.
        assert (A = A' ∪ ❴x❵) as eq.
        {
            apply predicate_ext; intros y; split.
            -   intros Ay.
                classic_case (x = y) as [eq|neq].
                +   rewrite eq.
                    right; reflexivity.
                +   left.
                    rewrite HeqA'; split.
                    *   exact Ay.
                    *   exact neq.
            -   intros [A'y|xy].
                +   rewrite HeqA' in A'y.
                    apply A'y.
                +   rewrite singleton_eq in xy; rewrite <- xy.
                    exact Ax.
        }
        rewrite eq.
        apply union_closed2.
        +   apply IHn.
            symmetry; exact A'_fin.
        +   apply point_closed.
Qed.

End ClosureHausdorff.


Require Import List.
Require Import NPeano EqNat Compare_dec.

(* determine whether given list of numbers is in decreasing order *)
Fixpoint decreasing_order (ns : list nat) : bool :=
  match ns with
      | nil => true
      | a :: ns' => andb (match ns' with
                            | nil => true
                            | b :: _ => ltb b a
                          end)
                         (decreasing_order ns')
  end.

Fixpoint last_is_1 (ns : list nat) : bool :=
  match ns with
    | nil => false
    | 1 :: nil => true
    | _ :: nil => false
    | n :: ns' => last_is_1 ns'
  end.

Definition coinlist := list nat.
Definition repr := list nat.

Definition N := 4.
Definition C : coinlist := 25 :: 6 :: 5 :: 1 :: nil.

Eval compute in decreasing_order C.

(* this should follow from decreasing_order and last_is_1
Definition no_zeroes (C:coinlist) := forallb (fun c:nat => ltb 0 c) C.
*)

Fixpoint repr_value (C : coinlist) (V : repr) : nat :=  (* inner product V . C *)
  match C, V with
      | nil, nil => 0
      | c :: C', v :: V' => (c*v) + repr_value C' V'
      | _, _ => 0
  end.

Eval compute in (beq_nat 38 (repr_value (25 :: 10 :: 5 :: 1 :: nil) (1 :: 1 :: 0 :: 3 :: nil))).

Fixpoint repr_size (A : repr) : nat :=
  match A with
      | nil => 0
      | a :: A' => a + repr_size A'
  end.

Eval compute in (beq_nat 5 (repr_size (1 :: 1 :: 0 :: 3 :: nil))).

Fixpoint repr_lt (U V : repr) : bool :=
  match U, V with
    | nil, nil => false
    | u :: U', v :: V' =>
      orb (ltb u v) (andb (beq_nat u v) (repr_lt U' V'))
    | nil, _ => true
    | _, nil => false
  end.

Fixpoint repr_le (U V : repr) : bool :=
  match U, V with
    | nil, nil => true
    | u :: U', v :: V' =>
      orb (ltb u v) (andb (beq_nat u v) (repr_le U' V'))
    | nil, _ => true
    | _, nil => false
  end.

Definition repr_gt (U V : repr) : bool := repr_lt V U.
Definition repr_ge (U V : repr) : bool := repr_le V U.

Eval compute in (repr_lt (1 :: 1 :: 0 ::  3 :: nil) (1 :: 3 :: 0 :: 0 :: nil)).
Eval compute in (repr_lt (1 :: 1 :: 0 ::  3 :: nil) (1 :: 1 :: 0 :: 3 :: nil)).
Eval compute in (repr_le (1 :: 1 :: 0 ::  3 :: nil) (1 :: 1 :: 0 :: 3 :: nil)).
Eval compute in (repr_le (1 :: 1 :: 0 ::  3 :: nil) (1 :: 3 :: 0 :: 0 :: nil)).
Eval compute in negb (repr_lt (1 :: 1 :: nil) (1 :: 1 :: nil)).
Eval compute in negb (repr_lt (3 :: 1 :: nil) (1 :: 1 :: nil)).

Fixpoint make_list (k:nat) (v:nat) :=
  match k with
    | 0 => nil
    | S k' => v :: make_list k' v
  end.

(* comp : is the first better than the second *)
Fixpoint best_of (comp : repr -> repr -> bool) (candidate : repr) (Rs : list repr) : repr :=
  match Rs with
      | nil => candidate
      | r :: Rs' => best_of comp (if (comp r candidate) then r else candidate) Rs'
  end.

Eval compute in 11 / 3.
Eval compute in 11 mod 3.

Fixpoint range (n:nat) : list nat :=
  match n with
    | 0 => nil
    | S n' => n' :: range n'
  end.

Fixpoint range_from (start num : nat) : list nat :=
  match num with
    | 0 => nil
    | S m => start :: range_from (S start) m
  end.

Eval compute in (range 5).
Eval compute in (range_from 10 5).

Fixpoint cons_each (x:nat) (V:list repr) :=
  match V with
    | nil => nil
    | v :: V' => (cons x v) :: cons_each x V'
  end.

Fixpoint all_reprs_iterate
         (all_reprs : coinlist -> nat -> list repr) (C':coinlist) (c:nat) (v:nat) (X : list nat) : list repr :=
  match X with
    | nil => nil
    | x :: X' =>
      (* x .. c *)
      app
        (cons_each x (all_reprs C' (v - (x * c))))
        (all_reprs_iterate all_reprs C' c v X')
  end.

Fixpoint all_reprs (C : coinlist) (v : nat) {struct C} : list repr :=
  match C with
      | nil => nil
      | c :: nil => (v :: nil) :: nil
      | c :: C' => let max_of_c := v / c in
                   let count_of_c_opts := range (S max_of_c) in
                   (* all_reprs_iterate all_reprs C' c v *)
                   (fix all_reprs_iterate (X : list nat) : list repr :=
                      match X with
                        | nil => nil
                        | x :: X' =>
                          (* x .. c *)
                          app
                            (cons_each x (all_reprs C' (v - (c * x))))
                            (all_reprs_iterate X')
                      end)
                     count_of_c_opts
  end.

Eval compute in (all_reprs C 17).

(* new is "more [or equally] minimal" than cur if:
     - size(new) < size(cur), or
     - size(new)=size(cur) and cur <= new  [lexic. less than] *)
Definition more_minimal (new : repr) (cur : repr) : bool :=
  orb (ltb (repr_size new) (repr_size cur))
      (andb (beq_nat (repr_size new) (repr_size cur))
            (repr_le cur new)).

Fixpoint make_repr_all_ones (n:nat) (v:nat) : repr :=
  match n with
    | 0 => nil
    | 1 => v :: nil
    | S n' => 0 :: make_repr_all_ones n' v
  end.

(* brute force computations of the minimal and greedy representations *)
Definition minimal_bf C v := best_of more_minimal (make_repr_all_ones (length C) v) (all_reprs C v).
Definition greedy_bf C v :=  best_of repr_ge (make_repr_all_ones (length C) v) (all_reprs C v).

Fixpoint greedy (C:coinlist) (v:nat) : repr :=
  match C with
    | nil => nil
    | c :: C' => let q := v / c in
                 let r := v mod c in
                 q :: greedy C' r
  end.

Eval compute in (make_repr_all_ones 4 17).
Eval compute in (more_minimal  (0 :: 1 :: 1 :: 2 :: nil) (0 :: 0 :: 1 :: 12 :: nil)).
Eval compute in (more_minimal  (1 :: 2 :: 1 :: 0 :: nil) (0 :: 1 :: 1 :: 2 :: nil) ).

Eval compute in
    let v := 83 in
    (minimal_bf C v ,
     greedy_bf C v,
     greedy C v).

(* =================================================== *)
(* Pearson's algorithm to find smallest counterexample *)

Definition targetCvals (C:coinlist) : coinlist :=
  map (fun c => c - 1) C.

Eval compute in targetCvals (25 :: 10 :: 5 :: 1 :: nil).

Definition greedy_multi (C:coinlist) (V : list nat) : list repr :=
  map (greedy C) V.

Eval compute in (greedy_multi C (targetCvals C)).

Definition zero_out : repr -> repr :=
  map (fun x => 0).

Fixpoint generate_possible_ce (R : repr) (i : nat) : repr :=
  match R, i with
    | x :: R', 0 => x+1 :: zero_out R'
    | x :: R', S i' => x :: generate_possible_ce R' i'
    | _, _ => R
  end.

Definition generate_possible_ces_from (R : repr) (i j : nat) : list repr :=
  map (generate_possible_ce R) (range_from i (j - i)).

Eval compute in generate_possible_ce (2 :: 1 :: 3 :: 1 :: 2 :: 7 :: nil) 3.
Eval compute in generate_possible_ces_from (2 :: 1 :: 3 :: 1 :: 2 :: 7 :: nil) 1 4.

Fixpoint app_all (Rs : list (list repr)) : list repr :=
  match Rs with
    | nil => nil
    | x :: Rs' => app x (app_all Rs')
  end.

Definition generate_min_reprs_to_check (Gs : list repr) : list repr :=
  app_all (map (fun G => generate_possible_ces_from G 1 N) Gs).

Eval compute in generate_min_reprs_to_check  (greedy_multi C (targetCvals C)).

Definition is_min_lt_greedy_repr (R : repr) : bool :=
  ltb (repr_size R) (repr_size (greedy C (repr_value C R))).

Fixpoint findp (A:Type) (f: A -> bool) (As : list A) : option A :=
  match As with
    | nil => None
    | a :: As' => if (f a) then Some a else findp A f As'
  end.

Definition find_counterexample (C:coinlist) : option nat :=
  match
    findp _ is_min_lt_greedy_repr (generate_min_reprs_to_check  (greedy_multi C (targetCvals C)))
  with
    | None => None
    | Some R => Some (repr_value C R)
  end.

Eval compute in (find_counterexample C).

Eval compute in
    let v := 10 in
    (minimal_bf C v ,
     greedy_bf C v,
     greedy C v).


Require Import Coq.Arith.PeanoNat.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Program.Basics.
Require Import DschingisKhan.Prelude.PreludeInit.
Require Import DschingisKhan.Prelude.PreludeUtil.

Module BinaryTrees.

  Import ListNotations.

  Inductive direction : Set := LeftDir | RightDir.

  Definition encode (ds : list direction) : nat := fold_left (fun i : nat => direction_rect (fun _ : direction => nat) (2 * i + 1) (2 * i + 2)) ds 0.

  Lemma encode_inj (ds1 : list direction) (ds2 : list direction)
    (ENCODE_EQ : encode ds1 = encode ds2)
    : ds1 = ds2.
  Proof with lia || eauto.
    revert ENCODE_EQ. unfold encode; do 2 rewrite <- fold_left_rev_right.
    intros ENCODE_EQ; eapply rev_inj; revert ENCODE_EQ.
    generalize (rev ds2) as xs2. generalize (rev ds1) as xs1. clear ds1 ds2.
    set (myF := fold_right (fun d : direction => fun i : nat => direction_rect (fun _ : direction => nat) (2 * i + 1) (2 * i + 2) d) 0).
    induction xs1 as [ | x1 xs1 IH], xs2 as [ | x2 xs2]; simpl...
    - destruct x2; simpl direction_rect...
    - destruct x1; simpl direction_rect...
    - destruct x1; destruct x2; simpl direction_rect...
      all: intros ?; assert (claim1 : myF xs1 = myF xs2)...
      all: eapply eq_congruence...
  Qed.

  Lemma encode_last (ds : list direction) (d : direction) :
    encode (ds ++ [d]) =
    match d with
    | LeftDir => 2 * encode ds + 1
    | RightDir => 2 * encode ds + 2
    end.
  Proof.
    unfold encode at 1. rewrite <- fold_left_rev_right, rev_unit.
    unfold fold_right, encode. rewrite <- fold_left_rev_right.
    now destruct d as [ | ].
  Qed.

  Lemma decodable (idx : nat)
    : {ds : list direction | encode ds = idx}.
  Proof with lia || eauto.
    induction idx as [[ | i'] IH] using NotherianRecursion.
    - exists ([])...
    - set (i := S i'). destruct (i mod 2) as [ | [ | i_mod_2]] eqn: H_obs.
      + assert (claim1 : i = 2 * ((i - 2) / 2) + 2).
        { eapply positive_even with (n := (i - 2) / 2)... }
        assert (claim2 : (i - 2) / 2 < i)...
        pose proof (IH ((i - 2) / 2) claim2) as [ds H_ds].
        exists (ds ++ [RightDir]).
        unfold encode. rewrite fold_left_last. unfold direction_rect at 1.
        unfold encode in H_ds. rewrite H_ds...
      + assert (claim1 : i = 2 * ((i - 1) / 2) + 1).
        { eapply positive_odd with (n := (i - 1) / 2)... }
        assert (claim2 : (i - 1) / 2 < i)...
        pose proof (IH ((i - 1) / 2) claim2) as [ds H_ds].
        exists (ds ++ [LeftDir]).
        unfold encode. rewrite fold_left_last. unfold direction_rect at 1.
        unfold encode in H_ds. rewrite H_ds...
      + pose proof (Nat.mod_bound_pos i 2)...
  Defined.

  Definition decode (idx : nat) : list direction := proj1_sig (decodable idx).

  Section BINARY_TREE.

  Context {A : Type}.

  Inductive bintree : Type := BTnull | BTnode (t_l : bintree) (x : A) (t_r : bintree).

  Fixpoint getHeight (t : bintree) {struct t} : nat :=
    match t with
    | BTnull => 0
    | BTnode t_l x t_r => 1 + max (getHeight t_l) (getHeight t_r)
    end
  .

  Fixpoint getSize (t : bintree) {struct t} : nat :=
    match t with
    | BTnull => 0
    | BTnode t_l x t_r => 1 + (getSize t_l + getSize t_r)
    end
  .

  Definition getLeftChild (t : bintree) : option bintree :=
    match t with
    | BTnull => None
    | BTnode t_l x t_r => Some t_l
    end
  .

  Definition getRightChild (t : bintree) : option bintree :=
    match t with
    | BTnull => None
    | BTnode t_l x t_r => Some t_r
    end
  .

  Definition getKey (t : bintree) : option A :=
    match t with
    | BTnull => None
    | BTnode t_l x t_r => Some x
    end
  .

  Definition goto : list direction -> bintree -> option bintree :=
    let k_step := @direction_rect _ (fun k : bintree -> option bintree => k <=< getLeftChild) (fun k : bintree -> option bintree => k <=< getRightChild) in
    let k_base := @Some _ in
    fold_right (A := bintree -> option bintree) (B := direction) k_step k_base
  .

  Lemma goto_unfold (ds : list direction) (t : bintree) :
    goto ds t =
    match ds with
    | [] => Some t
    | LeftDir :: ds' =>
      match t with
      | BTnull => None
      | BTnode t_l x t_r => goto ds' t_l
      end
    | RightDir :: ds' =>
      match t with
      | BTnull => None
      | BTnode t_l x t_r => goto ds' t_r
      end
    end.
  Proof with try reflexivity.
    destruct ds as [ | [ | ] ds']...
    all: destruct t as [ | t_l x t_r]...
  Qed.

  Definition lookup (t : bintree) (ds : list direction) : option A :=
    (getKey <=< goto ds) t
  .

  Definition toList (t : bintree) : list A :=
    map (lookup t ∘ decode) (seq 0 (2 ^ getHeight t)) >>= maybe [] pure
  .

  Section COMPLETE_TREE.

  Definition isComplete (t : bintree) : Prop :=
    forall idx : nat, idx < getSize t -> lookup t (decode idx) <> None
  .

  End COMPLETE_TREE.

  Section BREADTH_FIRST_SEARCH.

  Fixpoint rk_bt (t : bintree) {struct t} : nat :=
    match t with
    | BTnull => 1
    | BTnode t_l x t_r => 1 + rk_bt t_l + rk_bt t_r
    end
  .

  Definition rk_queue (ts : list bintree) : nat := list_sum (map rk_bt ts).

  Inductive bfsAux_spec : list bintree -> list A -> Prop :=
  | bfsAux_nil
    : bfsAux_spec [] []
  | bfsAux_cons_null (ts : list bintree) (xs : list A)
    (IH_SPEC : bfsAux_spec ts xs)
    : bfsAux_spec (BTnull :: ts) xs
  | bfsAux_cons_node (t_l : bintree) (x : A) (t_r : bintree) (ts : list bintree) (xs : list A)
    (IH_SPEC : bfsAux_spec ([t_l; t_r] ++ ts) xs)
    : bfsAux_spec (BTnode t_l x t_r :: ts) (x :: xs)
  .

  Definition bfsAux_withSpec (ts : list bintree)
    : {xs : list A | forall xs' : list A, bfsAux_spec ts xs' <-> xs = xs'}.
  Proof.
    assert (WF_REC : forall ts : list bintree, Acc (fun lhs : list bintree => fun rhs : list bintree => rk_queue lhs < rk_queue rhs) ts).
    { exact (well_founded_relation_on_image rk_queue Nat.lt (@lt_strong_ind (@Acc nat Nat.lt) (@Acc_intro nat Nat.lt))). }
    induction (WF_REC ts) as [ts H_acc_inv IH]. clear H_acc_inv WF_REC. destruct ts as [ | [ | t_l x t_r] ts].
    - exists ([]). intros xs'. split.
      + intros SPEC. inversion SPEC; subst. reflexivity.
      + intros ?; subst xs'. econstructor 1.
    - assert (IH_rk : rk_queue ts < rk_queue (BTnull :: ts)).
      { cbn. eapply le_intro_S_n_le_S_m. reflexivity. }
      pose proof (IH ts IH_rk) as [xs IH_xs].
      exists (xs). intros xs'. split.
      + intros SPEC. inversion SPEC; subst. eapply IH_xs. exact (IH_SPEC).
      + intros ?; subst xs'. econstructor 2. eapply IH_xs. reflexivity.
    - assert (IH_rk : rk_queue ([t_l; t_r] ++ ts) < rk_queue (BTnode t_l x t_r :: ts)).
      { cbn. eapply le_intro_S_n_le_S_m. rewrite Nat.add_assoc. reflexivity. }
      pose proof (IH ([t_l; t_r] ++ ts) IH_rk) as [xs IH_xs].
      exists (x :: xs). intros xs'. split.
      + intros SPEC. inversion SPEC; subst. eapply eq_congruence. eapply IH_xs. exact (IH_SPEC).
      + intros ?; subst xs'. econstructor 3. eapply IH_xs. reflexivity.
  Defined.

  Definition bfsAux (ts : list bintree) : list A := proj1_sig (bfsAux_withSpec ts).

  Lemma bfsAux_spec_iff (ts : list bintree) (xs : list A)
    : bfsAux_spec ts xs <-> bfsAux ts = xs.
  Proof. revert xs. exact (proj2_sig (bfsAux_withSpec ts)). Qed.

  Theorem bfsAux_unfold (ts : list bintree) :
    bfsAux ts =
    match ts with
    | [] => []
    | BTnull :: ts' => bfsAux ts'
    | BTnode t_l x t_r :: ts' => x :: bfsAux ([t_l; t_r] ++ ts')
    end.
  Proof.
    destruct ts as [ | [ | t_l x t_r] ts']; eapply bfsAux_spec_iff; econstructor.
    all: eapply bfsAux_spec_iff; reflexivity.
  Qed.

  Definition bfs (t : bintree) : list A := bfsAux [t].

  End BREADTH_FIRST_SEARCH.

  End BINARY_TREE.

  Global Arguments bintree : clear implicits.

End BinaryTrees.


Require Import QArith Qminmax Qabs QOrderedType.
Require Import Nsatz.

Definition Q_of_nat : nat -> Q := (fun n => inject_Z (Z_of_nat n)).

Section Distance.

  Definition qDistance (x y : Q) : Q :=
    Qabs (x-y).

  Lemma qDistance_Uniq :
    forall x y, qDistance x y == 0 <-> x == y.
  Proof.
    intros. unfold qDistance.
    apply Qabs_case.
    - split; intros; nsatz.
    - split; intros; nsatz.
  Qed.

  Lemma qDistance_symm :
    forall x y,
      qDistance x y == qDistance y x.
  Proof.
    intros. unfold qDistance.
    rewrite Qabs_Qminus. reflexivity.
  Qed.

  Add Parametric Morphism : qDistance with
    signature Qeq ==> Qeq ==> Qeq as qDistance_mor.
  Proof. intros. unfold qDistance. rewrite H, H0. reflexivity. Qed.

  Lemma qDistance_or : forall x y,
    (x == y + (qDistance x y)) \/ (x == y - (qDistance x y)).
  Proof.
    unfold qDistance.
    intros. apply Qabs_case;
    intros; [left | right]; nsatz.
  Qed.

End Distance.

Section QInterval.

Record QInterval : Type :=
  mkInterval {
    upperBound : Q;
    lowerBound : Q;

    orderPf : lowerBound <= upperBound
  }.

Inductive inQInterval : Q -> QInterval -> Prop :=
| mkInQInterval :
    forall q QI,
      q <= (upperBound QI) ->
      (lowerBound QI) <= q ->
  inQInterval q QI.

Definition boundriesOfIntervalIntersection QInt1 QInt2 : Q * Q :=
    let UB := Qmin (upperBound QInt1) (lowerBound QInt2) in
    let LB := Qmax (lowerBound QInt1) (lowerBound QInt2) in
  (UB, LB).

  Definition intervalIntersection QInt1 QInt2 : option QInterval :=
    let boundries := boundriesOfIntervalIntersection QInt1 QInt2 in
    match Qlt_le_dec (fst boundries) (snd boundries) with
    | left _ => None
    | right pf => Some (mkInterval (fst boundries) (snd boundries) pf)
    end.

End QInterval.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Functions                                                               *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibBag LibSet.
Generalizable Variables A.

(* ********************************************************************** *)
(** ** Indentity function *)

Definition id {A} (x : A) :=
  x.

(* ********************************************************************** *)
(** Constant functions *)

Definition const {A B} (v : B) : A -> B :=
  fun _ => v.
Definition const1 :=
  @const.
Definition const2 {A1 A2 B} (v:B) : A1->A2->B :=
  fun _ _ => v.
Definition const3 {A1 A2 A3 B} (v:B) : A1->A2->A3->B :=
  fun _ _ _ => v.
Definition const4 {A1 A2 A3 A4 B} (v:B) : A1->A2->A3->A4->B :=
  fun _ _ _ _ => v.
Definition const5 {A1 A2 A3 A4 A5 B} (v:B) : A1->A2->A3->A4->A5->B :=
  fun _ _ _ _ _ => v.

(* ********************************************************************** *)
(** Function application *)

Definition apply {A B} (f : A -> B) (x : A) :=
  f x.

Definition apply_to (A : Type) (x : A) (B : Type) (f : A -> B) :=
  f x.

(* ********************************************************************** *)
(** Function composition *)

Definition compose {A B C} (g : B -> C) (f : A -> B) :=
  fun x => g (f x).

Notation "f1 \o f2" := (compose f1 f2)
  (at level 49, right associativity) : func_scope.

Section Combinators.
Open Scope func_scope.
Variables (A B C D : Type).

Lemma compose_id_l : forall (f:A->B),
  id \o f = f.
Proof using. intros. apply~ func_ext_1. Qed.

Lemma compose_id_r : forall (f:A->B),
  f \o id = f.
Proof using. intros. apply~ func_ext_1. Qed.

Lemma compose_assoc : forall (f:C->D) (g:B->C) (h:A->B),
  (f \o g) \o h = f \o (g \o h).
Proof using. intros. apply~ func_ext_1. Qed.

Lemma compose_eq_l : forall (f:B->C) (g1 g2:A->B),
  g1 = g2 -> f \o g1 = f \o g2.
Proof using. intros. subst~. Qed.

Lemma compose_eq_r : forall (f:A->B) (g1 g2:B->C),
  g1 = g2 -> g1 \o f = g2 \o f.
Proof using. intros. subst~. Qed.

(** Composition of [LibList.map] behaves well. **)
(* Could not be put in [LibList] because of circular dependencies. *)
Require Import LibList.
Lemma list_map_compose : forall A B C (f : A -> B) (g : B -> C) l,
  LibList.map g (LibList.map f l) = LibList.map (g \o f) l.
Proof.
  introv. induction l.
   reflexivity.
   rew_list. fequals~.
Qed.

End Combinators.

(** Tactic for simplifying function compositions *)
(* TODO: not used; might become deprecated *)

Hint Rewrite compose_id_l compose_id_r compose_assoc : rew_compose.
Tactic Notation "rew_compose" :=
  autorewrite with rew_compose.
Tactic Notation "rew_compose" "in" "*" :=
  autorewrite with rew_compose in *.
Tactic Notation "rew_compose" "in" hyp(H) :=
  autorewrite with rew_compose in H.

(* ********************************************************************** *)
(** ** Function update *)

(** [fupdate f a b x] is like [f] except that it returns [b] for input [a] *)

Definition fupdate A B (f : A -> B) (a : A) (b : B) : A -> B :=
  fun x => If (x = a) then b else f x.

Lemma fupdate_def : forall A B (f:A->B) a b x,
  fupdate f a b x = If (x = a) then b else f x.
Proof. auto. Qed.

Lemma fupdate_eq : forall A B (f:A->B) a b x,
  x = a ->
  fupdate f a b x = b.
Proof using. intros. unfold fupdate. case_if*. Qed.

Lemma fupdate_neq : forall A B (f:A->B) a b x,
  x <> a ->
  fupdate f a b x = f x.
Proof using. intros. unfold fupdate. case_if*. Qed.

(* Opaque fupdate. -- could be added in the future *)

(* ********************************************************************** *)
(** ** Function image *)

Section FunctionImage.
Open Scope set_scope.
Require Import LibList.

Definition image A B (f : A -> B) (E : set A) : set B :=
  \set{ y | exists_ x \in E, y = f x }.

Lemma in_image_prove_eq : forall A B x (f : A -> B) (E : set A),
  x \in E -> f x \in image f E.
Proof using. introv N. unfold image. rew_set. exists* x. Qed.

Lemma in_image_prove : forall A B x y (f : A -> B) (E : set A),
  x \in E -> y = f x -> y \in image f E.
Proof using. intros. subst. applys* in_image_prove_eq. Qed.

Lemma in_image_inv : forall A B y (f : A -> B) (E : set A),
  y \in image f E -> exists x, x \in E /\ y = f x.
Proof using. introv N. unfolds image. rew_set in N. auto. Qed.

Lemma finite_image : forall A B (f : A -> B) (E : set A),
  finite E ->
  finite (image f E).
Proof using.
  introv M. lets (L&H): finite_covers_basic M.
  applys finite_prove_covers (LibList.map f L). introv N.
  lets (y&Hy&Ey): in_image_inv (rm N). subst x. applys* Mem_map.
Qed.

Lemma image_covariant : forall A B (f : A -> B) (E F : set A),
  E \c F ->
  image f E \c image f F.
Proof using.
  introv. do 2 rewrite incl_in_eq. introv M N.
  lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
Qed.

Lemma image_union : forall A B (f : A -> B) (E F : set A),
  image f (E \u F) = image f E \u image f F.
Proof using.
  Hint Resolve in_image_prove.
  introv. apply in_extens. intros x. iff N.
    lets (y&Hy&Ey): in_image_inv (rm N). rewrite in_union_eq in Hy.
     rewrite in_union_eq. destruct* Hy.
    rewrite in_union_eq in N. destruct N as [N|N].
      lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
       rewrite in_union_eq. eauto.
      lets (y&Hy&Ey): in_image_inv (rm N). applys* in_image_prove.
       rewrite in_union_eq. eauto.
Qed.

Lemma image_singleton : forall A B (f : A -> B) (x : A),
  image f \{x} = \{f x}.
Proof using.
  intros. apply in_extens. intros z. iff N.
    lets (y&Hy&Ey): in_image_inv (rm N). rewrite in_single_eq in Hy. subst~.
    rewrite in_single_eq in N. applys* in_image_prove.
Qed.

End FunctionImage.

Hint Resolve finite_image : finite.

(* ********************************************************************** *)
(** ** Function preimage *)

Section FunctionPreimage.
Open Scope set_scope.

Definition preimage A B (f : A -> B) (E : set B) : set A :=
  \set{ x | exists_ y \in E, y = f x }.

End FunctionPreimage.

(* ********************************************************************** *)
(** ** Function iteration *)

Fixpoint applyn A n (f : A -> A) x :=
  match n with
  | O => x
  | S n' =>
    f (applyn n' f x)
  end.

Lemma applyn_fix : forall A n f (x : A),
  applyn (S n) f x = applyn n f (f x).
Proof. introv. induction~ n. simpls. rewrite~ IHn. Qed.

Lemma applyn_comp : forall A n m f (x : A),
  applyn n f (applyn m f x) = applyn (n + m) f x.
Proof.
  introv. gen m; induction n; introv; simpls~.
  rewrite~ IHn.
Qed.

Lemma applyn_nested : forall A n m f (x : A),
  applyn n (applyn m f) x = applyn (n * m) f x.
Proof.
  introv. gen m. induction n; introv; simpls~.
  rewrite IHn. rewrite~ applyn_comp.
Qed.

Lemma applyn_altern : forall A B (f : A -> B) (g : B -> A) x n,
  applyn n (fun x => f (g x)) (f x) =
    f (applyn n (fun x => g (f x)) x).
Proof. introv. gen x. induction~ n. introv. repeat rewrite applyn_fix. autos~. Qed.

Lemma applyn_ind : forall A (P : A -> Prop) (f : A -> A) x n,
  (forall x, P x -> P (f x)) ->
  P x ->
  P (applyn n f x).
Proof. introv I. induction n; introv Hx; autos*. Qed.