From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq.
From mathcomp Require Import div choice fintype tuple finfun bigop.
From mathcomp Require Import prime binomial ssralg finset.

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

(* Erik Martin-Dorel, 2016 *)

(** * Tactic for rewriting under bigops *)

(** ** When the bigop appears in the goal *)

(** [under_big] allows one to apply a given tactic under the bigop
    that correspond to the specified arguments. *)
Ltac under_big b i Hi tac :=
  let b' := eval hnf in b in
  match b' with
  | @BigOp.bigop ?R ?I ?idx ?r ?f =>
    match f with
    | fun x => @BigBody ?R ?I x ?op (@?P x) (@?F1 x) =>
      (* erewrite (@eq_bigr R idx op I r P F1 _); (*not robust enough*) *)
      pattern b;
      match goal with
      | [|- ?G b] =>
        refine (@eq_rect_r _ _ G _ b
          (@eq_bigr R idx op I r P F1 _ _ : _ = @BigOp.bigop _ _ _ _ (fun i => _)));
        [|move=> i Hi; tac;
          try reflexivity (* instead of "; first reflexivity" *) ];
        cbv beta
      end
    end
  end.

(** The following tactic can be used to add support for patterns to
tactic notation:
It will search for the first subterm of the goal matching [pat], and
then call [tac] with that subterm.

Inpired by Ralf Jung's post on 2016-02-25 to the ssreflect mailing list.
*)
Ltac find_pat pat tac :=
  match goal with |- context [?x] =>
                  unify pat x with typeclass_instances;
                  tryif tac x then idtac else fail
  end.

(** [under] allows one to apply a given tactic under some bigop:
    if [pat] is a local variable (let-in) that appears in the goal,
    only the occurrences of [pat] will be rewritten;
    otherwise the occurrences of the first bigop that matches [pat]
    will be rewritten. *)
Tactic Notation "under" open_constr(pat) simple_intropattern(i) simple_intropattern(Hi) tactic(tac) :=
  tryif match goal with [|- context [pat]] => is_var pat end
  then under_big pat i Hi tac
  else find_pat pat ltac:(fun b => under_big b i Hi tac).

(** A shortcut when we want to rewrite the first occurrence of [bigop _ _ _] *)
Notation big := (bigop _ _ _) (only parsing).

(** [swap under big ? _ tac] : shortcut for [(under big ? _ tac); last first] *)
Tactic Notation "swap" tactic(tac) :=
  tac; last first.

(** ** When the bigop appears in some hypothesis *)

(** [under_big_in] allows one to apply a given tactic under the bigop
    that correspond to the specified arguments, in some hypothesis *)
Ltac under_big_in H b i Hi tac :=
  let b' := eval hnf in b in
  match b' with
  | @BigOp.bigop ?R ?I ?idx ?r ?f =>
    match f with
    | fun x => @BigBody ?R ?I x ?op (@?P x) (@?F1 x) =>
      (* erewrite (@eq_bigr R idx op I r P F1 _); (*not robust enough*) *)
      pattern b in H;
      match type of H with
      | ?G b =>
        let e := fresh in
        let new := fresh in
        refine (let e := G _ in _);
        shelve_unifiable;
        suff new : e;
        [ try clear H ; try rename new into H
        | refine (@eq_rect _ _ G H _
            (@eq_bigr R idx op I r P F1 _ _ : _ = @BigOp.bigop _ _ _ _ (fun i => _)));
          move=> i Hi; tac;
          try reflexivity (* instead of "; first reflexivity" *)
        ]; try unfold e in * |- *; try clear e ; cbv beta
      end
    end
  end.

Ltac find_pat_in H pat tac :=
  match type of H with context [?x] =>
    unify pat x with typeclass_instances;
    tryif tac x then idtac else fail
  end.

(** [under...in] allows one to apply a given tactic under some bigop:
    if [pat] is a local variable (let-in) that appears in H,
    only the occurrences of [pat] will be rewritten;
    otherwise the occurrences of the first bigop that matches [pat]
    will be rewritten. *)
Tactic Notation "under" open_constr(pat) "in" hyp(H) simple_intropattern(i) simple_intropattern(Hi) tactic(tac) :=
  tryif match type of H with context [pat] => is_var pat end
  then under_big_in H pat i Hi tac
  else find_pat_in H pat ltac:(fun b => under_big_in H b i Hi tac).

(** * Similar material, for the bigop predicates *)

(** ** When the bigop appears in the goal *)

(** [underp_big] allows one to apply a given tactic for rewriting the
    predicate of the bigop corresponding to the specified arguments. *)
Ltac underp_big b i tac :=
  let b' := eval hnf in b in
  match b' with
  | @BigOp.bigop ?R ?I ?idx ?r ?f =>
    match f with
    | fun x => @BigBody ?R ?I x ?op (@?P1 x) (@?F x) =>
      pattern b;
      match goal with
      | [|- ?G b] =>
        refine (@eq_rect_r _ _ G _ b
          (@eq_bigl R idx op I r P1 _ F _ : _ = @BigOp.bigop _ _ _ _ (fun i => _)));
        [|move=> i; tac;
          try reflexivity (* instead of "; first reflexivity" *) ];
        cbv beta
      end
    end
  end.

(** [underp] allows one to apply a given tactic for rewriting
    some bigop predicate:
    if [pat] is a local variable (let-in) that appears in the goal,
    only the occurrences of [pat] will be rewritten;
    otherwise the occurrences of the first bigop that matches [pat]
    will be rewritten. *)
Tactic Notation "underp" open_constr(pat) simple_intropattern(i) tactic(tac) :=
  tryif match goal with [|- context [pat]] => is_var pat end
  then underp_big pat i tac
  else find_pat pat ltac:(fun b => underp_big b i tac).

(** ** When the bigop appears in some hypothesis *)

(** [underp_big_in] allows one to apply a given tactic for rewriting the
    predicate of the bigop corresponding to the specified arguments,
    in some hypothesis *)
Ltac underp_big_in H b i tac :=
  let b' := eval hnf in b in
  match b' with
  | @BigOp.bigop ?R ?I ?idx ?r ?f =>
    match f with
    | fun x => @BigBody ?R ?I x ?op (@?P1 x) (@?F x) =>
      pattern b in H;
      match type of H with
      | ?G b =>
        let e := fresh in
        let new := fresh in
        refine (let e := G _ in _);
        shelve_unifiable;
        suff new : e;
        [ try clear H ; try rename new into H
        | refine (@eq_rect _ _ G H _
            (@eq_bigl R idx op I r P1 _ F _ : _ = @BigOp.bigop _ _ _ _ (fun i => _)));
          move=> i; tac;
          try reflexivity (* instead of "; first reflexivity" *)
        ]; try unfold e in * |- *; try clear e ; cbv beta
      end
    end
  end.

(** [underp...in] allows one to apply a given tactic for rewriting
    some bigop predicate:
    if [pat] is a local variable (let-in) that appears in H,
    only the occurrences of [pat] will be rewritten;
    otherwise the occurrences of the first bigop that matches [pat]
    will be rewritten. *)
Tactic Notation "underp" open_constr(pat) "in" hyp(H) simple_intropattern(i) tactic(tac) :=
  tryif match type of H with context [pat] => is_var pat end
  then underp_big_in H pat i tac
  else find_pat_in H pat ltac:(fun b => underp_big_in H b i tac).

