(** * LogRel.BundledAlgorithmicTyping: algorithmic typing bundled with its pre-conditions, and a tailored induction principle. *)
From LogRel.AutoSubst Require Import core unscoped Ast Extra.
From LogRel Require Import Utils BasicAst Notations Context NormalForms Weakening UntypedReduction GenericTyping DeclarativeTyping DeclarativeInstance AlgorithmicTyping DeclarativeSubst TypeConstructorsInj.

Import DeclarativeTypingProperties AlgorithmicTypingData.

(** ** Definition of bundled algorithmic typing *)

(** The idea of these definitions is to put together an algorithmic derivation with the
pre-conditions that ensure it is sensible. Indeed, for instance [Γ |-[al] A] does not
re-check that Γ is well-typed: in the algorithm, this information is instead maintained as
an invariant. But this means that algorithmic variants, do not unconditionally
imply its declarative counterpart, they only do so if their pre-conditions are fulfilled,
eg if the context or type are well-formed. *)

(** Also note that in the case of judgements that “output” a type, ie type inference and
neutral conversion, we allow for an arbitrary conversion to “rectify” the output type.
This makes it easier to handle these in the logical relation, because it means the interface
is stable by arbitrary conversion. *)

(** In the case of a context, there is no judgement, only a pre-condition, as algorithmic
typing never re-checks a context. *)
Record WfContextBun Γ :=
{
  bn_wf_ctx : [|-[de] Γ] ;
}.

Record WfTypeBun Γ A :=
{
  bun_wf_ty_ctx : [|-[de] Γ] ;
  bun_wf_ty : [Γ |-[al] A] ;
}.

Record InferBun Γ A t :=
{
  bun_inf_ctx : [|-[de] Γ] ;
  bun_inf : [Γ |-[al] t ▹ A]
}.

Record InferConvBun Γ A t :=
{
  bun_inf_conv_ctx : [|-[de] Γ] ;
  bun_inf_conv_ty : term ;
  bun_inf_conv_inf : [Γ |-[al] t ▹ bun_inf_conv_ty] ;
  (** Allows to change the type to any convertible one. *)
  bun_inf_conv_conv : [Γ |-[de] bun_inf_conv_ty ≅ A]
}.

Record InferRedBun Γ A t :=
{
  bun_inf_red_ctx : [|-[de] Γ] ;
  bun_inf_red : [Γ |-[al] t ▹h A]
}.

Record CheckBun Γ A t :=
{
  bun_chk_ctx : [|-[de] Γ] ;
  bun_chk_ty : [Γ |-[de] A] ;
  bun_chk : [Γ |-[al] t ◃ A]
}.

Record ConvTypeBun Γ A B :=
{
  bun_conv_ty_ctx : [|-[de] Γ] ;
  bun_conv_ty_l : [Γ |-[de] A] ;
  bun_conv_ty_r : [Γ |-[de] B] ;
  bun_conv_ty : [Γ |-[al] A ≅ B]
}.

Record ConvTypeRedBun Γ A B :=
{
  bun_conv_ty_red_ctx : [|-[de] Γ] ;
  bun_conv_ty_red_l : [Γ |-[de] A] ;
  bun_conv_ty_red_wh_l : isType A ;
  bun_conv_ty_red_r : [Γ |-[de] B] ;
  bun_conv_ty_red_wh_r : isType B ;
  bun_conv_ty_red : [Γ |-[al] A ≅h B]
}.

Record ConvTermBun Γ A t u :=
{
  bun_conv_tm_ctx : [|-[de] Γ] ;
  bun_conv_tm_ty : [Γ |-[de] A] ;
  bun_conv_tm_l : [Γ |-[de] t : A] ;
  bun_conv_tm_r : [Γ |-[de] u : A] ;
  bun_conv_tm : [Γ |-[al] t ≅ u : A]
}.

Record ConvTermRedBun Γ A t u :=
{
  bun_conv_tm_red_ctx : [|-[de] Γ] ;
  bun_conv_tm_red_ty : [Γ |-[de] A] ;
  bun_conv_tm_red_wh_ty : isType A ;
  bun_conv_tm_red_l : [Γ |-[de] t : A] ;
  bun_conv_tm_red_wh_l : whnf t ;
  bun_conv_tm_red_r : [Γ |-[de] u : A] ;
  bun_conv_tm_red_wh_r : whnf u ;
  bun_conv_tm_red : [Γ |-[al] t ≅h u : A]
}.

Record ConvNeuBun Γ A m n :=
{
  bun_conv_ne_ctx : [|-[de] Γ] ;
  bun_conv_ne_l : ∑ T, [Γ |-[de] m : T] ;
  bun_conv_ne_wh_l : whne m ;
  bun_conv_ne_r : ∑ T, [Γ |-[de] n : T] ;
  bun_conv_ne_wh_r : whne n ;
  bun_conv_ne : [Γ |-[al] m ~ n ▹ A]
}.

Record ConvNeuRedBun Γ A m n :=
{
  bun_conv_ne_red_ctx : [|-[de] Γ] ;
  bun_conv_ne_red_l : ∑ T, [Γ |-[de] m : T] ;
  bun_conv_ne_red_wh_l : whne m ;
  bun_conv_ne_red_r : ∑ T, [Γ |-[de] n : T] ;
  bun_conv_ne_red_wh_r : whne n ;
  bun_conv_ne_red : [Γ |-[al] m ~h n ▹ A]
}.

Record ConvNeuConvBun Γ A m n :=
{
  bun_conv_ne_conv_ctx : [|-[de] Γ] ;
  bun_conv_ne_conv_l : ∑ T, [Γ |-[de] m : T] ;
  bun_conv_ne_conv_wh_l : whne m ;
  bun_conv_ne_conv_r : ∑ T, [Γ |-[de] n : T] ;
  bun_conv_ne_conv_wh_r : whne n ;
  bun_conv_ne_conv_ty : term ;
  bun_conv_ne_conv : [Γ |-[al] m ~ n ▹ bun_conv_ne_conv_ty] ;
  bun_conv_ne_conv_conv : [Γ |-[de] bun_conv_ne_conv_ty ≅ A]
}.

Record RedTypeBun Γ A B :=
{
  bun_red_ty_ctx : [|-[de] Γ] ;
  bun_red_ty_ty : [Γ |-[al] A] ;
  bun_red_ty : [A ⇒* B] ;
}.

Record OneStepRedTermBun Γ A t u :=
{
  bun_osred_tm_ctx : [|-[de] Γ] ;
  (** We do not have the instance yet, so we have to specify it by hand,
  but this really is [Γ |-[bn] t : A]. *)
  bun_osred_tm_tm : typing (ta := bn) (Typing := InferConvBun) Γ A t ;
  bun_osred_tm : [t ⇒ u]
}.

Record RedTermBun Γ A t u :=
{
  bun_red_tm_ctx : [|-[de] Γ] ;
  bun_red_tm_tm : typing (ta := bn) (Typing := InferConvBun) Γ A t ;
  bun_red_tm : [t ⇒* u] ;
}.

Record RedTypeBunI Γ A B :=
{
  buni_red_ty_ctx : [|-[de] Γ] ;
  buni_red_ty_ty : [Γ |-[de] A] ;
  buni_red_ty : [A ⇒* B] ;
}.

Record OneStepRedTermBunI Γ A t u :=
{
  buni_osred_tm_ctx : [|-[de] Γ] ;
  buni_osred_tm_tm : [Γ |-[de] t : A] ;
  buni_osred_tm : [t ⇒ u]
}.

Record RedTermBunI Γ A t u :=
{
  buni_red_tm_ctx : [|-[de] Γ] ;
  buni_red_tm_tm : [Γ |-[de] t : A] ;
  buni_red_tm : [t ⇒* u] ;
}.

(** ** Instances *)

(** We actually define two instances, one fully-algorithmic and one where only conversion
is algorithmic, but typing is not. This is needed because we cannot show right away that
(bundled) algorithmic typing has all the properties to be an instance of the generic interface.
The issue is that the logical relation does not give enough properties of neutrals, in particular
we cannot derive that neutral application is injective, ie if [tApp n u] and [tApp n' u'] are
convertible then [n] and [n'] are and so are [u] and [u']. Thus, we use the mixed instance, which
we can readily show, to gather more properties of conversion, enough to show the fully
algorithmic one. *)

Module BundledTypingData.

  #[export] Instance WfContext_Bundle : WfContext bn := WfContextBun.
  #[export] Instance WfType_Bundle : WfType bn := WfTypeBun.
  #[export] Instance Inferring_Bundle : Inferring bn := InferBun.
  #[export] Instance InferringRed_Bundle : InferringRed bn := InferRedBun.
  #[export] Instance Typing_Bundle : Typing bn := InferConvBun.
  #[export] Instance Checking_Bundle : Checking bn := CheckBun.
  #[export] Instance ConvType_Bundle : ConvType bn := ConvTypeBun.
  #[export] Instance ConvTypeRed_Bundle : ConvTypeRed bn :=  ConvTypeRedBun.
  #[export] Instance ConvTerm_Bundle : ConvTerm bn := ConvTermBun.
  #[export] Instance ConvTermRed_Bundle : ConvTermRed bn := ConvTermRedBun.
  #[export] Instance ConvNeu_Bundle : ConvNeu bn := ConvNeuBun.
  #[export] Instance ConvNeuRed_Bundle : ConvNeuRed bn := ConvNeuRedBun.
  #[export] Instance ConvNeuConv_Bundle : ConvNeuConv bn := ConvNeuConvBun.
  #[export] Instance RedType_Bundle : RedType bn := RedTypeBun.
  #[export] Instance OneStepRedTerm_Bundle : OneStepRedTerm bn := OneStepRedTermBun.
  #[export] Instance RedTerm_Bundle : RedTerm bn := RedTermBun.

  Ltac fold_bun :=
    change WfContextBun with (wf_context (ta := bn)) in *;
    change WfTypeBun with (wf_type (ta := bn)) in *;
    change InferBun with (inferring (ta := bn)) in * ;
    change InferRedBun with (infer_red (ta := bn)) in * ;
    change InferConvBun with (typing (ta := bn)) in * ;
    change CheckBun with (check (ta := bn)) in * ;
    change ConvTypeBun with (conv_type (ta := bn)) in * ;
    change ConvTermBun with (conv_term (ta := bn)) in * ;
    change ConvNeuBun with (conv_neu (ta := bn)) in * ;
    change ConvTypeRedBun with (conv_type_red (ta := bn)) in * ;
    change ConvTermRedBun with (conv_term_red (ta := bn)) in * ;
    change ConvNeuRedBun with (conv_neu_red (ta := bn)) in *;
    change ConvNeuConvBun with (conv_neu_conv (ta := bn)) in *;
    change RedTypeBun with (red_ty (ta := bn)) in * ;
    change OneStepRedTermBun with (osred_tm (ta := bn)) in * ;
    change RedTermBun with (red_tm (ta := bn)) in *.

End BundledTypingData.

Import BundledTypingData.

