From iris.program_logic Require Export language ectx_language ectxi_language.
From iris_examples.logrel.prelude Require Export base.

Module stlc.
  Inductive expr :=
    | Var (x : var)
    | Lam (e : {bind 1 of expr})
    | App (e1 e2 : expr)
    (* Unit *)
    | Unit
    (* Products *)
    | Pair (e1 e2 : expr)
    | Fst (e : expr)
    | Snd (e : expr)
    (* Sums *)
    | InjL (e : expr)
    | InjR (e : expr)
    | Case (e0 : expr) (e1 : {bind expr}) (e2 : {bind expr}).

  Instance Ids_expr : Ids expr. derive. Defined.
  Instance Rename_expr : Rename expr. derive. Defined.
  Instance Subst_expr : Subst expr. derive. Defined.
  Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.

  Inductive val :=
    | LamV (e : {bind 1 of expr})
    | UnitV
    | PairV (v1 v2 : val)
    | InjLV (v : val)
    | InjRV (v : val).

  Fixpoint of_val (v : val) : expr :=
    match v with
    | LamV e => Lam e
    | UnitV => Unit
    | PairV v1 v2 => Pair (of_val v1) (of_val v2)
    | InjLV v => InjL (of_val v)
    | InjRV v => InjR (of_val v)
    end.
  Notation "# v" := (of_val v) (at level 20).

  Fixpoint to_val (e : expr) : option val :=
    match e with
    | Lam e => Some (LamV e)
    | Unit => Some UnitV
    | Pair e1 e2 => v1 ← to_val e1; v2 ← to_val e2; Some (PairV v1 v2)
    | InjL e => InjLV <$> to_val e
    | InjR e => InjRV <$> to_val e
    | _ => None
    end.

  (** Evaluation contexts *)
  Inductive ectx_item :=
  | AppLCtx (e2 : expr)
  | AppRCtx (v1 : val)
  | PairLCtx (e2 : expr)
  | PairRCtx (v1 : val)
  | FstCtx
  | SndCtx
  | InjLCtx
  | InjRCtx
  | CaseCtx (e1 : {bind expr}) (e2 : {bind expr}).

  Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
    match Ki with
    | AppLCtx e2 => App e e2
    | AppRCtx v1 => App (of_val v1) e
    | PairLCtx e2 => Pair e e2
    | PairRCtx v1 => Pair (of_val v1) e
    | FstCtx => Fst e
    | SndCtx => Snd e
    | InjLCtx => InjL e
    | InjRCtx => InjR e
    | CaseCtx e1 e2 => Case e e1 e2
    end.

  Definition state : Type := ().

  Inductive head_step : expr → state → list Empty_set → expr → state → list expr → Prop :=
  | BetaS e1 e2 v2 σ :
      to_val e2 = Some v2 →
      head_step (App (Lam e1) e2) σ [] e1.[e2/] σ []
  | FstS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Fst (Pair e1 e2)) σ [] e1 σ []
  | SndS e1 v1 e2 v2 σ :
      to_val e1 = Some v1 → to_val e2 = Some v2 →
      head_step (Snd (Pair e1 e2)) σ [] e2 σ []
  | CaseLS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjL e0) e1 e2) σ [] e1.[e0/] σ []
  | CaseRS e0 v0 e1 e2 σ :
      to_val e0 = Some v0 →
      head_step (Case (InjR e0) e1 e2) σ [] e2.[e0/] σ [].

  (** Basic properties about the language *)
  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. by induction v; simplify_option_eq. Qed.

  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof.
    revert v; induction e; intros; simplify_option_eq; auto with f_equal.
  Qed.

  Instance of_val_inj : Inj (=) (=) of_val.
  Proof. by intros ?? Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma fill_item_val Ki e :
    is_Some (to_val (fill_item Ki e)) → is_Some (to_val e).
  Proof. intros [v ?]. destruct Ki; simplify_option_eq; eauto. Qed.

  Instance fill_item_inj Ki : Inj (=) (=) (fill_item Ki).
  Proof. destruct Ki; intros ???; simplify_eq; auto with f_equal. Qed.

  Lemma val_stuck e1 σ1 κ e2 σ2 ef :
    head_step e1 σ1 κ e2 σ2 ef → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma head_ctx_step_val Ki e σ1 κ e2 σ2 ef :
    head_step (fill_item Ki e) σ1 κ e2 σ2 ef → is_Some (to_val e).
  Proof. destruct Ki; inversion_clear 1; simplify_option_eq; eauto. Qed.

  Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
    to_val e1 = None → to_val e2 = None →
    fill_item Ki1 e1 = fill_item Ki2 e2 → Ki1 = Ki2.
  Proof.
    destruct Ki1, Ki2; intros; try discriminate; simplify_eq;
    repeat match goal with
           | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
           end; auto.
  Qed.

  Lemma val_head_stuck e1 σ1 κ e2 σ2 efs : head_step e1 σ1 κ e2 σ2 efs → to_val e1 = None.
  Proof. destruct 1; naive_solver. Qed.

  Lemma lang_mixin : EctxiLanguageMixin of_val to_val fill_item head_step.
  Proof.
    split; apply _ || eauto using to_of_val, of_to_val, val_head_stuck,
           fill_item_val, fill_item_no_val_inj, head_ctx_step_val.
  Qed.
End stlc.

(** Language *)
Canonical Structure stlc_ectxi_lang := EctxiLanguage stlc.lang_mixin.
Canonical Structure stlc_ectx_lang := EctxLanguageOfEctxi stlc_ectxi_lang.
Canonical Structure stlc_lang := LanguageOfEctx stlc_ectx_lang.

Export stlc.

Hint Extern 20 (PureExec _ _ _) => progress simpl : typeclass_instances.

Hint Extern 5 (IntoVal _ _) => eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (IntoVal _ _) =>
  rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.

Hint Extern 5 (AsVal _) => eexists; eapply of_to_val; fast_done : typeclass_instances.
Hint Extern 10 (AsVal _) =>
  eexists; rewrite /IntoVal; eapply of_to_val; rewrite /= !to_of_val /=; solve [ eauto ] : typeclass_instances.


Require Import Coq.Classes.Morphisms.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Monad.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Prop.
Require Import ExtLib.Tactics.
Require Import MirrorCore.ExprDAs.
Require Import MirrorCore.Instantiate.
Require Import MirrorCore.RTac.Core.
Require Import MirrorCore.RTac.CoreK.

Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Util.Nat.
Require Import MirrorCore.Util.Compat.

Set Implicit Arguments.
Set Strict Implicit.

Polymorphic Lemma equiv_hlist_app'
  : forall {T} (F : T -> Type)
      (eqv : forall x : T, Relation_Definitions.relation (F x))
      (a b : list T) (c c' : hlist F a) (d d' : hlist F b),
    equiv_hlist eqv (hlist_app c d) (hlist_app c' d') <->
    (equiv_hlist eqv c c' /\ equiv_hlist eqv d d').
Proof using.
  intros. symmetry. eapply equiv_hlist_app.
Qed.

Ltac solve_equiv_hlist :=
  repeat match goal with
         | |- _ => assumption
         | |- _ => reflexivity
         | |- equiv_hlist _ (hlist_app _ _) (hlist_app _ _) =>
           eapply equiv_hlist_app'; split; auto
         | |- _ => constructor
         end.