(*
(** * Tests and examples *)

Section Tests.

(* A test lemma covering several testcases. *)
Let test1 (n : nat) (R : ringType) (f1 f2 g : nat -> R) :
  (\big[+%R/0%R]_(i < n) ((f1 i + f2 i) * g i) +
  \big[+%R/0%R]_(i < n) ((f1 i + f2 i) * g i) =
  \big[+%R/0%R]_(i < n) ((f1 i + f2 i) * g i) +
  \big[+%R/0%R]_(i < n) (f1 i * g i) + \big[+%R/0%R]_(i < n) (f2 i * g i))%R.
Proof.
set b1 := {2}(bigop _ _ _).
Fail under b1 x _ rewrite GRing.mulrDr.

under b1 x _ rewrite GRing.mulrDl. (* only b1 is rewritten *)

Undo 1. rewrite /b1.
under b1 x _ rewrite GRing.mulrDl. (* 3 occurrences are rewritten *)

rewrite big_split /=.
by rewrite GRing.addrA.
Qed.

(* A test with a side-condition. *)
Let test2 (n : nat) (R : fieldType) (f : nat -> R) :
  (forall k : 'I_n, f k != 0%R) ->
  (\big[+%R/0%R]_(k < n) (f k / f k) = n%:R)%R.
Proof.
move=> Hneq0.
swap under big ? _ rewrite GRing.divff. (* the bigop variable becomes "i" *)
done.

rewrite big_const cardT /= size_enum_ord /GRing.natmul.
case: {Hneq0} n =>// n.
by rewrite iteropS iterSr GRing.addr0.
Qed.

(* Another test lemma when the bigop appears in some hypothesis *)
Let test3 (n : nat) (R : fieldType) (f : nat -> R) :
  (forall k : 'I_n, f k != 0%R) ->
  (\big[+%R/0%R]_(k < n) (f k / f k) +
  \big[+%R/0%R]_(k < n) (f k / f k) = n%:R + n%:R)%R -> True.
Proof.
move=> Hneq0 H.
set b1 := {2}big in H.
under b1 in H ? _ rewrite GRing.divff. (* only b1 is rewritten *)
done.

Undo 2.
move: H.
under b1 ? _ rewrite GRing.divff.
done.

done.
Qed.

(* A test lemma for [underp] *)
Let testp1 (A : finType) (n : nat) (F : A -> nat) :
  \big[addn/O]_(0 <= k < n)
  \big[addn/O]_(J in {set A} | #|J :&: [set: A]| == k)
  \big[addn/O]_(j in J) F j >= 0.
Proof.
under big k _ underp big J rewrite setIT. (* the bigop variables are kept *)
done.
Qed.

(* A test lemma for [underp...in] *)
Let testp2 (A : finType) (n : nat) (F : A -> nat) :
  \big[addn/O]_(J in {set A} | #|J :&: [set: A]| == 1)
  \big[addn/O]_(j in J) F j = \big[addn/O]_(j in A) F j -> True.
Proof.
move=> H.
underp big in H J rewrite setIT. (* the bigop variable "J" is kept *)
done.
Qed.

End Tests.
 *)


(* Automatically Synthesized by Autosubst. Considered preliminaries **)
From Undecidability.HOU Require Import std.std.
From Undecidability.HOU Require Export unscoped.

Section Terms.

  Inductive type  : Type :=
  | typevar  : nat  -> type
  | arr  : type  -> type  -> type .

  Structure Const :=
  {
    const_type:> Type;
    const_dis: Dis const_type;
    ctype: const_type -> type
  }.

  Context {X: Const}.

Lemma congr_typevar  { s0 : nat  } { t0 : nat  } : s0 = t0 -> typevar s0 = typevar t0 .
Proof. congruence. Qed.

Lemma congr_arr  { s0 : type  } { s1 : type  } { t0 : type  } { t1 : type  } : s0 = t0 -> s1 = t1 -> arr s0 s1 = arr t0 t1 .
Proof. congruence. Qed.

Inductive exp  : Type :=
  | var_exp  : fin  -> exp
  | const  : X  -> exp
  | lam  : exp  -> exp
  | app  : exp  -> exp  -> exp .

Lemma congr_const  { s0 : X  } { t0 : X  } : s0 = t0 -> const  s0 = const  t0 .
Proof. congruence. Qed.

Lemma congr_lam  { s0 : exp  } { t0 : exp  } : s0 = t0 -> lam  s0 = lam  t0 .
Proof. congruence. Qed.

Lemma congr_app  { s0 : exp  } { s1 : exp  } { t0 : exp  } { t1 : exp  } : s0 = t0 -> s1 = t1 -> app  s0 s1 = app  t0 t1 .
Proof. congruence. Qed.

Definition upRen_exp_exp   (xi : fin  -> fin ) : _ :=
  up_ren xi.

Fixpoint ren_exp   (xiexp : fin  -> fin ) (s : exp ) : _ :=
    match s with
    | var_exp  s => (var_exp ) (xiexp s)
    | const  s0 => const  s0
    | lam  s0 => lam  (ren_exp (upRen_exp_exp xiexp) s0)
    | app  s0 s1 => app  (ren_exp xiexp s0) (ren_exp xiexp s1)
    end.

Definition up_exp_exp   (sigma : fin  -> exp ) : _ :=
  scons ((var_exp ) var_zero) (funcomp (ren_exp shift) sigma).

Fixpoint subst_exp   (sigmaexp : fin  -> exp ) (s : exp ) : _ :=
    match s with
    | var_exp  s => sigmaexp s
    | const  s0 => const  s0
    | lam  s0 => lam  (subst_exp (up_exp_exp sigmaexp) s0)
    | app  s0 s1 => app  (subst_exp sigmaexp s0) (subst_exp sigmaexp s1)
    end.

Definition upId_exp_exp  (sigma : fin  -> exp ) (Eq : forall x, sigma x = (var_exp ) x) : forall x, (up_exp_exp sigma) x = (var_exp ) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint idSubst_exp  (sigmaexp : fin  -> exp ) (Eqexp : forall x, sigmaexp x = (var_exp ) x) (s : exp ) : subst_exp sigmaexp s = s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (idSubst_exp (up_exp_exp sigmaexp) (upId_exp_exp (_) Eqexp) s0)
    | app  s0 s1 => congr_app (idSubst_exp sigmaexp Eqexp s0) (idSubst_exp sigmaexp Eqexp s1)
    end.

Definition upExtRen_exp_exp   (xi : fin  -> fin ) (zeta : fin  -> fin ) (Eq : forall x, xi x = zeta x) : forall x, (upRen_exp_exp xi) x = (upRen_exp_exp zeta) x :=
  fun n => match n with
  | S n => ap shift (Eq n)
  | 0 => eq_refl
  end.

Fixpoint extRen_exp   (xiexp : fin  -> fin ) (zetaexp : fin  -> fin ) (Eqexp : forall x, xiexp x = zetaexp x) (s : exp ) : ren_exp xiexp s = ren_exp zetaexp s :=
    match s with
    | var_exp  s => ap (var_exp ) (Eqexp s)
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (extRen_exp (upRen_exp_exp xiexp) (upRen_exp_exp zetaexp) (upExtRen_exp_exp (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (extRen_exp xiexp zetaexp Eqexp s0) (extRen_exp xiexp zetaexp Eqexp s1)
    end.

Definition upExt_exp_exp   (sigma : fin  -> exp ) (tau : fin  -> exp ) (Eq : forall x, sigma x = tau x) : forall x, (up_exp_exp sigma) x = (up_exp_exp tau) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint ext_exp   (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) (Eqexp : forall x, sigmaexp x = tauexp x) (s : exp ) : subst_exp sigmaexp s = subst_exp tauexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (ext_exp (up_exp_exp sigmaexp) (up_exp_exp tauexp) (upExt_exp_exp (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (ext_exp sigmaexp tauexp Eqexp s0) (ext_exp sigmaexp tauexp Eqexp s1)
    end.

Fixpoint compRenRen_exp    (xiexp : fin  -> fin ) (zetaexp : fin  -> fin ) (rhoexp : fin  -> fin ) (Eqexp : forall x, (funcomp zetaexp xiexp) x = rhoexp x) (s : exp ) : ren_exp zetaexp (ren_exp xiexp s) = ren_exp rhoexp s :=
    match s with
    | var_exp  s => ap (var_exp ) (Eqexp s)
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compRenRen_exp (upRen_exp_exp xiexp) (upRen_exp_exp zetaexp) (upRen_exp_exp rhoexp) (up_ren_ren (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compRenRen_exp xiexp zetaexp rhoexp Eqexp s0) (compRenRen_exp xiexp zetaexp rhoexp Eqexp s1)
    end.

Definition up_ren_subst_exp_exp    (xi : fin  -> fin ) (tau : fin  -> exp ) (theta : fin  -> exp ) (Eq : forall x, (funcomp tau xi) x = theta x) : forall x, (funcomp (up_exp_exp tau) (upRen_exp_exp xi)) x = (up_exp_exp theta) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint compRenSubst_exp    (xiexp : fin  -> fin ) (tauexp : fin  -> exp ) (thetaexp : fin  -> exp ) (Eqexp : forall x, (funcomp tauexp xiexp) x = thetaexp x) (s : exp ) : subst_exp tauexp (ren_exp xiexp s) = subst_exp thetaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compRenSubst_exp (upRen_exp_exp xiexp) (up_exp_exp tauexp) (up_exp_exp thetaexp) (up_ren_subst_exp_exp (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compRenSubst_exp xiexp tauexp thetaexp Eqexp s0) (compRenSubst_exp xiexp tauexp thetaexp Eqexp s1)
    end.

Definition up_subst_ren_exp_exp    (sigma : fin  -> exp ) (zetaexp : fin  -> fin ) (theta : fin  -> exp ) (Eq : forall x, (funcomp (ren_exp zetaexp) sigma) x = theta x) : forall x, (funcomp (ren_exp (upRen_exp_exp zetaexp)) (up_exp_exp sigma)) x = (up_exp_exp theta) x :=
  fun n => match n with
  | S n => eq_trans (compRenRen_exp shift (upRen_exp_exp zetaexp) (funcomp shift zetaexp) (fun x => eq_refl) (sigma n)) (eq_trans (eq_sym (compRenRen_exp zetaexp shift (funcomp shift zetaexp) (fun x => eq_refl) (sigma n))) (ap (ren_exp shift) (Eq n)))
  | 0 => eq_refl
  end.

Fixpoint compSubstRen__exp    (sigmaexp : fin  -> exp ) (zetaexp : fin  -> fin ) (thetaexp : fin  -> exp ) (Eqexp : forall x, (funcomp (ren_exp zetaexp) sigmaexp) x = thetaexp x) (s : exp ) : ren_exp zetaexp (subst_exp sigmaexp s) = subst_exp thetaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compSubstRen__exp (up_exp_exp sigmaexp) (upRen_exp_exp zetaexp) (up_exp_exp thetaexp) (up_subst_ren_exp_exp (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compSubstRen__exp sigmaexp zetaexp thetaexp Eqexp s0) (compSubstRen__exp sigmaexp zetaexp thetaexp Eqexp s1)
    end.

Definition up_subst_subst_exp_exp    (sigma : fin  -> exp ) (tauexp : fin  -> exp ) (theta : fin  -> exp ) (Eq : forall x, (funcomp (subst_exp tauexp) sigma) x = theta x) : forall x, (funcomp (subst_exp (up_exp_exp tauexp)) (up_exp_exp sigma)) x = (up_exp_exp theta) x :=
  fun n => match n with
  | S n => eq_trans (compRenSubst_exp shift (up_exp_exp tauexp) (funcomp (up_exp_exp tauexp) shift) (fun x => eq_refl) (sigma n)) (eq_trans (eq_sym (compSubstRen__exp tauexp shift (funcomp (ren_exp shift) tauexp) (fun x => eq_refl) (sigma n))) (ap (ren_exp shift) (Eq n)))
  | 0 => eq_refl
  end.

Fixpoint compSubstSubst_exp    (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) (thetaexp : fin  -> exp ) (Eqexp : forall x, (funcomp (subst_exp tauexp) sigmaexp) x = thetaexp x) (s : exp ) : subst_exp tauexp (subst_exp sigmaexp s) = subst_exp thetaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (compSubstSubst_exp (up_exp_exp sigmaexp) (up_exp_exp tauexp) (up_exp_exp thetaexp) (up_subst_subst_exp_exp (_) (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (compSubstSubst_exp sigmaexp tauexp thetaexp Eqexp s0) (compSubstSubst_exp sigmaexp tauexp thetaexp Eqexp s1)
    end.

Definition rinstInst_up_exp_exp   (xi : fin  -> fin ) (sigma : fin  -> exp ) (Eq : forall x, (funcomp (var_exp ) xi) x = sigma x) : forall x, (funcomp (var_exp ) (upRen_exp_exp xi)) x = (up_exp_exp sigma) x :=
  fun n => match n with
  | S n => ap (ren_exp shift) (Eq n)
  | 0 => eq_refl
  end.

Fixpoint rinst_inst_exp   (xiexp : fin  -> fin ) (sigmaexp : fin  -> exp ) (Eqexp : forall x, (funcomp (var_exp ) xiexp) x = sigmaexp x) (s : exp ) : ren_exp xiexp s = subst_exp sigmaexp s :=
    match s with
    | var_exp  s => Eqexp s
    | const  s0 => congr_const (eq_refl s0)
    | lam  s0 => congr_lam (rinst_inst_exp (upRen_exp_exp xiexp) (up_exp_exp sigmaexp) (rinstInst_up_exp_exp (_) (_) Eqexp) s0)
    | app  s0 s1 => congr_app (rinst_inst_exp xiexp sigmaexp Eqexp s0) (rinst_inst_exp xiexp sigmaexp Eqexp s1)
    end.

Lemma instId_exp  : subst_exp (var_exp ) = id .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun x => idSubst_exp (var_exp ) (fun n => eq_refl) (id x))). Qed.

Lemma varL_exp   (sigmaexp : fin  -> exp ) : funcomp (subst_exp sigmaexp) (var_exp ) = sigmaexp .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun x => eq_refl)). Qed.

Lemma rinstInst_exp   (xiexp : fin  -> fin ) : ren_exp xiexp = subst_exp (funcomp (var_exp ) xiexp) .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun x => rinst_inst_exp xiexp (_) (fun n => eq_refl) x)). Qed.

Lemma compComp_exp    (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) (s : exp ) : subst_exp tauexp (subst_exp sigmaexp s) = subst_exp (funcomp (subst_exp tauexp) sigmaexp) s .
Proof. exact (compSubstSubst_exp sigmaexp tauexp (_) (fun n => eq_refl) s). Qed.

Lemma compComp'_exp    (sigmaexp : fin  -> exp ) (tauexp : fin  -> exp ) : funcomp (subst_exp tauexp) (subst_exp sigmaexp) = subst_exp (funcomp (subst_exp tauexp) sigmaexp) .
Proof. exact (FunctionalExtensionality.functional_extensionality _ _ (fun n => compComp_exp sigmaexp tauexp n)). Qed.

End Terms.

(* CUSTOM CHANGES *)
Definition beta {X} (s: exp) (t: exp) := @subst_exp X (t .: var_exp) s.
#[export] Hint Rewrite @instId_exp @rinstInst_exp @compComp_exp @compComp'_exp @varL_exp : asimpl.
#[export] Hint Unfold beta upRen_exp_exp up_exp_exp : asimpl.

Ltac asimpl := autounfold with asimpl; autorewrite with asimpl using (cbn [subst_exp ren_exp]; fsimpl).
Tactic Notation "asimpl" "in" hyp(J) :=
  autounfold with asimpl in J; autorewrite with asimpl in J using (cbn [subst_exp ren_exp] in J; fsimplin J).


(** CS6225 Spring 20 @ IITM : PSet 9 -- 90 points *)

(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 10 *)

Require Import Frap.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu)
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

Set Implicit Arguments.

(** * Hoare Logic with Input/Output Traces *)

(* Hoare logic as covered in lecture is only the beginning, so far as
 * programming features that can be supported. In this problem set, we
 * will implement one of variant, a Hoare logic that deals with
 * input/output traces.
 *
 * As we learned in compiler verification, behaviors of a program can be
 * defined as sequences of communications with the outside world. Hoare logic
 * certainly can be used for proving properties about program behaviors.
 * Besides valuation and heap, we will need to keep track of traces of a program
 * to ensure the properties we want, sometimes by proving invariants in the
 * middle of the program.
 *
 * The problem set consists of 4 tasks; basically we ask you to formally prove
 * the correctness of some programs using Hoare logic:
 * 1) To design a big-step operational semantics of the given language.
 * 2) To define a Hoare logic for the language, and to prove the consistency
 *    between the semantics and the logic.
 * 3) To verify three example programs we provide, using Hoare logic.
 * 4) To design your own interesting program and to verify it.
 *)

(** * Language syntax *)

(* There is nothing special with the definitions of [exp] and [bexp]; they are
 * exactly same as we've seen in the lecture.
 *)
Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Mult (e1 e2 : exp).

Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp).

(* [heap] and [valuation] are also as usual. *)
Definition heap := fmap nat nat.
Definition valuation := fmap var nat.

(* Besides [heap] and [valuation], we have one more component to verify using
 * Hoare logic, called [io]. We keep track of inputs and outputs of a certain
 * program, regarding them as meaningful communication with the outside world.
 * When a program is executed, it generates [trace], which is a list of [io]s,
 * meaning inputs and outputs that occurred during the execution. Traces are
 * also called behaviors of a program.
 *)
Inductive io := In (v : nat) | Out (v : nat).
Definition trace := list io.

(* We now have two types of assertions: [iassertion] is used only for asserting
 * properties of internal states. [assertion] can be used for asserting
 * properties of [trace]s as well as internal states.
 *)
Definition iassertion := heap -> valuation -> Prop.
Definition assertion := trace -> heap -> valuation -> Prop.

(* [cmd] has more constructors than what we've seen.  The new ones are called
 * [Input] and [Output]. As expected, semantically they generates [io]s,
 * eventually forming a [trace] of a program.
 *)
Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)

| Assert (a : iassertion) (* Note that we are using [iassertion], not
                           * [assertion], for [Assert]. While [valuation] and
                           * [heap] are internal states directly manipulated by
                           * a program, [trace] is rather an abstract notion for
                           * defining a behavior of a program.
                           *)

(* The new constructors are below! *)
| Input (x : var) (* [Input] takes an input from the external world and assigns
                   * the value to the local variable [x].
                   *)
| Output (e : exp). (* [Output] prints the value of [e]. *)

(** We here provide fancy notations for our language. *)

Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Notation "*[ e ]" := (Read e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Mult : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" :=
  (If_ b then_ else_) (at level 75, b at level 0) : cmd_scope.
Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75) : cmd_scope.
Notation "'assert' {{ I }}" := (Assert I) (at level 75) : cmd_scope.
Notation "x '<--' 'input'" := (Input x) (at level 75) : cmd_scope.
Notation "'output' e" := (Output e) (at level 75) : cmd_scope.
Delimit Scope cmd_scope with cmd.

Infix "+" := plus : reset_scope.
Infix "-" := Init.Nat.sub : reset_scope.
Infix "*" := mult : reset_scope.
Infix "=" := eq : reset_scope.
Infix "<" := lt : reset_scope.
Delimit Scope reset_scope with reset.
Open Scope reset_scope.

(** * Task 1: A big-step operational semantics for commands *)

(* Your first task is to define a big-step operational semantics for commands.
 * While it should be very similar to what we've seen in class, it should
 * also represent something about [io]s (or [trace]). Make sure the semantics
 * captures the effects of [Input]/[Output] on [trace]s. The most
 * recent event should appear at the *front* of the list in the trace.
 *
 * We provide the signature of the big-step semantics below. Replace the
 * [Axiom] below with your own definition of the semantics.
 * The first three arguments are the trace, heap, and valuation before execution,
 * and the final three arguments are the trace, heap, and valuation after execution.
 *)

(** * Define your semantics here! *)

(* 10 points *)
Axiom exec : trace -> heap -> valuation -> cmd ->
             trace -> heap -> valuation -> Prop.

(** * Task 2 : Hoare logic *)

(* We also ask you to define a Hoare logic for our language. The logic should
 * derive triples of the form {{ P }} c {{ Q }}, where "P" and "Q" have type
 * [assertion] and "c" has type [cmd]. It should be also very similar to the
 * Hoare logic we've defined in class.
 *)

(* The logic should be consistent with the semantics you defined, so we
 * also ask you to prove a soundness relation between your Hoare logic and your
 * semantics.  You will need this consistency to prove the correctness of
 * example programs we will provide soon.
 *)

(** Task 2-1: Define your Hoare logic here! *)

(* 10 points *)
Axiom hoare_triple : assertion -> cmd -> assertion -> Prop.

Notation "[[ tr , h , v ]] ~> e" := (fun tr h v => e%reset) (at level 90).
Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c%cmd Q) (at level 90, c at next level).

(** Task 2-2: Prove the consistency theorem. *)

(* 10 points *)
Theorem hoare_triple_big_step :
  forall pre c post,
    hoare_triple pre c post ->
    forall tr h v tr' h' v',
      exec tr h v c tr' h' v' ->
      pre tr h v -> post tr' h' v'.
Proof.
Admitted.

(** * Task 3: Verification of some example programs *)

(* Now it's time to verify programs using the Hoare logic you've just defined!
 * We provide three example programs and three corresponding correctness
 * theorems. You are required to prove the theorems stated below using Hoare
 * logic.
 *)

(** Task 3-1: adding two inputs -- prove [add_two_inputs_ok] *)

Example add_two_inputs :=
  ("x" <-- input;;
   "y" <-- input;;
   output ("x" + "y"))%cmd.

(* 10 points *)
Theorem add_two_inputs_ok:
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
Admitted.

(** Task 3-2: finding the maximum of three numbers -- prove [max3_ok] *)

Example max3 :=
  ("x" <-- input;;
   "y" <-- input;;
   "z" <-- input;;
   when "x" < "y" then
     when "y" < "z" then
       output "z"
     else
       output "y"
     done
   else
     when "x" < "z" then
       output "z"
     else
       output "x"
     done
   done)%cmd.

(* 10 points *)
Inductive max3_spec : trace -> Prop :=
| M3s: forall x y z mx,
    mx >= x ->
    mx >= y ->
    mx >= z ->
    (mx = x \/ mx = y \/ mx = z) ->
    max3_spec [Out mx; In z; In y; In x].

Theorem max3_ok:
  forall tr h v tr' h' v',
    exec tr h v max3 tr' h' v' ->
    tr = nil ->
    max3_spec tr'.
Proof.
Admitted.

(** Task 3-3: Fibonacci sequence -- prove [fibonacci_ok] *)

Inductive fibonacci_spec : trace -> Prop :=
| Fs0: fibonacci_spec nil
| Fs1: fibonacci_spec [Out 1]
| Fs2: fibonacci_spec [Out 1; Out 1]
| Fsn:
    forall x y tr,
      fibonacci_spec (Out y :: Out x :: tr) ->
      fibonacci_spec (Out (x + y) :: Out y :: Out x :: tr).

(* 20 points *)
Example fibonacci (n: nat) :=
  ("cnt" <- 0;;
   "x" <- 0;;
   "y" <- 1;;
   output "y";;
   {{ fun _ _ _ => True }} (* You may change this loop invariant to make your
                            * proof easier! *)
   while "cnt" < n loop
     "tmp" <- "y";;
     "y" <- "x" + "y";;
     "x" <- "tmp";;
     "cnt" <- "cnt" + 1;;
     output "y"
   done)%cmd.

Theorem fibonacci_ok (n: nat):
  forall tr h v tr' h' v',
    exec tr h v (fibonacci n) tr' h' v' ->
    tr = nil ->
    fibonacci_spec tr'.
Proof.
Admitted.

(** * Task 4: Implement your own program to verify. *)

(* The last task is to implement your own program and to verify its correctness
 * using Hoare logic. Note that the three examples we provided above had nothing
 * to do with [heap]s. Design a program that uses the heap and loops in a nontrivial
 * manner and prove its correctness.
 *)

(* 20 points *)

(** Define your own program and prove its correctness here! *)


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable out_ : Universe -> Universe -> Universe -> Prop.
Variable lt_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable congA_ : Universe -> Universe -> Universe -> Universe -> Universe -> Universe -> Prop.
Variable cong_ : Universe -> Universe -> Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.
Variable betS_ : Universe -> Universe -> Universe -> Prop.

Variable lemma_equalanglesNC_1 : (forall A B C Xa Xb Xc : Universe, (congA_ A B C Xa Xb Xc -> ~(col_ Xa Xb Xc))).
Variable defequalangles_2 : (forall A B C Ca Cb Cc : Universe, (exists U V Su Sv : Universe, (congA_ A B C Ca Cb Cc -> (out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C))))))))))).
Variable defequalangles2_3 : (forall A B C Ca Cb Cc U V Su Sv : Universe, ((out_ B A U /\ (out_ B C V /\ (out_ Cb Ca Su /\ (out_ Cb Cc Sv /\ (cong_ B U Cb Su /\ (cong_ B V Cb Sv /\ (cong_ U V Su Sv /\ ~(col_ A B C)))))))) -> congA_ A B C Ca Cb Cc)).
Variable lemma_ray2_4 : (forall A B C : Universe, (out_ A B C -> A <> B)).
Variable lemma_inequalitysymmetric_5 : (forall A B : Universe, (A <> B -> B <> A)).
Variable lemma_collinearorder_6 : (forall A B C : Universe, (col_ A B C -> (col_ B A C /\ (col_ B C A /\ (col_ C A B /\ (col_ A C B /\ col_ C B A)))))).
Variable defcollinear_7 : (forall A B C : Universe, (col_ A B C -> (A = B \/ (A = C \/ (B = C \/ (betS_ B A C \/ (betS_ A B C \/ betS_ A C B))))))).
Variable defcollinear2a_8 : (forall A B C : Universe, (A = B -> col_ A B C)).
Variable defcollinear2b_9 : (forall A B C : Universe, (A = C -> col_ A B C)).
Variable defcollinear2c_10 : (forall A B C : Universe, (B = C -> col_ A B C)).
Variable defcollinear2d_11 : (forall A B C : Universe, (betS_ B A C -> col_ A B C)).
Variable defcollinear2e_12 : (forall A B C : Universe, (betS_ A B C -> col_ A B C)).
Variable defcollinear2f_13 : (forall A B C : Universe, (betS_ A C B -> col_ A B C)).
Variable lemma_ray1_14 : (forall A B P : Universe, (out_ A B P -> (betS_ A P B \/ (B = P \/ betS_ A B P)))).
Variable cn_congruencereflexive_15 : (forall A B : Universe, cong_ A B A B).
Variable deflessthan_16 : (forall A B C D : Universe, (exists X : Universe, (lt_ A B C D -> (betS_ C X D /\ cong_ C X A B)))).
Variable deflessthan2_17 : (forall A B C D X : Universe, ((betS_ C X D /\ cong_ C X A B) -> lt_ A B C D)).
Variable lemma_lessthancongruence_18 : (forall A B C D E F : Universe, ((lt_ A B C D /\ cong_ C D E F) -> lt_ A B E F)).
Variable lemma_congruencetransitive_19 : (forall A B C D E F : Universe, ((cong_ A B C D /\ cong_ C D E F) -> cong_ A B E F)).
Variable lemma_betweennotequal_20 : (forall A B C : Universe, (betS_ A B C -> (B <> C /\ (A <> B /\ A <> C)))).
Variable lemma_ray4_1_21 : (forall A B E : Universe, ((betS_ A E B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_2_22 : (forall A B E : Universe, ((E = B /\ A <> B) -> out_ A B E)).
Variable lemma_ray4_3_23 : (forall A B E : Universe, ((betS_ A B E /\ A <> B) -> out_ A B E)).
Variable lemma_layoffunique_24 : (forall A B C D : Universe, ((out_ A B C /\ (out_ A B D /\ cong_ A C A D)) -> C = D)).
Variable lemma_differenceofparts_25 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (betS_ A B C /\ betS_ Xa Xb Xc))) -> cong_ B C Xb Xc)).
Variable axiom_5_line_26 : (forall A B C D E F G H : Universe, ((betS_ A B C /\ (betS_ E F G /\ (cong_ B C F G /\ (cong_ A D E H /\ (cong_ B D F H /\ cong_ A B E F))))) -> cong_ D C H G)).
Variable lemma_congruenceflip_27 : (forall A B C D : Universe, (cong_ A B C D -> (cong_ B A D C /\ (cong_ B A C D /\ cong_ A B D C)))).
Variable lemma_congruencesymmetric_28 : (forall A B C D : Universe, (cong_ B C A D -> cong_ A D B C)).
Variable lemma_partnotequalwhole_29 : (forall A B C : Universe, (betS_ A B C -> ~(cong_ A B A C))).
Variable lemma_ray5_30 : (forall A B C : Universe, (out_ A B C -> out_ A C B)).
Variable lemma_ray3_31 : (forall B C D V : Universe, ((out_ B C D /\ out_ B C V) -> out_ B D V)).
Variable lemma_betweennesspreserved_32 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ (cong_ B C Xb Xc /\ betS_ A B C))) -> betS_ Xa Xb Xc)).
Variable lemma_interior5_33 : (forall A B C D Xa Xb Xc Xd : Universe, ((betS_ A B C /\ (betS_ Xa Xb Xc /\ (cong_ A B Xa Xb /\ (cong_ B C Xb Xc /\ (cong_ A D Xa Xd /\ cong_ C D Xc Xd))))) -> cong_ B D Xb Xd)).

