Require Export FunctionalExtensionality.
Require Export PropExtensionality.
Require Export List.
Require Export Sorting.
Require Export PeanoNat.
Require Export ZArith.

Proposition In_remove (T: Type)
    (eq_dec: forall (x y: T), {x = y} + {x <> y})
    (x y: T) (xs: list T):
  In x xs -> y <> x -> In x (remove eq_dec y xs).
induction xs; intros; inversion H;
simpl; destruct (eq_dec y a).
exfalso. apply H0. rewrite <- H1. auto.
rewrite H1. left. reflexivity.
apply IHxs; assumption.
right. apply IHxs; assumption.
Qed.

Proposition In_remove_elim (T: Type)
    (eq_dec: forall (x y: T), {x = y} + {x <> y})
    (x y: T) (xs: list T):
  y <> x -> In x (remove eq_dec y xs) -> In x xs.
induction xs; intros; simpl in H0.
inversion H0.
specialize (IHxs H).
destruct (eq_dec y a).
specialize (IHxs H0). right. assumption.
inversion H0. rewrite H1. left. auto.
specialize (IHxs H1). right. assumption.
Qed.

(* ========= *)
(* VARIABLES *)
(* ========= *)

Definition V := nat.
Definition dummy: V := 0.

(* ========================================= *)
(* FRESHNESS OF VARIABLES AND ITS PROPERTIES *)
(* ========================================= *)

Fixpoint maximum (xs: list V): V :=
  match xs with
  | nil => dummy
  | (x::xs) => max x (maximum xs)
  end.
Proposition maximum_prop (xs: list V):
  forall x, In x xs -> x <= maximum xs.
intros. induction xs. inversion H.
simpl. destruct H.
rewrite H.
apply Nat.le_max_l.
destruct (le_gt_dec a (maximum xs)).
rewrite max_r; try assumption.
apply IHxs; assumption.
unfold gt in g.
apply Nat.lt_le_incl in g.
rewrite max_l; try assumption.
eapply le_trans.
apply IHxs; assumption.
assumption.
Qed.
Proposition maximum_In (xs: list V):
  xs <> nil -> In (maximum xs) xs.
intro. destruct xs.
exfalso; apply H; reflexivity.
induction xs.
simpl. left. unfold dummy.
rewrite Nat.max_0_r; reflexivity.
simpl.
assert (In (maximum (v :: xs)) (v :: xs)).
  apply IHxs. intro. inversion H0. clear IHxs.
inversion H0. simpl in H1.
destruct (Nat.max_dec a (maximum xs)).
rewrite e.
destruct (Nat.max_dec v a).
left. auto.
right. left. auto.
left. rewrite e. auto.
destruct (Nat.max_dec a (maximum xs)).
rewrite e.
destruct (Nat.max_dec v a).
left. auto.
right. left. auto.
rewrite e.
right. right. apply H1.
Qed.

Proposition maximum_app (xs ys: list V):
  maximum (xs ++ ys) = max (maximum xs) (maximum ys).
induction xs; simpl. reflexivity.
rewrite IHxs.
apply Nat.max_assoc.
Qed.

Proposition maximum_subset (xs zs: list V):
  (forall x : V, In x xs -> In x zs) -> maximum xs <= maximum zs.
intro. destruct xs.
simpl. unfold dummy.
apply Nat.le_0_l.
pose proof (maximum_prop zs).
pose proof (maximum_In (v :: xs)).
apply H0. apply H. apply H1. intro. inversion H2.
Qed.

Definition fresh (xs: list V): V := S (maximum xs).
Proposition fresh_prop (xs: list V):
  forall x, In x xs -> x < fresh xs.
unfold fresh.
intros. apply le_lt_n_Sm.
apply maximum_prop; assumption.
Qed.
Proposition fresh_notIn (xs: list V):
  ~In (fresh xs) xs.
intro.
pose proof (fresh_prop xs).
specialize H0 with (fresh xs).
specialize (H0 H).
eapply Nat.lt_irrefl. apply H0.
Qed.

Proposition fresh_app (xs ys: list V):
  fresh (xs ++ ys) = max (fresh xs) (fresh ys).
unfold fresh.
rewrite maximum_app.
simpl. reflexivity.
Qed.

Proposition fresh_notInApp (xs ys: list V):
  ~In (fresh (xs ++ ys)) xs.
rewrite fresh_app.
destruct (Nat.max_dec (fresh xs) (fresh ys)).
rewrite e. apply fresh_notIn.
rewrite e.
pose proof (Max.le_max_l (fresh xs) (fresh ys)).
rewrite e in H.
destruct (Nat.eq_dec (fresh xs) (fresh ys)).
rewrite <- e0. apply fresh_notIn.
apply Nat.le_lteq in H. destruct H. clear n.
intro.
apply fresh_prop in H0.
eapply Nat.lt_irrefl.
eapply Nat.lt_trans. apply H. apply H0.
exfalso. apply n. assumption.
Qed.

Proposition fresh_notInGeneral (xs zs: list V):
  (forall x, In x xs -> In x zs) -> ~In (fresh zs) xs.
intro.
apply maximum_subset in H.
unfold fresh.
intro.
apply maximum_prop in H0.
eapply le_trans in H; [|apply H0].
eapply Nat.nle_succ_diag_l. apply H.
Qed.

(* ========= *)
(* THE STORE *)
(* ========= *)

Definition store := V -> Z.

Definition store_update (s: store) (x: V) (v: Z): store :=
  fun y => if Nat.eq_dec x y then v else s y.

Proposition store_update_lookup_same (s: store) (x: V) (v: Z):
  store_update s x v x = v.
unfold store_update.
destruct (Nat.eq_dec x x).
reflexivity.
exfalso. apply n. reflexivity.
Qed.

