(* Ordering code by Antal :) *)

(* CH: We already have a similar class in RandomQC.v, why not use that
   one instead (maybe after moving it to separate file)? *)
Require Import OrderedType.

Require Import Bool.
Module BoolOT <: OrderedType.

Definition t := bool.

Definition eq       := @Logic.eq       bool.
Definition eq_refl  := @Logic.eq_refl  bool.
Definition eq_sym   := @Logic.eq_sym   bool.
Definition eq_trans := @Logic.eq_trans bool.
Definition eq_dec   := bool_dec.

Definition lt (b1 b2 : bool) : Prop := b1 = false /\ b2 = true.

Theorem lt_trans : forall x y z : bool, lt x y -> lt y z -> lt x z.
Proof. unfold lt; tauto. Qed.

Theorem lt_not_eq : forall x y : bool, lt x y -> ~ eq x y.
Proof. unfold lt, eq; intuition; congruence. Qed.

Theorem compare : forall x y : bool, Compare lt eq x y.
Proof.
  unfold lt, eq; repeat (let b := fresh in intros b; destruct b);
  [apply EQ | apply GT | apply LT | apply EQ]; auto.
Qed.

End BoolOT.

Require Import Ascii NArith.
Module AsciiOT <: OrderedType.

Definition t := ascii.

Definition eq       := @Logic.eq       ascii.
Definition eq_refl  := @Logic.eq_refl  ascii.
Definition eq_sym   := @Logic.eq_sym   ascii.
Definition eq_trans := @Logic.eq_trans ascii.
Definition eq_dec   := ascii_dec.

Definition lt (c d : ascii) : Prop := (N_of_ascii c < N_of_ascii d)%N.

Theorem lt_trans : forall c d e : ascii, lt c d -> lt d e -> lt c e.
Proof. intros until 0; unfold lt; apply N.lt_trans. Qed.

Theorem lt_not_eq : forall c d : ascii, lt c d -> ~ eq c d.
Proof.
  unfold lt, eq; red; intros;
  assert (N_of_ascii c = N_of_ascii d) as eq' by (f_equal; assumption);
  generalize dependent eq'; apply N.lt_neq; assumption.
Qed.

Theorem compare : forall c d : t, Compare lt eq c d.
Proof.
  unfold lt, eq; intros;
  remember (N_of_ascii c ?= N_of_ascii d)%N as C; symmetry in HeqC; destruct C;
  [ apply EQ; replace c with (ascii_of_N (N_of_ascii c))
                        by apply ascii_N_embedding;
              replace d with (ascii_of_N (N_of_ascii d))
                        by apply ascii_N_embedding;
              f_equal; apply N.compare_eq
  | apply LT
  | apply GT; apply N.gt_lt];
  assumption.
Qed.

End AsciiOT.

Require Import Coq.Strings.String.
Module StringOT <: OrderedType.

Definition t := string.

Definition eq       := @Logic.eq       string.
Definition eq_refl  := @Logic.eq_refl  string.
Definition eq_sym   := @Logic.eq_sym   string.
Definition eq_trans := @Logic.eq_trans string.
Definition eq_dec   := string_dec.

Inductive SOrdering := SLT | SEQ | SGT.

Fixpoint strcmp (s1 s2 : string) : SOrdering :=
  match s1, s2 with
    | EmptyString,    EmptyString    => SEQ
    | EmptyString,    String _ _     => SLT
    | String _   _,   EmptyString    => SGT
    | String ch1 s1', String ch2 s2' =>
        match AsciiOT.compare ch1 ch2 with
          | LT _ => SLT
          | EQ _ => strcmp s1' s2'
          | GT _ => SGT
        end
  end.

Definition lt (s1 s2 : string) := strcmp s1 s2 = SLT.

Local Ltac do_ascii_lt_trans :=
  match goal with
    | [  _ : AsciiOT.lt ?c1 ?c2
      ,  _ : AsciiOT.lt ?c2 ?c3
      |- _ ]
      => assert (AsciiOT.lt c1 c3) by (eapply AsciiOT.lt_trans; eauto)
  end.

Local Ltac not_ascii_lt_refl :=
  match goal with
    | [ _ : AsciiOT.lt ?c ?c |- _ ]
      => assert (c <> c) by (apply AsciiOT.lt_not_eq; assumption);
         congruence
  end.