Module BundledIntermediateData.

  #[export] Instance WfContext_BundleInt : WfContext bni := WfContextDecl.
  #[export] Instance WfType_BundleInt : WfType bni := WfTypeDecl.
  #[export] Instance Typing_BundleInt : Typing bni := TypingDecl.
  #[export] Instance ConvType_BundleInt : ConvType bni := ConvTypeBun.
  #[export] Instance ConvTerm_BundleInt : ConvTerm bni := ConvTermBun.
  #[export] Instance ConvNeuConv_BundleInt : ConvNeuConv bni := ConvNeuConvBun.
  #[export] Instance RedType_BundleInt : RedType bni := RedTypeBunI.
  #[export] Instance OneStepRedTerm_BundleInt : OneStepRedTerm bni := OneStepRedTermBunI.
  #[export] Instance RedTerm_BundleInt : RedTerm bni := RedTermBunI.

  Ltac unfold_bni :=
    change (wf_context (ta := bni)) with (wf_context (ta := de)) in *;
    change (wf_type (ta := bni)) with (wf_type (ta := de)) in *;
    change (typing (ta := bni)) with (typing (ta := de)) in * ;
    change (conv_type (ta := bni)) with (conv_type (ta := bn)) in * ;
    change (conv_term (ta := bni)) with (conv_term (ta := bn)) in * ;
    change (conv_neu_conv (ta := bni)) with (conv_neu_conv (ta := bn)) in *.

End BundledIntermediateData.

Set Universe Polymorphism.

(** ** Induction principle for bundled algorithmic conversion *)

(** We show an induction principle tailored for the bundled predicates: it threads the invariants
of the algorithm through the derivation, giving us stronger hypothesis in the minor premises,
corresponding to both the pre-conditions being true, and the post-conditions of the induction
hypotheses holding. *)

