(* From the standard library. *)
Require Import List ZArith Psatz.
Import ListNotations.
Local Open Scope Z_scope.

(* From StLib. *)
Require Import Sets.

(** Warmup: A few simple, handy tactics. *)

Ltac inv H := inversion H; subst; clear H.

Tactic Notation "decide" constr(x) "=" constr(y) :=
  destruct (Z.eq_dec x y); subst; simpl in *.

(** * First automation layer: Simplifying goals. *)

Ltac simplify_hyps :=
  repeat
    match goal with
      | [ H : @is_in _ _ (@empty _) |- _ ] => inv H
      | [ H : @is_in _ _ (@singleton _ _) |- _ ] => inv H
      | [ H : @is_in _ _ (@segment _ _) |- _ ] => inv H
      | [ H : @is_in _ _ (@bin_union _ _ _) |- _ ] => inv H
      | [ H : @is_in _ _ (@times _ _ _ _) |- _ ] => inv H
      | [ H : @is_in _ _ (@param_union _ _ _ _) |- _ ] => inv H

      | [ H : @empty _ _ |- _] => inversion H
      | [ H : @singleton _ _ _ |- _ ] => red in H
      | [ H : @segment _ _ _ |- _ ] => red in H
      | [ H : @bin_union _ _ _ _ |- _ ] => red in H
      | [ H : @times _ _ _ _ _ |- _ ] => destruct H
      | [ H : @param_union _ _ _ _ _ |- _ ] => destruct H as [? [? ?]]

      | [ x : @prod _ _ |- _ ] => destruct x

      | [ H : _ /\ _ |- _ ] => destruct H
      | [ H : _ \/ _ |- _ ] => destruct H
end.

Ltac simplify_goal' :=
  match goal with
    | [ |- @subset _ _ _ ] => intro

    | [ |- @is_in _ _ (@singleton _ _) ] =>
      constructor; red
    | [ |- @is_in _ _ (@segment _ _) ] =>
      constructor; split
    | [ |- @is_in _ (@pair _ _ _ _) (@times _ _ _ _) ] =>
      constructor; split
    | [ |- @is_in _ _ (@param_union _ _ _ _) ] =>
      constructor; red

    | [ H : @same _ ?A _ |- @is_in _ _ ?A ] => now apply H
    | [ H : @same _ _ ?A |- @is_in _ _ ?A ] => now apply H

    | [ |- forall _, _ ] => intro
    | [ |- _ /\ _ ] => split
    | [ |- _ <-> _ ] => split
    | [ |- ~ _ ] => intro

    | [ x : @prod _ _ |- _ ] => destruct x
    | [ |- @pair _ _ _ _ = @pair _ _ _ _ ] => f_equal
  end.

Ltac simplify_goal :=
  repeat progress simplify_goal'.

Ltac double_incl := match goal with [ |- @same _ _ _ ] => intro end.

Ltac forward :=
  repeat
    first [assumption | reflexivity |
           progress simplify_goal | progress simplify_hyps | double_incl].

(** [step] does set-theoretic reasoning.  [lhs] and [rhs] allow one to prove
 * that an element belongs to a binary union, by proving that it belongs to one
 * of the two given sets. *)

Ltac lhs :=
  match goal with
    [ |- @is_in _ _ (@bin_union _ _ _) ] => constructor; left
  end.

Ltac rhs :=
  match goal with
      [ |- @is_in _ _ (@bin_union _ _ _) ] => constructor; right
  end.

Ltac forward' :=
  repeat first [lhs; now forward' | rhs; now forward' |
                progress forward].

(** * Bruteforce pass-or-fail automation. *)

Ltac iter_exists l tac :=
  match l with
    | ?x :: ?xs =>
      (exists x; tac) || iter_exists xs tac
  end.

