Require Import ExtLib.Structures.Traversable.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.
Require Import MirrorCore.Util.Compat.
Require Import MirrorCore.ExprI.
Require Import MirrorCore.ExprDAs.
Require Import MirrorCore.SubstI.
Require Import MirrorCore.VariablesI.
Require Import MirrorCore.UnifyI.
Require Import MirrorCore.VarsToUVars.
Require Import MirrorCore.Lemma.

Set Implicit Arguments.
Set Strict Implicit.

Lemma Forall_iff : forall {T} (P : T -> Prop) a b,
    Forall P (a :: b) <-> (P a /\ Forall P b).
Proof. clear. split.
       - inversion 1; auto.
       - constructor; tauto.
Qed.
Lemma and_split_iff : forall (P Q R S : Prop),
    (P <-> R) -> (Q <-> S) ->
    ((P /\ Q) <-> (R /\ S)).
Proof. clear. tauto. Qed.

Section lemma_apply.
  Variable typ : Set.
  Variable expr : Set.
  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Expr_expr : Expr _ expr}.
  Context {ExprOk_expr : ExprOk Expr_expr}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Let tyProp : typ := @typ0 _ _ _ _.
  Context {subst : Type}.
  Context {ExprUVar_expr : ExprUVar expr}.
  Context {ExprUVarOk_expr : ExprUVarOk ExprUVar_expr}.
  Context {Subst_subst : Subst subst expr}.
  Context {SubstOk_subst : SubstOk subst typ expr}.
  (** TODO: Ideally I wouldn't need these things, but they are necessary b/c of
   ** where [substR] fits into things
   **)
  Context {SubstUpdate_subst : SubstUpdate subst expr}.
  Context {SubstUpdateOk_subst : SubstUpdateOk subst typ expr}.

  Variable unify : unifier typ expr subst.

  Hypothesis Hunify : unify_sound unify.

  Definition eapplicable (s : subst) (tus tvs : EnvI.tenv typ)
             (lem : lemma typ expr expr) (e : expr)
  : option subst :=
    let pattern := vars_to_uvars 0 (length tus) lem.(concl) in
    unify (tus ++ lem.(vars)) tvs 0 pattern e tyProp s.

  Ltac fill_holes :=
    let is_prop P := match type of P with
                       | Prop => idtac
                       | _ => fail
                     end
    in
    repeat match goal with
             | |- _ => progress intros
             | H : exists x , _ |- _ => destruct H
             | H : _ /\ _ |- _ => destruct H
             | |- exists x, _ /\ _ =>
               eexists; split; [ solve [ eauto ] | ]
             | |- _ /\ _ =>
               (split; eauto); [ ]
             | [ H : _ -> _ , H' : ?P |- _ ] =>
               is_prop P ;
                 specialize (H H')
             | [ H : forall x, @?X x -> _ , H' : ?P |- _ ] =>
               is_prop P ;
                 specialize (@H _ H')
             | [ H : forall x y, @?X x y -> _ , H' : ?P |- _ ] =>
               is_prop P ;
                 first [ specialize (@H _ _ H')
                       | specialize (fun y => @H _ y H')
                       | specialize (fun x => @H x _ H')
                       | specialize (@H _ _ eq_refl)
                       | specialize (fun y => @H _ y eq_refl)
                       | specialize (fun x => @H x _ eq_refl)
                       ]
             | [ H : forall x y z, @?X x y z -> _ , H' : ?P |- _ ] =>
               is_prop P ;
                 first [ specialize (@H _ _ _ H')
                       | specialize (fun x => @H x _ _ H')
                       | specialize (fun y => @H _ y _ H')
                       | specialize (fun z => @H _ _ z H')
                       | specialize (fun x y => @H x y _ H')
                       | specialize (fun y z => @H _ y z H')
                       | specialize (fun x z => @H x _ z H')
                       | specialize (@H _ _ _ eq_refl)
                       | specialize (fun x => @H x _ _ eq_refl)
                       | specialize (fun y => @H _ y _ eq_refl)
                       | specialize (fun z => @H _ _ z eq_refl)
                       | specialize (fun x y => @H x y _ eq_refl)
                       | specialize (fun y z => @H _ y z eq_refl)
                       | specialize (fun x z => @H x _ z eq_refl)
                       ]
             | [ H : forall x y z a, @?X x y z a -> _ , H' : ?P |- _ ] =>
               is_prop P ;
                 first [ specialize (@H _ _ _ _ H')
                       | specialize (fun x => @H x _ _ _ H')
                       | specialize (fun y => @H _ y _ _ H')
                       | specialize (fun z => @H _ _ z _ H')
                       | specialize (fun a => @H _ _ _ a H')
                       | specialize (fun x y => @H x y _ _ H')
                       | specialize (fun y z => @H _ y z _ H')
                       | specialize (fun z a => @H _ _ z a H')
                       | specialize (fun x a => @H x _ _ a H')
                       | specialize (fun x y z => @H x y z _ H')
                       | specialize (fun y z a => @H _ y z a H')
                       | specialize (fun x z a => @H x _ z a H')
                       | specialize (fun x y a => @H x y _ a H')
                       | specialize (fun x => @H x _ _ _ eq_refl)
                       | specialize (fun y => @H _ y _ _ eq_refl)
                       | specialize (fun z => @H _ _ z _ eq_refl)
                       | specialize (fun a => @H _ _ _ a eq_refl)
                       | specialize (fun x y => @H x y _ _ eq_refl)
                       | specialize (fun y z => @H _ y z _ eq_refl)
                       | specialize (fun z a => @H _ _ z a eq_refl)
                       | specialize (fun x a => @H x _ _ a eq_refl)
                       | specialize (fun x y z => @H x y z _ eq_refl)
                       | specialize (fun y z a => @H _ y z a eq_refl)
                       | specialize (fun x z a => @H x _ z a eq_refl)
                       | specialize (fun x y a => @H x y _ a eq_refl)
                       ]
           end.

  Lemma eapplicable_sound'
  : forall s tus tvs lem g s1,
      eapplicable s tus tvs lem g = Some s1 ->
      WellFormed_subst s ->
      WellFormed_subst s1 /\
      forall sD (gD : exprT _ _ Prop),
        (@lemmaD _ _ _ _ _ (exprD_typ0 (T:=Prop)) _ nil nil lem) ->
        substD (tus ++ lem.(vars)) tvs s = Some sD ->
        exprD_typ0 (tus ++ lem.(vars)) tvs g = Some gD ->
        exists s1D (pDs : list (exprT _ _ Prop)),
          substR (tus ++ lem.(vars)) tvs s s1 /\
          substD (tus ++ lem.(vars)) tvs s1 = Some s1D /\
          mapT (fun e => exprD_typ0 (tus ++ lem.(vars)) tvs (vars_to_uvars 0 (length tus) e)) lem.(premises) = Some pDs /\
          forall (us : hlist _ tus) (us' : hlist _ lem.(vars)) (vs : hlist _ tvs),
            s1D (hlist_app us us') vs ->
            (Forall (fun pD => pD (hlist_app us us') vs) pDs -> gD (hlist_app us us') vs)
            /\ sD (hlist_app us us') vs.
  Proof.
    unfold eapplicable. intros.
    eapply (@Hunify (tus ++ vars lem) tvs _ _ _ _ _ nil) in H; auto.
    forward_reason.
    split; eauto.

    simpl in *. intros.
    unfold exprD_typ0 in H4; forward.
    inv_all; subst.
    specialize (fun v1 Hv1 => @H1 v1 _ _ Hv1 H4 H3).

    unfold lemmaD in H2. simpl in H2.
    forward.
    eapply lemmaD'_weakenU in H2; eauto.
    { revert H2. instantiate (1 := tus). simpl. intro.
      destruct H2 as [ ? [ ? ? ] ].
      unfold lemmaD' in H2. forward; inv_all; subst.
      rewrite exprD_typ0_conv
         with (pfu := eq_refl) (pfv := eq_sym (app_nil_r_trans lem.(vars))) in H7.
      autorewrite_with_eq_rw_in H7.
      unfold exprD_typ0 in H7. forward; inv_all; subst.
      eapply (@vars_to_uvars_sound _ _ _ _ _ _ _ _ tus (concl lem) nil tyProp) in H7; eauto.
      simpl in H7. forward_reason.
      eapply exprD_weakenV with (tvs' := tvs) in H7; eauto.
      forward_reason.
      specialize (H1 _ H7).
      forward_reason.
      assert (exists pDs,
                List.mapT_list (F:=option)
                  (fun e1 : expr =>
                     exprD_typ0 (tus ++ vars lem) tvs (vars_to_uvars 0 (length tus) e1))
                  (premises lem) = Some pDs /\
                forall us vs vs',
                  Forall (fun p => p (hlist_app us vs') vs) pDs <-> Forall (fun p => p us (hlist_app vs' Hnil)) l).
      { clear - H2 ExprOk_expr RTypeOk_typ ExprUVarOk_expr.
        revert l H2. induction (premises lem); simpl; intros; inv_all; subst.
        + eexists; split; [ reflexivity | intuition; constructor ].
        + forward; inv_all; subst.
          eapply IHl in H0; clear IHl.
          rewrite exprD_typ0_conv
             with (pfu := eq_refl) (pfv := eq_sym (app_nil_r_trans _)) in H.
          autorewrite_with_eq_rw_in H.
          forward.
          unfold exprD_typ0 in H.
          forward.
          change (vars lem) with (nil ++ vars lem) in H.
          eapply vars_to_uvars_sound in H; eauto with typeclass_instances.
          simpl in H. forward_reason.
          eapply exprD_weakenV with (tvs' := tvs) in H; eauto.
          forward_reason.
          unfold exprD_typ0.
          change_rewrite H.
          change_rewrite H0.
          eexists; split; [ reflexivity | ].
          inv_all; subst.
          intros. autorewrite with eq_rw.
          do 2 rewrite Forall_iff.
          eapply and_split_iff; eauto.
          { specialize (H5 (hlist_app us vs') Hnil vs).
            simpl in *.
            rewrite <- H5; clear H5.
            rewrite <- H3; clear H3.
            simpl. rewrite hlist_app_nil_r.
            clear.
            generalize dependent (app_nil_r_trans (vars lem)).
            generalize dependent (vars lem ++ nil).
            intros; subst. reflexivity. } }
      forward_reason.
      do 2 eexists; split; eauto.
      split; eauto.
      split; eauto.
      intros.
      eapply H11 in H14; clear H11.
      clear - H14 H13 H12 H6 H9 H8 H5.
      destruct H14.
      repeat match goal with
               | H : _ , H' : _ |- _ =>
                 first [ specialize (H H') | specialize (H Hnil) ]
             end.
      rewrite H13; clear H13.
      split; auto.
      intros. autorewrite with eq_rw.
      simpl in *. rewrite <- H0; clear H0.
      specialize (H9 (hlist_app us us') Hnil vs).
      simpl in *. rewrite <- H9; clear H9.
      rewrite <- H8; clear H8.
      eapply H6 in H5; clear H6.
      rewrite foralls_sem in H5.
      specialize (H5 us').
      eapply impls_sem in H5.
      { revert H5.
        autorewrite with eq_rw.
        rewrite hlist_app_nil_r.
        generalize (app_nil_r_trans (vars lem)).
        generalize (vars lem ++ nil). intros; subst. eapply H5. }
      { rewrite List.Forall_map. assumption. } }
    { clear - ExprOk_expr.
      intros. eapply exprD_typ0_weaken in H.
      destruct H. exists x.
      forward_reason; split; eauto.
      intros. rewrite <- H0. reflexivity. }
  Qed.

End lemma_apply.


(** Type syntax:

 Simple types with a Unit type, the functional arrow and a reference type
 to distinguish pure terms from terms with references.

*)

Inductive Ty: Set :=
  | Unit : Ty
  | Arr  : Ty -> Ty -> Ty
  | Ref : Ty -> Ty
.

Notation "A ⇒  B" := (Arr A B) (at level 17, right associativity).


From QuickChick Require Import QuickChick.
From Coq Require Import List String ExtrOcamlNatInt.
Import ListNotations.

Local Instance this_section : Mutant.section := "test"%string.

Definition prop_example :=
  let x := 10 mutant! 20 in
  let y := 1 mutant: "foo" 2 mutant! 3 mutant: "bar" 4 in
  whenFail (show x ++ " + " ++ show y ++ " <> 11")%string
           (x + y = 11 ?).

Definition main := runTests [
  qc "example" prop_example
].

Extraction "mutation.ml" main.


Require Export Coq.Lists.List. Export ListNotations.
Require Export Coq.ZArith.ZArith. Open Scope Z_scope.
Require Export coqutil.Word.Interface coqutil.Word.Properties.
Require Export coqutil.Map.Interface coqutil.Map.Properties.
Require Import coqutil.Tactics.rdelta coqutil.Tactics.destr coqutil.Decidable.
Require Import coqutil.Tactics.rewr coqutil.Tactics.Tactics.
Require Export coqutil.Z.Lia.
Require Export coqutil.Datatypes.PropSet.
Require Export bedrock2.Lift1Prop.
Require Export bedrock2.Map.Separation.
Require Export bedrock2.Map.SeparationLogic.
Require Export bedrock2.Array.
Require Export bedrock2.Scalars.
Require Export bedrock2.ptsto_bytes.
Require Export coqutil.Word.SimplWordExpr.
Require Export bedrock2.SepLogAddrArith.
Require Import coqutil.Tactics.Simp.
Require Export riscv.Utility.Utility.
Require Import riscv.Utility.Encode.
Require Import riscv.Spec.Decode.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Logic.PropExtensionality.

Declare Scope sep_scope.

Infix "*" := sep : sep_scope.

Delimit Scope sep_scope with sep.
Arguments impl1 {T} (_)%sep (_)%sep.
Arguments iff1 {T} (_)%sep (_)%sep.

(* TODO does not get rid of %sep in printing as intended *)
Arguments sep {key} {value} {map} (_)%sep (_)%sep.

Definition bytes_per_word{width}{BW: Bitwidth width}: Z := Memory.bytes_per_word width.

Section ptstos.
  Context {width} {BW: Bitwidth width} {word: word.word width} {word_ok: word.ok word}.
  Context {mem : map.map word byte} {mem_ok: map.ok mem}.
  Context (iset: InstructionSet).

  Definition word_array: word -> list word -> mem -> Prop :=
    array ptsto_word (word.of_Z bytes_per_word).

  (* we use InvalidInstruction to put data into the instruction memory, so we have
     to allow them, but make sure that they can be represented with 32 bits *)
  Definition valid_InvalidInstruction(instr: Instruction): Prop :=
    exists n, 0 <= n < 2 ^ 32 /\ instr = InvalidInstruction n.

  (* contains all the conditions needed to successfully execute instr, except
     that addr needs to be in the set of executable addresses, which is dealt with elsewhere *)
  Definition ptsto_instr(addr: word)(instr: Instruction): mem -> Prop :=
    (truncated_scalar Syntax.access_size.four addr (encode instr) *
     emp (verify instr iset \/ valid_InvalidInstruction instr) *
     emp ((word.unsigned addr) mod 4 = 0))%sep.

  Definition program(addr: word)(prog: list Instruction): mem -> Prop :=
    array ptsto_instr (word.of_Z 4) addr prog.

  Lemma invert_ptsto_instr: forall {addr instr R m},
    (ptsto_instr addr instr * R)%sep m ->
     (verify instr iset \/ valid_InvalidInstruction instr) /\
     (word.unsigned addr) mod 4 = 0.
  Proof.
    intros.
    unfold array, ptsto_instr in *.
    lazymatch goal with
    | H: (?T * ?P1 * ?P2 * R)%sep ?m |- _ =>
      assert ((T * R * P1 * P2)%sep m) as A by ecancel_assumption; clear H
    end.
    do 2 (apply sep_emp_r in A; destruct A as [A ?]).
    auto.
  Qed.

  Lemma invert_ptsto_program1: forall {addr instr R m},
    (program addr [instr] * R)%sep m ->
     (verify instr iset \/ valid_InvalidInstruction instr) /\
     (word.unsigned addr) mod 4 = 0.
  Proof.
    unfold program. intros. simpl in *. eapply invert_ptsto_instr.
    ecancel_assumption.
  Qed.

  Lemma cast_word_array_to_bytes bs (addr : word) : iff1
    (array ptsto_word (word.of_Z bytes_per_word) addr bs)
    (array ptsto (word.of_Z 1) addr (flat_map (fun x =>
       (LittleEndianList.le_split (Z.to_nat bytes_per_word) (word.unsigned x)))
          bs)).
  Proof.
    revert addr; induction bs; intros; [reflexivity|].
    cbn [array flat_map].
    etransitivity. 1:eapply Proper_sep_iff1; [reflexivity|]. 1:eapply IHbs.
    etransitivity. 2:symmetry; eapply bytearray_append.
    eapply Proper_sep_iff1.
    { unfold scalar, truncated_word, truncated_scalar, littleendian, ptsto_bytes.
      rewrite HList.tuple.to_list_of_list. reflexivity. }
    assert (0 < bytes_per_word). { (* TODO: deduplicate *)
      unfold bytes_per_word; simpl; destruct width_cases as [EE | EE]; rewrite EE; cbv; trivial.
    }
    Morphisms.f_equiv.
    Morphisms.f_equiv.
    Morphisms.f_equiv.
    simpl.
    rewrite LittleEndianList.length_le_split.
    rewrite Z2Nat.id; blia.
  Qed.

  Lemma putmany_of_footprint_None: forall n (vs: HList.tuple byte n) (addr: word) (z: Z) (m: mem),
      0 < z ->
      z + Z.of_nat n <= 2 ^ width ->
      map.get m addr = None ->
      map.get (map.putmany_of_tuple (Memory.footprint (word.add addr (word.of_Z z)) n) vs m)
              addr = None.
  Proof.
    induction n; intros.
    - simpl. assumption.
    - destruct vs as [v vs]. simpl.
      assert (2 ^ width > 0) as Gz. {
        destruct width_cases as [E | E]; rewrite E; reflexivity.
      }
      rewrite map.get_put_diff; cycle 1. {
        intro C.
        apply (f_equal word.unsigned) in C.
        rewrite word.unsigned_add in C. unfold word.wrap in C.
        rewrite word.unsigned_of_Z in C. unfold word.wrap in C.
        pose proof (word.unsigned_range addr) as R.
        remember (word.unsigned addr) as w.
        rewrite Z.add_mod_idemp_r in C by blia.
        rewrite Z.mod_eq in C by blia.
        assert (z = 2 ^ width * ((w + z) / 2 ^ width)) by blia.
        remember ((w + z) / 2 ^ width) as k.
        assert (k < 0 \/ k = 0 \/ 0 < k) as D by blia. destruct D as [D | [D | D]]; Lia.nia.
      }
      rewrite <- word.add_assoc.
      replace ((word.add (word.of_Z (word := word) z) (word.of_Z 1)))
        with (word.of_Z (word := word) (z + 1)); cycle 1. {
        apply word.unsigned_inj.
        rewrite word.unsigned_add.
        rewrite! word.unsigned_of_Z.
        apply Z.add_mod.
        destruct width_cases as [E | E]; rewrite E; cbv; discriminate.
      }
      eapply IHn; try blia; assumption.
  Qed.

  Lemma putmany_of_footprint_None'': forall n (vs: HList.tuple byte n) (a1 a2: word) (m: mem),
      0 < word.unsigned (word.sub a1 a2) ->
      word.unsigned (word.sub a1 a2) + Z.of_nat n <= 2 ^ width ->
      map.get m a2 = None ->
      map.get (map.putmany_of_tuple (Memory.footprint a1 n) vs m) a2 = None.
  Proof.
    intros.
    pose proof putmany_of_footprint_None as P.
    specialize P with (1 := H) (2 := H0) (3 := H1).
    specialize (P vs).
    replace (word.add a2 (word.of_Z (word.unsigned (word.sub a1 a2)))) with a1 in P; [exact P|].
    apply word.unsigned_inj.
    rewrite word.unsigned_add. unfold word.wrap.
    rewrite word.of_Z_unsigned.
    rewrite word.unsigned_sub. unfold word.wrap.
    rewrite Z.add_mod_idemp_r by (destruct width_cases as [E | E]; rewrite E; cbv; discriminate).
    rewrite <- (word.of_Z_unsigned a1) at 1.
    rewrite word.unsigned_of_Z. unfold word.wrap.
    f_equal.
    blia.
  Qed.

  Lemma putmany_of_footprint_None': forall n (vs: HList.tuple byte n) (a1 a2: word) (m: mem),
      a1 <> a2 ->
      word.unsigned (word.sub a1 a2) + Z.of_nat n <= 2 ^ width ->
      map.get m a2 = None ->
      map.get (map.putmany_of_tuple (Memory.footprint a1 n) vs m) a2 = None.
  Proof.
    intros.
    apply putmany_of_footprint_None''; try assumption.
    pose proof (word.unsigned_range (word.sub a1 a2)).
    assert (word.unsigned (word.sub a1 a2) = 0 \/ 0 < word.unsigned (word.sub a1 a2)) as C
        by blia. destruct C as [C | C].
    - exfalso. apply H.
      rewrite word.unsigned_sub in C.
      apply word.unsigned_inj.
      apply Z.div_exact in C; [|(destruct width_cases as [E | E]; rewrite E; cbv; discriminate)].
      remember ((word.unsigned a1 - word.unsigned a2) / 2 ^ width) as k.
      pose proof (word.unsigned_range a1).
      pose proof (word.unsigned_range a2).
      assert (k < 0 \/ k = 0 \/ 0 < k) as D by blia. destruct D as [D | [D | D]]; try Lia.nia.
      (* LIABUG if primitive projections are on, we need this:
      rewrite D in C.
      rewrite Z.mul_0_r in C.
      blia.
      *)
    - assumption.
  Qed.

  Lemma byte_list_to_word_list_array: forall bytes,
    Z.of_nat (length bytes) mod bytes_per_word = 0 ->
    exists word_list : list word,
      Z.of_nat (Datatypes.length word_list) =
      Z.of_nat (Datatypes.length bytes) / bytes_per_word /\
    forall p,
      iff1 (array ptsto (word.of_Z 1) p bytes)
           (array ptsto_word (word.of_Z bytes_per_word) p word_list).
  Proof.
    assert (AA: 0 < bytes_per_word). {
      unfold bytes_per_word.
      simpl.
      destruct width_cases as [E | E]; rewrite E; cbv; reflexivity.
    }
    intros.
    Z.div_mod_to_equations.
    subst r.
    specialize (H0 ltac:(blia)); clear H1.
    ring_simplify in H0.
    assert (0 <= q) by Lia.nia.
    revert dependent bytes.
    pattern q.
    refine (natlike_ind _ _ _ q H); clear -BW word_ok mem_ok; intros.
    { case bytes in *; cbn in *; ring_simplify in H0; try discriminate.
      exists nil; split; reflexivity. }
    rewrite Z.mul_succ_r in *.
    specialize (H0 (List.skipn (Z.to_nat bytes_per_word) bytes)).
    rewrite List.length_skipn in H0.
    specialize (H0 ltac:(Lia.nia)).
    case H0 as [words' [Hlen Hsep] ].
    eexists (cons _ words').
    split; [cbn; blia|].
    intros p0; specialize (Hsep (word.add p0 (word.of_Z bytes_per_word))).
    rewrite array_cons.
    etransitivity.
    2:eapply Proper_sep_iff1; [reflexivity|].
    2:eapply Hsep.
    clear Hsep.

    rewrite <-(List.firstn_skipn (Z.to_nat bytes_per_word) bytes) at 1.
    unfold ptsto_word, truncated_word, truncated_scalar, littleendian.

    rewrite <-bytearray_index_merge.
    1: eapply Proper_sep_iff1; [|reflexivity].
    2: rewrite word.unsigned_of_Z; setoid_rewrite Z.mod_small.
    3: {
      unfold bytes_per_word.
      simpl.
      destruct width_cases as [E | E]; rewrite E; cbv; intuition discriminate.
    }
    2: rewrite List.length_firstn_inbounds; Lia.nia.
    cbv [ptsto_bytes.ptsto_bytes].
    Morphisms.f_equiv.
    rewrite HList.tuple.to_list_of_list.
    setoid_rewrite word.unsigned_of_Z.
    setoid_rewrite Z.mod_small.
    1:unshelve erewrite (_:Memory.bytes_per Syntax.access_size.word = length _); shelve_unifiable; cycle 1.
    1:setoid_rewrite LittleEndianList.split_le_combine.
    1:reflexivity.
    { rewrite List.length_firstn_inbounds; try Lia.nia. reflexivity. }
    intros.
    pose proof (LittleEndianList.le_combine_bound (List.firstn (Z.to_nat bytes_per_word) bytes)).
    split; [blia|].
    destruct H0.
    eapply Z.lt_le_trans. 1: eassumption.
    eapply Z.pow_le_mono_r. 1: reflexivity.
    rewrite List.length_firstn_inbounds; try Lia.nia.
    unfold bytes_per_word;
    destruct width_cases as [E | E]; rewrite E; cbv; inversion 1.
  Qed.

  Lemma ll_mem_to_hl_mem: forall mH mL (addr: word) bs R,
      (eq mH * array ptsto (word.of_Z 1) addr bs * R)%sep mL ->
      exists mTraded,
        (eq (map.putmany mH mTraded) * R)%sep mL /\
        map.disjoint mH mTraded /\
        Memory.anybytes addr (Z.of_nat (List.length bs)) mTraded.
  Proof.
    unfold sep, map.split.
    intros.
    simp.
    epose proof array_1_to_anybytes.
    eauto 10.
    Unshelve. all : exact _.
  Qed.

  Lemma hl_mem_to_ll_mem: forall mH mHSmall mTraded mL (addr: word) n R,
      map.split mH mHSmall mTraded ->
      Memory.anybytes addr n mTraded ->
      (eq mH * R)%sep mL ->
      exists bs,
        List.length bs = Z.to_nat n /\
        (eq mHSmall * array ptsto (word.of_Z 1) addr bs * R)%sep mL.
  Proof.
    unfold sep, map.split.
    intros.
    apply anybytes_to_array_1 in H0.
    simp. repeat eexists; try eassumption.
  Qed.

  Lemma load_from_word_array: forall p words frame m i v,
      (word_array p words * frame)%sep m ->
      nth_error words (Z.to_nat i) = Some v ->
      0 <= i ->
      Memory.load Syntax.access_size.word m (word.add p (word.of_Z (i * bytes_per_word))) = Some v.
  Proof.
    unfold word_array.
    intros.
    eapply nth_error_split in H0. simp.
    seprewrite_in @array_append H.
    seprewrite_in @array_cons H.
    eapply load_word_of_sep.
    use_sep_assumption.
    cancel.
    cancel_seps_at_indices 0%nat 0%nat. {
      f_equal. f_equal. f_equal. rewrite Z.mul_comm. f_equal. 1: blia.
      apply word.unsigned_of_Z_nowrap.
      unfold bytes_per_word.
      destruct width_cases as [E | E]; rewrite E; cbv; intuition congruence.
    }
    ecancel_done.
  Qed.

  Lemma store_to_word_array: forall p oldwords frame m i v,
      (word_array p oldwords * frame)%sep m ->
      0 <= i < Z.of_nat (List.length oldwords) ->
      exists newwords m',
        Memory.store Syntax.access_size.word m (word.add p (word.of_Z (i * bytes_per_word))) v = Some m' /\
        (word_array p newwords * frame)%sep m' /\
        nth_error newwords (Z.to_nat i) = Some v /\
        (forall j w, j <> Z.to_nat i -> nth_error oldwords j = Some w -> nth_error newwords j = Some w) /\
        length newwords = length oldwords.
  Proof.
    unfold word_array.
    intros.
    destruct (List.nth_error oldwords (Z.to_nat i)) eqn: E. 2: {
      exfalso. eapply nth_error_Some. 2: eassumption. blia.
    }
    eapply nth_error_split in E. simp.
    seprewrite_in @array_append H.
    seprewrite_in @array_cons H.
    eexists (l1 ++ v :: l2).
    eapply store_word_of_sep. {
      use_sep_assumption. cancel. cancel_seps_at_indices 0%nat 0%nat. {
        f_equal. f_equal. f_equal. rewrite Z.mul_comm. f_equal. 1: blia.
        apply word.unsigned_of_Z_nowrap.
        unfold bytes_per_word.
        destruct width_cases as [E | E]; rewrite E; cbv; intuition congruence.
      }
      ecancel_done.
    }
    clear H.
    intros. ssplit.
    - seprewrite @array_append. seprewrite @array_cons.
      use_sep_assumption.
      cancel.
      cancel_seps_at_indices 0%nat 0%nat. {
        f_equal. f_equal. f_equal. rewrite Z.mul_comm. f_equal. 2: blia.
        symmetry. apply word.unsigned_of_Z_nowrap.
        unfold bytes_per_word.
        destruct width_cases as [E | E]; rewrite E; cbv; intuition congruence.
      }
      ecancel_done.
    - rewrite nth_error_app2 by blia. replace (Z.to_nat i - length l1)%nat with O by blia. reflexivity.
    - intros. assert (j < Z.to_nat i \/ Z.to_nat i < j)%nat as C by blia. destruct C as [C | C].
      + rewrite nth_error_app1 by blia. rewrite nth_error_app1 in H1 by blia. assumption.
      + rewrite nth_error_app2 by blia. rewrite nth_error_app2 in H1 by blia.
        replace (j - length l1)%nat with (S (j - length l1 - 1)) in * by blia.
        assumption.
    - rewrite ?List.app_length. reflexivity.
  Qed.

  Lemma store_bytes_sep_hi2lo: forall (mH mL : mem) R a n v_old v,
      Memory.load_bytes n mH a = Some v_old ->
      (eq mH * R)%sep mL ->
      (eq (Memory.unchecked_store_bytes n mH a v) * R)%sep (Memory.unchecked_store_bytes n mL a v).
  Proof.
    intros. apply sep_comm. apply sep_comm in H0.
    unfold Memory.load_bytes, Memory.unchecked_store_bytes, sep, map.split in *.
    simp. do 2 eexists. ssplit. 3: eassumption. 3: reflexivity.
    - rewrite map.putmany_of_tuple_to_putmany.
      rewrite (map.putmany_of_tuple_to_putmany _ mq).
      symmetry. apply map.putmany_assoc.
    - unfold map.disjoint in *.
      intros.
      pose proof (map.putmany_of_tuple_preserves_domain (ok := mem_ok) _ _ v_old v _ H) as A.
      unfold map.same_domain, map.sub_domain in A. apply proj2 in A.
      edestruct A as [v3 B]. 1: eassumption.
      eauto.
  Qed.
End ptstos.

(* These lemmas are for any kind of map, so that they can also be used to describe locals *)
Section MoreSepLog.
  Context {key value} {map : map.map key value}.
  Context {ok : map.ok map} {key_eqb: key -> key -> bool} {key_eq_dec : EqDecider key_eqb}.

  Lemma sep_inline_eq: forall (A R: map -> Prop) m1,
    (exists m2, (R * eq m2)%sep m1 /\ A m2) <->
    (R * A)%sep m1.
  Proof.
    unfold iff, Separation.sep.
    repeat match goal with
           | |- _ => intros || simp || eassumption || reflexivity
           | |- _ /\ _ => split
           | |- exists _, _ => eexists
           end.
  Qed.

  Lemma subst_split: forall (m m1 m2 M: map) (R: map -> Prop),
      map.split m m1 m2 ->
      (eq m * R)%sep M ->
      (eq m1 * eq m2 * R)%sep M.
  Proof.
    intros.
    unfold map.split in H. destruct H. subst.
    use_sep_assumption.
    cancel.
    cbn [seps].
    intro m. unfold sep, map.split. split; intros.
    - subst. eauto 10.
    - simp. reflexivity.
  Qed.

  Lemma subst_split_bw: forall (m m1 m2 M : map) (R : map -> Prop),
      map.split m m1 m2 ->
      sep (sep (eq m1) (eq m2)) R M ->
      sep (eq m) R M.
  Proof.
    unfold sep, map.split. intros. simp. eauto 10.
  Qed.

  Lemma eq_sep_to_split: forall (m m1: map) P,
      (eq m1 * P)%sep m ->
      exists m2, map.split m m1 m2 /\ P m2.
  Proof. unfold sep. intros. simp. eauto. Qed.

  Lemma sep_put_iff: forall (m: map) P R k v_old v_new,
      (ptsto k v_old * R)%sep m ->
      iff1 P (ptsto k v_new * R)%sep ->
      P (map.put m k v_new).
  Proof.
    intros.
    eapply sep_put in H.
    seprewrite H0.
    ecancel_assumption.
  Qed.

  Lemma sep_eq_put: forall (m1 m: map) P x v,
      (eq m1 * P)%sep m ->
      (forall m' w, P m' -> map.get m' x = Some w -> False) ->
      (eq (map.put m1 x v) * P)%sep (map.put m x v).
  Proof.
    intros. unfold sep, map.split in *. simp.
    exists (map.put mp x v), mq.
    specialize H0 with (1 := Hp2).
    repeat split; trivial.
    - apply map.map_ext.
      intro y.
      rewrite map.get_put_dec.
      rewrite ?map.get_putmany_dec.
      destr (map.get mq y).
      + destruct_one_match.
        * subst. exfalso. eauto.
        * reflexivity.
      + destruct_one_match.
        * subst. rewrite map.get_put_same. reflexivity.
        * rewrite map.get_put_diff by congruence. reflexivity.
    - unfold map.disjoint in *. intros.
      rewrite map.get_put_dec in H. destruct_one_match_hyp.
      + subst. eauto.
      + eauto.
  Qed.

  Lemma grow_eq_sep: forall (M M' m mAdd: map) (R: map -> Prop),
      (eq m * R)%sep M ->
      map.split M' M mAdd ->
      (eq (map.putmany m mAdd) * R)%sep M'.
  Proof.
    intros. apply sep_comm. apply sep_comm in H.
    unfold sep, map.split in *. simp.
    do 2 eexists. ssplit. 4: reflexivity. 3: eassumption.
    - symmetry. apply map.putmany_assoc.
    - unfold map.disjoint in *. intros. rewrite map.get_putmany_dec in H0.
      destruct_one_match_hyp.
      + simp. eapply H0p1. 2: eassumption. rewrite map.get_putmany_dec.
        rewrite H. instantiate (1 := ltac:(destruct(map.get mq k))).
        destruct (map.get mq k); reflexivity.
      + eauto.
  Qed.

  Lemma join_sep: forall (m m1 m2: map) (P P1 P2: map -> Prop),
      map.split m m1 m2 ->
      P1 m1->
      P2 m2 ->
      iff1 (P1 * P2)%sep P ->
      P m.
  Proof.
    unfold sep, map.split. intros. simp. eapply H2. eauto 10.
  Qed.

  Lemma sep_def: forall {m: map} {P Q: map -> Prop},
      (P * Q)%sep m ->
      exists m1 m2, map.split m m1 m2 /\ P m1 /\ Q m2.
  Proof. unfold sep. intros *. apply id. Qed.

  Lemma sep_eq_empty_l: forall (R: map -> Prop), (eq map.empty * R)%sep = R.
  Proof.
    intros. eapply iff1ToEq.
    unfold iff1, sep, map.split. split; intros.
    - destruct H as (? & ? & (? & ?) & ? & ?). subst. rewrite map.putmany_empty_l. assumption.
    - eauto 10 using map.putmany_empty_l, map.disjoint_empty_l.
  Qed.

  Lemma sep_eq_empty_r: forall (R: map -> Prop), (R * eq map.empty)%sep = R.
  Proof.
    intros. eapply iff1ToEq.
    unfold iff1, sep, map.split. split; intros.
    - destruct H as (? & ? & (? & ?) & ? & ?). subst. rewrite map.putmany_empty_r. assumption.
    - eauto 10 using map.putmany_empty_r, map.disjoint_empty_r.
  Qed.

  Lemma get_in_sep: forall (lSmaller l: map) k v R,
      map.get lSmaller k = Some v ->
      (eq lSmaller * R)%sep l ->
      map.get l k = Some v.
  Proof.
    intros. eapply sep_comm in H0.
    unfold sep, map.split in H0. simp.
    eapply map.get_putmany_right.
    assumption.
  Qed.

  Lemma eq_put_to_sep: forall (m: map) k v,
      map.get m k = None ->
      eq (map.put m k v) = sep (eq m) (ptsto k v).
    intros. eapply iff1ToEq.
    unfold iff1, ptsto, sep, map.split. split; intros.
    - subst. exists m, (map.put map.empty k v). ssplit; try reflexivity.
      + apply map.map_ext. intros.
        rewrite map.get_put_dec, map.get_putmany_dec, map.get_put_dec, map.get_empty.
        destr (key_eqb k k0); reflexivity.
      + unfold map.disjoint. intros. rewrite map.get_put_dec in H1.
        rewrite map.get_empty in H1. destr (key_eqb k k0); congruence.
    - destruct H0 as (? & ? & (? & ?) & ? & ?).  subst.
      apply map.map_ext. intros.
      rewrite map.get_put_dec, map.get_putmany_dec, map.get_put_dec, map.get_empty.
      destr (key_eqb k k0); reflexivity.
  Qed.

  Lemma ptsto_no_aliasing: forall l (Q: map -> Prop) R k v1 v2,
      Q l ->
      iff1 Q (ptsto k v1 * ptsto k v2 * R)%sep ->
      False.
  Proof.
    intros. seprewrite_in H0 H. apply sep_emp_r in H. apply proj1 in H.
    unfold sep, map.split, ptsto, map.disjoint in H.
    decompose [Logic.and ex] H. clear H. subst.
    specialize (H7 k). rewrite ?map.get_put_same in H7. eauto.
  Qed.

  Lemma get_Some_to_ptsto: forall k v (m: map),
      map.get m k = Some v ->
      eq m = (eq (map.remove m k) * ptsto k v)%sep.
  Proof.
    intros. extensionality l. eapply propositional_extensionality.
    unfold sep, map.split.
    split; intros.
    - subst. do 2 eexists. ssplit; try reflexivity.
      + apply map.map_ext. intros.
        rewrite map.get_putmany_dec, map.get_put_dec, map.get_remove_dec, map.get_empty.
        destr (key_eqb k k0); congruence.
      + unfold map.disjoint. intros.
        rewrite map.get_remove_dec in H0. rewrite map.get_put_dec, map.get_empty in H1.
        destr (key_eqb k k0); congruence.
    - unfold ptsto in H0. decompose [Logic.and ex] H0. subst.
      apply map.map_ext. intros.
        rewrite map.get_putmany_dec, map.get_put_dec, map.get_remove_dec, map.get_empty.
        destr (key_eqb k k0); congruence.
  Qed.

  Lemma sep_ptsto_to_get_None: forall k v m (R: map -> Prop) l,
      (eq m * ptsto k v * R)%sep l ->
      map.get m k = None.
  Proof.
    intros. destr (map.get m k); [exfalso|reflexivity].
    erewrite get_Some_to_ptsto in H by eassumption.
    eapply ptsto_no_aliasing. 1: exact H. ecancel.
  Qed.

  Lemma ptsto_unique: forall k v0 v1 (R1 R2: map -> Prop) l,
      (ptsto k v0 * R1)%sep l ->
      (ptsto k v1 * R2)%sep l ->
      v0 = v1.
  Proof.
    intros. apply sep_comm in H. apply sep_comm in H0.
    unfold sep, map.split, ptsto in *.
    decompose [Logic.and ex] H. decompose [Logic.and ex] H0. subst.
    apply (f_equal (fun m => map.get m k)) in H6.
    rewrite ?map.get_putmany_dec, ?map.get_put_same in H6.
    congruence.
  Qed.

  Lemma sep_eq_to_disjoint: forall m1 m2 (R: map -> Prop) l,
      (eq m1 * eq m2 * R)%sep l ->
      map.disjoint m1 m2.
  Proof.
    unfold sep, map.split. intros. decompose [Logic.and ex] H. subst. assumption.
  Qed.
End MoreSepLog.

(* This can be overridden by the user.
   The idea of "addr" is that if the addresses of two sepclauses are the same,
   we're sure that these two clauses should be matched & canceled with each other,
   even if they still contain many evars outside of their address.
   "addr" should return a Gallina term of type "word" *)
Ltac addr P ::=
  let __ := lazymatch type of P with
            | @map.rep _ _ _ -> Prop => idtac
            | _ => fail 10000 P "is not a sep clause"
            end in
  lazymatch P with
  | ptsto ?A _ => A
  | ptsto_bytes _ ?A _ => A
  | ptsto_word ?A _ => A
  | ptsto_instr _ ?A _ => A
  | array _ _ ?A _ => A
  | word_array ?A _ => A
  | _ => fail "no recognizable address"
  end.

#[export] Hint Unfold program word_array: unf_to_array.

Require Export bedrock2.footpr.


(**********************************************************************************
 * uniirec.v                                                                      *
 * Formalizing Domains, Ultrametric Spaces and Semantics of Programming Languages *
 * Nick Benton, Lars Birkedal, Andrew Kennedy and Carsten Varming                 *
 * Jan 2012                                                                       *
 * Build with Coq 8.3pl2 plus SSREFLECT                                           *
 **********************************************************************************)

(* Construction of recursive domain for interpreting unityped lambda calculus *)

Require Export PredomAll.
Require Import PredomRec.

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

(*=kcpoCat *)
Lemma kcpoCatAxiom : @Category.axiom cpoType
  (fun X Y => exp_cppoType X (liftCppoType Y)) (fun X Y Z f g => kleisli f << g) (@eta).
(*CLEAR*)
split ; last split ; last split.
- move => D0 D1 f. simpl. rewrite kleisli_unit. by rewrite comp_idL.
- move => D0 D1 f. simpl. by rewrite kleisli_eta_com.
- move => D0 D1 D2 D3 f g h. simpl. rewrite <- kleisli_comp. by rewrite comp_assoc.
- move => D0 D1 D2 f f' g g'. simpl. move => e e'. rewrite e. by rewrite e'.
Qed.
(*CLEARED*)Canonical Structure kcpoCatMixin := CatMixin kcpoCatAxiom.
Canonical Structure kcpoCatType := Eval hnf in CatType kcpoCatMixin.
(*=End *)

Module Type RecDom.
  Variable DInf : cpoType.
  Definition VInf :=  discrete_cpoType nat + (DInf -=> DInf _BOT).
  Variable Roll : VInf =-> DInf.
  Variable Unroll : DInf =-> VInf.

  Variable RU_id : Roll << Unroll =-= Id.
  Variable UR_id : Unroll << Roll =-= Id.

  Variable delta : (DInf -=> DInf _BOT) =-> (DInf -=> DInf _BOT).
  Variable delta_simpl : forall e, delta e =-= eta << Roll << ([| in1,
      (in2 <<
    ((exp_fun (CCOMP DInf (DInf _BOT) (DInf _BOT):cpoCatType _ _) (kleisli e) : cpoCatType _ _) <<
     ((exp_fun
        ((CCOMP DInf (DInf _BOT) (DInf _BOT)) << SWAP) e :cpoCatType _ _) << KLEISLI))) |]) << Unroll.

  Variable delta_eta : delta eta =-= eta.
  Variable id_min : eta =-= @FIXP _ delta.

End RecDom.

Module RD : RecDom.

Lemma kcpoTerminalAxiom : CatTerminal.axiom (Zero: kcpoCatType).
simpl. move => D x y. split.
move => i. simpl. apply: DLless_cond. by case.
move => i. simpl. apply:DLless_cond. by case.
Qed.

Canonical Structure kcpoTermincalCatMixin :=
   @terminalCatMixin kcpoCatType (Zero: kcpoCatType)
    (fun X => const _ (PBot: (liftCpoPointedType Zero))) kcpoTerminalAxiom.
Canonical Structure kcpoTerminalCat := Eval hnf in @terminalCatType kcpoCatType kcpoTermincalCatMixin.

Lemma kcpo_comp_eq (X Y Z : cpoType) m m' : ((CCOMP X (Y _BOT) (Z _BOT)) << KLEISLI >< Id) (m,m') =-= Category.tcomp kcpoCatMixin m m'.
by [].
Qed.

Definition kcpoBaseCatMixin := CppoECatMixin kcpoTermincalCatMixin kcpo_comp_eq.

(*=kcpoBaseCat *)
Canonical Structure kcpoBaseCatType := Eval hnf in CppoECatType kcpoBaseCatMixin.
Lemma leftss : (forall (X Y Z : kcpoBaseCatType) (f : kcpoBaseCatType X Y),
    (PBot:kcpoCatType _ _) << f =-= (PBot: X =-> Z)).
(*=End *)
move => X Y Z f. apply: fmon_eq_intro.
move => x. split ; last by apply: leastP.
apply: DLless_cond.
move => z. move => A. case: (kleisliValVal A) => y [_ F]. by case: (PBot_incon_eq (Oeq_sym F)).
Qed.

Definition ProjSet (T:Tower kcpoBaseCatType) := fun (d:prodi_cpoType (fun n => tobjects T n _BOT)) => forall n,
      PROJ (fun n => tobjects T n _BOT) n d =-=
      kleisli (tmorphisms T n) (PROJ (fun n => tobjects T n _BOT) (S n) d) /\
      exists n, exists e, PROJ (fun n => tobjects T n _BOT) n d =-= Val e.

Lemma ProjSet_inclusive T : admissible (@ProjSet T).
unfold ProjSet. unfold admissible.
intros c C n.
split. do 3 rewrite -> lub_comp_eq.
refine (lub_eq_compat _).
refine (fmon_eq_intro _).
intros m. simpl. specialize (C m n). by apply (proj1 C).
specialize (C 0 0). destruct C as [_ C]. clear n.
destruct C as [n [e P]].
exists n.
assert (forall n, continuous ((PROJ (fun n0 : nat => tobjects T n0 _BOT) n))) as Cp by auto.
assert (PROJ (fun n : nat => tobjects T n _BOT) n (c 0) <= PROJ (fun n : nat => tobjects T n _BOT) n (lub c)) as L by
  (apply: fmonotonic ; auto).
rewrite -> P in L.
destruct (DLle_Val_exists_eq L) as [dn [Y X]].
exists dn. by apply Y.
Qed.

Definition kcpoCone (T:Tower kcpoBaseCatType) : Cone T.
exists (sub_cpoType (@ProjSet_inclusive T)) (fun i:nat => PROJ _ i << Forget (@ProjSet_inclusive T)).
move => i. apply: fmon_eq_intro. case => d Pd.
by apply (Oeq_sym (proj1 (Pd i))).
Defined.

Implicit Arguments InheritFun [D E P].

Lemma retract_total D E (f:D =-> E _BOT) (g:E =-> D _BOT) : kleisli f << g =-= eta -> total g.
unfold total. move => X d. have X':=fmon_eq_elim X d.
case: (kleisliValVal X'). move => e [Y _]. exists e. by apply Y.
Qed.

Lemma xx (T:Tower kcpoBaseCatType) i : (forall d : tobjects T i, ProjSet (PRODI_fun (t_nm T i) d)).
move => d n. split. simpl.
by rewrite -> (fmon_eq_elim (t_nmProjection T i n) d).
exists i. exists d. simpl. by rewrite t_nn_ID.
Qed.

Definition kcpoCocone (T:Tower kcpoBaseCatType) : CoCone T.
exists (sub_cpoType (@ProjSet_inclusive T)) (fun i => eta << @InheritFun _ _ _ (@ProjSet_inclusive T) (PRODI_fun (t_nm T i)) (@xx T i)).
move => i. rewrite {1} /Category.comp. simpl. apply: fmon_eq_intro => d. split.
- apply: DLless_cond. case => x Px C. case: (kleisliValVal C). clear C.
  move => y [md X].
  apply Ole_trans with (kleisli (eta << InheritFun (@ProjSet_inclusive T) (PRODI_fun (t_nm T i.+1)) (@xx T _)) (Val y)) ;
   first by rewrite <- md.
  rewrite kleisliVal. rewrite -> X. apply: (fmonotonic (@eta_m _)). unfold Ole. simpl.
  move => n. simpl. have Y:=vinj X.
  case: (fmon_stable (Forget (@ProjSet_inclusive T)) Y). clear Y. simpl. move => Y Y'.
  specialize (Y' n). rewrite -> Y'. rewrite -> (fmon_eq_elim (t_nmEmbedding T i n) d). simpl.
  rewrite -> md. by rewrite kleisliVal.
- case: (retract_total (proj1 (teppair T i)) d). move => x e.
  apply Ole_trans with (y:=kleisli (eta << InheritFun (@ProjSet_inclusive T) (PRODI_fun (t_nm T i.+1)) (@xx T _)) (Val x)) ;
  last by rewrite <- e.
  rewrite kleisliVal. apply: DLle_leVal. move => n. simpl.
  apply Ole_trans with (y:=(kleisli (t_nm T i.+1 n) (Val x))) ; last by rewrite kleisliVal.
  rewrite <- e. by apply (proj1 (fmon_eq_elim (t_nmEmbedding T i n) d)).
Defined.

Lemma limit_def (T:Tower kcpoBaseCatType) (C:Cone T) d n e' : mcone C n d =-= Val e' ->
   exists e, lub (chainPE (kcpoCocone T) C) d =-= Val e.
move => X. simpl.
have aa:exists e, (fcont_app (chainPE (kcpoCocone T) C) d) n =-= Val e.
exists (@InheritFun _ _ _ (@ProjSet_inclusive T) (PRODI_fun (t_nm T n)) (@xx T n) e').
apply (@Oeq_trans _ _ (kleisli (eta << InheritFun (@ProjSet_inclusive T) (PRODI_fun (t_nm T n)) (@xx T _)) (mcone C n d))) ; first by [].
rewrite -> X. by rewrite kleisliVal.
case: aa => e aa. case: (chainVallubnVal 1 aa) => x bb. exists x. by apply bb.
Qed.

(*=kcpoLimit *)
Definition kcpoLimit (T:Tower kcpoBaseCatType) : Limit T.
(*=End *)
exists (kcpoCone T) (fun C : Cone T => lub (chainPE (@kcpoCocone T) C)).
move => C n. simpl. split.
- apply: (Ole_trans _ (comp_le_compat (Ole_refl _) (le_lub (chainPE (kcpoCocone T) C) n))).
  simpl. rewrite {1} /Category.comp. simpl. rewrite comp_assoc. rewrite <- kleisli_comp2.
  rewrite <- comp_assoc. rewrite -> ForgetInherit. rewrite prodi_fun_pi. rewrite t_nn_ID. rewrite kleisli_unit.
  by rewrite comp_idL. simpl.
  rewrite {1} / Category.comp. simpl.
  refine (Ole_trans (Oeq_le (PredomCore.comp_lub_eq _ (chainPE (kcpoCocone T) C))) _).
  rewrite (lub_lift_left _ n). apply: lub_le => i. simpl. rewrite comp_assoc.
  rewrite <- (kleisli_comp2 (InheritFun (@ProjSet_inclusive T) (PRODI_fun (t_nm T (n + i))) (@xx T _))
    (PROJ (fun n0 : nat => tobjects T n0 _BOT) n << Forget (@ProjSet_inclusive T))).
  rewrite <- comp_assoc. rewrite ForgetInherit. rewrite prodi_fun_pi. by apply (proj2 ((coneCom_l C (leq_addr i n)))).
- move => C h X. apply: fmon_eq_intro => d. simpl in h. split.
  + apply: DLless_cond. case => x Px E. case: (proj2 (Px 0)) => n. case => y Py. rewrite -> E.
    have A:=(fmon_eq_elim (X n) d). have AA:=tset_trans A (fmon_stable (kleisli _) E). clear A.
    have A:=tset_trans AA (kleisliVal _ _). clear AA. simpl in A. rewrite -> Py in A.
    case: (limit_def A) => lc e. rewrite -> e. apply: DLle_leVal. case: lc e => lc Plc e. unfold Ole. simpl.
    move => i. specialize (X i). have Xi:=fmon_eq_elim X d.
    have Xii: (mcone C i) d =-= (kleisli (PROJ _ i << Forget (@ProjSet_inclusive T)) ( h d)) by apply Xi.
    rewrite -> E in Xii. rewrite -> kleisliVal in Xii. simpl in Xii.
    rewrite <- Xii. clear Xi Xii.
    simpl in e. have aa := Ole_trans (le_lub _ i) (proj1 e). clear e h X E. simpl in aa.
    have bb:kleisli (eta << (@InheritFun _ _ _ (@ProjSet_inclusive T) (PRODI_fun (t_nm T (i))) (@xx T (i))))
            ((mcone C i) d) <= Val (exist (fun x : forall i : nat, Stream (tobjects T i) => ProjSet x)
            lc Plc) by apply aa. clear aa.
    apply: DLless_cond => di X. rewrite -> X in bb. rewrite -> kleisliVal in bb. rewrite -> X.
    have aa:=vleinj bb. clear bb. unfold Ole in aa. simpl in aa. specialize (aa i). simpl in aa.
    rewrite <- aa. by rewrite -> (fmon_eq_elim (t_nn_ID T i) di).
  + simpl. apply: lub_le => n. specialize (X n). have Y:=fmon_eq_elim X d. clear X.
    simpl mcone in Y. simpl. apply Ole_trans with (y:=kleisli (eta << (@InheritFun _ _ _ (@ProjSet_inclusive T) (PRODI_fun (t_nm T n)) (@xx T n))) ( (mcone C n) d))  ; first by [].
    rewrite -> Y.
    apply Ole_trans with (y:=(kleisli (eta << InheritFun (@ProjSet_inclusive T) (PRODI_fun (t_nm T n)) (@xx T _)) <<
                              kleisli (PROJ (fun n0 : nat => tobjects T n0 _BOT) n << Forget (@ProjSet_inclusive T)))
                              ( h d)) ; first by [].
    apply: DLless_cond. move => aa X. rewrite -> X. case: (kleisliValVal X) => b [P Q]. clear X.
    case: (kleisliValVal P) => hd [P' Q']. rewrite -> P'. apply: DLle_leVal.
    rewrite <- (vinj Q). clear P Q aa h d Y P'. unfold Ole. case: hd Q' => x Px Q.
    simpl. simpl in Q. move => i. simpl.
    case: (ltngtP n i).
    * move => l. have a:= comp_eq_compat (tset_refl (t_nm T n i)) (coneCom_l (kcpoCone T) (ltnW l)).
      rewrite -> comp_assoc in a. have yy:t_nm T n i << mcone (kcpoCone T) n <= mcone (kcpoCone T) i.
        rewrite -> a. rewrite -> (comp_le_compat (proj2 (t_nm_EP T (ltnW l))) (Ole_refl _)).
        by rewrite comp_idL.
      specialize (yy (exist _ x Px)). simpl in yy. rewrite -> Q in yy. rewrite -> kleisliVal in yy.
      by apply yy.
    * move => l. have a:= (proj2 (fmon_eq_elim (coneCom_l (kcpoCone T) (ltnW l)) (exist _ x Px))).
      simpl in a. have aa:(kleisli ( (t_nm T n i)) (x n)) <= (x i) by apply a.
      rewrite -> Q in aa. rewrite -> kleisliVal in aa. by apply aa.
    * move => e. rewrite <- e. clear i e. rewrite -> (proj1 (fmon_eq_elim (t_nn_ID T n) b)). by rewrite -> Q.
Defined.

Lemma summ_mon (F G : BiFunctor kcpoBaseCatType)
   X Y Z W : monotonic (fun p => [|kleisli (eta << in1) << (morph F X Y Z W p : (ob F X Z) =-> (ob F Y W)),
                      kleisli (eta << in2) << (morph G X Y Z W p : (ob G X Z) =-> (ob G Y W))|]).
move => p p' l. simpl.
unfold sum_fun. simpl. unfold in1. simpl. unfold in2. simpl.
move => x. simpl. do 2 rewrite -> SUM_fun_simpl. case: x.
- move => s. simpl. by rewrite -> l.
- move => s. simpl. by rewrite -> l.
Qed.

Definition summ (F G : BiFunctor kcpoBaseCatType) X Y Z W := Eval hnf in mk_fmono (@summ_mon F G X Y Z W).

Lemma sumc (F G : BiFunctor kcpoBaseCatType) X Y Z W : continuous (@summ F G X Y Z W).
move => c. simpl. unfold sum_fun. simpl. move => x. simpl. rewrite -> SUM_fun_simpl. simpl.
case:x ; simpl => s.
- do 2 rewrite lub_comp_eq. simpl. apply lub_le_compat => i. simpl. unfold sum_fun. simpl. by rewrite SUM_fun_simpl.
- do 2 rewrite lub_comp_eq. simpl. apply lub_le_compat => i. simpl. unfold sum_fun. simpl. by rewrite SUM_fun_simpl.
Qed.

Definition sum_func (F G : BiFunctor kcpoBaseCatType) X Y Z W := Eval hnf in mk_fcont (@sumc F G X Y Z W).

Lemma sum_func_simpl F G X Y Z W x : @sum_func F G X Y Z W x = [|kleisli (eta << in1) << (morph F X Y Z W x : (ob F X Z) =-> (ob F Y W)),
                      kleisli (eta << in2) << (morph G X Y Z W x : (ob G X Z) =-> (ob G Y W))|].
by [].
Qed.

Definition biSum (F G : BiFunctor kcpoBaseCatType) : BiFunctor kcpoBaseCatType.
exists (fun X Y => (ob F X Y) + (ob G X Y)) (fun X Y Z W => @sum_func F G X Y Z W).
move => T0 T1 T2 T3 T4 T5 f g h k. simpl.
apply: (@sum_unique cpoSumCatType).
- rewrite sum_fun_fst. rewrite {2} / Category.comp. simpl. rewrite <- comp_assoc.
  rewrite sum_fun_fst. rewrite comp_assoc. rewrite <- kleisli_comp2. rewrite sum_fun_fst.
  rewrite <- (comp_eq_compat (tset_refl (kleisli (eta << in1))) (@morph_comp _ F T0 T1 T2 T3 T4 T5 f g h k)).
  rewrite {6} /Category.comp. simpl. rewrite comp_assoc. by rewrite kleisli_comp.
- rewrite sum_fun_snd. rewrite {2} / Category.comp. simpl. rewrite <- comp_assoc.
  rewrite sum_fun_snd. rewrite comp_assoc. rewrite <- kleisli_comp2. rewrite sum_fun_snd.
  rewrite <- (comp_eq_compat (tset_refl (kleisli (eta << in2))) (@morph_comp _ G T0 T1 T2 T3 T4 T5 f g h k)).
  rewrite {6} /Category.comp. simpl. rewrite comp_assoc. by rewrite kleisli_comp.
- move => T0 T1. simpl. apply: (@sum_unique cpoSumCatType).
  + simpl. rewrite sum_fun_fst. rewrite (comp_eq_compat (tset_refl (kleisli (eta << in1))) (morph_id F _ _)).
    by rewrite kleisli_eta_com.
  + simpl. rewrite sum_fun_snd. rewrite (comp_eq_compat (tset_refl (kleisli (eta << in2))) (morph_id G _ _)).
    by rewrite kleisli_eta_com.
Defined.

Lemma bifunm
   X Y Z W : monotonic (fun (p:@cppoMorph kcpoBaseCatType Y X * @cppoMorph kcpoBaseCatType Z W) =>
  eta << (exp_fun (CCOMP _ _ _ :cpoCatType _ _) (kleisli (snd p) : cpoCatType _ _)) << (exp_fun ((CCOMP _ _ _) << SWAP) (fst p)) << KLEISLI).
move => p p' l f.
simpl. apply: DLle_leVal. case: l => l l'. rewrite l. by rewrite -> (kleisli_le_compat l').
Qed.

Add Parametric Morphism (D:cpoType) : (@Val D)
with signature (@Ole D: D -> D -> Prop) ++> (@Ole (D _BOT))
as Val_le_cpo_compat.
intros.
apply: DLle_leVal.
auto.
Qed.

Lemma bifunc X Y Z W : continuous (mk_fmono (@bifunm X Y Z W)).
move => c x. simpl.
 apply Ole_trans with (y:=eta (((KLEISLI (lub (pi2 << (c:natO =-> _))):cpoCatType _ _) <<
      exp_fun (CCOMP _ _ (_ _BOT):cpoCatType _ _)
        (kleisli x) (lub (pi1 << (c:natO =-> _)))))) ; first by [].
do 2 rewrite lub_comp_eq. rewrite -> PredomCore.lub_comp_both.
rewrite lub_comp_eq. by apply lub_le_compat => n.
Qed.

Definition bi_fun (X Y Z W : kcpoBaseCatType) : (@cppoMorph kcpoBaseCatType Y X * cppoMorph Z W) =->
(@cppoMorph kcpoBaseCatType (fcont_cpoType X (Z _BOT)) (fcont_cpoType Y (W _BOT)))
:= Eval hnf in mk_fcont (@bifunc X Y Z W).

Lemma bi_fun_simpl T0 T2 T4 T5 f g x : (bi_fun T0 T4 T2 T5) (f,g) x = Val (kleisli g << (kleisli x << f)).
by [].
Qed.

Definition biFun : BiFunctor kcpoBaseCatType.
exists (fun X Y => fcont_cpoType X (Y _BOT)) (fun X Y Z W => @bi_fun X Y Z W).
move => T0 T1 T2 T3 T4 T5 f g h k. apply: fmon_eq_intro => x.
apply Oeq_trans with (y:=kleisli ((bi_fun T1 T4 T3 T5) (f, g)) ((bi_fun T0 T1 T2 T3) (h, k) x)) ; first by [].
rewrite bi_fun_simpl. rewrite kleisliVal. rewrite bi_fun_simpl.
apply Oeq_trans with (y:= (bi_fun T0 T4 T2 T5) (h << f, g << k) x) ; last by [].
rewrite bi_fun_simpl. apply: (fmon_stable eta).
rewrite <- kleisli_comp. rewrite <- kleisli_comp. rewrite {6 8} /Category.comp. simpl.
rewrite <- kleisli_comp. by repeat rewrite comp_assoc.

move => X Y. apply: fmon_eq_intro => x. apply: (fmon_stable eta).
simpl. rewrite kleisli_unit. rewrite comp_idL. by rewrite kleisli_eta_com.
Defined.

Definition biVar : BiFunctor kcpoBaseCatType.
exists (fun X Y => Y) (fun X Y Z W => pi2).
by [].
by [].
Defined.

Definition biConst (D:kcpoBaseCatType) : BiFunctor kcpoBaseCatType.
exists (fun (X Y:kcpoBaseCatType) => D) (fun (X Y Z W:kcpoBaseCatType) => const _ eta).
move => T0 T1 T2 T3 T4 T5 f g h k. simpl. unfold Category.comp. simpl.
rewrite kleisli_unit. by rewrite comp_idL.
move => T0 T1. by [].
Defined.

(*=FS *)
Definition FS := biSum (biConst (discrete_cpoType nat)) biFun.
(*=End *)
(*=DInf *)
Definition DInf : cpoType := @DInf kcpoBaseCatType kcpoLimit FS leftss.
Definition VInf := (discrete_cpoType nat) + (DInf -=> DInf _BOT).
Definition Fold : VInf =-> DInf _BOT := Fold kcpoLimit FS leftss.
Definition Unfold : DInf =-> VInf _BOT := Unfold kcpoLimit FS leftss.
(*=End *)
Lemma FU_iso : kleisli Fold << Unfold =-= eta.
by apply (FU_id kcpoLimit FS leftss).
Qed.

Lemma UF_iso : kleisli Unfold << Fold =-= eta.
by apply (UF_id kcpoLimit FS leftss).
Qed.

Lemma ob X Y : ob FS X Y = discrete_cpoType nat + (X -=> (Y _BOT)).
by simpl.
Qed.

Lemma morph1 X Y Z W f g x : morph FS X Y Z W (f,g) (INL _ _ x) =-= Val (INL _ _ x).
simpl. unfold sum_fun. simpl. unlock SUM_fun. simpl. by rewrite kleisliVal.
Qed.

Lemma morph2 X Y Z W f g x : morph FS X Y Z W (f,g) (INR _ _ x) =-= Val (INR _ _ (kleisli g << (kleisli x << f))).
simpl. unfold sum_fun. simpl. unlock SUM_fun. simpl; by rewrite kleisliVal.
Qed.

(*=Delta *)
Definition delta : (DInf -=> DInf _BOT) =-> (DInf -=> DInf _BOT) := delta kcpoLimit FS leftss.
(*=End *)

Lemma eta_mono X Y (f g : X =-> Y) : eta << f =-= eta << g -> f =-= g.
move => A.
apply: fmon_eq_intro => x.
have A':=fmon_eq_elim A x. by apply (vinj A').
Qed.

(*=ROLL *)
Lemma foldT : total Fold.
(*CLEAR*)
move => x. simpl.
have X:=fmon_eq_elim UF_iso x. case: (kleisliValVal X). clear X. move => y [P Q]. exists y. by apply P.
Qed.
(*CLEARED*)Lemma unfoldT : total Unfold.  (*CLEAR*)
move => x. simpl.
have X:=fmon_eq_elim FU_iso x. case: (kleisliValVal X). clear X. move => y [P Q]. exists y. by apply P.
Qed. (*CLEARED*)
Definition Roll : VInf =-> DInf := totalL foldT.
Definition Unroll : DInf =-> VInf := totalL unfoldT.
Lemma RU_id : Roll << Unroll =-= Id. (*CLEAR*)
apply eta_mono.
have X:=FU_iso.
have A:eta << Roll =-= Fold by apply totalL_eta.
rewrite <- A in X. clear A.
have A:eta << Unroll =-= Unfold by apply totalL_eta.
rewrite <- A in X. clear A.
rewrite -> comp_assoc in X. rewrite -> kleisli_eta_com in X.
rewrite <- comp_assoc in X. rewrite X. by rewrite comp_idR.
Qed. (*CLEARED*)
Lemma UR_id : Unroll << Roll =-= Id.
(*=End *)
(*=End *)
apply eta_mono.
have X:=UF_iso.
have A:eta << Roll =-= Fold by apply totalL_eta.
rewrite <- A in X. clear A.
have A:eta << Unroll =-= Unfold by apply totalL_eta.
rewrite <- A in X. clear A.
rewrite -> comp_assoc in X. rewrite -> kleisli_eta_com in X.
rewrite <- comp_assoc in X. rewrite X. by rewrite comp_idR.
Qed.

Lemma delta_simpl (e:DInf =-> DInf _BOT) : delta e =-=
  eta << Roll << ([| in1,
      (in2 <<
    ((exp_fun (CCOMP DInf (DInf _BOT) (DInf _BOT):cpoCatType _ _) (kleisli e) : cpoCatType _ _) <<
     ((exp_fun
        ((CCOMP DInf _ (DInf _BOT)) <<
         SWAP) e : cpoCatType _ _) << KLEISLI))) |]) << Unroll.
rewrite (@delta_simpl _ kcpoLimit FS leftss e).
fold Fold. fold Unfold. fold DInf. simpl. rewrite <- comp_assoc.
 rewrite {1 2} /Category.comp. simpl. have A:eta << Unroll =-= Unfold by apply totalL_eta.
rewrite <- A. rewrite (comp_assoc Unroll eta). rewrite kleisli_eta_com.
rewrite comp_assoc. apply: (comp_eq_compat _ (tset_refl Unroll)).
have B:eta << Roll =-= Fold by apply totalL_eta.
rewrite <- B. rewrite <- (comp_eq_compat (kleisli_eta_com (eta << Roll)) (tset_refl ([| _,_|]))).
rewrite <- (comp_assoc _ eta). apply comp_eq_compat ; first by [].
rewrite kleisli_eta_com.
do 4 rewrite comp_assoc. rewrite kleisli_eta_com. simpl. apply: sum_unique.
- rewrite sum_fun_fst. do 2 rewrite <- comp_assoc. by rewrite sum_fun_fst.
- rewrite sum_fun_snd. repeat rewrite <- comp_assoc. by rewrite sum_fun_snd.
Qed.

(*=minimal *)
Lemma id_min : eta =-= FIXP delta.
(*=End *)
apply tset_sym. rewrite <- (id_min kcpoLimit FS leftss). fold delta.
 simpl. apply:fmon_eq_intro => n. simpl. apply lub_eq_compat. by apply fmon_eq_intro => m.
Qed.

Lemma delta_eta : delta eta =-= eta.
by apply (delta_id_id kcpoLimit FS leftss).
Qed.

End RD.


(** * Reduction of the Halting Problem of the Heap Machine to the Halting Problem of Turing Machines *)

Require Import ProgrammingTools.
Require Import LM.Semantics LM.Alphabets LM.StepTM.

Local Arguments plus : simpl never.
Local Arguments mult : simpl never.

(** Initialise the alphabet of the [Step] Machine *)
Definition sigStep : Type := sigList sigHClos + sigHeap.
Definition retr_heap_step : Retract sigHeap sigStep := _.
Definition retr_closures_step : Retract (sigList sigHClos) sigStep := _.

Definition Loop := While (Step retr_closures_step retr_heap_step).

Definition Loop_Rel : pRel sigStep^+ unit 11 :=
  ignoreParam (
      fun tin tout =>
        forall (T V : list HClos) (H: Heap),
          tin[@Fin0] ≃ T ->
          tin[@Fin1] ≃ V ->
          tin[@Fin2] ≃ H ->
          (forall i : Fin.t 8, isRight tin[@FinR 3 i]) ->
          exists T' V' H',
            steps (T,V,H) (T',V',H') /\
            halt_state (T',V',H') /\
            match T' with
            | nil =>
              tout[@Fin0] ≃ @nil HClos /\
              tout[@Fin1] ≃ V' /\
              tout[@Fin2] ≃ H' /\
              (forall i : Fin.t 8, isRight tout[@FinR 3 i])
            | _ => True
            end
    ).

Lemma Loop_Realise : Loop ⊨ Loop_Rel.
Proof.
  eapply Realise_monotone.
  { unfold Loop. TM_Correct.
    - apply Step_Realise.
  }
  {
    apply WhileInduction; intros; intros T V heap HEncT HEncV HEncHep HInt; cbn in *.
    {
      modpon HLastStep. destruct_unit; cbn in *. modpon HLastStep.
      exists T, V, heap. repeat split; auto. constructor.
    }
    {
      modpon HStar. destruct HStar as (T1&V1&heap1&HStar); modpon HStar.
      modpon HLastStep. destruct HLastStep as (T2&V2&heap2&HLastStep); modpon HLastStep.
      do 3 eexists. repeat split. econstructor 2. all: eauto.
    }
  }
Qed.

Fixpoint Loop_steps T V H k :=
  match k with
  | 0 => Step_steps T V H
  | S k' =>
    match step_fun (T, V, H) with
    | Some (T',V',H') =>
      if is_halt_state (T',V',H')
      then 1 + Step_steps T V H + Step_steps T' V' H'
      else 1 + Step_steps T V H + Loop_steps T' V' H' k'
    | None => Step_steps T V H
    end
  end.

Definition Loop_T : tRel sigStep^+ 11 :=
  fun tin i => exists T V H k,
      halts_k (T,V,H) k /\
      tin[@Fin0] ≃ T /\
      tin[@Fin1] ≃ V /\
      tin[@Fin2] ≃ H /\
      (forall i : Fin.t 8, isRight tin[@FinR 3 i]) /\
      Loop_steps T V H k <= i.

Lemma Loop_Terminates : projT1 Loop ↓ Loop_T.
Proof.
  eapply TerminatesIn_monotone.
  { unfold Loop. TM_Correct.
    - apply Step_Realise.
    - apply Step_Terminates. }
  {
    eapply WhileCoInduction. intros tin i. intros (T&V&Heap&k&Halt&HEncT&HEncV&HEncH&HInt&Hi).
    exists (Step_steps T V Heap). repeat split.
    { hnf. do 3 eexists; repeat split; eauto. }
    intros ymid tmid HStep. cbn in HStep. modpon HStep. destruct ymid as [ () | ].
    - destruct HStep as (HStep&_).
      destruct Halt as (((T'&V')&H')&HSteps&HTerm). pose proof (halt_state_steps_k HStep HSteps) as (H&->); inv H. cbn in *. assumption.
    - destruct HStep as (T1&V1&Heap1&HStep); modpon HStep.
      destruct Halt as (((T2&V2)&H2)&HSteps&HTerm).
      unfold Loop_T; cbn.

      inv HSteps.
      + exfalso. eapply HTerm; eauto.
      + pose proof (step_functional HStep H) as <-. cbn -[step_fun] in *.
        rewrite (step_step_fun HStep) in Hi. rename k0 into k. move HTerm at bottom. clear H. rename H0 into HSteps.
        destruct (is_halt_state (T1, V1, Heap1)) eqn:EHalt.
        * apply is_halt_state_correct in EHalt. pose proof (halt_state_steps_k EHalt HSteps) as (H&->); inv H.
          exists (Step_steps T1 V1 Heap1). split.
          -- do 3 eexists. eexists 0. cbn -[step_fun]. repeat split; hnf; eauto.
          -- omega.
        * exists (Loop_steps T1 V1 Heap1 k). split.
          -- do 3 eexists. exists k. repeat split; hnf; eauto.
          -- omega.
  }
Qed.

Definition initTapes : state -> tapes sigStep^+ 11 :=
  fun '(T,V,H) => initValue T ::: initValue V ::: initValue H ::: Vector.const (initRight _) 8.

Definition Halts {sig: finType} {n: nat} (M : mTM sig n) (t : tapes sig n) :=
  exists outc k, loopM (initc M t) k = Some outc.

Theorem HaltingProblem s :
  halts s <-> Halts (projT1 Loop) (initTapes s).
Proof.
  destruct s as ((T&V)&Heap). split.
  {
    intros (s'&HSteps&HHalt).
    apply steps_steps_k in HSteps as (k&HSteps).
    destruct (@Loop_Terminates (initTapes (T,V,Heap)) (Loop_steps T V Heap k)) as (outc&Term).
    { cbn. hnf. do 4 eexists; repeat split; cbn; eauto.
      1: hnf; eauto.
      1-3: apply initValue_contains.
      intros i; destruct_fin i; cbn; apply initRight_isRight.
    }
    hnf. eauto.
  }
  {
    intros (tout&k&HLoop).
    pose proof Loop_Realise HLoop as HLoopRel. hnf in HLoopRel. modpon HLoopRel.
    1-3: apply initValue_contains.
    intros i; destruct_fin i; cbn; apply initRight_isRight.
    destruct HLoopRel as (T'&V'&H'&HStep&HTerm&_). cbn in *. hnf. eauto.
  }
Qed.

(** This vernacular command checks wether we have indeed assumed no axioms. *)
Print Assumptions HaltingProblem.
(**
<<
Closed under the global context
>>
*)


From Categories Require Import Essentials.Notations.
From Categories Require Import Essentials.Types.
From Categories Require Import Essentials.Facts_Tactics.
From Categories Require Import Category.Main.
From Categories Require Import Functor.Main.
From Categories Require Import Cat.Cat.
From Categories Require Import Ext_Cons.Prod_Cat.Prod_Cat Ext_Cons.Prod_Cat.Operations.
From Categories Require Import Basic_Cons.Product.
From Categories Require Import Basic_Cons.Exponential.
From Categories Require Import NatTrans.NatTrans NatTrans.Func_Cat NatTrans.NatIso.
From Categories Require Import Cat.Product Cat.Exponential.

(** Facts about exponentials in Cat. *)

Local Open Scope functor_scope.

Section Exp_Cat_morph_ex_compose.
  Context {C C' C'' : Category}
          (F : (C'' × C) –≻  C')
          {B : Category}
          (G : B –≻ C'')
  .

  (** This is the more specific case of curry_compose. Proven separately for cat
      because of universe polymorphism issues that prevent cat to both have
      expoenentials and type_cat in it. *)
  Theorem Exp_Cat_morph_ex_compose :
    Exp_Cat_morph_ex (F ∘ (Prod_Functor G (Functor_id C)))
    = (Exp_Cat_morph_ex F) ∘ G.
  Proof.
    Func_eq_simpl.
    {
      FunExt.
      apply NatTrans_eq_simplify.
      apply JMeq_eq.
      ElimEq; trivial.
    }
    {
      FunExt; cbn.
      Func_eq_simpl.
      FunExt.
      cbn; auto.
    }
  Qed.

End Exp_Cat_morph_ex_compose.

Section Exp_Cat_morph_ex_compose_Iso.
  Context {C C' C'' : Category}
          (F : (C'' × C) –≻  C')
          {B : Category}
          (G : B –≻ C'').

  Local Hint Extern 1 => apply NatTrans_eq_simplify; cbn.

  Program Definition Exp_Cat_morph_ex_compose_Iso_RL :
    ((Exp_Cat_morph_ex (F ∘ (Prod_Functor G (Functor_id C))))
       –≻ ((Exp_Cat_morph_ex F) ∘ G))%nattrans :=
    {|
      Trans :=
        fun c =>
          {|
            Trans := fun d => id
          |}
    |}.

  Program Definition Exp_Cat_morph_ex_compose_Iso_LR :
    (((Exp_Cat_morph_ex F) ∘ G)
       –≻ (Exp_Cat_morph_ex (F ∘ (Prod_Functor G (Functor_id C)))))%nattrans
    :=
    {|
      Trans :=
        fun c =>
          {|
            Trans := fun d => id
          |}
    |}.

  (** This is the isomorphic form of the theorem above. *)
  Program Definition Exp_Cat_morph_ex_compose_Iso :
    (((Exp_Cat_morph_ex (F ∘ (Prod_Functor G (Functor_id C))))%functor)
       ≃ ((Exp_Cat_morph_ex F) ∘ G)%functor)%natiso :=
    {|
      iso_morphism := Exp_Cat_morph_ex_compose_Iso_RL;
      inverse_morphism := Exp_Cat_morph_ex_compose_Iso_LR
    |}.

End Exp_Cat_morph_ex_compose_Iso.

Section Exp_Cat_morph_ex_NT.
  Context {C C' C'' : Category}
          {F F' : (C'' × C) –≻  C'}
          (N : (F –≻ F')%nattrans).
  (** If we have a natural transformation from F to F' then we have a natural
      transformation from (curry F) to (curry F'). *)
  Program Definition Exp_Cat_morph_ex_NT :
    ((Exp_Cat_morph_ex F) –≻ (Exp_Cat_morph_ex F'))%nattrans :=
    {|
      Trans := fun d =>
                 {|
                   Trans := fun c => Trans N (d, c);
                   Trans_com :=
                     fun c c' h => @Trans_com _ _ _ _ N (d, c) (d ,c') (id,  h);
                   Trans_com_sym :=
                     fun c c' h => @Trans_com_sym _ _ _ _ N (d, c) (d ,c') (id,  h)
                 |}
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; FunExt; cbn.
    apply Trans_com.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Exp_Cat_morph_ex_NT_obligation_1.
  Qed.

End Exp_Cat_morph_ex_NT.

Section Exp_Cat_morph_ex_Iso.
  Context {C C' C'' : Category}
          {F F' : (C'' × C) –≻ C'}
          (N : (F ≃ F')%natiso)
  .

  (** If F is naturally isomorphic to F' then (curry F) is naturally
      isomorphic to (curry F'). *)
  Program Definition Exp_Cat_morph_ex_Iso :
    (Exp_Cat_morph_ex F ≃ Exp_Cat_morph_ex F')%natiso :=
    {|
      iso_morphism := Exp_Cat_morph_ex_NT (iso_morphism N);
      inverse_morphism := Exp_Cat_morph_ex_NT (inverse_morphism N)
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality x; cbn.
    apply NatTrans_eq_simplify; extensionality y; cbn.
    change (Trans (N⁻¹) (x, y) ∘ Trans (iso_morphism N) (x, y))%morphism
    with (Trans (N⁻¹ ∘ N)%morphism (x, y)).
    rewrite left_inverse; trivial.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality x; cbn.
    apply NatTrans_eq_simplify; extensionality y; cbn.
    change (Trans (iso_morphism N) (x, y) ∘ Trans (N⁻¹) (x, y))%morphism
    with (Trans (N ∘ (N⁻¹))%morphism (x, y)).
    rewrite right_inverse; trivial.
  Qed.

End Exp_Cat_morph_ex_Iso.

Section Exp_Cat_morph_ex_inverse_NT.
  Context {C C' C'' : Category}
          {F F' : (C'' × C) –≻  C'}
          (N : ((Exp_Cat_morph_ex F) –≻ (Exp_Cat_morph_ex F'))%nattrans).

  (** If we have a natural transformation from (curry F) to (curry F') then
      we have a natural transformation from F to F'. *)
  Program Definition Exp_Cat_morph_ex_inverse_NT : (F –≻ F')%nattrans :=
    {|
      Trans := fun d => Trans (Trans N (fst d)) (snd d)
    |}.

  Local Obligation Tactic := idtac.

  Next Obligation.
  Proof.
    intros [d1 d2] [d1' d2'] [h1 h2]; cbn in *.
    replace (F @_a (_, _) (_, _) (h1, h2))%morphism
    with ((F @_a (_, _) (_, _) (id d1', h2))
            ∘ (F @_a (_, _) (_, _) (h1, id d2)))%morphism by auto.
    rewrite assoc_sym.
    cbn_rewrite (Trans_com (Trans N d1') h2).
    rewrite assoc.
    cbn_rewrite (f_equal (fun w => Trans w d2) (Trans_com N h1)).
    rewrite assoc_sym.
    rewrite <- F_compose.
    cbn; auto.
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Exp_Cat_morph_ex_inverse_NT_obligation_1.
  Qed.

End Exp_Cat_morph_ex_inverse_NT.

Section Exp_Cat_morph_ex_inverse_Iso.
  Context {C C' C'' : Category}
          {F F' : (C'' × C) –≻  C'}
          (N : (Exp_Cat_morph_ex F ≃ Exp_Cat_morph_ex F')%natiso)
  .

  (** If (curry F) is naturally isomorphic  to (curry F') then we have that F is
      naturally isomorphic to F'. *)
  Program Definition Exp_Cat_morph_ex_inverse_Iso :  (F ≃ F')%natiso :=
    {|
      iso_morphism := Exp_Cat_morph_ex_inverse_NT (iso_morphism N);
      inverse_morphism := Exp_Cat_morph_ex_inverse_NT (inverse_morphism N)
    |}.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality x; cbn.
    match goal with
      [|- ?U = _] =>
      match U with
         (Trans (Trans ?A ?X) ?Y ∘ Trans (Trans ?B ?X) ?Y)%morphism =>
         change U with (Trans (Trans (A ∘ B) X) Y)
      end
    end.
    cbn_rewrite (left_inverse N); trivial.
  Qed.

  Next Obligation.
  Proof.
    apply NatTrans_eq_simplify; extensionality x; cbn.
    match goal with
      [|- ?U = _] =>
      match U with
        (Trans (Trans ?A ?X) ?Y ∘ Trans (Trans ?B ?X) ?Y)%morphism =>
        change U with (Trans (Trans (NatTrans_compose B A) X) Y)
      end
    end.
    cbn_rewrite (right_inverse N); trivial.
  Qed.

End Exp_Cat_morph_ex_inverse_Iso.


(************************************************************************)
(* Copyright (c) 2017-2018, Ajay Kumar Eeralla <ae266@mail.missouri.edu>*)
(************************************************************************)

Require Export destructTerm.
Require Import Coq.Bool.Bool.
Set Nested Proofs Allowed.
Require Import List.
Import ListNotations.

Section auxProps.
  Axiom ifMorphPair2: forall b t1 t2 t3, (t1, If b then t2 else t3) # If b then (t1, t2) else (t1, t3).
  Axiom ifMorphPair1: forall b t1 t2 t3, (If b then t1 else t2, t3) # If b then (t1, t3) else (t2, t3).
  Axiom ifMorphf3: forall b t1 t2 t3 t4 {f: message-> message -> message -> Bool}, (f t1 t2 (If b then t3 else t4)) ## (IF b then (f t1 t2 t3) else (f t1 t2 t4)).
  Axiom ifMorphf3b_fst: forall b t1 t2 t3 t4 {f: message-> message -> message -> message}, (f (If b then t1 else t2) t3 t4) # (If b then (f t1 t3 t4) else (f t2 t3 t4)).
  Axiom andB_elim: forall b1 b2 t1 t2, (If b1 & b2 then t1 else t2) # (If b1 then (If b2 then t1 else t2) else t2).
  Axiom ifMorphIfThen: forall b1 b2 t1 t2 t3, (If b1 then (If b2 then t1 else t2) else t3) # (If b2 then (If b1 then t1 else t3) else (If b1 then t2 else t3)).
  Axiom orB_FAlse_r: forall b, b or FAlse = b.
  Axiom orB_FAlse_l: forall b, FAlse or b = b.
  Axiom ifMorphIf: forall b1 b2 b3 b4 t1 t2, (If b1 & (IF b2 then b3 else b4) then t1 else t2) # (If b2 then (If b1 & b3 then t1 else t2) else (If b1 & b4 then t1 else t2)).
  Fixpoint ifMorphDef (f: Mlist -> message) (al: Mlist) (l: Mlist) :=
    match l with
    | nil => f (al ++ nil)
    | cons (If b then t1 else t2) nil  => If b then (f (al ++ (cons t1 nil))) else (f (al ++ (cons t2 nil)))
| h :: tl => match h with
             | If b then t1 else t2 => If b then (ifMorphDef f (al ++ (cons t1 nil)) tl) else (ifMorphDef f (al ++ (cons t2 nil)) tl)
| _ => ifMorphDef f (al ++ (cons h nil)) tl
  end
  end.
  Axiom clos_sub_vtrm: forall n1 s1 n2 s2 t, let mvl:= (distMvars [msg t]) in (cons n1  (cons n2 nil))= mvl \/ (cons n2 (cons n1 nil)) = mvl -> closMsg ({{n1:=s1}} ({{n2:=s2}}t)) = true.

  (* Compute ifMorphDef f nil [O; If FAlse then nonce 1 else O; nonce 2; If TRue then (If TRue then nonce 100 else O) else nonce 4]. *)
  Axiom ifMorphAttComp: forall l, (f l) # (ifMorphDef f nil l).
  End auxProps.

  (* Axiom ifMorphAttComp: forall b f l t, (If b then (f l) else t) # (If b then (ifMorphDef f nil l) else t). *)
 Open Scope msg_scope.
(* Section auxTacs. *)
  Ltac rew_ifMorphIf :=
    match goal with
    |[|- context[(If ?B1 & (IF ?B2 then ?B3 else ?B4) then ?T1 else ?T2)] ] => rewrite (@ifMorphIf B1 B2 B3 B4 T1 T2)
    end.
  Ltac apply_ifbr ml1 ml2 b b' x x' y y' := apply (@IFBRANCH_M1 _ ml1 ml2 b b' x x' y y'); simpl.
  Ltac aply_ifbr :=
    match goal with
    | [|- [msg (If ?B1 then ?T1 else ?F1)]
            ~ [msg (If ?B2 then ?T2 else ?F2)] ]
      => apply_ifbr [] [] B1 B2 T1 T2 F1 F2
    | [|- [?X1, msg (If ?B1 then ?T1 else ?F1)]
            ~ [?Y1, msg (If ?B2 then ?T2 else ?F2)] ]
      => apply_ifbr [X1] [Y1] B1 B2 T1 T2 F1 F2
    | [|- [?X1, ?X2, msg (If ?B1 then ?T1 else ?F1)]
            ~ [?Y1, ?Y2, msg (If ?B2 then ?T2 else ?F2)] ]
      => apply_ifbr [X1, X2] [Y1, Y2] B1 B2 T1 T2 F1 F2
    | [|- [?X1, ?X2, ?X3, msg (If ?B1 then ?T1 else ?F1)]
            ~ [?Y1, ?Y2, ?Y3, msg (If ?B2 then ?T2 else ?F2)] ]
      => apply_ifbr [X1, X2, X3] [Y1, Y2, Y3] B1 B2 T1 T2 F1 F2
    | [|- [?X1, ?X2, ?X3, ?X4, msg (If ?B1 then ?T1 else ?F1)]
            ~ [?Y1, ?Y2, ?Y3, ?Y4, msg (If ?B2 then ?T2 else ?F2)] ]
      => apply_ifbr [X1, X2, X3, X4] [Y1, Y2, Y3, Y4] B1 B2 T1 T2 F1 F2
    | [|- [?X1, ?X2, ?X3, ?X4, ?X5, msg (If ?B1 then ?T1 else ?F1)]
            ~ [?Y1, ?Y2, ?Y3, ?Y4, ?Y5, msg (If ?B2 then ?T2 else ?F2)] ]
      => apply_ifbr [X1, X2, X3, X4, X5] [Y1, Y2, Y3, Y4, Y5] B1 B2 T1 T2 F1 F2
    | [|- [?X1, ?X2, ?X3, ?X4, ?X5, ?X6, msg (If ?B1 then ?T1 else ?F1)]
            ~ [?Y1, ?Y2, ?Y3, ?Y4, ?Y5, ?Y6, msg (If ?B2 then ?T2 else ?F2)] ]
      => apply_ifbr [X1, X2, X3, X4, X5, X6] [Y1, Y2, Y3, Y4, Y5, Y6] B1 B2 T1 T2 F1 F2
    | [|- [?X1, ?X2, ?X3, ?X4, ?X5, ?X6, ?X7, msg (If ?B1 then ?T1 else ?F1)]
            ~ [?Y1, ?Y2, ?Y3, ?Y4, ?Y5, ?Y6, ?Y7, msg (If ?B2 then ?T2 else ?F2)] ]
      => apply_ifbr [X1, X2, X3, X4, X5, X6, X7] [Y1, Y2, Y3, Y4, Y5, Y6, Y7] B1 B2 T1 T2 F1 F2
                    (** extend this for other cases *)
    end.

  Proposition freshNeqExt: forall (n: nat) (m: message), ^? m = true /\ (Fresh (cons n nil) [msg m]) = true -> ((nonce n) #? m) ## FAlse.
Proof. intros. pose proof(FRESHNEQ n m).
       apply (@Example10_B ((nonce n)#?m) FAlse FAlse).
       unfold const; auto.
Qed.
Ltac aply_freshneq n :=
  match goal with
  |[|-context[ (nonce n) #? ?X] ] =>  pose proof(@freshNeqExt n X) as tmp; rewrite tmp; try unfold Fresh; try auto
  end.
Axiom compHid: forall (n1 n2: nat) (t1 t2: message) {n} (z: mylist n),
    closMylist [msg t1, msg t2] = true /\ closMylist z = true /\
      Fresh [n1; n2] ([msg t1, msg t2]++z)%msg = true ->
    (|t1|#?|t2|) ## TRue ->
    (z ++ [msg (comm t1 (k n1)), msg (comm t2 (k n2))]) ~ (z ++ [msg (comm t2 (k n1)), msg (comm t1 (k n2))]).

Proposition vchecksImplyVoteEql: (vcheck (v 0)) & (vcheck (v 1)) ## TRue -> (|v 0| #? |v 1|) ## TRue.
Proof. intros.
       pose proof(vote_len_eql).
       rewrite H in H0; unfold v in H0; red_in H0; try auto.
Qed.
Ltac aplyCompHid :=
  match goal with
  | [|- [msg (comm ?V0 (kc (nonce ?N2))), msg (comm ?V1 (kc (nonce ?N3)))]
          ~ [msg (comm _ (kc (nonce _))), msg (comm _ (kc (nonce _)))] ]
    => apply (@compHid N2 N3 V0 V1 _ []%msg); try apply vchecksImplyVoteEql; try auto; try assumption
  end.

(* End auxTacs. *)
(* Definition V (b:bool) := *)
(*     match b with *)
(*     | false => (V0 (nonce 0)) *)
(*     | true => (V1 (nonce 0)) *)
(*     end. *)

(*   Definition cn (b:bool) :nat := *)
(*     match b with *)
(*     | false => 0 *)
(*     | true => 1 *)
(*     end. *)
(* SearchAbout eqb%bool. *)
(** abbreviations *)

Definition sr n := rs (nonce n).
Definition t0 seed1 seed2 := (((vk 0), (Mvar 0), sign (Mvar 0) (ssk 0) (sr seed1)), ((vk 1), (Mvar 1), sign (Mvar 1) (ssk 1) (sr seed2))).

Definition tau n (m:message) := match n, m with
                                | 1, m => (pi1 m)
                                | 2, m => (pi1 (pi2 m))
                                | 3, m => (pi2 (pi2 m))
                                | _, _ => O
                                end.

Definition d n x := (dec (tau n x) (ske 11)).
Definition pvchecks x := ((pi2 (d 1 x)) #? TWO) & ((pi2 (d 2 x)) #? TWO) & ((pi2 (d 3 x)) #? TWO).
Definition pochecks x := ((tau 3 (d 1 x)) #? THREE) & ((tau 3 (d 2 x)) #? THREE) & ((tau 3 (d 3 x)) #? THREE).

Definition dist x := !((d 1 x) #? (d 2 x)) & !((d 1 x) #? (d 3 x))& ! ((d 2 x) #? (d 3 x)).
Definition isin (x y:message):Bool := (x #? (tau 1 y)) or (x #? (tau 2 y)) or (x #? (tau 3 y)).
Definition bcheck (x y:message):Bool := (isin x ((tau 1 (pi2 (tau 1 y))), ((tau 1 (pi2 (tau 2 y))), (tau 1 (pi2 (tau 3 y)))))).
Definition ncheck (x y:message):Bool := (isin x ((tau 3 (pi2 (tau 1 y))), ((tau 3 (pi2 (tau 2 y))), (tau 3 (pi2 (tau 3 y)))))).

                            Definition lbl:= |(nonce 100)|.
Definition label x y := If (x #? (tau 2 (pi2 (tau 1 y)))) then (pi1 (tau 1 y))
                           else  (If (x#? (tau 2 (pi2 (tau 2 y)))) then (pi1 (tau 2 y))
                                                       else (If (x #? (tau 2 (pi2 (tau 3 y)))) then (pi1 (tau 3 y))
                                                             else O)).
Add Parametric Morphism :(@label) with
signature EQm ==> EQm ==> EQm as label_mor.
Proof. intros; aply_cong; auto. Qed.

Definition bnlcheck( x y z:message):Bool:= (bcheck x z) & (|(label x z)| #? lbl) & (ncheck y z).

(* Add morphism for bnlcheck *)
Add Parametric Morphism :(@bnlcheck) with
    signature EQm ==> EQm ==> EQm ==> EQb as bnlcheck_mor.
Proof. intros; aply_cong; auto. Qed.

Definition mvchecks x (n n':nat) := (dist (x n n')) & (pvchecks (x n n')).

Definition p n x := ( (tau 1 (d n x)), (tau 2 (d n x))).

Definition sotrm x := (shufl (p 1 x) (p 2 x) (p 3 x)).

Definition isink (x y:message):Bool := (x #? (tau 2 (d 1 y))) or (x #? (tau 2 (d 2 y))) or (x #? (tau 2 (d 3 y))).

Lemma tau1: forall x y z, (tau 1 (x, (y, z))) # x.
Proof. intros. unfold tau. rewrite proj1; auto. reflexivity.
Qed.
Lemma tau2: forall x y z, (tau 2 (x, (y, z))) # y.
Proof. intros. unfold tau; rewrite proj2, proj1;auto. reflexivity. Qed.
Lemma tau3: forall x y z, (tau 3 (x, (y, z))) # z.
Proof. intros. unfold tau. repeat rewrite proj2; try reflexivity.
Qed.
(* better to apply nodup seperately *)
Axiom nodup: forall {m} (l1 l2: mylist m), let l1' := conv_mylist_listos l1 in
                                           let l2' := conv_mylist_listos l2 in
                                           let l1'' := noDup l1' in
                                           let l2'' := noDup l2' in
                                           let y:= oslToMylist l1'' l2'' in
                                           (pi1ProdMylist y) ~ (pi2ProdMylist y) -> l1 ~ l2.

Axiom cca2Trans: forall {m} {l1 l2 l1' l2': mylist m}, l1 ~ l1' /\ l2 ~ l2' /\ l1' ~ l2' -> l1 ~ l2.
Ltac aply_cca2Trans L R :=
  match goal with
  | [|- ?X ~ ?Y] => apply (@cca2Trans _ X Y L R); try split
  end.

Ltac aplyCCA2 n n1 n2 n3 u u' := aplyDestrEnc 11 7; apply nodup; simpl;
  match goal with
  | [|- ?X ~ ?Y] => apply (@subMvarEnc n n1 n2 n3 u u' _ X Y); simpl; (* replace encryptions with (Mvar n) *)
                    match goal with
                    | [|- ?X1 ~ ?Y1] => apply (@rewDecs n n1 u u' _ X1 Y1); simpl; (* rewrite decryptions to pass the cca2compliance *)
                                        match goal with
                                        |[|- ?X2 ~ ?Y2] => apply (@ENCCCA2 n n1 n2 n3 u u' _ X2); repeat (try apply len_reg; try rewrite eqmeql; try apply nameEql; try simpl; try intuition)
                                        end
                    end
  end.
(* Some stuff *)
Axiom funcapp_f1m': forall {n n'} f p1 (z z':mylist n) (z1 z1':mylist n'), (z ++ z1) ~ (z' ++ z1') -> ((z ++ z1) ++ [msg (f (ostomsg (getelt_at_pos p1 z1)))]) ~ ((z' ++ z1') ++ [msg (f (ostomsg (getelt_at_pos p1 z1')))]).
Ltac funcapp_f1m'_in g n H:= apply funcapp_f1m' with (f:=g) (p1:=n) in H; unfold getelt_at_pos in H; simpl in H.
Axiom ifmor_ifm: forall f b x y, (f (If b then x else y)) # (If b then (f x) else (f y)).

Lemma extFuncapp1: forall n b b' x x' y y' (z z': mylist n) g, (z ++ [bol b, msg (If b then x else y)]) ~ (z' ++ [bol b', msg (If b' then x' else y')]) -> (z ++ [bol b, msg (If b then x else y), msg (If b then (g x) else |_)])~ (z' ++ [bol b', msg (If b' then x' else y'), msg (If b' then (g x') else |_)]).
Proof. intros.
       funcapp_f1m'_in g 2 H.
       simpl.
       repeat rewrite ifmor_ifm in H.
       funcapp_fm_last |_ H; auto. apply ind_assoc in H; simpl in H.
       apply funcapp_f3bm' with (f:= (ifm_then_else_)) (p1:= 1) (p2:=3) (p3:=4) in H; unfold getelt_at_pos; simpl in H.
       simpl in H.
       (********************)
       apply ind_assoc in H; simpl in H.
       do 2  apply restr with (p:= droplastsec) in H; unfold droplastsec in H; simpl in H; simpl; try rewrite Nat.eqb_refl; auto.
       repeat rewrite aply_ifeval_gen in H;auto. Qed.