Theorem proposition_04_34 : (forall A B C Xa Xb Xc : Universe, ((cong_ A B Xa Xb /\ (cong_ A C Xa Xc /\ congA_ B A C Xb Xa Xc)) -> (cong_ B C Xb Xc /\ (congA_ A B C Xa Xb Xc /\ congA_ A C B Xa Xc Xb)))).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.

                    From adtind Require Import goal19.

 Require Import Extraction.
 Extract Inductive nat => nat [ "(O)" "S" ].
 Extract Inductive list => list [ "Nil" "Cons" ].
Definition lfind_example_1  := ( Cons (Succ Zero) Nil).
Definition lfind_example_2  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_3  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_4  := ( Cons Zero         (Cons (Succ Zero)            (Cons (Succ Zero)               (Cons (Succ Zero)                  (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)))))).
Definition lfind_example_5  := ( Cons (Succ Zero) (Cons Zero Nil)).
Definition lfind_example_6  := ( Cons (Succ Zero) (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil))).
Definition lfind_example_7  := ( Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) Nil)).
Definition lfind_example_8  := ( Cons (Succ (Succ (Succ (Succ Zero)))) Nil).
Definition lfind_example_9  := ( Cons Zero (Cons (Succ Zero) (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_10  := ( Cons Zero         (Cons Zero            (Cons Zero (Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero Nil)))))).
Definition lfind_example_11  := ( Cons Zero Nil).
Definition lfind_example_12  := ( Cons (Succ (Succ Zero)) Nil).
Definition lfind_example_13  := ( Cons Zero (Cons (Succ Zero) Nil)).
Definition lfind_example_14  := ( Cons Zero (Cons Zero (Cons (Succ Zero) (Cons Zero Nil)))).
Definition lfind_example_15  := ( Cons Zero         (Cons (Succ (Succ Zero))            (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons (Succ Zero) Nil)))).
Definition lfind_example_16  := ( Cons Zero (Cons Zero Nil)).
Definition lfind_example_17  := ( Cons (Succ (Succ Zero)) (Cons Zero (Cons Zero (Cons Zero Nil)))).
Definition lfind_example_18  := ( Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)).
Definition lfind_example_19  := ( Cons (Succ Zero) Nil).
Definition lfind_example_20  := ( Cons Zero (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)))).
Definition lfind_example_21  := ( Cons Zero (Cons (Succ Zero) (Cons Zero (Cons Zero (Cons Zero Nil))))).
Definition lfind_example_22  := ( Cons Zero Nil).
Definition lfind_example_23  := ( Cons Zero (Cons (Succ (Succ Zero)) Nil)).
Definition lfind_example_24  := ( Cons (Succ Zero) (Cons Zero (Cons Zero Nil))).
Definition lfind_example_25  := ( Nil).

                    Extraction "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal19_theorem0_40_lem2/lfind_extraction.ml" lfind_example_1 lfind_example_2 lfind_example_3 lfind_example_4 lfind_example_5 lfind_example_6 lfind_example_7 lfind_example_8 lfind_example_9 lfind_example_10 lfind_example_11 lfind_example_12 lfind_example_13 lfind_example_14 lfind_example_15 lfind_example_16 lfind_example_17 lfind_example_18 lfind_example_19 lfind_example_20 lfind_example_21 lfind_example_22 lfind_example_23 lfind_example_24 lfind_example_25 .


Require Import Coqingbird.Chapter_9.

Definition bluebird B := forall x y z, B $ x $ y $ z = x $ (y $ z).

Theorem Problem_1 :
  forall B, bluebird B ->
            forall C D, exists E, composes C D E.
Proof.
  intros.
  exists (B $ C $ D).
  congruence.
Qed.

Theorem Problem_2 :
  forall B, bluebird B ->
            forall M, mockingbird M ->
                      forall x, exists Yx, fond x Yx.
Proof.
  (*Yx = M(x.M) = M(BxM)*)
  intros.
  exists (M $ (B $ x $ M)).
  congruence.
Qed.

Theorem Problem_3 :
  forall B, bluebird B -> forall M, mockingbird M ->
            exists E, egocentric E.
Proof.
  (*E = M(M.M) = M(BMM)*)
  intros.
  exists (M $ (B $ M $ M)).
  congruence.
Qed.

Theorem Problem_4 :
  forall B, bluebird B -> forall M, mockingbird M -> forall K, kestrel K ->
            exists HE, hopelessly_egocentric HE.
Proof.
  intros.
  exists (M $ (B $ K $ M)).
  congruence.
Qed.

Definition dove D := forall x y z w, D $ x $ y $ z $ w = x $ y $ (z $ w).

Theorem Problem_5 :
  forall B, bluebird B -> exists D, dove D.
Proof.
  intros.
  exists (B $ B).
  congruence.
Qed.

Definition blackbird B1 := forall x y z w, B1 $ x $ y $ z $ w = x $ (y $ z $ w).

Theorem Problem_6 :
  forall B, bluebird B -> exists B1, blackbird B1.
Proof.
  intros.
  exists (B $ B $ B).
  congruence.
Qed.

Definition eagle E := forall x y z w v, E $ x $ y $ z $ w $ v = x $ y $ (z $ w $ v).

Theorem Problem_7 :
  forall B, bluebird B -> exists E, eagle E.
Proof.
  intros.
  exists (B $ (B $ B $ B)).
  congruence.
Qed.

Definition bunting B2 := forall x y z w v, B2 $ x $ y $ z $ w $ v = x $ (y $ z $ w $ v).

Theorem Problem_8 :
  forall B, bluebird B -> exists B2, bunting B2.
Proof.
  intros.
  exists (B $ B $ (B $ B $ B)).
  congruence.
Qed.

Definition bunting' B2' := forall x y z w v u, B2' $ x $ y $ z $ w $ v $ u = x $ (y $ z $ w $ v $ u).

Theorem generalized_bunting :
  forall B, bluebird B -> exists B2', bunting' B2'.
Proof.
  intros.
  exists (B $ B $ (B $ B $ (B $ B $ B))).
  congruence.
Qed.

Definition dickcissel D1 := forall x y z w v, D1 $ x $ y $ z $ w $ v = x $ y $ z $ (w $ v).

Theorem Problem_9 :
  forall B, bluebird B -> exists D1, dickcissel D1.
