(** * Counting ones in [positive] and [N] *)

Require Import Coq.PArith.PArith.
Require Import Coq.NArith.NArith.
Require Import Coq.ZArith.ZArith.
Require Import Omega.

Require Import Data.Bits.

Lemma Pos_popcount_pow2:
  forall n, Pos_popcount (Pos.pow 2 n) = 1%positive.
Proof.
  apply Pos.peano_ind; intros.
  * reflexivity.
  * rewrite Pos.pow_succ_r.
    apply H.
Qed.

Lemma Pos_popcount_1_Is_power (p : positive) :
  Pos_popcount p = 1%positive -> Is_power p.
Proof.
  induction p as [p IH | p IH |]; simpl; auto.
  specialize (Pos.succ_not_1 (Pos_popcount p)); contradiction.
Qed.

(** And now for [N] *)

Lemma N_popcount_double:
  forall n, N_popcount (N.double n) = N_popcount n.
Proof.
  intros.
  destruct n.
  * reflexivity.
  * reflexivity.
Qed.

Lemma N_popcount_Ndouble:
  forall n, N_popcount (Pos.Ndouble n) = N_popcount n.
Proof.
  intros.
  destruct n.
  * reflexivity.
  * reflexivity.
Qed.

Lemma N_popcount_Nsucc_double:
  forall n, N_popcount (Pos.Nsucc_double n) = N.succ (N_popcount n).
Proof.
  intros.
  destruct n.
  * reflexivity.
  * reflexivity.
Qed.

Lemma N_popcount_pow2:
  forall n, N_popcount (N.pow 2 n) = 1%N.
Proof.
  apply N.peano_ind; intros.
  * reflexivity.
  * rewrite N.pow_succ_r by apply N.le_0_l.
    rewrite <- N.double_spec.
    rewrite N_popcount_double.
    assumption.
Qed.

Lemma N_popcount_1_pow2 (n : N) :
  N_popcount n = 1%N -> exists i : N, (2^i = n)%N.
Proof.
  destruct n as [|p]; simpl; [discriminate | intros def_Npcp].
  assert (Pos_popcount p = 1%positive) as def_pcp by (inversion def_Npcp; reflexivity).
  apply Pos_popcount_1_Is_power, Is_power_correct in def_pcp.
  destruct def_pcp as [y def_p]; rewrite def_p.
  specialize (shift_nat_correct y 1); rewrite Z.mul_1_r, Zpower_nat_Z; intros def_power.
  exists (N.of_nat y).
  rewrite <-N2Z.inj_iff, N2Z.inj_pow; simpl.
  rewrite def_power, nat_N_Z; reflexivity.
Qed.

Lemma N_double_succ:
  forall n,
  N.double (N.succ n) = N.succ (N.succ (N.double n)).
Proof.
  destruct n.
  * reflexivity.
  * reflexivity.
Qed.

Lemma Pop_popcount_diff:
  forall p1 p2,
  (N.pos (Pos_popcount p1) + N.pos (Pos_popcount p2) =
  N_popcount (Pos.ldiff p1 p2) + N_popcount (Pos.ldiff p2 p1) + N.double (N_popcount (Pos.land p2 p1)))%N.
Proof.
  induction p1; intros; destruct p2.
  all: try (
    simpl;
    try specialize (IHp1 p2);
    rewrite ?N_popcount_Ndouble, ?N_popcount_Nsucc_double,
            ?N_double_succ;
    zify; omega
  ).
  * simpl.
    destruct (Pos_popcount p2); simpl in *; try rewrite <- Pplus_one_succ_r; try reflexivity.
Qed.

Lemma N_popcount_diff:
  forall n1 n2,
  (N_popcount n1 + N_popcount n2 =
  N_popcount (N.ldiff n1 n2) + N_popcount (N.ldiff n2 n1) + N.double (N_popcount (N.land n2 n1)))%N.
Proof.
  intros. destruct n1, n2; try reflexivity.
  apply Pop_popcount_diff.
Qed.


Require Import Reals.
Require Import Lra.
Local Open Scope R_scope.
Require Import Vector.
Require Import utils.

Theorem R_isring : ring_theory 0 1 Rplus Rmult Rminus Ropp eq.
Proof.
  constructor.
  (* addition *)
  (* left identity *) apply Rplus_0_l.
  (* commutativity *) apply Rplus_comm.
  (* associativity *) intros; rewrite Rplus_assoc; easy.
  (* multiplication *)
  (* left identity *) apply Rmult_1_l.
  (* commutativity *) apply Rmult_comm.
  (* associativity *) intros; rewrite Rmult_assoc; easy.
  (* distributivity *) apply Rmult_plus_distr_r.
  (* sub = opp *) reflexivity.
  (* additive inverse *) apply Rplus_opp_r.
Qed.

Instance Rring : Ring R :=
  {
  r0 := 0;
  r1 := 1;
  radd := Rplus;
  rmult := Rmult;
  rainv := Ropp;
  rminus := Rminus;
  req := eq;
  isring := R_isring;
  }.

Theorem R_isfield : field_theory R0 R1 Rplus Rmult Rminus Ropp Rdiv Rinv eq.
Proof.
  constructor.
  (* ring axioms *) apply R_isring.
  (* 0 <> 1 *) apply R1_neq_R0.
  (* div = inv *) reflexivity.
  (* multiplicative inverse *) apply Rinv_l.
Qed.

Instance Rfield : Field R :=
  {
  fdiv := Rdiv;
  finv := Rinv;
  isfield := R_isfield;
  }.

Definition Rscalar_mult {A : Type} `{Field A} {n : nat}
           (k : R) (xs : t R n) :=
  map (fun x => rmult k x) xs.

Definition Raddition {A : Type} `{Field A} {n : nat}
           (xs ys : t R n) :=
  zipwith radd xs ys.

Theorem Raddition_commu {n : nat}
        (xs ys : t R n) : Raddition xs ys = Raddition ys xs.
Proof.
  unfold Raddition; apply zipwith_commu.
  intros a b; simpl; lra.
Qed.

