Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj16synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus lv2 (plus lv0 lv1))).
Admitted.
QuickChick conj16synthconj3.


Require Import Coq.Bool.Bool.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List.
Require Import Charge.Logics.ILogic.
Require Import Charge.Logics.ILEmbed.
Require Import MapPositive.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Data.Fun.
Require Import ExtLib.Data.Positive.
Require Import ExtLib.Tactics.
Require Import MirrorCore.SymI.
Require Import MirrorCore.TypesI.

Set Implicit Arguments.
Set Strict Implicit.

Section typed.
  Variable typ : Type.
  Variable RType_typ : RType typ.
  Variable RelDec_typ_eq : RelDec (@eq typ).
  Variable RelDecCorrect_typ_eq : RelDec_Correct RelDec_typ_eq.

  Inductive iefunc :=
  | ief_embed (from to : typ).
(* | fref (fi : positive) *)

  Global Instance RelDec_iefunc : RelDec (@eq iefunc) :=
  { rel_dec := fun a b =>
	         match a, b with
		   | ief_embed a t, ief_embed a' t' => a ?[eq] a' && t ?[eq] t'
	         end
  }.

  Global Instance RelDec_Correct_iefunc : RelDec_Correct RelDec_iefunc.
  Proof.
    constructor.
    destruct x; destruct y; simpl;
    try solve [ try rewrite andb_true_iff ;
                repeat rewrite rel_dec_correct; intuition congruence ].
  Qed.

  Definition logic_ops := forall (t : typ),
    option (ILogicOps (typD t)).
  Definition embed_ops := forall (t u : typ),
    option (EmbedOp (typD t) (typD u)).
  Definition logic_opsOk (l : logic_ops) : Prop :=
    forall g, match l g return Prop with
                | Some T => @ILogic _ T
                | None => True
              end.
  Definition embed_opsOk (ls : logic_ops) (es : embed_ops) : Prop :=
    forall t t',
      match ls t , ls t' , es t t' return Prop with
        | Some a , Some b , Some T => @Embed _ a _ _ T
        | _ , _ , _ => True
      end.

  Variable gs : logic_ops.
  Variable es : embed_ops.

  Variable Typ2_tyArr : Typ2 _ Fun.
  Variable Typ0_tyProp : Typ0 _ Prop.

  Let tyArr : typ -> typ -> typ := @typ2 _ _ _ _.
  Let tyProp : typ := @typ0 _ _ _ _.

  Definition typeof_func (f : iefunc) : option typ :=
    match f with
      | ief_embed a b =>
        match es a b with
          | None => None
          | Some _ => Some (tyArr a b)
        end
    end.

  Definition typ2_cast_bin (a b c : typ)
  : (typD a -> typD b -> typD c) -> typD (tyArr a (tyArr b c)) :=
    fun f =>
      match eq_sym (typ2_cast a (tyArr b c)) in _ = t
            return t with
        | eq_refl => match eq_sym (typ2_cast  b c) in _ = t
                           return _ -> t with
                       | eq_refl => f
                     end
        end.

  Definition typ2_cast_quant (a b c : typ)
  : ((typD a -> typD b) -> typD c) -> typD (tyArr (tyArr a b) c) :=
    fun f =>
      match eq_sym (typ2_cast (tyArr a b) c) in _ = t
            return t with
        | eq_refl => match eq_sym (typ2_cast a b) in _ = t
                           return t -> _ with
                       | eq_refl => f
                     end
      end.

  Definition funcD (f : iefunc) :
    match typeof_func f with
      | Some t => typD t
      | None => unit
    end.
  refine (
    match f as f
          return match typeof_func f with
		   | Some t => typD t
		   | None => unit
		 end
    with
      | ief_embed t u =>
        match es t u as x
              return match match x with
			     | Some _ => Some (tyArr t u)
			     | None => None
			   end with
		       | Some t0 => typD t0
		       | None => unit
		     end
        with
	  | Some t0 =>
            match eq_sym (typ2_cast t u) in _ = t return t
            with
              | eq_refl => @embed _ _ _
            end
	  | None => tt
        end
    end).
  Defined.

  Global Instance RSym_iefunc : RSym iefunc :=
  { typeof_sym := typeof_func
  ; sym_eqb := fun a b => Some (rel_dec a b)
  ; symD := funcD
  }.

  Global Instance RSymOk_iefunc : RSymOk RSym_iefunc.
  Proof.
    constructor.
    intros. unfold sym_eqb; simpl.
    consider (a ?[ eq ] b); auto.
  Qed.

End typed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj8eqsynthconj3 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus lv0 (Succ lv1)) (plus (Succ lv0) lv1)).
Admitted.
QuickChick conj8eqsynthconj3.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.

Section RequestVoteTermSanity.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Definition requestVote_term_sanity (net : network) : Prop :=
    forall t h mi mt p,
      In p (nwPackets net) ->
      pBody p = RequestVote t h mi mt ->
      t <= currentTerm (snd (nwState net (pSrc p))).

  Class requestVote_term_sanity_interface : Prop :=
    {
      requestVote_term_sanity_invariant :
        forall net,
          refined_raft_intermediate_reachable net ->
          requestVote_term_sanity net
    }.
End RequestVoteTermSanity.


Require Import Coq.Logic.Eqdep.

Require Export CatSem.PCF_o_c.RPCF_syntax_rep.
Require Export CatSem.PCF_o_c.RPCF_rep_hom.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section weak_init.

Variable R : PCFPO_rep.
(*
Fixpoint init_tac V t (v : PCF V t) :
    R (retype (fun t0 => type_mor R t0) V) (type_mor R t).
intros V t v.
induction v.
apply (bottom (PCFPO_rep_struct := R) _ _ tt).

destruct c.
apply (nats (PCFPO_rep_struct:=R) n _ tt).
apply (tttt (PCFPO_rep_struct:=R) _ tt).
apply (ffff (PCFPO_rep_struct:=R) _ tt).
rewrite <- (eq_sym (type_arrow_dist _ _ _)).
apply (Succ (PCFPO_rep_struct:=R) _ tt).

rewrite <- (eq_sym (type_arrow_dist _ _ _)).
apply (Pred (PCFPO_rep_struct:=R) _ tt).

rewrite <- (eq_sym (type_arrow_dist _ _ _)).
apply (Zero (PCFPO_rep_struct:=R) _ tt).

Check arrow_distrib4.
rewrite <- (eq_sym (arrow_distrib4 (type_arrow_dist R) _ _ _ _ )).
apply (CondN (PCFPO_rep_struct:=R) _ tt).
rewrite <- (eq_sym (arrow_distrib4 (type_arrow_dist R) _ _ _ _ )).
apply (CondB (PCFPO_rep_struct:=R) _ tt).
apply (rweta (RMonad_struct := R) _ _
         (ctype (fun t => type_mor R t) v)).
rewrite <- (eq_sym (type_arrow_dist R _ _ )) in IHv1.
exact ( app (PCFPO_rep_struct:=R) _ _ _ (IHv1,IHv2)).
rewrite <- (eq_sym (type_arrow_dist _ _ _ )).
apply (abs (PCFPO_rep_struct:=R) ).
apply (rlift R (@der_comm _ _ _ _ _ ) _ (IHv)).

rewrite <- (eq_sym (type_arrow_dist _ _ _ ))in IHv.
apply (rec (PCFPO_rep_struct:=R) _ _ IHv).
Defined.

Print init_tac.
*)

(** the initial morphism STS -> R *)