(* [bruteforce' l] tries to solve the current goal.  If needed, it
 * instanciates existential variables using the variables provided in [l]. *)

Ltac bruteforce' l :=
  simplify_hyps;
  match goal with
    | [ |- _ ] => assumption
    | [ |- @subset _ _ _ ] => intro; bruteforce' l

    | [ |- @is_in _ _ (@singleton _ _) ] =>
      constructor; red; bruteforce' l
    | [ |- @is_in _ _ (@segment _ _) ] =>
      constructor; split; bruteforce' l
    | [ |- @is_in _ (@pair _ _ _ _) (@times _ _ _ _) ] =>
      constructor; split; bruteforce' l
    | [ |- @is_in _ _ (@bin_union _ _ _) ] =>
      (lhs; bruteforce' l) || (rhs; bruteforce' l)
    | [ |- @is_in _ _ (@param_union _ _ _ _) ] =>
      constructor; red; bruteforce' l

    | [ |- forall _, _ ] =>
      intro; bruteforce' l
    | [ |- exists _, _ ] =>
      iter_exists l ltac:(bruteforce' l)
    | [ |- ~ _ ] =>
      intro; bruteforce' l
    | [ |- _ /\ _ ] =>
      split; bruteforce' l
    | [ |- _ \/ _ ] =>
      (left; bruteforce' l) || (right; bruteforce' l)
    | [ H : _ \/ _ |- _ ] =>
      destruct H; bruteforce' l

    | [ |- False ] =>
      simpl in *; nia
    | [ |- _ <= _ ] =>
      simpl in *; nia
    | [ |- _ = _ ] =>
      simpl in *; nia
    | [ |- _ = _ ] =>
      progress f_equal; bruteforce' l
  end.

Ltac bruteforce :=
  bruteforce' ([] : list Z).

(** * Generating all expressions from a list of constants. *)

(** The following few functions are used to generate a list of ALL expressions
 * of depth at most [n], using constants from a list [l] and operators from a
 * list [ops]. *)

(** Appends [op x y] to [acc] for every [op] in [ops]. *)
Fixpoint apply_ops (x y : Z) ops (acc : list Z) :=
  match ops with
    | op :: ops' =>
      apply_ops x y ops' ((op x y) :: acc)
    | nil => acc
  end.

(** Appends [op x y] to [acc] for every [y] in [ys] and every [op] in [ops]. *)
Fixpoint map_ops (x : Z) ys ops (acc : list Z) :=
  match ys with
    | y :: ys' =>
      map_ops x ys' ops (apply_ops x y ops acc)
    | nil => acc
  end.

(** Appends [op x y] to [acc] for every [x] in [xs], every [y] in [ys] and
 * every [op] in [ops]. *)
Fixpoint gen_expr_step xs ys ops acc :=
  match xs with
    | x :: xs' =>
      gen_expr_step xs' ys ops (map_ops x ys ops acc)
    | nil => acc
  end.

(** Iterates [gen_expr_step] on list [l] with operators from list [ops]. *)
Fixpoint gen_expr' l ops (n : nat) acc :=
  match n with
    | 0%nat => acc
    | S k =>
      gen_expr' l ops k (gen_expr_step l acc ops acc)
  end.
Definition gen_expr l ops n :=
  rev' (gen_expr' l ops n l).


From Hammer Require Import Hammer.

Arguments id {A} x.

Definition compose {A B C} (g : B -> C) (f : A -> B) :=
fun x : A => g (f x).

Hint Unfold compose.

Notation " g ∘ f " := (compose g f)
(at level 40, left associativity) : program_scope.

Local Open Scope program_scope.

Definition arrow (A B : Type) := A -> B.

Definition impl (A B : Prop) : Prop := A -> B.

Definition const {A B} (a : A) := fun _ : B => a.

Definition flip {A B C} (f : A -> B -> C) x y := f y x.

Definition apply {A B} (f : A -> B) (x : A) := f x.

Arguments prod_curry   {A B C} f p.
Arguments prod_uncurry {A B C} f x y.


Require Import List Lia Nat Bool.
Import ListNotations.
From Minirust.def Require Import utils ty le.
From Minirust.proof.lemma Require Import le.

Lemma declare_impl {T: Type} (t: T) : exists t', t=t'. exists t. reflexivity. Qed.

Ltac declare x Hx obj := destruct (declare_impl obj) as [x Hx].
Ltac have x obj := destruct (declare_impl obj) as [x _].

Lemma bind_some {T T'} {x: T} {f: T -> option T'} : (Some x >>= f) = f x.
Proof.
simpl. auto.
Qed.

Lemma bind_none {T T'} {f: T -> option T'} : (None >>= f) = None.
Proof.
simpl. auto.
Qed.

Lemma transpose_map {T1 T2 T3} {f: T1 -> option T2} {g: T2 -> option T3} {l: list T1} {l'} (H: transpose (map f l) = Some l') :
map g l' = map (fun x => (f x) >>= g) l.
Proof.
generalize dependent l'.
induction l as [|x l IH].
{ intros l' H. simpl in H. inversion H. simpl. auto. }

intros l' H.
simpl in H.
destruct (f x) as [t2|] eqn:Hfx; cycle 1.
{ discriminate H. }

destruct (transpose (map f l)) as [l2|] eqn:E; cycle 1.
{ simpl in H. discriminate H. }

simpl in H.
inversion H.
simpl.
rewrite Hfx.
simpl.
f_equal.
apply IH.
auto.
Qed.

Lemma transpose_some {T} {x: T} {l: list (option T)} : transpose ((Some x) :: l) = (transpose l o-> (fun a => x :: a)).
Proof. simpl. auto. Qed.

Lemma transpose_len {T r} {l: list (option T)} (H: transpose l = Some r) :
  length l = length r.
Proof.
generalize dependent r.
induction l.
{ intros r X. inversion X. auto. }

intros r X.
simpl.
destruct r.
{ destruct a; inversion X; destruct (transpose l); simpl in H0; discriminate H0. }
simpl.
f_equal.
apply IHl.
inversion X.
destruct a; destruct (transpose l); inversion H0; auto.
Qed.

Lemma transpose_nil {T1 T2 l} {f: T1 -> option T2} (H: transpose (map f l) = Some []) :
 l = [].
Proof.
destruct l. { auto. }
simpl in H.
destruct (f t); cycle 1.
{ discriminate H. }

destruct (transpose (map f l)); cycle 1.
{ simpl in H. discriminate H. }

simpl in H.
inversion H.
Qed.

Lemma transpose_map_Forall {T1 T2} {l: list T1} {l': list T2} {P: T2 -> Prop} {f: T1 -> option T2}
  (A: transpose (map f l) = Some l')
  (B: forall x, forall y, f x = Some y -> P y) :
  Forall P l'.
Proof.
generalize dependent l'.
induction l as [|x l IH].
{ intros l' A. simpl in A. inversion A. apply Forall_nil. }

intros l' A.
destruct l'.
{ destruct (transpose_nil A). auto. }

simpl in A.

destruct (f x) eqn:F; cycle 1.
{ discriminate A. }

destruct (transpose (map f l)) eqn:G; cycle 1.
{ discriminate A. }

simpl in A.
inversion A.
rewrite <- H0.
apply Forall_cons.
- apply (B _ _ F).
- apply IH. inversion H1. auto.
Qed.

Section utils.

Context {memory: Memory}.

Lemma transpose_le_step [o1 o2: option (list Value)] [v1 v2]
  (Hle1: le o1 o2)
  (Hle2: le v1 v2) :
  le (o1 o-> (fun r => v1 :: r)) (o2 o-> (fun r => v2 :: r)).
Proof.
destruct o1; cycle 1.
{ simpl. auto. }

destruct o2; cycle 1.
{ simpl. auto. }

simpl (Some _ o-> _).
assert (le (v1 :: l) (v2 :: l0)); cycle 1. { auto. }

rewrite le_list_step.
auto.
Qed.

Lemma transpose_le [l1 l2: list (option Value)] (Hle: le l1 l2) :
  le (transpose l1) (transpose l2).
Proof.
generalize dependent l2.
induction l1 as [|x1 l1 IH].
{ intros. simpl in Hle. destruct l2; auto. contradict Hle. }

intros.
destruct l2 as [|x2 l2].
{ contradict Hle. }

destruct x1; cycle 1.
{ simpl. auto. }

destruct x2; cycle 1.
{ simpl in Hle. contradict (proj1 Hle). }

simpl (transpose (Some _ :: _)).
assert (le l1 l2).
{ inversion Hle. auto. }

have A (IH l2 H).
apply (transpose_le_step A).
inversion Hle.
auto.
Qed.

Lemma map_nth_switchd {A B : Type} {f : A -> B}
                      (da: A) {l : list A} {n : nat} {db : B}
  (H: n < length l) :
  nth n (map f l) db = f (nth n l da).
Proof.
generalize dependent n.
induction l as [|x l IH].
{ intros. destruct n; simpl in H; lia. }

intros.
destruct n as [|n]. { auto. }

simpl.
apply IH.
simpl in H.
lia.
Qed.

Lemma transpose_nth_ext {T} (def: T) {xs: list T} {l: list (option T)} (Hlen: length l = length xs) (H: forall def j, j < length l -> nth j l None = Some (nth j xs def))
 : transpose l = Some xs.
Proof.
generalize dependent xs.
induction l as [|a l IH].
{ intros. simpl. destruct xs; simpl; try discriminate. auto. }

intros.
destruct xs as [|x xs]. { discriminate. }

assert (0 < length (a :: l)) as Hobv. { simpl. lia. }
pose proof (H def 0 Hobv).

destruct a as [a|]; cycle 1. {
  simpl in H0. discriminate.
}

simpl.

simpl in H0. inversion H0.
rewrite H2 in *. clear a H2.

rewrite (IH xs).
{ simpl. auto. }
{ simpl in Hlen. lia. }
intros def' j Hj.

pose proof (H def' (S j)).
simpl in H1.
apply H1.
lia.
Qed.

Lemma transpose_nth {T xs} {l: list (option T)} (H: transpose l = Some xs) :
  forall def j, j < length l -> nth j l None = Some (nth j xs def).
Proof.
generalize dependent xs.
induction l as [|x_ l IH].
{ intros. simpl in H0. lia. }

intros.
destruct x_ as [x|]; cycle 1.
{ simpl in H. discriminate. }

destruct xs as [|x__ xs].
{ pose proof transpose_len H.
  simpl in *. lia.
}

assert (x__ = x) as ->. {
  simpl in H.
  destruct (transpose l); try discriminate.
  simpl in H.
  inversion H.
  auto.
}

destruct j as [|j].
{ simpl. auto. }

simpl.
apply IH.
{ simpl in H. destruct (transpose l); try discriminate. simpl in H. inversion H. auto. }
{ simpl in *. lia. }
Qed.

End utils.


(***************************************************************************
 * Cast-Free Featherweight Java
 *
 * Bruno De Fraine, with help from Erik Ernst and Mario Sudholt, Summer 2008
 ***************************************************************************)

(** printing \in %\ensuremath{\in}% *)
(** printing \notin %\ensuremath{\notin}% *)
(** printing == %\ensuremath{\doteq}% *)

(** This library provides a number of auxiliary constructs (and their
    properties) for the study of programming languages in Coq. The definition
    of these constructs is mostly straightforward. *)

Require Import AdditionalTactics.
Require Export Atom.
Require Export List.

Set Implicit Arguments.

(** * Atoms *)

Notation "x == y" := (eq_atom_dec x y) (at level 67).

Fact eq_atom_true: forall (A : Type) a (c d : A),
    (if a == a then c else d) = c.
Proof.
  intros.
  destruct (a == a); [ | destruct n]; reflexivity.
Qed.

Fact eq_atom_false: forall (A : Type) a b (c d : A),
    a <> b -> (if a == b then c else d) = d.
Proof.
  intros.
  destruct (a == b); [ subst; destruct H | ]; reflexivity.
Qed.

Definition In_atom_list_dec := In_dec eq_atom_dec.

(** * Environments *)

(** An environment maps atoms to some value of an variable type [A]. We model
    an environment as a list of pairs: [list (atom * A)]. *)

Notation "x \in E" := (In x E) (at level 69).
Notation "x \notin E" := (~ In x E) (at level 69).

Section Environment.

    Variable A: Type.

    (** The function [get x E] retrieves the first binding of [x] in
        environment [E]. *)

    Fixpoint get (x: atom) (E: list (atom * A)) : option A :=
        match E with
        | nil => None
        | (y,v)::E => if x == y then Some v else get x E
        end.

    (** [binds x v E] holds when [x] is bound to [v] in [E].  [no_binds x E]
        holds when there is no binding for [x] in [E].  *)

    Definition binds x v E : Prop :=
        get x E = Some v.

    Definition no_binds x E : Prop :=
        get x E = None.

    Fact binds_first: forall x (a : A) E, binds x a ((x,a)::E).
    Proof.
      intros.
      unfold binds. simpl.
      apply eq_atom_true.
    Qed.

    Fact binds_other: forall x y (a b : A) E,
        binds y b E -> x <> y -> binds y b ((x,a)::E).
    Proof.
      intros.
      unfold binds in *. simpl.
      rewrite eq_atom_false with (1:=sym_not_eq H0).
      assumption.
    Qed.

    Fact binds_nil: forall x (a : A), ~binds x a nil.
    Proof.
      unfold binds. simpl. intros. discriminate.
    Qed.

    Fact binds_fun: forall E x (a b : A),
        binds x a E -> binds x b E -> a = b.
    Proof.
      unfold binds. intros E x a b H H'.
      rewrite H' in H. injection H.
      auto.
    Qed.

    Fact binds_elim_eq: forall x (a b : A) E,
        binds x a ((x,b)::E) -> a = b.
    Proof.
      intros x a b E.
      unfold binds. simpl.
      rewrite eq_atom_true.
      injection 1. auto.
    Qed.

    Fact binds_elim_neq: forall x y (a b : A) E,
        x <> y -> binds x a ((y,b)::E) -> binds x a E.
    Proof.
      intros x y a b E H.
      unfold binds. simpl.
      rewrite eq_atom_false; trivial.
    Qed.

    Fact binds_head : forall x a E F,
        binds x a F -> binds x a (F ++ E).
    Proof.
      unfold binds.
      induction F as [|(y,b)]; simpl; intros H.
      Case "nil". discriminate.
      Case "cons". destruct (x == y); auto.
    Qed.

    Fact binds_nobinds : forall x a E,
        binds x a E -> no_binds x E -> False.
    Proof.
      unfold binds. unfold no_binds. intros.
      rewrite H in H0. discriminate.
    Qed.

    Fact nobinds_nil: forall x, no_binds x nil.
    Proof.
      intros.
      unfold no_binds. reflexivity.
    Qed.

    Fact nobinds_cons: forall x y b E,
        no_binds x E ->
        x <> y ->
        no_binds x ((y,b)::E).
    Proof.
      unfold no_binds. intros.
      simpl.
      rewrite eq_atom_false with (1:=H0).
      assumption.
    Qed.

    Fact nobinds_app: forall x E1 E2,
       no_binds x E1 ->
       no_binds x E2 ->
       no_binds x (E1++E2).
    Proof.
      unfold no_binds. intros.
      induction E1 as [|(y,v)]; simpl.
      Case "nil". assumption.
      Case "cons". destruct (x==y).
        SCase "x=y".
          subst. rewrite binds_first in H. discriminate H.
        SCase "x<>y".
          simpl in H. rewrite eq_atom_false with (1:=n) in H.
          auto.
    Qed.

    (** The functions [keys E] and [dom E] retrieve the atoms that are bound in
        the environment [E]. *)

    Definition keys (E: list (atom * A)) : list atom :=
        List.map (fun p => match p with (x,_) => x end) E.

    Definition dom := keys.

    Fact dom_binds: forall (E : list (atom * A)) (x : atom),
        x \in dom E -> exists v:A, binds x v E.
    Proof.
      intros.
      induction E as [| (u, v) E]; simpl in H.
      Case "nil". contradiction.
      Case "cons".
        unfold binds in *. simpl in *.
        destruct (x == u); [ eauto | apply IHE ].
        destruct H; [ symmetry in H; contradiction | apply H ].
    Qed.

    Fact binds_In : forall a x E,
        binds x a E -> x \in dom E.
    Proof.
      intros.
      induction E as [| (u, v) E].
      Case "nil". contradiction (binds_nil H).
      Case "cons".
        unfold binds in *. simpl in *.
        destruct (x == u); auto.
    Qed.

    Fact dom_binds_neg: forall (E : list (atom * A)) (x : atom),
        x \notin dom E -> get x E = None.
    Proof.
      intros.
      induction E as [| (u, v) E].
      Case "nil". reflexivity.
      Case "cons".
        simpl in *.
        destruct (x == u); [ contradiction H | apply IHE ]; auto.
    Qed.

    (** The function [imgs E] retrieves the values in [E]. [map f E] applies
        [f] to the values in [E]. *)

    Definition imgs (E: list (atom * A)) : list A :=
        List.map (fun p => match p with (_,v) => v end) E.

    Definition map (B: Type) (f: A -> B) (E: list (atom * A)) : list (atom * B) :=
        List.map (fun p => match p with (x,v) => (x, f v) end) E.

    (** [ok E] holds when the environment [E] contains no duplicate bindings. *)

    Inductive ok: list (atom * A) -> Prop :=
    | ok_nil: ok nil
    | ok_cons: forall E x v, ok E -> no_binds x E -> ok ((x,v)::E).

    Fact binds_concat_ok : forall x a E F,
      binds x a E -> ok (F ++ E) -> binds x a (F ++ E).
    Proof.
      induction F as [|(y,b)]; simpl; intros H Ok.
      Case "nil". assumption.
      Case "cons".
        inversion Ok. subst.
        destruct (y == x).
        SCase "x=y".
          subst.
          contradiction binds_nobinds with (a:=a) (2:=H4).
          eauto.
        SCase "x<>y".
          apply binds_other; [ auto | assumption ].
    Qed.

    Fact binds_weaken : forall x a E F G,
      binds x a (G ++ E) ->
      ok (G ++ F ++ E) ->
      binds x a (G ++ F ++ E).
    Proof.
      induction G as [|(y,b)]; simpl; intros H Ok.
      Case "nil". apply binds_concat_ok; assumption.
      Case "cons".
        inversion Ok. subst.
        destruct (y == x).
        SCase "x=y".
          subst.
          rewrite binds_elim_eq with (1:=H).
          apply binds_first.
        SCase "x<>y".
          apply binds_other with (2:=n).
          apply IHG; [ eauto using binds_elim_neq | assumption ].
    Qed.

   (** [forall_env P E] holds when proposition [P x v] holds for all bindings
       [(x, v)] in environment [E]. *)

    Variable P: atom -> A -> Prop.

    Inductive forall_env : list (atom * A) -> Prop :=
    | fa_nil: forall_env nil
    | fa_cons: forall E x v, forall_env E -> P x v -> forall_env ((x,v)::E).

    Hint Constructors forall_env.

    Fact fa_single: forall x a, P x a -> forall_env ((x,a)::nil).
    Proof.
      auto.
    Qed.

    Fact fa_app: forall E F,
        forall_env E -> forall_env F -> forall_env (E++F).
    Proof.
      intros; induction H; simpl; auto.
    Qed.

    Fact fa_weaken: forall E F G,
        forall_env (E++F++G) -> forall_env (E++G).
    Proof.
      intros; induction E as [| (y,a)]; simpl.
      Case "nil".
        induction F as [| (y,a)].
        SCase "nil". trivial.
        SCase "cons". apply IHF. inversion H. subst. assumption.
      Case "cons". inversion H. subst. auto.
    Qed.

    Fact fa_binds_elim: forall x a E,
        binds x a E -> forall_env E -> P x a.
    Proof.
      intros; induction H0.
      Case "fa_nil". contradiction (binds_nil H).
      Case "fa_cons". destruct (x == x0).
        SCase "x = x0". subst. rewrite (binds_elim_eq H). assumption.
        SCase "x <> x0". eauto using binds_elim_neq.
    Qed.

End Environment.

Unset Implicit Arguments.
Hint Constructors ok.
Hint Constructors forall_env.
Implicit Arguments fa_nil [A].

Set Implicit Arguments.

(** [env_zip aenv bs benv] will match up environment [aenv] with the value list
    [bs] to produce the environment [benv]. *)

Inductive env_zip (A: Type) (B: Type) : list (atom * A) -> list B -> list (atom * B) -> Prop :=
| z_nil : env_zip nil nil nil
| z_cons : forall x a b aenv bs benv,
    env_zip aenv bs benv ->
    env_zip ((x,a)::aenv) (b::bs) ((x,b)::benv).

Hint Constructors env_zip.

Unset Implicit Arguments.


From Coq Require Import ssreflect ssrbool.
From Equations Require Import Equations.
From MetaCoq.PCUIC Require Import PCUICAst PCUICAstUtils PCUICContextConversion PCUICContextReduction
  PCUICCumulativity PCUICConversion PCUICEquality PCUICLiftSubst PCUICNormal PCUICReduction PCUICTyping
  PCUICGlobalEnv PCUICConfluence PCUICSubstitution PCUICClosed PCUICClosedTyp
  PCUICWeakeningEnvConv PCUICWeakeningEnvTyp
  PCUICWellScopedCumulativity PCUICOnFreeVars PCUICSR.

From MetaCoq.Template Require Import config.
From MetaCoq.Template Require Import utils.

Local Set Keyed Unification.

Set Default Goal Selector "!".

Implicit Types (cf : checker_flags) (Σ : global_env_ext).

Definition conv_cum {cf:checker_flags} pb Σ Γ u v :=
  ∥ Σ ;;; Γ ⊢ u ≤[pb] v ∥.

Lemma eq_term_eq_termp {cf:checker_flags} leq (Σ : global_env_ext) x y :
  eq_term Σ Σ x y ->
  eq_termp leq Σ x y.
Proof.
  destruct leq; [easy|].
  cbn.
  apply eq_term_upto_univ_leq; cbn; auto.
Qed.

Lemma alt_into_ws_cumul_pb_terms {cf Σ} {wfΣ : wf Σ} {Γ l l'} :
  All2 (convAlgo Σ Γ) l l' ->
  is_closed_context Γ ->
  forallb (is_open_term Γ) l ->
  forallb (is_open_term Γ) l' ->
  ws_cumul_pb_terms Σ Γ l l'.
Proof.
  solve_all. eapply into_ws_cumul_pb; tea.
Qed.

(** Might be better suited with [red_context] hyps ensuring closedness directly *)
Lemma red_ctx_rel_par_conv {cf Σ Γ Γ0 Γ0' Γ1 Γ1'} {wfΣ : wf Σ} :
  is_closed_context (Γ ,,, Γ0) ->
  is_closed_context (Γ ,,, Γ1) ->
  red_ctx_rel Σ Γ Γ0 Γ0' ->
  red_ctx_rel Σ Γ Γ1 Γ1' ->
  eq_context_upto Σ (eq_universe Σ) (eq_universe Σ) Γ0' Γ1' ->
  ws_cumul_ctx_pb_rel Conv Σ Γ Γ0 Γ1.
Proof.
  intros clΓ0 clΓ1 r0 r1 eq.
  apply red_ctx_rel_red_context_rel, red_context_app_same_left in r0; auto.
  2:{ now eapply on_free_vars_ctx_on_ctx_free_vars_closedP_impl. }
  apply red_ctx_rel_red_context_rel, red_context_app_same_left in r1; auto.
  2:{ now eapply on_free_vars_ctx_on_ctx_free_vars_closedP_impl. }
  eapply red_ctx_red_context in r0; eapply red_ctx_red_context in r1.
  eapply into_closed_red_ctx in r0 => //.
  eapply into_closed_red_ctx in r1 => //.
  eapply (red_ctx_ws_cumul_ctx_pb (l:=Conv)) in r0.
  eapply (red_ctx_ws_cumul_ctx_pb (l:=Conv)) in r1.
  apply ws_cumul_ctx_pb_rel_app. etransitivity; tea.
  symmetry. etransitivity; tea.
  eapply (eq_context_upto_cat _ _ _ Γ _ Γ) in eq. 2:reflexivity.
  eapply (eq_context_upto_ws_cumul_ctx_pb (pb:=Conv)) in eq. 2-3:fvs.
  now symmetry.
Qed.

Lemma into_red_terms {Σ Γ ts ts'} :
  All2 (red Σ Γ) ts ts' ->
  is_closed_context Γ ->
  forallb (is_open_term Γ) ts ->
  red_terms Σ Γ ts ts'.
Proof.
  induction 1; [constructor|].
  move=> /= clΓ /andP[clx cll]. constructor; eauto using into_closed_red.
Qed.

Lemma alpha_eq_context_gen Γ Δ :
  eq_context_upto_names Γ Δ ->
  eq_context_gen eq eq Γ Δ.
Proof.
  induction 1; constructor; auto.
Qed.

Lemma untyped_subslet_ass {Γ s Δ} :
  assumption_context Δ ->
  #|s| = context_assumptions Δ ->
  untyped_subslet Γ s Δ.
Proof.
  induction Δ as [|[na [b|] ty] Δ] in s |- *; destruct s; simpl; try discriminate.
  - constructor.
  - intros h; elimtype False; inv h.
  - intros h; elimtype False; inv h.
  - intros h [=]. constructor. apply IHΔ => //.
    now inv h.
Qed.

Lemma shiftnP_up n m : n <= m -> forall i, shiftnP n xpred0 i -> shiftnP m xpred0 i.
Proof.
  intros lt i; rewrite /shiftnP !orb_false_r.
  move/Nat.ltb_lt => H; apply Nat.ltb_lt. lia.
Qed.

Lemma inst_case_ws_cumul_ctx_pb {cf Σ} {wfΣ : wf Σ} {ind mdecl idecl Γ pars pars' puinst puinst' ctx ctx'} :
  declared_inductive Σ ind mdecl idecl ->
  #|pars| = ind_npars mdecl ->
  #|pars'| = ind_npars mdecl ->
  on_free_vars_ctx (closedP #|pars| xpredT) ctx ->
  on_free_vars_ctx (closedP #|pars'| xpredT) ctx' ->
  is_closed_context Γ ->
  ws_cumul_pb_terms Σ Γ pars pars' ->
  R_universe_instance (eq_universe Σ) puinst puinst' ->
  eq_context_gen eq eq ctx ctx' ->
  Σ ⊢ Γ,,, inst_case_context pars puinst ctx = Γ,,, inst_case_context pars' puinst' ctx'.
Proof.
  intros decli wfp wfp' onp onp' clΓ eqpars eqinst eqctx.
  rewrite /inst_case_context.
  eapply ws_cumul_ctx_pb_rel_app.
  have clpars : is_closed_context (Γ,,, smash_context [] (ind_params mdecl)).
  { rewrite on_free_vars_ctx_app clΓ /=.
    apply on_free_vars_ctx_smash => //.
    generalize (declared_inductive_closed_params decli).
    now move/(closed_ctx_on_free_vars (shiftnP #|Γ| xpred0)). }
  have lenpars : #|pars| = context_assumptions (ind_params mdecl).
  { rewrite -(declared_minductive_ind_npars decli).
    now rewrite wfp. }
  have asspars : assumption_context (smash_context [] (ind_params mdecl)).
  { eapply PCUICContexts.smash_context_assumption_context => //. constructor. }
  have lenpars' : #|pars| = context_assumptions (smash_context [] (ind_params mdecl)).
  { rewrite context_assumptions_smash_context /= //. }
  eapply (substitution_ws_cumul_ctx_pb_subst_conv (Γ'':=[])
    (Γ' := smash_context [] mdecl.(ind_params))
    (Γ'0 := smash_context [] mdecl.(ind_params))) => //.
  * eapply (PCUICSpine.ws_cumul_ctx_pb_rel_trans (Δ' := ctx'@[puinst])).
    - eapply ws_cumul_ctx_pb_rel_app.
      eapply eq_context_upto_ws_cumul_ctx_pb.
      { rewrite on_free_vars_ctx_app clpars /=. len.
        rewrite on_free_vars_ctx_subst_instance -lenpars.
        eapply on_free_vars_ctx_impl; tea. apply shiftnP_up. lia. }
      { rewrite on_free_vars_ctx_app clpars /=. len.
        rewrite on_free_vars_ctx_subst_instance -lenpars.
        eapply on_free_vars_ctx_impl; tea. apply shiftnP_up. lia. }
      eapply eq_context_upto_cat; [reflexivity|].
      eapply eq_context_upto_univ_subst_instance'; tc. 1:reflexivity.
      assumption.
    - cbn.
      eapply subst_instance_ws_cumul_ctx_pb_rel => //.
      rewrite !on_free_vars_ctx_app clΓ /=. len.
      apply /andP; split.
      { apply on_free_vars_ctx_smash => //.
        generalize (declared_inductive_closed_params decli).
        now move/(closed_ctx_on_free_vars (shiftnP #|Γ| xpred0)). }
      rewrite -(declared_minductive_ind_npars decli) -wfp'.
      eapply on_free_vars_ctx_impl; tea.
      intros i. rewrite closedP_shiftnP.
      eapply shiftnP_up. lia.
  * now eapply All2_rev.
  * apply (untyped_subslet_ass asspars). now len.
  * apply (untyped_subslet_ass asspars). now len.
Qed.

#[global] Hint Resolve sq : core.

Lemma conv_cum_alt {cf:checker_flags} {leq} {Σ : global_env_ext} {Γ t t'} (wfΣ : ∥ wf Σ ∥) :
  conv_cum leq Σ Γ t t' <->
  ∥∑ v v', [× Σ ;;; Γ ⊢ t ⇝ v, Σ ;;; Γ ⊢ t' ⇝ v' & eq_termp leq Σ v v']∥.
Proof.
  destruct wfΣ.
  assert (forall P Q, (P <~> Q) -> (∥P∥ <-> ∥Q∥)) by
      (intros P Q H; split; intros [p]; constructor; apply H in p; auto).
  destruct leq; cbn; apply H.
  * eapply (ws_cumul_pb_alt_closed (pb:=Conv)).
  * eapply (ws_cumul_pb_alt_closed (pb:=Cumul)).
Qed.

Lemma conv_conv_cum_l {cf:checker_flags} :
  forall (Σ : global_env_ext) leq Γ u v,
      Σ ;;; Γ ⊢ u = v ->
      conv_cum leq Σ Γ u v.
Proof.
  intros Σ [] Γ u v h.
  - cbn. constructor. assumption.
  - cbn. constructor. now apply ws_cumul_pb_eq_le.
Qed.

Lemma conv_conv_cum_r {cf:checker_flags} :
  forall (Σ : global_env_ext) leq Γ u v,
      Σ ;;; Γ ⊢ u = v ->
      conv_cum leq Σ Γ v u.
Proof.
  intros Σ [] Γ u v h.
  - cbn. constructor. now symmetry.
  - cbn. constructor. apply ws_cumul_pb_eq_le.
    now symmetry.
Qed.

Definition closed_red_red {Σ Γ T U} : Σ ;;; Γ ⊢ T ⇝ U -> red Σ Γ T U := clrel_rel.
Coercion closed_red_red : closed_red >-> red.

Section fixed.
  Context {cf : checker_flags}.
  Context (Σ : global_env_ext).
  Context (wfΣ : ∥ wf Σ ∥).

  Definition isIndConstructApp (t : term) : bool :=
    match (decompose_app t).1 with
    | tInd _ _
    | tConstruct _ _ _ => true
    | _ => false
    end.

  Lemma isIndConstructApp_mkApps hd args :
    isIndConstructApp (mkApps hd args) = isIndConstructApp hd.
  Proof using Type.
    unfold isIndConstructApp.
    destruct (mkApps_elim hd args).
    rewrite !decompose_app_mkApps; by easy.
  Qed.

  Lemma eq_term_upto_univ_napp_nonind Re Rle napp t t' :
    eq_term_upto_univ_napp Σ Re Rle napp t t' ->
    isIndConstructApp t = false ->
    eq_term_upto_univ Σ Re Rle t t'.
  Proof using Type.
    intros eq not_ind.
    generalize 0.
    intros k.
    induction eq in k, not_ind |- *; eauto using eq_term_upto_univ_napp.
    - rewrite (isIndConstructApp_mkApps _ [u]) in not_ind.
      constructor; auto.
    - discriminate not_ind.
    - discriminate not_ind.
  Qed.

  Lemma whnf_red_isIndConstructApp Γ t t' :
    whnf_red Σ Γ t t' ->
    isIndConstructApp t' = isIndConstructApp t.
  Proof using Type.
    intros r.
    induction r; auto.
    rewrite (isIndConstructApp_mkApps _ [arg']) (isIndConstructApp_mkApps _ [arg]).
    apply IHr.
  Qed.

  Lemma eq_termp_mkApps_inv leq v args v' args' :
    isApp v = false ->
    isApp v' = false ->
    eq_termp leq Σ (mkApps v args) (mkApps v' args') ->
    eq_termp_napp leq Σ #|args| v v' × All2 (fun x y => eq_term Σ Σ x y) args args'.
  Proof using Type.
    intros noapp1 noapp2 eq.
    apply eq_term_upto_univ_mkApps_inv in eq as (?&?) => //.
  Qed.

  Definition conv_cum_napp leq Γ napp t t' :=
    match t with
    | tInd _ _
    | tConstruct _ _ _ => ∥eq_termp_napp leq Σ napp t t'∥
    | _ => conv_cum leq Σ Γ t t'
    end.

  Lemma conv_cum_mkApps_inv leq Γ hd args hd' args' :
    conv_cum leq Σ Γ (mkApps hd args) (mkApps hd' args') ->
    isApp hd = false ->
    isApp hd' = false ->
    whnf RedFlags.default Σ Γ (mkApps hd args) ->
    whnf RedFlags.default Σ Γ (mkApps hd' args') ->
    ∥conv_cum_napp leq Γ #|args| hd hd' × ws_cumul_pb_terms Σ Γ args args'∥.
  Proof using wfΣ.
    intros conv notapp notapp' wh wh'.
    eapply conv_cum_alt in conv as [(?&?&[r1 r2 e])]; auto.
    sq.
    pose proof (whnf_red_inv _ _ _ _ wh r1) as w1.
    apply whnf_red_mkApps_l_inv in w1 as (?&?&->&?&?); auto.
    pose proof (whnf_red_inv _ _ _ _ wh' r2) as w2.
    apply whnf_red_mkApps_l_inv in w2 as (?&?&->&?&?); auto.
    apply whnf_red_isApp in w as ?.
    apply whnf_red_isApp in w0 as ?.
    apply eq_termp_mkApps_inv in e as (?&?); try congruence.
    have clΓ : is_closed_context Γ by fvs.
    have [clhd clargs] : is_open_term Γ hd /\ forallb (is_open_term Γ) args.
    { move/clrel_src: r1. now rewrite on_free_vars_mkApps => /andP. }
    have [clhd' clargs'] : is_open_term Γ hd' /\ forallb (is_open_term Γ) args'.
    { move/clrel_src: r2. now rewrite on_free_vars_mkApps => /andP. }
    split.
    - apply whnf_red_isIndConstructApp in w as ?.
      destruct hd.
      all: cbn.
      1-9, 12-15: apply conv_cum_alt; eauto.
      1-13: constructor.
      1-13: exists x1, x.
      1-13: split; eauto with pcuic.
      1-13: (eapply eq_term_upto_univ_napp_nonind; [exact e|try exact H1]).
      1-13: cbn in *; congruence.
      all: depelim w; subst.
      all: depelim e.
      all: depelim w0; subst.
      all: apply All2_length in a.
      all: try (constructor; constructor; rewrite a; auto).
      all: destruct leq; cbn; repeat constructor => //.
    - eapply alt_into_ws_cumul_pb_terms => //.
      clear -a1 a a0.
      induction a1 in args, args', x2, a, x3, a0, a1 |- *; depelim a; depelim a0; [now constructor|].
      constructor.
      + apply conv_alt_red.
        now exists x, y.
      + now apply IHa1.
  Qed.

  Lemma conv_cum_tCase_inv leq Γ ci p discr brs ci' p' discr' brs' mdecl idecl mdecl' idecl' :
    conv_cum leq Σ Γ (tCase ci p discr brs) (tCase ci' p' discr' brs') ->
    declared_inductive Σ ci mdecl idecl ->
    declared_inductive Σ ci' mdecl' idecl' ->
    wf_predicate mdecl idecl p ->
    wf_predicate mdecl' idecl' p' ->
    whnf RedFlags.default Σ Γ (tCase ci p discr brs) ->
    whnf RedFlags.default Σ Γ (tCase ci' p' discr' brs') ->
    ∥ [× ci = ci',
      ws_cumul_pb_predicate Σ Γ p p',
      Σ;;; Γ ⊢ discr = discr' &
      ws_cumul_pb_brs Σ Γ p brs brs']∥.
  Proof using wfΣ.
    intros conv decli decli' wfp wfp' whl whr.
    depelim whl; solve_discr.
    depelim w; solve_discr; try discriminate.
    depelim whr; solve_discr.
    depelim w0; solve_discr; try discriminate.
    apply conv_cum_alt in conv as [(?&?&[r1 r2 eq])]; auto.
    have clΓ : is_closed_context Γ by fvs.
    set(l := tCase ci _ _ _) in *.
    set(r := tCase ci' _ _ _) in *.
    have cll : is_open_term Γ l.
    { now move/clrel_src: r1. }
    have clr : is_open_term Γ r.
    { now move/clrel_src: r2. }
    sq.
    subst l r; eapply whnf_red_inv in r1; eauto.
    eapply whnf_red_inv in r2; eauto.
    depelim r1.
    depelim r2.
    depelim eq.
    set (pl := {| pparams := motivepars |}) in *.
    set (pr := {| pparams := motivepars0 |}) in *.
    specialize e as (?&?&?&?).
    destruct (declared_inductive_inj decli decli') as [-> ->].
    repeat inv_on_free_vars.
    have clred : red_terms Σ Γ (pparams p) motivepars.
    { eapply into_red_terms; tea. }
    have clred' : red_terms Σ Γ (pparams p') motivepars0.
    { eapply into_red_terms; tea. }
    have eqpars : ws_cumul_pb_terms Σ Γ (pparams p) (pparams p').
    { etransitivity => //.
      { eapply red_terms_ws_cumul_pb_terms; tea. }
      transitivity motivepars0.
      { eapply eq_terms_ws_cumul_pb_terms; fvs.
        * eapply closed_red_terms_open_right in clred; solve_all.
        * eapply closed_red_terms_open_right in clred'; solve_all. }
      symmetry. eapply red_terms_ws_cumul_pb_terms. eapply into_red_terms; tea. }
    have eq_instctx : Σ ⊢ Γ,,, inst_case_predicate_context p = Γ,,, inst_case_predicate_context p'.
    { eapply (inst_case_ws_cumul_ctx_pb decli); tea.
      { apply (wf_predicate_length_pars wfp). }
      { apply (wf_predicate_length_pars wfp'). } }
    repeat split; eauto.
    - transitivity motiveret0.
      { eapply ws_cumul_pb_alt_closed. exists motiveret, motiveret0.
        split; auto.
        * split; auto.
          + rewrite on_free_vars_ctx_app. apply /andP. split; auto.
            eapply on_free_vars_ctx_inst_case_context; tea => //.
            rewrite test_context_k_closed_on_free_vars_ctx //.
          + len. now setoid_rewrite shiftnP_add in p6.
        * eapply closed_red_refl.
          + rewrite on_free_vars_ctx_app. apply /andP. split; auto.
            eapply on_free_vars_ctx_inst_case_context; tea => //.
            now rewrite test_context_k_closed_on_free_vars_ctx.
          + eapply red_on_free_vars in r1; tea.
            { len. rewrite (All2_fold_length a5).
              now setoid_rewrite shiftnP_add in p1. }
            len. rewrite -shiftnP_add (All2_fold_length a5).
            eapply on_ctx_free_vars_inst_case_context; auto.
            1:now rewrite test_context_k_closed_on_free_vars_ctx.
            now erewrite -> on_free_vars_ctx_on_ctx_free_vars. }
      eapply (ws_cumul_pb_ws_cumul_ctx (Γ := Γ ,,, inst_case_predicate_context p') (pb':=Conv)) => //.
      symmetry. eapply red_ws_cumul_pb.
      eapply into_closed_red; eauto. 1:fvs.
      len. now setoid_rewrite shiftnP_add in p1.
    - apply ws_cumul_pb_alt_closed; eauto.
      exists discr'0, discr'1. split; eauto.
      all:eapply into_closed_red; eauto.
    - rename a0 into brsa1.
      rename a2 into brsa2.
      rename a3 into brseq.
      clear -wfΣ decli brsa1 brsa2 brseq clΓ wfp wfp' a a1 p0 p5 p4 p9 r3 eqpars.
      induction brseq in brs, brs', brsa1, brsa2, p4, p9 |- *;
        depelim brsa1; depelim brsa2; [constructor|].
      destruct p0, p1, r.
      cbn in p4, p9. move/andP: p4 => [fv p4].
      move/andP: p9 => [fv' p9].
      constructor.
      2: { apply IHbrseq; auto. }
      have eqctx : Σ ⊢ Γ ,,, inst_case_branch_context p x0 = Γ ,,, inst_case_branch_context p' x1.
      { rewrite /inst_case_branch_context.
        eapply (inst_case_ws_cumul_ctx_pb decli); tea.
        { apply (wf_predicate_length_pars wfp). }
        { apply (wf_predicate_length_pars wfp'). }
        { rewrite -test_context_k_closed_on_free_vars_ctx //.
          now move/andP: fv'. }
        { rewrite -test_context_k_closed_on_free_vars_ctx; now move/andP: fv. }
        now rewrite e e0. }
      rewrite e e0; split => //.
      transitivity (bbody x); tea.
      { eapply red_ws_cumul_pb. rewrite /inst_case_branch_context. split; auto.
        1:now eapply ws_cumul_ctx_pb_closed_left in eqctx.
        move/andP: fv' => []. now len; rewrite shiftnP_add. }
      transitivity (bbody y); tea.
      { constructor; auto. 1:now eapply ws_cumul_ctx_pb_closed_left.
        { eapply closed_red_open_right. eapply into_closed_red; tea.
          { now eapply ws_cumul_ctx_pb_closed_left. }
          move/andP: fv' => []. len. now setoid_rewrite shiftnP_add. }
        move/andP: fv => [] fv fvx1. len.
        eapply red_on_free_vars in fvx1; tea.
        { rewrite e (All2_fold_length a0) -e0. now setoid_rewrite shiftnP_add in fvx1. }
        rewrite shiftnP_add. relativize (#|bcontext x1| + _).
        1:rewrite -> on_free_vars_ctx_on_ctx_free_vars. 2:now len.
        now eapply ws_cumul_ctx_pb_closed_right in eqctx. }
      symmetry.
      eapply ws_cumul_pb_ws_cumul_ctx; tea.
      eapply red_ws_cumul_pb. rewrite /inst_case_branch_context. split; auto.
      1:now eapply ws_cumul_ctx_pb_closed_right in eqctx.
      move/andP: fv => []. len. now rewrite shiftnP_add.
  Qed.

  Lemma conv_cum_tFix_inv leq Γ mfix idx mfix' idx' :
    conv_cum leq Σ Γ (tFix mfix idx) (tFix mfix' idx') ->
    ∥idx = idx' ×
     All2 (fun d d' =>
      [× rarg d = rarg d',
         eq_binder_annot d.(dname) d'.(dname),
         Σ;;; Γ ⊢ dtype d = dtype d' &
         Σ;;; Γ,,, fix_context mfix ⊢ dbody d = dbody d'])
          mfix mfix'∥.
  Proof using wfΣ.
    intros conv.
    apply conv_cum_alt in conv as [(?&?&[r1 r2 eq])]; auto.
    sq.
    assert (forall defs i, whnf RedFlags.default Σ Γ (tFix defs i)).
    { intros defs i.
      apply whnf_fixapp with (v := []).
      destruct unfold_fix as [(?&?)|]; [|easy].
      now rewrite nth_error_nil. }
    have clΓ := clrel_ctx r1.
    have cll := clrel_src r1.
    have clr := clrel_src r2.
    assert (clx := closed_red_open_right r1).
    assert (cly := closed_red_open_right r2).
    eapply whnf_red_inv in r1; eauto.
    eapply whnf_red_inv in r2; eauto.
    depelim r1.
    depelim r2.
    depelim eq.
    split; [easy|].
    cbn in cll, clr, clx, cly.
    have clmfixctx : is_closed_context (Γ ,,, fix_context mfix).
    { rewrite on_free_vars_ctx_app clΓ /=. apply on_free_vars_fix_context; solve_all. }
    have clmfixctx' : is_closed_context (Γ ,,, fix_context mfix').
    { rewrite on_free_vars_ctx_app clΓ /=. apply on_free_vars_fix_context; solve_all. }
    solve_all.
    move: clmfixctx clmfixctx'.
    clear -wfΣ a a0 a1 clΓ.
    cut (#|mfix| = #|mfix'|);
      [|now apply All2_length in a; apply All2_length in a0; apply All2_length in a1].
    revert a a0 a1.
    generalize mfix at 1 2 4 5 6.
    generalize mfix' at 1 2 4 5.
    intros ctx_fix ctx_fix'.
    intros all1 all2 all len_eq.
    induction all in mfix, mfix', all1, all2, all |- *;
      depelim all1; depelim all2; subst; [constructor|].
    constructor; [|now auto].
    destruct r as ((?&(((? & ?) & ?)&?))&?), p as (?&?&?&?&?), p0 as (?&?&?&?&?).
    split; auto; try congruence.
    - eapply ws_cumul_pb_alt_closed; exists (dtype x), (dtype y). split; eauto.
      all:eapply into_closed_red; eauto.
      { now move/andP: i1. }
      { now move/andP: i2. }
    - eapply ws_cumul_pb_alt_closed.
      exists (dbody x), (dbody y).
      split; [| |easy].
      all:eapply into_closed_red; auto.
      * move/andP: i1 => []. now len; rewrite shiftnP_add.
      * eapply PCUICRedTypeIrrelevance.context_pres_let_bodies_red; eauto.
        eapply PCUICRedTypeIrrelevance.fix_context_pres_let_bodies; eauto.
      * move/andP: i2 => []. len. now rewrite len_eq shiftnP_add.
  Qed.

  Lemma conv_cum_tCoFix_inv leq Γ mfix idx mfix' idx' :
    conv_cum leq Σ Γ (tCoFix mfix idx) (tCoFix mfix' idx') ->
    ∥idx = idx' ×
    All2 (fun d d' =>
      [× rarg d = rarg d',
        eq_binder_annot d.(dname) d'.(dname),
        Σ;;; Γ ⊢ dtype d = dtype d' &
        Σ;;; Γ,,, fix_context mfix ⊢ dbody d = dbody d'])
          mfix mfix'∥.
  Proof using wfΣ.
    intros conv.
    apply conv_cum_alt in conv as [(?&?&[r1 r2 eq])]; auto. sq.
    assert (forall defs i, whnf RedFlags.default Σ Γ (tCoFix defs i)).
    { intros defs i.
      apply whnf_cofixapp with (v := []). }
    have clΓ := clrel_ctx r1.
    have cll := clrel_src r1.
    have clr := clrel_src r2.
    assert (clx := closed_red_open_right r1).
    assert (cly := closed_red_open_right r2).
    eapply whnf_red_inv in r1; eauto.
    eapply whnf_red_inv in r2; eauto.
    depelim r1.
    depelim r2.
    depelim eq.
    split; [easy|].
    cbn in cll, clr, clx, cly.
    have clmfixctx : is_closed_context (Γ ,,, fix_context mfix).
    { rewrite on_free_vars_ctx_app clΓ /=. apply on_free_vars_fix_context; solve_all. }
    have clmfixctx' : is_closed_context (Γ ,,, fix_context mfix').
    { rewrite on_free_vars_ctx_app clΓ /=. apply on_free_vars_fix_context; solve_all. }
    solve_all.
    move: clmfixctx clmfixctx'.
    clear -wfΣ a a0 a1 clΓ.
    cut (#|mfix| = #|mfix'|);
      [|now apply All2_length in a; apply All2_length in a0; apply All2_length in a1].
    revert a a0 a1.
    generalize mfix at 1 2 4 5 6.
    generalize mfix' at 1 2 4 5.
    intros ctx_fix ctx_fix'.
    intros all1 all2 all len_eq.
    induction all in mfix, mfix', all1, all2, all |- *;
      depelim all1; depelim all2; subst; [constructor|].
    constructor; [|now auto].
    destruct r as ((?&(((? & ?) & ?)&?))&?), p as (?&?&?&?&?), p0 as (?&?&?&?&?).
    split; auto; try congruence.
    - eapply ws_cumul_pb_alt_closed; exists (dtype x), (dtype y). split; eauto.
      all:eapply into_closed_red; eauto.
      { now move/andP: i1. }
      { now move/andP: i2. }
    - eapply ws_cumul_pb_alt_closed.
      exists (dbody x), (dbody y).
      split; [| |easy].
      all:eapply into_closed_red; auto.
      * move/andP: i1 => []. now len; rewrite shiftnP_add.
      * eapply PCUICRedTypeIrrelevance.context_pres_let_bodies_red; eauto.
        eapply PCUICRedTypeIrrelevance.fix_context_pres_let_bodies; eauto.
      * move/andP: i2 => []. len. now rewrite len_eq shiftnP_add.
  Qed.

  Lemma conv_cum_tProj_inv leq Γ p c p' c' :
    conv_cum leq Σ Γ (tProj p c) (tProj p' c') ->
    whnf RedFlags.default Σ Γ (tProj p c) ->
    whnf RedFlags.default Σ Γ (tProj p' c') ->
    ∥ p = p' × Σ;;; Γ ⊢ c = c' ∥.
  Proof using wfΣ.
    intros conv whl whr.
    apply conv_cum_alt in conv as [(?&?&[r1 r2 ?])]; auto. sq.
    have clΓ := clrel_ctx r1.
    have cll := clrel_src r1.
    have clr := clrel_src r2.
    eapply whnf_red_inv in r1; eauto.
    eapply whnf_red_inv in r2; eauto.
    depelim r1.
    depelim r2.
    depelim c0.
    split; [easy|].
    apply ws_cumul_pb_alt_closed; eauto.
    exists c'0, c'1; split; eauto.
    all:eapply into_closed_red; eauto.
  Qed.

End fixed.


Require Import Crypto.Compilers.Syntax.

Section language.
  Context {base_type_code}
          {var : base_type_code -> Type}.

  Section cps.
    Context {rT : Type}
            (Forall : forall T (R : var T -> rT), rT).

    Fixpoint intros_interp_flat_type_cps
             {t : flat_type base_type_code}
      : forall (R : interp_flat_type var t -> rT),
        rT
      := match t return (interp_flat_type var t -> rT) -> rT with
         | Tbase T => fun R => Forall _ (fun v : var T => R v)
         | Unit => fun R => R tt
         | Prod A B
           => fun R : interp_flat_type _ A * interp_flat_type _ B -> _
              => @intros_interp_flat_type_cps
                   A
                   (fun a
                    => @intros_interp_flat_type_cps
                         B
                         (fun b
                          => R (a, b)))
         end.
  End cps.
  Definition intros_interp_flat_type_Prop {t}
    := @intros_interp_flat_type_cps Prop (fun T R => forall v : var T, R v) t.
  Definition intros_interp_flat_type_Type {t}
    := @intros_interp_flat_type_cps Type (fun T R => forall v : var T, R v) t.

  Fixpoint intros_interp_flat_type
           {t : flat_type base_type_code}
    : forall {R : interp_flat_type var t -> Type},
      @intros_interp_flat_type_Type t R
      -> (forall v : interp_flat_type var t, R v)
    := match t return forall R : interp_flat_type var t -> Type,
           @intros_interp_flat_type_Type t R -> (forall v : interp_flat_type _ t, R v)
       with
       | Tbase T => fun R f => f
       | Unit => fun R p 'tt => p
       | Prod A B
         => fun (R : interp_flat_type _ A * interp_flat_type _ B -> _)
                (f : intros_interp_flat_type_Type
                       (fun a => intros_interp_flat_type_Type (fun b => R (a, b))))
                '((a, b) : interp_flat_type _ A * interp_flat_type _ B)
            => @intros_interp_flat_type
                 B _ (@intros_interp_flat_type A _ f a) b
       end.

  Fixpoint introsP_interp_flat_type
           {t : flat_type base_type_code}
    : forall {R : interp_flat_type var t -> Prop},
      @intros_interp_flat_type_Prop t R
      -> (forall v : interp_flat_type var t, R v)
    := match t return forall R : interp_flat_type var t -> Prop,
           @intros_interp_flat_type_Prop t R -> (forall v : interp_flat_type _ t, R v)
       with
       | Tbase T => fun R f => f
       | Unit => fun R p 'tt => p
       | Prod A B
         => fun (R : interp_flat_type _ A * interp_flat_type _ B -> _)
                (f : intros_interp_flat_type_Prop
                       (fun a => intros_interp_flat_type_Prop (fun b => R (a, b))))
                '((a, b) : interp_flat_type _ A * interp_flat_type _ B)
            => @introsP_interp_flat_type
                 B _ (@introsP_interp_flat_type A _ f a) b
       end.
End language.

Ltac post_intro_interp_flat_type_intros :=
  let do_cbv _ :=
      (cbv [intros_interp_flat_type_Type intros_interp_flat_type_Prop intros_interp_flat_type_cps]) in
  lazymatch goal with
  | [ |- @intros_interp_flat_type_Type _ ?var ?t ?R ]
    => let t' := (eval cbv in t) in
       change (@intros_interp_flat_type_Type _ var t' (fun v => id (R v)));
       do_cbv (); post_intro_interp_flat_type_intros
  | [ |- @intros_interp_flat_type_Prop _ ?var ?t ?R ]
    => let t' := (eval cbv in t) in
       change (@intros_interp_flat_type_Prop _ var t' (fun v => id (R v)));
       do_cbv (); post_intro_interp_flat_type_intros
  | [ |- forall x, _ ] => intro; post_intro_interp_flat_type_intros
  | [ |- id ?P ] => change P
  end.
Ltac intro_interp_flat_type :=
  lazymatch goal with
  | [ |- forall v : interp_flat_type ?var ?t, @?R v ]
    => let t' := (eval compute in t) in
       refine (@intros_interp_flat_type _ var t' (fun v => id (R v)) _);
       post_intro_interp_flat_type_intros
  end.


Require Import AutoDB.

(* Our bookstore has two relations (tables):
   - The [Books] relation contains the books in the
     inventory, represented as a tuple with
     [Author], [Title], and [ISBN] attributes.
     The [ISBN] attribute is a key for the relation,
     specified by the [where attributes .. depend on ..]
     constraint.
   - The [Orders] relation contains the orders that
     have been placed, represented as a tuple with the
     [ISBN] and [Date] attributes.

   The schema for the entire query structure specifies that
   the [ISBN] attribute of [Orders] is a foreign key into
   [Books], specified by the [attribute .. of .. references ..]
   constraint.
 *)

(* Let's define some synonyms for strings we'll need,
 * to save on type-checking time. *)
Definition sBOOKS := "Books".
Definition sAUTHOR := "Authors".
Definition sTITLE := "Title".
Definition sISBN := "ISBN".
Definition sORDERS := "Orders".
Definition sDATE := "Date".

(* Now here's the actual schema, in the usual sense. *)

Definition BookStoreSchema :=
  Query Structure Schema
    [ relation sBOOKS has
              schema <sAUTHOR :: string,
                      sTITLE :: string,
                      sISBN :: nat>
                      where attributes [sTITLE; sAUTHOR] depend on [sISBN];
      relation sORDERS has
              schema <sISBN :: nat,
                      sDATE :: nat> ]
    enforcing [attribute sISBN for sORDERS references sBOOKS].

(* Aliases for the tuples contained in Books and Orders, respectively. *)
Definition Book := TupleDef BookStoreSchema sBOOKS.
Definition Order := TupleDef BookStoreSchema sORDERS.

(* Our bookstore has two mutators:
   - [PlaceOrder] : Place an order into the 'Orders' table
   - [AddBook] : Add a book to the inventory table

   Our bookstore has two observers:
   - [GetTitles] : The titles of the books written by an author
   - [NumOrders] : The number of orders for an author
 *)

(* So, first let's give the type signatures of the methods. *)
Definition BookStoreSig : ADTSig :=
  ADTsignature {
      "Init" : unit → rep,
      "PlaceOrder" : rep × Order → rep × bool,
      "DeleteOrder" : rep × nat → rep × list Order,
      "AddBook" : rep × Book → rep × bool,
      "DeleteBook" : rep × nat → rep × list Book,
      "GetTitles" : rep × string → rep × list string,
      "NumOrders" : rep × string → rep × nat
    }.

(* Now we write what the methods should actually do. *)

Definition BookStoreSpec : ADT BookStoreSig :=
  QueryADTRep BookStoreSchema {
    const "Init" (_ : unit) : rep := empty,

    update "PlaceOrder" ( o : Order ) : bool :=
        Insert o into sORDERS,

    update "DeleteOrder" ( oid : nat ) : list Order :=
        Delete o from sORDERS where o!sISBN = oid ,

    update "AddBook" ( b : Book ) : bool :=
        Insert b into sBOOKS ,

    update "DeleteBook" ( id : nat ) : list Book :=
        Delete book from sBOOKS where book!sISBN = id ,

    query "GetTitles" ( author : string ) : list string :=
      For (b in sBOOKS)
      Where (author = b!sAUTHOR)
      Return (b!sTITLE),

     query "NumOrders" ( author : string ) : nat :=
        Count (For (o in sORDERS) (b in sBOOKS)
               Where (author = b!sAUTHOR)
               Where (b!sISBN = o!sISBN)
               Return ())
}.

(* Aliases for internal names of the two tables *)
Definition Books := GetRelationKey BookStoreSchema sBOOKS.
Definition Orders := GetRelationKey BookStoreSchema sORDERS.

(* Aliases for internal notions of schemas for the two tables *)
Definition BookSchema := QSGetNRelSchemaHeading BookStoreSchema Books.
Definition OrderSchema := QSGetNRelSchemaHeading BookStoreSchema Orders.

(* Now we define an index structure for each table. *)

Definition BookStorage : BagPlusProof (@Tuple BookSchema).
  mkIndex BookSchema [ BookSchema/sAUTHOR; BookSchema/sISBN ].
Defined.
(* In other words, index first on the author field, then the ISBN field.
 * Works especially efficiently for accesses keyed on author. *)

Definition OrderStorage : BagPlusProof (@Tuple OrderSchema).
  mkIndex OrderSchema [ OrderSchema/sISBN ].
Defined.

(* For convenience, we define aliases for the types of the
   index structures contained in our storage types. *)
Definition TBookStorage := BagTypePlus BookStorage.
Definition TOrderStorage := BagTypePlus OrderStorage.

(* This abstraction relation connects:
 * 1. Abstract database from reference implementation, using sets
 * 2. Our fancy realization, using search trees (from Bags library) *)

Definition BookStore_AbsR
           (or : UnConstrQueryStructure BookStoreSchema)
           (nr : TBookStorage * TOrderStorage) : Prop :=
  or!sBOOKS ≃ fst nr /\ or!sORDERS ≃ snd nr.

Theorem BookStoreManual :
  Sharpened BookStoreSpec.
Proof.

  unfold BookStoreSpec.

  (* First, we unfold various definitions and drop constraints *)
  start honing QueryStructure.

  (* Then we introduce the BookStore_AbsR abstraction relation *)
  hone representation using BookStore_AbsR.

  (* We start the actual refinement with the constructor, in a fully
  automated way *)
  hone constructor "Init". {
    initializer.
  }

  hone method "DeleteOrder". {
    startMethod BookStore_AbsR.

    deleteChecksSucceeded.

    finish honing.
  }

  hone method "DeleteBook". {
    startMethod BookStore_AbsR.

    setoid_rewrite refine_if_bool_eta.
    simplify with monad laws.

    match goal with
        [ |- context [{b |
            ((forall tup tup',
                GetUnConstrRelation ?or ?Ridx tup
                -> GetUnConstrRelation ?or ?Ridx tup' ->
                FunctionalDependency_P ?attr1 ?attr2 _ _)
             -> decides b (DeletePreservesSchemaConstraints
                     (GetUnConstrRelation ?or ?Ridx) ?DeletedTuples
                     ?P)) }]] =>
        rewrite (@DeletePrimaryKeysOK _ or Ridx DeletedTuples
                   attr1 attr2); simplify with monad laws
    end.
    match goal with
        [ |- context [
                 {b'|
                           ?P ->
                           decides b'
                             (DeletePreservesCrossConstraints
                                (GetUnConstrRelation ?qs ?Ridx)
                                (GetUnConstrRelation ?qs ?Ridx')
                                ?DeletedTuples
                                (ForeignKey_P ?attr1 ?attr2 ?tupmap))} ]
        ] => rewrite (@DeleteForeignKeysCheck _ qs Ridx Ridx'
                                                 DeletedTuples)
    end;
      [simplify with monad laws;
        concretize;
        asPerm (OrderStorage, BookStorage);
        commit
      | auto with typeclass_instances
      | unfold tupleAgree; clear; simpl; intros; rewrite <- H; eauto
      | auto with typeclass_instances
      | unfold Iterate_Ensemble_BoundedIndex_filter; simpl; intuition
      | simpl; auto
      ].
    Split Constraint Checks;
      [ deleteChecksSucceeded; reflexivity
      | deleteChecksFailed].
  }

  (* We then move on to the "GetTitles" method, which we decide to
     implement semi-manually *)

  hone method "GetTitles". {
    (* STEP 1: unfold the definition of the abstraction relation. *)
    startMethod BookStore_AbsR.

    (* STEP 2: use rewrites to phrase the query in terms of some
     * concrete list computation. *)
    (* First, instead of looping over the mathematical relation,
     * let's loop over an enumeration of the elements in the
     * concrete data structure. *)

    rewrite refine_List_Query_In by EquivalentBagIsEquivalentIndexedList.

    (* Next, we can implement the [Where] test as a list [filter]. *)
    rewrite refine_List_Query_In_Where; instantiate (1 := _).

    (* Now the expression is close enough to a list computation, so
     * we can replace the whole [for] with selection of some list that
     * is a permutation of the one we're building. *)
    rewrite refine_List_For_Query_In_Return_Permutation.

    (* A tactic from our library will do this sort of rewriting for us. *)
    Undo 3.
    concretize.

    (* STEP 3: more rewrites to find opportunities to use the index
     * structures efficiently *)
    (* We are filtering the results of enumerating all entries in a data structure.
     * There's a method available that combines the two operations. *)

    rewrite filter over BookStorage
            using search term (Some n, (@None nat, @nil (TSearchTermMatcher BookSchema))).

    (* Again, a generic tactic can handle this phase. *)
    Undo 1.
    asPerm BookStorage.

    (* STEP 4: Now we have settled on the final list expression.
     * Let's commit to using it instead of one of its other permutations. *)
    setoid_rewrite refine_Permutation_Reflexivity.
    simplify with monad laws.

    (* As usual, we have automation for this phase. *)
    Undo 2.
    commit.

    (* STEP 5: Pick the current database as the new one. *)
    rewrite refine_pick_val by eauto.
    simplify with monad laws.

    (* Automated version: *)
    Undo 2.
    choose_db BookStore_AbsR.

    (* And we're done! *)
    finish honing.
  }

  (* We then move on to implementing one of the mutators.
     Again, we adopt a slightly more manual style to demonstrate the
     main steps of the implementation. *)
  hone method "PlaceOrder". {

    (* First, we unfold the definition of our abstraction relation *)
    startMethod BookStore_AbsR.

    (* Then, we remove trivial or redundant checks *)
    pruneDuplicates.

    (* Since the specification represents datasets as mathematical
       sets, every inserted item is paired with a unique ID, which we
       need to pick. Further refinements will drop this index, which
       thus doesn't have any computational cost. *)

    pickIndex.

    (* To ease its implementation, we convert this foregin key check
       into a query *)
    foreignToQuery.

    (* This query, operating on sets, is then transformed into a
       filter on lists, making use of the equivalence relations
       specified by Bookstore_AbsR *)
    concretize.

    (* At this point, we need to pick a list of results whose elements
       are a permutation of the one derived from the query. Using
       permutation-preserving transformations, we substitute slow
       operations for more efficient ones *)
    asPerm (BookStorage, OrderStorage).

    (* This representation is reasonably satisfactory; we pick the
       resulting list, and proceed to a few extra optimizations *)
    commit.

    (* Now that we have a decision procedure for the constraint checks,
       all that remains is to proceed to the actual insertions. We
       distinguish the case where checks succeeded, and the case where
       checks failed. *)
    Split Constraint Checks.

    (* First, the case where checks succeed: the insertion is valid: *)
    checksSucceeded.

    (* Second, the case where checks failed: in that case, the DB
       remains untouched: *)
    checksFailed.
  }

  (* The remaining methods are similar, so we'll just throw the
   * automation at them. *)

  hone method "AddBook". {

    startMethod BookStore_AbsR.

    (* The, we remove trivial or redundant checks *)
    pruneDuplicates.

    (* Since the specification represents datasets as mathematical
       sets, every inserted item is paired with a unique ID, which we
       need to pick. Further refinements will drop this index, which
       thus doesn't have any computational cost. *)
    pickIndex.

    (* To ease its implementation, we convert this functional dependency
       check into a query *)
    fundepToQuery.

    (* This query, operating on sets, is then transformed into a
       filter on lists, making use of the equivalence relations
       specified by Bookstore_AbsR *)
    concretize.

    (* At this point, we need to pick a list of results whose elements
       are a permutation of the one derived from the query. Using
       permutation-preserving transformations, we substitute slow
       operations for more efficient ones *)
    asPerm (BookStorage, OrderStorage).

    (* This representation is reasonnably satisfactory; we pick the
       resulting list, and proceed to a few extra optimizations *)
    commit.

    (* Now that we have a decision procedure for the constraint checks,
       all that remains is to proceed to the actual insertions. We
       distinguish the case where checks succeeded, and the case where
       checks failed. *)
    Split Constraint Checks.

    (* First, the case where checks succeed: the insertion is valid: *)

    checksSucceeded.

    (* Second, the case where checks failed: in that case, the DB
       remains untouched: *)
    checksFailed.
  }

  hone method "NumOrders". {
    observer.
  }

  unfold cast, eq_rect_r, eq_rect, eq_sym; simpl.

  (* At this point our implementation is fully computational: we're done! *)

  Show.

  finish sharpening.

Defined.


Require Import Why3.

Inductive Why3Unhabited : Prop := .
Axiom letUsTrustWhy3 : Why3Unhabited.

Ltac ae := why3 "alt-ergo" timelimit 5 ; case letUsTrustWhy3.
Ltac z3 := why3 "z3" timelimit 5; case letUsTrustWhy3.

Require Export ZArith.
Open Scope Z_scope.
Require Export Lists.List.

Section S0.
  Variable a:Set->Set.

  Goal forall b:Set->Set, forall x:a nat, x=x.
    intros; ae.
  Qed.

Goal
  forall f: (nat->nat)->nat, f S = O -> True.
intros; ae.
Qed.

End S0.

(* Mutually inductive types *)

Inductive tree : Set :=
  | Leaf : tree
  | Node : Z -> forest -> tree
with forest : Set :=
  | Nil : forest
  | Cons : tree -> forest -> forest.

Fixpoint tree_size (t:tree) : Z := match t with
  | Leaf => 0
  | Node _ f => 1 + forest_size f end
with forest_size (f:forest) : Z := match f with
  | Nil => 0
  | Cons t f => tree_size t + forest_size f end.

Goal tree_size (Node 42 (Cons Leaf Nil)) = 1.
ae.
Qed.

Goal (match Leaf with Leaf => 1 | Node z f => 2 end)=1.
ae.
Qed.

Inductive foo : Set :=
  | OO : foo
  | SS : forall x:nat, p x -> foo
with p : nat -> Prop :=
  | cc : p O.

Goal p O.
(* not a first order goal *)
try ae.
exact cc.
Qed.

Inductive fooo : nat -> Prop :=
  c : bar O -> fooo O
with bar : nat -> Prop :=
  d : forall f:nat->nat, bar (f O).

Goal fooo O.
(* Don't know *)
try ae.
exact (c (d (fun x => O))).
Qed.

Inductive tree' : Set :=
  | Empty' : tree'
  | Node' : forest' -> tree'
with forest' : Set :=
  | Forest' : (nat -> tree') -> forest'.

Goal forall f: nat ->tree, True.
intros.
ae.
Qed.

Parameter f : (nat -> nat) -> nat.

Goal f (plus O) = f (plus O).
(* not a first order goal *)
try ae.
trivial.
Qed.

Parameter f' : nat -> nat.

Axiom f'_def: f' O = O.

Goal f' (f' O) = O.
ae.
Qed.

Variable b:Set.

Section S.

Variable b:Set->Set.

Variable a:Set.

Inductive sorted : list a -> Prop :=
  ccc: sorted (@nil a)
| ddd: forall x: a, sorted (cons x nil).

Variable f : a -> a.

Goal True.
ae.
Qed.

Goal forall x: a, f (f x) = f x -> f (f (f x)) = f x.
intros.
ae.
Qed.

Goal forall l: list a, l=l.
ae.
Qed.

End S.

Goal True.
ae.
Qed.

Parameter par: Z -> Prop.

(* let in *)
Goal
  let t := Z in
  let f := par 0 in
  (forall x:t, par x -> par (let y := x+1 in y)) ->
  f -> par 1.
ae.
Qed.

(* cast *)
Goal
  (
  (forall x:Z, par x -> par (x+1)) -> par (0 : Z) -> par 1 : Prop).
ae.
Qed.

(* type definitions *)

Parameter t : Set -> Set.

Inductive foobar : Set :=
  C : t nat -> foobar.

Goal forall x:foobar, x=x.
intros.
ae.
Qed.

(* predicate definition *)

Definition p' (x:nat) := x=O.

Goal p' O.
ae.
Qed.

Goal plus O O = O.
ae.
Qed.

Definition eq' (A:Set) (x y : A) := x=y.

Goal
  eq' nat O O.
ae.
Qed.

Definition pred (n:nat) := match n with
  | O => O
  | S p => p
  end.

Goal pred (S O) = O.
ae.
Qed.

(* function definition *)

Definition ff (x:Z) (y:Z) := x+y.

Goal ff 1 2 = 3.
ae.
Qed.

Definition id A (x:A) := x.

Goal id nat O = O.
ae.
Qed.

(* recursive function definition *)

Goal length (cons 1 (cons 2 nil)) = S (S O).
ae.
Qed.

(* recursive predicate definition *)

Goal In 0 (cons 1 (cons 0 nil)).
ae.
Qed.

(* inductive types *)

Parameter P : (nat -> nat) -> Prop.

Goal forall (a:Set), forall x:nat, x=S O -> P S ->
  let y := (S (S O)) in S x=y.
intros.
ae.
Qed.

Goal  forall (a:Set), forall x:Z, x=1 -> P S -> let y := 2 in x+1=y.
intros.
ae.
Qed.

Goal  forall x: list nat, x=x.
intros.
ae.
Qed.

Goal (match (S (S (S O))) with (S (S _)) => True | _ => False end).
ae.
Qed.

Goal
  forall a, forall (x: list (list a)),
  1<=2 -> match x with nil => 1 | x :: r => 2 end <= 2.
intros a x.
assert (x=nil \/ exists y: list a, exists z:list (list a),
                 x = cons y z).
destruct x; ae.
ae.
Qed.

(* Polymorphic, Mutually inductive types *)

Inductive ptree {a:Set} : Set :=
  | PLeaf : ptree
  | PNode : a -> pforest -> ptree

with pforest {a:Set} : Set :=
  | PNil : pforest
  | PCons : ptree -> pforest -> pforest.

Goal forall x : @ptree Z, x=x.
ae.
Qed.

Definition a := 0+0.
Definition bb := a.

Goal bb=0.
ae.
Qed.

Goal bb=0.
ae.
Qed.

Fixpoint ptree_size {a:Set} (t:@ptree a) : Z := match t with
  | PLeaf => 0
  | PNode _ f => 1 + pforest_size f end
with pforest_size {a:Set} (f:@pforest a) : Z := match f with
  | PNil => 0
  | PCons t f => ptree_size t + pforest_size f end.

Goal ptree_size (@PLeaf Z) = 0.
ae.
Qed.

Goal forall (a:Set), ptree_size (@PLeaf a) = 0.
intros.
ae.
Qed.

(* the same, without parameters *)

Inductive ptree' : Type -> Type :=
  | PLeaf' : forall (a:Type), ptree' a
  | PNode' : forall (a:Type), a -> pforest' a -> ptree' a

with pforest' : Type -> Type :=
  | PNil' : forall  (a:Type), pforest' a
  | PCons' : forall (a:Type), ptree' a -> pforest' a -> pforest' a.

Goal forall x : ptree' Z, x=x.
ae.
Qed.

(* order of type parameters matters *)

Definition wgt (k:(nat * Z)%type) := match k with
  | (_, p) => p
  end.
Implicit Arguments wgt.

Goal wgt (S O, 3) = 3.
ae.
Qed.

Require Import Rbase.
Require Import R_sqrt.
Require Import Rfunctions.
Require Import Rbasic_fun.

Goal forall (x:R), (0 <= x * x)%R.
ae.
Qed.


Require Import MLTT2F.Overture MLTT2F.Path_eq.
Set Universe Polymorphism.

Module Export FibrantReplacement.

  Private Inductive repl (X: Type) : Type :=
  | η : X -> repl X.

  Arguments η {_} _.

  Axiom Fibrant_repl : forall X, Fibrant (repl X).
  Global Existing Instance Fibrant_repl.

  Definition repl_ind {X} (P: repl X -> Type) {FibP: FibrantF P}
             (H: forall x : X, P (η x))
    : forall z, P z.
  Proof.
    destruct z. apply H.
  Defined.
End FibrantReplacement.

Definition repl_rec {X P} {FibP: Fibrant P} (H: X -> P)
  : repl X -> P
  := repl_ind (λ _ : repl X, P) H.

Axiom FibrantF_repl_rec : ∀ A (P: A -> Type) {FibP: FibrantF P},
    FibrantF (repl_rec P).
Global Existing Instance FibrantF_repl_rec.

Definition repl_sigma {A} (B: repl A -> Type) {FibB: FibrantF B}
  : sigT B -> repl (sigT (B o η)).
Proof.
  intros [x y]; revert x y.
  use repl_ind; cbn. intros x y. exact (η (x; y)).
Defined.

Definition repl_J' {A} {x: A} (P: (∃ y: A, η x = η y) -> Type)
           {FibP: FibrantF P}
           {y: A} (p: η x = η y)
  : P (x; 1) -> P (y; p).
Proof.
  transparent assert (P' : ((∃ z, η x = z) → Type)). {
    refine (_ o repl_sigma (λ z, η x = z)).
    use repl_rec. exact P. }
  change (P' (η x; 1) -> P' (η y; p)).
  intro u; refine (paths_rec (η x; 1) P' u (η y; p) _).
  subst P'. classes.
  ref (path_sigma (λ z, η x = z) p _).
  exact (transport_paths_r _ p 1 @ concat_1p p).
Defined.

Definition repl_J {A} {x: A} (P: ∀ (y: A), η x = η y -> Type)
           {H: FibrantF (λ w: ∃ y, η x = η y, P w.1 w.2)}
           {y: A} (p: η x = η y)
  : P x 1 -> P y p.
Proof.
  ref (repl_J' (λ w, P w.1 w.2) p).
Defined.

Definition repl_f {A B} (f: A -> B) : repl A -> repl B
  := repl_rec (η o f).

Axiom repl_f_compose : forall {A B C} (f: A -> B) (g: B -> C), repl_f g o repl_f f ≡≡ repl_f (g o f).

Axiom repl_f_idmap : forall {A}, repl_f (λ x: A, x) ≡≡ idmap.


From Undecidability.L Require Import L Tactics.Computable Tactics.ComputableTactics Tactics.Extract.
From MetaCoq Require Import Template.All TemplateMonad.Core Template.Ast.
Require Import String List.
Export String.StringSyntax.

Import MCMonadNotation.
Local Open Scope string_scope.

(* *** Generation of encoding functions *)

Fixpoint mkLApp (s : term) (L : list term) :=
  match L with
  | [] => s
  | t :: L => mkLApp (tApp (tConstruct (mkInd term_kn 0) 1 []) [s; t]) L
  end.

Definition encode_arguments (B : term) (a i : nat) A_j :=
      A <- tmUnquoteTyped Type A_j ;;
      name <- (tmEval cbv (name_of A_j ++ "_term") >>=  Core.tmFreshName)  ;;
      E <- tmTryInfer name None (registered A);;
      t <- ret (@enc A E);;
      l <- tmQuote t;;
      ret (tApp l [tRel (a - i - 1) ]).

Definition mkMatch (t1 t2 d : Ast.term) (pred : Ast.predicate term)  (cases : nat -> list term -> Core.TemplateMonad term) :=
  hs_num <- tmGetOption (split_head_symbol t1) "no head symbol found";;
  let '(ind, Params) := hs_num in
  let params := List.length Params in
  L <- list_constructors ind >>= tmEval hnf ;;
  body <- monad_map_i (fun i '(n, s, args) =>
  l <- tmArgsOfConstructor ind i ;;
  l' <- monad_map_i (insert_params FUEL Params) (skipn params l) ;;
  t <- cases i l' ;; ret (mk_branch (context_to_bcontext args) t)) L ;;
ret (tCase (mk_case_info ind params Relevant)
                        pred
                        d
                        body).

Definition L_facts_mp := MPfile ["L_facts"; "Util"; "L"; "Undecidability"].

Definition tmMatchCorrect (A : Type) : Core.TemplateMonad Prop :=
  t <- (tmEval hnf A >>= tmQuote) ;;
  hs_num <- tmGetOption (split_head_symbol t) "no inductive";;
  let '(ind, Params) := hs_num in
  decl <- tmQuoteInductiveDecl (inductive_mind ind) ;;
  let '(mdecl,idecl) := decl in
  let params := firstn mdecl.(ind_npars) Params in
  num <- tmEval cbv (| ind_ctors idecl |) ;;
  x <- Core.tmFreshName "x" ;;
  mtch <- mkMatch t (* argument type *) tTerm (* return type *) (tRel (2 * num))
           (mk_predicate Instance.empty params (context_to_bcontext (ind_predicate_context ind mdecl idecl)) tTerm)
           (fun i (* ctr index *) ctr_types (* ctr type *) =>
              args <- tmEval cbv (|ctr_types|);;
              C <- monad_map_i (encode_arguments t args) ctr_types ;;
              ret ( (* stack (map (tLambda (naAnon)) ctr_types) *)
                               (((fun s => mkAppList s C) (tRel (args + 2 * (num - i) - 1)))))
           ) ;;
   E' <- Core.tmInferInstance None (registered A);;
   E <- tmGetMyOption E' "failed" ;;
   t' <- ret (@enc A E);;
   l <- tmQuote t';;
   encn <- ret (tApp l [tRel (2*num) ]) ;;
   lhs <- ret (mkLApp encn ((fix f n := match n with 0 => [] | S n => tRel (2 * n + 1) :: f n end ) num)) ;;
   ter <- ret (tProd naAnon t (it (fun s : term => tProd naAnon tTerm (tProd naAnon (tApp (tConst (L_facts_mp, "proc") []) [tRel 0]) s)) num ((tApp (tConst (L_facts_mp, "redLe") []) [mkNat num; lhs; mtch]))));;
   ter <- tmEval cbv ter ;;
   tmUnquoteTyped Prop ter.

Definition matchlem n A := (Core.tmBind (tmMatchCorrect A) (fun m => tmLemma n m ;; ret tt)).

Definition tmGenEncode (n : ident) (A : Type) : TemplateMonad unit :=
  e <- tmEncode n A;;
  modpath <- tmCurrentModPath tt ;;
  e <- tmUnquoteTyped (encodable A) (tConst (modpath, n) []);;
  p <- Core.tmLemma (n ++ "_proc") (forall x : A, proc (@enc_f A e x)) ;;
  n2 <- tmEval cbv ((n ++ "_inj"));;
  i <- Core.tmLemma n2  (injective (@enc_f _ e)) ;;
  n3 <- tmEval cbv ("registered_" ++ n) ;;
  d <- tmInstanceRed n3 None (@mk_registered A e p i);;
  m <- tmMatchCorrect A;;
  n4 <- tmEval cbv (n ++ "_correct") ;;
  (Core.tmBind (tmMatchCorrect A) (fun m => tmLemma n4 m ;; ret tt)).

Arguments tmGenEncode _%string _%type.

(*
Definition tmGenEncode' (n : ident) (A : Type) :=
  e <- tmEncode n A;;
  modpath <- tmCurrentModPath tt ;;
  e <- tmUnquoteTyped (encodable A) (tConst (modpath, n) []);;
  p <- Core.tmLemma (n ++ "_proc") (forall x : A, proc (@enc_f A e x)) ;;
  n2 <- tmEval cbv ((n ++ "_inj"));;
  i <- Core.tmLemma n2  (injective (@enc_f _ e)) ;;
  n3 <- tmEval cbv ("registered_" ++ n) ;;
  d <- tmInstanceRed n3 None  (@mk_registered A e p i);;
  m <- tmMatchCorrect A ;; ret tt. *)

(* TODO : use other methode instead, e.g. with typeclasses, as default obligation tactic is very fragile *)
Global Obligation Tactic := try fold (injective (enc_f)); match goal with
                           | [ |- forall x : ?X, proc ?f ] => try register_proc
                           | [ |- injective ?f ] => register_inj
                           | [ |- context [_ >(<= _) _] ] => extract match
                           end || Tactics.program_simpl.


From oadt.lang_oadt Require Import
     base syntax semantics typing indistinguishable infrastructure
     values preservation progress obliviousness.
Import syntax.notations semantics.notations typing.notations
       equivalence.notations indistinguishable.notations.

Implicit Types (b : bool) (x X y Y : atom) (L : aset).

Lemma gdefs_typing_wf Σ :
  gctx_typing Σ ->
  gctx_wf Σ.
Proof.
  intros.
  eapply map_Forall_impl; eauto.
  simpl.
  intros ??. inversion 1; eauto.
Qed.

(** * Soundness *)

Definition stuck (Σ : gctx) (e : expr) : Prop :=
  nf (step Σ) e /\ ¬val e.

(** If a program is well-typed, it will never get stuck. *)
Corollary soundness e Σ τ e' :
  Σ; e ▷ τ ->
  Σ ⊨ e -->* e' ->
  ¬(stuck Σ e').
Proof.
  intros [Hd Ht]. apply gdefs_typing_wf in Hd.
  induction 1;
    qauto use: progress, preservation unfold: stuck, nf.
Qed.

(** * Obliviousness *)

(** [e1] and [e2] are trace-indistinguishable if the traces they produce are
pointwise indistinguishable, i.e. they always take the same number of steps, and
each expressions they step to remain indistinguishable. This ensures that an
attacker can not tell [e1] and [e2] apart, even given the entire execution
traces of them. *)
Definition trace_indistinguishable Σ e1 e2 : Prop :=
  forall n e1',
    Σ ⊨ e1 -->{n} e1' ->
    (exists e2', Σ ⊨ e2 -->{n} e2') /\
    (forall e2', Σ ⊨ e2 -->{n} e2' -> e1' ≈ e2').

(** Essentially a noninterference theorem. Indistinguishable well-typed
expressions produce indistinguishable traces. *)
Theorem obliviousness Σ e1 e2 τ1 τ2 :
  Σ; e1 ▷ τ1 ->
  Σ; e2 ▷ τ2 ->
  e1 ≈ e2 ->
  trace_indistinguishable Σ e1 e2.
Proof.
  unfold trace_indistinguishable.
  intros [Hd Ht1] [_ Ht1']. apply gdefs_typing_wf in Hd.
  intros ??? H. revert dependent e2.
  induction H; intros.
  - hauto ctrs: nsteps inv: nsteps.
  - edestruct obliviousness_step as [[??] ?]; eauto.
    split; intros.
    + hauto ctrs: nsteps use: preservation.
    + select (_ ⊨ _ -->{_} _) (fun H => sinvert H).
      qauto use: preservation.
Qed.

(** This is a corollary for open programs. An open (partial) program can be
instantiated with indistinguishable expressions, and the resulting programs
produce indistinguishable traces. As a consequence, a type-checked function does
not leak when it is applied to concrete arguments. *)
Corollary obliviousness_open Σ x l τ' e τ s1 s2 :
  gctx_typing Σ ->
  Σ; ({[x:=(l, τ')]}) ⊢ e :{⊥} τ ->
  x ∉ fv τ' ->
  Σ; ∅ ⊢ s1 :{l} τ' ->
  Σ; ∅ ⊢ s2 :{l} τ' ->
  s1 ≈ s2 ->
  trace_indistinguishable Σ <{ {x↦s1}e }> <{ {x↦s2}e }>.
Proof.
  intros.
  eapply obliviousness; eauto.

  1-2: split; eauto;
  eapply subst_preservation;
  eauto using gdefs_typing_wf; fast_set_solver!!.

  apply indistinguishable_subst; try reflexivity; eauto.
Qed.

(** This is another corollary. Two expressions that only differ in an oblivious
value in it produce indistinguishable traces, meaning that an attacker can not
infer the oblivious value by analyzing the execution trace. *)
Corollary obliviousness_open_obliv_val Σ x l τ' e τ v1 v2 :
  gctx_typing Σ ->
  Σ; ({[x:=(l, τ')]}) ⊢ e :{⊥} τ ->
  x ∉ fv τ' ->
  Σ; ∅ ⊢ v1 :{l} τ' ->
  Σ; ∅ ⊢ v2 :{l} τ' ->
  Σ; ∅ ⊢ τ' :: *@O ->
  val v1 -> val v2 ->
  trace_indistinguishable Σ <{ {x↦v1}e }> <{ {x↦v2}e }>.
Proof.
  eauto using obliviousness_open, indistinguishable_obliv_val, gdefs_typing_wf.
Qed.


Require Import  prosa.classic.util.all.
Require Import  prosa.classic.model.arrival.basic.task
                prosa.classic.model.arrival.basic.job prosa.classic.model.priority
                prosa.classic.model.arrival.basic.task_arrival
                prosa.classic.model.schedule.uni.schedule.
Require Import  prosa.classic.model.policy_tdma.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq fintype bigop.

Module Platform_TDMA.

  Import Job  UniprocessorSchedule div.
  Export PolicyTDMA.

  (* In this section, we define properties of the processor platform for TDMA. *)
  Section Properties.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_deadline: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Consider any job arrival sequence... *)
    Variable arr_seq: arrival_sequence Job.

    (* ..., any uniprocessor... *)
    Variable sched: schedule Job.

    (* ... and any sporadic task set. *)
    Variable ts: {set sporadic_task}.

    (* Consider any TDMA slot assignment... *)
    Variable time_slot: TDMA_slot sporadic_task.

    (* ... and any slot order. *)
    Variable slot_order: TDMA_slot_order sporadic_task.

    (* In order to characterize a TDMA policy, we first define whether a job is executing its TDMA slot at time t. *)
    Let job_in_time_slot (job:Job) (t:instant):=
        Task_in_time_slot ts slot_order (job_task job) time_slot t.

    (* We say that a TDMA policy is respected by the schedule iff
       1. when a job is scheduled at time t, then the corresponding task
          is also in its own time slot... *)
    Definition sched_implies_in_slot j t:=
      (scheduled_at sched j t -> job_in_time_slot j t).

    (* 2. when a job is backlogged at time t,the corresponding task
          isn't in its own time slot or another previous job of the same task is scheduled *)
    Definition backlogged_implies_not_in_slot_or_other_job_sched j t:=
      (backlogged job_arrival job_cost sched j t ->
        ~ job_in_time_slot j t \/
        (exists j_other, arrives_in arr_seq j_other/\
                         job_arrival j_other < job_arrival j/\
                         job_task j = job_task j_other/\
                         scheduled_at sched j_other t)).

    Definition Respects_TDMA_policy:=
      forall (j:Job) (t:time),
        arrives_in arr_seq j ->
        sched_implies_in_slot j t /\ backlogged_implies_not_in_slot_or_other_job_sched j t.

  End Properties.

End Platform_TDMA.


Require Import Integers.
Require Import Coqlib.
Require Import List. Import ListNotations.
Require Import DRBG_working_state.
Require Import DRBG_state_handle.
Require Import DRBG_generate_algorithm_result.
Require Import DRBG_reseed_function.
Require Import entropy.

(* 12/15/15

new fn: how many bits of entropy it consumed
prefix of that length that relates the two infinite streams
abstraction function
will need to have all of these (orange) parameters

stream = exists finite prefix of size n ++ stream'

see naphat's entropy.v

but how do i use the abstraction function??
what's the new theorem statement?

(also, how do i deal with the failures in the stream?)

? i don't remember what else

do i need some relation on the input stream? or just equality?

DRBG_generate_function_helper' ga rf stream state n prr ai reseed ct :=
  min_bits

f $ DRBG_gen inputs = DRBG_gen' inputs

note: stream in (entropy_stream), stream out (ENTROPY.result)

wouldn't it be an abstraction theorem instead?
would definitely need to reason about low-level parts of naphat's spec

would i need an abstraction function/theorem for reseed as well? since it actually calls GE

need to do the abstraction function on the stream of all successes

gen_func (filter entropy_stream) .. other inputs .. = entropy_stream' .. other outputs ..
is the filtering ok?

gen_func (filter entropy_stream) .. other inputs ..
is equivalent to
calling gen_func repeatedly until n successes?

and then gen_func (filter entropy_stream) =

should i say "after n generate calls, the stream returned is equal to the original stream with the first (e * 1 + (l/r)) bits removed"?

prove that after 1 generate call
(maybe i shouldn't be thinking in terms of # calls???)
if reseed_ctr then ... otherwise ... ?

maybe i should have a version that RETURNS the bits that it took off the head of the stream
/ returns their length / concats the stream

do the proof first for (filter entropy_stream)
(ALSO naphat has some relevant proofs/tests in entropy.v)

if the entropy fails, then the reseed fails, the gen func helper fails, and the gen func fails (up to the top level). so, i have to deal with calling generate until there is a success. that might not terminate?

Inductive result X: Type: Type :=
| success: X -> stream -> @result X
| error : error_code -> stream -> @result X.

 *)
Fixpoint DRBG_generate_function_helper
         (generate_algorithm: DRBG_working_state -> Z -> list Z
                              -> DRBG_generate_algorithm_result)
         (reseed_function: ENTROPY.stream -> DRBG_state_handle
                           -> bool -> list Z -> ENTROPY.result DRBG_state_handle)
         (entropy_stream: ENTROPY.stream)
         (state_handle: DRBG_state_handle)
         (requested_number_of_bytes: Z)
         (prediction_resistance_request: bool)
         (additional_input: list Z)
         (should_reseed: bool)
         (count: nat): ENTROPY.result (list Z * DRBG_working_state) :=
  (* reseed happens here on second call to helper *)
  let result := if should_reseed then
                  (* passes the entropy stream to the reseed function *)
                  match reseed_function entropy_stream state_handle
                                        prediction_resistance_request
                                        additional_input with
                  | ENTROPY.success x entropy_stream =>
                    ENTROPY.success (x, []) entropy_stream
                  | ENTROPY.error e entropy_stream =>
                    ENTROPY.error e entropy_stream
                  end
                else ENTROPY.success (state_handle, additional_input) entropy_stream in
  match result with
    | ENTROPY.error e s => ENTROPY.error e s
    | ENTROPY.success (state_handle, additional_input) entropy_stream =>
      let '(working_state, security_strength, prediction_resistance_flag) := state_handle in
      (* generate_algorithm actually called here *)
      match generate_algorithm working_state requested_number_of_bytes additional_input with
        | generate_algorithm_reseed_required =>
          match count with
            | O => ENTROPY.error ENTROPY.generic_error entropy_stream (* impossible *)
            | S count' =>
              (* reseed happens here -- calls helper again *)
              DRBG_generate_function_helper
                generate_algorithm reseed_function entropy_stream state_handle
                requested_number_of_bytes prediction_resistance_request additional_input
                true count'
          end
        | generate_algorithm_success x y => ENTROPY.success (x, y) entropy_stream
      end
    end.

Definition DRBG_generate_function
           (generate_algorithm: Z -> DRBG_working_state -> Z -> list Z
                                -> DRBG_generate_algorithm_result)
           (reseed_function: ENTROPY.stream -> DRBG_state_handle -> bool
                             -> list Z -> ENTROPY.result DRBG_state_handle)
           (reseed_interval: Z)
           (max_number_of_bytes_per_request: Z)
           (max_additional_input_length: Z)
           (entropy_stream: ENTROPY.stream)
           (state_handle: DRBG_state_handle)
           (requested_number_of_bytes requested_security_strength: Z)
           (prediction_resistance_request: bool)
           (additional_input: list Z):
  ENTROPY.result (list Z * DRBG_state_handle) :=
  let '(working_state, security_strength, prediction_resistance_flag) := state_handle in
  if Z.gtb requested_number_of_bytes max_number_of_bytes_per_request
  then ENTROPY.error ENTROPY.generic_error entropy_stream
  else
    if Z.gtb requested_security_strength security_strength
    then ENTROPY.error ENTROPY.generic_error entropy_stream
    else
      if Z.gtb (Zlength additional_input) max_additional_input_length
      then ENTROPY.error ENTROPY.generic_error entropy_stream
      else
        if prediction_resistance_request && (negb prediction_resistance_flag)
        then ENTROPY.error ENTROPY.generic_error entropy_stream
        else
          (* helper used here *)
          match DRBG_generate_function_helper
                  (* generate_algorithm here *)
                  (generate_algorithm reseed_interval) reseed_function entropy_stream
                  state_handle requested_number_of_bytes prediction_resistance_request
                  additional_input prediction_resistance_request 1%nat with
            | ENTROPY.error e s => ENTROPY.error e s
            | ENTROPY.success (output, new_working_state) entropy_stream =>
              ENTROPY.success (output, (new_working_state, security_strength,
                                        prediction_resistance_flag))
                              entropy_stream
          end.


Require Import Tactics.

Require Import Pointer AndersenModel AndersenSound AndersenIter.

Lemma incl_intersect2 : forall s1 t1 s2 t2,
  AllocSet.incl s1 s2 = true
  -> AllocSet.incl t1 t2 = true
  -> AllocSet.incl (AllocSet.intersect s1 t1)
  (AllocSet.intersect s2 t2) = true.
  intros.
  generalize (AllocSet.incl_ok (AllocSet.intersect s1 t1) (AllocSet.intersect s2 t2));
    intuition.
  apply H3; intuition.
  destruct (AllocSet.In_intersect H1).
  caseEq (AllocSet.In x (AllocSet.intersect s2 t2)); intuition.
  destruct (AllocSet.In_intersect' H6); eauto.
Qed.

Definition andersen : mustNotAlias_procedure.
  red; intros.
  destruct (fixed_point (abstractProgram program)) as [fp Hfp].

  caseEq (AllocSet.incl (AllocSet.intersect
    (VarMap.sel (avars fp) v1) (VarMap.sel (avars fp) v2))
  AllocSet.empty); intro Hincl.

  apply NotAliased.
  apply andersen_sound; intuition.
  match goal with
    | [ |- ?X = false ] => caseEq X
  end; trivial; intro Heq.

  wrong.
  assert (approx' abs fp); auto.
  destruct H0.
  assert (AllocSet.In site AllocSet.empty = true).
  apply AllocSet.incl_In with (AllocSet.intersect (VarMap.sel (avars fp) v1)
    (VarMap.sel (avars fp) v2)); auto.
  apply AllocSet.incl_In with (AllocSet.intersect (VarMap.sel (avars abs) v1)
    (VarMap.sel (avars abs) v2)); auto.
  apply incl_intersect2; auto.

  rewrite AllocSet.In_empty in H0; discriminate.

  apply Unknown.
Qed.


(**
This file is part of the Coquelicot formalization of real
analysis in Coq: http://coquelicot.saclay.inria.fr/

Copyright (C) 2011-2015 Sylvie Boldo
#
#
Copyright (C) 2011-2015 Catherine Lelay
#
#
Copyright (C) 2011-2015 Guillaume Melquiond

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
COPYING file for more details.
*)

Require Import Reals mathcomp.ssreflect.ssreflect.
Require Import Psatz.
Require Import Rcomplements Rbar Hierarchy.
Require Import Derive RInt Continuity Lim_seq ElemFct RInt_analysis.

(** This file describes an experiment: most 18-year old French
students pass an exam called Baccalaureate which ends the high school
and is required for attending the university. We took the 2013
mathematics test of the scientific Baccalaureate at the same time as
the students. The pdf of the test is available #here#. *)

Ltac pos_rat :=
  repeat ( apply Rdiv_lt_0_compat
         || apply Rplus_lt_0_compat
         || apply Rmult_lt_0_compat) ;
  try by apply Rlt_0_1.

Lemma sign_0_lt : forall x, 0 < x <-> 0 < sign x.
Proof.
intros x.
unfold sign.
destruct total_order_T as [[H|H]|H] ; lra.
Qed.

Lemma sign_lt_0 : forall x, x < 0 <-> sign x < 0.
Proof.
intros x.
unfold sign.
destruct total_order_T as [[H|H]|H] ; lra.
Qed.

(** * Exercice 2 *)
(* 8:14 *)

Definition fab (a b x : R) : R := (a + b * ln x) / x.

(** ** Questions 1 *)

(** 1.a. On voit sur le graphique que l'image de 1 par f correspond au point B(1,2). On a donc f(1) = 2.
Comme la tangente (BC) à la courbe en ce point admet pour coefficient directeur 0, f'(1) = 0 *)

(** 1.b *)

Lemma Dfab (a b : R) : forall x, 0 < x
  -> is_derive (fab a b) x (((b - a) - b * ln x) / x ^ 2).
Proof.
  move => x Hx.
  evar_last.
  apply is_derive_div.
  apply @is_derive_plus.
  apply is_derive_const.
  apply is_derive_scal.
  now apply is_derive_Reals, derivable_pt_lim_ln.
  apply is_derive_id.
  by apply Rgt_not_eq.
  rewrite /Rdiv /plus /zero /one /=.
  field.
  by apply Rgt_not_eq.
Qed.

(** 1.c *)

Lemma Val_a_b (a b : R) : fab a b 1 = 2 -> Derive (fab a b) 1 = 0 -> a = 2 /\ b = 2.
Proof.
  move => Hf Hdf.
  rewrite /fab in Hf.
  rewrite ln_1 in Hf.
  rewrite Rdiv_1 in Hf.
  rewrite Rmult_0_r in Hf.
  rewrite Rplus_0_r in Hf.
  rewrite Hf in Hdf |- * => {a Hf}.
  split.
  reflexivity.
  replace (Derive (fab 2 b) 1) with (((b - 2) - b * ln 1) / 1 ^ 2) in Hdf.
  rewrite ln_1 /= in Hdf.
  field_simplify in Hdf.
  rewrite !Rdiv_1 in Hdf.
  by apply Rminus_diag_uniq.
  apply sym_eq, is_derive_unique.
  apply Dfab.
  by apply Rlt_0_1.
Qed.

Definition f (x : R) : R := fab 2 2 x.

(** ** Questions 2 *)
(* 8:38 *)
(** 2.a. *)

Lemma Signe_df : forall x, 0 < x -> sign (Derive f x) = sign (- ln x).
Proof.
  move => x Hx.
  rewrite (is_derive_unique f x _ (Dfab 2 2 x Hx)).
  replace ((2 - 2 - 2 * ln x) / x ^ 2) with (2 / x ^ 2 * (- ln x)) by (field ; now apply Rgt_not_eq).
  rewrite sign_mult sign_eq_1.
  apply Rmult_1_l.
  apply Rdiv_lt_0_compat.
  apply Rlt_0_2.
  apply pow2_gt_0.
  by apply Rgt_not_eq.
Qed.

(** 2.b. *)

Lemma filterlim_f_0 :
  filterlim f (at_right 0) (Rbar_locally m_infty).
Proof.
  unfold f, fab.
  eapply (filterlim_comp_2 _ _ Rmult).
  eapply filterlim_comp_2.
  apply filterlim_const.
  eapply filterlim_comp_2.
  apply filterlim_const.
  by apply is_lim_ln_0.
  apply (filterlim_Rbar_mult 2 m_infty m_infty).
  unfold is_Rbar_mult, Rbar_mult'.
  case: Rle_dec (Rlt_le _ _ Rlt_0_2) => // H _ ;
  case: Rle_lt_or_eq_dec (Rlt_not_eq _ _ Rlt_0_2) => //.
  apply (filterlim_Rbar_plus 2 _ m_infty).
  by [].
  by apply filterlim_Rinv_0_right.
  by apply (filterlim_Rbar_mult m_infty p_infty).
Qed.

Lemma Lim_f_p_infty : is_lim f p_infty 0.
Proof.
  apply is_lim_ext_loc with (fun x => 2 / x + 2 * (ln x / x)).
    exists 0.
    move => y Hy.
    rewrite /f /fab.
    field.
    by apply Rgt_not_eq.
  eapply is_lim_plus.
  apply is_lim_scal_l.
  apply is_lim_inv.
  by apply is_lim_id.
  by [].
  apply is_lim_scal_l.
  by apply is_lim_div_ln_p.
  unfold is_Rbar_plus, Rbar_plus' ; apply f_equal, f_equal ; ring.
Qed.

(** 2.c. *)

Lemma Variation_1 : forall x y, 0 < x -> x < y -> y < 1 -> f x < f y.
Proof.
  apply (incr_function _ 0 1 (fun x => (2 - 2 - 2 * ln x) / x ^ 2)).
  move => x H0x Hx1.
  by apply (Dfab 2 2 x).
  move => x H0x Hx1.
  apply sign_0_lt.
  rewrite -(is_derive_unique _ _ _ (Dfab 2 2 x H0x)).
  rewrite Signe_df.
  apply -> sign_0_lt.
  apply Ropp_lt_cancel ; rewrite Ropp_0 Ropp_involutive.
  rewrite -ln_1.
  by apply ln_increasing.
  by apply H0x.
Qed.

Lemma Variation_2 : forall x y, 1 < x -> x < y -> f x > f y.
Proof.
  move => x y H1x Hxy.
  apply Ropp_lt_cancel.
  apply (incr_function (fun x => - f x) 1 p_infty (fun z => - ((2 - 2 - 2 * ln z) / z ^ 2))).
  move => z H1z _.
  apply: is_derive_opp.
  apply (Dfab 2 2 z).
  by apply Rlt_trans with (1 := Rlt_0_1).
  move => z H1z _.
  apply Ropp_lt_cancel ; rewrite Ropp_0 Ropp_involutive.
  apply sign_lt_0.
  rewrite -(is_derive_unique _ _ _ (Dfab 2 2 z (Rlt_trans _ _ _ Rlt_0_1 H1z))).
  rewrite Signe_df.
  apply -> sign_lt_0.
  apply Ropp_lt_cancel ; rewrite Ropp_0 Ropp_involutive.
  rewrite -ln_1.
  apply ln_increasing.
  by apply Rlt_0_1.
  by apply H1z.
  by apply Rlt_trans with (1 := Rlt_0_1).
  by [].
  by [].
  by [].
Qed.

(** ** Questions 3 *)
(* 9:40 *)

(** 3.a *)

Lemma f_eq_1_0_1 : exists x, 0 < x <= 1 /\ f x = 1.
Proof.
  case: (IVT_Rbar_incr (fun x => f (Rabs x)) 0 1 m_infty 2 1).
    eapply filterlim_comp.
    apply filterlim_Rabs_0.
    by apply filterlim_f_0.
  apply is_lim_comp with 1.
  replace 2 with (f 1).
  apply is_lim_continuity.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln 1) / 1 ^ 2) ; apply is_derive_Reals, Dfab.
  by apply Rlt_0_1.
  rewrite /f /fab ln_1 /= ; field.
  rewrite -{2}(Rabs_pos_eq 1).
  apply (is_lim_continuity Rabs 1).
  by apply continuity_pt_filterlim, continuous_Rabs.
  by apply Rle_0_1.
  exists (mkposreal _ Rlt_0_1) => /= x H0x Hx.
  rewrite /ball /= /AbsRing_ball /= in H0x.
  apply Rabs_lt_between' in H0x.
  rewrite Rminus_eq_0 in H0x.
  contradict Hx.
  rewrite -(Rabs_pos_eq x).
  by apply Rbar_finite_eq.
  by apply Rlt_le, H0x.
  move => x H0x Hx1.
  apply (continuity_pt_comp Rabs).
  by apply continuity_pt_filterlim, continuous_Rabs.
  rewrite Rabs_pos_eq.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln x) / x ^ 2) ; apply is_derive_Reals, Dfab.
  by [].
  by apply Rlt_le.
  by apply Rlt_0_1.
  split => //.
  apply Rminus_lt_0 ; ring_simplify ; by apply Rlt_0_1.
  move => x [H0x [Hx1 Hfx]].
  rewrite Rabs_pos_eq in Hfx.
  exists x ; repeat split.
  by apply H0x.
  by apply Rlt_le.
  by apply Hfx.
  by apply Rlt_le.
Qed.

(** 3.b. *)

Lemma f_eq_1_1_p_infty : exists x, 1 <= x /\ f x = 1.
Proof.
  case: (IVT_Rbar_incr (fun x => - f x) 1 p_infty (-2) 0 (-1)).
  replace (-2) with (-f 1).
  apply (is_lim_continuity (fun x => - f x)).
  apply continuity_pt_opp.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln 1) / 1 ^ 2) ; apply is_derive_Reals, Dfab.
  by apply Rlt_0_1.
  rewrite /f /fab ln_1 /= ; field.
  evar_last.
  apply is_lim_opp.
  by apply Lim_f_p_infty.
  simpl ; by rewrite Ropp_0.
  move => x H0x Hx1.
  apply continuity_pt_opp.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln x) / x ^ 2) ; apply is_derive_Reals, Dfab.
  by apply Rlt_trans with (1 := Rlt_0_1).
  by [].
  split ; apply Rminus_lt_0 ; ring_simplify ; by apply Rlt_0_1.
  move => x [H0x [Hx1 Hfx]].
  exists x ; split.
  by apply Rlt_le.
  rewrite -(Ropp_involutive (f x)) Hfx ; ring.
Qed.

(** ** Questions 5 *)
(* 10:08 *)

(** 5.a. *)

(** 5.b. *)

Lemma If : forall x, 0 < x -> is_derive (fun y : R => 2 * ln y + (ln y) ^ 2) x (f x).
Proof.
  move => y Hy.
  evar_last.
  apply @is_derive_plus.
  apply is_derive_Reals.
  apply derivable_pt_lim_scal.
  by apply derivable_pt_lim_ln.
  apply is_derive_pow.
  by apply is_derive_Reals, derivable_pt_lim_ln.
  rewrite /f /fab /plus /= ; field.
  by apply Rgt_not_eq.
Qed.

Lemma RInt_f : is_RInt f ( / exp 1) 1 1.
Proof.
  have Haux1: (0 < /exp 1).
    apply Rinv_0_lt_compat.
    apply exp_pos.
  evar_last.
  apply: is_RInt_derive.
  move => x Hx.
  apply If.
  apply Rlt_le_trans with (2 := proj1 Hx).
  apply Rmin_case.
  by apply Haux1.
  by apply Rlt_0_1.
  move => x Hx.
  apply continuity_pt_filterlim.
  apply derivable_continuous_pt.
  exists (((2 - 2) - 2 * ln x) / x ^ 2) ; apply is_derive_Reals, Dfab.
  apply Rlt_le_trans with (2 := proj1 Hx).
  apply Rmin_case.
  by apply Haux1.
  by apply Rlt_0_1.
  rewrite /minus /= /plus /opp /= -[eq]/(@eq R).
  rewrite ln_Rinv.
  rewrite ln_exp.
  rewrite ln_1.
  ring.
  by apply exp_pos.
Qed.

(** * Exercice 4 *)
(* 10:36 *)

Fixpoint u (n : nat) : R :=
  match n with
    | O => 2
    | S n => 2/3 * u n + 1/3 * (INR n) + 1
  end.

(** ** Questions 1 *)
(** 1.a. *)

(** 1.b. *)

(** ** Questions 2 *)
(* 10:40 *)
(** 2.a *)

Lemma Q2a : forall n, u n <= INR n + 3.
Proof.
  elim => [ | n IH] ; rewrite ?S_INR /=.
  apply Rminus_le_0 ; ring_simplify ; apply Rle_0_1.
  eapply Rle_trans.
  apply Rplus_le_compat_r.
  apply Rplus_le_compat_r.
  apply Rmult_le_compat_l.
  lra.
  by apply IH.
  lra.
Qed.

(** 2.b. *)
Lemma Q2b : forall n, u (S n) - u n = 1/3 * (INR n + 3 - u n).
Proof.
  move => n ; simpl.
  field.
Qed.

(** 2.c. *)

Lemma Q2c : forall n, u n <= u (S n).
Proof.
  move => n.
  apply Rminus_le_0.
  rewrite Q2b.
  apply Rmult_le_pos.
  lra.
  apply (Rminus_le_0 (u n)).
  by apply Q2a.
Qed.

(** ** Question 3 *)
(* 10:49 *)

Definition v (n : nat) : R := u n - INR n.

(** 3.a. *)

Lemma Q3a : forall n, v n = 2 * (2/3) ^ n.
Proof.
  elim => [ | n IH].
  rewrite /v /u /= ; ring.
  replace (2 * (2 / 3) ^ S n) with (v n * (2/3)) by (rewrite IH /= ; ring).
  rewrite /v S_INR /=.
  field.
Qed.

(** 3.b. *)

Lemma Q3b : forall n, u n = 2 * (2/3)^n + INR n.
Proof.
  move => n.
  rewrite -Q3a /v ; ring.
Qed.

Lemma Q3c : is_lim_seq u p_infty.
Proof.
  apply is_lim_seq_ext with (fun n => 2 * (2/3)^n + INR n).
  move => n ; by rewrite Q3b.
  eapply is_lim_seq_plus.
  eapply is_lim_seq_mult.
  by apply is_lim_seq_const.
  apply is_lim_seq_geom.
  rewrite Rabs_pos_eq.
  lra.
  lra.
  by [].
  apply is_lim_seq_INR.
  by [].
Qed.

(** ** Questions 4 *)
(* 11:00 *)

Definition Su (n : nat) : R := sum_f_R0 u n.
Definition Tu (n : nat) : R := Su n / (INR n) ^ 2.

(** 4.a. *)

Lemma Q4a : forall n, Su n = 6 - 4 * (2/3)^n + INR n * (INR n + 1) / 2.
Proof.
  move => n.
  rewrite /Su.
  rewrite -(sum_eq (fun n => (2/3)^n * 2 + INR n)).
  rewrite sum_plus.
  rewrite -scal_sum.
  rewrite tech3.
  rewrite sum_INR.
  simpl ; field.
  apply Rlt_not_eq, Rlt_div_l.
  repeat apply Rplus_lt_0_compat ; apply Rlt_0_1.
  apply Rminus_lt_0 ; ring_simplify ; by apply Rlt_0_1.
  move => i _.
  rewrite Q3b ; ring.
Qed.

(** 4.b. *)

Lemma Q4b : is_lim_seq Tu (1/2).
Proof.
  apply is_lim_seq_ext_loc with (fun n => (6 - 4 * (2/3)^n) / (INR n ^2) + / (2 * INR n) + /2).
    exists 1%nat => n Hn ; rewrite /Tu Q4a.
    simpl ; field.
    apply Rgt_not_eq, (lt_INR O) ; intuition.
  eapply is_lim_seq_plus.
  eapply is_lim_seq_plus.
  eapply is_lim_seq_div.
  eapply is_lim_seq_minus.
  apply is_lim_seq_const.
  eapply is_lim_seq_mult.
  by apply is_lim_seq_const.
  apply is_lim_seq_geom.
  rewrite Rabs_pos_eq.
  lra.
  lra.
  by [].
  rewrite /is_Rbar_minus /is_Rbar_plus /=.
  now ring_simplify (6 + - (4 * 0)).
  repeat eapply is_lim_seq_mult.
  apply is_lim_seq_INR.
  apply is_lim_seq_INR.
  apply is_lim_seq_const.
  apply is_Rbar_mult_p_infty_pos.
  by apply Rlt_0_1.
  by [].
  by [].
  by apply is_Rbar_div_p_infty.
  apply is_lim_seq_inv.
  eapply is_lim_seq_mult.
  by apply is_lim_seq_const.
  by apply is_lim_seq_INR.
  by apply is_Rbar_mult_sym, is_Rbar_mult_p_infty_pos, Rlt_0_2.
  by [].
  by [].
  apply is_lim_seq_const.
  apply (f_equal (@Some _)), f_equal.
  field.
Qed.
(* 11:33 *)