Proof.
  intros.
  exists (B $ (B $ B)).
  congruence.
Qed.

Definition becard B3 := forall x y z w, B3 $ x $ y $ z $ w = x $ (y $ (z $ w)).

Theorem Problem_10 :
  forall B, bluebird B -> exists B3, becard B3.
Proof.
  intros.
  exists (B $ (B $ B) $ B).
  congruence.
Qed.

Definition dovekie D2 := forall x y z w v, D2 $ x $ y $ z $ w $ v = x $ (y $ z) $ (w $ v).

Theorem Problem_11 :
  forall B, bluebird B -> exists D2, dovekie D2.
Proof.
  intros.
  exists (B $ (B $ (B $ B)) $ B).
  congruence.
Qed.

Definition bald_eagle Ê := forall x y1 y2 y3 z1 z2 z3, Ê $ x $ y1 $ y2 $ y3 $ z1 $ z2 $ z3 = x $ (y1 $ y2 $ y3) $ (z1 $ z2 $ z3).

Lemma compose0 a b c :
  a = b ->
  a $ c = b $ c.
Proof.
  congruence.
Qed.

Lemma compose1 B a b c d :
  bluebird B ->
  a = B $ b $ c $ d ->
  a = b $ (c $ d).
Proof.
  congruence.
Qed.

Hint Resolve compose0 : compositor.
Hint Resolve compose1 : compositor.

Theorem Problem_12 :
  forall B, bluebird B -> exists Ê, bald_eagle Ê.
Proof.
  unfold bald_eagle.
  eauto 15 with compositor.
Qed.

Definition warbler W := forall x y, W $ x $ y = x $ y $ y.

Theorem Problem_14 :
  forall W I, warbler W -> identity I -> exists M, mockingbird M.
Proof.
  intros.
  exists (W $ I).
  congruence.
Qed.

Theorem Problem_15 :
  forall W K, warbler W -> kestrel K -> exists I, identity I.
Proof.
  intros.
  exists (W $ K).
  congruence.
Qed.

Theorem Problem_13 :
  forall W K, warbler W -> kestrel K -> exists M, mockingbird M.
Proof.
  (*Yes, the proof of this comes after Problems 14 and 15.*)
  intros.
  assert (exists I, identity I).
  eapply Problem_15.
  eassumption.
  eassumption.
  inversion H1.
  eapply Problem_14.
  eassumption.
  eassumption.
Qed.

Definition cardinal C := forall x y z, C $ x $ y $ z = x $ z $ y.

Theorem Problem_16 :
  forall C K, cardinal C -> kestrel K -> exists I, identity I.
Proof.
  intros.
  exists (C $ K $ K).
  congruence.
Qed.

Definition thrush T := forall x y, T $ x $ y = y $ x.

Lemma identity_hint I a b :
  identity I ->
  a = I $ b ->
  a = b.
Proof.
  congruence.
Qed.

Lemma identity_hint2 I a b c :
  identity I ->
  a = I $ b $ c ->
  a = b $ c.
Proof.
  congruence.
Qed.

Lemma kestrel_hint K a b c :
  kestrel K ->
  a = K $ b $ c ->
  a = b.
Proof.
  congruence.
Qed.

Lemma cardinal_hint C a b c d:
  cardinal C ->
  a = C $ b $ c $ d ->
  a = b $ d $ c.
Proof.
  congruence.
Qed.

Lemma apply_hint a b c d :
  a = b ->
  c = d ->
  a $ c = b $ d.
Proof.
  congruence.
Qed.

Hint Resolve identity_hint : bird_hints.
Hint Resolve identity_hint2 : bird_hints.
Hint Resolve kestrel_hint : bird_hints.
Hint Resolve cardinal_hint : bird_hints.
Hint Resolve apply_hint : bird_hints.

Theorem Problem_17 :
  forall C I, cardinal C -> identity I -> exists T, thrush T.
Proof.
  unfold thrush.
  eauto with bird_hints.
Qed.

(*Print Problem_17.*)

Theorem Problem_18 :
  forall T, thrush T -> (forall B, exists B', fond B B') -> exists A, forall x, A $ x = x $ A.
Proof.
  intros.
  destruct H0 with T as [E].
  exists E.
  congruence.
Qed.

Lemma mockingbird_hint M x x' a :
  mockingbird M ->
  a = M $ x ->
  x = x' ->
  a = x' $ x.
Proof.
  congruence.
Qed.

Lemma thrush_hint T x y a :
  thrush T ->
  a = T $ x $ y ->
  a = y $ x.
Proof.
  congruence.
Qed.

Hint Resolve mockingbird_hint : bird_hints.
Hint Resolve thrush_hint : bird_hints.
Hint Resolve compose1 : bird_hints.

Theorem Problem_19 :
  forall B T M, bluebird B -> thrush T -> mockingbird M ->
                exists A, forall x, A $ x = x $ A.
Proof.
  intros.
  exists (M $ (B $ T $ M)).
  congruence.
Qed.

(*end*)


From Coq Require Import ZArith Znumtheory Lia Psatz List Bool.
From Coqtail Require Import Zprime MillerRabin.

Import ListNotations.
Open Scope Z_scope.

(** Checking naively for <= 1373652 would take a few hours, so we
    split the computation *)

Lemma MR_range_split l a b c : a <= b <= c -> MR_range l a c = MR_range l a b && MR_range l (1 + b) c.
Proof.
  intros abc.
  apply eq_true_iff_eq.
  rewrite andb_true_iff.
  rewrite 3 MR_range_spec.
  split.
  - intros ac; split; intros n bn; apply ac; lia.
  - intros [ab bc]; intros n bn. destruct (Z_lt_ge_dec n (1 + b)). apply ab; lia. apply bc; lia.
Qed.

Lemma MR_range_split' l a b c : a <= b <= c -> MR_range l a b = true -> MR_range l (1 + b) c = true -> MR_range l a c = true.
Proof.
  intros abc.
  rewrite (MR_range_split _ a b c); auto.
  now intros -> ->.
Qed.

(** First technique to parallelize computation: using "par:" *)