Definition additive_inverse {A : Type} `{Field A} {n : nat} (x : t A n) : t A n :=
  map rainv x.

Fixpoint Vzero {F : Type} `{Ring F} (n : nat) : t F n :=
  match n with
  | 0 => nil F
  | S n' => cons F r0 n' (Vzero n')
  end.

Theorem R2_isvectorspace : vectorspace_theory Rscalar_mult Raddition (@Vzero R Rring 2).
Proof.
  split; intros.
  - apply Raddition_commu.
  - split; intros.
Admitted.

Instance R2 : VectorSpace R (t R 2) :=
  {
  vscalar_mult := Rscalar_mult;
  vaddition := Raddition;
  v0 := Vzero 2;
  isvectorspace := R2_isvectorspace;
  }.


Require Export Coq.Sorting.Permutation.
Require Export Omega.
Require Export List.
Export ListNotations.
Require Export hetList.
Require Import ZArith.
Open Scope Z_scope.

(*looks nicer in unicode*)
Definition int := Z.

Fixpoint sum (l : list int) : int :=
  match l with
      |hd::tl => hd + sum tl
      |List.nil => 0
  end.

(*split L l1 l2: L is composed of l1 and l2*)
Inductive split : list int -> list int -> list int -> Prop :=
|splitNil : split nil nil nil
|splitConsL : forall a x b1 b2 c,
                split a (b1++b2) c ->
                split (x::a) (b1++x::b2) c
|splitConsR : forall a x b c1 c2,
                split a b (c1++c2) ->
                split (x::a) b (c1++x::c2).

Inductive partition (k:int) (l:list int) : Prop :=
|partition_ : forall (l1 l2 : list int),
                sum l = k * 2 -> split l l1 l2 ->
                sum l1 = k -> sum l2 = k -> partition k l.

(*triple of integers*)
Definition vote : Type := prod (prod int int) int.

Definition add_votes v1 v2 :=
  match v1, v2 with
      |(a,b,c), (d,e,f) => (a+d,b+e,c+f)
  end.

Fixpoint score_votes vs :=
  match vs with
      |v::vs => add_votes v (score_votes vs)
      |nil => (0,0,0)
  end.

(*The convention here is that the first position corresponds to the
**candidate the manipulators want to win << p, a, b >> *)
Inductive p_wins : vote -> Prop :=
|p_wins_ : forall p a b, p > a -> p > b -> p_wins(p, a, b).

(*make a vote of weight 2k*)
Inductive mkVote k : vote -> Prop :=
|veto_a : mkVote k (k*2, 0, k*2)
|veto_b : mkVote k (k*2, k*2, 0).

(*construct a list of votes given a list of weights*)
Inductive mkVotes : list int -> list vote -> Prop :=
|mkVotesNil : mkVotes nil nil
|mkVotesNonNil : forall ks vs k v,
                   mkVotes ks vs -> mkVote k v ->
                   mkVotes (k::ks) (v::vs).

(*base_vote is the vote of the non manipulator.
**weights are the weights of the manipulators*)
Inductive manipulate (base_vote : vote) (weights : list int) : Prop :=
|manipulate_ : forall votes,
                 mkVotes weights votes ->
                 p_wins (score_votes (base_vote::votes)) ->
                 manipulate base_vote weights.

Definition reduce k (l:list int) := ((0,k*2-1,k*2-1), l).

Ltac inv H := inversion H; subst; clear H.

Ltac copy H :=
  match type of H with
      |?x => assert(x) by auto
  end.

Ltac invertHyp :=
  match goal with
      |H:exists x, ?P |- _ => inv H; try invertHyp
      |H:?A /\ ?B |- _ => inv H; try invertHyp
  end.

Theorem sumRemoveMid : forall a b c k, sum (a++b::c) = k ->
                                  sum (a++c) = k - b.
Proof.
  induction a; intros.
  {simpl in *. symmetry in H. apply Zplus_minus_eq in H. auto. }
  {simpl in *. symmetry in H. apply Zplus_minus_eq in H. eapply IHa in H.
   rewrite H. rewrite Z.add_sub_assoc. rewrite Zplus_minus. auto. }
Qed.

Ltac votesEq :=
  match goal with
      | |- (?a,?b,?c)=(?a,?b,?f) =>
        let n := fresh
        in assert(n:c=f) by omega; rewrite n; try votesEq
      | |- (?a,?b,?c)=(?a,?e,?f) =>
        let n := fresh
        in assert(n:b=e) by omega; rewrite n; try votesEq
      | |- (?a,?b,?c)=(?d,?e,?f) =>
        let n := fresh
        in assert(n:a=d) by omega; rewrite n; try votesEq
      | |- _ => eauto
  end.

Theorem mkVotesSum : forall weights l1 l2 k1 k2,
                       sum l1 = k1 -> sum l2 = k2 -> split weights l1 l2 ->
                       exists vs, mkVotes weights vs /\
                             score_votes vs = ((k1+k2)*2, k2*2, k1*2).
Proof.
  intros. genDeps {{ k1; k2 }}. induction H1; intros.
  {simpl in *. subst. exists nil. simpl. repeat constructor. }
  {apply sumRemoveMid in H. eapply IHsplit in H; eauto. invertHyp.
   exists ((x*2,0,x*2)::x0). split. constructor. auto. constructor.
   simpl. rewrite H0. votesEq. }
  {apply sumRemoveMid in H0. eapply IHsplit in H0; eauto. invertHyp.
   exists ((x*2,x*2,0)::x0). split. constructor. auto. constructor.
   simpl. rewrite H0. votesEq. }
Qed.

Theorem score_votes_total : forall vs,
                              exists s1 s2 s3, score_votes vs = (s1,s2,s3).
Proof.
  induction vs.
  {exists 0. exists 0. exists 0. simpl. auto. }
  {destruct a. destruct p. invertHyp. repeat econstructor.
   simpl. rewrite H. auto. }
Qed.

Theorem add_votesSub : forall k1 k2 k3 vs s1 s2 s3,
                         add_votes (k1,k2,k3) vs = (s1,s2,s3) ->
                         vs = (s1-k1,s2-k2,s3-k3).
Proof.
  intros. simpl in *. destruct vs. destruct p. inv H.
  repeat (rewrite <- Z.add_sub_assoc; rewrite Zplus_minus). auto.
Qed.

Definition multOf x k := exists y, y * k = x.

Theorem mustBe4K : forall weights k votes s1 s2 s3,
                 sum weights = k  ->
                 mkVotes weights votes ->
                 score_votes votes = (s1,s2,s3) ->
                 s1  = k * 2 /\ s2 + s3 = s1 /\ multOf s2 2 /\ multOf s3 2.
Proof.
  intros. genDeps {{ k; s1; s2; s3 }}. induction H0; intros.
  {simpl in *. inv H1. split; auto. split; auto. unfold multOf.
   split; exists 0; auto. }
  {simpl in *. symmetry in H2. apply Zplus_minus_eq in H2. inv H.
   {apply add_votesSub in H1. eapply IHmkVotes in H1; eauto. invertHyp.
    unfold multOf in *. invertHyp. split. omega. split. omega. split.
    exists (x0). omega. exists (x+k). omega. }
   {apply add_votesSub in H1. eapply IHmkVotes in H1; eauto. split. omega. split.
    omega. unfold multOf in *. invertHyp. split. exists (x0+k). omega. exists x. omega. }
  }
Qed.

Ltac solveByInv :=
  match goal with
      |H:_ |- _ => solve[inv H]
  end.

Theorem weightsToVotes : forall votes weights s1 s2 s3,
                  mkVotes weights votes ->
                  score_votes votes = (s1,s2,s3) ->
                  exists l1 l2, split weights l1 l2 /\ sum l1 * 2 = s2 /\ sum l2 * 2 = s3.
Proof.
  intros. genDeps {{ s1; s2; s3 }}. induction H; intros.
  {simpl in H0. inv H0. exists nil. exists nil. split. constructor. auto. }
  {simpl in H1. inv H0.
   {apply add_votesSub in H1. eapply IHmkVotes in H1. invertHyp.
    exists x. exists (nil++k::x0). split. constructor. simpl. auto. simpl.
    split; omega. }
   {apply add_votesSub in H1. eapply IHmkVotes in H1. invertHyp.
    exists (nil++k::x). exists x0. split. constructor. simpl. auto. simpl.
    split; omega. }
  }
Qed.

Theorem veto_npc : forall l k nonManipVote weights,
                     reduce k l = (nonManipVote, weights) -> sum l = k*2 ->
                     (partition k l <-> manipulate nonManipVote weights).
Proof.
  intros. split; intros.
  {unfold reduce in H. inv H. inversion H1. eapply mkVotesSum in H2; eauto.
   invertHyp. econstructor. eauto. simpl. rewrite H3. constructor; omega. }
  {unfold reduce in *. inv H. inv H1.
   assert(exists s1 s2 s3, score_votes votes = (s1,s2,s3)). apply score_votes_total.
   invertHyp. simpl in H2. rewrite H3 in H2. inv H2. copy H0.
   eapply mustBe4K in H1; eauto. invertHyp. unfold multOf in *. invertHyp.
   assert(x1 <= k). omega. assert(x <= k). omega. rewrite <- Z.mul_assoc in H1.
   simpl in H1. assert((x1+x) = k * 2). omega. assert(x1=k /\ x=k). omega. invertHyp.
   eapply weightsToVotes in H; eauto. invertHyp. econstructor; eauto.
   erewrite Z.mul_cancel_r in H; auto.  omega. erewrite Z.mul_cancel_r in H10; auto.
   omega. }
Qed.


(* -*- coding: utf-8; mode:coq -*-
 * Auto-generated - Do not edit or overwrite!
 *)

Require Import Arith. (* ouvre droit, notamment, à 'auto with arith' *)

Section exo1.

  (* Programme annoté :

  { y = 2 }
    Auto0:x <- (y + 3)
  { (x = 5 and y = 2) }

  *)

  (* Valeurs des Weakest Least Preconditions (WLP) *)
  Definition Post (x y : nat) := (x = 5 /\ y = 2).
  Definition Pre (x y : nat) := y = 2.
  Definition Auto0 (x y : nat) := ((y + 3) = 5 /\ y = 2).

  (* Obligations de preuve engendrées *)
  Lemma obligation_Pre : forall x y : nat,
    (y = 2 -> ((y + 3) = 5 /\ y = 2)).
  Proof.
    intros.
    split.
    rewrite H.
    trivial.
    assumption.
  Qed.

End exo1.


Require Import Bool Arith List Cpdt.CpdtTactics.

Notation "'Yes'" := (left _ _).
Notation "'No'" := (right _ _).
Notation "'Reduce' x" := (if x then Yes else No) (at level 50).

Definition compare : forall n m : nat, {n <= m} + {n > m}.
  refine (fix f (n m : nat) : {n <= m} + {n > m} :=
            match n, m with
            | O, _ => Yes
            | _, O => No
            | S n', S m' => Reduce (f n' m')
            end); crush.
Defined.


(* ###################################################################### *)
(* taken from http://www.cis.upenn.edu/~rrand/popl_2016/ *)
(** * Case study: Red-Black Trees *)

Open Scope bool_scope.
Require Import Coq.Arith.Arith_base.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import Psatz.

(** (We use [admit] and [Admitted] to hide solutions from exercises.) *)

Axiom admit : forall {T : Type}, T.

(** We will now see how we can use Coq's language to implement an
    interesting functional program: a red-black tree module. Red-black
    trees are binary search trees that use an intricate invariant to
    guarantee that they are well-balanced.

    We state our definitions inside of a Coq [Section], which allows
    us parameterize them by the type of elements to be
    stored. Specifically, we use the [Parameter] and [Hypothesis]
    keywords to introduce parameters and hypothesis that can be
    invoked in definitions and lemmas inside the [Section]. *)

Section RedBlack.

(** Our definitions are parameterized by a type [A] and a comparison
    function [comp] between elements of [A]. The [comparison] type is
    defined in the standard library, and represents the result of
    comparing two elements of a totally ordered type. *)

Parameter A : Type.
Parameter comp : A -> A -> comparison.
(* Inductive comparison : Type := Eq | Lt | Gt. *)

(** In order for our definitions to work, we must assume that a few
    properties hold of the [comp] operator. First, we assume that
    [comp] is _transitive_: that is, if [x] is less than [y] and [y]
    is less than [z], then [x] is less than [z]. *)

Hypothesis comp_trans :
  forall x y z, comp x y = Lt ->
                comp y z = Lt ->
                comp x z = Lt.

(** Next, we assume that [comp] is reflexive, and that elements that
    test for [Eq] are equal. *)

Hypothesis comp_refl_iff :
  forall x y, comp x y = Eq <-> x = y.

(** [A <-> B] ("A if and only if B") states that [A] and [B] are
    _logically equivalent_, i.e., that [A] implies [B] and [B] implies
    [A]. It can be applied in either direction with the [apply]
    tactic. It can also be rewritten with [rewrite]. *)

(** **** Exercise: 1 star (comp_refl)  *)
(** Practice the use of [rewrite] to prove the following. *)

Lemma comp_refl : forall x, comp x x = Eq.
Proof.
intro. rewrite comp_refl_iff. reflexivity.
Qed.
(* FILL IN HERE *)
(** [] *)

(** Finally, we assume that if [x] is less than [y], then [y] is
    greater than [x]. The [CompOpp] function swaps [Lt] and [Gt]. *)

Hypothesis comp_opp :
  forall x y, comp x y = CompOpp (comp y x).

(** Red-black trees are binary search trees that contain elements of
    [A] on their internal nodes, and such that every internal node is
    colored with either [Red] or [Black]. [Leaf] represents an empty
    tree. [Node c left x right] represents an internal node colored
    [c], with children [left] and [right], storing element [x : A]. *)

Inductive color := Red | Black.

Inductive tree :=
| Leaf : tree
| Node : color -> tree -> A -> tree -> tree.

(** **** Exercise: 2 stars (elements)  *)

(** Using the list functions we have already studied, complete the
    definition of the [elements] function below. Your implementation
    should perform an inorder traversal of the elements of [t] and
    accumulate them in a list. *)

Fixpoint elements (t : tree) : list A :=
 match t with
  | Leaf => []
  | Node _ l x r => (elements l) ++ x :: [] ++ (elements r)
 end.
(* FILL IN HERE *)
(** [] *)

(** Before getting into details about the red-black invariants, let's
    study the following function, which looks up an element [x] of [A]
    on a tree. *)

Fixpoint member x t : bool :=
  match t with
  | Leaf => false
  | Node _ t1 x' t2 =>
    match comp x x' with
    | Lt => member x t1
    | Eq => true
    | Gt => member x t2
    end
  end.

(** **** Exercise: 1 star (member_ex)  *)

(** To test your understanding of [member], prove the following
    result. *)

Example member_ex :
  forall x tl y tr,
    member x tl = true ->
    comp x y = Lt ->
    member x (Node Black tl y tr) = true.
Proof.
intros c tl y tr.
intros mem_left x_le_y.
simpl. rewrite x_le_y. rewrite mem_left. reflexivity.
Qed.
(* FILL IN HERE *)

(** [] *)

(** We want to state a specification for [member] and prove that it is
    valid. First, we formalize what it means for a tree to be a binary
    search tree. This requires the following function, which tests
    whether a property [f] holds of the elements of a tree [t]: *)

Fixpoint all (f : A -> bool) (t : tree) : bool :=
  match t with
  | Leaf => true
  | Node _ t1 x t2 => all f t1 && f x && all f t2
  end.

(** Let's prove the following simple property of [all], which will
    be useful later. *)

Lemma all_weaken :
  forall f g,
    (forall x, f x = true -> g x = true) ->
    forall t, all f t = true -> all g t = true.
Proof.
  intros f g Hfg t.

(** New tactic
    ----------

    - [trivial]: solves simple goals through [reflexivity] and by
      looking for assumptions in the context that apply directly. If
      it cannot solve the goal, it does nothing. *)

  induction t as [|c t1 IH1 x t2 IH2].
  - trivial.
  - simpl. intros H.

(** Often, tactics generate multiple subgoals that can be solved
    with simple (or very similar) proofs. We can handle these
    simultaneously using the tactic sequencing operator [;]. *)

(** New Tactics
    -----------

    - [;]: An expression such as [foo; bar] first calls [foo], then
      calls [bar] on all generated subgoals. A common idiom is [foo;
      trivial], which solves the trivial subgoals and does nothing on
      the remaining ones.

    - [try]: Calling [try foo] tries to execute [foo], doing nothing
      if [foo] raises any errors. In particular, if [foo] is a
      _terminating tactic_ such as [discriminate], [try foo] attempts
      to solve the goal, and does nothing if it fails.

    - [destruct ... eqn: ...]: Do case analysis on an expression while
      generating an equation. *)

(* WORKED IN CLASS *)
    destruct (all f t1) eqn:H1; try discriminate.
    destruct (f x) eqn:H2; try discriminate.
    destruct (all f t1) eqn:H3; try discriminate.
    rewrite IH1; trivial.
    rewrite Hfg; trivial.
    rewrite IH2; trivial.
Qed.

(** We can now state the binary-tree invariant: Each element [x]
    on an internal node is strictly greater than those to its left,
    and strictly smaller than those to its right. The auxiliary
    function [ltb] tests whether an element of [A] is smaller than
    another one. *)

Definition ltb x y :=
  match comp x y with
  | Lt => true
  | _ => false
  end.

Fixpoint search_tree (t : tree) : bool :=
  match t with
  | Leaf => true
  | Node _ t1 x t2 =>
    all (fun y => ltb y x) t1
    && all (ltb x) t2
    && search_tree t1
    && search_tree t2
  end.

(** In order to state the specification of [member], we define a
    function [occurs] that looks up an element [x] on all nodes of a
    tree [t]. The [eqb] function tests whether two elements of [A] are
    equal. *)

Definition eqb x y :=
  match comp x y with
  | Eq => true
  | _ => false
  end.

Fixpoint occurs (x : A) (t : tree) : bool :=
  match t with
  | Leaf => false
  | Node _ t1 y t2 => occurs x t1 || eqb x y || occurs x t2
  end.

(** **** Exercise: 2 stars (eqb_eq)  *)

(** Show that [eqb] implies equality. *)

Lemma eqb_eq : forall x y, eqb x y = true -> x = y.
Proof.

intros x y.
unfold eqb.
rewrite <- comp_refl_iff.
destruct comp eqn:f.
+ trivial.
+ intro. discriminate.
+ intro. discriminate.
Qed.

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

(** **** Exercise: 3 stars (none_occurs)  *)
(** If [x] is strictly smaller (or bigger) than the elements of a tree
    [t], we know that [x] cannot occur in [t], thanks to the following
    general result. Your job is to prove it and then use it to show
    the [member_prune_right] and [member_prune_left] lemmas below. *)

Lemma none_occurs :
  forall (x : A) (f : A -> bool) (t : tree),
    f x = false ->
    all f t = true ->
    occurs x t = false.
Proof.
intros.
destruct all eqn:H1.
induction t.
- trivial.
- simpl.

simpl in H1.
destruct (all f t1) eqn:H3; trivial.
destruct (all f t2) eqn:H4; trivial.
destruct (f a) eqn:H2; trivial.
rewrite IHt1 in H1.
rewrite IHt1.
rewrite IHt2.
+

destruct (all f t1) eqn:H1 in H0; try discriminate.
simpl in H0.
destruct (f a) eqn:H2; try discriminate.
simpl in H0.

apply IHt2 in H0.
apply IHt1 in H1.

simpl.
rewrite H0.
rewrite H1.

simpl.
unfold eqb.
rewrite <- H2.
destruct all eqn:H3.
destruct all eqn:H4.
destruct all eqn:H5.
rewrite <- H.
destruct comp; trivial.
- rewrite H. rewrite H2.

symmetry in IHt1.
simpl in H0.
destruct (all f t2) eqn:H2; try discriminate.
rewrite <- IHt1; trivial.
simpl.
rewrite IHt1; trivial.
rewrite IHt2; trivial.

simpl in H0.
simpl in H0.

simpl.

rewrite <- H.

unfold eqb.
destruct comp.
simpl.

apply f.
destruct eqb eqn:H4.
simpl.
destruct (all f t2); try discriminate.
rewrite <- IHt1; trivial.

induction (Node c t1 a t2).
++
trivial.
++

rewrite <- H.
destruct occurs.
++
rewrite <- H.
apply all.
rewrite <- IHt2.
rewrite IHt2.

destruct occurs.
rewrite IHt1.

destruct all in IHt1.

destruct occurs.
rewrite <- IHt1.
++

destruct all in IHt2.
destruct occurs.
destruct occurs eqn:H2 in IHt2.
destruct occurs eqn:H1 in IHt1.
rewrite <- IHt1.
destruct occurs eqn:H1.
destruct occurs eqn:H2 in IHt2.
rewrite <- IHt1.
rewrite IHt2.
destruct occurs eqn:H3.
destruct occurs.
rewrite <- IHt1.
++
+++
rewrite <- H0.

trivial.
simpl.
rewrite <- H.

simpl.
simpl in H0.
trivial.
simpl in H0.

++
destruct H0 eqn:H1.
++
simpl.

+++

simpl.

unfold occurs.

unfold all in H0.
++

(* FILL IN HERE *) Admitted.

Lemma member_prune_right :
  forall x y t,
    comp y x = Lt ->
    all (ltb x) t = true ->
    occurs y t = false.
Proof.
(* FILL IN HERE *) Admitted.

Lemma member_prune_left :
  forall x y t,
    comp y x = Gt ->
    all (fun z => ltb z x) t = true ->
    occurs y t = false.
Proof.
(* FILL IN HERE *) Admitted.

(** [] *)

(** With these results, we are ready to prove the correctness of
    [member]. Notice that we state the lemma in a slightly different
    form, using an [if] expression instead of an implication
    ([->]). This allows the Coq simplification engine to perform a few
    deduction steps as we progress through the proof. *)

Lemma member_correct :
  forall x t,
    if search_tree t then member x t = occurs x t
    else True.
Proof.
  intros x t.
  induction t as [|c t1 IH1 y t2 IH2]; simpl; trivial.
  destruct (all (fun z => ltb z y) t1) eqn:H1; simpl; trivial.
  destruct (all (ltb y) t2) eqn:H2; simpl; trivial.

(** Notice how the induction hypotheses change after the following
    lines. *)

  destruct (search_tree t1) eqn:H3; simpl; trivial.
  destruct (search_tree t2) eqn:H4; simpl; trivial.
  unfold eqb. rewrite IH1, IH2.

(** Note that we can apply lemmas with universally quantified
    variables and hypotheses as functions. This has the effect of
    instantiating these quantified variables and providing proofs for
    the required hypotheses directly. *)
(** Cf. the use of [member_prune_left] and [member_prune_right]
    below. *)

(* WORKED IN CLASS *)
  destruct (comp x y) eqn:Hxy.
  - rewrite Bool.orb_true_r. reflexivity.
  - rewrite (member_prune_right y x t2 Hxy H2).
    rewrite Bool.orb_false_r. rewrite Bool.orb_false_r. reflexivity.
  - rewrite (member_prune_left y x t1 Hxy H1). reflexivity.
Qed.

(** ** The Invariant

    We now turn our attention to the actual red-black invariant. A
    red-black tree is _valid_ if (1) all paths from the root of the
    tree to its leaves go through the same number of black nodes, and
    (2) if red nodes only have black children (we stipulate that the
    leaves of the tree are black). *)
(** The [well_colored] function below checks whether (2) holds
    or not. To check (1), we use the [black_height] function defined
    below: [black_height n t] returns [true] if and only if every path
    from the root of the tree to a leaf goes through exactly [n] black
    nodes. *)

Definition tree_color (t : tree) : color :=
  match t with
  | Leaf => Black
  | Node c _ _ _ => c
  end.

Fixpoint well_colored (t : tree) : bool :=
  match t with
  | Leaf => true
  | Node c t1 _ t2 =>

    let colors_ok :=
      match c, tree_color t1, tree_color t2 with
      | Red, Black, Black => true
      | Red, _, _ => false
      | Black, _, _ => true
      end in
    colors_ok && well_colored t1 && well_colored t2
  end.

Fixpoint black_height n (t : tree) : bool :=
  match t, n with
  | Leaf, 0 => true
  | Node Red tl _ tr, _ =>
    black_height n tl && black_height n tr
  | Node Black tl _ tr, S n =>
    black_height n tl && black_height n tr
  | _, _ => false
  end.

(** We combine both invariants in a single [is_red_black]
    function: *)

Definition is_red_black n (t : tree) : bool :=
  well_colored t && black_height n t.

(** The red-black invariant implies that the height of the tree is
    logarithmic on the number of nodes. To prove that this is the
    case, we define a [size] function for computing various measures
    on trees. Notice that [size] takes a function argument, which
    determines which measure [size] actually computes. We can see that
    [size max] computes the height of the tree, [size min] computes
    the size of the smallest path from the root to a leaf, and [size
    plus] computes the total number of elements stored on the tree. *)

Fixpoint size (f : nat -> nat -> nat) (t : tree) : nat :=
  match t with
  | Leaf => 0
  | Node _ t1 _ t2 => S (f (size f t1) (size f t2))
  end.

(** It seems natural to claim that the black height of a tree is at
    most the size of its minimal path. Showing this result is
    easy. Here, we use the order relation on naturals provided by the
    standard library. *)

Lemma size_min_black_height :
  forall t n,
    if black_height n t then n <= size min t
    else True.
Proof.
  intros t.
  induction t as [|[] tl IHl x tr IHr]; intros n; simpl.
  - destruct n as [|n]; trivial.

(** Many of the results we will encounter involve integer
    inequalities. To solve these goals, we can use the [lia] tactic.

    New Tactics
    -----------

    - [lia]: Short for "Linear Integer Arithmetic"; tries to solve
      goals that involve linear systems of inequalites on integers.

    - [specialize]: Instantiate a universally quantified hypothesis *)

  - specialize (IHl n). specialize (IHr n).
    destruct (black_height n tl); trivial. simpl.
    destruct (black_height n tr); trivial. lia.

(* WORKED IN CLASS *)
  - destruct n as [|n]; trivial.
    specialize (IHl n). specialize (IHr n).
    destruct (black_height n tl); trivial. simpl.
    destruct (black_height n tr); trivial. lia.
Qed.

(** We also need to relate the black and maximal heights of a
    tree. Unlike the preceeding lemma, however, this result requires a
    clever generalization to allow the induction to go through. *)

(** **** Exercise: 2 stars (size_max_black_height)  *)

(** The last part of the following proof covers trees with black
    roots, and is very similar to the analogous one for red
    roots. Your job is to complete it. *)

Lemma size_max_black_height :
  forall t n,
    if is_red_black n t then
      match tree_color t with
      | Red => size max t <= 2 * n + 1
      | Black => size max t <= 2 * n
      end
    else True.
Proof.
  intros t. unfold is_red_black.
  induction t as [|[] tl IHl x tr IHr]; simpl; intros n.
  - (* t is a Leaf *)
    destruct n; trivial.
  - (* t has a red root *)
    destruct (tree_color tl); simpl; trivial.
    destruct (tree_color tr); simpl; trivial.
    specialize (IHl n). specialize (IHr n).
    destruct (well_colored tl); simpl in *; trivial.
    destruct (well_colored tr); simpl in *; trivial.
    destruct (black_height n tl); simpl in *; trivial.
    destruct (black_height n tr); simpl in *; trivial.
    lia.
  - (* t has a black root *)
    (* FILL IN HERE *) admit.
Qed.

(** [] *)

(** **** Exercise: 3 stars (size_max_size_min)  *)

(** The previous two results imply the next one, which relates the
    height of the tree to the length of its mininal path. The [assert]
    tactic is used below to bring those results into the context as
    explicit hypotheses. Finish the proof. *)

Lemma size_max_size_min :
  forall t n,
    if is_red_black n t then size max t <= 2 * size min t + 1
    else True.
Proof.
  intros t n.
  assert (H1 := size_min_black_height t n).
  assert (H2 := size_max_black_height t n).
  unfold is_red_black in *.
(* FILL IN HERE *) Admitted.

(** [] *)

(** Finally, we derive the bound we sought by appealing to the
    following lemma, proved using results from Coq's standard
    library.

    New Tactics
    -----------

    - [assert]: Introduce a new hypothesis in the context, requiring
      us to prove that it holds. The curly braces [{}] allow us to
      focus on the current subgoal, like [+] and [-]. *)

Lemma size_min_size_plus :
  forall t,
    size min t <= log2 (size plus t + 1).
Proof.
  intros t. apply Nat.log2_le_pow2; try lia.
  induction t as [|c t1 IH1 x t2 IH2]; simpl; trivial.
  assert (H1 : 2 ^ min (size min t1) (size min t2)
               <= 2 ^ size min t1).
  { apply Nat.pow_le_mono_r; lia. }
  assert (H2 : 2 ^ min (size min t1) (size min t2)
               <= 2 ^ size min t2).
  { apply Nat.pow_le_mono_r; lia. }
  lia.
Qed.

Lemma is_red_black_balanced :
  forall t n,
    is_red_black n t = true ->
    size max t <= 2 * log2 (size plus t + 1) + 1.
Proof.
  intros t n H.
  assert (H1 := size_max_size_min t n). rewrite H in H1.
  assert (H2 := size_min_size_plus t). lia.
Qed.

(** ** Insertion

    Knowing that red-black trees are balanced would be useless if that
    invariant were not preserved by tree operations. To conclude this
    module, we define an insertion operation and show that it
    preserves the red-black invariant.

    Our definition is adapted from Chris Okasaki's classical paper
    "Red-Black Trees in a Functional Setting". It is essentially a
    standard insertion function on binary trees, except for an
    additional balancing step for restoring the tree invariants. *)

Definition balance_black_left tl x tr : tree :=
  match tl, x, tr with
  | Node Red (Node Red t1 x1 t2) x2 t3, x3, t4
  | Node Red t1 x1 (Node Red t2 x2 t3), x3, t4 =>
    Node Red (Node Black t1 x1 t2) x2 (Node Black t3 x3 t4)
  | _, _, _ => Node Black tl x tr
  end.

Definition balance_black_right tl x tr : tree :=
  match tl, x, tr with
  | t1, x1, Node Red (Node Red t2 x2 t3) x3 t4
  | t1, x1, Node Red t2 x2 (Node Red t3 x3 t4) =>
    Node Red (Node Black t1 x1 t2) x2 (Node Black t3 x3 t4)
  | _, _, _ => Node Black tl x tr
  end.

Definition balance_left c t1 x t2 : tree :=
  match c with
  | Red => Node c t1 x t2
  | Black => balance_black_left t1 x t2
  end.

Definition balance_right c t1 x t2 : tree :=
  match c with
  | Red => Node c t1 x t2
  | Black => balance_black_right t1 x t2
  end.

Fixpoint insert_aux x t : tree :=
  match t with
  | Leaf => Node Red Leaf x Leaf
  | Node c t1 x' t2 =>
    match comp x x' with
    | Eq => t (* Element was already present *)
    | Lt => balance_left c (insert_aux x t1) x' t2
    | Gt => balance_right c t1 x' (insert_aux x t2)
    end
  end.

Definition make_black t : tree :=
  match t with
  | Leaf => Leaf
  | Node _ t1 x t2 => Node Black t1 x t2
  end.

Definition insert x t : tree :=
  make_black (insert_aux x t).

(** The next lemmas are not strictly necessary, but they greatly
    help us reasoning about the behavior of the balancing functions
    above. Although they rely on a feature that we're not discussing
    here in detail -- namely, _inductive propositions_ --, their use
    is relatively simple, and is illustrated in the proof of the
    [black_height_balance_left] lemma below. *)

Inductive balance_left_spec : color -> tree -> A -> tree -> tree -> Prop :=
| BalanceLeftSpec1 :
    forall t1 x1 t2 x2 t3 x3 t4,
      balance_left_spec Black (Node Red (Node Red t1 x1 t2) x2 t3) x3 t4
                        (Node Red (Node Black t1 x1 t2) x2 (Node Black t3 x3 t4))
| BalanceLeftSpec2 :
    forall t1 x1 t2 x2 t3 x3 t4,
      balance_left_spec Black (Node Red t1 x1 (Node Red t2 x2 t3)) x3 t4
                        (Node Red (Node Black t1 x1 t2) x2 (Node Black t3 x3 t4))
| BalanceLeftSpec3 :
    forall c t1 x t2,
      balance_left_spec c t1 x t2 (Node c t1 x t2).

Lemma case_balance_left :
  forall c t1 x t2,
    balance_left_spec c t1 x t2 (balance_left c t1 x t2).
Proof.
  intros [] t1 x t2; simpl; try constructor.
  destruct t1 as [|[] [|[]] ? [|[]]]; simpl; constructor.
Qed.

Inductive balance_right_spec : color -> tree -> A -> tree -> tree -> Prop :=
| BalanceRightSpec1 :
    forall t1 x1 t2 x2 t3 x3 t4,
      balance_right_spec Black t1 x1 (Node Red (Node Red t2 x2 t3) x3 t4)
                         (Node Red (Node Black t1 x1 t2) x2 (Node Black t3 x3 t4))
| BalanceRightSpec2 :
    forall t1 x1 t2 x2 t3 x3 t4,
      balance_right_spec Black t1 x1 (Node Red t2 x2 (Node Red t3 x3 t4))
                         (Node Red (Node Black t1 x1 t2) x2 (Node Black t3 x3 t4))
| BalanceRightSpec3 :
    forall c t1 x t2,
      balance_right_spec c t1 x t2 (Node c t1 x t2).

Lemma case_balance_right :
  forall c t1 x t2,
    balance_right_spec c t1 x t2 (balance_right c t1 x t2).
Proof.
  intros [] t1 x t2; simpl; try constructor.
  destruct t2 as [|[] [|[]] ? [|[]]]; simpl; constructor.
Qed.

Lemma black_height_balance_left :
  forall c t1 x t2 n,
    black_height n (balance_left c t1 x t2)
    = black_height n (Node c t1 x t2).
Proof.
  intros c t1 x t2 n.
  destruct (case_balance_left c t1 x t2)
    as [t1 x1 t2 x2 t3 x3 t4|t1 x1 t2 x2 t3 x3 t4|c t1 x t2]; simpl; trivial.
  - destruct n as [|n]; trivial.
    rewrite Bool.andb_assoc. reflexivity.
  - destruct n as [|n]; trivial.
    rewrite Bool.andb_assoc, Bool.andb_assoc.
    reflexivity.
Qed.

(** **** Exercise: 2 stars (black_height_balance_right)  *)

(** Using the previous lemma as a template, complete the proof of
    [black_height_balance_right] below. *)

Lemma black_height_balance_right :
  forall c t1 x t2 n,
    black_height n (balance_right c t1 x t2)
    = black_height n (Node c t1 x t2).
Proof.
(* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 3 stars (height_ok_insert_aux)  *)

(** Use the last two results to show that the black height invariant
    is preserved by [insert_aux]. *)

Lemma height_ok_insert_aux :
  forall x t n,
    black_height n (insert_aux x t)
    = black_height n t.
Proof.
(* FILL IN HERE *) Admitted.

(** [] *)

(** The most complicated part of the invariant preservation proof for
    the insertion algorithm is showing that nodes are still colored
    correctly after an insertion step. One problem is that, even after
    a balancing step, [insert_aux] may produce a tree that is colored
    incorrectly at its root. We formalize this property with the
    following definition: *)

Definition almost_well_colored t : bool :=
  match t with
  | Leaf => true
  | Node _ t1 _ t2 => well_colored t1 && well_colored t2
  end.

(** **** Exercise: 1 star (well_colored_weaken)  *)

(** Show that well-colored trees are almost well-colored. *)

Lemma well_colored_weaken :
  forall t,
    well_colored t = true ->
    almost_well_colored t = true.
Proof.
(* FILL IN HERE *) Admitted.

(** [] *)

(** The following two lemmas show that tree balancing restores the
    coloring invariant if one of the trees is almost
    well-colored. They use more advanced proof automation features to
    consider many of the cases arising in this proof at once. You
    don't have to understand how these proofs work right now, but they
    will be needed later for showing our final result. *)

Lemma well_colored_balance_black_left :
  forall t1 x t2,
    almost_well_colored t1 = true ->
    well_colored (balance_black_left t1 x t2)
    = well_colored t2.
Proof.
  intros t1 x t2.
  refine (match t1 with
          | Node Red (Node Red _ _ _) _ _ => _
          | Node Red _ _ (Node Red _ _ _) => _
          | _ => _
          end); simpl; try reflexivity;
  repeat match goal with
  | |- context[match ?b with _ => _ end] =>
    destruct b; simpl; try discriminate
  | |- context[?b && _ = true] =>
    destruct b; simpl; try discriminate
  | |- _ = true -> _ =>
    intros H; rewrite H
  end; reflexivity.
Qed.

Lemma well_colored_balance_black_right :
  forall t1 x t2,
    almost_well_colored t2 = true ->
    well_colored (balance_black_right t1 x t2)
    = well_colored t1.
Proof.
  intros t1 x t2.
  refine (match t2 with
          | Node Red (Node Red _ _ _) _ _ => _
          | Node Red _ _ (Node Red _ _ _) => _
          | _ => _
          end); simpl; try reflexivity;
  repeat match goal with
  | |- ?b = true -> _ =>
    match b with
    | context[tree_color ?t] =>
      destruct (tree_color t); simpl; try discriminate
    | context[well_colored ?t] =>
      destruct (well_colored t); simpl; try discriminate
    end
  end; repeat rewrite Bool.andb_true_r; reflexivity.
Qed.

Lemma well_colored_insert_aux :
  forall x t,
    if well_colored t then
      match tree_color t with
      | Red => almost_well_colored (insert_aux x t)
      | Black => well_colored (insert_aux x t)
      end = true
    else True.
Proof.
  intros x t.
  induction t as [|[] t1 IH1 x' t2 IH2]; trivial; simpl.
  - reflexivity.
  - destruct (tree_color t1); simpl; trivial.
    destruct (tree_color t2); simpl; trivial.
    destruct (comp x x'); simpl.
    + destruct (well_colored t1 && well_colored t2); trivial.
    + destruct (well_colored t1); simpl; trivial.
      destruct (well_colored t2); simpl; trivial.
      rewrite IH1. reflexivity.
    + destruct (well_colored t1); simpl; trivial.
  - destruct (comp x x'); simpl.
    + destruct (well_colored t1 && well_colored t2); trivial.
    + destruct (well_colored t1); simpl; trivial.
      assert (IH1' : almost_well_colored (insert_aux x t1) = true).
      { destruct (tree_color t1); trivial.
        apply well_colored_weaken. trivial. }
      rewrite well_colored_balance_black_left; trivial.
      destruct (well_colored t2); trivial.
    + rewrite Bool.andb_comm.
      destruct (well_colored t2); simpl; trivial.
      assert (IH1' : almost_well_colored (insert_aux x t2) = true).
      { destruct (tree_color t2); trivial.
        apply well_colored_weaken. trivial. }
      rewrite well_colored_balance_black_right; trivial.
      destruct (well_colored t1); trivial.
Qed.

Definition new_height n c :=
  match c with
  | Red => S n
  | Black => n
  end.

Lemma black_height_make_black :
  forall t n,
    black_height (new_height n (tree_color t)) (make_black t)
    = black_height n t.
Proof. intros [|[] t1 x t2]; reflexivity. Qed.

Lemma almost_well_colored_make_black :
  forall t, well_colored (make_black t) = almost_well_colored t.
Proof. intros [|c t1 x t2]; reflexivity. Qed.

Lemma is_red_black_insert :
  forall x n t,
    if is_red_black n t then
      is_red_black (new_height n (tree_color (insert_aux x t))) (insert x t) = true
    else True.
Proof.
  intros x n t.
  unfold insert, is_red_black.
  assert (H1 := well_colored_insert_aux x t).
  assert (H2 := height_ok_insert_aux x t).
  rewrite black_height_make_black.
  rewrite H2.
  rewrite almost_well_colored_make_black.
  destruct (well_colored t); simpl; trivial.
  destruct (tree_color t).
  - rewrite H1. destruct (black_height n t); trivial.
  - rewrite well_colored_weaken; trivial.
    destruct (black_height n t); trivial.
Qed.

End RedBlack.


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

(** Properties of the greatest common divisor *)

Require Import NAxioms NSub NZGcd.

Module Type NGcdProp
 (Import A : NAxiomsSig')
 (Import B : NSubProp A).

 Include NZGcdProp A A B.

(** Results concerning divisibility*)

Definition divide_1_r n : (n | 1) -> n == 1
 := divide_1_r_nonneg n (le_0_l n).

Definition divide_antisym n m : (n | m) -> (m | n) -> n == m
 := divide_antisym_nonneg n m (le_0_l n) (le_0_l m).

Lemma divide_add_cancel_r : forall n m p, (n | m) -> (n | m + p) -> (n | p).
Proof.
 intros n m p (q,Hq) (r,Hr).
 exists (r-q). rewrite mul_sub_distr_r, <- Hq, <- Hr.
 now rewrite add_comm, add_sub.
Qed.

Lemma divide_sub_r : forall n m p, (n | m) -> (n | p) -> (n | m - p).
Proof.
 intros n m p H H'.
 destruct (le_ge_cases m p) as [LE|LE].
 apply sub_0_le in LE. rewrite LE. apply divide_0_r.
 apply divide_add_cancel_r with p; trivial.
 now rewrite add_comm, sub_add.
Qed.

(** Properties of gcd *)

Definition gcd_0_l n : gcd 0 n == n := gcd_0_l_nonneg n (le_0_l n).
Definition gcd_0_r n : gcd n 0 == n := gcd_0_r_nonneg n (le_0_l n).
Definition gcd_diag n : gcd n n == n := gcd_diag_nonneg n (le_0_l n).
Definition gcd_unique' n m p := gcd_unique n m p (le_0_l p).
Definition gcd_unique_alt' n m p := gcd_unique_alt n m p (le_0_l p).
Definition divide_gcd_iff' n m := divide_gcd_iff n m (le_0_l n).

Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m.
Proof.
 intros. apply gcd_unique_alt'.
 intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial.
 apply divide_add_r; trivial. now apply divide_mul_r.
 apply divide_add_cancel_r with (p*n); trivial.
 now apply divide_mul_r. now rewrite add_comm.
Qed.

Lemma gcd_add_diag_r : forall n m, gcd n (m+n) == gcd n m.
Proof.
 intros n m. rewrite <- (mul_1_l n) at 2. apply gcd_add_mult_diag_r.
Qed.

Lemma gcd_sub_diag_r : forall n m, n<=m -> gcd n (m-n) == gcd n m.
Proof.
 intros n m H. symmetry.
 rewrite <- (sub_add n m H) at 1. apply gcd_add_diag_r.
Qed.

(** On natural numbers, we should use a particular form
  for the Bezout identity, since we don't have full subtraction. *)

Definition Bezout n m p := exists a b, a*n == p + b*m.

Instance Bezout_wd : Proper (eq==>eq==>eq==>iff) Bezout.
Proof.
 unfold Bezout. intros x x' Hx y y' Hy z z' Hz.
 setoid_rewrite Hx. setoid_rewrite Hy. now setoid_rewrite Hz.
Qed.

Lemma bezout_1_gcd : forall n m, Bezout n m 1 -> gcd n m == 1.
Proof.
 intros n m (q & r & H).
 apply gcd_unique; trivial using divide_1_l, le_0_1.
 intros p Hn Hm.
 apply divide_add_cancel_r with (r*m).
 now apply divide_mul_r.
 rewrite add_comm, <- H. now apply divide_mul_r.
Qed.

(** For strictly positive numbers, we have Bezout in the two directions. *)

Lemma gcd_bezout_pos_pos : forall n, 0<n -> forall m, 0<m ->
 Bezout n m (gcd n m) /\ Bezout m n (gcd n m).
Proof.
 intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn.
 pattern n. apply strong_right_induction with (z:=1); trivial.
 unfold Bezout. solve_proper.
 clear n Hn. intros n Hn IHn.
 intros m Hm. rewrite <- le_succ_l, <- one_succ in Hm.
 pattern m. apply strong_right_induction with (z:=1); trivial.
 unfold Bezout. solve_proper.
 clear m Hm. intros m Hm IHm.
 destruct (lt_trichotomy n m) as [LT|[EQ|LT]].
 (* n < m *)
 destruct (IHm (m-n)) as ((a & b & EQ), (a' & b' & EQ')).
 rewrite one_succ, le_succ_l.
 apply lt_add_lt_sub_l; now nzsimpl.
 apply sub_lt; order'.
 split.
 exists (a+b). exists b.
 rewrite mul_add_distr_r, EQ, mul_sub_distr_l, <- add_assoc.
 rewrite gcd_sub_diag_r by order.
 rewrite sub_add. reflexivity. apply mul_le_mono_l; order.
 exists a'. exists (a'+b').
 rewrite gcd_sub_diag_r in EQ' by order.
 rewrite (add_comm a'), mul_add_distr_r, add_assoc, <- EQ'.
 rewrite mul_sub_distr_l, sub_add. reflexivity. apply mul_le_mono_l; order.
 (* n = m *)
 rewrite EQ. rewrite gcd_diag.
 split.
 exists 1. exists 0. now nzsimpl.
 exists 1. exists 0. now nzsimpl.
 (* m < n *)
 rewrite gcd_comm, and_comm.
 apply IHn; trivial.
 now rewrite <- le_succ_l, <- one_succ.
Qed.

Lemma gcd_bezout_pos : forall n m, 0<n -> Bezout n m (gcd n m).
Proof.
 intros n m Hn.
 destruct (eq_0_gt_0_cases m) as [EQ|LT].
 rewrite EQ, gcd_0_r. exists 1. exists 0. now nzsimpl.
 now apply gcd_bezout_pos_pos.
Qed.

(** For arbitrary natural numbers, we could only say that at least
  one of the Bezout identities holds. *)

Lemma gcd_bezout : forall n m,
 Bezout n m (gcd n m) \/ Bezout m n (gcd n m).
Proof.
 intros n m.
 destruct (eq_0_gt_0_cases n) as [EQ|LT].
 right. rewrite EQ, gcd_0_l. exists 1. exists 0. now nzsimpl.
 left. now apply gcd_bezout_pos.
Qed.

Lemma gcd_mul_mono_l :
  forall n m p, gcd (p * n) (p * m) == p * gcd n m.
Proof.
 intros n m p.
 apply gcd_unique'.
 apply mul_divide_mono_l, gcd_divide_l.
 apply mul_divide_mono_l, gcd_divide_r.
 intros q H H'.
 destruct (eq_0_gt_0_cases n) as [EQ|LT].
 rewrite EQ in *. now rewrite gcd_0_l.
 destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial.
 apply divide_add_cancel_r with (p*m*b).
 now apply divide_mul_l.
 rewrite <- mul_assoc, <- mul_add_distr_l, add_comm, (mul_comm m), <- EQ.
 rewrite (mul_comm a), mul_assoc.
 now apply divide_mul_l.
Qed.

Lemma gcd_mul_mono_r :
 forall n m p, gcd (n*p) (m*p) == gcd n m * p.
Proof.
 intros. rewrite !(mul_comm _ p). apply gcd_mul_mono_l.
Qed.

Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p).
Proof.
 intros n m p H G.
 destruct (eq_0_gt_0_cases n) as [EQ|LT].
 rewrite EQ in *. rewrite gcd_0_l in G. now rewrite <- (mul_1_l p), <- G.
 destruct (gcd_bezout_pos n m) as (a & b & EQ); trivial.
 rewrite G in EQ.
 apply divide_add_cancel_r with (m*p*b).
 now apply divide_mul_l.
 rewrite (mul_comm _ b), mul_assoc. rewrite <- (mul_1_l p) at 2.
 rewrite <- mul_add_distr_r, add_comm, <- EQ.
 now apply divide_mul_l, divide_factor_r.
Qed.

Lemma divide_mul_split : forall n m p, n ~= 0 -> (n | m * p) ->
 exists q r, n == q*r /\ (q | m) /\ (r | p).
Proof.
 intros n m p Hn H.
 assert (G := gcd_nonneg n m). le_elim G.
 destruct (gcd_divide_l n m) as (q,Hq).
 exists (gcd n m). exists q.
 split. now rewrite mul_comm.
 split. apply gcd_divide_r.
 destruct (gcd_divide_r n m) as (r,Hr).
 rewrite Hr in H. rewrite Hq in H at 1.
 rewrite mul_shuffle0 in H. apply mul_divide_cancel_r in H; [|order].
 apply gauss with r; trivial.
 apply mul_cancel_r with (gcd n m); [order|].
 rewrite mul_1_l.
 rewrite <- gcd_mul_mono_r, <- Hq, <- Hr; order.
 symmetry in G. apply gcd_eq_0 in G. destruct G as (Hn',_); order.
Qed.

(** TODO : relation between gcd and division and modulo *)

(** TODO : more about rel_prime (i.e. gcd == 1), about prime ... *)

End NGcdProp.


(*|
###########################################################################
Coq can't compute a well-founded function on ``Z``, but it works on ``nat``
###########################################################################

:Link: https://stackoverflow.com/q/44186751
|*)

(*|
Question
********

I'm writing (for myself) an explanation of how to do well-founded
recursion in Coq. (see i.e. the Coq'Art book, chapter 15.2). First I
made an example function based on ``nat`` and that worked fine, but
then I did it again for ``Z``, and when I use ``Compute`` to evaluate
it, it doesn't reduce all the way down to a ``Z`` value. Why?

Here is my example (I put the text inside comments so one can
copy-paste the whole thing into your editor):
|*)

(* Test of well-founded recursion *)

(* TL;DR: To do well-founded recursion, first create 'functional' and
then create the recursive function using Acc_iter, the iterator for
accessible relations *)

(* As an example, compute the sum of the series from 1 to n, something
like this sketch:

fix f n := (if n = 0 then 0 else n + f (n-1))

Now, let's not use structural recursion on n.

Instead, we use well-founded recursion on n, using that the relation
less-than ('lt') is wellfounded. The function f terminates because the
recursive call is made on a structurally smaller term (in the
decreasing Acc-chain). *)

(* First we do it for nat *)

Require Import Arith.Arith.
Require Import Program.Utils. (* for 'dec' *)
Require Import Wellfounded.

(* From a proof that a relation is wellfounded, we can get a proof
that a particular element in its domain is accessible.

The Check commands here are not necessary, just for documentation,
dear reader. *)

Check well_founded : forall A : Type, (A -> A -> Prop) -> Prop.
Check lt_wf : well_founded lt.
Check (lt_wf 4711 : Acc lt 4711).

(* First define a 'functional' F for f. It is a function that takes a
function F_rec for the 'recursive call' as an argument. Because we
need to know n <> 0 in the second branch we use 'dec' to turn the
boolean if-condition into a sumbool. This we get info about it into
the branches.

We write most of it with refine, and leave some holes to be filled in
with tactics later. *)

Definition F (n : nat) (F_rec : (forall y : nat, y < n -> nat)) : nat.
  refine (if dec (n =? 0) then 0 else n + (F_rec (n - 1) _ )).
  (* now we need to show that n-1 < n, which is true for nat if n<>0 *)
  destruct n; now auto with *.
Defined.

(* The functional can be used by an iterator to call f as many times
as is needed.

Side note: One can either make an iterator that takes the maximal
recursive depth d as a nat argument, and recurses on d, but then one
has to provide d, and also a 'default value' to return in case d
reaches zero and one must terminate early.

The neat thing with well-founded recursion is that the iterator can
recurse on the proof of wellfoundedness and doesnt need any other
structure or default value to guarantee it will terminate. *)

(* The type of Acc_iter is pretty hairy *)

Check Acc_iter :
  forall (A : Type) (R : A -> A -> Prop) (P : A -> Type),
    (forall x : A, (forall y : A, R y x -> P y) -> P x) ->
    forall x : A, Acc R x -> P x.

(* P is there because the return type could be dependent on the
argument, but in our case, f:nat->nat, and R = lt, so we have *)

Check Acc_iter (R:=lt) (fun _:nat=>nat) :
  (forall n : nat, (forall y : nat, y < n -> nat) -> nat) ->
  forall n : nat, Acc lt n -> nat.

(* Here the first argument is the functional that the iterator takes,
the second argument n is the input to f, and the third argument is a
proof that n is accessible. The iterator returns the value of f
applied to n.

Several of Acc_iter's arguments are implicit, and some can be
inferred. Thus we can define f simply as follows: *)

Definition f n := Acc_iter _ F (lt_wf n).

(* It works like a charm *)

Compute (f 50). (* This prints 1275 *)
Check eq_refl : f 50 = 1275.

(* Now let's do it for Z. Here we can't use lt, or lt_wf because they
are for nat. For Z we can use Zle and (Zwf c) which takes a lower
bound. It needs a lower bound under which we know that the function
will always terminate to guarantee termination. Here we use (Zwf 0) to
say that our function will always terminate at or below 0. We also
have to change the if-statement to 'if n <= 0 then 0 else ...' so we
return zero for arguments less than zero. *)

Require Import ZArith.
Require Import Zwf.

Open Scope Z.

(* Now we define the function g based on the functional G *)

Definition G (n : Z) (G_rec : (forall y : Z, Zwf 0 y n -> Z)) : Z.
  refine (if dec (n <? 0) then 0 else n + (G_rec (n - 1) _ )).
  (* now we need to show that n-1 < n *)
  now split; [apply Z.ltb_ge | apply Z.lt_sub_pos].
Defined.

Definition g n := Acc_iter _ G (Zwf_well_founded 0 n).

(* But now we can't compute! *)

Compute (g 1).

(* We just get a huge a term *)

(*|
Comment: I noticed that ``Zwf_well_founded`` is defined as ``Opaque``
in the library, so I tried to make it ``Transparent`` by copying the
proof and ending the lemma with ``Defined.`` instead of ``Qed.`` but
that didn't help...

Added observation:

If I define ``f'`` for ``nat`` with ``Fixpoint`` instead, and recurse
on the accesibility proof, *and end with* ``Defined``. then it
computes. But if I end with ``Qed.``. it doesn't reduce. Is this
related? I guess there is an issue of transparency in the definition
of ``G`` or ``g`` somewhere... Or am I completely mistaken?
|*)

Close Scope Z. (* .none *)
Fixpoint f' (n : nat) (H: Acc lt n) : nat.
  refine (if dec (n <=? 0) then 0 else n + (f' (n - 1) (Acc_inv H _))).
  apply Nat.leb_gt in e.
  apply Nat.sub_lt; auto with *.
Defined.
(* Compute (f' 10 (lt_wf 10)). doesn't evaluate to a nat if ended with Qed. *)

(*| Anyway, my problem persists for ``Z``. |*)

Open Scope Z. (* .none *)
Fixpoint g' (n : Z) (H : Acc (Zwf 0) n) : Z.
  refine (if dec (n <=? 0) then 0 else n + (g' (n - 1) (Acc_inv H _))).
  split; now apply Z.leb_gt in e; auto with *.
Defined.

Compute (g' 10 (Zwf_well_founded 0 10)).

(*|
----

**A:** This is a related `question
<https://stackoverflow.com/questions/32354286/compute-with-a-recursive-function-defined-by-well-defined-induction>`__.

**A:** This `one <https://stackoverflow.com/questions/28478445/>`__ is
somewhat related as well.
|*)

(*|
Answer
******

Making `Zwf_well_founded
<https://coq.inria.fr/library/Coq.ZArith.Zwf.html#Zwf_well_founded>`__
transparent won't help, because of the way it is defined in the
standard library:

.. code-block:: coq

    Lemma Zwf_well_founded : well_founded (Zwf c).
      ...
      case (Z.le_gt_cases c y); intro; auto with zarith.
      ...
    Qed.

If you replace the line in the proof above with

.. code-block:: coq

      case (Z_le_gt_dec c y); intro; auto with zarith.

and replace ``Qed.`` with ``Defined.`` (which you already did)
everything should work. This is due the fact that the original proof
depends on a logical term, and that prevents the evaluator from doing
pattern-matching, because logical entity ``Z.le_gt_cases`` is opaque,
while computational entity ``Z_le_gt_dec`` is transparent. See `Using
Coq's evaluation mechanisms in anger
<http://gallium.inria.fr/blog/coq-eval/>`__ blog post by Xavier Leroy.
You might also find useful `Qed Considered Harmful
<https://gmalecha.github.io/reflections/2017/qed-considered-harmful>`__
post by Gregory Malecha.

Instead of modifying the proof of ``Zwf_well_founded`` you can reuse
`Zlt_0_rec
<https://coq.inria.fr/library/Coq.ZArith.Wf_Z.html#Zlt_0_rec>`__ like
so:
|*)

Require Import Coq.ZArith.ZArith.

Open Scope Z.

Definition H (x : Z) (H_rec : (forall y : Z, 0 <= y < x -> Z))
           (nonneg : 0 <= x) : Z.
  refine (if Z_zerop x then 0 else x + (H_rec (Z.pred x) _ )).
  auto with zarith.
Defined.

Definition h (z : Z) : Z :=
  match Z_lt_le_dec z 0 with left _ => 0 | right pf => (Zlt_0_rec _ H z pf) end.

Check eq_refl : h 100 = 5050.

(*|
It's a bit less convenient because now we have to deal with negative
numbers in ``h``.
|*)


Require Export SfLib.

Definition multiset (A:Type) := list A.

Definition In (A:Type) T e := @In A e T.

Definition Union (A:Type) (m1 m2 : multiset A) := m1 ++ m2.

Definition Add (A:Type) (m:multiset A) (a:A) := m++[a].

Definition Empty_set (A:Type) := @nil A.

Axiom classicT : forall (P : Prop), {P} + {~ P}.

Fixpoint Subtract (A:Type) (m:multiset A) (e:A) :=
  match m with
    |m::ms => if classicT (m = e)
              then ms
              else m::Subtract A ms e
    |nil => nil
  end.

Definition Single (A:Type) (m1 : A) : multiset A := [m1].

Definition Couple (A:Type) (m1 m2 : A) : multiset A := [m1;m2].

Axiom MultisetExtensionality : forall A (M1 M2 : multiset A),
                                 (forall x:A, In A M1 x -> In A M2 x) /\
                                 (forall x:A, In A M2 x -> In A M1 x) -> M1 = M2.

Hint Unfold In.
Ltac invUnion :=
  unfold In in *;
  match goal with
      |H:List.In ?x (Union ?A ?T1 ?T2) |- _ => apply in_app_iff in H
      | |- List.In ?x (Union ?A ?T1 ?T2) => apply in_app_iff
  end.

Hint Resolve in_app_iff.

Theorem Union_commutative : forall A (M1 M2 : multiset A), Union A M1 M2 = Union A M2 M1.
Proof.
  intros. apply MultisetExtensionality. split; intros.
  {repeat invUnion. inversion H; auto. }
  {repeat invUnion. inversion H; eauto. }
Qed.

Theorem Union_associative : forall A (M1 M2 M3 : multiset A),
                              Union A M1 (Union A M2 M3) = Union A (Union A M1 M2) M3.
Proof.
  intros. apply MultisetExtensionality. split; intros.
  {repeat invUnion. inversion H. left. invUnion; auto. invUnion.
   inversion H0; auto. left. invUnion; auto. }
  {repeat invUnion. inversion H. invUnion. inversion H0. auto. right.
   invUnion. auto. right. invUnion. auto. }
Qed.

Theorem union_empty_r : forall A T, Union A T (Empty_set A) = T.
Proof.
  intros. rewrite Union_commutative. simpl. auto.
Qed.

Theorem couple_swap : forall (T:Type) (t1 t2:T), Couple T t1 t2 = Couple T t2 t1.
Proof.
  intros. apply MultisetExtensionality. split; intros.
  {inversion H. subst. simpl. right. auto. inversion H0. subst. simpl. auto.
   inversion H1. }
  {inversion H. subst. simpl. right. auto. inversion H0. subst. simpl. auto.
   inversion H1. }
Qed.

Theorem pullOut : forall (A:Type) T (e:A),
                    In A T e -> T = Union A (Subtract A T e) (Single A e).
Proof.
  induction T; intros.
  {inversion H. }
  {inversion H; subst.
   {simpl. destruct (classicT (e=e)).
    {rewrite Union_commutative. simpl. auto. }
    {exfalso. apply n; auto. }
   }
   {simpl. destruct (classicT (a=e)).
    {subst. rewrite Union_commutative. simpl. auto. }
    {simpl. erewrite <- IHT; eauto. }
   }
  }
Qed.

Theorem UnionSubtract : forall (X:Type) T (x:X),
                          Subtract X (Union X T (Single X x)) x = T.
Proof.
  induction T; intros.
  {simpl. destruct (classicT(x=x)). auto. exfalso; apply n; auto. }
  {simpl. destruct (classicT(a=x)). subst. rewrite Union_commutative.
   simpl; auto. rewrite IHT. auto. }
Qed.

Theorem subtractSingle : forall (X:Type) T (x1:X),
              (Subtract X (Union X (Subtract X T x1) (Single X x1)) x1) =
              Subtract X T x1.
Proof.
  induction T; intros.
  {simpl. destruct (classicT (x1=x1)); auto. exfalso; apply n; auto. }
  {simpl. destruct (classicT(a=x1)).
   {rewrite UnionSubtract. auto. }
   {simpl. destruct (classicT(a=x1)); try contradiction.
    rewrite IHT; eauto. }
  }
Qed.

Theorem UnionSwap: forall (X : Type) (T1 T2 T3 : multiset X),
                     Union X (Union X T1 T2) T3 = Union X (Union X T1 T3) T2.
Proof.
  intros. rewrite <- Union_associative. rewrite (Union_commutative X T2).
  rewrite Union_associative. auto.
Qed.

Theorem coupleUnion : forall (U:Type) (t1 t2 : U),
                        Couple U t1 t2 = Union U (Single U t1) (Single U t2).
Proof.
  intros. simpl. unfold Couple. unfold Single. auto.
Qed.

Ltac flipCouples :=
  rewrite couple_swap; rewrite coupleUnion; try flipCouples; rewrite <- coupleUnion.

Ltac flipCouplesIn H :=
  rewrite couple_swap in H; rewrite coupleUnion in H; try flipCouplesIn H; rewrite <- coupleUnion in H.

Theorem pullOutL : forall (A:Type) (T1 : multiset A) T2 T3,
                     Union A T1 (Couple A T2 T3) =
                     Union A (Union A T1 (Single A T3)) (Single A T2).
Proof.
  intros. rewrite coupleUnion. rewrite Union_associative.
  rewrite UnionSwap. auto.
Qed.

Theorem pullOutR : forall (A:Type) (T1 : multiset A) T2 T3,
                     Union A T1 (Couple A T2 T3) =
                     Union A (Union A T1 (Single A T2)) (Single A T3).
Proof.
  intros. rewrite coupleUnion. rewrite Union_associative.
  rewrite UnionSwap. auto.
Qed.

Theorem subtractUnion : forall (A:Type) T (e:A),
                          In A T e -> Union A (Subtract A T e) (Single A e) = T.
Proof.
  induction T; intros.
  {inversion H. }
  {inversion H; subst. simpl. destruct (classicT(e=e)).
   {rewrite Union_commutative. simpl. auto. }
   {exfalso. apply n; auto. }
   {simpl. destruct (classicT(a=e)).
    {subst. rewrite Union_commutative. simpl. auto. }
    {simpl. rewrite IHT; auto. }
   }
  }
Qed.

Theorem UnionEqSingleton : forall (A:Type) (T:multiset A) t t',
                             Union A T (Single A t) = (Single A t') ->
                             t = t' /\ T = Empty_set A.
Proof.
  intros. destruct T.
  {inversion H. auto. }
  {inversion H; subst. rewrite Union_commutative in H2. simpl in *.
   inversion H2. }
Qed.

Theorem union_empty_l : forall (A:Type) (T:multiset A),
                           Union A (Empty_set A) T = T.
Proof.
  intros. simpl. auto.
Qed.

Theorem UnionSwapR : forall (A:Type) T (t1 t2 t3 : A),
                       Union A (Union A T (Single A t1)) (Couple A t2 t3) =
                       Union A (Union A T (Single A t3)) (Couple A t2 t1).
Proof.
  intros. repeat rewrite <- Union_associative. repeat rewrite coupleUnion.
  rewrite (Union_associative A (Single A t1)).
  rewrite (Union_commutative A (Single A t1)). rewrite <- Union_associative.
  rewrite (Union_commutative A (Single A t1)).
  rewrite (Union_associative A (Single A t2)).
  rewrite (Union_commutative A (Single A t2)). rewrite <- Union_associative.
  auto.
Qed.

Theorem UnionSwapL : forall (A:Type) T (t1 t2 t3 : A),
                       Union A (Union A T (Single A t1)) (Couple A t2 t3) =
                       Union A (Union A T (Single A t2)) (Couple A t1 t3).
Proof.
  intros. repeat rewrite <- Union_associative. rewrite coupleUnion.
  rewrite coupleUnion. rewrite (Union_associative A (Single A t1)).
  rewrite (Union_commutative A (Single A t1)).
  rewrite <- Union_associative. rewrite <- (coupleUnion A t1). auto.
Qed.


Require Export P02.

Theorem xorb_fn_applied_twice :
  forall (f : bool -> bool) (y : bool),
  (forall (x : bool), f x = xorb y x) ->
  forall (b : bool), f (f b) = b.
Proof.
  exact FILL_IN_HERE.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Essentials.HoTT_Facts.
Require Import Category.Main.
Require Import Basic_Cons.Product.
Require Import Coq_Cats.Type_Cat.Type_Cat.

Local Obligation Tactic := basic_simpl; auto 2.

Definition SumType (A B : Type_Cat) : hSet.
Proof.
  refine
    (
      @BuildTruncType 0 (A + B)%type _
    ).
Defined.

(** The sum of types in coq is the categorical notion of sum in category of types. *)
Program Definition sum_Sum (A B : Type_Cat) : @Sum Type_Cat A B.
Proof.
  refine
    (
      @Build_Product
        (Type_Cat^op)
        A
        B
        (SumType A B)
        inl
        inr
        (
          fun p'
              r1
              r2
              x =>
            match x return p' with
            | inl a => r1 a
            | inr b => r2 b
            end
        )
        _
        _
        _
    ); auto.
  intros p' r1 r2 f g H1 H2 H3 H4.
  rewrite <- H3 in H1.
  rewrite <- H4 in H2.
  clear H3 H4.
  extensionality x.
  destruct x;
    match goal with
        [|- f (?m ?y) = g (?m ?y)] =>
        apply (@equal_f _ _ (fun x => f (m x)) (fun x => g (m x)))
    end; auto.
Defined.

(* sum_Sum defined *)

Program Instance Type_Cat_Has_Sums : Has_Sums Type_Cat := sum_Sum.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (y : natural) (z : natural) (lf2 : natural)
  : natural := plus lf1 Zero.


Require Import QArith Qround QvecArith PerceptronDef.
Require Import TerminationRefinement MCEBounds PerceptronSound.

Definition Qfloor_nat (q : Q) : nat := Z.to_nat (Qfloor q).

Lemma AB_limit : forall (A B C: Q),
  0 < A -> 0 < B -> 0 < C -> C > B / A -> A * C *C > B * C.
Proof.
  intros. unfold Qdiv in H2. apply (Qmult_lt_l _ _ A H) in H2.
  rewrite (Qmult_comm B _) in H2. rewrite Qmult_assoc in H2.
  rewrite Qmult_inv_r in H2. rewrite Qmult_1_l in H2.
  apply (Qmult_lt_r _ _ C H1) in H2. unfold Qmult;
  repeat rewrite Qred_correct. apply H2. unfold not. intros.
  apply Qlt_not_le in H. apply H. rewrite H3. apply Qle_refl. Qed.

Lemma Qfloor_lt' : forall (x : Q),
  x < 1 + inject_Z (Qfloor x).
Proof.
  intros. assert (1 = inject_Z 1%Z). reflexivity. rewrite H.
  unfold Qplus; rewrite Qred_correct.
  rewrite <- inject_Z_plus. rewrite Zplus_comm. apply Qlt_floor. Qed.

Lemma Nat_Z_inj : forall (n : nat),
  inject_nat n == inject_Z (Z.of_nat n).
Proof.
  intros. induction n. reflexivity. simpl.
  rewrite Zpos_P_of_succ_nat. rewrite <- Z.add_1_l.
  rewrite inject_Z_plus. rewrite IHn. unfold Qplus.
  rewrite Qred_correct. reflexivity. Qed.

Lemma Z_pos_nat_inj : forall (x : Z),
  (0 <= x -> Z.of_nat (Z.to_nat x) = x)%Z.
Proof.
  intros. induction x. reflexivity. simpl.
  apply positive_nat_Z. assert (H3 := Zlt_neg_0 p). omega. Qed.

 (****************************************************************************************
    Show that MCEBounds -> MCE reaches a fixed point.
  ****************************************************************************************)
Lemma linearly_separable_MCE : forall {n : nat} (w0 : Qvec (S n)) (T : list ((Qvec n)*bool)),
  linearly_separable T -> exists (E0 : nat),
  MCE E0 T w0 = MCE (S E0) T w0.
Proof.
  intros. apply (linearly_separable_bound T w0) in H. simpl in H.  destruct H as [A [B [C H]]].
  exists (S (Qfloor_nat (C / A))).
  assert (H0 := (H (S (Qfloor_nat (C / A))))).
  assert (H1 := (MCE_progress (S (Qfloor_nat (C / A))) w0 T)).
  inversion H1.
  {
    destruct H0 as [HA [HB [HC HAC]]].
    unfold MCE in H2. inversion H2.
    { fold (MCE (S (Qfloor_nat (C / A))) T w0) in H3.
      fold (MCE (S (Qfloor_nat (C / A))) T w0) in H2. rewrite <- H3 in HAC.
      assert (0 < inject_nat (S (Qfloor_nat (C / A)))). simpl.
      unfold Qplus; rewrite Qred_correct.
      apply (Qplus_lt_le_compat 0 _ 0 _). reflexivity. apply Qnat_le_0.
      assert (C / A < inject_nat (S (Qfloor_nat (C / A)))). simpl.
      rewrite Nat_Z_inj. unfold Qfloor_nat. rewrite Z_pos_nat_inj.
      apply Qfloor_lt'. assert (0%Z = Qfloor 0). reflexivity.
      rewrite H4. apply Qfloor_resp_le. apply Qlt_le_weak.
      unfold Qdiv. rewrite <- (Qmult_0_l (/ A)). apply Qmult_lt_r.
      apply Qinv_lt_0_compat. apply HA. apply HC.
      assert (HCA := (AB_limit A C (inject_nat (S (Qfloor_nat (C / A)))) HA HC H0 H4)).
      clear - HAC HCA. apply Qlt_not_le in HCA. exfalso. apply HCA.
      destruct HAC as [HleA HleC]. apply (Qle_trans _ _ _ HleA HleC).
    }
    fold (MCE (S (Qfloor_nat (C / A))) T w0) in H2. fold (MCE (S (Qfloor_nat (C / A))) T w0) in H0.
    rewrite <- H0 in HAC. assert (HCA := (AB_limit A C (inject_nat (S m)) HA HC)). exfalso.
    apply Qlt_not_le in HCA. apply HCA. destruct HAC as [HleA HleC]. apply (Qle_trans _ _ _ HleA HleC).
    simpl. unfold Qplus; rewrite Qred_correct.
    apply (Qplus_lt_le_compat 0 _ 0 _). reflexivity. apply Qnat_le_0.
    assert (C / A < inject_nat (S (Qfloor_nat (C / A)))).
    simpl. rewrite Nat_Z_inj. unfold Qfloor_nat. rewrite Z_pos_nat_inj.
    apply Qfloor_lt'. assert (0%Z = Qfloor 0). reflexivity.
    rewrite H4. apply Qfloor_resp_le. apply Qlt_le_weak.
    unfold Qdiv. rewrite <- (Qmult_0_l (/ A)). apply Qmult_lt_r.
    apply Qinv_lt_0_compat. apply HA. apply HC. apply (Qlt_trans _ _ _ H4).
    apply Qnat_lt. apply le_lt_n_Sm. apply H3.
  } apply H2. Qed.

 (****************************************************************************************
    Show that perceptron_MCE reaches a fixed point. (MCE fixed point + termination refinement)
  ****************************************************************************************)
Theorem linearly_separable_perceptron_MCE : forall {n : nat} (w0 : Qvec (S n)) (T : (list ((Qvec n)*bool))),
  linearly_separable T ->
  exists (E0 : nat) M (w : (Qvec (S n))), forall E, (E >= E0)%nat -> perceptron_MCE E T w0 = Some (M, w).
Proof.
  intros. apply linearly_separable_MCE with w0 T in H. destruct H as [E0 H].
  exists (S E0). exists (MCE E0 T w0). exists (Qvec_sum_class w0 (MCE E0 T w0)). intros E.
  intros H1. apply MCE_eq_perceptron_MCE in H. apply perceptron_MCE_done with (S E0). omega. apply H. Qed.

 (****************************************************************************************
  (Show that perceptron reaches a fixed point (converges)
    perceptron_MCE reaches a fixed point + termination refinement
 ****************************************************************************************)
Theorem linearly_separable_perceptron : forall {n : nat} (w0 : Qvec (S n)) (T : (list ((Qvec n)*bool))),
  linearly_separable T <->
  exists (E0 : nat) (w : (Qvec (S n))), forall E, (E >= E0)%nat -> perceptron E T w0 = Some w.
Proof.
  split; intros. apply linearly_separable_perceptron_MCE with w0 T in H.
  destruct H as [E0 [M [w H]]]. exists E0. exists w. intros. apply H in H0.
  apply perceptron_MCE_perceptron. exists M. auto.
  destruct H as [E0 [w H]].
  apply (perceptron_linearly_separable (S E0) w0 w).
  apply H. auto. Qed.

(*******************************************************************************************
  Show that Average Perceptron reaches a fixed point (converges)
    linearly_separable_perceptron + termination refinement
 *******************************************************************************************)
Theorem linearly_separable_average_perceptron : forall {n : nat} (w0 : Qvec (S n)) (T : (list ((Qvec n)*bool))),
    linearly_separable T <->
    exists (E0 : nat) (w : (Qvec (S n))), forall E, (E >= E0)%nat -> average_perceptron E T w0 = Some w.
Proof.
  split; intros. apply linearly_separable_perceptron with w0 T in H.
  destruct H as [E0 [w H]].
  assert (forall E, (E >= E0)%nat -> exists w, average_perceptron E T w0 = Some w).
  { intros. apply H in H0. apply perceptron_average_perceptron. exists w. auto. }
  clear H. exists E0. assert (E0 >= E0)%nat. omega. apply H0 in H.
  destruct H as [? H]. exists x. clear -H.
  intros. eapply average_perceptron_done. apply H0. apply H.
  destruct H as [E0 [w H]]. assert (E0 >= E0)%nat. omega.
  apply H in H0. assert (exists w, perceptron E0 T w0 = Some w).
  apply perceptron_average_perceptron. exists w. apply H0.
  destruct H1 as [? H1]. apply (perceptron_linearly_separable E0 w0 x).
  apply H1.
Qed.

Print Assumptions linearly_separable_perceptron.


(******************************************************************************)
(** Imports **)

(* Disable notation conflict warnings *)
Set Warnings "-notation-overridden".

(* SSReflect *)
From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat seq eqtype.
Set Bullet Behavior "Strict Subproofs".

(* Sortedness *)
Require Import Coq.Sorting.Sorted Coq.Sorting.Permutation.

(* Basic Haskell libraries *)
Require Import GHC.Base      Proofs.GHC.Base.
Require Import Data.Foldable Proofs.Data.Foldable.
Require Import Data.OldList  Proofs.Data.OldList.

(* Working with Haskell *)
Require Import SortSorted.
Require Import OrdTactic.
Require Import HSUtil.

(******************************************************************************)
(** Name dismabiguation -- copied from HSUtil **)

Notation list    := Coq.Init.Datatypes.list.
Notation seq     := Coq.Lists.List.seq.
Notation reflect := ssrbool.reflect.

(******************************************************************************)
(** Basic facts about StronglySorted **)

Theorem StronglySorted_R_ext' {A} (R1 R2 : A -> A -> Prop) (xs : list A) :
  (forall a b, R1 a b <-> R2 a b) ->
  StronglySorted R1 xs -> StronglySorted R2 xs.
Proof.
  move=> R12_iff; elim: xs => [|x xs IH] SS1; first by constructor.
  inversion SS1 as [|x' xs' SS1' All1]; subst x' xs'.
  constructor; first by apply IH.
  eapply Forall_impl; last exact All1.
  apply R12_iff.
Qed.

Corollary StronglySorted_R_ext {A} (R1 R2 : A -> A -> Prop) (xs : list A) :
  (forall a b, R1 a b <-> R2 a b) ->
  StronglySorted R1 xs <-> StronglySorted R2 xs.
Proof. by split; apply StronglySorted_R_ext'; last symmetry. Qed.

Theorem StronglySorted_snoc {A} (R : A -> A -> Prop) (x : A) (xs : list A) :
  StronglySorted R xs -> Forall (R^~ x) xs -> StronglySorted R (xs ++ [:: x]).
Proof.
  elim: xs => [|x' xs IH] /= SS' AllRev'; first by constructor.
  inversion SS'     as [|x'' xs' SS   All];    subst x'' xs'.
  inversion AllRev' as [|x'' xs' Rx'x AllRev]; subst x'' xs'.
  constructor.
  - by apply IH.
  - move: All AllRev; rewrite !Forall_forall => /= All AllRev a.
    rewrite in_app_iff => -[IN | [? | //]]; last subst a=> //.
    by apply All.
Qed.

Theorem StronglySorted_rev' {A} (R : A -> A -> Prop) (xs : list A) :
  StronglySorted R xs -> StronglySorted (fun a b => R b a) (rev xs).
Proof.
  elim: xs => [|x xs IH] /= SS'; first by constructor.
  inversion SS' as [|x' xs' SS All]; subst x' xs'.
  move: (IH SS) => IH'.
  apply StronglySorted_snoc; first by apply IH.
  move: All; rewrite !Forall_forall => All a; rewrite -in_rev; apply All.
Qed.

Corollary StronglySorted_rev {A} (R : A -> A -> Prop) (xs : list A) :
  StronglySorted R xs <-> StronglySorted (fun a b => R b a) (rev xs).
Proof.
  split; first apply StronglySorted_rev'.
  rewrite -{2}(rev_involutive xs)=> SS.
  by eapply StronglySorted_rev', StronglySorted_R_ext; last exact SS.
Qed.

Theorem StronglySorted_app {A} (R : A -> A -> Prop) (xs ys : list A) :
  StronglySorted R (xs ++ ys) -> StronglySorted R xs /\ StronglySorted R ys.
Proof.
  elim: xs => [|x xs IH] //= SS; first by auto using StronglySorted.
  inversion SS as [|x' rest SS' All E1]; subst x' rest.
  move: (IH SS') => [SS_xs SS_ys]; split=> //.
  constructor=> //.
  apply/Forall_forall=> a In_a; move: All => /Forall_forall/(_ a).
  by rewrite in_app_iff; apply; left.
Qed.

(******************************************************************************)
(** StronglySorted and NoDup (and similar) **)

Theorem StronglySorted_irrefl_not_in {A} (R : A -> A -> Prop) (x : A) (xs : list A) :
  (forall a, ~ R a a) ->
  StronglySorted R (x :: xs) ->
  ~ In x xs.
Proof.
  move=> irrefl_R SS_xxs; inversion SS_xxs as [|x' xs' SS_xs R_x_xs E1]; subst x' xs'; clear SS_xxs.
  elim: xs SS_xs R_x_xs => [|x' xs IH] SS_xs R_x_xs //=.
  move=> [? | In_x_xs]; first subst x'.
  - inversion_clear R_x_xs; eapply irrefl_R; eassumption.
  - apply IH=> //.
    + by inversion SS_xs.
    + by inversion R_x_xs.
Qed.

Theorem StronglySorted_irrefl_NoDup {A} (R : A -> A -> Prop) (xs : list A) :
  (forall a, ~ R a a) ->
  StronglySorted R xs ->
  NoDup xs.
Proof.
  move=> irrefl_R.
  elim: xs => [|x xs IH] SS_xxs //=; constructor.
  - eapply StronglySorted_irrefl_not_in; eassumption.
  - by apply IH; inversion SS_xxs.
Qed.

Theorem StronglySorted_eq_In {A} (R : A -> A -> Prop) (xs ys : list A) :
  (forall a, ~ R a a) ->
  (forall a b c, R a b -> R b c -> R a c) ->
  StronglySorted R xs ->
  StronglySorted R ys ->
  (xs = ys) <-> (forall a, In a xs <-> In a ys).
Proof.
  move=> irrefl_R trans_R SS_xs; elim: SS_xs ys =>  {xs} [|x xs SS_xs IH_xs R_xs] /= ys SS_ys.
  all: case: ys SS_ys => [|y ys] //= SS_ys.
  all: split; try discriminate.
  all: try by (move=> /(_ x) || move=> /(_ y)); simpl; tauto.
  - by inversion 1.
  - move=> ext_eq.
    have NIn_x_xs: ~ In x xs by eapply StronglySorted_irrefl_not_in; eauto using StronglySorted.
    have NIn_y_ys: ~ In y ys by eapply StronglySorted_irrefl_not_in.
    have E: x = y; last subst y. {
      inversion SS_ys; subst.
      move: (ext_eq x) => [fwd_x bwd_x].
      move: (ext_eq y) => [fwd_y bwd_y].
      case: (fwd_x (or_introl erefl)) => [// | In_x_ys].
      case: (bwd_y (or_introl erefl)) => [// | In_y_xs].
      have Rxy: (R x y) by eapply Forall_forall; eassumption.
      have Ryx: (R y x) by eapply Forall_forall; eassumption.
      by move: (trans_R _ _ _ Rxy Ryx) => /irrefl_R.
    }
    f_equal.
    apply IH_xs; first by inversion SS_ys.
    move=> a; move: (ext_eq a) => [fwd bwd].
    split=> [a_xs | a_ys].
    + have x_a_disj: (x <> a) by contradict NIn_x_xs; subst.
      by move: (fwd (or_intror a_xs))=> [].
    + have x_a_disj: (x <> a) by contradict NIn_y_ys; subst.
      by move: (bwd (or_intror a_ys))=> [].
Qed.

Theorem StronglySorted_NoDup {A} (R R' : A -> A -> Prop) :
  (forall x,       R  x x) ->
  (forall x,     ~ R' x x) ->

  (forall x y z, R  x y -> R  y z -> R  x z) ->
  (forall x y z, R' x y -> R' y z -> R' x z) ->

  (forall x y, R  x y <-> (x =  y \/ R' x y)) ->
  (forall x y, R' x y <-> (x <> y /\ R  x y)) ->

  forall xs,
    StronglySorted R xs -> NoDup xs -> StronglySorted R' xs.
Proof.
  move=> R_refl R'_irrefl R_trans R'_trans R_def R'_def.
  elim=> [|x xs IH] //= Sorted_xxs NoDup_xxs; first by constructor.
  inversion Sorted_xxs as [|x' xs' Sorted_xs R_x_xs E1];  subst x' xs'; clear Sorted_xxs.
  inversion NoDup_xxs  as [|x' xs' NIn_x_xs NoDup_xs E1]; subst x' xs'; clear NoDup_xxs.
  constructor; first by apply IH.
  clear IH Sorted_xs NoDup_xs.
  elim: xs R_x_xs NIn_x_xs => [|x' xs IH] //= R_x_x'xs NIn_x_x'xs.
  inversion R_x_x'xs as [|x'' xs' R_x_x' R_x_xs E1]; subst x'' xs'; clear R_x_x'xs.
  constructor.
  - apply R'_def; split=> //.
    by contradict NIn_x_x'xs; subst; left.
  - apply IH=> //=.
    by contradict NIn_x_x'xs; right.
Qed.

(******************************************************************************)
(** Previous StronglySorted theorems with specific relations **)

Corollary StronglySorted_Zlt_eq_In (xs ys : list Int) :
  StronglySorted Z.lt xs ->
  StronglySorted Z.lt ys ->
  (xs = ys) <-> (forall a, In a xs <-> In a ys).
Proof. apply StronglySorted_eq_In; [exact Z.lt_irrefl | exact Z.lt_trans]. Qed.

Corollary StronglySorted_Nlt_eq_In (xs ys : list N) :
  StronglySorted N.lt xs ->
  StronglySorted N.lt ys ->
  (xs = ys) <-> (forall a, In a xs <-> In a ys).
Proof. apply StronglySorted_eq_In; [exact N.lt_irrefl | exact N.lt_trans]. Qed.

Corollary StronglySorted_Ord_eq_In {A} `{OrdLaws A} (xs ys : list A) :
  StronglySorted _<_ xs ->
  StronglySorted _<_ ys ->
  (xs = ys) <-> (forall a, In a xs <-> In a ys).
Proof.
  apply StronglySorted_eq_In; order A.
Qed.

Corollary StronglySorted_NoDup_Ord {A} `{OrdLaws A} `{!EqExact A} (xs : list A) :
  StronglySorted _<=_ xs ->
  NoDup xs ->
  StronglySorted _<_ xs.
Proof.
  apply StronglySorted_NoDup; try order A.
  - move=> x y; split=> [LExy | [-> | LTxy]]; try order A.
    move: LExy. destruct (compare x y) eqn:Cxy; try order A.
    move: Cxy => /Ord_compare_Eq/Eq_eq; order A.
  - move=> x y; split=> [LTxy | [Nxy LExy]]; try order A.
    rewrite Ord_lt_le; apply/negP; contradict Nxy.
    by apply/Eq_eq; order A.
Qed.

(******************************************************************************)
(** Basic facts about NoDup **)

Theorem NoDup_reorder {A} (pre : list A) (x : A) (post : list A) :
  NoDup (pre ++ x :: post) <-> NoDup (x :: (pre ++ post)).
Proof.
  elim: pre => [|p pre IH] //=; split=> [ND_mid | ND_fst].
  - inversion ND_mid as [|p' rest NIn_p ND_mid' E1]; subst p' rest.
    move/IH in ND_mid'; inversion ND_mid' as [|x' rest NIn_x ND_mid'' E1]; subst x' rest.
    constructor=> //.
    + move=> [? | //]; subst p.
      apply NIn_p; rewrite in_app_iff /=; auto.
    + constructor=> //.
      contradict NIn_p; move: NIn_p.
      rewrite !in_app_iff /=; tauto.
  - inversion ND_fst  as [|x' rest NIn_x ND_fst'  E1]; subst x' rest.
    inversion ND_fst' as [|p' rest NIn_p ND_fst'' E1]; subst p' rest.
    constructor=> //.
    + contradict NIn_p; move: NIn_p.
      rewrite !in_app_iff /= => -[? | [? | ?]]; try tauto; subst p.
      by exfalso; apply NIn_x; left.
    + apply IH; constructor=> //.
      by contradict NIn_x; right.
Qed.

(******************************************************************************)
(** Theorems about sort and nub **)

Theorem sortN {A} `{OrdLaws A} :
  sort [::] = [::].
Proof. done. Qed.

Theorem sort1 {A} `{OrdLaws A} `{!EqExact A} (x : A) :
  sort [:: x] = [:: x].
Proof. done. Qed.

Theorem sort_StronglySorted {A} `{OrdLaws A} (xs : list A) :
  StronglySorted _<=_ (sort xs).
Proof.
  eapply Sorted_StronglySorted, sort_sorted; try typeclasses eauto.
  order A.
Qed.

Theorem sort_elem {A} `{Ord A} (xs : list A) :
  forall x, elem x (sort xs) = elem x xs.
Proof. apply elem_Permutation, sort_permutation. Qed.

Theorem sort_In {A} `{Ord A} (xs : list A) :
  forall x, In x (sort xs) <-> In x xs.
Proof. move=> ?; apply (Permutation_in' erefl), sort_permutation. Qed.

Theorem sort_NoDup {A} `{OrdLaws A} `{!EqExact A} (xs : list A) :
  NoDup xs <-> NoDup (sort xs).
Proof. apply Permutation_NoDup', Permutation_sym, sort_permutation. Qed.

Theorem nub_NoDup {A} `{EqExact A} (xs : list A) : NoDup (nub xs).
Proof.
  rewrite /nub /nubBy.
  have: NoDup ([::] : list A) by constructor.
  move: {1 3}[::].
  elim: xs => [|x xs IH] /= acc acc_uniq; first by constructor.
  case MEM: (elem_by _==_ x acc).
  + by apply IH.
  + constructor.
    * clear IH.
      have: In x (x :: acc) by constructor.
      move: (x :: acc); clear acc acc_uniq MEM.
      elim: xs => [|x' xs IH] acc IN //=.
      destruct (x == x') eqn:EQ => //=.
      -- move/Eq_eq in EQ; subst x'.
         by move: (IN) => /elem_byP ->; apply IH.
      -- case MEM': (elem_by _==_ x' acc) => //=; first by apply IH.
         move=> [? | IN']; first by subst x'; contradict EQ; rewrite Eq_refl.
         eapply IH; last apply IN'.
         by right.
    * eapply IH; constructor=> //.
      by apply/elem_byP; rewrite MEM.
Qed.

Corollary StronglySorted_sort_nub {A} `{OrdLaws A} `{!EqExact A} (xs : list A) :
  StronglySorted _<_ (sort (nub xs)).
Proof.
  apply StronglySorted_NoDup_Ord; first by apply sort_StronglySorted.
  have decA: forall x y : A, {x = y} + {x <> y} by move=> x y; case: (EqExact_cases x y); tauto.
  rewrite -sort_NoDup; apply nub_NoDup.
Qed.

Corollary StronglySorted_sort_nub_Zlt (xs : list Int) :
  StronglySorted Z.lt (sort (nub xs)).
Proof.
  eapply StronglySorted_R_ext; last by apply StronglySorted_sort_nub.
  by unfold "<", Ord_Integer___ => /= a b; rewrite -Z.ltb_lt.
Qed.

Corollary StronglySorted_sort_nub_Nlt (xs : list N) :
  StronglySorted N.lt (sort (nub xs)).
Proof.
  eapply StronglySorted_R_ext; last by apply StronglySorted_sort_nub.
  by unfold "<", Ord_Char___ => /= a b; rewrite -N.ltb_lt.
Qed.


(**
多数決関数とfull adder
========================

@suharahiromichi

2020/04/30
 *)

From mathcomp Require Import all_ssreflect.
Require Import ssr_omega.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Print All. *)

Section Majority.

  Definition maj3 (b c d : bool) : bool := if (b + c + d <= 1) then false else true.

  Definition maj3_0 (a b c : bool) : bool :=
    a && b && ~~c || ~~a && b && c || a && ~~b && c || a && b && c.
  Definition maj3_1 (a b c : bool) : bool := a && b || b && c || c && a.
  Definition maj3_2 (a b c : bool) : bool := a * b + b * c + c * a != 0.

  Goal forall (a b c : bool), maj3_0 a b c = maj3_1 a b c.
  Proof.
    move=> a b c.
    rewrite /maj3_0 /maj3_1.

    rewrite [_ || a && b && c]orbC !orbA.   (* 先頭に移動する。 *)
    rewrite -[a && b && c]Bool.orb_diag.    (* 項を複製する。 *)
    rewrite -{1}[a && b && c]Bool.orb_diag. (* 項を複製する。 *)
    rewrite [_ || a && ~~b && c]orbC !orbA. (* 先頭に移動する。 *)
    have -> : a && ~~b && c || a && b && c = a && c.
      (* 一旦右結合にして、~~bとbを末尾にして、左結合に戻す。 *)
      by rewrite -!andbA [~~b && _]andbC [b && _]andbC ?andbA
         -andb_orr orbC orbN andbT andbC.
    rewrite [a && c]andbC.

    rewrite [_ || a && b && c]orbC !orbA.   (* 先頭に移動する。 *)
    rewrite [_ || ~~a && b && c]orbC !orbA. (* 先頭に移動する。 *)
    have -> : ~~ a && b && c || a && b && c = b && c.
      (* 一旦右結合にして、~~aとaを末尾にして、左結合に戻す。 *)
      by rewrite -!andbA [~~a && _]andbC [a && _]andbC ?andbA
         -andb_orr orbC orbN andbT andbC.

    rewrite [_ || a && b && c]orbC !orbA.   (* 先頭に移動する。 *)
    rewrite [_ || a && b && ~~c]orbC !orbA. (* 先頭に移動する。 *)
    have -> : a && b && ~~c || a && b && c = a && b
      (* すでに、~~cとcは末尾にある。 *)
      by rewrite -andb_orr orbC orbN andbT andbC.                                             done.
  Qed.

  Lemma test2 (a b :nat) : (a + b != 0) = (a != 0) || (b != 0).
  Proof.
      by elim: a; elim: b.
  Qed.

  Lemma test a : (nat_of_bool a != 0) = a.
  Proof.
    by case: a.
  Qed.

  Goal forall (a b c : bool), maj3_1 a b c = maj3_2 a b c.
  Proof.
    move=> a b c.
    rewrite /maj3_1 /maj3_2.
    rewrite !mulnb.
    rewrite 2!test2.
    rewrite 3!test.
    done.
  Qed.

  Goal forall (a b c : bool), maj3 a b c = maj3_1 a b c.
  Proof.
      by case; case; case.
  Qed.

End Majority.

Section Median.

  (* 5回比較するので、効率悪い *)
  Definition median (m n p : nat) := maxn (maxn (minn m n) (minn n p)) (minn p m).

  (* 展開したバブルソート *)
  Definition median' (n1 n2 n3 : nat) :=
    let (n1', n2') := if n1 < n2 then (n1, n2) else (n2, n1) in
    let (n2'', n3') := if n2' < n3 then (n2', n3) else (n3, n2') in
    let (n1'', n2''') := if (n1' < n2'') then (n1', n2'') else (n2'', n1') in n2'''.

  (* 上記をswapなしにしたもの *)
  Definition median'' (m n p : nat) :=
    if m < n then
      if n < p then n else (if m < p then p else m)
    else
      if m < p then m else (if n < p then p else n).

  (* bool で証明する。 *)

  Goal forall (a b c : bool), median a b c = maj3 a b c.
  Proof.
      by case; case; case.
  Qed.

  Goal forall (a b c : bool), median a b c = median' a b c.
  Proof.
    rewrite /median /median'.
      by case; case; case.
  Qed.

  Goal forall (a b c : bool), median a b c = median'' a b c.
  Proof.
    rewrite /median /median'.
      by case; case; case.
  Qed.

  (* nat で証明する。 *)

  (* ゴールと前提にある if式の条件で場合分けする。 *)
  Ltac if_condition' :=
    intros;
    repeat match goal with
           | [ |- context[if ?b then _ else _] ] =>
             let H' := fresh in destruct b eqn: H'
           | [ H : context[if ?b then _ else _] |- _ ] =>
             let H' := fresh in destruct b eqn: H'
           | _ => idtac
           end.

  Ltac if_condition :=
    if_condition'; try done; ssromega.

  Goal forall (m n p : nat), median' m n p = median'' m n p.
  Proof.
    move=> m n p.
    rewrite /median' /median''.
    if_condition.
  Qed.

  Goal forall (m n p : nat), median m n p = median'' m n p.
  Proof.
    move=> m n p.
    rewrite /median /median'' /maxn /minn.
    if_condition.
  Qed.

  Goal forall (m n p : nat), median m n p = median' m n p.
  Proof.
    move=> m n p.
    rewrite /median /median' /maxn /minn.
    if_condition.
  Qed.

  (* MathComp 風に rewrite で簡単にする。遅い。 *)

  Goal forall (m n p : nat), median' m n p = median'' m n p.
  Proof.
    move=> m n p.
    rewrite /median' /median''.
    case: ifP => Hmn; case: ifP => Hnp; case: ifP => Hpm; ssromega.
  Qed.

  Goal forall (m n p : nat), median m n p = median'' m n p.
  Proof.
    move=> m n p.
    rewrite /median /median'' /maxn /minn.
    case Hmn : (m < n); case Hnp : (n < p); case Hpm : (p < m);
      case Hmp : (m < p); case Hnm : (n < m);
        case Hpp : (p < p); case Hnn : (n < n); case Hmm : (m < m);
        rewrite ?Hmn ?Hnp ?Hpm ?Hmp ?Hnm ?Hpp ?Hnn; ssromega.
  Qed.

  Goal forall (m n p : nat), median m n p = median' m n p.
  Proof.
    move=> m n p.
    rewrite /median /median' /maxn /minn.
    case Hmn : (m < n); case Hnp : (n < p); case Hpm : (p < m);
      case Hmp : (m < p); case Hnm : (n < m);
        case Hpp : (p < p); case Hnn : (n < n); case Hmm : (m < m);
        rewrite ?Hmn ?Hnp ?Hpm ?Hmp ?Hnm ?Hpp ?Hnn; ssromega.
  Qed.

End Median.

Section FullAdder.

  (* majority3 *)
  Definition maj (a b c : bool) : bool := (2 <= a + b + c).

  (* parity3 *)
  Definition par (a b c : bool) : bool := odd (a + b + c).

  Compute maj false false false.             (* false *)
  Compute maj true false false.              (* false *)
  Compute maj true false true.               (* true *)
  Compute maj true true true.                (* true *)

  Compute par false false false.             (* false *)
  Compute par true false false.              (* true *)
  Compute par true false true.               (* false *)
  Compute par true true true.                (* true *)

  Goal forall (a b c : bool),
      a + b + c = 2 * maj a b c + par a b c.
  Proof.
      by case; case; case.
  Qed.

End FullAdder.

(* おまけ *)

Goal forall (a b c : bool), maj3 a b c = maj a b c.
Proof.
    by case; case; case.
Qed.

(* END *)


Require Import ZArith.
Require Import NAux.
Require Import NPolS.
Require Import PolSBase.
Require Import PolFBase.
Require Import PolAux.
Require Import PolAuxList.
Require Import NSignTac.

Definition Zfactor :=
  factor Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Definition Zfactor_minus :=
  factor_sub Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Definition Zget_delta :=
 get_delta Z Zplus Zmult Z.opp 0%Z 1%Z is_Z1 is_Z0 is_Zpos is_Zdiv Z.div Zgcd.

Ltac
Nfactor_term term1 term2 :=
let term := constr:(Nminus term1 term2) in
let rfv := FV NCst Nplus Nmult Nminus Nopp term (@nil N) in
let fv := Trev rfv in
let expr1 := mkPolexpr Z NCst Nplus Nmult Nminus Nopp term1 fv in
let expr2 := mkPolexpr Z NCst Nplus Nmult Nminus Nopp term2 fv in
let re := eval vm_compute in (Zfactor_minus (PEsub expr1 expr2)) in
let factor := match re with (PEmul ?X1 _) => X1 end in
let expr3 := match re with (PEmul _ (PEsub ?X1 _)) => X1 end in
let expr4 := match re with (PEmul _ (PEsub _ ?X1 )) => X1 end in
let
 re1' :=
  eval
     unfold
      Nconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl in (Nconvert_back (PEmul factor expr3) fv) in
let re1'' := eval lazy beta in re1' in
let re1''' := clean_zabs_N re1'' in
let
 re2' :=
  eval
     unfold
      Nconvert_back, convert_back,  pos_nth,  jump,
         hd,  tl in (Nconvert_back (PEmul factor expr4) fv) in
let re2'' := eval lazy beta in re2' in
let re2''' := clean_zabs_N re2'' in
replace2_tac term1 term2 re1''' re2'''; [idtac| ring | ring].

Ltac Npolf :=
progress (
(try
match goal with
| |- (?X1 = ?X2)%N =>  Nfactor_term X1 X2
| |- (?X1 <> ?X2)%N =>  Nfactor_term X1 X2
| |- N.lt ?X1 ?X2 => Nfactor_term X1 X2
| |- N.gt ?X1 ?X2 =>Nfactor_term X1 X2
| |- N.le ?X1 ?X2 => Nfactor_term X1 X2
| |- N.ge ?X1 ?X2 =>Nfactor_term X1 X2
| _ => fail end)); try (Nsign_tac); try repeat (rewrite Nmult_1_l || rewrite Nmult_1_r).

Ltac hyp_Npolf H :=
progress (
generalize H;
(try
match type of H with
  (?X1 = ?X2)%N =>  Nfactor_term X1 X2
| (?X1 <> ?X2)%N =>  Nfactor_term X1 X2
| N.lt ?X1 ?X2 => Nfactor_term X1 X2
| N.gt ?X1 ?X2 =>Nfactor_term X1 X2
| N.le ?X1 ?X2 => Nfactor_term X1 X2
| N.ge ?X1 ?X2 =>Nfactor_term X1 X2
| _ => fail end)); clear H; intros H; try hyp_Nsign_tac H; try repeat rewrite Nmult_1_l in H.


Require Export Ltree  building  graft.

Set Implicit Arguments.

(*  having some infinite branch *)

CoInductive SomeInf (A:Type):(LTree A)->Prop :=
   InfLeft : forall (a:A)(t1 t2:LTree A),
                                    SomeInf t1 ->
                                    SomeInf (LBin a t1 t2)
|  InfRight : forall (a:A)(t1 t2:LTree A),
                                     SomeInf t2 ->
                                     SomeInf (LBin a t1 t2).

(*  every branch is infinite *)
CoInductive EveryInf (A:Type) :(LTree A)->Prop :=
  InfI : forall (a:A) (t1 t2: LTree A),
                                EveryInf t1 ->
                                EveryInf t2 ->
                                EveryInf (LBin a t1 t2).

(* having some finite branch *)

Inductive SomeFin (A:Type) : (LTree A)->Prop :=
  SomeFin_leaf : SomeFin LLeaf
| SomeFin_left : forall (a:A) (t1 t2: LTree A),
                                      SomeFin t1 ->
                                      SomeFin (LBin a t1 t2)
| SomeFin_right : forall (a:A) (t1 t2: LTree A),
                                      SomeFin t2 ->
                                      SomeFin (LBin a t1 t2).

(* Every branch is finite (i.e. this is a finite tree) *)

Inductive Finite (A:Type) :(LTree A)->Prop :=
  Finite_leaf : Finite LLeaf
| Finite_bin : forall (a:A) (t1 t2: LTree A),
                                      Finite t1 ->
                                      Finite t2 ->
                                      Finite (LBin a t1 t2).

Hint Resolve Finite_leaf Finite_bin SomeFin_leaf
SomeFin_left  SomeFin_right.

(* we prove that the tree built in module building has
   only infinite branches *)

(* technical unfolding lemma *)

Lemma Positive_tree_from_unfold :
  forall p, Positive_Tree_from p =
            LBin p (Positive_Tree_from (xO p)) (Positive_Tree_from (xI p)).
Proof.
  intros p; now LTree_unfold (Positive_Tree_from p).
Qed.

Lemma Positive_tree_from_inf : forall p, EveryInf  (Positive_Tree_from  p).
Proof.
 cofix.
 intro p; rewrite (Positive_tree_from_unfold p); split; auto.
Qed.

(* a tree with an infinite branch *)

CoFixpoint zigzag (b:bool): LTree bool :=
    if b then (LBin b LLeaf (zigzag false))
         else (LBin b (zigzag true) LLeaf ).

(*
       true
      /   \
    Leaf  false
          /   \
       true    Leaf
      /   \
    Leaf  false
          /   \
       true    Leaf
      /   \
    Leaf  false
          /   \
       true    Leaf
       ...
*)

Lemma zigzag_unfold : forall b,
                        zigzag b =
                        if b
                        then LBin b LLeaf (zigzag false)
                        else LBin b (zigzag true) LLeaf.
Proof.
 intro b;LTree_unfold (zigzag b); cbn ; case b; simpl; auto.
Qed.

Lemma zigzag_inf : forall b, SomeInf (zigzag b).
Proof.
  cofix H;  intro b;   rewrite (zigzag_unfold b);
  case b; cbn; [right|left]; auto.
Qed.

(* Some Finite/Infinite relationships *)

Lemma Finite_Not_SomeInf : forall (A:Type) (t: LTree A),
                              Finite t -> ~ SomeInf t.
Proof.
 intros A t H; induction  H as [| a t1 t2 H1 IHt1 H2 IHt2].
 -  red; inversion 1.
 -  inversion 1; tauto.
Qed.

Lemma SomeInf_Not_Finite : forall (A:Type) (t: LTree A),
                             SomeInf t -> ~ Finite t.
Proof.
 intros A t; generalize (Finite_Not_SomeInf (t:=t)); tauto.
Qed.

Lemma SomeFin_Not_EveryInf : forall (A:Type)(t: LTree A),
                              SomeFin t -> ~ EveryInf t.
Proof.
  intros A t Ht; induction Ht;   red; inversion 1; auto.
Qed.

Lemma Not_SomeFin_EveryInf : forall (A:Type)(t: LTree A),
                              ~ SomeFin t -> EveryInf t.
Proof.
 intros A ; cofix H.
 intro t; destruct  t as [| a t1 t2].
 -  destruct 1; constructor.
 -  intro H0; split ; apply H; red; auto.
Qed.

Section classic.
  Hypothesis class:forall P:Prop, ~~P ->P.

  Remark demorgan : forall P Q, ~(~P /\ ~Q)-> P \/ Q.
  Proof.
    intros; apply class; tauto.
  Qed.

  Remark  Not_Finite_or : forall (A:Type) (a:A) (t1 t2: LTree A),
                          ~ Finite (LBin a t1 t2) ->
                          ~ Finite t1  \/  ~Finite t2.
  Proof.
   intros A a t1 t2 H; apply demorgan;   intro; apply H.
   right; apply class; tauto.
  Qed.

  Lemma Not_Finite_SomeInf : forall (A:Type)(t: LTree A),
                               ~Finite t -> SomeInf t.
  Proof.
   intro A; cofix the_thm.
   intro t ; destruct  t as [| a t1 t2].
   - destruct 1; left.
   - intro H; case (Not_Finite_or H); [left|right];
      apply the_thm ; auto.
   Qed.

End classic.

Theorem graft_Finite_LLeaf : forall (A:Type) (t: LTree A),
                             Finite t ->
                             graft t LLeaf = t.
Proof.
 intros A t H; induction H as  [| a t1 t2 H1 IHt1 H2 IHt2].
 -  rewrite graft_unfold; auto.
 -  rewrite graft_unfold, IHt1,  IHt2; auto.
Qed.


Require Import PeanoNat.
Local Open Scope nat_scope.

Inductive ErrorNat :=
|Error : ErrorNat
|Num: nat -> ErrorNat.

Inductive Exp :=
| number : ErrorNat -> Exp
| plus : Exp -> Exp -> Exp
| minus : Exp -> Exp -> Exp
| mult : Exp -> Exp -> Exp
| div : Exp -> Exp -> Exp.

Coercion number : ErrorNat >-> Exp.
Coercion Num : nat >-> ErrorNat.

Fixpoint plusErr (n1 : ErrorNat) (n2 : ErrorNat) : ErrorNat :=
  match n1,n2 with
  | Error, _ => Error
  | _ , Error => Error
  | Num n1',Num n2' => Num (n1' + n2')
  end.

Fixpoint minusErr (n1 : ErrorNat) (n2 : ErrorNat) : ErrorNat :=
  match n1,n2 with
  | Error, _ => Error
  | _ , Error => Error
  | Num n1',Num n2' => if n1' <? n2' then Error else Num (n1' - n2')
  end.

Fixpoint multiplyErr (n1 : ErrorNat) (n2 : ErrorNat) : ErrorNat :=
  match n1,n2 with
  | Error, _ => Error
  | _ , Error => Error
  | Num n1',Num n2' => Num (n1' * n2')
  end.

Fixpoint divisionErr (n1 : ErrorNat) (n2 : ErrorNat) : ErrorNat :=
  match n1,n2 with
  | Error, _ => Error
  | _ , Error => Error
  | Num n1',Num n2' => if n2' =? 0 then Error else Num (n1' / n2')
  end.

Fixpoint eval (exp: Exp) : ErrorNat :=
  match exp with
    |number n => n
    |plus exp1 exp2 => plusErr (eval exp1)(eval exp2)
    |minus exp1 exp2 => minusErr (eval exp1)(eval exp2)
    |mult exp1 exp2 => multiplyErr(eval exp1)(eval exp2)
    |div exp1 exp2 => divisionErr(eval exp1)(eval exp2)
  end.

Compute (eval(div 7 2)).
Compute (eval (plus 12 3)).
Compute (eval (mult 12 0)).