Section BundledConv.
  Universe u.

  Context (PTyEq PTyRedEq : context -> term -> term -> Type@{u})
  (PNeEq PNeRedEq PTmEq PTmRedEq : context -> term -> term -> term -> Type@{u}).

  (** Rather than writing by hand the various large statements of the induction principles,
  we use Ltac to derive them generically. Hopefully, there is no need to touch any part of
  this code when extending modifying the language with more features. *)
  #[local] Ltac pre_cond Hyp :=
    lazymatch Hyp with
    | context [PTyEq ?Γ ?A ?B] =>
        constr:([|-[de] Γ] -> [Γ |-[de] A] -> [Γ |-[de] B] -> Hyp)
    | context [PTyRedEq ?Γ ?A ?B] =>
        constr:([|-[de] Γ] -> [Γ |-[de] A] -> [Γ |-[de] B] -> Hyp)
    | context [PNeEq ?Γ ?A ?t ?u] =>
        constr:([|-[de] Γ] -> (∑ T, [Γ |-[de] t : T]) -> (∑ T, [Γ |-[de] u : T]) -> Hyp)
    | context [PNeRedEq ?Γ ?A ?t ?u] =>
        constr:([|-[de] Γ] -> (∑ T, [Γ |-[de] t : T]) -> (∑ T, [Γ |-[de] u : T]) -> Hyp)
    | context [PTmEq ?Γ ?A ?t ?u] =>
        constr:([|-[de] Γ] -> ([Γ |-[de] t : A]) -> ([Γ |-[de] u : A]) -> Hyp)
    | context [PTmRedEq ?Γ ?A ?t ?u] =>
        constr:([|-[de] Γ] -> ([Γ |-[de] t : A]) -> ([Γ |-[de] u : A]) -> Hyp)
    end.

  #[local] Ltac post_cond Hyp :=
    lazymatch Hyp with
    | context C [PTyEq ?Γ ?A ?B] =>
        context C [PTyEq Γ A B × [Γ |-[de] A ≅ B]]
    | context C [PTyRedEq ?Γ ?A ?B] =>
        context C [PTyRedEq Γ A B × [Γ |-[de] A ≅ B]]
    | context C [PNeEq ?Γ ?A ?m ?n] =>
        context C [PNeEq Γ A m n ×
          [× ([Γ |-[de] m ≅ n : A]),
          (forall T, [Γ |-[de] m : T] -> [Γ |-[de] A ≅ T]) &
          (forall T, [Γ |-[de] n : T] -> [Γ |-[de] A ≅ T])]]
    | context C [PNeRedEq ?Γ ?A ?m ?n] =>
        context C [PNeRedEq Γ A m n ×
          [× ([Γ |-[de] m ≅ n : A]),
          (forall T, [Γ |-[de] m : T] -> [Γ |-[de] A ≅ T]) &
          (forall T, [Γ |-[de] n : T] -> [Γ |-[de] A ≅ T])]]
    | context C [PTmEq ?Γ ?A ?t ?u] =>
        context C [PTmEq Γ A t u × [Γ |-[de] t ≅ u : A]]
    | context C [PTmRedEq ?Γ ?A ?t ?u] =>
        context C [PTmRedEq Γ A t u × [Γ |-[de] t ≅ u : A]]
    | ?Hyp' => Hyp'
    end.

  #[local] Ltac bundle Hyp :=
    lazymatch Hyp with
      | [?Γ |-[al] ?A ≅ ?B] => constr:([Γ |-[bn] A ≅ B])
      | [?Γ |-[al] ?A ≅h ?B] => constr:([Γ |-[bn] A ≅h B])
      | [?Γ |-[al] ?t ≅ ?u : ?A] => constr:([Γ |-[bn] t ≅ u : A])
      | [?Γ |-[al] ?t ≅h ?u : ?A] => constr:([Γ |-[bn] t ≅h u : A])
      | [?Γ |-[al] ?m ~ ?n ▹ ?A] => constr:([Γ |-[bn] m ~ n ▹ A])
      | [?Γ |-[al] ?m ~h ?n ▹ ?A] => constr:([Γ |-[bn] m ~h n ▹ A])
      | ?Hyp' => constr:(Hyp')
    end.

  #[local] Ltac strong_step step :=
    lazymatch step with
      | ?Hyp -> ?T => let Hyp' := (post_cond Hyp) with T' := (strong_step T) in constr:(Hyp' -> T')
      | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:(
      let T' := ltac:(eval hnf in (T x)) in let T'' := strong_step T' in exact T''))
      | ?T => (pre_cond T)
    end.

  (* Eval cbn beta in ltac:(let T := strong_step (forall (Γ : context) (na' : aname) (A B A' B' : term),
    [Γ |-[ al ] A ≅ A'] ->
    PTyEq Γ A A' ->
    [Γ,, A |-[ al ] B ≅ B'] ->
    PTyEq (Γ,, A) B B' -> PTyRedEq Γ (tProd A B) (tProd na' A' B')) in exact T).
  *)

  #[local] Ltac weak_concl concl :=
    lazymatch concl with
    | ?Hyp -> ?T => let T' := weak_concl T in let Hyp' := bundle Hyp in constr:(Hyp' -> T')
    | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:(
      let T' := ltac:(eval hnf in (T x)) in let T'' := weak_concl T' in exact T''))
    | ?T => constr:(T)
    end.

  #[local] Ltac strong_concl concl :=
  lazymatch concl with
  | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:(
    let T' := ltac:(eval hnf in (T x)) in let T'' := strong_concl T' in exact T''))
  | ?T => let T' := (post_cond T) in let T'' := (pre_cond T') in constr:(T'')
  end.

  #[local] Ltac strong_statement T :=
    lazymatch T with
      | ?Step -> ?T => let Step' := strong_step Step in let T' := strong_statement T in constr:(Step' -> T')
      | ?Chd × ?Ctl => let Chd' := strong_concl Chd in let Ctl' := strong_statement Ctl in constr:(Chd' × Ctl')
      | ?Cend => let Cend' := strong_concl Cend in constr:(Cend')
    end.

  #[local] Ltac weak_statement T :=
  lazymatch T with
    | ?Step -> ?T => let Step' := strong_step Step in let T' := weak_statement T in constr:(Step' -> T')
    | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl')
    | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl')
    | ?Cend => let Cend' := weak_concl Cend in constr:(Cend')
  end.

  #[local] Definition algo_conv_discipline_stmt :=
    ltac:(
      let t := (type of (AlgoConvInduction PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq)) in
      let ind := strong_statement t in
      exact ind).

  (** The main theorem *)
  Theorem algo_conv_discipline : algo_conv_discipline_stmt.
  Proof.
    unfold algo_conv_discipline_stmt; intros.
    apply AlgoConvInduction.
    - intros * HA HB ? IHA' ? ? ?.
      pose proof (HA' := HA).
      pose proof (HB' := HB).
      eapply subject_reduction_type, RedConvTyC in HA', HB' ; tea.
      destruct IHA'.
      1-3: boundary.
      split ; [now eauto|..].
      symmetry in HB'.
      do 2 etransitivity ; tea.
      now econstructor.
    - intros * ? IHA ? IHB ? HP HP'.
      eapply prod_ty_inv in HP as [], HP' as [? HB'].
      assert [Γ,, A |-[de] B'].
      { eapply stability ; tea.
        econstructor.
        1: now eapply ctx_refl.
        now eapply IHA.
      }
      split ; [gen_typing|..].
      destruct IHB as [].
      1-3: gen_typing.
      now econstructor.
    - intros.
      split ; [now eauto|..].
      now gen_typing.
    - intros * ?? _.
      split ; [gen_typing|..].
      now econstructor.
    - intros * ?? _.
      split ; [gen_typing|..].
      now econstructor.
    - intros * Hconv IH ? HM HN.
      assert [Γ |-[de] M : U].
      {
        eapply algo_conv_wh in Hconv as [neM neN].
        inversion HM ; subst ; clear HM.
        1-4: now inversion neM.
        assumption.
      }
      assert [Γ |-[de] N : U].
      {
        eapply algo_conv_wh in Hconv as [neM neN].
        inversion HN ; subst ; clear HN.
        1-4: now inversion neN.
        assumption.
      }
      split ; [now eauto|..].
      do 2 econstructor.
      all: now apply IH.
    - intros * Hin ? [] _.
      split ; [now eauto|..].
      split.
      + do 2 constructor ; gen_typing.
      + intros T Hty.
        eapply termGen' in Hty as [? [[? [->]] ?]].
        eapply in_ctx_inj in Hin ; tea ; subst.
        eassumption.
      + intros T Hty.
        eapply termGen' in Hty as [? [[? [->]] ?]].
        eapply in_ctx_inj in Hin ; tea ; subst.
        eassumption.
    - intros * ? IHm ? IHt ? Htym Htyn.
      pose proof Htym as [? Htym'].
      pose proof Htyn as [? Htyn'].
      eapply termGen' in Htym' as [? [[? [? [-> Htym']]] ?]].
      eapply termGen' in Htyn' as [? [[? [? [-> Htyn']]] ?]].
      edestruct IHm as [? [IHmc IHm' IHn']].
      1: easy.
      1-2: now econstructor.
      unshelve eapply IHm', prod_ty_inj in Htym' as [].
      unshelve eapply IHn', prod_ty_inj in Htyn' as [].
      edestruct IHt.
      1: easy.
      1-2: now gen_typing.
      split ; [now eauto|..].
      split.
      + econstructor ; gen_typing.
      + intros ? Happ.
        eapply termGen' in Happ as [? [(?&?&[-> Htym']) ?]].
        eapply IHm', prod_ty_inj in Htym' as [].
        etransitivity ; [..|eassumption].
        eapply typing_subst1 ; tea.
        now econstructor.
      + intros ? Happ.
        eapply termGen' in Happ as [? [(?&?&[-> Htyn']) ?]].
        eapply IHn', prod_ty_inj in Htyn' as [HA ?].
        etransitivity ; [..|eassumption].
        eapply typing_subst1.
        2: eassumption.
        symmetry in HA.
        now gen_typing.
    - intros * ? IHn ? IHP ? IHz ? IHs ? Hty Hty'.
      pose proof Hty as [? Hty2].
      pose proof Hty' as [? Hty2'].
      eapply termGen' in Hty2 as [? [[->]]].
      eapply termGen' in Hty2' as [? [[->]]].
      edestruct IHn as [? [IHnc IHnty IHnty']].
      1: easy.
      1-2: now eexists.
      assert [|-[de] Γ,, tNat] by boundary.
      assert [Γ,, tNat |-[de] P ≅ P']
        by now edestruct IHP.
      assert [Γ |-[de] hz' : P[tZero..]].
      {
       econstructor ; tea.
       symmetry.
       eapply typing_subst1 ; tea.
       now do 2 econstructor.
      }
      assert [Γ |-[de] hs' : elimSuccHypTy P].
      {
       econstructor ; tea.
       symmetry.
       now eapply elimSuccHypTy_conv.
      }
      split ; [eauto 10 |..].
      split.
      + now econstructor.
      + now intros ?[? [[->]]]%termGen'.
      + intros ?[? [[->]]]%termGen'.
        etransitivity.
        1: eapply typing_subst1.
        all: eassumption.
    - intros * ? IHe ? IHP ? Hty Hty'.
      pose proof Hty as [? Hty2].
      pose proof Hty' as [? Hty2'].
      eapply termGen' in Hty2 as [? [[->]]].
      eapply termGen' in Hty2' as [? [[->]]].
      edestruct IHe as [? [IHec IHnty IHnty']].
      1: easy.
      1-2: now eexists.
      assert [|-[de] Γ,, tEmpty] by boundary.
      assert [Γ,, tEmpty |-[de] P ≅ P']
        by now edestruct IHP.
      split ; [eauto |..].
      split.
      + now econstructor.
      + now intros ?[? [[->]]]%termGen'.
      + intros ?[? [[->]]]%termGen'.
        etransitivity.
        1: eapply typing_subst1.
        all: eassumption.
    - intros * ? IHm HA ? ? Htym Htyn.
      pose proof Htym as [? Htym'].
      pose proof Htyn as [? Htyn'].
      edestruct IHm as [_ [IHmc IHm' IHn']].
      1: easy.
      1-2: now eexists.
      pose proof (HA' := HA).
      eapply subject_reduction_type, RedConvTyC in HA'.
      2: boundary.
      split ; [now eauto|..].
      split.
      + gen_typing.
      + intros.
        symmetry in HA'.
        etransitivity ; gen_typing.
      + intros.
        symmetry in HA'.
        etransitivity ; gen_typing.
    - intros * HA Ht Hu ? IH ? Htyt Htyu.
      pose proof (HA' := HA).
      pose proof (Ht' := Ht).
      pose proof (Hu' := Hu).
      eapply subject_reduction_type, RedConvTyC in HA'.
      2: boundary.
      eapply subject_reduction, RedConvTeC in Ht' ; tea.
      eapply subject_reduction, RedConvTeC in Hu' ; tea.
      pose proof (Ht'' := Ht').
      pose proof (Hu'' := Hu').
      eapply boundary in Ht'' as [], Hu'' as [].
      split ; [now gen_typing|..].
      etransitivity ; [..|etransitivity].
      1: eassumption.
      2: now symmetry.
      econstructor.
      2: now symmetry.
      eapply IH.
      all: gen_typing.
    - intros * ? IHA ? IHB ? Hty Hty'.
      pose proof (Htyd := Hty).
      pose proof (Htyd' := Hty').
      eapply termGen' in Htyd as [? [[->] _]].
      eapply termGen' in Htyd' as [? [[->] _]].
      assert [Γ,, A |-[de] B' : U].
      { eapply stability ; tea.
        econstructor.
        1: now eapply ctx_refl.
        now econstructor.
      }
      split ; [now gen_typing|..].
      econstructor.
      + assumption.
      + now eapply IHA.
      + now eapply IHB ; gen_typing.
    - intros.
      split ; [eauto|..].
      now econstructor.
    - intros.
      split ; [eauto|..].
      now econstructor.
    - intros * ? IHt ? Htyt Htyt'.
      pose proof (Htyd := Htyt).
      pose proof (Htyd' := Htyt').
      eapply termGen' in Htyd as [? [[->] _]].
      eapply termGen' in Htyd' as [? [[->] _]].
      split ; [eauto|..].
      now econstructor.
    - intros.
      split ; eauto.
      now econstructor.
    - intros * ? ? ? IH ? Hf Hg.
      assert [Γ |-[de] A] by
        (now eapply boundary, prod_ty_inv in Hf).
      pose proof (Hf' := Hf).
      pose proof (Hg' := Hg).
      eapply typing_eta' in Hf'.
      eapply typing_eta' in Hg'.
      split ; [now gen_typing|..].
      econstructor ; tea.
      now eapply IH ; gen_typing.
    - intros * ? IHm ? ? Htym Htyn.
      edestruct IHm as [? [? Hm']].
      1: easy.
      1-2: now eexists.
      split ; [now eauto|..].
      econstructor ; tea.
      now eapply Hm'.
Qed.

  Definition BundledConvInductionConcl : Type :=
    ltac:(let t := eval red in (AlgoConvInductionConcl PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq) in
      let t' := weak_statement t in exact t').

  (** As a corollary, we get the desired induction principle. The difference with the above one
  is that we do not get the post-condition of the algorithm in the conclusion, but this is
  in general not necessary. *)
  Corollary BundledConvInduction :
    ltac:(
      let t := (type of (AlgoConvInduction PTyEq PTyRedEq PNeEq PNeRedEq PTmEq PTmRedEq)) in
      let ind := weak_statement t in
      exact ind).
  Proof.
    intros.
    repeat split.
    all: intros * [].
    all: apply algo_conv_discipline ; assumption.
  Qed.

End BundledConv.

(** ** Soundness of algorithmic conversion *)

(** Contrarily to the induction principle above, if we instantiate the main principle with
only constant true predicates, we get only the post-conditions, ie a soundness theorem: bundled algorithmic conversion judgments imply their declarative counterparts. *)

Section ConvSoundness.

  Let PTyEq (Γ : context) (A B : term) :=
    [Γ |-[de] A] ->
    [Γ |-[de] B] ->
    [Γ |-[de] A ≅ B].
  Let PTmEq (Γ : context) (A t u : term) :=
    [Γ |-[de] t : A] -> [Γ |-[de] u : A] ->
    [Γ |-[de] t ≅ u : A].
  Let PNeEq (Γ : context) (A : term) (m n : term) :=
    (∑ T, [Γ |-[de] m : T]) ->
    (∑ T, [Γ |-[de] n : T]) ->
    [× [Γ |-[de] m ≅ n : A],
      (forall T, [Γ |-[de] m : T] -> [Γ |-[de] A ≅ T]) &
      (forall T, [Γ |-[de] n : T] -> [Γ |-[de] A ≅ T])].

  Theorem conv_sound : AlgoConvInductionConcl PTyEq PTyEq PNeEq PNeEq PTmEq PTmEq.
  Proof.
    subst PTyEq PTmEq PNeEq.
    red.
    pose proof (algo_conv_discipline
      (fun _ _ _ => True) (fun _ _ _ => True) (fun _ _ _ _ => True)
      (fun _ _ _ _ => True) (fun _ _ _ _ => True) (fun _ _ _ _ => True)) as [H' H] ;
    cycle -1.
    1:{
      repeat (split ; [
      intros ; apply H' ; tea ; match goal with H : sigT _ |- _ => destruct H | _ => idtac end ; gen_typing
      | ..] ; clear H' ; try destruct H as [H' H]).
      intros ; apply H ; gen_typing. }
    all: now constructor.
  Qed.

End ConvSoundness.

Theorem bn_conv_sound :
BundledConvInductionConcl
  (fun Γ A B => [Γ |-[de] A ≅ B])
  (fun Γ A B => [Γ |-[de] A ≅ B])
  (fun Γ A t u => [Γ |-[de] t ≅ u : A])
  (fun Γ A t u => [Γ |-[de] t ≅ u : A])
  (fun Γ A t u => [Γ |-[de] t ≅ u : A])
  (fun Γ A t u => [Γ |-[de] t ≅ u : A]).
Proof.
  red.
  prod_splitter.
  all: intros * [].
  all: match goal with H : context [al] |- _ => eapply conv_sound in H end.
  all: prod_hyp_splitter.
  all: try eassumption.
  all: now eexists.
Qed.

(** ** Induction principle for bundled algorithmic typing *)

(** This is repeating the same ideas as before, but for typing. *)

Section BundledTyping.

  Context (PTy : context -> term -> Type)
    (PInf PInfRed PCheck : context -> term -> term -> Type).

  #[local] Ltac pre_cond Hyp :=
    lazymatch Hyp with
    | context [PTy ?Γ ?A] =>
        constr:([|-[de] Γ] -> Hyp)
    | context [PInf ?Γ ?A ?t] =>
        constr:([|-[de] Γ] -> Hyp)
    | context [PInfRed ?Γ ?A ?t] =>
        constr:([|-[de] Γ] -> Hyp)
    | context [PCheck ?Γ ?A ?t] =>
        constr:([|-[de] Γ] -> [Γ |-[de] A] -> Hyp)
    end.

  #[local] Ltac post_cond Hyp :=
    lazymatch Hyp with
    | context C [PTy ?Γ ?A] =>
        context C [PTy Γ A × [Γ |-[de] A]]
    | context C [PInf ?Γ ?A ?t] =>
        context C [PInf Γ A t × [Γ |-[de] t : A]]
    | context C [PInfRed ?Γ ?A ?t] =>
        context C [PInfRed Γ A t × [Γ |-[de] t : A]]
    | context C [PCheck ?Γ ?A ?t] =>
        context C [PCheck Γ A t × [Γ |-[de] t : A]]
    | ?Hyp' => Hyp'
    end.

  #[local] Ltac bundle Hyp :=
    lazymatch Hyp with
      | [?Γ |-[al] ?A] => constr:([Γ |-[bn] A])
      | [?Γ |-[al] ?t ▹ ?A] => constr:([Γ |-[bn] t ▹ A])
      | [?Γ |-[al] ?t ▹h ?A] => constr:([Γ |-[bn] t ▹h A])
      | [?Γ |-[al] ?t ◃ ?A] => constr:([Γ |-[bn] t ◃ A])
      | ?Hyp' => constr:(Hyp')
    end.

  #[local] Ltac strong_step step :=
    lazymatch step with
      | ?Hyp -> ?T => let Hyp' := (post_cond Hyp) with T' := (strong_step T) in constr:(Hyp' -> T')
      | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:(
      let T' := ltac:(eval hnf in (T x)) in let T'' := strong_step T' in exact T''))
      | ?T => (pre_cond T)
    end.

  #[local] Ltac weak_concl concl :=
    lazymatch concl with
    | ?Hyp -> ?T => let T' := weak_concl T in let Hyp' := bundle Hyp in constr:(Hyp' -> T')
    | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:(
      let T' := ltac:(eval hnf in (T x)) in let T'' := weak_concl T' in exact T''))
    | ?T => constr:(T)
    end.

  #[local] Ltac strong_concl concl :=
  lazymatch concl with
  | forall x : ?Hyp, @?T x => constr:(forall x : Hyp, ltac:(
    let T' := ltac:(eval hnf in (T x)) in let T'' := strong_concl T' in exact T''))
  | ?T => let T' := (post_cond T) in let T'' := (pre_cond T') in constr:(T'')
  end.

  #[local] Ltac strong_statement T :=
    lazymatch T with
      | ?Step -> ?T => let Step' := strong_step Step in let T' := strong_statement T in constr:(Step' -> T')
      | ?Chd × ?Ctl => let Chd' := strong_concl Chd in let Ctl' := strong_statement Ctl in constr:(Chd' × Ctl')
      | ?Cend => let Cend' := strong_concl Cend in constr:(Cend')
    end.

  #[local] Ltac weak_statement T :=
  lazymatch T with
    | ?Step -> ?T => let Step' := strong_step Step in let T' := weak_statement T in constr:(Step' -> T')
    | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl')
    | ?Chd × ?Ctl => let Chd' := weak_concl Chd in let Ctl' := weak_statement Ctl in constr:(Chd' × Ctl')
    | ?Cend => let Cend' := weak_concl Cend in constr:(Cend')
  end.

  Let PTy' (c : context) (t : term) :=
        [ |-[ de ] c] -> PTy c t × [c |-[ de ] t].
  Let PInf' (c : context) (t t1 : term) :=
     [ |-[ de ] c] -> PInf c t t1 × [c |-[ de ] t1 : t].
  Let PInfRed' (c : context) (t t1 : term) :=
       [ |-[ de ] c] -> PInfRed c t t1 × [c |-[ de ] t1 : t].
  Let PCheck' (c : context) (t t1 : term) :=
         [ |-[ de ] c] ->
         [c |-[ de ] t] -> PCheck c t t1 × [c |-[ de ] t1 : t].

  (** The main theorem *)
  Theorem algo_typing_discipline : ltac:(
    let t := (type of (AlgoTypingInduction PTy PInf PInfRed PCheck)) in
    let ind := strong_statement t in
    exact ind).
  Proof.
    intros.
    subst PTy' PInf' PInfRed' PCheck'.
    apply AlgoTypingInduction.
    1-8: solve [intros ;
      repeat unshelve (
        match reverse goal with
          | IH : context [prod] |- _ => destruct IH ; [..|shelve] ; gen_typing
        end) ;
      now split ; [|econstructor] ; eauto].
    - intros * ? IHI ? IHC ?.
      destruct IHI as [? IHt].
      1: gen_typing.
      destruct IHC ; tea.
      1: now eapply boundary, prod_ty_inv in IHt as [].
      split ; [|econstructor] ; eauto.
    - intros.
      split ; [eauto|..].
      now econstructor.
    - intros.
      split ; [eauto|..].
      now econstructor.
    - intros.
      split ; [eauto|..].
      now econstructor.
    - intros * ? IHn ? IHP ? IHz ? IHs ?.
      assert [|-[de] Γ,, tNat]
        by (econstructor ; tea ; now econstructor).
      assert [Γ |-[ de ] P[tZero..]].
      {
        eapply typing_subst1.
        1: now econstructor.
        now eapply IHP.
      }
      assert [Γ |-[de] elimSuccHypTy P]
        by now eapply elimSuccHypTy_ty.
      split ; [eauto 10 |..].
      econstructor.
      + now eapply IHP.
      + now eapply IHz.
      + now eapply IHs.
      + now eapply IHn.
    - intros.
      split ; [eauto|..].
      now econstructor.
    - intros * ? IHe ? IHP ?.
      assert [|-[de] Γ,, tEmpty]
        by (econstructor ; tea ; now econstructor).
      split ; [eauto|..].
      econstructor.
      + now eapply IHP.
      + now eapply IHe.
    - intros * ? IH HA ?.
      destruct IH as [? IH] ; tea.
      split ; [eauto|..].
      econstructor ; tea.
      eapply subject_reduction_type, RedConvTyC in HA.
      1: eassumption.
      now boundary.
    - intros * ? IHt HA ?.
      destruct IHt as [? IHt] ; eauto.
      split ; [eauto|].
      econstructor ; tea.
      eapply conv_sound in HA ; tea.
      now boundary.
  Qed.

  Definition BundledTypingInductionConcl : Type :=
    ltac:(let t := eval red in (AlgoTypingInductionConcl PTy PInf PInfRed PCheck) in
      let t' := weak_statement t in exact t').

  Corollary BundledTypingInduction :
    ltac:(
      let t := (type of (AlgoTypingInduction PTy PInf PInfRed PCheck)) in
      let ind := weak_statement t in
      exact ind).
  Proof.
    intros.
    repeat match goal with |- prod _ _ => split end.
    all: intros * [].
    all: apply algo_typing_discipline ; assumption.
  Qed.

End BundledTyping.

Section TypingSoundness.

  Let PTy (Γ : context) (A : term) :=
    [|-[de] Γ] -> [Γ |-[de] A].
  Let PInf (Γ : context) (A t : term) :=
    [|-[de] Γ] ->
    [Γ |-[de] t : A].
  Let PCheck (Γ : context) (A t : term) :=
    [Γ |-[de] A] ->
    [Γ |-[de] t : A].

  Theorem typing_sound : AlgoTypingInductionConcl PTy PInf PInf PCheck.
  Proof.
    subst PTy PInf PCheck.
    red.
    pose proof (algo_typing_discipline
      (fun _ _ => True) (fun _ _ _ => True) (fun _ _ _ => True) (fun _ _ _ => True)) as [H' H]
      ;
    cycle -1.
    1: repeat (split ; [
      intros ; apply H' ; tea ; match goal with H : sigT _ |- _ => destruct H | _ => idtac end ; gen_typing
      | ..] ; clear H' ; try destruct H as [H' H]).
    1: now intros ; apply H ; gen_typing.
    all: now constructor.
  Qed.

End TypingSoundness.

Theorem bn_alg_typing_sound :
BundledTypingInductionConcl
  (fun Γ A => [Γ |-[de] A])
  (fun Γ A t => [Γ |-[de] t : A])
  (fun Γ A t => [Γ |-[de] t : A])
  (fun Γ A t => [Γ |-[de] t : A]).
Proof.
  red.
  prod_splitter.
  all: intros * [].
  all: match goal with H : context [al] |- _ => eapply typing_sound in H end.
  all: prod_hyp_splitter.
  all: now eassumption.
Qed.

Lemma bn_typing_sound Γ t A :
  [Γ |-[bn] t : A] -> [Γ |-[de] t : A].
Proof.
  intros [???Hty?].
  econstructor ; tea.
  now eapply typing_sound in Hty.
Qed.

Corollary inf_conv_decl Γ t A A' :
[Γ |-[al] t ▹ A] ->
[Γ |-[de] A ≅ A'] ->
[Γ |-[de] t : A'].
Proof.
  intros Ht Hconv.
  apply typing_sound in Ht.
  2: boundary.
  now econstructor.
Qed.


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

(* Why3 assumption *)
Definition unit := unit.

(* Why3 assumption *)
Definition char := Z.

(* Why3 assumption *)
Inductive regexp :=
  | Empty : regexp
  | Epsilon : regexp
  | Char : Z -> regexp
  | Alt : regexp -> regexp -> regexp
  | Concat : regexp -> regexp -> regexp
  | Star : regexp -> regexp.
Axiom regexp_WhyType : WhyType regexp.
Existing Instance regexp_WhyType.

(* Why3 assumption *)
Definition word := (list Z).

(* Why3 assumption *)
Inductive mem : (list Z) -> regexp -> Prop :=
  | mem_eps : (mem nil Epsilon)
  | mem_char : forall (c:Z), (mem (cons c nil) (Char c))
  | mem_altl : forall (w:(list Z)) (r1:regexp) (r2:regexp), (mem w r1) ->
      (mem w (Alt r1 r2))
  | mem_altr : forall (w:(list Z)) (r1:regexp) (r2:regexp), (mem w r2) ->
      (mem w (Alt r1 r2))
  | mem_concat : forall (w1:(list Z)) (w2:(list Z)) (r1:regexp) (r2:regexp),
      (mem w1 r1) -> ((mem w2 r2) -> (mem (List.app w1 w2) (Concat r1 r2)))
  | mems1 : forall (r:regexp), (mem nil (Star r))
  | mems2 : forall (w1:(list Z)) (w2:(list Z)) (r:regexp), (mem w1 r) ->
      ((mem w2 (Star r)) -> (mem (List.app w1 w2) (Star r))).

Axiom inversion_mem_star : forall (c:Z) (w:(list Z)) (r:regexp),
  forall (w':(list Z)) (r':regexp), ((w' = (cons c w)) /\ (r' = (Star r))) ->
  ((mem w' r') -> exists w1:(list Z), exists w2:(list Z),
  (w = (List.app w1 w2)) /\ ((mem (cons c w1) r) /\ (mem w2 r'))).

Axiom inversion_mem_star2 : forall (c:Z) (w:(list Z)) (r:regexp), (mem
  (cons c w) (Star r)) -> exists w1:(list Z), exists w2:(list Z),
  (w = (List.app w1 w2)) /\ ((mem (cons c w1) r) /\ (mem w2 (Star r))).

(* Why3 goal *)
Theorem WP_parameter_residual : forall (r:regexp) (c:Z),
  match r with
  | Empty => True
  | Epsilon => True
  | (Char c') => True
  | (Alt r1 r2) => True
  | (Concat r1 r2) => forall (result:bool), ((result = true) <-> (mem nil
      r1)) -> ((result = true) -> forall (o:regexp), (forall (w:(list Z)),
      (mem w o) <-> (mem (cons c w) r2)) -> forall (o1:regexp),
      (forall (w:(list Z)), (mem w o1) <-> (mem (cons c w) r1)) ->
      forall (w:(list Z)), (mem w (Alt (Concat o1 r2) o)) <-> (mem (cons c w)
      r))
  | (Star r1) => True
  end.
(* Why3 intros r c. *)
intros r c.
destruct r; auto.
intros.
split; intros.

inversion H3; subst; clear H3.
inversion H6; subst; clear H6.
rewrite List.app_comm_cons.
constructor; auto.
now apply H2.
rewrite <- List.app_nil_l with (l:= (c::w)%list).
constructor.
tauto.
now apply H1.

inversion H3; subst; clear H3.
destruct w1.
apply mem_altr.
rewrite H1.
rewrite <- H4.
now simpl.
apply mem_altl.
simpl in H4.
injection H4; intros; subst; clear H4.
constructor.
now rewrite H2.
auto.
Qed.


Require Import EqNat.
Require Import Bool.
Require Import String.
Require Import Arith.Bool_nat.
Require Import Coq.Arith.PeanoNat.
Require Import Div2.
Require Import While.
Require Import Heap.
Require Import Refinement.
Require Import Program.Tactics.
Require Import Program.Equality.

(************************************************************

                      SQUARE ROOT EXAMPLE

*************************************************************)

Definition square : nat -> nat := fun n => n * n.

Definition sqrtSpec (ptr : Ptr) : WhileL nat nat :=
  Spec (MkPT (fun s => {x : nat | find s ptr = Some x})
             (fun s Hpre result s' =>
                match Hpre with
                  | exist _ x _ => square result <= x < square (result+1)
                end)).

Definition find_eqb_some (h : option nat) : nat :=
  match h with
    | Some n => n
    | _ => 0
  end.

Definition Inv (Q R : Ptr) (s : nat) (si st : heap nat) :=
  { q : nat & prod (find st Q = Some q) (
  { r : nat & prod (find st R = Some r) (
            prod (le (square r) s) (
            prod (lt s (square q))
                 (R <> Q))) } ) }.

Definition Cond (Q R : Ptr) (st : heap nat) :=
  negb (Nat.eqb (find_eqb_some (find st R) + 1)
                (find_eqb_some (find st Q))).

Hint Unfold isExecutable square.
Hint Resolve Nat.ltb_lt Lt.lt_n_Sm_le.
Hint Resolve le_0_n leb_iff_conv beq_nat_eq.

(*** Derivation ***)

Definition deriveSqrt (P : Ptr) :
  { c : WhileL nat nat & prod (sqrtSpec P ⊑ c) (isExecutable c) }.
Proof.
  econstructor; unfold sqrtSpec. split.
  - READ P s.
    NEW (s + 1) Q.
    NEW 0 R.
    WHILE (Inv Q R s) (Cond Q R); unfold Inv, Cond.
    * repeat (eexists; split; eauto); repeat split; eauto.
      rewrite Nat.add_comm; apply Nat.lt_lt_add_r; auto.
    * READ Q vInQ.
      READ R vInR.
      IFF (s <? square (Nat.div2 (vInQ + vInR))).
      WRITE Q (Nat.div2 (vInQ + vInR)).
      RETURN tt.
      repeat (eexists; split; eauto); repeat split; eauto.
      now apply Nat.ltb_lt.
      WRITE R (Nat.div2 (vInQ + vInR)).
      RETURN tt.
      repeat (eexists; split; eauto); repeat split; eauto.
      symmetry in Heqb; apply Lt.lt_n_Sm_le; now apply leb_iff_conv.
    * READ R vInR.
      RETURN vInR.
      auto.
      rewrite e1 in i; rewrite e0 in i; simpl in i.
      remember (vInR + 1 =? s3) as b; destruct b.
      apply beq_nat_eq in Heqb; now subst.
      exfalso; now simpl in i.
  - repeat (simpl; intros; split; intros);
    destruct (v <? square (Nat.div2 (v0 + v1))); auto.
Defined.

Variable t : Ptr.

Eval simpl in projT1 (deriveSqrt t).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall U V P Q : Universe, ((wd_ U V /\ (wd_ P Q /\ (col_ U V P /\ col_ U V Q))) -> col_ P Q U)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Undecidability.L Require Import L Tactics.LTactics LBool.

Class eqbClass X (eqb : X -> X -> bool): Type :=
  _eqb_spec : forall (x y:X), reflect (x=y) (eqb x y).

#[export] Hint Mode eqbClass + -: typeclass_instances. (* treat argument as input and force evar-freeness*)

Definition eqb X eqb `{H:eqbClass (X:=X) eqb} := eqb.

Arguments eqb {_ _ _}: simpl never.

Lemma eqb_spec {X} {f : X -> X -> bool} {_:eqbClass f}:
  forall (x y:X), reflect (x=y) (eqb x y).
Proof.
  intros. eapply _eqb_spec.
Qed.

#[global]
Instance eqbBool_inst : eqbClass Bool.eqb.
Proof.
  intros ? ?. eapply iff_reflect. rewrite eqb_true_iff. reflexivity.
Qed.

Lemma dec_reflect_remove {P Y} (d:dec P) b (H:reflect P b) (y y' : Y):
  (if d then y else y') = (if b then y else y').
Proof.
  destruct H,d;easy.
Qed.

Lemma eqDec_remove {X Y eqb} {H:eqbClass (X:=X) eqb} x x' (d:dec (x=x')) (a b : Y):
  (if d then a else b) = (if eqb x x' then a else b).
Proof.
  apply dec_reflect_remove. eapply eqb_spec.
Qed.

Class eqbComp X {R:encodable X} eqb {H:eqbClass (X:=X) eqb} :=
  { comp_eqb : computable eqb  }.
Arguments eqbComp _ {_ _ _}.

#[export] Hint Mode eqbComp + - - -: typeclass_instances.

#[global]
Existing Instance comp_eqb.

#[global]
Instance eqbComp_bool : eqbComp bool.
Proof.
  constructor. unfold Bool.eqb.
  extract.
Qed.


(** Copyright (c) 2015 Bill White **)
(** Distributed under the MIT/X11 software license **)
(** See http://www.opensource.org/licenses/mit-license.php **)

(** CTreeGrafting: A cgraft describes how to extend a ctree to a better approximation.
    The purpose is so that a small ctree can be given in the block header and
    the graft to extend it to a larger ctree can be given in the block delta without
    repeating the ctree information in the header.
 **)

Require Export CTrees.

(***
A "cgraft" can be used to extend a ctree to be a better approximation without repeating the part that is known.
The idea is to use this to put just what's needed in the block header
(enough of an approx to support the coinstake tx)
and then a graft of the extra part that's needed in the block delta.
***)
Definition cgraft : Type := list (prod hashval (sigT ctree)).

Fixpoint cgraft_valid (G:cgraft) : Prop :=
match G with
| nil => True
| (h,existT n T)::G' => ctree_hashroot T = h /\ cgraft_valid G'
end.

(*** Coercion needed due to dependent types ***)
Definition eqnat_coerce_ctree (m n:nat) (E:m = n) (T:ctree m) : ctree n :=
eq_rect m ctree T n E.

(***
The dependent types here are a little tricky.
I could omit m from the input return (existT n T) where T, leaving the caller of the function to check if m = n (which it should).
Instead I decided to do it here. Either way a coercion using the proof of the equation seems to be needed.
***)
Fixpoint cgraft_assoc (G:cgraft) (k:hashval) (m:nat) : ctree m :=
match G with
| nil => ctreeH m k
| (h,existT n T)::G' =>
  if hashval_eq_dec h k then
    match eq_nat_dec n m with
      | left E => eqnat_coerce_ctree n m E T
      | _ => ctreeH m k
    end
  else
    cgraft_assoc G' k m
end.

Lemma cgraft_assoc_hashroot (G:cgraft) (k:hashval) (m:nat) :
  cgraft_valid G ->
  ctree_hashroot (cgraft_assoc G k m) = k.
induction G as [|[h [n T]] G' IH].
- intros _. destruct m; reflexivity.
- simpl. intros [H1 H2]. destruct (hashval_eq_dec h k) as [E1|E1].
  + destruct (eq_nat_dec n m) as [E2|E2].
    * destruct E2. simpl. (*** tricky ***)
      rewrite <- E1. exact H1.
    * destruct m; reflexivity. (*** even though this is impossible (since if ctree m and ctree n have the same hashroot, m should equal n) the proof goes through. ***)
  + exact (IH H2).
Qed.

Lemma cgraft_assoc_subqc (G:cgraft) (k:hashval) (m:nat) :
  cgraft_valid G -> subqc (ctreeH m k) (cgraft_assoc G k m).
intros H1. generalize (cgraft_assoc_hashroot G k m H1). intros H2.
destruct m as [|m].
- simpl. unfold subqc. unfold subqm. apply subqhH.
  change (mtree_hashroot (ctree_mtree (cgraft_assoc G k 0)) = Some k).
  rewrite mtree_hashroot_ctree_hashroot. congruence.
- unfold subqc.
  change (subqm (mtreeH m (Some k)) (ctree_mtree (cgraft_assoc G k (S m)))).
  change (mtree_hashroot (ctree_mtree (cgraft_assoc G k (S m))) = mtree_hashroot (mtreeH m (Some k))).
  change (mtree_hashroot (ctree_mtree (cgraft_assoc G k (S m))) = Some k).
  rewrite mtree_hashroot_ctree_hashroot. congruence.
Qed.

Fixpoint ctree_cgraft (G:cgraft) {n} : ctree n -> ctree n :=
match n with
| O => fun T:ctree 0 =>
         match T with
           | inl h => cgraft_assoc G h 0
           | _ => T
         end
| S n => fun T:ctree (S n) =>
           match T with
             | inr (inl h) => cgraft_assoc G h (S n)
             | inr (inr (inl Tl)) => ctreeBL (ctree_cgraft G Tl)
             | inr (inr (inr (inl Tr))) => ctreeBR (ctree_cgraft G Tr)
             | inr (inr (inr (inr (Tl,Tr)))) => ctreeB (ctree_cgraft G Tl) (ctree_cgraft G Tr)
             | _ => T
           end
end.

Theorem ctree_cgraft_subqc (G:cgraft) {n} (T:ctree n) :
  cgraft_valid G -> subqc T (ctree_cgraft G T).
intros H1. induction n as [|n IH].
- destruct T as [h|[a hl]].
  + simpl.
    change (subqc (ctreeH 0 h) (cgraft_assoc G h 0)).
    now apply cgraft_assoc_subqc.
  + apply subqm_ref.
- destruct T as [[gamma hl]|[h|[Tl|[Tr|[Tl Tr]]]]].
  + apply subqm_ref.
  + change (subqc (ctreeH (S n) h) (cgraft_assoc G h (S n))).
    now apply cgraft_assoc_subqc.
  + split.
    * apply IH.
    * apply subqm_ref.
  + split.
    * apply subqm_ref.
    * apply IH.
  + split.
    * apply IH.
    * apply IH.
Qed.

Transparent ctree_mtree.

Theorem ctree_approx_fun_cgraft_valid (G:cgraft) {n} (T:ctree n) (f:bitseq n -> list asset) :
  cgraft_valid G ->
  octree_approx_fun_p (Some T) f ->
  octree_approx_fun_p (Some (ctree_cgraft G T)) f.
intros HG.
induction n as [|n IH].
- destruct T as [h|[h hl]].
  + unfold octree_approx_fun_p. simpl. intros H1.
    rewrite H1.
    generalize (cgraft_assoc_hashroot G h 0 HG).
    destruct (cgraft_assoc G h 0) as [k|[k kl]].
    * simpl. congruence.
    * simpl. destruct (hlist_hashroot kl); congruence.
  + simpl. tauto.
- destruct T as [[gamma hl]|[h|[Tl|[Tr|[Tl Tr]]]]].
  + simpl. tauto.
  + unfold octree_approx_fun_p.
    intros [Tl [Tr [H1 [H2 H3]]]].
    unfold ctree_cgraft.
    generalize (cgraft_assoc_hashroot G h (S n) HG).
    intros H4.
    destruct (cgraft_assoc G h (S n)) as [[[[|] delta] kl]|[k|[Tl'|[Tr'|[Tl' Tr']]]]].
    * { simpl. simpl in H4.
        destruct (mtree_hashroot Tl) as [hl|] eqn:E1;
          destruct (mtree_hashroot Tr) as [hr|] eqn:E2;
          simpl in H1.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [_ H4].
          split.
          + apply (mtree_hashroot_mtree_approx_fun_p Tl).
            * rewrite mtree_hashroot_empty. exact E1.
            * exact H2.
          + apply (mtree_hashroot_mtree_approx_fun_p Tr).
            * assert (L1: mtree_hashroot Tr = mtree_hashroot (ctree_mtree (ctreeL kl delta))).
              { rewrite mtree_hashroot_ctree_hashroot.
                congruence.
              }
              destruct n; exact L1.
            * exact H3.
        - discriminate H1.
      }
    * { simpl. simpl in H4.
        destruct (mtree_hashroot Tl) as [hl|] eqn:E1;
          destruct (mtree_hashroot Tr) as [hr|] eqn:E2;
          simpl in H1.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [_ H4].
          split.
          + apply (mtree_hashroot_mtree_approx_fun_p Tl).
            * assert (L1: mtree_hashroot Tl = mtree_hashroot (ctree_mtree (ctreeL kl delta))).
              { rewrite mtree_hashroot_ctree_hashroot.
                congruence.
              }
              destruct n; exact L1.
            * exact H2.
          + apply (mtree_hashroot_mtree_approx_fun_p Tr).
            * rewrite mtree_hashroot_empty. exact E2.
            * exact H3.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - discriminate H1.
      }
    * { simpl. exists Tl. exists Tr. simpl in H4. subst k. repeat split.
        - exact H1.
        - exact H2.
        - exact H3.
      }
    * { simpl. simpl in H4.
        destruct (mtree_hashroot Tl) as [hl|] eqn:E1;
          destruct (mtree_hashroot Tr) as [hr|] eqn:E2;
          simpl in H1.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [_ H4].
          split.
          + apply (mtree_hashroot_mtree_approx_fun_p Tl).
            * rewrite mtree_hashroot_ctree_hashroot. congruence.
            * exact H2.
          + apply (mtree_hashroot_mtree_approx_fun_p Tr).
            * rewrite mtree_hashroot_empty. exact E2.
            * exact H3.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - exfalso. discriminate H1.
      }
    * { simpl. simpl in H4.
        destruct (mtree_hashroot Tl) as [hl|] eqn:E1;
          destruct (mtree_hashroot Tr) as [hr|] eqn:E2;
          simpl in H1.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [_ H4].
          split.
          + apply (mtree_hashroot_mtree_approx_fun_p Tl).
            * rewrite mtree_hashroot_empty. exact E1.
            * exact H2.
          + apply (mtree_hashroot_mtree_approx_fun_p Tr).
            * rewrite mtree_hashroot_ctree_hashroot. congruence.
            * exact H3.
        - discriminate H1.
      }
    * { simpl. simpl in H4.
        destruct (mtree_hashroot Tl) as [hl|] eqn:E1;
          destruct (mtree_hashroot Tr) as [hr|] eqn:E2;
          simpl in H1.
        - inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [_ H4].
          apply hashpairinj in H4. destruct H4 as [H4a H4].
          apply hashpairinj in H4. destruct H4 as [H4b _].
          split.
          + apply (mtree_hashroot_mtree_approx_fun_p Tl).
            * rewrite mtree_hashroot_ctree_hashroot. congruence.
            * exact H2.
          + apply (mtree_hashroot_mtree_approx_fun_p Tr).
            * rewrite mtree_hashroot_ctree_hashroot. congruence.
            * exact H3.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - exfalso. inversion H1. rewrite H0 in H4.
          apply hashpairinj in H4. destruct H4 as [H4 _].
          apply hashnatinj in H4. omega.
        - discriminate H1.
      }
  + intros [H1 H2]. split.
    * apply IH. exact H1.
    * exact H2.
  + intros [H1 H2]. split.
    * exact H1.
    * apply IH. exact H2.
  + intros [H1 H2]. split.
    * apply IH. exact H1.
    * apply IH. exact H2.
Qed.

Opaque ctree_cgraft.
Opaque cgraft_valid.
Opaque ctree_mtree.
Opaque mtree_approx_fun_p.

Theorem ctree_valid_cgraft_valid (G:cgraft) (T:ctree 160) :
  ctree_valid T ->
  cgraft_valid G ->
  ctree_valid (ctree_cgraft G T).
intros [f [H1 H2]] HG.
exists f. split.
- exact H1.
- assert (L1: octree_approx_fun_p (Some (ctree_cgraft G T)) f).
  { apply ctree_approx_fun_cgraft_valid.
    - exact HG.
    - unfold octree_approx_fun_p. unfold octree_mtree. exact H2.
  }
  unfold octree_approx_fun_p in L1. unfold octree_mtree in L1.
  exact L1.
Qed.


(******************************************************************************)
(** * Decomposing paths and cycles *)
(******************************************************************************)

Require Import Arith micromega.Lia.
Require Import HahnBase HahnList HahnRelationsBasic.
Require Import HahnEquational HahnMaxElt HahnRewrite.
Require Import HahnDom HahnMinPath HahnPath.

Set Implicit Arguments.

Lemma acyclic_restr A d (r: relation A) : acyclic r -> acyclic (restr_rel d r).
Proof.
  eauto using acyclic_mon with hahn.
Qed.

Lemma acyclic_seqC A (r r' : relation A) : acyclic (r ⨾ r') <-> acyclic (r' ⨾ r).
Proof.
  unfold acyclic; rewrite clos_trans_rotl.
  unfold irreflexive, seq; ins; desf; intuition; desf; [|eapply H];
    rewrite t_rt_step in *; desf; eauto 10.
Qed.

Lemma acyclic_seq_from_union A (r1 r2: relation A):
  acyclic (r1 ∪ r2) -> acyclic (r1⨾ r2).
Proof.
  ins.
  arewrite (r1 ⊆ r1 ∪ r2).
  arewrite (r2 ⊆ r1 ∪ r2) at 2.
  rewrite (ct_step (r1 ∪ r2)).
  rewrite inclusion_t_rt at 1.
  relsf.
  red; rels.
Qed.

Definition acyclic_rotl := acyclic_seqC.

Lemma acyclic_via_expand_minus :
  forall X (r : relation X)
    (IRR1: irreflexive r)
    (IRR2: irreflexive ((r ⨾ r \ r) ⨾ r＊)),
    acyclic r.
Proof.
  unfold acyclic; ins; rewrite ct_begin.
  by rewrite seq_rt_absorb_l, irreflexive_union.
Qed.

Lemma acyclic_seq_via_expand_minus :
  forall X (r r' : relation X)
    (IRR1: irreflexive (r ⨾ r'))
    (IRR2: irreflexive ((r ⨾ r' ⨾ r \ r) ⨾ r' ⨾ (r ⨾ r')＊)),
    acyclic (r ⨾ r').
Proof.
  unfold acyclic; ins; rewrite ct_end, <- seqA.
  rewrite seq_rt_absorb_r, !seqA; relsf.
  rewrite irreflexive_union; split; ins.
  by rewrite seqA, irreflexive_seqC, seqA.
Qed.

Lemma acyclic_union A (r r': relation A) (R: acyclic r) (FF: acyclic (r' ⨾ r＊)):
  acyclic (r ∪ r').
Proof.
  unfold acyclic; ins; rewrite path_union.
  apply irreflexive_union; split; auto.
  rewrite irreflexive_seqC.
  rewrite ct_begin, !seqA; relsf.
  rewrite <- seqA; rewrite <- ct_begin.
    by rewrite acyclic_seqC in FF.
Qed.

Lemma acyclic_union1 A (r r': relation A) (R: acyclic r)
      (R': acyclic r')
      (FF: acyclic (r⁺ ⨾ r'⁺)):
  acyclic (r ∪ r').
Proof.
  unfold acyclic; ins; rewrite path_union.
  apply irreflexive_union; split; auto.
  rewrite irreflexive_seqC.
  rewrite ct_begin, !seqA; relsf.
  rewrite <- seqA, <- ct_begin.
  rewrite rtE; relsf.
  rewrite path_union.
  apply irreflexive_union; split; auto.
  rewrite irreflexive_seqC.
  rewrite ct_begin, !seqA; relsf.
  rewrite <- !seqA, <- ct_begin.
  apply acyclic_rotl.
  rewrite <- seqA, <- ct_begin.
    by apply acyclic_rotl.
Qed.

(******************************************************************************)
(** Extension of a relation with a singleton *)
(******************************************************************************)

Lemma cycle_decomp_u1 A (r : relation A) a b c :
  (r ∪ singl_rel a b)⁺ c c -> r⁺ c c \/ r＊ b a.
Proof.
  ins; apply ct_union_singl in H; unfolder in H.
  desf; eauto using clos_refl_trans.
Qed.

Lemma acyclic_union_singl A (r : relation A) a b :
  acyclic (r ∪ singl_rel a b) <-> acyclic r /\ ~ r＊ b a.
Proof.
  unfold acyclic; rewrite ct_union_singl, irreflexive_union.
  rewrite irreflexive_seqC, seqA; rels; intuition;
    unfolder in *; ins; desf; eauto.
Qed.

Lemma acyclic_union_singl_max A (r : relation A) a b (MAX: max_elt r b) :
  acyclic (r ∪ singl_rel a b) <-> acyclic r /\ a <> b.
Proof.
  rewrite acyclic_union_singl; intuition; desf; eauto using rt_refl.
  apply rt_begin in H; unfolder in H; desf; eauto.
Qed.

(******************************************************************************)
(** Union with a total relation *)
(******************************************************************************)

Section AcyclicUnionTotal.

  Variable A : Type.
  Implicit Type r : relation A.

  Lemma acyclic_decomp_u_total r dom r' (T: is_total dom r') (DB: domb r' dom) :
      acyclic (r ∪ r') <-> acyclic r /\ irreflexive (r＊ ⨾ r'⁺).
  Proof.
    split; intuition.
      by eapply inclusion_acyclic; try eassumption; eauto with hahn.
      eapply irreflexive_inclusion; try eassumption.
      by rewrite <- rt_ct with (r := r ∪ r'); eauto with hahn.
    unfold acyclic; rewrite path_decomp_u_total; eauto.
    eapply irreflexive_union; splits; ins; rewrite irreflexive_seqC, seqA in *; rels.
  Qed.

  Lemma acyclic_union_total_r r dom r' (T: is_total dom r') (DB: domb r' dom) :
      acyclic (r ∪ r') <-> acyclic r /\ acyclic r' /\ irreflexive (r⁺ ⨾ r'⁺).
  Proof.
    rewrite acyclic_decomp_u_total; eauto; rewrite rtE; relsf;
      rewrite irreflexive_union; tauto.
  Qed.

  Lemma acyclic_union_total_l r dom r' (T: is_total dom r) (DB: domb r dom) :
      acyclic (r ∪ r') <-> acyclic r /\ acyclic r' /\ irreflexive (r⁺ ⨾ r'⁺).
  Proof.
    rewrite unionC, irreflexive_seqC, acyclic_union_total_r; eauto; tauto.
  Qed.

  Lemma acyclic_utd :
    forall r (ACYC: acyclic r)
           r' (T: transitive r') (IRR: irreflexive r') dom
           (F: is_total dom r') (DB: domb r' dom)
           (I': irreflexive (r' ⨾ r⁺)),
    acyclic (r ∪ r').
  Proof.
    ins; eapply acyclic_union_total_r; splits; eauto using trans_irr_acyclic.
    rewrite irreflexive_seqC; relsf.
  Qed.

End AcyclicUnionTotal.

(******************************************************************************)
(** Union of relations where one has a certain domain/codomain. *)
(******************************************************************************)

Section PathDom.

  Variable X : Type.
  Implicit Type r : relation X.

  Lemma acyclic_du r r' adom bdom (A: doma r adom) (B: domb r bdom) :
    acyclic r' ->
    acyclic (r ∪ ⦗bdom⦘ ⨾ r'⁺ ⨾ ⦗adom⦘) ->
    acyclic (r ∪ r').
  Proof.
    unfold acyclic; ins.
    rewrite path_ur2; eauto.
    rewrite (unionC r), path_ur, <- (unionC r); eauto.
    rewrite seq_union_r, !irreflexive_union; repeat split; ins.
    eapply irreflexive_inclusion, H.
    rewrite inclusion_seq_eqv_l, inclusion_seq_eqv_r, ct_of_ct, cr_of_ct, rt_ct;
      auto with hahn.
    rewrite irreflexive_seqC, seqA, inclusion_ct_seq_eqv_l, !seqA.
    seq_rewrite seq_eqvK; do 2 rewrite ct_of_ct at 1.
    rewrite !crE, !seq_union_l, !seq_id_l, !seq_union_r, !seq_id_r.
    rewrite !irreflexive_union; repeat split; ins.

    rewrite ct_end, seqA, !seq_union_l, !seqA.
    rewrite <- rt_ct in H0; eapply irreflexive_inclusion, H0.
    eapply inclusion_seq_mon, inclusion_union_l; ins.
      assert (EQ: r ≡ r ⨾ eqv_rel bdom).
        by split; rewrite seq_eqv_r; red; ins; desf; eauto.
      by rewrite EQ at 1; rewrite seqA;
         eauto using inclusion_step2_ct with hahn.
    rewrite (inclusion_seq_eqv_l (dom:=adom)).
    by sin_rewrite ct_ct; eauto with hahn.

    rewrite ct_begin, irreflexive_seqC, <- !seqA, !seq_union_r, !seqA.
    rewrite <- ct_rt in H0; eapply irreflexive_inclusion, H0.
    apply inclusion_seq_mon; ins.
    apply inclusion_union_l; ins.
      assert (EQ: r ≡ eqv_rel adom ⨾ r).
        by split; rewrite seq_eqv_l; red; ins; desf; eauto.
      by rewrite EQ at 1; rewrite <- !seqA;
         eauto using inclusion_step2_ct with hahn.
    rewrite <- inclusion_union_r2.
    apply inclusion_step_t, inclusion_seq_mon; ins.
    by rewrite inclusion_seq_eqv_l; sin_rewrite ct_ct.

    rewrite seqA; sin_rewrite ct_ct.
    eapply irreflexive_inclusion, H0; eauto using inclusion_t_r_t with hahn.
  Qed.

  Lemma acyclic_ud r r' adom bdom (A: doma r' adom) (B: domb r' bdom) :
    acyclic r ->
    acyclic (⦗bdom⦘ ⨾ r⁺ ⨾ ⦗adom⦘∪ r') ->
    acyclic (r ∪ r').
  Proof.
    ins; rewrite unionC in *; eauto using acyclic_du.
  Qed.

End PathDom.

(******************************************************************************)
(** Union with a transitive relation *)
(******************************************************************************)

Section PathUnionTransitive.

  Variable A : Type.
  Implicit Type r : relation A.

  Lemma acyclic_ut r r' (T: transitive r') :
    acyclic (r ∪ r') <->
    acyclic r /\ irreflexive r' /\ acyclic (r' ⨾ r⁺).
  Proof.
    unfold acyclic; ins; rewrite path_ut2; ins.
    rewrite irreflexive_union, irreflexive_seqC, !seqA, rt_rt, (rtE r); relsf.
    rewrite irreflexive_union, <- ct_end, irreflexive_seqC, rtE; relsf.
    rewrite irreflexive_union; intuition.
    rewrite ct_begin, seqA; sin_rewrite (rewrite_trans T).
    by rewrite <- seqA, <- ct_begin.
  Qed.

  Lemma acyclic_utt r r' (T: transitive r) (T': transitive r') :
    acyclic (r ∪ r') <->
    irreflexive r /\ irreflexive r' /\ acyclic (r ⨾ r').
  Proof.
    ins; rewrite acyclic_ut, ct_of_trans, acyclic_rotl; ins.
    by unfold acyclic; rewrite ct_of_trans.
  Qed.

End PathUnionTransitive.

(******************************************************************************)
(** Absorption *)
(******************************************************************************)

Lemma acyclic_absorb A (r r': relation A) (F: r' ⨾ r ⊆ r \/ r' ⨾ r ⊆ r') :
  acyclic (r ∪ r') <-> acyclic r /\ acyclic r'.
Proof.
  intuition; eauto 2 using acyclic_mon with hahn.
  all: unfold acyclic; ins; rewrite path_absorb; eauto.
  all: rewrite !irreflexive_union; splits; ins.
  all: apply irreflexive_seqC.
  * eapply irreflexive_inclusion, H1.
    eapply ct_ind_right with (P:= fun x => x ;; _); ins; eauto with hahn.
    all: rewrite ct_begin at 1; rewrite ?seqA;
         sin_rewrite H; rewrite <- ct_begin; relsf.
  * eapply irreflexive_inclusion, H2.
    eapply ct_ind_left with (P:= fun x => _ ;; x); ins; eauto with hahn.
    all: rewrite ct_end at 1; rewrite ?seqA;
         sin_rewrite H; seq_rewrite <- ct_end; relsf.
Qed.

(******************************************************************************)
(** Paths with disconnected relations *)
(******************************************************************************)

Lemma acyclic_disj A (r : relation A) (D: r ⨾ r ≡ ∅₂) : acyclic r.
Proof.
  by apply irreflexive_disj, ct_ct_disj.
Qed.

Lemma acyclic_unc X (r r' : relation X)
      (A : r ⨾ r ≡ ∅₂)
      (B : r' ⨾ r' ≡ ∅₂) :
  acyclic (r ∪ r') <-> acyclic (r ⨾ r').
Proof.
  unfold acyclic.
  rewrite pathp_unc, !irreflexive_union; ins.
  rewrite (irreflexive_seqC r), (irreflexive_seqC r').
  rewrite seq_rtE_l, seqA, A, !seq_false_r, union_false_r.
  rewrite seq_rtE_l, seqA, B, !seq_false_r, union_false_r.
  rewrite (acyclic_rotl r' r); intuition.
  by red; ins; eapply A; vauto.
  by red; ins; eapply B; vauto.
Qed.

(** Paths with specific attributes *)
(******************************************************************************)

Lemma acyclic_specific_absorb A (r r' : relation A) :
  r ⨾ r' ⊆ r ⨾ r ->
  r' ⨾ r' ⊆ r' ⨾ r ->
  acyclic r ->
  irreflexive r' ->
  acyclic (r ∪ r').
Proof.
  ins. red.
  rewrite path_specific_absorb; try done.
  apply irreflexive_union; split; try done.
  rewrite irreflexive_seqC.
  rewrite rtE; relsf.
  apply irreflexive_union; split; try done.
  by rewrite ct_end, seqA, H, <- seqA, <- ct_end, ct_unit.
Qed.

Lemma acyclic_seq_union_incompat A (r r' r'' : relation A)
      (DISJ: r' ⨾ r'' ⊆ ∅₂) (DISJ': r'' ⨾ r' ⊆ ∅₂)
      (ACYC: acyclic (r ⨾ r'＊)) (ACYC': acyclic (r''⁺ ⨾ (r ⨾ r'＊)⁺)) :
  acyclic (r ⨾ (r' ∪ r'')＊).
Proof.
  ins; desf.
  arewrite ((r' ∪ r'')＊ <<= r'＊ ∪ r''⁺).
    apply inclusion_rt_ind_left; ins; vauto.
    relsf; unionL; rels.
      by rewrite rt_begin at 1; relsf; sin_rewrite DISJ'; relsf.
      by rewrite ct_begin at 1; relsf; sin_rewrite DISJ; relsf.
    by arewrite (r'' <<= r''^*) at 1; relsf.
  relsf.
  red; rewrite <- ct_of_union_ct_r.
  apply acyclic_ut; splits; ins.
  apply acyclic_seqC.
  arewrite (r <<= (r ⨾ r'＊)⁺) by (unfolder; eauto using rt_refl, t_step).
  arewrite (r <<= (r ⨾ r'＊)⁺) at 1 by (unfolder; eauto using rt_refl, t_step).
  apply acyclic_seqC.
  rewrite ct_begin with (r := _ ;; r''^+); rewrite !seqA.
  sin_rewrite ct_ct; rewrite <- seqA, <- ct_begin; red; rels.
  by apply acyclic_seqC.
Qed.

(** Preferential union *)
(******************************************************************************)

Definition pref_union X (r r' : relation X) x y :=
  r x y \/ r' x y /\ ~ r y x.

Lemma acyclic_pref_union :
  forall X (r r' : relation X) (dom : X -> Prop)
         (IRR: irreflexive r)
         (T: transitive r)
         (TOT: is_total dom r)
         (DL: forall x y (R: r' x y), dom x /\ ~ dom y),
    acyclic (pref_union r r').
Proof.
  ins; unfold pref_union.
  assert (EQ: restr_rel (fun x => ~ dom x)
                    (fun x y => r x y \/ r' x y /\ ~ r y x)
          ≡ restr_rel (fun x => ~ dom x) r).
    unfold restr_rel; split; red; ins; desf; eauto.
    by specialize_full DL; eauto; ins; desf.

  apply min_cycle with (dom := dom) (r' := r);
    repeat split; repeat red; ins; desf; eauto using t_step;
    try hahn_rewrite EQ in H;
    try hahn_rewrite EQ in S';
    repeat match goal with
          | H : clos_trans _ _ _ |- _ =>
            rewrite (clos_trans_of_transitive (transitive_restr T)) in H
          | H : clos_refl_trans _ _ _ |- _ =>
            rewrite (clos_refl_trans_of_transitive (transitive_restr T)) in H
          | H : r' _ _ |- _ => apply DL in H; desf
        end;
    unfold restr_rel, clos_refl, seq in *; desf; eauto.
Qed.

Lemma in_pref_union :
  forall X (r r' : relation X) (dom : X -> Prop)
         (IRR: irreflexive r)
         (T: transitive r)
         (TOT: is_total dom r)
         (DL: forall x y (R: r' x y), dom x /\ ~ dom y) x y
         (R: clos_trans (pref_union r r') x y)
         (D: dom y),
    r x y.
Proof.
  unfold pref_union; ins; apply clos_trans_t1n in R; induction R; desf; eauto.
    by eapply DL in H; desf.
  apply clos_t1n_trans in R.
  assert (K:=DL _ _ H); desc.
  destruct (classic (x = z)) as [|N]; [|apply TOT in N]; desf; ins.
    by exfalso; eauto.
  exfalso; eapply acyclic_pref_union with (r:=r), t_trans, t_trans; vauto.
Qed.


Set Implicit Arguments.
(* Load the CFML library. *)
Require Import CFML.CFLib.
(* Load the examples CF definitions. *)
Require Import CFML.Stdlib.Array_proof.
Require Import CFML.Stdlib.Pervasives_proof.
Require Import Challenge1_ml.

Require Import TLC.LibList TLC.LibListZ.

Open Scope Z_scope.

Ltac auto_tilde ::= try unfold LibListZ.length in *; rew_list in *; eauto with maths.

Definition Buf (L1 L2 : list int) gap b :=
  Hexists l r Ljunk buf,
    b ~> `{ buf' := buf;
            l' := (l:int);
            r' := (r:int) } \*
    buf ~> Array (rev L1 ++ Ljunk ++ L2) \*
    \[
      length L1 = l /\
      length Ljunk = gap /\
      r = l + gap
    ].

Definition Buf' (L : list int) (pos : int) b :=
  Hexists L1 L2 gap,
    b ~> Buf L1 L2 gap \*
    \[
      L = rev L1 ++ L2 /\
      pos = length L1
    ].

Lemma Buf_open : forall b L1 L2 gap,
  b ~> Buf L1 L2 gap ==>
  Hexists l r Ljunk buf,
    b ~> `{ buf' := buf;
            l' := (l:int);
            r' := (r:int) } \*
    buf ~> Array (rev L1 ++ Ljunk ++ L2) \*
    \[
      length L1 = l /\
      length Ljunk = gap /\
      r = l + gap
    ].
Proof using. intros. xunfolds~ Buf. Qed.

Lemma Buf_close : forall b gap Ljunk L1 L2 buf l r L,
  length L1 = l ->
  length Ljunk = gap ->
  r = l + gap ->
  L = rev L1 ++ Ljunk ++ L2 ->
  buf ~> Array L \*
  b ~> `{ buf' := buf;
          l' := (l:int);
          r' := (r:int) } ==>
  b ~> Buf L1 L2 gap.
Proof using. intros. xunfolds~ Buf. Qed.

Implicit Arguments Buf_close [].

Hint Extern 1 (RegisterOpen (Buf _ _ _)) =>
  Provide Buf_open.
Hint Extern 1 (RegisterClose (record_repr _)) =>
  Provide Buf_close.

Lemma left_spec : forall b L1 L2 gap,
  app left [b]
    PRE (b ~> Buf L1 L2 gap)
    POST (fun (tt:unit) =>
      match L1 with
      | nil => b ~> Buf L1 L2 gap
      | x :: L1' => b ~> Buf L1' (x :: L2) gap
      end
    ).
Proof.
  intros. xcf.
  xopen b. xpull. intros l r Ljunk buf. intros (? & ? & ?).
  xapps. xrets. xif; swap 1 2.
  { xret. destruct L1. { xclose~ b. } false~. math. }
  { xapps. xapps. xapps. xapps. xapps. xapps. xapps.
    { apply~ index_of_inbound. }
    xapps. xapps. xapps.
    { apply~ index_of_inbound. }
    destruct L1. { false~. }
    destruct (last_case Ljunk) as [|HH].
    { subst Ljunk.
      xchange~ (Buf_close b gap); auto_tilde.
      rewrite~ read_middle. rewrite~ update_middle. }
    { destruct HH as (j & Ljunk' & ?). subst Ljunk.
      xchange~ (Buf_close b gap (z :: Ljunk')); auto_tilde.
      rewrite~ read_middle.
      transitivity (((rev L1 ++ z :: Ljunk') ++ j :: L2)[(r - 1)%I:=z]).
      { auto_tilde. }
      rewrite~ update_middle. }}
Qed.

Lemma left_spec' : forall b L pos,
  app left [b]
    PRE (b ~> Buf' L pos)
    POST (fun (tt:unit) =>
      If pos > 0 then b ~> Buf' L (pos - 1) else b ~> Buf' L pos).
Proof.
  introv. unfold hdata.
  unfold Buf'. xpull. intros L1 L2 gap (? & ?).
  destruct~ L1.
  { case_if~. { false. math. } xapply~ left_spec. }
  { case_if~; swap 1 2. { false~. } xapply~ left_spec. }
Qed.

Lemma right_spec : forall b L1 L2 gap,
  app right [b]
    PRE (b ~> Buf L1 L2 gap)
    POST (fun (tt:unit) =>
      match L2 with
      | nil => b ~> Buf L1 L2 gap
      | x :: L2' => b ~> Buf (x :: L1) L2' gap
      end
    ).
Proof.
  intros. xcf.
  xopen b. xpull. intros l r Ljunk buf. intros (? & ? & ?).
  xapps. xapps. xapps. xrets. xif; swap 1 2.
  { xret. destruct L2. { xclose~ b. } false~. math. }
  { xapps. xapps. xapps.
    { apply~ index_of_inbound. }
    xapps. xapps. xapps.
    { apply~ index_of_inbound. }
    xapps. xapps. xapps. xapps.
    asserts~: (length L2 <> 0).
    destruct L2. { false~. }
    destruct Ljunk as [|j Ljunk'].
    { xchange~ (Buf_close b gap); auto_tilde.
      rewrite~ read_middle. rewrite~ update_middle. }
    { xchange~ (Buf_close b gap (Ljunk' & z) (z :: L1)); auto_tilde.
      rewrite~ update_middle.
      replace (rev L1 ++ j :: Ljunk' ++ z :: L2) with ((rev L1 ++ j :: Ljunk') ++ z :: L2)
                                                      by rew_list~.
      rewrite~ read_middle. } }
Qed.

Lemma right_spec' : forall b L pos,
  app right [b]
    PRE (b ~> Buf' L pos)
    POST (fun (tt:unit) =>
      If pos < length L then b ~> Buf' L (pos + 1) else b ~> Buf' L pos).
Proof.
  introv. unfold hdata.
  unfold Buf'. xpull. intros L1 L2 gap (? & ?). subst L.
  destruct~ L2.
  { case_if~. { false. math. } xapply~ right_spec. }
  { case_if~; swap 1 2. { false~. } xapply~ right_spec. }
Qed.

Lemma grow_spec : forall k b L1 L2 gap,
  app grow [k b]
    PRE (b ~> Buf L1 L2 gap \* \[ k >= 0 ])
    POST (fun (tt:unit) => b ~> Buf L1 L2 (gap + k)).
Proof.
  intros. xcf.

  xpull.
  intros Hk.

  xopen b.
  xpull.
  intros l r ljunk buf ?.
  unpack.
  xapps. xapps. xapp as buf'; only 1: auto_tilde.
  intros L HL.
  xapps.
  xfor_inv (fun (i:int) =>
    Hexists L',
      buf' ~> Array L' \* \[
      forall k, 0 <= k < i -> L'[k] = (rev L1)[k] ] ).
  - math.
  - admit.
  - admit.
  - admit.
  Unshelve. exact \[].
Qed.

Lemma insert_spec : forall b x L1 L2 (gap:int),
  app insert [b x]
    PRE (b ~> Buf L1 L2 gap \* \[gap > 0])
    POST (fun (tt:unit) => b ~> Buf (x :: L1) L2 (gap - 1)).
Proof.
  intros. xcf.

  xpull.
  intros Hgap.

  xopen b.
  xpull.
  intros l r ljunk buf ?.
  unpack.
  xapps. xapps.
  xrets.
  xif.
  - xfail. math.
  - destruct ljunk; only 1: false~.
    xapps. xapps.
    xapps.
    { apply~ index_of_inbound. }
    xapps. xapps.
    xchange~ (Buf_close b (gap - 1) (ljunk));
    auto_tilde.
    rewrite~ update_middle.
Qed.

Lemma delete_spec : forall b L1 L2 gap,
  app delete [b]
    PRE (b ~> Buf L1 L2 gap)
    POST (fun (tt:unit) =>
      match L1 with
      | nil => b ~> Buf L1 L2 gap
      | x :: L1' => b ~> Buf L1' L2 (gap + 1)
      end).
Proof.
  intros. xcf.
  xopen b.
  xpull.
  intros l r ljunk buf ?.
  unpack.
  xapps. xrets.
  xif.
  - xapps. xapps.
    destruct L1; only 1: false~.
    rew_list in *.
    xchange~ (Buf_close b (gap + 1) (z :: ljunk)).
    math.
  - xrets.
    assert (L1 = nil) as -> by apply~ length_zero_inv.
    xclose~ b.
Qed.


From Hammer Require Import Hammer.

From WeakUpTo Require Export Diagrams.
Set Implicit Arguments.

Ltac cgen H := generalize H; clear H.

Section Reductions.

Section R.
Variables A X: Type.
Definition reduction := A -> relation X.
Definition incl_r: relation reduction := fun R1 R2 => forall a, incl (R1 a) (R2 a).
Definition eeq_r: relation reduction := fun R1 R2 => forall a, eeq (R1 a) (R2 a).
End R.

Variable A: Type.

Section Diagram.
Variables X Y: Type.
Definition diagram_r(RX: reduction A X) R (RY: reduction A Y) S := forall a, diagram (RX a) R (RY a) S.
End Diagram.

Section Weak.

Inductive Lbl: Type := T | L(a: A).
Definition reduction_t := reduction Lbl.

Variable X: Type.
Variable Red: reduction_t X.

Definition Weak: reduction_t X := fun l =>
match l with
| T => star (Red T)
| L a => comp (star (Red T)) (comp (Red (L a)) (star (Red T)))
end.

Definition EWeak: reduction_t X := fun l =>
match l with
| T => union2 (eq (A:=X)) (Red T)
| L a => Red (L a)
end.

Definition REWeak: reduction_t X := fun l =>
match l with
| T => union2 (eq (A:=X)) (Red T)
| L a => comp (Red (L a)) (star (Red T))
end.

Lemma weak_refl: forall x, Weak T x x.
Proof. hammer_hook "Reductions" "Reductions.weak_refl". intro x; simpl; auto. Qed.
Hint Immediate weak_refl.

Lemma tau_weak: forall y l x z, Red T x y -> Weak l y z -> Weak l x z.
Proof. hammer_hook "Reductions" "Reductions.tau_weak".
intros y l; destruct l; simpl; intros x z XY YZ.
apply S_star with y; assumption.
destruct YZ as [ w YW WZ ].
exists w; auto.
apply S_star with y; assumption.
Qed.

Lemma weak_tau: forall y l x z, Red l x y -> Weak T y z -> Weak l x z.
Proof. hammer_hook "Reductions" "Reductions.weak_tau".
intros y l; destruct l; simpl; intros x z XY YZ.
apply S_star with y; assumption.
exists x; auto.
exists y; auto.
Qed.

Lemma red_weak: forall l x y, Red l x y -> Weak l x y.
Proof. hammer_hook "Reductions" "Reductions.red_weak".
intros l x y H.
apply weak_tau with y; auto.
Qed.

Lemma taus_weak: forall y l x z, Weak T x y -> Weak l y z -> Weak l x z.
Proof. hammer_hook "Reductions" "Reductions.taus_weak".
intros y l; destruct l; simpl; intros x z XY YZ.
apply star_trans with y; assumption.
destruct YZ as [ w YW WZ ].
exists w; auto.
apply star_trans with y; assumption.
Qed.

Lemma weak_taus: forall y l x z, Weak l x y -> Weak T y z -> Weak l x z.
Proof. hammer_hook "Reductions" "Reductions.weak_taus".
intros y l; destruct l; simpl; intros x z XY YZ.
apply star_trans with y; assumption.
destruct XY as [ w XW WY ].
destruct WY as [ t WT TY ].
exists w; auto.
exists t; auto.
apply star_trans with y; assumption.
Qed.

Theorem Weak_ind:
forall P: Lbl -> X -> X -> Prop,
(forall x, P T x x) ->
(forall y l x z ,
Red T x y -> Weak l y z -> P l y z -> P l x z) ->
(forall y a x z,
Red (L a) x y -> Weak T y z -> P T y z -> P (L a) x z) ->
forall l x x', Weak l x x' -> P l x x'.
Proof. hammer_hook "Reductions" "Reductions.Weak_ind".
intros P Hrefl Htau Ha l x x' Hxx'.
destruct l.
induction Hxx' as [ x | x1 x x' Hxx1 Hx1x' IH ]; [ apply Hrefl | apply Htau with x1; assumption ].
destruct Hxx' as [ x1 Hxx1 Hx1x' ].
destruct Hx1x' as [ x2 Hx1x2 Hx2x' ].
induction Hxx1 as [ x | w x x1 Hxw Hwx1 IH ].
apply Ha with x2; simpl; auto.
clear Hx1x2.
induction Hx2x' as [ x2 | u x2 x' Hux1 Hx1x' IH ]; [ apply Hrefl | apply Htau with u; assumption ].
apply Htau with w; auto.
exists x1; auto; exists x2; assumption.
Qed.

End Weak.

End Reductions.

Hint Immediate weak_refl.
Hint Resolve red_weak.