From Coq Require Import String Arith NArith ZArith Eqdep_dec.

From Vyper Require FSet Map UInt256.

From Vyper Require Import Config Calldag.
From Vyper.L10 Require Import AST Base Callset Descend.

Local Open Scope list_scope.
Local Open Scope string_scope.

Ltac destruct_let_pair
:= match goal with
   |- (let (_, _) := ?x in _) = let (_, _) := ?x in _ =>
     destruct x
   end.
Ltac destruct_if
:= match goal with
   |- (if ?x then _ else _) = (if ?x then _ else _) =>
     destruct x
   end.

Section Expr.
Context {C: VyperConfig}.

Definition storage_var_is_declared (cd: calldag)
                                   (name: string)
: bool
:= match cd_declmap cd name with
   | Some (StorageVarDecl _) => true
   | _ => false
   end.

Fixpoint interpret_expr {bigger_call_depth_bound smaller_call_depth_bound: nat}
                        (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
                        {cd: calldag}
                        (fc: fun_ctx cd bigger_call_depth_bound)
                        (do_call: forall
                                      (fc': fun_ctx cd smaller_call_depth_bound)
                                      (world: world_state)
                                      (arg_values: list uint256),
                                    world_state * expr_result uint256)
                        (builtins: string -> option builtin)
                        (world: world_state)
                        (loc: string_map uint256)
                        (e: expr)
                        (CallOk: let _ := string_set_impl in
                                 FSet.is_subset (expr_callset e)
                                                (decl_callset (fun_decl fc))
                                 = true)
{struct e}
: world_state * expr_result uint256
:= let fix interpret_expr_list (world: world_state)
                           (loc: string_map uint256)
                           (e: list expr)
                           (CallOk: let _ := string_set_impl in
                                    FSet.is_subset (expr_list_callset e)
                                                   (decl_callset (fun_decl fc))
                                    = true)
  {struct e}
  : world_state * expr_result (list uint256)
  := match e as e' return e = e' -> _ with
     | nil => fun _ => (world, ExprSuccess nil)
     | (h :: t)%list => fun E =>
         let (world', result_h) := interpret_expr Ebound fc do_call builtins
                                                  world loc h
                                                  (callset_descend_head E CallOk)
         in match result_h with
            | ExprAbort ab => (world', ExprAbort ab)
            | ExprSuccess x =>
               let (world'', result_t) := interpret_expr_list world' loc t
                                                              (callset_descend_tail E CallOk)
               in (world'', match result_t with
                            | ExprAbort _ => result_t
                            | ExprSuccess y => ExprSuccess (x :: y)%list
                            end)
             end
     end eq_refl
   in match e as e' return e = e' -> _ with
   | Const val => fun _ => (world, ExprSuccess val)
   | LocalVar name => fun _ =>
       (world, match map_lookup loc name with
               | Some val => ExprSuccess val
               | None => expr_error "undeclared local variable"
               end)
   | StorageVar name => fun _ =>
     if storage_var_is_declared cd name
        then (world, ExprSuccess (match storage_lookup world name with
                                  | None => zero256
                                  | Some x => x
                                  end))
        else (world, expr_error "undeclared global variable")
   | UnOp op a => fun E =>
       let (world', result) := interpret_expr Ebound fc do_call builtins
                                              world loc a
                                              (callset_descend_unop E CallOk)
       in (world', match result with
                   | ExprSuccess val => interpret_unop op val
                   | ExprAbort _ => result
                   end)
   | BinOp op a b => fun E =>
       let (world', result_a) := interpret_expr Ebound fc do_call builtins
                                                world loc a
                                                (callset_descend_binop_left E CallOk)
       in match result_a with
       | ExprAbort _ => (world', result_a)
       | ExprSuccess x =>
         let (world'', result_b) := interpret_expr Ebound fc do_call builtins
                                                   world' loc b
                                                   (callset_descend_binop_right E CallOk)
         in (world'', match result_b with
                      | ExprAbort _ => result_b
                      | ExprSuccess y => interpret_binop op x y
                      end)
       end
   | IfThenElse cond yes no => fun E =>
       let (world', result_cond) := interpret_expr Ebound fc do_call builtins
                                                   world loc cond
                                                   (callset_descend_if_cond E CallOk)
       in match result_cond with
          | ExprAbort _ => (world', result_cond)
          | ExprSuccess cond_value =>
              if (Z_of_uint256 cond_value =? 0)%Z
                then interpret_expr Ebound fc do_call builtins
                                    world' loc no
                                    (callset_descend_if_else E CallOk)
                else interpret_expr Ebound fc do_call builtins
                                    world' loc yes
                                    (callset_descend_if_then E CallOk)
          end
   | LogicalAnd a b => fun E =>
       let (world', result_a) := interpret_expr Ebound fc do_call builtins
                                                world loc a
                                                (callset_descend_and_left E CallOk)
       in match result_a with
          | ExprAbort _ => (world', result_a)
          | ExprSuccess a_value =>
              if (Z_of_uint256 a_value =? 0)%Z
                then (world', result_a)
                else interpret_expr Ebound fc do_call builtins
                                    world' loc b
                                    (callset_descend_and_right E CallOk)
          end
   | LogicalOr a b => fun E =>
       let (world', result_a) := interpret_expr Ebound fc do_call builtins
                                                world loc a
                                                (callset_descend_or_left E CallOk)
       in match result_a with
          | ExprAbort msg => (world', result_a)
          | ExprSuccess a_value =>
              if (Z_of_uint256 a_value =? 0)%Z
                then interpret_expr Ebound fc do_call builtins
                                    world' loc b
                                    (callset_descend_or_right E CallOk)
                else (world', result_a)
          end
   | PrivateOrBuiltinCall name args => fun E =>
       let (world', result_args) :=
         interpret_expr_list world loc args
                             (callset_descend_args E CallOk)
       in match result_args with
          | ExprAbort ab => (world', ExprAbort ab)
          | ExprSuccess arg_values =>
              match fun_ctx_descend fc CallOk Ebound E with
              | Some new_fc => do_call new_fc world' arg_values
              | None => (* can't resolve the function, maybe it's a builtin *)
                 match builtins name with
                 | Some (existT _ arity b) =>
                    (if (arity =? List.length arg_values)%nat as arity_ok
                     return _ = arity_ok -> _
                         then fun Earity => call_builtin arg_values Earity (b world')
                         else fun _ => (world', expr_error "builtin with wrong arity"))
                       eq_refl
                 | None => (world', expr_error "can't resolve function name")
                 end
              end
          end
   end eq_refl.

(* This is not needed as PropExtensionality covers it.
   But this is an example of induction on expr.
 *)
Lemma interpret_expr_fun_ctx_irrel {bigger_call_depth_bound smaller_call_depth_bound: nat}
                                   (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
                                   {cd: calldag}
                                   {fc1 fc2: fun_ctx cd bigger_call_depth_bound}
                                   (FcOk: fun_name fc1 = fun_name fc2)
                                   (do_call: forall
                                                 (fc': fun_ctx cd smaller_call_depth_bound)
                                                 (world: world_state)
                                                 (arg_values: list uint256),
                                               world_state * expr_result uint256)
                                   (builtins: string -> option builtin)
                                   (world: world_state)
                                   (loc: string_map uint256)
                                   (e: expr)
                                   (CallOk1: let _ := string_set_impl in
                                                FSet.is_subset (expr_callset e)
                                                               (decl_callset (fun_decl fc1))
                                                = true)
                                   (CallOk2: let _ := string_set_impl in
                                                FSet.is_subset (expr_callset e)
                                                               (decl_callset (fun_decl fc2))
                                                = true):
  interpret_expr Ebound fc1 do_call builtins world loc e CallOk1
   =
  interpret_expr Ebound fc2 do_call builtins world loc e CallOk2.
Proof.
revert world loc.
induction e using expr_ind'; cbn; intros.
{ trivial. }
{ trivial. }
{ trivial. }
{ (* unop *)
  now rewrite IHe with (CallOk2 := callset_descend_unop eq_refl CallOk2).
}
{ (* binop *)
  rewrite IHe1 with (CallOk2 := callset_descend_binop_left eq_refl CallOk2).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  rewrite IHe2 with (CallOk2 := callset_descend_binop_right eq_refl CallOk2).
  destruct_let_pair.
  trivial.
}
{ (* if *)
  rewrite IHe1 with (CallOk2 := callset_descend_if_cond eq_refl CallOk2).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  destruct_if.
  { now rewrite IHe3 with (CallOk2 := callset_descend_if_else eq_refl CallOk2). }
  now rewrite IHe2 with (CallOk2 := callset_descend_if_then eq_refl CallOk2).
}
{ (* and *)
  rewrite IHe1 with (CallOk2 := callset_descend_and_left eq_refl CallOk2).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  now destruct_if.
}
{ (* or *)
  rewrite IHe1 with (CallOk2 := callset_descend_or_left eq_refl CallOk2).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  now destruct_if.
}
(* call *)
remember (fix interpret_expr_list world loc (e: list expr) CallOk := _) as interpret_expr_list1.
remember (fix interpret_expr_list world loc (e: list expr)
                                  (CallOk: FSet.is_subset (expr_list_callset e)
                                           (decl_callset (fun_decl fc2))
                                           = true) := _) as interpret_expr_list2.
assert (L: interpret_expr_list1 world loc args (callset_descend_args eq_refl CallOk1)
            =
           interpret_expr_list2 world loc args (callset_descend_args eq_refl CallOk2)).
{
  remember (callset_descend_args eq_refl CallOk1) as ListCallOk1.
  remember (callset_descend_args eq_refl CallOk2) as ListCallOk2.
  clear HeqListCallOk1 HeqListCallOk2 CallOk1 CallOk2.
  revert world loc ListCallOk1 ListCallOk2.
  induction args; intros. { now subst. }
  rewrite Heqinterpret_expr_list1. rewrite Heqinterpret_expr_list2. cbn.
  rewrite (List.Forall_inv H
            (callset_descend_head eq_refl ListCallOk1)
            (callset_descend_head eq_refl ListCallOk2)).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  rewrite<- Heqinterpret_expr_list1.
  rewrite<- Heqinterpret_expr_list2.
  rewrite (IHargs (List.Forall_inv_tail H) w loc
            (callset_descend_tail eq_refl ListCallOk1)
            (callset_descend_tail eq_refl ListCallOk2)).
  now destruct_let_pair.
}
clear Heqinterpret_expr_list1 Heqinterpret_expr_list2.
rewrite L.
destruct_let_pair.
destruct e. 2:{ trivial. }
assert (F: fun_ctx_descend fc1 CallOk1 Ebound eq_refl
            =
           fun_ctx_descend fc2 CallOk2 Ebound eq_refl).
{ apply fun_ctx_descend_irrel. }
rewrite F.
now destruct (fun_ctx_descend fc2 CallOk2 Ebound eq_refl).
Qed.

End Expr.

Ltac destruct_interpret_expr_irrel
:= match goal with
   H: fun_name ?fc1 = fun_name ?fc2
   |- (let (_, _) := interpret_expr ?Ebound ?fc1 ?do_call ?builtins ?world ?loc ?e ?c1 in _)
       =
      (let (_, _) := interpret_expr ?Ebound ?fc2 ?do_call ?builtins ?world ?loc ?e ?c2 in _)
       =>
      rewrite (interpret_expr_fun_ctx_irrel Ebound H do_call builtins
                                            world loc e c1 c2);
      destruct_let_pair
   end.


Require Import Coq.Lists.List.
Import ListNotations.

Require Import Tactics.
Require Import Axioms.
Require Import Sigma.
Require Import Equality.
Require Import Sequence.
Require Import Relation.
Require Import Ordinal.
Require Import Syntax.
Require Import SimpSub.
Require Import Dynamic.
Require Import Ofe.
Require Import Uniform.
Require Import Intensional.
Require Import Candidate.
Require Import System.
Require Import Semantics.
Require Import SemanticsKnot.
Require Import Judgement.
Require Import Hygiene.
Require Import ProperClosed.
Require Import ProperFun.
Require Import Shut.

Require Import SemanticsFut.
Require Import Equivalence.
Require Import Equivalences.
Require Import ProperLevel.
Require Import Defined.
Require Import PageType.
Require Import Subsumption.

Local Ltac prove_hygiene :=
  repeat (apply hygiene_auto; cbn; repeat2 split; auto);
  eauto using hygiene_weaken, clo_min, hygiene_shift', hygiene_subst1, subst_closub;
  try (apply hygiene_var; cbn; auto; done).

Lemma pwctx_cons_tml :
  forall i m p s s' a G,
    pwctx i s s' G
    -> hygiene clo m
    -> hygiene clo p
    -> hygiene (ctxpred G) a
    -> (i > 0 -> seqhyp (pred i) m p (hyp_tm (subst s a)) (hyp_tm (subst s' a)))
    -> (forall j s'',
          j < i
          -> pwctx j s s'' G
          -> relhyp j false (hyp_tm (subst s' a)) (hyp_tm (subst s'' a)))
    -> (forall j s'',
          j < i
          -> pwctx j s'' s' G
          -> relhyp j true (hyp_tm (subst s a)) (hyp_tm (subst s'' a)))
    -> pwctx i (dot m s) (dot p s') (cons (hyp_tml a) G).
Proof.
intros i m p s s' a G Hs Hclm Hclp Hcla Hh Hleft Hright.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
apply pwctx_cons; auto.
  {
  simpsub.
  destruct i as [| i].
    {
    apply (seqhyp_tml _#5 (iubase empty_urel)); eauto using subst_closub; try (intro; omega).
    }
  assert (S i > 0) as Hpos by omega.
  invert (Hh Hpos).
  intros R Hal Har Hmp.
  apply (seqhyp_tml _#5 R); eauto using subst_closub.
  }

  {
  intros j b s'' Hsmall Hs'.
  destruct b.
    {
    cbn.
    invert Hsmall.
    intros Hji.
    apply Hleft; auto.
    eapply seqctx_pwctx_demote_left; eauto.
    }

    {
    cbn.
    invert Hsmall.
    intros Hji.
    so (seqctx_impl_closub _#4 Hs') as (_ & Hcls'').
    destruct j as [| j].
      {
      apply (relhyp_tml _#4 (iubase empty_urel)); eauto using subst_closub; intro; omega.
      }
    exploit (Hleft j s'') as H.
      {
      omega.
      }

      {
      cbn in Hs'.
      apply (pwctx_downward (S j)); [omega |].
      refine (seqctx_pwctx_left _#5 _ Hs').
      eapply pwctx_downward; eauto.
      }
    invertc H.
    intros R Hal Har.
    apply (relhyp_tml _#4 R); eauto using subst_closub.
    }
  }

  {
  intros j b s'' Hsmall Hs'.
  destruct b.
    {
    cbn.
    invert Hsmall.
    intros Hji.
    apply Hright; auto.
    eapply seqctx_pwctx_demote_right; eauto.
    }

    {
    cbn.
    invert Hsmall.
    intros Hji.
    so (seqctx_impl_closub _#4 Hs') as (Hcls'' & _).
    destruct j as [| j].
      {
      apply (relhyp_tml _#4 (iubase empty_urel)); eauto using subst_closub; try (intro; omega).
      }
    exploit (Hright j s'') as H.
      {
      omega.
      }

      {
      cbn in Hs'.
      apply (pwctx_downward (S j)); [omega |].
      refine (seqctx_pwctx_right _#5 _ Hs').
      eapply pwctx_downward; eauto.
      }
    invertc H.
    intros R Hal Har.
    apply (relhyp_tml _#4 R); eauto using subst_closub.
    }
  }
Qed.

Lemma pwctx_cons_tml_seq :
  forall i m p s s' a G,
    pwctx i s s' G
    -> hygiene clo m
    -> hygiene clo p
    -> hygiene (ctxpred G) a
    -> (i > 0 -> seqhyp (pred i) m p (hyp_tm (subst s a)) (hyp_tm (subst s' a)))
    -> (forall i t t',
          pwctx i t t' (promote G)
          -> exists pg R,
               interp pg true i (subst t a) R
               /\ interp pg false i (subst t' a) R)
    -> pwctx i (dot m s) (dot p s') (cons (hyp_tml a) G).
Proof.
intros i m p s s' a G Hs Hclm Hclp Hcla Hh Hact.
apply pwctx_cons; auto.
  {
  simpsub.
  so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
  destruct i as [| i].
    {
    apply (seqhyp_tml _#5 (iubase empty_urel)); eauto using subst_closub; try omega.
    }
  invert (Hh (Nat.lt_0_succ _)).
  intros R Hl Hr Hmp.
  apply (seqhyp_tml _#5 R); eauto using subst_closub.
  }

  {
  intros j b u Hsmall Hu.
  destruct b.
    {
    cbn.
    so (pwctx_smaller _#6 Hsmall Hs) as Hsj.
    so (Hact j s s' Hsj) as (pg & R & Hl & Hr).
    so (Hact j s u (seqctx_pwctx_left _#5 Hsj Hu)) as (pg' & R' & Hl' & Hr').
    so (interp_fun _#7 Hl Hl'); subst R'.
    eapply relhyp_tm; eauto using interp_increase, toppg_max.
    }

    {
    cbn.
    cbn in Hu.
    so (pwctx_impl_closub _#4 Hs) as (_ & Hcls').
    so (seqctx_impl_closub _#4 Hu) as (_ & Hclu).
    destruct j as [| j].
      {
      apply (relhyp_tml _#4 (iubase empty_urel)); try (intros; omega);
      eapply subst_closub; eauto.
      }
    so (seqctx_promote _#4 Hu) as Hu'.
    so (pwctx_promote _#4 (pwctx_smaller _#6 Hsmall Hs)) as Hsj.
    cbn in Hsj.
    fold (promote G) in Hsj.
    so (Hact j s s' Hsj) as (pg & R & Hl & Hr).
    so (Hact j s u (seqctx_pwctx_left _#5 Hsj Hu')) as (pg' & R' & Hl' & Hr').
    so (interp_fun _#7 Hl Hl'); subst R'.
    apply (relhyp_tml _#4 R); try (eapply subst_closub; eauto);
    intro; cbn; eauto using interp_increase, toppg_max.
    }
  }

  {
  intros j b u Hsmall Hu.
  destruct b.
    {
    cbn.
    so (pwctx_smaller _#6 Hsmall Hs) as Hsj.
    so (Hact j s s' Hsj) as (pg & R & Hl & Hr).
    so (Hact j u s' (seqctx_pwctx_right _#5 Hsj Hu)) as (pg' & R' & Hl' & Hr').
    so (interp_fun _#7 Hr Hr'); subst R'.
    eapply relhyp_tm; eauto using interp_increase, toppg_max.
    }

    {
    cbn.
    cbn in Hu.
    so (pwctx_impl_closub _#4 Hs) as (Hcls & _).
    so (seqctx_impl_closub _#4 Hu) as (Hclu & _).
    destruct j as [| j].
      {
      apply (relhyp_tml _#4 (iubase empty_urel)); try (intros; omega);
      eapply subst_closub; eauto.
      }
    so (seqctx_promote _#4 Hu) as Hu'.
    so (pwctx_promote _#4 (pwctx_smaller _#6 Hsmall Hs)) as Hsj.
    cbn in Hsj.
    fold (promote G) in Hsj.
    so (Hact j s s' Hsj) as (pg & R & Hl & Hr).
    so (Hact j u s' (seqctx_pwctx_right _#5 Hsj Hu')) as (pg' & R' & Hl' & Hr').
    so (interp_fun _#7 Hr Hr'); subst R'.
    apply (relhyp_tml _#4 R); try (eapply subst_closub; eauto);
    intro; cbn; eauto using interp_increase, toppg_max.
    }
  }
Qed.

Lemma sound_fut_kind_formation :
  forall G lv k k',
    pseq (promote G) (deq k k' (kuniv lv))
    -> pseq G (deq lv lv pagetp)
    -> pseq G (deq (fut k) (fut k') (kuniv lv)).
Proof.
intros G lv k l.
revert G.
refine (seq_pseq_promote 2 [] k [] l 2 true [] _ false [] _ _ _); cbn.
intros G Hclk Hcll Hseq Hseqlv.
rewrite -> seq_eqkind in Hseq |- *.
rewrite -> seq_deq in Hseqlv.
eassert _ as Hlv; [refine (seq_pagetp_invert G lv _) |].
  {
  intros i t t' Ht.
  so (Hseqlv _#3 Ht) as (R & Hl & _ & Hlv & _).
  eauto.
  }
clear Hseqlv.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
destruct i as [| i].
  {
  so (Hlv _#3 Hs) as (pg & Hlvl & Hlvr).
  exists pg, (qfut qone), (iufut0 stop), (pginterp_lt_top _ _ Hlvl).
  simpsub.
  do2 9 split; auto;
  try (apply kinterp_eval_refl; apply interp_kfut_zero; eapply subst_closub; eauto);
  try (apply interp_eval_refl; apply interp_fut_zero; eapply subst_closub; eauto).
  }
so (pwctx_promote _#4 Hs) as Hs'.
so (Hseq _#3 Hs') as (pg & K & R & h & Hlvl & Hlvr & Hkl & Hkr & Hll & Hlr & Hklt & Hkrt & Hllt & Hlrt).
exists pg, (qfut K), (iufut stop (S i) R), h.
simpsub.
do2 9 split; auto;
try (apply kinterp_eval_refl; apply interp_kfut; auto);
try (apply interp_eval_refl; apply interp_fut; auto).
Qed.

Lemma sound_fut_formation :
  forall G a b,
    pseq (promote G) (deqtype a b)
    -> pseq G (deqtype (fut a) (fut b)).
Proof.
intros G a b.
revert G.
refine (seq_pseq_promote 2 [] a [] b 1 true [] _ _ _); cbn.
intros G Hcla Hclb Hseq.
rewrite -> seq_eqtype in Hseq |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
destruct i as [| i].
  {
  exists (iufut0 stop).
  simpsub.
  do2 3 split;
  apply interp_eval_refl; apply interp_fut_zero; eapply subst_closub; eauto.
  }
so (pwctx_promote _#4 Hs) as Hs'.
so (Hseq _#3 Hs') as (R & Hal & Har & Hbl & Hbr).
exists (iufut stop (S i) R).
do2 3 split;
apply interp_eval_refl; apply interp_fut; auto.
Qed.

Lemma sound_fut_formation_univ :
  forall G lv a b,
    pseq (promote G) (deq a b (univ lv))
    -> pseq G (deq lv lv pagetp)
    -> pseq G (deq (fut a) (fut b) (univ lv)).
Proof.
intros G lv a b.
revert G.
refine (seq_pseq_promote 2 [] a [] b 2 true [] _ false [] _ _ _); cbn.
intros G Hcla Hclb Hseq Hseqlv.
rewrite -> seq_univ in Hseq |- *.
rewrite -> seq_deq in Hseqlv.
eassert _ as Hlv; [refine (seq_pagetp_invert G lv _) |].
  {
  intros i t t' Ht.
  so (Hseqlv _#3 Ht) as (R & Hl & _ & Hlv & _).
  eauto.
  }
clear Hseqlv.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
destruct i as [| i].
  {
  so (Hlv _#3 Hs) as (pg & Hlvl & Hlvr).
  exists pg, (iufut0 stop).
  do2 5 split; auto;
  apply interp_eval_refl; apply interp_fut_zero; eapply subst_closub; eauto.
  }
so (pwctx_promote _#4 Hs) as Hs'.
so (Hseq _#3 Hs') as (pg & R & Hlvl & Hlvr & Hal & Har & Hbl & Hbr).
exists pg, (iufut stop (S i) R).
simpsub.
do2 5 split; auto;
apply interp_eval_refl; apply interp_fut; auto.
Qed.

Lemma sound_fut_intro :
  forall G m n a,
    pseq (promote G) (deq m n a)
    -> pseq G (deq (next m) (next n) (fut a)).
Proof.
intros G m n a.
revert G.
refine (seq_pseq_promote 3 [] m [] n [] a 1 true [] _ _ _); cbn.
intros G Hclm Hcln Hcla Hseq.
rewrite -> seq_deq in Hseq |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
destruct i as [| i].
  {
  exists (iufut0 stop).
  simpsub.
  do2 4 split;
  try (apply interp_eval_refl; apply interp_fut_zero; eapply subst_closub; eauto);
  rewrite -> den_iufut0;
  apply fut_action_next_zero; try prove_hygiene.
  }
so (pwctx_promote _#4 Hs) as Hs'.
so (Hseq _#3 Hs') as (R & Hal & Har & Hm & Hn & Hmn).
exists (iufut stop (S i) R).
simpsub.
do2 4 split;
try (apply interp_eval_refl; apply interp_fut; auto);
apply fut_action_next; auto; omega.
Qed.

Lemma sound_fut_elim :
  forall G m n a p q b,
    pseq G (deq m n (fut a))
    -> pseq (promote G) (deqtype a a)
    -> pseq (cons (hyp_tml a) G) (deq p q b)
    -> pseq G (deq (subst1 (prev m) p) (subst1 (prev n) q) (subst1 (prev m) b)).
Proof.
intros G m n a p q b.
revert G.
refine (seq_pseq_promote 1 [] a 3 false [] _ true [] _ false [_] _ _ _); cbn.
intros G Hcla Hseqmn Hseqa Hseqpq.
rewrite -> seq_eqtype in Hseqa.
rewrite -> seq_deq in Hseqmn, Hseqpq |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
so (Hseqmn _#3 Hs) as (Af & Hal & Har & Hm & Hn & Hmn).
assert (forall c d,
          rel (den Af) i c d
          -> pwctx i (dot (prev c) s) (dot (prev d) s') (cons (hyp_tml a) G)) as Hs'.
  {
  intros c d Hcd.
  so (urel_closed _#5 Hcd) as (Hclc & Hcld).
  apply pwctx_cons_tml_seq; auto; try prove_hygiene.
    {
    intro Hpos.
    destruct i as [| i]; [omega |].
    cbn [pred].
    simpsubin Hal.
    simpsubin Har.
    invert (basic_value_inv _#6 value_fut Hal).
    intros A Hal' Heq1.
    invert (basic_value_inv _#6 value_fut Har).
    intros A' Har' Heq2.
    so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
    clear Heq2.
    subst Af.
    so (iufut_inj _#5 Heq); subst A'.
    apply (seqhyp_tm _#5 A); auto.
    apply (fut_action_prev _ (S i)).
    exact Hcd.
    }

    {
    intros j t t' Ht.
    so (Hseqa _#3 Ht) as (R & Hl & Hr & _).
    exists toppg, R.
    auto.
    }
  }
clear Hseqmn.
so (Hseqpq _#3 (Hs' _ _ Hm)) as (B & Hbml & Hbmr & Hmp & _).
so (Hseqpq _#3 (Hs' _ _ Hn)) as (B' & _ & Hbnr & _ & Hnq & _).
so (Hseqpq _#3 (Hs' _ _ Hmn)) as (B'' & Hbml' & Hbnr' & _ & _ & Hmnpq).
so (basic_fun _#7 Hbml Hbml'); subst B''.
so (basic_fun _#7 Hbnr Hbnr'); subst B'.
exists B.
simpsub.
do2 4 split; auto.
Qed.

Lemma sound_fut_elim_eqtype :
  forall G m n a b c,
    pseq G (deq m n (fut a))
    -> pseq (promote G) (deqtype a a)
    -> pseq (cons (hyp_tml a) G) (deqtype b c)
    -> pseq G (deqtype (subst1 (prev m) b) (subst1 (prev n) c)).
Proof.
intros G m n a b c.
revert G.
refine (seq_pseq_promote 1 [] a 3 false [] _ true [] _ false [_] _ _ _); cbn.
intros G Hcla Hseqmn Hseqa Hseqbc.
rewrite -> seq_eqtype in Hseqa, Hseqbc |- *.
rewrite -> seq_deq in Hseqmn.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
so (Hseqmn _#3 Hs) as (Af & Hal & Har & Hm & Hn & Hmn).
assert (forall p q,
          rel (den Af) i p q
          -> pwctx i (dot (prev p) s) (dot (prev q) s') (cons (hyp_tml a) G)) as Hs'.
  {
  intros p q Hpq.
  so (urel_closed _#5 Hpq) as (Hclp & Hclq).
  apply pwctx_cons_tml_seq; auto; try prove_hygiene.
    {
    intro Hpos.
    destruct i as [| i]; [omega |].
    cbn [pred].
    simpsubin Hal.
    simpsubin Har.
    invert (basic_value_inv _#6 value_fut Hal).
    intros A Hal' Heq1.
    invert (basic_value_inv _#6 value_fut Har).
    intros A' Har' Heq2.
    so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
    clear Heq2.
    subst Af.
    so (iufut_inj _#5 Heq); subst A'.
    apply (seqhyp_tm _#5 A); auto.
    apply (fut_action_prev _ (S i)).
    exact Hpq.
    }

    {
    intros j t t' Ht.
    so (Hseqa _#3 Ht) as (R & Hl & Hr & _).
    exists toppg, R.
    auto.
    }
  }
clear Hseqmn.
so (Hseqbc _#3 (Hs' _ _ Hm)) as (R & Hmbl & Hmbr & _).
so (Hseqbc _#3 (Hs' _ _ Hn)) as (R' & _ & _ & Hncl & Hncr).
so (Hseqbc _#3 (Hs' _ _ Hmn)) as (R'' & Hmbl' & _ & _ & Hncr').
so (basic_fun _#7 Hmbl Hmbl'); subst R''.
so (basic_fun _#7 Hncr Hncr'); subst R'.
exists R.
simpsub.
do2 3 split; auto.
Qed.

(* This almost follows from sound_fut_eta_hyp, but not quite. *)
Lemma sound_fut_eta :
  forall G m a,
    pseq G (deq m m (fut a))
    -> pseq G (deq m (next (prev m)) (fut a)).
Proof.
intros G m a.
revert G.
refine (seq_pseq 1 [] m 1 [] _ _ _); cbn.
intros G Hclm Hseq.
rewrite -> seq_deq in Hseq |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
so (Hseq i s s' Hs) as (R & Hfutl & Hfutr & Hm & _).
exists R.
do2 3 split; auto.
simpsubin Hfutl.
simpsubin Hfutr.
simpsub.
destruct i as [| i].
  {
  invert (basic_value_inv _#6 value_fut Hfutl).
  intros _ <-.
  rewrite -> den_iufut0 in Hm |- *.
  split.
    {
    apply fut_action_next_zero; prove_hygiene.
    }

    {
    destruct Hm as (n & _ & _ & _ & _ & Hsteps & _).
    refine (urel_equiv_1 _#6 _ (equiv_symm _#3 (steps_equiv _#3 Hsteps)) _).
      {
      prove_hygiene.
      }
    so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hsteps (subst_closub _#4 Hcls Hclm))) as H; cbn in H.
    destruct H.
    apply fut_action_next_zero; prove_hygiene.
    }
  }
invert (basic_value_inv _#6 value_fut Hfutl).
intros A Hal Heq1.
invert (basic_value_inv _#6 value_fut Hfutr).
intros A' Har Heq2.
so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
clear Heq2.
subst R.
so (iufut_inj _#5 Heq); subst A'.
cbn in Hm.
split.
  {
  apply fut_action_next; auto.
  eapply fut_action_prev; eauto.
  }

  {
  destruct Hm as (n & n' & _ & _ & _ & Hsteps & Hsteps' & Hn).
  refine (urel_equiv_1 _#6 _ (equiv_symm _#3 (steps_equiv _#3 Hsteps)) _).
    {
    prove_hygiene.
    }
  apply fut_action_next; auto.
  apply (urel_equiv_2 _#4 n').
    {
    prove_hygiene.
    }

    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply equiv_prev.
      eapply steps_equiv; eauto.
      }
    apply steps_equiv.
    apply star_one; apply step_prev2.
    }
  apply Hn.
  omega.
  }
Qed.

Lemma sound_fut_eta_hyp_pre :
  forall G1 G2 a m n b,
    hygiene (ctxpred G1) a
    -> hygiene (ctxpred (G2 ++ hyp_tm (fut a) :: G1)) b
    -> seq (promote G1) (deqtype a a)
    -> seq (substctx (dot (next (var 0)) sh1) G2 ++ cons (hyp_tml a) G1) (deq m n (subst (under (length G2) (dot (next (var 0)) sh1)) b))
    -> seq (G2 ++ cons (hyp_tm (fut a)) G1) (deq (subst (under (length G2) (dot (prev (var 0)) sh1)) m) (subst (under (length G2) (dot (prev (var 0)) sh1)) n) b).
Proof.
intros G1 G2 a m n b Hcla Hclb Hseqa Hseq.
rewrite -> seq_eqtype in Hseqa.
eapply subsume_seq_extract; eauto; clear Hseq.
apply subsume_under.
do2 2 split.
  {
  intros j.
  rewrite -> !ctxpred_length.
  cbn [length].
  destruct j as [| j].
    {
    simpsub.
    split; try omega.
    intros _.
    apply hygiene_auto; cbn.
    split; auto.
    apply hygiene_var.
    omega.
    }

    {
    simpsub.
    split.
      {
      intros H.
      apply hygiene_var.
      omega.
      }

      {
      intros H.
      invertc H.
      intro; omega.
      }
    }
  }

  {
  intros j.
  rewrite -> !ctxpred_length.
  cbn [length].
  destruct j as [| j].
    {
    simpsub.
    split; try omega.
    intros _.
    apply hygiene_auto; cbn.
    split; auto.
    apply hygiene_var.
    omega.
    }

    {
    simpsub.
    split.
      {
      intros H.
      apply hygiene_var.
      omega.
      }

      {
      intros H.
      invertc H.
      intro; omega.
      }
    }
  }
intros i ss ss' Hss.
invertc Hss.
intros p q s s' Hs Hpq Hleft Hright <- <-.
simpsubin Hpq.
so (seqhyp_impl_closed _#5 Hpq) as (Hclp & Hclq).
assert (exists p' q' A,
          star step p (next p')
          /\ star step q (next q')
          /\ (i > 0
              -> interp toppg true (pred i) (subst s a) A
                 /\ interp toppg false (pred i) (subst s' a) A
                 /\ rel (den A) (pred i) p' q')) as H.
  {
  invertc Hpq.
  intros R Hfutl Hfutr Hpq.
  invert (basic_value_inv _#6 value_fut Hfutl).
    {
    intros _ <- <-.
    cbn in Hpq.
    decompose Hpq.
    intros p' q' _ _ _ Hp' Hq' _.
    exists p', q', (iubase empty_urel).
    do2 2 split; auto.
    omega.
    }

    {
    intros i' A Hal <- Heq1.
    invert (basic_value_inv _#6 value_fut Hfutr).
    intros A' Har Heq2.
    so (eqtrans Heq1 (eqsymm Heq2)) as Heq; clear Heq2.
    subst R.
    so (iufut_inj _#5 Heq); subst A'.
    cbn in Hpq.
    decompose Hpq.
    intros p' q' _ _ _ Hp' Hq' Hpq'.
    exists p', q', A.
    do2 2 split; auto.
    }
  }
destruct H as (p' & q' & A & Hstepsp & Hstepsq & Hif).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepsp Hclp)) as H; cbn in H.
destruct H as (Hclp' & _).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepsq Hclq)) as H; cbn in H.
destruct H as (Hclq' & _).
do2 4 split.
  {
  simpsub.
  apply pwctx_cons_tml_seq; auto; try prove_hygiene.
    {
    intros Hpos.
    so (Hif Hpos) as (Hal & Har & Hpq').
    apply (seqhyp_tm _#5 A); auto.
    eapply urel_equiv; eauto; try prove_hygiene.
      {
      apply equiv_symm.
      apply steps_equiv.
      eapply star_trans.
        {
        apply (star_map' _ _ prev); auto using step_prev1.
        exact Hstepsp.
        }
      apply star_one; apply step_prev2.
      }

      {
      apply equiv_symm.
      apply steps_equiv.
      eapply star_trans.
        {
        apply (star_map' _ _ prev); auto using step_prev1.
        exact Hstepsq.
        }
      apply star_one; apply step_prev2.
      }
    }

    {
    intros j t t' Ht.
    so (Hseqa _#3 Ht) as (R & Hl & Hr & _).
    eauto.
    }
  }

  {
  simpsub.
  apply equivsub_dot; auto using equivsub_refl.
  apply (equiv_trans _ _ (next p')).
    {
    apply equiv_next.
    apply steps_equiv.
    eapply star_trans.
      {
      apply (star_map' _ _ prev); auto using step_prev1.
      exact Hstepsp.
      }
    apply star_one.
    apply step_prev2.
    }

    {
    apply equiv_symm.
    apply steps_equiv; auto.
    }
  }

  {
  simpsub.
  apply equivsub_dot; auto using equivsub_refl.
  apply (equiv_trans _ _ (next q')).
    {
    apply equiv_next.
    apply steps_equiv.
    eapply star_trans.
      {
      apply (star_map' _ _ prev); auto using step_prev1.
      exact Hstepsq.
      }
    apply star_one.
    apply step_prev2.
    }

    {
    apply equiv_symm.
    apply steps_equiv; auto.
    }
  }

  {
  intros j d uu Hj Huu.
  simpsub.
  simpsubin Huu.
  rewrite -> qpromote_cons in Huu |- *.
  rewrite -> qpromote_hyp_tm.
  invertc Huu.
  intros r u Hu Hr <-.
  simpsub.
  apply seqctx_cons; auto.
  simpsub.
  destruct j as [| j].
    {
    so (seqctx_impl_closub _#4 Hu) as (Hcls & Hclu).
    so (seqhyp_impl_closed _#5 Hr) as (_ & Hclr).
    rewrite -> ctxpred_qpromote in Hcls, Hclu.
    apply (seqhyp_tm _#5 (iufut0 stop)).
      {
      apply interp_eval_refl.
      apply interp_fut_zero; prove_hygiene.
      }

      {
      apply interp_eval_refl.
      apply interp_fut_zero; prove_hygiene.
      }

      {
      apply (urel_equiv_1 _#3 (next p')); try prove_hygiene.
        {
        apply equiv_symm; apply steps_equiv; eauto.
        }
      apply fut_action_next_zero; auto; prove_hygiene.
      }
    }
  rewrite -> !substh_qpromote_hyp in Hr.
  so (seqhyp_demote_maybe _#7 Hr) as H.
  simpsubin H.
  invertc H.
  intros A' Hal Hau Hr' _ _ _ _.
  apply (seqhyp_tm _#5 (iufut stop (S j) A')).
    {
    apply interp_eval_refl.
    apply interp_fut.
    apply Hal.
    omega.
    }

    {
    apply interp_eval_refl.
    apply interp_fut.
    apply Hau.
    omega.
    }

    {
    apply (urel_equiv_1 _#3 (next p')); try prove_hygiene.
      {
      apply equiv_symm; apply steps_equiv; eauto.
      }
    apply fut_action_next; auto.
    apply (urel_equiv_1 _#3 (prev p)); try prove_hygiene.
      {
      apply steps_equiv.
      eapply star_trans.
        {
        apply (star_map' _ _ prev); auto using step_prev1.
        exact Hstepsp.
        }
      apply star_one; apply step_prev2.
      }

      {
      apply Hr'.
      omega.
      }
    }
  }

  {
  intros j d uu Hj Huu.
  simpsub.
  simpsubin Huu.
  rewrite -> qpromote_cons in Huu |- *.
  rewrite -> qpromote_hyp_tm.
  invertc Huu.
  intros r u Hu Hr <-.
  simpsub.
  apply seqctx_cons; auto.
  simpsub.
  destruct j as [| j].
    {
    so (seqctx_impl_closub _#4 Hu) as (Hclu & Hcls').
    so (seqhyp_impl_closed _#5 Hr) as (Hclr & _).
    rewrite -> ctxpred_qpromote in Hcls', Hclu.
    apply (seqhyp_tm _#5 (iufut0 stop)).
      {
      apply interp_eval_refl.
      apply interp_fut_zero; prove_hygiene.
      }

      {
      apply interp_eval_refl.
      apply interp_fut_zero; prove_hygiene.
      }

      {
      apply (urel_equiv_2 _#4 (next q')); try prove_hygiene.
        {
        apply equiv_symm; apply steps_equiv; eauto.
        }
      apply fut_action_next_zero; auto; prove_hygiene.
      }
    }
  rewrite -> !substh_qpromote_hyp in Hr.
  so (seqhyp_demote_maybe _#7 Hr) as H.
  simpsubin H.
  invertc H.
  intros A' Hal Hau Hr' _ _ _ _.
  apply (seqhyp_tm _#5 (iufut stop (S j) A')).
    {
    apply interp_eval_refl.
    apply interp_fut.
    apply Hal.
    omega.
    }

    {
    apply interp_eval_refl.
    apply interp_fut.
    apply Hau.
    omega.
    }

    {
    apply (urel_equiv_2 _#4 (next q')); try prove_hygiene.
      {
      apply equiv_symm; apply steps_equiv; eauto.
      }
    apply fut_action_next; auto.
    apply (urel_equiv_2 _#4 (prev q)); try prove_hygiene.
      {
      apply steps_equiv.
      eapply star_trans.
        {
        apply (star_map' _ _ prev); auto using step_prev1.
        exact Hstepsq.
        }
      apply star_one; apply step_prev2.
      }

      {
      apply Hr'.
      omega.
      }
    }
  }
Qed.

Lemma sound_fut_eta_hyp :
  forall G1 G2 a m n b,
    pseq (promote G1) (deqtype a a)
    -> pseq (substctx (dot (next (var 0)) sh1) G2 ++ cons (hyp_tml a) G1) (deq m n (subst (under (length G2) (dot (next (var 0)) sh1)) b))
    -> pseq (G2 ++ cons (hyp_tm (fut a)) G1) (deq (subst (under (length G2) (dot (prev (var 0)) sh1)) m) (subst (under (length G2) (dot (prev (var 0)) sh1)) n) b).
Proof.
intros G1 G2 a m n b (i1, Hseqa) (i2, Hseq).
so (shut_term _ G1 a) as (i3 & Hcla).
so (shut_term _ (G2 ++ hyp_tm (fut a) :: G1) b) as (i4 & Hclb).
so (upper_bound_all 4 i1 i2 i3 i4) as (i & Hi1 & Hi2 & Hi3 & Hi4 & _).
exists i; intros j Hj.
autorewrite with canonlist.
eapply sound_fut_eta_hyp_pre; try (finish_pseq j).
rewrite -> promote_append.
rewrite -> promote_shut.
apply Hseqa; eauto using le_trans.
Qed.

Lemma sound_fut_ext :
  forall G a b c m n,
    pseq G (deq m m (fut b))
    -> pseq G (deq n n (fut c))
    -> pseq G (deq (next (prev m)) (next (prev n)) (fut a))
    -> pseq G (deq m n (fut a)).
Proof.
intros G a b c m n.
revert G.
refine (seq_pseq 0 3 [] _ [] _ [] _ _ _).
cbn.
intros G Hseqm Hseqn Hseq.
rewrite -> seq_deq in Hseqm, Hseqn, Hseq |- *.
intros i s s' Hs.
assert (exists m1 m2,
          hygiene clo (subst s m)
          /\ hygiene clo (subst s' m)
          /\ star step (subst s m) (next m1)
          /\ star step (subst s' m) (next m2)) as (m1 & m2 & Hclm & Hclm' & Hstepm1 & Hstepm2).
  {
  so (Hseqm _ _ _ Hs) as (R & Hl & _ & Hm & _).
  simpsubin Hl.
  invert (basic_value_inv _#6 value_fut Hl).
    {
    intros _ <- <-.
    rewrite -> den_iufut0 in Hm.
    destruct Hm as (m1 & m2 & _ & Hcl & Hcl' & Hstep & Hstep' & _).
    exists m1, m2.
    auto.
    }
  intros i' A _ <- <-.
  rewrite -> den_iufut in Hm.
  destruct Hm as (m1 & m2 & _ & Hcl & Hcl' & Hstep & Hstep' & _).
  exists m1, m2.
  auto.
  }
assert (exists n1 n2,
          hygiene clo (subst s n)
          /\ hygiene clo (subst s' n)
          /\ star step (subst s n) (next n1)
          /\ star step (subst s' n) (next n2)) as (n1 & n2 & Hcln & Hcln' & Hstepn1 & Hstepn2).
  {
  so (Hseqn _ _ _ Hs) as (R & Hl & _ & Hn & _).
  simpsubin Hl.
  invert (basic_value_inv _#6 value_fut Hl).
    {
    intros _ <- <-.
    rewrite -> den_iufut0 in Hn.
    destruct Hn as (n1 & n2 & _ & Hcl & Hcl' & Hstep & Hstep' & _).
    exists n1, n2.
    auto.
    }
  intros i' A _ <- <-.
  rewrite -> den_iufut in Hn.
  destruct Hn as (n1 & n2 & _ & Hcl & Hcl' & Hstep & Hstep' & _).
  exists n1, n2.
  auto.
  }
clear Hseqm Hseqn.
so (Hseq _ _ _ Hs) as (R & Hl & Hr & Hm & Hn & Hmn).
exists R.
do2 2 split; auto.
simpsubin Hl.
simpsubin Hr.
simpsubin Hm.
simpsubin Hn.
simpsubin Hmn.
destruct i as [| i].
  {
  invert (basic_value_inv _#6 value_fut Hl).
  intros _ <-.
  rewrite -> !den_iufut0.
  do2 2 split.
    {
    exists m1, m2.
    do2 5 split; auto.
    intros H.
    omega.
    }

    {
    exists n1, n2.
    do2 5 split; auto.
    intros H.
    omega.
    }

    {
    exists m1, n2.
    do2 5 split; auto.
    intros H.
    omega.
    }
  }
invert (basic_value_inv _#6 value_fut Hl).
intros A Hal <-.
rewrite -> !den_iufut in Hm, Hn, Hmn |- *.
destruct Hm as (m1' & m2' & _ & _ & _ & Hstep1 & Hstep2 & H).
so (determinism_normal_value _#3 value_next Hstep1) as Heq.
injection Heq.
intros <-.
so (H (Nat.lt_0_succ _)) as Hm.
clear Heq Hstep1 H.
so (determinism_normal_value _#3 value_next Hstep2) as Heq.
injection Heq.
intros <-.
clear Heq Hstep2.
cbn in Hm.
destruct Hn as (n1' & n2' & _ & _ & _ & Hstep1 & Hstep2 & H).
so (determinism_normal_value _#3 value_next Hstep1) as Heq.
injection Heq.
intros <-.
so (H (Nat.lt_0_succ _)) as Hn.
clear Heq Hstep1 H.
so (determinism_normal_value _#3 value_next Hstep2) as Heq.
injection Heq.
intros <-.
clear Heq Hstep2.
cbn in Hn.
destruct Hmn as (m1' & n2' & _ & _ & _ & Hstep1 & Hstep2 & H).
so (determinism_normal_value _#3 value_next Hstep1) as Heq.
injection Heq.
intros <-.
so (H (Nat.lt_0_succ _)) as Hmn.
clear Heq Hstep1 H.
so (determinism_normal_value _#3 value_next Hstep2) as Heq.
injection Heq.
intros <-.
clear Heq Hstep2.
cbn in Hmn.
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepm1 Hclm)) as H.
cbn in H.
destruct H as (Hclm1 & _).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepm2 Hclm')) as H.
cbn in H.
destruct H as (Hclm2 & _).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepn1 Hcln)) as H.
cbn in H.
destruct H as (Hcln1 & _).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepn2 Hcln')) as H.
cbn in H.
destruct H as (Hcln2 & _).
assert (equiv (prev (subst s m)) m1) as Hequivm1.
  {
  apply steps_equiv.
  eapply star_trans.
    {
    apply star_map'; eauto using step_prev1 with dynamic.
    }
  apply star_one.
  apply step_prev2.
  }
assert (equiv (prev (subst s' m)) m2) as Hequivm2.
  {
  apply steps_equiv.
  eapply star_trans.
    {
    apply star_map'; eauto using step_prev1 with dynamic.
    }
  apply star_one.
  apply step_prev2.
  }
assert (equiv (prev (subst s n)) n1) as Hequivn1.
  {
  apply steps_equiv.
  eapply star_trans.
    {
    apply star_map'; eauto using step_prev1 with dynamic.
    }
  apply star_one.
  apply step_prev2.
  }
assert (equiv (prev (subst s' n)) n2) as Hequivn2.
  {
  apply steps_equiv.
  eapply star_trans.
    {
    apply star_map'; eauto using step_prev1 with dynamic.
    }
  apply star_one.
  apply step_prev2.
  }
do2 2 split.
  {
  exists m1, m2.
  do2 5 split; auto.
  intros _.
  cbn.
  eapply urel_equiv; eauto.
  }

  {
  exists n1, n2.
  do2 5 split; auto.
  intros _.
  cbn.
  eapply urel_equiv; eauto.
  }

  {
  exists m1, n2.
  do2 5 split; auto.
  intros _.
  cbn.
  eapply urel_equiv; eauto.
  }
Qed.


(** * Induction: Demostracion por Induccion *)

(** La siguiente linea importa todas nuestras definiciones del
    capitulo anterior. *)

Require Export Basics.

(** Para que funcione, necesita usar [coqc] para compilar [Basics.v]
    en [Basics.vo] (Esto es como hacer un archivo .class de un archivo
    .java, o un archivo .o de un .c).

    Aqui presentamos dos formas de compilar el codigo:

     - CoqIDE:

         Abrir [Basics.v].
         En el menu "Compile", click en "Compile Buffer".

     - Linea de comandos:

         Ejecute [coqc Basics.v]

    *)

(* ###################################################################### *)
(** * Nombrando Casos *)

(** El hecho de que no hay un comando explicito para moverse de una
    rama de un analisis por caso al siguiente puede hacer los scripts
    de prueba dificiles de leer.  En pruebas grandes, con casos
    anidados, uno se puede desorientar facilmente cuando se esta
    frente a Coq llendo paso a paso en una prueba.  (Imaginese
    tratando de acordarse que los primeros cinco sub-casos pertenecen
    a la primer rama del analisis por caso principal, y los siete
    siguientes pertenencen al segundo...)  Un uso disciplinado de
    identacion y comentarios puede ayudar, pero una forma mejor es
    usar la tactica [Case]. *)

(* [Case] no viene por default in Coq: tenemos que definirla nosotros
    mismos.  No hay necesidad de entender como funciona -- puede
    simplemente saltear la definicion e ir derecho al ejemplo que
    sigue.  Usa ciertas herramientas de Coq que todavia no hemos
    discutido -- la libreria de strings y el comando [Ltac], que nos
    permite declarar tacticas propias.  Kudos a Aaron Bohannon por
    este lindo hack! *)

Require String. Open Scope string_scope.

Ltac move_to_top x :=
  match reverse goal with
  | H : _ |- _ => try move x after H
  end.

Tactic Notation "assert_eq" ident(x) constr(v) :=
  let H := fresh in
  assert (x = v) as H by reflexivity;
  clear H.

Tactic Notation "Case_aux" ident(x) constr(name) :=
  first [
    set (x := name); move_to_top x
  | assert_eq x name; move_to_top x
  | fail 1 "because we are working on a different case" ].

Tactic Notation "Case" constr(name) := Case_aux Case name.
Tactic Notation "SCase" constr(name) := Case_aux SCase name.
Tactic Notation "SSCase" constr(name) := Case_aux SSCase name.
Tactic Notation "SSSCase" constr(name) := Case_aux SSSCase name.
Tactic Notation "SSSSCase" constr(name) := Case_aux SSSSCase name.
Tactic Notation "SSSSSCase" constr(name) := Case_aux SSSSSCase name.
Tactic Notation "SSSSSSCase" constr(name) := Case_aux SSSSSSCase name.
Tactic Notation "SSSSSSSCase" constr(name) := Case_aux SSSSSSSCase name.

(** Aqui hay un ejemplo de como [Case] se usa.  Vaya paso a paso en la
   prueba y observe como el contexto cambia. *)

Theorem andb_true_elim1 : forall b c : bool,
  andb b c = true -> b = true.
Proof.
  intros b c H.
  destruct b.
  Case "b = true".  (* <----- aqui *)
    reflexivity.
  Case "b = false".  (* <---- y aqui *)
    rewrite <- H.
    reflexivity.
Qed.

(** [Case] hace algo muy simple: Simplemente agrega el string que le
    pasemos ("tageado" con el identificador "Case") al contexto del
    objetivo actual.  Cuando se generan sub-objetivos, este string es
    copiado en sus contextos.  Cuando el ultimo de los sub-objetivos
    es finalmente demostrado y el siguiente ojetivo de nivel superior
    se activa, este string no va a aparecer mas en el contexto, y
    podremos determinar que hemos terminado con el caso.  Tambien,
    como "sanity check" (checkeo de sanidad?), si intentamos ejecutar
    un nuevo [Case] mientras estamos resolviendo uno, vamos a obtener
    un mensaje claro de error.

    Para casos anidados (e.g., para cuando utilizamos [destruct] en el
    caso creado por otro [destruct]), hay una tactica [SCase] (por
    "sub-caso"). *)

(** **** Ejercicio: 2 stars (andb_true_elim2) *)
(** Demuestre [andb_true_elim2], marcando casos (y sub-casos) cuando
    utilice [destruct]. *)

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** No hay reglas estrictas y definidas de como una demostracion puede
    ser estructurada en Coq -- en particular, donde se deben quebrar
    las lineas y como las distintas secciones de una demostracion
    deben ser identadas.  Sin embargo, si se marca explicitamente con
    [Case] los lugares donde los sub-casos son generados, entonces la
    demostracion puede ser legible independientemente de otros aspectos en
    el formateo de la misma.

    Este es un buen lugar para mencionar otro "tip" (posiblemente
    obvio) acerca del ancho de las lineas.  En general, los usuarios
    principiantes de Coq tienden a ser extremistas, escribiendo o una
    tactica por linea, o pruebas enteras en una linea.  El buen
    estilo se encuentra un poco en el medio.  En particular, una
    convencion razonable es limitarse a los 80 caracteres por linea.
    Lineas mas largas que esto pueden ser dificiles de leer y pueden
    ser dificiles de imprimir.  Muchos editores tienen facilidades
    para enforzar este limite. *)

(* ###################################################################### *)
(** * Pruebas por Induccion *)

(** Hemos provado en el capitulo anterior que [0] es un elemento
    neutral para [+] a la izquierda usando un argumento simple.  El
    hecho de que tambien es neutral a la _derecha_... *)

Theorem plus_0_r_firsttry : forall n:nat,
  n + 0 = n.

(** ... no puede ser provado en la misma forma.  Aplicando simplemente
  [reflexivity] no funciona: el [n] en [n + 0] es un numero
  desconocido arbitrario, con lo que el [match] en la definicion de
  [+] no puede ser simplificado.  *)

Proof.
  intros n.
  simpl. (* No hace nada! *)
Abort.

(** Razonando por casos usando [destruct n] no nos lleva muy lejos: el
   caso [n = 0] funciona, pero en el caso [n = S n'] para algun [n']
   nos quedamos bloqueados de la misma forma.  Podemos usar [destruct
   n'] para ir un paso mas alla, pero [n] puede ser arbitrariamente
   grande, con lo que si seguimos de esta forma nunca vamos a
   terminar. *)

Theorem plus_0_r_secondtry : forall n:nat,
  n + 0 = n.
Proof.
  intros n. destruct n as [| n'].
  Case "n = 0".
    reflexivity. (* todo bien hasta aca... *)
  Case "n = S n'".
    simpl.       (* ...pero aca estamos bloqueados como antes. *)
Abort.

(** Para demostrar este tipo de teoremas -- de hecho, para demostrar
    casi cualquier teorema sobre numeros, listas, y cualquier otro
    tipo de datos definido inductivamente -- necesitamos un
    razonamiento mas elaborado: _induccion_.

    Recuerden el principio de induccion sobre numeros naturales: Si
    [P(n)] es una proposicion involucrando un numero natural [n] y
    queremos ver que P es cierto para _todo_ numero [n], podemos
    razonar de la siguiente forma:
    - mostrar que [P(O)] vale;
    - mostrar que, para cualquier [n'], si [P(n')] vale, entonces vale
    [P(S n')];
    - concluir que [P(n)] vale para todo [n].

    En Coq, estos pasos son iguales, pero el orden es inverso:
    comenzamos con el obejtivo que queremos probar [P(n)] para todo
    [n] y lo dividimos (aplicando la tactica [induction]) en dos
    sub-objetivos: primero [P(O)] luego [P(n') -> P(S n')].  Asi es
    como funciona en el problema que estuvimos trabajando hasta ahora:
    *)

Theorem plus_0_r : forall n:nat, n + 0 = n.
Proof.
  intros n. induction n as [| n'].
  Case "n = 0".     reflexivity.
  Case "n = S n'".  simpl. rewrite -> IHn'. reflexivity.  Qed.

(** Como [destruct], la tactica [induction] toma una clausula [as...]
    que especifica los nombres de las variables a ser introducidas en
    los sub-objetivos.  En la primer rama, [n] es reemplazado por [0]
    el objetivo es [0 + 0 = 0], que es cierto por simplificacion.  En el
    segundo, [n] es reemplazado por [S n'] y la hipotesis [n' + 0 =
    n'] es agregada al contexto (con el nombre [IHn'], es decir, la
    Hipotesis Inductiva para [n']).  El objetivo en este caso es [(S
    n') + 0 = S n'], que se puede simplificar a [S (n' + 0) = S n'],
    que a su cez se puede resolver usando la hipotesis inductiva. *)

Theorem minus_diag : forall n,
  minus n n = 0.
Proof.
  (* WORKED IN CLASS *)
  intros n. induction n as [| n'].
  Case "n = 0".
    simpl. reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity.  Qed.

(** **** Ejercicio: 2 stars (basic_induction) *)

(** Pruebe los siguientes teoremas usando induccion.  Tal ver requiera
    utilizar algun resultado previo. *)

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem plus_n_Sm : forall n m : nat,
  S (n + m) = n + (S m).
Proof.
  (* FILL IN HERE *) Admitted.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Ejercicio: 2 stars (double_plus) *)

(** Considere la siguiente funcion, que duplica el argumento: *)

Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

(** Use induccion para probar este simple lema sobre [double]: *)

Lemma double_plus : forall n, double n = n + n .
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Ejercicio: 1 star (destruct_induction) *)
(** Explique brevemente la diferencia entre las tacticas
    [destruct] e [induction].

(* FILL IN HERE *)

*)
(** [] *)

(* ###################################################################### *)
(** * Pruebas dentro de Pruebas *)

(** En Coq, al igual que en los razonamientos matematicos informales,
    las demostraciones largas son usualmente divididas en una
    secuencia de teoremas, con las demostraciones del final utilizando
    los teoremas demostrados anteriormente.  Ocasionalmente, sin
    embargo, una demostracion puede necesitar algun hecho (fact) que
    es trivial y de poco interes general para molestarse en darle un
    nombre propio.  En tales casos, es conveniente poder establecer y
    demostrar localmente un "sub-teorema" en el punto en que debe ser
    utilizado.  La tactica [assert] nos permite hacer esto.  Por
    ejemplo, en nuestra demostracion del teorema [mult_0_plus] nos
    referimos a otro teorema [plus_O_n].  Podemos utilizar [assert]
    para establecer [plus_O_n] "in-line": *)

Theorem mult_0_plus' : forall n m : nat,
  (0 + n) * m = n * m.
Proof.
  intros n m.
  assert (H: 0 + n = n).
    Case "Proof of assertion". reflexivity.
  rewrite -> H.
  reflexivity.  Qed.

(** La tactica [assert] introduce dos sub-objetivos.  El primero es la
    asercion en si misma; al prefijarla con [H:], le hemos dado como
    nombre [H].  (Note que tambien podemos utilizar [as] como hicimos
    con [destruct] e [induction], i.e., [assert (0 + n = n) as H].
    Tambien note que hemos marcado la prueba de esta asercion con un
    [Case], para mejorar la legibilidad de la prueba y para, mientras
    usamos Coq interactivamente, saber que hemos concluido la prueba
    de la asercion observando que el string ["Proof of assertion"]
    desaparece del contexto.)  El segundo objetivo es el mismo que el
    que teniamos antes de invocar [assert], excepto que ahora tiene
    una hipotesis llamada [H] que establece [0 + n = n].  Es decir,
    [assert] genera un sub-objetivo para demostrar la asercion, y un
    segundo sub-objetivo donde la asercion esta a nuestra mano para
    utilizar y hacer progreso en la prueba principal. *)

(** Actualmente, [assert] nos va a ser util en muchos tipos de
    situaciones.  Por ejemplo, suponga que queremos probar que [(n +
    m) + (p + q) = (m + n) + (p + q)].  La unica diferencia entre los
    dos lados del igual es que los argumentos [m] y [n] en el primer
    [+] estan intercambiados, con lo que pareceria que podemos
    utilizar la comutatividad de la suma ([plus_comm]) para reescribir
    uno en otro.  Sin embargo, la tactica [rewrite] es un poco
    estupida respecto de _donde_ aplicar la reescritura.  Hay tres usos
    de [+] aqui, y resulta que si hacemos [rewrite -> plus_comm] vamos
    a afectar el de mas _afuera_. *)

Theorem plus_rearrange_firsttry : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  (* Necesitamos intercambiar (n + m) por (m + n)...
     pareceria que plus_comm debiera funcionar! *)
  rewrite -> plus_comm.
  (* No funciona... Coq reescribio la suma incorrecta! *)
Abort.

(** Para poder aplicar [plus_comm] en el lugar que queremos, podemos
    introducir un lema local estableciendo [n + m = m + n] (para los
    [m] y [n] particulares que utilizamos en la demostracion), demostrar
    este lema utilizando [plus_comm], y usar luego este lema para reescribir
    el lugar correcto. *)

Theorem plus_rearrange : forall n m p q : nat,
  (n + m) + (p + q) = (m + n) + (p + q).
Proof.
  intros n m p q.
  assert (H: n + m = m + n).
    Case "Proof of assertion".
    rewrite -> plus_comm. reflexivity.
  rewrite -> H. reflexivity.  Qed.

(** **** Ejercicio: 4 stars (mult_comm) *)
(** Utilice [assert] para ayudar probar este teorema.  No deberia
    necesitar [induction]. *)

Theorem plus_swap : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  (* FILL IN HERE *) Admitted.

(** Ahora demuestre la conmutatividad de la multiplicacion.  (Va a
    necesitar posiblemente demostrar un teorema subsidiario para
    usarlo en este.)  Puede encontrar util [plus_swap]. *)

Theorem mult_comm : forall m n : nat,
 m * n = n * m.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Ejercicio: 2 stars, opcional (evenb_n__oddb_Sn) *)

(** Pruebe el siguiente teorema sencillo: *)

Theorem evenb_n__oddb_Sn : forall n : nat,
  evenb n = negb (evenb (S n)).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** * Mas ejercicios *)

(** **** Ejercicio: 3 stars, opcional (more_exercises) *)
(** Tome un pedazo de papel.  Por cada uno de los siguientes teoremas,
    primero _piense_ acerca de si (a) puede ser demostrado utilizando
    simplemente [rewrite], [simpl] y [reflexivity], o (b) tambien
    requiere analisis por caso ([destruct]), o (c) tambien requiere
    induccion.  Escriba su prediccion.  Entonces complete las
    demostraciones.  (No hay necesidad de entregar el papel, este
    ejercicio es para estimular el pensamiento antes de hackear!) *)

Theorem ble_nat_refl : forall n:nat,
  true = ble_nat n n.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem zero_nbeq_S : forall n:nat,
  beq_nat 0 (S n) = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem andb_false_r : forall b : bool,
  andb b false = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem plus_ble_compat_l : forall n m p : nat,
  ble_nat n m = true -> ble_nat (p + n) (p + m) = true.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem S_nbeq_0 : forall n:nat,
  beq_nat (S n) 0 = false.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem mult_1_l : forall n:nat, 1 * n = n.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem all3_spec : forall b c : bool,
    orb
      (andb b c)
      (orb (negb b)
               (negb c))
  = true.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem mult_plus_distr_r : forall n m p : nat,
  (n + m) * p = (n * p) + (m * p).
Proof.
  (* FILL IN HERE *) Admitted.

Theorem mult_assoc : forall n m p : nat,
  n * (m * p) = (n * m) * p.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Ejercicio: 2 stars, opcional (beq_nat_refl) *)
(** Pruebe el siguiente teorema.  Poner [true] en el lado izquierdo de
    la igualdad puede verse raro, pero es asi como el teorema esta
    escrito en la libreria estandard de Coq, y nosotros copiamos en
    consecuencia.  Como se puede reescribir igualmente en cualquier
    direccion, no vamos a tener problemas usando el teorema, sin
    importar en que forma lo escribamos. *)

Theorem beq_nat_refl : forall n : nat,
  true = beq_nat n n.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Exercise: 2 stars, optional (plus_swap') *)
(** La tactica [replace] permite especificar un subtermino particular
   a reescribir, y a que se debe reescribir.  Mas precisamente,
   [replace (t) with (u)] reemplaza (todas las copias de) la expresion
   [t] en el objetivo por la expresion [u], y genera [t = u] como
   sub-objetivo adicional. Esto es util cuando [rewrite] reescribe una
   parte incorrecta del objetivo.

   Utilice la tactica [replace] para demostrar [plus_swap'], similar a
   [plus_swap] pero sin necesitar [assert (n + m = m + n)].  *)

Theorem plus_swap' : forall n m p : nat,
  n + (m + p) = m + (n + p).
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** **** Ejercicio: 3 stars (binary_commute) *)
(** Recuerde las funciones [increment] y [binary-to-unary] que
    escribio para el ejercicio [binary] en el capitulo [Basics].
    Pruebe que estas funciones conmutan -- es decir, que incrementar
    un numero binario y convertirlo a unitario es igual a convertirlo
    en unario primero y luego incrementarlo.

    (Antes de empezar a trabajar en este ejercicio, por favor copie
    sus definiciones del ejercicio [binary] aqui, para que este
    archivo pueda ser evaluado independientemente.  Si necesita
    modificar las definiciones para hacer la prueba mas facil,
    sientase libre de hacerlo). *)

(* FILL IN HERE *)
(** [] *)

(** **** Ejercicio: 5 stars, advanced (binary_inverse) *)
(** Este ejercicio es una continuacion del ejercicio anterior acerca
    numeros binarios.  Usted debe completar las definiciones y
    teoremas del ejercicio previo antes de hacer este ejercicio.

    (a) Primero, escriba una funcion para convertir numeros naturales a
        numeros binarios.  Luego, pruebe que convertir un numero
        natural a binario, y luego convertir a natural el resultado,
        resulta en el mismo numero.

    (b) Tal vez usted considere que tambien podemos probar lo
        contrario, es decir, que convertir un numero binario en natural
        y viceversa resulta en el mismo numero natural.  Sin embargo,
        no es asi!  Explique por que.

    (c) Defina una funcion [normalize] de numeros binarios a numeros
        binarios tal que para cada numero binario b, convertir b a
        numero natural y viceversa resulta en [(normalize b)].  Demuestrelo.

    Como antes, sientase en la libertad de cambiar las definiciones si
    asi lo desea.  *)

(* FILL IN HERE *)
(** [] *)

(* ###################################################################### *)
(** * Material Avanzado *)

(** ** Prueba Formal vs. Informal *)

(** "Pruebas informales son algoritmos; pruebas formales son codigo." *)

(** La pregunta de que exactamente constituye una "prueba" de un
    teorema matematico a intrigado a filosofos por milenios.  Una
    definicion burda y rapida puede ser: una prueba de una proposicion
    matematica [P] es un texto escrito (o dicho) que infunde en el
    lector (o receptor) la certeza de que [P] es verdad.  Es decir,
    una prueba es un acto de comunicacion.

    Ahora, la comunicacion en general puede incluir tipos diferentes
    de lectores.  En una mano, el "lector" puede ser un programa como
    Coq, en cuyo caso la "creencia" que es inculcada es un checkeo
    mecanico de que [P] puede ser derivado de un conjunto de reglas
    logicas, y la prueba es una receta que guia al programa para
    realizar este checkeo.  Estas recetas son pruebas _formales_.

    Alternativamente, el lector puede ser un ser humano, en cuyo caso
    la prueba puede ser escrita en espaniol o cualquier otro lenguaje
    natural, necesariamente _informal_.  Aqui, el criterio para el
    exito esta especificado de forma mas difusa.  Una "buena" prueba
    es una que convence al lector de que [P] vale.  Pero la misma
    prueba puede ser leida por muchos lectores diferentes, en los que
    algunos pueden convencerse de cierto argumento, mientras que otros
    pueden ponerlo en duda.  Un lector puede ser particularmente
    pedante, inexperto, o simplemente lento; la unica forma de
    convencerlo va a ser haciendo el argumento extremadamente
    puntillosamente.  Pero otro lector, conocedor del area, puede
    encontrar estos detalles tan apabullantes, que le hacen perder el
    argumento principal.  Lo unico que necesita es que le digan las
    ideas principales, porque es mas facil llenar los detalles por si
    mismo.  De ultima, no hay un estandard universal, porque no hay una
    sola forma de escribir una prueba informal de forma tal que
    convenza a todos los lectores.  En practica, sin embargo, los
    matematicos han desarrollado una serie de convenciones y modismos
    para escribir acerca de objetos matematicos complejos que, para
    cierta comunidad, hace la comunicacion decentemente fiable.  Las
    convenciones utilizadas en esta forma estilizadad de comunicacion
    da paso a estandardes claros para juzgar una prueba buena o mala.

    Como estamos usando Coq en este curso, vamos a trabajar
    fuertemente con pruebas formales.  Pero eso no significa que
    podemos ignorar las pruebas informales!  Las pruebas formales son
    utiles en muchos sentidos, pero no son muy eficientes como
    mechanismo para comunicar ideas entre humanos. *)

(** Por ejemplo, aqui hay un ejemplo de que la suma de los naturales
    es asociativa: *)

Theorem plus_assoc' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof. intros n m p. induction n as [| n']. reflexivity.
  simpl. rewrite -> IHn'. reflexivity.  Qed.

(** Coq esta perfectamente feliz con esta prueba.  Para un humano, sin
    embargo, es dificil entender que esta pasando.  Si el lector esta
    acostumbrado a Coq, puede ir paso por paso en su cabeza,
    imaginando cual es el estado del contexto y el objetivo en cada
    paso, pero si la prueba fuera ligeramente mas complicada, esto
    seria completamente imposible.  En cambio, un matematico
    escribiria algo asi: *)

(** - _Teorema_: Para cada [n], [m] y [p],
      n + (m + p) = (n + m) + p.
    _Prueba_: Por induccion en [n].

    - Primero, suponga [n = 0].  Debemos mostrar
        0 + (m + p) = (0 + m) + p.
      Esto se desprende de la definicion de [+].

    - Siguiente, suponga [n = S n'], donde
        n' + (m + p) = (n' + m) + p.
      Debemos mostrar
        (S n') + (m + p) = ((S n') + m) + p.
      Por definicion de [+], esto es equivalente a
        S (n' + (m + p)) = S ((n' + m) + p),
      que es inmediato por la hipotesis inductiva. [] *)

(** El aspecto general de la prueba es basicamente similar.  Y esto no
    es pura casualidad: Coq ha sido diseniado de forma que la tactica
    [induction] genera los mismos sub-objetivos, en el mismo orden,
    que las vinietas que un matematico/a podria escribir.  Pero las
    pruebas difieren en los detalles: la prueba formal es mucho mas
    explicita en algunos aspectos (ej., el uso de [reflexivity]) pero
    mucho menos explicita en otros (en particular, el "estado de la
    prueba" en cada paso en la prueba en Coq es implicita, mientras
    que en la prueba informal se le recuerda al lector varias veces
    sobre el punto en el que se esta). *)

(** Aca hay una prueba formal con una estructura mas clara: *)

Theorem plus_assoc'' : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n'].
  Case "n = 0".
    reflexivity.
  Case "n = S n'".
    simpl. rewrite -> IHn'. reflexivity.   Qed.

(** **** Ejercicio: 2 stars, advanced (plus_comm_informal) *)
(** Traduzca su prueba de [plus_comm] en una prueba informal. *)

(** Teorema: La adicion es conmutativa.

    Prueba: (* FILL IN HERE *)
[]
*)

(** **** Ejercicio: 2 stars, opcional (beq_nat_refl_informal) *)
(** Escriba una prueba informal del siguiente teorema, usando la
    prueba informal de [plus_assoc] como modelo.  No se restringa a
    parafrasear las tacticas de Coq en espaniol!

    Teorema: [true = beq_nat n n] para cada [n].

    Prueba: (* FILL IN HERE *)
[]
 *)

(* $Date: 2013-07-17 16:19:11 -0400 (Wed, 17 Jul 2013) $ *)


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
(** Sharpened ADT for an expression grammar with parentheses *)
Require Import Coq.Init.Wf Coq.Arith.Wf_nat.
Require Import Coq.ZArith.ZArith.
Require Import Coq.Lists.List Coq.Strings.String.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Fiat.Parsers.ContextFreeGrammar.Core.
Require Import Fiat.Parsers.ContextFreeGrammar.PreNotations.
Require Import Fiat.Parsers.ContextFreeGrammar.Equality.
Require Import Coq.Program.Equality.
Require Import Coq.MSets.MSetPositive.
Require Import Fiat.Common.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.Wf.
Require Import Fiat.Common.Enumerable.
Require Import Fiat.Common.LogicFacts.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.Splitters.BruteForce.
Require Import Fiat.Parsers.ParserInterface.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.CorrectnessBaseTypes.
Require Import Fiat.Parsers.BooleanRecognizerFull.
Require Import Fiat.Parsers.BooleanRecognizerCorrect.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.StringLike.ForallChars.
Require Import Fiat.Parsers.StringLike.FirstChar.
Require Import Fiat.Parsers.StringLike.FirstCharSuchThat.
Require Import Fiat.Parsers.StringLike.LastChar.
Require Import Fiat.Parsers.StringLike.LastCharSuchThat.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.MinimalParseOfParse.
Require Import Fiat.Parsers.ContextFreeGrammar.Properties.
Require Import Fiat.Parsers.ContextFreeGrammar.Fold.
Require Import Fiat.Parsers.BaseTypesLemmas.
Require Import Fiat.Parsers.ContextFreeGrammar.Valid.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidProperties.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidReflective.
Require Import Fiat.Parsers.Refinement.DisjointLemmasEarlyDeclarations.
Require Import Fiat.Parsers.Refinement.PossibleTerminalsSets.
Require Import Fiat.Common.BoolFacts.
Require Fiat.Parsers.Reachable.All.MinimalReachable.
Require Fiat.Parsers.Reachable.All.MinimalReachableOfReachable.
Require Fiat.Parsers.Reachable.All.ReachableParse.
Require Fiat.Parsers.Reachable.OnlyFirst.MinimalReachable.
Require Fiat.Parsers.Reachable.OnlyFirst.MinimalReachableOfReachable.
Require Fiat.Parsers.Reachable.OnlyFirst.ReachableParse.
Require Fiat.Parsers.Reachable.OnlyLast.MinimalReachable.
Require Fiat.Parsers.Reachable.OnlyLast.MinimalReachableOfReachable.
Require Fiat.Parsers.Reachable.OnlyLast.ReachableParse.
Require Fiat.Parsers.Reachable.MaybeEmpty.Core.
Require Fiat.Parsers.Reachable.MaybeEmpty.MinimalOfCore.
Require Fiat.Parsers.Reachable.MaybeEmpty.OfParse.

Set Implicit Arguments.

Local Open Scope string_like_scope.

Local Arguments string_beq : simpl never.

Section search_forward.
  Context {G : pregrammar' Ascii.ascii}
          {HSLM : StringLikeMin Ascii.ascii}
          {HSL : StringLike Ascii.ascii}
          {HSI : StringIso Ascii.ascii}
          {HSLP : StringLikeProperties Ascii.ascii}
          {HSIP : StringIsoProperties Ascii.ascii}
          (pdata : possible_data G).

  Local Notation possible_terminals_of nt
    := (@all_possible_ascii_of_nt G pdata nt).
  Local Notation possible_first_terminals_of_production its
    := (@possible_first_ascii_of_production G pdata its).
  Local Notation might_be_empty_of_production its
    := (@might_be_empty_of_pr_production G pdata its).

  Lemma terminals_disjoint_search_for_not'
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq
                               (possible_terminals_of nt)
                               (possible_first_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
  : forall_chars__char_in (take n str) (possible_terminals_of nt)
    /\ ((length str <= n /\ might_be_empty_of_production its)
        \/ (for_first_char
              (drop n str)
              (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of nt)))
            /\ n < length str)).
  Proof.
    destruct H_reachable as [ nt' [ prefix [ HinV HinL ] ] ].
    pose proof HinV as HinV';
      rewrite <- (@initial_nonterminals_correct _ G (@rdp_list_predata _ G) (@rdp_list_rdata' _ G)) in HinV'.
    apply and_comm; split.
    { destruct (Compare_dec.le_dec (length str) n); [ left | right ].
      { split; trivial.
        pose proof (drop_length str n) as H.
        rewrite (proj2 (Nat.sub_0_le (length str) n)) in H by assumption.
        generalize dependent (drop n str); clear -pit HinV' HinL HSLP HSIP.
        intros.
        eapply might_be_empty_pr_parse_of_production; eassumption. }
      { split; try omega; [].
        eapply first_char_in__impl__for_first_char;
          [
          | apply possible_first_ascii_parse_of_production; eassumption ].
        intros ch H'.
        apply Bool.negb_true_iff, Bool.not_true_iff_false.
        intro H''.
        apply list_in_bl in H''; [ | apply (@ascii_bl) ].
        eapply fold_right_andb_map_in in H_disjoint; [ | eassumption ].
        apply Bool.negb_true_iff, Bool.not_true_iff_false in H_disjoint.
        apply H_disjoint.
        apply list_in_lb; [ apply (@ascii_lb) | assumption ]. } }
    { apply (all_possible_ascii_of_item_nt pit). }
  Qed.

  Lemma terminals_disjoint_search_for_not
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_terminals_of nt) (possible_first_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : is_first_char_such_that
        (might_be_empty_of_production its)
        str
        n
        (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of nt))).
  Proof.
    pose proof (terminals_disjoint_search_for_not' _ H_disjoint pit pits H_reachable) as H.
    split;
      [ destruct H as [H0 H1]
      | destruct H as [H0 [[H1 H2] | H1]]; solve [ left; eauto | right; eauto ] ].
    revert H0.
    apply forall_chars__char_in__impl__forall_chars.
    intros ch H' H''.
    apply Bool.negb_true_iff, Bool.not_true_iff_false in H''.
    apply H''.
    apply list_in_lb; [ apply (@ascii_lb) | ]; assumption.
  Qed.

  Lemma terminals_disjoint_search_for'
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_terminals_of nt) (possible_first_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : forall_chars (take n str)
                   (fun ch => negb (list_bin ascii_beq ch (possible_first_terminals_of_production its)))
      /\ ((length str <= n /\ might_be_empty_of_production its)
          \/ (first_char_in
                (drop n str)
                (possible_first_terminals_of_production its)
              /\ n < length str)).
  Proof.
    destruct H_reachable as [ nt' [ prefix [ HinV HinL ] ] ].
    pose proof HinV as HinV';
      rewrite <- (@initial_nonterminals_correct _ G (@rdp_list_predata _ G) (@rdp_list_rdata' _ G)) in HinV'.
    apply and_comm; split.
    { destruct (Compare_dec.le_dec (length str) n); [ left | right ].
      { split; trivial.
        pose proof (drop_length str n) as H.
        rewrite (proj2 (Nat.sub_0_le (length str) n)) in H by assumption.
        generalize dependent (drop n str); clear -pit HinV' HinL HSLP HSIP.
        intros.
        eapply might_be_empty_pr_parse_of_production; eassumption. }
      { split; try omega; try assumption.
        apply possible_first_ascii_parse_of_production; assumption. } }
    { eapply forall_chars__char_in__impl__forall_chars.
      { intros ch H'.
        apply Bool.negb_true_iff, Bool.not_true_iff_false.
        intro H''.
        apply list_in_bl in H''; [ | apply (@ascii_bl) ].
        eapply fold_right_andb_map_in in H_disjoint; [ | eassumption ].
        apply Bool.negb_true_iff, Bool.not_true_iff_false in H_disjoint.
        apply H_disjoint.
        apply list_in_lb; [ apply (@ascii_lb) | assumption ]. }
      { apply all_possible_ascii_of_item_nt; assumption. } }
  Qed.

  Lemma terminals_disjoint_search_for
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_terminals_of nt) (possible_first_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : is_first_char_such_that
        (might_be_empty_of_production its)
        str
        n
        (fun ch => list_bin ascii_beq ch (possible_first_terminals_of_production its)).
  Proof.
    pose proof (terminals_disjoint_search_for' _ H_disjoint pit pits H_reachable) as H.
    split;
      [ destruct H as [H0 H1]
      | destruct H as [H0 [[H1 H2] | [H1 ?]]]; [ right | left; split ]; eauto ].
    { revert H0.
      apply forall_chars_Proper; [ reflexivity | ].
      intros ch H' H''.
      apply Bool.negb_true_iff, Bool.not_true_iff_false in H'.
      apply H'.
      assumption. }
    { revert H1.
      apply first_char_in__impl__for_first_char.
      intros ch H'.
      apply list_in_lb; [ apply (@ascii_lb) | ]; assumption. }
  Qed.
End search_forward.

Section search_backward.
  Context {G : pregrammar' Ascii.ascii}
          {HSLM : StringLikeMin Ascii.ascii}
          {HSL : StringLike Ascii.ascii}
          {HSI : StringIso Ascii.ascii}
          {HSLP : StringLikeProperties Ascii.ascii}
          {HSIP : StringIsoProperties Ascii.ascii}
          (pdata : possible_data G).

  Local Notation possible_terminals_of_production its
    := (@all_possible_ascii_of_production G pdata its).
  Local Notation possible_last_terminals_of nt
    := (@possible_last_ascii_of_nt G pdata nt).
  Local Notation might_be_empty_of nt
    := (@might_be_empty_of_pr_nt G pdata nt).

  Lemma terminals_disjoint_rev_search_for_not'
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_last_terminals_of nt) (possible_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
  : forall_chars__char_in (drop n str) (possible_terminals_of_production its)
    /\ ((n = 0 /\ might_be_empty_of nt)
        \/ (for_last_char
              (take n str)
              (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of_production its)))
            /\ n > 0)).
  Proof.
    destruct H_reachable as [ nt' [ prefix [ HinV HinL ] ] ].
    pose proof HinV as HinV';
      rewrite <- (@initial_nonterminals_correct _ G (@rdp_list_predata _ G) (@rdp_list_rdata' _ G)) in HinV'.
    apply and_comm; split.
    { destruct (Compare_dec.zerop n); [ left | right ].
      { split; trivial; []; subst.
        eapply might_be_empty_pr_parse_of_item_nt; try eassumption.
        rewrite take_length; reflexivity. }
      { split; try omega; [].
        eapply last_char_in__impl__for_last_char;
          [
          | apply possible_last_ascii_parse_of_item_nt; eassumption ].
        intros ch H'.
        apply Bool.negb_true_iff, Bool.not_true_iff_false.
        intro H''.
        apply list_in_bl in H''; [ | apply (@ascii_bl) ].
        eapply fold_right_andb_map_in in H_disjoint; [ | eassumption ].
        apply Bool.negb_true_iff, Bool.not_true_iff_false in H_disjoint.
        apply H_disjoint.
        apply list_in_lb; [ apply (@ascii_lb) | assumption ]. } }
    { apply all_possible_ascii_of_parse_of_production; assumption. }
  Qed.

  Lemma terminals_disjoint_rev_search_for_not
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_last_terminals_of nt) (possible_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : is_after_last_char_such_that
        str
        n
        (fun ch => negb (list_bin ascii_beq ch (possible_terminals_of_production its))).
  Proof.
    pose proof (terminals_disjoint_rev_search_for_not' _ H_disjoint pit pits H_reachable) as H.
    split;
      [ destruct H as [H0 H1]
      | destruct H as [H0 [[H1 H2] | H1]];
        destruct_head and;
        try solve [ left; eauto
                  | right; eauto
                  | assumption
                  | apply for_last_char_nil; rewrite ?take_length; apply Min.min_case_strong; omega ] ].
    revert H0.
    apply forall_chars__char_in__impl__forall_chars.
    intros ch H' H''.
    apply Bool.negb_true_iff, Bool.not_true_iff_false in H''.
    apply H''; clear H''.
    apply list_in_lb; [ apply (@ascii_lb) | ]; assumption.
  Qed.

  Lemma terminals_disjoint_rev_search_for'
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_last_terminals_of nt) (possible_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : forall_chars (drop n str)
                   (fun ch => negb (list_bin ascii_beq ch (possible_last_terminals_of nt)))
      /\ ((n = 0 /\ might_be_empty_of nt)
          \/ (last_char_in
                (take n str)
                (possible_last_terminals_of nt)
              /\ n > 0)).
  Proof.
    destruct H_reachable as [ nt' [ prefix [ HinV HinL ] ] ].
    pose proof HinV as HinV';
      rewrite <- (@initial_nonterminals_correct _ G (@rdp_list_predata _ G) (@rdp_list_rdata' _ G)) in HinV'.
    apply and_comm; split.
    { destruct (Compare_dec.zerop n); [ left | right ].
      { split; trivial; [].
        eapply might_be_empty_pr_parse_of_item_nt; try eassumption.
        rewrite take_length; subst; reflexivity. }
      { split; try omega; try assumption; [].
        apply possible_last_ascii_parse_of_item_nt; assumption. } }
    { eapply forall_chars__char_in__impl__forall_chars.
      { intros ch H'.
        apply Bool.negb_true_iff, Bool.not_true_iff_false.
        intro H''.
        apply list_in_bl in H''; [ | apply (@ascii_bl) ].
        eapply fold_right_andb_map_in in H_disjoint; [ | eassumption ].
        apply Bool.negb_true_iff, Bool.not_true_iff_false in H_disjoint.
        apply H_disjoint.
        apply list_in_lb; [ apply (@ascii_lb) | eassumption ]. }
      { apply all_possible_ascii_of_parse_of_production; assumption. } }
  Qed.

  Lemma terminals_disjoint_rev_search_for
        (str : @String Ascii.ascii HSLM)
        {nt its}
        (H_disjoint : disjoint ascii_beq (possible_last_terminals_of nt) (possible_terminals_of_production its))
        {n}
        (pit : parse_of_item G (StringLike.take n str) (NonTerminal nt))
        (pits : parse_of_production G (StringLike.drop n str) its)
        (H_reachable : production_is_reachable G (NonTerminal nt :: its))
    : is_after_last_char_such_that
        str
        n
        (fun ch => list_bin ascii_beq ch (possible_last_terminals_of nt)).
  Proof.
    pose proof (terminals_disjoint_rev_search_for' _ H_disjoint pit pits H_reachable) as H.
    split;
      [ destruct H as [H0 H1]
      | destruct H as [H0 [[H1 H2] | [H1 ?]]];
        try solve [ right; eauto
                  | left; split; eauto
                  | assumption
                  | apply for_last_char_nil; rewrite ?take_length; apply Min.min_case_strong; omega ] ].
    { revert H0.
      apply forall_chars_Proper; [ reflexivity | ].
      intros ch H' H''.
      apply Bool.negb_true_iff, Bool.not_true_iff_false in H'.
      apply H'.
      assumption. }
    { revert H1.
      apply last_char_in__impl__for_last_char.
      intros ch H'.
      apply list_in_lb; [ apply (@ascii_lb) | ]; assumption. }
  Qed.
End search_backward.

Ltac get_grammar :=
  lazymatch goal with
  | [ |- context[ParserInterface.split_list_is_complete_idx ?G] ] => G
  end.

(*Ltac pose_rvalid_for G :=
  lazymatch goal with
  | [ H : is_true (grammar_rvalid G) |- _ ] => idtac
  | _ => let Hvalid := fresh "Hvalid" in
         assert (Hvalid : is_true (grammar_rvalid G))
           by (vm_compute; reflexivity)
  end.
Ltac pose_rvalid := let G := get_grammar in pose_rvalid_for G.*)

Module Export Exports.
  Export DisjointLemmasEarlyDeclarations.
  (** hide the arguments to Build_disjoint_search_data *)
  Local Arguments FromAbstractInterpretation.Build_fold_grammar_data' {_ _ _ _ _} _ _ : assert.
  Notation precomputed_search_data
    := (FromAbstractInterpretation.Build_fold_grammar_data' _ _).

  Ltac do_disjoint_precomputations _ ::=
    let G := get_grammar in
    lazymatch goal with
    | [ |- context[@ParserInterface.split_list_is_complete_idx _ G ?HSLM ?HSL] ]
      => pose (_ : @StringLikeProperties _ HSLM HSL)
    end;
    pose_possible_data_for G.
End Exports.


Require Import Coqlib.
Require Import AST.
Require Import Integers.
Require Import compcert.common.Values.
Require Import Memory.
Require Export Maps.
Require Import Events.
Require Import Globalenvs.

Require Import sepcomp.mem_lemmas. (*for mem_forward*)
Require Import sepcomp.core_semantics.
Require Import sepcomp.effect_semantics.
Require Import Op.
Require Import Registers.

Require Import sepcomp.RTL.
Require Import sepcomp.RTL_coop.

Inductive RTL_effstep (ge:genv):  (block -> Z -> bool) ->
            RTL_core -> mem -> RTL_core -> mem -> Prop :=
  | rtl_effstep_exec_Inop:
      forall s f sp pc rs m pc',
      (fn_code f)!pc = Some(Inop pc') ->
      RTL_effstep ge EmptyEffect (RTL_State s f sp pc rs) m
        (RTL_State s f sp pc' rs) m
  | rtl_effstep_exec_Iop:
      forall s f sp pc rs m op args res pc' v,
      (fn_code f)!pc = Some(Iop op args res pc') ->
      eval_operation ge sp op rs##args m = Some v ->
      RTL_effstep ge EmptyEffect (RTL_State s f sp pc rs) m
        (RTL_State s f sp pc' (rs#res <- v)) m
  | rtl_effstep_exec_Iload:
      forall s f sp pc rs m chunk addr args dst pc' a v,
      (fn_code f)!pc = Some(Iload chunk addr args dst pc') ->
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.loadv chunk m a = Some v ->
      RTL_effstep ge EmptyEffect (RTL_State s f sp pc rs) m
        (RTL_State s f sp pc' (rs#dst <- v)) m
  | rtl_effstep_exec_Istore:
      forall s f sp pc rs m chunk addr args src pc' a m',
      (fn_code f)!pc = Some(Istore chunk addr args src pc') ->
      eval_addressing ge sp addr rs##args = Some a ->
      Mem.storev chunk m a rs#src = Some m' ->
      RTL_effstep ge (StoreEffect a (encode_val chunk (rs#src)))
        (RTL_State s f sp pc rs) m
        (RTL_State s f sp pc' rs) m'
  | rtl_effstep_exec_Icall:
      forall s f sp pc rs m sig ros args res pc' fd,
      (fn_code f)!pc = Some(Icall sig ros args res pc') ->
      find_function ge ros rs = Some fd ->
      funsig fd = sig ->
      RTL_effstep ge EmptyEffect
        (RTL_State s f sp pc rs) m
        (RTL_Callstate (Stackframe res f sp pc' rs :: s) fd rs##args) m
  | rtl_effstep_exec_Itailcall:
      forall s f stk pc rs m sig ros args fd m',
      (fn_code f)!pc = Some(Itailcall sig ros args) ->
      find_function ge ros rs = Some fd ->
      funsig fd = sig ->
      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
      RTL_effstep ge (FreeEffect m 0 (f.(fn_stacksize)) stk)
        (RTL_State s f (Vptr stk Int.zero) pc rs) m
        (RTL_Callstate s fd rs##args) m'

(* WE DO NOT TREAT BUILTINS
  | rtl_effstep_exec_Ibuiltin:
      forall s f sp pc rs m ef args res pc' t v m',
      (fn_code f)!pc = Some(Ibuiltin ef args res pc') ->
      external_call ef ge rs##args m t v m' ->
      RTL_effstep ge
         (BuiltinEffect ge (ef_sig ef) (rs##args) m)
         (RTL_State s f sp pc rs) m
         (RTL_State s f sp pc' (rs#res <- v)) m'
*)
  | rtl_effstep_exec_Icond:
      forall s f sp pc rs m cond args ifso ifnot b pc',
      (fn_code f)!pc = Some(Icond cond args ifso ifnot) ->
      eval_condition cond rs##args m = Some b ->
      pc' = (if b then ifso else ifnot) ->
      RTL_effstep ge EmptyEffect
        (RTL_State s f sp pc rs) m
        (RTL_State s f sp pc' rs) m
  | rtl_effstep_exec_Ijumptable:
      forall s f sp pc rs m arg tbl n pc',
      (fn_code f)!pc = Some(Ijumptable arg tbl) ->
      rs#arg = Vint n ->
      list_nth_z tbl (Int.unsigned n) = Some pc' ->
      RTL_effstep ge EmptyEffect
        (RTL_State s f sp pc rs) m
        (RTL_State s f sp pc' rs) m
  | rtl_effstep_exec_Ireturn:
      forall s f stk pc rs m or m',
      (fn_code f)!pc = Some(Ireturn or) ->
      Mem.free m stk 0 f.(fn_stacksize) = Some m' ->
      RTL_effstep ge (FreeEffect m 0 (f.(fn_stacksize)) stk)
        (RTL_State s f (Vptr stk Int.zero) pc rs) m
        (RTL_Returnstate s (regmap_optget or Vundef rs)) m'
  | rtl_effstep_exec_function_internal:
      forall s f args m m' stk,
      Mem.alloc m 0 f.(fn_stacksize) = (m', stk) ->
      RTL_effstep ge EmptyEffect
        (RTL_Callstate s (Internal f) args) m
        (RTL_State s
                  f
                  (Vptr stk Int.zero)
                  f.(fn_entrypoint)
                  (init_regs args f.(fn_params)))
        m'
(*no external calls
  | rtl_effstep_exec_function_external:
      forall s ef args res t m m',
      external_call ef ge args m t res m' ->
      RTL_effstep ge (Callstate s (External ef) args) m
         t (Returnstate s res m')*)
  | rtl_effstep_exec_return:
      forall res f sp pc rs s vres m,
      RTL_effstep ge EmptyEffect
        (RTL_Returnstate (Stackframe res f sp pc rs :: s) vres) m
        (RTL_State s f sp pc (rs#res <- vres)) m

  | rtl_effstep_sub_val: forall E EE c m c' m',
      (forall b ofs, Mem.valid_block m b ->
                     E b ofs = true -> EE b ofs = true) ->
      RTL_effstep ge E c m c' m' ->
      RTL_effstep ge EE c m c' m'.

Lemma rtl_eff_exec_Iload':
  forall ge s f sp pc rs m chunk addr args dst pc' rs' a v,
  (fn_code f)!pc = Some(Iload chunk addr args dst pc') ->
  Op.eval_addressing ge sp addr rs##args = Some a ->
  Mem.loadv chunk m a = Some v ->
  rs' = (rs#dst <- v) ->
  RTL_effstep ge EmptyEffect
      (RTL_State s f sp pc rs) m
      (RTL_State  s f sp pc' rs') m.
Proof.
  intros. subst rs'. eapply rtl_effstep_exec_Iload; eauto.
Qed.

Lemma rtl_eff_exec_Iop':
  forall g s f sp pc rs m op args res pc' rs' v,
  (fn_code f)!pc = Some(Iop op args res pc') ->
  Op.eval_operation g sp op rs##args m = Some v ->
  rs' = (Registers.Regmap.set res v rs) ->
  RTL_effstep g EmptyEffect (RTL_State s f sp pc rs) m
    (RTL_State s f sp pc' rs') m.
Proof.
  intros. subst rs'. eapply rtl_effstep_exec_Iop; eauto.
Qed.

Lemma rtl_effax1: forall (M : block -> Z -> bool) g c m c' m',
      RTL_effstep g M c m c' m' ->
      (corestep rtl_coop_sem g c m c' m' /\
       Mem.unchanged_on (fun (b : block) (ofs : Z) => M b ofs = false) m m').
Proof.
intros.
  induction H.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Inop; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Iop; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Iload; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Istore; eassumption.
         eapply StoreEffect_Storev; eassumption.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Icall; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Itailcall; eassumption.
         eapply FreeEffect_free; eassumption.
(*  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Ibuiltin; eassumption.
         eapply ec_builtinEffectPolymorphic; eassumption.*)
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Icond; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Ijumptable; eassumption.
         apply Mem.unchanged_on_refl.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_Ireturn; eassumption.
         eapply FreeEffect_free; eassumption.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_function_internal; eassumption.
         eapply Mem.alloc_unchanged_on; eassumption.
  split. unfold corestep, coopsem; simpl.
         eapply rtl_corestep_exec_return; eassumption.
         apply Mem.unchanged_on_refl.
  (*effstep_sub_val*)
    destruct IHRTL_effstep.
    split; trivial.
    eapply unchanged_on_validblock; try eassumption.
    intros; simpl. remember (E b ofs) as d.
    destruct d; trivial. apply eq_sym in Heqd.
    rewrite (H _ _ H3 Heqd) in H4. discriminate.
Qed.

Lemma rtl_effax2: forall  g c m c' m',
      corestep rtl_coop_sem g c m c' m' ->
      exists M, RTL_effstep g M c m c' m'.
Proof.
intros. inv H.
    eexists. eapply rtl_effstep_exec_Inop; eassumption.
    eexists. eapply rtl_effstep_exec_Iop; eassumption.
    eexists. eapply rtl_effstep_exec_Iload; eassumption.
    eexists. eapply rtl_effstep_exec_Istore; eassumption.
    eexists. eapply rtl_effstep_exec_Icall; try eassumption. trivial.
    eexists. eapply rtl_effstep_exec_Itailcall; try eassumption. trivial.
   (* eexists. eapply rtl_effstep_exec_Ibuiltin; eassumption.*)
    eexists. eapply rtl_effstep_exec_Icond; try eassumption. trivial.
    eexists. eapply rtl_effstep_exec_Ijumptable; eassumption.
    eexists. eapply rtl_effstep_exec_Ireturn; eassumption.
    eexists. eapply rtl_effstep_exec_function_internal; eassumption.
    eexists. eapply rtl_effstep_exec_return.
Qed.

(*
Lemma RTL_effstep_sub: forall g U V c m c' m'
         (UV: forall b ofs, U b ofs = true -> V b ofs = true),
         (RTL_effstep g U c m c' m' -> RTL_effstep g V c m c' m').
Qed.
*)
(*
Definition cmin_effstep ge (E:block -> Z -> bool)
   (c : RTL_core) m (c' : RTL_core) m': Prop :=
   coopstep g c m c' m' /\ Mem.unchanged_on (fun b ofs => E b ofs = false) m m'.
*)

Program Definition rtl_eff_sem :
  @EffectSem genv RTL_core.
eapply Build_EffectSem with (sem := rtl_coop_sem)(effstep:=RTL_effstep).
apply rtl_effax1.
apply rtl_effax2.
intros.
eapply rtl_effstep_sub_val; eassumption.
Defined.


From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq.
From mathcomp
Require Import path.
Require Import Eqdep.
Require Import Relation_Operators.
From fcsl
Require Import pred prelude ordtype finmap pcm unionmap heap.
From DiSeL
Require Import Freshness State EqTypeX Protocols Worlds NetworkSem Rely.
From DiSeL
Require Import Actions Injection Process Always HoareTriples InferenceRules.
From DiSeL
Require Import InductiveInv While.
From DiSeL
Require Import CalculatorProtocol CalculatorInvariant.
From DiSeL
Require Import CalculatorClientLib CalculatorServerLib.

Export CalculatorProtocol.

Section DelegatingCalculator.

Variables (l1 l2 : Label).
Hypothesis (lab_disj : l2 != l1).

Variable f : input -> option nat.
Variable prec : input -> bool.
Variables (cs1 cls1 : seq nid).
Variables (cs2 cls2 : seq nid).
Notation nodes1 := (cs1 ++ cls1).
Notation nodes2 := (cs2 ++ cls2).
Hypothesis Huniq1 : uniq nodes1.
Hypothesis Huniq2 : uniq nodes2.

(* Protocol I'm a server in *)
Notation cal1 := (cal_with_inv l1 f prec cs1 cls1).
Notation cal2 := (cal_with_inv l2 f prec cs2 cls2).

Notation W1 := (mkWorld cal1).
Notation W2 := (mkWorld cal2).

(* Composite world *)
Definition V := W1 \+ W2.
Lemma validV : valid V.
Proof.
rewrite /V; apply/andP=>/=.
split; first by rewrite validPtUn/= validPt/= domPt inE/=.
by rewrite unitR valid_unit.
Qed.

(* This server node *)
Variable sv : nid.
(* It's a server in protocol cal1 *)
Hypothesis  Hs1 : sv \in cs1.
(* It's a client in protocol cal2 *)
Hypothesis  Hc2 : sv \in cls2.
(* Delegate server *)
Variable sd : nid.
Hypothesis  Hs2 : sd \in cs2.

Notation loc i k := (getLocal sv (getStatelet i k)).
Notation loc1 i := (loc i l1).
Notation loc2 i := (loc i l2).

(* Delegate computation to someone else *)
Definition delegate_f := compute_f l2 f prec cs2 cls2 _ Hc2 sd.

Notation cal_ii := (ii l1 f prec cs1 cls1).

Definition receive_msg :=
  with_inv cal_ii (blocking_receive_req l1 f prec cs1 cls1 _ Hs1).
Definition send_ans to args ans :=
  with_inv cal_ii (send_answer l1 f prec cs1 cls1 _ Hs1 to args ans).

Definition delegating_body_spec :=
  forall _ : unit,
      DHT [sv, V]
  (fun i =>
     loc1 i = st :-> ([::]:reqs) /\
     loc2 i = st :-> ([::]:reqs),
   fun (r : unit) m =>
     loc1 m = st :-> ([::]:reqs) /\
     loc2 m = st :-> ([::]:reqs)).

Program Definition delegating_body :
  delegating_body_spec := fun (_ : unit) =>
  Do _ (
    r <-- uinject (receive_msg);
    let: (from, args) := r in
    (* Delegate computations *)
    ans <-- uinject (delegate_f args);
    uinject (send_ans from args ans);;
    ret sv V tt).

Lemma hook_complete_unit (c : context) : hook_complete (c, Unit).
Proof. by move=>????; rewrite dom0. Qed.

Lemma hooks_consistent_unit (c : context) : hooks_consistent c Unit.
Proof. by move=>????; rewrite dom0. Qed.

Next Obligation.
rewrite -(unitR V)/V.
have V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV.
apply: (injectL V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit].
by move=>??????; rewrite dom0.
Defined.

Next Obligation.
rewrite -(unitR V)/V.
have V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV.
apply: (injectR V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit].
by move=>??????; rewrite dom0.
Qed.

Next Obligation.
rewrite -(unitR V)/V.
have V: valid (W1 \+ W2 \+ Unit) by rewrite unitR validV.
apply: (injectL V); do?[apply: hook_complete_unit | apply: hooks_consistent_unit].
by move=>??????; rewrite dom0.
Defined.

Lemma hcomp l : hook_complete (mkWorld l).
Proof. by move=>????; rewrite dom0. Qed.

Next Obligation.
move=>i/=[K1 L1]; apply: vrf_coh=>CD1; apply: step.
move: (coh_split CD1 (hcomp cal1) (hcomp cal2))=>[i1[j1]][C1 D1 Z]; subst i.
apply: inject_rule=>//.
have E1 : loc (i1 \+ j1) l1 = loc i1 l1
  by rewrite (locProjL CD1 _ C1)// domPt inE/=.
rewrite E1 in K1.
apply: with_inv_rule=>//.
apply: (gh_ex (g:=[::])).
apply: call_rule=>//[[from args]] i2/=[K2]H1 H2 _ j2 CD2 R1.
have E2 : loc (i1 \+ j1) l2 = loc j1 l2.
  by rewrite (locProjR CD1 _ D1)// domPt inE/=.
(* Adapt the second protocol's view *)
rewrite E2 -(rely_loc' l2 R1) in L1.
apply: step; clear C1 D1.
have D2: j2 \In Coh W2 by case: (rely_coh R1)=>/= _; rewrite injExtL//(cohW CD1).
clear R1; rewrite joinC; apply: inject_rule=>//.
apply: call_rule=>//ans j3[L3]F D3 i3 CD3/= R2.
have C3: i3 \In Coh W1 by case: (rely_coh R2)=>/= _; rewrite injExtR//(cohW CD3).
apply: step; rewrite joinC.
rewrite -(rely_loc' _ R2) in K2; move:K2=>K3; clear R2.
apply: inject_rule=>//; apply: with_inv_rule=>//.
apply: (gh_ex (g:=[:: (from, sv, args)])).
apply: call_rule; first by rewrite inE eqxx.
move=>_ i4 [K4 _] _ j4 CD4 R3.
rewrite -(rely_loc' _ R3) in L3; move: L3=>L4.
apply: ret_rule=>m R _; rewrite (rely_loc' _ R).
move/rely_coh: (R3)=>[]; rewrite injExtL ?(cohW CD2)//.
move=>_ D4; clear R3; rewrite !(rely_loc' _ R); clear R.
have X: l2 \in dom W2.1 by rewrite domPt inE eqxx.
rewrite (@locProjR _ _ _ _ _ CD4 X D4); split=>//.
have X': l1 \in dom W1.1 by rewrite domPt inE eqxx.
rewrite /= eqxx in K4; rewrite (@locProjL _ _ _ _ _ CD4 X' _)//.
by apply: (cohUnKL CD4 D4); apply: hook_complete_unit.
Qed.

Definition delegating_server_loop_cond (res : unit) := true.

Definition delegating_server_loop_inv :=
  fun (_ r : unit) i =>
    loc1 i = st :-> ([::]:reqs) /\
    loc2 i = st :-> ([::]:reqs).

Program Definition delegating_server_loop :
  DHT [sv, V]
  (fun i => loc1 i = st :-> ([::]:reqs) /\
            loc2 i = st :-> ([::]:reqs),
   fun (r : unit) m => False) :=
  Do _ (@while sv V _ _ delegating_server_loop_cond delegating_server_loop_inv _
        (fun r => Do _ (delegating_body r))) tt.

Next Obligation. by apply: with_spec (x x0). Defined.
Next Obligation.
by move:H; rewrite /delegating_server_loop_inv !(rely_loc' _ H0).
Qed.
Next Obligation. by apply: with_spec x. Defined.
Next Obligation.
by apply: ghC=>i1 s[H1 H2] C1/=; apply: call_rule.
Qed.
Next Obligation.
move=>i/=E1; apply: call_rule'=>//.
- by move=>C1; exists tt=>//.
by move=>s' m/(_ s')/=; case.
Qed.

End DelegatingCalculator.