(*
  Copyright 2022 ZhengPu Shi
  This file is part of CoqMatrix. It is distributed under the MIT
  "expat license". You should have recieved a LICENSE file with it.

  purpose   : auxiliary library for sequence.
  author    : ZhengPu Shi
  date      : 2022.06
 *)

Require Import Nat PeanoNat Lia Bool.
Require Export BasicConfig HierarchySetoid.
Require RExt.

Generalizable Variable A B C Aeq Beq Ceq Aadd Aopp Amul Ainv.

(* ######################################################################### *)
(** * Sequence by function, f : nat -> A  *)

Open Scope nat_scope.
Open Scope A_scope.

Declare Scope seq_scope.
Delimit Scope seq_scope with seq.
Open Scope seq_scope.

Declare Scope seq2_scope.
Delimit Scope seq2_scope with seq2.
Open Scope seq2_scope.

(* ======================================================================= *)
(** ** Equality of sequence *)
Section seqeq.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := Aeq : A_scope.

  (** Equality of two sequence which have one index *)
  Definition seqeq n (f g : nat -> A) := forall i, i < n -> f i == g i.

  (** seqeq is a equivalence relation *)
  Section seqeq_equiv.
    Context {n : nat}.
    Infix "==" := (seqeq n) : A_scope.
    Lemma seqeq_refl : forall (f : nat -> A), f == f.
    Proof.
      intros. hnf. easy.
    Qed.

    Lemma seqeq_sym : forall (f g : nat -> A), f == g -> g == f.
    Proof.
      intros. hnf in *. intros. rewrite <- H; auto. easy.
    Qed.

    Lemma seqeq_trans : forall (f g h : nat -> A), f == g -> g == h -> f == h.
    Proof.
      intros. hnf in *. intros. rewrite H, <- H0; auto. easy.
    Qed.

    Lemma seqeq_equiv : Equivalence (seqeq n).
    Proof.
      intros. constructor; intro; intros.
      apply seqeq_refl.
      apply seqeq_sym; auto.
      apply seqeq_trans with y; auto.
    Qed.

    Global Existing Instance seqeq_equiv.
  End seqeq_equiv.

  (** seqeq of S has a equivalent form. *)
  Lemma seqeq_S : forall n (f g : nat -> A),
      seqeq (S n) f g <-> (seqeq n f g) /\ (f n == g n).
  Proof.
    split; intros.
    - split; auto. unfold seqeq in *. auto.
    - unfold seqeq in *. intros. destruct H.
      destruct (i =? n) eqn:E1.
      + apply Nat.eqb_eq in E1. subst; auto.
      + apply Nat.eqb_neq in E1. apply H. lia.
  Qed.

  (** seqeq is decidable  *)
  Lemma seqeq_dec `{Dec_Aeq : Decidable A Aeq} : forall n, Decidable (seqeq n).
  Proof.
    induction n; constructor; intros.
    - left. unfold seqeq. easy.
    - unfold seqeq in *.
      destruct (decidable a b), (decidable (a n) (b n)).
      + left. intros. destruct (i =? n) eqn:E1.
        apply Nat.eqb_eq in E1; subst; auto.
        apply Nat.eqb_neq in E1. apply a0. lia.
      + right. intro. destruct n0. apply H. auto.
      + right. intro. destruct n0. intros. auto.
      + right. intro. destruct n0. intros. auto.
  Qed.

  (** *** seqeq is decidable with the help of bool equality *)
  Section seqeq_dec_with_eqb.

    Context {Aeqb : A -> A -> bool}.
    Context {Aeqb_true_iff : forall a b : A, Aeqb a b = true <-> Aeq a b}.
    Context {Aeqb_false_iff : forall a b : A, Aeqb a b = false <-> ~(Aeq a b)}.

    (** Boolean equality of two sequence *)
    Fixpoint seqeqb n (f g : nat -> A) : bool :=
      match n with
      | O => true
      | 1 => Aeqb (f 0)%nat (g 0)%nat
      | S n' => (seqeqb n' f g) && Aeqb (f n') (g n')
      end.

    (** seqeqb of S has a equivalent form. *)
    Lemma seqeqb_S : forall {n} (f g : nat -> A),
        seqeqb (S n) f g = (seqeqb n f g) && (Aeqb (f n) (g n)).
    Proof.
      intros. destruct n; auto.
    Qed.

    (** seqeqb = true <-> seqeq *)
    Lemma seqeqb_true_iff : forall n f g, seqeqb n f g = true <-> seqeq n f g.
    Proof.
      induction n; intros.
      - unfold seqeqb, seqeq. split; intros; auto. lia.
      - rewrite seqeqb_S. rewrite seqeq_S.
        rewrite andb_true_iff.
        (* s1 <-> t1 -> s2 <-> t2 -> s1 /\ s2 <-> t1 /\ t2 *)
        apply ZifyClasses.and_morph; auto.
    Qed.

    (** seqeqb = false <-> ~seqeq *)
    Lemma seqeqb_false_iff : forall n f g, seqeqb n f g = false <-> ~(seqeq n f g).
    Proof.
      induction n; intros.
      - unfold seqeqb, seqeq. split; intros; try easy. destruct H. easy.
      - rewrite seqeqb_S. rewrite seqeq_S.
        rewrite andb_false_iff.
        rewrite IHn. rewrite Aeqb_false_iff. split; intros H.
        + apply Classical_Prop.or_not_and; auto.
        + apply Classical_Prop.not_and_or in H; auto.
    Qed.

    (** seqeq is decidable (with the help of eqb)  *)
    Lemma seqeq_dec_with_eqb : forall n f g, {seqeq n f g} + {~(seqeq n f g)}.
    Proof.
      intros. destruct (seqeqb n f g) eqn:E1.
      - left. apply seqeqb_true_iff in E1. auto.
      - right. apply seqeqb_false_iff in E1. auto.
    Qed.

    End seqeq_dec_with_eqb.

End seqeq.

(* ======================================================================= *)
(** ** Equality of sequence with two index *)
Section seq2eq.

  Context `{Equiv_Aeq : Equivalence A Aeq}.
  Infix "==" := Aeq : A_scope.

  (** Equality of two sequence which have two indexes *)
  Definition seq2eq r c (f g : nat -> nat -> A) :=
    forall ri ci, ri < r -> ci < c -> f ri ci == g ri ci.

  (** seq2eq of Sr has a equivalent form. *)
  Lemma seq2eq_Sr : forall r c (f g : nat -> nat -> A),
      seq2eq (S r) c f g <-> (seq2eq r c f g) /\ (seqeq (Aeq:=Aeq) c (f r) (g r)).
  Proof.
    split.
    - intros. split; auto.
      + unfold seq2eq in *. intros. apply H; auto.
      + unfold seq2eq, seqeq in *. intros. auto.
    - unfold seq2eq,seqeq. intros. destruct H.
      destruct (ri =? r)%nat eqn : E1.
      + apply Nat.eqb_eq in E1. subst; auto.
      + apply Nat.eqb_neq in E1. apply H; auto. lia.
  Qed.

  (** seq2eq is a equivalence relation *)

  Lemma seq2eq_refl : forall r c (f : nat -> nat -> A), let R := seq2eq r c in R f f.
  Proof.
    intros. hnf. easy.
  Qed.

  Lemma seq2eq_sym : forall r c (f g : nat -> nat -> A), let R := seq2eq r c in R f g -> R g f.
  Proof.
    intros. hnf in *. intros. rewrite <- H; auto. easy.
  Qed.

  Lemma seq2eq_trans : forall r c (f g h : nat -> nat -> A),
      let R := seq2eq r c in R f g -> R g h -> R f h.
  Proof.
    intros. hnf in *. intros. rewrite H, <- H0; auto. easy.
  Qed.

  Lemma seq2eq_equiv : forall r c, Equivalence (seq2eq r c).
  Proof.
    intros. constructor; intro; intros.
    apply seq2eq_refl.
    apply seq2eq_sym; auto.
    apply seq2eq_trans with y; auto.
  Qed.

  Global Existing Instance seq2eq_equiv.

  (** *** seq2eq is decidable with the help of bool equality *)
  Section seq2eq_dec_with_eqb.

    Context {Aeqb : A -> A -> bool}.
    Context {Aeqb_true_iff : forall a b : A, Aeqb a b = true <-> Aeq a b}.
    Context {Aeqb_false_iff : forall a b : A, Aeqb a b = false <-> ~(Aeq a b)}.

    (** seq2eq is decidable  *)
    Lemma seq2eq_dec `{Dec_Aeq : Decidable A Aeq} : forall r c, Decidable (seq2eq r c).
    Proof.
      induction r; constructor; intros.
      - left. unfold seq2eq. intros. easy.
      - unfold seq2eq in *. specialize (IHr c).
        destruct (decidable a b).
        + (* Tips: need to construct a prop *)
          assert (Decidable (fun f g : nat -> nat -> A =>
                               forall ci, ci < c -> f r ci == g r ci)) as H.
          { constructor. intros. apply seqeq_dec. }
          destruct (@decidable _ _ H a b).
          * left. intros. destruct (ri =? r) eqn:E1.
            ** apply Nat.eqb_eq in E1; subst; auto.
            ** apply Nat.eqb_neq in E1. apply a0; auto. lia.
          * right. intro. destruct n. intros. apply H0; auto.
        + right. intro. destruct n. intros. auto.
    Qed.

    (** Boolean equality of two sequence *)
    Fixpoint seq2eqb r c (f g : nat -> nat -> A) : bool :=
      match r with
      | O => true
      | 1 => seqeqb (Aeqb:=Aeqb) c (f 0)%nat (g 0)%nat
      | S r' => (seq2eqb r' c f g) && (seqeqb (Aeqb:=Aeqb) c (f r') (g r'))
      end.

    (** seq2eqb of Sr has a equivalent form. *)
    Lemma seq2eqb_Sr : forall r c (f g : nat -> nat -> A),
        seq2eqb (S r) c f g = (seq2eqb r c f g) && (seqeqb (Aeqb:=Aeqb) c (f r) (g r)).
    Proof.
      intros. destruct r; auto.
    Qed.

    (** seq2eqb = true <-> seq2eq *)
    Lemma seq2eqb_true_iff : forall r c f g,
        seq2eqb r c f g = true <-> seq2eq r c f g.
    Proof.
      induction r; intros.
      - unfold seq2eqb, seq2eq. split; intros; auto. lia.
      - rewrite seq2eqb_Sr. rewrite seq2eq_Sr.
        rewrite andb_true_iff.
        (* s1 <-> t1 -> s2 <-> t2 -> s1 /\ s2 <-> t1 /\ t2 *)
        apply ZifyClasses.and_morph; auto.
        apply (seqeqb_true_iff (Aeqb_true_iff:=Aeqb_true_iff)).
    Qed.

    (** seq2eqb = false <-> ~seq2eq *)
    Lemma seq2eqb_false_iff : forall r c f g,
        seq2eqb r c f g = false <-> ~(seq2eq r c f g).
    Proof.
      induction r; intros.
      - unfold seq2eqb, seq2eq. split; intros; try easy. destruct H. easy.
      - rewrite seq2eqb_Sr. rewrite seq2eq_Sr.
        rewrite andb_false_iff.
        rewrite IHr. rewrite (seqeqb_false_iff (Aeqb_false_iff:=Aeqb_false_iff)).
        split; intros H.
        + apply Classical_Prop.or_not_and; auto.
        + apply Classical_Prop.not_and_or in H; auto.
    Qed.

    (** seq2eq is decidable (with the help of eqb)  *)
    Lemma seq2eq_dec_with_eqb : forall r c f g, {seq2eq r c f g} + {~(seq2eq r c f g)}.
    Proof.
      intros. destruct (seq2eqb r c f g) eqn:E1.
      - left. apply seq2eqb_true_iff in E1. auto.
      - right. apply seq2eqb_false_iff in E1. auto.
    Qed.

  End seq2eq_dec_with_eqb.

End seq2eq.

(* ======================================================================= *)
(** ** Sum of a sequence *)
Section Sum.

  Context `{M : AMonoid A Aadd A0 Aeq}.
  Infix "==" := Aeq : A_scope.
  Infix "+" := Aadd : A_scope.

  (** Sum of a sequence *)
  Fixpoint seqsum (f : nat -> A) (n : nat) : A :=
    match n with
    | O => A0
    | S n' => seqsum f n' + f n'
    end.

  (** Sum of a sequence which every element is zero get zero. *)
  Lemma seqsum_seq0 : forall (f : nat -> A) (n : nat),
      (forall i, i < n -> f i == A0) -> seqsum f n == A0.
  Proof.
    intros f n H. induction n; simpl. easy.
    rewrite H; auto. rewrite IHn; auto. monoid_simpl.
  Qed.

  (** Corresponding elements of two sequences are equal, imply the sum are
      equal. *)
  Lemma seqsum_eq : forall (f g : nat -> A) (n : nat),
      (forall i, i < n -> f i == g i) -> seqsum f n == seqsum g n.
  Proof.
    intros f g n H.
    induction n; simpl; auto. easy.
    rewrite H, IHn; auto. easy.
  Qed.

  (** Sum with plus of two sequence equal to plus with two sum. *)
  Lemma seqsum_add (Comm: Commutative Aadd Aeq) : forall (f g : nat -> A) (n : nat),
      seqsum (fun i => f i + g i) n == seqsum f n + seqsum g n.
  Proof.
    intros f g n. induction n; simpl. monoid_simpl. rewrite IHn.
    rewrite ?associative. f_equiv.
    rewrite <- ?associative. f_equiv.
    apply commutative.
  Qed.

  (** *** Below, we need ring structure *)
  Context `{R : Ring A Aadd A0 Aopp Amul A1 Aeq}.
  Add Ring ring_inst : make_ring_theory.

  Infix "*" := Amul : A_scope.

  (** Constant left multiply to the sum of a sequence. *)
  Lemma seqsum_cmul_l : forall c (f : nat -> A) (n : nat),
      c * seqsum f n == seqsum (fun i => c * f i) n.
  Proof.
    intros c f n. induction n; simpl. ring.
    ring_simplify. rewrite IHn. ring.
  Qed.

  (** Constant right multiply to the sum of a sequence. *)
  Lemma seqsum_cmul_r : forall c (f : nat -> A) (n : nat),
      seqsum f n * c == seqsum (fun i => f i * c) n.
  Proof.
    intros c f n. induction n; simpl; try ring.
    ring_simplify. rewrite IHn. ring.
  Qed.

  (** Sum a sequence which only one item in nonzero, then got this item. *)
  Lemma seqsum_unique : forall (f : nat -> A) (k : A) (n i : nat),
      (i < n) -> f i == k -> (forall j, i <> j -> f j == A0) ->
      seqsum f n == k.
  Proof.
    (* key idea: induction n, and case {x =? n} *)
    intros f k n. induction n; intros. easy. simpl.
    destruct (i =? n)%nat eqn : E1.
    - apply Nat.eqb_eq in E1. subst.
      assert (seqsum f n == A0).
      { apply seqsum_seq0. intros. apply H1. lia. }
      rewrite H0. rewrite H2. ring.
    - apply Nat.eqb_neq in E1.
      assert (f n == A0).
      { apply H1; auto. }
      assert (seqsum f n == k).
      { apply IHn with i; auto. lia. }
      rewrite H3,H2. ring.
  Qed.

  (** Add the sum and a tail element *)
  Lemma seqsum_extend_r : forall n f,
      seqsum f n + f n == seqsum f (S n).
  Proof.
    reflexivity.
  Qed.

  (** Add a head element and the sum *)
  Lemma seqsum_extend_l : forall n f,
      f O + seqsum (fun i => f (S i)) n == seqsum f (S n).
  Proof.
    intros n f. induction n.
    - simpl. ring.
    - simpl. ring_simplify. rewrite IHn. simpl. ring.
  Qed.

  (** Sum the m+n elements equal to plus of two parts.
      Σ[i,0,(m+n)] f(i) = Σ[i,0,m] f(i) + Σ[i,0,n] f(m + i). *)
  Lemma seqsum_plusIdx : forall m n f,
      seqsum f (m + n) == seqsum f m + seqsum (fun i => f (m + i)%nat) n.
  Proof.
    intros m n f.
    induction m.
    - simpl. ring_simplify. easy.
    - simpl. rewrite IHm.
      rewrite !associative. f_equiv.
      remember (fun x => f (m + x)%nat) as g.
      (* Tips: replace is not suitable for setoid, but only eq. So, use assert *)
      assert (f (m + n)%nat == g n) as H1. { subst. easy. } rewrite H1; clear H1.
      rewrite seqsum_extend_r.
      assert (f m == g 0) as H1. { subst. f_equiv. lia. } rewrite H1; clear H1.
      assert (seqsum (fun x : nat => f (S (m + x))) n ==
                seqsum (fun x : nat => g (S x)) n) as H1.
      { subst. apply seqsum_eq. intros. f_equiv. auto. } rewrite H1; clear H1.
      rewrite seqsum_extend_l.
      easy.
  Qed.

  (** Product two sum equal to sum of products.
      Σ[i,0,m] f(i) * Σ[i,0,n] g(i) = Σ[i,0,m*n] f(i/n)*g(i%n).

      For example:
        (a + b + c) * (x + y) = a*x + a*y + b*x + b*y + c*x + c*y
   *)
  Lemma seqsum_product : forall m n f g,
      n <> O ->
      seqsum f m * seqsum g n == seqsum (fun i => f (i / n)%nat * g (i mod n)%nat) (m * n).
  Proof.
    intros.
    induction m.
    - simpl. ring.
    - simpl. ring_simplify. rewrite IHm; auto. clear IHm.
      remember ((fun i : nat => f (i / n)%nat * g (i mod n)%nat)) as h.
      rewrite seqsum_cmul_l.
      (* Σ[i,0,n] f(m)*g(i) = Σ[i,0,n] f((m*n+i)/n)*g((m*n+i)%n) *)
      assert (seqsum (fun i : nat => f m * g i) n ==
                seqsum (fun i : nat => h ((m * n) + i)%nat) n) as H1.
      { subst. apply seqsum_eq.
        intros i Hi. f_equiv.
        * f_equiv.
          (* (m * n + i) / n = m *)
          rewrite Nat.div_add_l; auto.  (* a * b + c) / b = a + c / b *)
          rewrite Nat.div_small; auto.  (* a < b -> a / b = 0 *)
        * f_equiv.
          (* (m * n + i) % n = i *)
          rewrite Nat.add_mod; auto.  (* (a + b) % n = a % n + b % n) % n *)
          rewrite Nat.mod_mul; auto.  (* (a * b) mod b = 0 *)
          rewrite Nat.add_0_l.
          repeat rewrite Nat.mod_small; auto. (* a < b -> a % b = 0 *)
      }
      rewrite H1; clear H1.
      rewrite <- seqsum_plusIdx. f_equiv. apply Nat.add_comm.
  Qed.

End Sum.

Module Sequence_test.

  Import RExt.

  Example seq1 := fun n => Z2R (Z.of_nat n).

  (* Compute seqsum seq1 3. *)
  (* Compute @seqsum R Rplus R0 seq1 3. *)

  (* Eval simpl in seqeqb 5 seq1 seq1. *)
  (* Compute seqeqb 5 seq1 seq1. *)
  (* Compute seqeqb 5 seq1 seq1. *)

  Open Scope Z.
  Example seq2 := fun i j => Z.of_nat i + Z.of_nat j.
  Example seq3 := fun i j => Z.of_nat i + Z.of_nat j + 1.

  (* Eval simpl in seq2eqb 2 3 seq2 seq3. *)
  (* Compute seq2eqb (Aeqb:=Z.eqb) 2 3 seq2 seq3. *)

End Sequence_test.


(* -*- mode: coq; mode: visual-line -*- *)
(** Contractibility *)

Require Import Overture PathGroupoids.
Local Open Scope path_scope.

(** Naming convention: we consistently abbreviate "contractible" as "contr".  A theorem about a space [X] being contractible (which will usually be an instance of the typeclass [Contr]) is called [contr_X]. *)

(** Allow ourselves to implicitly generalize over types [A] and [B], and a function [f]. *)
Generalizable Variables A B f.

(** If a space is contractible, then any two points in it are connected by a path in a canonical way. *)
Definition path_contr `{Contr A} (x y : A) : x = y
  := (contr x)^ @ (contr y).

(** Similarly, any two parallel paths in a contractible space are homotopic, which is just the principle UIP. *)
Definition path2_contr `{Contr A} {x y : A} (p q : x = y) : p = q.
Proof.
  assert (K : forall (r : x = y), r = path_contr x y).
  - intro r; destruct r; symmetry; now apply concat_Vp.
  - transitivity (path_contr x y);auto with path_hints.
Defined.

(** It follows that any space of paths in a contractible space is contractible. *)

Global Instance contr_paths_contr `{Contr A} (x y : A) : Contr (x = y) | 10000.
Proof.
  exists ((contr x)^ @ contr y).
  exact (path2_contr ((contr x)^ @ contr y)).
Defined.

(** Also, the total space of any based path space is contractible.  We define the [contr] fields as separate definitions, so that we can give them [simpl nomatch] annotations. *)

Definition path_basedpaths {X : Type} {x y : X} (p : x = y)
: (x;1) = (y;p) :> {z:X & x=z}.
Proof.
  destruct p; reflexivity.
Defined.

Arguments path_basedpaths {X x y} p : simpl nomatch.

Global Instance contr_basedpaths {X : Type} (x : X) : Contr {y : X & x = y} | 100.
Proof.
  exists (x ; 1).
  intros [y p]; apply path_basedpaths.
Defined.

(* Sometimes we end up with a sigma of a one-sided path type that's not eta-expanded, which Coq doesn't seem able to match with the previous instance. *)
Global Instance contr_basedpaths_etashort {X : Type} (x : X) : Contr (sig (@paths X x)) | 100
  := contr_basedpaths x.

Definition path_basedpaths' {X : Type} {x y : X} (p : y = x)
: (x;1) = (y;p) :> {z:X & z=x}.
Proof.
  destruct p; reflexivity.
Defined.

Global Instance contr_basedpaths' {X : Type} (x : X) : Contr {y : X & y = x} | 100.
Proof.
  refine (Build_Contr _ (x;1) _).
  intros [y p]; apply path_basedpaths'.
Defined.

Arguments path_basedpaths' {X x y} p : simpl nomatch.

(** Some useful computation laws for based path spaces *)

Definition ap_pr1_path_contr_basedpaths {X : Type}
           {x y z : X} (p : x = y) (q : x = z)
: ap pr1 (path_contr ((y;p):{y':X & x = y'}) (z;q)) = p^ @ q.
Proof.
  destruct p,q; reflexivity.
Defined.

Definition ap_pr1_path_contr_basedpaths' {X : Type}
           {x y z : X} (p : y = x) (q : z = x)
: ap pr1 (path_contr ((y;p):{y':X & y' = x}) (z;q)) = p @ q^.
Proof.
  destruct p,q; reflexivity.
Defined.

Definition ap_pr1_path_basedpaths {X : Type}
           {x y : X} (p : x = y)
: ap pr1 (path_basedpaths p) = p.
Proof.
  destruct p; reflexivity.
Defined.

Definition ap_pr1_path_basedpaths' {X : Type}
           {x y : X} (p : y = x)
: ap pr1 (path_basedpaths' p) = p^.
Proof.
  destruct p; reflexivity.
Defined.

(** If the domain is contractible, the function is propositionally constant. *)
Definition contr_dom_equiv {A B} (f : A -> B) `{Contr A} : forall x y : A, f x = f y
  := fun x y => ap f ((contr x)^ @ contr y).

(** Any retract of a contractible type is contractible *)
Definition contr_retract {X Y : Type} `{Contr X}
           (r : X -> Y) (s : Y -> X) (h : forall y, r (s y) = y)
  : Contr Y
  := Build_Contr _ (r (center X)) (fun y => (ap r (contr _)) @ h _).

(** Sometimes the easiest way to prove that a type is contractible doesn't produce the definitionally-simplest center.  (In particular, this can affect performance, as Coq spends a long time tracing through long proofs of contractibility to find the center.)  So we give a way to modify the center. *)
Definition contr_change_center {A : Type} (a : A) `{Contr A}
  : Contr A.
Proof.
  exists a.
  intros; apply path_contr.
Defined.

(** If a type is contractible, then so is its type of contractions. *)
Global Instance contr_contr `{Funext} (A : Type) `{Contr A}
  : Contr (Contr A) | 100.
Proof.
  exists _; intros [a2 c2].
  destruct (contr a2).
  apply (ap (Build_Contr _ (center A))).
  apply path_forall; intros x.
  apply path2_contr.
Defined.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrbool eqtype ssrnat.

Lemma test1 : forall a b : nat, a == b -> a == 0 -> b == 0.
Proof. move=> a b Eab Eac; congr (_ == 0) : Eac; exact: eqP Eab. Qed.

Definition arrow A B := A -> B.

Lemma test2 : forall a b : nat, a == b -> arrow (a == 0) (b == 0).
Proof. move=> a b Eab; congr (_ == 0); exact: eqP Eab. Qed.

Definition equals T (A B : T) := A = B.

Lemma test3 : forall a b : nat, a = b -> equals nat (a + b) (b + b).
Proof. move=> a b E; congr (_ + _); exact E. Qed.

Variable S : eqType.
Variable f : nat -> S.
Coercion f : nat >-> Equality.sort.

Lemma test4 : forall a b : nat, b = a -> @eq S (b + b) (a + a).
Proof. move=> a b Eba; congr (_ + _); exact:  Eba. Qed.


(* (c) Copyright 2006-2015 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
Require Import mathcomp.ssreflect.ssreflect.
From mathcomp
Require Import ssrfun ssrbool eqtype ssrnat seq choice fintype.
From mathcomp
Require Import ssralg poly ssrnum zmodp polydiv interval.

Import GRing.Theory.
Import Num.Theory.

Import Pdiv.Idomain.

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

Local Open Scope ring_scope.

Section Multiplicity.

Variable R : idomainType.
Implicit Types x y c : R.
Implicit Types p q r d : {poly R}.

(* Definition multiplicity (x : R) (p : {poly R}) : nat :=  *)
(*   (odflt ord0 (pick (fun i : 'I_(size p).+1 =>  ((('X - x%:P) ^+ i %| p))  *)
(*                                  && (~~ (('X - x%:P) ^+ i.+1 %| p))))). *)

(* Notation "'\mu_' x" := (multiplicity x) *)
(*   (at level 8, format "'\mu_' x") : ring_scope. *)

(* Lemma mu0 : forall x, \mu_x 0 = 0%N. *)
(* Proof. *)
(* by move=> x; rewrite /multiplicity; case: pickP=> //= i; rewrite !dvdp0. *)
(* Qed. *)

(* Lemma muP : forall p x, p != 0 -> *)
(*   (('X - x%:P) ^+ (\mu_x p) %| p) && ~~(('X - x%:P) ^+ (\mu_x p).+1 %| p). *)
(* Proof. *)
(* move=> p x np0; rewrite /multiplicity; case: pickP=> //= hp. *)
(* have {hp} hip: forall i, i <= size p  *)
(*     -> (('X - x%:P) ^+ i %| p) -> (('X - x%:P) ^+ i.+1 %| p). *)
(*   move=> i; rewrite -ltnS=> hi; move/negbT: (hp (Ordinal hi)).  *)
(*   by rewrite -negb_imply negbK=> /implyP. *)
(* suff: forall i, i <= size p -> ('X - x%:P) ^+ i %| p. *)
(*   move=> /(_ _ (leqnn _)) /(size_dvdp np0). *)
(*   rewrite -[size _]prednK; first by rewrite size_exp size_XsubC mul1n ltnn. *)
(*   by rewrite lt0n size_poly_eq0 expf_eq0 polyXsubC_eq0 lt0n size_poly_eq0 np0. *)
(* elim=> [|i ihi /ltnW hsp]; first by rewrite expr0 dvd1p. *)
(* by rewrite hip // ihi. *)
(* Qed. *)

(* Lemma cofactor_XsubC : forall p a, p != 0 ->  *)
(*   exists2 q : {poly R}, (~~ root q a) & p = q * ('X - a%:P) ^+ (\mu_a p). *)
(* Proof. *)
(* move=> p a np0. *)

Definition multiplicity (x : R) (p : {poly R}) :=
  if p == 0 then 0%N else sval (multiplicity_XsubC p x).

Notation "'\mu_' x" := (multiplicity x)
  (at level 8, format "'\mu_' x") : ring_scope.

Lemma mu_spec p a : p != 0 ->
  { q : {poly R} & (~~ root q a)
    & ( p = q * ('X - a%:P) ^+ (\mu_a p)) }.
Proof.
move=> nz_p; rewrite /multiplicity -if_neg.
by case: (_ p a) => m /=/sig2_eqW[q]; rewrite nz_p; exists q.
Qed.

Lemma mu0 x : \mu_x 0 = 0%N.
Proof. by rewrite /multiplicity {1}eqxx. Qed.

Lemma root_mu p x : ('X - x%:P) ^+ (\mu_x p) %| p.
Proof.
case p0: (p == 0); first by rewrite (eqP p0) mu0 expr0 dvd1p.
case: (@mu_spec p x); first by rewrite p0.
by move=> q qn0 hp //=; rewrite {2}hp dvdp_mulIr.
Qed.

(* Lemma size_exp_XsubC : forall x n, size (('X - x%:P) ^+ n) = n.+1. *)
(* Proof. *)
(* move=> x n; rewrite -[size _]prednK ?size_exp ?size_XsubC ?mul1n //. *)
(* by rewrite ltnNge leqn0 size_poly_eq0 expf_neq0 // polyXsubC_eq0. *)
(* Qed. *)

Lemma root_muN p x : p != 0 ->
  (('X - x%:P)^+(\mu_x p).+1 %| p) = false.
Proof.
move=> pn0; case: (mu_spec x pn0)=> q qn0 hp /=.
rewrite {2}hp exprS dvdp_mul2r; last first.
  by rewrite expf_neq0 // polyXsubC_eq0.
apply: negbTE; rewrite -eqp_div_XsubC; apply: contra qn0.
by move/eqP->; rewrite rootM root_XsubC eqxx orbT.
Qed.

Lemma root_le_mu p x n : p != 0 -> ('X - x%:P)^+n %| p = (n <= \mu_x p)%N.
Proof.
move=> pn0; case: leqP=> hn; last apply/negP=> hp.
  apply: (@dvdp_trans _ (('X - x%:P) ^+ (\mu_x p))); last by rewrite root_mu.
  by rewrite dvdp_Pexp2l // size_XsubC.
suff : ('X - x%:P) ^+ (\mu_x p).+1 %| p by rewrite root_muN.
by apply: dvdp_trans hp; rewrite dvdp_Pexp2l // size_XsubC.
Qed.

Lemma muP p x n : p != 0 ->
  (('X - x%:P)^+n %| p) && ~~(('X - x%:P)^+n.+1 %| p) = (n == \mu_x p).
Proof. by move=> hp0; rewrite !root_le_mu; case: (ltngtP n (\mu_x p))=> hn. Qed.

Lemma mu_gt0 p x : p != 0 -> (0 < \mu_x p)%N = root p x.
Proof. by move=> pn0; rewrite -root_le_mu// expr1 root_factor_theorem. Qed.

Lemma muNroot p x : ~~ root p x -> \mu_x p = 0%N.
Proof.
case p0: (p == 0); first by rewrite (eqP p0) rootC eqxx.
by move=> pnx0; apply/eqP; rewrite -leqn0 leqNgt mu_gt0 ?p0.
Qed.

Lemma mu_polyC c x : \mu_x (c%:P) = 0%N.
Proof.
case c0: (c == 0); first by rewrite (eqP c0) mu0.
by apply: muNroot; rewrite rootC c0.
Qed.

Lemma cofactor_XsubC_mu  x p n :
  ~~ root p x -> \mu_x (p * ('X - x%:P) ^+ n) = n.
Proof.
move=> p0; apply/eqP; rewrite eq_sym -muP//; last first.
  apply: contra p0; rewrite mulf_eq0 expf_eq0 polyXsubC_eq0 andbF orbF.
  by move/eqP->; rewrite root0.
rewrite dvdp_mulIr /= exprS dvdp_mul2r -?root_factor_theorem //.
by rewrite expf_eq0 polyXsubC_eq0 andbF //.
Qed.

Lemma mu_mul p q x : p * q != 0 ->
  \mu_x (p * q) = (\mu_x p + \mu_x q)%N.
Proof.
move=>hpqn0; apply/eqP; rewrite eq_sym -muP//.
rewrite exprD dvdp_mul ?root_mu//=.
move:hpqn0; rewrite mulf_eq0 negb_or; case/andP=> hp0 hq0.
move: (mu_spec x hp0)=> [qp qp0 hp].
move: (mu_spec x hq0)=> [qq qq0 hq].
rewrite {2}hp {2}hq exprS exprD !mulrA [qp * _ * _]mulrAC.
rewrite !dvdp_mul2r ?expf_neq0 ?polyXsubC_eq0 // -eqp_div_XsubC.
move: (mulf_neq0 qp0 qq0); rewrite -hornerM; apply: contra; move/eqP->.
by rewrite hornerM hornerXsubC subrr mulr0.
Qed.

Lemma mu_XsubC x : \mu_x ('X - x%:P) = 1%N.
Proof.
apply/eqP; rewrite eq_sym -muP; last by rewrite polyXsubC_eq0.
by rewrite expr1 dvdpp/= -{2}[_ - _]expr1 dvdp_Pexp2l // size_XsubC.
Qed.

Lemma mu_mulC c p x : c != 0 -> \mu_x (c *: p) = \mu_x p.
Proof.
move=> cn0; case p0: (p == 0); first by rewrite (eqP p0) scaler0.
by rewrite -mul_polyC mu_mul ?mu_polyC// mulf_neq0 ?p0 ?polyC_eq0.
Qed.

Lemma mu_opp p x : \mu_x (-p) = \mu_x p.
Proof.
rewrite -mulN1r -polyC1 -polyC_opp mul_polyC mu_mulC //.
by rewrite -oppr0 (inj_eq (inv_inj (@opprK _))) oner_eq0.
Qed.

Lemma mu_exp p x n : \mu_x (p ^+ n) = (\mu_x p * n)%N.
Proof.
elim: n p => [|n ihn] p; first by rewrite expr0 mu_polyC muln0.
case p0: (p == 0); first by rewrite (eqP p0) exprS mul0r mu0 mul0n.
by rewrite exprS mu_mul ?ihn ?mulnS// mulf_eq0 expf_eq0 p0 andbF.
Qed.

Lemma mu_addr p q x : p != 0 -> (\mu_x p < \mu_x q)%N ->
  \mu_x (p + q) = \mu_x p.
Proof.
move=> pn0 mupq.
have pqn0 : p + q != 0.
  move: mupq; rewrite ltnNge; apply: contra.
  by rewrite -[q]opprK subr_eq0; move/eqP->; rewrite opprK mu_opp leqnn.
have qn0: q != 0 by move: mupq; apply: contraL; move/eqP->; rewrite mu0 ltn0.
case: (mu_spec x pn0)=> [qqp qqp0] hp.
case: (mu_spec x qn0)=> [qqq qqq0] hq.
rewrite hp hq -(subnK (ltnW mupq)).
rewrite mu_mul ?mulf_eq0; last first.
  rewrite expf_eq0 polyXsubC_eq0 andbF orbF.
  by apply: contra qqp0; move/eqP->; rewrite root0.
rewrite mu_exp mu_XsubC mul1n [\mu_x qqp]muNroot // add0n.
rewrite exprD mulrA -mulrDl mu_mul; last first.
  by rewrite mulrDl -mulrA -exprD subnK 1?ltnW // -hp -hq.
rewrite muNroot ?add0n ?mu_exp ?mu_XsubC ?mul1n //.
rewrite rootE !hornerE horner_exp hornerXsubC subrr.
by rewrite -subnSK // subnS exprS mul0r mulr0 addr0.
Qed.

Lemma mu_addl p q x : q != 0 -> (\mu_x p > \mu_x q)%N ->
  \mu_x (p + q) = \mu_x q.
Proof. by move=> q0 hmu; rewrite addrC mu_addr. Qed.

Lemma mu_div p x n : (n <= \mu_x p)%N ->
  \mu_x (p %/ ('X - x%:P) ^+ n) = (\mu_x p - n)%N.
Proof.
move=> hn.
case p0: (p == 0); first by rewrite (eqP p0) div0p mu0 sub0n.
case: (@mu_spec p x); rewrite ?p0 // => q hq hp.
rewrite {1}hp -{1}(subnK hn) exprD mulrA.
rewrite Pdiv.IdomainMonic.mulpK; last by apply: monic_exp; apply: monicXsubC.
rewrite mu_mul ?mulf_eq0 ?expf_eq0 ?polyXsubC_eq0 ?andbF ?orbF; last first.
  by apply: contra hq; move/eqP->; rewrite root0.
by rewrite mu_exp muNroot // add0n mu_XsubC mul1n.
Qed.

End Multiplicity.

Notation "'\mu_' x" := (multiplicity x)
  (at level 8, format "'\mu_' x") : ring_scope.

Section PolyrealIdomain.

 (*************************************************************************)
 (* This should be replaced by a 0-characteristic condition + integrality *)
 (* and merged into poly and polydiv                                      *)
 (*************************************************************************)

Variable R : realDomainType.

Lemma size_deriv (p : {poly R}) : size p^`() = (size p).-1.
Proof.
have [lep1|lt1p] := leqP (size p) 1.
  by rewrite {1}[p]size1_polyC // derivC size_poly0 -subn1 (eqnP lep1).
rewrite size_poly_eq // mulrn_eq0 -subn2 -subSn // subn2.
by rewrite lead_coef_eq0 -size_poly_eq0 -(subnKC lt1p).
Qed.

Lemma derivn_poly0 : forall (p : {poly R}) n, (size p <= n)%N = (p^`(n) == 0).
Proof.
move=> p n; apply/idP/idP.
   move=> Hpn; apply/eqP; apply/polyP=>i; rewrite coef_derivn.
   rewrite nth_default; first by rewrite mul0rn coef0.
   by apply: leq_trans Hpn _; apply leq_addr.
elim: n {-2}n p (leqnn n) => [m | n ihn [| m]] p.
- by rewrite leqn0; move/eqP->; rewrite derivn0 leqn0 -size_poly_eq0.
- by move=> _; apply: ihn; rewrite leq0n.
- rewrite derivSn => hmn hder; case e: (size p) => [|sp] //.
  rewrite -(prednK (ltn0Sn sp)) [(_.-1)%N]lock -e -lock -size_deriv ltnS.
  exact: ihn.
Qed.

Lemma mu_deriv : forall x (p : {poly R}), root p x ->
  \mu_x (p^`()) = (\mu_x p - 1)%N.
Proof.
move=> x p px0; have [-> | nz_p] := eqVneq p 0; first by rewrite derivC mu0.
have [q nz_qx Dp] := mu_spec x nz_p.
case Dm: (\mu_x p) => [|m]; first by rewrite Dp Dm mulr1 (negPf nz_qx) in px0.
rewrite subn1 Dp Dm !derivCE exprS mul1r mulrnAr -mulrnAl mulrA -mulrDl.
rewrite cofactor_XsubC_mu // rootE !(hornerE, hornerMn) subrr mulr0 add0r.
by rewrite mulrn_eq0.
Qed.

Lemma mu_deriv_root : forall x (p : {poly R}), p != 0 -> root p x ->
  \mu_x p  = (\mu_x (p^`()) + 1)%N.
Proof.
by move=> x p p0 rpx; rewrite mu_deriv // subn1 addn1 prednK // mu_gt0.
Qed.

End PolyrealIdomain.


From Hammer Require Import Hammer.

Require Import QArith_base Equalities Orders OrdersTac.

Local Open Scope Q_scope.

Module Q_as_DT <: DecidableTypeFull.
Definition t := Q.
Definition eq := Qeq.
Definition eq_equiv := Q_Setoid.
Definition eqb := Qeq_bool.
Definition eqb_eq := Qeq_bool_iff.

Include BackportEq.
Include HasEqBool2Dec.

End Q_as_DT.

Module Q_as_OT <: OrderedTypeFull.
Include Q_as_DT.
Definition lt := Qlt.
Definition le := Qle.
Definition compare := Qcompare.

Instance lt_strorder : StrictOrder Qlt.
Proof. hammer_hook "QOrderedType" "QOrderedType.Q_as_OT.lt_strorder".   split; [ exact Qlt_irrefl | exact Qlt_trans ]. Qed.

Instance lt_compat : Proper (Qeq==>Qeq==>iff) Qlt.
Proof. hammer_hook "QOrderedType" "QOrderedType.Q_as_OT.lt_compat".   auto with *. Qed.

Definition le_lteq := Qle_lteq.
Definition compare_spec := Qcompare_spec.

End Q_as_OT.

Module QOrder := OTF_to_OrderTac Q_as_OT.
Ltac q_order := QOrder.order.


Require Import ExtLib.Structures.Monoid.

Set Implicit Arguments.
Set Strict Implicit.

Section Sets.
  Variable S : Type.
  Variable T : Type.

  Class DSet : Type :=
  { contains   : T -> S -> bool
  ; empty      : S
  ; singleton  : T -> S
  ; union      : S -> S -> S
  ; filter     : (T -> bool) -> S -> S
  ; intersect  : S -> S -> S
  ; difference : S -> S -> S
  ; subset     : S -> S -> bool
    (** point-wise **)
  ; add        : T -> S -> S
  ; remove     : T -> S -> S
  }.

  Variable DS : DSet.
  Variable eqT : T -> T -> Prop.

  Class DSet_Laws : Type :=
  { DSet_WF : S -> Prop
  ; empty_WF : DSet_WF empty
  ; singleton_WF : forall x, DSet_WF (singleton x)
  ; union_WF : forall s s', DSet_WF s -> DSet_WF s' -> DSet_WF (union s s')
  ; filter_WF : forall s f, DSet_WF s -> DSet_WF (filter f s)
  ; intersect_WF : forall s s', DSet_WF s -> DSet_WF s' -> DSet_WF (intersect s s')
  ; difference_WF : forall s s', DSet_WF s -> DSet_WF s' -> DSet_WF (difference s s')
  ; add_WF : forall s x, DSet_WF s -> DSet_WF (add x s)
  ; remove_WF : forall s x, DSet_WF s -> DSet_WF (remove x s)

  ; empty_not_contains : forall t, contains t empty = false
  ; singleton_contains : forall t u,
    contains t (singleton u) = true <-> eqT t u
  ; union_contains     : forall s s',
    DSet_WF s -> DSet_WF s' ->
    forall x, orb (contains x s) (contains x s') = contains x (union s s')
  ; intersect_contains : forall s s',
    DSet_WF s -> DSet_WF s' ->
    forall x, andb (contains x s) (contains x s') = contains x (intersect s s')
  ; difference_contains : forall s s',
    DSet_WF s -> DSet_WF s' ->
    forall x, andb (contains x s) (negb (contains x s')) = contains x (difference s s')
  ; subset_contains    : forall s s',
    DSet_WF s -> DSet_WF s' ->
    subset s s' = true <->
    (forall x, contains x s = true -> contains x s' = true)

  ; add_contains       : forall s x, DSet_WF s ->
    contains x (add x s) = true
  ; add_contains_not   : forall s x y, DSet_WF s ->
    ~eqT x y -> contains x (add y s) = contains x s
  ; remove_contains    : forall s x, DSet_WF s ->
    contains x (remove x s) = false
  ; remove_contains_not : forall s x y, DSet_WF s ->
    ~eqT x y -> contains x (remove y s) = contains x s
  }.

End Sets.

Arguments contains {S} {T} {_} _ _.
Arguments empty {S} {T} {_}.
Arguments singleton {S} {T} {_} _.
Arguments union {S} {T} {_} _ _.
Arguments intersect {S} {T} {_} _ _.
Arguments difference {S} {T} {_} _ _.
Arguments subset {S} {T} {_} _ _.
Arguments add {S} {T} {_} _ _.
Arguments remove {S} {T} {_} _ _.
Arguments filter {S} {T} {_} _ _.

Section monoid.
  Variable S : Type.
  Context {T : Type}.
  Context {set : DSet S T}.

  Definition Monoid_set_union : Monoid S :=
  {| monoid_plus := union
   ; monoid_unit := empty
  |}.
End monoid.


(*
Parts of this file are copied and modified from the Coq Demos of the lecture Semantics at UdS:
http://www.ps.uni-saarland.de/courses/sem-ws17/confluence.v
 *)

Set Implicit Arguments.
Require Import Morphisms FinFun ConstructiveEpsilon.
From Undecidability.HOU Require Import std.tactics std.decidable std.misc std.ars.basic std.ars.confluence.
Import ArsInstances.
Section Evaluator.

  Variables (X: Type) (R: X -> X -> Prop) (rho: X -> X).

  Definition red_fun rho :=
    (forall x, star R x (rho x)) /\
    (forall x y, evaluates R x y -> exists n, it n rho x = y).

  Variables (red: red_fun rho).

  Fact red_fun_fp x :
    Normal R x -> rho x = x.
  Proof using red.
    intros H. symmetry.
    eapply Normal_star_stops; eauto.
    apply red.
  Qed.

  Fact red_fun_fp_it x n :
    Normal R x -> it n rho x = x.
  Proof using red.
    intros H.
    induction n as [|n IH]; cbn.
    - reflexivity.
    - rewrite IH. apply red_fun_fp, H.
  Qed.

  Variable (delta: Dec1 (Normal R)).

  Fixpoint E n x : option X :=
    match n with
    | 0 => None
    | S n' => if delta x then Some x else E n' (rho x)
    end.

  Fact E_S n x :
    E (S n) x = if delta x then Some x else E n (rho x).
  Proof.
    reflexivity.
  Qed.

  Fact E_it x n :
    Normal R (it n rho x) -> E (S n) x = Some (it n rho x).
  Proof using red.
    revert x.
    induction n as [|n IH]; intros x.
    - cbn. destruct (delta x) as [H|H]; tauto.
    - cbn [it]. rewrite it_commute. intros H1 % IH.
      rewrite E_S.
      destruct (delta x) as [H|H]; [|exact H1].
      rewrite red_fun_fp; [|exact H].
      rewrite red_fun_fp_it; [|exact H].
      reflexivity.
  Qed.

  Fact E_correct x y :
    evaluates R x y <-> exists n, E n x = Some y.
  Proof using red.
    split.
    - intros H. generalize H. intros [n <-] % red.
      exists (S n). apply E_it, H.
    - intros [n H]; revert x H.
      induction n as [|n IH]; cbn; intros x.
      + discriminate.
      + destruct (delta x) as [H|H]; intros H1.
        * assert (x=y) as <- by congruence.
          split; auto.
        * apply IH in H1 as [H1 H2].
          split; [|exact H2].
          rewrite <- H1. apply red.
  Qed.

  Fact E_unique n m x y1 y2:
    E n x = Some y1 -> E m x = Some y2 -> y1 = y2.
  Proof.
    induction n in x, m |-*; destruct m; try discriminate.
    cbn; destruct delta; eauto; now intros [= ->] [= ->].
  Qed.

  Fact E_stops n x:
    Normal R x -> E (S n) x = Some x.
  Proof. cbn; destruct delta; intuition. Qed.

  Fact E_step n x y:
    E n x = Some y -> E (S n) x = Some y.
  Proof.
    induction n in x, y |-*; cbn; try discriminate.
    destruct (delta x); eauto.
  Qed.

  Fact E_monotone n m x y:
    n <= m ->  E n x = Some y -> E m x = Some y.
  Proof.
    induction 1 in x, y |-*; eauto using E_step.
  Qed.

End Evaluator.

Section EvaluatorTakahashi.
  Variable (X: Type) (R S: X -> X -> Prop).
  Hypothesis (D: Dec1 (Normal R)).

  Variable (rho: X -> X).
  Hypotheses (tf: tak_fun S rho).
  Hypotheses (refl: Reflexive S) (H1: subrelation R S)
             (H2: subrelation S (star R)).

  Lemma rho_evaluates:
    forall x y : X, evaluates R x y -> exists n : nat, it n rho x = y.
  Proof using H1 H2 S tf.
    intros x y [H3 H4].
    eapply sandwich_equiv with (S := S) in H3; eauto.
    eapply tak_cofinal in H3; eauto.
    destruct H3 as [n H3]; exists n.
    eapply sandwich_equiv with (S := S) in H3; eauto.
    now eapply Normal_star_stops in H3.
  Qed.

  Lemma red_fun_rho: red_fun R rho.
  Proof using H1 H2 S tf refl.
    split.
    - intros x. eapply H2, tf, refl.
    - eapply rho_evaluates.
  Qed.

  Lemma evaluates_E s:
    (exists t, evaluates R s t) -> exists n, exists t, E rho D n s = Some t.
  Proof using H1 H2 S tf refl.
    intros [t H]; destruct (E_correct red_fun_rho D s t) as [H3 _].
    eapply H3 in H. destruct H as [n]. exists n. now (exists t).
  Qed.

  Instance decidable_E s n:
    Dec (exists t, E rho D n s = Some t).
  Proof.
    destruct (E rho D n s).
    - left; eexists; eauto.
    - right; intros []; discriminate.
  Qed.

  Lemma E_evaluates (s: X):
    { n: nat | exists t, E rho D n s = Some t } -> { t | evaluates R s t }.
  Proof using H1 H2 S tf refl.
    intros [n H].
    destruct (E rho D n s) as [t|] eqn: H3.
    - exists t. eapply E_correct; eauto using red_fun_rho.
    - exfalso. destruct H. discriminate.
  Qed.

  Lemma compute_evaluation (s: X):
    (exists t, evaluates R s t) -> { t | evaluates R s t }.
  Proof using H1 H2 S tf refl rho D.
    intros.
    eapply E_evaluates.
    eapply constructive_indefinite_ground_description
      with (f := id) (g := id); eauto.
    - eapply decidable_E.
    - eapply evaluates_E, H.
  Qed.

End EvaluatorTakahashi.


(** Copyright (c) 2018 by Swirlds, Inc.
   Implemented by Karl Crary.
*)

Require Import Nat.
Require Import Bool.
Require Import Omega.
Require Import List.
Require Import Sorting.
Require Import Permutation.

Require Import Tact.
Require Import Decide.
Require Import Relation.
Require Import Weight.
Require Import Calculate.
Require Import Majority.

Lemma Forall_app :
  forall (A : Type) (P : A -> Prop) (l m : list A),
    Forall P l
    -> Forall P m
    -> Forall P (l ++ m).
Proof.
intros A P l m Hl Hm.
apply Forall_forall.
intros x Hx.
so (in_app_or _#4 Hx) as [H | H].
  {
  apply (Forall_forall _#3 andel Hl); auto.
  }

  {
  apply (Forall_forall _#3 andel Hm); auto.
  }
Qed.

Lemma NoDup_app_invert :
  forall T (l1 l2 : list T),
    NoDup (l1 ++ l2)
    -> NoDup l1 /\ NoDup l2.
Proof.
intros T l1 l2 Hdist.
revert Hdist.
induct l1.

(* nil *)
{
intros Hdist.
cbn in Hdist.
split; auto.
apply NoDup_nil.
}

(* cons *)
{
intros x l1 IH Hdist.
rewrite <- app_comm_cons in Hdist.
invertc Hdist.
intros Hnin Hdist.
so (IH Hdist) as (Hdist1 & Hdist2).
split; auto.
apply NoDup_cons; auto.
contradict Hnin.
apply in_or_app; left; auto.
}
Qed.

(* Never actually use this. *)
Lemma sorted_unique :
  forall (U : Type) (R : U -> U -> Prop),
    order U R
    -> (forall x y, R x y \/ R y x)
    -> (forall x y, decidable (R x y))
    -> forall (l m : list U),
         Sorted R l
         -> Sorted R m
         -> Permutation l m
         -> l = m.
Proof.
intros U R Hord Htotal Hdec l m Hl Hm Hlm.
revert m Hl Hm Hlm.
induct l.

(** nil *)
{
intros m _ _ Hperm.
symmetry.
apply Permutation_nil; auto.
}

(** cons *)
{
intros x l' IH m Hl Hm Hlm.
destruct m as [| y m'].
  {
  exfalso.
  symmetry in Hlm.
  eapply Permutation_nil_cons; eauto.
  }
so (Sorted_inv _#4 Hl) as (Hl' & _).
so (Sorted_inv _#4 Hm) as (Hm' & _).
assert (x = y).
  {
  destruct (Permutation_in _ Hlm (or_introl (eq_refl _))) as [| Hinx].
    {
    subst y.
    reflexivity.
    }
  destruct (Permutation_in _ (Permutation_sym Hlm) (or_introl (eq_refl _))) as [| Hiny].
    {
    subst y.
    reflexivity.
    }
  apply (ord_antisym U R); auto.
    {
    exact (Forall_forall _#3 andel (@Sorted_extends _ _ (ord_trans _ _ Hord) _ _ Hl) _ Hiny).
    }

    {
    exact (Forall_forall _#3 andel (@Sorted_extends _ _ (ord_trans _ _ Hord) _ _ Hm) _ Hinx).
    }
  }
subst y.
f_equal.
apply IH; auto.
eapply Permutation_cons_inv; eauto.
}
Qed.

Lemma map_sorted :
  forall (T U : Type) (R : U -> U -> Prop) (f : T -> U) (l : list T),
    Sorted (fun x y => R (f x) (f y)) l
    -> Sorted R (map f l).
Proof.
intros S U R f l Hsorted.
apply Sorted_LocallySorted_iff.
so (Sorted_LocallySorted_iff _ _ andel Hsorted) as H.
clear Hsorted.
induct H.

(* nil *)
{
apply LSorted_nil.
}

(* cons1 *)
{
intros x.
cbn.
apply LSorted_cons1.
}

(* consn *)
{
intros x y l _ IH Hxy.
cbn in IH.
cbn.
apply LSorted_consn; auto.
}
Qed.

Lemma sorted_impl :
  forall T R R' l,
    inclusion T R R'
    -> Sorted R l
    -> Sorted R' l.
Proof.
intros T R R' l Hincl Hl.
apply Sorted_LocallySorted_iff.
so (Sorted_LocallySorted_iff _#3 andel Hl) as H.
clear Hl.
induct H; eauto using LocallySorted.
Qed.

Lemma strongly_sorted_app_inv :
  forall T (R : T -> T -> Prop) (l m : list T),
    StronglySorted R (l ++ m)
    -> forall x y,
         In x l
         -> In y m
         -> R x y.
Proof.
intros T R l m Hsorted x y Hx Hy.
revert Hsorted x Hx.
induct l.

(* nil *)
{
intros _ x Hx.
destruct Hx.
}

(* cons *)
{
intros z l IH Hsorted x Hx.
rewrite <- app_comm_cons in Hsorted.
invertc Hsorted.
intros Hsorted Hfirst.
destruct Hx as [Heq | Hx].
  {
  subst z.
  refine (Forall_forall _#3 andel Hfirst _ _).
  apply in_or_app.
  right; auto.
  }

  {
  apply IH; auto.
  }
}
Qed.

Lemma strongly_sorted_remove_middle :
  forall T (R : T -> T -> Prop) (l : list T) (x : T) (m : list T),
    StronglySorted R (l ++ x :: m)
    -> StronglySorted R (l ++ m).
Proof.
intros T R l x m.
induct l.

(* nil *)
{
intros Hsorted.
cbn.
cbn in Hsorted.
invert Hsorted; auto.
}

(* cons *)
{
intros y l IH Hsorted.
rewrite <- app_comm_cons in Hsorted.
rewrite <- app_comm_cons.
invertc Hsorted.
intros Hsorted Hfirst.
apply SSorted_cons; auto.
apply Forall_forall.
intros z Hz.
exploit (Forall_forall _#3 andel Hfirst z); auto.
apply in_or_app.
so (in_app_or _#4 Hz) as [H | H].
  {
  left; auto.
  }

  {
  right; right; auto.
  }
}
Qed.

Module Type WEIGHT_AND_VALUE.

Parameter T : Type.
Parameter U : Type.

Axiom eqT_decide : forall (x y : T), decidable (x = y).

Parameter wt : T -> nat.
Parameter vl : T -> U.

Axiom wt_pos : forall x, wt x > 0.

Parameter lebU : U -> U -> bool.

Axiom lebU_order : order U (fun x y => lebU x y = true).
Axiom lebU_total : forall x y, lebU x y = true \/ lebU y x = true.

Parameter inh : U.

End WEIGHT_AND_VALUE.

Module MedianFun (Import X:WEIGHT_AND_VALUE).

Module TOrder.

Definition t := T.

Definition leb (x y : T) := X.lebU (vl x) (vl y).

Lemma leb_total : forall (x y : T), leb x y = true \/ leb y x = true.
Proof.
intros x y.
unfold leb.
apply lebU_total.
Qed.

End TOrder.

Module TSort := Sort TOrder.

Definition leU (x y : U) : Prop := lebU x y = true.
Definition leT (x y : T) : Prop := leU (vl x) (vl y).

(* Strict select is easier to work with for some purposes:
   we don't need to deal with or rule out zero weights.
*)
Fixpoint sselect (l : list T) (n : nat) {struct l} : U :=
  match l with
  | nil => X.inh
  | cons x l' =>
      if ltb n (wt x) then
        vl x
      else
        sselect l' (n - wt x)
  end.

Fixpoint select (l : list T) (n : nat) {struct l} : U :=
  match l with
  | nil => X.inh
  | cons x l' =>
      if leb n (wt x) then
        vl x
      else
        select l' (n - wt x)
  end.

Definition median (l : list T) : U :=
  select (TSort.sort l) (S (sumweight wt l) / 2).

Lemma tsort_sorted :
  forall l,
    Sorted leT (TSort.sort l).
Proof.
intro l.
(** The lemmas Sorted_sort and LocallySorted_sort are reversed in the library. *)
refine (sorted_impl _#4 _ (TSort.LocallySorted_sort _)).
intros x y Hxy.
exact Hxy.
Qed.

Lemma leU_order : order U leU.
Proof.
exact lebU_order.
Qed.

Lemma leU_total : forall x y, leU x y \/ leU y x.
Proof.
exact lebU_total.
Qed.

Lemma leU_decide : forall x y, decidable (leU x y).
Proof.
intros x y.
unfold leU.
destruct (bool_dec (lebU x y) true); [left | right]; auto.
Qed.

Lemma eqU_decide : forall (x y : U), decidable (x = y).
Proof.
intros x y.
so (leU_decide x y) as [Hxy | Hnxy].
  {
  so (leU_decide y x) as [Hyx | Hyx].
    {
    left.
    apply (ord_antisym _ _ lebU_order); auto.
    }

    {
    right.
    intro.
    subst y.
    contradiction.
    }
  }
right.
intro.
subst y.
destruct Hnxy.
apply (ord_refl _ _ lebU_order).
Qed.

Lemma sselect_prefix :
  forall l m n x,
    Forall (fun y => x = vl y) l
    -> n < sumweight wt l
    -> sselect (l ++ m) n = x.
Proof.
intros l m n x Hl Hle.
revert n Hle.
induct Hl.

(* nil *)
{
intros n Hlt.
cbn in Hlt.
omega.
}

(* cons *)
{
intros y l -> _ IH n Hlt.
rewrite <- app_comm_cons.
cbn [sselect].
remember (ltb n (wt y)) as b eqn:Heqb.
destruct b; auto.
apply IH.
symmetry in Heqb.
so (Nat.ltb_ge _ _ andel Heqb).
rewrite -> sumweight_cons in Hlt.
omega.
}
Qed.

Lemma sselect_cons_r :
  forall (x : T) (l : list T) n,
    sselect (x :: l) (wt x + n) = sselect l n.
Proof.
intros x l n.
cbn [sselect].
remember (ltb (wt x + n) (wt x)) as b eqn:Heqb.
destruct b.
  {
  symmetry in Heqb.
  so (Nat.ltb_lt _ _ andel Heqb).
  omega.
  }

  {
  f_equal.
  omega.
  }
Qed.

Lemma sselect_app_r :
  forall (l m : list T) n,
    sselect (l ++ m) (sumweight wt l + n) = sselect m n.
Proof.
intros l m.
induct l.

(* nil *)
{
intro n.
cbn.
reflexivity.
}

(* cons *)
{
intros x l IH n.
rewrite <- app_comm_cons.
rewrite -> sumweight_cons.
rewrite <- Nat.add_assoc.
rewrite <- IH.
apply sselect_cons_r.
}
Qed.

Lemma sselect_lift :
  forall (l : list T) (x : T) (m : list T),
    Forall (fun y => vl x = vl y) l
    -> forall n, sselect (l ++ x :: m) n = sselect (x :: l ++ m) n.
Proof.
intros l x m Hl n.
so (lt_dec n (sumweight wt l + wt x)) as [Hlt | Hnlt].
  {
  transitivity (vl x).
    {
    replace (l ++ x :: m) with ((l ++ x :: nil) ++ m).
    2:{
      rewrite <- app_assoc.
      cbn.
      reflexivity.
      }
    apply sselect_prefix.
      {
      apply Forall_app; auto.
      }

      {
      rewrite -> sumweight_app.
      rewrite -> sumweight_cons.
      omega.
      }
    }

    {
    symmetry.
    rewrite -> app_comm_cons.
    apply sselect_prefix.
      {
      apply Forall_cons; auto.
      }

      {
      rewrite -> sumweight_cons.
      omega.
      }
    }
  }

  {
  transitivity (sselect m (n - sumweight wt l - wt x)).
    {
    replace n with (sumweight wt l + (wt x + (n - sumweight wt l - wt x))) at 1 by omega.
    rewrite -> sselect_app_r.
    rewrite -> sselect_cons_r.
    reflexivity.
    }

    {
    symmetry.
    replace n with (wt x + (sumweight wt l + (n - sumweight wt l - wt x))) at 1 by omega.
    rewrite -> sselect_cons_r.
    rewrite -> sselect_app_r.
    reflexivity.
    }
  }
Qed.

Lemma Transitive_leT : Relations_1.Transitive leT.
Proof.
intros x y z Hxy Hyz.
unfold leT in *.
eapply (ord_trans _ _ leU_order); eauto.
Qed.

Lemma sselect_unique :
  forall (l m : list T) (n : nat),
    Sorted leT l
    -> Sorted leT m
    -> Permutation l m
    -> sselect l n = sselect m n.
Proof.
intros l m n Hl Hm Hperm.
so (Sorted_StronglySorted Transitive_leT Hl) as Hl'.
so (Sorted_StronglySorted Transitive_leT Hm) as Hm'.
clear Hl Hm.
revert m n Hl' Hm' Hperm.
induct l.

(* nil *)
{
intros m n Hl Hm Hperm.
rewrite -> (Permutation_nil Hperm).
reflexivity.
}

(* cons *)
{
intros x l IH m n Hxl Hm Hperm.
so (Permutation_in _#4 Hperm (or_introl (eq_refl _))) as Hin.
so (in_split _#3 Hin) as (m1 & m2 & ->).
clear Hin.
so (Permutation_cons_app_inv _#5 Hperm) as Hperm'.
rewrite -> sselect_lift.
2:{
  apply Forall_forall.
  intros y Hy.
  apply (ord_antisym _ _ leU_order).
    {
    change (leT x y).
    so (StronglySorted_inv Hxl) as (_ & Hall).
    refine (Forall_forall _#3 andel Hall _ _).
    apply (@Permutation_in _ (m1 ++ m2)).
      {
      apply Permutation_sym; auto.
      }

      {
      apply in_or_app.
      left; auto.
      }
    }

    {
    change (leT y x).
    apply (strongly_sorted_app_inv _#4 Hm); auto.
    left; auto.
    }
  }
cbn [sselect].
set (b := ltb n (wt x)).
destruct b; auto.
so (StronglySorted_inv _#4 Hxl) as (Hl & _).
apply IH; auto.
eapply strongly_sorted_remove_middle; eauto.
}
Qed.

Lemma sselect_eq_select :
  forall l n,
    sselect l n = select l (S n).
Proof.
intros l.
induct l.

(* nil *)
{
intro n.
cbn.
reflexivity.
}

(* cons *)
{
intros x l IH n.
cbn [select sselect].
remember (ltb n (wt x)) as b eqn:Heq.
destruct b.
  {
  replace (leb (S n) (wt x)) with true; auto.
  }

  {
  replace (leb (S n) (wt x)) with false; auto.
  replace (S n - wt x) with (S (n - wt x)); auto.
  symmetry in Heq.
  so (Nat.ltb_ge _ _ andel Heq).
  omega.
  }
}
Qed.

Lemma select_unique :
  forall (l m : list T) (n : nat),
    Sorted leT l
    -> Sorted leT m
    -> Permutation l m
    -> select l n = select m n.
Proof.
intros l m n Hl Hm Hperm.
destruct n as [| n].
2:{
  rewrite <- !sselect_eq_select.
  apply sselect_unique; auto.
  }
destruct l as [| x l].
  {
  destruct m as [| y m].
    {
    cbn.
    reflexivity.
    }

    {
    destruct (Permutation_nil_cons _#3 Hperm).
    }
  }

  {
  destruct m as [| y m].
    {
    destruct (Permutation_nil_cons _#3 (Permutation_sym _#3 Hperm)).
    }

    {
    cbn.
    apply (ord_antisym _ _ leU_order).
      {
      assert (In y (cons x l)) as Hin.
        {
        apply (@Permutation_in _ (cons y m)); auto using Permutation_sym.
        left; auto.
        }
      destruct Hin as [| Hin].
        {
        subst y.
        apply (ord_refl _ _ leU_order).
        }

        {
        so (@Sorted_extends _ _ Transitive_leT _ _ Hl) as H.
        exact (Forall_forall _#3 andel H _ Hin).
        }
      }

      {
      assert (In x (cons y m)) as Hin.
        {
        apply (@Permutation_in _ (cons x l)); auto.
        left; auto.
        }
      destruct Hin as [| Hin].
        {
        subst y.
        apply (ord_refl _ _ leU_order).
        }

        {
        so (@Sorted_extends _ _ Transitive_leT _ _ Hm) as H.
        exact (Forall_forall _#3 andel H _ Hin).
        }
      }
    }
  }
Qed.

Lemma median_unique :
  forall (l m : list T),
    Permutation l m
    -> median l = median m.
Proof.
intros l m Hlm.
unfold median.
replace (sumweight wt m) with (sumweight wt l).
2:{
  apply permutation_weight; auto.
  }
apply select_unique; auto using tsort_sorted.
apply (@Permutation_trans _ _ l).
  {
  apply Permutation_sym.
  apply TSort.Permuted_sort.
  }
apply (@Permutation_trans _ _ m); auto.
apply TSort.Permuted_sort.
Qed.

Lemma select_spec :
  forall (l : list T) (n : nat),
    0 < n
    -> n <= sumweight wt l
    -> exists l1 x l2,
         l = l1 ++ x :: l2
         /\ select l n = vl x
         /\ sumweight wt l1 < n
         /\ n <= sumweight wt (l1 ++ x :: nil).
Proof.
intros l.
induct l.

(* nil *)
{
intros n Hlo Hhi.
exfalso.
cbn in Hhi.
omega.
}

(* cons *)
{
intros x l IH n Hlo Hhi.
cbn [select].
remember (leb n (wt x)) as b eqn:Heqb.
symmetry in Heqb.
destruct b.
  {
  exists nil, x, l.
  do2 3 split; auto.
  cbn.
  so (leb_complete _ _ Heqb).
  omega.
  }

  {
  exploit (IH (n - wt x)) as H.
    {
    so (leb_complete_conv _ _ Heqb).
    omega.
    }

    {
    rewrite -> sumweight_cons in Hhi.
    omega.
    }
  destruct H as (l1 & y & l2 & Heq & Hselect & Hlo' & Hi').
  exists (cons x l1), y, l2.
  do2 3 split; auto.
    {
    rewrite <- app_comm_cons.
    f_equal.
    auto.
    }

    {
    rewrite -> sumweight_cons.
    omega.
    }

    {
    rewrite <- app_comm_cons.
    rewrite -> sumweight_cons.
    omega.
    }
  }
}
Qed.

Lemma median_spec :
  forall (l : list T),
    length l > 0
    -> NoDup l
    -> exists x m n,
         median l = vl x
         /\ In x l
         /\ weight wt (fun y => In y l /\ leT y x) m
         /\ S (sumweight wt l) / 2 <= m
         /\ weight wt (fun y => In y l /\ leT x y) n
         /\ S (sumweight wt l) / 2 <= n.
Proof.
intros l Hnonempty Hdist.
set (n := S (sumweight wt l) / 2).
so (permutation_weight _ wt _ _ (TSort.Permuted_sort l)) as Heql.
exploit (select_spec (TSort.sort l) n) as H.
  {
  (* The result is also true if n=0, but we skip the special case since it's easy enough
     to show that n > 0.
  *)
  destruct l as [| x l].
    {
    exfalso.
    cbn in Hnonempty.
    omega.
    }
  subst n.
  apply Nat.div_str_pos.
  split; auto.
  rewrite -> sumweight_cons.
  so (wt_pos x).
  omega.
  }

  {
  rewrite <- Heql.
  remember (sumweight wt l) as m eqn:H.
  clear H.
  subst n.
  apply atleasthalf_le_all.
  }
destruct H as (l1 & x & l2 & Heq & Hselect & Hlower & Hupper).
rewrite -> Heq in Heql.
exploit (weight_subset _ wt (fun y => In y l /\ leT y x) (fun y => In y l) (sumweight wt l)) as H.
  {
  intros y Hiny.
  apply dec_and.
    {
    left; auto.
    }
  unfold leT.
  apply leU_decide.
  }

  {
  intros y (Hy & _).
  auto.
  }

  {
  apply weight_In; auto.
  }
destruct H as (n1 & Hweightn1 & _).
exploit (weight_subset _ wt (fun y => In y l /\ leT x y) (fun y => In y l) (sumweight wt l)) as H.
  {
  intros y Hiny.
  apply dec_and.
    {
    left; auto.
    }
  unfold leT.
  apply leU_decide.
  }

  {
  intros y (Hy & _).
  auto.
  }

  {
  apply weight_In; auto.
  }
destruct H as (n2 & Hweightn2 & _).
exists x, n1, n2.
do2 5 split; auto.
  {
  apply (@Permutation_in _ (TSort.sort l)).
    {
    apply Permutation_sym.
    apply TSort.Permuted_sort.
    }
  rewrite -> Heq.
  apply in_or_app; right.
  left; auto.
  }

  {
  refine (le_trans _#3 Hupper _).
  refine (weight_subset' _#6 _ _ (weight_In _#3 _) Hweightn1).
    {
    intros y _.
    apply dec_In.
    exact eqT_decide.
    }

    {
    intros y Hy.
    split.
      {
      apply (Permutation_in _#4 (Permutation_sym _#3 (TSort.Permuted_sort l))).
      rewrite -> Heq.
      apply in_or_app.
      so (in_app_or _#4 Hy) as [Hy' | Hy'].
        {
        left; auto.
        }

        {
        destruct Hy' as [H | H].
          {
          subst y.
          right; left; auto.
          }

          {
          destruct H.
          }
        }
      }

      {
      so (in_app_or _#4 Hy) as [Hy' | Hy'].
        {
        apply (strongly_sorted_app_inv _ _ l1 (x :: l2)); auto.
          {
          apply Sorted_StronglySorted; auto using Transitive_leT.
          rewrite <- Heq.
          apply tsort_sorted.
          }

          {
          left; auto.
          }
        }

        {
        destruct Hy' as [H | H].
          {
          subst y.
          unfold leT.
          apply ord_refl.
          exact leU_order.
          }

          {
          destruct H.
          }
        }
      }
    }

    {
    refine (NoDup_app_invert _ _ l2 _ andel).
    rewrite <- app_assoc.
    cbn.
    rewrite <- Heq.
    apply (Permutation_NoDup _#3 (TSort.Permuted_sort l)); auto.
    }
  }

  {
  assert (n <= sumweight wt (x :: l2)) as Hupper'.
    {
    rewrite -> sumweight_cons.
    replace (wt x + sumweight wt l2) with (sumweight wt l - sumweight wt l1).
    2:{
      rewrite -> Heql.
      rewrite -> sumweight_app.
      rewrite -> sumweight_cons.
      omega.
      }
    apply under_half_complement.
    exact Hlower.
    }
  refine (le_trans _#3 Hupper' _).
  refine (weight_subset' _#6 _ _ (weight_In _#3 _) Hweightn2).
    {
    intros y _.
    apply dec_In.
    exact eqT_decide.
    }

    {
    intros y Hy.
    split.
      {
      apply (Permutation_in _#4 (Permutation_sym _#3 (TSort.Permuted_sort l))).
      rewrite -> Heq.
      apply in_or_app.
      right; auto.
      }

      {
      destruct Hy as [Hy | Hy].
        {
        subst y.
        unfold leT.
        apply ord_refl.
        exact leU_order.
        }

        {
        apply (strongly_sorted_app_inv _ _ (l1 ++ x :: nil) l2); auto.
          {
          apply Sorted_StronglySorted; auto using Transitive_leT.
          rewrite <- app_assoc.
          cbn.
          rewrite <- Heq.
          apply tsort_sorted.
          }

          {
          apply in_or_app.
          right; left; auto.
          }
        }
      }
    }

    {
    refine (NoDup_app_invert _ l1 _ _ ander).
    rewrite <- Heq.
    apply (Permutation_NoDup _#3 (TSort.Permuted_sort l)); auto.
    }
  }
Qed.

Lemma majority_median :
  forall (P : T -> Prop) (l : list T),
    NoDup l
    -> majority wt P (fun x => In x l)
    -> exists x y,
         P x
         /\ P y
         /\ leU (vl x) (median l)
         /\ leU (median l) (vl y).
Proof.
intros P l Hdist Hmaj.
assert (length l > 0) as Hnonempty.
  {
  so (majority_inhabitant _#4 Hmaj) as (x & Hx).
  so (majority_incl _#4 Hmaj _ Hx) as Hin.
  destruct l.
    {
    destruct Hin.
    }

    {
    cbn.
    omega.
    }
  }
so (median_spec l Hnonempty Hdist) as (x & m & n & Hmedian & Hinx & Hweight_le & Hm & Hweight_ge & Hn).
assert (atleasthalf wt (fun y => In y l /\ leT y x) (fun y => In y l)) as Hmajle.
  {
  exists m, (sumweight wt l).
  do2 3 split; auto.
    {
    intros z Hz.
    destruct Hz; auto.
    }

    {
    apply weight_In; auto.
    }
  }
assert (atleasthalf wt (fun y => In y l /\ leT x y) (fun y => In y l)) as Hmajge.
  {
  exists n, (sumweight wt l).
  do2 3 split; auto.
    {
    intros z Hz.
    destruct Hz; auto.
    }

    {
    apply weight_In; auto.
    }
  }
so (majority_atleasthalf_intersect _#5 eqT_decide Hmaj Hmajle) as (y & HPy & Hiny & Hyx).
so (majority_atleasthalf_intersect _#5 eqT_decide Hmaj Hmajge) as (z & HPz & Hinz & Hxz).
exists y, z.
do2 3 split; auto.
  {
  rewrite -> Hmedian.
  exact Hyx.
  }

  {
  rewrite -> Hmedian.
  exact Hxz.
  }
Qed.

End MedianFun.

Require Import Hashgraph.
Require Import HashgraphFacts.
Require Import Vote.

Module EventWeightAndValue.

Definition T := event.
Definition U := nat.

Definition eqT_decide := eq_event_decide.

Definition wt := creatorstake.
Definition vl := timestamp.

Lemma wt_pos : forall x, wt x > 0.
Proof.
intro x.
unfold wt.
apply stake_positive.
Qed.

Definition lebU := Nat.leb.

Lemma lebU_order : order nat (fun x y => lebU x y = true).
Proof.
unfold lebU.
apply Build_order.
  {
  intros x.
  rewrite -> leb_iff.
  auto.
  }

  {
  intros x y z.
  rewrite -> !leb_iff.
  omega.
  }

  {
  intros x y.
  rewrite -> !leb_iff.
  omega.
  }
Qed.

Definition lebU_total := NatOrder.leb_total.

Definition inh := 0.

End EventWeightAndValue.

Module EventMedian := MedianFun EventWeightAndValue.

Export EventMedian.


Require Import Logic.Set.Set.
Require Import Logic.Set.Decidable.

(* Ordering of syntactic representations of sets. This relation is not          *)
(* compatible with set equality (==) and is used for normalization only.        *)
Fixpoint leq (x y:set) : Prop :=
    match x with
    | Nil           => True
    | (Cons x xs)   =>
        match y with
        | Nil           => False
        | (Cons y ys)   => (x <> y) /\ (leq x y)     (* lexicographic order     *)
                        \/ (x = y)  /\ (leq xs ys)
        end
    end.

(* Strict equality between sets is decidable so leq itself is decidable.        *)
Lemma leqDec : forall (x y:set), {leq x y} + {~leq x y}.
Proof.
    induction x as [|x IH1 xs IH2]; intros y.
    - left. apply I.
    - destruct y as [|y ys].
        + right. simpl. unfold not. intros. contradiction.
        + destruct (eqDecSet x y) as [H1|H1].
            { destruct (IH2 ys) as [H2|H2].
                { left. right. split; assumption. }
                { right. simpl. intros [[H3 H4]|[H3 H4]].
                    { apply H3 in H1. contradiction. }
                    { apply H2 in H4. contradiction. }}}
            { destruct (IH1 y) as [H2|H2].
                { left. left. split; assumption. }
                { right. simpl. intros [[H3 H4]|[H3 H4]].
                    { apply H2 in H4. contradiction. }
                    { apply H1 in H3. contradiction. }}}
Qed.

Lemma leqRefl : forall (x:set), leq x x.
Proof.
    induction x as [|x _ xs IH].
    - apply I.
    - right. split.
        + reflexivity.
        + apply IH.
Qed.

Lemma leqxNil : forall (x:set), leq x Nil -> x = Nil.
Proof.
    intros x. destruct x as [|x xs].
    - intros. reflexivity.
    - simpl. intros. contradiction.
Qed.

Lemma leqASym : forall (x y:set), leq x y -> leq y x -> x = y.
Proof.
    induction x as [|x IH1 xs IH2].
    - intros y H1 H2. symmetry. apply leqxNil. assumption.
    - intros [|y ys].
        + intros H. apply leqxNil in H. inversion H.
        + simpl. intros [[H1 H2]|[H1 H2]].
            { intros [[H3 H4]|[H3 H4]].
                { exfalso. apply H1. apply IH1; assumption. }
                { exfalso. apply H1. symmetry. assumption. }}
            { intros [[H3 H4]|[H3 H4]].
                { exfalso. apply H3. symmetry. assumption. }
                { subst. rewrite (IH2 ys).
                    { reflexivity. }
                    { assumption. }
                    { assumption. }}}
Qed.

Lemma leqTrans : forall (x y z:set), leq x y -> leq y z -> leq x z.
Proof.
    induction x as [|x IH1 xs IH2]; intros y z H1 H2.
    - apply I.
    - destruct z as [|z zs].
        + apply leqxNil in H2. subst. apply leqxNil in H1. inversion H1.
        + simpl. destruct (eqDecSet x z) as [H|H].
            { subst. right. split.
                { reflexivity. }
                { destruct y as [|y ys].
                    { apply leqxNil in H1. inversion H1. }
                    { simpl in H1. simpl in H2.
                        destruct H1 as [[H1 H3]|[H1 H3]].
                            { destruct H2 as [[H2 H4]|[H2 H4]].
                                { exfalso. apply H1. apply leqASym; assumption. }
                                { exfalso. apply H1. symmetry. assumption. }}
                            { destruct H2 as [[H2 H4]|[H2 H4]].
                                { exfalso. apply H2. symmetry. assumption. }
                                { subst. apply IH2 with ys; assumption. }}}}}
            { left. split.
                { assumption. }
                { destruct y as [|y ys].
                    { apply leqxNil in H1. inversion H1. }
                    { simpl in H1. simpl in H2.
                        destruct H1 as [[H1 H3]|[H1 H3]].
                            { destruct H2 as [[H2 H4]|[H2 H4]].
                                { apply IH1 with y; assumption. }
                                { subst. assumption. }}
                            { destruct H2 as [[H2 H4]|[H2 H4]].
                                { subst. assumption. }
                                { subst. apply leqRefl. }}}}}
Qed.

Lemma leqTotal : forall (x y:set), leq x y \/ leq y x.
Proof.
    induction x as [|x IH1 xs IH2]; intros y.
    - left. apply I.
    - destruct y as [|y ys].
        + right. apply I.
        + destruct (eqDecSet x y) as [H|H].
            { subst. destruct (IH2 ys) as [H|H].
                { left. right. split.
                    { reflexivity. }
                    { assumption. }}
                { right. right. split.
                    { reflexivity. }
                    { assumption. }}}
            { destruct (IH1 y) as [H'|H'].
                { left. left. split; assumption. }
                { right. left. split.
                    { intros E. apply H. symmetry. assumption. }
                    { assumption. }}}
Qed.


Require Import Coq.Lists.List.
Import ListNotations.

Definition Paramorphism {A B : Type} (f: A -> list A -> B -> B) (z:B)
  : list A -> B
  :=
    fix h l :=
      match l with
      | [] => z
      | x::xs => f x xs (h xs)
      end.


Require Import List.
Import ListNotations.
From Coq Require Import Relations.
Require Import Coq.Logic.Classical_Prop.
Require Import NonEmptyList.
Require Import LambekSyntax.
Require Import SyntaxOps.
Require Import Semantics.
Require Import Singleton.

Lemma conseqNonEmpty:  forall Γ x A, Γ ⊨ x ⇒ A -> x <> [].
Proof.
  intros. intro XisNull.
  unfold semConsequence in H.  destruct H as [NEmp STrue].
  subst.
  assert (forall s, In s Γ -> seqTrue singletonModel s). {
    intros. unfold seqTrue. intros.  unfold seqValuation. destruct s.
    assert (nonEmptySequent (s ⇒ f)) as NE by apply NEmp, H. unfold nonEmptySequent in NE.
    destruct s. 1:{ apply NE; reflexivity. }
    intro.  apply allTrueOnSingleton. }
  apply (STrue singletonModel) in H.
  unfold seqTrue in H.
  assert (seqValuation singletonModel ([] ⇒ A) WpointOnSingleton) as HH by apply H.
  apply HH.
Qed.

Lemma strValuationRight: forall M X x A p,
    strValuation M X (x ++ [A]) p = strValuation M (pullMultLeft X x) [A] p.
Proof.
  intros.
  generalize dependent X.
  induction x.
  - simpl. reflexivity.
  - intro. simpl. rewrite (IHx  (X ° a)). reflexivity.
Qed.

Lemma strValuationToFormValuationLeft: forall M X x p,
    strValuation M X x p <-> formValuation M (pullMultLeft X x) p.
Proof.
  intros.
  generalize dependent X.
  induction x.
  - simpl. reflexivity.
  - intro. simpl. rewrite (IHx  (X ° a)). reflexivity.
Qed.

Lemma leftDivSound: forall Γ x A B, Γ ⊨ x ⇒ A -> Γ ⊨ ((x ++ [A \\ B]) ⇒ B).
Proof.
  intros.
  unfold semConsequence. intros.
  unfold seqTrue. split.
  - unfold semConsequence in H. destruct H. assumption.
  - intros M allΓ p.
    assert (x <> []) as XnonEmpty by (apply (conseqNonEmpty Γ x A); assumption).
    unfold seqValuation.
    destruct x as [| X x]. 1:{ exfalso. apply XnonEmpty. reflexivity. }
    simpl.  intros StrVal. simpl.
    rewrite strValuationRight in StrVal.
    simpl in StrVal.
    destruct StrVal as [p1 [FVpml [p2 [XX1 XX2]]]].
    unfold semConsequence in H.
    destruct H as [_ H]. set (HH := H M allΓ p1) . unfold seqTrue in HH.
    unfold seqValuation in HH.  rewrite strValuationToFormValuationLeft in HH.
    apply (XX1 p1). 2:assumption.
    apply HH. assumption.
Qed.

Lemma rightDivSound: forall Γ x A B, Γ ⊨ x ⇒ A -> Γ ⊨ ((B // A) :: x) ⇒ B.
Proof.
  intros.
  unfold semConsequence. intros.
  unfold seqTrue. split.
  - unfold semConsequence in H. destruct H. assumption.
  - intros M allΓ p.
    assert (x <> []) as XnonEmpty by (apply (conseqNonEmpty Γ x A); assumption).
    simpl. intros StrVal.
    destruct x as [| X x]. 1: congruence.
    simpl in StrVal.
    apply strValuationToFormValuationRight in StrVal.
    apply pullMultRightExtraction in StrVal.
    simpl in StrVal.
    destruct StrVal as [p1 [R1 [p2 [FV2 C12p]]]].
    assert (formValuation M A p2) as AatP2. {
      unfold semConsequence in H.
      destruct H as [AllNonEmpty HH].
      set (HHH := (HH M allΓ)).
      unfold seqTrue in HHH. unfold seqValuation in HHH.
      apply (HHH p2).
      apply strValuationToFormValuationRight.
      apply FV2. }
    apply R1 with (y:=p2). 1:apply AatP2.
    apply C12p.
Qed.

Lemma arrowLeftSound M x A B:
  x <> [] ->
  seqTrue M ((A :: x) ⇒ B) <-> seqTrue M (x ⇒ A \\ B).
Proof.
  intros NE.
  unfold seqTrue.
  split.
  - intros H p.
    unfold seqValuation.
    destruct x as [| X x]. 1: congruence.
    unfold seqValuation in H.
    intros SV.
    simpl.
    intros p1 FVA p2 C1p2.
    set (HH := H p2).
    apply HH.
    apply strValuationToFormValuationRight.
    simpl.
    exists p1. split. 1: assumption.
    exists p. split. 2: assumption.
    apply strValuationToFormValuationRight in SV.
    assumption.
  - intros H p.
    unfold seqValuation.
    destruct x as [|X x]. 1: congruence.
    intros SV.
    simpl in H.
    apply strValuationToFormValuationRight in SV.
    simpl in SV.
    destruct SV as [p1 [FVA [p2 [FVx C12p]]]].
    apply strValuationToFormValuationRight in FVx.
    apply (H p2 FVx p1 FVA p C12p).
Qed.

Lemma arrowRightSound {M} x A B:
  x <> [] ->
  seqTrue M ((x ++ [A]) ⇒ B) <-> seqTrue M (x ⇒ B // A).
Proof.
  intros NE.
  unfold seqTrue.
  split.
  - intros H p.
    unfold seqValuation.
    destruct x as [| X x]. 1: congruence.
    simpl in H.
    intros SV.
    simpl.
    intros p1 FVA p2 Cp12.
    set (HH := H p2).
    apply HH.
    apply (strValuationToFormValuationLeft).
    rewrite pullMultLeftSplit.
    simpl.
    exists p. split.
    1: { apply strValuationToFormValuationLeft in SV. assumption. }
    exists p1. auto.
  - intros H p.
    destruct x as [|X x]. 1: congruence.
    simpl.
    unfold seqValuation.
    intros SV.
    simpl in H.
    apply strValuationToFormValuationLeft in SV.
    rewrite pullMultLeftSplit in SV.
    simpl in SV.
    destruct SV as [p1 [FVXx [p2 [FVA C12p]]]].
    apply strValuationToFormValuationLeft in FVXx.
    apply (H p1 FVXx p2 FVA p C12p).
Qed.

Lemma mulInSeqTrue M x A B z CC:
  seqTrue M ((x ++ (A ° B :: z)) ⇒ CC) <-> seqTrue M ((x ++ A :: B :: z) ⇒ CC).
Proof.
  generalize dependent CC.
  induction x as [| X x].
  - intros CC. simpl.
    unfold seqTrue.
    split.
    + intros H p.
      unfold seqValuation.
      intros SV.
      unfold seqValuation in H.
      simpl in SV.
      apply H.
      assumption.
    + intros H p.
      unfold seqValuation.
      intros SV.
      unfold seqValuation in H.
      set (HH := H p).
      simpl in HH.
      apply (HH SV).
  - intros CC. simpl.
    set (IHXC := IHx (X \\ CC)).
    repeat rewrite (arrowLeftSound M). 1: assumption.
    all: apply not_eq_sym, app_cons_not_nil.
Qed.

Lemma pointwiseMultLeft1 M A B X p
      (AtoB: forall p', formValuation M A p' -> formValuation M B p')
      (H: formValuation M (A ° X) p):
  formValuation M (B ° X) p.
Proof.
  simpl. simpl in H.
  destruct H as [p1 [FVA [p2 [FVX C12p]]]].
  exists p1. split. 1:{ apply AtoB. assumption. }
  exists p2. auto.
Qed.

Lemma pointwiseMultLeft M A B X p
      (ABEq: forall p', formValuation M A p' <-> formValuation M B p'):
  formValuation M (A ° X) p <-> formValuation M (B ° X) p.
Proof.
  split.
  all:(apply pointwiseMultLeft1; intros;  apply ABEq; assumption).
Qed.

Lemma pointwiseMultRight1 M A B X p
      (AtoB: forall p', formValuation M A p' -> formValuation M B p')
      (H: formValuation M (X ° A) p):
  formValuation M (X ° B) p.
Proof.
  simpl. simpl in H.
  destruct H as [p1 [FVX [p2 [FVA C12p]]]].
  exists p1. split. 1:assumption.
  exists p2. split. 1:{ apply AtoB. assumption. }
  assumption.
Qed.

Lemma pointwiseMultRight M A B X p
      (ABEq: forall p', formValuation M A p' <-> formValuation M B p'):
  formValuation M (X ° A) p <-> formValuation M (X ° B) p.
Proof.
  split.
  all:( apply pointwiseMultRight1; intros; apply ABEq; assumption).
Qed.

Lemma leftMultRearrange M A B X p
      (H: formValuation M (A \\ B ° X) p):
  formValuation M (A \\ (B ° X)) p.
Proof.
  simpl. simpl in H.
  intros p1 FVA p2 C1p2.
  destruct H as [p3 [HH [p4 [FVX C34p]]]].
  destruct p1 as [[u1 u2] Wp1].
  destruct p2 as [[u1' u4] Wp2].
  destruct p3 as [[u2' u3] Wp3].
  destruct p4 as [[u3' u4'] Wp4].
  destruct p as [[u2'' u4''] Wp].
  destruct C1p2 as [C1p21 [C1p22 C1p23]].
  destruct C34p as [C34p1 [C34p2 C34p3]].
  simpl in *. subst.
  set (pB := exist Wpred (u1', u3') (transitivity _ _ _ Wp1 Wp3)).
  set (p1 := exist Wpred (u1', u2'') Wp1).
  set (p3 := exist Wpred (u2'', u3') Wp3).
  set (p4 := exist Wpred (u3', u4) Wp4).
  exists pB. split.
  - apply (HH p1 FVA pB).
    repeat (split; auto).
  - exists p4. split.
    1: assumption.
    repeat (split; auto).
Qed.

Lemma rightMultRearrange M X B A p
      (H: formValuation M (X ° (B // A)) p):
  formValuation M ((X ° B) // A) p.
Proof.
  simpl. simpl in H.
  intros p1 FVA p2 Cp12.
  destruct H as [p3 [FVX [p4 [HH C34p]]]].
  destruct p1 as [[u3 u4] Wp1].
  destruct p2 as [[u1 u4'] Wp2].
  destruct p3 as [[u1' u2] Wp3].
  destruct p4 as [[u2' u3'] Wp4].
  destruct p as [[u1'' u3''] Wp].
  destruct Cp12 as [Cp121 [Cp122 Cp123]].
  destruct C34p as [C34p1 [C34p2 C34p3]].
  simpl in *. subst.
  set (p1 := exist Wpred (u3, u4') Wp1).
  set (p2 := exist Wpred (u1, u4') Wp2).
  set (p3 := exist Wpred (u1, u2') Wp3).
  set (p4 := exist Wpred (u2', u3) Wp4).
  set (pB := exist Wpred (u2', u4') (transitivity _ _ _ Wp4 Wp1)).
  exists p3. split. 1: assumption.
  exists pB. split. 1: { apply (HH p1 FVA pB). split; auto. }
  split; auto.
Qed.

Lemma pointwiseReplaceInStrHead1 M A B z p
      (AtoB: forall p', formValuation M A p' -> formValuation M B p'):
  strValuation M A z p -> strValuation M B z p.
Proof.
  generalize dependent A.
  generalize dependent B.
  induction z as [| Z z].
  - intros. simpl. simpl in H. apply AtoB. assumption.
  - intros. simpl. simpl in H.
    apply (IHz (B ° Z) (A ° Z)). 2: assumption.
    intro p'.
    apply pointwiseMultLeft1.
    assumption.
Qed.

Lemma pointwiseReplaceInStrHead M A B z p
      (ABEq: forall p', formValuation M A p' <-> formValuation M B p'):
  strValuation M A z p <-> strValuation M B z p.
Proof.
  split; apply pointwiseReplaceInStrHead1; intros; apply ABEq; assumption.
Qed.

Lemma pointwiseReplaceInStrTail M X x A B z p :
  (forall p', formValuation M A p' -> formValuation M B p') ->
  strValuation M X (x ++ A :: z) p -> strValuation M X (x ++ B :: z) p.
Proof.
  intros H.
  generalize dependent X.
  induction x as [| X' x].
  - intro X. simpl.
    generalize dependent A.
    generalize dependent B.
    induction z as [| Z z].
    + intros B A H.
      simpl.
      intros [p1 [FVX [p2 [FVA CCC]]]].
      exists p1. split. 1: assumption.
      exists p2. split. 1: { apply H. assumption. }
      assumption.
    + intros B A H SVXA.
      simpl. simpl in SVXA.
      set (IHz':= IHz (B ° Z) (A ° Z)).
      assert (forall p', formValuation M (X ° (A ° Z)) p' -> formValuation M (X ° (B ° Z)) p') as XAZeqXBZ. {
        intro p'.
        apply pointwiseMultRight1.
        intro.
        apply pointwiseMultLeft1.
        assumption. }
      rewrite (pointwiseReplaceInStrHead _ (X ° B ° Z) (X ° (B ° Z))).
      2:apply strAssoc.
      apply IHz'.
      1: { intro p'. apply pointwiseMultLeft1. assumption. }
      apply (pointwiseReplaceInStrHead _ (X ° (A ° Z)) (X ° A ° Z)).
      1: { intro p'. rewrite strAssoc. apply iff_refl. }
      assumption.
  - intro X. simpl.
    apply (IHx (X ° X')).
Qed.

Lemma pointwiseReplaceInSeq M x A B z CC p :
  (forall p', formValuation M A p' -> formValuation M B p') ->
  seqValuation M ((x ++ B :: z) ⇒ CC) p ->
  seqValuation M ((x ++ A :: z) ⇒ CC) p.
Proof.
  intros H.
  destruct x as [| X x].
  - simpl. intros HD AtA.
    apply HD. apply (pointwiseReplaceInStrHead1 M A B). all: auto.
  - simpl. intros TL AtA.
    apply TL. apply (pointwiseReplaceInStrTail M X x A B z). all: auto.
Qed.

Lemma strValuationStepInMiddle M X x A B z p:
  strValuation M X (x ++ A :: B :: z) p <->
  strValuation M X (x ++ (A ° B) :: z) p.
Proof.
  generalize dependent X.
  induction x as [| X x].
  - simpl. intro X.
    apply pointwiseReplaceInStrHead.
    intros p'. apply strAssoc.
  - simpl. intros X'.
    apply (IHx (X' ° X)).
Qed.

Lemma seqValuationStepInMiddle M x A B z CC p:
  seqValuation M ((x ++ A :: B :: z) ⇒ CC) p <-> seqValuation M ((x ++ A ° B :: z) ⇒ CC) p.
Proof.
  destruct x as [| X x].
  - simpl. apply iff_refl.
  - simpl. rewrite strValuationStepInMiddle. apply iff_refl.
Qed.

Lemma leftElimSema M A B p1 p2 p
      (FVA: formValuation M A p1)
      (FVDiv: formValuation M (A \\ B) p2)
      (C12p: C p1 p2 p):
  formValuation M B p.
Proof.
  simpl in FVDiv.
  apply (FVDiv p1 FVA p). apply C12p.
Qed.

Lemma pullMultRightI M X x y p:
  formValuation M (pullMultRight (pullMultRight X x) y) p <->
  formValuation M (pullMultRight X (x ++ y)) p.
Proof.
  generalize dependent p.
  generalize dependent X.
  induction x.
  - simpl. reflexivity.
  - intros.
    set (TG := pullMultRight (pullMultRight X (a :: x)) y). simpl in TG. subst TG.
    set (TG := pullMultRight X ((a :: x) ++ y)). simpl in TG. subst TG.
    rewrite pullMultRightExtraction.
    rewrite <- (pointwiseMultRight M _ _ _ p (IHx a)).
    apply iff_refl.
Qed.

Lemma strValuationToFormValuationRightPartial M X x y p:
  strValuation M X (x ++ y) p <-> strValuation M (pullMultRight X x) y p.
Proof.
  repeat rewrite strValuationToFormValuationRight.
  generalize dependent p.
  generalize dependent X.
  induction x as [| X' x].
  - intros X p. simpl.  apply iff_refl.
  - intros X p.
    set (TG := pullMultRight X ((X' :: x) ++ y)). simpl in TG. subst TG.
    set (TG := pullMultRight (pullMultRight X (X' :: x))). simpl in TG. subst TG.
    rewrite <- pullMultRightExtraction.
    rewrite (IHx (X ° X')).
    rewrite pullMultRightExtraction.
    rewrite pullMultRightI.
    rewrite pullMultRightExtraction.
    rewrite (pointwiseMultRight M _ _ _ p (IHx X')).
    apply iff_refl.
Qed.

Lemma strValuationSplit M X x Y y p:
  strValuation M X (x ++  Y :: y) p <-> formValuation M ((pullMultRight X x) ° (pullMultRight Y y)) p.
Proof.
  split.
  - intros H.
    rewrite (strValuationToFormValuationRightPartial M X x (Y::y) p) in H.
    apply strValuationToFormValuationRight in H.
    set (PMR := pullMultRight (pullMultRight X x) (Y :: y)) in H.
    simpl in PMR.
    apply H.
  - intros H.
    rewrite <- pullMultRightExtraction in H.
    rewrite <- strValuationToFormValuationRight in H.
    rewrite strValuationStepBack in H.
    rewrite <- strValuationToFormValuationRightPartial in H.
    apply H.
Qed.

Lemma semConsequenceToValuation {M} {Γ}
      (allΓ: forall s' : sequent, In s' Γ -> seqTrue M s')
      {X} {x} {A} {p}:
  Γ ⊨ (X :: x) ⇒ A -> formValuation M (pullMultRight X x) p -> formValuation M A p.
Proof.
  intros H1 H2.
  rewrite <- strValuationToFormValuationRight in H2.
  unfold semConsequence in H1.
  destruct H1 as [_ H1].
  apply (H1 M allΓ p H2).
Qed.

Lemma soundness: forall Γ s, Γ ⊢ s -> Γ ⊨ s.
Proof.
  intros Γ s [NE HH].
  induction HH as
      [ s inΓ NE2
      | A
      | y X x A B z CC
      | X x A B
      | y B A X x z CC
      | X x B A
      | x A B y CC
      | X x Y y A B ].
  - unfold semConsequence. split. 1:apply NE.
    intros M allΓ.
    apply allΓ, inΓ.
  - unfold semConsequence. split. 1: apply NE.
    intros M allΓ p.
    unfold seqValuation. unfold strValuation.
    intro. assumption.
  - unfold semConsequence. split. 1: apply NE.
    intros M allΓ p.
    rewrite app_assoc.
    unfold seqValuation.
    generalize dependent p.
    generalize dependent CC.
    induction y as [| Y y].
    + intros CC HH2 IHHH2 p.
      simpl. intro strVal.
      generalize dependent B.
      induction z as [| Z z].
      * intros B _ IHHH2 strVal.
        simpl in IHHH2.
        unfold semConsequence in IHHH2.
        destruct IHHH2 as [_ IHHH2].
        set (BtoCC := IHHH2 M allΓ p).
        unfold seqValuation in BtoCC. apply BtoCC.
        unfold strValuation.
        destruct IHHH1 as [_ IHHH1].
        rewrite strValuationRight in strVal.
        unfold strValuation in strVal.
        simpl in strVal.
        destruct strVal as [p1 [FVA [p2 [RR C12p]]]].
        set (IHH1S := IHHH1 M allΓ p1).
        unfold seqValuation in IHH1S.
        rewrite strValuationToFormValuationLeft in IHH1S.
        set (FVAA := IHH1S FVA).
        set (TG := RR p1 FVAA p C12p).
        assumption.
      * intros B HH2 IHHH2 StrVal.
        simpl in IHHH2.
        apply (IHz (B ° Z)).
        **  apply (mulArrow Γ [] B Z z CC). assumption.
        **  unfold semConsequence. split. 1: apply NE.
            intros.
            rewrite mulInSeqTrue.
            simpl.
            unfold semConsequence in IHHH2.
            destruct IHHH2 as [_ IHHH2].
            apply (IHHH2 M0 H).
        ** simpl in StrVal.
           apply strValuationStepInMiddle in StrVal.
           apply pointwiseReplaceInStrTail with (A:=(A \\ B) ° Z).
           { apply leftMultRearrange. }
           assumption.
    + intros CC HH2 IHHH2 p. simpl.
      intros StrVal.
      set (IHy':= IHy (Y \\ CC)).
      assert (genProof Γ ((y ++ B :: z) ⇒ (Y \\ CC))) as HH2'. {
        destruct y as [| Y' y'].
        - simpl.
          apply (arrowLeft Γ B z Y CC HH2).
        - simpl.
          apply (arrowLeft Γ Y' (y' ++ B :: z) Y CC HH2).
      }
      assert (Γ ⊨ (y ++ B :: z) ⇒ Y \\ CC) as IHHH2'. {
        unfold semConsequence.
        split. 1:apply NE.
        intros M0 allΓ0.
        apply arrowLeftSound.
        * apply not_eq_sym. apply app_cons_not_nil.
        * apply IHHH2.
          apply allΓ0.
      }
      set (IHy'' := IHy' HH2' IHHH2').
      destruct (splitTl (y ++ X :: x) (A \\ B) z) as [[R r] E].
      rewrite E in *.
      apply strValuationToFormValuationRight in StrVal.
      simpl in StrVal.
      destruct StrVal as [p1 [FVY [p2 [FVR C12p]]]].
      set (IHy''' := IHy'' p2).
      rewrite strValuationToFormValuationRight in IHy'''.
      apply IHy''' in FVR.
      apply (leftElimSema M Y CC p1 p2 p). all:assumption.
  - unfold semConsequence. unfold semConsequence in IHHH.
    destruct IHHH as [_ IHHH].
    split. 1:assumption.
    intros. rewrite <- arrowLeftSound. 2:congruence.
    apply IHHH. assumption.
  - unfold semConsequence. split. 1: apply NE.
    intros M allΓ.
    generalize dependent CC.
    induction z as [| Z z] using rev_ind.
    + intros. intro p.
      generalize dependent B.
      induction y as [| Y y] using rev_ind.
      * intros B HH2 IHHH2 H.
        rewrite app_nil_r in H.
        apply strValuationToFormValuationRight in H.
        destruct H as [p1 [RR [p2 [FVA C12p]]]].
        set (FVA' := semConsequenceToValuation allΓ IHHH1 FVA).
        set (RR' := RR p2 FVA' p C12p).
        apply (semConsequenceToValuation allΓ IHHH2 RR').
      * intros B  HH2 IHHH2.
        rewrite <- app_assoc in HH2. simpl in HH2.
        set (HH2' := mulArrow Γ y Y B [] CC HH2).
        rewrite <- app_assoc in IHHH2. simpl in IHHH2.
        assert (Γ ⊨ (y ++ [Y ° B]) ⇒ CC) as IHHH2'. {
          unfold semConsequence.
          split. 1:assumption.
          intros M0 allΓ0.
          apply (mulInSeqTrue M0).
          unfold semConsequence in IHHH2.
          destruct IHHH2 as [_ IHHH2].
          apply (IHHH2 M0 allΓ0).
        }
        set (IHy' := IHy (Y ° B) HH2' IHHH2').
        rewrite <- app_assoc.
        set (tmp := [Y] ++ B // A :: X :: x ++ []). simpl in tmp. subst tmp.
        rewrite seqValuationStepInMiddle.
        apply (pointwiseReplaceInSeq _ y (Y ° (B // A)) ((Y ° B) // A) (X :: x ++ []) CC p).
        ** apply rightMultRearrange.
        ** assumption.
    + intros CC HH2 IHHH2.
      rewrite app_comm_cons in HH2. rewrite app_assoc in HH2.
      rewrite app_comm_cons in IHHH2. rewrite app_assoc in IHHH2.
      destruct (splitTl y B z) as [[Hd tl] e]. simpl in e. rewrite e in *.
      set (HH2' := arrowRight Γ Hd tl Z CC HH2).
      assert (Γ ⊨ (Hd :: tl) ⇒ CC // Z) as IHHH2'. {
        unfold semConsequence. unfold semConsequence in IHHH2.
        split. 1:assumption.
        destruct IHHH2 as [_ IHHH2].
        intros.
        apply arrowRightSound. 1:congruence.
        apply IHHH2.
        assumption.
      }
      set (IHz'' := IHz (CC // Z) HH2' IHHH2').
      assert ((y ++ B // A :: X :: x ++ z ++ [Z]) = (y ++ B // A :: X :: x ++ z) ++ [Z]). {
        repeat rewrite app_comm_cons.
        repeat rewrite <- app_assoc.
        reflexivity.
      }
      rewrite H.
      destruct (splitTl y (B // A) (X :: x ++ z)) as [[Hd' tl'] e']. simpl in e'. rewrite e' in *.
      apply arrowRightSound.
      1: congruence.
      assumption.
  - unfold semConsequence. unfold semConsequence in IHHH.
    destruct IHHH as [_ IHHH].
    split. 1:assumption.
    intros. rewrite <- arrowRightSound. 2:congruence.
    apply IHHH. assumption.
  - unfold semConsequence. unfold semConsequence in IHHH.
    split. 1:assumption.
    intros M allΓ.
    destruct IHHH as [_ IHHH].
    rewrite mulInSeqTrue.
    apply IHHH.
    apply allΓ.
  - unfold semConsequence.
    split. 1:assumption.
    intros M allΓ.
    intros p StrVal.
    rewrite (strValuationSplit M X x Y y p) in StrVal.
    simpl in StrVal.
    destruct StrVal as [p1 [FVXx [p2 [FVYy C12p]]]].
    unfold semConsequence in IHHH1. unfold semConsequence in IHHH2.
    destruct IHHH1 as [_ IHHH1]. destruct IHHH2 as [_ IHHH2].
    set (IH1v := IHHH1 M allΓ p1). set (IH2v := IHHH2 M allΓ p2).
    unfold seqValuation in IH1v. unfold seqValuation in IH2v.
    rewrite strValuationToFormValuationRight in IH1v.
    rewrite strValuationToFormValuationRight in IH2v.
    apply IH1v in FVXx. apply IH2v in FVYy.
    simpl.
    exists p1.
    split. 1: assumption.
    exists p2. auto.
Qed.