Fixpoint init V t (v : PCF V t) :
    R (retype (fun t0 => type_mor R t0) V) (type_mor R t) :=
  match v in PCF _ t return
        R (retype (fun t0 => type_mor R t0) V) (type_mor R t) with
  | Var t v => rweta (RMonad_struct := R) _ _ (ctype _ v)
  | App r s u v => app (PCFPO_rep_struct := R) _ _ _
           (eq_rect (A:=type_type R)
              _
              (fun t1 : type_type R =>
                (R (retype (fun t2 : TY => type_mor R t2) _)) t1)
               (init u) _
               ( (type_arrow_dist R _ _ )),
                         init v)
  | Lam _ _ v =>
        eq_rect (A:=type_type R) _
             (fun t1 : type_type R =>
                (R (retype (fun t2 : TY => type_mor R t2) _)) t1)
            (abs (PCFPO_rep_struct := R) _ _ _
                  (rlift R
            (@der_comm TY (type_type R) (fun t => type_mor R t) _ V )
                   _ (init v)))
               _ (eq_sym (type_arrow_dist R _ _ ))
  | Rec _ v => rec (PCFPO_rep_struct := R) _ _
                  (eq_rect (A:=type_type R) _
                   (fun t1 : type_type R =>
                (R (retype (fun t2 : TY => type_mor R t2) _)) t1)
                 (init v) _ (type_arrow_dist R _ _ ))
  | Bottom _  => bottom (PCFPO_rep_struct := R) _ _ tt
  | Const _ y => match y in Consts t1 return
                    R (retype (fun t2 => type_mor R t2) V) (type_mor R t1)
                 with
                 | Nats m => nats (PCFPO_rep_struct := R) m
                      (retype _ V) tt
                 | succ => eq_rect
           (type_mor R Nat ~~> type_mor R Nat)
           (fun t1 : type_type R =>
            (R (retype (fun t2 : TY => type_mor R t2) _)) t1)
           ((Succ (retype (fun t1 : TY => type_mor R t1) _)) tt)
           (type_mor R (Nat ~> Nat))
           (eq_sym (type_arrow_dist R Nat Nat))
                 | condN => eq_rect
           (type_mor R Bool ~~> type_mor R Nat ~~>
            type_mor R Nat ~~> type_mor R Nat)
           (fun t1 : type_type R =>
            (R (retype (fun t2 : TY => type_mor R t2) _)) t1)
           ((CondN (retype (fun t1 : TY => type_mor R t1) _)) tt)
           (type_mor R
              (Bool ~> Nat ~> Nat ~> Nat))
           (eq_sym
              (arrow_distrib4 (Uar:=PCF.arrow) (U'ar:=type_arrow (p:=R))
                 (g:=type_mor R) (type_arrow_dist R) Bool
                 Nat Nat Nat))
                 | condB => eq_rect
           (type_mor R Bool ~~> type_mor R Bool ~~>
            type_mor R Bool ~~> type_mor R Bool)
           (fun t1 : type_type R =>
            (R (retype (fun t2 : TY => type_mor R t2) _)) t1)
           ((CondB (retype (fun t1 : TY => type_mor R t1) _)) tt)
           (type_mor R
              (Bool ~> Bool ~> Bool ~> Bool))
           (eq_sym
              (arrow_distrib4 (Uar:=PCF.arrow) (U'ar:=type_arrow (p:=R))
                 (g:=type_mor R) (type_arrow_dist R) Bool
                 Bool Bool Bool))
                 | zero => eq_rect
           (type_mor R Nat ~~> type_mor R Bool)
           (fun t1 : type_type R =>
            (R (retype (fun t2 : TY => type_mor R t2) _)) t1)
           ((Zero (retype (fun t1 : TY => type_mor R t1) _)) tt)
           (type_mor R (Nat ~> Bool))
           (eq_sym (type_arrow_dist R Nat Bool))
                 | ttt => tttt (PCFPO_rep_struct := R) _ tt
                 | fff => ffff (PCFPO_rep_struct := R) _ tt
                 | preds => eq_rect
           (type_mor R Nat ~~> type_mor R Nat)
           (fun t1 : type_type R =>
            (R (retype (fun t2 : TY => type_mor R t2) _)) t1)
           ((Pred (retype (fun t1 : TY => type_mor R t1) _)) tt)
           (type_mor R (Nat ~> Nat))
           (eq_sym (type_arrow_dist R Nat Nat))
                 end
  end.

Lemma init_lift (V : IT) t (y : PCF V t) W (f : V ---> W) :
   (init (y //- f)) =
      rlift R (retype_map f) _ (init y).
Proof.
  intros V t y.
  induction y;
  simpl;
  intros.

  unfold rlift.
  assert (H':=rmod_hom_rmkl
      (bottom (PCFPO_rep_struct := R) (type_mor R t))).
      simpl in H'; auto.

  destruct c.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (nats n (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (tttt (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      assert (H':=rmod_hom_rmkl
      (ffff (PCFPO_rep_struct := R))).
      simpl in H'; auto.

      unfold rlift.
      destruct R as [TR Rar RM Rmor Rdist Rrep];
      simpl.
      generalize (eq_sym (Rdist Nat Nat)).
      destruct Rrep as
       [Rapp Rabs Rrec tttt
      ffff nats RSucc Pred Zero CondN CondB bottom
        beta_red
        (*propag_app1 propag_abs propag_app2 propag_rec*)
       CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn Pred_Z
        Rec_A ].
      simpl in *.
      clear Rapp Rabs Rrec tttt ffff nats Pred Zero
        CondN CondB bottom
        beta_red
        (*propag_app1 propag_abs propag_app2
        propag_rec*)
        CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn
        Pred_Z Rec_A.
      generalize RSucc.
      simpl in *.
      rewrite <- Rdist.
      intros RSucc0 e.
      rewrite (UIP_refl _ _ e).
      simpl.
      assert (H':=rmod_hom_rmkl RSucc0 ).
      simpl in H'.
      auto.

     unfold rlift.
     destruct R as [TR Rar RM Rmor Rdist Rrep];
     simpl.
     generalize (eq_sym (Rdist Nat Nat)).
      destruct Rrep as
       [Rapp Rabs Rrec tttt
      ffff nats Succ RPred Zero CondN CondB bottom
        beta_red
        (*propag_app1 propag_abs propag_app2 propag_rec*)
       CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn Pred_Z
        Rec_A ].
      simpl in *.
      clear Rapp Rabs Rrec tttt ffff nats Zero
        CondN CondB bottom Succ
        beta_red
        (*propag_app1 propag_abs propag_app2
        propag_rec*)
        CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn
        Pred_Z Rec_A.
      generalize RPred.
      simpl in *.
      rewrite <- Rdist.
      intros RPred0 e.
      rewrite (UIP_refl _ _ e).
      simpl.
      assert (H':=rmod_hom_rmkl RPred0 ).
      simpl in H'.
      auto.

      unfold rlift.
      destruct R as [TR Rar RM Rmor Rdist Rrep];
      simpl.
      generalize (eq_sym (Rdist Nat Bool)).
      destruct Rrep as
       [Rapp Rabs Rrec tttt
      ffff nats Succ Pred RZero CondN CondB bottom
        beta_red
        (*propag_app1 propag_abs propag_app2 propag_rec*)
       CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn Pred_Z
        Rec_A ].
      simpl in *.
      clear Rapp Rabs Rrec tttt ffff nats Succ Pred
        CondN CondB bottom
        beta_red
        (*propag_app1 propag_abs propag_app2
        propag_rec*)
        CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn
        Pred_Z Rec_A.
      generalize RZero.
      simpl in *.
      rewrite <- Rdist.
      intros RZero0 e.
      rewrite (UIP_refl _ _ e).
      simpl.
      assert (H':=rmod_hom_rmkl RZero0 ).
      simpl in H'.
      auto.

      unfold rlift.
      destruct R as [TR Rar RM Rmor Rdist Rrep];
      simpl.
      generalize (eq_sym
        (arrow_distrib4 (Uar:=PCF.arrow) (U'ar:=Rar) (g:=Rmor)
           Rdist Bool Nat Nat Nat)).
      destruct Rrep as
       [Rapp Rabs Rrec tttt
      ffff nats Succ Pred Zero RCondN CondB bottom
        beta_red
        (*propag_app1 propag_abs propag_app2 propag_rec*)
       CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn Pred_Z
        Rec_A ].
      simpl in *.
      clear Rapp Rabs Rrec tttt ffff nats Pred Zero
        Succ CondB bottom
        beta_red
        (*propag_app1 propag_abs propag_app2
        propag_rec*)
        CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn
        Pred_Z Rec_A.
      generalize RCondN.
      simpl in *.
      do 3 rewrite <- Rdist.
      intros RCondN0 e.
      rewrite (UIP_refl _ _ e).
      simpl.
      assert (H':=rmod_hom_rmkl RCondN0 ).
      simpl in H'.
      auto.

      unfold rlift.
      destruct R as [TR Rar RM Rmor Rdist Rrep];
      simpl.
      generalize (eq_sym
        (arrow_distrib4 (Uar:=PCF.arrow) (U'ar:=Rar) (g:=Rmor)
           Rdist Bool Bool Bool Bool)).
      destruct Rrep as
       [Rapp Rabs Rrec tttt
      ffff nats Succ Pred Zero CondN RCondB bottom
        beta_red
        (*propag_app1 propag_abs propag_app2 propag_rec*)
       CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn Pred_Z
        Rec_A ].
      simpl in *.
      clear Rapp Rabs Rrec tttt ffff nats Pred Zero
        Succ CondN bottom
        beta_red
        (*propag_app1 propag_abs propag_app2
        propag_rec*)
        CondN_t CondN_f
        CondB_t CondB_f Succ_red Zero_t Zero_f Pred_Sn
        Pred_Z Rec_A.
      generalize RCondB.
      simpl in *.
      do 3 rewrite <- Rdist.
      intros RCondB0 e.
      rewrite (UIP_refl _ _ e).
      simpl.
      assert (H':=rmod_hom_rmkl RCondB0 ).
      simpl in H'.
      auto.

      unfold rlift.
      rew (retakl R).

      rewrite IHy1.
      rewrite IHy2.
      clear IHy1 IHy2.
      generalize (type_arrow_dist R s t).
      intro e.
      simpl.
      unfold rlift.
      assert (H':= rmod_hom_rmkl (app (type_mor R s) (type_mor R t))).
      simpl in H'.
      rewrite <- H'.
      simpl.
      apply f_equal.
      generalize dependent e.
      rewrite <- type_arrow_dist.
      intro e.
      rewrite (UIP_refl _ _ e).
      simpl.
      auto.

      rewrite IHy.
      clear IHy.
      generalize (eq_sym (type_arrow_dist R t s)).
      rewrite type_arrow_dist.
      intro e.
      rewrite (UIP_refl _ _ e).
      simpl.
      unfold rlift.
      assert (H':= rmod_hom_rmkl (abs (type_mor R t) (type_mor R s))).
      simpl in *.
      rewrite <- H'.
      apply f_equal.
      rew (rklkl R).
      rew (rklkl R).
      apply (rkl_eq R).
      simpl.
      intros t0 z.
      rew (retakl R).
      rew (retakl R).
      destruct z as [t0 z];
      simpl.
      destruct z as [t0 z | ];
      simpl; auto.
      unfold rlift;
      rew (retakl R).

      rewrite IHy.
      clear IHy.
      generalize (type_arrow_dist R t t).
      intro e.
      simpl.
      unfold rlift.
      assert (H':= rmod_hom_rmkl (rec (type_mor R t))).
      simpl in H'.
      rewrite <- H'.
      simpl.
      apply f_equal.
      generalize dependent e.
      rewrite <- type_arrow_dist.
      intro e.
      rewrite (UIP_refl _ _ e).
      simpl.
      auto.
Qed.

Lemma init_subst V t (y : PCF V t) W (f : SM_ipo _ V ---> PCFE W):
      init (y >>= f) =
        rkleisli (RMonad_struct := R)
           (SM_ind (V:= retype (fun t => type_mor R t)  V)
                   (W:= R (retype (fun t => type_mor R t)  W))
              (fun t v => match v with
                          | ctype t p => init (f t p)
                          end)) _ (init y).
Proof.
  intros V t y.
  induction y;
  simpl;
  intros.

  rerew (rmhom_rmkl (bottom (type_mor R t)
            (PCFPO_rep_struct := R))).

  destruct c.
  simpl. intros.
  rerew (rmhom_rmkl (nats n (PCFPO_rep_struct := R))).

  simpl. intros.
  rerew (rmhom_rmkl (tttt (PCFPO_rep_struct := R))).

  simpl. intros.
  rerew (rmhom_rmkl (ffff (PCFPO_rep_struct := R))).

  simpl in *.
  intros.
  generalize (eq_sym (type_arrow_dist R Nat Nat)).
  intro e.
  generalize (Succ (PCFPO_rep_struct := R)).
  generalize e.
  rewrite e.
  intros.
  rewrite (UIP_refl _ _ e0).
  simpl.
  rerew (rmhom_rmkl m).

  simpl. intros.
  generalize (eq_sym (type_arrow_dist R Nat Nat)).
  generalize (Pred (PCFPO_rep_struct := R)).
  rewrite <- type_arrow_dist.
  intros m e.
  rewrite (UIP_refl _ _ e).
  simpl.
  rerew (rmhom_rmkl m).

  simpl. intros.
  generalize (eq_sym (type_arrow_dist R Nat Bool)).
  generalize (Zero (PCFPO_rep_struct := R)).
  rewrite <- type_arrow_dist.
  intros m e.
  rewrite (UIP_refl _ _ e).
  simpl.
  rerew (rmhom_rmkl m).

  simpl. intros.
  generalize (eq_sym (arrow_distrib4
         (type_arrow_dist R) Bool Nat Nat Nat)).
  generalize (CondN (PCFPO_rep_struct := R)).
  do 3 rewrite <- type_arrow_dist.
  intros m e.
  rewrite (UIP_refl _ _ e).
  simpl.
  rerew (rmhom_rmkl m).

  simpl. intros.
  generalize (eq_sym (arrow_distrib4
         (type_arrow_dist R) Bool Bool Bool Bool)).
  generalize (CondB (PCFPO_rep_struct := R)).
  do 3 rewrite <- type_arrow_dist.
  intros m e.
  rewrite (UIP_refl _ _ e).
  simpl.
  rerew (rmhom_rmkl m).

  simpl. intros.
  rew (retakl R).

  simpl; intros.
  rewrite IHy1.
  rewrite IHy2.
  clear IHy1 IHy2.
  generalize (type_arrow_dist R s t).
  intro e.
  assert (H:=rmhom_rmkl (app (type_mor R s) (type_mor R t)
              (PCFPO_rep_struct := R))).
  simpl in H.
  rewrite <- H.
  apply f_equal.
  simpl.
  generalize dependent e.
  rewrite <- type_arrow_dist.
  intro e.
  rewrite (UIP_refl _ _ e).
  simpl.
  auto.

  simpl; intros.
  generalize (eq_sym (type_arrow_dist R t s)).
  rewrite type_arrow_dist.
  intro e.
  rewrite (UIP_refl _ _ e).
  simpl.
  assert (H := IHy _ (sshift (P:=PCFEM) t f)).
  simpl in *.
  rerew (rmhom_rmkl (abs (type_mor R t) (type_mor R s)
         (PCFPO_rep_struct := R))).
  apply f_equal.
  assert (H1:=rlift_rkleisli (M:=R)).
  simpl in H1.
  rewrite H1.
  transitivity
( (rlift R (a:=retype (fun t0 : TY => type_mor R t0) (opt t W))
   (b:=opt (type_mor R t) (retype (fun t0 : TY => type_mor R t0) W))
            (@der_comm _ _ _ _ _ )) (type_mor R s)
      (init (y >>= sshift_ (P:=PCFEM) (W:=W) f))).
  repeat apply f_equal.
  apply subst_eq.
  intros.
  rewrite shift_shift.
  auto.

  rewrite H.
  simpl.
  rew (rkleisli_rlift (M:=R)).
  apply (rkl_eq R).
  clear dependent y.
  simpl.
  intros t0 z.
  destruct z as [t0 z];
  simpl.
  destruct z as [t0 z | ];
  simpl.
  unfold inj.
  generalize (f t0 z).
  clear dependent z.
  intro z.
  assert (H := init_lift z (some t (A:=W))).
  rewrite lift_rename in H.
  simpl in H.
  rewrite H.
  rew (rlift_rlift R).
  apply (rlift_eq R).
  simpl.
  intros t1 y.
  destruct y;
  auto.

  rew (rlift_rweta R).

  simpl; intros.
  rewrite IHy.
  clear IHy.
  generalize (type_arrow_dist R t t).
  intro e.
  rerew (rmhom_rmkl (rec (type_mor R t) (PCFPO_rep_struct := R))).
  apply f_equal.
  simpl.
  generalize dependent e.
  rewrite <- type_arrow_dist.
  intro e.
  rewrite (UIP_refl _ _ e).
  simpl.
  auto.
Qed.

Ltac eq_elim := match goal with
      | [ H : ?a = ?a |- _ ] => rewrite (UIP_refl _ _ H)
      | [ H : _ = _ |- _ ] => destruct H end.

Lemma double_eq_rect A (t : A) P (y : P t) s
      (e: t = s) (e': s = t) :
   eq_rect s P (eq_rect t P y _ e) _ e' = y.
Proof.
  intros; repeat eq_elim; simpl; auto.
Qed.

Lemma double_eq_rect_one A (t : A) P (y : P t) s r
      (e: t = s) (e': s = r) (e'': t = r) :
   eq_rect s P (eq_rect t P y _ e) _ e' =
    eq_rect t P y _ e''.
Proof.
  intros; repeat eq_elim; auto.
Qed.

Lemma eq_eq_rect A (z : A) (P : A -> Type)
       (f g : P z) (y : A) (e : z = y):
   f = g -> eq_rect z P f y e = eq_rect z P g y e.
Proof.
  intros; subst; auto.
Qed.

Lemma init_eval V t (v v' : PCF V t) :
     eval v v' -> init v <<< init v'.
Proof.
  intros V t v v' H.
  induction H.
  unfold substar.
  assert (H3:= beta_red (PCFPO_rep_struct := R)).

  assert (H2 := H3 _ _ _ (rlift R
      (a:=retype (fun t0 : TY => type_mor R t0) (opt s V))
         (b:=opt (type_mor R s) (retype (fun t0 : TY => type_mor R t0) V))
         (@der_comm _ _ _ _ _) (type_mor R t) (init M))).
  assert (H4:=H2 (init N)).
  simpl in *.
  generalize (eq_sym (type_arrow_dist R s t)).
  rewrite type_arrow_dist.
  intro e.
  rewrite (UIP_refl _ _ e).
  simpl.
  apply (IRel_eq_r H4).

  assert (H':=init_subst M
      (SM_ind (V:=(opt s V))(W:=PCFEM V)
  ((fun (t0 : TY) (x0 : opt s V t0) =>
    match x0 in (opt _ _ r) return (PCF V r) with
    | some t1 v0 => Var (V:=V) (t:=t1) v0
    | none => N
    end)))).
  simpl in H'.
  apply (eq_trans_2 H').
  unfold Rsubstar.
  rew (rlift_rkleisli (M:=R)).
  apply (rkl_eq R).
  simpl.
  intros t0 z;
  destruct z as [t0 z];
  simpl.
  destruct z as [t0 z | ];
  simpl; auto.

  simpl.
  assert (H:=CondN_t (PCFPO_rep_struct := R)
              (init n) (init m)).
  apply (IRel_trans_2 H).
  clear H.
  apply IRel_eq.
  apply f_equal.
  simpl in *.
  apply (injective_projections);
  simpl; auto.
  generalize (eq_sym (arrow_distrib4
            (type_arrow_dist R) Bool Nat Nat Nat)).
  intro e.
  assert (H:=double_eq_rect_one
      (P:=fun t => R (retype (fun t1 => type_mor R t1) V) t)
      ((CondN (retype (fun t1 : TY => type_mor R t1) V)) tt)
              e
            (type_arrow_dist R Bool (Nat ~> Nat ~> Nat))).
  assert (H':type_mor R Bool ~~>
            type_mor R Nat ~~> type_mor R Nat ~~> type_mor R Nat =
            type_mor R Bool ~~> type_mor R (Nat ~> Nat ~> Nat)).
  do 2 rewrite type_arrow_dist. auto.
  assert (H2:= H H').
  clear H.
  simpl in *.

transitivity (eq_rect (type_mor R (Nat ~> Nat))
  (fun t1 : type_type R => (R (retype (fun t2 : TY => type_mor R t2) V)) t1)
  (((app (type_mor R Nat) (type_mor R (Nat ~> Nat)))
      (retype (fun t2 : TY => type_mor R t2) V))
     (eq_rect (type_mor R (Nat ~> Nat ~> Nat))
        (fun t1 : type_type R =>
         (R (retype (fun t2 : TY => type_mor R t2) V)) t1)
        (((app (type_mor R Bool) (type_mor R (Nat ~> Nat ~> Nat)))
            (retype (fun t2 : TY => type_mor R t2) V))
           (

eq_rect
       (type_mor R Bool ~~>
        type_mor R Nat ~~> type_mor R Nat ~~> type_mor R Nat)
       (fun t : type_type R =>
        (R (retype (fun t1 : TY => type_mor R t1) V)) t)
       ((CondN (retype (fun t1 : TY => type_mor R t1) V)) tt)
       (type_mor R Bool ~~> type_mor R (Nat ~> Nat ~> Nat)) H'

,
           (tttt (retype (fun t2 : TY => type_mor R t2) V)) tt))
        (type_mor R Nat ~~> type_mor R (Nat ~> Nat))
        (type_arrow_dist R Nat (Nat ~> Nat)), init n))
  (type_mor R Nat ~~> type_mor R Nat) (type_arrow_dist R Nat Nat)
).
  apply eq_eq_rect.
  apply f_equal.
  simpl.
  apply (injective_projections);
  simpl; auto.
  apply eq_eq_rect.
  apply f_equal.
  simpl.
  apply (injective_projections);
  simpl; auto.
  clear H2.
  generalize H'.
  rewrite type_arrow_dist.
  rewrite type_arrow_dist.
  intro H'0.
  rewrite (UIP_refl _ _ H'0).
  simpl.
  auto.

  simpl.
  assert (H:=CondN_f (PCFPO_rep_struct := R)
              (init n) (init m)).
  apply (IRel_trans_2 H).
  clear H.
  apply IRel_eq.
  apply f_equal.
  simpl in *.
  apply (injective_projections);
  simpl; auto.
  generalize (eq_sym (arrow_distrib4
            (type_arrow_dist R) Bool Nat Nat Nat)).
  intro e.
  assert (H:=double_eq_rect_one
      (P:=fun t => R (retype (fun t1 => type_mor R t1) V) t)
      ((CondN (retype (fun t1 : TY => type_mor R t1) V)) tt)
              e
            (type_arrow_dist R Bool (Nat ~> Nat ~> Nat))).
  assert (H':type_mor R Bool ~~>
            type_mor R Nat ~~> type_mor R Nat ~~> type_mor R Nat =
            type_mor R Bool ~~> type_mor R (Nat ~> Nat ~> Nat)).
  do 2 rewrite type_arrow_dist. auto.
  assert (H2:= H H').
  clear H.
  simpl in *.

transitivity (eq_rect (type_mor R (Nat ~> Nat))
  (fun t1 : type_type R => (R (retype (fun t2 : TY => type_mor R t2) V)) t1)
  (((app (type_mor R Nat) (type_mor R (Nat ~> Nat)))
      (retype (fun t2 : TY => type_mor R t2) V))
     (eq_rect (type_mor R (Nat ~> Nat ~> Nat))
        (fun t1 : type_type R =>
         (R (retype (fun t2 : TY => type_mor R t2) V)) t1)
        (((app (type_mor R Bool) (type_mor R (Nat ~> Nat ~> Nat)))
            (retype (fun t2 : TY => type_mor R t2) V))
           (

eq_rect
       (type_mor R Bool ~~>
        type_mor R Nat ~~> type_mor R Nat ~~> type_mor R Nat)
       (fun t : type_type R =>
        (R (retype (fun t1 : TY => type_mor R t1) V)) t)
       ((CondN (retype (fun t1 : TY => type_mor R t1) V)) tt)
       (type_mor R Bool ~~> type_mor R (Nat ~> Nat ~> Nat)) H'

,
           (ffff (retype (fun t2 : TY => type_mor R t2) V)) tt))
        (type_mor R Nat ~~> type_mor R (Nat ~> Nat))
        (type_arrow_dist R Nat (Nat ~> Nat)), init n))
  (type_mor R Nat ~~> type_mor R Nat) (type_arrow_dist R Nat Nat)
).
  apply eq_eq_rect.
  apply f_equal.
  simpl.
  apply (injective_projections);
  simpl; auto.
  apply eq_eq_rect.
  apply f_equal.
  simpl.
  apply (injective_projections);
  simpl; auto.
  clear H2.
  generalize H'.
  rewrite type_arrow_dist.
  rewrite type_arrow_dist.
  intro H'0.
  rewrite (UIP_refl _ _ H'0).
  simpl.
  auto.

  simpl.
  assert (H:=CondB_t (PCFPO_rep_struct := R)
              (init u) (init v)).
  apply (IRel_trans_2 H).
  clear H.
  apply IRel_eq.
  apply f_equal.
  simpl in *.
  apply (injective_projections);
  simpl; auto.
  generalize (eq_sym
                    (arrow_distrib4 (Uar:=PCF.arrow)
               (U'ar:=type_arrow (p:=R)) (g:=type_mor R)
                (type_arrow_dist R) Bool Bool Bool Bool)).
  intro e.
  assert (H:=double_eq_rect_one
      (P:=fun t => R (retype (fun t1 => type_mor R t1) V) t)
      ((CondB (retype (fun t1 : TY => type_mor R t1) V)) tt)
              e
            (type_arrow_dist R Bool (Bool ~> Bool ~> Bool))).
  assert (H':type_mor R Bool ~~>
            type_mor R Bool ~~> type_mor R Bool ~~> type_mor R Bool =
            type_mor R Bool ~~> type_mor R (Bool ~> Bool ~> Bool)).
  do 2 rewrite type_arrow_dist. auto.
  assert (H2:= H H').
  clear H.
  simpl in *.

transitivity (
eq_rect (type_mor R (Bool ~> Bool))
  (fun t1 : type_type R => (R (retype (fun t2 : TY => type_mor R t2) V)) t1)
  (((app (type_mor R Bool) (type_mor R (Bool ~> Bool)))
      (retype (fun t2 : TY => type_mor R t2) V))
     (eq_rect (type_mor R (Bool ~> Bool ~> Bool))
        (fun t1 : type_type R =>
         (R (retype (fun t2 : TY => type_mor R t2) V)) t1)
        (((app (type_mor R Bool) (type_mor R (Bool ~> Bool ~> Bool)))
            (retype (fun t2 : TY => type_mor R t2) V))
           (
eq_rect
       (type_mor R Bool ~~>
        type_mor R Bool ~~> type_mor R Bool ~~> type_mor R Bool)
       (fun t : type_type R =>
        (R (retype (fun t1 : TY => type_mor R t1) V)) t)
       ((CondB (retype (fun t1 : TY => type_mor R t1) V)) tt)
       (type_mor R Bool ~~> type_mor R (Bool ~> Bool ~> Bool)) H'
,
           (tttt (retype (fun t2 : TY => type_mor R t2) V)) tt))
        (type_mor R Bool ~~> type_mor R (Bool ~> Bool))
        (type_arrow_dist R Bool (Bool ~> Bool)), init u))
  (type_mor R Bool ~~> type_mor R Bool) (type_arrow_dist R Bool Bool)
).
  apply eq_eq_rect.
  apply f_equal.
  simpl.
  apply (injective_projections);
  simpl; auto.
  apply eq_eq_rect.
  apply f_equal.
  simpl.
  apply (injective_projections);
  simpl; auto.
  clear H2.
  generalize H'.
  rewrite type_arrow_dist.
  rewrite type_arrow_dist.
  intro H'0.
  rewrite (UIP_refl _ _ H'0).
  simpl.
  auto.

  simpl.
  assert (H:=CondB_f (PCFPO_rep_struct := R)
              (init u) (init v)).
  apply (IRel_trans_2 H).
  clear H.
  apply IRel_eq.
  apply f_equal.
  simpl in *.
  apply (injective_projections);
  simpl; auto.
  generalize (eq_sym
                    (arrow_distrib4 (Uar:=PCF.arrow)
               (U'ar:=type_arrow (p:=R)) (g:=type_mor R)
                (type_arrow_dist R) Bool Bool Bool Bool)).
  intro e.
  assert (H:=double_eq_rect_one
      (P:=fun t => R (retype (fun t1 => type_mor R t1) V) t)
      ((CondB (retype (fun t1 : TY => type_mor R t1) V)) tt)
              e
            (type_arrow_dist R Bool (Bool ~> Bool ~> Bool))).
  assert (H':type_mor R Bool ~~>
            type_mor R Bool ~~> type_mor R Bool ~~> type_mor R Bool =
            type_mor R Bool ~~> type_mor R (Bool ~> Bool ~> Bool)).
  do 2 rewrite type_arrow_dist. auto.
  assert (H2:= H H').
  clear H.
  simpl in *.

transitivity (
eq_rect (type_mor R (Bool ~> Bool))
  (fun t1 : type_type R => (R (retype (fun t2 : TY => type_mor R t2) V)) t1)
  (((app (type_mor R Bool) (type_mor R (Bool ~> Bool)))
      (retype (fun t2 : TY => type_mor R t2) V))
     (eq_rect (type_mor R (Bool ~> Bool ~> Bool))
        (fun t1 : type_type R =>
         (R (retype (fun t2 : TY => type_mor R t2) V)) t1)
        (((app (type_mor R Bool) (type_mor R (Bool ~> Bool ~> Bool)))
            (retype (fun t2 : TY => type_mor R t2) V))
           (
eq_rect
       (type_mor R Bool ~~>
        type_mor R Bool ~~> type_mor R Bool ~~> type_mor R Bool)
       (fun t : type_type R =>
        (R (retype (fun t1 : TY => type_mor R t1) V)) t)
       ((CondB (retype (fun t1 : TY => type_mor R t1) V)) tt)
       (type_mor R Bool ~~> type_mor R (Bool ~> Bool ~> Bool)) H'
,
           (ffff (retype (fun t2 : TY => type_mor R t2) V)) tt))
        (type_mor R Bool ~~> type_mor R (Bool ~> Bool))
        (type_arrow_dist R Bool (Bool ~> Bool)), init u))
  (type_mor R Bool ~~> type_mor R Bool) (type_arrow_dist R Bool Bool)
).
  apply eq_eq_rect.
  apply f_equal.
  simpl.
  apply (injective_projections);
  simpl; auto.
  apply eq_eq_rect.
  apply f_equal.
  simpl.
  apply (injective_projections);
  simpl; auto.
  clear H2.
  generalize H'.
  rewrite type_arrow_dist.
  rewrite type_arrow_dist.
  intro H'0.
  rewrite (UIP_refl _ _ H'0).
  simpl.
  auto.

  (*

  assert (H:=CondN_f (PCFPO_rep_struct := R)).
  simpl in *.
  generalize (eq_sym (arrow_distrib4
            (type_arrow_dist R) Bool Nat Nat Nat)).
  do 3 rewrite type_arrow_dist.
  intro e.
  rewrite (UIP_refl _ _ e).
  simpl.
  apply H.

  assert (H:=CondB_t (PCFPO_rep_struct := R)).
  simpl in *.
  generalize (eq_sym (arrow_distrib4
            (type_arrow_dist R) Bool Bool Bool Bool)).
  do 3 rewrite type_arrow_dist.
  intro e.
  rewrite (UIP_refl _ _ e).
  simpl.
  apply H.

  assert (H:=CondB_f (PCFPO_rep_struct := R)).
  simpl in *.
  generalize (eq_sym (arrow_distrib4
            (type_arrow_dist R) Bool Bool Bool Bool)).
  do 3 rewrite type_arrow_dist.
  intro e.
  rewrite (UIP_refl _ _ e).
  simpl.
  apply H.
*)
  assert (H:=Succ_red (PCFPO_rep_struct := R)
           (retype (fun t => type_mor R t) V) n).
  simpl in *.
  apply (IRel_trans_2 H).
  clear H.
  apply IRel_eq.
  apply f_equal.
  rewrite double_eq_rect.
  auto.

  assert (H:=Zero_t (PCFPO_rep_struct := R)
           (retype (fun t => type_mor R t) V)).
  simpl in *.
  apply (IRel_trans_2 H).
  clear H.
  apply IRel_eq.
  apply f_equal.
  rewrite double_eq_rect.
  auto.

  assert (H:=Zero_f (PCFPO_rep_struct := R)
           (retype (fun t => type_mor R t) V)n).
  simpl in *.
  apply (IRel_trans_2 H).
  clear H.
  apply IRel_eq.
  apply f_equal.
  rewrite double_eq_rect.
  auto.

  assert (H:=Pred_Succ (PCFPO_rep_struct := R)
      (retype (fun t => type_mor R t) V)n).
  simpl in *.
  apply (IRel_trans_2 H).
  clear H.
  apply IRel_eq.
  apply f_equal.
  rewrite double_eq_rect.
  rewrite double_eq_rect.
  auto.

  assert (H:=Pred_Z (PCFPO_rep_struct := R)
       (retype (fun t => type_mor R t) V)).
  simpl in *.
  apply (IRel_trans_2 H).
  clear H.
  apply IRel_eq.
  apply f_equal.
  rewrite double_eq_rect.
  auto.

  simpl.

  assert (H:=Rec_A (PCFPO_rep_struct := R)
        (V:=retype (fun t => type_mor R t) V)
        (t:=type_mor R t) (eq_rect (type_mor R (t ~> t))
       (fun t1 : type_type R =>
        (R (retype (fun t2 : TY => type_mor R t2) V)) t1) (init g)
       (type_mor R t ~~> type_mor R t) (type_arrow_dist R t t))).
  auto.
Qed.

Lemma eq_rect_rel T (V : IPO T) (r s : T)(p:r = s)
   (y z : V r) : y <<< z ->
     eq_rect r V y _ p <<< eq_rect r V z _ p.
Proof.
  intros; subst; auto.
Qed.

Lemma init_eval_star V t (y z : PCF V t) :
  eval_star y z -> init y <<< init z.
Proof.
  intros V t y z H.
  induction H.
  apply init_eval;
  auto.
  simpl.
  apply (PO_mor_monotone
  (app (PCFPO_rep_struct := R) (type_mor R s)
         (type_mor R t)
         (retype (fun t => type_mor R t) V))).
  simpl in *.
  constructor.
  apply (eq_rect_rel (type_arrow_dist R s t) IHpropag).
  reflexivity.

  simpl.
  apply (PO_mor_monotone
  (app (PCFPO_rep_struct := R) (type_mor R s)
         (type_mor R t)
         (retype (fun t => type_mor R t) V))).
  simpl in *.
  constructor.
  simpl.
  assert (H': init M <<< init M)
       by reflexivity.
  apply (eq_rect_rel (type_arrow_dist R s t) H').
  auto.

  simpl.
  generalize (eq_sym (type_arrow_dist R s t)).
  rewrite type_arrow_dist.
  intro e.
  rewrite (UIP_refl _ _ e).
  simpl.
  apply (PO_mor_monotone
  (abs (PCFPO_rep_struct := R) (type_mor R s)
         (type_mor R t)
         (retype (fun t => type_mor R t) V))).
  simpl.
  apply (rlift R (@der_comm _ _ (fun t0 => type_mor R t0) _ _ )).
  auto.

  simpl.
  apply (PO_mor_monotone
  (rec (PCFPO_rep_struct := R) (type_mor R t)
         (retype (fun t => type_mor R t) V))).
  apply (eq_rect_rel (type_arrow_dist R t t) IHpropag).
Qed.

Lemma init_mono c t (y z : PCFE c t):
   y <<< z -> init y <<< init z.
Proof.
  intros c t y z H.
  induction H.
  reflexivity.
  transitivity (init y);
  auto.
  apply init_eval_star;
  auto.
Qed.

Obligation Tactic := idtac.

Program Instance init_car_pos :
forall c : TY -> Type,
ipo_mor_struct
  (a:=retype_ipo (fun t : TY => type_mor R t) (PCFE c))
  (b:=R (retype (fun t : TY => type_mor R t) c))
  (fun t y => match y with
     | ctype _ p => init  p
     end).
Next Obligation.
Proof.
  intros.
  unfold Proper;
  red.
  simpl.
  intros y z H.
  induction H.
  apply init_mono;
  auto.
Qed.

Definition init_c:
(forall c : ITYPE TY,
  (RETYPE_PO (fun t : TY => type_mor R t)) (PCFEM c) --->
  R ((RETYPE (fun t : TY => type_mor R t)) c)) :=
  fun c => Build_ipo_mor (init_car_pos c).

Obligation Tactic := idtac.

Program Instance init_rmon_s:
  gen_RMonad_Hom_struct (P:=PCFEM) (Q:=R)
    (G1:=RETYPE (fun t => type_mor R t))
    (G2:=RETYPE_PO (fun t => type_mor R t))
    (NNNT1 (fun t => type_mor R t)) init_c.
Next Obligation.
Proof.
  simpl.
  intros c t z.
  destruct z as [t z];
  simpl.
  auto.
Qed.
Next Obligation.
Proof.
  simpl.
  intros V W f t z.
  destruct z as [t z];
  simpl.
  assert (H:=init_subst z f).
  simpl in *.
  transitivity
  ((rkleisli (RMonad_struct := R)(a:=retype (fun t : TY => type_mor R t) V)
       (b:=retype (fun t : TY => type_mor R t) W)
       (SM_ind (V:=retype (fun t : TY => type_mor R t) V)
          (W:=R (retype (fun t : TY => type_mor R t) W))
          (fun (t : type_type R)
             (v : retype (fun t0 : TY => type_mor R t0) V t) =>
           match
             v in (retype _ _ t0)
             return ((R (retype (fun t1 : TY => type_mor R t1) W)) t0)
           with
           | ctype t0 p => init (f t0 p)
           end))) (type_mor R t) (init z)).
           auto.
  apply (rkl_eq R).
  simpl.
  clear dependent z.
  clear t.
  intros t z.
  destruct z as [t z];
  simpl.
  auto.
Qed.

Definition initM : gen_RMonad_Hom PCFEM R
    (G1:=RETYPE (fun t => type_mor R t))
    (G2:=RETYPE_PO (fun t => type_mor R t))
    (NNNT1 (fun t => type_mor R t)) :=
Build_gen_RMonad_Hom init_rmon_s.

Hint Resolve double_eq_rect.

Obligation Tactic := simpl; intros; repeat elim_unit; auto.

Program Instance initR_s :
        PCFPO_rep_Hom_struct (P:=PCFE_rep)(R:=R)
        (f:=fun t => type_mor R t)
        (fun _ => eq_refl) (type_arrow_dist R) (initM).

Definition initR : PCFPO_rep_Hom PCFE_rep R :=
        Build_PCFPO_rep_Hom initR_s.

End weak_init.


Require Import Recdef Relations Wellfounded.
Require Import Arith NPeano PeanoNat List Bool Psatz.
Require Import Cecoa.Lib Cecoa.Syntax Cecoa.CBV_cache Cecoa.Bounds Cecoa.Ordering.
Require Import Omega.

Import List.ListNotations.

Section Evaluates.

Variables variable function constructor : Type.

Notation value := (Syntax.value constructor).
Notation term := (Syntax.term variable function constructor).
Notation pattern := (Syntax.pattern variable constructor).
Notation rule := (Syntax.rule variable function constructor).
Notation cbv := (CBV_cache.cbv variable function constructor).
Notation cache := (CBV_cache.cache variable function constructor).

Variable variable_eq_dec : forall (x1 x2 : variable), {x1=x2}+{x1<>x2}.

Variable function_eq_dec : forall (x1 x2 : function), {x1=x2}+{x1<>x2}.

Variable constructor_eq_dec : forall (x1 x2 : constructor), {x1=x2}+{x1<>x2}.

Variable term_default : term.

Variable value_default : value.

Variable function_default : function.

Variable rule_default : rule.

Variable prog : list rule.

Variable max_arity : nat.

Notation wf :=
  (CBV_cache.wf variable_eq_dec function_eq_dec constructor_eq_dec rule_default prog max_arity).

Notation assoc_cache := (assoc (term_beq variable_eq_dec function_eq_dec constructor_eq_dec)).

(* Function ranks and compatibility *)

Variable rank: function -> nat.

Hypothesis prog_is_ppo : PPO_prog prog rank.

Hypothesis prog_is_wf : wf_prog max_arity prog.

Definition term_order (t1 t2: term): Prop :=
  In t1 (sub_terms_strict _ _ _ t2).

Set Implicit Arguments.

Lemma term_order_wf : well_founded term_order.
Proof.
intro t.
induction t as [ x | c lt IH | f lt IH ] using term_ind2;
 constructor; unfold term_order; simpl; [ tauto | | ].

- intros t Hin.
  rewrite in_flat_map in Hin.
  destruct Hin as (t' & Hin1 & Hin2).
  apply sub_term_eq_or_strict in Hin2.
  destruct Hin2 as [ Heq | Hin2 ].

  + subst t'.
     apply IH.
     exact Hin1.

  + apply Acc_inv_trans with t'.

    * constructor.
      exact Hin2.

    * apply IH.
      exact Hin1.

- intros t Hin.
  rewrite in_flat_map in Hin.
  destruct Hin as (t' & Hin1 & Hin2).
  apply sub_term_eq_or_strict in Hin2.
  destruct Hin2 as [ Heq | Hin2 ].

  + subst t'.
     apply IH.
     exact Hin1.

  + apply Acc_inv_trans with t'.

    * constructor.
      exact Hin2.

    * apply IH.
      exact Hin1.
Qed.

Definition active_term := prod function (list value).

Definition term_from_active_term (t: active_term) : term :=
  let (f, lv) := t in
  fapply f (map (@term_from_value _ _ _) lv).

Definition value_list_order (lv lv' : list value) : Prop :=
  suml (map (@value_size _) lv) < suml (map (@value_size _) lv').

Lemma value_list_order_wf : well_founded value_list_order.
Proof.
unfold value_list_order.
apply wf_inverse_image.
refine lt_wf.
Defined.

Definition active_term_order_superset t t' :=
  lexprod lt value_list_order (rank (fst t), snd t) (rank (fst t'), snd t').

Definition active_term_order_superset_wf : well_founded active_term_order_superset.
Proof.
unfold active_term_order_superset.
apply wf_inverse_image.
apply wf_lexprod.
- apply lt_wf.
- apply value_list_order_wf.
Defined.

Fixpoint unify (s : list (variable * value)) (v : value) (p : pattern) {struct p} :
  option (list (variable * value)) :=
  let unify_list := fix unify_list
    (s : list (variable * value)) (lv : list value) (lp : list pattern) {struct lp} :
    option (list (variable * value)) :=
    match lv, lp with
    | [], [] => Some s
    | v::lv', p::lp' => match unify s v p with
      | None => None
      | Some s' => unify_list s' lv' lp'
      end
    | _, _ => None
    end in
  match p with
  |  p_var x =>
    match assoc (variable_beq variable_eq_dec) x s with
    | None => Some ((x, v) :: s)
    | Some v' => if value_beq constructor_eq_dec v v' then Some s else None
    end
  | p_capply c' lp =>match v with
      | c_capply c lv => if constructor_beq constructor_eq_dec c c' then unify_list s lv lp else None
      end
  end.

Fixpoint unify_list_aux (s : list (variable * value)) (lv : list value) (lp : list pattern) :
  option (list (variable * value)) :=
  match lv, lp with
  | [], [] => Some s
  | v::lv', p::lp' => match unify s v p with
    | None => None
    | Some s' => unify_list_aux s' lv' lp'
    end
  | _, _ => None
  end.

Lemma unify_equation (s : list (variable * value)) (v : value) (p : pattern) :
  unify s v p =
  match p with
  |  p_var x =>
    match assoc (variable_beq variable_eq_dec) x s with
      | None => Some ((x, v) :: s)
      | Some v' => if value_beq constructor_eq_dec v v' then Some s else None
    end
  | p_capply c' lp =>
    match v with
      | c_capply c lv => if constructor_beq constructor_eq_dec c c' then unify_list_aux s lv lp else None
    end
  end.
Proof.
  revert s v.
  induction p as [ x | c lp IH ] using pattern_ind2;
    [ simpl; trivial | ].
  intros s [ c' lv ].
  simpl.
  case constructor_beq; [ | trivial ].
  clear c c'; revert s lv.
  induction lp as [ | p lp IHlp ];
    intros s lv;
    [ destruct lv; trivial | ].
  destruct lv as [ | [ c lv' ] lv ]; simpl; trivial.
  case unify; trivial.
  intros s'.
  apply IHlp.
  intros; apply IH; right; assumption.
Qed.

Definition unify_list
  (s : list (variable * value)) (lv : list value) (lp : list pattern) :
  option (variable -> value) :=
  option_map (assoc_default (variable_beq variable_eq_dec) value_default) (unify_list_aux s lv lp).

Lemma unify_list_unify_unify_list :
  forall s s' v lv p lp,
    unify_list_aux s (v :: lv) (p :: lp) = Some s' ->
    exists s'', unify s v p = Some s'' /\ unify_list_aux s'' lv lp = Some s'.
Proof.
  intros s s' v lv p lp.
  case_eq (unify s v p); simpl;
  [ intro s'' | ]; intro Huni; rewrite Huni; [ | discriminate ].
  intros Hunis; exists s''.
  now split.
Qed.

Lemma unify_list_length :
  forall s s' lv lp, unify_list_aux s lv lp = Some s' -> length lv = length lp.
Proof.
  intros s s' lv; revert s s';
  induction lv as [ | v lv IH ]; intros s s' lp Hunis;
  destruct lp; [ trivial | discriminate | discriminate | ].
  simpl; f_equal;
  apply unify_list_unify_unify_list in Hunis;
  destruct Hunis as (s'' & _ & Hunis); now apply IH in Hunis.
Qed.

Lemma unify_cons_eq_unify_list :
  forall s s' c lv c' lp',
    unify s (c_capply c lv) (p_capply c' lp') = Some s' ->
    c = c' /\ unify_list_aux s lv lp' = Some s'.
Proof.
  intros s s' c lv c' lp' Huni;
  rewrite unify_equation in Huni;
  case_eq (constructor_beq constructor_eq_dec c c'); intros Hc; rewrite Hc in Huni;
  [ now rewrite constructor_beq_eq in Hc | discriminate Huni ].
Qed.

Lemma unify_list_aux_extension lv lp s s':
  unify_list_aux s lv lp = Some s' ->
  exists s'',
    s' = s'' ++ s /\
    forall x, assoc (variable_beq variable_eq_dec) x s <> None -> assoc (variable_beq variable_eq_dec) x s'' = None.
Proof.
  remember (suml (map (value_size (constructor := constructor)) lv)) as size eqn: Hsize.
  revert lv lp s s' Hsize;
    induction size as [ size IH ] using lt_wf_ind; intros lv lp s s' Hsize Hunis.

  destruct lv as [ | v lv ].

  - exists [].
    assert (Hnil : 0 = length lp) by (now apply unify_list_length in Hunis).
    destruct lp; [ clear Hnil | now contradict Hnil ].
    simpl in Hunis; injection Hunis; clear Hunis; intros; now subst s'.

  - assert (Hlen : length (v :: lv) = length lp) by (apply unify_list_length in Hunis; assumption).
    destruct lp as [ | p lp ]; [ discriminate Hlen | clear Hlen ].
    apply unify_list_unify_unify_list in Hunis; destruct Hunis as (s'' & Huni & Hunis).
    set (size' := suml (map (value_size (constructor := constructor)) lv)).
    assert (Hlt: size' < size)
      by (simpl in Hsize; rewrite Hsize;
          change size' with (0 + size'); unfold size';
          apply plus_lt_compat_r;
          destruct v as [ c' lv' ];
          simpl;
          apply lt_O_Sn).
    apply (IH _ Hlt) in Hunis; [ | easy ];
    destruct Hunis as (s''' & Happ & Hconsistent); clear size' Hlt lp.

    destruct p as [ x | c lp' ].

    + simpl in Huni; case_eq (assoc (variable_beq variable_eq_dec) x s).

      * intros v'' Hsome; rewrite Hsome in Huni.
        destruct value_beq in Huni; [ | discriminate Huni ];
        injection Huni; intros; subst s' s''; clear Huni.
        now exists s'''.

      * intros Hnone; rewrite Hnone in Huni.
        injection Huni; intro; subst s''; clear Huni.
        exists (s''' ++ [(x,v)]); split; [ now rewrite <- app_assoc | ].
        intros y Hsome.
        { rewrite assoc_app_eq_None; split.
          - apply Hconsistent.
            change ((x,v) :: s) with ([(x,v)] ++ s).
            rewrite assoc_app_neq_None; now right.
          - simpl.
            case_eq (variable_beq variable_eq_dec y x); [ | easy ].
            rewrite variable_beq_eq; intro; now subst y.
        }

    + destruct v as [ c' lv' ].
      apply unify_cons_eq_unify_list in Huni; destruct Huni as (Hc' & Hunis); subst c'.
      set (size' := suml (map (value_size (constructor := constructor)) lv')).
      assert (Hlt: size' < size) by (subst size; simpl; unfold size'; omega).
      apply (IH _ Hlt) in Hunis; [ | easy ];
      destruct Hunis as (s'''' & Happ' & Hconsistent'); clear size' Hlt.

      exists (s''' ++ s'''').
      subst s' s''.
      split; [ now rewrite <- app_assoc | ].
      intros x Hsome.
      rewrite assoc_app_eq_None; split.
      * apply Hconsistent.
        rewrite assoc_app_neq_None; right; assumption.
      * apply Hconsistent'; assumption.
Qed.

Lemma unify_all_vars_defined :
  forall (s s': list (variable * value)) (v: value) (p: pattern),
    unify s v p = Some s' ->
    forall x, In x (vars_of_pattern p) -> assoc (variable_beq variable_eq_dec) x s' <> None.
Proof.
  intros s s' v p; revert s s' v.
  induction p as [ x | c lp IH ] using pattern_ind2;
    intros s s' v Huni.

  - (* cas variable : unify va forcer s' à contenir x *)
    intros x' [ Hx' | H ]; [ | tauto ]; subst x'.
    rewrite unify_equation in Huni.
    case_eq (assoc (variable_beq variable_eq_dec) x s).
    + intros v' Heq; rewrite Heq in Huni.
      destruct (value_beq _ _ _) in Huni; [ | discriminate ].
      injection Huni; intros H; subst s'.
      rewrite Heq; discriminate.
    + intros Heq; rewrite Heq in Huni; injection Huni; intros H; subst s'.
      simpl.
      case_eq ((variable_beq variable_eq_dec) x x); [ intros; discriminate | ].
      rewrite <- not_true_iff_false, variable_beq_eq; tauto.

  - simpl; destruct v as [ c' lv ].
    apply unify_cons_eq_unify_list in Huni; destruct Huni as (H & Hunis); subst c'; clear c.
    revert s s' lv Hunis.
    induction lp as [ | p lp IHlp ]; [ easy | ].
    intros s s' [ | v lv ] Hunis;
    [ apply unify_list_length in Hunis; now contradict Hunis | ].
    apply unify_list_unify_unify_list in Hunis.
    destruct Hunis as (s'' & Huni & Hunis).
    intros x; rewrite in_flat_map; intros (p' & [Hp' | Hp'] & Hx).
    + subst p'.
      apply IH with (x := x) in Huni; [ | now left | easy ].
      apply unify_list_aux_extension in Hunis.
      destruct Hunis as (s''' & Heq & _); subst s'.
      rewrite assoc_app_neq_None; now right.
    + apply IHlp with (s := s'') (lv := lv).
      * intros p'' Hin; apply IH; now right.
      * easy.
      * apply in_flat_map.
        now exists p'.
Qed.

Lemma eq_psubst_consistent_assoc_extension :
  forall s s' p,
    (forall x, assoc (variable_beq variable_eq_dec) x s <> None -> assoc (variable_beq variable_eq_dec) x s' = None) ->
    (forall x, In x (vars_of_pattern p) -> assoc (variable_beq variable_eq_dec) x s <> None) ->
    psubst (assoc_default (variable_beq variable_eq_dec) value_default (s' ++ s)) p =
    psubst (assoc_default (variable_beq variable_eq_dec) value_default s) p.
Proof.
  intros s s' p; revert s s'.
  induction p as [ x | c lp IH ] using pattern_ind2;
    intros s s' Hconsistent Hvars.

  - assert (Hsomes : assoc (variable_beq variable_eq_dec) x s <> None)
      by (apply Hvars; simpl; now left).
    assert (Hnones' : assoc (variable_beq variable_eq_dec) x s' = None)
      by (apply Hconsistent, Hsomes).
    assert (H : exists v, assoc (variable_beq variable_eq_dec) x s = Some v)
      by now apply neq_None_eq_Some.
    clear Hsomes.
    destruct H as (v & Hsome's).
    simpl; unfold assoc_default.
    rewrite Hsome's.
    case_eq (assoc (variable_beq variable_eq_dec) x (s' ++ s)).
    + intros v'; rewrite assoc_app_eq_Some.
      intros [ Hsomes' | (_ & Hsome) ];
        [ rewrite Hnones' in Hsomes'; discriminate Hsomes'
        | rewrite Hsome's in Hsome; now injection Hsome ].
    + rewrite assoc_app_eq_None; intros (_ & Himpossible); congruence.

  - simpl; f_equal.
    apply map_ext_in.
    intros p Hin; apply IH; [ assumption | assumption | ].
    simpl in Hvars.
    intros x Hx; apply Hvars.
    apply in_flat_map; now exists p.
Qed.

Lemma unify_sound :
  forall (s s': list (variable * value)) (v: value) (p: pattern),
    unify s v p = Some s' ->
    psubst (assoc_default (variable_beq variable_eq_dec) value_default s') p = v.
Proof.
  intros s s' [ c lv ] p; revert s s' c lv.
  induction p as [ x | c lp IH ] using pattern_ind2.
  - intros s s' c' lv; simpl.
    case_eq (assoc (variable_beq variable_eq_dec) x s).
    + intros [ c'' lv'' ] H'' Hassoc.
      case_eq (constructor_beq constructor_eq_dec c' c'');
        case_eq (list_beq value (value_beq constructor_eq_dec) lv lv'');
        intros Heqc Heqlv;
        rewrite Heqc, Heqlv in Hassoc;
        simpl in Hassoc;
        try discriminate.
      injection Hassoc; intros; subst.
      apply list_beq_eq in Heqc; subst;
      [ | intros; apply value_beq_eq; assumption ].
      apply constructor_beq_eq in Heqlv; subst.
      unfold assoc_default.
      rewrite H''; trivial.
    + intros Hnone Hsome; injection Hsome; intros; subst; clear Hsome.
      unfold assoc_default.
      simpl.
      case_eq ((variable_beq variable_eq_dec) x x); [ intros; trivial | ].
      intros Heq.
      rewrite <- not_true_iff_false, variable_beq_eq in Heq.
      now contradict Heq.
  - intros s s' c' lv.
    rewrite unify_equation.
    case_eq (constructor_beq constructor_eq_dec c' c); [ | intros _ H; discriminate H ].
    rewrite constructor_beq_eq.
    intros Heq; subst.
    revert s s' lv;
    induction lp as [ | p lp IHlp ]; intros s s' lv.
    + destruct lv; [ now simpl | ].
      simpl; intros H; discriminate H.
    + destruct lv as [ | [ c' lv' ] lv ]; [ intros H; discriminate H | ].
      simpl.
      case_eq (unify s (c_capply c' lv') p); [ | intros _ H; discriminate H ].
      intros s'' Hs'' Heq.
      f_equal; simpl; f_equal.
      assert (Hvars' := unify_all_vars_defined _ _ _ Hs'').
      apply IH in Hs''.
      * apply unify_list_aux_extension in Heq;
        destruct Heq as (s''' & Heq & Hconsistent);
        subst s'.
        now rewrite eq_psubst_consistent_assoc_extension.
      * left; trivial.
      * simpl in IHlp.
        assert (Hf_equal : forall lv', c_capply c lv' = c_capply c lv -> lv' = lv)
               by (intros lv'' H''; injection H''; trivial).
        apply Hf_equal.
        apply IHlp with (s := s''); [ | assumption ].
        intros p' Hin.
        apply IH.
        right; assumption.
Qed.

Lemma psubst_app p v (s s' : list (variable * value)) :
  (forall x : variable, assoc (variable_beq variable_eq_dec) x s <> None -> assoc (variable_beq variable_eq_dec) x s' = None) ->
  (forall x, In x (vars_of_pattern p) -> assoc (variable_beq variable_eq_dec) x s <> None) ->
  psubst (assoc_default (variable_beq variable_eq_dec) value_default s        ) p = v ->
  psubst (assoc_default (variable_beq variable_eq_dec) value_default (s' ++ s)) p = v.
Proof.
revert v s s'.
induction p as [ x | c lp IHp ] using pattern_ind2; simpl; intros v s s' Hconsistent Hall Hassoc.

- unfold assoc_default in *.
  case_eq (assoc (variable_beq variable_eq_dec) x (s' ++ s)).

  + intros v' Hx.
    apply assoc_app_eq_Some in Hx.
    destruct Hx as [ Hx | [ Hnone Hx ] ]; [ | rewrite Hx in Hassoc; assumption ].
    case_eq (assoc (variable_beq variable_eq_dec) x s).

    * intros v'' Hx'.
      rewrite Hx' in Hassoc.
      subst v''.
      apply eq_None_neq_Some in Hx; [contradict Hx |].
      apply Hconsistent.
      auto.

    * intro Hx'.
      rewrite Hx' in Hassoc.
      apply eq_None_neq_Some in Hx; [contradict Hx |].
      apply Hconsistent.
      auto.

  + intro Hassoc'.
    apply assoc_app_eq_None in Hassoc'.
    destruct Hassoc' as [_ Hassoc'].
    rewrite Hassoc' in Hassoc.
    assumption.

- rewrite <- Hassoc.
  f_equal.
  apply map_in_ext.
  intros p Hp.
  apply eq_psubst_consistent_assoc_extension; [ assumption | ].
  intros x Hx.
  apply Hall.
  apply in_flat_map.
  eauto.
Qed.

Lemma unify_list_sound :
  forall (lp : list pattern) (lv : list value) (s : variable -> value),
    unify_list [] lv lp = Some s -> map (psubst s) lp = lv.
Proof.
assert (
  Hgen: forall lv lp s0 s, unify_list s0 lv lp = Some s ->
  map (psubst s) lp = lv
).
{
unfold unify_list.
induction lv as [ | v lv IHlv ]; intros [ | p lp ] s0 s Hula;
 [ trivial | simpl in Hula; discriminate Hula | simpl in Hula; discriminate Hula | ].
unfold option_map in Hula.
case_eq (unify_list_aux s0 (v :: lv) (p :: lp));
 [ | intro Hnone; rewrite Hnone in Hula; discriminate Hula ].
intros s' Hs'.
rewrite Hs' in Hula.
injection Hula; clear Hula; intro; subst s.
apply unify_list_unify_unify_list in Hs'.
destruct Hs' as (s'' & Hs'' & Hs').
simpl.
f_equal.

- assert(HHs'' := Hs'').
  apply unify_sound in Hs''.
  assert(HHs' := Hs').
  apply unify_list_aux_extension in Hs'.
  destruct Hs' as (s''' & Hs' & Hconsistent).
  subst s'.
  apply psubst_app; [ assumption | | assumption ].
  intros x Hx.
  eapply unify_all_vars_defined; [ exact HHs'' | exact Hx].

- eapply IHlv with (s0 := s'').
  rewrite Hs'.
  reflexivity.
}
eauto.
Qed.

Fixpoint first_rule_rec (prog': list rule) (t: active_term) :
  option (nat * (variable -> value) * term) :=
  match prog' with
    | [] => None
  | rule_intro f lp t' :: prog'' =>
    if function_beq function_eq_dec (fst t) f
    then
      match unify_list [] (snd t) lp with
        | None =>
          match first_rule_rec prog'' t with
            | None => None
            | Some (i, s, t) => Some (S i, s, t)
            end
        | Some s => Some (0, s, subst s t')
      end
    else
      match first_rule_rec prog'' t with
        | None => None
        | Some (i, s, t) => Some (S i, s, t)
      end
  end.

Definition first_rule (t: active_term) :
  option (nat * (variable -> value) * term) :=
  first_rule_rec prog t.

Global Arguments first_rule t : simpl never.

Lemma first_rule_sound :
  forall (f: function) (lv: list value) (i: nat) (s: variable -> value) (t: term),
  first_rule (f, lv) = Some (i, s, t) ->
  { lpt : (list pattern * term)| let (lp, t') := lpt in
    i < length prog /\
    nth i prog rule_default = rule_intro f lp t' /\
    unify_list [] lv lp = Some s /\
    t = subst s t'}.
Proof.
  clear prog_is_ppo prog_is_wf.
  unfold first_rule.
  induction prog as [ | r0 prog' IHp ];
    simpl; intros f lv i s t; [ intros H; discriminate H | ].
  destruct r0 as [ f0 lp0 t0 ].
  case_eq (function_beq function_eq_dec f f0).
  - intro Heqf; rewrite function_beq_eq in Heqf.
    case_eq (unify_list [] lv lp0).
    + intros s' Hs'.
      intros H; injection H; clear H.
      intros Heqt Heqs Hi.
      subst s' t f0 i.
      exists (lp0, t0).
      repeat split; [ apply lt_O_Sn | assumption ].
    + (* ici on dispose d’une hypothèse unify_list = None *)
      intros Hnone Hrec.
      case_eq (first_rule_rec prog' (f,lv)); [ | intros H; rewrite H in Hrec; discriminate Hrec ].
      intros [ [i' s'] t'] Heq.
      rewrite Heq in Hrec.
      injection Hrec; clear Hrec; intros; subst.
      apply IHp in Heq.
      destruct Heq as [[lp t'] Hlpt].
      exists (lp, t').
      repeat split; try tauto.
      omega.

  - intros Hneq Hrec.
    case_eq (first_rule_rec prog' (f,lv)); [ | intros H; rewrite H in Hrec; discriminate Hrec ].
    intros [ [i' s'] t'] Heq.
    rewrite Heq in Hrec.
    injection Hrec; clear Hrec; intros; subst.
    apply IHp in Heq.
    destruct Heq as [[lp t'] Hlpt].
    exists (lp, t').
    repeat split; try tauto.
    omega.
Qed.

Definition active_term_order_superset_dec: forall (t t': active_term), {active_term_order_superset t t'} + {~ active_term_order_superset t t'}.
Proof.
intros t t'.
apply lex_prod_dec.
- apply eq_nat_dec.

- apply lt_dec.

- intros x y.
  unfold value_list_order.
  apply lt_dec.
Defined.

Definition lex : (active_term * term) -> (active_term * term) -> Prop :=
  lexprod active_term_order_superset term_order.

Lemma wf_lex : well_founded lex.
Proof.
exact (wf_lexprod active_term_order_superset_wf term_order_wf).
Qed.

Lemma sub_terms_trans t1 t2 t3:
  In t1 (sub_terms variable function constructor t2) ->
  In t2 (sub_terms _ _ _ t3) ->
  In t1 (sub_terms _ _ _ t3).
Proof.
induction t3 using term_ind2; intros H1 H2; simpl in *.
- destruct H2 as [Heq | Hf].
  + subst t2.
    left; now inversion H1.

  + inversion Hf.

- destruct H2 as [Heq |Hin].
  + subst t2.
    exact H1.

  + right.
    rewrite in_flat_map in *.
    destruct Hin as (x & Hin & Hx).
    exists x.
    split; [exact Hin |].
    auto.

- destruct H2 as [Heq |Hin].
  + subst t2.
    exact H1.

  + right.
    rewrite in_flat_map in *.
    destruct Hin as (x & Hin & Hx).
    exists x.
    split; [exact Hin |].
    auto.
Qed.

Lemma sub_terms_strict_trans t1 t2 t3:
  In t1 (sub_terms_strict variable function constructor t2) ->
  In t2 (sub_terms_strict _ _ _ t3) ->
  In t1 (sub_terms_strict _ _ _ t3).
Proof.
intros H1 H2.
destruct t3.
- inversion H2.

- simpl in *.
  apply in_flat_map in H2.
  apply sub_term_strict_incl in H1.
  destruct H2 as (x & Hin & Hx).
  apply in_flat_map.
  exists x; split; [exact Hin | now apply sub_terms_trans with t2].

- simpl in *.
  apply in_flat_map in H2.
  apply sub_term_strict_incl in H1.
  destruct H2 as (x & Hin & Hx).
  apply in_flat_map.
  exists x; split; [exact Hin | now apply sub_terms_trans with t2].
Qed.

Lemma lex_trans a1 a2 a3:
  lex a1 a2 -> lex a2 a3 -> lex a1 a3.
Proof.
intros H1 H2.
refine (lexprod_trans _ _ H1 H2).
- intros x1 x2 x3 Hx1 Hx2.
  refine (lexprod_trans lt_trans _ Hx1 Hx2).
  intros v1 v2 v3 Hv1 Hv2.
  eapply lt_trans; [exact Hv1 | exact Hv2].
- intros.
  eapply sub_terms_strict_trans; eauto.
Qed.

Inductive list_order {A : Type} (R : A -> A -> Prop) : list A -> list A -> Prop :=
| lo_cons:  forall l1 l2 h, Forall (fun x => R x h) l1 -> list_order R (l1 ++ l2) (h :: l2).

Definition W {A : Type} (R : A -> A -> Prop) (l : list A) : Prop :=
  Acc (list_order R) l.
(*  forall l', list_order R l' l -> Acc (list_order R) l'. *)

Lemma deuxpointun (A : Type) (R : A -> A -> Prop) (l : list A) (a : A) :
  (forall b, R b a -> forall l', W R l' -> W R (b :: l')) ->
   W R l (* /\
   (forall l', list_order R l' l -> W R (a :: l')) *) ->
  W R (a :: l).
Proof.
  intros H1 H2.
  constructor; intros l' Hlo.
  inversion Hlo; subst.
  induction l1.
  - simpl in *.
    constructor.
    apply H2.

  - constructor.
    assert (Ha0 : R a0 a) by (inversion H3; assumption).
    apply (H1 a0 Ha0).
    unfold W.
    apply IHl1; try constructor; inversion H3; assumption.
Qed.

Lemma deuxpointdeux (A : Type) (R : A -> A -> Prop) (l : list A) (a : A) :
  (forall b, R b a -> forall l, W R l -> W R (b :: l)) ->
  (forall l, W R l -> W R (a :: l)).
Proof.
intros H l' Hacc.
induction Hacc as [l'' Hl'' _].
apply deuxpointun.
- intros b Hb l' Hl'.
  now apply H.

- now constructor.
Qed.

Lemma deuxpointtrois (A : Type) (R : A -> A -> Prop) (l : list A) (a : A) :
  well_founded R -> W R l -> W R (a :: l).
Proof.
intros HR.
revert l.
induction (HR a).
intros l Hl.
eapply deuxpointdeux; [ exact l | | exact Hl ].
intros b Hb l' Hl'.
now apply H0.
Qed.

Lemma list_order_wf (A : Type) (R : A -> A -> Prop) :
  well_founded R -> well_founded (list_order R).
Proof.
intro HwfR.
intro l.
induction l.
- constructor.
  intros.
  inversion H.

- now apply deuxpointtrois.
Qed.

Lemma product_suml_lt l1 l2 :
  product lt l1 l2 ->
  suml l1 < suml l2.
Proof.
intro Hprod.
induction Hprod.
- simpl; subst; omega.

- simpl.
  apply plus_lt_le_compat; [assumption|].
  induction H0.
  + trivial.

  + assert (x0 <= y0) by (destruct H0; omega).
     simpl; omega.
Qed.

Lemma PPO_active_term_order_superset act act' :
  PPO rank (term_from_active_term act) (term_from_active_term act') ->
  active_term_order_superset act act'.
Proof.
intro HPPO.
destruct act as (f & lv).
destruct act' as (f' & lv').
simpl in HPPO.
inversion HPPO; subst.
- apply in_map_iff in H1.
  destruct H1 as (v & Hv & _).
  destruct v.
  inversion Hv.

- apply in_map_iff in H2.
  destruct H2 as (v & Hv & _).
  subst t.
  contradict H3.
  apply fapply_not_PPO_value; trivial.
  apply term_value_eqv; eauto.

- now left.

- unfold active_term_order_superset.
  simpl.
  rewrite H2.
  right.
  unfold value_list_order.
  apply product_suml_lt.
  clear f f' H2 HPPO.
  revert H4; intros Hppo.
  assert (Hlen := Hppo).
  apply product_length in Hlen.
  do 2 rewrite map_length in Hlen.
  revert lv' Hppo Hlen;
    induction lv as [ | v lv IH ];
    intros lv' Hppo Hlen;
    destruct lv' as [ | v' lv' ];
    simpl in *;
    try discriminate Hlen.

  + inversion Hppo.

  + revert Hppo;
    set (lt := map (@term_from_value _ _ _) lv : list term);
    set (lt' := map (@term_from_value _ _ _) lv' : list term);
    intros Hppo.
    apply eq_add_S in Hlen.
    inversion Hppo; subst.

    * apply term_from_value_injective in H2; subst v'.
      apply product_conseq; trivial.
      apply IH; assumption.

    * apply product_consst;
      [ apply (PPO_value_lt_size variable function) with (rank := rank); assumption | ].

      { clear Hppo v v' IH H2;
        revert lt lv' lt' Hlen H4;
        induction lv as [ | v lv IH ];
        intros lt lv' lt' Hlen Hfor;
        destruct lv' as [ | v' lv' ];
        [ constructor
        | inversion Hlen
        | inversion Hlen
        | ].

        subst lt lt'.
        simpl in *.
        apply eq_add_S in Hlen.
        constructor.

        - inversion Hfor; subst.
          destruct H2.
          + left.
            apply (PPO_value_lt_size variable function) with (rank := rank); assumption.
          + right.
            f_equal.
            apply (@term_from_value_injective variable function); assumption.
        - apply IH;
          [ | inversion Hfor ];
          assumption.
      }
Qed.

Lemma term_order_PPO t1 t2 : term_order t1 t2 -> PPO rank t1 t2.
Proof.
intro Horder.
unfold term_order in Horder.
induction t2 using term_ind2.
- inversion Horder.

- simpl in Horder.
  apply in_flat_map in Horder.
  destruct Horder as (t' & Hin & Ht').
  apply PPO_trans_eq with t'.
  + apply sub_term_eq_or_strict in Ht'.
    destruct Ht' as [Heq | Ht'].
    * now subst; right.

    * left; apply H; assumption.

  + now apply ppo_constr_in.

- simpl in Horder.
  apply in_flat_map in Horder.
  destruct Horder as (t' & Hin & Ht').
  apply PPO_trans_eq with t'.
  + apply sub_term_eq_or_strict in Ht'.
    destruct Ht' as [Heq | Ht'].
    * now subst; right.

    * left; apply H; assumption.

  + now apply ppo_fun_in.
Qed.

Lemma max_arity_subst s t f lp :
  rule_vars_defined (rule_intro f lp t) ->
  let t' := fapply f (map (fun p => term_from_value variable function (@psubst variable constructor s p)) lp) in
  max_arity_term (subst s t) <= Nat.max (max_arity_rule (rule_intro f lp t)) (max_arity_term t').
Proof.
  intros Hvars t'.
  assert (Hn : forall x, In x (vars_of_term t) ->
                   max_arity_term (term_from_value variable function (s x)) <= max_arity_term t').
  { subst t'.
    intros x Hx; apply Hvars in Hx; simpl.
    rewrite PeanoNat.Nat.max_le_iff; right.
    clear t f Hvars.
    rewrite in_flat_map in Hx; destruct Hx as (p & Hp & Hvars).
    transitivity (max_arity_term (term_from_value variable function (psubst s p))).
    - clear lp Hp; revert x Hvars.
      induction p as [ x | c lp IH ] using pattern_ind2.
      + simpl.
        intros x' H; destruct H; [ subst x' | ]; easy.
      + intros x Hx; simpl in Hx.
        apply in_flat_map in Hx; destruct Hx as (p & Hp & Hvars).
        transitivity (max_arity_term (term_from_value variable function (psubst s p))).
        * now apply IH.
        * simpl.
          rewrite PeanoNat.Nat.max_le_iff; right.
          now apply maxl_is_max, in_map, in_map, in_map.
    - apply maxl_is_max, in_map.
      set (t := term_from_value _ _ _);
      change (term_from_value _ _ _) with ((fun p => term_from_value variable function (psubst s p)) p) in t;
        subst t.
      now apply in_map.
  }

  remember (max_arity_term t') as n eqn: Heq; clear Heq.
  transitivity (Nat.max (max_arity_term t) n).
  - clear f lp t' Hvars.
    induction t as [ x | c lt IH | f lt IH ] using term_ind2.
    + simpl; apply Hn.
      simpl; now left.

    + simpl; rewrite <- Max.max_assoc.
      apply Nat.max_le_compat; [ now rewrite map_length | ].
      simpl in Hn; clear c.
      induction lt as [ | t lt IHlt ]; [ now apply le_O_n | ].
      simpl.
      set (ml := maxl _) at 2.
      replace (Nat.max (Nat.max (max_arity_term t) ml) n)
      with (Nat.max (Nat.max (max_arity_term t) n) (Nat.max ml n));
        [ | now rewrite <- Max.max_assoc, (Max.max_assoc n), (Max.max_comm n),
            <- (Max.max_assoc ml), Max.max_idempotent, Max.max_assoc ].
      subst ml; apply Nat.max_le_compat.

      * apply IH; [ now left | ].
        intros x Hx; apply Hn.
        now simpl; apply in_or_app; left.

      * apply IHlt.
        now intros t' Ht'; apply IH; right.
        now intros x Hx; apply Hn; simpl; apply in_or_app; right.

    + simpl; rewrite <- Max.max_assoc.
      apply Nat.max_le_compat; [ now rewrite map_length | ].
      simpl in Hn; clear f.
      induction lt as [ | t lt IHlt ]; [ now apply le_O_n | ].
      simpl.
      set (ml := maxl _) at 2.
      replace (Nat.max (Nat.max (max_arity_term t) ml) n)
      with (Nat.max (Nat.max (max_arity_term t) n) (Nat.max ml n));
        [ | now rewrite <- Max.max_assoc, (Max.max_assoc n), (Max.max_comm n),
            <- (Max.max_assoc ml), Max.max_idempotent, Max.max_assoc ].
      subst ml; apply Nat.max_le_compat.

      * apply IH; [ now left | ].
        intros x Hx; apply Hn.
        now simpl; apply in_or_app; left.

      * apply IHlt.
        now intros t' Ht'; apply IH; right.
        now intros x Hx; apply Hn; simpl; apply in_or_app; right.

  - simpl.
    apply PeanoNat.Nat.max_le_compat_r.
    now apply PeanoNat.Nat.le_max_l.
Qed.

Lemma first_rule_max_arity act t i s :
  wf_prog max_arity prog ->
  first_rule act = Some (i, s, t) ->
  max_arity_term (term_from_active_term act) <= max_arity ->
  max_arity_term t <= max_arity.
Proof.
intros Hwfprog Hrule.
destruct act as [f lv].
apply first_rule_sound in Hrule.
destruct Hrule as ([lp'  t''] & Hlengthi & Heqi & Hunify_list & Hsubst).
subst t.
etransitivity.
- apply max_arity_subst with (f := f) (lp := lp').
  eapply andl_in; [ apply Hwfprog | ].
  apply in_map.
  rewrite <- Heqi.
  now apply nth_In.
- apply Max.max_lub.
   + etransitivity; [ apply maxl_is_max  | apply Hwfprog].
       apply in_map.
       rewrite <- Heqi.
       apply nth_In; trivial.
   + rewrite <- map_map.
      erewrite unify_list_sound; eauto.
Qed.

Inductive evaluates : term -> value -> Prop :=
| CAPPLY : forall lt lv c, evaluates_list lt lv -> evaluates (capply c lt) (c_capply c lv)
| FAPPLY : forall lt lv f v i s t, evaluates_list lt lv ->
           first_rule (f, lv) = Some (i, s, t) ->
           evaluates t v ->
           evaluates (fapply f lt) v
with evaluates_list : list term -> list value -> Prop :=
| E_nil : evaluates_list [] []
| E_cons : forall t v lt lv, evaluates t v -> evaluates_list lt lv -> evaluates_list (t :: lt) (v :: lv).

Scheme evaluates_mut := Induction for evaluates Sort Prop
with evaluates_list_mut := Induction for evaluates_list Sort Prop.

Lemma evaluates_ind2 : forall P,
(forall lt lv c, Forall2 evaluates lt lv ->
                 Forall2 P lt lv ->
                 P (capply c lt) (c_capply c lv)) ->
(forall lt lv f i s v t,
  Forall2 evaluates lt lv -> Forall2 P lt lv ->
  first_rule (f, lv) = Some (i, s, t) ->
  evaluates t v -> P t v ->
  P (fapply f lt) v) ->
forall (t : term) (v : value), evaluates t v -> P t v.
Proof.
intros P Hc Hf t v He.
induction He using evaluates_mut with (P := fun t v H => P t v)
(P0 := fun lt lv H => Forall2 P lt lv /\ Forall2 evaluates lt lv).
- apply Hc; tauto.
- eapply Hf; eauto; tauto.
- auto.
- split; constructor; auto; tauto.
Qed.

Inductive Forall2' (A B : Type) (R : A -> B -> Type) : list A -> list B -> Type :=
    Forall2'_nil : Forall2' R [] []
  | Forall2'_cons : forall (x : A) (y : B) (l : list A) (l' : list B),
                   R x y -> Forall2' R l l' -> Forall2' R (x :: l) (y :: l').

Lemma Forall2_trans_rel (A : Type) (R1 R2 : A -> A -> Prop) (l1 l2 : list A) : (forall x y, R1 x y -> R2 x y) -> Forall2 R1 l1 l2 -> Forall2 R2 l1 l2.
Proof.
intros H Hall.
induction Hall; auto.
Qed.

Lemma Forall2_product (A : Type) (R : A -> A -> Prop) (ls lt : list A) :
  ls <>  [] -> Forall2 R ls lt -> product R ls lt.
Proof.
induction ls; intros Hnil Hall; try tauto.
clear Hnil.
destruct lt as [ | b lt]; [inversion Hall |].
inversion Hall; subst.
constructor 2; trivial.
eapply Forall2_trans_rel.
- intros; constructor; exact H.
- trivial.
Qed.

Lemma Forall2_eq A (l1 l2 : list A) :
  Forall2 eq l1 l2 -> l1 = l2.
Proof.
intro H; induction H; subst; trivial.
Qed.

Lemma evaluates_unique t v1 v2 :
  evaluates t v1 ->
  evaluates t v2 ->
  v1 = v2.
Proof.
intro H1; revert v2.
induction H1 using evaluates_ind2.
- intros v2 H2.
  inversion H2; subst; clear H2.
  f_equal; revert lv0 H5.
  induction H; intros lv0 Hlv0; inversion Hlv0; trivial.
  subst.
  f_equal; inversion H0; subst; auto.
- intros v2 Hv2.
  inversion Hv2; subst; clear Hv2.
  assert (Heq : lv = lv0) by
   (clear H6 H1; revert lv0 H5;
    induction H; intros lv0 Hlv0; inversion Hlv0; trivial;
    subst; f_equal; inversion H0; subst; auto).
  subst lv0.
  rewrite H6 in H1; inversion H1; subst.
  now apply IHevaluates.
Qed.

Lemma evaluates_value v :
  evaluates (term_from_value _ _ v) v.
Proof.
induction v using value_ind2.
constructor.
induction l as [|v lv]; constructor; auto with *.
Qed.

Lemma In_nth:
  forall (A : Type) (l : list A) (x d : A) n,
  n < length l -> nth n l d = x -> x ∈ l.
Proof.
intros A l x d n.
revert l.
induction n; intros [ | a l];
unfold nth; simpl; intros; try tauto; try omega.
auto with *.
Qed.

Lemma evaluates_sound t v c:
  (forall (t0 : term) (v0 : value), assoc_cache t0 c = Some v0
    -> evaluates t0 v0 /\ max_arity_term (term_from_value variable function v0) <= max_arity) ->
  evaluates t v ->
  max_arity_term t <= max_arity ->
  exists p, wf p /\ proj_right p = v /\ proj_left p = t /\ cache_left p = c /\
            max_arity_term (term_from_value variable function v) <= max_arity /\
   (forall t0 v0, assoc_cache t0 (cache_right p) = Some v0
      -> evaluates t0 v0 /\ max_arity_term (term_from_value variable function v0) <= max_arity).
Proof.
intros Hc Heval.
revert c Hc.
induction Heval using evaluates_ind2; intros c0 Hc0 Harity.
- assert (Hlp : exists lp c1,
    andl (map wf lp) /\ map (@proj_left _ _ _) lp = lt /\
    map (@proj_right _ _ _) lp = lv /\
    cache_path variable_eq_dec function_eq_dec constructor_eq_dec c0 c1 lp = true /\
    maxl (map (@max_arity_term _ _ _) (map (@term_from_value variable function _) lv)) <= max_arity /\
    forall (t0 : term) (v : value), assoc_cache t0 c1 = Some v -> evaluates t0 v
        /\ max_arity_term (term_from_value variable function v) <= max_arity
    ).
  { assert (Harityall: forall t, In t lt -> max_arity_term t <= max_arity) by
    ( intros t Ht; simpl in Harity; apply Max.max_lub_r in Harity;
      etransitivity; [ | apply Harity]; now apply maxl_is_max, in_map).
    clear Harity H.
    revert c0 lv H0 Hc0.
    induction lt using rev_ind; intros c0 lv H0 Hc0.
   - exists []; exists c0; simpl.
     inversion H0.
     simpl; intuition.
     now rewrite cache_beq_refl.
   - apply Forall2_app_inv_l in H0.
     destruct H0 as (lv' & ly & Hlt & Hx & Heq).
     subst lv.
     inversion Hx; subst.
     inversion H3; subst; clear H3.
     destruct IHlt with (c0 := c0) (lv := lv') as (lp & c' & Hlp);
     auto with *.
     decompose record Hlp.
     destruct H1  with (c:= c') as [p Hp]; auto with *.
     exists (lp ++ [p]); exists (cache_right p).
     decompose record Hp; subst.
     rewrite map_app, cache_path_app, andl_app.
     repeat rewrite map_app.
     simpl; repeat rewrite cache_beq_refl.
     repeat split; try tauto.
     + rewrite maxl_app.
       apply Nat.max_lub; trivial.
       simpl.
       now rewrite Max.max_0_r.
     + now apply H12.
     + now apply H12 in H0.
  }
  destruct Hlp as [lp Hlp]; decompose record Hlp.
  eexists (cbv_constr  _ _ (capply c lt) _ (c_capply c lv)); simpl.
  repeat split; eauto.
  + erewrite <- map_length; rewrite H1.
    now apply Max.max_lub_l in Harity.
  + apply Nat.max_lub; trivial.
    rewrite map_length.
    apply Max.max_lub_l in Harity.
    subst lv lt.
    now rewrite map_length in *.
  + now apply H7.
  + edestruct H7; eauto.
- assert (Hlp : exists lp c1,
    andl (map wf lp) /\ map (@proj_left _ _ _) lp = lt /\
    map (@proj_right _ _ _) lp = lv /\
    cache_path variable_eq_dec function_eq_dec constructor_eq_dec c0 c1 lp = true /\
    maxl (map (@max_arity_term _ _ _) (map (@term_from_value variable function _) lv)) <= max_arity /\
    forall (t0 : term) (v : value), assoc_cache t0 c1 = Some v -> evaluates t0 v
    /\ max_arity_term (term_from_value variable function v) <= max_arity

    ).
  { assert (Harityall: forall t, In t lt -> max_arity_term t <= max_arity) by
    ( intros t0 Ht; simpl in Harity; apply Max.max_lub_r in Harity;
      etransitivity; [ | apply Harity]; now apply maxl_is_max, in_map).
    clear Harity H1 H.
    revert c0 lv H0 Hc0.
    induction lt using rev_ind; intros c0 lv H0 Hc0.
   - exists []; exists c0; simpl.
     inversion H0.
     simpl; intuition.
     now rewrite cache_beq_refl.
   - apply Forall2_app_inv_l in H0.
     destruct H0 as (lv' & ly & Hlt & Hx & Heq).
     subst lv.
     inversion Hx; subst.
     inversion H3; subst; clear H3.
     destruct IHlt with (c0 := c0) (lv := lv') as (lp & c' & Hlp);
     auto with *.
     decompose record Hlp.
     destruct H1  with (c:= c') as [p Hp]; auto with *.
     exists (lp ++ [p]); exists (cache_right p).
     decompose record Hp; subst.
     rewrite map_app, cache_path_app, andl_app.
     repeat rewrite map_app.
     simpl; repeat rewrite cache_beq_refl.
     repeat split; try tauto.
     + rewrite maxl_app.
       apply Nat.max_lub; trivial.
       simpl.
       now rewrite Max.max_0_r.
     + now apply H12.
     + now apply H12 in H0.
  }
  destruct Hlp as (lp & cr & Hlp); decompose record Hlp.
  case_eq (assoc (term_beq variable_eq_dec function_eq_dec constructor_eq_dec) (fapply f (map (@term_from_value _ _ _) lv)) cr).
  + intros v0 Hv0.
    destruct (H8 _ _ Hv0) as [Heval0 Harity0].
    eexists (cbv_split _ (cbv_read _ (fapply f _) _) _ _ _ _).
    subst.
    assert (v0 = v).
    { eapply evaluates_unique; eauto.
      econstructor; eauto.
      clear H H1 H0 H2 H5 H6 Hv0 H8 Hlp cr IHHeval Harity Heval0.
      induction lp; constructor; trivial.
      apply evaluates_value.
    }
    subst v0.
    repeat split; trivial;simpl; repeat split; eauto.
    * apply Max.max_lub_l in Harity.
      now rewrite map_length in Harity.
    * now apply H8.
    * now apply H8 in H3.
  + assert(Hrule := H1).
    apply first_rule_sound in H1.
    destruct H1 as [[lp' t'] (Hlen & Hnth & Hunify & Hsubst)].
    destruct IHHeval with cr as [p Hp]; trivial.
    * unfold wf_prog in prog_is_wf; destruct prog_is_wf as (Hvars & Hmaxarity).
      subst t.
      apply first_rule_max_arity in Hrule; trivial.
      simpl; rewrite map_length.
      apply Nat.max_lub; trivial.
      subst lv lt.
      apply Nat.max_lub_l in Harity.
      now rewrite map_length in *.
    * intro Hcache.
      decompose record Hp; decompose record Hlp.
      set (tt := fapply f(map (term_from_value variable function (constructor:=constructor)) (map (psubst s) lp'))).
      eexists (cbv_split lp (cbv_update i s p cr (fapply f _) ((tt, v) :: (cache_right p)) v) _ (fapply f lt) ((tt, v):: (cache_right p)) v).
      simpl; subst.
      assert(Hlp_len : length lp <= max_arity) by
      (simpl in Harity; rewrite map_length in Harity; lia).
      apply unify_list_sound in Hunify.
      rewrite <- H7 in *; simpl.
      repeat split; auto.
      -- subst tt; exists lp'; rewrite Hunify.
         eexists; repeat split; eauto; try tauto.
         now repeat rewrite map_length.
      -- intros.
         case_eq (term_beq variable_eq_dec function_eq_dec constructor_eq_dec t0 tt).
         ++ intro Heq; rewrite term_beq_eq in Heq; subst t0.
            replace (term_beq variable_eq_dec function_eq_dec constructor_eq_dec tt tt) with true in H1 by
            (symmetry; now apply term_beq_eq).
            subst tt.
            eapply FAPPLY with (lv := (map (proj_right (constructor:=constructor)) lp)) (i := i) (s := s) (t := proj_left p); trivial.
            ** rewrite Hunify.
               clear H6 H3 H0 H1 Hcache Hlp H5 H6 H7 H11 H12 H13 H16 H14 H2 Harity H Hunify Hlp_len Hrule.
               induction lp; constructor.
               apply evaluates_value.
               apply IHlp; trivial.
               simpl in H17.
               now apply Nat.max_lub_r in H17.
            ** assert( Hbeq : forall t, term_beq variable_eq_dec function_eq_dec constructor_eq_dec t t = true) by
               (now intros; rewrite term_beq_eq).
               rewrite Hbeq in H3.
               now inversion H3.
         ++ intro Heq; rewrite Heq in H3.
            now apply H13.
      -- case_eq (term_beq variable_eq_dec function_eq_dec constructor_eq_dec t0 tt).
         ++ intro Heq; rewrite Heq in H3; inversion H3; now subst.
         ++ intro Hneq; rewrite Hneq in H3.
            now apply H13 in H3.
Qed.

(* Simpler, weaker version *)
Lemma evaluates_sound' (t : term) (v : value):
  evaluates t v ->
  max_arity_term t <= max_arity ->
  exists p, wf p /\ proj_right p = v /\ proj_left p = t.
Proof.
intros.
destruct (@evaluates_sound t v []); trivial.
- intros t' v' Hf; inversion Hf.
- intuition; eexists; eauto.
Qed.

End Evaluates.

Create HintDb eval.

Ltac reduce :=
  progress (repeat constructor) ||
  (econstructor; [repeat constructor; repeat reduce; eauto with eval
                              | solve [unfold first_rule; simpl; trivial]
                              | unfold assoc_default; repeat constructor; eauto with eval]).

Hint Extern 1 (@evaluates _ _ _ _ _ _ _ _ _ _)  => eapply evaluates_value: eval.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal4.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Lemma conj8synthconj3 : forall  (lv0 : lst), (@eq natural (len (append lv0 (Cons Zero lv0))) (Succ (len (append lv0 lv0)))).
Admitted.
QuickChick conj8synthconj3.


(** Defines the EType relation checks the well-formedness of a type
    indication τ, and transforms it into a semantical type *)

Require Import Environment.
Require Import SemanticalDomains.
Require Import AbstractSyntax.
Require Import ConstraintElaboration.

(** The type elaboration relation (general definition). *)

Inductive EType (Δ : ElDesign) : tind -> type -> Prop :=
| ETypeBool : EType Δ tind_boolean Tbool
| ETypeNat :
    forall {e e' n n'},
      EConstr Δ e e' n n' ->
      EType Δ (tind_natural e e') (Tnat n n')
| ETypeArray :
    forall {tau t e e' n n'},
      EType Δ tau t ->
      EConstr Δ e e' n n' ->
      EType Δ (tind_array tau e e') (Tarray t n n').

(** The type elaboration relation for generic constant type
    indication. *)

Inductive ETypeg : tind -> type -> Prop :=
| ETypeGBool : ETypeg tind_boolean Tbool
| ETypeGNat :
    forall {e e' n n'},
      EConstrG e e' n n' ->
      ETypeg (tind_natural e e') (Tnat n n').

(** Hints for EType and ETypeg *)

#[export] Hint Constructors EType : hvhdl.
#[export] Hint Constructors ETypeg : hvhdl.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition table_maps_block_spec (table: Pointer) (level: Z64) (ipa_state: Z64) (adt: RData) : option Z :=
    match level, ipa_state with
    | VZ64 level, VZ64 ipa_state =>
      rely is_int64 level; rely is_int64 ipa_state; rely (level >? 0);
      rely peq (base table) buffer_loc;
      when gidx == (buffer (priv adt)) @ (offset table);
      let gn := (gs (share adt)) @ gidx in
      rely prop_dec (glock gn = Some CPU_ID);
      rely g_tag (ginfo gn) =? GRANULE_STATE_TABLE;
      rely prop_dec (forall i, is_int64 ((g_data (gnorm gn)) @ i) = true);
      let pgte := (g_data (gnorm gn)) @ 0 in
      let base_pa := __entry_to_phys pgte level in
      rely is_int64 base_pa; rely is_int64 (base_pa + PGTES_PER_TABLE * GRANULE_SIZE);
      if __addr_is_level_aligned base_pa (level - 1) then
        Some (if prop_dec (forall i (Hi: 0 <= i < PGTES_PER_TABLE),
                        let e := (g_data (gnorm gn)) @ i in
                        let pa := __entry_to_phys e level in
                        PTE_TO_IPA_STATE e = ipa_state /\ pa = base_pa + i * GRANULE_SIZE)
              then 1 else 0)
      else Some 0
    end.

End Spec.


Add LoadPath "/home/user/Downloads/archives/sets-in-coq".
Require Export ZF.
Import IZF.

(*Theorem thm: not (exists x:set, ((power x) == x) ).*)
Theorem thm: not (exists x:set, ((power x) \incl x) ).
Proof.
intro H.
destruct H as [x A].
unfold "\incl" in A.
assert (H1 : not(x\in x)).
+ intro w.
  assert (G : x \in (singl x) ).
  * apply singl_intro.
  * destruct (regularity_ax _ _ G) as [z J C].
    apply C.
    exists x.
    trivial.
    rewrite -> (singl_elim _ _ J).
    trivial.
+ apply H1.
  apply (A x).
  apply power_intro.
  trivial.
Defined.

Definition N :=.

(* END OF PROOFS *)
(*
(*
Check (@eq_elim).
Check symmetry H.
Check (@eq_elim _ _ _ H).
pose (A := fun r => @eq_elim r _ _ H).
(*pose (B := fun r => @eq_elim r _ _ (symmetry H)).*)*)

Check regularity_ax (singl x) x.

destruct (regularity_ax x (x) w) as [z J C].
apply C.
exists x.
trivial.

pose (M1:=B x w).
pose (M2:=B z J).
rewrite <- H in M1.

%change x with (power x) in M1.
pose (M1:=B x w).

pose (eq_intro)

Theorem thm: not (exists x:set, ((power x) \incl x) ).
Proof.
intro H.
destruct H.
Print power.
unfold "\incl" in H.
assert (H1 : not(x\in x)).
Focus 2.
+ apply H1.
  apply (H x).
  apply power_intro.
  trivial.
+ intro w.
  pose(u:= minus2 x (singl x)).
  (*pose(u:= subset x (fun y => y \in singl x)).*)
  destruct (regularity_ax x x w).

  (*destruct (regularity_ax x x w).*)
  apply H1.
  exists u.
  admit.

  trivial.
  trivial.
  constructor.

Check (H x).
*)


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.spec_sha.
Require Import sha.sha_lemmas.
Require Import sha.bdo_lemmas.
Local Open Scope logic.

Definition block_data_order_loop2 :=
   nth 1 (loops (fn_body f_sha256_block_data_order)) Sskip.

Fixpoint Xarray' (b: list int) (i k: nat) : list int :=
 match k with
 | O => nil
 | S k' => W (nthi b) (Z.of_nat i - 16 + (16-(Z.of_nat k)- Z.of_nat i) mod 16) ::
                 Xarray' b i k'
 end.

Definition Xarray (b: list int) (i: nat) := Xarray' b i 16.

Lemma Xarray_simpl:
   forall b, Zlength b = 16 -> Xarray b 16 = b.
Proof.
intros.
apply Zlength_length in H; [ simpl in H | computable].
assert (forall n, (n<=16)%nat -> Xarray' b 16 n = skipn (16-n) b);
 [ | apply H0; auto ].
induction n; intros.
clear H0. rewrite skipn_short by lia. reflexivity.

unfold Xarray'; fold Xarray'.
rewrite IHn by lia. clear IHn.
change (Z.of_nat 16) with 16%Z.

assert (H1: firstn 1 (skipn (16 - S n) b) =
            W (nthi b) (16 - 16 + (Z.of_nat (16 - S n) - 16) mod 16) :: nil). {
 unfold firstn.
 destruct (skipn (16 - S n) b) eqn:?.
 pose proof (skipn_length b (16 - S n)).
 rewrite Heql in H1.
 simpl length in H1.
 lia.
 f_equal.
 pose proof (nth_skipn 0 (16 - S n)%nat b Int.zero).
 rewrite Heql in H1.
 unfold nth at 1 in H1.
 subst.
 rewrite Z.sub_diag. rewrite Z.add_0_l.
 rewrite Nat.add_0_l.
 rewrite Zminus_mod.
 rewrite Z.mod_same by lia. rewrite Z.sub_0_r.
 rewrite Z.mod_mod by lia.
 assert (0 <= (Z.of_nat (16 - S n))mod 16 < 16)%Z by (apply Z.mod_pos_bound; lia).
 rewrite W_equation.
 rewrite if_true by  lia.
 rewrite Z.mod_small.
 unfold nthi.
 rewrite Nat2Z.id.
 reflexivity.
 split; try lia.
}
assert (H2 := skipn_skipn 1 (16 - S n) b).
replace (16 - S n + 1)%nat with (16 - n)%nat in H2 by lia.
rewrite <- H2.
rewrite <- (firstn_skipn 1 (skipn (16 - S n) b)) at 2.
rewrite H1.
unfold app.
rewrite Nat2Z.inj_sub by lia.
reflexivity.
Qed.

Lemma length_Xarray:
  forall b i, Zlength (Xarray b i) = 16.
Proof.
intros. reflexivity.
Qed.

Lemma nth_Xarray:
  forall b i k,
     (0 <= k < 16)%Z ->
  nthi (Xarray b i) k = W (nthi b) (Z.of_nat i - 16 + (k- Z.of_nat i) mod 16)%Z .
Proof.
intros.
unfold nthi at 1.
remember (Z.to_nat k) as k'.
rewrite <- (Nat2Z.id k') in Heqk'.
apply Z2Nat.inj in Heqk'; try lia.
subst k.
assert (k'<16)%nat by lia.
clear H.
do 16 (destruct k'; try reflexivity).
exfalso; lia.
Qed.

Lemma extract_from_b:
  forall b i n,
    Zlength b = 16 ->
    (16 <= i < 64) ->
    (0 <= n < 16) ->
    nthi (Xarray b (Z.to_nat i)) ((i + n) mod 16) = W (nthi b) (i - 16 + n).
Proof.
intros.
rewrite nth_Xarray by (apply Z.mod_pos_bound; lia).
f_equal.
f_equal.
rewrite Z2Nat.id by lia. auto.
rewrite Z2Nat.id by lia.
rewrite Zminus_mod.
rewrite Zmod_mod.
rewrite Zplus_mod.
rewrite <- Zminus_mod.
rewrite (Zmod_small n) by lia.
replace (i mod 16 + n - i) with (i mod 16 - i + n) by lia.
rewrite Zplus_mod.
rewrite Zminus_mod.
rewrite Zmod_mod.
rewrite Z.sub_diag.
rewrite (Zmod_small 0) by lia.
rewrite Z.add_0_l.
repeat rewrite Zmod_mod.
apply Zmod_small; lia.
Qed.

Global Opaque Xarray.

Lemma Xarray_update:
 forall i b,
  Zlength b = LBLOCKz ->
  16 <= i < 64 ->
   upd_Znth (i mod 16) (map Vint (Xarray b (Z.to_nat i)))
          (Vint (W (nthi b) i))
  = map Vint (Xarray b (Z.to_nat i+1)).
Proof.
intros.
unfold upd_Znth.
rewrite !sublist_map.
rewrite <- !map_cons, <- !map_app.
f_equal.
repeat match type of H0 with
| (64 <= _ < _)%Z => exfalso; lia
| (?A <= _ < _)%Z =>
 assert (H9: i=A \/ (A+1 <= i < 64)%Z) by lia;
 clear H0; destruct H9 as [H0|H0];
 [subst i; reflexivity
 | simpl in H0 ]
end.
Qed.

Lemma W_unfold:
  forall i b,
  16 <= i < 64 ->
   W (nthi b) (i) =
    Int.add (W (nthi b) (i - 16 + 0))
             (Int.add
                (Int.add (sigma_0 (W (nthi b) (i - 16 + 1)))
                   (sigma_1 (W (nthi b) (i - 16 + 14))))
                (W (nthi b) (i - 16 + 9))).
Proof.
 intros.
 rewrite W_equation.
 rewrite if_false by lia.
  rewrite Z.add_0_r;
      rewrite (Int.add_commut (W (nthi b) (i - 16)));
      repeat rewrite <- Int.add_assoc; f_equal;
      rewrite Int.add_commut; repeat rewrite Int.add_assoc; f_equal;
        [do 2 f_equal; lia | ];
      f_equal; [do 2 f_equal; lia | f_equal; lia].
Qed.

Lemma sha256_block_data_order_loop2_proof:
  forall (Espec : OracleKind)
     (b: list int) ctx (regs: list int) gv Xv
     (Hregs: length regs = 8%nat),
     Zlength b = LBLOCKz ->
     semax (func_tycontext f_sha256_block_data_order Vprog Gtot nil)
 (PROP ()
   LOCAL (temp _ctx ctx; temp _i (Vint (Int.repr 16));
               temp _a (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 0));
               temp _b (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 1));
               temp _c (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 2));
               temp _d (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 3));
               temp _e (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 4));
               temp _f (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 5));
               temp _g (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 6));
               temp _h (Vint (nthi (Round regs (nthi b) (LBLOCKz-1)) 7));
               gvars gv; lvar _X (tarray tuint LBLOCKz) Xv)
   SEP ( K_vector gv;
           data_at Tsh (tarray tuint LBLOCKz) (map Vint b) Xv))
  block_data_order_loop2
  (normal_ret_assert
    (PROP ()
     LOCAL(temp _ctx ctx;
                temp _a (Vint (nthi (Round regs (nthi b) 63) 0));
                temp _b (Vint (nthi (Round regs (nthi b) 63) 1));
                temp _c (Vint (nthi (Round regs (nthi b) 63) 2));
                temp _d (Vint (nthi (Round regs (nthi b) 63) 3));
                temp _e (Vint (nthi (Round regs (nthi b) 63) 4));
                temp _f (Vint (nthi (Round regs (nthi b) 63) 5));
                temp _g (Vint (nthi (Round regs (nthi b) 63) 6));
                temp _h (Vint (nthi (Round regs (nthi b) 63) 7));
                gvars gv; lvar _X (tarray tuint LBLOCKz) Xv)
     SEP (K_vector gv;
            data_at_ Tsh (tarray tuint LBLOCKz) Xv))).
Proof.
intros.
unfold block_data_order_loop2; simpl nth.
rewrite semax_skip_seq.
match goal with
 | |- context [Ssequence ?s1 (Sloop (Ssequence (Sifthenelse ?e Sskip Sbreak) ?s2) ?s3)] =>
      fold (Sfor s1 e s2 s3)
 end.
abbreviate_semax.
change 16%nat with LBLOCK.

forward_for_simple_bound 64%Z
   (EX i:Z,
    PROP ((16 <= i)%Z )
    LOCAL  (temp _ctx ctx;
                  temp _a (Vint (nthi (Round regs (nthi b) (i - 1)) 0));
                  temp _b (Vint (nthi (Round regs (nthi b) (i - 1)) 1));
                  temp _c (Vint (nthi (Round regs (nthi b) (i - 1)) 2));
                  temp _d (Vint (nthi (Round regs (nthi b) (i - 1)) 3));
                  temp _e (Vint (nthi (Round regs (nthi b) (i - 1)) 4));
                  temp _f (Vint (nthi (Round regs (nthi b) (i - 1)) 5));
                  temp _g (Vint (nthi (Round regs (nthi b) (i - 1)) 6));
                  temp _h (Vint (nthi (Round regs (nthi b) (i - 1)) 7));
                  lvar _X (tarray tuint LBLOCKz) Xv;
                  gvars gv)
     SEP (K_vector gv;
       data_at Tsh (tarray tuint LBLOCKz) (map Vint (Xarray b (Z.to_nat i))) Xv)).
*
forward. (* skip; *)
Exists 16.
entailer!.
rewrite Xarray_simpl; auto.
*
Intros.
destruct H0 as [_ H2].
assert (H0: LBLOCKz <= i < 64) by (change LBLOCKz with 16%Z; lia).
clear H2 H1.
(*assert (H': length b = 16%nat) by (apply Zlength_length in H; auto). *)
assert (LBE := LBLOCK_zeq).
change LBLOCKz with 16%Z in H0.
change (tarray tuint LBLOCKz) with (tarray tuint 16).
change LBLOCKz with 16%Z in H.
assert (Hand15 : forall j, Int.min_signed <= Z.land j 15 <= Int.max_signed)
 by (intros j; assert  (X:=Z.mod_pos_bound j 16); rewrite Zland_15; cbn; lia).
forward.	(*s0 = X[(i+1)&0x0f]; *)
autorewrite with sublist. rewrite Zland_15.
forward. (* s0 = sigma0(s0); *)
rewrite extract_from_b by auto; rewrite Int.and_mone; rewrite <- sigma_0_eq.

forward. (* s1 = X[(i+14)&0x0f]; *)
autorewrite with sublist. rewrite Zland_15.

forward. (* s1 = sigma1(s1); *)
rewrite extract_from_b by auto; rewrite Int.and_mone; rewrite <- sigma_1_eq.

forward. (* T1 = X[i&0xf]; *)
autorewrite with sublist. rewrite Zland_15.
replace (nthi (Xarray b (Z.to_nat i)) (i mod 16))
  with (W (nthi b) (i - 16 + 0))
 by (replace (i mod 16) with ((i + 0) mod 16)
        by (rewrite Z.add_0_r; auto);
      rewrite extract_from_b; try lia; auto).

forward. (* t = X[(i+9)&0xf]; *)
autorewrite with sublist. rewrite Zland_15.
rewrite extract_from_b by (try assumption; try lia).

forward.  (* T1 += s0 + s1 + t; *)
pattern (i-16) at 1; rewrite <- (Z.add_0_r (i - 16)).
rewrite <- (W_unfold i b) by auto.

forward. (* X[i&0xf] = T1; *)
rewrite Zland_15.
rewrite Xarray_update by assumption.
unfold K_vector.
change CBLOCKz with 64%Z.
assert (LEN: Zlength K256 = 64%Z) by reflexivity.
forward.  (* Ki=K256[i]; *)
autorewrite with sublist.
rename b into bb.
assert (Hregs' := length_Round _ (nthi bb) (i-1) Hregs).
remember (Round regs (nthi bb) (i - 1)) as regs' eqn:H1.
(destruct regs' as [ | a [ | b [ | c [ | d [ | e [ | f [ | g [ | h [ | ]]]]]]]]];
  try now inversion Hregs'); [ clear Hregs' ].
change (nthi [a;b;c;d;e;f;g;h]) with (fun t => nth (Z.to_nat t) [a;b;c;d;e;f;g;h] Int.zero);
  cbv beta; simpl nth.
forward. (* T1 += h + Sigma1(e) + Ch(e,f,g) + Ki; *)
rewrite <- Sigma_1_eq, <- Ch_eq.
forward. 	(* T2 = Sigma0(a) + Maj(a,b,c); *)
rewrite <- Sigma_0_eq, <- Maj_eq.
repeat forward.
rewrite Z.add_simpl_r.
rewrite Z2Nat.inj_add by lia.
entailer!.
(* all: try apply derives_refl.   to support Coq 8.13 *)
clear - H H0 H1.
rewrite Round_equation.
forget (W (nthi bb) i) as Wbbi.
rewrite if_false by lia.
rewrite <- H1; clear H1.
unfold rnd_function, nthi; simpl.
repeat split; try reflexivity.
 +
  f_equal.
  rewrite <- Int.add_assoc; symmetry; rewrite <- Int.add_assoc.
  f_equal. f_equal.
  rewrite Int.add_commut. rewrite !Int.add_assoc. reflexivity.
 +
  f_equal. f_equal. rewrite Int.add_commut. f_equal.
*
 entailer!.
Qed.