(** 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 (z : natural) (lf3 : natural) : natural := plus z lf3.


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

Require Import List Arith Nat Lia Relations Bool.

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

Local Infix "∈" := In (at level 70, no associativity).
Local Infix "⊆" := incl (at level 70, no associativity).
Local Notation "P ≅ Q" := ((P -> Q) * (Q -> P))%type (at level 70, no associativity).

Set Implicit Arguments.

Section finite_t_upto.

  Variable (X : Type) (R : X -> X -> Prop).

  Definition fin_t_upto (P : X -> Type) :=
     { l : _ & (forall x, P x -> exists y, y ∈ l /\ R x y)
              *(forall x y, x ∈ l -> R x y -> P y) }%type.

  Definition finite_t_upto :=
     { l : _ | forall x, exists y, y ∈ l /\ R x y }.

  Fact finite_t_fin_upto : finite_t_upto ≅ fin_t_upto (fun _ => True).
  Proof. split; intros []; red; eauto; firstorder. Qed.

End finite_t_upto.

Arguments finite_t_upto : clear implicits.

Section finite_t_weak_dec_powerset.

  (* We built a list containing all weakly decidable predicates,
      ie the weakly decidable powerset build as from atoms
        x = _ and x <> _

     We do NOT require that X is a discrete type. *)

  Variable (X : Type).

  Let wdec (R : X -> Prop) := forall x, R x \/ ~ R x.

  Let pset_fin_t (l : list X) : { ll |  length ll = 2 ^ (length l)
                                     /\ forall R, wdec R
                                   ->   exists T, T ∈ ll
                                     /\ forall x, x ∈ l -> R x <-> T x }.
  Proof.
    induction l as [ | x l IHl ].
    + exists ((fun _ => True) :: nil); split; auto.
      intros R HR; exists (fun _ => True); simpl; split; tauto.
    + destruct IHl as (ll & Hl & Hll).
      exists (map (fun T a => x<>a /\ T a) ll ++ map (fun T a => x=a \/ T a) ll); split.
      1: rewrite app_length, !map_length; simpl; lia.
      intros R HR.
      destruct (Hll R) as (T & H1 & H2); auto.
      destruct (HR x) as [ H0 | H0 ].
      * exists (fun a => x = a \/ T a); split.
        - apply in_or_app; right.
          apply in_map_iff; exists T; auto.
        - intros y [ <- | H ]; simpl; try tauto.
          rewrite H2; auto; split; auto.
          intros [ -> | ]; auto.
          apply H2; auto.
      * exists (fun a => x <> a /\ T a); split.
        - apply in_or_app; left.
          apply in_map_iff; exists T; auto.
        - intros y [ <- | H ]; simpl; split; try tauto.
          ++ rewrite <- H2; auto; split; auto.
             contradict H0; subst; auto.
          ++ rewrite <- H2; tauto.
  Qed.

  (* Because = is not supposed decidable (X is not discrete), we
     cannot show that every element in ll below is weakly decidable *)

  Theorem finite_t_weak_dec_powerset (h : finite_t X) :
            { ll |  length ll = 2 ^ (length (proj1_sig h))
                 /\ forall R, wdec R -> exists T, T ∈ ll /\ forall x, R x <-> T x }.
  Proof.
    destruct h as (l & Hl).
    destruct (pset_fin_t l) as (ll & H & Hll).
    exists ll; split; auto.
    intros R HR.
    destruct (Hll _ HR) as (T & H1 & H2).
    exists T; split; auto.
  Qed.

End finite_t_weak_dec_powerset.

(* We show that there is a finite_t bound over weakly (hence also strongly) decidable
    binary relations upto equivalence. Notice that it is not guaranteed that the list l
    below contains only decidable relations *)

Theorem finite_t_weak_dec_rels X :
           finite_t X
        -> { ll | forall R,
                      (forall x y : X, R x y \/ ~ R x y)
                   -> exists T, T ∈ ll /\ forall x y, R x y <-> T x y }.
Proof.
  intros h.
  destruct finite_t_weak_dec_powerset with (h := finite_t_prod h h)
    as (l & _ & Hl).
  exists (map (fun P x y => P (x,y)) l).
  intros R HR.
  destruct (Hl (fun c => R (fst c) (snd c))) as (T & H1 & H2).
  + intros []; apply HR.
  + exists (fun x y => T (x,y)); split.
    * apply in_map_iff; exists T; auto.
    * intros x y; apply (H2 (x,y)).
Qed.


(** * Utheory.v: Specification of $U$, interval $[0,1]$ *)

From ALEA Require Export Misc.
From ALEA Require Export Ccpo.
Set Implicit Arguments.
Open Scope O_scope.

(** ** Basic operators of $U$ *)
(** - Constants : $0$ and $1$
    - Constructor : [Unth] $n (\equiv \frac{1}{n+1})$
    - Operations : $x+y~(\equiv min (x+y,1))$, $x*y$, [inv] $x~(\equiv 1 -x)$
    - Relations : $x\leq y$, $x==y$
*)
Module Type Universe.
Parameter U : cpo.
Declare Scope U_scope.

Parameter U1 : U.
Parameters Uplus Umult Udiv: U -> U -> U.
Parameter Uinv : U -> U.
Parameter Unth : nat -> U.
(*
Definition Uplus x y := UPlus x y.
Definition Umult x y := UMult x y.
*)

Infix "+" := Uplus : U_scope.
Infix "*"  := Umult  : U_scope.
Infix "/"  := Udiv  : U_scope.
Notation "[1-] x" := (Uinv x)  (at level 35, right associativity) : U_scope.
Notation "1" := U1 : U_scope.
Notation "[1/]1+ n" := (Unth n) (at level 35, right associativity) : U_scope.
Open Scope U_scope.

(** ** Basic Properties *)

Parameter Udiff_0_1 : ~0 == 1.

Parameter Unit : forall x:U, x <= 1.

Parameter Uplus_sym : forall x y:U, x + y == y + x.
Parameter Uplus_assoc : forall x y z:U, x + (y + z) == x + y + z.
Parameter Uplus_zero_left : forall x:U, 0 + x == x.

Parameter Umult_sym : forall x y:U, x * y == y * x.
Parameter Umult_assoc : forall x y z:U, x * (y * z) == x * y * z.
Parameter Umult_one_left : forall x:U, 1 * x == x.

Parameter Uinv_one : [1-] 1 == 0.
Parameter Uinv_opp_left : forall x, [1-] x + x == 1.

Parameter Umult_div : forall x y, ~0 == y -> x <= y -> y * (x/y) == x.
Parameter Udiv_le_one : forall x y,  ~0 == y -> y <= x -> (x/y) == 1.
Parameter Udiv_by_zero : forall x y,  0 == y -> (x/y) == 0.

(** - Property  : $1 - (x+y) + x=1-y$ holds when $x+y$ does not overflow *)
Parameter Uinv_plus_left : forall x y, y <= [1-] x -> [1-] (x + y) + x == [1-] y.

(** - Property  : $(x + y) \times z  = x \times z + y \times z$
    holds when $x+y$ does not overflow *)
Parameter Udistr_plus_right : forall x y z (H : x <= [1-] y), (x + y) * z == x * z + y * z.

(** - Property  : $1 - (x \times y) = (1 - x)\times y + (1-y)$ *)
Parameter Udistr_inv_right : forall x y:U,  [1-] (x * y) == ([1-] x) * y + [1-] y.

(** - Totality of the order *)
Parameter Ule_class : forall x y : U, class (x <= y).

Parameter Ule_total : forall x y : U, orc (x<=y) (y<=x).
Arguments Ule_total : clear implicits.

(** - The relation $x\leq y$ is compatible with operators *)

Parameter Uplus_le_compat_right : forall x y z:U, y <= z -> x + y <= x + z.

Parameter Umult_le_compat_right : forall x y z:U, y <= z -> x * y <= x * z.

Parameter Uinv_le_compat : forall x y:U, x <= y -> [1-] y <= [1-] x.

(** - Properties of simplification in case there is no overflow *)
Parameter Uplus_le_simpl_right : forall x y z, z <= [1-] x -> x + z <= y + z -> x <= y.

Parameter Umult_le_simpl_left : forall x y z: U, ~0 == z -> z * x <= z * y -> x <= y .

(** -  Property [Unth] $\frac{1}{n+1} == 1 - n \times \frac{1}{n+1}$ *)
Parameter Unth_prop : forall n, [1/]1+n == [1-](comp Uplus 0 (fun k => [1/]1+n) n).

(** - Archimedian property *)
Parameter archimedian : forall x, ~0 == x -> exc (fun n => [1/]1+n <= x).

(** - Stability properties of lubs with respect to [+] and [*] *)

Parameter Uplus_right_continuous : forall k, continuous (mk_fmono (Uplus_le_compat_right k)).
Parameter Umult_right_continuous : forall k, continuous (mk_fmono (Umult_le_compat_right k)).

End Universe.


(* infotheo: information theory and error-correcting codes in Coq             *)
(* Copyright (C) 2020 infotheo authors, license: LGPL-2.1-or-later            *)
From mathcomp Require Import all_ssreflect ssralg fingroup finalg matrix.
Require Import Reals.
From mathcomp Require Import Rstruct.
Require Import ssrR Reals_ext ssr_ext ssralg_ext logb Rbigop.
Require Import fdist entropy convex ln_facts jensen num_occ.

(******************************************************************************)
(*                         String entropy                                     *)
(*                                                                            *)
(* For details, see: Reynald Affeldt, Jacques Garrigue, and Takafumi Saikawa. *)
(* Examples of formal proofs about data compression. International Symposium  *)
(* on Information Theory and Its Applications (ISITA 2018), Singapore,        *)
(* October 28--31, 2018, pages 633--637. IEEE, Oct 2018                       *)
(*                                                                            *)
(* Main reference:                                                            *)
(*   Gonzalo Navarro. Compact Data Structures: A Practical Approach.          *)
(*   Cambridge University Press, 2016.                                        *)
(******************************************************************************)

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Local Open Scope R_scope.
Local Open Scope num_occ_scope.
Local Open Scope entropy_scope.
Local Coercion INR : nat >-> R.

Definition simplR := (add0R, addR0, subR0, mul0R, mulR0, mul1R, mulR1).

Local Hint Resolve leRR : core.
Local Hint Resolve leR0n : core.

Section seq_nat_fdist.

Variables (A : finType) (f : A -> nat).
Variable total : nat.
Hypothesis sum_f_total : (\sum_(a in A) f a)%nat = total.
Hypothesis total_gt0 : total != O.

Let f_div_total := [ffun a : A => f a / total].

Lemma f_div_total_pos c : 0 <= f_div_total c.
Proof.
rewrite ffunE; apply mulR_ge0 => //.
apply /Rlt_le /invR_gt0 /ltR0n.
by rewrite lt0n.
Qed.

Lemma f_div_total_1 : \sum_(a in A) [ffun a : A => f a / total] a = 1.
Proof.
under eq_bigr do rewrite ffunE /=.
rewrite /f_div_total -big_distrl -big_morph_natRD.
by rewrite sum_f_total /= mulRV // INR_eq0'.
Qed.

Definition seq_nat_fdist := FDist.make f_div_total_pos f_div_total_1.

End seq_nat_fdist.

Section string.

Variable A : finType.

Section entropy.
Variable S : seq A.
Hypothesis S_nonempty : size S != O.

Definition pchar c := N(c|S) / size S.

Definition num_occ_dist := seq_nat_fdist (sum_num_occ_size S) S_nonempty.

Definition Hs0 := `H num_occ_dist.
End entropy.

Section string_concat.

(*
Definition Hs (s : seq A) :=
 \rsum_(a in A)
  if N(a|s) == 0%nat then 0 else
  N(a|s) / size s * log (size s / N(a|s)).
*)

Definition nHs (s : seq A) :=
 \sum_(a in A)
  if N(a|s) == 0%nat then 0 else
  N(a|s) * log (size s / N(a|s)).

Lemma szHs_is_nHs s (H : size s != O) :
  size s * `H (@num_occ_dist s H) = nHs s.
Proof.
rewrite /entropy /nHs /num_occ_dist /= -mulRN1 big_distrl big_distrr /=.
apply eq_bigr => a _ /=; rewrite ffunE.
case: ifPn => [/eqP -> | Hnum]; first by rewrite !mulRA !simplR.
rewrite {1}/Rdiv (mulRC N(a | s)) 3![in LHS]mulRA mulRV ?INR_eq0' // ?mul1R.
rewrite -mulRA mulRN1 -logV; last by apply divR_gt0; rewrite ltR0n lt0n.
rewrite Rinv_Rdiv //; apply/eqP; by rewrite INR_eq0'.
Qed.

Definition mulnRdep (x : nat) (y : x != O -> R) : R.
case/boolP: (x == O) => Hx.
+ exact 0.
+ exact (x * y Hx).
Defined.
Arguments mulnRdep x y : clear implicits.

Lemma mulnRdep_0 y : mulnRdep 0 y = 0.
Proof. rewrite /mulnRdep /=. by destruct boolP. Qed.

Lemma mulnRdep_nz x y (Hx : x != O) : mulnRdep x y = x * y Hx.
Proof.
rewrite /mulnRdep /=.
destruct boolP.
  by elimtype False; rewrite i in Hx.
do 2!f_equal; apply eq_irrelevance.
Qed.

Lemma szHs_is_nHs_full s : mulnRdep (size s) (fun H => Hs0 H) = nHs s.
Proof.
rewrite /mulnRdep; destruct boolP; last by apply szHs_is_nHs.
rewrite /nHs (eq_bigr (fun a => 0)); first by rewrite big1.
move=> a _; suff -> : N(a|s) == O by [].
by rewrite /num_occ -leqn0 -(eqP i) count_size.
Qed.

Theorem concats_entropy ss :
(*  \rsum_(s <- ss) size s * Hs s
       <= size (flatten ss) * Hs (flatten ss). *)
(* \rsum_(s <- ss) mulnRdep (size s) (fun H => Hs0 H)
       <= mulnRdep (size (flatten ss)) (fun H => Hs0 H). *)
  \sum_(s <- ss) nHs s <= nHs (flatten ss).
Proof.
(* (1) First simplify formula *)
(*rewrite szHs_is_nHs.
rewrite (eq_bigr _ (fun i _ => szHs_is_nHs i)).*)
rewrite exchange_big /nHs /=.
(* (2) Move to per-character inequalities *)
apply leR_sumR => a _.
(* Remove strings containing no occurrences *)
rewrite (bigID (fun s => N(a|s) == O)) /=.
rewrite big1; last by move=> i ->.
rewrite num_occ_flatten add0R.
rewrite [in X in _ <= X](bigID (fun s => N(a|s) == O)).
rewrite [in X in _ <= X]big1 //= ?add0n;
  last by move=> i /eqP.
rewrite (eq_bigr
       (fun i => N(a|i) * log (size i / N(a|i))));
  last by move=> i /negbTE ->.
rewrite -big_filter -[in X in _ <= X]big_filter.
(* ss' contains only strings with ocurrences *)
set ss' := [seq s <- ss | N(a|s) != O].
case/boolP: (ss' == [::]) => Hss'.
  by rewrite (eqP Hss') !big_nil eqxx.
have Hnum s : s \in ss' -> (N(a|s) > 0)%nat.
  by rewrite /ss' mem_filter lt0n => /andP [->].
have Hnum': 0 < N(a|flatten ss').
  apply /ltR0n; destruct ss' => //=.
  rewrite /num_occ count_cat ltn_addr //.
  by rewrite Hnum // in_cons eqxx.
have Hsz: 0 < size (flatten ss').
  apply (ltR_leR_trans Hnum').
  by apply /le_INR /leP /count_size.
apply (@leR_trans ((\sum_(i <- ss') N(a|i))%:R *
    log (size (flatten ss') /
      (\sum_(i <- ss') N(a|i))%nat)));
  last first.
  (* Not mentioned in the book: one has to compensate for the discarding
     of strings containing no occurences.
     Works thanks to monotonicity of log. *)
  (* (3) Compensate for removed strings *)
  case: ifP => Hsum.
    by rewrite (eqP Hsum) mul0R.
  apply leR_wpmul2l => //.
  apply Log_increasing_le => //.
    apply/mulR_gt0 => //.
    apply/invR_gt0/ltR0n.
    by rewrite lt0n Hsum.
  apply leR_wpmul2r.
    apply /Rlt_le /invR_gt0 /ltR0n.
    by rewrite lt0n Hsum.
  apply /le_INR /leP.
  rewrite !size_flatten !sumn_big_addn.
  rewrite !big_map big_filter.
  rewrite [in X in (_ <= X)%nat]
    (bigID (fun s => N(a|s) == O)) /=.
  by apply leq_addl.
(* (4) Prepare to use jensen_dist_concave *)
have Htotal := esym (num_occ_flatten a ss').
rewrite big_tnth in Htotal.
have Hnum2 : N(a|flatten ss') != O.
  rewrite -lt0n -ltR0n'; exact/ltRP.
set d := seq_nat_fdist Htotal Hnum2.
set r := fun i =>
  (size (tnth (in_tuple ss') i))
  / N(a|tnth (in_tuple ss') i).
have Hr: forall i, r i \in Rpos_interval.
  rewrite /r /= => i.
  rewrite classical_sets.in_setE; apply Rlt_mult_inv_pos; apply /ltR0n.
    apply (@leq_trans N(a|tnth (in_tuple ss') i)).
      by rewrite Hnum // mem_tnth.
    by apply count_size.
  by apply /Hnum /mem_tnth.
(* (5) Apply Jensen *)
move: (jensen_dist_concave log_concave d Hr).
rewrite /d /r /=.
under eq_bigr do rewrite ffunE /=.
under [X in _ <= log X -> _]eq_bigr do rewrite ffunE /=.
rewrite -(big_tnth _ _ _ xpredT
  (fun s => (N(a|s) / N(a|flatten ss')) *
           log ((size s) / N(a|s)))).
rewrite -(big_tnth _ _ _ xpredT
  (fun s => (N(a|s) / N(a|flatten ss')) *
           (size s / N(a|s)))).
(* (6) Transform the statement to match the goal *)
move/(@leR_wpmul2r N(a|flatten ss') _ _ (leR0n _)).
rewrite !big_distrl /=.
rewrite (eq_bigr
  (fun i => N(a|i) * log (size i / N(a|i))));
  last first.
  by move=> i _; rewrite mulRAC -!mulRA (mulRA (/ _)) mulVR ?mul1R // gtR_eqF.
move/leR_trans; apply. (* LHS matches *)
rewrite mulRC -num_occ_flatten big_filter.
rewrite (eq_bigr
  (fun i => size i / N(a|flatten ss')));
  last first.
  move=> i Hi; rewrite mulRCA {1}/Rdiv mulRAC.
  by rewrite mulRV ?mul1R // INR_eq0'.
rewrite -big_filter -/ss' -big_distrl.
rewrite -big_morph_natRD /=.
by rewrite size_flatten sumn_big_addn big_map.
Qed.

End string_concat.

End string.

(* tentative definition *)
Section higher_order_empirical_entropy.

Variables (A : finType) (l : seq A).
Hypothesis A0 : (O < #|A|)%nat.
Let n := size l.
Let def : A. Proof. move/card_gt0P : A0 => /sigW[def _]; exact def. Defined.
Hypothesis l0 : n != O.

(* the string consisting of the concatenation of the symbols following w in s *)
Fixpoint takes {k : nat} (w : k.-tuple A) (s : seq A) {struct s} : seq A :=
  if s is _ :: t then
    let s' := takes w t in
    if take k s == w then nth def (drop k s) O :: s' else s'
  else
    [::].

(* sample ref: https://www.dcc.uchile.cl/~gnavarro/ps/jea08.2.pdf *)
Definition hoH (k : nat) := / n%:R *
  \sum_(w in {: k.-tuple A}) #|takes w l|%:R *
    match Bool.bool_dec (size w != O) true with
      | left H => `H (num_occ_dist H)
      | _ => 0
    end.

Lemma hoH_decr (k : nat) : hoH k.+1 <= hoH k.
Proof.
rewrite /hoH; apply/leRP; rewrite leR_pmul2l'; last first.
  by apply/ltRP/invR_gt0/ltRP; rewrite ltR0n' lt0n.
(* TODO *)
Abort.

End higher_order_empirical_entropy.


(** 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 (z : natural) (lf2 : natural) : natural := plus lf2 z.


(**
    The "classical" definition of well-foundedness
    Pierre Casteran

 keywords :  well-founded relations, classical logic, axiom of choice

 *)

Require Import Relations.

(**
  Please consider the usual mathematical definition of well-founded relations :
 *)

Definition classic_wf {A}(R: relation A) :=
  ~ exists (s: nat-> A),  forall i,  R (s (S i)) (s i).

(** Prove that Coq's  definition entails the classical one *)

Theorem wf_classic_wf {A} (R: relation A) : well_founded R -> classic_wf R.
Proof.
Admitted.

(** Now, we work with some axioms (assumed in the following libraries) *)

Require Import Classical ClassicalChoice.

(** In the current context, prove that the classical definition entails Coq's
    (you may apply the following theorem)  *)

About choice.

Print Assumptions choice.

Theorem classic_wf_wf {A} (R: relation A) : classic_wf R -> well_founded R.
Proof.
Admitted.

Print Assumptions classic_wf_wf.

(*

Axioms:
relational_choice : forall (A B : Type) (R : A -> B -> Prop),
                    (forall x : A, exists y : B, R x y) ->
                    exists R' : A -> B -> Prop, subrelation R' R /\ (forall x : A, exists ! y : B, R' x y)
dependent_unique_choice : forall (A : Type) (B : A -> Type) (R : forall x : A, B x -> Prop),
                          (forall x : A, exists ! y : B x, R x y) ->
                          exists f : forall x : A, B x, forall x : A, R x (f x)
classic : forall P : Prop, P \/ ~ P

*)

Print Assumptions wf_classic_wf.

(*

Closed under the global context
*)


(* Exercise 5.4 *)

Definition dyslexic_imp := forall P Q : Prop, (P -> Q) -> (Q -> P).
Definition dyslexic_contrap := forall P Q : Prop, (P -> Q) -> (~P -> ~Q).

Theorem dyslexic_imp_is_false : ~dyslexic_imp.
Proof.
  unfold not.
  unfold dyslexic_imp.
  intros dyslexic_imp.
  apply (dyslexic_imp False True).
  intro false.
  apply False_ind.
  assumption.
  apply I.
Qed.

Theorem dyslexic_contrap_is_false : ~dyslexic_contrap.
Proof.
  unfold not.
  unfold dyslexic_contrap.
  intros dyslexic_contrap.
  apply (dyslexic_contrap False True).
  intro false.
  apply False_ind.
  assumption.
  intro false.
  assumption.
  apply I.
Qed.


Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Sets.Image.

Definition edge X := X -> X -> Prop.

Section bisim.

Variables (X: Type) (A: edge X)
  (Y: Type) (B: edge Y).
Definition is_bisimulation (r: X -> Y -> Prop) : Prop :=
 (forall c1 c2 d2, (A c1 c2 /\ r c2 d2 -> exists d1, B d1 d2 /\ r c1 d1)) /\
 (forall d1 d2 c2, (B d1 d2 /\ r c2 d2 -> exists c1, A c1 c2 /\ r c1 d1)).

End bisim.

Lemma bisim_id: forall X A, is_bisimulation X A X A eq.
intros X A.
unfold is_bisimulation.
split.
intros c1 c2 d2 [H H0].
exists c1;
rewrite H0 in H; auto.
intros d1 d2 c2 [H H0].
exists d1.
rewrite <- H0 in H; auto.
Qed.

Definition rel_comp {X Y Z} (r1: X -> Y -> Prop) (r2: Y -> Z -> Prop) :=
  fun x z => exists y, r1 x y /\ r2 y z.

Definition rel_inv {X Y} (r: X -> Y -> Prop): Y -> X -> Prop :=
  fun y x => r x y.

Lemma bisim_comp: forall X A Y B Z C,
  forall r1 r2, is_bisimulation X A Y B r1 -> is_bisimulation Y B Z C r2 ->
    is_bisimulation X A Z C (rel_comp r1 r2).
Admitted.

Lemma bisim_inv: forall X A Y B,
  forall r, is_bisimulation X A Y B r ->
    is_bisimulation Y B X A (rel_inv r).
Admitted.

Section set_relation.
Variables (X: Type) (A: edge X) (a: X)
  (Y: Type) (B: edge Y) (b: Y).
Definition set_equal: Prop :=
  exists r, is_bisimulation X A Y B r /\ r a b.
End set_relation.

Definition set_member (X: Type) (A: edge X) (a: X)
  (Y: Type) (B: edge Y) (b: Y): Prop :=
  exists z, set_equal X A a Y B z /\ B z b.

Definition set_subset (X: Type) (A: edge X) (a: X)
  (Y: Type) (B: edge Y) (b: Y): Prop :=
  forall Z C c, set_member Z C c X A a -> set_member Z C c Y B b.

Definition sum X Y := (X -> Prop) -> (Y -> Prop) -> Prop.
Definition inl {X Y} (a: X): sum X Y := fun p _ => p a.
Definition inr {X Y} (b: Y): sum X Y := fun _ q => q b.
Definition out {X Y} : sum X Y := fun _ _ => False.

Definition opt X := (X -> Prop) -> Prop.
Definition some {X} x: opt X := fun f => f x.
Definition none {X}: opt X := fun _ => False.

Definition cnat := forall X, (X -> X) -> X -> X.
Definition zero: cnat := fun f x => x.
Definition succ (n: cnat): cnat := fun X f x => f (n X f x).
Definition cle (n: cnat) (m: cnat) := forall P: cnat -> Prop, P n -> (forall z, P z -> P (succ z)) -> P m.
Definition clt n m := cle (succ n) m.
Definition wf_nat n := cle zero n.

Proposition inl_inr_disj: forall X Y (x: X) (y: Y), inl (Y := Y) x <> inr y.
intros X Y x y H.
specialize (equal_f (A := X -> Prop) (B := (Y -> Prop) -> Prop) H (fun _ => False)).
intro H0.
specialize (equal_f H0 (fun _ => True)).
unfold inl, inr.
intro H1.
rewrite H1.
exact I.
Qed.

Proposition inl_out_disj: forall X Y (x: X), inl (Y := Y) x <> out.
intros X Y x H.
specialize (equal_f (A := X -> Prop) (B := (Y -> Prop) -> Prop) H (fun _ => True)).
intro H0.
specialize (equal_f H0 (fun _ => True)).
unfold inl, out.
intro H1.
rewrite <- H1.
exact I.
Qed.

Proposition inr_out_disj: forall X Y (y: Y), inr (X := X) y <> out.
intros X Y y H.
specialize (equal_f (A := X -> Prop) (B := (Y -> Prop) -> Prop) H (fun _ => True)).
intro H0.
specialize (equal_f H0 (fun _ => True)).
unfold inr, out.
intro H1.
rewrite <- H1.
exact I.
Qed.

Proposition inl_inj: forall X Y, injective _ _(inl (X := X) (Y := Y)).
intros X Y x1 x2 H.
specialize (equal_f H (fun z => z = x1)).
intro H0.
specialize (equal_f H0 (fun _ => True)).
unfold inl.
intro.
symmetry.
rewrite <- H1.
auto.
Qed.

Proposition inr_inj: forall X Y, injective _ _ (inr (X := X) (Y := Y)).
intros X Y y1 y2 H.
specialize (equal_f H (fun _ => True)).
intro H0.
specialize (equal_f H0 (fun z => z = y2)).
unfold inr.
intro.
rewrite H1.
auto.
Qed.

Goal forall n, cle n n.
intros n P H H0.
auto.
Qed.

Goal forall l m n, cle l m -> cle m n -> cle l n.
intros l m n H H0 P H1 H2.
apply H0.
apply H.
apply H1.
apply H2.
apply H2.
Qed.

(* empty *)

Definition empty_c := forall X, (X -> X) -> X -> X.
Definition empty_e: edge empty_c := fun _ _ => False.
Definition empty_b: empty_c := fun _ x => x.

Theorem axiom_empty: forall X A a, ~ set_member X A a empty_c empty_e empty_b.
intros X A a H.
destruct H as [x [H H0]].
auto.
Qed.

(* pair *)

Section pair.

Variables (X: Type) (A: edge X) (a: X) (Y: Type) (B: edge Y) (b: Y).
Definition pair_c := sum X Y.
Definition pair_e: edge (sum X Y) :=
  fun c1 c2 =>
    (exists a1 a2, c1 = inl a1 /\ c2 = inl a2 /\ A a1 a2) \/
    (exists b1 b2, c1 = inr b1 /\ c2 = inr b2 /\ B b1 b2) \/
    (c1 = inl a /\ c2 = out) \/
    (c1 = inr b /\ c2 = out).
Definition pair_b: pair_c := out.

End pair.

Lemma inl_pair_set_equal: forall Z C c X A a Y B b,
  set_equal Z C c (pair_c X Y) (pair_e X A a Y B b) (inl a)
  <-> set_equal Z C c X A a.

split; intro H.
destruct H as [r [H H0]].
exists (fun z x => r z (inl x)).
split; auto; clear H0 c.
destruct H as [H H0].
split.
clear H0.
intros c1 c2 d2.
intros H1; destruct H1 as [H1 H2].
specialize (H c1 c2 (inl d2)).
destruct H as [d1 H3].
tauto.
destruct H3 as [H H3].
assert (exists x1, d1 = inl x1 /\ A x1 d2).
  destruct H as [H|[H|[H|H]]].
  destruct H as [a1 [a2 [H [H5 H6]]]].
  exists a1.
  apply inl_inj in H5.
  rewrite <- H5 in H6.
  tauto.
  destruct H as [_ [b2 [_ [H _]]]].
  apply False_ind; apply (inl_inr_disj _ _ d2 b2); auto.
  apply False_ind; apply (inl_out_disj _ Y d2); tauto.
  apply False_ind; apply (inl_out_disj _ Y d2); tauto.

destruct H0 as [x1 [H0 H4]].
exists x1.
rewrite <- H0.
tauto.

clear H.
intros d1 d0 c0 H1.
destruct H1 as [H1 H2].
admit.

(* if part *)

Admitted.

Lemma inr_pair_set_equal: forall Z C c X A a Y B b,
  set_equal Z C c (pair_c X Y) (pair_e X A a Y B b) (inr b)
  <-> set_equal Z C c Y B b.
Admitted.

Theorem pair_axiom:
  forall X A a Y B b Z C c, set_member Z C c (pair_c X Y) (pair_e X A a Y B b) (pair_b X Y)
    <-> set_equal Z C c X A a \/ set_equal Z C c Y B b.
split.

(* z in {x, y} -> z = x \/ z = y *)
intros H.
destruct H as [sb [H H0]].
unfold pair_b in H0.
case H0 as [H0| [H0| [H0| H0]]].

(* case 1 *)
destruct H0 as [a1 [a2 H0]].
absurd (inl (Y := Y) a2 = out).
apply (inl_out_disj X Y a2).
symmetry.
tauto.

(* case 2 *)
destruct H0 as [b1 [b2 H0]].
absurd (inr (X := X) b2 = out).
apply (inr_out_disj X Y b2).
symmetry.
tauto.

(* case 3 *)
destruct H0 as [H0 _].
left.
rewrite H0 in H.
apply inl_pair_set_equal in H.
auto.

(* case 4 *)

destruct H0 as [H0 _].
right.
rewrite H0 in H.
apply inr_pair_set_equal in H.
auto.

(* if part *)
intros H.
destruct H as [H | H].

  (* z = x *)
  unfold set_member.
  exists (inl a).
  split.
  apply inl_pair_set_equal; auto.
  unfold pair_e.
  tauto.
  (* z = y *)
  unfold set_member.
  exists (inr b).
  split.
  apply inr_pair_set_equal; auto.
  unfold pair_e.
  tauto.
Qed.

Section pow.

Variable X: Type.
Variables  (A: edge X) (a: X).
Definition pow_c := sum X (X -> Prop).
Definition pow_e (b1 b2: pow_c): Prop :=
  (exists a1 a2, b1 = inl a1 /\ b2 = inl a2 /\ A a1 a2)
  \/ (exists a1 p, b1 = inl a1 /\ b2 = inr p /\ A a1 a /\ p a1)
  \/ (exists p, b1 = inr p /\ b2 = out).
Definition pow_b: pow_c := out.
End pow.

Theorem power_axiom: forall X A a Y B b,
  set_member X A a (pow_c Y) (pow_e Y B b) (pow_b Y) <-> set_subset X A a Y B b.
split.

(* x in pow y -> x subset y *)
intro H.
unfold set_subset.
intros Z C c H0.
destruct H as [s [H H1]].
destruct H1 as [H1| [H1| H1]].

(* case 1 *)
destruct H1 as [a1 [a2 [H1 [H2 H3]]]].
unfold pow_b in H2.
absurd (inl a2 = out (Y := Y -> Prop)).
apply inl_out_disj.
symmetry; auto.

(* case 2 *)
destruct H1 as [a1 [p [H1 [H2 [H3 H4]]]]].
symmetry in H2.
apply inr_out_disj in H2; case H2.

(* case 3 *)

destruct H1 as [p [H1 _]].
destruct H0 as [u [H0 H2]].
destruct H as [rp [H H3]].
destruct H0 as [r [H0 H4]].
exists b.

admit.

(* x subset y -> x in pow y *)
admit.
Admitted.

Definition U :=
  (forall X: Type, (X -> X -> Prop) -> X -> Prop) -> Prop.

Definition i: forall X: Type, (X -> X -> Prop) -> X -> U.
intros X A a f.
exact (f X A a).
Defined.

Definition set (u: U): Prop :=
  exists X A a, u = i X A a.

Definition ueq (u1 u2: U): Prop :=
exists X A a Y B b, u1 = i X A a /\ u2 = i Y B b /\ set_equal X A a Y B b.

Definition elt (u1 u2: U): Prop :=
  exists X A a Y B b, u1 = i X A a /\ u2 = i Y B b /\ set_member X A a Y B b.


Require Import mathcomp.ssreflect.ssreflect.
From mathcomp Require Import ssreflect ssrbool ssrfun ssrnat eqtype finfun fintype choice seq tuple path.
From mathcomp Require Import finset perm fingroup matrix ssralg.
Require Import tools combclass subseq partition Yamanouchi permuted ordtype Schensted plactic Greene_inv std stdtab tableau.

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

Local Open Scope ring_scope.
Import GRing.Theory.
Open Local Scope ring_scope.

Section add_mx.
(*Not in MathComp (as far as I know) but useful here :
adding k in a cell of the matrix given by its coordinates
This cant be done with a map *)
Fact add_mx_key: unit. Proof. by []. Qed.
Definition add_mx m n (A:'M_(m,n)) k i0 j0 : 'M_(m,n):=
  \matrix[add_mx_key]_(i,j) (if (i==i0)&&(j==j0) then ((A i0 j0) + k)%N else A i0 j0).

End add_mx.

Section bimon_mat.

Variables m' n': nat.
Notation m := m'.+1.
Notation n := n'.+1.
Definition alph := ('I_m * 'I_n)%type.

Canonical alph_pordType := Eval hnf in POrdType alph (prodlex_pordMixin _ _).

Definition alph_ordMixin :=
  Order.Mixin (T := alph_pordType) (@prodlex_total _ _).
Canonical alph_ordType :=
  Eval hnf in OrdType alph alph_ordMixin.

Definition bimon_of_mat (M : 'M[nat]_(m, n)) : seq alph :=
  flatten [seq nseq (M a b) (a,b) | a <- enum 'I_m, b <- enum 'I_n].

Fixpoint mat_of_bimon (w : seq alph) : 'M_(m,n):=
  match w with
  | [::] => \matrix_(i, j) (0%N)
  | ((i0, j0) :: b) => let M := mat_of_bimon b in add_mx M 1 i0 j0
  end.

End bimon_mat.

  (*Par récurrence sur le nombre de lignes => utiliser row' ou [u|d]submx ?
    Dans tous les cas, il faut définir ce qu'est une matrice à laquelle on ajoute une ligne, col_mx doit pouvoir marcher la dessus
*)
(*
Definition col_mx_ind (A:'M[T]_(m.+1,n)) := let M':= row' (Ordinal (ltnSn m)) A in let r := row (Ordinal (ltnSn m)) A in A = col_mx M' r.
*)

Section Bla.

Variables m' n': nat.
Notation m := m'.+1.
Notation n := n'.+1.
Notation alph := (alph m' n').

Definition col_mx_ind (A:'M[nat]_(m'.+1, n'.+1)) :=
  let M':= row' (Ordinal (ltnSn m')) A in
  let r := row (Ordinal (ltnSn m')) A in A = col_mx M' r.

Lemma bimon_lex (M : 'M_(m,n)): is_row (bimon_of_mat M).
Proof.

  (*
  elim: m M => [|m0 IHm0 M0].
  - admit.
  - *)
Admitted.

Lemma matK (M:'M_(m,n)): mat_of_bimon (bimon_of_mat M) = M.
Proof.
Admitted.

Lemma bimonK (w: seq alph) : is_row w -> bimon_of_mat (mat_of_bimon w) = w.
Proof.
Admitted.

Definition bottomw_of_mat (M:'M_(m,n)): seq 'I_n :=
  [seq p.2 | p <- (bimon_of_mat M)].

Definition upw_of_mat (M:'M_(m,n)): seq 'I_m :=
  [seq p.1 | p <- (bimon_of_mat M)].

End Bla.

Section Schensted.

Variables m' n' : nat.
Notation m := m'.+1.
Notation n := n'.+1.
Notation alph := (alph m' n').

Fixpoint tab_of_yam_rev y (w: seq 'I_m) : seq (seq 'I_m) :=
  if y is y0 :: y' then
    if w is w0 :: w' then
    append_nth (tab_of_yam_rev y' w') w0 y0
    else [::]
  else [::].

Definition tab_of_yam y w := tab_of_yam_rev y (rev w).

Definition RSKmap (M : 'M[nat]_(m, n)) : seq (seq 'I_n) * seq (seq 'I_m):=
  let (P,Q) := RSmap (bottomw_of_mat M) in
  (P, tab_of_yam Q (upw_of_mat M)).

(*Definition istabpair (pair : seq(seq 'I_n) * seq (seq 'I_m)) :=
  let: (P,Q) := pair in
  is_tableau P && is_tableau Q.
 *)

Lemma RSKmap_spec M : let (P,Q) := RSKmap M in
                      is_tableau P && is_tableau Q.
Proof.
  admit.
Admitted.

(*Definition de RSKmap_inv :
-w=[::]
tant que Q est non nul:
  -parcourir Q en sens croissant à la recherche du plus grand élément
  -enlever cet élément i et garder les ligne k_1...k_n dans l'ordre
  -faire invinstab P [k] -> on obitent P' [j]
  -w= (i,j)::w
fin
retourner w.
*)

Variable T: eqType.

Fixpoint remove_in_tab k (Q:seq (seq nat)) compt:=
  match Q with
  |(h::t) => let i := index k h in
             let (Q',l) := remove_in_tab k t compt.+1 in
             ((take i h)::Q', cat l (nseq (size (drop i h)) compt))
  |[::] => ([::],[::])
  end.

Fixpoint invinstabseq (P:seq (seq nat)) lnrow: (seq(seq nat)*seq nat):=
  match lnrow with
  |(nrow::ln') => let (P',l) := invinstabnrow P nrow in
                  let (Q,l') := invinstabseq P' ln' in
                  (Q, l::l')
  |[::] => ([::],[::])
  end.

Fixpoint RSK_inv (pair: seq(seq nat) * seq(seq nat)) (a:nat) : seq (seq (nat*nat)):=
  let (P,Q) := pair in
  let (Q',nrow) := remove_in_tab a Q 0 in
  let (P',l) := invinstabseq P nrow in
  if a is a'.+1 then
    [seq (a,j)| j<-l]::RSK_inv (P',Q') a'
  else
    [seq (0%N,j)| j<-l] :: [::].

Definition RSKmap_inv pair:=
  mat_of_bimon (flatten (RSK_inv pair)).

End Schensted.


Add LoadPath "/Users/anikaitsingh/Desktop/coqSoftwareFoundations/chapter3/chapter1".
Add LoadPath "/Users/anikaitsingh/Desktop/coqSoftwareFoundations/chapter3/chapter2".
Add LoadPath "/Users/anikaitsingh/Desktop/coqSoftwareFoundations/chapter3/chapter3".

Print LoadPath.

Require Export natList.
Require Export Basics.

(*List Excercise 1*)

Theorem app_nil_r : forall l : natlist,
  l ++ [] = l.
Proof.
intros l.
induction l.
- reflexivity.
- simpl. rewrite -> IHl. reflexivity.
Qed.

Theorem rev_app_distr: forall l1 l2 : natlist,
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
intros l1 l2.
induction l1.
- simpl. induction l2.
+ reflexivity.
+ rewrite -> app_nil_r. reflexivity.
-simpl. induction l2.
+ simpl. rewrite -> app_nil_r. reflexivity.
+ simpl. rewrite -> IHl1. simpl. rewrite <-app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall l : natlist,
  rev (rev l) = l.
Proof.
intros l.
induction l.
- simpl. reflexivity.
- simpl. rewrite -> rev_app_distr. simpl. rewrite -> IHl. reflexivity.
Qed.

 Theorem app_assoc4 : forall l1 l2 l3 l4 : natlist,
  l1 ++ (l2 ++ (l3 ++ l4)) = ((l1 ++ l2) ++ l3) ++ l4.
Proof.
intros l1 l2 l3 l4.
rewrite -> app_assoc.
rewrite -> app_assoc.
reflexivity.
Qed.

Lemma nonzeros_app : forall l1 l2 : natlist,
  nonzeros (l1 ++ l2) = (nonzeros l1) ++ (nonzeros l2).
Proof.
intros l1 l2.
induction l1.
- simpl. reflexivity.
- simpl. destruct n.
+ rewrite <- IHl1. reflexivity.
+ simpl. rewrite <- IHl1. reflexivity.
Qed.

Fixpoint beq_natlist (l1 l2 : natlist) : bool :=
match l1 with
|nil =>
  match l2 with
  |nil => true
  |a => false
  end
|s:: l1' =>
  match l2 with
  |nil => false
  |x :: l2' =>
    match beq_nat (x) (s) with
    |true => beq_natlist (l1') (l2')
    |false => false
    end
  end
end.

Example test_beq_natlist1 :
  (beq_natlist nil nil = true).
 Proof. reflexivity. Qed.

Example test_beq_natlist2 :
  beq_natlist [1;2;3] [1;2;3] = true.
Proof. reflexivity. Qed.

Example test_beq_natlist3 :
  beq_natlist [1;2;3] [1;2;4] = false.
 Proof. reflexivity. Qed.

Theorem equality: forall n, beq_nat n n = true.
Proof.
intros n.
induction n.
- reflexivity.
- simpl. rewrite <- IHn. reflexivity.
Qed.

Theorem beq_natlist_refl : forall l:natlist,
  true = beq_natlist l l.
 Proof.
intros l.
induction l.
- reflexivity.
- simpl. rewrite <- IHl. simpl. rewrite -> equality. reflexivity.
Qed.

Fixpoint leb (n m : nat) : bool :=
  match n with
  | O => true
  | S n' =>
      match m with
      | O => false
      | S m' => leb n' m'
      end
  end.

(*list exercise 2*)
Theorem count_member_nonzero : forall(s : bag),
  leb 1 (count 1 (1 :: s)) = true.
Proof.
intros s.
simpl. reflexivity. Qed.

 Theorem ble_n_Sn : forall n,
  leb n (S n) = true.
Proof.
  intros n. induction n as [| n' IHn'].
  - (* 0 *)
    simpl. reflexivity.
  - (* S n' *)
    simpl. rewrite IHn'. reflexivity. Qed.

Theorem remove_decreases_count: forall (s : bag),
  leb (count 0 (remove_one 0 s)) (count 0 s) = true.
Proof.
intros s.
induction s.
- simpl. reflexivity.
- simpl. destruct n.
+ simpl. rewrite -> ble_n_Sn. reflexivity.
+ simpl. rewrite -> IHs. reflexivity.
Qed.

Theorem rev_injective: forall (l1 l2 : natlist), rev l1 = rev l2 -> l1 = l2.
Proof.
intros l1 l2.
intros H.
rewrite <- rev_involutive.
rewrite <- H.
rewrite -> rev_involutive.
reflexivity.
Qed.

(*Options*)

 Inductive natoption : Type :=
  | Some : nat -> natoption
  | None : natoption.

Fixpoint nth_error (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => match beq_nat n O with
               | true => Some a
               | false => nth_error l' (pred n)
               end
  end.
Example test_nth_error1 : nth_error [4;5;6;7] 0 = Some 4.
Proof. reflexivity. Qed.
Example test_nth_error2 : nth_error [4;5;6;7] 3 = Some 7.
Proof. reflexivity. Qed.
Example test_nth_error3 : nth_error [4;5;6;7] 9 = None.
Proof. reflexivity. Qed.

Fixpoint nth_error' (l:natlist) (n:nat) : natoption :=
  match l with
  | nil => None
  | a :: l' => if beq_nat n O then Some a
               else nth_error' l' (pred n)
  end.

 Definition option_elim (d : nat) (o : natoption) : nat :=
  match o with
  | Some n' => n'
  | None => d
  end.

Definition hd_error (l : natlist) : natoption :=
match l with
| nil => None
| s :: n => Some s
end.

Example test_hd_error1 : hd_error [] = None.
Proof. reflexivity. Qed.
Example test_hd_error2 : hd_error [1] = Some 1.
Proof. reflexivity. Qed.
Example test_hd_error3 : hd_error [5;6] = Some 5.
Proof. reflexivity. Qed.

Theorem option_elim_hd : forall (l:natlist) (default:nat),
  hd default l = option_elim default (hd_error l).
Proof.
intros l.
intros default.
destruct l.
- simpl. reflexivity.
- simpl. reflexivity.
Qed.

(*Partial Map*)

 Inductive id : Type :=
  | Id : nat -> id.

 Definition beq_id (x1 x2 : id) :=
  match x1, x2 with
  | Id n1, Id n2 => beq_nat n1 n2
  end.

Theorem beq_id_refl : forall x, true = beq_id x x.
Proof.
intros x.
destruct x.
simpl. rewrite -> equality. reflexivity.
Qed.

Inductive partial_map : Type :=
  | empty : partial_map
  | record : id -> nat -> partial_map -> partial_map.

 Definition update (d : partial_map)
                  (x : id) (value : nat)
                  : partial_map :=
  record x value d.

Fixpoint find (x : id) (d : partial_map) : natoption :=
  match d with
  | empty => None
  | record y v d' => if beq_id x y
                     then Some v
                     else find x d'
  end.

Theorem update_eq :
  forall (d : partial_map) (x : id) (v: nat),
    find x (update d x v) = Some v.
Proof.
intros d x v.
simpl.
destruct x.
simpl.
induction n.
- reflexivity.
- simpl.  rewrite -> equality. reflexivity.
Qed.

Theorem update_neq :
  forall (d : partial_map) (x y : id) (o: nat),
    beq_id x y = false -> find x (update d y o) = find x d.
Proof.
intros d x y o.
simpl.
intros H.
rewrite -> H. reflexivity.
Qed.

Inductive baz : Type :=
  | Baz1 : baz -> baz
  | Baz2 : baz -> bool -> baz.

(*no constructor that defines a distinct baz. Such as O in a nat. Thus, 0 elements can be created from this definition.*)


(**************************************************************************
* TLC: A library for Coq                                                  *
* Reflection between booleans and propositions                            *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics.
Require Export LibBool LibLogic.

Implicit Type P : Prop.
Implicit Type b : bool.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Reflection between booleans and propositions *)

(** - [istrue b] produces a proposition that is [True] if and only if
      the boolean [b] is equal to [true].

    - [isTrue P] produces a boolean expression that is [true] if and only
      if the proposition [P] is equal to [True]. *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Translation from booleans into propositions *)

(** Any boolean [b] can be viewed as a proposition through the
    relation [b = true]. *)

Coercion istrue (b : bool) : Prop := (b = true).

(** Specification *)

Lemma istrue_eq_eq_true : forall b,
  istrue b = (b = true).
Proof using. reflexivity. Qed.

Lemma istrue_true_eq :
  istrue true = True.
Proof using. rewrite istrue_eq_eq_true. extens*. Qed.

Lemma istrue_false_eq :
  istrue false = False.
Proof using. rewrite istrue_eq_eq_true. extens. iff; auto_false. Qed.

Global Opaque istrue.

(** Proving the goals [true] and [~ false] *)

Lemma istrue_true : istrue true. (* [true] *)
Proof using. reflexivity. Qed.

Lemma not_istrue_false : ~ (istrue false). (* ~ false. *)
Proof using. rewrite istrue_false_eq. intuition. Qed.

(** Equivalence of [false] and [False] *)

Lemma false_of_False :
  False ->
  false.
Proof using. intros K. false. Qed.

Lemma False_of_false :
  false ->
  False.
Proof using. intros K. rewrite~ istrue_false_eq in K. Qed.

(** Hints for proving [false] and [False] *)

Hint Resolve istrue_true not_istrue_false.

Hint Extern 1 (istrue false) =>
  apply false_of_False.

Hint Extern 1 (False) => match goal with
  | H: istrue false |- _ => apply (not_istrue_false H) end.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Translation from propositions into booleans *)

(** The expression [isTrue P] evaluates to [true] if and only if
    the proposition [P] is [True]. *)

Definition isTrue (P : Prop) : bool :=
  If P then true else false.

(** Specification *)

Lemma isTrue_eq_if : forall P,
  isTrue P = If P then true else false.
Proof using. reflexivity. Qed.

Lemma isTrue_True :
  isTrue True = true.
Proof using. unfolds. case_if; auto_false~. Qed.

Lemma isTrue_False :
  isTrue False = false.
Proof using. unfolds. case_if; auto_false~. Qed.

Global Opaque isTrue.

(** Lemmas *)

Lemma isTrue_eq_true : forall P,
  P ->
  isTrue P = true.
Proof using. intros. rewrite isTrue_eq_if. case_if*. Qed.

Lemma isTrue_eq_false : forall P,
  ~ P ->
  isTrue P = false.
Proof using. intros. rewrite isTrue_eq_if. case_if*. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Extensionality for boolean equality, stated using [istrue] *)

Lemma bool_ext : forall b1 b2,
  (b1 <-> b2) ->
  b1 = b2.
Proof using.
  destruct b1; destruct b2; intros; auto_false.
  destruct H. false H; auto.
  destruct H. false H0; auto.
Qed.

Lemma bool_ext_eq : forall b1 b2,
  (b1 = b2) = (b1 <-> b2).
Proof using.
  intros. extens. iff M. { subst*. } { applys* bool_ext. }
Qed.

Instance Extensionality_bool : Extensionality bool.
Proof using. apply (Extensionality_make bool_ext). Defined.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Rewriting rules *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Rewriting rules for distributing [istrue] *)

Lemma istrue_isTrue_eq : forall P,
  istrue (isTrue P) = P.
Proof using. extens. rewrite isTrue_eq_if. case_if; auto_false*. Qed.

Lemma istrue_neg_eq : forall b,
  istrue (!b) = ~ (istrue b).
Proof using. extens. tautob. Qed.

Lemma istrue_and_eq : forall b1 b2,
  istrue (b1 && b2) = (istrue b1 /\ istrue b2).
Proof using. extens. tautob. Qed.

Lemma istrue_or_eq : forall b1 b2,
  istrue (b1 || b2) = (istrue b1 \/ istrue b2).
Proof using. extens. tautob. Qed.

(** Corollary *)

Lemma istrue_neg_isTrue : forall P,
  istrue (! isTrue P) = ~ P.
Proof using. intros. rewrite istrue_neg_eq. rewrite~ istrue_isTrue_eq. Qed.

(** [istrue] and conditionals *)

Lemma If_istrue : forall b A (x y : A),
    (If istrue b then x else y)
  = (if b then x else y).
Proof using. intros. case_if as C; case_if as D; auto. Qed.

Lemma istrue_If_eq : forall P b1 b2,
    istrue (If P then b1 else b2)
  = (If P then istrue b1 else istrue b2).
Proof using. extens. case_if*. Qed.

Lemma istrue_if_eq : forall b1 b2 b3,
    istrue (if b1 then b2 else b3)
  = (If istrue b1 then istrue b2 else istrue b3).
Proof using. intros. do 2 case_if; auto. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Rewriting rules for distributing [isTrue] *)

Lemma isTrue_istrue : forall b,
  isTrue (istrue b) = b.
Proof using. extens. rewrite* istrue_isTrue_eq. Qed.

Lemma isTrue_not : forall P,
  isTrue (~ P) = ! isTrue P.
Proof using. extens. do 2 rewrite isTrue_eq_if. do 2 case_if; auto_false*. Qed.

Lemma isTrue_and : forall P1 P2,
  isTrue (P1 /\ P2) = (isTrue P1 && isTrue P2).
Proof using. extens. do 3 rewrite isTrue_eq_if. do 3 case_if; auto_false*. Qed.

Lemma isTrue_or : forall P1 P2,
  isTrue (P1 \/ P2) = (isTrue P1 || isTrue P2).
Proof using. extens. do 3 rewrite isTrue_eq_if. do 3 case_if; auto_false*. Qed.

(** Corollary *)

Lemma isTrue_not_istrue : forall b,
  isTrue (~ istrue b) = !b.
Proof using. intros. rewrite isTrue_not. rewrite~ isTrue_istrue. Qed.

(** Simplification of equalities involving isTrue *)

Section IsTrueEqualities.

Ltac prove_isTrue_lemma :=
  intros; try extens; try iff; rewrite isTrue_eq_if in *; case_if; auto_false*.

Lemma true_eq_isTrue_eq : forall P,
  (true = isTrue P) = P.
Proof using. prove_isTrue_lemma. Qed.

Lemma isTrue_eq_true_eq : forall P,
  (isTrue P = true) = P.
Proof using. prove_isTrue_lemma. Qed.

Lemma false_eq_isTrue_eq : forall P,
  (false = isTrue P) = ~ P.
Proof using. prove_isTrue_lemma. Qed.

Lemma isTrue_eq_false_eq : forall P,
  (isTrue P = false) = ~ P.
Proof using. prove_isTrue_lemma. Qed.

Lemma isTrue_eq_isTrue_eq : forall P1 P2,
  (isTrue P1 = isTrue P2) = (P1 <-> P2).
Proof using.
  intros. extens. iff; repeat rewrite isTrue_eq_if in *;
  repeat case_if; auto_false*.
Qed.

End IsTrueEqualities.

(** [isTrue] and conditionals *)

Lemma if_isTrue : forall P A (x y : A),
    (if isTrue P then x else y)
  = (If P then x else y).
Proof using.
  intros. case_if as C; case_if as D; auto.
  { rewrite* isTrue_eq_true_eq in C. }
  { rewrite* isTrue_eq_false_eq in C. }
Qed.

Lemma isTrue_If : forall P1 P2 P3,
    isTrue (If P1 then P2 else P3)
  = If P1 then isTrue P2 else isTrue P3.
Proof using. extens. case_if*. Qed.

Lemma isTrue_If_eq_if_isTrue : forall P1 P2 P3,
    isTrue (If P1 then P2 else P3)
  = (if isTrue P1 then isTrue P2 else isTrue P3).
Proof using. intros. rewrite if_isTrue. rewrite~ isTrue_If. Qed.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Lemmas for testing booleans *)

Lemma bool_inv_or : forall b,
  b \/ !b.
Proof using. tautob. Qed.

Lemma bool_inv_or_eq : forall b,
  b = true \/ b = false.
Proof using. tautob. Qed.

Lemma xor_inv_or : forall b1 b2,
  xor b1 b2 ->
     (b1 = true /\ b2 = false)
  \/ (b1 = false /\ b2 = true).
Proof using. tautob; auto_false*. Qed.

Arguments xor_inv_or [b1] [b2].

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Lemmas for normalizing [b = true] and [b = false] terms *)

Lemma bool_eq_true_eq : forall b,
  (b = true) = istrue b.
Proof using. extens. tautob. Qed.

Lemma bool_eq_false_eq : forall b,
  (b = false) = istrue (!b).
Proof using. extens. tautob. Qed.

Lemma true_eq_bool_eq : forall b,
  (true = b) = istrue b.
Proof using. extens. tautob. Qed.

Lemma false_eq_bool_eq : forall b,
  (false = b) = istrue (!b).
Proof using. extens. tautob. Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Tactics *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics [rew_istrue] to distribute [istrue] *)

(** [rew_istrue] distributes [istrue]. It is useful to replace all
    boolean operators with corresponding logical operators. *)

Hint Rewrite istrue_true_eq istrue_false_eq istrue_isTrue_eq
  istrue_neg_eq istrue_and_eq istrue_or_eq
  If_istrue istrue_If_eq istrue_if_eq: rew_istrue.

Tactic Notation "rew_istrue" :=
  autorewrite with rew_istrue.
Tactic Notation "rew_istrue" "in" hyp(H) :=
  autorewrite with rew_istrue in H.
Tactic Notation "rew_istrue" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_istrue).
  (* autorewrite with rew_istrue in *. *)

Tactic Notation "rew_istrue" "~" :=
  rew_istrue; auto_tilde.
Tactic Notation "rew_istrue" "~" "in" hyp(H) :=
  rew_istrue in H; auto_tilde.
Tactic Notation "rew_istrue" "~" "in" "*" :=
  rew_istrue in *; auto_tilde.

Tactic Notation "rew_istrue" "*" :=
  rew_istrue; auto_star.
Tactic Notation "rew_istrue" "*" "in" hyp(H) :=
  rew_istrue in H; auto_star.
Tactic Notation "rew_istrue" "*" "in" "*" :=
  rew_istrue in *; auto_star.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics [rew_isTrue] to distribute [isTrue] *)

(** [rew_isTrue] distributes [isTrue].
    This tactic is probably much less useful than [rew_istrue], since logical
    operators are often simpler to work with. *)

Hint Rewrite isTrue_True isTrue_False isTrue_istrue
  isTrue_not isTrue_and isTrue_or
  if_isTrue isTrue_If : rew_isTrue.

Tactic Notation "rew_isTrue" :=
  autorewrite with rew_isTrue.
Tactic Notation "rew_isTrue" "in" hyp(H) :=
  autorewrite with rew_isTrue in H.
Tactic Notation "rew_isTrue" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_isTrue).
  (* autorewrite with rew_isTrue in *. *)

Tactic Notation "rew_isTrue" "~" :=
  rew_isTrue; auto_tilde.
Tactic Notation "rew_isTrue" "~" "in" hyp(H) :=
  rew_isTrue in H; auto_tilde.
Tactic Notation "rew_isTrue" "~" "in" "*" :=
  rew_isTrue in *; auto_tilde.

Tactic Notation "rew_isTrue" "*" :=
  rew_isTrue; auto_star.
Tactic Notation "rew_isTrue" "*" "in" hyp(H) :=
  rew_isTrue in H; auto_star.
Tactic Notation "rew_isTrue" "*" "in" "*" :=
  rew_isTrue in *; auto_star.

(* ---------------------------------------------------------------------- *)
(** ** Tactics useful for program verification, when reasoning about
       the result of if-statements over boolean expressions, i.e.
       an expression of the form [b = ..] or [.. = b], which produces
       hypotheses of the form [true = ..] and [false = ..] or symmetric.
       It is used as post-treatment for tactic [case_if]. *)

Hint Rewrite
  true_eq_isTrue_eq isTrue_eq_true_eq
  false_eq_isTrue_eq isTrue_eq_false_eq
  isTrue_eq_isTrue_eq
  not_not_eq
  istrue_true_eq istrue_false_eq istrue_isTrue_eq
  istrue_neg_eq istrue_and_eq istrue_or_eq
  bool_eq_true_eq bool_eq_false_eq true_eq_bool_eq false_eq_bool_eq
  : rew_bool_eq.

Tactic Notation "rew_bool_eq" :=
  autorewrite with rew_bool_eq.
Tactic Notation "rew_bool_eq" "~" :=
  rew_bool_eq; auto_tilde.
Tactic Notation "rew_bool_eq" "*" :=
  rew_bool_eq; auto_star.

Tactic Notation "rew_bool_eq" "in" hyp(H) :=
  autorewrite with rew_bool_eq in H.
Tactic Notation "rew_bool_eq" "~" "in" hyp(H) :=
  rew_bool_eq in H; auto_tilde.
Tactic Notation "rew_bool_eq" "*" "in" hyp(H) :=
  rew_bool_eq in H; auto_star.

Tactic Notation "rew_bool_eq" "in" "*" :=
  autorewrite_in_star_patch ltac:(fun tt => autorewrite with rew_bool_eq).
  (* autorewrite with rew_bool_eq in *. *)
Tactic Notation "rew_bool_eq" "~" "in" "*" :=
  rew_bool_eq; auto_tilde.
Tactic Notation "rew_bool_eq" "*" "in" "*" :=
  rew_bool_eq; auto_star.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Tactics extended for reflection *)

(** Extension of the tactic [case_if] to automatically performs
    simplification using [logics].

    For less aggressive introduction of [istrue], consider rewriting
    without the lemmas:
    [bool_eq_true_eq bool_eq_false_eq true_eq_bool_eq false_eq_bool_eq]
*)

Ltac case_if_post H ::=
  rew_bool_eq in H; tryfalse.

(** Extension of the tactic [test_dispatch] from LibLogic.v, so as to
    be able to call the tactic [tests] directly on boolean expressions *)

Ltac tests_bool_base E H1 H2 :=
  tests_prop_base (istrue E) H1 H2.

Ltac tests_dispatch E H1 H2 ::=
  match type of E with
  | bool => tests_bool_base E H1 H2
  | Prop => tests_prop_base E H1 H2
  | {_}+{_} => tests_ssum_base E H1 H2
  end.

(** Extension of the tactic [apply_to_head_of] (see LibTactics). *)

Ltac apply_to_head_of E cont ::=
  let go E := let P := get_head E in cont P in
  match E with
  | istrue ?A => go A
  | istrue (neg ?A) => go A
  | ?A = ?B => first [ go A | go B ]
  | ?A => go A
  end.


Definition Regular_Induction := forall P, (P(0) /\ (forall k, P(k) -> P(S k)))
                                            -> (forall n, P(n)).
Definition Strong_Induction := forall P, (P(0) /\
                                         (forall k, (forall m, m <= k -> P(m)) -> P(S k)))
                                            -> (forall n, P(n)).

Definition Generalized_Strong_Induction := forall P, P(0) /\
                                                     (forall k, (forall m, m <= k -> P(m)) -> P(S k))
                                                     -> forall n m, m <= n -> P(m).

Lemma regular_implies_generalized_strong:
  Regular_Induction -> Generalized_Strong_Induction.
Proof.
  unfold Regular_Induction. unfold Generalized_Strong_Induction.
  intros RI P H1.
  induction n.
  - intros m H2. inversion H2.  destruct H1. assumption.
  - intros m H2. inversion H2.
    + destruct H1. apply H1. intros m0 H3. apply IHn. assumption.
    + apply IHn. assumption.
Qed.

Lemma generalized_strong_implies_strong:
  Generalized_Strong_Induction -> Strong_Induction.
  unfold Generalized_Strong_Induction. unfold Strong_Induction.
  intros. specialize (H P). pose proof (H H0) as H1.
  specialize (H1 n). specialize (H1 n).  apply H1. constructor.
Qed.

Lemma regular_implies_strong:
  Regular_Induction -> Strong_Induction.
Proof.
  intro H.
  apply generalized_strong_implies_strong.
  apply regular_implies_generalized_strong.
  assumption.
Qed.

Lemma strong_implies_regular: Strong_Induction -> Regular_Induction.
Proof.
  unfold Strong_Induction.  unfold Regular_Induction.
  intros SI P H.
  apply SI.
  split.
  - destruct H. apply H.
  - intro k. intro A.
    destruct H.  apply H0. apply A. auto.
Qed.

Theorem strong_equals_regular: Strong_Induction <-> Regular_Induction.
  split.
  apply strong_implies_regular.
  apply regular_implies_strong.
Qed.


Require Import Axiom_Extensionality.
Require Import Axiom_ProofIrrelevance.
Require Import Axiom_PropEqual.

Definition Relation (a b:Type) : Type := a -> b -> Prop.

Lemma eqRelation : forall (a b:Type) (r s:Relation a b),
    (forall x y, r x y <-> s x y) -> r = s.
Proof.
    intros a b r s H. apply extensionality2. intros x y.
    apply eqProp. apply H. apply H.
Qed.

Definition Total (a b:Type) (r:Relation a b) : Prop :=
    forall (x:a), exists (y:b), r x y.

Arguments Total {a} {b} _.

Definition Functional (a b:Type) (r:Relation a b) : Prop :=
    forall (x:a) (y y':b), r x y -> r x y' -> y = y'.

Arguments Functional {a} {b} _.

Inductive Func (a b:Type) : Type :=
    func : forall (r:Relation a b), Total r -> Functional r -> Func a b.

Arguments func {a} {b} _ _ _.

Notation "a ==> b" := (Func a b) (at level 60, right associativity).

Definition rel (a b:Type) (f:a ==> b) : Relation a b :=
    match f with
    | func r _ _ => r
    end.

Arguments rel {a} {b} _ _ _.

Lemma eqFunc : forall (a b:Type) (f g:a ==> b), rel f = rel g -> f = g.
Proof.
    intros a b f g H. destruct f as [r fTot fFunc]. destruct g as [s gTot gFunc].
    simpl in H. revert gTot gFunc fTot fFunc. rewrite H. clear H r.
    intros gTot gFunc fTot fFunc.
    rewrite (proof_irrelevance _ gTot fTot).
    rewrite (proof_irrelevance _ gFunc fFunc).
    reflexivity.
Qed.

Lemma eqFunc2 : forall (a b:Type) (f g:a ==> b),
    (forall (x:a) (y:b), rel f x y <-> rel g x y) <-> f = g.
Proof.
    intros a b f g. split.
    - intros H. apply eqFunc. apply eqRelation. exact H.
    - intros H x y. split.
        + intros H'. rewrite <- H. exact H'.
        + intros H'. rewrite H. exact H'.
Qed.

Lemma Func_exists : forall (a b:Type) (f:a ==> b) (x:a),
    exists y, rel f x y.
Proof.
    intros a b [r fTot fFunc] x. destruct (fTot x) as [y Hy].
    exists y. exact Hy.
Qed.

Arguments Func_exists {a} {b} _ _.

Lemma Func_unique : forall (a b:Type) (f:a ==> b) (x:a) (y y':b),
    rel f x y -> rel f x y' -> y = y'.
Proof.
    intros a b [r fTot fFunc] x y y' Hy Hy'. simpl in Hy, Hy'.
    apply (fFunc x). exact Hy. exact Hy'.
Qed.

Arguments Func_unique {a} {b} _ _ _ _ _ _.

Definition toRel (a b:Type) (f:a -> b): Relation a b :=
    fun (x:a) (y:b) => f x = y.

Arguments toRel {a} {b} _ _ _.

Lemma toRelTotal : forall (a b:Type) (f:a -> b), Total (toRel f).
Proof.
    intros a b f. unfold Total. intros x. unfold toRel.
    exists (f x). reflexivity.
Qed.

Arguments toRelTotal {a} {b} _ _.

Lemma toRelFunctional : forall (a b:Type) (f:a -> b), Functional (toRel f).
Proof.
    intros a b f. unfold Functional. intros x y y' Hy Hy'.
    unfold toRel in Hy. unfold toRel in Hy'. rewrite <- Hy, <-Hy'.
    reflexivity.
Qed.

Arguments toRelFunctional {a} {b} _ _ _ _ _ _.

Definition toFunc (a b:Type) (f:a -> b) : a ==> b :=
    func (toRel f) (toRelTotal f) (toRelFunctional f).

Arguments toFunc {a} {b} _.

Lemma relToFunc : forall (a b:Type) (f:a -> b) (x:a) (y:b),
    rel (toFunc f) x y = (f x = y).
Proof.
    intros a b f x y. unfold toFunc. simpl. unfold toRel. reflexivity.
Qed.

Definition toRelComp (a b c:Type) (f:a ==> b) (g:b ==> c) : Relation a c :=
    match f with
      func r _ _  =>
        match g with
          func s _ _  =>
            fun (x:a) =>
              fun (z:c) =>
                exists (y:b), r x y /\ s y z
        end
    end.

Arguments toRelComp {a} {b} {c} _ _ _ _.

Lemma toRelCompTotal : forall (a b c:Type) (f:a ==> b) (g:b ==> c),
    Total(toRelComp f g).
Proof.
    intros a b c [r fTot fFunc] [s gTot gFunc]. unfold Total. intros x.
    unfold toRelComp. destruct (fTot x) as [y Hy]. destruct (gTot y) as [z Hz].
    exists z, y. split.
    - exact Hy.
    - exact Hz.
Qed.

Arguments toRelCompTotal {a} {b} {c} _ _ _.

Lemma toRelCompFunctional : forall (a b c:Type) (f:a ==> b) (g:b ==> c),
    Functional(toRelComp f g).
Proof.
    intros a b c [r fTot fFunc] [s gTot gFunc]. unfold Functional.
    intros x z z'. unfold toRelComp. intros [y [Hy Hz]] [y' [Hy' Hz']].
    assert (y = y') as E. { apply (fFunc x y y' Hy Hy'). }
    apply (gFunc y z z' Hz). rewrite E. exact Hz'.
Qed.

Arguments toRelCompFunctional {a} {b} {c} _ _ _ _ _ _ _.

Definition composeFunc (a b c:Type) (f:a ==> b) (g:b ==> c) : a ==> c :=
    func (toRelComp f g) (toRelCompTotal f g) (toRelCompFunctional f g).

Arguments composeFunc {a} {b} {c} _ _.

Notation "f ; g" := (composeFunc f g) (at level 40, left associativity).

Lemma composeFunc_assoc:forall (a b c d:Type)(f:a ==> b)(g:b ==> c)(h: c ==> d),
    f;g;h = f;(g;h).
Proof.
    intros a b c d f g h. apply eqFunc2. intros x t.
    destruct f as [rf fTot fFunc].
    destruct g as [rg gTot gFunc].
    destruct h as [rh hTot hFunc].
    simpl. split.
    - intros [z [[y [H1 H2]] H3]]. exists y. split.
        + exact H1.
        + exists z. split.
            { exact H2. }
            { exact H3. }
    - intros [y [H1 [z [H2 H3]]]]. exists z. split.
        + exists y. split.
            { exact H1. }
            { exact H2. }
        + exact H3.
Qed.

Definition idRel (a:Type) : Relation a a := fun (x y:a) => y = x.

Lemma idRelTotal : forall (a:Type), Total (idRel a).
Proof. intros a. unfold Total. intros x. exists x. reflexivity. Qed.

Lemma idRelFunctional : forall (a:Type), Functional (idRel a).
Proof.
    intros a. unfold Functional. intros x y y'. unfold idRel. intros Hy Hy'.
    rewrite Hy, Hy'. reflexivity.
Qed.

Definition idFunc (a:Type) : a ==> a :=
    func (idRel a) (idRelTotal a) (idRelFunctional a).

Definition compose (a b c:Type) (f:a -> b) (g:b -> c) : a -> c :=
    fun (x:a) => g (f x).

Arguments compose {a} {b} {c} _ _ _.

Notation "g @ f" := (compose f g) (at level 60, right associativity).

Lemma compose_assoc : forall (a b c d:Type) (f:a -> b) (g:b-> c) (h:c -> d),
    h @ g @ f = (h @ g) @ f.
Proof.
    intros a b c d f g h. apply extensionality. intros x. reflexivity.
Qed.

Definition id (a:Type) : a-> a := fun (x:a) => x.

Arguments id {a} _.

Lemma toFunc_compose : forall (a b c:Type) (f:a -> b) (g:b -> c),
    toFunc (g @ f) = toFunc f ; toFunc g.
Proof.
    intros a b c f g. apply eqFunc. unfold compose, composeFunc. simpl.
    apply eqRelation. unfold toRel. intros x z. split.
    - intros H. exists (f x). split.
        + reflexivity.
        + exact H.
    - intros [y [H1 H2]]. rewrite H1. exact H2.
Qed.

Lemma toFunc_id : forall (a:Type), toFunc (id) = idFunc a.
Proof.
    intros a. apply eqFunc2. intros x y. simpl. unfold idRel, toRel, id. split.
    - intros H. symmetry. exact H.
    - intros H. symmetry. exact H.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type :=  Nil : lst | Cons : natural -> lst -> lst .

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

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 rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Lemma append_nil : forall (x : lst), append x Nil = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma append_assoc : forall (x y z : lst), append (append x y) z = append x (append y z).
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite IHx. reflexivity.
Qed.

Lemma rev_append : forall (x y : lst), rev (append x y) = append (rev y) (rev x).
Proof.
   intros.
   induction x.
   - simpl. rewrite append_nil. reflexivity.
   - simpl. rewrite IHx. rewrite append_assoc. reflexivity.
Qed.

Lemma rev_rev : forall (x : lst), rev (rev x) = x.
Proof.
   intros.
   induction x.
   - reflexivity.
   - simpl. rewrite rev_append. simpl. rewrite IHx. reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), eq (rev (append (rev x) (rev y))) (append y x).
Proof.
   induction x.
   - intros. simpl. rewrite rev_rev. rewrite append_nil. reflexivity.
   - intros.  simpl. lfind.  simpl.  rewrite (eq_refl : Cons n Nil = rev (Cons n Nil)).  rewrite IHx.  rewrite rev_rev.  simpl.  reflexivity.
Admitted.


Require Export Relations Morphisms Setoid Equalities SetoidClass.
Require Import Basics.
Require Import Setof.

Class SemiGroup {A} `{A_setoid : Setoid A} (op : A -> A -> A) :=
  {
     op_morphism :> Proper (equiv ==> equiv ==> equiv) op;
     op_assoc : forall a1 a2 a3, op (op a1 a2) a3 == op a1 (op a2 a3)
}.

Class Monoid {A} `{A_setoid : Setoid A} (op : A -> A -> A) :=
    {
     wm :> SemiGroup op;
     unit : A;
     unit_lunit : forall a, op unit a == a;
     unit_runit : forall a, op a unit == a
}.

Class Commutative {A} `{A_setoid : Setoid A} (op : A -> A -> A) :=
  { op_commut : forall a1 a2, op a1 a2 == op a2 a1 }.

Class Zero {A} `{A_setoid : Setoid A} (op : A -> A -> A) :=
  { zero : A;
    op_zero : forall a1, op a1 zero == zero }.

Class Zeros {A} `{A_setoid : Setoid A} (op : A -> A -> A) :=
  { zeros : Setof (A:=A) ;
    op_zeros : forall zero, zeros zero -> forall a1, zeros (op a1 zero);
    exist_zero : exists zero, zeros zero}.

Class ManyUnits {A} `{A_setoid : Setoid A} (op : A -> A -> A)
	`{A_zero : Zeros A op} :=
  {
	many_units :
	   forall x, exists u, op x u == x
	                       /\ (forall y, op y u == y \/ zeros (op y u))
}.

Program Instance zeros_zero {A} `{A_setoid : Setoid A} (op : A -> A -> A)
    { _ : Zero op} {_ : Proper (equiv ==> equiv ==> equiv) op}
    : Zeros op := { zeros := singleton zero }.
Next Obligation.
exists zero.   split; try reflexivity.
rewrite H3. rewrite H2.
apply op_zero.
Qed.
Next Obligation.
exists zero. exists zero. split; reflexivity.
Qed.


Require Import Coq.Arith.Arith
               Coq.Numbers.Natural.Peano.NPeano
               List.

Import ListNotations.
Import Nat. (* For 8.5.0 *)
Definition key := nat.

Inductive tree : Type :=
|  Node: key -> tree -> tree -> tree
|  Leaf : tree.

Definition priqueue := list tree.

Definition empty : priqueue := nil.

Notation  "a >? b" := (ltb b a) (at level 70, only parsing) : nat_scope.

Definition smash (t u:  tree) : tree :=
  match t , u with
  |  Node x t1 Leaf, Node y u1 Leaf =>
                   if  x >? y then Node x (Node y u1 t1) Leaf
                                else Node y (Node x t1 u1) Leaf
  | _ , _ => Leaf  (* arbitrary bogus tree *)
  end.

Fixpoint carry (q: list tree) (t: tree) : list tree :=
  match q, t with
  | nil, Leaf        => nil
  | nil, _            => t :: nil
  | Leaf :: q', _  => t :: q'
  | u :: q', Leaf  => u :: q'
  | u :: q', _       => Leaf :: carry q' (smash t u)
 end.

Definition insert (x: key) (q: priqueue) : priqueue :=
     carry q (Node x Leaf Leaf).

Fixpoint join (p q: priqueue) (c: tree) : priqueue :=
  match p, q, c with
  | [], _ , _            => carry q c
  | _, [], _             => carry p c
  | Leaf::p', Leaf::q', _              => c :: join p' q' Leaf
  | Leaf::p', q1::q', Leaf            => q1 :: join p' q' Leaf
  | Leaf::p', q1::q', Node _ _ _  => Leaf :: join p' q' (smash c q1)
  | p1::p', Leaf::q', Leaf            => p1 :: join p' q' Leaf
  | p1::p', Leaf::q',Node _ _ _   => Leaf :: join p' q' (smash c p1)
  | p1::p', q1::q', _                   => c :: join p' q' (smash p1 q1)
  end.

Fixpoint unzip (t: tree) (cont: priqueue -> priqueue) : priqueue :=
  match t with
  | Node x t1 t2   => unzip t2 (fun q => Node x t1 Leaf  :: cont q)
  | Leaf => cont nil
  end.

Definition heap_delete_max (t: tree) : priqueue :=
  match t with
    Node x t1 Leaf  => unzip t1 (fun u => u)
  | _ => nil   (* bogus value for ill-formed or empty trees *)
  end.

Fixpoint find_max' (current: key) (q: priqueue) : key :=
  match q with
  |  []         => current
  | Leaf::q' => find_max' current q'
  | Node x _ _ :: q' => find_max' (if x >? current then x else current) q'
  end.

Fixpoint find_max (q: priqueue) : option key :=
  match q with
  | [] => None
  | Leaf::q' => find_max q'
  | Node x _ _ :: q' => Some (find_max' x q')
 end.

Fixpoint delete_max_aux (m: key) (p: priqueue) : priqueue * priqueue :=
  match p with
  | Leaf :: p'   => let (j,k) := delete_max_aux m p'  in (Leaf::j, k)
  | Node x t1 Leaf :: p' =>
       if m >? x
       then (let (j,k) := delete_max_aux m p'
             in (Node x t1 Leaf::j,k))
       else (Leaf::p', heap_delete_max (Node x t1 Leaf))
  | _ => (nil, nil) (* Bogus value *)
  end.

Definition delete_max (q: priqueue) : option (key * priqueue) :=
  match find_max q with
  | None => None
  | Some  m => let (p',q') := delete_max_aux m q
                            in Some (m, join p' q' Leaf)
  end.

Definition merge (p q: priqueue) := join p q Leaf.

Definition main_easy :=
 let a := insert 5 (insert 3 (insert 7 empty)) in
 let b := insert 3 (insert 6 (insert 9 empty)) in
 let c := merge a b in
 match delete_max c with
 | Some (k, _) => k
 | None => 0
 end.

Fixpoint insert_list (l : list nat) (q : priqueue) :=
    match l with
    | [] => q
    | x :: l => insert_list l (insert x q)
    end.

Fixpoint make_list (n : nat) (l : list nat) :=
  match n with
  | 0 => 0 :: l
  | S 0 => 1 :: l
  | S (S n) => make_list n (S (S n) :: l)
  end.

Definition main :=
  let a := insert_list (make_list 2000 []) empty in
  let b := insert_list (make_list 2001 []) empty in
  let c := merge a b in
  match delete_max c with
  | Some (k, _) => k
  | None => 0
  end.


Fixpoint plus (x : nat) (y : nat) {struct x} : nat :=
  match x with
    | 0 => y
    | S x' => plus x' (S y)
  end.

Fixpoint equal (x : nat) (y : nat) {struct x} : Prop :=
  match x with
    | 0 =>
      match y with
        | 0 => True
        | S y' => False
      end
    | S x' =>
      match y with
        | 0 => False
        | S y' => equal x' y'
      end
    end.

(* distilled from conjecture: forall x y, equal (plus x y) (plus y x). *)
Definition conj (x : nat) (y : nat) : Prop :=
  let f1 :=
    (fix r (x : nat) (y : nat) {struct x} : Prop :=
      match x with
        | 0 =>
          (let f2 :=
            (fix r (y : nat) : Prop :=
              match y with
                | 0 => True
                | S y' => r y'
              end)
            in f2 y)
        | S x' =>
          match y with
            | 0 =>
              (let f3 :=
                (fix r (x : nat) : Prop :=
                  match x with
                    | 0 => True
                    | S x' => r x'
                  end)
                in f3 x')
            | S y' => r x' y'
          end
      end)
    in f1 x y.

Ltac case_eq x := generalize (refl_equal x); pattern x at -1; case x.

Lemma conj_zero : forall x, conj x 0 -> conj (S x) 0.
Proof.
  induction x. auto. simpl. simpl in IHx. intros. apply H.
Defined.

Theorem conj_correct : forall x y, conj x y.
Proof.
  induction x ; induction y. firstorder. firstorder.
  apply conj_zero. auto. firstorder.
Defined.

Theorem loop_correct : forall x, (fix r (x:nat) : Prop := match x with | 0 => True | S x' => r x' end) x.
Proof.
  induction x. auto. auto.
Defined.

Theorem conj_correct2 : forall x y, conj x y.
Proof.
  induction x ; induction y. firstorder. firstorder.
  simpl. cut (  True -> (fix r (x0 : nat) : Prop := match x0 with
                               | 0 => True
                               | S x' => r x'
                               end) x).
  intros. apply H. auto. intros. clear. induction x. auto. auto.
  firstorder.
Defined.

Theorem conj_correct3 : forall x y, conj x y.
Proof.
  induction x ; induction y. firstorder. firstorder.
  simpl. apply loop_correct. firstorder.
Defined.

Theorem plus_Z_x : forall x, equal (plus 0 x) x.
Proof.
  intros. induction x. firstorder. simpl. simpl in IHx. auto.
Defined.

Theorem plus_comm : forall x y, equal (plus x y) (plus y x).
  intros.

Fixpoint plus_l (x : nat) (y : nat) {struct x} : nat :=
  match x with
    | 0 => y
    | S x' => plus_l x' (S y)
  end.

Fixpoint plus_r (x : nat) (y : nat) {struct y} : nat :=
  match y with
    | 0 => x
    | S y' => plus_r (S x) y'
  end.

Theorem r_equal_l : forall (x : nat) (y : nat), equal (plus_l x y) (plus_r x y).
Proof.
  induction x. induction y. firstorder.
  Focus 2. intros. simpl. unfold plus_r.

inversion (plus_r x (S y)).
  intros. unfold plus_l. unfold plus_r.


Require Export XR_le_IZR.
Require Export XR_archimed.
Require Export XR_Rle_trans.
Require Export XR_Rle_lt_trans.

Local Open Scope R_scope.

Lemma one_IZR_r_R1 : forall r (n m:Z),
  r < IZR n <= r + R1 ->
  r < IZR m <= r + R1 ->
  n = m.
Proof.
  intros r n m ha hb.
  destruct ha as [ hal har ].
  destruct hb as [ hbl hbr ].
  apply Z.le_antisymm.
  {
    apply Z.lt_succ_r.
    apply lt_IZR.
    unfold Z.succ.
    rewrite plus_IZR.
    simpl.
    eapply Rle_lt_trans.
    exact har.
    apply Rplus_lt_compat_r.
    exact hbl.
  }
  {
    apply Z.lt_succ_r.
    apply lt_IZR.
    unfold Z.succ.
    rewrite plus_IZR.
    simpl.
    eapply Rle_lt_trans.
    exact hbr.
    apply Rplus_lt_compat_r.
    exact hal.
  }
Qed.


Lemma id_P : forall P:Prop, P -> P.
Proof.
 intros ; assumption.
Qed.

Lemma id_PP : forall P:Prop, (P -> P) -> P -> P.
Proof.
 intros; assumption.
Qed.

Lemma imp_trans : forall P Q R :Prop, (P -> Q) -> (Q -> R) -> P -> R.
Proof.
 intros P Q R H H0 p; apply H0; apply H; assumption.
Qed.

Lemma imp_perm :  forall P Q R :Prop, (P -> Q -> R) -> Q -> P -> R.
Proof.
 intros P Q R H q p ; apply H; assumption.
Qed.

Lemma ignore_Q : forall P Q R :Prop, (P -> R) -> P -> Q -> R.
Proof.
 intros P Q R H p q; apply H; assumption.
Qed.

Lemma delta_imp :  forall P Q :Prop,(P -> P -> Q) -> P -> Q.
Proof.
 intros P Q H p; apply H; assumption.
Qed.

Lemma delta_impR :forall P Q :Prop, (P -> Q) -> P -> P -> Q.
Proof.
  intros P Q H p; apply H; assumption.
Qed.

Lemma diamond : forall P Q R T:Prop, (P -> Q) ->
                                  (P -> R) ->
                                  (Q -> R -> T) ->
                                  P -> T.
Proof.
 intros P Q R T H H0 H1 p; apply H1.
 apply H; assumption.
 apply H0; assumption.
Qed.

Lemma weak_peirce : forall P Q:Prop, ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
 intros P Q H ; apply H ; intro H0.
 apply H0; intro p; apply H.
 intro; assumption.
Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(* This contribution was updated for Coq V5.10 by the COQ workgroup.        *)
(* January 1995                                                             *)
(****************************************************************************)
(*                              Relations_2.v                               *)
(****************************************************************************)

Require Import Relations_1.

Section Relations_2.
   Variable U : Type.
   Variable R : Relation U.

   Inductive Rstar : Relation U :=
     | Rstar_0 : forall x : U, Rstar x x
     | Rstar_n : forall x y z : U, R x y -> Rstar y z -> Rstar x z.

   Inductive Rstar1 : Relation U :=
     | Rstar1_0 : forall x : U, Rstar1 x x
     | Rstar1_1 : forall x y : U, R x y -> Rstar1 x y
     | Rstar1_n : forall x y z : U, Rstar1 x y -> Rstar1 y z -> Rstar1 x z.

   Inductive Rplus : Relation U :=
     | Rplus_0 : forall x y : U, R x y -> Rplus x y
     | Rplus_n : forall x y z : U, R x y -> Rplus y z -> Rplus x z.

   Definition Strongly_confluent : Prop :=
     forall x a b : U, R x a -> R x b -> exists z : U, R a z /\ R b z.

End Relations_2.
Hint Resolve Rstar_0.
Hint Resolve Rstar1_0.
Hint Resolve Rstar1_1.
Hint Resolve Rplus_0.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Coq.Bool.Bool.
Require Import Crypto.Util.ZUtil.Notations.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Testbit.
Local Open Scope bool_scope. Local Open Scope Z_scope.

Module Z.
  Lemma land_same_r : forall a b, (a &' b) &' b = a &' b.
  Proof.
    intros a b; apply Z.bits_inj'; intros n H.
    rewrite !Z.land_spec.
    case_eq (Z.testbit b n); intros;
      rewrite ?Bool.andb_true_r, ?Bool.andb_false_r; reflexivity.
  Qed.

  Lemma land_m1'_l a : Z.land (-1) a = a.
  Proof. apply Z.land_m1_l. Qed.
#[global]
  Hint Rewrite Z.land_m1_l land_m1'_l : zsimplify_const zsimplify zsimplify_fast.

  Lemma land_m1'_r a : Z.land a (-1) = a.
  Proof. apply Z.land_m1_r. Qed.
#[global]
  Hint Rewrite Z.land_m1_r land_m1'_r : zsimplify_const zsimplify zsimplify_fast.

  Lemma sub_1_lt_le x y : (x - 1 < y) <-> (x <= y).
  Proof. lia. Qed.

  Lemma land_mod a b :
    0 <= b ->
    a &' b = (a mod (2 ^ (Z.log2 b + 1))) &' b.
  Proof.
    pose proof (Z.log2_nonneg b).
    intros. rewrite <-Z.land_ones by lia.
    rewrite <-Z.land_assoc, (Z.land_comm (Z.ones _)).
    rewrite Z.land_ones_low; auto with zarith.
  Qed.

  Lemma land_add_high a b c d :
    Z.log2 d < c ->
    0 <= d ->
    (a + b * 2 ^ c) &' d = a &' d.
  Proof.
    pose proof (Z.log2_nonneg d).
    intros. rewrite land_mod by lia.
    rewrite Z.add_mod, Z.mul_mod by (apply Z.pow_nonzero; lia).
    match goal with
    | |- context [?a ^ ?b mod ?a ^ ?c] =>
      replace b with ((b - c) + c) by lia;
        rewrite (Z.pow_add_r a (b - c) c) by lia;
        rewrite Z.mod_mul by (apply Z.pow_nonzero; lia)
    end.
    rewrite Z.mul_0_r, Z.mod_0_l, Z.add_0_r, Z.mod_mod
      by (apply Z.pow_nonzero; lia).
    rewrite <-Z.land_ones, <-Z.land_assoc, (Z.land_comm (Z.ones _))
      by auto with zarith.
    rewrite Z.land_ones_low; auto with zarith.
  Qed.

  Lemma land_pow2 x n :
    0 <= n ->
    Z.land x (2^n-1) = x mod 2^n.
  Proof.
    intros. rewrite Z.sub_1_r, <- Z.ones_equiv.
    apply Z.land_ones; auto with zarith.
  Qed.

  Lemma land_pow2_testbit a b :
  a &' 2^b = if Z.testbit a b then 2^b else 0.
  Proof.
    apply Z.bits_inj_iff; red; intros; rewrite Z.land_spec.
    destruct (Z.testbit a b) eqn:E.
    - destruct (Z.eqb_spec b n); subst.
      + now rewrite E, andb_true_l.
      + now rewrite Z.pow2_bits_false, andb_false_r.
    - rewrite Z.testbit_0_l; destruct (Z.eqb_spec b n); subst.
      + now rewrite E, andb_false_l.
      + now rewrite Z.pow2_bits_false, andb_false_r. Qed.

  Lemma land_pow2_small a b
        (Ha : 0 <= a < 2^b) :
    a &' 2^b = 0.
  Proof. now rewrite land_pow2_testbit, Testbit.Z.bits_above_pow2. Qed.

  Lemma land_pow2_small_neg a b
        (Ha : - 2^b <= a < 0)
        (Hb : 0 < b) :
    a &' 2^b = 2^b.
  Proof. now rewrite land_pow2_testbit, Testbit.Z.testbit_small_neg. Qed.

  Lemma land_div2 a b (Ha : 0 <= a < 2^(b + 1))  :
    a / 2 &' 2^b = 0.
  Proof.
    destruct (Z.ltb_spec b 0).
    - now rewrite Pow.Z.base_pow_neg, Z.land_0_r.
    - rewrite land_pow2_testbit, Z.div2_bits, Testbit.Z.bits_above_pow2;
      try (replace (Z.succ b) with (b + 1); nia). Qed.
End Z.