Theorem lt_trans : forall s1 s2 s3 : string, lt s1 s2 -> lt s2 s3 -> lt s1 s3.
Proof.
  unfold lt; intros s1 s2; generalize dependent s1; induction s2 as [| c2 s2'].
  (* s2 = "" *)
    destruct s1; [trivial | simpl; congruence].
  (* s2 <> "" *)
    destruct s1 as [| c1 s1']; simpl.
    (* s1 = "" *)
      destruct s3; [congruence | trivial].
    (* s1 <> "" *)
      destruct s3 as [| c3 s3']; [congruence |].
      (* s3 <> "" *)
        destruct (AsciiOT.compare c1 c2) as [? | ? | ?] eqn:?;
        destruct (AsciiOT.compare c2 c3) as [? | ? | ?] eqn:?;
        destruct (AsciiOT.compare c1 c3) as [? | ? | ?] eqn:?;
        unfold AsciiOT.eq in *; subst;
        solve [ apply IHs2'
              | congruence
              | repeat (try not_ascii_lt_refl; do_ascii_lt_trans) ].
Qed.

Theorem lt_not_eq : forall s1 s2 : string, lt s1 s2 -> ~ eq s1 s2.
Proof.
  unfold lt, eq; induction s1 as [| c1 s1'].
  (* s1 = "" *)
    destruct s2; simpl; congruence.
  (* s1 <> "" *)
    destruct s2 as [| c2 s2']; simpl.
    (* s2 = "" *)
      congruence.
    (* s2 <> "" *)
        destruct (AsciiOT.compare c1 c2) as [? | ? | ?] eqn:?;
        intros Hc Heq; inversion Heq.
        (* c1 < c2 *)
          subst; not_ascii_lt_refl.
        (* c1 = c2 *)
          apply IHs1' in Hc; apply Hc; assumption.
        (* c1 > c2 *)
          congruence.
Qed.

Theorem compare : forall s1 s2 : t, Compare lt eq s1 s2.
Proof.
  unfold lt, eq; induction s1 as [| c1 s1'].
  (* s1 = "" *)
    destruct s2; [apply EQ | apply LT]; auto.
  (* s1 <> "" *)
    destruct s2 as [| c2 s2']; [apply GT; auto | ].
    destruct (AsciiOT.compare c1 c2) as [? | ? | ?] eqn:Hcmp.
    (* c1 < c2 *)
      apply LT; simpl; rewrite Hcmp; auto.
    (* c1 = c2 *)
      unfold AsciiOT.eq in *; subst.
      destruct (IHs1' s2'); [apply LT | apply EQ | apply GT];
      first [ simpl; rewrite Hcmp; assumption | subst; reflexivity ].
    (* c1 > c2 *)
      apply GT; simpl.
      destruct (AsciiOT.compare c2 c1) as [? | ? | ?] eqn:Hcmp'.
        reflexivity.
        unfold AsciiOT.eq in *; subst; not_ascii_lt_refl.
        do_ascii_lt_trans; not_ascii_lt_refl.
Qed.

End StringOT.


Require Import Utf8.
Require Import Cpdt.CpdtTactics.

Module Type STLCArrow.

Parameter Inc : Set -> Set.

Parameter Exp : Set -> Set.

Parameter Choose : Set -> Set.

Parameter Empty_inj : Set -> Set.

(* Specification is below *)

Axiom empty_inj_empty : forall (V : Set), Choose (Empty_inj V) = Empty_set.

(*
  Interestingly, we can still use the same signature to make Exp track
    of both term variables and type variables.
  For example, Exp (V * W) where term variables in V, type variables in W
  Choose := fst
  Inc := fun (x,y) => (inc x, y) (Leave type variable unchanged)
  Then we can track multiple groups of variables by Choose
*)

Parameter ty : Set -> Set.

Parameter exp_var : forall {V : Set}, Choose V -> Exp V.

Parameter exp_abs : forall {V : Set}, ty V -> Exp (Inc V) -> Exp V.

Parameter exp_app : forall {V : Set}, Exp V -> Exp V -> Exp V.

Parameter exp_tt : forall {V : Set}, Exp V.

Parameter exp_ff : forall {V : Set}, Exp V.

Parameter exp_if  : forall {V : Set}, Exp V -> Exp V -> Exp V -> Exp V.

Parameter val  : forall {V : Set}, Exp V -> Prop.

Definition Val (V : Set) :=  {x : Exp V | val x}.

Parameter step : forall {V : Set}, Exp V -> Exp V -> Prop.

Notation "∅" := (Empty_set).
Notation Exp0 := (Exp (Empty_inj Empty_set)).
Notation Val0 := (Val (Empty_inj Empty_set)).

Parameter subst_one : forall {V : Set}, Val0 -> Exp (Inc V) -> Exp V.
Parameter subst_all : forall {V : Set} (f : V -> Val0), Exp V -> Exp0.

Axiom subst_one_equations: forall {V: Set} {cond a b : Exp (Inc V)},
  (* conditional *)
  (subst_one (exp_if cond a b) = (exp_if (subst_one cond) (subst_one a) (subst_one b)))
  /\ (subst_one (V:=V) (exp_tt) = exp_tt)
  /\ (subst_one (V:=V) (exp_ff) = exp_ff)
  (* app abs var *)
  /\ (subst_one (exp_abs T body) = exp_abs)
  /\ (subst_one (exp_var ))
  /\ (subst_one (exp_app a b) = (exp_app (subst_one a) (subst_one b))).

(*
Several design point:
1. In the signature, we will only store the operational semantic, substitution lemmas,
    like dynmaic typed lambda calculus
2. In the module functor, we will store the proof of semantic typing, where the relation will be in a parameterized  way
  For example, we  will have the following two
    Definition compat_app {V} (R: Ctx V -> Exp V -> ty V -> Prop) :=
      R Γ x (ty_arrow T1 T2) ->
      R Γ y T1 ->
      R Γ (exp_app x y) T2.
    And give
    Definition type_safe_app : compat_app TypeSafe.
3. In the signature, we will also keep mixing-in the new expression, new terms

*)

Axiom val_tt : forall {V : Set},
  val (V := V) (exp_tt).
Axiom val_ff : forall {V : Set},
  val (V := V) (exp_ff).
Axiom val_abs : forall {V : Set} T body,
  val (V := V) (exp_abs T body).
Axiom val_var : forall {V: Set} v,
  val (V := V) (exp_var v).

(* Eval Context *)
Parameter E : Set.

Parameter hole : E.

Parameter plugE : E -> exp0 -> exp0.

(* Inherited Stepping *)
Axiom step_respect_E: forall E x y,
  step x y ->
  step (plugE E x) (plugE E y).

Axiom step_determinstic : forall {V : Set} (x y z : Exp V),
  step x y ->
  step x z ->
  y = z.

(* Customized Evaluation Point *)

Axiom step_if0: forall {V : Set} {a b : Exp V},
  step (exp_if (exp_tt) a b) a.

Axiom step_if1: forall {V : Set} {a b : Exp V},
  step (exp_if (exp_ff) a b) b.

Axiom step_app0: forall {V : Set} {a b : Exp V},
  step (exp_app (exp_abs ) a b) b.

End STLCArrow.

Module Type STLCbic <: STLCArrow.

Include STLCArrow.

Parameter exp_prod : forall {V : Set}, Exp V -> Exp V -> Exp V.

End STLCbic.

Print STLCbic.

Inductive Exp (U : Type)


Require Import list_examples.

Definition sum_def := FunDef "sum_recursive" ["x"]
 (SIf ("x"=0)
   (SReturn 0)
   (SReturn (arr_val "x"
           + ECall "sum_recursive" [arr_next "x"]))).

Inductive sum_spec : Spec kcfg :=
  sum_claim : forall H l x, heap_fun sum_spec nil
  sum_def [Int x]
    (asP H (rep_list l x))
    (fun r => constraint (r = sum l) :* litP H).

Lemma sum_proof : sound kstep sum_spec.
Proof. list_solver. Qed.


(* 3/13/21- this one is a super early attempt at CDS *)

(* an obvious pointer that I gotta reformulate my def for dy, since stuff like this was meant to be avoided *)
(* n:nat⊢(fun i : nat => eq_rec (max i n) (fun x : nat => kon (S x) 0) (BEAT i n) (max n i) (max_comm i n)) : dy (S n) 1 0 *)

(* Trying DyCG with contents taking two arguments- one for # of pre-existing DR's needed, one for # of DR's introduced *)

Load "CDS_prims".
Load "Vect".
Load "extensions".

(* Some number proofs *)
    (* gonna make them all Fixpoints rather than using nat_ind so they reduce better *)
    Fixpoint Sdistr (m j : nat) {struct m} : (S (m+j)) = (m+(S j))
        := match m as k return ((S (k+j)) = (k+(S j))) with 0 => eq_refl | S i => f_equal S (Sdistr i j) end.

    Fixpoint max_plus (m n : nat) {struct m} : (max m (m+n)) = (m+n)
        := match m as k return ((max k (k+n)) = (k+n)) with 0 => eq_refl | S i => f_equal S (max_plus i n) end.

    Fixpoint max_plus_2 (m n : nat) {struct m} : (max m (S (m+n))) = (S (m+n))
        := match m as k return ((max k (S (k+n))) = (S (k+n))) with 0 => eq_refl | S i => f_equal S (max_plus_2 i n) end.

    Fixpoint Zria (n : nat) {struct n} : n = (n+0)
        := match n as k return (k = (k+0)) with 0 => eq_refl | S i => f_equal S (Zria i) end.

    Fixpoint max_plus_2_in (m n : nat) {struct m} : (S (m+n)) = (max m (S (m+n)))
        := match m as k return ((S (k+n)) = (max k (S (k+n)))) with 0 => eq_refl | S i => f_equal S (max_plus_2_in i n) end.

    Fixpoint add_comm (m n : nat) {struct m} : (m+n) = (n+m)
        := match m as k return ((k+n) = (n+k)) with 0 => Zria n | S i => eq_trans (f_equal S (add_comm i n)) (Sdistr n i) end.

    (* Definition assoc_flip : forall m n k : nat, (m+(n+k)) = (n+(m+k))
        :=  fun m n k : nat =>
            eq_trans' (add_assoc m n k) (eq_trans (f_equal (fun i : nat => i+k) (add_comm m n)) (add_assoc n m k)). *)
    Fixpoint assoc_flip (m n k : nat) {struct m} : (m+(n+k)) = (n+(m+k))
        :=  match m as i return ((i+(n+k)) = (n+(i+k))) with
                | 0     => eq_refl
                | S i   => eq_trans (f_equal S (assoc_flip i n k)) (Sdistr n (i+k))
            end.

(* Proofs used in other proofs/definitions (which are not defined elsewhere): *)
    Definition andb_trans : forall b c d : bool, (b && (c && d)) = ((b && c) && d)
        := fun b c d : bool => bool_ind (fun s : bool => (s && (c && d)) = ((s && c) && d)) eq_refl eq_refl b.

    Definition refl_l_id_trans : forall {A : Type} {x y : A} (e : x = y), e = (eq_trans eq_refl e)
        := fun (A : Type) (x : A) => eq_ind_dep x (fun (z : A) (d : x = z) => d = eq_trans eq_refl d) eq_refl.

    Fixpoint max_idem (m : nat) {struct m} : (max m m) = m
        := match m as k return ((max k k) = k) with 0 => eq_refl | S i => f_equal S (max_idem i) end.

    Fixpoint max_assoc (x y z : nat) {struct x} : (max (max x y) z) = (max x (max y z))
        :=  match x as p,y as q,z as r return ((max (max p q) r) = (max p (max q r))) with
                |   0,  q,  r   =>  @eq_refl nat (max q r)
                | S i,  0,  r   =>  @eq_refl nat (max (S i) r)
                | S i,S j,  0   =>  @eq_refl nat (S (max i j))
                | S i,S j,S k   =>  @f_equal nat nat S (max (max i j) k) (max i (max j k)) (max_assoc i j k)
            end.

    Fixpoint max_comm (m n : nat) {struct m} : (max m n) = (max n m)
        :=  match m as x,n as y return ((max x y) = (max y x)) with
                |   0,  0   =>  eq_refl
                | S i,  0   =>  eq_refl
                |   0,S j   =>  eq_refl
                | S i,S j   =>  f_equal S (max_comm i j)
            end.

    (* Definition max_idemish : forall m n : nat, (max (max m n) n) = (max m n)
        := fun m n : nat => eq_trans (max_trans m n n) (f_equal (max m) (max_idem n)). *)

    Definition max_idemish : forall m n : nat, (max m (max n m)) = (max n m)
        :=  fun m n : nat =>
            eq_trans    (f_equal (max m) (max_comm n m))
                        (eq_trans'  (max_assoc m m n)
                                    (eq_trans (f_equal (fun x : nat => max x n) (max_idem m)) (max_comm m n))).

    Definition max_dist : forall m n k : nat, (max (max m k) (max n k)) = (max (max m n) k)
        :=  fun m n k : nat =>
            eq_trans    (f_equal    (max (max m k)) (max_comm n k))
                        (eq_trans   (max_assoc  m k (max k n))
                                    (eq_trans   (f_equal    (max m)
                                                            (eq_trans   (eq_trans'  (max_assoc k k n)
                                                                                (f_equal (fun x : nat => max x n) (max_idem k)))
                                                                        (max_comm k n)))
                                                (eq_sym (max_assoc m n k)))).

(* Defining the generalized quantifiers *)
Definition every : forall s : statterm, (Sns s -> prop) -> (Sns s -> prop) -> prop
    := fun (s : statterm) (P Q : Sns s -> prop) => p_forall s (fun x : Sns s => (P x) implies (Q x)).
Definition a     : forall s : statterm, (Sns s -> prop) -> (Sns s -> prop) -> prop
    := fun (s : statterm) (P Q : Sns s -> prop) => p_exists s (fun x : Sns s => (P x) and (Q x)).

Notation "'e^' n" := (Vect e n) (at level 0) : vect_scope.
    (* [] : e^0 *)
    (* (::) : forall {n : nat}, e -> e^n -> e^(S n) *)
    (* head : forall {n : nat}, e^(S n) -> e *)
    (* tail : forall {n : nat}, e^(S n) -> e^n *)
    (* (++) : forall {m n : nat}, e^m -> e^n -> e^(m+n) *)
    (* vsplit_at : forall m n : nat, e^(m+n) -> (e^m)*(e^n) *)
    (* take : forall (m : nat) {n : nat}, e^(m+n) -> e^m *)
    (* drop : forall (m : nat) {n : nat}, e^(m+n) -> e^n *)

(* contexts are the same as before- ∀n:nat, (con n) is a function from an n-length vector of entities to a proposition *)
Definition con : nat -> Set := fun n : nat => e^n -> prop.

(* General quantifiers over e-vectors of any length *)
Fixpoint vexists {n : nat} : con n -> prop
    :=  match n as k return (con k -> prop) with
            | 0     =>  fun c : con 0 => c []
            | S i   =>  fun c : con (S i) => p_exists ent (fun x : e => vexists (fun v : e^i => c (x::v)))
        end.
Fixpoint vforall {n : nat} : con n -> prop
    :=  match n as k return (con k -> prop) with
            | 0     =>  fun c : con 0 => c []
            | S i   =>  fun c : con (S i) => p_forall ent (fun x : e => vforall (fun v : e^i => c (x::v)))
        end.

(* contents now take two arguments- ∀i,m:nat, (kon i m) takes a context with at least i DR's and adds m DR's to it *)
Definition kon : nat -> nat -> Set := fun m i : nat => forall n : nat, con (m+n) -> con (i+(m+n)).

Definition cc : forall m i : nat, kon m i -> kon m i
    :=  fun (m i : nat) (k : kon m i) (n : nat) (c : con (m+n)) (v : e^(i+(m+n))) => (c (drop i v)) and (k n c v).

(* castings for contexts & contents with length arguments implicit (vcast moved to Vect.v) *)
Definition ccast : forall {m : nat}, con m -> forall {n : nat}, m = n -> con n
    :=  fun m : nat => eq_rec m con.
Definition kcast : forall {m i : nat}, kon m i -> forall (j : nat) {n : nat}, (m+j) = n -> con n -> con (i+n)
    := fun (m i : nat) (h : kon m i) (j : nat) => eq_rec (m+j) (fun n : nat => con n -> con (i+n)) (h j).

(* First definition where extra i arg to kon matters- NOT prevents adding NEW DR's, not reference to pre-existing DR's *)
Definition NOT : forall {m i : nat}, kon m i -> kon m 0
    := fun (m i : nat) (k : kon m i) (n : nat) (c : con (m+n)) (v : e^(m+n)) => not (vexists (fun u : e^i => k n c (u++v))).

Definition dynNOT : forall (m i n : nat) (k : kon m i) (c : con (m+n)) (v : e^(m+n)),
    (NOT (NOT k) n c v) ≡ (vexists (fun u : e^i => k n c (u++v)))
    :=  fun (m i n : nat) (k : kon m i) (c : con (m+n)) (v : e^(m+n)) =>
        let q := (vexists (fun u : e^i => k n c (u++v))) in
        conj    (dne q)
                (fun (w : world) (p : (q@w) = true) =>
                 eq_trans (p_not_ax (not q) w) (f_equal negb (eq_trans (p_not_ax q w) (f_equal negb p)))).

(* starting to look a little better I suppose *)
Definition d_AND : forall {m n i j : nat}, kon m i -> kon n j -> kon (max m n) (j+i)
    :=  fun (m n i j : nat) (h : kon m i) (k : kon n j) (a : nat) (c : con ((max m n)+a)) (v : e^((j+i)+((max m n)+a))) =>
        let (x,p)   := (m_frnt m n a) in
        let (y,q)   := (n_frnt m n a) in
        let d       := (ccast c p) in
        let u       := (vcast v (eq_trans (f_equal (plus (j+i)) p) (add_assoc j i (m+x)))) in
        (h x d (drop j u))
        and (kcast k (i+y) (eq_trans (assoc_flip n i y) (f_equal (plus i) (eq_trans' q p))) (cc m i h x d) u).

Infix "AND" := d_AND (at level 0) : dyn_scope.
Open Scope dyn_scope.
(* *so* much better than what it used to look like *)
Definition dynAND : forall (m n i j a : nat) (h : kon m i) (k : kon n j) (c : con ((max m n)+a)) (v : e^((j+i)+((max m n)+a))),
    (cc (max m n) (j+i) (h AND k) a c v)
    ≡
    (let (x,p) := (m_frnt m n a) in
     let (y,q) := (n_frnt m n a) in
     kcast (cc n j k) (i+y) (eq_trans (assoc_flip n i y) (f_equal (plus i) (eq_trans' q p)))
                            (cc m i h x (ccast c p)) (vcast v (eq_trans (f_equal (plus (j+i)) p) (add_assoc j i (m+x)))))
    :=  fun (m n i j a : nat) (h : kon m i) (k : kon n j) (c : con ((max m n)+a)) (v : e^((j+i)+((max m n)+a))) =>
        match (m_frnt m n a) as s, (n_frnt m n a) as t
        return  (((c (drop (j+i) v))
                    and (let (x',p') := s in let (y',q') := t in
                         (h x' (ccast c p') (drop j (vcast v (eq_trans (f_equal (plus (j+i)) p') (add_assoc j i (m+x'))))))
                         and (kcast k (i+y')    (eq_trans (assoc_flip n i y') (f_equal (plus i) (eq_trans' q' p')))
                                                (cc m i h x' (ccast c p'))
                                                (vcast v (eq_trans (f_equal (plus (j+i)) p') (add_assoc j i (m+x')))))))
                 ≡
                 (let (x,p) := s in
                  let (y,q) := t in
                  kcast (cc n j k) (i+y) (eq_trans (assoc_flip n i y) (f_equal (plus i) (eq_trans' q p)))
                        (cc m i h x (ccast c p)) (vcast v (eq_trans (f_equal (plus (j+i)) p) (add_assoc j i (m+x))))))
        with
            | exist _ x p,exist _ y q =>
                let C := (cc m i h x (ccast c p)) in
                let D := (eq_trans (f_equal (plus (j+i)) p) (add_assoc j i (m+x))) in
                let E := (eq_trans (assoc_flip n i y) (f_equal (plus i) (eq_trans' q p))) in
                let u := (vcast v D) in
                proj1 (int_eq
                        ((c (drop (j+i) v)) and ((h x (ccast c p) (drop j u)) and (kcast k (i+y) E C u)))
                        (kcast (cc n j k) (i+y) E C u))
                        (fun w : world =>
                             eq_trans   (p_and_ax (c (drop (j+i) v)) ((h x (ccast c p) (drop j u)) and (kcast k (i+y) E C u)) w)
                            (eq_trans   (f_equal    (andb ((c (drop (j+i) v))@w))
                                                    (p_and_ax (h x (ccast c p) (drop j u)) (kcast k (i+y) E C u) w))
                            (eq_trans   (andb_trans ((c (drop (j+i) v))@w) ((h x (ccast c p) (drop j u))@w)
                                                    ((kcast k (i+y) E C u)@w))
                            (eq_trans   (f_equal    (fun t : bool => t && ((kcast k (i+y) E C u)@w))
                                            (eq_trans
                                                (f_equal (fun b : bool => b && ((h x (ccast c p) (drop j u))@w))
                                                    (let z := ((max m n)+a) in
                                                     eq_ind_dep z
                                                        (fun (r : nat) (d : z = r) =>
                                                            ((c (drop (j+i) v))@w)
                                                            = ((ccast c d
                                                                (drop i (drop j (vcast v
                                                                    (eq_trans (f_equal (plus (j+i)) d) (add_assoc j i r))))))@w))
                                                        (eq_trans
                                                            (f_equal    (fun l : e^z => (c l)@w) (drop_assoc j i z v))
                                                            (f_equal    (fun d : ((j+i)+z) = (j+(i+z)) =>
                                                                            (c (drop i (drop j (vcast v d))))@w)
                                                                        (refl_l_id_trans (add_assoc j i z))))
                                                        (m+x) p))
                                                (eq_sym (p_and_ax   (ccast c p (drop i (drop j u)))
                                                                    (h x (ccast c p) (drop j u)) w))))
                                        (eq_ind_dep (n+(i+y))
                                            (fun (z : nat) (r : n+(i+y) = z) => forall (d : con z) (l : e^(j+z)),
                                                    ((d (drop j l))@w) && ((kcast k (i+y) r d l)@w)
                                                        = ((kcast (cc n j k) (i+y) r d l)@w))
                                            (fun (d : con (n+(i+y))) (l : e^(j+(n+(i+y)))) =>
                                                eq_sym (p_and_ax (d (drop j l)) (k (i+y) d l) w))
                                           (i+(m+x)) E C u)))))
        end.

(* holy f-in' crap. This is beyond ridiculous *)
(* Definition dynAND:forall (m n i j a : nat) (h : kon m i) (k : kon n j) (c : con ((max n m)+a)) (v : e^((j+i)+((max n m)+a))),
    (cc (max n m) (j+i) (h AND k) a c v)
    ≡
    (cc n j k (i+(proj1_sig (m_frnt n m a)))
        (ccast      (cc m i h (proj1_sig (n_frnt n m a)) (ccast c (proj2_sig (n_frnt n m a))))
                    (eq_trans   (f_equal (plus i) (eq_trans' (proj2_sig (n_frnt n m a)) (proj2_sig (m_frnt n m a))))
                                (assoc_flip i n (proj1_sig (m_frnt n m a)))))
        (vcast v    (eq_trans   (f_equal    (plus (j+i)) (proj2_sig (m_frnt n m a)))
                                (eq_trans   (add_assoc j i (n+(proj1_sig (m_frnt n m a))))
                                            (f_equal (plus j) (assoc_flip i n (proj1_sig (m_frnt n m a))))))))
    :=  fun (m n i j a : nat) (h : kon m i) (k : kon n j) (c : con ((max n m)+a)) (v : e^((j+i)+((max n m)+a))) =>
        let b := ((max n m)+a) in
        int_eq  (cc (max n m) (j+i) (h AND k) a c v)
                (cc n j k (i+(proj1_sig (m_frnt n m a)))
                    (ccast      (cc m i h (proj1_sig (n_frnt n m a)) (ccast c (proj2_sig (n_frnt n m a))))
                                (eq_trans   (f_equal (plus i) (eq_trans' (proj2_sig (n_frnt n m a)) (proj2_sig (m_frnt n m a))))
                                            (assoc_flip i n (proj1_sig (m_frnt n m a)))))
                    (vcast v    (eq_trans (f_equal (plus (j+i)) (proj2_sig (m_frnt n m a)))
                                          (eq_trans (add_assoc j i (n+(proj1_sig (m_frnt n m a))))
                                                    (f_equal (plus j) (assoc_flip i n (proj1_sig (m_frnt n m a))))))))
            (fun w : world =>
             match (n_frnt n m a) as s,(m_frnt n m a) as t
             return ((((c (drop (j+i) v))
                        and ((h (proj1_sig s) (ccast c (proj2_sig s))
                               ((drop j (take (j+i) v)) ++ (vcast (drop (j+i) v) (proj2_sig s))))
                             and (k (i+(proj1_sig t))
                                    (ccast      (cc m i h (proj1_sig s) (ccast c (proj2_sig s)))
                                                (eq_trans   (f_equal (plus i) (eq_trans' (proj2_sig s) (proj2_sig t)))
                                                            (assoc_flip i n (proj1_sig t))))
                                    (vcast  v   (eq_trans (f_equal (plus (j+i)) (proj2_sig t))
                                                          (eq_trans (add_assoc j i (n+(proj1_sig t)))
                                                                    (f_equal (plus j) (assoc_flip i n (proj1_sig t)))))))))@w)
                    =
                    (((ccast    (cc m i h (proj1_sig s) (ccast c (proj2_sig s)))
                                (eq_trans   (f_equal (plus i) (eq_trans' (proj2_sig s) (proj2_sig t)))
                                            (assoc_flip i n (proj1_sig t)))
                                (drop j (vcast  v
                                                (eq_trans   (f_equal (plus (j+i)) (proj2_sig t))
                                                            (eq_trans (add_assoc j i (n+(proj1_sig t)))
                                                                      (f_equal (plus j) (assoc_flip i n (proj1_sig t))))))))
                        and (k  (i+(proj1_sig t))   (ccast  (cc m i h (proj1_sig s) (ccast c (proj2_sig s)))
                                                            (eq_trans (f_equal (plus i) (eq_trans' (proj2_sig s) (proj2_sig t)))
                                                                      (assoc_flip i n (proj1_sig t))))
                                                    (eq_rec ((j+i)+b) (Vect e) v (j+(n+(i+(proj1_sig t))))
                                                            (eq_trans (f_equal (plus (j + i)) (proj2_sig t))
                                                                      (eq_trans (add_assoc j i (n+(proj1_sig t)))
                                                                                (f_equal (plus j)
                                                                                (assoc_flip i n (proj1_sig t))))))))@w))
             with exist _ x p,exist _ y q =>
             let l := (take j (take (j+i) v)) in
             let r := (drop j (take (j+i) v)) in
             let u := (drop (j+i) v) in
             let d := (eq_trans (f_equal (plus i) (eq_trans' p q)) (assoc_flip i n y)) in
             let t := (eq_trans (f_equal (plus (j+i)) q) (eq_trans (add_assoc j i (n+y)) (f_equal (plus j) (assoc_flip i n y)))) in
             let G := (fun (R : nat -> Set) (X : R b) => eq_rec b R X (m+x) p) in
             let U := (G (Vect e) u) in
             let C := (G con c) in
             let R := (k (i+y) (eq_rec (i+(m+x)) con (cc m i h x C) (n+(i+y)) d) (eq_rec ((j+i)+b) (Vect e) v (j+(n+(i+y))) t)) in
             let T := (eq_rec (i+(m+x)) con (cc m i h x C) (n+(i+y)) d (drop j (eq_rec ((j+i)+b) (Vect e) v (j+(n+(i+y))) t))) in
             (eq_trans  (p_and_ax (c u) ((h x C (r ++ U)) and R) w)
             (eq_trans  (f_equal (andb ((c u)@w)) (p_and_ax (h x C (r ++ U)) R w))
             (eq_trans  (andb_trans ((c u)@w) ((h x C (r ++ U))@w) (R@w))
             (eq_trans
                (f_equal (fun s : bool => s && (R@w))
                    (eq_trans
                        (f_equal  (fun s : bool => s && ((h x C (r ++ U))@w))
                            (eq_trans   (eq_ind_dep b (fun (z : nat) (s : b = z) =>
                                                        ((c u)@w) = ((eq_rec b con c z s (eq_rec b (Vect e) u z s))@w))
                                                    eq_refl (m+x) p)
                                        (f_equal (fun xs : e^(m+x) => (C xs)@w) (tkdr_app_inv2b i r U))))
                        (eq_trans'
                            (p_and_ax (C (drop i (r ++ U))) (h x C (r ++ U)) w)
                            (eq_ind_dep (i+(n+y))
                                (fun (z : nat) (A : (i+(n+y)) = z) =>
                                   ((cc m i h x C (r ++ U))@w) =
                                   ((eq_rec (i+(m+x)) con (cc m i h x C) z (eq_trans (f_equal (plus i) (eq_trans' p q)) A)
                                        (drop j (eq_rec ((j+i)+b) (Vect e) v (j+z)
                                                        (eq_trans (f_equal (plus (j+i)) q)
                                                                  (eq_trans (add_assoc j i (n+y)) (f_equal (plus j) A))))))@w))
                                (eq_ind_dep b
                                    (fun (z : nat) (s : b = z) => forall E : con (i+z),
                                      ((E (r ++ (eq_rec b (Vect e) u z s)))@w) =
                                      ((eq_rec (i+z) con E (i + (n + y)) (f_equal (plus i) (eq_trans' s q))
                                            (drop j (eq_rec ((j+i)+b) (Vect e) v (j+(i+(n+y)))
                                                            (eq_trans (f_equal (plus (j+i)) q) (add_assoc j i (n+y))))))@w))
                                    (fun E : con (i+b) =>
                                        eq_ind_dep b
                                            (fun (z : nat) (s : b = z) =>
                                                ((E (r ++ u))@w) =
                                                ((eq_rec (i+b) con E (i+z) (f_equal (plus i) s)
                                                            (drop j (eq_rec ((j+i)+b) (Vect e) v (j+(i+z))
                                                                            (eq_trans (f_equal (plus (j+i)) s)
                                                                                (add_assoc j i z)))))@w))
                                            (f_equal (fun xs : e^(i+b) => (E xs)@w)
                                                (eq_trans (tkdr_app_inv2b j l (r ++ u))
                                                    (eq_trans'
                                                        (f_equal (drop j)
                                                            (eq_trans
                                                                (f_equal
                                                                    (fun xs : e^((j+i)+b) =>
                                                                        eq_rec ((j+i)+b) (Vect e) xs (j+(i+b)) (add_assoc j i b))
                                                                    (eq_trans (tkdr_app_inv (j+i) v)
                                                                        (f_equal (fun ys : e^(j+i) => ys ++ u)
                                                                            (tkdr_app_inv j (take (j + i) v)))))
                                                                (app_assoc l r u)))
                                                        (f_equal
                                                            (fun s : ((j+i)+b) = (j+(i+b)) =>
                                                                drop j (eq_rec ((j+i)+b) (Vect e) v (j+(i+b)) s))
                                                            (refl_l_id_trans (add_assoc j i b))))))
                                            (n+y) q)
                                    (m+x) p (cc m i h x C))
                            (n+(i+y)) (assoc_flip i n y)))))
                (eq_sym (p_and_ax T R w))))))
             end). *)

Definition d_OR : forall {m n i j : nat}, kon m i -> kon n j -> kon (max m n) 0
    := fun (m n i j : nat) (h : kon m i) (k : kon n j) => NOT ((NOT h) AND (NOT k)).
Infix "OR" := d_OR (at level 0) : dyn_scope.

(* so, interesting- defining (h IMPLIES k), with (h : kon m i) and (k : kon n j), as ((NOT h) OR (h AND k)) yields a term of type
    (kon (max (max n m) m) 0) rather than (kon (max n m) 0). Equivalent, obviously, but I'll have to cast it
    to keep this definition of IMPLIES *)

Definition d_IMPLIES : forall {m n i j : nat}, kon m i -> kon n j -> kon (max m n) 0
    :=  fun (m n i j : nat) (h : kon m i) (k : kon n j) (a : nat) =>
        kcast   ((h AND k) OR (NOT h)) a
                (f_equal    (fun x : nat => x+a)
                            (eq_trans   (max_comm (max m n) m)
                                        (eq_trans' (max_assoc m m n) (f_equal (fun y : nat => max y n) (max_idem m)))))
Infix "IMPLIES" := d_IMPLIES (at level 0) : dyn_scope.

(* NOTE: Now that I've swapped m and n in the max stuff for the connectives, the definitions below which depend on them
    won't work correctly! Gotta redo them to reflect the change! *)

(* Dynamic predicate stuff *)
(* moving nth,max, m_frnt,n_frnt to Vect.v *)

(* vmax takes an n-length vector of nat's and returns the smallest x:nat which is strictly greater than every nat in the vector *)
(* Defined via recursion on the length rather than the vector itself for ease of reductions *)
    (* ie for any u : Vect nat 0, (vmax u) will simplify to 0, not just when u is known to be [] *)
    (* similarly, for any u : Vect nat (S i), (vmax u) with simplify to (max (S (head u)) (vmax (tail u))), *)
    (* as opposed to only (vmax (m::l)) reducing to (max (S m) (vmax l)) for any terms m:nat & l:Vect nat i *)
    (* this is often relevant in cases where vmax is used on a variable of the type that can't be pattern-matched on *)
Fixpoint vmax {n : nat} : Vect nat n -> nat
    :=  match n as k return (Vect nat k -> nat) with
            | 0     =>  fun _ : Vect nat    0   => 0
            | S i   =>  fun v : Vect nat (S i)  => max (S (head v)) (vmax (tail v))
        end.

(* defining a generalized version of the p_i type stuff *)
(* apparently using Type here doesn't schematize the function in the way it does for Inductive def's *)
Fixpoint nary (A B : Set) (m : nat) {struct m} : Set := match m with 0 => B | S i => A -> nary A B i end.
Definition p_i : nat -> Set := nary e prop.

(* To define dy/dyn, starting with what I call the "uncurried" version of both, making dy/dyn be the "curried" versions *)

(*  Update to udy/dy- adding an additional nat argument to represent # of DR's it requires a context to have,
    Before considering the index arguments the term will receive *)
(*  This argument will go first, and it shouldn't affect udy'/dy' at all- just replacing id w/ max of this argument *)
(*  for udyn/dyn, this argument will be 0 (thus (max 0) = id, so they'll work just the same as they already did) *)

(* udy(n?)(\'?), aka "uncurried" dy(n?)(\'?), takes all of its DR's indices in a single vector at once vs as separate arguments *)
Definition udy' : (nat -> nat) -> nat -> nat -> Set
    := fun (f : nat -> nat) (m i : nat) => forall u : Vect nat m, kon (f (vmax u)) i.
Definition udy  : nat -> nat -> nat -> Set := fun n : nat => udy' (max n).

Fixpoint udyn (m : nat) {struct m} : p_i m -> udy 0 m 0
    :=  match m as k return (p_i k -> udy 0 k 0) with
            | 0     =>  fun (p : prop) (_ : Vect nat 0) (j : nat) (_ : con j) (_ : e^j) => p
            | S i   =>  fun (P : e -> p_i i) (u : Vect nat (S i)) (j : nat) (c : con ((vmax u)+j)) (v : e^((vmax u)+j)) =>
                        let (x,q) := (m_frnt (S (head u)) (vmax (tail u)) j) in
                        let (y,r) := (n_frnt (S (head u)) (vmax (tail u)) j) in
                        udyn    i           (P (nth (head u)    (eq_rec ((vmax u)+j) (Vect e) v (S ((head u)+x)) q)))
                                (tail u) y                      (eq_rec ((vmax u)+j)  con     c ((vmax (tail u))+y) r)
                                                                (eq_rec ((vmax u)+j) (Vect e) v ((vmax (tail u))+y) r)
        end.

Fixpoint dy' (f : nat -> nat) (m i : nat) {struct m} : Set
    :=  match m with
            | 0     =>  kon (f 0) i
            | S j   =>  forall m : nat, dy' (f∘(max (S m))) j i
        end.
Definition dy : nat -> nat -> nat -> Set := fun n : nat => dy' (max n).

(* udytody : forall (f : nat -> nat) (m i : nat), udy' f m i -> dy' f m i *)
(* udytody is meant as a sort of "currying" function *)
Fixpoint udytody (f : nat -> nat) (m i : nat) : udy' f m i -> dy' f m i
    :=  match m as k return (udy' f k i -> dy' f k i) with
            | 0     =>  fun  k : udy' f 0 i => k []
            | S j   =>  fun (k : udy' f (S j) i) (m : nat) => udytody (f∘(max (S m))) j i (fun l : Vect nat j => k (m::l))
        end.

Definition dyn  : forall m : nat, p_i m -> dy 0 m 0 := fun (m : nat) (P : p_i m) => udytody id m 0 (udyn m P).

(* So, this definition of dy should work, and doesn't require a starting point. Just flips associativity of max's *)
(* Fixpoint dy2 (n m i : nat) {struct m} : Set := match m with 0 => kon n i | S j => forall m : nat, dy2 (max (S m) n) j i end. *)

(* for 0≤m≤3: *)
    (* (dyn 0) :=: (fun (p : prop) (j : nat) (_ : con j) (_ : e^j) => p) *)
    (* (dyn 1) :=: (fun (P : e -> prop) (m : nat) (j : nat) (c : con (S (m+j))) (v : e^(S (m+j))) => P (nth m v)) *)
    (* (dyn 2) :=: (fun (Q : e -> e -> prop) (m : nat) (n : nat) (j : nat) (c : con (S ((max m n)+j))) (v : e^(S ((max m n)+j))) =>
                 let (x,q)  :=  (let (w,p) := (m_frnt m n j) in
                                 exist (fun x : nat => (S ((max m n)+j)) = (S (m+x))) w (f_equal S p)) in
                 let (y,r)  :=  (let (z,t) := (n_frnt m n j) in
                                 exist (fun y : nat => (S ((max m n)+j)) = (S (n+y))) z (f_equal S t)) in
                 Q  (nth m (eq_rec (S ((max m n)+j)) (Vect e) v (S (m+x)) q))
                    (nth n (eq_rec (S ((max m n)+j)) (Vect e) v (S (n+y)) r)))
            :≈: (fun (Q : e -> e -> prop) (m : nat) (n : nat) (j : nat) (c : con (S ((max m n)+j))) (v : e^(S ((max m n)+j))) =>
                 let (x,q) := (m_frnt m n j) in
                 let (y,r) := (n_frnt m n j) in
                 Q  (nth m (eq_rec ((max m n)+j) (fun z : nat => e^(S z)) v (m+x) q))
                    (nth n (eq_rec ((max m n)+j) (fun z : nat => e^(S z)) v (n+y) r))) *)
    (* (dyn 3) :=: (fun (R : e -> e -> e -> prop) (m : nat) (n : nat) (k : nat) (j : nat) (c : con ((vmax [m,n,k])+j))
                     (v : e^((vmax [m,n,k])+j)) =>
                 let (x,q)   := (let (w,p) := (m_frnt m (max n k) j) in
                                 exist (fun x : nat => (S ((max m (max n k))+j)) = (S (m+x))) w (f_equal S p)) in
                 let (y,r)   := (let (z,t) := (n_frnt m (max n k) j) in
                                 exist (fun y : nat => (S ((max m (max n k))+j)) = (S ((max n k)+y))) z (f_equal S t)) in
                 let (w,p)  :=  (let (a,s) := (m_frnt n k y) in
                                 exist (fun x : nat => (S ((max n k)+y)) = (S (n+x))) a (f_equal S s)) in
                 let (z,t)  :=  (let (b,d) := (n_frnt n k y) in
                                 exist (fun z : nat => (S ((max n k)+y)) = (S (k+z))) b (f_equal S d)) in
                 R  (nth m  (eq_rec (S ((max m (max n k))+j)) (Vect e) v (S (m+x)) q))
                    (nth n  (eq_rec (S ((max n k)+y)) (Vect e)
                                    (eq_rec (S ((max m (max n k))+j)) (Vect e) v (S ((max n k)+y)) r) (S (n+w)) p))
                    (nth k  (eq_rec (S ((max n k)+y)) (Vect e)
                                    (eq_rec (S ((max m (max n k))+j)) (Vect e) v (S ((max n k)+y)) r) (S (k+z)) t)))
            :≈: (fun (R : e -> e -> e -> prop) (m : nat) (n : nat) (k : nat) (j : nat) (c : con (S ((max m (max n k))+j)))
                     (v : e^(S ((max m (max n k))+j))) =>
                 let (x,q)  :=  (m_frnt m (max n k) j) in
                 let (y,r)  :=  (n_frnt m (max n k) j) in
                 let (w,p)  :=  (m_frnt n k y) in
                 let (z,t)  :=  (n_frnt n k y) in
                 R  (nth m  (eq_rec ((max m (max n k))+j) (fun s : nat => e^(S s)) v (m+x) q))
                    (nth n  (eq_rec ((max m (max n k))+j) (fun s : nat => e^(S s)) v (n+w) (eq_trans r p)))
                    (nth k  (eq_rec ((max m (max n k))+j) (fun s : nat => e^(S s)) v (k+z) (eq_trans r t)))) *)

(* Note- there are some more generalized versions of a few of these functions- look at extra_dy_stuff.v *)
(* as well as the dyn work files for them *)

(* context extension- defined to add arbitrary # of DR's, but the c⁺ notation will still be for +1 *)
Definition cext : forall i : nat, kon 0 i := fun (i j : nat) (c : con j) (v : e^(i+j)) => c (drop i v).
Notation "c ⁺" := (cext 1 _ c) (at level 0).

(* Dynamic Existential Quantifier *)

(* Ok…not exactly ideal. But it works, so it's good enough for now I suppose *)
(* um…isn't D's argument supposed to be 0, not (n+j)? I think that might just be the problem (but we'll see) *)
Definition EXISTS : forall {n i : nat}, dy n 1 i -> kon n (S i)
    :=  fun (n i : nat) (D : dy n 1 i) (j : nat) (c : con (n+j)) (v : e^(S (i+(n+j)))) =>
        eq_rec  (max n (S (n+j))) (fun k : nat => kon k i) (D (n+j)) (S (n+j)) (max_plus_2 n j) 0
                (eq_rec (n+j) (con∘S) c⁺ ((n+j)+0) (Zria (n+j)))
                (eq_rec (S (i+(n+j))) (Vect e) v (i+(S ((n+j)+0)))
                        (eq_trans (f_equal (S∘(plus i)) (Zria (n+j))) (Sdistr i ((n+j)+0)))).

Definition FORALL : forall {n i : nat}, dy n 1 i -> kon n 0
    := fun (n i : nat) (D : dy n 1 i) => NOT (EXISTS (fun j : nat => NOT (D j))).

Definition d_THAT : forall {m n i j : nat}, dy m 1 i -> dy n 1 j -> dy (max n m) 1 (j+i)
    :=  fun (m n i j : nat) (D : dy m 1 i) (E : dy n 1 j) (k : nat) =>
        eq_rec  (max (max n (S k)) (max m (S k))) (fun x : nat => kon x (j+i))
                ((D k) AND (E k)) (max (max n m) (S k)) (max_dist n m (S k)).
Infix "THAT" := d_THAT (at level 20) : dyn_scope.

Definition A : forall {m n i j : nat}, dy m 1 i -> dy n 1 j -> kon (max n m) (S (j+i))
    :=  fun (m n i j : nat) (D : dy m 1 i) (E : dy n 1 j) => EXISTS (D THAT E).

Definition EVERY : forall {m n i j : nat}, dy m 1 i -> dy n 1 j -> kon (max n m) 0
    :=  fun (m n i j : nat) (D : dy m 1 i) (E : dy n 1 j) =>
        FORALL (fun k : nat =>
                eq_rec  (max (max n (S k)) (max m (S k))) (fun x : nat => kon x 0)
                        ((D k) IMPLIES (E k)) (max (max n m) (S k)) (max_dist n m (S k))).

(* Example Sentence: "A donkey brays" ≡ (A DONKEY BRAY) ≡ (λc:c.λX^|c|,y.(donkey y) and (bray y)) *)
                                   (* ≡ (λj:nat.λc:con j.λv:e^(S j).(donkey (head v)) and (bray (head v))) *)

Axioms farmer donkey bray : e -> prop.
Axioms own beat : e -> e -> prop.
Axiom ch : e.
Definition DONKEY : dy 0 1 0 := (dyn 1 donkey).
    (* := fun (m j : nat) (_ : con (S (m+j))) (v : e^(S (m+j))) => donkey (nth m v) *)
Definition BRAY : dy 0 1 0 := (dyn 1 bray).
    (* := fun (m j : nat) (_ : con (S (m+j))) (v : e^(S (m+j))) => bray (nth m v) *)
Definition FARMER : dy 0 1 0 := (dyn 1 farmer).
    (* := fun (m j : nat) (_ : con (S (m+j))) (v : e^(S (m+j))) => farmer (nth m v) *)
Definition OWN  : dy 0 2 0 := (dyn 2 own).
    (* :=   fun (m n j : nat) (_ : con (S ((max m n)+j))) (v : e^(S ((max m n)+j))) =>
            let (x,q)   :=  (let (z,p) := (m_frnt m n j) in
                             exist (fun x : nat => (S ((max m n)+j)) = (S (m+x))) z (f_equal S p)) in
            let (y,r)   :=  (let (z,p) := (n_frnt m n j) in
                             exist (fun y : nat => (S ((max m n)+j)) = (S (n+y))) z (f_equal S p)) in
            own (nth m (eq_rec (S ((max m n)+j)) (Vect e) v (S (m+x)) q))
                (nth n (eq_rec (S ((max m n)+j)) (Vect e) v (S (n+y)) r)) *)
    (* :≈   fun (m n j : nat) (_ : con (S ((max m n)+j))) (v : e^(S ((max m n)+j))) =>
            let (x,q)   := (m_frnt m n j) in
            let (y,r)   := (n_frnt m n j) in
            own (nth m (eq_rec ((max m n)+j) (fun z : nat => e^(S z)) v (m+x) q))
                (nth n (eq_rec ((max m n)+j) (fun z : nat => e^(S z)) v (n+y) r)) *)
Definition BEAT : dy 0 2 0 := (dyn 2 beat).
    (* :=   fun (m n j : nat) (_ : con (S ((max m n)+j))) (v : e^(S ((max m n)+j))) =>
            let (x,q)   :=  (let (z,p) := (m_frnt m n j) in
                             exist (fun x : nat => (S ((max m n)+j)) = (S (m+x))) z (f_equal S p)) in
            let (y,r)   :=  (let (z,p) := (n_frnt m n j) in
                             exist (fun y : nat => (S ((max m n)+j)) = (S (n+y))) z (f_equal S p)) in
            beat    (nth m (eq_rec (S ((max m n)+j)) (Vect e) v (S (m+x)) q))
                    (nth n (eq_rec (S ((max m n)+j)) (Vect e) v (S (n+y)) r)) *)
    (* :≈   fun (m n j : nat) (_ : con (S ((max m n)+j))) (v : e^(S ((max m n)+j))) =>
            let (x,q)   := (m_frnt m n j) in
            let (y,r)   := (n_frnt m n j) in
            beat    (nth m (eq_rec ((max m n)+j) (fun z : nat => e^(S z)) v (m+x) q))
                    (nth n (eq_rec ((max m n)+j) (fun z : nat => e^(S z)) v (n+y) r)) *)

(* A (dyn 1 donkey) (dyn 1 bray) *)

(* so these are predicted one entity is both the farmer and the donkey… *)

Definition ADON : dy 0 1 1  := fun i : nat => @A 0 (S i) 0 0 DONKEY (OWN i).
Definition FTA  : dy 0 1 1  := @d_THAT 0 0 0 1 FARMER ADON.
Definition BT   : dy 0 2 0  := fun a b : nat => eq_rec (max b a) (fun x : nat => kon (S x) 0) (BEAT b a) (max a b) (max_comm b a).

(* Definition EFWOADBI : dy 0 1 0 := fun n : nat => @EVERY 0 (S n) 1 0 FTA (BT n). *)
    (* :=  fun n : nat =>
        EVERY   (FARMER THAT (fun i : nat => A DONKEY (OWN i)))
                (fun i : nat => eq_rec (max i n) (fun x : nat => kon (S x) 0) (BEAT i n) (max n i) (max_comm i n)). *)

(* shouldn't this be kon 0 0? *)
(* should be (@EVERY 0 0 1 0) *)
Definition EFWOADBI0 : kon 0 0
    :=  @EVERY  0 0 1 0
                (@d_THAT 0 0 0 1 FARMER (fun i : nat => @A 0 (S i) 0 0 DONKEY (OWN i)))
                (fun i : nat => eq_rec (max i 0) (fun x : nat => kon (S x) 0) (BEAT i 0) i (max_comm i 0)).
    (*  :=  (EFWOADBI 0). *)
    (*  :=  EVERY   (FARMER THAT (fun i : nat => A DONKEY (OWN i)))
                    (fun i : nat => eq_rec (max i 0) (fun x : nat => kon (S x) 0) (BEAT i 0) i (max_comm i 0)). *)

(* EFWOADBI    : dy 0 1 0
            : forall m j : nat, con (S (m+j)) -> con (S (m+j))
            : forall m : nat, kon (S m) 0

    @EVERY : forall m n i j : nat, dy m 1 i -> dy n 1 j -> kon (max n m) 0
    (@EVERY 0 0 1 0 FTA (BT 0)) : kon 0 0 *)

Definition efnil : prop := EFWOADBI0 0 (fun _ : e^0 => truth) [].
(* Eval compute in efnil.
    := (not (p_exists ent
         (fun x : e => not (not ((not (p_exists ent (fun y : e => ((farmer x) and ((donkey x) and (own y x))) and (beat y y))))
                            and (not (not (p_exists ent (fun z : e => (farmer x) and ((donkey x) and (own z x))))))))))) *)
(* Still bad… *)

(*  Eval compute in (EFWOADBI 0 0 (fun _ : e^0 => truth) [ch]).
    =   not (p_exists ent
                    (fun x : e =>
                     not (not ((not (p_exists ent (fun y : e => ((farmer ch) and ((donkey ch) and (own x ch))) and (beat x y))))
                               and (not (not (p_exists ent (fun _ : e => (farmer ch) and ((donkey ch) and (own x ch))))))))))
    ≈   not (p_exists ent
                    (fun x : e =>
                     (not (p_exists ent (fun y : e => ((farmer ch) and ((donkey ch) and (own x ch))) and (beat x y))))
                      and (p_exists ent (fun _ : e => (farmer ch) and ((donkey ch) and (own x ch))))))
     : prop *)

(* ∀w:world.[(EFWOADBI 0 0 (fun _ : e^0 => truth) [ch])@w
                    <-> ∀x:e.[((farmer ch)@w && ((donkey ch)@w && (own x ch)@w)) ~> ∃y:e.[(beat x y)@w]]] *)


(*
Copyright © 2006-2008 Russell O’Connor

Permission is hereby granted, free of charge, to any person obtaining a copy of
this proof and associated documentation files (the "Proof"), to deal in
the Proof without restriction, including without limitation the rights to
use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
the Proof, and to permit persons to whom the Proof is furnished to do so,
subject to the following conditions:

The above copyright notice and this permission notice shall be included in all
copies or substantial portions of the Proof.

THE PROOF IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION WITH THE PROOF OR THE USE OR OTHER DEALINGS IN THE PROOF.
*)

Require Export CoRN.algebra.CPolynomials.
Require Import CoRN.algebra.CSums.
Require Import CoRN.tactics.Rational.
Require Import CoRN.model.ordfields.Qordfield.
Require Import CoRN.algebra.COrdFields2.
Require Import CoRN.algebra.CRing_Homomorphisms.
Require Coq.Vectors.Vector.
Export Vector.VectorNotations.
From Coq Require Import Lia.

Set Implicit Arguments.

(**
** Bernstein Polynomials
*)

Section Bernstein.
Opaque cpoly_cring.

Variable R : CRing.
Add Ring R : (CRing_Ring R) (preprocess [unfold cg_minus;simpl]).
Add Ring cpolycring_th : (CRing_Ring (cpoly_cring R))  (preprocess [unfold cg_minus;simpl]).
(** [Bernstein n i] is the ith element of the n dimensional Bernstein basis *)

Fixpoint Bernstein (n i:nat) {struct n}: (i <= n) -> cpoly_cring R :=
match n return (i <= n) -> cpoly_cring R  with
 O => fun _ => [1]
|S n' =>
  match i return (i <= S n') -> cpoly_cring R  with
   O => fun _ => ([1][-]_X_)[*](Bernstein (le_O_n n'))
  |S i' => fun p =>
    match (le_lt_eq_dec _ _ p) with
     | left p' => ([1][-]_X_)[*](Bernstein (lt_n_Sm_le _ _ p'))[+]_X_[*](Bernstein (le_S_n _ _ p))
     | right _ => _X_[*](Bernstein (lt_n_Sm_le _ _ p))
    end
  end
end.

(** These lemmas provide an induction principle for polynomials using the Bernstien basis *)
Lemma Bernstein_inv1 : forall n i (H:i < n) (H0:S i <= S n),
 Bernstein H0[=]([1][-]_X_)[*](Bernstein (lt_n_Sm_le _ _ (lt_n_S _ _ H)))[+]_X_[*](Bernstein (le_S_n _ _ H0)).
Proof.
 intros n i H H0.
 simpl (Bernstein H0).
 destruct (le_lt_eq_dec _ _ H0).
  replace (lt_n_Sm_le (S i) n l) with (lt_n_Sm_le _ _ (lt_n_S _ _ H)) by apply le_irrelevent.
  reflexivity.
 exfalso; lia.
Qed.

Lemma Bernstein_inv2 : forall n (H:S n <= S n),
 Bernstein H[=]_X_[*](Bernstein (le_S_n _ _ H)).
Proof.
 intros n H.
 simpl (Bernstein H).
 destruct (le_lt_eq_dec _ _ H).
  exfalso; lia.
 replace (lt_n_Sm_le n n H) with (le_S_n n n H) by apply le_irrelevent.
 reflexivity.
Qed.

Lemma Bernstein_ind : forall n i (H:i<=n) (P : nat -> nat -> cpoly_cring R -> Prop),
P 0 0 [1] ->
(forall n p, P n 0 p -> P (S n) 0 (([1][-]_X_)[*]p)) ->
(forall n p, P n n p -> P (S n) (S n) (_X_[*]p)) ->
(forall i n p q, (i < n) -> P n i p -> P n (S i) q -> P (S n) (S i) (([1][-]_X_)[*]q[+]_X_[*]p)) ->
P n i (Bernstein H).
Proof.
 intros n i H P H0 H1 H2 H3.
 revert n i H.
 induction n; intros [|i] H.
    apply H0.
   exfalso; auto with *.
  apply H1.
  apply IHn.
 simpl.
 destruct (le_lt_eq_dec (S i) (S n)).
  apply H3; auto with *.
 inversion e.
 revert H.
 rewrite H5.
 intros H.
 apply H2.
 auto with *.
Qed.

(** [1] important property of the Bernstein basis is that its elements form a partition of unity *)

Lemma partitionOfUnity : forall n, @Sumx (cpoly_cring R) _ (fun i H => Bernstein (lt_n_Sm_le i n H)) [=][1].
Proof.
 induction n.
  reflexivity.
 set (A:=(fun (i : nat) (H : i < S n) => Bernstein (lt_n_Sm_le i n H))) in *.
 set (B:=(fun i => ([1][-]_X_)[*](part_tot_nat_fun (cpoly_cring R) _ A i)[+]_X_[*]match i with O => [0] | S i' => (part_tot_nat_fun _ _ A i') end)).
 rewrite -> (fun a b => Sumx_Sum0 _ a b B).
  unfold B.
  rewrite -> Sum0_plus_Sum0.
  do 2 rewrite -> mult_distr_sum0_lft.
  rewrite -> Sumx_to_Sum in IHn; auto with *.
   setoid_replace (Sum0 (S (S n)) (part_tot_nat_fun (cpoly_cring R) (S n) A))
     with (Sum0 (S (S n)) (part_tot_nat_fun (cpoly_cring R) (S n) A)[-][0]) using relation (@st_eq (cpoly_cring R)) by ring.
   change (Sum0 (S (S n)) (part_tot_nat_fun (cpoly_cring R) (S n) A)[-][0])
     with (Sum 0 (S n) (part_tot_nat_fun (cpoly_cring R) (S n) A)).
   set (C:=(fun i : nat => match i with | 0 => ([0] : cpoly_cring R)
     | S i' => part_tot_nat_fun (cpoly_cring R) (S n) A i' end)).
   setoid_replace (Sum0 (S (S n)) C) with (Sum0 (S (S n)) C[-][0]) using relation (@st_eq (cpoly_cring R)) by ring.
   change (Sum0 (S (S n)) C[-][0]) with (Sum 0 (S n) C).
   rewrite -> Sum_last.
   rewrite -> IHn.
   replace (part_tot_nat_fun (cpoly_cring R) (S n) A (S n)) with ([0]:cpoly_cring R).
    rewrite -> Sum_first.
    change (C 0) with ([0]:cpoly_cring R).
    rewrite <- (Sum_shift _ (part_tot_nat_fun (cpoly_cring R) (S n) A)) by reflexivity.
     rewrite -> IHn by ring.
    ring.
   unfold part_tot_nat_fun.
   destruct (le_lt_dec (S n) (S n)).
    reflexivity.
   exfalso; lia.
  intros i j Hij. subst.
  intros Hi Hj.
  unfold A.
  replace (lt_n_Sm_le j n Hi) with (lt_n_Sm_le j n Hj) by apply le_irrelevent.
  apply eq_reflexive.
 destruct i; intros Hi; unfold B, A, part_tot_nat_fun.
  simpl. symmetry.
  rewrite <- (le_irrelevent _ _ (le_0_n _) _).
  ring.
 destruct (le_lt_dec (S n) i).
  exfalso; lia.
 destruct (le_lt_dec (S n) (S i)); simpl (Bernstein (lt_n_Sm_le (S i) (S n) Hi));
   destruct (le_lt_eq_dec (S i) (S n) (lt_n_Sm_le (S i) (S n) Hi)).
    exfalso; lia.
   replace  (lt_n_Sm_le i n (lt_n_Sm_le (S i) (S n) Hi)) with (lt_n_Sm_le i n l) by apply le_irrelevent.
  ring.
  replace (le_S_n i n (lt_n_Sm_le (S i) (S n) Hi)) with (lt_n_Sm_le i n l) by apply le_irrelevent.
  replace l1 with l0 by apply le_irrelevent.
  reflexivity.
 exfalso; lia.
Qed.

Lemma RaiseDegreeA : forall n i (H:i<=n), (nring (S n))[*]_X_[*]Bernstein H[=](nring (S i))[*]Bernstein (le_n_S _ _ H).
Proof.
 induction n.
  intros [|i] H; [|exfalso; lia].
  repeat split; ring.
 intros i H.
 change (nring (S (S n)):cpoly_cring R) with (nring (S n)[+][1]:cpoly_cring R).
 rstepl (nring (S n)[*]_X_[*]Bernstein H[+]_X_[*]Bernstein H).
 destruct i as [|i].
  simpl (Bernstein H) at 1.
  rstepl (([1][-]_X_)[*](nring (S n)[*]_X_[*]Bernstein (le_O_n n))[+] _X_[*]Bernstein H).
  rewrite -> IHn.
  rstepl ((([1][-]_X_)[*]Bernstein (le_n_S _ _ (le_O_n n))[+]_X_[*]Bernstein H)).
  rstepr (Bernstein (le_n_S 0 (S n) H)).
  set (le_n_S 0 n (le_0_n n)).
  rewrite (Bernstein_inv1 l).
  rewrite (le_irrelevent _ _ (lt_n_Sm_le 1 (S n) (lt_n_S 0 (S n) l)) l).
  rewrite (le_irrelevent _ _ H (le_S_n 0 (S n) (le_n_S 0 (S n) H))).
  reflexivity.
 simpl (Bernstein H) at 1.
 destruct (le_lt_eq_dec _ _ H).
  rstepl (([1][-]_X_)[*](nring (S n)[*]_X_[*]Bernstein (lt_n_Sm_le (S i) n l))[+]
    _X_[*](nring (S n)[*]_X_[*]Bernstein (le_S_n i n H))[+] _X_[*]Bernstein H).
  do 2 rewrite -> IHn.
  change (nring (S (S i)):cpoly_cring R) with (nring (S i)[+][1]:cpoly_cring R).
  set (l0:= (le_n_S (S i) n (lt_n_Sm_le (S i) n l))).
  replace (le_n_S i n (le_S_n i n H)) with H by apply le_irrelevent.
  rstepl ((nring (S i)[+][1])[*](([1][-]_X_)[*]Bernstein l0[+]_X_[*]Bernstein H)).
  rewrite (Bernstein_inv1 l).
  replace (lt_n_Sm_le (S (S i)) (S n) (lt_n_S (S i) (S n) l)) with l0 by apply le_irrelevent.
  replace (le_S_n (S i) (S n) (le_n_S (S i) (S n) H)) with H by apply le_irrelevent.
  reflexivity.
 rstepl (_X_[*](nring (S n)[*]_X_[*]Bernstein (lt_n_Sm_le _ _ H))[+] _X_[*]Bernstein H).
 rewrite IHn.
 replace (le_n_S i n (lt_n_Sm_le i n H)) with H by apply le_irrelevent.
 revert H.
 inversion_clear e.
 intros H.
 rewrite -> (Bernstein_inv2 (le_n_S _ _ H)).
 replace (le_S_n (S n) (S n) (le_n_S (S n) (S n) H)) with H by apply le_irrelevent.
 change (nring (S (S n)):cpoly_cring R) with (nring (S n)[+][1]:cpoly_cring R).
 ring.
Qed.

Lemma RaiseDegreeB : forall n i (H:i<=n), (nring (S n))[*]([1][-]_X_)[*]Bernstein H[=](nring (S n - i))[*]Bernstein (le_S _ _ H).
Proof.
 induction n.
  intros [|i] H; [|exfalso; lia].
  repeat split; ring.
 intros i H.
 change (nring (S (S n)):cpoly_cring R) with (nring (S n)[+][1]:cpoly_cring R).
 set (X0:=([1][-](@cpoly_var R))) in *.
 rstepl (nring (S n)[*]X0[*]Bernstein H[+]X0[*]Bernstein H).
 destruct i as [|i].
  simpl (Bernstein H) at 1.
  fold X0.
  rstepl (X0[*](nring (S n)[*]X0[*]Bernstein (le_O_n n))[+] X0[*]Bernstein H).
  rewrite -> IHn.
  replace (le_S 0 n (le_O_n n)) with H by apply le_irrelevent.
  simpl (S n - 0).
  change (nring (S (S n) - 0):cpoly_cring R) with (nring (S n)[+][1]:cpoly_cring R).
  rstepl ((nring (S n))[*](X0[*]Bernstein H)[+]X0[*]Bernstein H).
  change (Bernstein (le_S _ _ H)) with (X0[*]Bernstein (le_O_n (S n))).
  replace (le_O_n (S n)) with H by apply le_irrelevent.
  ring.
 simpl (Bernstein H) at 1.
 destruct (le_lt_eq_dec _ _ H).
  fold X0.
  rstepl (X0[*](nring (S n)[*]X0[*]Bernstein (lt_n_Sm_le (S i) n l))[+]
    _X_[*](nring (S n)[*]X0[*]Bernstein (le_S_n i n H))[+] X0[*]Bernstein H).
  do 2 rewrite -> IHn.
  rewrite <- (minus_Sn_m n i) by auto with *.
  rewrite <-(minus_Sn_m (S n) (S i)) by auto with *.
  replace (S n - S i) with (n - i) by auto with *.
  change (nring (S (n - i)):cpoly_cring R) with (nring (n - i)[+][1]:cpoly_cring R).
  replace (le_S (S i) n (lt_n_Sm_le (S i) n l)) with H by apply le_irrelevent.
  set (l0:= (le_S i n (le_S_n i n H))).
  rstepl ((nring (n - i)[+][1])[*](X0[*]Bernstein H[+]_X_[*]Bernstein l0)).
  rewrite -> (Bernstein_inv1 H).
  fold X0.
  replace (lt_n_Sm_le _ _ (lt_n_S _ _ H)) with H by apply le_irrelevent.
  replace (le_S_n _ _ (le_S (S i) (S n) H)) with l0 by apply le_irrelevent.
  reflexivity.
 revert H.
 inversion e.
 clear - IHn.
 intros H.
 assert (l:(n < (S n))) by auto.
 rewrite -> (Bernstein_inv1 l).
 fold X0.
 rstepl (_X_[*](nring (S n)[*]X0[*]Bernstein (lt_n_Sm_le _ _ H))[+] X0[*]Bernstein H).
 rewrite -> IHn.
 replace (S n - n) with 1 by auto with *.
 replace (S (S n) - S n) with 1 by auto with *.
 replace (le_S_n n (S n) (le_S (S n) (S n) H))
   with (le_S n n (lt_n_Sm_le n n H)) by apply le_irrelevent.
 replace (lt_n_Sm_le (S n) (S n) (lt_n_S n (S n) l)) with H by apply le_irrelevent.
 ring.
Qed.

Lemma RaiseDegree : forall n i (H: i<=n),
 (nring (S n))[*]Bernstein H[=](nring (S n - i))[*]Bernstein (le_S _ _ H)[+](nring (S i))[*]Bernstein (le_n_S _ _ H).
Proof.
 intros n i H.
 rstepl ((nring (S n))[*]([1][-]_X_)[*]Bernstein H[+](nring (S n))[*]_X_[*]Bernstein H).
 rewrite RaiseDegreeA, RaiseDegreeB. reflexivity.
Qed.

Opaque Bernstein.

(** Given a vector of coefficents for a polynomial in the Bernstein basis, return the polynomial *)
Arguments Vector.nil {A}.
Arguments Vector.cons [A].

Fixpoint evalBernsteinBasisH (n i:nat) (v:Vector.t R i) : i <= n -> cpoly_cring R :=
match v in Vector.t _ i return i <= n -> cpoly_cring R with
|Vector.nil => fun _ => [0]
|Vector.cons a i' v' =>
  match n as n return (S i' <= n) -> cpoly_cring R with
  | O => fun p => False_rect _ (le_Sn_O _ p)
  | S n' => fun p => _C_ a[*]Bernstein (le_S_n _ _ p)[+]evalBernsteinBasisH v' (le_Sn_le _ _ p)
  end
end.

Definition evalBernsteinBasis (n:nat) (v:Vector.t R n) : cpoly_cring R :=
evalBernsteinBasisH v (le_refl n).

(** The coefficents are linear *)
Opaque polyconst.

Section obsolute_stuff_from_Bvector.
Variable A : Type.
Variable (g : A -> A -> A).
Lemma Vbinary : forall (n : nat), Vector.t A n -> Vector.t A n -> Vector.t A n.
Proof.
  induction n as [| n h]; intros v v0.
  apply Vector.nil.

  inversion v as [| a n0 H0 H1]; inversion v0 as [| a0 n1 H2 H3].
  exact (Vector.cons (g a a0) n (h H0 H2)).
Defined.

Definition Vid n : Vector.t A n -> Vector.t A n :=
  match n with
  | O => fun _ => Vector.nil
  | S n' => fun v : Vector.t A (S n') => Vector.cons (Vector.hd v) _ (Vector.tl v)
  end.

Lemma Vid_eq : forall (n:nat) (v:Vector.t A n), v = Vid v.
Proof.
  destruct v; auto.
Qed.

Lemma VSn_eq :
  forall (n : nat) (v : Vector.t A (S n)), v = Vector.cons (Vector.hd v) _ (Vector.tl v).
Proof.
  intros.
  exact (Vid_eq v).
Qed.

Lemma V0_eq : forall (v : Vector.t A 0), v = Vector.nil.
Proof.
  intros.
  exact (Vid_eq v).
Qed.
End obsolute_stuff_from_Bvector.

Lemma evalBernsteinBasisPlus : forall n (v1 v2: Vector.t R n),
evalBernsteinBasis (Vbinary (fun (x y:R)=>x[+]y) v1 v2)[=]evalBernsteinBasis v1[+]evalBernsteinBasis v2.
Proof.
 unfold evalBernsteinBasis.
 intros n.
 generalize (le_refl n).
 generalize n at 1 3 4  6 7  9 11.
 intros i.
 induction i.
  intros l v1 v2.
  rewrite (V0_eq v1), (V0_eq v2). ring.
 intros l v1 v2.
 destruct n as [|n].
  exfalso; auto with *.
 rewrite (VSn_eq v1), (VSn_eq v2).
 simpl.
 rewrite IHi.
 rewrite -> c_plus. ring.
Qed.

Lemma evalBernsteinBasisConst : forall n c,
evalBernsteinBasis (Vector.const c (S n))[=]_C_ c.
Proof.
 intros n c.
 stepr (evalBernsteinBasis (Vector.const c (S n))[+]_C_ c[*]Sum (S n) n (part_tot_nat_fun _ _ (fun (i : nat) (H : i < S n) => Bernstein (lt_n_Sm_le i n H)))).
  rewrite -> Sum_empty by auto with *.
  ring.
 unfold evalBernsteinBasis.
 generalize (le_refl (S n)).
 generalize (S n) at 1 4 5 6.
 intros i l.
 induction i.
  rstepr (_C_ c[*][1]).
  rewrite <- (partitionOfUnity n).
  rewrite -> Sumx_to_Sum; auto with *.
  intros i j Hij.
  rewrite Hij.
  intros H H'.
  replace (lt_n_Sm_le j n H) with (lt_n_Sm_le j n H') by apply le_irrelevent.
  reflexivity.
 rstepl (evalBernsteinBasisH (Vector.const c i) (le_Sn_le i (S n) l)[+]
   _C_ c[*](Bernstein (le_S_n i n l)[+] Sum (S i) n (part_tot_nat_fun (cpoly_cring R) (S n)
     (fun (i0 : nat) (H : i0 < S n) => Bernstein (lt_n_Sm_le i0 n H))))).
 replace (Bernstein (le_S_n _ _ l)) with (part_tot_nat_fun (cpoly_cring R) (S n)
   (fun (i0 : nat) (H : i0 < S n) => Bernstein (lt_n_Sm_le i0 n H)) i).
  rewrite <- Sum_first.
  apply IHi.
 clear - i.
 unfold part_tot_nat_fun.
 destruct (le_lt_dec (S n) i).
  exfalso; auto with *.
 simpl.
 replace (lt_n_Sm_le _ _ l0) with (le_S_n _ _ l) by apply le_irrelevent.
 reflexivity.
Qed.

Variable eta : RingHom Q_as_CRing R.

Opaque Qred.
Opaque Q_as_CRing.
Opaque Vbinary.
Opaque Vector.const.

(** To convert a polynomial to the Bernstein basis, we need to know how to
multiply a bernstein basis element by [_X_] can convert it to the Bernstein basis.
At this point we must work with rational coeffients.  So we assume there is a
ring homomorphism from [Q] to R *)

Fixpoint BernsteinBasisTimesXH (n i:nat) (v:Vector.t R i) : i <= n -> Vector.t R (S i) :=
match v in Vector.t _ i return i <= n -> Vector.t R (S i) with
| Vector.nil => fun _ => Vector.cons [0] _ Vector.nil
| Vector.cons a i' v' => match n as n return S i' <= n -> Vector.t R (S (S i')) with
  | O => fun p => False_rect _ (le_Sn_O _ p)
  | S n' => fun p => Vector.cons (eta(Qred (i#P_of_succ_nat n'))[*]a) _ (BernsteinBasisTimesXH v' (le_Sn_le _ _ p))
  end
end.

Definition BernsteinBasisTimesX (n:nat) (v:Vector.t R n) : Vector.t R (S n) :=
BernsteinBasisTimesXH v (le_refl n).

Lemma evalBernsteinBasisTimesX : forall n (v:Vector.t R n),
 evalBernsteinBasis (BernsteinBasisTimesX v)[=]_X_[*]evalBernsteinBasis v.
Proof.
 intros n.
 unfold evalBernsteinBasis, BernsteinBasisTimesX.
 generalize (le_refl (S n)) (le_refl n).
 generalize n at 1 3 5 7 9 11.
 intros i.
 induction i.
  intros l l0 v.
  rewrite (V0_eq v).
  simpl.
  rewrite <- c_zero. ring.
 intros l l0 v.
 destruct n as [|n].
  exfalso; auto with *.
 rewrite (VSn_eq v).
 simpl.
 rewrite -> IHi.
 rewrite -> c_mult.
 rewrite -> ring_dist_unfolded.
 apply csbf_wd; try reflexivity.
 set (A:= (_C_ (eta (Qred (Qmake (Zpos (P_of_succ_nat i)) (P_of_succ_nat n)))))).
 rstepl (_C_ (Vector.hd v)[*](A[*]Bernstein (le_S_n (S i) (S n) l))).
 rstepr (_C_ (Vector.hd v)[*](_X_[*]Bernstein (le_S_n i n l0))).
 apply mult_wdr.
 unfold A; clear A.
 assert (Hn : (nring (S n):Q)[#][0]).
  stepl (S n:Q).
   simpl.
   unfold Qap, Qeq.
   auto with *.
  symmetry; apply nring_Q.
 setoid_replace (Qred (P_of_succ_nat i # P_of_succ_nat n))
   with (([1][/](nring (S n))[//]Hn)[*](nring (S i))).
  set (eta':=RHcompose _ _ _ _C_ eta).
  change (_C_ (eta (([1][/]nring (S n)[//]Hn)[*]nring (S i))))
    with ((eta' (([1][/]nring (S n)[//]Hn)[*]nring (S i))):cpoly_cring R).
  rewrite -> rh_pres_mult.
  rewrite -> rh_pres_nring.
  rewrite <- mult_assoc_unfolded.
  replace (le_S_n (S i) (S n) l) with (le_n_S _ _ (le_S_n i n l0)) by apply le_irrelevent.
  rewrite <- RaiseDegreeA.
  rewrite <- (@rh_pres_nring _ _ eta').
  rewrite <- mult_assoc_unfolded.
  rewrite -> mult_assoc_unfolded.
  rewrite <- rh_pres_mult.
  setoid_replace (eta' (([1][/]nring (S n)[//]Hn)[*]nring (S n))) with ([1]:cpoly_cring R).
   ring.
  rewrite <- (@rh_pres_unit _ _ eta').
  apply csf_wd.
  apply (@div_1 Q_as_CField).
 rewrite -> Qred_correct.
 rewrite -> Qmake_Qdiv.
 change (Zpos (P_of_succ_nat n)) with ((S n):Z).
 rewrite <- (nring_Q (S n)).
 change (Zpos (P_of_succ_nat i)) with ((S i):Z).
 rewrite <- (nring_Q (S i)).
 change (nring (S i)/nring (S n) == (1/(nring (S n)))*nring (S i))%Q.
 field.
 apply Hn.
Qed.

(** Convert a polynomial to the Bernstein basis *)
Fixpoint BernsteinCoefficents (p:cpoly_cring R) : sigT (Vector.t R) :=
match p with
| cpoly_zero _ => existT _ _ Vector.nil
| cpoly_linear _ c p' =>
  let (n', b') := (BernsteinCoefficents p') in
  existT _ _  (Vbinary (fun (x y:R)=>x[+]y) (Vector.const c _) (BernsteinBasisTimesX b'))
end.

Lemma evalBernsteinCoefficents : forall p, (let (n,b) := BernsteinCoefficents p in evalBernsteinBasis b)[=]p.
Proof.
 induction p.
  reflexivity.
 simpl.
 destruct (BernsteinCoefficents p).
 rewrite -> evalBernsteinBasisPlus.
 rewrite -> evalBernsteinBasisConst.
 rewrite -> evalBernsteinBasisTimesX.
 rewrite -> IHp.
 rewrite -> poly_linear.
 ring.
Qed.

End Bernstein.

Section BernsteinOrdField.

Variable F : COrdField.

Opaque cpoly_cring.

(** A second important property of the Bernstein polynomials is that they
are all non-negative on the unit interval. *)

Lemma BernsteinNonNeg : forall x:F, [0] [<=] x -> x [<=] [1] ->
forall n i (p:Nat.le i n), [0][<=](Bernstein F p)!x.
Proof.
 intros x Hx0 Hx1.
 induction n.
  intros i p.
  simpl (Bernstein F p).
  autorewrite with apply.
  auto with *.
 intros [|i] p; simpl (Bernstein F p).
  autorewrite with apply.
  auto with *.
 destruct (le_lt_eq_dec (S i) (S n) p); autorewrite with apply; auto with *.
Qed.

End BernsteinOrdField.


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

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

(* Why3 goal *)
Definition num_occ: forall {a:Type} {a_WT:WhyType a}, a -> (list a) -> Z.
intros a a_WT x.
exact (fix num_occ (l : list a) : int :=
  match l with
  | nil => 0
  | cons y r => (if why_decidable_eq x y then 1 else 0) + num_occ r
  end)%Z.
Defined.

(* Why3 goal *)
Lemma num_occ_def : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)),
  match l with
  | Init.Datatypes.nil => ((num_occ x l) = 0%Z)
  | (Init.Datatypes.cons y r) => ((x = y) -> ((num_occ x
      l) = (1%Z + (num_occ x r))%Z)) /\ ((~ (x = y)) -> ((num_occ x
      l) = (0%Z + (num_occ x r))%Z))
  end.
Proof.
intros a a_WT x [|y r].
easy.
split ; intros H.
change ((if why_decidable_eq x y then 1 else 0) + num_occ x r = 1 + num_occ x r)%Z.
now case why_decidable_eq.
change ((if why_decidable_eq x y then 1 else 0) + num_occ x r = 0 + num_occ x r)%Z.
now case why_decidable_eq.
Qed.

(* Why3 goal *)
Lemma Num_Occ_NonNeg : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), (0%Z <= (num_occ x l))%Z.
intros a a_WT x l.
induction l as [|lh lt IHl].
easy.
simpl.
case why_decidable_eq ; intros H.
omega.
easy.
Qed.

(* Why3 goal *)
Lemma Mem_Num_Occ : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), (list.Mem.mem x l) <-> (0%Z < (num_occ x l))%Z.
Proof.
intros a a_WT x l.
induction l as [|lh lt IHl].
now split.
simpl.
case why_decidable_eq ; intros H ; split.
intros _.
clear.
generalize (Num_Occ_NonNeg x lt).
omega.
now left.
intros [H'|H'] ; try easy.
now apply IHl.
right.
now apply IHl.
Qed.

(* Why3 goal *)
Lemma Append_Num_Occ : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l1:(list a)) (l2:(list a)), ((num_occ x
  (Init.Datatypes.app l1 l2)) = ((num_occ x l1) + (num_occ x l2))%Z).
Proof.
intros a a_WT x l1 l2.
induction l1 as [|l1h l1t IHl1].
easy.
simpl.
rewrite IHl1.
rewrite Zplus_assoc.
now case why_decidable_eq.
Qed.

(* Why3 goal *)
Lemma reverse_num_occ : forall {a:Type} {a_WT:WhyType a}, forall (x:a)
  (l:(list a)), ((num_occ x l) = (num_occ x (Lists.List.rev l))).
intros a a_WT x l.
induction l; simpl.
auto.
rewrite Append_Num_Occ.
rewrite <- IHl.
ring_simplify.
simpl (num_occ x (a0 :: nil))%list.
ring.
Qed.


From Babel Require Export FQP.premises.

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

From Babel Require FieldTheories.
From Babel Require RealTheories.

Module Export ComplexTheory.

Export FieldTheories.FieldTheory.
Export RealTheories.RealTheory.

Definition ℂ : Type := R * R.
(** We'll make C opaque so Coq doesn't treat it as a pair. *)
Opaque C.

Declare Scope ℂ_scope.
Delimit Scope ℂ_scope with ℂ.
Bind Scope ℂ_scope with ℂ.
Open Scope ℂ_scope.

(** real part is the first element *)
Definition real : ℂ -> R := fst.
(** imaginary part is the second element *)
Definition imag : ℂ -> R := snd.

Definition R2C (r : R) : ℂ := (r, 0).
Coercion R2C : R >-> ℂ.

(** Define the 'real numbers' in ℂ, and the corresponding transition *)
Definition realc (c : ℂ) := snd c = 0.
(** Given a proof for the reality of c, we get the real part as the real
    number. *)
Definition realc2R (c : ℂ) (H : realc c) : R := fst c.
Coercion realc2R : realc >-> R.

(** We give names to three generally useful constants *)
Notation i := (0, 1).
Notation "0" := (0:ℂ) : ℂ_scope.
Notation "1" := (1:ℂ) : ℂ_scope.

(** We can define plus component-wise *)

Definition Cplus (c1 c2 : ℂ) : ℂ := (fst c1 + fst c2, snd c1 + snd c2).

(** And then define minus and opp together: *)

Definition Copp (c : ℂ) : ℂ := (- fst c, - snd c).
Definition Cminus (c1 c2 : ℂ) : ℂ := Cplus c1 (Copp c2).

(** Multiplication and division. We'll define division in terms of an inverse. *)

Definition Cmult (c1 c2 : ℂ) : ℂ :=
    (fst c1 * fst c2 - snd c1 * snd c2, fst c1 * snd c2 + snd c1 * fst c2).

Definition Cinv (c : ℂ) : ℂ :=
  (fst c / (fst c ^ 2 + snd c ^ 2), - snd c / (fst c ^ 2 + snd c ^ 2)).

Definition Cdiv (c1 c2 : ℂ) : ℂ := Cmult c1 (Cinv c2).

Definition Cnorm2 (c : ℂ) : R := fst c ^ 2 + snd c ^ 2.
Definition Cnorm (c : ℂ) : R := √ (Cnorm2 c).
Arguments Cnorm2 c /.
Arguments Cnorm c /.

Infix "+" := Cplus : ℂ_scope.
Notation "- x" := (Copp x) : ℂ_scope.
Infix "-" := Cminus : ℂ_scope.
Infix "*" := Cmult : ℂ_scope.
Notation "/ x" := (Cinv x) : ℂ_scope.
Infix "/" := Cdiv : ℂ_scope.
Notation "⎸ x  ⎸²" := (Cnorm2 x) : ℂ_scope.
Notation "⎸ x  ⎸" := (Cnorm x) : ℂ_scope.

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

Lemma c_proj_eq : forall (c1 c2 : ℂ),
  fst c1 = fst c2 -> snd c1 = snd c2 -> c1 = c2.
Proof. intros. destruct c1, c2. simpl in *. subst. reflexivity. Qed.

Ltac lca := eapply c_proj_eq; simpl; lra.

(* ################################################################# *)
(** * C is a field *)

Open Scope ℂ_scope.

Lemma C1_neq_C0 : 1 <> 0. Proof. intros F. inversion F. lra. Qed.

Lemma Cplus_comm : forall c1 c2 : ℂ, c1 + c2 = c2 + c1. Proof. intros. lca. Qed.
Lemma Cplus_assoc : forall c1 c2 c3 : ℂ, c1 + c2 + c3 = c1 + (c2 + c3).
Proof. intros. lca. Qed.

Lemma Cplus_opp_r : forall c : ℂ, c + - c = 0. Proof. intros. lca. Qed.

Lemma Cplus_0_l : forall c : ℂ, 0 + c = c. Proof. intros. lca. Qed.

Lemma Cmult_comm : forall c1 c2:ℂ, c1 * c2 = c2 * c1. Proof. intros. lca. Qed.

Lemma Cmult_assoc : forall c1 c2 c3:ℂ, c1 * c2 * c3 = c1 * (c2 * c3).
Proof. intros. lca. Qed.

Lemma Cmult_1_l : forall c:ℂ, 1 * c = c. Proof. intros. lca. Qed.

Lemma Cmult_plus_distr_r : forall c1 c2 c3:ℂ, (c1 + c2) * c3 = c1 * c3 + c2 * c3.
Proof. intros. lca. Qed.

Lemma Cinv_l : forall c:ℂ, c <> 0 -> / c * c = 1.
Proof.
  intros.
  eapply c_proj_eq; simpl; unfold Rminus, Rdiv.
  - repeat rewrite <- Ropp_mult_distr_l.
    rewrite Ropp_involutive.
    repeat rewrite Rmult_1_r.
    rewrite (Rmult_comm (fst c)). rewrite Rmult_assoc.
    rewrite (Rmult_comm (snd c) (/ _)). rewrite Rmult_assoc.
    rewrite <- Rmult_plus_distr_l.
    rewrite Rinv_l; try lra.
    contradict H. apply Rplus_sqr_eq_0 in H. lca.
  - repeat rewrite Rmult_1_r.
    rewrite (Rmult_comm (fst c)). rewrite Rmult_assoc.
    rewrite (Rmult_comm (- snd c)). rewrite Rmult_assoc.
    rewrite <- Rmult_plus_distr_l.
    lra.
Qed.

(** Construct the complex field *)
Definition ℂ_field : field.
Proof.
  apply (@build_field ℂ 0 1 Cplus Cmult Cminus Copp Cdiv Cinv eq).
  constructor. constructor.
  (* addition *)
  (* left identity *) apply Cplus_0_l.
  (* commutativity *) apply Cplus_comm.
  (* associativity *) intros; rewrite Cplus_assoc; easy.
  (* multiplication *)
  (* left identity *) apply Cmult_1_l.
  (* commutativity *) apply Cmult_comm.
  (* associativity *) intros; rewrite Cmult_assoc; easy.
  (* distributivity *) apply Cmult_plus_distr_r.
  (* sub = opp *) reflexivity.
  (* additive inverse *) apply Cplus_opp_r.
  (* 0 <> 1 *) apply C1_neq_C0.
  (* div = inv *) reflexivity.
  (* multiplicative inverse *) apply Cinv_l.
Defined.

Add Field CField : (field_proof ℂ_field).

(** Some additional useful lemmas *)

Lemma Cplus_opp_l : forall c : ℂ, - c + c = 0. Proof. intros. lca. Qed.
Lemma Cplus_0_r : forall c : ℂ, c + 0 = c. Proof. intros. lca. Qed.
Lemma Cmult_0_l : forall c:ℂ, 0 * c = 0. Proof. intros. lca. Qed.
Lemma Cmult_0_r : forall c:ℂ, c * 0 = 0. Proof. intros. lca. Qed.
Lemma Cmult_1_r : forall c:ℂ, c * 1 = c. Proof. intros. lca. Qed.

Lemma Cmult_plus_dist_l : forall c1 c2 c3:ℂ, c1 * (c2 + c3) = c1 * c2 + c1 * c3.
Proof. intros. lca. Qed.
Lemma Cmult_plus_dist_r : forall c1 c2 c3:ℂ, (c1 + c2) * c3 = c1 * c3 + c2 * c3.
Proof. intros. lca. Qed.

Lemma Cinv_r : forall c:ℂ, c <> 0 -> c * /c = 1.
Proof. intros. rewrite Cmult_comm. apply Cinv_l. easy. Qed.

Lemma Copp_mult_distr_r : forall c1 c2 : ℂ, - (c1 * c2) = c1 * - c2.
Proof. intros; lca. Qed.
Lemma Copp_mult_distr_l : forall c1 c2 : ℂ, - (c1 * c2) = - c1 * c2.
Proof. intros; lca. Qed.
Lemma Copp_involutive: forall c : ℂ, - - c = c. Proof. intros; lca. Qed.

Lemma R2C_neq : forall (r1 r2 : R), r1 <> r2 -> R2C r1 <> R2C r2.
Proof. intros r1 r2 H F. inversion F. easy. Qed.

(* ################################################################# *)
(** * The complex conjugate *)

Definition Cconj (x : ℂ) : ℂ := (fst x, (- snd x)%R).

Notation "a ^*" := (Cconj a) (at level 10) : ℂ_scope.

Lemma Cconj_R : forall r : R, r^* = r.         Proof. intros; lca. Qed.
Lemma Cconj_0 : 0^* = 0.                  Proof. lca. Qed.
Lemma Cconj_opp : forall C, (- C)^* = - (C^*). Proof. reflexivity. Qed.
Lemma Cconj_rad2 : (/ √2)^* = / √2.       Proof. lca. Qed.
Lemma Cconj_involutive : forall c, (c^*)^* = c. Proof. intros; lca. Qed.
Lemma Cconj_plus_distr : forall (x y : ℂ), (x + y)^* = x^* + y^*. Proof. intros; lca. Qed.
Lemma Cconj_mult_distr : forall (x y : ℂ), (x * y)^* = x^* * y^*. Proof. intros; lca. Qed.

Lemma Cconj_mult_norm2 : forall c, c^* * c = ⎸c ⎸².
Proof. move => c. rewrite /Cconj /Cnorm2. by lca. Qed.

(** Note that the type is ℂ in this equation. *)
Lemma mult_Cconj_norm2 : forall c, c * c^* = ⎸c ⎸².
Proof. move => c. rewrite Cmult_comm. by apply Cconj_mult_norm2. Qed.

(* ================================================================= *)
(** ** Solving equations with square roots *)

(* Dealing with square roots is important for quantum computing,
   so we'll prove a few lemmas and add some automation here. *)

Lemma Csqrt_inv : forall (r : R), 0 < r -> R2C (√ (/ r)) = (/ √ r).
Proof.
  intros r H.
  apply c_proj_eq; simpl.
  field_simplify_eq [(@pow2_sqrt r (or_introl H)) (@sqrt_inv r H)].
  rewrite Rinv_r. reflexivity.
  apply sqrt_neq_0_compat; lra.
  apply sqrt_neq_0_compat; lra.
  field. apply sqrt_neq_0_compat; lra.
Qed.

Lemma Csqrt2_inv : R2C (√ (/ 2)) = (/ √ 2).
Proof. apply Csqrt_inv; lra. Qed.

Lemma Csqrt2_square : √2 * √2 = 2.
Proof.
  eapply c_proj_eq; simpl; try lra.
  rewrite Rmult_0_r Rminus_0_r.
  apply sqrt_def.
  lra.
Qed.

Ltac nonzero :=
  repeat match goal with
  | |- _ /\ _ => split
  end;
  try match goal with
  | |- (?x <> 0)%ℂ  => apply R2C_neq
  end;
  repeat match goal with
  | |- (√?x <> 0)%R  => apply sqrt_neq_0_compat
  | |- (/?x <> 0)%R  => apply Rinv_neq_0_compat
  end;
  match goal with
  | |- (_ <> _)%R        => lra
  | |- (_ < _)%R        => lra
  end.

Ltac R_field_simplify := repeat field_simplify_eq [pow2_sqrt2 sqrt2_inv];
                         try nonzero.
Ltac R_field := R_field_simplify; reflexivity.
Ltac C_field_simplify := repeat field_simplify_eq [Csqrt2_square Csqrt2_inv];
                         try nonzero.
Ltac C_field := C_field_simplify; reflexivity.

End ComplexTheory.