(*************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*             Ralph Matthes [+]                              *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(*                             [+] Affiliation IRIT -- CNRS   *)
(*************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(*************************************************************)

(* * Pigeonhole principle *)

Require Import Arith Lia List Permutation Relations.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list.

Set Implicit Arguments.

Local Infix "~p" := (@Permutation _) (at level 70, no associativity).

Section incl.

  Variable X : Type.

  Implicit Type l : list X.

  Fact incl_cons_linv l m x : incl (x::m) l -> In x l /\ incl m l.
  Proof.
    intros H; split.
    + apply H; left; auto.
    + intros ? ?; apply H; right; auto.
  Qed.

  Fact incl_app_rinv l m p : incl m (l++p) -> exists m1 m2, m ~p m1++m2 /\ incl m1 l /\ incl m2 p.
  Proof.
    induction m as [ | x m IHm ].
    + exists nil, nil; simpl; repeat split; auto; intros ? [].
    + intros H.
      apply incl_cons_linv in H.
      destruct H as (H1 & H2).
      destruct (IHm H2) as (m1 & m2 & H3 & H4 & H5).
      apply in_app_or in H1; destruct H1.
      * exists (x::m1), m2; repeat split; auto.
        - constructor 2; auto.
        - intros ? [|]; subst; auto.
      * exists m1, (x::m2); repeat split; auto.
        - apply Permutation_cons_app; auto.
        - intros ? [|]; subst; auto.
  Qed.

  Fact incl_cons_rinv x l m : incl m (x::l) -> exists m1 m2, m ~p m1 ++ m2 /\ Forall (eq x) m1 /\ incl m2 l.
  Proof.
    intros H.
    apply (@incl_app_rinv (x::nil) _ l) in H.
    destruct H as (m1 & m2 & H1 & H2 & H3).
    exists m1, m2; repeat split; auto.
    rewrite Forall_forall.
    intros a Ha; apply H2 in Ha; destruct Ha as [ | [] ]; auto.
  Qed.

  Fact incl_right_cons_choose x l m : incl m (x::l) -> In x m \/ incl m l.
  Proof.
    intros H.
    apply incl_cons_rinv in H.
    destruct H as ( m1 & m2 & H1 & H2 & H3 ); simpl in H1.
    destruct m1 as [ | y m1 ].
    + right.
      intros u H; apply H3; revert H.
      apply Permutation_in; auto.
    + left.
      apply Permutation_in with (1 := Permutation_sym H1).
      rewrite Forall_forall in H2.
      rewrite (H2 y); left; auto.
  Qed.

  Fact incl_left_right_cons x l y m : incl (x::l) (y::m) -> y = x  /\ In y l
                                                         \/ y = x  /\ incl l m
                                                         \/ In x m /\ incl l (y::m).
  Proof.
    intros H; apply incl_cons_linv in H.
    destruct H as [ [|] H2 ]; auto.
    apply incl_right_cons_choose in H2; tauto.
  Qed.

  Fact perm_incl_left m1 m2 l: m1 ~p m2 -> incl m2 l -> incl m1 l.
  Proof. intros H1 H2 ? H. apply H2; revert H; apply Permutation_in; auto. Qed.

  Fact perm_incl_right m l1 l2: l1 ~p l2 -> incl m l1 -> incl m l2.
  Proof.
    intros H1 H2 ? ?; apply Permutation_in with (1 := H1), H2; auto.
  Qed.

End incl.

Section Permutation_tools.

  Variable X : Type.

  Implicit Types (l : list X).

  Theorem Permutation_In_inv l1 l2: l1 ~p l2 -> forall x, In x l1 -> exists l, exists r, l2 = l++x::r.
  Proof. intros H ? ?; apply in_split, Permutation_in with (1 := H); auto. Qed.

  Fact perm_in_head x l : In x l -> exists m, l ~p x::m.
  Proof.
    induction l as [ | y l IHl ].
    + destruct 1.
    + intros [ ? | H ]; subst.
      * exists l; apply Permutation_refl.
      * destruct (IHl H) as (m & Hm).
        exists (y::m).
        apply Permutation_trans with (2 := perm_swap _ _ _).
        constructor 2; auto.
  Qed.

End Permutation_tools.

Section pigeon_list.

  Variable (X : Type).

  Implicit Types (l m : list X).

  Inductive list_has_dup : list X -> Prop :=
    | in_list_hd0 : forall l x, In x l -> list_has_dup (x::l)
    | in_list_hd1 : forall l x, list_has_dup l -> list_has_dup (x::l).

  Fact list_hd_cons_inv x l : list_has_dup (x::l) -> In x l \/ list_has_dup l.
  Proof. inversion 1; subst; auto. Qed.

  Definition list_has_dup_cons_inv := list_hd_cons_inv.

  Fact list_has_dup_cons_iff x l : list_has_dup (x::l) <-> In x l \/ list_has_dup l.
  Proof.
    split.
    + apply list_hd_cons_inv.
    + intros []; [ constructor 1 | constructor 2 ]; auto.
  Qed.

  Fact list_has_dup_app_left l m : list_has_dup m -> list_has_dup (l++m).
  Proof. induction l; simpl; auto; constructor 2; auto. Qed.

  Fact list_has_dup_app_right l m : list_has_dup l -> list_has_dup (l++m).
  Proof.
    induction 1; simpl.
    + constructor 1; apply in_or_app; left; auto.
    + constructor 2; auto.
  Qed.

  Fact perm_list_has_dup l m : l ~p m -> list_has_dup l -> list_has_dup m.
  Proof.
    induction 1 as [ | x l m H1 IH1 | x y l | ]; auto;
      intros H; apply list_hd_cons_inv in H.
    + destruct H as [ H | H ].
      * apply Permutation_in with (1 := H1) in H.
        apply in_list_hd0; auto.
      * apply in_list_hd1; auto.
    + destruct H as [ [ H | H ] | H ]; subst.
      * apply in_list_hd0; left; auto.
      * apply in_list_hd1, in_list_hd0; auto.
      * apply list_hd_cons_inv in H.
        destruct H as [ H | H ].
        - apply in_list_hd0; right; auto.
        - do 2 apply in_list_hd1; auto.
  Qed.

  Fact list_has_dup_swap x y l : list_has_dup (x::y::l) -> list_has_dup (y::x::l).
  Proof. apply perm_list_has_dup; constructor. Qed.

  Fact list_has_dup_app_inv l m : list_has_dup (l++m) -> list_has_dup l
                                                      \/ list_has_dup m
                                                      \/ exists x, In x l /\ In x m.
  Proof.
    induction l as [ | x l IHl ]; simpl; intros H; auto.
    apply list_hd_cons_inv in H.
    + destruct H as [ H | H ].
      * apply in_app_or in H; destruct H as [ H | H ].
        - left; constructor; auto.
        - do 2 right; exists x; simpl; auto.
      * destruct (IHl H) as [ H1 | [ H1 | (y & H1 & H2) ] ]; auto.
        - left; constructor 2; auto.
        - do 2 right; exists y; simpl; auto.
  Qed.

  Fact list_has_dup_eq_duplicates m: list_has_dup m <-> exists x aa bb cc, m = aa++x::bb++x::cc.
  Proof.
    split.
    + induction 1 as [ m x Hm | m x _ IHm ].
      - apply in_split in Hm.
        destruct Hm as (bb & cc & Hm).
        exists x, nil, bb, cc; subst; auto.
      - destruct IHm as (y & aa & bb & cc & IHm).
        exists y, (x::aa), bb, cc; subst; auto.
    + intros (x & aa & bb & cc & Hm).
      subst m.
      apply list_has_dup_app_left.
      constructor 1; apply in_or_app; right.
      constructor 1; reflexivity.
  Qed.

  Definition list_has_dup_equiv := list_has_dup_eq_duplicates.

  Fact repeat_choice_two x m : Forall (eq x) m -> (exists m', m = x::x::m') \/ m = nil \/ m = x::nil.
  Proof.
    intros H.
    destruct m as [ | a [ | b m ] ]; auto.
    + inversion H; subst; auto.
    + rewrite Forall_forall in H.
      rewrite <- (H a), <- (H b); simpl; auto; left; exists m; auto.
  Qed.

  (* If m in included in x::l then
       a) either m is included in l
       b) or m has a duplicate (x but that does not matter here)
       c) or m is permutable with x::m' with m' included in l
   *)

  Fact incl_right_cons_incl_or_lhd_or_perm m x l :
       incl m (x::l) -> incl m l
                     \/ list_has_dup m
                     \/ exists m', m ~p x::m' /\ incl m' l.
  Proof.
    intros H.
    apply incl_cons_rinv in H.
    destruct H as (m1 & m2 & H1 & H2 & H3).
    destruct (repeat_choice_two H2) as [ (?&?) | [|] ];
      subst m1; simpl in H1; clear H2.
    + right; left; apply perm_list_has_dup with (1 := Permutation_sym H1), in_list_hd0; left; auto.
    + left; revert H1 H3; apply perm_incl_left.
    + firstorder.
  Qed.

  Fact incl_left_right_php x l y m : incl (y::m) (x::l) -> list_has_dup (y::m)
                                                        \/ x = y  /\ incl m l
                                                        \/ In y l /\ incl m l
                                                        \/ In y l /\ exists m', m ~p x::m' /\ incl m' l.
  Proof.
    intros H; apply incl_left_right_cons in H.
    destruct H as [ (? & ?) | [ (? & ?) | (H1 & H2) ] ]; subst; auto.
    + left; apply in_list_hd0; auto.
    + apply incl_right_cons_incl_or_lhd_or_perm in H2; firstorder.
      left; apply in_list_hd1; auto.
  Qed.

  (* length_le_and_incl_implies_dup_or_perm is a generalisation of the PHP
      for which the inductive case works w/o needing decidable equality

      A shorter proof

      The proof is by induction on l
   *)

  (* ** Generalized statement *)

  Lemma length_le_and_incl_implies_dup_or_perm l m :
            length l <= length m
         -> incl m l
         -> list_has_dup m \/ m ~p l.
  Proof.
    revert m; induction l as [ | x l IHl ]; intros m; simpl; intros H1 H2; auto.
    + destruct m as [ | y ]; auto; destruct (H2 y); simpl; auto.
    + destruct incl_right_cons_incl_or_lhd_or_perm with (1 := H2)
        as [ H3 | [ H3 | (m' & H3 & H4) ] ]; auto.
      * destruct IHl with (2 := H3) as [ | H ]; try lia; auto.
        apply Permutation_length in H; lia.
      * destruct IHl with (2 := H4) as [ H | H ]; try (simpl; lia).
        - apply Permutation_length in H3; simpl in H3; lia.
        - left; apply perm_list_has_dup with (1 := Permutation_sym H3).
          constructor 2; auto.
        - right; apply perm_trans with (1 := H3); auto.
  Qed.

  (* If  m is strictly longer than l
      and m is (set) included in l
      then it has a duplicate

      This proof does not require weakly decidable equality
      and it does not find where is the duplicate
    *)

  Theorem finite_php_dup l m : length l < length m
                            -> incl m l
                            -> list_has_dup m.
  Proof.
    intros H1 H2.
    destruct (@length_le_and_incl_implies_dup_or_perm l m) as [ | H3 ]; auto; try lia.
    apply Permutation_length in H3; lia.
  Qed.

  (* ** The Finite PHP on lists of the same type *)

  Theorem finite_pigeon_hole l m :
         length l < length m
      -> incl m l
      -> exists x aa bb cc, m = aa++x::bb++x::cc.
  Proof.
    intros; apply list_has_dup_eq_duplicates, finite_php_dup with l; auto.
  Qed.

  Theorem partition_intersection l m k :
           length k < length (l++m)
        -> incl (l++m) k
        -> list_has_dup l
        \/ list_has_dup m
        \/ exists x, In x l /\ In x m.
  Proof.
    intros H1 H2.
    apply list_has_dup_app_inv, list_has_dup_eq_duplicates.
    revert H1 H2; apply finite_pigeon_hole.
  Qed.

End pigeon_list.

Fact not_list_has_dup_an a n : ~ list_has_dup (list_an a n).
Proof.
  revert a; induction n as [ | n IHn ]; simpl; intros a H.
  + inversion H.
  + apply list_hd_cons_inv in H.
    rewrite list_an_spec in H.
    destruct H as [ | H ]; try lia.
    revert H; apply IHn.
Qed.

Fact list_has_dup_map_inv X Y (f : X -> Y) l :
           (forall x y, In x l -> In y l -> f x = f y -> x = y)
        -> list_has_dup (map f l)
        -> list_has_dup l.
Proof.
  intros H; do 2 rewrite list_has_dup_eq_duplicates.
  intros (y & m1 & m2 & m3 & E).
  apply map_app_inv in E; destruct E as (l1 & l10 & H1 & H2 & H3); symmetry in H3.
  apply map_cons_inv in H3; destruct H3 as (x1 & l11 & H3 & H4 & H5).
  apply map_app_inv in H5; destruct H5 as (l2 & l12 & H5 & H6 & H7); symmetry in H7.
  apply map_cons_inv in H7; destruct H7 as (x2 & l3 & H7 & H8 & H9); subst.
  apply H in H8; subst.
  + exists x1, l1, l2, l3; auto.
  + apply in_or_app; right; right; simpl.
    apply in_or_app; simpl; auto.
  + apply in_or_app; simpl; auto.
Qed.

Fact not_list_an_has_dup a n : ~ list_has_dup (list_an a n).
Proof.
  revert a; induction n as  [ | n IHn ]; simpl; intros a H.
  + inversion H.
  + apply list_hd_cons_inv in H.
    rewrite list_an_spec in H.
    destruct H as [ | H ]; try lia.
    revert H; apply IHn.
Qed.

Fact list_exists X Y (R : X -> Y -> Prop) l : (forall x, In x l -> exists y, R x y) -> exists ll, Forall2 R l ll.
Proof.
  induction l as [ | x l IHl ]; intros Hl.
  exists nil; constructor.
  destruct (Hl x) as (y & Hy).
  left; auto.
  destruct IHl as (ll & Hll).
  intros; apply Hl; right; auto.
  exists (y::ll); constructor; auto.
Qed.

Fact Forall2_conj X Y (R S : X -> Y -> Prop) ll mm : Forall2 (fun x y => R x y /\ S x y) ll mm <-> Forall2 R ll mm /\ Forall2 S ll mm.
Proof.
  split.
  induction 1; split; constructor; tauto.
  intros [H1 H2]; revert H1 H2.
  induction 1 as [ | x ll y mm H1 H2 IH ]; intros H; auto.
  apply Forall2_cons_inv in H; constructor; tauto.
Qed.

Fact Forall2_length X Y (R : X -> Y -> Prop) l m : Forall2 R l m -> length l = length m.
Proof. induction 1; simpl; f_equal; auto. Qed.

Fact Forall2_impl X Y (R S : X -> Y -> Prop) :
     (forall x y, R x y -> S x y) -> forall l m, Forall2 R l m -> Forall2 S l m.
Proof. induction 2; constructor; auto. Qed.

Fact Forall2_right_Forall X Y (P : Y -> Prop) lx ly : Forall2 (fun (_ : X) y => P y) lx ly <-> Forall P ly /\ length lx = length ly.
Proof.
  split.
  intros H; split.
  induction H; constructor; auto.
  revert H; apply Forall2_length.
  intros (H1 & H2); revert lx H2.
  induction H1; intros [ | ] H2; try discriminate H2; constructor; auto.
Qed.

Fact Forall2_app_inv_r X Y R l m1 m2 :
       @Forall2 X Y R l (m1++m2)
    -> { l1 : _ & { l2 | Forall2 R l1 m1 /\ Forall2 R l2 m2 /\ l = l1++l2 } }.
Proof.
  revert m2 l;
  induction m1 as [ | y m1 IH ]; simpl; intros m2 l H.
  exists nil, l; repeat split; auto.
  destruct l as [ | x l ].
  apply Forall2_nil_inv_l in H; discriminate H.
  apply Forall2_cons_inv in H; destruct H as [ H1 H2 ].
  apply IH in H2.
  destruct H2 as (l1 & l2 & H2 & H3 & H4); subst l.
  exists (x::l1), l2; repeat split; auto.
Qed.

Section PHP_rel.

  Variable (U V : Type) (R : U -> V -> Prop) (l : list U) (m : list V)
                        (HR : forall x, In x l -> exists y, In y m /\ R x y).

  Let image_R_l : exists Rl, incl Rl m /\ Forall2 R l Rl.
  Proof.
    destruct (list_exists _ l HR) as (Rl & HRl).
    exists Rl; split.
    + clear HR.
      rewrite Forall2_conj in HRl.
      apply proj1, Forall2_right_Forall, proj1 in HRl.
      rewrite Forall_forall in HRl; auto.
    + revert HRl; apply Forall2_impl; tauto.
  Qed.

  Hypothesis (Hlm : length m < length l).

  (* ** The finite relational PHP *)

  Theorem PHP_rel : exists a x b y c v, l = a++x::b++y::c
                                       /\ In v m /\ R x v /\ R y v.
  Proof.
    destruct image_R_l as (Rl & H1 & H2).
    destruct finite_pigeon_hole with (2 := H1) as (v & x & y & z & H).
    + apply Forall2_length in H2; lia.
    + subst Rl.
      apply Forall2_app_inv_r in H2; destruct H2 as (x' & l1 & H3 & H2 & ?); subst.
      apply Forall2_cons_inv_r in H2; destruct H2 as (v' & l2 & H4 & ? & H2); subst.
      apply Forall2_app_inv_r in H2; destruct H2 as (y' & l3 & H5 & H2 & ?); subst.
      apply Forall2_cons_inv_r in H2; destruct H2 as (v'' & l4 & H6 & ? & H2); subst.
      exists x', v', y', v'', l4, v; repeat (split; auto).
      apply H1, in_or_app; simpl; auto.
  Qed.

End PHP_rel.

Section php_upto.

  (* If R is a partial equivalence relation, l is a
      list contained in the list m (upto R), and m is
      shorter than l, then l contains a duplicate upto R *)

  Theorem php_upto X (R : X -> X -> Prop) (l m : list X) :
            symmetric _ R -> transitive _ R                  (* PER *)
         -> (forall x, In x l -> exists y, In y m /\ R x y)  (* l contained in m *)
         -> length m < length l                              (* shorter *)
         -> exists a x b y c, l = a++x::b++y::c /\ R x y.    (* duplicate *)
  Proof.
    intros HR1 HR2 H1 H2.
    destruct PHP_rel with (R := R) (2 := H2)
      as (a & x & b & y & c & z & G1 & G2 & G3 & G4); auto.
    exists a, x, b, y, c; split; auto.
    apply (HR2 _ z); auto.
  Qed.

End php_upto.


(** %\chapter{Encoding Mathematical Structures}% *)

Module DepRecords.

Require Import ssreflect ssrbool ssrnat ssrfun.

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

(** * Encoding partial commutative monoids *)

Module PCMDef.

(**

We have already seen a use of a dependent pair type, exemplified by
the Coq's definition of the universal quantification.

*)

Print ex.

(**
[[
Inductive ex (A : Type) (P : A -> Prop) : Prop :=
    ex_intro : forall x : A, P x -> ex P
]]

*)

Record mixin_of (T : Type) := Mixin {
    valid_op : T -> bool;
    join_op : T -> T -> T;
    unit_op : T;
    _ : commutative join_op;
    _ : associative join_op;
    _ : left_id unit_op join_op;
    _ : forall x y, valid_op (join_op x y) -> valid_op x;
    _ : valid_op unit_op
}.

(**
[[
mixin_of is defined
mixin_of_rect is defined
mixin_of_ind is defined
mixin_of_rec is defined
valid_op is defined
join_op is defined
unit_op is defined
]]
*)

Check valid_op.

(**
[[
valid_op
     : forall T : Type, mixin_of T -> T -> bool
]]
*)

Lemma r_unit T (pcm: mixin_of T) (t: T) : (join_op pcm t (unit_op pcm)) = t.
Proof.
case: pcm=>_ join unit Hc _ Hlu _ _ /=.

(**
[[
  T : Type
  t : T
  join : T -> T -> T
  unit : T
  Hc : commutative join
  Hlu : left_id unit join
  ============================
   join t unit = t
]]
*)

by rewrite Hc Hlu.
Qed.

(** ** An alternative definition *)

Inductive mixin_of' (T: Type) :=
  Mixin' (valid_op: T -> bool) (join_op : T -> T -> T) (unit_op: T) of
    commutative join_op &
    associative join_op &
    left_id unit_op join_op &
    forall x y, valid_op (join_op x y) -> valid_op x &
    valid_op unit_op.

(**

Although this definition seems more principled and is closer to what
we have seen in previous chapters, the record notation is more
convenient in this case, as it defined getters automatically as well
as allows one to express inheritance between data structures by means
of the coercion operator %\texttt{:>}%
operator%~\cite{Garillot-al:TPHOL09}%.%\footnote{In the next section
will show a different way to encode implicit inheritance, though.}%

** Packaging the structure from mixins
%\label{sec:packaging}%

*)

Section Packing.

Structure pack_type : Type := Pack {type : Type; _ : mixin_of type}.

(**

The dependent data structure [pack_type] declares two fields: the
field [type] of type [Type], which described the carrier type of the
PCM instance, and the actual PCM structure (without an explicit name
given) of type [mixin_of type]. That is, in order to construct an
instance of [pack_type], one will have to provide _both_ arguments:
the carrier set and a PCM structure for it.

*)

Local Coercion type : pack_type >-> Sortclass.

(**

Next, in the same section, we provide a number of abbreviations to
simplify the work with the PCM packed structure and prepare it to be
exported by clients.

*)
Variable cT: pack_type.

Definition pcm_struct : mixin_of cT :=
    let: Pack _ c := cT return mixin_of cT in c.

Definition valid := valid_op pcm_struct.
Definition join := join_op pcm_struct.
Definition unit := unit_op pcm_struct.

End Packing.

Module Exports.

Notation pcm := pack_type.
Notation PCMMixin := Mixin.
Notation PCM T m := (@Pack T m).

Notation "x \+ y" := (join x y) (at level 43, left associativity).
Notation valid := valid.
Notation Unit := unit.

Coercion type : pack_type >-> Sortclass.

(** * Properties of partial commutative monoids *)

Section PCMLemmas.
Variable U : pcm.

(**

For instance, the following lemma re-establishes the commutativity of
the [\+] operation:

*)

Lemma joinC (x y : U) : x \+ y = y \+ x.
Proof.
by case: U x y=> tp [v j z Cj *]; apply Cj.
Qed.

(**

Notice that in order to make the proof to go through, we had to "push"
the PCM elements [x] and [y] to be the assumption of the goal before
case-analysing on [U]. This is due to the fact that the structure of
[U] affects the type of [x] and [y], therefore destructing it by means
of [case] would change the representation of [x] and [y] as well,
doing some rewriting and simplifications. Therefore, when [U] is being
decomposed, al values, whose type depends on it (i.e., [x] and [y])
should be in the scope of decomposition. The naming pattern [*] helped
us to give automatic names to all remaining assumptions, appearing
from decomposition of [U]'s second component before moving it to the
context before finishing the proof by applying the commutativity
"field" [Cj].

*)

Lemma joinA (x y z : U) : x \+ (y \+ z) = x \+ y \+ z.
Proof.
by case: U x y z=>tp [v j z Cj Aj *]; apply: Aj.
Qed.

(*******************************************************************)
(**                     * Exercices 1 *                            *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [PCM Laws]
---------------------------------------------------------------------

Proove the rest of the PCM laws.
*)

Lemma joinAC (x y z : U) : x \+ y \+ z = x \+ z \+ y.
Proof.
(* fill in your proof here instead of [admit] *)
admit.
Qed.

Lemma joinCA (x y z : U) : x \+ (y \+ z) = y \+ (x \+ z).
Proof.
(* fill in your proof here instead of [admit] *)
admit.
Qed.

Lemma validL (x y : U) : valid (x \+ y) -> valid x.
Proof.
(* fill in your proof here instead of [admit] *)
admit.
Qed.

Lemma validR (x y : U) : valid (x \+ y) -> valid y.
Proof.
(* fill in your proof here instead of [admit] *)
admit.
Qed.

Lemma unitL (x : U) : (@Unit U) \+ x = x.
Proof.
(* fill in your proof here instead of [admit] *)
admit.
Qed.

Lemma unitR (x : U) : x \+ (@Unit U) = x.
Proof.
(* fill in your proof here instead of [admit] *)
admit.
Qed.

Lemma valid_unit : valid (@Unit U).
Proof.
(* fill in your proof here instead of [admit] *)
admit.
Qed.

(*******************************************************************)
(**                 * End of Exercices 1 *                         *)
(*******************************************************************)

End PCMLemmas.

End Exports.

End PCMDef.

Export PCMDef.Exports.

(** * Implementing inheritance hierarchies

We will now go even further and show how to build hierarchies of
mathematical structures using the same way of encoding inheritance. We
will use a _cancellative PCM_ as a running example.

*)

Module CancelPCM.

Record mixin_of (U : pcm) := Mixin {
  _ : forall a b c: U, valid (a \+ b) -> a \+ b = a \+ c -> b = c
}.

Structure pack_type : Type := Pack {pcmT : pcm; _ : mixin_of pcmT}.

Module Exports.

Notation cancel_pcm := pack_type.
Notation CancelPCMMixin := Mixin.
Notation CancelPCM T m:= (@Pack T m).

Coercion pcmT : pack_type >-> pcm.

Lemma cancel (U: cancel_pcm) (x y z: U):
  valid (x \+ y) -> x \+ y = x \+ z -> y = z.
Proof.
by case: U x y z=>Up [Hc] x y z; apply: Hc.
Qed.

End Exports.
End CancelPCM.

Export CancelPCM.Exports.

Lemma cancelC (U: cancel_pcm) (x y z : U) :
  valid (y \+ x \+ z) -> y \+ x = x \+ z -> y = z.
Proof.
by move/validL; rewrite ![y \+ _]joinC; apply: cancel.
Qed.

(**

* Instantiation and canonical structures

Now, as we have defined a PCM structure along with its specialized
version, a cancellative PCM, it is time to see how to _instantiate_
these abstract definitions with concrete datatypes, i.e., _prove_ the
later ones to be instances of a PCM.

** Defining arbitrary PCM instances

Natural numbers form a PCM, in particular, with addition as a join
operation and zero as a unit element. The validity predicate is
constant true, because the addition of two natural numbers is again a
valid natural number. Therefore, we can instantiate the PCM structure
for [nat] as follows, first by constructing the appropriate mixin.

*)

Definition natPCMMixin :=
  PCMMixin addnC addnA add0n (fun x y => @id true) (erefl _).

Definition NatPCM := PCM nat natPCMMixin.

(**

This definition will indeed work, although, being somewhat
unsatisfactory. For example, assume we want to prove the following
lemma for natural numbers treated as elements of a PCM, which should
trivially follow from the PCM properties of [nat] with addition and
zero:

[[
Lemma add_perm (a b c : nat) : a \+ (b \+ c) = a \+ (c \+ b).
]]

[[
The term "a" has type "nat" while it is expected to have type "PCMDef.type ?135".
]]

*)

Canonical natPCM := PCM nat natPCMMixin.

Print Canonical Projections.

(**
[[
...
nat <- PCMDef.type ( natPCM )
pred_of_mem <- topred ( memPredType )
pred_of_simpl <- topred ( simplPredType )
sig <- sub_sort ( sig_subType )
number <- sub_sort ( number_subType )
...
]]
*)

Lemma cancelNat : forall a b c: nat, true -> a + b = a + c -> b = c.
Proof.
move=> a b c; elim: a=>// n /(_ is_true_true) Hn _ H.
by apply: Hn; rewrite !addSn in H; move/eq_add_S: H.
Qed.

Definition cancelNatPCMMixin := CancelPCMMixin cancelNat.

Canonical cancelNatPCM := CancelPCM natPCM cancelNatPCMMixin.

(**

Let us now see the canonical instances in action, so we can prove a
number of lemmas about natural numbers employing the general PCM
machinery.

*)

Section PCMExamples.

Variables a b c: nat.

Goal a \+ (b \+ c) =  c \+ (b \+ a).
by rewrite joinA [c \+ _]joinC [b \+ _]joinC.
Qed.

Goal c \+ a = a \+ b -> c = b.
by rewrite [c \+ _]joinC; apply: cancel.
Qed.

(**

It might look a bit cumbersome, though, to write the PCM join
operation [\+] instead of the boolean addition when specifying the
facts about natural numbers (even though they are treated as elements
of the appropriate PCM). Unfortunately, it is not trivial to encode
the mechanism, which will perform such conversion implicitly. Even
though Coq is capable of figuring out what PCM is necessary for a
particular type (if the necessary canonical instance is defined),
e.g., when seeing [(a b : nat)] being used, it infers the [natPCM],
alas, it's not powerful enough to infer that the by writing the
addition function [+] on natural numbers, we mean the PCM's
join. However, if necessary, in most of the cases the conversion like
this can be done by manual rewriting using the following trivial
"conversion" lemma.

*)

Lemma addn_join (x y: nat): x + y = x \+ y.
Proof. by []. Qed.

End PCMExamples.

(** ** Types with decidable equalities

The module [eqtype] of SSReflect's standard library provides a
definition of the equality mixin and packaged class of the familiar
shape, which, after some simplifications, boil to the following ones:

[[
Module Equality.

Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y).

Structure mixin_of T := Mixin {op : rel T; _ : axiom op}.
Structure type := Pack {sort; _ : mixin_of sort}.

...

Notation EqMixin := Mixin.
Notation EqType T m := Pack T m.

End Equality.
]]

DEMO: check the corresponding files ssreflect-1.4/theories/eqtype.v
and ssreflect-1.4/theories/ssrnat.v

*)

(*******************************************************************)
(**                     * Exercices 2 *                            *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [Partially-ordered sets]
---------------------------------------------------------------------

A partially ordered set order is a pair (T, <==), where T is a carrier
set and <== is a relation on T, such that

- forall x in T, x <== x (reflexivity);

- forall x, y in T, x <== y /\ y <== x \implies x = y (antisymmetry);

- forall x, y, z in T, x <== y /\ y <== z \implies x <== z (transitivity).

Implement a data structure for partially-ordered sets using mixins and
packed classes. Prove the following laws:

Lemma poset_refl (x : T) : x <== x.
Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
*)

(**
---------------------------------------------------------------------
Exercise [Canonical instances of partially ordered sets]
---------------------------------------------------------------------

Provide canonical instances of partially ordered sets for the
following types:

- [nat] and [<=];

- [prod], whose components are posets;

- functions [A -> B], whose codomain (range) [B] is a partially
  ordered set.

In order to provide a canonical instance for functions, you will need
to assume and make use of the following axiom of functional
extensionality:

*)

Axiom fext : forall A (B : A -> Type) (f1 f2 : forall x, B x),
               (forall x, f1 x = f2 x) -> f1 = f2.

(*******************************************************************)
(**                 * End of Exercices 2 *                         *)
(*******************************************************************)

End DepRecords.


Require Import Classical.

(* Importando definiciones. *)
From src Require Export Defs_LC.

(* Lema auxiliar, a -> ~~a *)
Lemma double_neg_intro: forall (a: Prop), a -> ~~a.
Proof.
intros.
assert (~~a \/ ~~~a).
+ apply classic.
+ destruct H0.
  - trivial.
  - apply NNPP in H0.
    contradiction.
Qed.

(* Lema auxiliar, a /\ ~b -> ~(a -> b) *)
Lemma and_to_imply: forall (a b: Prop), a /\ ~b -> ~(a -> b).
Proof.
intros.
destruct H.
contradict H0.
apply H0.
trivial.
Qed.

(* Lema auxiliar: Modus Tollens *)
Lemma modus_tollens: forall (a b: Prop), (a -> b) -> (~b -> ~a).
Proof.
intros.
contradict H0.
apply H.
trivial.
Qed.

(* Lema auxiliar: Implicación de ~forall -> exists~ se cumple con dos variables *)
Lemma not_forall_exists_not_double: forall (U1 U2: Type) (P: U1 -> U2 -> Prop),
~(forall (x: U1),forall (y: U2), P x y) -> exists (x: U1), exists (y: U2), ~P x y.
Proof.
intros.
assert (exists x: U1, ~ forall y:U2, P x y).
+ apply not_all_ex_not.
  trivial.
+ destruct H0.
  exists x.
  apply not_all_ex_not.
  trivial.
Qed.

(* Ejercicio 3a *)
Theorem coten_conm: forall (a b: Prop), a ° b <-> b ° a.
Proof.
unfold cotenability.
split.
+ intro.
  contradict H.
  intro.
  assert (b \/ ~b).
  * apply classic.
  * destruct H1.
    - apply H in H1.
      contradiction.
    - trivial.
+ intro.
  contradict H.
  intro.
  assert (a \/ ~a).
  * apply classic.
  * destruct H1.
    - apply H in H1.
      contradiction.
    - trivial.
Qed.

(* Ejercicio 3b *)
Theorem coten_assoc: forall (a b c: Prop), a ° (b ° c) <-> (a ° b) ° c.
Proof.
unfold cotenability.
split.
+ intro.
  contradict H.
  intro.
  apply double_neg_intro.
  intro.
  apply H.
  apply and_to_imply.
  split.
  - trivial.
  - apply double_neg_intro.
    trivial.
+ intro.
  contradict H.
  intro.
  contradict H0.
  intro.
  apply H in H1.
  apply NNPP in H1.
  apply imply_to_or in H1.
  destruct H1.
  - trivial.
  - contradiction.
Qed.

(* Ejercicio 3c *)
Theorem coten_distr: forall (A B C: Prop), (A ° B) \/ (A ° C) <-> A ° (B \/ C).
Proof.
unfold cotenability.
intros.
split.
+ intro.
  destruct H.
  - contradict H.
    intro.
    apply H in H0.
    apply not_or_and in H0.
    destruct H0.
    trivial.
  - contradict H.
    intro.
    apply H in H0.
    apply not_or_and in H0.
    destruct H0.
    trivial.
+ intro.
  apply imply_to_and in H.
  destruct H.
  apply NNPP in H0.
  destruct H0.
  - left.
    apply and_to_imply.
    split.
    * trivial.
    * apply double_neg_intro.
      trivial.
  - right.
    apply and_to_imply.
    split.
    * trivial.
    * apply double_neg_intro.
      trivial.
Qed.

(* Ejercicio 3d *)
Theorem coten_fusion: forall (A B C: Prop), (A -> B -> C) <-> ((A ° B) -> C).
Proof.
unfold cotenability.
split.
+ intros.
  apply imply_to_and in H0.
  destruct H0.
  apply H.
  * trivial.
  * apply NNPP.
    trivial.
+ intros.
  apply H.
  apply and_to_imply.
  split.
  * trivial.
  * apply double_neg_intro.
    trivial.
Qed.

(* Ejercicio 3e *)
Theorem imply_def: forall (A B C: Prop), (A -> B) <-> ~(A ° ~B).
Proof.
unfold cotenability.
split.
+ intro.
  apply double_neg_intro.
  intro.
  apply double_neg_intro.
  apply H.
  trivial.
+ intros.
  apply NNPP in H.
  apply H in H0.
  apply NNPP.
  trivial.
Qed.

(* Ejercicio 4a *)
Theorem foura: forall (T1: Type) (A B C: T1->Prop) (a: T1), ((exists x:T1, (A x /\ B x)) -> (forall x:T1, B x -> C x))
/\ (B a /\ ~ C a) -> ~(forall x:T1, A x).
Proof.
intros.
destruct H.
apply ex_not_not_all.
assert (B a /\ ~ C a); trivial.
apply and_to_imply in H0.
apply modus_tollens in H.
+ exists a.
  destruct H1.
  assert (forall x:T1, ~ (A x /\  B x)).
  - apply not_ex_all_not.
    exact H.
  - assert (~ (A a /\ B a)).
    * apply H3.
    * apply not_and_or in H4.
      destruct H4.
      ++ trivial.
      ++ contradiction.
+ apply ex_not_not_all.
  exists a.
  trivial.
Qed.

(* Ejercicio 4b *)
Theorem fourb: forall (T1 T2 T3: Type) (B : T1 -> T2 -> Prop) (m: T2) (C W : T3 -> Prop) (G: T1 -> T3 -> Prop),
((exists x: T1, ~ (B x m) /\ forall y: T3, C y -> ~ G x y)
/\ (forall z: T1, ~ (forall y : T3, W y -> G z y) -> B z m)) -> forall x: T3, C x -> ~ W x.
Proof.
intros.
destruct H.
destruct H.
destruct H.
apply H2 in H0.
assert (forall z: T1, (exists y: T3, ~(W y -> G z y)) -> B z m).
+ intros.
  apply H1.
  apply ex_not_not_all.
  exact H3.
+ assert((exists y : T3, ~ (W y -> G x0 y)) -> B x0 m).
  - apply H3.
  - apply modus_tollens in H4.
    eapply not_ex_not_all in H4.
    apply modus_tollens in H4.
    apply H4.
    trivial.
    trivial.
Qed.

(* Ejercicio 4c *)
Theorem fourc: forall (T1 T3 T2 T4: Type) (P H : T1 -> Prop) (C: T1 -> Prop) (L: T3 -> Prop) (A: T1 -> T3 -> Prop) (R: T2 -> Prop) (B: T2 -> T4 -> Prop),
((~forall x: T1, ~ P x \/ ~ H x) -> (forall x: T1, C x /\ forall y: T3, L y -> A x y)) /\
((exists x:T1, H x /\ forall y: T3, L y -> A x y) -> (forall x: T2, R x /\ forall y:T4, B x y)) ->
((~forall x: T2, forall y: T4, B x y) -> forall x: T1, ~ P x \/ ~ H x).
Proof.
intros.
destruct H0.
apply not_forall_exists_not_double in H1.
destruct H1.
destruct H1.
apply modus_tollens in H2.
+ eapply not_ex_all_not in H2.
  apply not_and_or in H2.
  destruct H2.
  * right; apply H2.
  * apply modus_tollens in H0.
    - apply NNPP in H0.
      apply H0.
    - apply ex_not_not_all.
      apply not_all_ex_not in H2.
      destruct H2.
      exists x.
      apply or_not_and.
      right.
      apply ex_not_not_all.
      exists x2.
      trivial.
+ apply ex_not_not_all.
  exists x0.
  apply or_not_and.
  right.
  apply ex_not_not_all.
  exists x1; trivial.
Qed.


(* Exercise 9 *)

Require Import BenB.

Variables A B C D : Prop.

(* Disjunction is commutative *)

Theorem exercise_009 : (A \/ B) -> (B \/ A).
Proof.
imp_i a1.
dis_e (A \/ B) a2 a2.
hyp a1.
dis_i2.
hyp a2.
dis_i1.
hyp a2.
Qed.


Require Import List.
Require Import Omega.

Lemma app_hd {A}:
  forall (l1 l2:list A) d,
  l1 <> nil -> hd d (l1 ++ l2) = hd d l1.
Proof.
  intros l1 l2 d l1_non_nil; destruct l1.
  + exfalso; apply l1_non_nil; auto.
  + rewrite <-app_comm_cons; simpl; auto.
Qed.

Lemma app_last {A}:
  forall (l1 l2:list A) d,
  l2 <> nil -> last (l1 ++ l2) d = last l2 d.
Proof.
  intros l1 l2 d l2_non_nil; induction l1.
  + auto.
  + cut (length (l1 ++ l2) > 0).
    {
      rewrite <-app_comm_cons; simpl; destruct (l1 ++ l2).
      + simpl; intros; omega.
      + rewrite IHl1; auto.
    }
    cut (length l2 > 0).
    {
      intros; rewrite app_length; omega.
    }
    destruct l2.
    - exfalso; apply l2_non_nil; auto.
    - simpl; omega.
Qed.

Lemma app_firstn {A}:
  forall n (l1 l2:list A),
  n <= length l1 -> firstn n (l1 ++ l2) = firstn n l1.
Proof.
  induction n.
  + auto.
  + destruct l1.
    - simpl in *; intros; omega.
    - intros; rewrite <-app_comm_cons; simpl in *; rewrite IHn by omega; auto.
Qed.

Lemma app_firstn' {A}:
  forall n (l1 l2:list A),
  length l1 <= n -> firstn n (l1 ++ l2) = l1 ++ (firstn (n - length l1) l2).
Proof.
  induction n.
  + destruct l1; simpl; auto; intros; omega.
  + destruct l1.
    - simpl; auto.
    - intros; simpl in *; rewrite IHn; auto; omega.
Qed.

Lemma app_skipn {A}:
  forall n (l1 l2:list A),
  n <= length l1 -> skipn n (l1 ++ l2) = (skipn n l1) ++ l2.
Proof.
  induction n.
  + auto.
  + destruct l1.
    - simpl in *; intros; omega.
    - intros; rewrite <-app_comm_cons; simpl in *; rewrite IHn by omega; auto.
Qed.

Lemma app_skipn' {A}:
  forall n (l1 l2:list A),
  length l1 <= n -> skipn n (l1 ++ l2) = skipn (n - length l1) l2.
Proof.
  induction n.
  + destruct l1; auto; simpl; intros; omega.
  + destruct l1.
    - intros; simpl app; simpl length; rewrite <-minus_n_O; auto.
    - simpl; intros; rewrite IHn; auto; omega.
Qed.

Lemma firstn_whole {A}:
  forall n (l:list A),
  length l <= n -> firstn n l = l.
Proof.
  induction n.
  + destruct l; auto; simpl; intros; omega.
  + destruct l.
    - auto.
    - simpl; intros; rewrite IHn by omega; auto.
Qed.

Lemma hd_skip1_cons {A}:
  forall (l:list A) d,
  l <> nil -> (hd d l) :: (skipn 1 l) = l.
Proof.
  intros; destruct l.
  + exfalso; apply H; auto.
  + simpl; auto.
Qed.

Lemma removelast_length {A}:
  forall (l:list A),
  l <> nil -> S (length (removelast l)) = length l.
Proof.
  induction l.
  + intros Habs; exfalso; apply Habs; auto.
  + destruct l as [|b l].
    - intros; simpl; auto.
    - intros; simpl in *; apply f_equal, IHl; discriminate.
Qed.

Lemma skipn_length {A}:
  forall (l:list A) n,
  length (skipn n l) = length l - n.
Proof.
  induction l.
  + intros; case n; auto.
  + destruct n.
    - auto.
    - intros; simpl in *; apply IHl; omega.
Qed.

Inductive paren :=
  | open
  | close.

Inductive wp: list paren -> Prop :=
  | wp_e: wp nil
  | wp_p: forall l, wp l -> wp (open :: l ++ close :: nil)
  | wp_c: forall l1 l2, wp l1 -> wp l2 -> wp (l1 ++ l2).

Fixpoint is_wp_aux (l:list paren) (n:nat) :=
  match l, n with
  | nil, 0 => true
  | open :: t, k => is_wp_aux t (S k)
  | close :: t, S k => is_wp_aux t k
  | _, _ => false
  end.

Definition is_wp l := is_wp_aux l 0.

Lemma wp_implies_no_change:
  forall l1 l2 n, wp l1 -> is_wp_aux (l1 ++ l2) n = is_wp_aux l2 n.
Proof.
  intros l1 l2 n wp_l1.
  generalize l2, n; clear l2 n.
  induction wp_l1.
  + simpl; auto.
  + intros; simpl; rewrite <-app_assoc, IHwp_l1; simpl; auto.
  + intros; rewrite <-app_assoc, IHwp_l1_1, IHwp_l1_2; auto.
Qed.

Lemma wp_implies_is_wp: forall l, wp l -> is_wp l = true.
Proof.
  intros; unfold is_wp; rewrite <-app_nil_r with (l := l).
  rewrite wp_implies_no_change by auto; auto.
Qed.

Fixpoint rep_open (n:nat) :=
  match n with
  | 0 => nil
  | S k => open :: (rep_open k)
  end.

Lemma rep_open_split_last:
  forall n l, rep_open n ++ open :: l = rep_open (S n) ++ l.
Proof.
  intros; induction n.
  + simpl; auto.
  + simpl rep_open in *; repeat rewrite <-app_comm_cons; rewrite IHn.
    repeat rewrite <-app_comm_cons; auto.
Qed.

Lemma wp_non_nil_starts_open:
  forall l d, wp l -> l <> nil -> hd d l = open.
Proof.
  intros l d wp_l l_non_nil.
  induction wp_l.
  + exfalso; apply l_non_nil; auto.
  + simpl; auto.
  + destruct l1, l2.
    - simpl in l_non_nil; exfalso; apply l_non_nil; auto.
    - simpl; apply IHwp_l2; discriminate.
    - simpl; apply IHwp_l1; discriminate.
    - simpl; apply IHwp_l1; discriminate.
Qed.

Lemma wp_non_nil_ends_close:
  forall l d, wp l -> l <> nil -> last l d = close.
Proof.
  intros l d wp_l l_non_nil.
  induction wp_l.
  + exfalso; apply l_non_nil; auto.
  + rewrite app_comm_cons, app_last.
    - auto.
    - discriminate.
  + destruct l1, l2.
    - simpl in *; exfalso; apply l_non_nil; auto.
    - rewrite app_nil_l, IHwp_l2; auto.
    - rewrite app_nil_r, IHwp_l1; auto; discriminate.
    - rewrite app_last.
      * rewrite IHwp_l2; auto; discriminate.
      * discriminate.
Qed.

Lemma open_close_ins_keeps_wp:
  forall l l', wp (l ++ l') -> wp (l ++ open :: close :: nil ++ l').
Proof.
  (* useful general assertion *)
  assert (wp (open :: close :: nil)) as wp_oc.
  {
    assert (open :: close :: nil = (open :: nil) ++ (close :: nil)) as oc_eq by (simpl; auto).
    rewrite oc_eq; apply wp_p, wp_e.
  }
  (* we do length induction *)
  cut (forall n l l', length (l ++ l') <= n -> wp (l ++ l') -> wp (l ++ open :: close :: nil ++ l')).
  {
    intros H l l'; apply H with (n := length (l ++ l')); omega.
  }
  induction n.
  {
    (* trivial length 0 case *)
    destruct l, l'; simpl; intros; try omega.
    apply wp_oc.
  }
  {
    (* now we do induction in the wp cases *)
    intros l l' ll'_length_bounds wp_ll'.
    remember (l ++ l') as ll'.
    induction wp_ll'.
    {
      (* nil case is trivial *)
      assert (l = nil /\ l' = nil) as [l_is_nil l'_is_nil] by (apply app_eq_nil; auto).
      rewrite l_is_nil, l'_is_nil; simpl; apply wp_oc.
    }
    {
      (* the parenthesized one, not so much: we need to start by disposing of the easy cases first *)
      destruct l, l'.
      + simpl; apply wp_oc.
      + assert (nil ++ open :: close :: nil ++ p :: l' = (open :: close :: nil) ++ p :: l') as Heq by auto.
        rewrite Heq; apply wp_c.
        - apply wp_oc.
        - rewrite <-app_nil_l, <-Heqll'; apply wp_p; auto.
      + assert ((p :: l) ++ open :: close :: nil ++ nil = (p :: l) ++ (open :: close :: nil)) as Heq by auto.
        rewrite Heq; apply wp_c.
        - rewrite <-app_nil_r, <-Heqll'; apply wp_p; auto.
        - apply wp_oc.
      (* now that we are in the main case, we start by showing the expression follows the
         open :: x ++ close :: nil shape *)
      + assert (p = open) as p_is_open.
        {
          assert (p = hd close ((p :: l) ++ p0 :: l')) as p_eq by auto.
          assert (open = hd close (open :: l0 ++ close :: nil)) as open_eq by auto.
          rewrite p_eq, open_eq, Heqll'; auto.
        }
        assert (last (p0 :: l') open = close) as last_is_close.
        {
          assert (last (p0 :: l') open = last ((p :: l) ++ p0 :: l') open) as last_eq
            by (rewrite app_last by discriminate; auto).
          assert (close = last (open :: l0 ++ close :: nil) open) as close_eq
            by (rewrite app_comm_cons, app_last by discriminate; auto).
          rewrite last_eq, close_eq, Heqll'; auto.
        }
        rewrite p_is_open, app_removelast_last with (d := open) (l := p0 :: l'), last_is_close
          by discriminate.
        assert ((open :: l) ++ open :: close :: nil ++ removelast (p0 :: l') ++ close :: nil =
                open :: (l ++ open :: close :: nil ++ removelast (p0 :: l')) ++ close :: nil) as Heq.
        repeat (repeat rewrite app_assoc; repeat rewrite app_comm_cons); auto.
        (* now we can apply the usual machinery to shrink the string and call the inductive hypothesis *)
        rewrite Heq; apply wp_p, IHn.
        (* we have to prove the shrinking *)
        - assert (S(length(removelast (p0 :: l'))) = S(length l')) as removelast_len_eq
            by (rewrite removelast_length; try discriminate; auto).
          rewrite Heqll', app_length in ll'_length_bounds; simpl in ll'_length_bounds.
          rewrite app_length; omega.
        (* then we have to prove everything is well founded *)
        - assert (l0 = l ++ removelast (p0 :: l')) as l0_eq.
          {
            apply app_inv_head with (l := open :: nil); simpl app at 1.
            apply app_inv_tail with (l := close :: nil).
            rewrite <-app_comm_cons, Heqll', <-p_is_open, <-last_is_close.
            repeat rewrite <-app_assoc; rewrite <-app_removelast_last by discriminate.
            simpl; auto.
          }
          rewrite <-l0_eq; auto.
    }
    {
      (* the concatenation case *)
      (* we need to dispose of the easy cases *)
      destruct l1, l2.
      + apply IHwp_ll'1; auto; rewrite <-Heqll'.
      + apply IHwp_ll'2; auto; rewrite <-Heqll'.
      + apply IHwp_ll'1; rewrite app_nil_r in *; try omega; rewrite <-Heqll'; auto.
      (* this is the main case *)
      (* we need to handle the two cases, depending on where the added open :: close falls *)
      + destruct (le_dec (length (p :: l1)) (length l)).
        (* the easiest one: the open :: close is entirely beyond the first component *)
        - rewrite <-firstn_skipn with (n := length (p :: l1)).
          rewrite app_firstn, app_skipn by auto.
          assert (firstn (length (p :: l1)) l = p :: l1) as l1_eq.
          {
            erewrite <-app_firstn by auto; instantiate (1 := l').
            rewrite <-Heqll', app_firstn, firstn_whole by auto; auto.
          }
          assert (skipn (length (p :: l1)) l ++ l' = p0 :: l2) as l2_eq.
          {
            apply app_inv_head with (l := p :: l1).
            rewrite <-l1_eq, app_assoc, firstn_skipn, Heqll' at 1; auto.
          }
          rewrite l1_eq; apply wp_c, IHn; auto.
          * rewrite app_length, skipn_length.
            rewrite Heqll', app_length in ll'_length_bounds.
            assert (length (p :: l1) > 0) by (simpl; omega).
            omega.
          * rewrite l2_eq; auto.
        (* the open :: close falls in the middle or on the first component entirely *)
        - rewrite <-firstn_skipn with (n := length (p :: l1) + 2).
          rewrite app_firstn', app_skipn' by omega.
          assert (length (p :: l1) + 2 - length l - 2 = length (p :: l1) - length l) as len_eq by omega.
          assert (skipn (length (p :: l1) + 2 - length l) (open :: close :: nil ++ l') = p0 :: l2) as l2_eq.
          {
            do 2 rewrite app_comm_cons; rewrite app_skipn' by (simpl length at 1; omega); simpl length at 3.
            rewrite len_eq, <-app_skipn' by omega.
            apply app_inv_head with (l := p :: l1).
            rewrite <-Heqll', app_skipn', <-minus_n_n by auto; auto.
          }
          assert (l ++ firstn (length (p :: l1) - length l) l' = p :: l1) as l1_eq
            by (rewrite <-app_firstn', <-Heqll', app_firstn, firstn_whole by omega; auto).
          rewrite l2_eq; apply wp_c; auto.
          do 2 rewrite app_comm_cons; rewrite app_firstn' by (simpl length at 1; omega); simpl length at 3.
          rewrite len_eq.
          apply IHn; rewrite <-app_firstn', <-Heqll', app_firstn, firstn_whole by omega.
          * rewrite app_length in ll'_length_bounds; simpl in *; omega.
          * auto.
    }
  }
Qed.

Lemma is_wp_implies_wp_aux:
  forall l n, is_wp_aux l n = true -> wp ((rep_open n) ++ l).
Proof.
  induction l.
  {
    simpl; intros; destruct n.
    + simpl; apply wp_e.
    + discriminate.
  }
  {
    intros; destruct a.
    + rewrite rep_open_split_last; apply IHl; simpl in *; auto.
    + destruct n.
      - simpl in *; discriminate.
      - assert (rep_open (S n) ++ close :: l = rep_open n ++ open :: close :: nil ++ l) as Heq
          by (rewrite <-rep_open_split_last; simpl; auto).
        rewrite Heq.
        apply open_close_ins_keeps_wp, IHl; simpl in *; auto.
  }
Qed.

Lemma is_wp_implies_wp: forall l, is_wp l = true -> wp l.
Proof.
  unfold is_wp; intros.
  assert (nil = rep_open 0) as rep_open_0_is_nil by auto.
  rewrite <-app_nil_l, rep_open_0_is_nil.
  apply is_wp_implies_wp_aux; auto.
Qed.

Lemma is_wp_works:
  forall l, is_wp l = true <-> wp l.
Proof.
  split.
  + apply is_wp_implies_wp.
  + apply wp_implies_is_wp.
Qed.


From mathcomp Require Import ssreflect.

Require Import relation.

Axiom AxiomOfPower:
  forall U:Type, forall x: Collection U, exists y':Collection (Collection U), forall z:Collection U,
          (z ⊂ x -> z ∈ y').

Inductive PowerCollection {U:Type} (A:Collection U) : Collection (Collection U) :=
| definition_of_power: forall x':Collection U, x' ⊂ A -> x' ∈ PowerCollection A.

(* 𝔓:Unicode 1D513 *)
Notation "𝔓( X )" := (PowerCollection X) (at level 15).

Section AxiomOfPowerTest.
  Variable U:Type.

  Goal
    forall x': Collection U, forall Z:Collection (Collection U),
        Z = PowerCollection x' ->
        exists y':Collection (Collection U), forall z:Collection U, (z ⊂ x' -> z ∈ y').
  Proof.
    move => x' Z HZ.
    exists Z.
    rewrite HZ.
    move => z Hzx'.
    apply definition_of_power.
    apply Hzx'.
  Qed.
End AxiomOfPowerTest.


(* Software Foundations *)
(* Exercice 3 stars, b_timesm *)

Inductive beautiful: nat -> Prop :=
|b_0: beautiful 0
|b_3: beautiful 3
|b_5: beautiful 5
|b_sum: forall n m, beautiful n -> beautiful m -> beautiful (n +m).

Theorem b_timesm: forall n m, beautiful n -> beautiful (m * n).
Proof.
    intros. induction m as [|m'].
    simpl. apply b_0.
    simpl. apply b_sum with (n:=n)(m:=m'*n).
    apply H.
    apply IHm'.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Classes.Morphisms.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Hints.ZArith.
Require Import Crypto.Util.ZUtil.Tactics.ReplaceNegWithPos.
Require Import Crypto.Util.ZUtil.Testbit.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeBy.

Local Open Scope Z_scope.

Notation stabilizes_after x l := (exists b, forall n, l < n -> Z.testbit x n = b).

Lemma stabilizes_after_Proper x
  : Proper (Z.le ==> Basics.impl) (fun l => stabilizes_after x l).
Proof.
  intros ?? H [b H']; exists b.
  intros n H''; apply (H' n); lia.
Qed.

Module Z.
  Notation stabilization_time x := (Z.max (Z.log2 (Z.pred (- x))) (Z.log2 x)).
  Notation stabilization_time_weaker x := (Z.log2_up (Z.abs x)).

  Lemma stabilization_time_nonneg x : 0 <= stabilization_time x.
  Proof. rewrite Z.max_le_iff; constructor; apply Z.log2_nonneg. Qed.
#[global]
  Hint Resolve Z.stabilization_time_nonneg : zarith.

  Lemma stabilization_time_weaker_nonneg x : 0 <= stabilization_time_weaker x.
  Proof. apply Z.log2_up_nonneg. Qed.
#[global]
  Hint Resolve Z.stabilization_time_weaker_nonneg : zarith.
End Z.
Global Hint Resolve Z.stabilization_time_nonneg Z.stabilization_time_weaker_nonneg : zarith.

Lemma stabilization_time (x:Z) : stabilizes_after x (Z.stabilization_time x).
Proof.
  destruct (Z_lt_le_dec x 0); eexists; intros;
    [ eapply Z.bits_above_log2_neg | eapply Z.bits_above_log2]; lia.
Qed.

Lemma stabilization_time_weaker (x:Z) : stabilizes_after x (Z.stabilization_time_weaker x).
Proof.
  eapply stabilizes_after_Proper; try apply stabilization_time.
  repeat match goal with
         | [ |- context[Z.abs _ ] ] => apply Zabs_ind; intro
         | [ |- context[Z.log2 ?x] ]
           => rewrite (Z.log2_nonpos x) by lia
         | [ |- context[Z.log2_up ?x] ]
           => rewrite (Z.log2_up_nonpos x) by lia
         | _ => rewrite Z.max_r by auto with zarith
         | _ => rewrite Z.max_l by auto with zarith
         | _ => etransitivity; [ apply Z.le_log2_log2_up | lia ]
         | _ => progress Z.replace_all_neg_with_pos
         | [ H : 0 <= ?x |- _ ]
           => assert (x = 0 \/ x = 1 \/ 1 < x) by lia; clear H; destruct_head' or; subst
         | _ => lia
         | _ => simpl; lia
         | _ => rewrite Z.log2_up_eqn by assumption
         | _ => progress change (Z.log2_up 1) with 0
         end.
Qed.

Lemma land_stabilizes (a b la lb:Z) (Ha:stabilizes_after a la) (Hb:stabilizes_after b lb) : stabilizes_after (Z.land a b) (Z.max la lb).
Proof.
  destruct Ha as [ba Hba]. destruct Hb as [bb Hbb].
  exists (andb ba bb); intros n Hn.
  rewrite Z.land_spec, Hba, Hbb; trivial; lia.
Qed.

Lemma lor_stabilizes (a b la lb:Z) (Ha:stabilizes_after a la) (Hb:stabilizes_after b lb) : stabilizes_after (Z.lor a b) (Z.max la lb).
Proof.
  destruct Ha as [ba Hba]. destruct Hb as [bb Hbb].
  exists (orb ba bb); intros n Hn.
  rewrite Z.lor_spec, Hba, Hbb; trivial; lia.
Qed.

Local Arguments Z.pow !_ !_.
Local Arguments Z.log2_up !_.
Local Arguments Z.add !_ !_.
Lemma testbit_nonneg_iff x
  : (exists l, 0 <= l /\ forall n : Z, l < n -> Z.testbit x n = false) <-> 0 <= x.
Proof.
  split; intro H.
  { destruct H as [l [Hl H]].
    edestruct Z_lt_le_dec; [ | eassumption ].
    pose proof (fun pf n => Z.bits_above_log2_neg x n pf) as H'.
    specialize_by (lia || assumption).
    specialize (H (1 + Z.max l (Z.log2 (Z.pred (- x))))).
    specialize (H' (1 + Z.max l (Z.log2 (Z.pred (- x))))).
    specialize_by (apply Z.max_case_strong; lia).
    congruence. }
  { pose proof (fun n => Z.bits_above_log2 x n H) as Hf.
    eexists; split; [ | eapply Hf ]; auto with zarith. }
Qed.

Lemma stabilizes_bounded_pos (x l:Z) (H:stabilizes_after x l) (Hl : 0 <= l) (Hx : 0 < x)
  : x <= 2^(l + 1) - 1.
Proof.
  assert (Hlt : forall l n, l < n <-> l + 1 <= n) by (intros; lia).
  destruct H as [b H].
  destruct (proj2 (testbit_nonneg_iff x)) as [l' [H0' H1']]; [ lia | ].
  pose proof (Z.testbit_false_bound x (l' + 1)) as Hf.
  pose proof (Z.testbit_false_bound x (l + 1)) as Hf'.
  pose proof (fun pf n => Z.bits_above_log2 x n pf) as Hf''.
  pose proof (fun pf n => Z.log2_lt_pow2 x n pf) as Hlg.
  specialize_by lia.
  setoid_rewrite <- Z.le_ngt in Hf.
  setoid_rewrite <- Z.le_ngt in Hf'.
  setoid_rewrite <- Hlt in Hf; setoid_rewrite <- Hlt in Hf'; clear Hlt.
  setoid_rewrite <- Hlg in Hf''; clear Hlg.
  destruct b; specialize_by (lia || assumption); [ | lia ].
  specialize (H (1 + Z.max l l')).
  specialize (H1' (1 + Z.max l l')).
  specialize_by (apply Z.max_case_strong; lia).
  congruence.
Qed.

Lemma stabilizes_bounded (x l:Z) (H:stabilizes_after x l) (Hl : 0 <= l) : Z.abs x <= 2^(1 + l).
Proof.
  assert (Hlt : forall l n, l < n <-> l + 1 <= n) by (intros; lia).
  rewrite Z.add_comm.
  destruct (Z_zerop x); subst; simpl.
  { cut (0 < 2^(l + 1)); auto with zarith. }
  apply Zabs_ind; intro.
  { etransitivity; [ apply stabilizes_bounded_pos; eauto | ]; lia. }
  { Z.replace_all_neg_with_pos.
    destruct (Z.eq_dec x 1); subst.
    { assert (1 < 2^(l+1)) by auto with zarith.
      lia. }
    { assert (H' : stabilizes_after (Z.pred x) l).
      { destruct H as [b H]; exists (negb b).
        do 2 let x := fresh in intro x; specialize (H x).
        rewrite Z.bits_opp in H by lia.
        destruct b; rewrite ?Bool.negb_true_iff, ?Bool.negb_false_iff in H; assumption. }
      clear H.
      apply stabilizes_bounded_pos in H'; auto; lia. } }
Qed.


(**************************************
  not Finish reading, not Finish exercise
**************************************)

Require Import Coq.Init.Nat.
Require Import Coq.Lists.List.

(* ================================================================= *)
(** * The apply Tactic *)

(* This is proved in chapter Lists. *)
Theorem rev_involutive: forall l: list nat, rev (rev l) = l.
Proof. Admitted.

(** **** Exercise: 2 stars, optional (silly_ex)  *)
Theorem silly_ex:
  (forall n, even n = true -> odd (S n) = true) ->
  even 3 = true ->
  odd 4 = true.
Proof.
  intros H.
  apply H.
Qed.

(** **** Exercise: 3 stars (apply_exercise1)  *)
Theorem rev_exercise1: forall (l l': list nat),
  l = rev l' -> l' = rev l.
Proof.
  intros l l' H.
  rewrite H.
  symmetry.
  apply rev_involutive.
Qed.

(** **** Exercise: 1 star, optional (apply_rewrite)  *)

(**
   apply: change goal by forall rule or non-forall rule.
   rewrite: change goal by non-forall rule.
 **)

(* ================================================================= *)
(** * The apply ... with ... Tactic *)

Theorem trans_eq : forall (X:Type) (n m o : X),
  n = m -> m = o -> n = o.
Proof.
  intros X n m o eq1 eq2. rewrite -> eq1. rewrite -> eq2.
  reflexivity.  Qed.

Definition minustwo (n: nat): nat :=
  match n with
    | O => O
    | S O => O
    | S (S n') => n'
  end.

(** **** Exercise: 3 stars, optional (apply_with_exercise)  *)
Example trans_eq_exercise: forall (n m o p: nat),
   m = (minustwo o) ->
   (n + p) = m ->
   (n + p) = (minustwo o).
Proof.
  intros n m o p P Q.
  rewrite <- P.
  rewrite -> Q.
  reflexivity.
Qed. (* do not know how to use apply with *)

(* ================================================================= *)
(** * The inversion Tactic *)

(** **** Exercise: 1 star (inversion_ex3)  *)
Example inversion_ex3: forall (X: Type) (x y z: X) (l j: list X),
  x :: y :: l = z :: j ->
  y :: l = x :: j ->
  x = y.
Proof.
  intros X x y z l j P Q.
  inversion P.
  inversion Q.
  rewrite H0.
  reflexivity.
Qed.

(** **** Exercise: 1 star (inversion_ex6)  *)
Example inversion_ex6: forall (X: Type) (x y z: X) (l j: list X),
  x :: y :: l = nil ->
  y :: l = z :: j ->
  x = z.
Proof.
  intros X x y z l j P Q.
  inversion P.
Qed.

(* ================================================================= *)
(** * Using Tactics on Hypotheses *)

(** **** Exercise: 3 stars, recommended (plus_n_n_injective)  *)
Theorem plus_n_n_injective: forall n m, n + n = m + m -> n = m.
Proof.
  intros n m P.
  induction n.
  - simpl in P.
    destruct m.
    + reflexivity.
    + inversion P.
  - induction m.
    + simpl in P.
      inversion P.
    + simpl in P.
      inversion P.
      rewrite <- plus_n_Sm in H0.
      rewrite <- plus_n_Sm in H0.
      inversion H0.
      rewrite -> H1 in IHn.
Abort. (* TODO *)

(* ================================================================= *)
(** * Varying the Induction Hypothesis *)

(* ================================================================= *)
(** * Using destruct on Compound Expressions *)

(** **** Exercise: 3 stars, optional (combine_split)  *)
Theorem combine_split: forall X Y (l: list (X * Y)) l1 l2,
  split l = (l1, l2) -> combine l1 l2 = l.
Proof.
  induction l as [|(x, y) l'].
  + intros l1 l2 h1.
    simpl in h1.
    inversion h1.
    reflexivity.
  + simpl.
    destruct (split l') as [xs ys].
    intros l1 l2 h1.
    inversion h1.
    simpl.
    rewrite IHl'.
    - reflexivity.
    - reflexivity.
Qed.

(** **** Exercise: 2 stars (destruct_eqn_practice)  *)
Theorem bool_fn_applied_thrice:
  forall (f: bool -> bool)(b: bool),
  f (f (f b)) = f b.
Proof.
  intros f b.
  destruct b.
  - destruct (f true) eqn:H.
    + rewrite H.
      rewrite H.
      reflexivity.
    + destruct (f false) eqn:H1.
      * apply H.
      * apply H1.
  - destruct (f true) eqn:H.
    + destruct (f false) eqn:H1.
      * rewrite H.
        rewrite H.
        reflexivity.
      * rewrite H1.
        rewrite H1.
        reflexivity.
    + destruct (f false) eqn:H1.
      * rewrite H.
        rewrite H1.
        reflexivity.
      * rewrite H1.
        rewrite H1.
        reflexivity.
Qed.


Require Export Composition.

Definition Transitive R S :=
    forall x y z, x ∈ S -> y ∈ S -> z ∈ S ->
    <|x,y|> ∈ R -> <|y,z|> ∈ R -> <|x,z|> ∈ R.

Definition Symmetric R S :=
  forall x y, x ∈ S -> y ∈ S ->
  <|x,y|> ∈  R -> <|y,x|> ∈ R.

Definition Antisymmetric R S :=
  forall x y, x ∈ S -> y ∈ S ->
  <|x,y|> ∈ R -> <|y,x|> ∈ R -> x = y.

Definition Asymmetric R S :=
  forall x y, x ∈ S -> y ∈ S ->
  <|x,y|> ∈ R -> ~ <|y,x|> ∈ R.

Definition Nonsymmetric R S :=
  ~ Symmetric R S /\ ~ Antisymmetric R S.

Definition Connected R S :=
  forall x y, x ∈ S -> y ∈ S -> <|x,y|> ∈ R \/ <|y,x|> ∈ R.

Definition Reflexive R S :=
  forall x, x ∈ S -> <|x,x|> ∈ R.

Definition Irreflexive R S :=
  forall x, x ∈ S -> ~ <|x,x|> ∈ R.

Definition Nonreflexive R S :=
  exists x y, x ∈ S /\ y ∈ S /\ <|x,x|> ∈ R /\ ~ <|y,y|> ∈ R.

Theorem asym_irr R S :
    Asymmetric R S -> Irreflexive R S.
Proof.
  intros H x xS xxR.
  specialize (H x x xS xS xxR).
  case (H xxR).
Qed.

Theorem transirr_asym R S :
  Transitive R S -> Irreflexive R S -> Asymmetric R S.
Proof.
  intros trans irr x y xS yS xyR yxR.
  specialize (trans x y x xS yS xS xyR yxR).
  specialize (irr x xS).
  case (irr trans).
Qed.

Definition Tiering R S :=
  Transitive R S /\ Nonsymmetric R S.

Definition Preordering R S :=
    Transitive R S /\ Reflexive R S.


Set Warnings "-notation-overidden,-parsing".

Definition relation (X : Type) := X -> X -> Prop.

Print le.

Check le : nat -> nat -> Prop.
Check le : relation nat.

Definition partial_function {X : Type} (R : relation X) :=
 forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

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

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

Definition transitive {X : Type} (R : relation X) :=
 forall a b c : X, R a b -> R b c -> R a c.

Definition symmetric {X : Type} (R : relation X) :=
 forall a b : X, R a b -> R b a -> R a b.

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


Require Import Coq.Logic.Decidable.

(**
   This follows Chapter 14 (Least Number Search) of
   #Geert Smolka's Introduction to Computational Logic#

   The goal is to prove, for any decidable property [P : nat -> Prop], that [(exists n, P n) -> { n : nat | P n }].

 *)

Section LNS.
  Require Import PeanoNat.

  Variable P : nat -> Prop.
  Variable Pdec : forall n, {P n} + { ~ (P n)}.

  Inductive safe (n : nat) : Prop :=
  | safeI : P n -> safe n
  | safeS : safe (S n) -> safe n.

  Definition low (n : nat) :=
    forall k, k <= n -> P k -> k = n.

  Definition min (n : nat) :=
    P n /\ low n.

  Lemma low_S : forall n, low n -> ~(P n) -> low (S n).
  Proof.
    unfold low. intros.
    destruct (proj1 (Nat.le_succ_r _ _) H1).
    (* k <= n *)
    specialize (H k H3 H2). subst.
    destruct (H0 H2).
    (* k = S n *)
    apply H3.
  Qed.

  Fixpoint firstc' (n : nat) (l : low n) (s : safe n) : { m | min m}.
  Proof.
    destruct (Pdec n).
    exact (exist _ n (conj p l)).
    apply firstc' with (n:= S n).
    destruct s.
    destruct (n0 H).
    apply low_S ; assumption.
    destruct s.
    destruct (n0 H).
    assumption.
  Qed.

  Lemma safe_O : forall n, safe n -> safe O.
  Proof.
    induction n. tauto. intro. apply IHn, safeS, H.
  Defined.

  Lemma exists_safe_O : ex P -> safe O.
  Proof.
    intros [n A]. apply (safe_O n). apply (safeI _ A).
  Qed.

  Proposition least_witness : (exists n, P n) -> { n : nat | min n}.
  Proof.
    intro.
    apply (firstc' O).
    unfold low. intros. inversion H0. reflexivity.
    apply (exists_safe_O H).
  Qed.

  Proposition some_witness : (exists n, P n) -> { n : nat | P n }.
  Proof.
    intro.
    apply least_witness in H.
    unfold min in H.
    apply (exist P (proj1_sig H)).
    apply (proj2_sig H).
  Defined.
End LNS.

Section LNS_Pi2.
  Variable P : nat -> nat -> Prop.
  Variable Pdec : forall n m, {P n m} + { ~ (P n m) }.

  Definition search (W : forall n, exists m, P n m) (n : nat) : { m : nat | min (P n) m }.
  Proof.
    apply (least_witness (P n) (Pdec n) (W n)).
  Qed.

End LNS_Pi2.


Require Import Frap.

Lemma add_comm :
  forall a b,
    a + b = b + a.
Proof.
Show Proof.
  induct a.
Show Proof.
Print nat_ind.
  + simplify.
Show Proof. (* Notice simplify doesn't actually "do" anything to the proof term *)

(* TIP 1: Try to avoid nested induction *)
(* Instead: try searching through all the theorems to find something of a certain shape *)
Search (_ = _ + 0).  (* this found a plus_n_0 theorem *)
  apply plus_n_O.
Show Proof.
  + simplify.
Show Proof.
  rewrite IHa. (* plug relevant vars into Inductive Hypothesis *)
Show Proof.
(* The current goal "S (b + a) = b + S a" would require induction on second arg *)
(* Instead try search again *)
Search (_ + S _ = S (_ + _)).  (* and find Nat.add_succ_r *)
  symmetry.
Show Proof.
  apply Nat.add_succ_r.
Show Proof. (* Now there are no ?Goals, and we're done *)
Qed.

(*  TIP 2: Use "debug auto." to see what "auto." is doing !  *)


Require Import Relation_Definitions  Morphisms.
Require Import Setoid.
Require Import Arith.
Require Import Pnat.
Require Import MyZ.

Class Group:=
{
	T:Set;
	eq:T->T->Prop;
	e:T;
	inv:T->T;
	op:T->T->T;
	incl:T->Prop;
	equiv: Equivalence eq;
	equiv_dec:forall x y:T,{eq x y}+{~eq x y};
	closed_op:forall x y:T,incl x->incl y->incl(op x y);
closed_inv:forall x:T,incl x->incl (inv x);
incl_dec:forall x:T,{incl x}+{~incl x};
	well_inv:forall x y:T,eq x y->eq(inv x)(inv y);
	well_op:
	forall x1 y1 x2 y2:T,eq x1 y1->eq x2 y2->
	eq(op x1 x2)(op y1 y2);
well_incl:forall x1 x2:T,eq x1 x2->incl x1->incl x2;
	assoc:forall x y z:T,eq (op(op x y)z)(op x (op y z));
	e_r:forall x:T,eq(op x e)x;
	e_l:forall x:T,eq(op e x)x;
	inv_r:forall x:T,eq (op x(inv x))e;
	inv_l:forall x:T,eq(op (inv x)x)e
}.

Add Parametric Relation (G:Group): T eq
 reflexivity proved by (@Equivalence_Reflexive T  _ equiv)
 symmetry proved by (@Equivalence_Symmetric T _ equiv)
 transitivity proved by (@Equivalence_Transitive T _ equiv)
 as Group_equiv_x.

Add Parametric Morphism
(G:Group):
inv with signature (eq==>eq)as well_inv_x.
apply well_inv.
Qed.
Add Parametric Morphism
(G:Group):
op with signature(eq==>eq==>eq)as well_op_x.
intros x y H x0 y0.
apply well_op.
exact H.
Qed.
Add Parametric Morphism
(G:Group):
incl with signature (eq==>iff)as well_incl_x.
intros.
split.
apply well_incl.
exact H.
apply well_incl.
symmetry.
exact H.
Qed.

Theorem right_law
(g:Group)
:forall a b c:T,eq (op a c)(op b c)->eq a b.
intros.
assert (eq (op (op a c)(inv c))(op(op b c)(inv c))).
rewrite H.
reflexivity.
rewrite assoc in H0.
rewrite (assoc b c)in H0.
rewrite inv_r in H0.
rewrite e_r in H0.
rewrite e_r in H0.
exact H0.
Qed.
Theorem left_law
(g:Group)
:forall a b c:T,eq (op c a)(op c b)->eq a b.
intros.
assert (eq(op(inv c)(op c a))(op(inv c)(op c b))).
rewrite H.
reflexivity.
rewrite <-assoc in H0.
rewrite <-(assoc (inv c) c)in H0.
rewrite inv_l in H0.
rewrite e_l in H0.
rewrite e_l in H0.
exact H0.
Qed.
Theorem inv_inv(G:Group)
:forall x:T,eq (inv (inv x))x.
intros.
apply left_law  with (c:=inv x).
rewrite inv_l.
apply inv_r.
Qed.
Theorem inv_op(G:Group)
:forall x y:T,
eq(inv(op x y))(op(inv y)(inv x)).
intros.
apply right_law with (c:=(op x y)).
rewrite inv_l.
rewrite assoc.
rewrite <-(assoc(inv x)).
rewrite inv_l.
rewrite e_l.
rewrite inv_l.
reflexivity.
Qed.

Theorem inv_e(G:Group):eq(inv e)e.
apply right_law with (c:=e).
rewrite e_l.
apply inv_l.
Qed.

Program Definition TrivialGroup:Group
:=
{|
T:=unit
;eq:=(fun a b=>True)
;e:=tt
;inv:=(fun _=>tt)
;op:=(fun _ _=>tt)
;incl:=(fun _=>True)
|}.
Obligation 1.
split.
auto.
auto.
auto.
Qed.
Obligation 2.
left.
exact I.
Qed.
Obligation 5.
left.
exact I.
Qed.

Program Definition ZGroup:Group
:=
{|
T:=myZ
;eq:=myZeq
;e:=myZzero
;inv:=myZopp
;op:=myZplus
;incl:=(fun _=>True)
;equiv:=zequiv
;well_inv:=well_myZopp
;well_op:=well_myZplus
;assoc:=myZplus_assoc
;e_r:=(fun x=>(myZplus_zero_r x))
;e_l:=(fun x=>(myZplus_zero_l x))
;inv_r:=(fun x=>(myZplus_myZopp_r x))
;inv_l:=(fun x=>(myZplus_myZopp_l x))
 |}.
Obligation 1 of ZGroup.
apply myZeq_dec.
Qed.
Obligation 4.
auto.
Qed.

Class SubGroup:Type:=
{
G:Group
;sub:T->Prop
;sub_then_incl:forall a:T,sub a->incl a
;well_sub:forall x1 x2:T,eq x1 x2->sub x1->sub x2
;op_inv_a_b:forall a b:T,sub a->sub b->sub (op (inv a)b)
;sub_e:sub e
;sub_dec:forall x:T,{sub x}+{~sub x}
}.
Add Parametric Morphism
(sg:SubGroup):
sub with signature (eq==>iff) as well_sub_x.
intros.
split.
exact (well_sub x y H).
apply (well_sub y x).
info symmetry.
exact H.
Qed.

Program Definition AsGroup(sg:SubGroup):Group:=
{|
T:=(@T G)
;incl:=sub
;eq:=eq
;e:=(@e G)
;inv:=(@inv G)
;op:=(@op G)
;equiv_dec:=(@equiv_dec (@G sg))
;incl_dec:=sub_dec
;assoc:=assoc
;e_r:=e_r
;e_l:=e_l
;inv_r:=inv_r
;inv_l:=inv_l
|}.
Obligation 1.
cut (eq x (inv(inv x))).
intro.
apply (well_sub (op(inv(inv x))y)).
rewrite <-H1.
reflexivity.
apply op_inv_a_b.
assert (sub(op (inv x)e)).
apply (op_inv_a_b x e).
exact H.
exact sub_e.
apply (well_sub  (op(inv x)e)) .
rewrite e_r.
reflexivity.
exact H2.
exact H0.
symmetry.
apply inv_inv.
Qed.
Obligation 2.
apply well_sub with (x1:=(op (inv x)e)).
apply e_r.
apply op_inv_a_b.
exact H.
exact sub_e.
Qed.
Obligation 3.
Admitted.
Obligation 4.
rewrite H.
rewrite H0.
reflexivity.
Qed.
Obligation 5.
apply (well_sub x1 x2).
exact H.
exact H0.
Qed.

Definition Normal
(sg:SubGroup):Prop
:=forall a b:T,sub (op(inv a) b)->sub(op b(inv a)).

Theorem Normal2
(sg:SubGroup)
:Normal sg
->forall a g:T,
sub a->sub (op (op (inv g)a)g).
unfold Normal.
intros.
generalize (H (inv(op a g)) (inv g)).
intros.
rewrite inv_inv in H1.
rewrite assoc in H1.
rewrite inv_r in H1.
rewrite e_r in H1.
rewrite <-assoc in H1.
apply (H1 H0).
Qed.

Class QuotientGroup:Type:=
{
sg:SubGroup
;normal_sg:Normal sg
}.
Program Definition AsQGroup(qg:QuotientGroup)
:Group:=
{|T:=(@T G)
;incl:=(@incl (@G sg))
;eq:=fun a b=>sub (op (inv a)b)
;inv:=(@inv (@G (@sg qg)))
;op:=op
;e:=e
;incl_dec:=_
|}.

Obligation 1.
split.
unfold Reflexive.
intros.
rewrite inv_l.
apply sub_e.
unfold Symmetric.
intros.
assert (sub(inv(op(inv y)x))).
rewrite inv_op.
rewrite inv_inv.
exact H.
rewrite <-(inv_inv _ (op(inv y)x)).
rewrite <-e_r.
apply op_inv_a_b.
exact H0.
exact sub_e.
unfold Transitive.
intros.

assert (sub (op(op(inv x)y)(op(inv y)z))).
apply (@closed_op (AsGroup sg) (op(inv x) y)).
exact H.
exact H0.
rewrite assoc in H1.
rewrite <-(assoc y (inv y)) in H1.
rewrite inv_r in H1.
rewrite e_l in H1.
exact H1.
Qed.
Obligation 2.
exact (sub_dec (op(inv x)y)).
Qed.
Obligation 3.
apply (closed_op x y H H0).
Qed.
Obligation 4.
apply closed_inv.
exact H.
Qed.
Obligation 5.
apply incl_dec.
Qed.
Obligation 6.
apply normal_sg.
rewrite <-inv_op.
destruct qg.
destruct sg0.
apply (@closed_inv (AsGroup sg) (op (inv x)y))  .

apply H.
Qed.

Obligation 7.
assert (sub (op(op (inv x2)(op(inv x1)y1))(op x2(op(inv x2)y2)))).
rewrite <-assoc.
generalize normal_sg.
intro.
assert (sub (op(op(inv x2)(op(inv x1)y1))x2)).
apply Normal2.
exact H1.
apply H.

apply (@closed_op (AsGroup sg) _ (op(inv x2)y2)).
exact H2.
exact H0.

rewrite inv_op.
rewrite <-(assoc x2)in H1.
rewrite inv_r in H1.
rewrite e_l in H1.
rewrite <-assoc.
rewrite (assoc _ _ y1).
exact H1.
Qed.
Obligation 8.
apply sub_then_incl in H.
assert (incl (op x1(op(inv x1)x2))).
apply (closed_op _ _ H0 H).
rewrite <-assoc in H1.
rewrite inv_r in H1.
rewrite e_l in H1.
exact H1.
Qed.

Obligation 9.
rewrite inv_op.
rewrite inv_op.
rewrite assoc.
rewrite assoc.
rewrite <-(assoc (inv x)x).
rewrite inv_l.
rewrite e_l.
rewrite <-(assoc(inv y)).
rewrite inv_l.
rewrite e_l.
rewrite inv_l.
apply sub_e.
Qed.
Obligation 10.
rewrite e_r.
rewrite inv_l.
apply sub_e.
Qed.

Obligation 11.
rewrite e_l.
rewrite inv_l.
exact sub_e.
Qed.
Obligation 12.
rewrite inv_r.
rewrite inv_l.
exact sub_e.
Qed.
Obligation 13.
rewrite inv_l.
rewrite inv_l.
exact sub_e.
Qed.

Program Definition nMyZ(n:nat):SubGroup
:=
{|
G:=ZGroup
;sub:=fun k:myZ=>(exists m:myZ,k==(myZpos n)*m)
;sub_then_incl:=_
;well_sub:=_
;op_inv_a_b:=_
;sub_e:=_
;sub_dec:=_
|}.
Obligation 2.
destruct x1,x2,H0.
rewrite H in H1.
exists (myZmake n4 n5).
apply H1.
Qed.

Obligation 3.
exists ((myZopp H)+H0).
rewrite H1.
rewrite H2.
change (myZopp
  ((myZpos n)*H)+
  ((myZpos n)*H0)
==((myZpos n)*(myZopp H + H0))).
rewrite <-myZmul_myZopp_compat_r.
symmetry.
apply myZmul_myZplus_distr_l.
Qed.
Obligation 4.
change(exists m : myZ,
myZzero==(myZpos n)*m
).
exists myZzero.
simpl.
ring.
Qed.
Obligation 5.
change({(exists m : myZ,x ==(myZpos n)*m)} +
{~(exists m : myZ,x ==(myZpos n)*m)}).
apply myZdivisible_dec.


Require Export low_mods.
Require Import Num_Occ Indicies.

Fixpoint num_occ_l (l : list predicate) (P : predicate) : nat :=
  match l with
  | nil => 0
  | cons Q l' => if predicate_dec P Q then 1 + num_occ_l l' P
                                   else num_occ_l l' P
  end.

Lemma num_occ_l_app : forall (l1 l2 : list predicate) (P : predicate),
  num_occ_l (app l1 l2) P = num_occ_l l1 P + num_occ_l l2 P.
Proof.
  induction l1.  intros. reflexivity.
  intros l2 P. simpl. rewrite IHl1.
  destruct (predicate_dec P a); lia.
Qed.

Lemma leb_num_occ : forall (alpha : SecOrder) (P : predicate),
  (num_occ_l (preds_in alpha) P) <= (length (preds_in alpha)).
Proof.
  intros alpha P.
  induction alpha; simpl; auto;
  try (destruct (predicate_dec P p); auto);
  try (  rewrite num_occ_l_app; rewrite app_length; lia);
  lia.
Qed.

Lemma leb_id_fwd_plus : forall (alpha1 alpha2: SecOrder) (P : predicate)
                                    (n: nat),
   n <=
      (length (preds_in alpha1) - num_occ_l (preds_in alpha1) P) ->
   n <=
      (length (preds_in alpha1) + length (preds_in alpha2) -
        (num_occ_l (preds_in alpha1) P +
           num_occ_l (preds_in alpha2) P)).
Proof.
  intros alpha1 alpha2 P n Hleb.
  pose proof (leb_num_occ alpha2 P). firstorder.
Qed.

Lemma num_occ_l_ind_l_rev : forall l P,
  num_occ_l l P = length (indicies_l_rev l P).
Proof.
  induction l; intros P. auto.
  simpl in *. dest_pred_dec a P. simpl.
  firstorder.
Qed.

Lemma num_occ__l : forall (alpha : SecOrder) (P : predicate),
  (num_occ_l (preds_in alpha) P) = (num_occ alpha P).
Proof.
  intros. unfold num_occ.
  unfold indicies. rewrite map_length.
  apply num_occ_l_ind_l_rev.
Qed.


(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

Require Import Exponentiation.

(* Why3 goal *)
Notation power := Zpower.

Lemma power_is_exponentiation :
  forall x n, (0 <= n)%Z -> power x n = Exponentiation.power _ 1%Z Zmult x n.
Proof.
intros x [|n|n] H.
easy.
2: now elim H.
unfold Exponentiation.power, power, Zpower_pos.
now rewrite iter_nat_of_P.
Qed.

(* Why3 goal *)
Lemma Power_0 : forall (x:Z), ((power x 0%Z) = 1%Z).
Proof.
intros x.
apply refl_equal.
Qed.

(* Why3 goal *)
Lemma Power_s : forall (x:Z) (n:Z), (0%Z <= n)%Z -> ((power x
  (n + 1%Z)%Z) = (x * (power x n))%Z).
Proof.
intros x n h1.
rewrite Zpower_exp.
change (power x 1) with (x * 1)%Z.
ring.
now apply Zle_ge.
easy.
Qed.

(* Why3 goal *)
Lemma Power_s_alt : forall (x:Z) (n:Z), (0%Z < n)%Z -> ((power x
  n) = (x * (power x (n - 1%Z)%Z))%Z).
intros x n h1.
rewrite <- Power_s.
f_equal; auto with zarith.
omega.
Qed.

(* Why3 goal *)
Lemma Power_1 : forall (x:Z), ((power x 1%Z) = x).
Proof.
exact Zmult_1_r.
Qed.

(* Why3 goal *)
Lemma Power_sum : forall (x:Z) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((power x (n + m)%Z) = ((power x n) * (power x m))%Z)).
Proof.
intros x n m Hn Hm.
now apply Zpower_exp; apply Zle_ge.
Qed.

(* Why3 goal *)
Lemma Power_mult : forall (x:Z) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((power x (n * m)%Z) = (power (power x n) m))).
Proof.
intros x n m Hn Hm.
rewrite 3!power_is_exponentiation ; auto with zarith.
apply Power_mult ; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Power_mult2 : forall (x:Z) (y:Z) (n:Z), (0%Z <= n)%Z ->
  ((power (x * y)%Z n) = ((power x n) * (power y n))%Z).
Proof.
intros x y n Hn.
rewrite 3!power_is_exponentiation ; auto with zarith.
apply Power_mult2 ; auto with zarith.
Qed.

(* Why3 goal *)
Lemma Power_non_neg : forall (x:Z) (y:Z), ((0%Z <= x)%Z /\ (0%Z <= y)%Z) ->
  (0%Z <= (power x y))%Z.
intros x y (h1,h2).
now apply Z.pow_nonneg.
Qed.

Open Scope Z_scope.

(* Why3 goal *)
Lemma Power_monotonic : forall (x:Z) (n:Z) (m:Z), ((0%Z < x)%Z /\
  ((0%Z <= n)%Z /\ (n <= m)%Z)) -> ((power x n) <= (power x m))%Z.
intros.
apply Z.pow_le_mono_r; auto with zarith.
Qed.


(** * Definition of terms of Riesz spaces *)
Require Import Reals.

(** ** Term *)
Require Import RL.OLlibs.List_more.

Inductive Rterm : Type :=
| R_var : nat -> Rterm
| R_zero : Rterm
| R_plus : Rterm -> Rterm -> Rterm
| R_mul : R -> Rterm -> Rterm
| R_max : Rterm -> Rterm -> Rterm
| R_min : Rterm -> Rterm -> Rterm.

(** Notations *)

Notation "A +R B" := (R_plus A B) (at level 20, left associativity).
Notation "A \/R B" := (R_max A B) (at level 40, left associativity).
Notation "A /\R B" := (R_min A B) (at level 45, left associativity).
Notation "-R A" := (R_mul (-1) A) (at level 15).
Notation "A -R B" := (R_plus A (-R B)) (at level 10, left associativity).
Notation "r *R A" := (R_mul r A) (at level 15).

Fixpoint R_sum_term k A :=
  match k with
  | 0 => R_zero
  | 1 => A
  | S n => A +R (R_sum_term n A)
  end.

(** Substitution *)
Fixpoint Rsubs (t1 : Rterm) (x : nat) (t2 : Rterm) : Rterm :=
  match t1 with
  | R_var y => if (beq_nat x y) then t2 else R_var y
  | R_zero => R_zero
  | R_plus t t' => R_plus (Rsubs t x t2) (Rsubs t' x t2)
  | R_min t t' => R_min (Rsubs t x t2) (Rsubs t' x t2)
  | R_max t t' => R_max (Rsubs t x t2) (Rsubs t' x t2)
  | R_mul y t => R_mul y (Rsubs t x t2)
  end.

(** Definition of positive part, negative part and absolute value *)
Notation "'R_pos' A" := (A \/R R_zero) (at level 5).
Notation "'R_neg' A" := ((-R A) \/R R_zero) (at level 5).
Notation "'R_abs' A" := (A \/R (-R A)) (at level 5).


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith List Omega Wellfounded.

Require Import php measure_ind wf_chains.

Set Implicit Arguments.

(** Results about the well-foundedness of strict (reverse)
    inclusion between lists

    These proofs avoid the need of decidable equality
    and use the finitary Pigeon Hole Principle (PHP)
    instead
*)

Section sincl.

  (** Strict inclusion between lists is a well founded relation *)

  Variable (X : Type).

  Implicit Type (l m : list X).

  (* sincl l m if incl l m and there is a witness in m \ l *)

  Definition sincl l m := incl l m /\ exists x, ~ In x l /\ In x m.

  (* Any n-chain m ~~> l contains a
     duplication-free subset of l of size n
     which does not intersect m  *)

  Lemma sincl_chain n m l :
       chain sincl n m l -> incl m l
                         /\ exists ll, ~ list_has_dup ll
                                      /\ length ll = n
                                      /\ incl ll l
                                      /\ forall x, In x m -> In x ll -> False.
  Proof.
    induction 1 as [ m | n m l k H1 H2 (H7 & ll & H3 & H4 & H5 & H6) ].
    + split.
      * intros ?; auto.
      * exists nil; simpl; repeat split; auto.
        - inversion 1.
        - intros _ [].
    + split.
      * intros ? ?; apply H7, H1; auto.
      * destruct H1 as (G1 & x & G2 & G3).
        exists (x::ll); simpl; repeat split; auto.
        - contradict H3.
          apply list_has_dup_cons_inv in H3.
          destruct H3 as [ H3 | ]; auto.
          destruct (H6 x); auto.
        - apply incl_cons; auto.
        - intros y F1 [ F2 | F2 ]; subst.
          ** tauto.
          ** apply (H6 y); auto.
  Qed.

  (* Hence, by the PHP, if there is a n-chain to l then n must be less than length l *)

  Corollary sincl_chain_bounded l m n : chain sincl n m l -> n <= length l.
  Proof.
    intros H.
    apply sincl_chain in H.
    destruct H as (_ & ll & H1 & H2 & H3 & _).
    destruct (le_lt_dec n (length l)) as [ | C ]; auto.
    subst; destruct H1.
    apply finite_pigeon_hole with l; auto.
  Qed.

  (* Hence sincl is well-founded because n-chains to l have length bounded by length l *)

  Theorem wf_sincl : well_founded sincl.
  Proof.
    apply wf_chains.
    intros l; exists (length l).
    intros ? ?; apply sincl_chain_bounded.
  Qed.

End sincl.

Arguments wf_sincl {X}.

Section rincl_fin.

  (** Strict reverse inclusion between lists is well founded over a finite domain *)

  (* M the upper-bound/finiteness of the domain *)

  Variable (X : Type) (M : list X).

  (* l cap M strictly contains in m cap M *)

  Definition rincl_fin l m := (forall x, In x m -> In x M -> In x l)
                            /\ exists x, ~ In x m /\ In x l /\ In x M.

  (* Any n-chain m ~~> l contains a duplication-free subset of M of size n *)

  Lemma rincl_fin_chains n m l :   chain rincl_fin n m l
                   -> exists ll, ~ list_has_dup ll
                                /\ incl ll M
                                /\ length ll = n
                                /\ incl ll m.
  Proof.
    induction 1 as [ x | n m k l H1 H2 (ll & H3 & H4 & H5 & H6) ].
    + exists nil.
      repeat split; simpl; auto; inversion 1.
    + destruct H1 as (H1 & a & G1 & G2 & G3).
      exists (a::ll).
      repeat split.
      * contradict H3.
        apply list_has_dup_cons_inv in H3.
        destruct H3 as [ H3 | ]; auto.
        destruct G1; apply H6; auto.
      * apply incl_cons; auto.
      * simpl; f_equal; auto.
      * apply incl_cons; auto.
        intros ? ?; auto.
  Qed.

  (* Hence, by the PHP, if there is a n-chain to l then n is less than length M *)

  Corollary rincl_fin_chain_bounded l m n : chain rincl_fin n m l -> n <= length M.
  Proof.
    intros H.
    apply rincl_fin_chains in H.
    destruct H as (ll & H1 & H2 & H3 & _).
    destruct (le_lt_dec n (length M)) as [ | C ]; auto.
    subst n; destruct H1.
    apply finite_pigeon_hole with M; auto.
  Qed.

  Theorem wf_rincl_fin : well_founded rincl_fin.
  Proof.
    apply wf_chains.
    intros l; exists (length M).
    intros ? ?; apply rincl_fin_chain_bounded.
  Qed.

End rincl_fin.

Arguments wf_rincl_fin {X}.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  mult lf1 x.


Require Import Nat Arith.

Inductive Nat : Type := succ : Nat -> Nat |  zero : Nat.

Inductive Lst : Type := cons : Nat -> Lst -> Lst |  nil : Lst.

Inductive Tree : Type := node : Nat -> Tree -> Tree -> Tree |  leaf : Tree.

Inductive Pair : Type := mkpair : Nat -> Nat -> Pair
with ZLst : Type := zcons : Pair -> ZLst -> ZLst |  znil : ZLst.

Fixpoint plus (plus_arg0 : Nat) (plus_arg1 : Nat) : Nat
           := match plus_arg0, plus_arg1 with
              | zero, n => n
              | succ n, m => succ (plus n m)
              end.

Fixpoint append (append_arg0 : Lst) (append_arg1 : Lst) : Lst
           := match append_arg0, append_arg1 with
              | nil, x => x
              | cons x y, z => cons x (append y z)
              end.

Fixpoint len (len_arg0 : Lst) : Nat
           := match len_arg0 with
              | nil => zero
              | cons x y => succ (len y)
              end.

Fixpoint rev (rev_arg0 : Lst) : Lst
           := match rev_arg0 with
              | nil => nil
              | cons x y => append (rev y) (cons x nil)
              end.

Fixpoint qreva (qreva_arg0 : Lst) (qreva_arg1 : Lst) : Lst
           := match qreva_arg0, qreva_arg1 with
              | nil, x => x
              | cons z x, y => qreva x (cons z y)
              end.

Theorem plus_comm: forall (n m: Nat), plus n m = plus m n.
Proof.
  induction n; induction m.
  { simpl. rewrite IHn. rewrite <- IHm. simpl. rewrite IHn. reflexivity. }
  { simpl. rewrite IHn. simpl. reflexivity. }
  { simpl. rewrite <- IHm. simpl. reflexivity. }
  { reflexivity. }
Qed.
Theorem theorem0 : forall (x : Lst) (y : Lst), eq (len (qreva x y)) (plus (len x) (len y)).
Proof.
  induction x; induction y; simpl; try reflexivity.
  { rewrite plus_comm. simpl.
    rewrite IHx. simpl. rewrite plus_comm.
    simpl. reflexivity. }
  { rewrite plus_comm. simpl. rewrite IHx. rewrite plus_comm.
    simpl. reflexivity. }
Qed.