Proposition store_update_lookup_diff (s: store) (x x': V) (v: Z):
  x <> x' -> store_update s x v x' = s x'.
intros. unfold store_update.
destruct (Nat.eq_dec x x').
exfalso. apply H; assumption.
reflexivity.
Qed.

Proposition store_update_id (s: store) (x: V):
  store_update s x (s x) = s.
apply functional_extensionality; intro.
unfold store_update.
destruct (Nat.eq_dec x x0).
rewrite e; reflexivity.
reflexivity.
Qed.

Proposition store_update_collapse (s: store) (x: V) (v w: Z):
  (store_update (store_update s x v) x w) =
  (store_update s x w).
apply functional_extensionality; intro z.
unfold store_update.
destruct (Nat.eq_dec x z); reflexivity.
Qed.

Proposition store_update_swap (s: store) (e: Z) (x y: V) (v: Z):
  x <> y ->
  (store_update (store_update s x e) y v) =
  (store_update (store_update s y v) x e).
intros G; apply functional_extensionality; intro z.
unfold store_update.
destruct (Nat.eq_dec y z); destruct (Nat.eq_dec x z); try reflexivity.
exfalso. apply G. rewrite e0; rewrite e1. reflexivity.
Qed.

Definition eq_restr (s t: store) (z: list V): Prop :=
  forall (x: V), In x z -> s x = t x.

Proposition eq_restr_split (s t: store) (xs ys: list V):
  eq_restr s t (xs ++ ys) -> eq_restr s t xs /\ eq_restr s t ys.
unfold eq_restr; intro; split; intros;
apply H; apply in_or_app; auto.
Qed.

Proposition eq_restr_cons (s t: store) (x: V) (xs: list V):
  eq_restr s t (x :: xs) -> s x = t x /\ eq_restr s t xs.
intros; split.
apply H. left; auto.
intro; intro.
apply H. right; auto.
Qed.

Proposition eq_restr_comm (s t: store) (xs: list V):
  eq_restr s t xs -> eq_restr t s xs.
unfold eq_restr; intros; symmetry; apply H; assumption.
Qed.

Proposition eq_restr_incl (s t: store) (xs ys: list V):
  (forall x, In x ys -> In x xs) ->
  eq_restr s t xs -> eq_restr s t ys.
intros. intro; intro.
apply H in H1.
apply H0; auto.
Qed.

Proposition eq_restr_store_update (s t: store) (x: V) (v: Z) (xs: list V):
  eq_restr s t xs -> eq_restr (store_update s x v) (store_update t x v) xs.
intros. intro; intro.
unfold store_update. destruct (Nat.eq_dec x x0). reflexivity.
apply H. auto.
Qed.

(* ====================== *)
(* EXPRESSIONS AND GUARDS *)
(* ====================== *)

(* Expressions and guards are shallow, but finitely based *)
Record expr: Set := mkexpr {
  eval: store -> Z;
  evar: list V;
  econd: forall (s t: store), eq_restr s t evar -> eval s = eval t
}.
Coercion eval: expr >-> Funclass.

Proposition const_expr_cond (v: Z) (s t : store):
  eq_restr s t nil -> v = v.
intros. reflexivity.
Qed.
Definition const_expr (v: Z): expr :=
  mkexpr (fun s => v) nil (const_expr_cond v).
Coercion const_expr: Z >-> expr.
Proposition var_expr_cond (x: V) (s t : store):
  eq_restr s t (x :: nil) -> s x = t x.
intro. unfold eq_restr in H.
specialize H with x. apply H.
left. reflexivity.
Qed.
Definition var_expr (x: V): expr :=
  mkexpr (fun s => s x) (x :: nil) (var_expr_cond x).
Coercion var_expr: V >-> expr.

Proposition esub_cond (e: expr) (x: V) (e': expr) (s t : store):
  eq_restr s t (remove Nat.eq_dec x (evar e) ++ evar e') ->
  eval e (store_update s x (eval e' s)) =
    eval e (store_update t x (eval e' t)).
intro.
assert (eval e' s = eval e' t).
apply (econd e').
intro; intro; apply H.
apply in_or_app; right; assumption.
rewrite <- H0.
unfold store_update.
apply (econd e).
unfold eq_restr.
intro; intro.
destruct (Nat.eq_dec x x0).
reflexivity.
apply H; apply in_or_app; left.
apply In_remove; assumption.
Qed.
Definition esub (e: expr) (x: V) (e': expr): expr :=
  mkexpr (fun s => eval e (store_update s x (eval e' s)))
    (remove Nat.eq_dec x (evar e) ++ evar e') (esub_cond e x e').

Proposition esub_simpl (e: expr) (x: V) (e': expr):
  ~In x (evar e) -> forall s, eval (esub e x e') s = eval e s.
intros. simpl.
apply econd. intro. intro.
unfold store_update.
destruct (Nat.eq_dec x x0).
exfalso. apply H. rewrite e0. assumption.
reflexivity.
Qed.

Proposition esub_notInVar (e: expr) (x: V) (e': expr):
  ~In x (evar e') -> ~ In x (evar (esub e x e')).
intros; simpl; intro.
apply in_app_or in H0; destruct H0.
eapply remove_In; apply H0.
apply H; auto.
Qed.

Proposition expr_eq (e1 e2: expr):
  (eval e1 = eval e2) -> (evar e1 = evar e2) -> e1 = e2.
intros. destruct e1. destruct e2.
simpl in *. revert econd0. rewrite H. rewrite H0.
intro. pose proof (proof_irrelevance _ econd0 econd1).
rewrite H1. reflexivity.
Qed.

Record guard: Set := mkguard {
  gval: store -> bool;
  gvar: list V;
  gcond: forall (s t: store), eq_restr s t gvar -> gval s = gval t
}.
Coercion gval: guard >-> Funclass.

Proposition const_guard_cond (v: bool) (s t : store):
  eq_restr s t nil -> v = v.
intros. reflexivity.
Qed.
Definition const_guard (v: bool): guard :=
  mkguard (fun s => v) nil (const_guard_cond v).
Coercion const_guard: bool >-> guard.

Proposition equals_cond (e1 e2: expr) (s t : store):
  eq_restr s t (evar e1 ++ evar e2) ->
  (if Z.eq_dec (eval e1 s) (eval e2 s) then true else false) =
  (if Z.eq_dec (eval e1 t) (eval e2 t) then true else false).
intro H.
apply eq_restr_split in H; destruct H.
pose proof (econd e1 s t); rewrite H1.
pose proof (econd e2 s t); rewrite H2.
all: auto.
Qed.
Definition equals (e1 e2: expr): guard :=
  mkguard (fun s => if Z.eq_dec (eval e1 s) (eval e2 s) then
    true else false) (evar e1 ++ evar e2) (equals_cond e1 e2).

Proposition gsub_cond (g: guard) (x: V) (e: expr) (s t: store):
  eq_restr s t (remove Nat.eq_dec x (gvar g) ++ evar e) ->
  gval g (store_update s x (eval e s)) =
  gval g (store_update t x (eval e t)).
intro.
assert (eval e s = eval e t).
apply (econd e).
intro; intro; apply H.
apply in_or_app; right; assumption.
rewrite <- H0.
unfold store_update.
apply (gcond g).
unfold eq_restr.
intro; intro.
destruct (Nat.eq_dec x x0).
reflexivity.
apply H; apply in_or_app; left.
apply In_remove; assumption.
Qed.
Definition gsub (g: guard) (x: V) (e: expr): guard :=
  mkguard (fun s => gval g (store_update s x (eval e s)))
    (remove Nat.eq_dec x (gvar g) ++ evar e) (gsub_cond g x e).

Proposition gsub_notInVar (g: guard) (x:V) (e: expr):
  ~In x (evar e) -> ~In x (gvar (gsub g x e)).
intros; simpl; intro.
apply in_app_or in H0; destruct H0.
eapply remove_In; apply H0.
apply H. assumption.
Qed.

Proposition guard_eq (g1 g2: guard):
  (gval g1 = gval g2) -> (gvar g1 = gvar g2) -> g1 = g2.
intros. destruct g1. destruct g2.
simpl in *. revert gcond0. rewrite H. rewrite H0.
intro. pose proof (proof_irrelevance _ gcond0 gcond1).
rewrite H1. reflexivity.
Qed.

(* ==================== *)
(* CLASSICAL ASSERTIONS *)
(* ==================== *)

Definition heap := Z -> option Z.

Definition heap_update (h: heap) (k v: Z): heap :=
  fun n => if Z.eq_dec k n then Some v else h n.

Definition heap_clear (h: heap) (k: Z): heap :=
  fun n => if Z.eq_dec k n then None else h n.

Definition dom (h: heap) (k: Z): Prop := h k <> None.

Definition Partition (h h1 h2: heap): Prop :=
  (forall k, (dom h k -> dom h1 k \/ dom h2 k)) /\
  (forall k, ~(dom h1 k /\ dom h2 k)) /\
  (forall k, dom h1 k -> h k = h1 k) /\
  (forall k, dom h2 k -> h k = h2 k).

(* Assertions are shallow, but finitely based *)
Record cassert: Type := mkcassert {
  cval: heap * store -> Prop;
  cvar: list V;
  ccond: forall (h: heap) (s t: store), eq_restr s t cvar -> cval (h, s) <-> cval (h, t);
  cstable: forall (h: heap) (s: store), ~~cval (h, s) -> cval (h, s)
}.
Coercion cval: cassert >-> Funclass.

Proposition ctest_cond (g: guard):
  forall (h : heap) (s t : store),
   eq_restr s t (gvar g) -> g s = true <-> g t = true.
intros.
rewrite gcond with (t := t).
apply iff_refl.
assumption.
Qed.
Proposition ctest_stable (g: guard):
  forall (h : heap) (s : store),
   ~ ~ g s = true -> g s = true.
intros. destruct (g s); auto.
Qed.
Definition ctest (g: guard): cassert :=
  mkcassert (fun '(h, s) => gval g s = true) (gvar g) (ctest_cond g) (ctest_stable g).

Proposition chasval_cond (e1 e2: expr):
  forall (h : heap) (s t : store),
   eq_restr s t (evar e1 ++ evar e2) ->
   h (e1 s) = Some (e2 s) <->
   h (e1 t) = Some (e2 t).
intros.
apply eq_restr_split in H; destruct H.
split; intro.
- rewrite <- econd with (s := s); auto.
  rewrite <- (econd e2) with (s := s); auto.
- rewrite econd with (t := t); auto.
  rewrite (econd e2) with (t := t); auto.
Qed.
Proposition chasval_stable (e1 e2: expr):
  forall (h : heap) (s : store),
   ~ ~ (h (e1 s) = Some (e2 s)) ->
   h (e1 s) = Some (e2 s).
intros.
destruct (h (e1 s)).
remember (e2 s).
destruct (Z.eq_dec z z0).
rewrite e; auto.
exfalso; apply H. intro. inversion H0.
apply n; auto.
exfalso.
apply H. intro. inversion H0.
Qed.
Definition chasval (e1 e2: expr): cassert :=
  mkcassert (fun '(h, s) => h (e1 s) = Some (e2 s)) (evar e1 ++ evar e2)
    (chasval_cond e1 e2) (chasval_stable e1 e2).

Proposition cland_cond (p q: cassert):
  forall (h : heap) (s t : store),
   eq_restr s t (cvar p ++ cvar q) ->
   p (h, s) /\ q (h, s) <->
   p (h, t) /\ q (h, t).
intros.
apply eq_restr_split in H; destruct H.
split; intro; destruct H1.
rewrite ccond with (t := t) in H1; auto.
rewrite ccond with (t := t) in H2; auto.
rewrite <- ccond with (s := s) in H1; auto.
rewrite <- ccond with (s := s) in H2; auto.
Qed.
Proposition cland_stable (p q: cassert):
  forall (h : heap) (s : store),
   ~ ~ (p (h, s) /\ q (h, s)) ->
   p (h, s) /\ q (h, s).
intros; split; apply cstable; intro;
apply H; intro; destruct H1; apply H0; auto.
Qed.
Definition cland (p q: cassert): cassert :=
  mkcassert (fun '(h, s) => p (h, s) /\ q (h, s)) (cvar p ++ cvar q)
    (cland_cond p q) (cland_stable p q).

Proposition clor_cond (p q: cassert):
  forall (h : heap) (s t : store),
   eq_restr s t (cvar p ++ cvar q) ->
   ~(~p (h, s) /\ ~q (h, s)) <->
   ~(~p (h, t) /\ ~q (h, t)).
intros.
apply eq_restr_split in H; destruct H.
split; intro; intro; destruct H2;
apply H1; split; intro.
rewrite ccond with (t := t) in H4; auto.
rewrite ccond with (t := t) in H4; auto.
rewrite <- ccond with (s := s) in H4; auto.
rewrite <- ccond with (s := s) in H4; auto.
Qed.
Proposition clor_stable (p q: cassert):
  forall (h : heap) (s : store),
   ~ ~ (~(~p (h, s) /\ ~q (h, s))) ->
   ~(~p (h, s) /\ ~q (h, s)).
intros; intro; destruct H0.
apply H; intro; apply H2; split; auto.
Qed.
Definition clor (p q: cassert): cassert :=
  mkcassert (fun '(h, s) => ~(~p (h, s) /\ ~q (h, s))) (cvar p ++ cvar q)
    (clor_cond p q) (clor_stable p q).

Proposition climp_cond (p q: cassert):
  forall (h : heap) (s t : store),
   eq_restr s t (cvar p ++ cvar q) ->
   (p (h, s) -> q (h, s)) <->
   (p (h, t) -> q (h, t)).
intros.
apply eq_restr_split in H; destruct H.
split; intros.
apply ccond with (s := s); auto.
apply H1.
apply ccond with (t := t); auto.
apply ccond with (t := t); auto.
apply H1.
apply ccond with (s := s); auto.
Qed.
Proposition climp_stable (p q: cassert):
  forall (h : heap) (s : store),
   ~ ~ (p (h, s) -> q (h, s)) ->
   (p (h, s) -> q (h, s)).
intros.
apply cstable; intro.
apply H; intro.
apply H1; apply H2; auto.
Qed.
Definition climp (p q: cassert): cassert :=
  mkcassert (fun '(h, s) => p (h, s) -> q (h, s)) (cvar p ++ cvar q)
    (climp_cond p q) (climp_stable p q).

Proposition clexists_cond (x: V) (p: cassert):
  forall (h : heap) (s t : store),
   eq_restr s t (remove Nat.eq_dec x (cvar p)) ->
   ~ (forall v : Z, ~ p (h, store_update s x v)) <->
   ~ (forall v : Z, ~ p (h, store_update t x v)).
intros; split; intro; intro; apply H0; intro; intro.
- apply H1 with (v := v).
  apply ccond with (s := store_update s x v); auto.
  intro; intro; unfold store_update.
  destruct (Nat.eq_dec x x0); auto.
  apply H.
  apply In_remove; auto.
- apply H1 with (v := v).
  apply ccond with (t := store_update t x v); auto.
  intro; intro; unfold store_update.
  destruct (Nat.eq_dec x x0); auto.
  apply H.
  apply In_remove; auto.
Qed.
Proposition clexists_stable (x: V) (p: cassert):
  forall (h : heap) (s : store),
   ~ ~ ~ (forall v : Z, ~ p (h, store_update s x v)) ->
   ~ (forall v : Z, ~ p (h, store_update s x v)).
intros; intro.
apply H; intro; apply H1; intros; intro.
apply H0 with (v := v).
auto.
Qed.
Definition clexists (x: V) (p: cassert): cassert :=
  mkcassert (fun '(h, s) => ~forall v, ~p (h, store_update s x v)) (remove Nat.eq_dec x (cvar p))
  (clexists_cond x p) (clexists_stable x p).

Proposition clforall_cond (x: V) (p: cassert):
  forall (h : heap) (s t : store),
   eq_restr s t (remove Nat.eq_dec x (cvar p)) ->
   (forall v : Z, p (h, store_update s x v)) <->
   (forall v : Z, p (h, store_update t x v)).
intros; split; intro; intro.
- apply ccond with (s := store_update s x v).
  intro; intro; unfold store_update.
  destruct (Nat.eq_dec x x0); auto.
  apply H.
  apply In_remove; auto.
  apply H0.
- apply ccond with (t := store_update t x v).
  intro; intro; unfold store_update.
  destruct (Nat.eq_dec x x0); auto.
  apply H.
  apply In_remove; auto.
  apply H0.
Qed.
Proposition clforall_stable (x: V) (p: cassert):
  forall (h : heap) (s : store),
   ~ ~ (forall v : Z, p (h, store_update s x v)) ->
   (forall v : Z, p (h, store_update s x v)).
intros. apply cstable; intro. apply H; intro.
apply H0.
apply H1.
Qed.
Definition clforall (x: V) (p: cassert): cassert :=
  mkcassert (fun '(h, s) => forall v, p (h, store_update s x v)) (remove Nat.eq_dec x (cvar p))
  (clforall_cond x p) (clforall_stable x p).

Proposition csand_cond (p q: cassert):
  forall (h : heap) (s t : store),
   eq_restr s t (cvar p ++ cvar q) ->
   ~ (forall h1 h2 : heap, ~ (Partition h h1 h2 /\ p (h1, s) /\ q (h2, s))) <->
   ~ (forall h1 h2 : heap, ~ (Partition h h1 h2 /\ p (h1, t) /\ q (h2, t))).
intros; split; intro; intro; apply H0; intros; intro.
- destruct H2.
  eapply H1. split. apply H2.
  destruct H3.
  apply eq_restr_split in H; destruct H.
  split.
  apply ccond with (s := s); auto.
  apply ccond with (s := s); auto.
- destruct H2.
  eapply H1. split. apply H2.
  destruct H3.
  apply eq_restr_split in H; destruct H.
  split.
  apply ccond with (t := t); auto.
  apply ccond with (t := t); auto.
Qed.
Proposition csand_stable (p q: cassert):
  forall (h : heap) (s : store),
   ~ ~ ~ (forall h1 h2 : heap, ~ (Partition h h1 h2 /\ p (h1, s) /\ q (h2, s))) ->
   ~ (forall h1 h2 : heap, ~ (Partition h h1 h2 /\ p (h1, s) /\ q (h2, s))).
intros; intro. apply H; intro. auto.
Qed.
Definition csand (p q: cassert): cassert :=
  mkcassert (fun '(h, s) => ~forall h1 h2, ~(Partition h h1 h2 /\ p (h1, s) /\ q (h2, s)))
    (cvar p ++ cvar q) (csand_cond p q) (csand_stable p q).

Proposition csimp_cond (p q: cassert):
  forall (h : heap) (s t : store),
   eq_restr s t (cvar p ++ cvar q) ->
   (forall h'' h' : heap, Partition h'' h h' -> p (h', s) -> q (h'', s)) <->
   forall h'' h' : heap, Partition h'' h h' -> p (h', t) -> q (h'', t).
intros.
apply eq_restr_split in H; destruct H.
split; intro; intros.
apply ccond with (s := s); auto.
apply H1 with (h' := h'); auto.
apply ccond with (t := t); auto.
apply ccond with (t := t); auto.
apply H1 with (h' := h'); auto.
apply ccond with (s := s); auto.
Qed.
Proposition csimp_stable (p q: cassert):
  forall (h : heap) (s : store),
   ~ ~ (forall h'' h' : heap, Partition h'' h h' -> p (h', s) -> q (h'', s)) ->
   forall h'' h' : heap, Partition h'' h h' -> p (h', s) -> q (h'', s).
intros. apply cstable; intro. apply H; intro. apply H2.
apply H3 with (h' := h'); auto.
Qed.
Definition csimp (p q: cassert): cassert :=
  mkcassert (fun '(h, s) => forall h'' h', Partition h'' h h' -> p (h', s) -> q (h'', s))
    (cvar p ++ cvar q) (csimp_cond p q) (csimp_stable p q).

(* Abbreviations *)

Definition cltrue: cassert := (ctest true).
Definition clfalse: cassert := (ctest false).
Definition clnot (p: cassert): cassert := (climp p clfalse).
Definition clequiv (p q: cassert): cassert := (cland (climp p q) (climp q p)).
Definition chasvaldash (e: expr): cassert :=
  let y := fresh (evar e) in clexists y (chasval e y).
Definition cemp: cassert := (clforall dummy (clnot (chasvaldash dummy))).
Definition cpointsto (e e': expr): cassert :=
  let x := fresh (evar e) in cland (chasval e e') (clforall x (climp (chasvaldash x) (ctest (equals x e)))).
Definition cpointstodash (e: expr): cassert :=
  let y := fresh (evar e) in clexists y (cpointsto e y).
Definition chasval_alt (e e': expr): cassert :=
  csand (cpointsto e e') (ctest true).
Definition chasvaldash_alt (e: expr): cassert :=
  csand (cpointstodash e) (ctest true).

(* Operations on assertions *)

Proposition csub_cond (p: cassert) (x: V) (e: expr):
  forall (h : heap) (s t : store),
   eq_restr s t (remove Nat.eq_dec x (cvar p) ++ evar e) ->
   p (h, store_update s x (e s)) <->
   p (h, store_update t x (e t)).
intros.
apply eq_restr_split in H; destruct H.
split; intro.
- pose proof (econd e s t H0).
  rewrite <- H2.
  apply ccond with (s := store_update s x (e s)); auto.
  intro; intro; unfold store_update.
  destruct (Nat.eq_dec x x0); auto.
  apply H.
  apply In_remove; auto.
- pose proof (econd e s t H0).
  rewrite H2.
  apply ccond with (t := store_update t x (e t)); auto.
  intro; intro; unfold store_update.
  destruct (Nat.eq_dec x x0); auto.
  apply H.
  apply In_remove; auto.
Qed.
Proposition csub_stable (p: cassert) (x: V) (e: expr):
  forall (h : heap) (s : store),
   ~ ~ p (h, store_update s x (e s)) ->
   p (h, store_update s x (e s)).
intros. apply cstable. auto.
Qed.
Definition csub (p: cassert) (x: V) (e: expr): cassert :=
  mkcassert (fun '(h, s) => p (h, store_update s x (eval e s)))
    (remove Nat.eq_dec x (cvar p) ++ evar e) (csub_cond p x e) (csub_stable p x e).

Proposition csub_heap_update_cond (p: cassert) (x: V) (e: expr):
  forall (h : heap) (s t : store),
   eq_restr s t (x :: cvar p ++ evar e) ->
   p (heap_update h (s x) (e s), s) <->
   p (heap_update h (t x) (e t), t).
intros.
apply eq_restr_cons in H; destruct H.
apply eq_restr_split in H0; destruct H0.
rewrite H.
pose proof (econd e s t H1).
rewrite H2.
apply ccond.
auto.
Qed.
Proposition csub_heap_update_stable (p: cassert) (x: V) (e: expr):
  forall (h : heap) (s : store),
   ~ ~ p (heap_update h (s x) (e s), s) ->
   p (heap_update h (s x) (e s), s).
intros. apply cstable. auto.
Qed.
Definition csub_heap_update (p: cassert) (x: V) (e: expr): cassert :=
  mkcassert (fun '(h, s) => p (heap_update h (s x) (e s), s))
    (x :: cvar p ++ evar e) (csub_heap_update_cond p x e) (csub_heap_update_stable p x e).

Proposition csub_heap_clear_cond (p: cassert) (x: V):
  forall (h : heap) (s t : store),
   eq_restr s t (x :: cvar p) ->
   p (heap_clear h (s x), s) <->
   p (heap_clear h (t x), t).
intros.
apply eq_restr_cons in H; destruct H.
rewrite H.
apply ccond.
auto.
Qed.
Proposition csub_heap_clear_stable (p: cassert) (x: V):
  forall (h : heap) (s : store),
   ~ ~ p (heap_clear h (s x), s) ->
   p (heap_clear h (s x), s).
intros. apply cstable. assumption.
Qed.
Definition csub_heap_clear (p: cassert) (x: V): cassert :=
  mkcassert (fun '(h, s) => p (heap_clear h (s x), s))
    (x :: cvar p) (csub_heap_clear_cond p x) (csub_heap_clear_stable p x).

(* Properties of assertions *)
Definition valid (p: cassert): Prop :=
  forall (h: heap) (s: store), p (h, s).

(* ===================================== *)
(* BASIC INSTRUCTIONS AND WHILE PROGRAMS *)
(* ===================================== *)

Inductive assignment :=
| basic: V -> expr -> assignment
| lookup: V -> expr -> assignment
| mutation: V -> expr -> assignment
| new: V -> expr -> assignment
| dispose: V -> assignment.

Definition avar (a: assignment): list V :=
  match a with
  | basic x e => x :: evar e
  | lookup x e => x :: evar e
  | mutation x e => x :: evar e
  | new x e => x :: evar e
  | dispose x => x :: nil
  end.

Inductive program :=
| assign: assignment -> program
| diverge: program
| skip: program
| comp: program -> program -> program
| ite: guard -> program -> program -> program
| while: guard -> program -> program.
Coercion assign: assignment >-> program.

Fixpoint pvar (p: program): list V :=
  match p with
  | assign a => avar a
  | diverge => nil
  | skip => nil
  | comp S1 S2 => pvar S1 ++ pvar S2
  | ite g S1 S2 => gvar g ++ pvar S1 ++ pvar S2
  | while g S1 => gvar g ++ pvar S1
  end.

(* ================================================ *)
(* SEMANTICS OF PROGRAMS, SEE FIGURE 1 IN THE PAPER *)
(* ================================================ *)

Inductive bigstep: program -> heap * store -> option (heap * store) -> Prop :=
| step_basic (x: V) (e: expr) (h: heap) (s: store):
    bigstep (basic x e) (h, s) (Some (h, store_update s x (eval e s)))
| step_lookup (x: V) (e: expr) (h: heap) (s: store) (v: Z):
    h (eval e s) = Some v ->
    bigstep (lookup x e) (h, s) (Some (h, store_update s x v))
| step_lookup_fail (x: V) (e: expr) (h: heap) (s: store):
    h (eval e s) = None ->
    bigstep (lookup x e) (h, s) None
| step_mutation (x: V) (e: expr) (h: heap) (s: store):
    dom h (s x) ->
    bigstep (mutation x e) (h, s) (Some (heap_update h (s x) (eval e s), s))
| step_mutation_fail (x: V) (e: expr) (h: heap) (s: store):
    ~dom h (s x) ->
    bigstep (mutation x e) (h, s) None
| step_new (x: V) (e: expr) (h: heap) (s: store) (n: Z):
    ~(dom h n) ->
    bigstep (new x e) (h, s)
      (Some (heap_update h n (eval e s), store_update s x n))
| step_dispose (x: V) (h: heap) (s: store):
    dom h (s x) ->
    bigstep (dispose x) (h, s) (Some (heap_clear h (s x), s))
| step_dispose_fail (x: V) (h: heap) (s: store):
    ~dom h (s x) ->
    bigstep (dispose x) (h, s) None
| step_skip (h: heap) (s: store):
    bigstep skip (h, s) (Some (h, s))
| step_comp (S1 S2: program) (h h' h'': heap) (s s' s'': store):
    bigstep S1 (h, s) (Some (h', s')) ->
    bigstep S2 (h', s') (Some (h'', s'')) ->
    bigstep (comp S1 S2) (h, s) (Some (h'', s''))
| step_comp_fail1 (S1 S2: program) (h: heap) (s: store):
    bigstep S1 (h, s) None ->
    bigstep (comp S1 S2) (h, s) None
| step_comp_fail2 (S1 S2: program) (h h': heap) (s s': store):
    bigstep S1 (h, s) (Some (h', s')) ->
    bigstep S2 (h', s') None ->
    bigstep (comp S1 S2) (h, s) None
| step_ite_true (g: guard) (S1 S2: program) (h: heap) (s: store) o:
    g s = true ->
    bigstep S1 (h, s) o ->
    bigstep (ite g S1 S2) (h, s) o
| step_ite_false (g: guard) (S1 S2: program) (h: heap) (s: store) o:
    g s = false ->
    bigstep S2 (h, s) o ->
    bigstep (ite g S1 S2) (h, s) o
| step_while_true (g: guard) (S1: program) (h h': heap) (s s': store) o:
    g s = true ->
    bigstep S1 (h, s) (Some (h', s')) ->
    bigstep (while g S1) (h', s') o ->
    bigstep (while g S1) (h, s) o
| step_while_false (g: guard) (S1: program) (h: heap) (s: store):
    g s = false ->
    bigstep (while g S1) (h, s) (Some (h, s))
| step_while_fail (g: guard) (S1: program) (h: heap) (s: store):
    g s = true ->
    bigstep S1 (h, s) None ->
    bigstep (while g S1) (h, s) None.

Proposition diverge_empty (h: heap) (s: store):
  forall o, ~bigstep diverge (h, s) o.
intros; intro; inversion H.
Qed.

Proposition while_unfold (g: guard) (S1: program):
  forall h s o,
    bigstep (while g S1) (h, s) o <->
    bigstep (ite g (comp S1 (while g S1)) skip) (h, s) o.
intros. split; intros.
- inversion H.
  apply step_ite_true; auto.
  destruct o. destruct p.
  eapply step_comp. apply H6. apply H7.
  eapply step_comp_fail2. apply H6. apply H7.
  apply step_ite_false; auto.
  apply step_skip.
  apply step_ite_true; auto.
  apply step_comp_fail1; auto.
- inversion H.
  inversion H7.
  eapply step_while_true; auto.
  apply H13. apply H14.
  eapply step_while_fail; auto.
  eapply step_while_true; auto.
  apply H13. apply H14.
  inversion H7.
  apply step_while_false; auto.
Qed.

Fixpoint approx (n: nat) (g: guard) (S1: program): program :=
  match n with
  | O => diverge
  | S m => ite g (comp S1 (approx m g S1)) skip
  end.

Proposition while_approx (g: guard) (S1: program):
  forall h s o,
    bigstep (while g S1) (h, s) o <->
    exists n, bigstep (approx n g S1) (h, s) o.
intros; split; intro.
- remember (while g S1).
  induction H; try inversion Heqp.
  + apply IHbigstep2 in Heqp.
    destruct Heqp.
    exists (S x).
    simpl.
    apply step_ite_true.
    rewrite <- H3. apply H.
    destruct o; [destruct p|].
    eapply step_comp.
    rewrite <- H4. apply H0. apply H2.
    eapply step_comp_fail2.
    rewrite <- H4. apply H0. apply H2.
  + exists 1.
    simpl.
    apply step_ite_false.
    rewrite <- H1. apply H.
    apply step_skip.
  + exists 1.
    simpl.
    apply step_ite_true.
    rewrite <- H2. apply H.
    apply step_comp_fail1.
    rewrite <- H3. apply H0.
- destruct H.
  generalize dependent h.
  generalize dependent s.
  generalize dependent o.
  induction x; intros.
  + simpl in H.
    exfalso.
    pose proof (diverge_empty h s).
    specialize H0 with o.
    apply H0; auto.
  + simpl in H.
    inversion H.
    inversion H7.
    apply IHx in H14.
    eapply step_while_true.
    apply H6.
    apply H13.
    apply H14.
    apply step_while_fail.
    apply H6.
    apply H13.
    apply IHx in H14.
    eapply step_while_true.
    apply H6.
    apply H13.
    apply H14.
    inversion H7.
    eapply step_while_false.
    apply H6.
Qed.

Definition omega: program := while true skip.

Proposition omega_diverge_equiv:
  forall h s o,
    bigstep omega (h, s) o <->
    bigstep diverge (h, s) o.
intros. unfold omega.
rewrite while_approx.
split; intro.
destruct H.
generalize dependent s.
generalize dependent h.
induction x; intros; simpl in H.
auto.
inversion H.
inversion H7.
rewrite H11.
apply IHx.
inversion H13.
rewrite <- H11. assumption.
inversion H13.
rewrite H11.
apply IHx.
rewrite <- H11.
inversion H13. assumption.
inversion H6.
inversion H.
Qed.

(* ================ *)
(* PROGRAM MODALITY *)
(* ================ *)

Proposition bigstep_cond (S1: program) (p: heap * store) (o: option (heap * store)):
  bigstep S1 p o ->
  forall xs, (forall x, In x (pvar S1) -> In x xs) ->
  forall h s, (h, s) = p ->
  forall t, eq_restr s t xs ->
  (forall h' s', Some (h', s') = o ->
    exists t', eq_restr s' t' xs /\ bigstep S1 (h, t) (Some (h', t'))) /\
  (None = o ->
    bigstep S1 (h, t) None).
intro.
induction H; intros xs G h0 s0 G1 t G3; inversion G1; clear G1;
(split; [intros h'0 s'0 G2; inversion G2; clear G2 | intro G2; inversion G2; clear G2 ]).
- rewrite H1 in G3.
  exists (store_update t x (e t)). split.
  + intro; intro.
    unfold store_update.
    destruct (Nat.eq_dec x x0).
    apply econd.
    eapply eq_restr_incl; [|apply G3].
    intros. apply G. simpl; auto.
    apply G3; auto.
  + apply step_basic.
- exists (store_update t x v). split.
  + intro; intro.
    rewrite <- H2.
    unfold store_update.
    destruct (Nat.eq_dec x x0); auto.
  + apply step_lookup.
    pose proof (econd e s t).
    rewrite <- H0; auto.
    rewrite <- H2.
    eapply eq_restr_incl; [|apply G3].
    intros. apply G. simpl; auto.
- apply step_lookup_fail.
  erewrite <- econd. apply H.
  rewrite <- H2.
  eapply eq_restr_incl; [|apply G3].
  intros. apply G. simpl. auto.
- exists t. split.
  + rewrite <- H2. auto.
  + assert (s x = t x).
    { rewrite H2 in G3.
      apply G3. apply G. simpl. auto. }
    assert (e s = e t).
    { apply econd.
      eapply eq_restr_incl; [ | rewrite H2 in G3; apply G3].
      intros. apply G. simpl. auto. }
    rewrite H0.
    rewrite H5.
    apply step_mutation.
    rewrite <- H0. assumption.
- apply step_mutation_fail.
  assert (s x = t x).
  rewrite H2 in G3. apply G3.
  apply G. simpl. auto.
  rewrite <- H0. auto.
- exists (store_update t x n).
  split. rewrite H2 in G3.
  apply eq_restr_store_update; assumption.
  assert (e s = e t).
  { apply econd.
    eapply eq_restr_incl; [ | rewrite H2 in G3; apply G3].
    intros. apply G. simpl. auto. }
  rewrite H0.
  apply step_new. assumption.
- exists t. split.
  rewrite H2 in G3. auto.
  assert (s x = t x).
  { rewrite H2 in G3.
    apply G3. apply G. simpl. auto. }
  rewrite H0.
  apply step_dispose.
  rewrite <- H0. assumption.
- apply step_dispose_fail.
  assert (s x = t x).
  rewrite H2 in G3. apply G3.
  apply G. simpl. auto.
  rewrite <- H0. auto.
- exists t. split.
  rewrite <- H1. auto.
  apply step_skip.
- destruct IHbigstep1 with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app; auto. rewrite <- H3. auto.
  edestruct H1. reflexivity. destruct H7.
  destruct IHbigstep2 with (xs := xs) (h := h') (s := s') (t := x); auto.
  intros. apply G. simpl. apply in_or_app; auto.
  edestruct H9. reflexivity. destruct H11.
  exists x0. split; auto.
  eapply step_comp.
  apply H8.
  apply H12.
- apply step_comp_fail1.
  destruct IHbigstep with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app; auto. rewrite <- H2. auto.
- destruct IHbigstep1 with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app; auto. rewrite <- H3. auto.
  edestruct H1. reflexivity. destruct H5.
  eapply step_comp_fail2.
  apply H6.
  destruct IHbigstep2 with (xs := xs) (h := h') (s := s') (t := x); auto.
  intros. apply G. simpl. apply in_or_app; auto.
- destruct o. destruct p.
  destruct IHbigstep with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app. right. apply in_or_app; auto.
  rewrite <- H3; auto.
  destruct H4 with (h' := h1) (s' := s1); auto. destruct H6.
  inversion H1.
  exists x. split; auto.
  apply step_ite_true; auto.
  rewrite H3 in G3.
  rewrite <- gcond with (s := s); auto.
  eapply eq_restr_incl; [|apply G3]. intros.
  apply G. simpl. apply in_or_app; auto.
  inversion H1.
- destruct o. inversion H1.
  destruct IHbigstep with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app. right. apply in_or_app; auto.
  rewrite <- H3; auto.
  rewrite H3 in G3.
  apply step_ite_true.
  rewrite <- gcond with (s := s); auto.
  eapply eq_restr_incl; [|apply G3]. intros.
  apply G. simpl. apply in_or_app; auto.
  apply H5. auto.
- destruct o. destruct p.
  destruct IHbigstep with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app. right. apply in_or_app; auto.
  rewrite <- H3; auto.
  destruct H4 with (h' := h1) (s' := s1); auto. destruct H6.
  inversion H1.
  exists x. split; auto.
  apply step_ite_false; auto.
  rewrite H3 in G3.
  rewrite <- gcond with (s := s); auto.
  eapply eq_restr_incl; [|apply G3]. intros.
  apply G. simpl. apply in_or_app; auto.
  inversion H1.
- destruct o. inversion H1.
  destruct IHbigstep with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app. right. apply in_or_app; auto.
  rewrite <- H3; auto.
  rewrite H3 in G3.
  apply step_ite_false.
  rewrite <- gcond with (s := s); auto.
  eapply eq_restr_incl; [|apply G3]. intros.
  apply G. simpl. apply in_or_app; auto.
  apply H5. auto.
- destruct o; inversion H2. destruct p; inversion H6.
  destruct IHbigstep1 with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app; auto. rewrite H4 in G3; auto.
  destruct H5 with (h' := h') (s' := s'); auto. destruct H10.
  destruct IHbigstep2 with (xs := xs) (h := h') (s := s') (t := x); auto.
  destruct H12 with (h' := h1) (s' := s1); auto. destruct H14.
  exists x0.
  split; auto.
  eapply step_while_true.
  rewrite H4 in G3.
  rewrite <- gcond with (s := s); auto.
  intro; intro. apply G3. apply G. simpl. apply in_or_app; auto.
  apply H11.
  auto.
- destruct o; inversion H2.
  destruct IHbigstep1 with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app; auto. rewrite H4 in G3; auto.
  destruct H5 with (h' := h') (s' := s'); auto. destruct H7.
  destruct IHbigstep2 with (xs := xs) (h := h') (s := s') (t := x); auto.
  eapply step_while_true.
  erewrite <- gcond. apply H.
  rewrite H4 in G3.
  eapply eq_restr_incl; [|apply G3].
  intros. apply G. simpl.
  apply in_or_app. auto.
  apply H8.
  apply H10. auto.
- exists t. split. rewrite <- H2. assumption.
  apply step_while_false.
  erewrite <- gcond. apply H.
  rewrite H2 in G3.
  eapply eq_restr_incl; [|apply G3].
  intros. apply G. simpl.
  apply in_or_app. auto.
- destruct IHbigstep with (xs := xs) (h := h) (s := s) (t := t); auto.
  intros. apply G. simpl. apply in_or_app; auto. rewrite H3 in G3; auto.
  apply step_while_fail.
  erewrite <- gcond. apply H.
  rewrite H3 in G3.
  eapply eq_restr_incl; [|apply G3].
  intros. apply G. simpl.
  apply in_or_app. auto.
  apply H4. auto.
Qed.

Proposition cwlp_cond (S1: program) (q: cassert):
  forall (h : heap) (s t : store),
   eq_restr s t (pvar S1 ++ cvar q) ->
   (~ bigstep S1 (h, s) None /\ forall (h' : heap) (s' : store),
      bigstep S1 (h, s) (Some (h', s')) -> q (h', s')) <->
   (~ bigstep S1 (h, t) None /\ forall (h' : heap) (s' : store),
      bigstep S1 (h, t) (Some (h', s')) -> q (h', s')).
intros; split; intro; destruct H0.
- split.
  + intro.
    pose proof (bigstep_cond S1 (h, t) None H2 (pvar S1 ++ cvar q)).
    destruct H3 with (h := h) (s := t) (t := s); auto.
    intros. apply in_or_app; auto.
    apply eq_restr_comm. apply H.
  + intros.
    pose proof (bigstep_cond S1 (h, t) (Some (h', s')) H2 (pvar S1 ++ cvar q)).
    destruct H3 with (h := h) (s := t) (t := s); auto.
    intros. apply in_or_app; auto.
    apply eq_restr_comm. apply H.
    destruct H4 with (h' := h') (s' := s'); auto. destruct H6.
    rewrite ccond with (t := x).
    apply H1. assumption.
    eapply eq_restr_incl; [|apply H6].
    intros. apply in_or_app. auto.
- split.
  + intro.
    pose proof (bigstep_cond S1 (h, s) None H2 (pvar S1 ++ cvar q)).
    destruct H3 with (h := h) (s := s) (t := t); auto.
    intros. apply in_or_app; auto.
  + intros.
    pose proof (bigstep_cond S1 (h, s) (Some (h', s')) H2 (pvar S1 ++ cvar q)).
    destruct H3 with (h := h) (s := s) (t := t); auto.
    intros. apply in_or_app; auto.
    destruct H4 with (h' := h') (s' := s'); auto. destruct H6.
    rewrite ccond with (t := x).
    apply H1. assumption.
    eapply eq_restr_incl; [|apply H6].
    intros. apply in_or_app. auto.
Qed.
Proposition cwlp_stable (S1: program) (q: cassert):
  forall (h : heap) (s : store),
   ~ ~ (~ bigstep S1 (h, s) None /\ forall (h' : heap) (s' : store),
      bigstep S1 (h, s) (Some (h', s')) -> q (h', s')) ->
   (~ bigstep S1 (h, s) None /\ forall (h' : heap) (s' : store),
      bigstep S1 (h, s) (Some (h', s')) -> q (h', s')).
intros. split.
intro. apply H. intro. destruct H1.
apply H1. assumption.
intros. apply cstable. intro.
apply H. intro. destruct H2.
apply H3 in H0.
apply H1. assumption.
Qed.
Definition cwlp (S1: program) (q: cassert): cassert :=
  mkcassert (fun '(h, s) => ~bigstep S1 (h, s) None /\
      forall h' s', bigstep S1 (h, s) (Some (h', s')) -> q (h', s'))
    (pvar S1 ++ cvar q) (cwlp_cond S1 q) (cwlp_stable S1 q).


Require Import init.

Require Import order_minmax.

Require Export analysis_norm.

Definition series {V} `{Plus V, Zero V} (a : nat → V) (n : nat) := sum a 0 n.

Definition cauchy_series {V} `{Plus V, Zero V, AbsoluteValue V} (a : nat → V)
    := ∀ ε, 0 < ε → ∃ N, ∀ i j, N ≤ i → |sum a i j| < ε.
(* begin hide *)

Section AnalysisSeries.

Context {V} `{
    VP : Plus V,
    VZ : Zero V,
    VN : Neg V,
    @PlusComm V VP,
    @PlusAssoc V VP,
    @PlusLid V VP VZ,
    @PlusLinv V VP VZ VN,

    SM : ScalarMult real V,
    @ScalarId real V real_one SM,
    @ScalarLdist real V VP SM,
    @ScalarRdist real V real_plus VP SM,

    VA : AbsoluteValue V,
    @AbsDefinite V VA VZ,
    @AbsNeg V VA VN,
    @AbsTriangle V VA VP,
    @AbsPositive V VA,
    @AbsScalar V VA SM
}.

Existing Instance abs_metric.
(* end hide *)

Definition abs_converges (a : nat → V) := seq_converges (series (λ n, |a n|)).

Theorem series_scalar : ∀ af a c, seq_lim (series af) a →
    seq_lim (series (λ n, c · af n)) (c · a).
Proof.
    intros af a c a_lim.
    assert (series (λ n, c · af n) = (λ n, c · sum af 0 n)) as f_eq.
    {
        apply functional_ext.
        intros n.
        nat_induction n.
        -   unfold series.
            unfold zero; cbn.
            rewrite scalar_ranni.
            reflexivity.
        -   cbn.
            unfold series in IHn.
            rewrite IHn.
            rewrite scalar_ldist.
            reflexivity.
    }
    rewrite f_eq.
    apply seq_lim_scalar.
    exact a_lim.
Qed.

Theorem series_sum : ∀ af bf a b, seq_lim (series af) a → seq_lim (series bf) b
    → seq_lim (series (λ n, af n + bf n)) (a + b).
Proof.
    intros af bf a b a_lim b_lim.
    assert (series (λ n, af n + bf n) = (λ n, series af n + series bf n))
        as f_eq.
    {
        apply functional_ext.
        intros n.
        nat_induction n.
        -   unfold zero; cbn.
            rewrite plus_rid.
            reflexivity.
        -   cbn.
            unfold series in IHn.
            rewrite IHn.
            do 2 rewrite <- plus_assoc.
            apply lplus.
            do 2 rewrite plus_assoc.
            apply rplus.
            apply plus_comm.
    }
    rewrite f_eq.
    apply seq_lim_plus; assumption.
Qed.

Theorem series_converges_cauchy :
    ∀ af, seq_converges (series af) → cauchy_series af.
Proof.
    intros af af_conv.
    apply converges_cauchy in af_conv.
    intros ε ε_pos.
    specialize (af_conv ε ε_pos) as [N af_conv].
    exists N.
    intros i j i_ge.
    assert (N ≤ i + j) as j_ge.
    {
        apply (trans i_ge).
        rewrite <- (plus_rid i) at 1.
        apply le_lplus.
        apply nat_pos.
    }
    specialize (af_conv (i + j) i j_ge i_ge).
    unfold series in af_conv; cbn in af_conv.
    rewrite sum_minus in af_conv.
    rewrite plus_lid in af_conv.
    exact af_conv.
Qed.

Theorem cauchy_series_converges : complete V →
    ∀ af, cauchy_series af → seq_converges (series af).
Proof.
    intros V_comp af af_conv.
    apply V_comp.
    intros ε ε_pos.
    specialize (af_conv ε ε_pos) as [N af_conv].
    exists N.
    intros i j i_ge j_ge.
    unfold series; cbn.
    destruct (connex i j) as [leq|leq].
    -   apply nat_le_ex in leq as [c eq]; subst.
        rewrite abs_minus.
        rewrite sum_minus.
        rewrite plus_lid.
        apply af_conv.
        exact i_ge.
    -   apply nat_le_ex in leq as [c eq]; subst.
        rewrite sum_minus.
        rewrite plus_lid.
        apply af_conv.
        exact j_ge.
Qed.
(* begin hide *)
End AnalysisSeries.

Section AnalysisSeries.

Context {V} `{
    VP : Plus V,
    VZ : Zero V,
    VN : Neg V,
    @PlusComm V VP,
    @PlusAssoc V VP,
    @PlusLid V VP VZ,
    @PlusLinv V VP VZ VN,

    SM : ScalarMult real V,
    @ScalarId real V real_one SM,
    @ScalarLdist real V VP SM,
    @ScalarRdist real V real_plus VP SM,

    VA : AbsoluteValue V,
    @AbsDefinite V VA VZ,
    @AbsNeg V VA VN,
    @AbsTriangle V VA VP,
    @AbsPositive V VA,
    @AbsScalar V VA SM
}.

Existing Instance abs_metric.
(* end hide *)

Theorem abs_converge_test : complete V → ∀ af,
    abs_converges af → seq_converges (series af).
Proof.
    intros V_comp af af_conv.
    apply (cauchy_series_converges V_comp).
    intros ε ε_pos.
    unfold abs_converges in af_conv.
    apply series_converges_cauchy in af_conv.
    specialize (af_conv ε ε_pos) as [N af_conv].
    exists N.
    intros i j i_geq.
    specialize (af_conv i j i_geq) as ltq.
    apply (le_lt_trans2 ltq).
    clear ε ε_pos N af_conv i_geq ltq.
    assert (0 ≤ sum (λ n, |af n|) i j) as sum_pos.
    {
        nat_induction j.
        -   unfold zero at 2; cbn.
            apply refl.
        -   cbn.
            rewrite <- (plus_rid 0).
            apply le_lrplus; [>exact IHj|].
            apply abs_pos.
    }
    rewrite (abs_pos_eq _ sum_pos).
    clear sum_pos.
    nat_induction j.
    -   unfold zero; cbn.
        rewrite <- abs_zero.
        apply refl.
    -   cbn.
        apply (trans (abs_tri _ _)).
        apply le_rplus.
        exact IHj.
Qed.

Theorem series_skip : ∀ an n,
    seq_converges (series an) ↔ seq_converges (series (λ m, an (m + n))).
Proof.
    intros an n.
    split.
    -   intros [x anx].
        exists (x - sum an 0 n).
        rewrite metric_seq_lim in *.
        intros ε ε_pos.
        specialize (anx ε ε_pos) as [N anx].
        exists N.
        intros m m_geq.
        specialize (anx (n + m) (trans m_geq (nat_le_self_lplus m n))).
        cbn in *.
        unfold series in *.
        rewrite sum_argument_plus.
        rewrite plus_lid.
        rewrite <- plus_assoc.
        rewrite <- neg_plus.
        rewrite <- (plus_lid n) at 2.
        rewrite sum_plus.
        exact anx.
    -   intros [x anx].
        exists (x + sum an 0 n).
        rewrite metric_seq_lim in *.
        intros ε ε_pos.
        specialize (anx ε ε_pos) as [N anx].
        exists (N + n).
        intros m m_geq.
        apply nat_le_ex in m_geq as [c eq]; subst m.
        specialize (anx (N + c) (nat_le_self_rplus _ _)).
        cbn in *.
        unfold series in *.
        rewrite sum_argument_plus in anx.
        rewrite plus_lid in anx.
        rewrite <- (neg_neg (sum an 0 n)).
        rewrite <- plus_assoc.
        rewrite <- neg_plus.
        rewrite (plus_comm (-sum an 0 n)).
        rewrite (plus_comm N n).
        rewrite <- plus_assoc.
        rewrite sum_minus.
        rewrite plus_lid.
        exact anx.
Qed.
(* begin hide *)
End AnalysisSeries.
(* end hide *)


Require Export DevCoq.Dev.basic_matroid_list.

Parameter rk_singleton_ge : forall P, rk (P :: nil)  >= 1.
Parameter rk_couple_ge : forall P Q, ~ P = Q -> rk(P :: Q :: nil) >= 2.
Parameter rk_three_points_on_lines : forall A B, exists C, rk (A :: B :: C :: nil) = 2 /\ rk (B :: C :: nil) = 2 /\ rk (A :: C :: nil) = 2.
Parameter rk_inter : forall A B C D, exists J, rk (A :: B :: J :: nil) = 2 /\ rk (C :: D :: J :: nil) = 2.
Parameter rk_lower_dim : exists P0 P1 P2, rk( P0 :: P1 :: P2 :: nil) >=3.

Lemma rk_singleton_1 : forall A, rk(A :: nil) <= 1.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_singleton : forall A, rk(A :: nil) = 1.
Proof.
intros.
assert(H := rk_singleton_ge A).
assert(HH := rk_singleton_1 A).
omega.
Qed.

Lemma matroid1_b_useful2 : forall (l : list Point) (a : Point), length (a :: l) >= 1 -> rk (a :: l) >= 1.
Proof.
intros.
assert(HH := rk_singleton a).
assert(HH0 := matroid2 (a :: nil) (a :: l)).
assert(HH1 : incl (a :: nil) (a :: l));[my_inO|].
assert(HH2 := HH0 HH1).
omega.
Qed.

Lemma rk_couple_2 : forall A B, rk(A :: B :: nil) <= 2.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma rk_couple : forall A B : Point,~ A = B -> rk(A :: B :: nil) = 2.
Proof.
intros.
assert(HH := rk_couple_2 A B).
assert(HH0 := rk_couple_ge A B H).
omega.
Qed.

Lemma rk_triple_3 : forall A B C : Point, rk (A :: B :: C :: nil) <= 3.
Proof.
intros.
apply matroid1_b_useful.
intuition.
Qed.

Lemma couple_rk1 : forall A B, rk(A :: B :: nil) = 2 -> ~ A = B.
Proof.
intros.
intro.
rewrite H0 in H.
assert(HH : equivlist (B :: B :: nil) (B :: nil));[my_inO|].
rewrite HH in H.
assert(HH0 := rk_singleton_1 B).
omega.
Qed.

Lemma couple_rk2 : forall A B, rk(A :: B :: nil) = 1 -> A = B.
Proof.
intros.
case_eq(eq_dec A B).
intros.
assumption.
intros.
assert(HH := rk_couple A B n).
omega.
Qed.

Lemma rk_quadruple_inter_aux : forall A B C D E,
~ A = C ->
~ A = D ->
~ B = C ->
~ B = D ->
rk(A :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(A :: B :: C :: D :: nil) = 2 \/ rk(A :: B :: C :: D :: nil) = 3.
Proof.
intros.

assert (HH0 : rk((A :: B :: E :: nil) ++ (C :: D :: E :: nil)) + rk(list_inter (A :: B :: E :: nil) (C :: D :: E :: nil)) <=
       rk(A :: B :: E :: nil) + rk(C :: D :: E :: nil)).
apply matroid3_useful;my_inO.
assert(HH1 : equivlist (list_inter (A :: B :: E :: nil) (C :: D :: E :: nil))  (E :: nil)).
my_inO.
assert(HH2 := rk_singleton E).
rewrite HH1 in HH0.
rewrite HH2 in HH0.
rewrite H3 in HH0.
rewrite H4 in HH0.

assert(HH3 : rk(A :: B :: E :: C :: D :: E :: nil) = 2 \/ rk(A :: B :: E :: C :: D :: E :: nil) = 3).
apply le_lt_or_eq in HH0;simpl in HH0.
destruct HH0.
assert(HH4 : rk(A :: B :: E :: C :: D :: E :: nil) < 3).
solve[intuition].
assert(HH5 : incl (A :: B :: E :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (A :: B :: E :: nil) (A :: B :: E :: C :: D :: E :: nil) HH5).
omega.
omega.

destruct HH3.

assert(HH3 := rk_couple A C H).
assert(HH4 : incl (A :: C :: nil) (A :: B :: C :: D :: nil));[my_inO|].
assert(HH5 : incl (A :: B :: C :: D :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (A :: C :: nil) (A :: B :: C :: D :: nil) HH4).
assert(HH7 := matroid2 (A :: B :: C :: D :: nil) (A :: B :: E :: C :: D :: E :: nil) HH5).
omega.

assert(HH3 : incl (A :: B :: C :: D :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH4 := matroid2 (A :: B :: C :: D :: nil) (A :: B :: E :: C :: D :: E :: nil) HH3).
rewrite H5 in HH4.
apply le_lt_or_eq in HH4.
destruct HH4.
assert(HH5 := rk_couple A C H).
assert(HH6 : incl (A :: C :: nil) (A :: B :: C :: D :: nil));[my_inO|].
assert(HH7 := matroid2 (A :: C :: nil) (A :: B :: C :: D :: nil) HH6).
omega.
omega.
Qed.

Lemma rk_quadruple_inter_aux2 : forall B C D E,
~ B = C ->
~ B = D ->
rk(D :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(D :: B :: C :: D :: nil) = 2 \/ rk(D :: B :: C :: D :: nil) = 3.
Proof.
intros.

assert (HH0 : rk((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) + rk(list_inter (D :: B :: E :: nil) (C :: D :: E :: nil)) <=
       rk(D :: B :: E :: nil) + rk(C :: D :: E :: nil)).
apply matroid3_useful;my_inO.
assert (HH1 : equivlist (list_inter (D :: B :: E :: nil) (C :: D :: E :: nil)) (D :: E :: nil));[my_inO|].
rewrite HH1 in HH0.
case_eq(eq_dec D E).
intros;subst.
rewrite H1 in HH0;rewrite H2 in HH0.
assert(HH2 : equivlist (E :: E :: nil) (E :: nil));[my_inO|].
replace (rk (E :: E :: nil)) with (rk(E :: nil)) in HH0.
2:rewrite HH2;intuition.
assert(HH3 := rk_singleton E).
rewrite HH3 in HH0.

assert(HH4 : rk(E :: B :: E :: C :: E :: E :: nil) = 2 \/ rk((E :: B :: E :: C :: E :: E :: nil)) = 3).
apply le_lt_or_eq in HH0;simpl in HH0.
destruct HH0.
assert(HH5 : rk((E :: B :: E :: C :: E :: E :: nil)) < 3).
solve[intuition].
assert(HH4 : incl (E :: B :: E :: nil) (E :: B :: E :: C :: E :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (E :: B :: E :: nil) (E :: B :: E :: C :: E :: E :: nil) HH4).
omega.
omega.

assert(HH5 : equivlist (E :: B :: E :: C :: E :: E :: nil) (E :: B :: C :: E :: nil));[my_inO|].
rewrite HH5 in HH4.
omega.

intros.
rewrite H1 in HH0;rewrite H2 in HH0.
assert(HH2 := rk_couple D E n).
rewrite HH2 in HH0.
assert(HH3 : rk((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) = 2).
assert(HH4 : incl (D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)));[my_inO|].
assert(HH5 := matroid2 (D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) HH4).
omega.
assert(HH4 := rk_couple B C H).
assert(HH5 : incl (B :: C :: nil) (D :: B :: C :: D :: nil));[my_inO|].
assert(HH6 := matroid2 (B :: C :: nil) (D :: B :: C :: D :: nil) HH5).
assert(HH7 : incl (D :: B :: C :: D :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)));[my_inO|].
assert(HH8 := matroid2 (D :: B :: C :: D :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) HH7).
omega.
Qed.

Lemma rk_quadruple_inter : forall A B C D E,
rk(A :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(A :: B :: C :: D :: nil) = 1 \/ rk(A :: B :: C :: D :: nil) = 2 \/ rk(A :: B :: C :: D :: nil) = 3.
Proof.
intros.
case_eq(eq_dec A C);
case_eq(eq_dec A D);
case_eq(eq_dec B C);
case_eq(eq_dec B D).

intros.
rewrite e;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e3.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n);assert(HH : equivlist (D :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e2.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n0);assert(HH : equivlist (C :: C :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e2.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n0);assert(HH : equivlist (C :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e in *.
assert(HH0 := rk_quadruple_inter_aux2 B C D E n0 n H H0).
omega.

intros.
rewrite e0;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e2.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n0);assert(HH : equivlist (C :: C :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e0.
case_eq(eq_dec C D).
intros;rewrite e1.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n1);assert(HH : equivlist (C :: C :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e0.
case_eq(eq_dec C D).
intros;rewrite e1.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n1);assert(HH : equivlist (C :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e in *.
assert(HH0 : equivlist (C :: D :: E :: nil) (D :: C :: E :: nil));[my_inO|].
rewrite HH0 in H0.
assert(HH1 := rk_quadruple_inter_aux2 B D C E n n0 H H0).
assert(HH2 : equivlist (C :: B :: C :: D :: nil) (C :: B :: D :: C :: nil));[my_inO|].
rewrite HH2.
omega.

intros.
rewrite e;rewrite e1.
case_eq(eq_dec C D).
intros;rewrite e2.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n0);assert(HH : equivlist (D :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e0.
case_eq(eq_dec C D).
intros;rewrite e1.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n1);assert(HH : equivlist (D :: C :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e;rewrite e0.
case_eq(eq_dec C D).
intros;rewrite e1.
assert(HH0 : equivlist (D :: D :: D :: D :: nil) (D :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton D);omega.
intros.
assert(HH0 := rk_couple C D n1);assert(HH : equivlist (D :: D :: C :: D :: nil) (C :: D :: nil));[my_inO|].
rewrite HH;omega.

intros.
rewrite e in *.
assert(HH0 := rk_quadruple_inter_aux2 B C D E n0 n H H0).
omega.

intros.
rewrite e in  *.
assert(HH0 : equivlist (A :: D :: E :: nil) (D :: A :: E :: nil));[my_inO|].
rewrite HH0 in H.
assert(HH1 := rk_quadruple_inter_aux2 A C D E n0 n H H0).
assert(HH2 : equivlist (D :: A :: C :: D :: nil) (A :: D :: C :: D :: nil));[my_inO|].
rewrite HH2 in HH1.
omega.

intros.
rewrite e in  *.
assert(HH0 : equivlist (A :: C :: E :: nil) (C :: A :: E :: nil));[my_inO|].
rewrite HH0 in H.
assert(HH1 : equivlist (C :: D :: E :: nil) (D :: C :: E :: nil));[my_inO|].
rewrite HH1 in H0.
assert(HH2 := rk_quadruple_inter_aux2 A D C E n0 n1 H H0).
assert(HH3 : equivlist (C :: A :: D :: C :: nil) (A :: C :: C :: D :: nil));[my_inO|].
rewrite HH3 in HH2.
omega.

intros.
rewrite e in *.
assert(HH0 : equivlist (A :: D :: E :: nil) (D :: A :: E :: nil));[my_inO|].
rewrite HH0 in H.
assert(HH1 := rk_quadruple_inter_aux2 A C D E n1 n0 H H0).
assert(HH2 : equivlist (A :: D :: C :: D :: nil) (D :: A :: C :: D :: nil));[my_inO|].
rewrite HH2.
omega.

intros.
assert(HH0 := rk_quadruple_inter_aux A B C D E n2 n1 n0 n H H0).
omega.
Qed.

Lemma rk_quadruple_max_3 : forall X Y Z W: Point,rk(X :: Y :: Z :: W :: nil) <= 3.
intros.
assert(HH0 := rk_inter X Y Z W).
destruct HH0.
destruct H.
assert(HH1 := rk_quadruple_inter X Y Z W x H H0).
omega.
Qed.

Lemma rk_quintuple_inter_aux : forall A B C D E,
~ A = C ->
~ A = D ->
~ B = C ->
~ B = D ->
rk(A :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(A :: B :: C :: D :: E :: nil) = 2 \/ rk(A :: B :: C :: D :: E :: nil) = 3.
Proof.
intros.

assert (HH0 : rk((A :: B :: E :: nil) ++ (C :: D :: E :: nil)) + rk(list_inter (A :: B :: E :: nil) (C :: D :: E :: nil)) <=
       rk(A :: B :: E :: nil) + rk(C :: D :: E :: nil)).
apply matroid3_useful;my_inO.
assert(HH1 : equivlist (list_inter (A :: B :: E :: nil) (C :: D :: E :: nil))  (E :: nil)).
my_inO.
assert(HH2 := rk_singleton E).
rewrite HH1 in HH0.
rewrite HH2 in HH0.
rewrite H3 in HH0.
rewrite H4 in HH0.

assert(HH3 : rk(A :: B :: E :: C :: D :: E :: nil) = 2 \/ rk(A :: B :: E :: C :: D :: E :: nil) = 3).
apply le_lt_or_eq in HH0;simpl in HH0.
destruct HH0.
assert(HH4 : rk(A :: B :: E :: C :: D :: E :: nil) < 3).
solve[intuition].
assert(HH5 : incl (A :: B :: E :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (A :: B :: E :: nil) (A :: B :: E :: C :: D :: E :: nil) HH5).
omega.
omega.

destruct HH3.

assert(HH3 := rk_couple A C H).
assert(HH4 : incl (A :: C :: nil) (A :: B :: C :: D :: E :: nil));[my_inO|].
assert(HH5 : incl (A :: B :: C :: D :: E :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (A :: C :: nil) (A :: B :: C :: D :: E :: nil) HH4).
assert(HH7 := matroid2 (A :: B :: C :: D :: E :: nil) (A :: B :: E :: C :: D :: E :: nil) HH5).
omega.

assert(HH3 : incl (A :: B :: C :: D :: E :: nil) (A :: B :: E :: C :: D :: E :: nil));[my_inO|].
assert(HH4 := matroid2 (A :: B :: C :: D :: E :: nil) (A :: B :: E :: C :: D :: E :: nil) HH3).
rewrite H5 in HH4.
apply le_lt_or_eq in HH4.
destruct HH4.
assert(HH5 := rk_couple A C H).
assert(HH6 : incl (A :: C :: nil) (A :: B :: C :: D :: E :: nil));[my_inO|].
assert(HH7 := matroid2 (A :: C :: nil) (A :: B :: C :: D :: E :: nil) HH6).
omega.
omega.
Qed.

Lemma rk_quintuple_inter_aux2 : forall B C D E,
~ B = C ->
~ B = D ->
rk(D :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(D :: B :: C :: D :: E :: nil) = 2 \/ rk(D :: B :: C :: D :: E :: nil) = 3.
Proof.
intros.

assert (HH0 : rk((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) + rk(list_inter (D :: B :: E :: nil) (C :: D :: E :: nil)) <=
       rk(D :: B :: E :: nil) + rk(C :: D :: E :: nil)).
apply matroid3_useful;my_inO.
assert (HH1 : equivlist (list_inter (D :: B :: E :: nil) (C :: D :: E :: nil)) (D :: E :: nil));[my_inO|].
rewrite HH1 in HH0.
case_eq(eq_dec D E).
intros;subst.
rewrite H1 in HH0;rewrite H2 in HH0.
assert(HH2 : equivlist (E :: E :: nil) (E :: nil));[my_inO|].
replace (rk (E :: E :: nil)) with (rk(E :: nil)) in HH0.
2:rewrite HH2;intuition.
assert(HH3 := rk_singleton E).
rewrite HH3 in HH0.

assert(HH4 : rk(E :: B :: E :: C :: E :: E :: nil) = 2 \/ rk((E :: B :: E :: C :: E :: E :: nil)) = 3).
apply le_lt_or_eq in HH0;simpl in HH0.
destruct HH0.
assert(HH5 : rk((E :: B :: E :: C :: E :: E :: nil)) < 3).
solve[intuition].
assert(HH4 : incl (E :: B :: E :: nil) (E :: B :: E :: C :: E :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (E :: B :: E :: nil) (E :: B :: E :: C :: E :: E :: nil) HH4).
omega.
omega.

assert(HH5 : equivlist (E :: B :: E :: C :: E :: E :: nil) (E :: B :: C :: E :: E :: nil));[my_inO|].
rewrite HH5 in HH4.
omega.

intros.
rewrite H1 in HH0;rewrite H2 in HH0.
assert(HH2 := rk_couple D E n).
rewrite HH2 in HH0.
assert(HH3 : rk((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) = 2).
assert(HH4 : incl (D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)));[my_inO|].
assert(HH5 := matroid2 (D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) HH4).
omega.
assert(HH4 := rk_couple B C H).
assert(HH5 : incl (B :: C :: nil) (D :: B :: C :: D :: E :: nil));[my_inO|].
assert(HH6 := matroid2 (B :: C :: nil) (D :: B :: C :: D :: E :: nil) HH5).
assert(HH7 : incl (D :: B :: C :: D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)));[my_inO|].
assert(HH8 := matroid2 (D :: B :: C :: D :: E :: nil) ((D :: B :: E :: nil) ++ (C :: D :: E :: nil)) HH7).
omega.
Qed.

Lemma rk_quintuple_inter : forall A B C D E,
rk(A :: B :: E :: nil) = 2 ->
rk(C :: D :: E :: nil) = 2 ->
rk(A :: B :: C :: D :: E :: nil) = 1 \/ rk(A :: B :: C :: D :: E :: nil) = 2 \/ rk(A :: B :: C :: D :: E :: nil) = 3.
Proof.
intros.
case_eq(eq_dec A C);
case_eq(eq_dec A D);
case_eq(eq_dec B C);
case_eq(eq_dec B D).

intros;rewrite <-e2;rewrite e;rewrite e1.
case_eq(eq_dec D E).
intros;rewrite e3.
assert(HH0 : equivlist (E :: E :: E :: E :: E :: nil) (E :: nil));[my_inO|].
rewrite HH0;assert(HH1 := rk_singleton E);omega.
intros.
assert(HH0 := rk_couple D E n);assert(HH : equivlist (D :: D :: D :: D :: E :: nil) (D :: E :: nil));[my_inO|].
rewrite HH;omega.

intros;apply False_ind;apply n;rewrite e;rewrite <-e0;rewrite e1;reflexivity.

intros;apply False_ind;apply n;rewrite e;rewrite <-e0;rewrite e1;reflexivity.

intros;rewrite e in *.
assert(HH := rk_quintuple_inter_aux2 B C D E n0 n H H0);intuition.

intros;apply False_ind;apply n;rewrite <-e;rewrite e0;rewrite <-e1;reflexivity.

intros;rewrite e;rewrite e0.
assert(HH0 : equivlist (C :: C :: C :: D :: E :: nil) (C :: D :: E :: nil));[my_inO|].
rewrite HH0;right;left;assumption.

intros;rewrite e;rewrite e0.
assert(HH0 : equivlist (C :: D :: C :: D :: E :: nil) (C :: D :: E :: nil));[my_inO|].
rewrite HH0;right;left;assumption.

intros;rewrite e in *.
assert(HH : equivlist (C :: D :: E :: nil) (D :: C :: E :: nil));[my_inO|];rewrite HH in H0.
assert(HH0 := rk_quintuple_inter_aux2 B D C E n n0 H H0).
assert(HH1 : equivlist (C :: B :: D :: C :: E :: nil) (C :: B :: C :: D :: E :: nil));[my_inO|].
rewrite HH1 in HH0;intuition.

intros;apply False_ind;apply n;rewrite <-e0;rewrite e;rewrite e1;reflexivity.

intros;rewrite e;rewrite e0.
assert(HH0 : equivlist (D :: C :: C :: D :: E :: nil) (C :: D :: E :: nil));[my_inO|].
rewrite HH0;right;left;assumption.

intros;rewrite e;rewrite e0.
assert(HH0 : equivlist (D :: D :: C :: D :: E :: nil) (C :: D :: E :: nil));[my_inO|].
rewrite HH0;right;left;assumption.

intros;rewrite e in *.
assert(HH0 := rk_quintuple_inter_aux2 B C D E n0 n H H0);intuition.

intros;rewrite e in *.
assert(HH : equivlist (A :: D :: E :: nil) (D :: A :: E :: nil));[my_inO|];rewrite HH in H.
assert(HH0 := rk_quintuple_inter_aux2 A C D E n0 n H H0).
assert(HH1 : equivlist (D :: A :: C :: D :: E :: nil) (A :: D :: C :: D :: E :: nil));[my_inO|].
rewrite HH1 in HH0;intuition.

intros;rewrite e in *.
assert(HH : equivlist (A :: C :: E :: nil) (C :: A :: E :: nil));[my_inO|];rewrite HH in H.
assert(HH0 : equivlist (C :: D :: E :: nil) (D :: C :: E :: nil));[my_inO|];rewrite HH0 in H0.
assert(HH1 := rk_quintuple_inter_aux2 A D C E n0 n1 H H0).
assert(HH2 : equivlist (C :: A :: D :: C :: E :: nil) (A :: C :: C :: D :: E :: nil));[my_inO|].
rewrite HH2 in HH1;intuition.

intros;rewrite e in *.
assert(HH : equivlist (A :: D :: E :: nil) (D :: A :: E :: nil));[my_inO|];rewrite HH in H.
assert(HH0 := rk_quintuple_inter_aux2 A C D E n1 n0 H H0).
assert(HH1 : equivlist (D :: A :: C :: D :: E :: nil) (A :: D :: C :: D :: E :: nil));[my_inO|].
rewrite HH1 in HH0;intuition.

intros.
assert(HH := rk_quintuple_inter_aux A B C D E n2 n1 n0 n H H0);intuition.
Qed.

Lemma rk_quintuple_max_3 : forall X Y Z W V: Point, rk(X :: Y :: Z :: W :: V :: nil) <= 3.
Proof.
intros.

assert(HH := rk_lower_dim).
destruct HH;destruct H;destruct H.
assert(HH := rk_triple_3 x x0 x1).
assert(HH0 : rk (x :: x0 :: x1 :: nil) = 3);[omega|].
assert(HH1 := rk_quadruple_max_3 x x0 x1 X).
assert(HH2 := rk_quadruple_max_3 x x0 x1 Y).
assert(HH3 := rk_quadruple_max_3 x x0 x1 Z).
assert(HH4 := rk_quadruple_max_3 x x0 x1 W).
assert(HH5 := rk_quadruple_max_3 x x0 x1 V).
assert(HH6 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: nil));[my_inO|].
assert(HH7 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: Y :: nil));[my_inO|].
assert(HH8 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: Z :: nil));[my_inO|].
assert(HH9 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: W :: nil));[my_inO|].
assert(HH10 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: V :: nil));[my_inO|].
assert(HH11 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: nil) HH6).
assert(HH12 : rk (x :: x0 :: x1 :: X :: nil) = 3);[omega|].
assert(HH13 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: Y :: nil) HH7).
assert(HH14 : rk (x :: x0 :: x1 :: Y :: nil) = 3);[omega|].
assert(HH15 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: Z :: nil) HH8).
assert(HH16 : rk (x :: x0 :: x1 :: Z :: nil) = 3);[omega|].
assert(HH17 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: W :: nil) HH9).
assert(HH18 : rk (x :: x0 :: x1 :: W :: nil) = 3);[omega|].
assert(HH19 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: V :: nil) HH10).
assert(HH20 : rk (x :: x0 :: x1 :: V :: nil) = 3);[omega|].
clear H HH HH1 HH2 HH3 HH4 HH5 HH6 HH7 HH8 HH9 HH10 HH11 HH13 HH15 HH17 HH19.

case_eq(eq_dec X Y);intros.
rewrite e;assert(HH21 : equivlist (Y :: Y :: Z :: W :: V :: nil) (Y :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 Y Z W V);assumption.
case_eq(eq_dec X Z);intros.
rewrite e;assert(HH21 : equivlist (Z :: Y :: Z :: W :: V :: nil) (Y :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 Y Z W V);assumption.
case_eq(eq_dec X W);intros.
rewrite e;assert(HH21 : equivlist (W :: Y :: Z :: W :: V :: nil) (Y :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 Y Z W V);assumption.
case_eq(eq_dec X V);intros.
rewrite e;assert(HH21 : equivlist (V :: Y :: Z :: W :: V :: nil) (Y :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 Y Z W V);assumption.
case_eq(eq_dec Y Z);intros.
rewrite e;assert(HH21 : equivlist (X :: Z :: Z :: W :: V :: nil) (X :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Z W V);assumption.
case_eq(eq_dec Y W);intros.
rewrite e;assert(HH21 : equivlist (X :: W :: Z :: W :: V :: nil) (X :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Z W V);assumption.
case_eq(eq_dec Y V);intros.
rewrite e;assert(HH21 : equivlist (X :: V :: Z :: W :: V :: nil) (X :: Z :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Z W V);assumption.
case_eq(eq_dec Z W);intros.
rewrite e;assert(HH21 : equivlist (X :: Y :: W :: W :: V :: nil) (X :: Y :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Y W V);assumption.
case_eq(eq_dec Z V);intros.
rewrite e;assert(HH21 : equivlist (X :: Y :: V :: W :: V :: nil) (X :: Y :: W :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Y W V);assumption.
case_eq(eq_dec W V);intros.
rewrite e;assert(HH21 : equivlist (X :: Y :: Z :: V :: V :: nil) (X :: Y :: Z :: V :: nil));[my_inO|];
rewrite HH21;assert(HH22 := rk_quadruple_max_3 X Y Z V);assumption.
clear H H0 H1 H2 H3 H4 H5 H6 H7 H8.

assert (HH23 : rk((x :: x0 :: x1 :: X :: nil) ++ (x :: x0 :: x1 :: Y :: nil)) + rk(list_inter (x :: x0 :: x1 :: X :: nil) (x :: x0 :: x1 :: Y :: nil)) <=
       rk(x :: x0 :: x1 :: X :: nil) + rk(x :: x0 :: x1 :: Y :: nil)).
apply matroid3_useful;my_inO.
assert(HH24 : equivlist (list_inter (x :: x0 :: x1 :: X :: nil) (x :: x0 :: x1 :: Y :: nil))  (x :: x0 :: x1 :: nil));[my_inO|].
rewrite HH24 in HH23;clear HH24.
assert(HH25 : equivlist ((x :: x0 :: x1 :: X :: nil) ++ x :: x0 :: x1 :: Y :: nil) (x :: x0 :: x1 :: X :: Y :: nil));[my_inO|].
rewrite HH25 in HH23;clear HH25.
assert(HH26 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: nil));[my_inO|].
assert(HH27 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: nil) HH26).
assert(HH28 : rk(x :: x0 :: x1 :: X :: Y :: nil) = 3);[omega|].
clear HH12 HH14 HH23 HH26 HH27.

assert (HH29 : rk((x :: x0 :: x1 :: X :: Y :: nil) ++ (x :: x0 :: x1 :: Z :: nil)) + rk(list_inter (x :: x0 :: x1 :: X :: Y :: nil) (x :: x0 :: x1 :: Z :: nil)) <=
       rk(x :: x0 :: x1 :: X :: Y :: nil) + rk(x :: x0 :: x1 :: Z :: nil)).
apply matroid3_useful;my_inO.
assert(HH30 : equivlist (list_inter (x :: x0 :: x1 :: X :: Y :: nil) (x :: x0 :: x1 :: Z :: nil))  (x :: x0 :: x1 :: nil));[my_inO|].
rewrite HH30 in HH29;clear HH30.
assert(HH31 : equivlist ((x :: x0 :: x1 :: X :: Y :: nil) ++ x :: x0 :: x1 :: Z :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: nil));[my_inO|].
rewrite HH31 in HH29;clear HH31.
assert(HH32 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: nil));[my_inO|].
assert(HH33 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y ::  Z :: nil) HH32).
assert(HH34 : rk(x :: x0 :: x1 :: X :: Y :: Z :: nil) = 3);[omega|].
clear HH16 HH28 HH29 HH32 HH33.

assert (HH35 : rk((x :: x0 :: x1 :: X :: Y :: Z :: nil) ++ (x :: x0 :: x1 :: W :: nil)) + rk(list_inter (x :: x0 :: x1 :: X :: Y :: Z :: nil) (x :: x0 :: x1 :: W :: nil)) <=
       rk(x :: x0 :: x1 :: X :: Y :: Z :: nil) + rk(x :: x0 :: x1 :: W :: nil)).
apply matroid3_useful;my_inO.
assert(HH36 : equivlist (list_inter (x :: x0 :: x1 :: X :: Y :: Z :: nil) (x :: x0 :: x1 :: W :: nil))  (x :: x0 :: x1 :: nil));[my_inO|].
rewrite HH36 in HH35;clear HH36.
assert(HH37 : equivlist ((x :: x0 :: x1 :: X :: Y :: Z :: nil) ++ x :: x0 :: x1 :: W :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: W :: nil));[my_inO;left;my_inO|].
rewrite HH37 in HH35;clear HH37.
assert(HH38 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: W :: nil));[my_inO|].
assert(HH39 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y ::  Z :: W :: nil) HH38).
assert(HH40 : rk(x :: x0 :: x1 :: X :: Y :: Z :: W ::nil) = 3);[omega|].
clear HH18 HH34 HH35 HH38 HH39.

assert (HH41 : rk((x :: x0 :: x1 :: X :: Y :: Z :: W :: nil) ++ (x :: x0 :: x1 :: V :: nil)) + rk(list_inter (x :: x0 :: x1 :: X :: Y :: Z :: W ::nil) (x :: x0 :: x1 :: V :: nil)) <=
       rk(x :: x0 :: x1 :: X :: Y :: Z :: W :: nil) + rk(x :: x0 :: x1 :: V :: nil)).
apply matroid3_useful;my_inO.
assert(HH42 : equivlist (list_inter (x :: x0 :: x1 :: X :: Y :: Z :: W :: nil) (x :: x0 :: x1 :: V :: nil))  (x :: x0 :: x1 :: nil));[my_inO|].
rewrite HH42 in HH41;clear HH42.
assert(HH43 : equivlist ((x :: x0 :: x1 :: X :: Y :: Z :: W :: nil) ++ x :: x0 :: x1 :: V :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: W :: V :: nil));[my_inO;left;my_inO|].
rewrite HH43 in HH41;clear HH43.
assert(HH44 : incl (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y :: Z :: W :: V :: nil));[my_inO|].
assert(HH45 := matroid2 (x :: x0 :: x1 :: nil) (x :: x0 :: x1 :: X :: Y ::  Z :: W :: V :: nil) HH44).
assert(HH46 : rk(x :: x0 :: x1 :: X :: Y :: Z :: W ::V :: nil) = 3);[omega|].
clear HH20 HH40 HH41 HH44 HH45.
assert(HH47 : incl (X :: Y :: Z :: W :: V :: nil)(x :: x0 :: x1 :: X :: Y :: Z :: W :: V :: nil));[my_inO|].
assert(HH48 := matroid2 (X :: Y :: Z :: W :: V :: nil)(x :: x0 :: x1 :: X :: Y :: Z :: W :: V :: nil) HH47).
omega.
Qed.


Parameter object : Type.
Parameter arrow : Type.
Parameter source : arrow -> object -> Prop.
Parameter target : arrow -> object -> Prop.

Notation "f ':' A '~>' B" := ((source f A) /\ (target f B)) (at level 40).

Axiom R1a: forall A, exists u, u: A ~> A.
Axiom R1b: forall A B C f g, f:A ~> B /\ g: B ~> C -> exists gf, gf: A ~> C.

Parameter top : object.
Axiom R2: forall A, exists bang, bang: A ~> top.

Parameter conj : object -> object -> object.
Notation "A 'and' B" := (conj A B) (at level 25).

Axiom R3a: forall A B, exists prA, prA : A and B ~> A.
Axiom R3b: forall A B, exists prB, prB : A and B ~> B.
Axiom R3c: forall A B C f g, f: C ~> A /\ g: C ~> B -> exists h, h: C ~> A and B.

Lemma andComm: forall A B, exists swap, swap: A and B ~> B and A.
Proof.
  intros.
  pose proof (R3b A B). destruct H.
  pose proof (R3a A B). destruct H0.
  eapply R3c. split.
  - apply H.
  - apply H0.
Qed.


Set Implicit Arguments.
Require Export graft.

Definition LTree_decomp (A:Set) (t: LTree A) : LTree A
  := match t with
         LLeaf => LLeaf
       | LBin a t1 t2 => (LBin  a t1 t2)
       end.

Lemma LTree_decompose :
   forall (A : Set) (t: LTree A), t = LTree_decomp t.
Proof.
 destruct t; trivial.
Qed.

Ltac  LTree_unfold term :=
  apply trans_equal with (1 := LTree_decompose term).

Lemma graft_unfold1 : forall (A:Set) (t': LTree A),
    graft LLeaf  t' = t'.
Proof.
 intros A t'; LTree_unfold (graft LLeaf t');
  case t'; simpl; auto.
Qed.

Lemma graft_unfold2: forall (A:Set)(a:A) (t1 t2 t':LTree A),
                      (graft (LBin a t1 t2) t')=
                      (LBin a (graft t1 t') (graft t2 t')).
Proof.
 intros A a t1 t2 t'; LTree_unfold (graft (LBin a t1 t2) t');
  simpl; auto.
Qed.

Lemma graft_unfold : forall (A:Set) (t t': LTree A),
                     graft t t' = match t  with
                                  | LLeaf => t'
                                  | LBin n t1 t2 =>
                                             LBin  n (graft t1 t')
                                                     (graft t2 t')
                                  end.
Proof.
 intros A t t'; case t.
 apply graft_unfold1.
 intros; apply graft_unfold2.
Qed.


(* 7. Hierarchies *)
(* 7.5 Linking a custom data type to the library *)

From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
(* Set Printing Coercions.                     (* *** *) *)

Inductive windrose : predArgType := N | S | E | W.
Check N \in windrose.
Fail Check N != S.
Fail Check #| windrose | == 4.

Definition w2o (w : windrose) : 'I_4 :=
  match w with
  | N => inord 0
  | S => inord 1
  | E => inord 2
  | W => inord 3
  end.

Definition o2w (o : 'I_4) : windrose :=
  match val o with
  | 0 => N
  | 1 => S
  | 2 => E
  | _ => W
  end.

(* w2o と o2w がキャンセルの関係であることを証明する。 *)
Lemma can_wo4 : cancel w2o o2w.
Proof.
  case.
  rewrite /o2w.
  rewrite /val.
  rewrite /=.
  rewrite inordK.
  - done.
  - done.
  Restart.
    by case; rewrite /o2w /= inordK.
Qed.
Definition windrose_eqMixin := CanEqMixin can_wo4.

(* w2o が injective であることを証明する。 *)

Lemma inj_w2o : injective w2o.
Proof.
  Check can_inj : forall (rT aT : Type) (f : aT -> rT) (g : rT -> aT),
    cancel f g -> injective f.
  apply can_inj with (g:=o2w).              (* cancel (f:=w2o) (g:=o2w) *)
  by apply can_wo4.
Qed.
Definition windrose_eqMixin' := InjEqMixin inj_w2o.

(* Equality.axiom (∀x y, w2o x == w2o y) が成立することを証明する。 *)

Lemma w2o_eqP : Equality.axiom (fun x y => w2o x == w2o y).
Proof.
  Check inj_eqAxiom : forall (T : Type) (eT : eqType) (f : T -> Equality.sort eT),
    injective f -> Equality.axiom (T:=T) (fun x y : T => f x == f y).
  apply: inj_eqAxiom.
    by apply: inj_w2o.
Qed.
Definition windrose_eqMixin'' := EqMixin w2o_eqP.

(* Definition windrose_eqMixin := CanEqMixin can_wo4. *)
Canonical windrose_eqType := EqType windrose windrose_eqMixin.

Check N \in windrose.
Check N != S.
Fail Check #| windrose | == 4.

Definition windrose_choiceMixin := CanChoiceMixin can_wo4.
Canonical windrose_choiceType := ChoiceType windrose windrose_choiceMixin.

Definition windrose_countMixin := CanCountMixin can_wo4.
Canonical windrose_countType := CountType windrose windrose_countMixin.

Definition windrose_finMixin := CanFinMixin can_wo4.

(* pcan_enumP は証明されているが、can_enumP はないので証明する。 *)
Lemma can_enumP : forall (eT : countType) (fT : finType)
         (f : Countable.sort eT -> Finite.sort fT)
         (g : Finite.sort fT -> Countable.sort eT),
    cancel f g -> Finite.axiom (undup (map g (Finite.enum fT))).
Proof.
  move=> eT fT f g.
  move=> fK x; rewrite count_uniq_mem ?undup_uniq // mem_undup.
  by rewrite -[x]fK map_f //.
Qed.

Lemma windrose_enumP : Finite.axiom (undup (map o2w (Finite.enum (ordinal_finType 4)))).
Proof.
  Check can_enumP.
  apply can_enumP with (f:=w2o).
  by apply can_wo4.
Qed.
Definition windrose_finMixin' := FinMixin windrose_enumP.

(* Definition windrose_finMixin := CanFinMixin can_wo4. *)
Canonical windrose_finType := FinType windrose windrose_finMixin.

Check N \in windrose.
Check N != S.
Check #| windrose | == 4.

(* END *)

Print Equality.axiom.
(* 一般に injective なら Equality.axiom が成り立つという定理： inj_eqAxiom *)
Check inj_eqAxiom : forall (T : Type) (eT : eqType) (f : T -> eT),
    injective f -> Equality.axiom (T:=T) (fun x y : T => f x == f y).
Check @inj_eqAxiom
      windrose                              (* T : Type *)
      (ordinal_eqType 4)                    (* eT : eqType *)
      w2o.                                  (* T -> eT *)

Print Finite.axiom.
(* 一般に cancel なら Finite.axiom が成り立つという定理 *)
Check can_enumP : forall (eT : countType)  (* windrose *)
                         (fT : finType)    (* 'I_4 *)
                         (f : eT -> fT)  (* w2o : windrose -> 'I_4. *)
                         (g : fT -> eT), (* o2w' : 'I_4 -> windrose. *)
    cancel f g -> Finite.axiom (T:=eT) (undup (map g (Finite.enum fT))).
Check @can_enumP
      windrose_countType
      (ordinal_finType 4)
      w2o
      o2w.

(* その他の補題 *)
Check can_pcan : forall (rT aT : Type) (f : aT -> rT) (g : rT -> aT),
    cancel f g -> pcancel f (fun y : rT => Some (g y)).

Definition o2n (o : 'I_4) : nat := val o.

(* サブタイプ型の値からオリジナル型の値を取り出す。 *)
Check @val : forall (T : Type) (P : pred T) (s : subType P), s -> T.
(* これは、injective である。 *)
Check val_inj.

(* サブタイプ('I_4 から、オリジナルタイプの nat を取り出す。 *)
Goal injective o2n.
Proof.
  move=> n x.
  rewrite /o2n.
  (* val n = val x -> n = x *)
  by apply val_inj.
Qed.

(* END *)

(* 主役は w2o か o2w か *)

(*
(* pcancel w2o o2w であることを証明する。 *)
Definition pcan_wo4 := can_pcan can_wo4.
Definition o2w' o : option windrose := Some (o2w o).
 *)


Require Import Imp.
Require Import Smallstep.
Require Import Types.

Module STLC.

Inductive ty :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

Inductive tm :=
  | tvar   : id -> tm
  | tapp   : tm -> tm -> tm
  | tabs   : id -> ty -> tm -> tm
  | ttrue  : tm
  | tfalse : tm
  | tif    : tm -> tm -> tm -> tm
.

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Reserved Notation "'[' x ':=' s ']' t" (at level 20).

Fixpoint subst (x : id) (s : tm) (t : tm) : tm :=
  match t with
    | tvar i   => if eq_id_dec i x then s else tvar i
    | tapp a b => tapp ([x := s] a) ([x := s] b)
    | tabs i tp bd => if eq_id_dec i x then tabs i tp bd
                      else tabs i tp ([x := s] bd)
    | tif c bt be => tif ([x := s] c) ([x := s] bt) ([x := s] be)
    | e => e
  end
  where "'[' x ':=' s ']' t" := (subst x s t).

(* Exercise: 3 stars (substi) *)

Inductive substi (s : tm) (x : id) : tm -> tm -> Prop :=
  | s_var1 :
      substi s x (tvar x) s
  | s_var2 : forall i,
      i <> x ->
      substi s x (tvar i) (tvar i)
  | s_app  : forall a a' b b',
      substi s x a a' ->
      substi s x b b' ->
      substi s x (tapp a b) (tapp a' b')
  | s_abs1 : forall tp bd,
      substi s x (tabs x tp bd) (tabs x tp bd)
  | s_abs2 : forall i tp bd bd',
      i <> x ->
      substi s x bd bd' ->
      substi s x (tabs i tp bd) (tabs i tp bd')
  | s_if   : forall c c' t t' e e',
      substi s x c c' ->
      substi s x t t' ->
      substi s x e e' ->
      substi s x (tif c t e) (tif c' t' e')
  | s_true :
      substi s x ttrue ttrue
  | s_false :
      substi s x tfalse tfalse
.

Hint Constructors substi.

Theorem substi_correct : forall s x t t',
  [x := s] t = t' <-> substi s x t t'.
Proof.
  split; intro.
  - generalize dependent t'.
    induction t; simpl; intros; subst; auto;
      destruct (eq_id_dec i x0); subst; auto.
  - induction H; simpl; subst; auto;
      try rewrite eq_id; try rewrite neq_id; auto.
Qed.

(* END substi. *)

Inductive value : tm -> Prop :=
  | v_abs   : forall x T t, value (tabs x T t)
  | v_true  : value ttrue
  | v_false : value tfalse.

Hint Constructors value.

Reserved Notation "t1 '==>' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
      value v2 ->
      (tapp (tabs x T t12) v2) ==> [x := v2] t12
  | ST_App1   : forall t1 t1' t2,
      t1 ==> t1' ->
      tapp t1 t2 ==> tapp t1' t2
  | ST_App2   : forall t1 t2 t2',
      value t1 ->
      t2 ==> t2' ->
      tapp t1 t2 ==> tapp t1 t2'
  | ST_IfTrue  : forall t e,
      tif ttrue t e ==> t
  | ST_IfFalse : forall t e,
      tif tfalse t e ==> e
  | ST_If : forall c c' t e,
      c ==> c' ->
      tif c t e ==> tif c' t e
  where "t1 '==>' t2" := (step t1 t2).

Hint Constructors step.

Notation multistep := (multi step).

Notation "t1 '==>*' t2" := (multistep t1 t2) (at level 40).

Notation idB    := (tabs x TBool (tvar x)).
Notation idBB   := (tabs x (TArrow TBool TBool) (tvar x)).
Notation idBBBB := (tabs x (TArrow (TArrow TBool TBool) (TArrow TBool TBool))
                           (tvar x)).

(* Exercise: 2 stars (step_example3) *)

Lemma step_example5 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App1. apply ST_AppAbs. apply v_abs.
  eapply multi_step.
    apply ST_AppAbs. apply v_abs.
  simpl. apply multi_refl.
Qed.

Lemma step_example5_with_normalize :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof. normalize. Qed.

(* END step_example3. *)

Definition context := id -> option ty.

Definition pupdate { A : Type } (m : id -> option A) (x : id) (v : A) :=
  update m x (Some v).

Hint Unfold pupdate.

Reserved Notation "Gamma '|-' t '\in' T" (at level 40).

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall G i T,
      G i = Some T ->
      G |- tvar i \in T
  | T_Abs : forall G i T11 bd T12,
      pupdate G i T11 |- bd \in T12 ->
      G |- tabs i T11 bd \in TArrow T11 T12
  | T_App : forall G a1 a2 T11 T12,
      G |- a1 \in TArrow T11 T12 ->
      G |- a2 \in T11 ->
      G |- tapp a1 a2 \in T12
  | T_True : forall G,
      G |- ttrue \in TBool
  | T_False : forall G,
      G |- tfalse \in TBool
  | T_If : forall G c t e T,
      G |- c \in TBool ->
      G |- t \in T ->
      G |- e \in T ->
      G |- (tif c t e) \in T
  where "Gamma '|-' t '\in' T" := (has_type Gamma t T).

Hint Constructors has_type.

(* Exercise: 2 stars, optional (typing_example_2_full) *)

Example typing_example_2_full :
  (fun _ => None) |-
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x))))) \in
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  apply T_Abs. apply T_Abs.
  unfold pupdate.
  apply T_App with TBool. apply T_Var. reflexivity.
  apply T_App with TBool. apply T_Var. reflexivity.
  apply T_Var. reflexivity.
Qed.

(* END typing_example_2_full. *)

(* Exercise: 2 stars (typing_example_3) *)

Example typing_example_3 :
  exists T,
    (fun _ => None) |-
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z)))))) \in T.
Proof with auto.
  exists (TArrow (TArrow TBool TBool)
    ((TArrow (TArrow TBool TBool) (TArrow TBool TBool)))).
  repeat econstructor.
Qed.

(* END typing_example_3. *)

(* Exercise: 3 stars, optional (typing_nonexample_3) *)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
       (fun _ => None) |-
          (tabs x S
             (tapp (tvar x) (tvar x))) \in
     T).
Proof.
  intros [S [T H]].
  inversion H;  subst; clear H.
  inversion H5; subst; clear H5.
  inversion H2; subst; clear H2.
  inversion H4; subst; clear H4.
  rewrite H2 in H1.
  inversion H1.
  clear H1 H2 S.
  induction T11; inversion H0.
  apply IHT11_1. rewrite <- H2. assumption.
Qed.

(* END typing_nonexample_3. *)

End STLC.


Set Implicit Arguments.
Require Import Arith.
Require Import Wf_nat.
Require Import List.
Import ListNotations.

Section var.
  Variable var : Set.

  Inductive term : Set :=
  | tvar : var -> term
  | tapp : term -> term -> term
  | tabs : (var -> term) -> term.

  (* Inductive value : term -> Prop := *)
  (* | vabs : forall (x: var -> term), value (tabs x). *)

  (* Inductive eval : term -> term -> Prop := *)
  (* | E_App1 : forall (t1 t1' t2: term), eval t1 t1' -> eval (tapp t1 t2) (tapp t1' t2) *)
  (* | E_App2 : forall (v1 t2 t2': term), value v1 -> eval t2 t2' -> eval (tapp v1 t2) (tapp v1 t2'). *)
End var.

Definition Exp := forall var, term var.

Example identity : Exp := fun _ => tabs (fun x => tvar x).
Example self_app : Exp := fun _ => tabs (fun x => tapp (tvar x) (tvar x)).

Fixpoint size (t: term unit): nat :=
  match t with
  | tvar _ => 1
  | tapp t1 t2 => 1 + (size t1) + (size t2)
  | tabs t' => 1 + size (t' tt)
  end.

Definition Size (t: Exp) := size (t unit).

Eval compute in Size identity.
Eval compute in Size self_app.

Fixpoint depth (t: term unit): nat :=
  match t with
  | tvar _ => 1
  | tapp t1 t2 => 1 + (list_max [(depth t1); (depth t2)])
  | tabs t' => 1 + depth (t' tt)
  end.

Definition Depth (t: Exp) := depth (t unit).

Eval compute in Depth identity.
Eval compute in Depth self_app.

Section flatten.
  Variable var: Set.

  Fixpoint flatten (t : term (term var)) : term var :=
    match t with
    | tvar t' => t'
    | tapp t1 t2 => tapp (flatten t1) (flatten t2)
    | tabs t1 => tabs (fun x => flatten (t1 (tvar x)))
  end.

End flatten.

Definition Exp1 := forall var : Set, var -> term var.
Definition Subst (E: Exp1) (E' : Exp): Exp := fun var => flatten (E (term var) (E' var)).

Example ident1 : Exp1 := fun _ X => tvar X.

Example free_var : Exp1 := fun _ x => tabs (fun y => tvar x).
Example expr : Exp := fun _ => tabs (fun x => tvar x).

Eval compute in Subst free_var expr.


From Coq Require Import ZArith Ascii String Eqdep_dec.
From Vyper Require Import Config.

Inductive int_size
:= I8 | I32 | I64 | I128 | I256.

Definition int_size_in_bits (i: int_size): Z
:= match i with
   | I8 => 8
   | I32 => 32
   | I64 => 64
   | I128 => 128
   | I256 => 256
   end.

Definition int_size_in_bytes (i: int_size): Z
:= match i with
   | I8 => 1
   | I32 => 4
   | I64 => 8
   | I128 => 16
   | I256 => 32
   end.

Lemma int_size_ok (i: int_size):
  int_size_in_bits i = (8 * int_size_in_bytes i)%Z.
Proof.
  destruct i; trivial.
Qed.

Definition string_of_int_size (i: int_size): string
:= match i with
   | I8 => "8"
   | I32 => "32"
   | I64 => "64"
   | I128 => "128"
   | I256 => "256"
   end.

Definition int_size_of_string (s: string): option int_size
:= match s with
   | "8"%string => Some I8
   | "32"%string => Some I32
   | "64"%string => Some I64
   | "128"%string => Some I128
   | "256"%string => Some I256
   | _ => None
   end.

Lemma int_size_of_string_of_int_size (i: int_size):
  int_size_of_string (string_of_int_size i) = Some i.
Proof.
now destruct i.
Qed.

Definition uint_max (i: int_size) := (2 ^ int_size_in_bits i - 1)%Z.
Definition sint_max (i: int_size) := (2 ^ (int_size_in_bits i - 1) - 1)%Z.
Definition sint_min (i: int_size) := (- 2 ^ (int_size_in_bits i - 1))%Z.

Example uint_max_byte: uint_max I8 = 255%Z.    Proof. trivial. Qed.
Example sint_min_byte: sint_min I8 = (-128)%Z. Proof. trivial. Qed.
Example sint_max_byte: sint_max I8 = 127%Z.    Proof. trivial. Qed.

Inductive yul_type
:= BoolType
 | IntType (size: int_size) (signed: bool).

Lemma yul_type_eq_dec (a b: yul_type)
: {a = b} + {a <> b}.
Proof.
repeat decide equality.
Defined.

Definition U8 := IntType I8 false.
Definition S8 := IntType I8 true.
Definition U32 := IntType I32 false.
Definition S32 := IntType I32 true.
Definition U64 := IntType I64 false.
Definition S64 := IntType I64 true.
Definition U128 := IntType I128 false.
Definition S128 := IntType I128 true.
Definition U256 := IntType I256 false.
Definition S256 := IntType I256 true.

Definition uint256_to_Z_as_signed {C: VyperConfig} (n: uint256)
: Z
:= let z := Z_of_uint256 n in
   if Z.testbit z 255%Z
     then z - 2 ^ 256
     else z.

Inductive yul_value {C: VyperConfig} (t: yul_type)
:= NumberValue (value: uint256)
               (ok: match t with
                    | BoolType => false
                    | IntType size true  => let x := uint256_to_Z_as_signed value in
                                            andb (sint_min size <=? x)%Z (x <=? sint_max size)%Z
                    | IntType size false => let x := Z_of_uint256 value in
                                            andb (0 <=? x)%Z (x <=? uint_max size)%Z
                    end = true)
 | BoolValue (b: bool)
             (ok:  match t with
                   | BoolType => true
                   | _ => false
                   end = true).

Definition yul_true  {C: VyperConfig} := BoolValue BoolType true eq_refl.
Definition yul_false {C: VyperConfig} := BoolValue BoolType false eq_refl.

Lemma yul_uint256_helper {C: VyperConfig} (value: uint256):
  ((0 <=? Z_of_uint256 value)%Z && (Z_of_uint256 value <=? uint_max I256)%Z)%bool = true.
Proof.
assert (R := uint256_range value).
apply andb_true_intro. split.
now rewrite Z.leb_le.
unfold uint_max. unfold int_size_in_bits.
rewrite Z.leb_le.
apply Zsucc_le_reg.
replace (Z.succ (2 ^ 256 - 1))%Z with (2 ^ 256)%Z by trivial.
now apply Zlt_le_succ.
Qed.

Definition yul_uint256 {C: VyperConfig} (value: uint256)
: yul_value U256
:= NumberValue U256 value (yul_uint256_helper value).

Definition dynamic_value {C: VyperConfig} := { t: yul_type & yul_value t }.

Definition dynamic_value_of_uint256 {C: VyperConfig} (value: uint256)
:= existT _ U256 (yul_uint256 value).

Definition uint256_of_yul_value {C: VyperConfig} {t: yul_type} (y: yul_value t)
: uint256
:= match y with
   | NumberValue _ value _ => value
   | BoolValue _ true  _ => one256
   | BoolValue _ false _ => zero256
   end.

Local Lemma uint256_to_yul_value_helper_bool {C: VyperConfig} {t: yul_type} (T: t = BoolType):
   match t with
   | BoolType => true
   | IntType _ _ => false
   end = true.
Proof.
now subst.
Qed.

Local Lemma uint256_to_yul_value_helper_sint {C: VyperConfig} {t: yul_type} {u : uint256}
                                             {size: int_size} (T: t = IntType size true)
                                             (E: let x := uint256_to_Z_as_signed u in
                                                  ((sint_min size <=? x)%Z &&
                                                    (x <=? sint_max size)%Z)%bool = true):
   match t with
   | BoolType => false
   | IntType size true =>
       let x := uint256_to_Z_as_signed u in ((sint_min size <=? x)%Z && (x <=? sint_max size)%Z)%bool
   | IntType size false => let x := Z_of_uint256 u in ((0 <=? x)%Z && (x <=? uint_max size)%Z)%bool
   end = true.
Proof.
now subst.
Qed.

Local Lemma uint256_to_yul_value_helper_uint {C: VyperConfig} {t: yul_type} {u : uint256}
                                             {size: int_size} (T: t = IntType size false)
                                             (E: let x := Z_of_uint256 u in
                                                  ((0 <=? x)%Z && (x <=? uint_max size)%Z)%bool = true):
   match t with
   | BoolType => false
   | IntType size true =>
       let x := uint256_to_Z_as_signed u in ((sint_min size <=? x)%Z && (x <=? sint_max size)%Z)%bool
   | IntType size false => let x := Z_of_uint256 u in ((0 <=? x)%Z && (x <=? uint_max size)%Z)%bool
   end = true.
Proof.
now subst.
Qed.

Definition yul_value_of_uint256 {C: VyperConfig} (u: uint256) (t: yul_type)
: option (yul_value t)
:= match t as t' return t = t' -> _ with
   | BoolType => fun T =>
                 match Z_of_uint256 u with
                 | 0%Z => Some (BoolValue t false (uint256_to_yul_value_helper_bool T))
                 | 1%Z => Some (BoolValue t true (uint256_to_yul_value_helper_bool T))
                 | _ => None
                 end
   | IntType size true => fun T =>
                          let x := uint256_to_Z_as_signed u in
                          (if andb (sint_min size <=? x)%Z (x <=? sint_max size)%Z as c
                           return _ = c -> _
                             then fun E => Some (NumberValue t u (uint256_to_yul_value_helper_sint T E))
                             else fun _ => None) eq_refl
   | IntType size false => fun T =>
                           let x := Z_of_uint256 u in
                           (if andb (0 <=? x)%Z (x <=? uint_max size)%Z as c return _ = c -> _
                              then fun E => Some (NumberValue t u (uint256_to_yul_value_helper_uint T E))
                              else fun _ => None) eq_refl
   end eq_refl.

Lemma yul_value_of_uint256_u256 {C: VyperConfig} (u: uint256):
  yul_value_of_uint256 u U256 = Some (yul_uint256 u).
Proof.
simpl.
assert (R := uint256_range u).
unfold uint_max. unfold int_size_in_bits.
assert (T: ((0 <=? Z_of_uint256 u)%Z && (Z_of_uint256 u <=? 2 ^ 256 - 1)%Z)%bool = true).
{
  apply andb_true_intro.
  destruct R as (L, U).
  split. { apply Z.leb_le. exact L. }
  apply Z.leb_le.
  rewrite Z.sub_1_r.
  apply Z.lt_le_pred in U.
  exact U.
}
rewrite Logic2.if_yes with (E := T).
f_equal.
unfold yul_uint256.
f_equal.
apply eq_proofs_unicity. decide equality.
Qed.

Lemma yul_value_of_uint256_of_yul_value {C: VyperConfig} (t: yul_type) (v: yul_value t):
  yul_value_of_uint256 (uint256_of_yul_value v) t = Some v.
Proof.
destruct t; cbn; destruct v; try discriminate.
{
  destruct b; cbn; [unfold one256 | unfold zero256];
     rewrite uint256_ok; cbn; repeat f_equal; apply eq_proofs_unicity;
     decide equality.
}
destruct signed; cbn in *.
{
  (* signed *)
  remember (fun E =>
             Some (NumberValue (IntType size true) value (uint256_to_yul_value_helper_sint eq_refl E)))
    as good_branch.
  enough (Q: forall E, good_branch E = Some (NumberValue (IntType size true) value ok)).
  {
    clear Heqgood_branch.
    revert good_branch Q.
    assert (ok' := ok).
    now rewrite ok'.
  }
  intros.
  subst. repeat f_equal.
  apply eq_proofs_unicity; decide equality.
}
(* unsigned *)
remember (fun E =>
           Some (NumberValue (IntType size false) value (uint256_to_yul_value_helper_uint eq_refl E)))
  as good_branch.
enough (Q: forall E, good_branch E = Some (NumberValue (IntType size false) value ok)).
{
  clear Heqgood_branch.
  revert good_branch Q.
  assert (ok' := ok).
  now rewrite ok'.
}
intros.
subst. repeat f_equal.
apply eq_proofs_unicity; decide equality.
Qed.

Definition uint256_of_dynamic_value {C: VyperConfig} (d: dynamic_value)
: uint256
:= let '(existT _ _ v) := d in
   uint256_of_yul_value v.

Lemma bool_eq_via_uint256 {C: VyperConfig}
                          (a b: bool)
                          (E: (if a then one256 else zero256)
                               =
                              (if b then one256 else zero256)):
  a = b.
Proof.
assert (E': Z_of_uint256 (if a then one256 else zero256) = Z_of_uint256 (if b then one256 else zero256))
  by now rewrite E.
unfold one256 in E'. unfold zero256 in E'.
destruct a, b; repeat rewrite uint256_ok in E'; now try discriminate.
Qed.

Lemma yul_value_eq_via_uint256 {C: VyperConfig}
                               (t: yul_type)
                               (a b: yul_value t)
                               (E: uint256_of_yul_value a = uint256_of_yul_value b):
  a = b.
Proof.
unfold uint256_of_yul_value in E.
destruct a, b, t; try discriminate; [| apply bool_eq_via_uint256 in E ];
  subst; f_equal; apply Eqdep_dec.eq_proofs_unicity; decide equality.
Qed.

Definition string_of_type (t: yul_type)
:= match t with
   | BoolType => "bool"%string
   | IntType size signed => String (if signed then "s"%char else "u"%char) (string_of_int_size size)
   end.

Example string_of_u256: string_of_type U256 = "u256"%string. Proof. trivial. Qed.

Definition type_of_string (s: string)
: option yul_type
:= match s with
   | String "s"%char size =>
        match int_size_of_string size with
        | Some s => Some (IntType s true)
        | None => None
        end
   | String "u"%char size =>
        match int_size_of_string size with
        | Some s => Some (IntType s false)
        | None => None
        end
   | "bool"%string => Some BoolType
   | _ => None
   end.

Lemma type_of_string_of_type (t: yul_type):
  type_of_string (string_of_type t) = Some t.
Proof.
destruct t as [|size]. { trivial. }
now destruct size, signed.
Qed.

Local Lemma int_zero_value_helper {C: VyperConfig} (size: int_size) (signed: bool):
   match IntType size signed with
   | BoolType => false
   | IntType size true =>
       let x := uint256_to_Z_as_signed zero256 in
       ((sint_min size <=? x)%Z && (x <=? sint_max size)%Z)%bool
   | IntType size false =>
       let x := Z_of_uint256 zero256 in ((0 <=? x)%Z && (x <=? uint_max size)%Z)%bool
   end = true.
Proof.
cbn. unfold zero256. unfold uint256_to_Z_as_signed.
rewrite uint256_ok. cbn.
now destruct signed, size.
Qed.

Definition int_zero_value {C: VyperConfig} (size: int_size) (signed: bool)
: yul_value (IntType size signed)
:= NumberValue (IntType size signed) zero256 (int_zero_value_helper size signed).

Definition zero_value {C: VyperConfig} (t: yul_type)
: yul_value t
:= match t with
   | BoolType => yul_false
   | IntType size signed => int_zero_value size signed
   end.

Lemma zero_value_ok {C: VyperConfig} (t: yul_type):
  Z_of_uint256 (uint256_of_yul_value (zero_value t)) = 0%Z.
Proof.
destruct t; cbn; unfold zero256; rewrite uint256_ok; trivial.
Qed.


Require Export Arith.
Require Export ArithRing.
Require Export Wf_nat.
Add LoadPath "../../progav/SRC/".
(* The preliminary theorems are already in the exercise fib_positive. *)
Require Export fib_positive.

Theorem div2_rec:
 forall (P : nat ->  Set),
 P 0 -> P 1 -> (forall n, P n ->  P (S (S n))) -> forall (n : nat),  P n.
Proof.
intros P H0 H1 Hrec n; assert (P n * P (S n))%type.
elim n; intuition.
intuition.
Qed.

Theorem div2_spec:
 forall n,  ({x : nat | 2 * x = n}) + ({x : nat | 2 * x + 1 = n}).
intros n; elim n  using div2_rec.
left; exists 0; trivial.
right; exists 0; trivial.
intros p [[x Heq]|[x Heq]].
left; exists (S x); rewrite <- Heq; ring.
right; exists (S x); rewrite <- Heq; ring.
Qed.

Theorem half_smaller0: forall n x, 2 * x = S n ->  (x < S n).
Proof.
intros; omega.
Qed.

Theorem half_smaller1: forall n x, 2 * x + 1 = n ->  (x < n).
Proof.
intros; omega.
Qed.

Definition fib_log_F:
 forall (x : nat),
 (forall (y : nat),
  y < x ->  ({u : nat & {v : nat | u = fib y /\ v = fib (S y)}})) ->
  ({u : nat & {v : nat | u = fib x /\ v = fib (S x)}}).
intros [|x'].
intros _.
exists 1; exists 1; auto.
destruct (div2_spec (S x')) as [[half_sx' Heq]|[half_x' Heq]]; intros fib_log.
destruct (fib_log half_sx' (half_smaller0 _ _ Heq)) as [u [v [Heq1 Heq2]]].
rewrite <- Heq.
exists (u * u + (v - u) * (v - u)).
exists ((2 * u) * v - u * u).
rewrite Heq1; rewrite Heq2.
split.
replace (S half_sx') with (half_sx' + 1).
rewrite <- fib_2n.
trivial.
ring.
replace (S half_sx') with (half_sx' + 1).
rewrite <- fib_2n_plus_1.
replace (2 * half_sx' + 1) with (S (2 * half_sx')).
trivial.
ring.
ring.
destruct (fib_log half_x' (half_smaller1 _ _ Heq)) as [u [v [Heq1 Heq2]]].
rewrite <- Heq.
exists ((2 * u) * v - u * u).
exists (v * v + u * u).
rewrite Heq1; rewrite Heq2.
split.
replace (S half_x') with (half_x' + 1).
rewrite <- fib_2n_plus_1.
trivial.
ring.
replace (S half_x') with (half_x' + 1).
rewrite <- fib_2n_plus_2.
trivial.
ring.
Qed.

Definition fib_log :
  forall (x : nat),  ({u : nat & {v : nat | u = fib x /\ v = fib (S x)}}) :=
   well_founded_induction
    lt_wf (fun x => {u : nat & {v : nat | u = fib x /\ v = fib (S x)}})
    fib_log_F.