Section parameterized.
  Variable typ : Set.
  Variable expr : Set.

  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Expr_expr : Expr typ expr}.
  Context {ExprOk_expr : ExprOk _}.
  Context {Typ0_Prop : Typ0 _ Prop}.

  Fixpoint instantiateGoal (f : nat -> option expr) (g : Goal typ expr)
  : Goal typ expr :=
    match g with
      | GSolved => GSolved
      | GGoal g => GGoal (instantiate f 0 g)
      | GAll t g' => GAll t (instantiateGoal f g')
      | GExs ts sub g' =>
        GExs ts (amap_instantiate f sub) (instantiateGoal f g')
      | GHyp h g' => GHyp (instantiate f 0 h) (instantiateGoal f g')
      | GConj_ a b =>
        GConj_ (instantiateGoal f a) (instantiateGoal f b)
    end.

  Definition GExs_nil_check (ts : list typ) (s : amap _)
             (g : Goal typ expr) : Goal typ expr :=
    match ts with
      | nil => g
      | _ :: _ => GExs ts s g
    end.

  Theorem GExs_nil_check_respects tus tvs ts sub
  : only_in_range (length tus) (length ts) sub ->
    WellFormed_amap sub ->
    (EqGoal (tus ++ ts) tvs ==> EqGoal tus tvs)%signature
         (@GExs typ expr ts sub) (GExs_nil_check ts sub).
  Proof.
    red. intros; subst.
    unfold EqGoal in *. simpl.
    destruct ts.
    { simpl in *.
      rewrite goalD_conv with (pfu := HList.app_nil_r_trans tus)
                              (pfv := eq_refl).
      autorewrite_with_eq_rw.
      destruct H1.
      split.
      { split.
        { intro. rewrite app_nil_r in H1. apply H1.
          inv_all. rewrite app_nil_r in *. assumption. }
        { rewrite app_nil_r in *.
          intros. apply H1 in H3.
          constructor; auto.
          eapply only_in_range_0_WellFormed_pre_entry; eauto.
          rewrite app_nil_r. assumption. } }
      { inversion H2; try constructor.
        eapply only_in_range_0_substD with (tus := tus++nil) (tvs:=tvs) in H; eauto.
        destruct H as [ ? [ ? ? ] ].
        rewrite H.
        constructor.
        do 5 red; intros; equivs.
        autorewrite with eq_rw.
        do 5 red in H5.
        rewrite H5; try reflexivity.
        unfold tenv.
        rewrite <- hlist_app_nil_r.
        revert H6. clear. firstorder. } }
    { simpl in *.
      destruct H1.
      split.
      { split; intros; inv_all; constructor; tauto. }
      inversion H2; try constructor.
      match goal with
        | |- _ _ match ?X with _ => _ end
                 match ?Y with _ => _ end =>
          change Y with X ; destruct X
      end; constructor.
      clear - H5; do 5 red; intros; equivs.
      eapply exists_iff. intros.
      eapply Quant._exists_iff. intros.
      eapply and_iff. reflexivity.
      intros. eapply H5; reflexivity. }
  Qed.

  Definition GExs_do_solved (tes : tenv typ) (m : amap expr) (g : Goal typ expr)
  : Goal typ expr :=
    match g with
      | GSolved =>
        if amap_is_full (length tes) m then
          GSolved
        else
          GExs tes m g
      | _ => GExs tes m g
    end.

  Definition GHyp_do_solved (e : expr) (g : Goal typ expr)
  : Goal typ expr :=
    match g with
      | GSolved => GSolved
      | _ => GHyp e g
    end.

  Definition GAll_do_solved (ts : typ) (g : Goal typ expr)
  : Goal typ expr :=
    match g with
      | GSolved => GSolved
      | _ => GAll ts g
    end.

  Lemma WellFormed_Goal_All_iff
  : forall tus tvs t (g : Goal typ expr),
      WellFormed_Goal tus tvs (GAll t g) <->
      WellFormed_Goal tus (tvs ++ t :: nil) g.
  Proof using.
    split. intros; inv_all; subst. auto.
    intros. constructor. auto.
  Qed.

  (** DUPLICATE **)
  Lemma WellFormed_Goal_Solved_iff
  : forall tus tvs,
      WellFormed_Goal (typ:=typ) (expr:=expr) tus tvs GSolved <->
      True.
  Proof using.
    split. intros; inv_all; subst. auto.
    intros. constructor.
  Qed.

  Theorem GAll_do_solved_respects tus tvs t
  : (EqGoal tus (tvs ++ t :: nil) ==> EqGoal tus tvs)%signature
      (GAll_do_solved t) (@GAll typ expr t).
  Proof.
    red. red. simpl. unfold GAll_do_solved. simpl.
    intros.  destruct H. split.
    { clear - H.
      destruct x;
        (try rewrite WellFormed_Goal_All_iff);
        (try rewrite H);
        (try rewrite WellFormed_Goal_All_iff);
        try reflexivity.
      rewrite <- H.
      split; constructor. }
    { destruct x; simpl in *;
      try solve [ destruct H0; constructor;
                  do 5 red; intros; eapply forall_iff; intros; eapply H0; eauto;
                  solve_equiv_hlist ].
      inversion H0. subst.
      constructor.
      do 5 red; intros. split; auto.
      intros. eapply H3. eauto.
      eapply equiv_hlist_app'. split; eauto.
      constructor. reflexivity. constructor. auto. }
  Qed.

  Lemma WellFormed_Goal_Hyp_iff
  : forall tus tvs t (g : Goal typ expr),
      WellFormed_Goal tus tvs (GHyp t g) <->
      WellFormed_Goal tus tvs g.
  Proof.
    split. intros; inv_all; subst. auto.
    intros. constructor. auto.
  Qed.

  Theorem GHyp_do_solved_respects tus tvs t tD
  : propD tus tvs t = Some tD ->
    (EqGoal tus tvs ==> EqGoal tus tvs)%signature
      (GHyp_do_solved t) (@GHyp typ expr t).
  Proof.
    red. red. simpl. unfold GHyp_do_solved. simpl.
    intros. destruct H0. split.
    { clear - H0.
      destruct x;
        (try rewrite WellFormed_Goal_Hyp_iff);
        (try rewrite H0);
        (try rewrite WellFormed_Goal_Hyp_iff);
        try reflexivity. }
    { destruct x; simpl in *; rewrite H;
      try solve
          [ destruct H1; constructor;
            do 5 red; intros;
            eapply impl_iff; intros;
            [ equivs; reflexivity |  eapply H1; eauto ] ].
      inversion H1. subst.
      constructor.
      do 5 red; intros. split; auto.
      simpl; intros. eapply H4; eauto. }
  Qed.

  Lemma WellFormed_Goal_iff_GExs_cancel
  : forall (tus tvs ts : tenv typ) m x y,
      (WellFormed_Goal (tus ++ ts) tvs x <->
       WellFormed_Goal (tus ++ ts) tvs y) ->
      (WellFormed_Goal tus tvs (GExs ts m x) <->
       WellFormed_Goal tus tvs (GExs ts m y)).
  Proof using.
    intros. split; intros; inv_all; subst; constructor; tauto.
  Qed.

  Lemma GoalImplies_GExs_do_solved
  : forall c (cs : ctx_subst c) ts m g,
      GoalImplies (cs, GExs ts m g)
                  (cs, GExs_do_solved ts m g).
  Proof.
    Transparent GoalImplies. simpl; intros.
    split; auto.
    split.
    { destruct g; simpl; auto.
      destruct (amap_is_full (length ts) m);
        auto. constructor. }
    { forward; inv_all; subst.
      destruct g; simpl in *; forwardy; inv_all; subst;
      Cases.rewrite_all_goal.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * split; [ reflexivity | ].
        intros. eapply Pure_pctxD; eauto.
      * Opaque amap_is_full.
        match goal with
          | |- match _ _ _ (if ?X then _ else _) with _ => _ end =>
            consider X; intros; simpl
        end.
        + split; [ reflexivity | ].
          intros. eapply Pure_pctxD; eauto. intros.
          eapply Quant._exists_sem.
          eapply subst_getInstantiation in H3; eauto.
          destruct H3.
          exists (hlist_map (fun t (x : exprT _ _ (typD t))=> x us0 vs0) x).
          eauto.
        + change_rewrite H3.
          split; [ reflexivity | ].
          intros. eapply Pure_pctxD; eauto. }
  Qed.

  Fixpoint toResult (ctx ctx' : Ctx typ expr)
           (g : Goal typ expr)
  : ctx_subst (Ctx_append ctx ctx') -> Result ctx :=
    match ctx' as ctx'
          return ctx_subst (Ctx_append ctx ctx') -> Result ctx
    with
      | CTop _ _ => fun cs => More_ cs g
      | CAll ctx' t => fun cs =>
        @toResult ctx ctx' (GAll t g) (fromAll cs)
      | CHyp ctx' h => fun cs =>
        @toResult ctx ctx'  (GHyp h g) (fromHyp cs)
      | CExs ctx' ts => fun cs : ctx_subst (CExs (Ctx_append ctx ctx') ts) =>
        let '(s,cs') := fromExs cs in
        @toResult ctx ctx' (GExs ts s g) cs'
    end.

  Fixpoint reduceResult (ctx ctx' : Ctx typ expr)
           (g : Goal typ expr)
  : ctx_subst (Ctx_append ctx ctx') -> Result ctx :=
    match ctx' as ctx'
          return ctx_subst (Ctx_append ctx ctx') -> Result ctx
    with
      | CTop _ _ => fun cs =>
        (** TODO: this should be More_ but to do the right reasoning,
         ** I need to find a better equivalence relation
         **)
        More cs g
      | CAll ctx' t => fun cs =>
        @reduceResult ctx ctx' (GAll_do_solved t g) (fromAll cs)
      | CHyp ctx' h => fun cs =>
        @reduceResult ctx ctx'  (GHyp_do_solved h g) (fromHyp cs)
      | CExs ctx' ts => fun cs : ctx_subst (CExs (Ctx_append ctx ctx') ts) =>
        let '(s,cs') := fromExs cs in
        @reduceResult ctx ctx' (GExs_do_solved ts s g) cs'
    end.

  (** This assumes that the goal is a [GSolved] **)
  Fixpoint solveGoal (ctx ctx' : Ctx typ expr)
  : ctx_subst (Ctx_append ctx ctx') -> Result ctx :=
    match ctx' as ctx'
          return ctx_subst (Ctx_append ctx ctx') -> Result ctx
    with
      | CTop _ _ => fun cs => Solved cs
      | CAll ctx' t => fun cs =>
        @solveGoal ctx ctx' (fromAll cs)
      | CHyp ctx' h => fun cs =>
        @solveGoal ctx ctx' (fromHyp cs)
      | CExs ctx' ts => fun cs =>
        let '(s,cs') := fromExs cs in
        let g' := GExs_do_solved ts s GSolved in
        match g' with
          | GSolved => @solveGoal ctx ctx' cs'
          | g' => @toResult ctx ctx' g' cs'
        end
    end.

  Lemma solveGoal_toGoal
  : forall ctx ctx' (cs : ctx_subst (Ctx_append ctx ctx')),
      (EqResult)
        (@solveGoal ctx ctx' cs) (toResult ctx ctx' GSolved cs).
  Proof.
  Abort.

  Definition reduceGoal (ctx ctx' : Ctx typ expr)
             (s : ctx_subst (Ctx_append ctx ctx'))
             (g : Goal typ expr)
  : Result ctx :=
    match g with
      | GSolved => @solveGoal ctx ctx' s
      | _ => @reduceResult ctx ctx' g s
    end.

  Definition ResultImplies ctx (r1 r2 : Result ctx) : Prop :=
    match fromResult r1 , fromResult r2 with
      | _ , None => True
      | Some a , Some b => GoalImplies a b
      | None , _ => False
    end.

End parameterized.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrbool.
Require Import funs.
Require Import dataset.
Require Import ssrnat.
Require Import seq.
Require Import paths.
Require Import finset.
Require Import connect.
Require Import hypermap.
Require Import geometry.
Require Import coloring.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* A quiz is a pair of binary trees that covers the inner regions of a    *)
(* configuration and store their arity. The embedding lemmas allow us to  *)
(* use questions to actually test for an isomorphic embedding of the      *)
(* configuration in a minimal uncolorable cubic map.                      *)

(* We are only interested in arities between 5 and 11 (in fact 9, 10, and 11 *)
(* only occur at the hub).                                                   *)

Inductive qarity : Set :=
  | Qa5 : qarity
  | Qa6 : qarity
  | Qa7 : qarity
  | Qa8 : qarity
  | Qa9 : qarity
  | Qa10 : qarity
  | Qa11 : qarity.

Definition nat_of_qarity (qa : qarity) : nat :=
  match qa with
  | Qa5 => 5
  | Qa6 => 6
  | Qa7 => 7
  | Qa8 => 8
  | Qa9 => 9
  | Qa10 => 10
  | Qa11 => 11
  end.

Coercion nat_of_qarity : qarity >-> nat.

Definition qarity_of_nat (n : nat) : qarity :=
  match n with
  | S (S (S (S (S O)))) => Qa5
  | S (S (S (S (S (S O))))) => Qa6
  | S (S (S (S (S (S (S O)))))) => Qa7
  | S (S (S (S (S (S (S (S O))))))) => Qa8
  | S (S (S (S (S (S (S (S (S O)))))))) => Qa9
  | S (S (S (S (S (S (S (S (S (S O))))))))) => Qa10
  | _ => Qa11
  end.

Lemma qarity_of_qarity : forall qa : qarity, qarity_of_nat qa = qa.
Proof. by case. Qed.

Lemma qarityDataP : comparable qarity.
Proof. rewrite /comparable; decide equality. Qed.

(* We specialize the question tree constructor according to the presence    *)
(* of left and right branches. We also need skewed left and right branches, *)
(* for configurations whose interior has an articulation.                   *)

Inductive question : Set :=
  | Qask0 : question
  | Qask1 : qarity -> question
  | QaskL : qarity -> question -> question
  | QaskR : qarity -> question -> question
  | QaskLR : qarity -> question -> question -> question
  | QaskLL : qarity -> question -> question
  | QaskRR : qarity -> question -> question.

Lemma questionDataP : comparable question.
Proof. rewrite /comparable; decide equality; apply qarityDataP. Qed.
Definition questionData : dataSet := Eval compute in
  compareData questionDataP.
Canonical Structure questionData.

Definition isQaskR q := if q is QaskR _ _ then true else false.

Fixpoint flatq (q : question) : natseq :=
  match q with
  | Qask0 => seq0
  | Qask1 qa => seq1 (qa : nat)
  | QaskL qa ql => Adds (qa : nat) (flatq ql)
  | QaskR qa qr => Adds (qa : nat) (flatq qr)
  | QaskLR qa ql qr => Adds (qa : nat) (cat (flatq ql) (flatq qr))
  | QaskLL qa qll => Adds (qa : nat) (flatq qll)
  | QaskRR qa qrr => Adds (qa : nat) (flatq qrr)
  end.

(* Mirror image questions. *)

Fixpoint flipq (q : question) : question :=
  match q with
  | QaskL qa ql => QaskR qa (flipq ql)
  | QaskR qa qr => QaskL qa (flipq qr)
  | QaskLR qa ql qr => QaskLR qa (flipq qr) (flipq ql)
  | QaskLL qa qll => QaskRR qa (flipq qll)
  | QaskRR qa qrr => QaskLL qa (flipq qrr)
  | _ => q
  end.

Definition qstepL (g : hypermap) (x : g) := node (edge (node x)).
Definition qstepR (g : hypermap) (x : g) := node (edge x).

Inductive quiz : Set := Quiz : forall q0 q1 : question, quiz.

Definition isQuizR qz := let: Quiz q0 q1 := qz in isQaskR q0 && isQaskR q1.

Definition flatqz qz := let: Quiz q0 q1 := qz in cat (flatq q0) (flatq q1).

Definition flipqz qz :=
  if qz is Quiz (QaskR qa0 q01) (QaskR qa1 q10) then
    Quiz (QaskR qa0 (flipq q10)) (QaskR qa1 (flipq q01))
  else qz.

Section FitQuiz.

Variable g : hypermap.

Fixpoint walkq (x : g) (q : question) {struct q} : seq g :=
  match q with
  | Qask0 => seq0
  | Qask1 qa => seq1 x
  | QaskL qa ql => Adds x (walkq (qstepL x) ql)
  | QaskR qa qr => Adds x (walkq (qstepR x) qr)
  | QaskLR qa ql qr => Adds x (cat (walkq (qstepL x) ql) (walkq (qstepR x) qr))
  | QaskLL qa qll =>
    let xl := qstepL x in Adds (edge (node xl)) (walkq (qstepL xl) qll)
  | QaskRR qa qrr => let xr := qstepR x in Adds xr (walkq (qstepR xr) qrr)
  end.

Definition fitq (x : g) q := (flatq q : seq _) =d maps arity (walkq x q).

Lemma size_walkq : forall (x : g) q, size (walkq x q) = size (flatq q).
Proof. move=> x q; elim: q x => //= *; rewrite ?size_cat; congr S; auto. Qed.

Lemma fitq_cat : forall x q s s',
 (cat (flatq q) s =d maps arity (cat (walkq x q) s'))
    = fitq x q && (s =d maps arity s').
Proof.
move=> x q s s'; rewrite /fitq; move: (introT eqP (size_walkq x q)).
elim: {q x}(walkq x q) (flatq q) => [|x s1 Hrec] [|n s2] //= Es12.
rewrite !eqseq_adds -andbA; congr andb; auto.
Qed.

Lemma size_flipq : forall q, size (flatq (flipq q)) = size (flatq q).
Proof. elim=> //= *; rewrite ?size_cat 1?addnC; congr S; auto. Qed.

Definition walkqz x qz :=
  let: Quiz q0 q1 := qz in cat (walkq x q0) (walkq (edge x) q1).

Lemma size_walkqz : forall x qz, size (walkqz x qz) = size (flatqz qz).
Proof. by move=> x [q0 q1]; rewrite /= ?size_cat ?size_walkq. Qed.

Definition fitqz x qz := flatqz qz =d maps arity (walkqz x qz).

End FitQuiz.

Lemma fitqz_flip : forall g x qz, plain_cubic g -> isQuizR qz ->
  @fitqz g x (flipqz qz) = @fitqz (mirror g) (face x) qz.
Proof.
move=> g x [q0 q1] [HgE HgN]; case: q0 => //=; case: q1 => //=.
move=> qa1 q10 qa0 q01 _; move Dh: (fun y : g => y : mirror g) => h.
rewrite (congr1 (fun f => f (face x)) Dh); move: x.
have De2: forall x : g, edge (edge x) = x by apply plain_eq.
have Dn3: forall x : g, node (node (node x)) = x by apply cubic_eq.
have Hh1: forall x : g, arity (h x) = arity x.
 by move=> x; rewrite -Dh arity_mirror.
have HhL: forall x : g, qstepL (h x) = h (qstepR x).
move=> x; rewrite -Dh /= /comp (f_finv (Inode g)) -{1}[x]De2 -{1}[edge x]Dn3.
  by rewrite Enode (finv_f (Inode g)).
have HhR: forall x : g, qstepR (h x) = h (qstepL x).
  move=> x; apply: (etrans _ (HhL _)).
  by rewrite -Dh /qstepL /qstepR /= (finv_f (Inode g)).
have HhE: forall x : g, edge (h (face x)) = h (face (edge x)).
  by move=> x; rewrite -Dh /= -{1}[x]De2 /comp Eedge.
have EaEN: forall x, arity (edge (node x)) = arity x.
  by move=> g' x; rewrite -arity_face Enode.
  move: (mirror g) h {Dh}Hh1 HhL HhR HhE => g' h Hh1 HhL HhR HhE.
have Eqs1: forall (n n' : nat) s s',
  (Adds n s =d Adds n' s') = (n =d n') && (s =d s') by done.
have Hq: forall q x, fitq x (flipq q) = fitq (h x) q.
  rewrite /fitq; elim=> //= *; rewrite ?HhL ?HhR ?EaEN Hh1 //;
    rewrite ?Eqs1 ?fitq_cat /fitq; try congr andb; auto.
  by rewrite andbC; congr andb.
move=> x; rewrite /fitqz /= !Eqs1 !fitq_cat /= !Eqs1 HhE !Hh1 !arity_face !HhR.
congr andb; rewrite !(andbC ((qa1 : nat) =d _)) !andbA; congr andb; rewrite andbC.
congr andb; apply: (etrans (Hq _ _) (congr1 (fun y => fitq (h y) _) _)).
  by rewrite /qstepL -{2}[x]De2 Eedge.
by rewrite /qstepL Eedge.
Qed.

Section QuizEmbedding.

Variables (gm gc : hypermap) (rc : seq gc).

Notation ac := (kernel rc).
Notation bc := (setC rc).
Let Hacbc := subsetP (kernel_off_ring rc).
Let HacF := kernelF rc.

Hypotheses (Hgm : plain_cubic gm) (Hgc : plain_quasicubic rc).
Let De2m := plain_eq Hgm.
Let Dn3m := cubic_eq Hgm.
Let De2c := plain_eq Hgc.
Let Dn3c := quasicubic_eq Hgc.

(* Adds the (disjoint) domain covered by the question to a previously covered *)
(* domain. The empty set is returned if the question is invalid (wrong arity, *)
(* cover overlap).                                                            *)

Variables (x0m : gm) (x0c : gc) (qz : quiz).
Let s0c : seq gc := walkqz x0c qz.
Let s0m : seq gm := walkqz x0m qz.

Definition valid_quiz :=
  and4 (isQuizR qz) (fitqz x0c qz) (simple s0c) (fband s0c =1 ac).

Hypotheses (Hqzc : valid_quiz) (Hqzm : fitqz x0m qz).

Definition embedqz x :=
  let i := find (cface x) s0c in
  let j := findex face (sub x0c s0c i) x in
  iter j face (sub x0m s0m i).

Notation h := embedqz.
Notation hc := (edge_central h).
Let HhcE := edge_central_edge h Hgc Hgm.

Remark Embedqz_Dhx0 : h x0c = x0m.
Proof.
rewrite /h /s0c /s0m; case: Hqzc => [H _ _ _]; case: qz H => [q0 q1].
by case q0; rewrite //= connect0 /= findex0.
Qed.
Notation Dhx0 := Embedqz_Dhx0.

Remark Embedqz_Dhs0 : forall i : nat, h (sub x0c s0c i) = sub x0m s0m i.
Proof.
move=> i; case Hi: (size s0c <= i).
  by rewrite !sub_default ?Dhx0 //; move: Hi; rewrite /s0c /s0m !size_walkqz.
rewrite leqNgt in Hi; move/idP: Hi => Hi.
set x := sub x0c s0c i; rewrite /h.
suffice ->: find (cface x) s0c = i by rewrite -/x findex0.
case: Hqzc => [_ _ Uq _]; move: Uq.
rewrite -(cat_take_drop i s0c) (drop_sub x0c Hi) -/x.
rewrite /simple maps_cat uniq_cat /=; move/and3P=> [_ Uq _].
rewrite find_cat /= connect0 (size_takel (ltnW Hi)) addn0.
case: (hasPx (cface x) (take i s0c)) => // [[y Hy Hxy]].
case/norP: Uq; case/mapsP; exists y; first done.
symmetry; exact: (rootP (Sface _)).
Qed.
Notation Dhs0 := Embedqz_Dhs0.

Remark Embedqz_Dhex0 : h (edge x0c) = edge x0m.
Proof.
case: Hqzc => [H _ _ _]; move: Dhs0 H; rewrite /s0c /s0m; case qz.
move=> /= q0 q1 H; move: {H}(H (size (flatq q0))).
by rewrite !sub_cat !size_walkq /= ltnn subnn andbC; case q1.
Qed.
Notation Dhex0 := Embedqz_Dhex0.

Lemma embedqz_arity : forall x, ac x -> arity (h x) = arity x.
Proof.
case: Hqzc => [_ Haqc _ Dac] x; rewrite -{}Dac /h; move=> Hx.
set i := find (cface x) s0c; set y := sub x0c s0c i.
set j := findex face y x.
have Hi: i < size s0c by rewrite /i -has_find.
have Hy: s0c y by exact: mem_sub Hi.
have Hxy: cface x y by exact: sub_find.
move: Haqc Hqzm; rewrite /fitqz -/s0c -/s0m => Eaqc Eqzm.
rewrite (arity_cface Hxy) /y -(sub_maps x0c 0) // -(eqP Eaqc) (eqP Eqzm).
rewrite (sub_maps x0m 0); first by elim j=> *; rewrite /= ?arity_face.
by move: Hi; rewrite /s0c /s0m !size_walkqz.
Qed.

Lemma embedqz_face : forall x, ac x -> h (face x) = face (h x).
Proof.
case: Hqzc => [_ _ _ Dac] x; rewrite -Dac => Hx.
set i := find (cface x) s0c; rewrite /h -(eq_find (cface1 x)) -/i.
set yc := sub x0c s0c i.
have Hxyc: cface yc x by rewrite Sface /yc /i sub_find.
rewrite -Dhs0 -/yc -{1}(iter_findex Hxyc).
move: (findex face yc x) (@findex_max _ face yc x) => j Hj.
rewrite leq_eqVlt in Hj; case/orP: {Hj}(Hj Hxyc) => [Dj|Hj].
  rewrite -[j]/(pred (S j)) (eqP Dj) -/(finv face yc) (f_finv (Iface gc)).
  rewrite findex0 /= -/(arity yc) -embedqz_arity.
    by rewrite -/(finv face (h yc)) (f_finv (Iface gm)).
  by rewrite -Dac (closed_connect (fbandF s0c) Hxyc).
by rewrite f_iter findex_iter.
Qed.

Lemma embedqz_central : sub_set s0c hc.
Proof.
have Hq: forall x q, ac x -> ac (edge x) -> hc x -> let s := walkq (node x) q in
    all ac s -> (maps h s =d walkq (node (h x)) q) -> all hc s.
  move=> x q; elim: q x => //= _.
  - move=> x HxF _ HxE _; case/andP; move/eqP=> Dhnx _.
    rewrite /edge_central Dhnx -{2}[x]Enode embedqz_face ?Eface ?set11 //.
    by rewrite (fclosed1 HacF) Enode.
  - move=> q Hrec x HxF HexF HxE; move/andP=> [HnxF HsF].
    rewrite eqseq_adds; case/andP; move/eqP=> Dhnx Hs.
    have HenxF: ac (edge (node x)) by rewrite (fclosed1 HacF) Enode.
    have HennxF: ac (edge (node (node x))) by rewrite (fclosed1 HacF) Enode.
    have HnxE: hc (node x).
      by rewrite /edge_central Dhnx -{2}[x]Enode embedqz_face ?Eface ?set11.
    have HennxE: hc (edge (node (node x))).
      rewrite /edge_central De2c -{1}[node (node x)]Enode (Dn3c (Hacbc HxF)).
      rewrite (embedqz_face HexF) (eqP HxE) -{1}[h x]Dn3m Enode.
      by rewrite -[h (edge _)]Eface -embedqz_face // De2m Enode Dhnx set11.
    rewrite HnxE /= /qstepL Hrec //.
    rewrite De2c -[node (node x)]Enode (Dn3c (Hacbc HxF)).
      by rewrite -(fclosed1 HacF).
    by rewrite -[h (edge _)]Eface -embedqz_face // Enode Dhnx.
  - move=> q Hrec x HxF HexF HxE; move/andP=> [HnxF HsF].
    rewrite eqseq_adds; case/andP; move/eqP=> Dhnx Hs.
    have HenxF: ac (edge (node x)) by rewrite (fclosed1 HacF) Enode.
    have HennxF: ac (edge (node (node x))) by rewrite (fclosed1 HacF) Enode.
    have HnxE: hc (node x).
      by rewrite /edge_central Dhnx -{2}[x]Enode embedqz_face ?Eface ?set11.
    by rewrite HnxE /= /qstepR Hrec ?De2c 1?HhcE // (eqP HnxE) Dhnx.
  - move=> ql Hrecl qr Hrecr x HxF HexF HxE /=.
    rewrite !all_cat eqseq_adds maps_cat eqseq_cat ?size_maps ?size_walkq //.
    move/and3P=> [HnxF HslF HsrF]; case/and3P; move/eqP=> Dhnx Hsl Hsr.
    have HenxF: ac (edge (node x)) by rewrite (fclosed1 HacF) Enode.
    have HennxF: ac (edge (node (node x))) by rewrite (fclosed1 HacF) Enode.
    have HnxE: hc (node x).
      by rewrite /edge_central Dhnx -{2}[x]Enode embedqz_face ?Eface ?set11.
    have HennxE: hc (edge (node (node x))).
    rewrite /edge_central De2c -{1}[node (node x)]Enode (Dn3c (Hacbc HxF)).
    rewrite (embedqz_face HexF) (eqP HxE) -{1}[h x]Dn3m Enode.
    rewrite -[h (edge _)]Eface -embedqz_face //.
      by rewrite De2m Enode Dhnx set11.
    rewrite HnxE /= /qstepL /qstepR Hrecl // ?Hrecr // ?De2c ?HhcE //.
    + by rewrite (eqP HnxE) Dhnx.
    + by rewrite -[node (node x)]Enode (Dn3c (Hacbc HxF)) -(fclosed1 HacF).
    by rewrite -[h (edge _)]Eface -embedqz_face // Enode Dhnx.
  - move=> q Hrec x HxF HexF HxE; move/andP=> [HenLnxF HsF].
    rewrite eqseq_adds; case/andP; move/eqP=> DhenLnx Hs.
    have HfexF: ac (face (edge x)) by rewrite -(fclosed1 HacF).
    have HffexF: ac (face (face (edge x))) by rewrite -(fclosed1 HacF).
    have HenLnxE: hc (edge (node (qstepL (node x)))).
      rewrite /edge_central De2c DhenLnx /qstepL De2m.
      rewrite -{1}[x]Eedge (Dn3c (Hacbc HfexF)).
      rewrite -{1}[face (edge x)]Eface De2c (Dn3c (Hacbc HffexF)).
      rewrite !embedqz_face // (eqP HxE) -{2}[h x]Eedge Dn3m.
      by rewrite -{2}[face (edge _)]Eface De2m Dn3m set11.
    rewrite HenLnxE /= {1}/qstepL Hrec ?DhenLnx //.
    rewrite De2c -{1}[x]Eedge /qstepL (Dn3c (Hacbc HfexF)).
    by rewrite -{1}[face (edge x)]Eface De2c (Dn3c (Hacbc HffexF)).
  - move=> q Hrec x HxF HexF HxE; move/andP=> [HRnxF HsF].
    rewrite eqseq_adds; case/andP; move/eqP=> DhRnx Hs.
    have HenxF: ac (edge (node x)) by rewrite (fclosed1 HacF) Enode.
    have HenenxF: ac (edge (node (edge (node x)))).
      by rewrite (fclosed1 HacF) Enode.
    have HRnxE: hc (qstepR (node x)).
      rewrite /edge_central DhRnx /qstepR -(monic2F_eqd (Eface gm)).
      rewrite -embedqz_face // Enode.
      by rewrite -(monic2F_eqd (Eface gm)) -embedqz_face // Enode set11.
    by rewrite HRnxE /= {1}/qstepR Hrec ?De2c ?HhcE // (eqP HRnxE) DhRnx.
have Hx0E: hc x0c by rewrite /edge_central Dhx0 Dhex0 set11.
have Hex0E: hc (edge x0c) by rewrite HhcE.
move: Hqzc => [Hqz _ _ Dac].
have Hs0F: subset s0c ac by rewrite -(eq_subset_r Dac); apply ring_fband.
have Ehs0: maps h s0c =d s0m.
  apply/eqP; pose n := size (flatqz qz).
  have Dnc: size s0c = n by rewrite /s0c size_walkqz.
  have Dnm: size s0m = n by rewrite /s0m size_walkqz.
  rewrite -(take_size s0c) -(take_size s0m) Dnc Dnm.
  elim: {-2}n (leqnn n) => [|i Hrec] Hi; first by rewrite !take0.
  rewrite (take_sub x0c) ?Dnc // maps_add_last Dhs0 (Hrec (ltnW Hi)).
  by rewrite -take_sub // Dnm.
apply: subsetP; move: Hs0F Ehs0 {Dac}; rewrite /s0c /s0m !subset_all.
case: qz Hqz => [q0 q1] /=.
rewrite !all_cat maps_cat eqseq_cat; last by rewrite size_maps !size_walkq.
case: q0 => //= [_ q01]; case: q1 => //= [_ q10] _; rewrite Hx0E Hex0E /=.
case/and3P; case/andP; move=> Hx0cF Hs01F Hex0cF Hs10F; rewrite !eqseq_adds.
case/and3P; case/andP; move/eqP=> <- Hs01; move/eqP=> <- Hs10.
rewrite /qstepR !Hq // ?De2c // ?(eqP Hx0E) //.
by rewrite /qstepR (eqP Hx0E) De2c De2m in Hs10 |- *.
Qed.

Lemma embedqz_rlinked : rlink_connected (setI ac hc).
Proof.
have Hq1: forall x a, fband a x ->
    rlink_connected (setI (fband a) hc) -> hc (node x) ->
    rlink_connected (setI (fband (add_last a (node x))) hc).
  move=> x a Hx Ha Hnx y z; rewrite {1 2}/setI -cats1 !fband_cat /= !orbF.
  have Henx: setI (fband a) hc (edge (node x)).
    by rewrite /setI (fclosed1 (fbandF a)) Enode Hx HhcE.
  case Hynx: (cface y (node x)).
    case Hznx: (cface z (node x)).
      move=> _ _; exists (Seq0 gc); last done.
      by rewrite /= /rlink Eface (same_cface Hynx) Sface andbT.
    rewrite orbF; move{Hznx} => _ Hz.
    case: {Ha}(Ha _ _ Henx Hz) => [p Hp Hap]; exists (Adds (node x) p).
      by move: Hp; rewrite Eedge /= {2}/rlink Eface Hynx.
    rewrite /= /setI fband_cat Hnx /= connect0 orbT.
    apply/allP => [t Ht]; rewrite fband_cat demorgan2; apply/orP; left.
    by apply: (allP Hap).
  case Hznx: (cface z (node x)) {Hynx}; rewrite !orbF.
    move=> Hy; case: {Ha}(Ha _ _ Hy Henx) => [p Hp Hap].
    exists (add_last p (edge (node x))).
      by rewrite -cats1 path_cat Hp last_add_last /= /rlink De2c Sface Hznx.
    apply/allP => [t Ht]; rewrite /setI fband_cat demorgan2; apply/orP; left.
    rewrite mem_add_last in Ht; case/setU1P: Ht => [<-|Ht] //.
    by apply: (allP Hap).
  move=> Hy Hz; case: {Ha}(Ha _ _ Hy Hz) => [p Hp Hap]; exists p; auto.
  apply/allP => [t Ht]; rewrite /setI fband_cat demorgan2; apply/orP; left.
  by apply: (allP Hap).
have Hq: forall x a q, fband a x -> fband a (edge x) -> all ac a ->
    rlink_connected (setI (fband a) hc) -> let s := walkq (node x) q in
    all (setI ac hc) s -> rlink_connected (setI (fband (cat a s)) hc).
  move=> x a q; elim: q x a => /=; try by move=> *; rewrite cats0.
  - by move=> _ x a Hx _ _ HaE; rewrite cats1 andbT; case/andP; auto.
  - move=> _ ql Hrec x a Hx Hex Ha HaE; case/andP; move/andP=> [Hnx HnxE] Hql.
    rewrite -cat_add_last /qstepL; apply Hrec; auto.
    + by rewrite -cats1 fband_cat /= cface1 Enode connect0 orbT.
    + rewrite De2c -2!(Enode gc (node (node _))) (Dn3c (Hacbc Hnx)) Enode.
      by rewrite -cats1 fband_cat -(fclosed1 (fbandF a)) Hex.
    by rewrite -cats1 all_cat Ha /= andbT.
  - move=> _ qr Hrec x a Hx _ Ha HaE; case/andP; move/andP=> [Hnx HnxE] Hqr.
    rewrite -cat_add_last /qstepR; apply Hrec; auto.
    + by rewrite -cats1 fband_cat (fclosed1 (fbandF a)) Enode Hx.
    + by rewrite De2c -cats1 fband_cat /= connect0 orbT.
    by rewrite -cats1 all_cat Ha /= andbT.
  - move=> _ ql Hrecl qr Hrecr x a Hx Hex Ha HaE; rewrite all_cat; case/and3P.
    move/andP=> [Hnx HnxE] Hql Hqr.
    rewrite -cat_add_last catA /qstepR; apply Hrecr; auto.
    + by rewrite cat_add_last fband_cat /= (fclosed1 (fbandF a)) Enode Hx.
    + by rewrite De2c cat_add_last fband_cat /= connect0 orbT.
    + rewrite cat_add_last all_cat Ha /= Hnx /=.
      by rewrite all_setI in Hql; case/andP: Hql.
    rewrite /qstepL; apply Hrecl; auto.
    + by rewrite -cats1 fband_cat /= cface1 Enode connect0 orbC.
    + rewrite De2c -2!(Enode gc (node (node _))) (Dn3c (Hacbc Hnx)) Enode.
      by rewrite -cats1 fband_cat -(fclosed1 (fbandF a)) Hex.
    by rewrite -cats1 all_cat Ha /= andbT.
  - move=> _ qll Hrec x a _ Hex Ha HaE; case/andP.
    move/andP=> [HneLnx HneLnxE] Hqll.
    have Hfex: ac (face (edge x)).
      case/hasP: Hex => [y Hy Hexy]; rewrite cface1 in Hexy.
      by rewrite (closed_connect HacF Hexy); apply (allP Ha).
    have Hffex: ac (face (face (edge x))) by rewrite -(fclosed1 HacF).
    have Dffex: node (qstepL (node x)) = face (face (edge x)).
      rewrite /qstepL -{1}[x]Eedge (Dn3c (Hacbc Hfex)).
      by rewrite -{1}[face (edge x)]Eface De2c (Dn3c (Hacbc Hffex)).
    rewrite -cat_add_last {2}/qstepL; apply Hrec; auto.
    + by rewrite -cats1 fband_cat /= connect0 orbT.
    + by rewrite De2c Dffex -cats1 fband_cat -!(fclosed1 (fbandF a)) /= Hex.
    + by rewrite -cats1 all_cat Ha /= andbT.
    rewrite Dffex -{1}[face (face (edge x))]Eface De2c; apply Hq1; auto.
      by rewrite -!(fclosed1 (fbandF a)).
    by rewrite -[face (face (edge x))]De2c Eedge -Dffex.
  move=> _ qrr Hrec x a Hx _ Ha HaE; case/andP; move/andP=> [HRnx HRnxE] Hqrr.
  have Henx: ac (edge (node x)).
    case/hasP: Hx => [y Hy Hxy]; rewrite -[x]Enode -cface1 in Hxy.
    by rewrite (closed_connect HacF Hxy); apply (allP Ha).
  rewrite -cat_add_last {2}/qstepR; apply Hrec; auto.
  - by rewrite 2!(fclosed1 (fbandF _)) /qstepR !Enode -cats1 fband_cat Hx.
  - by rewrite De2c -cats1 fband_cat /= connect0 orbT.
  - by rewrite -cats1 all_cat Ha /= andbT.
  by rewrite /qstepR; apply Hq1; auto; rewrite (fclosed1 (fbandF a)) Enode.
case: Hqzc => [Hqz _ _ Dac].
have Hs: all (setI ac hc) s0c.
  apply/allP => [y Hy].
  by rewrite /setI -Dac (embedqz_central Hy) (subsetP (ring_fband _) _ Hy).
move: Hqz Dac Hs; rewrite /s0c; case: qz => [q0 q1] /=; rewrite all_cat /=.
case: q0 => //= [_ q01]; case: q1 => //= [_ q10] _ Dac; case/and3P; case/andP.
move/andP=> [Hx0F Hx0E] Hq01; move/andP=> [Hx1F Hx1E] Hq10.
pose a := cat (seq2 x0c (edge x0c)) (walkq (qstepR x0c) q01).
pose a' := cat a (walkq (qstepR (edge x0c)) q10).
have Ha': rlink_connected (setI (fband a') hc).
  rewrite /a' /qstepR; apply Hq; auto; rewrite ?De2c.
  - by apply (subsetP (ring_fband a)); rewrite /a /= /setU1 set11.
  - by apply (subsetP (ring_fband a)); rewrite /a /= /setU1 set11 /= orbT.
  - apply/allP => [x Hx]; rewrite /= in Hx.
    by do 2 case/setU1P: Hx => [<-|Hx] //; case/andP: (allP Hq01 _ Hx).
  rewrite /a /qstepR; apply Hq; auto; rewrite ?De2c /= ?connect0 ?orbT //.
    by rewrite Hx0F Hx1F.
  rewrite /seq2 -cat1s cats1 -{2}[x0c]Eface De2c; apply Hq1; auto.
  - by rewrite /= Sface fconnect1.
  - move=> x y; rewrite /setI /= !orbF; move/andP=> [Hx _]; move/andP=> [Hy _].
    by exists (Seq0 gc); rewrite //= /rlink Eface (same_cface Hx) Sface andbT.
  by rewrite -{1}[x0c]De2c Eedge.
have Dac': ac =1 fband a'.
  move=> x; rewrite -Dac /fband /= !has_cat /=; congr orb.
  by rewrite !orbA; congr orb; rewrite orbC.
move=> x y Hx Hy; rewrite /setI !Dac' in Hx Hy.
case: (Ha' _ _ Hx Hy) => [p Hp Hpa]; exists p; first done.
by apply/allP => [z Hz]; rewrite /setI Dac'; apply: (allP Hpa).
Qed.

Lemma quiz_preembedding : preembedding ac h.
Proof.
split.
- exact embedqz_face.
- exact embedqz_arity.
- case: Hqzc => [_ _ _ Dac]; apply/subsetP => x; rewrite -Dac.
  move/hasP=> [y Hy Hxy]; apply/set0Pn; exists y; rewrite /setI Hxy.
  exact: embedqz_central.
exact embedqz_rlinked.
Qed.

End QuizEmbedding.

Unset Implicit Arguments.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(*****************************************************************************)
(*          Projet Coq - Calculus of Inductive Constructions V5.10           *)
(*****************************************************************************)
(*                                                                           *)
(*          Category Theory : Natural Transformations                        *)
(*                                                                           *)
(*          Amokrane Saibi May 1994                                          *)
(*                                                                           *)
(*****************************************************************************)

Require Export Functor.
Require Export Setoid_dup2.

Set Implicit Arguments.
Unset Strict Implicit.

(* Natural Transformations *)

Section nt_def.

Variables (C D : Category) (F G : Functor C D).

Definition NT_law (T : forall a : C, F a --> G a) :=
  forall (a b : C) (f : a --> b), FMor F f o T b =_S T a o FMor G f.

Structure > NT : Type :=
  {ApNT :> forall a : C, F a --> G a; Prf_NT_law :> NT_law ApNT}.

(*** rewrite rules ***)

Lemma NatCond :
 forall (T : NT) (a b : C) (f : a --> b), FMor F f o T b =_S T a o FMor G f.
Proof.
exact Prf_NT_law.
Qed.

Lemma NatCond1 :
 forall (T : NT) (a b : C) (f : a --> b), T a o FMor G f =_S FMor F f o T b.
Proof.
intros T a b f; apply Sym; apply (Prf_NT_law T f).
Qed.

(* *)

End nt_def.

(* Natural Transformations Setoid between F and G*)

Section setoid_nt.

Variables (C D : Category) (F G : Functor C D).

Definition Equal_NT (T T' : NT F G) := forall a : C, T a =_S T' a.

Lemma Equal_NT_equiv : Equivalence Equal_NT.
Proof.
apply Build_Equivalence; unfold Equal_NT in |- *.
unfold Reflexive in |- *; intros T a; apply Refl.
apply Build_Partial_equivalence.
unfold Transitive in |- *; intros T1 T2 T3 H H0 a.
(* *) apply Trans with (ApNT T2 a); auto.
unfold Symmetric in |- *; intros T1 T2 H a.
apply Sym; apply H.
Qed.

Canonical Structure NT_setoid : Setoid'' := Equal_NT_equiv.

End setoid_nt.

Infix "=_NT" := Equal_NT (at level 70).


Require Import VerdiRaft.Raft.

Section LastAppliedCommitIndexMatching.

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

  Definition lastApplied_commitIndex_match net :=
    forall h h' e,
      lastApplied (nwState net h') <= commitIndex (nwState net h) ->
      eIndex e <= lastApplied (nwState net h') ->
      In e (log (nwState net h')) <-> In e (log (nwState net h)).

  Definition commitIndex_lastApplied_match net :=
    forall h h' e,
      commitIndex (nwState net h') <= lastApplied (nwState net h) ->
      eIndex e <= commitIndex (nwState net h') ->
      In e (log (nwState net h')) <-> In e (log (nwState net h)).

  Definition lastApplied_lastApplied_match net :=
    forall h h' e,
      lastApplied (nwState net h') <= lastApplied (nwState net h) ->
      eIndex e <= lastApplied (nwState net h') ->
      In e (log (nwState net h')) <-> In e (log (nwState net h)).

  Class lastApplied_commitIndex_match_interface : Prop :=
    {
      lastApplied_commitIndex_match_invariant :
        forall net,
          raft_intermediate_reachable net ->
          lastApplied_commitIndex_match net;
      commitIndex_lastApplied_match_invariant :
        forall net,
          raft_intermediate_reachable net ->
          commitIndex_lastApplied_match net;
      lastApplied_lastApplied_match_invariant :
        forall net,
          raft_intermediate_reachable net ->
          lastApplied_lastApplied_match net
    }.

End LastAppliedCommitIndexMatching.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

(* Import SolidityNotations. *)
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
(*Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Debug.  *)
(* Set Typeclasses Unique Instances.
Unset Typeclasses Unique Solutions. *)

(* Existing Instance monadStateT.
Existing Instance monadStateStateT. *)
(* Module MultiSigWalletSpecSig := MultiSigWalletSpecSig XTypesSig StateMonadSig. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.
Require Import depoolContract.Lib.CommonStateProofs.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope solidity_scope.

(* Require Import MultiSigWallet.Specifications._validatelimit_inlineSpec.
Module _validatelimit_inlineSpec := _validatelimit_inlineSpec MultiSigWalletSpecSig.
Import _validatelimit_inlineSpec. *)

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

(* Opaque tvm_accept DePoolContract_Ф_checkPureDePoolBalance RoundsBase_Ф_getRound1. *)

Lemma ifSimpleState: forall X (b: bool) (f g: Ledger -> X * Ledger),
(if b then SimpleState f else SimpleState g ) =
SimpleState (if b then f else  g).
Proof.
  intros. destruct b; auto.
Qed.

Lemma ifFunApply: forall X (b: bool) (f g: Ledger -> X * Ledger) l,
(if b then f else  g ) l =
(if b then f l else g l).
Proof.
  intros. destruct b; auto.
Qed.

Lemma fstImplies : forall  X Y T (f: X*T) (g: X -> Y)  ,  (let (x, _) := f in g x) = g (fst f).
Proof.
  intros.
  destruct f; auto.
Qed.

Lemma sndImplies : forall  X Y T (f: X*T) (g: T -> Y)  ,  (let (_, t) := f in g t) = g (snd f).
Proof.
  intros.
  destruct f; auto.
Qed.

Lemma fstsndImplies : forall  X Y T (f: X*T) (g: X -> T -> Y)  ,  (let (x, t) := f in g x t) = g (fst f) (snd f).
Proof.
  intros.
  destruct f; auto.
Qed.

Ltac pr_numgoals := let n := numgoals in idtac "There are" n "goals".

(* function acceptRewardAndStartRoundCompleting(Round round2, uint64 value) private returns (Round) {
        uint64 effectiveStake = round2.stake - round2.unused;
        uint64 reward = value - effectiveStake;
        reward = cutDePoolReward(reward, round2);
        round2.rewards = math.muldiv(reward, m_participantRewardFraction, 100);
        round2.rewards -= math.min(round2.rewards, round2.participantQty * RET_OR_REINV_FEE);
        uint64 validatorReward = math.muldiv(reward, m_validatorRewardFraction, 100);
        if (validatorReward != 0)
            m_validatorWallet.transfer(validatorReward, false, 1);
        uint64 associationReward = math.muldiv(reward, m_associationRewardFraction, 100);
        if (associationReward != 0)
            m_association.transfer(associationReward, false, 1);
        round2 = startRoundCompleting(round2, CompletionReason.RewardIsReceived);
        return round2; }*)

Opaque DePoolContract_Ф_cutDePoolReward  DePoolContract_Ф_startRoundCompleting.

Opaque intMin.

Lemma DePoolContract_Ф_acceptRewardAndStartRoundCompleting_eval : forall ( Л_round2 : RoundsBase_ι_Round )
                                                                          ( Л_value : XInteger64 )
                                                                          (l: Ledger) ,
eval_state ( DePoolContract_Ф_acceptRewardAndStartRoundCompleting Л_round2 Л_value ) l =

let round2 := Л_round2 in
let effectiveStake := ( round2 ->> RoundsBase_ι_Round_ι_stake ) - ( round2 ->> RoundsBase_ι_Round_ι_unused ) in
let reward := Л_value - effectiveStake in
let round2 := {$ round2 with RoundsBase_ι_Round_ι_grossReward := reward $} in
let (reward, l_cutDePoolReward) := run ( ↓ ( DePoolContract_Ф_cutDePoolReward reward round2 ) ) l in
let newReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_participantRewardFraction ) l_cutDePoolReward ) / 100 in
let newReward' := newReward - (intMin newReward ((round2 ->> RoundsBase_ι_Round_ι_participantQty)*
                                                (eval_state ( ↑12 ε DePoolContract_ι_RET_OR_REINV_FEE ) l_cutDePoolReward )) ) in
let round2' := {$ round2 with RoundsBase_ι_Round_ι_rewards := newReward' $} in

let validatorReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_validatorRewardFraction ) l_cutDePoolReward ) / 100 in
let if1 : bool := ( negb ( validatorReward =? 0 ) ) in
let l1 := if if1 then exec_state (  tvm_transfer (  eval_state ( ↑2 ε ValidatorBase_ι_m_validatorWallet ) l_cutDePoolReward )
                                                validatorReward
                                                false
                                                 1
                                                default ) l_cutDePoolReward else l_cutDePoolReward in

let associationReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_associationRewardFraction ) l1 ) / 100  in
let if2 : bool := ( negb ( associationReward =? 0 ) ) in
let l2 := if if2 then exec_state (  tvm_transfer (  eval_state ( ↑12 ε DePoolContract_ι_m_association ) l1 )
                                                associationReward
                                                false
                                                1
                                                default ) l1 else l1 in
 eval_state ( ↓ ( DePoolContract_Ф_startRoundCompleting round2' RoundsBase_ι_CompletionReasonP_ι_RewardIsReceived ) ) l2.
 Proof.
  intros.
  destruct Л_round2.
  destruct l as
   (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState).
  destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState.

  compute. idtac.

  Time  repeat (

      time match goal with
        | |- ?x =>
          match x with
            | context [if ?b then _ else _] =>  idtac "if..." b;
                                              repeat rewrite ifSimpleState ;
                                              repeat rewrite ifFunApply ;
                                              case_eq b ; (* use case_eq to see destruction results *)
                                              simpl  ; intros
            | context  [match DePoolContract_Ф_cutDePoolReward ?a ?b
                                    with
                                    | SimpleState s => s
                                    end ?m] => idtac "found DePoolContract_Ф_cutDePoolReward ..."  a b ;
                                                let p := fresh"p" in
                                                destruct (DePoolContract_Ф_cutDePoolReward a b ) as (p);
                                                let v := fresh"v" in
                                                let l := fresh"l" in
                                                destruct (p m) as [v l];
                                                let Ledger_ι_DebugDePool := fresh "Ledger_ι_DebugDePool" in
                                                let Ledger_ι_ValidatorBase := fresh "Ledger_ι_ValidatorBase" in
                                                let Ledger_ι_ProxyBase := fresh "Ledger_ι_ProxyBase" in
                                                let Ledger_ι_ConfigParamsBase := fresh "Ledger_ι_ConfigParamsBase" in
                                                let Ledger_ι_ParticipantBase := fresh "Ledger_ι_ParticipantBase" in
                                                let Ledger_ι_DePoolHelper := fresh "Ledger_ι_DePoolHelper" in
                                                let Ledger_ι_Errors := fresh "Ledger_ι_Errors" in
                                                let Ledger_ι_InternalErrors := fresh "Ledger_ι_InternalErrors" in
                                                let Ledger_ι_DePoolLib := fresh "Ledger_ι_DePoolLib" in
                                                let Ledger_ι_DePoolProxyContract := fresh "Ledger_ι_DePoolProxyContract" in
                                                let Ledger_ι_RoundsBase := fresh "Ledger_ι_RoundsBase" in
                                                let Ledger_ι_DePoolContract := fresh "Ledger_ι_DePoolContract" in
                                                let Ledger_ι_DePool := fresh "Ledger_ι_DePool" in
                                                let Ledger_ι_Participant := fresh "Ledger_ι_Participant" in
                                                let Ledger_ι_TestElector := fresh "Ledger_ι_TestElector" in
                                                let Ledger_ι_VMState := fresh "Ledger_ι_VMState" in
                                                let Ledger_ι_LocalState := fresh "Ledger_ι_LocalState" in
                                                destruct l as
                                                (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                                              Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                                              Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                                              Ledger_ι_VMState, Ledger_ι_LocalState);
                                              destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                                              Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                                              Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                                              Ledger_ι_VMState, Ledger_ι_LocalState;
                                                (* destruct v ; *)
                                                simpl
            | context  [match DePoolContract_Ф_startRoundCompleting ?a ?b
                  with
                  | SimpleState s => s
                  end ?m] => idtac "found DePoolContract_Ф_startRoundCompleting ..."  a b;
                              let p := fresh"p" in
                              destruct (DePoolContract_Ф_startRoundCompleting a b) as (p);
                              let v := fresh"v" in
                              let l := fresh"l" in
                              destruct (p m) as [v l];
                              let Ledger_ι_DebugDePool := fresh "Ledger_ι_DebugDePool" in
                              let Ledger_ι_ValidatorBase := fresh "Ledger_ι_ValidatorBase" in
                              let Ledger_ι_ProxyBase := fresh "Ledger_ι_ProxyBase" in
                              let Ledger_ι_ConfigParamsBase := fresh "Ledger_ι_ConfigParamsBase" in
                              let Ledger_ι_ParticipantBase := fresh "Ledger_ι_ParticipantBase" in
                              let Ledger_ι_DePoolHelper := fresh "Ledger_ι_DePoolHelper" in
                              let Ledger_ι_Errors := fresh "Ledger_ι_Errors" in
                              let Ledger_ι_InternalErrors := fresh "Ledger_ι_InternalErrors" in
                              let Ledger_ι_DePoolLib := fresh "Ledger_ι_DePoolLib" in
                              let Ledger_ι_DePoolProxyContract := fresh "Ledger_ι_DePoolProxyContract" in
                              let Ledger_ι_RoundsBase := fresh "Ledger_ι_RoundsBase" in
                              let Ledger_ι_DePoolContract := fresh "Ledger_ι_DePoolContract" in
                              let Ledger_ι_DePool := fresh "Ledger_ι_DePool" in
                              let Ledger_ι_Participant := fresh "Ledger_ι_Participant" in
                              let Ledger_ι_TestElector := fresh "Ledger_ι_TestElector" in
                              let Ledger_ι_VMState := fresh "Ledger_ι_VMState" in
                              let Ledger_ι_LocalState := fresh "Ledger_ι_LocalState" in
                              destruct l as
                              (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                            Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                            Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                            Ledger_ι_VMState, Ledger_ι_LocalState);
                            destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                            Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                            Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                            Ledger_ι_VMState, Ledger_ι_LocalState;
                            (*  destruct v ; *)
                              simpl
            | _ =>  idtac "solving..." x; tryif solve [auto] then idtac "solved" else idtac "not solved"
          end
      end) .

      all: pr_numgoals.
 Qed.

Lemma DePoolContract_Ф_acceptRewardAndStartRoundCompleting_exec : forall ( Л_round2 : RoundsBase_ι_Round )
                                                                          ( Л_value : XInteger64 )
                                                                          (l: Ledger) ,
exec_state ( DePoolContract_Ф_acceptRewardAndStartRoundCompleting Л_round2 Л_value ) l =

let round2 := Л_round2 in
let effectiveStake := ( round2 ->> RoundsBase_ι_Round_ι_stake ) - ( round2 ->> RoundsBase_ι_Round_ι_unused ) in
let reward := Л_value - effectiveStake in
let round2 := {$ round2 with RoundsBase_ι_Round_ι_grossReward := reward $} in
let (reward, l_cutDePoolReward) := run ( ↓ ( DePoolContract_Ф_cutDePoolReward reward round2 ) ) l in
let newReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_participantRewardFraction ) l_cutDePoolReward ) / 100 in
let newReward' := newReward - (intMin newReward ((round2 ->> RoundsBase_ι_Round_ι_participantQty)*
                                                (eval_state ( ↑12 ε DePoolContract_ι_RET_OR_REINV_FEE ) l_cutDePoolReward )) ) in
let round2' := {$ round2 with RoundsBase_ι_Round_ι_rewards := newReward' $} in

let validatorReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_validatorRewardFraction ) l_cutDePoolReward ) / 100 in
let if1 : bool := ( negb ( validatorReward =? 0 ) ) in
let l1 := if if1 then exec_state (  tvm_transfer (  eval_state ( ↑2 ε ValidatorBase_ι_m_validatorWallet ) l_cutDePoolReward )
                                                validatorReward
                                                false
                                                 1
                                                default ) l_cutDePoolReward else l_cutDePoolReward in

let associationReward := reward * ( eval_state ( ↑12 ε DePoolContract_ι_m_associationRewardFraction ) l1 ) / 100  in
let if2 : bool := ( negb ( associationReward =? 0 ) ) in
let l2 := if if2 then exec_state (  tvm_transfer (  eval_state ( ↑12 ε DePoolContract_ι_m_association ) l1 )
                                                associationReward
                                                false
                                                1
                                                default ) l1 else l1 in
 exec_state ( ↓ ( DePoolContract_Ф_startRoundCompleting round2' RoundsBase_ι_CompletionReasonP_ι_RewardIsReceived ) ) l2.
 Proof.
  intros.
  destruct Л_round2.
  destruct l as
   (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState).
  destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
  Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
  Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
  Ledger_ι_VMState, Ledger_ι_LocalState.

  compute. idtac.

  Time  repeat (

      time match goal with
        | |- ?x =>
          match x with
            | context [if ?b then _ else _] =>  idtac "if..." b;
                                              repeat rewrite ifSimpleState ;
                                              repeat rewrite ifFunApply ;
                                              case_eq b ; (* use case_eq to see destruction results *)
                                              simpl  ; intros
            | context  [match DePoolContract_Ф_cutDePoolReward ?a ?b
                                    with
                                    | SimpleState s => s
                                    end ?m] => idtac "found DePoolContract_Ф_cutDePoolReward ..."  a b ;
                                                let p := fresh"p" in
                                                destruct (DePoolContract_Ф_cutDePoolReward a b ) as (p);
                                                let v := fresh"v" in
                                                let l := fresh"l" in
                                                destruct (p m) as [v l];
                                                let Ledger_ι_DebugDePool := fresh "Ledger_ι_DebugDePool" in
                                                let Ledger_ι_ValidatorBase := fresh "Ledger_ι_ValidatorBase" in
                                                let Ledger_ι_ProxyBase := fresh "Ledger_ι_ProxyBase" in
                                                let Ledger_ι_ConfigParamsBase := fresh "Ledger_ι_ConfigParamsBase" in
                                                let Ledger_ι_ParticipantBase := fresh "Ledger_ι_ParticipantBase" in
                                                let Ledger_ι_DePoolHelper := fresh "Ledger_ι_DePoolHelper" in
                                                let Ledger_ι_Errors := fresh "Ledger_ι_Errors" in
                                                let Ledger_ι_InternalErrors := fresh "Ledger_ι_InternalErrors" in
                                                let Ledger_ι_DePoolLib := fresh "Ledger_ι_DePoolLib" in
                                                let Ledger_ι_DePoolProxyContract := fresh "Ledger_ι_DePoolProxyContract" in
                                                let Ledger_ι_RoundsBase := fresh "Ledger_ι_RoundsBase" in
                                                let Ledger_ι_DePoolContract := fresh "Ledger_ι_DePoolContract" in
                                                let Ledger_ι_DePool := fresh "Ledger_ι_DePool" in
                                                let Ledger_ι_Participant := fresh "Ledger_ι_Participant" in
                                                let Ledger_ι_TestElector := fresh "Ledger_ι_TestElector" in
                                                let Ledger_ι_VMState := fresh "Ledger_ι_VMState" in
                                                let Ledger_ι_LocalState := fresh "Ledger_ι_LocalState" in
                                                destruct l as
                                                (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                                              Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                                              Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                                              Ledger_ι_VMState, Ledger_ι_LocalState);
                                              destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                                              Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                                              Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                                              Ledger_ι_VMState, Ledger_ι_LocalState;
                                                (* destruct v ; *)
                                                simpl
            | context  [match DePoolContract_Ф_startRoundCompleting ?a ?b
                  with
                  | SimpleState s => s
                  end ?m] => idtac "found DePoolContract_Ф_startRoundCompleting ..."  a b;
                              let p := fresh"p" in
                              destruct (DePoolContract_Ф_startRoundCompleting a b) as (p);
                              let v := fresh"v" in
                              let l := fresh"l" in
                              destruct (p m) as [v l];
                              let Ledger_ι_DebugDePool := fresh "Ledger_ι_DebugDePool" in
                              let Ledger_ι_ValidatorBase := fresh "Ledger_ι_ValidatorBase" in
                              let Ledger_ι_ProxyBase := fresh "Ledger_ι_ProxyBase" in
                              let Ledger_ι_ConfigParamsBase := fresh "Ledger_ι_ConfigParamsBase" in
                              let Ledger_ι_ParticipantBase := fresh "Ledger_ι_ParticipantBase" in
                              let Ledger_ι_DePoolHelper := fresh "Ledger_ι_DePoolHelper" in
                              let Ledger_ι_Errors := fresh "Ledger_ι_Errors" in
                              let Ledger_ι_InternalErrors := fresh "Ledger_ι_InternalErrors" in
                              let Ledger_ι_DePoolLib := fresh "Ledger_ι_DePoolLib" in
                              let Ledger_ι_DePoolProxyContract := fresh "Ledger_ι_DePoolProxyContract" in
                              let Ledger_ι_RoundsBase := fresh "Ledger_ι_RoundsBase" in
                              let Ledger_ι_DePoolContract := fresh "Ledger_ι_DePoolContract" in
                              let Ledger_ι_DePool := fresh "Ledger_ι_DePool" in
                              let Ledger_ι_Participant := fresh "Ledger_ι_Participant" in
                              let Ledger_ι_TestElector := fresh "Ledger_ι_TestElector" in
                              let Ledger_ι_VMState := fresh "Ledger_ι_VMState" in
                              let Ledger_ι_LocalState := fresh "Ledger_ι_LocalState" in
                              destruct l as
                              (Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                            Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                            Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                            Ledger_ι_VMState, Ledger_ι_LocalState);
                            destruct Ledger_ι_DebugDePool, Ledger_ι_ValidatorBase, Ledger_ι_ProxyBase, Ledger_ι_ConfigParamsBase, Ledger_ι_ParticipantBase,
                            Ledger_ι_DePoolHelper, Ledger_ι_Errors, Ledger_ι_InternalErrors, Ledger_ι_DePoolLib, Ledger_ι_DePoolProxyContract,
                            Ledger_ι_RoundsBase, Ledger_ι_DePoolContract, Ledger_ι_DePool, Ledger_ι_Participant, Ledger_ι_TestElector,
                            Ledger_ι_VMState, Ledger_ι_LocalState;
                            (*  destruct v ; *)
                              simpl
            | _ =>  idtac "solving..." x; tryif solve [auto] then idtac "solved" else idtac "not solved"
          end
      end) .

      all: pr_numgoals.
 Qed.


Require Import Coq.omega.Omega.
Require Import ExtLib.Core.RelDec.
Require Import ExtLib.Structures.Applicative.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Data.Option.
Require Import ExtLib.Data.Eq.
Require Import ExtLib.Tactics.
Require Import MirrorCore.TypesI.
Require Import MirrorCore.SymI.
Require Import MirrorCore.AbsAppI.
Require Import MirrorCore.Util.Forwardy.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.Lambda.ExprCore.
Require Import MirrorCore.Lambda.ExprD.

Set Implicit Arguments.
Set Strict Implicit.

Section raw_types.
  Context {typ func : Set}.

  Fixpoint lower (skip : nat) (_by : nat) (e : expr typ func) {struct e}
  : option (expr typ func) :=
    match e with
      | Var v => if v ?[ lt ] skip then Some (Var v)
                 else if (v - skip) ?[ lt ] _by then None
                      else Some (Var (v - _by))
      | Inj f => Some (Inj f)
      | UVar u => Some (UVar u)
      | App a b =>
        ap (ap (pure App) (lower skip _by a)) (lower skip _by b)
      | Abs t a =>
        ap (pure (Abs t)) (lower (S skip) _by a)
    end.

  Fixpoint lift (skip : nat) (_by : nat) (e : expr typ func) {struct e}
  : expr typ func :=
    match e with
      | Var v => Var (if v ?[ lt ] skip then v else (v + _by))
      | Inj f => Inj f
      | UVar u => UVar u
      | App a b =>
        App (lift skip _by a) (lift skip _by b)
      | Abs t a =>
        Abs t (lift (S skip) _by a)
    end.

End raw_types.

Section types.
  Context {typ : Set}.
  Context {func : Set}.
  Context {RType_typD : RType typ}.
  Context {Typ2_Fun : Typ2 RType_typD RFun}.
  Context {RSym_func : RSym func}.

  (** Reasoning principles **)
  Context {RTypeOk_typD : RTypeOk}.
  Context {Typ2Ok_Fun : Typ2Ok Typ2_Fun}.
  Context {RSymOk_func : RSymOk RSym_func}.

  Theorem typeof_expr_lower
  : forall tus e tvs tvs' tvs'' e',
      lower (length tvs) (length tvs') e = Some e' ->
      typeof_expr tus (tvs ++ tvs'') e' =
      typeof_expr tus (tvs ++ tvs' ++ tvs'') e.
  Proof using.
    intros tus e tvs tvs' tvs''; revert tvs.
    induction e; simpl; intros; simpl in *; forward; inv_all; subst; auto.
    { consider (v ?[ lt ] length tvs); intros; forward; inv_all; subst.
      { simpl.
        repeat rewrite ListNth.nth_error_app_L by omega. reflexivity. }
      { simpl.
        repeat rewrite ListNth.nth_error_app_R by omega.
        f_equal. omega. } }
    { eapply IHe1 in H. eapply IHe2 in H0.
      simpl. rewrite H0. rewrite H. reflexivity. }
    { simpl. specialize (IHe (t :: tvs)).
      simpl in *. eapply IHe in H.
      destruct H. reflexivity. }
  Qed.

  Theorem lambda_exprD_lower
  : forall tus tvs tvs' tvs'' e t val e',
      lower (length tvs) (length tvs') e = Some e' ->
      lambda_exprD tus (tvs ++ tvs' ++ tvs'') t e = Some val ->
      exists val',
        lambda_exprD tus (tvs ++ tvs'') t e' = Some val' /\
        forall us vs vs' vs'',
          val us (hlist_app vs (hlist_app vs' vs'')) =
          val' us (hlist_app vs vs'').
  Proof using RTypeOk_typD RSymOk_func Typ2Ok_Fun.
    intros tus tvs tvs' tvs'' e. revert tvs.
    induction e; simpl; intros;
    autorewrite with exprD_rw in *; simpl in *; forward; inv_all; subst.
    { consider (v ?[ lt ] length tvs); intros; forward.
      { inv_all; subst.
        autorewrite with exprD_rw. simpl.
        generalize (@nth_error_get_hlist_nth_appL _ typD (tvs' ++ tvs'') _ _ H).
        generalize (@nth_error_get_hlist_nth_appL _ typD tvs'' _ _ H).
        intros.
        forward_reason; Cases.rewrite_all_goal.
        rewrite H6 in *.
        inv_all. subst.
        destruct x0; destruct x1; simpl in *.
        rewrite H3 in *. rewrite H1 in *. inv_all; subst.
        simpl in *. rewrite H2. eexists; split; eauto.
        intros. simpl. rewrite H7. rewrite H5. reflexivity. }
      { inv_all; subst.
        autorewrite with exprD_rw. simpl.
        consider (nth_error_get_hlist_nth typD (tvs ++ tvs'') (v - length tvs')); intros.
        { destruct s.
          eapply nth_error_get_hlist_nth_appR in H1; [ simpl in * | omega ].
          destruct H1 as [ ? [ ? ? ] ].
          eapply nth_error_get_hlist_nth_appR in H1; [ simpl in * | omega ].
          eapply nth_error_get_hlist_nth_appR in H3; [ simpl in * | omega ].
          forward_reason.
          replace (v - length tvs' - length tvs)
             with (v - length tvs - length tvs') in H3 by omega.
          rewrite H1 in *. inv_all; subst. rewrite H2.
          eexists; split; eauto. intros.
          rewrite H4. rewrite H6. rewrite H5. reflexivity. }
        { exfalso.
          rewrite nth_error_get_hlist_nth_None in H3.
          eapply nth_error_get_hlist_nth_Some in H1. destruct H1. clear H1.
          simpl in *.
          repeat rewrite ListNth.nth_error_app_R in * by omega.
          replace (v - length tvs' - length tvs)
             with (v - length tvs - length tvs') in H3 by omega.
          congruence. } } }
    { autorewrite with exprD_rw. rewrite H0. simpl. eauto. }
    { autorewrite with exprD_rw.
      generalize H4.
      eapply typeof_expr_lower in H4; rewrite H4; clear H4.
      rewrite H0. simpl. intro.
      eapply IHe1 in H; eauto.
      eapply IHe2 in H4; eauto.
      forward_reason.
      Cases.rewrite_all_goal.
      eexists; split; eauto. intros.
      unfold AbsAppI.exprT_App.
      match goal with
        | |- match ?X with _ => _ end _ _ _ _ =
             match ?Y with _ => _ end _ _ _ _ =>
          change Y with X ; generalize X
      end; intros.
      autorewrite with eq_rw.
      clear - H4 H5. destruct e3; simpl.
      rewrite H5. rewrite H4. reflexivity. }
    { autorewrite with exprD_rw in *; simpl in *.
      destruct (typ2_match_case t0).
      { destruct H1 as [ ? [ ? [ ? ? ] ] ].
        rewrite H1 in *; clear H1.
        generalize dependent (typ2_cast x x0).
        destruct x1. simpl in *. intros.
        specialize (IHe (t :: tvs)). simpl in *.
        repeat first [ rewrite eq_option_eq in *
                     | rewrite eq_Const_eq in *
                     | rewrite eq_Arr_eq in * ].
        forward; inv_all; subst.
        eapply IHe in H2; eauto.
        forward_reason; Cases.rewrite_all_goal.
        simpl. eexists; split; eauto.
        intros. eapply FunctionalExtensionality.functional_extensionality.
        intros.
        specialize (H2 us (Hcons x2 vs)).
        simpl in H2. rewrite H2. reflexivity. }
      { rewrite H1 in *. congruence. } }
    { autorewrite with exprD_rw. rewrite H1. simpl.
      rewrite H2. eauto. }
  Qed.

  Theorem typeof_expr_lift
  : forall tus e tvs tvs' tvs'',
      typeof_expr tus (tvs ++ tvs' ++ tvs'') (lift (length tvs) (length tvs') e) =
      typeof_expr tus (tvs ++ tvs'') e.
  Proof using.
    intros tus e tvs; revert tvs; induction e; simpl; intros;
    Cases.rewrite_all_goal; auto.
    { consider (v ?[ lt ] length tvs); intros.
      { repeat rewrite ListNth.nth_error_app_L by auto.
        reflexivity. }
      { repeat rewrite ListNth.nth_error_app_R by omega.
        f_equal. omega. } }
    { specialize (IHe (t :: tvs)). simpl in *.
      rewrite IHe. reflexivity. }
  Qed.

  Theorem lambda_exprD_lift
  : forall tus e tvs tvs' tvs'' t,
      match lambda_exprD tus (tvs ++ tvs'') t e with
        | None => True
        | Some val =>
          match lambda_exprD tus (tvs ++ tvs' ++ tvs'') t (lift (length tvs) (length tvs') e) with
            | None => False
            | Some val' =>
              forall us vs vs' vs'',
                val us (hlist_app vs vs'') =
                val' us (hlist_app vs (hlist_app vs' vs''))
          end
      end.
  Proof using RTypeOk_typD RSymOk_func Typ2Ok_Fun.
    induction e; simpl; intros; autorewrite with exprD_rw; simpl;
    forward; inv_all; subst; Cases.rewrite_all_goal; auto.
    { consider (v ?[ lt ] length tvs); intros.
      { generalize (@nth_error_get_hlist_nth_appL _ typD (tvs' ++ tvs'') _ _ H).
        generalize (@nth_error_get_hlist_nth_appL _ typD tvs'' _ _ H).
        clear H. intros.
        forward_reason.
        revert H3. revert H0. Cases.rewrite_all_goal. destruct x1.
        intros; simpl in *. destruct x0; simpl in *.
        inv_all. subst.
        Cases.rewrite_all_goal.
        intros.
        rewrite H4. rewrite H6. reflexivity. }
      { eapply nth_error_get_hlist_nth_appR in H0; [ simpl in * | omega ].
        forward_reason.
        consider (nth_error_get_hlist_nth typD (tvs ++ tvs' ++ tvs'')
           (v + length tvs')); intros.
        { destruct s. forward.
          eapply nth_error_get_hlist_nth_appR in H3; [ simpl in * | omega ].
          forward_reason.
          eapply nth_error_get_hlist_nth_appR in H3; [ simpl in * | omega ].
          forward_reason.
          replace (v + length tvs' - length tvs - length tvs')
             with (v - length tvs) in H3 by omega.
          rewrite H0 in *. inv_all; subst.
          rewrite H1. congruence. }
        { rewrite nth_error_get_hlist_nth_None in H3.
          eapply nth_error_get_hlist_nth_Some in H0. destruct H0.
          clear H0. simpl in *.
          repeat rewrite ListNth.nth_error_app_R in H3 by omega.
          replace (v + length tvs' - length tvs - length tvs')
             with (v - length tvs) in H3 by omega.
          congruence. } } }
    { rewrite typeof_expr_lift. rewrite H.
      specialize (IHe1 tvs tvs' tvs'' (typ2 t0 t)).
      specialize (IHe2 tvs tvs' tvs'' t0).
      forward. inv_all. subst.
      unfold AbsAppI.exprT_App.
      autorewrite_with_eq_rw.
      rewrite <- IHe1. rewrite <- IHe2. reflexivity. }
    { destruct (typ2_match_case t0).
      { destruct H0 as [ ? [ ? [ ? ? ] ] ].
        rewrite H0 in *; clear H0.
        generalize dependent (typ2_cast x x0).
        destruct x1. simpl.
        intros. rewrite eq_option_eq in *.
        forward. inv_all; subst.
        specialize (IHe (t :: tvs) tvs' tvs'' x0).
        revert IHe. simpl. Cases.rewrite_all_goal.
        intros; forward.
        eapply FunctionalExtensionality.functional_extensionality.
        intros. eapply (IHe us (Hcons x1 vs)). }
      { rewrite H0 in *. congruence. } }
  Qed.

End types.


From iris.algebra Require Export ofe.
Set Default Proof Using "Type".

Section language_mixin.
  Context {expr val state : Type}.
  Context (of_val : val → expr).
  Context (to_val : expr → option val).
  Context (prim_step : expr → state → expr → state → list expr → Prop).

  Record LanguageMixin := {
    mixin_to_of_val v : to_val (of_val v) = Some v;
    mixin_of_to_val e v : to_val e = Some v → of_val v = e;
    mixin_val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None
  }.
End language_mixin.

Structure language := Language {
  expr : Type;
  val : Type;
  state : Type;
  of_val : val → expr;
  to_val : expr → option val;
  prim_step : expr → state → expr → state → list expr → Prop;
  language_mixin : LanguageMixin of_val to_val prim_step
}.
Delimit Scope expr_scope with E.
Delimit Scope val_scope with V.
Bind Scope expr_scope with expr.
Bind Scope val_scope with val.

Arguments Language {_ _ _ _ _ _} _.
Arguments of_val {_} _.
Arguments to_val {_} _.
Arguments prim_step {_} _ _ _ _ _.

Canonical Structure stateC Λ := leibnizC (state Λ).
Canonical Structure valC Λ := leibnizC (val Λ).
Canonical Structure exprC Λ := leibnizC (expr Λ).

Definition cfg (Λ : language) := (list (expr Λ) * state Λ)%type.

Class LanguageCtx {Λ : language} (K : expr Λ → expr Λ) := {
  fill_not_val e :
    to_val e = None → to_val (K e) = None;
  fill_step e1 σ1 e2 σ2 efs :
    prim_step e1 σ1 e2 σ2 efs →
    prim_step (K e1) σ1 (K e2) σ2 efs;
  fill_step_inv e1' σ1 e2 σ2 efs :
    to_val e1' = None → prim_step (K e1') σ1 e2 σ2 efs →
    ∃ e2', e2 = K e2' ∧ prim_step e1' σ1 e2' σ2 efs;
  fill_inj : Inj (=) (=) K;
}.

Instance language_ctx_id Λ : LanguageCtx (@id (expr Λ)).
Proof. constructor; try naive_solver. intros ???; auto. Qed.

Inductive atomicity := StronglyAtomic | WeaklyAtomic.

Section language.
  Context {Λ : language}.
  Implicit Types v : val Λ.
  Implicit Types e : expr Λ.

  Lemma to_of_val v : to_val (of_val v) = Some v.
  Proof. apply language_mixin. Qed.
  Lemma of_to_val e v : to_val e = Some v → of_val v = e.
  Proof. apply language_mixin. Qed.
  Lemma val_stuck e σ e' σ' efs : prim_step e σ e' σ' efs → to_val e = None.
  Proof. apply language_mixin. Qed.

  Definition reducible (e : expr Λ) (σ : state Λ) :=
    ∃ e' σ' efs, prim_step e σ e' σ' efs.
  Definition irreducible (e : expr Λ) (σ : state Λ) :=
    ∀ e' σ' efs, ¬prim_step e σ e' σ' efs.
  Definition stuck (e : expr Λ) (σ : state Λ) :=
    to_val e = None ∧ irreducible e σ.

  (* [Atomic WeaklyAtomic]: This (weak) form of atomicity is enough to open
     invariants when WP ensures safety, i.e., programs never can get stuck.  We
     have an example in lambdaRust of an expression that is atomic in this
     sense, but not in the stronger sense defined below, and we have to be able
     to open invariants around that expression.  See `CasStuckS` in
     [lambdaRust](https://gitlab.mpi-sws.org/FP/LambdaRust-coq/blob/master/theories/lang/lang.v).

     [Atomic StronglyAtomic]: To open invariants with a WP that does not ensure
     safety, we need a stronger form of atomicity.  With the above definition,
     in case `e` reduces to a stuck non-value, there is no proof that the
     invariants have been established again. *)
  Class Atomic (a : atomicity) (e : expr Λ) : Prop :=
    atomic σ e' σ' efs :
      prim_step e σ e' σ' efs →
      if a is WeaklyAtomic then irreducible e' σ' else is_Some (to_val e').

  Inductive step (ρ1 ρ2 : cfg Λ) : Prop :=
    | step_atomic e1 σ1 e2 σ2 efs t1 t2 :
       ρ1 = (t1 ++ e1 :: t2, σ1) →
       ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) →
       prim_step e1 σ1 e2 σ2 efs →
       step ρ1 ρ2.

  Inductive istep (i: nat) (ρ1 ρ2 : cfg Λ) : Prop :=
    | istep_atomic e1 σ1 e2 σ2 efs t1 t2 :
       ρ1 = (t1 ++ e1 :: t2, σ1) →
       ρ2 = (t1 ++ e2 :: t2 ++ efs, σ2) →
       prim_step e1 σ1 e2 σ2 efs →
       length t1 = i →
       istep i ρ1 ρ2.

  Lemma of_to_val_flip v e : of_val v = e → to_val e = Some v.
  Proof. intros <-. by rewrite to_of_val. Qed.

  Lemma not_reducible e σ : ¬reducible e σ ↔ irreducible e σ.
  Proof. unfold reducible, irreducible. naive_solver. Qed.
  Lemma reducible_not_val e σ : reducible e σ → to_val e = None.
  Proof. intros (?&?&?&?); eauto using val_stuck. Qed.
  Lemma val_irreducible e σ : is_Some (to_val e) → irreducible e σ.
  Proof. intros [??] ??? ?%val_stuck. by destruct (to_val e). Qed.
  Global Instance of_val_inj : Inj (=) (=) (@of_val Λ).
  Proof. by intros v v' Hv; apply (inj Some); rewrite -!to_of_val Hv. Qed.

  Lemma strongly_atomic_atomic e a :
    Atomic StronglyAtomic e → Atomic a e.
  Proof. unfold Atomic. destruct a; eauto using val_irreducible. Qed.

  Lemma reducible_fill `{LanguageCtx Λ K} e σ :
    to_val e = None → reducible (K e) σ → reducible e σ.
  Proof.
    intros ? (e'&σ'&efs&Hstep); unfold reducible.
    apply fill_step_inv in Hstep as (e2' & _ & Hstep); eauto.
  Qed.
  Lemma irreducible_fill `{LanguageCtx Λ K} e σ :
    to_val e = None → irreducible e σ → irreducible (K e) σ.
  Proof. rewrite -!not_reducible. naive_solver eauto using reducible_fill. Qed.

  Lemma step_Permutation (t1 t1' t2 : list (expr Λ)) σ1 σ2 :
    t1 ≡ₚ t1' → step (t1,σ1) (t2,σ2) → ∃ t2', t2 ≡ₚ t2' ∧ step (t1',σ1) (t2',σ2).
  Proof.
    intros Ht [e1 σ1' e2 σ2' efs tl tr ?? Hstep]; simplify_eq/=.
    move: Ht; rewrite -Permutation_middle (symmetry_iff (≡ₚ)).
    intros (tl'&tr'&->&Ht)%Permutation_cons_inv.
    exists (tl' ++ e2 :: tr' ++ efs); split; [|by econstructor].
    by rewrite -!Permutation_middle !assoc_L Ht.
  Qed.

  Class PureExec (P : Prop) (e1 e2 : expr Λ) := {
    pure_exec_safe σ :
      P → reducible e1 σ;
    pure_exec_puredet σ1 e2' σ2 efs :
      P → prim_step e1 σ1 e2' σ2 efs → σ1 = σ2 ∧ e2 = e2' ∧ efs = [];
  }.

  Lemma hoist_pred_pure_exec (P : Prop) (e1 e2 : expr Λ) :
    (P → PureExec True e1 e2) →
    PureExec P e1 e2.
  Proof. intros HPE. split; intros; eapply HPE; eauto. Qed.

  (* We do not make this an instance because it is awfully general. *)
  Lemma pure_exec_ctx K `{LanguageCtx Λ K} e1 e2 φ :
    PureExec φ e1 e2 →
    PureExec φ (K e1) (K e2).
  Proof.
    intros [Hred Hstep]. split.
    - unfold reducible in *. naive_solver eauto using fill_step.
    - intros σ1 e2' σ2 efs ? Hpstep.
      destruct (fill_step_inv e1 σ1 e2' σ2 efs) as (e2'' & -> & ?); [|exact Hpstep|].
      + destruct (Hred σ1) as (? & ? & ? & ?); eauto using val_stuck.
      + edestruct (Hstep σ1 e2'' σ2 efs) as (-> & -> & ->); auto.
  Qed.

  (* This is a family of frequent assumptions for PureExec *)
  Class IntoVal (e : expr Λ) (v : val Λ) :=
    into_val : to_val e = Some v.

  Class AsVal (e : expr Λ) := as_val : is_Some (to_val e).
  (* There is no instance [IntoVal → AsVal] as often one can solve [AsVal] more
  efficiently since no witness has to be computed. *)
  Global Instance as_vals_of_val vs : TCForall AsVal (of_val <$> vs).
  Proof.
    apply TCForall_Forall, Forall_fmap, Forall_true=> v.
    rewrite /AsVal /= to_of_val; eauto.
  Qed.
End language.


Require Stacklayout.

Import Coqlib.
Import Integers.
Import AST.
Import Values.
Import Memory.
Import Locations.

(* Free all argument memory locations to consider the
   semantics of the C-style primitive being implemented
   and compiled in a C-style context
*)

Section WITHMEMORYMODEL.
Context `{memory_model: Mem.MemoryModel}.

Definition free_extcall_arg sp m e :=
  match e with
    | S Outgoing ofs ty =>
      match sp with
        | Vptr b o =>
          let of :=(Ptrofs.unsigned (Ptrofs.add o (Ptrofs.repr (Stacklayout.fe_ofs_arg + 4 * ofs)))) in
          Mem.free m b of (of + size_chunk (chunk_of_type ty))
        | _ => None
      end
    | _ => Some m (* provide for other calling conventions *)
  end.

Fixpoint free_extcall_args sp m l :=
  match l with
    | nil => Some m
    | e :: l' =>
      match free_extcall_arg sp m e with
        | Some m' =>
          free_extcall_args sp m' l'
        | _ => None
      end
  end.

Lemma free_extcall_arg_extends  sp m e m':
  free_extcall_arg sp m e = Some m' ->
  Mem.extends m' m.
Proof.
  destruct e.
  {
    simpl.
    inversion 1; subst.
    apply Mem.extends_refl.
  }
  unfold free_extcall_arg.
  destruct sl; try discriminate.
  { inversion 1; subst; apply Mem.extends_refl. }
  { inversion 1; subst; apply Mem.extends_refl. }
  destruct sp; try discriminate.
  intros. eapply Mem.free_left_extends; eauto.
  apply Mem.extends_refl.
Qed.

Corollary free_extcall_args_extends sp l:
  forall m m',
  free_extcall_args sp m l = Some m' ->
  Mem.extends m' m.
Proof.
  induction l; simpl.
  {
    inversion 1; subst.
    apply Mem.extends_refl.
  }
  intros m m' H.
  destruct (free_extcall_arg sp m a) eqn:FREE ; try discriminate.
  eapply Mem.extends_extends_compose; eauto.
  eapply free_extcall_arg_extends; eauto.
Qed.

Lemma free_extcall_args_parallel_extends sp sp_
      (LESSDEF: Val.lessdef sp sp_)
      l:
  forall m m',
    free_extcall_args sp m l = Some m' ->
    forall m_,
      Mem.extends m m_ ->
      exists m'_,
        free_extcall_args sp_ m_ l = Some m'_ /\
        Mem.extends m' m'_.
Proof.
  induction l; simpl.
  {
    inversion 1; subst; eauto.
  }
  unfold free_extcall_arg.
  destruct a; auto.
  destruct sl; auto.
  destruct sp; try discriminate.
  inversion LESSDEF; subst.
  set (o := Ptrofs.unsigned
              (Ptrofs.add i (Ptrofs.repr (Stacklayout.fe_ofs_arg + 4 * pos)))).
  intros m m' H m_ H0.
  destruct (Mem.free m b o (o + size_chunk (chunk_of_type ty))) eqn:FREE; try discriminate.
  exploit Mem.free_parallel_extends; eauto.
  destruct 1 as (? & FREE_ & EXT).
  rewrite FREE_.
  eauto.
Qed.

End WITHMEMORYMODEL.


From iris.bi Require Export bi plainly.
From iris.proofmode Require Import tactics.
From iris Require Import options.
Import bi.

(** The "core" of an assertion is its maximal persistent part,
    i.e. the conjunction of all persistent assertions that are weaker
    than P (as in, implied by P). *)
Definition coreP `{!BiPlainly PROP} (P : PROP) : PROP :=
  (* TODO: Looks like we want notation for affinely-plainly; that lets us avoid
  using conjunction/implication here. *)
  (∀ Q : PROP, <affine> ■ (Q -∗ <pers> Q) -∗ <affine> ■ (P -∗ Q) -∗ Q)%I.
Instance: Params (@coreP) 1 := {}.
Typeclasses Opaque coreP.

Section core.
  Context `{!BiPlainly PROP}.
  Implicit Types P Q : PROP.

  Lemma coreP_intro P : P -∗ coreP P.
  Proof.
    rewrite /coreP. iIntros "HP" (Q) "_ HPQ".
    (* FIXME: Cannot apply HPQ directly. This works if we move it to the
    persistent context, but why should we? *)
    iDestruct (affinely_plainly_elim with "HPQ") as "HPQ".
    by iApply "HPQ".
  Qed.

  Global Instance coreP_persistent P : Persistent (coreP P).
  Proof.
    rewrite /coreP /Persistent. iIntros "HC" (Q).
    iApply persistently_wand_affinely_plainly. iIntros "#HQ".
    iApply persistently_wand_affinely_plainly. iIntros "#HPQ".
    iApply "HQ". iApply "HC"; auto.
  Qed.
  Global Instance coreP_affine P : Affine P → Affine (coreP P).
  Proof. intros ?. rewrite /coreP /Affine. iIntros "HC". iApply "HC"; eauto. Qed.

  Global Instance coreP_ne : NonExpansive (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.
  Global Instance coreP_proper : Proper ((⊣⊢) ==> (⊣⊢)) (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.

  Global Instance coreP_mono : Proper ((⊢) ==> (⊢)) (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.
  Global Instance coreP_flip_mono :
    Proper (flip (⊢) ==> flip (⊢)) (coreP (PROP:=PROP)).
  Proof. solve_proper. Qed.

  Lemma coreP_wand P Q : <affine> ■ (P -∗ Q) -∗ coreP P -∗ coreP Q.
  Proof.
    rewrite /coreP. iIntros "#HPQ HP" (R) "#HR #HQR". iApply ("HP" with "HR").
    iIntros "!> !> HP". iApply "HQR". by iApply "HPQ".
  Qed.

  Lemma coreP_elim P : Persistent P → coreP P -∗ P.
  Proof. rewrite /coreP. iIntros (?) "HCP". iApply "HCP"; auto. Qed.

  (** The [<affine>] modality is needed for general BIs:
  - The right-to-left direction corresponds to elimination of [<pers>], which
    cannot be done without [<affine>].
  - The left-to-right direction corresponds the introduction of [<pers>]. The
    [<affine>] modality makes it stronger since it appears in the LHS of the
    [⊢] in the premise. As a user, you have to prove [<affine> coreP P ⊢ Q],
    which is weaker than [coreP P ⊢ Q]. *)
  Lemma coreP_entails P Q : (<affine> coreP P ⊢ Q) ↔ (P ⊢ <pers> Q).
  Proof.
    split.
    - iIntros (HP) "HP". iDestruct (coreP_intro with "HP") as "#HcP {HP}".
      iIntros "!>". by iApply HP.
    - iIntros (->) "HcQ". by iDestruct (coreP_elim with "HcQ") as "#HQ".
  Qed.
  (** A more convenient variant of the above lemma for affine [P]. *)
  Lemma coreP_entails' P Q `{!Affine P} : (coreP P ⊢ Q) ↔ (P ⊢ □ Q).
  Proof.
    rewrite -(affine_affinely (coreP P)) coreP_entails. split.
    - rewrite -{2}(affine_affinely P). by intros ->.
    - intros ->. apply affinely_elim.
  Qed.
End core.