Local Ltac halve :=
  match goal with
    |- MR_range ?l ?a ?b = true =>
    pose (c := (a + b) / 2);
    vm_compute in c;
    apply (MR_range_split' l a c); [ easy | | simpl "+" ]; subst c
  end.

Lemma miller_rabin_2_3_par n : n <= 100000 -> miller_rabin [2; 3] n = primeb n.
Proof.
  apply MR_range_spec_2.
  (* Time native_compute. (* 48 secs *) reflexivity. *)

  halve; halve; halve; halve; halve.
Abort.
(*
  Time par: abstract (native_compute; reflexivity). (* 80 seconds : more ! *)
Qed. (* instant, when using abstract, but the Qed work is done sequentially anyway, it seems. *)
*)

(* Same for 1373652, note that the speed up is always less that 2 because of the Qed or abstract

Lemma miller_rabin_2_3_1373652_par n : n <= 1373652 -> miller_rabin [2; 3] n = primeb n.
Proof.
  apply MR_range_spec_2.
  halve; halve; halve; halve; halve; halve. (* 64 subgoals *)
  (* Time par: native_compute; reflexivity. (* 533 seconds -- njobs=8 *) *)
  Time par: abstract (native_compute; reflexivity). (* 2110 seconds ~= 533+1700 *)
Time Qed. (* 1700 seconds (0.2 with abstract) *)
*)

(** Other technique using async proofs (only coqc and coqide, the
    standard proof general is not there yet AFAIK)

To activate, be sure those lines are in your _CoqProject. This should
activate 8 threads for coqide and when make runs coqc.

-arg -async-proofs
-arg on
-arg -async-proofs-j
-arg 8

*)

Definition max := 1373652.
Definition d := max / 99.
Definition part n := MR_range [2; 3] (d * n) (Z.min max (d * n + d - 1)) = true.

Lemma M00 : part 00. Proof using. abstract (native_compute; idtac "00 done"; reflexivity). Qed.
Lemma M01 : part 01. Proof using. abstract (native_compute; idtac "01 done"; reflexivity). Qed.
Lemma M02 : part 02. Proof using. abstract (native_compute; idtac "02 done"; reflexivity). Qed.
Lemma M03 : part 03. Proof using. abstract (native_compute; idtac "03 done"; reflexivity). Qed.
Lemma M04 : part 04. Proof using. abstract (native_compute; idtac "04 done"; reflexivity). Qed.
Lemma M05 : part 05. Proof using. abstract (native_compute; idtac "05 done"; reflexivity). Qed.
Lemma M06 : part 06. Proof using. abstract (native_compute; idtac "06 done"; reflexivity). Qed.
Lemma M07 : part 07. Proof using. abstract (native_compute; idtac "07 done"; reflexivity). Qed.
Lemma M08 : part 08. Proof using. abstract (native_compute; idtac "08 done"; reflexivity). Qed.
Lemma M09 : part 09. Proof using. abstract (native_compute; idtac "09 done"; reflexivity). Qed.
Lemma M10 : part 10. Proof using. abstract (native_compute; idtac "10 done"; reflexivity). Qed.
Lemma M11 : part 11. Proof using. abstract (native_compute; idtac "11 done"; reflexivity). Qed.
Lemma M12 : part 12. Proof using. abstract (native_compute; idtac "12 done"; reflexivity). Qed.
Lemma M13 : part 13. Proof using. abstract (native_compute; idtac "13 done"; reflexivity). Qed.
Lemma M14 : part 14. Proof using. abstract (native_compute; idtac "14 done"; reflexivity). Qed.
Lemma M15 : part 15. Proof using. abstract (native_compute; idtac "15 done"; reflexivity). Qed.
Lemma M16 : part 16. Proof using. abstract (native_compute; idtac "16 done"; reflexivity). Qed.
Lemma M17 : part 17. Proof using. abstract (native_compute; idtac "17 done"; reflexivity). Qed.
Lemma M18 : part 18. Proof using. abstract (native_compute; idtac "18 done"; reflexivity). Qed.
Lemma M19 : part 19. Proof using. abstract (native_compute; idtac "19 done"; reflexivity). Qed.
Lemma M20 : part 20. Proof using. abstract (native_compute; idtac "20 done"; reflexivity). Qed.
Lemma M21 : part 21. Proof using. abstract (native_compute; idtac "21 done"; reflexivity). Qed.
Lemma M22 : part 22. Proof using. abstract (native_compute; idtac "22 done"; reflexivity). Qed.
Lemma M23 : part 23. Proof using. abstract (native_compute; idtac "23 done"; reflexivity). Qed.
Lemma M24 : part 24. Proof using. abstract (native_compute; idtac "24 done"; reflexivity). Qed.
Lemma M25 : part 25. Proof using. abstract (native_compute; idtac "25 done"; reflexivity). Qed.
Lemma M26 : part 26. Proof using. abstract (native_compute; idtac "26 done"; reflexivity). Qed.
Lemma M27 : part 27. Proof using. abstract (native_compute; idtac "27 done"; reflexivity). Qed.
Lemma M28 : part 28. Proof using. abstract (native_compute; idtac "28 done"; reflexivity). Qed.
Lemma M29 : part 29. Proof using. abstract (native_compute; idtac "29 done"; reflexivity). Qed.
Lemma M30 : part 30. Proof using. abstract (native_compute; idtac "30 done"; reflexivity). Qed.
Lemma M31 : part 31. Proof using. abstract (native_compute; idtac "31 done"; reflexivity). Qed.
Lemma M32 : part 32. Proof using. abstract (native_compute; idtac "32 done"; reflexivity). Qed.
Lemma M33 : part 33. Proof using. abstract (native_compute; idtac "33 done"; reflexivity). Qed.
Lemma M34 : part 34. Proof using. abstract (native_compute; idtac "34 done"; reflexivity). Qed.
Lemma M35 : part 35. Proof using. abstract (native_compute; idtac "35 done"; reflexivity). Qed.
Lemma M36 : part 36. Proof using. abstract (native_compute; idtac "36 done"; reflexivity). Qed.
Lemma M37 : part 37. Proof using. abstract (native_compute; idtac "37 done"; reflexivity). Qed.
Lemma M38 : part 38. Proof using. abstract (native_compute; idtac "38 done"; reflexivity). Qed.
Lemma M39 : part 39. Proof using. abstract (native_compute; idtac "39 done"; reflexivity). Qed.
Lemma M40 : part 40. Proof using. abstract (native_compute; idtac "40 done"; reflexivity). Qed.
Lemma M41 : part 41. Proof using. abstract (native_compute; idtac "41 done"; reflexivity). Qed.
Lemma M42 : part 42. Proof using. abstract (native_compute; idtac "42 done"; reflexivity). Qed.
Lemma M43 : part 43. Proof using. abstract (native_compute; idtac "43 done"; reflexivity). Qed.
Lemma M44 : part 44. Proof using. abstract (native_compute; idtac "44 done"; reflexivity). Qed.
Lemma M45 : part 45. Proof using. abstract (native_compute; idtac "45 done"; reflexivity). Qed.
Lemma M46 : part 46. Proof using. abstract (native_compute; idtac "46 done"; reflexivity). Qed.
Lemma M47 : part 47. Proof using. abstract (native_compute; idtac "47 done"; reflexivity). Qed.
Lemma M48 : part 48. Proof using. abstract (native_compute; idtac "48 done"; reflexivity). Qed.
Lemma M49 : part 49. Proof using. abstract (native_compute; idtac "49 done"; reflexivity). Qed.
Lemma M50 : part 50. Proof using. abstract (native_compute; idtac "50 done"; reflexivity). Qed.
Lemma M51 : part 51. Proof using. abstract (native_compute; idtac "51 done"; reflexivity). Qed.
Lemma M52 : part 52. Proof using. abstract (native_compute; idtac "52 done"; reflexivity). Qed.
Lemma M53 : part 53. Proof using. abstract (native_compute; idtac "53 done"; reflexivity). Qed.
Lemma M54 : part 54. Proof using. abstract (native_compute; idtac "54 done"; reflexivity). Qed.
Lemma M55 : part 55. Proof using. abstract (native_compute; idtac "55 done"; reflexivity). Qed.
Lemma M56 : part 56. Proof using. abstract (native_compute; idtac "56 done"; reflexivity). Qed.
Lemma M57 : part 57. Proof using. abstract (native_compute; idtac "57 done"; reflexivity). Qed.
Lemma M58 : part 58. Proof using. abstract (native_compute; idtac "58 done"; reflexivity). Qed.
Lemma M59 : part 59. Proof using. abstract (native_compute; idtac "59 done"; reflexivity). Qed.
Lemma M60 : part 60. Proof using. abstract (native_compute; idtac "60 done"; reflexivity). Qed.
Lemma M61 : part 61. Proof using. abstract (native_compute; idtac "61 done"; reflexivity). Qed.
Lemma M62 : part 62. Proof using. abstract (native_compute; idtac "62 done"; reflexivity). Qed.
Lemma M63 : part 63. Proof using. abstract (native_compute; idtac "63 done"; reflexivity). Qed.
Lemma M64 : part 64. Proof using. abstract (native_compute; idtac "64 done"; reflexivity). Qed.
Lemma M65 : part 65. Proof using. abstract (native_compute; idtac "65 done"; reflexivity). Qed.
Lemma M66 : part 66. Proof using. abstract (native_compute; idtac "66 done"; reflexivity). Qed.
Lemma M67 : part 67. Proof using. abstract (native_compute; idtac "67 done"; reflexivity). Qed.
Lemma M68 : part 68. Proof using. abstract (native_compute; idtac "68 done"; reflexivity). Qed.
Lemma M69 : part 69. Proof using. abstract (native_compute; idtac "69 done"; reflexivity). Qed.
Lemma M70 : part 70. Proof using. abstract (native_compute; idtac "70 done"; reflexivity). Qed.
Lemma M71 : part 71. Proof using. abstract (native_compute; idtac "71 done"; reflexivity). Qed.
Lemma M72 : part 72. Proof using. abstract (native_compute; idtac "72 done"; reflexivity). Qed.
Lemma M73 : part 73. Proof using. abstract (native_compute; idtac "73 done"; reflexivity). Qed.
Lemma M74 : part 74. Proof using. abstract (native_compute; idtac "74 done"; reflexivity). Qed.
Lemma M75 : part 75. Proof using. abstract (native_compute; idtac "75 done"; reflexivity). Qed.
Lemma M76 : part 76. Proof using. abstract (native_compute; idtac "76 done"; reflexivity). Qed.
Lemma M77 : part 77. Proof using. abstract (native_compute; idtac "77 done"; reflexivity). Qed.
Lemma M78 : part 78. Proof using. abstract (native_compute; idtac "78 done"; reflexivity). Qed.
Lemma M79 : part 79. Proof using. abstract (native_compute; idtac "79 done"; reflexivity). Qed.
Lemma M80 : part 80. Proof using. abstract (native_compute; idtac "80 done"; reflexivity). Qed.
Lemma M81 : part 81. Proof using. abstract (native_compute; idtac "81 done"; reflexivity). Qed.
Lemma M82 : part 82. Proof using. abstract (native_compute; idtac "82 done"; reflexivity). Qed.
Lemma M83 : part 83. Proof using. abstract (native_compute; idtac "83 done"; reflexivity). Qed.
Lemma M84 : part 84. Proof using. abstract (native_compute; idtac "84 done"; reflexivity). Qed.
Lemma M85 : part 85. Proof using. abstract (native_compute; idtac "85 done"; reflexivity). Qed.
Lemma M86 : part 86. Proof using. abstract (native_compute; idtac "86 done"; reflexivity). Qed.
Lemma M87 : part 87. Proof using. abstract (native_compute; idtac "87 done"; reflexivity). Qed.
Lemma M88 : part 88. Proof using. abstract (native_compute; idtac "88 done"; reflexivity). Qed.
Lemma M89 : part 89. Proof using. abstract (native_compute; idtac "89 done"; reflexivity). Qed.
Lemma M90 : part 90. Proof using. abstract (native_compute; idtac "90 done"; reflexivity). Qed.
Lemma M91 : part 91. Proof using. abstract (native_compute; idtac "91 done"; reflexivity). Qed.
Lemma M92 : part 92. Proof using. abstract (native_compute; idtac "92 done"; reflexivity). Qed.
Lemma M93 : part 93. Proof using. abstract (native_compute; idtac "93 done"; reflexivity). Qed.
Lemma M94 : part 94. Proof using. abstract (native_compute; idtac "94 done"; reflexivity). Qed.
Lemma M95 : part 95. Proof using. abstract (native_compute; idtac "95 done"; reflexivity). Qed.
Lemma M96 : part 96. Proof using. abstract (native_compute; idtac "96 done"; reflexivity). Qed.
Lemma M97 : part 97. Proof using. abstract (native_compute; idtac "97 done"; reflexivity). Qed.
Lemma M98 : part 98. Proof using. abstract (native_compute; idtac "98 done"; reflexivity). Qed.
Lemma M99 : part 99. Proof using. abstract (native_compute; idtac "99 done"; reflexivity). Qed.

Lemma miller_rabin_2_3_1373652 n : n <= max -> miller_rabin [2; 3] n = primeb n.
Proof using.
  apply MR_range_spec_0.
  Local Ltac p pr := refine (MR_range_split' _ _ _ _ _ pr _); [ split; discriminate | ].

  p M00. p M01. p M02. p M03. p M04. p M05. p M06. p M07. p M08. p M09.
  p M10. p M11. p M12. p M13. p M14. p M15. p M16. p M17. p M18. p M19.
  p M20. p M21. p M22. p M23. p M24. p M25. p M26. p M27. p M28. p M29.
  p M30. p M31. p M32. p M33. p M34. p M35. p M36. p M37. p M38. p M39.
  p M40. p M41. p M42. p M43. p M44. p M45. p M46. p M47. p M48. p M49.
  p M50. p M51. p M52. p M53. p M54. p M55. p M56. p M57. p M58. p M59.
  p M60. p M61. p M62. p M63. p M64. p M65. p M66. p M67. p M68. p M69.
  p M70. p M71. p M72. p M73. p M74. p M75. p M76. p M77. p M78. p M79.
  p M80. p M81. p M82. p M83. p M84. p M85. p M86. p M87. p M88. p M89.
  p M90. p M91. p M92. p M93. p M94. p M95. p M96. p M97. p M98. p M99.

  idtac "all done".
  reflexivity.
Qed.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
Require Export Coq.Lists.List.
Require Export Coq.Program.Basics.
Require Export Coq.Relations.Relations.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Bool.Bool.
Require Export liblayers.lib.LogicalRelations.

(** Unfortunately, we cannot export this library because CompCert
  declares a conflicting notation for [@@]. *)
Require Import Coq.Classes.RelationPairs.

(** * Generic operations *)

(** The class definitions below are MathClasses-style overloaded
  operators. This is quite useful because common structures show up
  between modules and layers, and at different levels of their
  construction.

  We use Coq's excellent support for UTF-8, which helps with clarity
  and conciseness. Proof General users may want to use the TeX input
  method to type special characters: hit [C-\], and Emacs will ask you
  "Input method:". If you answer [tex], Emacs will automatically
  replace any LaTeX sequence you (say, [\le]) by the corresponding
  symbol (say, ≤).

  By convention, most of the time we use the LaTeX sequence of the
  operator as the name for the class and field, so the sequences for
  the operators below should be obvious. The only exception is
  [compose], which is denoted by [̧\circ]. *)

Class Id A := { id : A }.

Class Compose A B C := { compose : A -> B -> C }.
Notation "(;)" := compose.
Notation "f ∘ g" := (compose g f) (at level 40, left associativity).

Class Emptyset A := { emptyset : A }.
Notation "∅" := emptyset.

Class Bot A := { bot : A }.
Notation "⊥" := bot.

Class Top A := { top : A }.
Notation "⊤" := top.

Class Le A := { le : relation A }.
Notation "(≤)" := le.
Infix "≤" := le (at level 70, right associativity).

Class Equiv A := { equiv : relation A }.
Notation "(≡)" := equiv.
Infix "≡" := equiv (at level 70, right associativity).

Class Oplus A := { oplus : A -> A -> A }.
Notation "(⊕)" := oplus.
Infix "⊕" := oplus (at level 60, right associativity).

Class Mapsto A B C := { mapsto : A -> B -> C }.
Notation "(↦)" := mapsto.
Notation "( i ↦)" := (mapsto i).
Infix "↦" := mapsto (at level 55, right associativity).

Class Vdash A B C := { vdash : A -> B -> C -> Prop }.
Notation "Γ ⊢ M : τ" := (vdash Γ M τ)
  (at level 65, left associativity, M at level 99).

(** Generic operators for a type of specifications [T] *)

Definition sim_relation {layerdata} (simrel: layerdata -> layerdata -> Type) T :=
  forall D1 D2 (R: simrel D1 D2), rel (T D1) (T D2).

Class Sim {layerdata} simrel (T: layerdata -> Type) :=
  { simRR : sim_relation simrel T }.

Notation sim := (simRR _ _).

Class Semof {layerdata} (A: Type) (T U: layerdata -> Type) :=
  { semof: forall D, A -> T D -> U D }.

Notation "〚-〛" := (semof _).
Notation "〚 M 〛" := (semof _ M).

(** Sometimes we want [eauto] to unfold the generic operators so as to
  apply theorems about a specific implementation. *)
Hint Unfold le : liblayers.

(** * Generic properties *)

(** Now we can give generic definitions for some recurring properties,
  making use of the overloaded operators above. *)

Class Associative {A} (R: relation A) (op: A -> A -> A): Prop :=
  associativity x y z : R (op (op x y) z) (op x (op y z)).

Class Commutative {A} (R: relation A) (op: A -> A -> A): Prop :=
  commutativity x y : R (op x y) (op y x).

Class LeftIdentity {A} (R: relation A) (op: A -> A -> A) (u: A): Prop :=
  id_left y : R (op u y) y.

Class RightIdentity {A} (R: relation A) (op: A -> A -> A) (u: A): Prop :=
  id_right x : R (op x u) x.

Class LeftUpperBound {A} (R: relation A) (op: A -> A -> A): Prop :=
  left_upper_bound x y : R x (op x y).

Class RightUpperBound {A} (R: relation A) (op: A -> A -> A): Prop :=
  right_upper_bound x y : R y (op x y).

Class LowerBound {A B} (R: rel A B) (lb: A): Prop :=
  lower_bound : forall y, R lb y.

Class UpperBound {A B} (R: rel A B) (ub: B): Prop :=
  upper_bound : forall x, R x ub.

(** ** Hints for [eauto] and [autorewrite] *)

(** Most of the generic properties above cannot be used directly as
  hints because the head term is a variable. Hence we register a
  couple of versions specialized to often-used (families of)
  relations. *)

Hint Resolve (associativity (R := eq)) : liblayers.
Hint Resolve (commutativity (R := eq)) : liblayers.
Hint Resolve (id_left (R := eq)) : liblayers.
Hint Resolve (id_right (R := eq)) : liblayers.

Hint Resolve (associativity (R := (≡))) : liblayers.
Hint Resolve (commutativity (R := (≡))) : liblayers.
Hint Resolve (id_left (R := (≡))) : liblayers.
Hint Resolve (id_right (R := (≡))) : liblayers.

Hint Resolve (associativity (R := (≤))) : liblayers.
Hint Resolve (commutativity (R := (≤))) : liblayers.
Hint Resolve (id_left (R := (≤))) : liblayers.
Hint Resolve (id_right (R := (≤))) : liblayers.
Hint Resolve (left_upper_bound (R := (≤))) : liblayers.
Hint Resolve (right_upper_bound (R := (≤))) : liblayers.
Hint Resolve (lower_bound (R := (≤))) : liblayers.
Hint Resolve (upper_bound (R := (≤))) : liblayers.

(** For rewriting we have a similar problem, where once things are
  filled in by unification with the match found, the generated
  subgoals (namely the typeclass instances to resolve) cannot contain
  existential variables. Hence we apply the same specialization
  strategy. Unfortunately, here we have to spell it out as separate
  lemmas, because the registered rewrite theorems cannot contain holes
  (only regular premises to be solved by the tactic provided). *)

Lemma associativity_eq {A} `{Associative A eq}:
  forall x y z, op (op x y) z = op x (op y z).
Proof associativity.

Lemma id_left_eq {A} `{LeftIdentity A eq}:
  forall x, op u x = x.
Proof id_left.

Lemma id_right_eq {A} `{RightIdentity A eq}:
  forall x, op x u = x.
Proof id_right.

Lemma associativity_le `{Le} `{Associative _ (≤)}:
  forall x y z, op (op x y) z ≤ op x (op y z).
Proof associativity.

Lemma id_left_le `{Le} `{LeftIdentity _ (≤)}:
  forall x, op u x ≤ x.
Proof id_left.

Lemma id_right_le `{Le} `{RightIdentity _ (≤)}:
  forall x, op x u ≤ x.
Proof id_right.

Lemma associativity_equiv `{Equiv} `{Associative _ (≡)}:
  forall x y z, op (op x y) z ≡ op x (op y z).
Proof associativity.

Lemma id_left_equiv `{Equiv} `{LeftIdentity _ (≡)}:
  forall x, op u x ≡ x.
Proof id_left.

Lemma id_right_equiv `{Equiv} `{RightIdentity _ (≡)}:
  forall x, op x u ≡ x.
Proof id_right.

Hint Rewrite
    @associativity_eq
    @id_left_le
    @id_right_eq
    @associativity_le
    @id_left_le
    @id_right_le
    @associativity_equiv
    @id_left_equiv
    @id_right_equiv
  using typeclasses eauto : liblayers.

(** ** Some properties of properties *)

Global Instance assoc_subrel {A} (R S: relation A) (op: A -> A -> A):
  subrelation R S ->
  Unconvertible _ R S ->
  Associative R op ->
  Associative S op.
Proof.
  intros HRS _ Hassoc x y z.
  apply HRS.
  apply associativity.
Qed.

Global Instance comm_subrel {A} (R S: relation A) (op: A -> A -> A):
  subrelation R S ->
  Unconvertible _ R S ->
  Commutative R op ->
  Commutative S op.
Proof.
  intros HRS _ Hcomm x y.
  apply HRS.
  apply commutativity.
Qed.

Global Instance id_left_subrel {A} (R S: relation A) (op: A -> A -> A) (u: A):
  subrelation R S ->
  Unconvertible _ R S ->
  LeftIdentity R op u ->
  LeftIdentity S op u.
Proof.
  intros HRS _ Hid x.
  apply HRS.
  apply id_left.
Qed.

Global Instance id_right_subrel {A} (R S: relation A) (op: A -> A -> A) (u: A):
  subrelation R S ->
  Unconvertible _ R S ->
  RightIdentity R op u ->
  RightIdentity S op u.
Proof.
  intros HRS _ Hid x.
  apply HRS.
  apply id_right.
Qed.

Global Instance id_left_id_right {A} (R: relation A) op u:
  LeftIdentity R op u ->
  Commutative R op ->
  Transitive R ->
  RightIdentity R op u.
Proof.
  intros Hleft Hcomm Htrans.
  intros x.
  transitivity (op u x).
  * apply commutativity.
  * apply id_left.
Qed.

Global Instance left_upper_bound_right_upper_bound {A} (R: relation A) op:
  LeftUpperBound R op ->
  Commutative R op ->
  Transitive R ->
  RightUpperBound R op.
Proof.
  intros Hleft Hcomm Htrans.
  intros x y.
  rewrite <- (commutativity y x).
  apply left_upper_bound.
Qed.

Instance refl_subrel_eq {A} (R: relation A):
  Reflexive R -> subrelation eq R.
Proof.
  intros Hrefl x y Hxy.
  subst.
  reflexivity.
Qed.

(** * Logical relationish kind of things *)

Ltac rel_auto :=
  unfold flip, impl in *;
  unfold arrow_rel, forall_rel, arrow_pointwise_rel, forall_pointwise_rel in *;
  eauto with liblayers;
  eassumption || congruence.

Ltac solve_monotonicity :=
  solve_monotonic; try rel_auto.

(** ** Generic instances for relation properties *)

Global Instance respectful_eq_transitive {A B} (R: relation B):
  Transitive R ->
  Transitive (@eq A ==> R)%signature.
Proof.
  firstorder.
Qed.

Instance pointwise_preorder A {B} `(PreOrder B):
  @PreOrder (A -> B) (- ==> R).
Proof.
  split.
  * intros f i.
    reflexivity.
  * intros f g h Hfg Hgh i.
    transitivity (g i); eauto.
Qed.

(** * Basic instances *)

(** ** [Prop] *)

Instance impl_preorder:
  PreOrder impl.
Proof.
  firstorder.
Qed.

(** ** Booleans *)

(** Boolean are sufficiently simple that we can prove pretty much
  anything by just enumerating all possibilities. *)
Ltac booltac :=
  repeat (intros [|] || intro; simpl);
  try match goal with
    | H: true = false |- _ => inversion H
    | H: false = true |- _ => inversion H
  end;
  tauto.

Global Instance leb_op: Le bool := { le := leb }.

Global Instance leb_preorder:
  PreOrder leb.
Proof.
  split; booltac.
Qed.

Section BOOL.
  Local Hint Extern 10 => booltac : typeclass_instances.
  Global Instance leb_antisym: Antisymmetric bool eq leb := _.
  Global Instance leb_lower_bound: LowerBound leb false := _.
  Global Instance leb_upper_bound: UpperBound leb true := _.
  Global Instance orb_monotonic: Proper (leb ++> leb ++> leb) orb := _.
  Global Instance orb_id_left: LeftIdentity eq orb false := _.
  Global Instance orb_assoc: Associative eq orb := _.
  Global Instance orb_comm: Commutative eq orb := _.
  Global Instance orb_le_left: LeftUpperBound leb orb := _.
  Global Instance andb_monotonic: Proper (leb ++> leb ++> leb) andb := _.
  Global Instance andb_id_left: LeftIdentity eq andb true := _.
  Global Instance andb_assoc: Associative eq andb := _.
  Global Instance andb_comm: Commutative eq andb := _.
End BOOL.

Lemma bool_le_true b1 b2:
  leb b1 b2 ->
  b1 = true ->
  b2 = true.
Proof.
  revert b1 b2; booltac.
Qed.

Hint Resolve bool_le_true : liblayers.

(** ** The [Equivalence] derived from a [PreOrder] *)

(** XXX: those should be generic properties of [R ∩ flip R], since
  they also apply to say, [eqrel] = [subrel ∩ flip subrel]. *)

Global Instance le_equiv `(Le): Equiv A | 10 :=
  { equiv x y := x ≤ y /\ y ≤ x }.

Global Instance le_equiv_equivalence `{Ale: Le}:
  PreOrder (≤) -> Equivalence (≡).
Proof.
  split.
  - intros x.
    split; reflexivity.
  - intros x y [Hxy Hyx].
    split; assumption.
  - intros x y z [Hxy Hyx] [Hyz Hzy].
    split; etransitivity; eassumption.
Qed.

Global Instance le_equiv_antisymmetric `{Ale: Le}:
  forall (H: Equivalence (≡)), Antisymmetric A (≡) (≤).
Proof.
  intros x y Hxy Hyx.
  split; assumption.
Qed.

Global Instance le_equiv_subrel `{Ale: Le}:
  subrelation (≡) (≤).
Proof.
  intros x y Hxy.
  apply Hxy.
Qed.

Global Instance le_equiv_subrel_flip `{Ale: Le}:
  subrelation (≡) (flip (≤)).
Proof.
  intros x y Hxy.
  apply Hxy.
Qed.

Global Instance le_equiv_op_mor {A B C} `{Le A} `{Le B} `{Le C} (op: A->B->C):
  Proper ((≤) ++> (≤) ++> (≤)) op ->
  Proper ((≡) ==> (≡) ==> (≡)) op | 100.
Proof.
  intros Hop x1 x2 [Hx12 Hx21] y1 y2 [Hy12 Hy21].
  split; apply Hop; assumption.
Qed.

Local Instance le_antisym_equiv_eq `{Ale: Le}:
  Antisymmetric A eq (≤) ->
  subrelation (≡) eq.
Proof.
  intros Hantisym.
  intros x y [Hxy Hyx].
  apply antisymmetry; assumption.
Qed.

Local Instance le_equiv_assoc `{Le} op:
  PreOrder (≤) ->
  Proper ((≤) ++> (≤) ++> (≤)) op ->
  Commutative (≤) op ->
  Associative (≤) op ->
  Associative (≡) op.
Proof.
  split.
  * apply associativity.
  * rewrite (commutativity x (op y z)).
    rewrite (commutativity y z).
    rewrite <- (commutativity z (op x y)).
    rewrite <- (commutativity y x).
    apply associativity.
Qed.

Local Instance le_equiv_comm `{Le} op:
  Commutative (≤) op ->
  Commutative (≡) op.
Proof.
  intros Hcomm.
  split; apply commutativity.
Qed.

(** ** Trivial order *)

Local Instance trivial_le A: Le A | 100 := { le := eq }.

Global Instance trivial_le_preorder {A}:
  @PreOrder A (≤).
Proof.
  split; typeclasses eauto.
Qed.

Global Instance trivial_le_antisym {A}:
  Antisymmetric A eq (≤).
Proof.
  firstorder.
Qed.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** Initial Author : Evgeny Makarov, INRIA, 2007 *)

(*i $Id: NZAxioms.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Export Equalities Orders NumPrelude GenericMinMax.

(** Axiomatization of a domain with zero, successor, predecessor,
    and a bi-directional induction principle. We require [P (S n) = n]
    but not the other way around, since this domain is meant
    to be either N or Z. In fact it can be a few other things,
    for instance [Z/nZ] (See file [NZDomain] for a study of that).
*)

Module Type ZeroSuccPred (Import T:Typ).
 Parameter Inline zero : t.
 Parameters Inline succ pred : t -> t.
End ZeroSuccPred.

Module Type ZeroSuccPredNotation (T:Typ)(Import NZ:ZeroSuccPred T).
 Notation "0" := zero.
 Notation S := succ.
 Notation P := pred.
 Notation "1" := (S 0).
 Notation "2" := (S 1).
End ZeroSuccPredNotation.

Module Type ZeroSuccPred' (T:Typ) :=
 ZeroSuccPred T <+ ZeroSuccPredNotation T.

Module Type IsNZDomain (Import E:Eq')(Import NZ:ZeroSuccPred' E).
 Declare Instance succ_wd : Proper (eq ==> eq) S.
 Declare Instance pred_wd : Proper (eq ==> eq) P.
 Axiom pred_succ : forall n, P (S n) == n.
 Axiom bi_induction :
  forall A : t -> Prop, Proper (eq==>iff) A ->
    A 0 -> (forall n, A n <-> A (S n)) -> forall n, A n.
End IsNZDomain.

Module Type NZDomainSig := EqualityType <+ ZeroSuccPred <+ IsNZDomain.
Module Type NZDomainSig' := EqualityType' <+ ZeroSuccPred' <+ IsNZDomain.

(** Axiomatization of basic operations : [+] [-] [*] *)

Module Type AddSubMul (Import T:Typ).
 Parameters Inline add sub mul : t -> t -> t.
End AddSubMul.

Module Type AddSubMulNotation (T:Typ)(Import NZ:AddSubMul T).
 Notation "x + y" := (add x y).
 Notation "x - y" := (sub x y).
 Notation "x * y" := (mul x y).
End AddSubMulNotation.

Module Type AddSubMul' (T:Typ) := AddSubMul T <+ AddSubMulNotation T.

Module Type IsAddSubMul (Import E:NZDomainSig')(Import NZ:AddSubMul' E).
 Declare Instance add_wd : Proper (eq ==> eq ==> eq) add.
 Declare Instance sub_wd : Proper (eq ==> eq ==> eq) sub.
 Declare Instance mul_wd : Proper (eq ==> eq ==> eq) mul.
 Axiom add_0_l : forall n, 0 + n == n.
 Axiom add_succ_l : forall n m, (S n) + m == S (n + m).
 Axiom sub_0_r : forall n, n - 0 == n.
 Axiom sub_succ_r : forall n m, n - (S m) == P (n - m).
 Axiom mul_0_l : forall n, 0 * n == 0.
 Axiom mul_succ_l : forall n m, S n * m == n * m + m.
End IsAddSubMul.

Module Type NZBasicFunsSig := NZDomainSig <+ AddSubMul <+ IsAddSubMul.
Module Type NZBasicFunsSig' := NZDomainSig' <+ AddSubMul' <+IsAddSubMul.

(** Old name for the same interface: *)

Module Type NZAxiomsSig := NZBasicFunsSig.
Module Type NZAxiomsSig' := NZBasicFunsSig'.

(** Axiomatization of order *)

Module Type NZOrd := NZDomainSig <+ HasLt <+ HasLe.
Module Type NZOrd' := NZDomainSig' <+ HasLt <+ HasLe <+
                      LtNotation <+ LeNotation <+ LtLeNotation.

Module Type IsNZOrd (Import NZ : NZOrd').
 Declare Instance lt_wd : Proper (eq ==> eq ==> iff) lt.
 Axiom lt_eq_cases : forall n m, n <= m <-> n < m \/ n == m.
 Axiom lt_irrefl : forall n, ~ (n < n).
 Axiom lt_succ_r : forall n m, n < S m <-> n <= m.
End IsNZOrd.

(** NB: the compatibility of [le] can be proved later from [lt_wd]
    and [lt_eq_cases] *)

Module Type NZOrdSig := NZOrd <+ IsNZOrd.
Module Type NZOrdSig' := NZOrd' <+ IsNZOrd.

(** Everything together : *)

Module Type NZOrdAxiomsSig <: NZBasicFunsSig <: NZOrdSig
 := NZOrdSig <+ AddSubMul <+ IsAddSubMul <+ HasMinMax.
Module Type NZOrdAxiomsSig' <: NZOrdAxiomsSig
 := NZOrdSig' <+ AddSubMul' <+ IsAddSubMul <+ HasMinMax.

(** Same, plus a comparison function. *)

Module Type NZDecOrdSig := NZOrdSig <+ HasCompare.
Module Type NZDecOrdSig' := NZOrdSig' <+ HasCompare.

Module Type NZDecOrdAxiomsSig := NZOrdAxiomsSig <+ HasCompare.
Module Type NZDecOrdAxiomsSig' := NZOrdAxiomsSig' <+ HasCompare.


From HoTT Require Import HoTT.
From HoTT.Basics Require PathGroupoids.
(* By default, the HoTT library does not dump a bunch of notations in your
   scope.  However, these notations are tremendously useful, so most users
   of the HoTT library will want to open these two scopes, which introduce
   notations for paths and for equivalences.  The Cliff's notes version of
   these notations:
Notation "1" := idpath : path_scope.
Notation "p @ q" := (concat p q) (at level 20) : path_scope.
Notation "p ^" := (inverse p) (at level 3) : path_scope.
Notation "p # x" := (transport _ p x) (right associativity, at level 65) : path_scope.
Notation "A <~> B" := (Equiv A B) (at level 85) : equiv_scope.
Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3) : equiv_scope.
NB: ^ and ^-1 bind quite tightly, so it's not uncommon to see terms like 'f^-1 a'
or '(f a)^-1'.
*)
Local Open Scope path_scope.
Local Open Scope equiv_scope.
Local Open Scope fibration_scope.

(* There are also a number of other notations which /are/ enabled by default. The
most important ones are these:
Notation idmap := (fun x => x).
Notation "( x ; y )" := (existT _ x y) : fibration_scope.
Notation "x .1" := (projT1 x) (at level 3) : fibration_scope.
Notation "x .2" := (projT2 x) (at level 3) : fibration_scope.
Notation "g 'o' f" := (compose g f) (at level 40, left associativity) : function_scope.
Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.
Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope.
Notation "p ..1" := (projT1_path p) (at level 3) : fibration_scope.
Notation "p ..2" := (projT2_path p) (at level 3) : fibration_scope.
NB: When writing code using the projT* notations, the space is usually omitted,
as in 'x.1' or 'p..2'. Coq will format it with a space, however.
 *)

(*
Exercise 2.1. Show that the three obvious proofs of Lemma 2.1.2 are pairwise equal.

Lemma 2.1.2:
Given:
  A : Type,
  a b c : A

We have a function:
  (a = b) -> (b = c) -> (x = z)
 *)
Section trans_pfs.
  Context {A : Type}.
    Definition
      free_path_ind : forall (P : forall (x y : A) (p : x = y), Type)
                           (x y : A) (p : x = y) (p0 : P x x idpath), P x y p.
    Proof.
      intros P x y p p0. apply paths_ind. assumption.
    Defined.

  Theorem trans1 : forall {x y z : A}, (x = y) -> (y = z) -> (x = z).
  Proof.
    enough (H : forall x y : A, (x = y) -> forall z, (y = z) -> (x = z)).
    - intros x y z p q. exact (H x y p z q).
    - intros x y p.
      refine (free_path_ind (fun x y q => forall z, (y = z) ->  (x = z)) x y p _).
      ** refine (@paths_ind A x (fun z q => x = z) _).
         exact idpath.
  Defined.

  Theorem trans2 : forall {x y z : A}, (x = y) -> (y = z) -> (x = z).
  Proof.
    enough (H : forall x y : A, (x = y) -> forall z, (y = z) -> (x = z)).
    - intros x y z p q. exact (H x y p z q).
    - intros x y p.
      refine (free_path_ind (fun x y q => forall z, (y = z) ->  (x = z)) x y p _).
      ** intros z q. exact q.
  Defined.

  Theorem trans3 : forall {x y z : A}, (x = y) -> (y = z) -> (x = z).
  Proof.
    enough (H : forall x y : A, (x = y) -> forall z, (y = z) -> (x = z)).
    - intros x y z p q. exact (H x y p z q).
    - intros x y p. Check paths_ind.
      refine (@paths_ind A y (fun z q => x = z) _).
      * exact p.
  Defined.

  Context {x y z : A}.
  Theorem trans1_eq_2 : forall (p : x = y) (q : y = z), (trans1 p q) = (trans2 p q).
  Proof.
    refine
      (@paths_ind A x (fun y p => forall (q : y = z), trans1 p q = trans2 p q) _ y).
    refine
      (@paths_ind A x (fun z q => trans1 _ q = trans2 _ q) _ z).
    exact idpath.
  Defined.

  Theorem trans2_eq_3 : forall (p : x = y) (q : y = z), (trans2 p q) = (trans3 p q).
  Proof.
    refine
      (@paths_ind A x (fun y p => forall (q : y = z), trans2 p q = trans3 p q) _ y).
    refine
      (@paths_ind A x (fun z q => trans2 _ q = trans3 _ q) _ z).
    exact idpath.
  Defined.

  Theorem trans1_eq_3 : forall (p : x = y) (q : y = z), (trans1 p q) = (trans3 p q).
  Proof.
    refine
      (@paths_ind A x (fun y p => forall (q : y = z), trans1 p q = trans3 p q) _ y).
    refine
      (@paths_ind A x (fun z q => trans1 _ q = trans3 _ q) _ z).
    exact idpath.
  Defined.
End trans_pfs.

Section trans_pfs_comm.

(*
Exercise 2.2. Show that the three equalities of proofs constructed in the previous exercise form a
commutative triangle. In other words, if the three definitions of concatenation are denoted by
(trans1 p q), (trans2 p q), and (trans3 p q), then the concatenated equality:

  (trans1 p q) = (trans2 p q) = (trans3 p q)

is equal to the equality (trans1 p q) = (trans3 p q).
 *)
  Variable A : Type.
  Variable x y z : A.

  Theorem trans_comm_triangle
    : forall (p : x = y) (q : y = z),
      (trans1_eq_2 p q @ trans2_eq_3 p q) =
      (trans1_eq_3 p q).
  Proof.
    refine
      (@paths_ind A x
      (fun y p => forall (q : y = z), (trans1_eq_2 p q @ trans2_eq_3 p q) = (trans1_eq_3 p q)) _ y).
    refine
      (@paths_ind A x (fun z q => (trans1_eq_2 _ q @ trans2_eq_3 _ q) = (trans1_eq_3 _ q)) _ z).
    exact idpath.
  Defined.

  End trans_pfs_comm.

(*
Exercise 2.3. Give a fourth, different, proof of Lemma 2.1.2, and prove that it is equal to the others.
 *)
Section transport_trans.
  Variable A : Set.
  Theorem trans_4 : forall x y z : A, (x = y) -> (y = z) -> (x = z).
  Proof.
    intros x y z p q.
    exact (transport (fun x' => x' = z) (p ^) q).
  Defined.

End transport_trans.

(*
Exercise 2.4
Define, by induction on n, a general notion of n-dimensional path in a type A,
simultaneously with the type of boundaries for such paths.

n-paths:

n = 0 - A 0-path is a point
            x
            .   : 0-path A
n = 1 - A 1-path is a equality between two 0-paths i.e. x, y : A, x = y
          x   y
          . ~ . : 1-path A
n = 2 - A 2-path is an equality between one paths i.e. p q : n_path 1, p = q.
            p
          . ~ .
          |   |  : 2-path A
          . ~ .
            q
...
*)

Section n_path.
  Variable A : Type.

  Fixpoint n_path (n : nat) : Type :=
    match n with
    | O => A
    | S n' => {x : n_path n' & ({y : n_path n' & (x = y)})}
    end.
End n_path.

Eval compute in (n_path nat 2).
(*
Exercise 2.5. Prove that the functions (2.3.6) and (2.3.7) are inverse equivalences.

A B : Type
x y : A
p   : x = y
f   : A -> B

(2.3.6):
  (f x = f y) -> (p_*(f x) = f y)

(2.3.7):
  (p_*(f x) = f y) -> f x = f y

*)
Module non_dep_apd.
  Check transport_const.

  Lemma forward {A B : Type} (f : A -> B) {x y : A} (p : x = y) :
    (f x = f y) -> (transport (fun _ => B) p (f x)) = (f y).
  Proof.
    intros f_path.
    refine (transport_const p (f x) @ _).
    exact f_path.
  Defined.

  Lemma backward {A B : Type} (f : A -> B) {x y : A} (p : x = y) : (transport (fun _ => B) p (f x)) = (f y) -> (f x) = (f y).
  Proof.
    intros f_apd_p.
    Check transport_const.
    refine ((transport_const p (f x)) ^ @ _).
    exact f_apd_p.
  Defined.

  Theorem for_back {A B : Type} (f : A -> B) {x y : A} {p : x = y} (f_p : f x = f y) :
    forward f p o backward f p == idmap.
  Proof.
    intros dep_eq.

    unfold forward. unfold backward.
    path_induction.
    reflexivity.
  Defined.

  Theorem back_for {A B : Type} (f : A -> B) {x y : A} {p : x = y} (f_p : f x = f y) :
    backward f p o forward f p == idmap.
  Proof.
    intros dep_eq.
    unfold forward. unfold backward.
    path_induction.
    reflexivity.
  Defined.

  (* Theorem triangle_law  *)

  Instance ex_2_4 {A B : Type} (f : A -> B) {x y : A} {p : x = y} (f_p : f x = f y) :
    IsEquiv (forward f p).
  Proof.
    Check Build_IsEquiv.
    refine (Build_IsEquiv _ _ (forward f p) (backward f p) (for_back f f_p) (back_for f f_p) _).
    -

End non_dep_apd.


From LM Require Import Prelims L Programs.

Require Import Lia.

  (** * Abstract Heap Machine *)
Section Lin.

  Let HA:=nat.

  Inductive clos :=
    closC (P:Pro) (a:HA).
  Notation "P ! a" := (closC P a) (at level 40).

  Inductive heapEntry := heapEntryC (g:clos) (alpha:HA).

  (** ** Heaps *)

  Let Heap := list heapEntry.
  Implicit Type H : Heap.
  Definition put H e := (H++[e],|H|).
  Definition get H alpha:= nth_error H alpha.
  Definition extended H H' := forall alpha m, get H alpha = Some m -> get H' alpha = Some m.

  Lemma get_current H m H' alpha : put H m = (H', alpha) -> get H' alpha = Some m.
  Proof.
    unfold put, get. intros [= <- <-].
    rewrite nth_error_app2. now rewrite <- minus_n_n. reflexivity.
  Qed.

  Lemma put_extends H H' m b: put H m = (H',b) -> extended H H'.
  Proof.
    unfold extended,get,put.
    intros [= <- <-] ? ? ?. rewrite nth_error_app1;eauto using nth_error_Some_lt.
  Qed.

  Fixpoint lookup H alpha x : option clos:=
    match get H alpha with
      Some (heapEntryC bound env') =>
      match x with
        0 => Some bound
      | S x' => lookup H env' x'
      end
    |  _ => None
    end.

 (** ** Reduction Rules *)

  Definition state := (list clos * list clos *Heap)%type.

  Hint Transparent state.

  Inductive step : state -> state -> Prop :=
    step_pushVal P P' Q a T V H:
      jumpTarget 0 [] P = Some (Q,P')
      ->step ((lamT::P)!a::T,V,H) (P'!a::T,Q!a::V,H)
  | step_beta a b g P Q H H' c T V:
      put H (heapEntryC g b) = (H',c)
      -> step ((appT::P)!a::T,g::Q!b::V,H) (Q!c ::P!a::T,V,H')
  | step_load P a x g T V H:
      lookup H a x = Some g
      -> step ((varT x::P)!a::T,V,H) (P!a::T,g::V,H)
  | step_nil a T V H: step ([]!a::T,V,H) (T,V,H).

  Hint Constructors step.

  (** ** Unfolding *)

  Inductive unfolds H a: nat -> term -> term -> Prop :=
  | unfoldsUnbound k n :
      n < k ->
      unfolds H a k (var n) (var n)
  | unfoldsBound k b P s s' n:
      n >= k ->
      lookup H a (n-k) = Some (P!b) ->
      reprP P s ->
      unfolds H b 0 s s' ->
      unfolds H a k (var n) s'
  | unfoldsLam k s s':
      unfolds H a (S k) s s' ->
      unfolds H a k (lam s) (lam s')
  | unfoldsApp k (s t s' t' : term):
      unfolds H a k s s' ->
      unfolds H a k t t' ->
      unfolds H a k (s t) (s' t').

  Lemma unfolds_bound H k s s' a:
    unfolds H a k s s'
    -> bound k s'.
  Proof.
    induction 1.
    -now constructor.
    -inv H2. inv H3. constructor. inv IHunfolds. eapply bound_ge. eauto. omega.
    -now constructor.
    -now constructor.
  Qed.

  Inductive reprC : Heap -> clos -> term -> Prop :=
    reprCC H P s a s' :
      reprP P s ->
      unfolds H a 0 s s' ->
      reprC H (P!a) s'.

  Lemma unfolds_subst' H s s' t' a a' k g:
    get H a' = Some (heapEntryC g a) ->
    reprC H g t' ->
    unfolds H a (S k) s s' ->
    unfolds H a' k s (subst s' k t').
  Proof.
    intros H1 R I__s. remember (S k) as k' eqn:eq__k.
    induction I__s in H1,k,eq__k|-*. all:subst k0.
    -decide (n<k). all:cbn [subst];decide _;try omega.
     +econstructor. omega.
     +assert (H':lookup H a' (n-k) = Some g).
      {subst n. cbn. rewrite Nat.sub_diag. cbn. rewrite H1. reflexivity. }
      inv R.
      econstructor.
      all:try eassumption;try omega.
    -rename s into u.
     assert (H':lookup H a' (n-k) = Some (P!b)).
     {destruct n. omega. rewrite Nat.sub_succ_l. cbn. rewrite H1. now rewrite Nat.sub_succ in H2. omega. }
     rewrite bound_closed_k.
     2:{ eapply bound_ge with (k:=0). 2:omega. now eauto using unfolds_bound. }
     econstructor. all:try eassumption;omega.
    -econstructor. all:eauto.
    -econstructor. all:eauto.
  Qed.

  Lemma unfolds_subst H s s' t' a a' g:
    get H a' = Some (heapEntryC g a) ->
    reprC H g t' ->
    unfolds H a 1 s s' ->
    unfolds H a' 0 s (subst s' 0 t').
  Proof.
    apply unfolds_subst'.
  Qed.

  Lemma bound_unfolds_id H k s a:
    bound k s ->
    unfolds H a k s s.
  Proof.
    induction 1.
    -now constructor.
    -now constructor.
    -now constructor.
  Qed.

  Instance extended_PO :
    PreOrder extended.
  Proof.
    unfold extended;split;repeat intro. all:eauto.
  Qed.

  Typeclasses Opaque extended.

  Lemma lookup_extend H H' a x g:
    extended H H' -> lookup H a x = Some g -> lookup H' a x = Some g.
  Proof.
    induction x in H,H',a,g|-*;intros H1 H2.
    all:cbn in H2|-*.
    all:destruct get as [[]|]eqn:H3.
    all:try congruence.
    all:try rewrite (H1 _ _ H3).
    all:try congruence.
    eapply IHx;eauto.
  Qed.

  Lemma unfolds_extend H H' a s t k :
    extended H H' ->
    unfolds H a k s t ->
    unfolds H' a k s t.
  Proof.
    induction 2.
    all:econstructor. 1-2,4-8:now eauto. erewrite lookup_extend;eauto.
  Qed.

  Lemma reprC_extend H H' g s:
    extended H H' ->
    reprC H g s ->
    reprC H' g s.
  Proof.
    inversion 2. subst. eauto using reprC, unfolds_extend.
  Qed.

  (** ** Time *)
  (** We can show the right generalisation that connects the big-step characterisation of the L time resource measure with abstract machine steps.
  For technical reasons, we seperate that there *is* a abstract machine reduction from the exact analysis of the step that reduction takes,
 by using evars and a existential quantified variable [l] that collects the steps during the proof and which we show equal to the desired formula (4k+1) afterwards. *)

  Lemma correctTime' s t k s0 P a T V H:
  timeBS k s t -> unfolds H a 0 s0 s ->
  exists g l H', reprC H' g t
            /\ pow step l ((compile s0++P)!a::T,V,H)
                  (P!a::T,g::V,H') /\ l = 4*k+1 /\ extended H H'.
  Proof.
    intros Ev R.
    induction Ev in s0,P,a,T,V,H,R |-*.
    -inversion R.
     +subst k s' s0. clear H0 R. rename P0 into Q,H3 into R.
      rewrite Nat.sub_0_r in H1.
      eexists (Q ! b),1,H.
      repeat split.
      *eauto using reprC.
      *cbn [compile]. apply (rcomp_1 step).  now constructor.
      *hnf. tauto.
     +subst k s' s0. clear R. rename H3 into R.
      eexists (compile s1 ! a),1,H.
      repeat split.
      *eauto using reprC,reprP,unfolds.
      *cbn [compile Datatypes.app]; autorewrite with list;cbn [Datatypes.app].
       apply (rcomp_1 step). constructor. apply jumpTarget_correct.
      *hnf. tauto.
    -inv R.
     {exfalso. inv H3. inv H4. }
     rename t0 into t1. rename H5 into I__s, H6 into I__t.
     cbn [compile List.app]; autorewrite with list; cbn [List.app].
     specialize (IHEv1 _ (compile t1 ++ appT ::P) _ T V _ I__s)
       as ([P__temp a2]&k1&Heap1&rep1&R1&eq_k1&Ext1).
     inv rep1. inv H4. inv H6. rename H3 into I__s'.
     apply (unfolds_extend Ext1) in I__t.
     specialize (IHEv2 _ (appT ::P) _ T ((compile s2!a2)::V) _ I__t)
                 as (g__t&k2&Heap2&rep2&R2&eq2&Ext2).
     edestruct (put Heap2 (heapEntryC g__t a2)) as [Heap2' a2'] eqn:eq.
     assert (Ext2' := (put_extends eq)).
     apply ( reprC_extend Ext2') in rep2.
     apply ( unfolds_extend Ext2) in I__s'. apply ( unfolds_extend Ext2') in I__s'.

     specialize (unfolds_subst (get_current eq) rep2 I__s') as I__subst.
     edestruct (IHEv3 _ [] _ (P!a::T) V _ I__subst) as (g__u&k3&Heap3&rep3&R3&eq3&Ext3).
     eexists g__u,_,Heap3.
     split;[ | split;[| split]].
     +eassumption.
     +apply pow_add. eexists. split.
      { exact R1. }
      apply pow_add. eexists. split.
      { exact R2. }
      apply pow_add. eexists. split.
      { apply (rcomp_1 step). constructor;eassumption. }
      autorewrite with list in R3.
      apply pow_add. eexists. split.
      {exact R3. }
      now apply (rcomp_1 step); constructor.
     +omega.
     +rewrite Ext1,Ext2,Ext2',Ext3. reflexivity.
  Qed.

  Definition init s :state := ([compile s!0],[],[]).

  Lemma correctTime s t k:
    timeBS k s t -> closed s ->
    exists g H, reprC H g t
           /\ pow step (4*k+2) (init s)
                  ([],[g],H).

  Proof.
    intros H1 H2.
    edestruct (correctTime' (s0:=s) (a:=0) (H:=[]) [] [] [] H1)
      as (g&l&H'&rep&R&eq&_).
    -apply bound_unfolds_id. assumption.
    -autorewrite with list in R.
      exists g,H'. split. assumption.
     replace (4 * k + 2) with ((4 * k + 1)+1) by omega.
     apply pow_add. eexists;split. subst l;eassumption.
     apply (rcomp_1 step). constructor.
  Qed.

End Lin.
Notation "a ! alpha" := (closC a alpha) (at level 40).

Lemma lookup_el H alpha x e: lookup H alpha x = Some e -> exists beta, heapEntryC e beta el H.
Proof.
  induction x in alpha, e|-*.
  all:cbn. all:unfold get. all:destruct nth_error as [[]|] eqn:eq.
  all:intros [= eq'].
  1:subst.
  all:eauto using nth_error_In.
Qed.

Section Analysis.

  Variable s : term.
 (* Hypothesis cs : closed s.*)
  Variable T V : list clos.
  Variable H: list heapEntry.
  Variable i : nat.

  Hypothesis R: pow step i (init s) (T,V,H).

  Lemma jumpTarget_eq c c0 c1 c2: jumpTarget 0 c0 c = Some (c1,c2) -> c1++[retT]++c2=c0++c.
  Proof.
    generalize 0 as k.
    induction c as [|[]] in c1,c2,c0|-*;cbn. congruence.
    all:intros ? H'.
    4:destruct k;[inv H';congruence|].
    all:apply IHc in H'.
    all:autorewrite with list in *.
    all:now cbn in *.
  Qed.

  (** ** Space *)
  (** As the closures get passed between T,V and H, the analysis that all programs are always smaller than
  the inital term and that all addresses are allocatd in H needs to be done simultaniously, by induction on the number of machine steps. *)

  Lemma size_clos P a : ((P!a) el (T++V) -> sizeP P <= 2*size s /\ a <= length H)
                        /\ (forall beta, heapEntryC (P!a) beta el H -> sizeP P <= 2*size s /\ a <= length H /\ beta <= length H).
  Proof.
    unfold sizeP.
    induction i in T,V,H,R,P,a|-*.
    -inv R. split.
     +intros [[= <- <-]|[]].
      eauto using sizeP_size,Nat.le_0_l.
     +intros ? [].
    -replace (S n) with (n + 1) in R by omega.
     apply pow_add in R. destruct R as [[[T' V'] H'] [R1 R2]].
     specialize (IHn _ _ _ R1).
     eapply rcomp_1 in R2.
     split.
     +intros Hel.
      apply in_app_or in Hel.
      inv R2.
      *apply jumpTarget_eq in H2.  cbn in H2;inv H2.
       destruct Hel as [[ [= <- <-]| ]|[[= <- <-] | ]].

       all:repeat (autorewrite with list in *;cbn in * ).
       1:specialize (proj1 (IHn _ a0) ltac:(eauto)).
       3:specialize (proj1 (IHn _ a0) ltac:(eauto)).

       1,3:repeat (autorewrite with list in *;cbn in * ).
       1,2:omega.

       1:specialize (proj1 (IHn P a) ltac:(eauto)).
       2:specialize (proj1 (IHn P a) ltac:(eauto)).

       all:omega.

      *inv H2.
       destruct Hel as [[[= <- <-] | [[= <- <-]|]]|].
       all:repeat ((try setoid_rewrite in_app_iff in IHn);cbn in IHn).
       1:specialize (proj1(IHn Q _) ltac:(eauto)).
       1:repeat (autorewrite with list in *;cbn in * ).
       1:now omega.

       1:specialize (proj1(IHn _ a0) ltac:(eauto)).
       1:repeat (autorewrite with list in *;cbn in * ).
       1:now omega.

       1:specialize (proj1(IHn P a) ltac:(eauto)).
       1:autorewrite with list in IHn.
       1:repeat (autorewrite with list in *;cbn in * ).
       1:now omega.

       1:specialize (proj1(IHn P a) ltac:(eauto)).
       1:autorewrite with list in IHn.
       1:repeat (autorewrite with list in *;cbn in * ).
       1:try now omega.
      *destruct Hel as [[[= <- <-]|]|[-> | ]].

       all:repeat ((try setoid_rewrite in_app_iff in IHn);cbn in IHn).
       1:specialize (proj1(IHn _ a0) ltac:(eauto)).
       1:repeat (autorewrite with list in *;cbn in * ).
       1:now omega.

       1:specialize (proj1(IHn _ a) ltac:(eauto)).
       1:repeat (autorewrite with list in *;cbn in * ).
       1:now omega.

       1:apply lookup_el in H2 as (?&?).
       1:specialize (proj2 (IHn _ a) _ ltac:(eauto)).
       1:repeat (autorewrite with list in *;cbn in * ).
       1:now omega.

       1:specialize (proj1(IHn _ a) ltac:(eauto)).
       1:repeat (autorewrite with list in *;cbn in * ).
       1:now omega.
      * apply IHn. intuition.
     +intros ? Hel. inv R2.
      1,3,4:now apply IHn.
      inv H2.
      apply in_app_or in Hel.
      edestruct Hel as [|[[= -> ->]|[]]].
      1:specialize (proj2(IHn _ a) _ ltac:(eauto)).
      all:autorewrite with list;cbn.
      now omega.
      1:specialize (proj1(IHn _ a) ltac:(eauto)).
      1:specialize (proj1(IHn _ beta) ltac:(eauto)).
      omega.
  Qed.

  Lemma length_H : length H <= i.
  Proof.
    induction i in T,V,H,R|-*.
    -inv R. cbn;omega.
    -replace (S n) with (n + 1) in R by omega.
     apply pow_add in R. destruct R as [[[T' V'] H'] [R1 R2]].
     specialize (IHn _ _ _ R1).
     eapply rcomp_1 in R2.
     inv R2.
     1,3,4:now omega.
     inv H2. autorewrite with list. cbn. omega.
  Qed.

  Lemma length_TV : length T + length V <= 1+i.
  Proof.
    induction i in T,V,H,R|-*.
    -inv R. cbn;omega.
    -replace (S n) with (n + 1) in R by omega.
     apply pow_add in R. destruct R as [[[T' V'] H'] [R1 R2]].
     specialize (IHn _ _ _ R1).
     eapply rcomp_1 in R2.
     inv R2.
     all:cbn in *. all:omega.
  Qed.

  Definition sizeC g :=
    match g with
      P!a => sizeP P + a
    end.
  Definition sizeHE e :=
    match e with
      heapEntryC g b => sizeC g + b
    end.
  Definition sizeH H :=
    sum (map sizeHE H).

  Definition sizeSt '(T,V,H) := sum (map sizeC T) + sum (map sizeC V) + sizeH H.

  Lemma list_bound X size m (A:list X):
    (forall x, x el A -> size x <= m) -> sum (map size A) <= length A * m.
  Proof.
    induction A;cbn;intros H'. omega.
    rewrite IHA. rewrite H'. omega. tauto. intuition.
  Qed.

  Lemma correctSpace:
    sizeSt (T,V,H) <= (i + 1) * (3*i+4*size s).
  Proof.
    cbn. rewrite <- sum_app,<-map_app. unfold sizeH.
    rewrite list_bound with (size:=sizeC) (m:=2*size s + i).
    rewrite list_bound with (size:=sizeHE) (m:=2*size s + 2*i).
    rewrite length_H. rewrite app_length,length_TV.
    lia.
    -intros [[]] H'. cbn - [mult sizeP]. edestruct size_clos as [H1 H2].
     apply H2 in H' as (->&->&->).
     rewrite length_H. omega.
    -intros [] H'. cbn - [mult sizeP]. edestruct size_clos as [H1 H2].
     apply H1 in H' as (->&->).
     rewrite length_H. omega.
  Qed.

End Analysis.

(** ** Bonus:  Unfolding on Programs *)

(** We define a function f to unfold a closure, needed for the Turing machine M_unf. *)

Section UnfoldPro.

  Variable H : list heapEntry.

  Fixpoint f (P:Pro) a k fuel {struct fuel}: option Pro :=
    match fuel with
      0 => None
    | S fuel =>
      match P,k with
       (* [retT],0 => Some [retT] *)
      | retT::P,S k =>
        match f P a k fuel with
          Some P' => Some (retT::P')
        | _ => None
        end
      | appT::P,_ =>
        match f P a k fuel with
          Some P' => Some (appT::P')
        | _ => None
        end
      | lamT::P,_ =>
        match f P a (S k) fuel with
          Some P' => Some (lamT::P')
        | _ => None
        end
      | varT n::P,_ =>
        if Dec (n >= k) then
          match lookup H a (n-k) with
            Some (closC Q b) =>
            match f Q b 1 fuel,f P a k fuel with
              Some Q', Some P' =>
              Some (lamT::Q'++retT::P')
            | _,_ => None
            end
          | _ => None
          end
        else
          match f P a k fuel with
            Some P' =>
            Some (varT n::P')
          | _ => None
          end
      |[],_ => Some []
      |_,_ => None
      end
    end.

  Lemma f_mono P a k n n' :
    n <= n' -> f P a k n <> None -> f P a k n' = f P a k n.
  Proof.
    induction n in P,a,k,n'|-*. now cbn.
    destruct n'. now omega.
    intros leq eq. cbn in eq|-*.
    repeat (let eq := fresh "eq" in destruct _ eqn:eq).
    all:try congruence.
    all:  repeat match goal with
            _ : S ?n <= S ?n',
                H : (f ?P ?a ?k ?n' = _) ,
                    H' : (f ?P ?a ?k ?n = _)
            |- _ => rewrite IHn in H;[ | omega | congruence]
                    end.
    all:congruence.
  Qed.

  Lemma f_correct' Q Q' a k s s' n:
    unfolds H a k s s' ->
    f Q a k n = Some Q' ->
    exists n', f (compile s++Q) a k n' = Some (compile s' ++ Q').
  Proof.
    induction s' in Q',Q,a,k,s,n |- *;intros H' eq.
    inv H'.
    - exists (S n). cbn. decide _. omega.
      now rewrite eq.
    - cbn. exfalso. inv H2. inv H3.
    - inv H'.
      {exfalso.  inv H2. inv H3. }
      cbn [compile].
      autorewrite with list.
      edestruct IHs'2 with (Q:=appT::Q) (n:=S n) as [n2 eq2]. 1:eassumption.
      cbn. now rewrite eq.
      edestruct IHs'1 as [n1 eq1]. 1:eassumption.
      2:{
        eexists. erewrite eq1. reflexivity.
      }
      eassumption.
    -inv H'.
     +inv H2. inv H3.
      edestruct IHs' with (n:=1)(Q:=@nil Tok) as [n1 eq1]. eassumption.
      reflexivity.
      autorewrite with list in eq1.
      exists (S (max n n1)).
      cbn. decide _. 2:omega. rewrite H1. erewrite f_mono.
      rewrite eq1. erewrite f_mono. rewrite eq.
      autorewrite with list. reflexivity.
      1,3:now apply Nat.max_case_strong;omega.
      1-2:congruence.
     + cbn.        edestruct IHs' as [n1 eq1].
       3:{eexists (S _).
       cbn.
       autorewrite with list.
       cbn. rewrite eq1. reflexivity. }
       eassumption.
       instantiate (1 := S n).
       cbn. rewrite eq. now destruct Q.
  Qed.

  Lemma f_correct a s s' k:
    unfolds H a k s s' ->
    exists n', f (compile s) a k n' = Some (compile s').
  Proof.
    intros H'.
    specialize (f_correct' (n:=1) (Q:=@nil Tok) (Q':=@nil Tok) H') as [n eq].
    reflexivity.
    autorewrite with list in eq.
    eexists. rewrite eq. reflexivity.
  Qed.

  Lemma f_correct_final P a s:
    reprC H (P!a) s ->
    exists t, s = lam t /\ exists n, f P a 1 n = Some (compile t).
  Proof.
    intros H'. inv H'. inv H4. inv H6.
    specialize (f_correct H2) as eq. eauto.
  Qed.

End UnfoldPro.

Lemma unfolds_inj H k s a s1 s2 :
  unfolds H k s a s1 -> unfolds H k s a s2 -> s1=s2.
Proof.
  induction 1 in s2|-*;intros H';inv H';try congruence;try omega.
  -apply IHunfolds.
   replace b with b0 in * by congruence.
   inv H2. inv H7.
   replace s1 with s in * by (apply compile_inj;congruence). tauto.
  -f_equal. apply IHunfolds. auto.
  -f_equal. all:auto.
Qed.