Require Import Coq.Lists.List. Import ListNotations.
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.IdfunWithAlt.
Require Import Crypto.Util.LetIn.
Require Crypto.Util.Tuple. Local Notation tuple := Tuple.tuple.
Local Open Scope Z_scope.

Create HintDb push_id discriminated.
Create HintDb uncps discriminated.

Lemma push_id {A} (a:A) : id a = a. reflexivity. Qed.
Hint Rewrite @push_id : push_id.

Definition id_with_alt_cps' {R A} (value value_for_alt : (A -> A) -> A) (f : A -> R) : R
  := dlet z := id_with_alt (value id) (value_for_alt id) in
     f z.
Definition id_with_alt_cps'' {R A} (value value_for_alt : (A -> R) -> R) (f : A -> R) : R
  := id_with_alt (value f) (value_for_alt f).
Definition id_with_alt_cps {R A} (value value_for_alt : forall R, (A -> R) -> R) (f : A -> R) : R
  := id_with_alt_cps' (value _) (value_for_alt _) f.
Definition id_with_alt_cps'_correct {R A} value value_for_alt f
  : @id_with_alt_cps' R A value value_for_alt f = f (id_with_alt (value id) (value_for_alt id))
  := eq_refl.
Hint Rewrite @id_with_alt_cps'_correct : uncps.
Definition id_with_alt_cps''_correct {R A} value value_for_alt f
  : @id_with_alt_cps'' R A value value_for_alt f = id_with_alt (value f) (value_for_alt f)
  := eq_refl.
Hint Rewrite @id_with_alt_cps''_correct : uncps.
Definition id_with_alt_cps_correct {R A} value value_for_alt f
  : @id_with_alt_cps R A value value_for_alt f = f (id_with_alt (value _ id) (value_for_alt _ id))
  := eq_refl.
Hint Rewrite @id_with_alt_cps_correct : uncps.
Definition id_with_alt_cps'_correct_gen {R A} (value value_for_alt : forall R, (A -> R) -> R) f
  : @id_with_alt_cps' R A (value _) (value_for_alt _) f = f (id_with_alt (value _ id) (value_for_alt _ id))
  := eq_refl.
Hint Rewrite @id_with_alt_cps'_correct_gen : uncps.
Definition id_with_alt_cps''_correct_gen {R A} (value value_for_alt : forall R, (A -> R) -> R) f
           (Hvalue : value _ f = f (value _ id))
  : @id_with_alt_cps'' R A (value _) (value_for_alt _) f = f (id_with_alt (value _ id) (value_for_alt _ id)).
Proof.
  cbv [id_with_alt_cps'' id_with_alt]; assumption.
Defined.
Hint Rewrite @id_with_alt_cps''_correct_gen : uncps.

Definition id_tuple'_with_alt_cps' {R A n}
           (value value_for_alt : (Tuple.tuple' A n -> Tuple.tuple' A n) -> Tuple.tuple' A n)
           (f : Tuple.tuple' A n -> R)
  : R
  := dlet z := id_tuple'_with_alt (value id) (value_for_alt id) in
     f z.
Definition id_tuple_with_alt_cps' {R A n}
           (value value_for_alt : (Tuple.tuple A n -> Tuple.tuple A n) -> Tuple.tuple A n)
           (f : Tuple.tuple A n -> R)
  : R
  := dlet z := id_tuple_with_alt (value id) (value_for_alt id) in
     f z.

Definition id_tuple'_with_alt_cps'_correct {R A n} value value_for_alt f
  : @id_tuple'_with_alt_cps' R A n value value_for_alt f = f (id_tuple'_with_alt (value id) (value_for_alt id))
  := eq_refl.
Hint Rewrite @id_tuple'_with_alt_cps'_correct : uncps.

Definition id_tuple_with_alt_cps'_correct {R A n} value value_for_alt f
  : @id_tuple_with_alt_cps' R A n value value_for_alt f = f (id_tuple_with_alt (value id) (value_for_alt id))
  := eq_refl.
Hint Rewrite @id_tuple_with_alt_cps'_correct : uncps.

Definition id_tuple'_with_alt_cps'' {R A n}
           (value value_for_alt : (Tuple.tuple' A n -> R) -> R)
           (f : Tuple.tuple' A n -> R)
  : R
  := id_with_alt (value f) (value_for_alt f).
Definition id_tuple_with_alt_cps'' {R A n}
           (value value_for_alt : (Tuple.tuple A n -> R) -> R)
           (f : Tuple.tuple A n -> R)
  : R
  := id_with_alt (value f) (value_for_alt f).

Definition id_tuple'_with_alt_cps''_correct {R A n} value value_for_alt f
  : @id_tuple'_with_alt_cps'' R A n value value_for_alt f = id_with_alt (value f) (value_for_alt f)
  := eq_refl.
Hint Rewrite @id_tuple'_with_alt_cps''_correct : uncps.

Definition id_tuple_with_alt_cps''_correct {R A n} value value_for_alt f
  : @id_tuple_with_alt_cps'' R A n value value_for_alt f = id_with_alt (value f) (value_for_alt f)
  := eq_refl.
Hint Rewrite @id_tuple_with_alt_cps''_correct : uncps.

Definition id_tuple'_with_alt_cps''_correct_gen {R A n}
           (value value_for_alt : forall R, (_ -> R) -> R) f
           (Hvalue : value _ f = f (value _ id))
  : @id_tuple'_with_alt_cps'' R A n (value _) (value_for_alt _) f = f (id_tuple'_with_alt (value _ id) (value_for_alt _ id)).
Proof.
  autorewrite with uncps.
  rewrite ?unfold_id_tuple'_with_alt, ?unfold_id_tuple_with_alt, ?unfold_id_with_alt, Hvalue.
  reflexivity.
Qed.
Hint Rewrite @id_tuple'_with_alt_cps''_correct_gen : uncps.

Definition id_tuple_with_alt_cps''_correct_gen {R A n}
           (value value_for_alt : forall R, (_ -> R) -> R) f
           (Hvalue : value _ f = f (value _ id))
  : @id_tuple_with_alt_cps'' R A n (value _) (value_for_alt _) f = f (id_tuple_with_alt (value _ id) (value_for_alt _ id)).
Proof.
  autorewrite with uncps.
  rewrite ?unfold_id_tuple_with_alt, ?unfold_id_tuple_with_alt, ?unfold_id_with_alt, Hvalue.
  reflexivity.
Qed.
Hint Rewrite @id_tuple_with_alt_cps''_correct_gen : uncps.

Definition id_tuple'_with_alt_cps {R A n}
           (value value_for_alt : forall R, (Tuple.tuple' A n -> R) -> R)
           (f : Tuple.tuple' A n -> R)
  : R
  := id_tuple'_with_alt_cps' (value _) (value_for_alt _) f.
Definition id_tuple_with_alt_cps {R A n}
           (value value_for_alt : forall R, (Tuple.tuple A n -> R) -> R)
           (f : Tuple.tuple A n -> R)
  : R
  := id_tuple_with_alt_cps' (value _) (value_for_alt _) f.

Definition id_tuple'_with_alt_cps_correct {R A n} value value_for_alt f
  : @id_tuple'_with_alt_cps R A n value value_for_alt f = f (id_tuple'_with_alt (value _ id) (value_for_alt _ id))
  := eq_refl.
Hint Rewrite @id_tuple'_with_alt_cps_correct : uncps.

Definition id_tuple_with_alt_cps_correct {R A n} value value_for_alt f
  : @id_tuple_with_alt_cps R A n value value_for_alt f = f (id_tuple_with_alt (value _ id) (value_for_alt _ id))
  := eq_refl.
Hint Rewrite @id_tuple_with_alt_cps_correct : uncps.

Lemma update_nth_id {T} i (xs:list T) : ListUtil.update_nth i id xs = xs.
Proof.
  revert xs; induction i; destruct xs; simpl; solve [ trivial | congruence ].
Qed.

Lemma map_fst_combine {A B} (xs:list A) (ys:list B) : List.map fst (List.combine xs ys) = List.firstn (length ys) xs.
Proof.
  revert xs; induction ys; destruct xs; simpl; solve [ trivial | congruence ].
Qed.

Lemma map_snd_combine {A B} (xs:list A) (ys:list B) : List.map snd (List.combine xs ys) = List.firstn (length xs) ys.
Proof.
  revert xs; induction ys; destruct xs; simpl; solve [ trivial | congruence ].
Qed.

Lemma nth_default_seq_inbouns d s n i (H:(i < n)%nat) :
  List.nth_default d (List.seq s n) i = (s+i)%nat.
Proof.
  progress cbv [List.nth_default].
  rewrite ListUtil.nth_error_seq.
  break_innermost_match; solve [ trivial | lia ].
Qed.

Lemma mod_add_mul_full a b c k m : m <> 0 -> c mod m = k mod m ->
                                   (a + b * c) mod m = (a + b * k) mod m.
Proof.
  intros; rewrite Z.add_mod, Z.mul_mod by auto.
  match goal with H : _ mod _ = _ mod _ |- _ => rewrite H end.
  rewrite <-Z.mul_mod, <-Z.add_mod by auto; reflexivity.
Qed.

Fixpoint map_cps {A B} (g : A->B) ls
         {T} (f:list B->T):=
  match ls with
  | nil => f nil
  | a :: t => map_cps g t (fun r => f (g a :: r))
  end.
Lemma map_cps_correct {A B} g ls: forall {T} f,
    @map_cps A B g ls T f = f (map g ls).
Proof. induction ls as [|?? IHls]; simpl; intros; rewrite ?IHls; reflexivity. Qed.
Hint Rewrite @map_cps_correct : uncps.

Fixpoint map_cps2 {A B} (g : A->forall T, (B -> T) -> T) ls
         {T} (f:list B->T) : T:=
  match ls with
  | nil => f nil
  | a :: t => map_cps2 g t (fun r => g a _ (fun ga => f (ga :: r)))
  end.
Lemma map_cps2_correct {A B} g g' (Hg : forall T k a, g a T k = k (g' a)) ls : forall {T} f,
    @map_cps2 A B g ls T f = f (map g' ls).
Proof. induction ls as [|?? IHls]; simpl; intros; rewrite ?IHls, ?Hg; reflexivity. Qed.

Definition firstn_cps {A} (n:nat) (l:list A) {T} (f:list A->T) :=
  match n with
  | O => f nil
  | S n' => match l with
            | nil => f nil
            | a :: l' => f (a :: firstn n' l')
            end
  end.
Lemma firstn_cps_correct {A} n l T f :
  @firstn_cps A n l T f = f (firstn n l).
Proof. induction n; destruct l; reflexivity. Qed.
Hint Rewrite @firstn_cps_correct : uncps.

Fixpoint flat_map_cps_specialized {T A B} (g:A->(list B->T)->T) (ls : list A) (f:list B->T)  :=
  match ls with
  | nil => f nil
  | (x::tl)%list => g x (fun r => flat_map_cps_specialized g tl (fun rr => f (r ++ rr))%list)
  end.

Definition flat_map_cps {A B} (g:A->forall {T}, (list B->T)->T) (ls : list A) {T} (f:list B->T)
  := @flat_map_cps_specialized T A B (fun a => @g a T) ls f.
Lemma unfold_flat_map_cps {A B} (g:A->forall {T}, (list B->T)->T) (ls : list A) {T} (f:list B->T)
  : @flat_map_cps A B g ls T f
    = match ls with
      | nil => f nil
      | (x::tl)%list => g x (fun r => flat_map_cps g tl (fun rr => f (r ++ rr))%list)
      end.
Proof. destruct ls; reflexivity. Qed.
Lemma flat_map_cps_correct {A B} (g:A->forall {T}, (list B->T)->T) ls :
  forall {T} (f:list B->T),
    (forall x T h, @g x T h = h (g x id)) ->
    @flat_map_cps A B g ls T f = f (List.flat_map (fun x => g x id) ls).
Proof.
  induction ls as [|?? IHls]; intros T f H; [reflexivity|].
  rewrite unfold_flat_map_cps. simpl @flat_map.
  rewrite H; erewrite IHls by eassumption.
  reflexivity.
Qed.
Hint Rewrite @flat_map_cps_correct using (intros; autorewrite with uncps; auto): uncps.

Fixpoint from_list_default'_cps {A} (d y:A) n xs {T}:
  (Tuple.tuple' A n -> T) -> T:=
  match n as n0 return ((Tuple.tuple' A n0 ->T) ->T) with
  | O => fun f => f y
  | S n' => fun f =>
              match xs with
              | nil => from_list_default'_cps d d n' nil (fun r => f (r, y))
              | x :: xs' => from_list_default'_cps d x n' xs' (fun r => f (r, y))
              end
  end.
Lemma from_list_default'_cps_correct {A} n : forall d y l {T} f,
    @from_list_default'_cps A d y n l T f = f (Tuple.from_list_default' d y n l).
Proof.
  induction n as [|? IHn]; intros; simpl; [reflexivity|].
  break_match; subst; apply IHn.
Qed.
Definition from_list_default_cps {A} (d:A) n (xs:list A) {T} :
  (Tuple.tuple A n -> T) -> T:=
  match n as n0 return ((Tuple.tuple A n0 ->T) ->T) with
  | O => fun f => f tt
  | S n' => fun f =>
              match xs with
              | nil => from_list_default'_cps d d n' nil f
              | x :: xs' => from_list_default'_cps d x n' xs' f
              end
  end.
Lemma from_list_default_cps_correct {A} n : forall d l {T} f,
    @from_list_default_cps A d n l T f = f (Tuple.from_list_default d n l).
Proof.
  destruct n; intros; simpl; [reflexivity|].
  break_match; auto using from_list_default'_cps_correct.
Qed.
Hint Rewrite @from_list_default_cps_correct : uncps.
Fixpoint to_list'_cps {A} n
         {T} (f:list A -> T) : Tuple.tuple' A n -> T :=
  match n as n0 return (Tuple.tuple' A n0 -> T) with
  | O => fun x => f [x]
  | S n' => fun (xs: Tuple.tuple' A (S n')) =>
              let (xs', x) := xs in
              to_list'_cps n' (fun r => f (x::r)) xs'
  end.
Lemma to_list'_cps_correct {A} n: forall t {T} f,
    @to_list'_cps A n T f t = f (Tuple.to_list' n t).
Proof.
  induction n; simpl; intros; [reflexivity|].
  destruct_head prod. apply IHn.
Qed.
Definition to_list_cps' {A} n {T} (f:list A->T)
  : Tuple.tuple A n -> T :=
  match n as n0 return (Tuple.tuple A n0 ->T) with
  | O => fun _ => f nil
  | S n' => to_list'_cps n' f
  end.
Definition to_list_cps {A} n t {T} f :=
  @to_list_cps' A n T f t.
Lemma to_list_cps_correct {A} n t {T} f :
  @to_list_cps A n t T f = f (Tuple.to_list n t).
Proof. cbv [to_list_cps to_list_cps' Tuple.to_list]; break_match; auto using to_list'_cps_correct. Qed.
Hint Rewrite @to_list_cps_correct : uncps.

Definition on_tuple_cps {A B} (d:B) (g:list A ->forall {T},(list B->T)->T) {n m}
           (xs : Tuple.tuple A n) {T} (f:tuple B m ->T) :=
  to_list_cps n xs (fun r => g r (fun rr => from_list_default_cps d m rr f)).
Lemma on_tuple_cps_correct {A B} d (g:list A -> forall {T}, (list B->T)->T)
      {n m} xs {T} f
      (Hg : forall x {T} h, @g x T h = h (g x id)) : forall H,
    @on_tuple_cps A B d g n m xs T f = f (@Tuple.on_tuple A B (fun x => g x id) n m H xs).
Proof.
  cbv [on_tuple_cps Tuple.on_tuple]; intros H.
  rewrite to_list_cps_correct, Hg, from_list_default_cps_correct.
  rewrite (Tuple.from_list_default_eq _ _ _ (H _ (Tuple.length_to_list _))).
  reflexivity.
Qed.  Hint Rewrite @on_tuple_cps_correct using (intros; autorewrite with uncps; auto): uncps.

Fixpoint update_nth_cps {A} n (g:A->A) xs {T} (f:list A->T) :=
  match n with
  | O =>
    match xs with
    | [] => f []
    | x' :: xs' => f (g x' :: xs')
    end
  | S n' =>
    match xs with
    | [] => f []
    | x' :: xs' => update_nth_cps n' g xs' (fun r => f (x' :: r))
    end
  end.
Lemma update_nth_cps_correct {A} n g: forall xs T f,
    @update_nth_cps A n g xs T f = f (update_nth n g xs).
Proof. induction n; intros; simpl; break_match; try apply IHn; reflexivity. Qed.
Hint Rewrite @update_nth_cps_correct : uncps.

Fixpoint combine_cps {A B} (la :list A) (lb : list B)
         {T} (f:list (A*B)->T) :=
  match la with
  | nil => f nil
  | a :: tla =>
    match lb with
    | nil => f nil
    | b :: tlb => combine_cps tla tlb (fun lab => f ((a,b)::lab))
    end
  end.
Lemma combine_cps_correct {A B} la: forall lb {T} f,
    @combine_cps A B la lb T f = f (combine la lb).
Proof.
  induction la; simpl combine_cps; simpl combine; intros;
    try break_match; try apply IHla; reflexivity.
Qed.
Hint Rewrite @combine_cps_correct: uncps.

(* differs from fold_right_cps in that the functional argument `g` is also a CPS function *)
Local Set Universe Polymorphism.
Definition fold_right_cps2_specialized_step
           (fold_right_cps2_specialized
            : forall {T A B} (g : B -> A -> (A->T)->T) (a0 : A) (l : list B) (f : A -> T), _)
           {T A B} (g : B -> A -> (A->T)->T) (a0 : A) (l : list B) (f : A -> T) :=
  match l with
  | nil => f a0
  | b :: tl => fold_right_cps2_specialized g a0 tl (fun r => g b r f)
  end.
Fixpoint fold_right_cps2_specialized {T A B} (g : B -> A -> (A->T)->T) (a0 : A) (l : list B) (f : A -> T) :=
  @fold_right_cps2_specialized_step (@fold_right_cps2_specialized) T A B g a0 l f.
Definition fold_right_cps2 {A B} (g : B -> A -> forall {T}, (A->T)->T) (a0 : A) (l : list B) {T} (f : A -> T) :=
  @fold_right_cps2_specialized T A B (fun b a => @g b a T) a0 l f.
Local Unset Universe Polymorphism.
Lemma unfold_fold_right_cps2 {A B} (g : B -> A -> forall {T}, (A->T)->T) (a0 : A) (l : list B) {T} (f : A -> T)
  : @fold_right_cps2 A B g a0 l T f
    = match l with
      | nil => f a0
      | b :: tl => fold_right_cps2 g a0 tl (fun r => g b r f)
      end.
Proof. destruct l; reflexivity. Qed.
Lemma fold_right_cps2_correct {A B} g a0 l : forall {T} f,
  (forall b a T h, @g b a T h = h (@g b a A id)) ->
  @fold_right_cps2 A B g a0 l T f = f (List.fold_right (fun b a => @g b a A id) a0 l).
Proof.
  induction l as [|?? IHl]; intros T f H; [reflexivity|].
  rewrite unfold_fold_right_cps2. simpl fold_right.
  rewrite H; erewrite IHl by eassumption.
  rewrite H; reflexivity.
Qed.
Hint Rewrite @fold_right_cps2_correct using (intros; autorewrite with uncps; auto): uncps.

Definition fold_right_no_starter {A} (f:A->A->A) ls : option A :=
  match ls with
  | nil => None
  | cons x tl => Some (List.fold_right f x tl)
  end.
Lemma fold_right_min ls x :
  x = List.fold_right Z.min x ls
  \/ List.In (List.fold_right Z.min x ls) ls.
Proof.
  induction ls; intros; simpl in *; try tauto.
  match goal with |- context [Z.min ?x ?y] =>
                  destruct (Z.min_spec x y) as [[? Hmin]|[? Hmin]]
  end; rewrite Hmin; tauto.
Qed.
Lemma fold_right_no_starter_min ls : forall x,
    fold_right_no_starter Z.min ls = Some x ->
    List.In x ls.
Proof.
  cbv [fold_right_no_starter]; intros; destruct ls; try discriminate.
  inversion H; subst; clear H.
  destruct (fold_right_min ls z);
    simpl List.In; tauto.
Qed.
Fixpoint fold_right_cps {A B} (g:B->A->A) (a0:A) (l:list B) {T} (f:A->T) :=
  match l with
  | nil => f a0
  | cons a tl => fold_right_cps g a0 tl (fun r => f (g a r))
  end.
Lemma fold_right_cps_correct {A B} g a0 l: forall {T} f,
    @fold_right_cps A B g a0 l T f = f (List.fold_right g a0 l).
Proof. induction l as [|? l IHl]; intros; simpl; rewrite ?IHl; auto. Qed.
Hint Rewrite @fold_right_cps_correct : uncps.

Definition fold_right_no_starter_cps {A} g ls {T} (f:option A->T) :=
  match ls with
  | nil => f None
  | cons x tl => f (Some (List.fold_right g x tl))
  end.
Lemma fold_right_no_starter_cps_correct {A} g ls {T} f :
  @fold_right_no_starter_cps A g ls T f = f (fold_right_no_starter g ls).
Proof.
  cbv [fold_right_no_starter_cps fold_right_no_starter]; break_match; reflexivity.
Qed.
Hint Rewrite @fold_right_no_starter_cps_correct : uncps.

Import Tuple.

Module Tuple.
  Fixpoint map_cps {A B n} (g : A->B) (t : tuple A n) {T} :
    (tuple B n->T) -> T:=
  match n return tuple A n -> (tuple B n -> T) -> T with
  | O => fun _ f => f tt
  | S n' => fun t f => map_cps g (tl t) (fun r => f (append (g (hd t)) r))
  end t.
  Lemma map_cps_correct {A B n} g t: forall {T} f,
      @map_cps A B n g t T f = f (map g t).
  Proof.
    induction n; simpl map_cps; intros; try destruct t;
    [|rewrite IHn, <-map_append,<-subst_append]; reflexivity.
  Qed. Hint Rewrite @map_cps_correct : uncps.

  Fixpoint map2_cps {n A B C} (g:A->B->C) (xs:tuple A n) (ys:tuple B n) {T} :
    (tuple C n->T) -> T :=
    match n return tuple _ n -> tuple _ n -> (tuple C n -> T) -> T with
    | O => fun _ _ f => f tt
    | S n' => fun xs ys f =>
                map2_cps g (tl xs) (tl ys) (fun zs => f (append (g (hd xs) (hd ys)) zs))
    end xs ys.
  Lemma map2_cps_correct {n A B C} g xs ys : forall {T} f,
      @map2_cps n A B C g xs ys T f = f (map2 g xs ys).
  Proof.
    induction n; simpl map2_cps; intros; try destruct xs, ys;
    [|rewrite IHn, <-map2_append,<-!subst_append]; reflexivity.
  Qed. Hint Rewrite @map2_cps_correct : uncps.

  Section internal_mapi_with_cps.
    (* We define fixpoints with fewer parameters to the internal [fix] to allow unfolding to partially specialize them *)
    Context {R T A B : Type}
            (f: nat->T->A->(T*B->R)->R).

    Fixpoint mapi_with'_cps_specialized {n} i
             (start:T)
      : Tuple.tuple' A n -> (T * tuple' B n -> R) -> R :=
      match n as n0 return (tuple' A n0 -> (T * tuple' B n0->R)->R) with
      | O => fun ys ret => f i start ys ret
      | S n' => fun ys ret =>
                  f i start (hd ys) (fun sb =>
                  mapi_with'_cps_specialized (S i) (fst sb) (tl ys)
                      (fun r => ret (fst r, (snd r, snd sb))))
      end.
  End internal_mapi_with_cps.

  Definition mapi_with'_cps {T A B n} i
          (f: nat->T->A->forall {R}, (T*B->R)->R) (start:T)
    : Tuple.tuple' A n -> forall {R}, (T * tuple' B n -> R) -> R
    := fun ts {R} => @mapi_with'_cps_specialized R T A B (fun n t a => @f n t a R) n i start ts.

  Definition mapi_with_cps {S A B n}
          (f: nat->S->A->forall {T}, (S*B->T)->T) (start:S) (ys:tuple A n) {T}
    : (S * tuple B n->T)->T :=
  match n as n0 return (tuple A n0 -> (S * tuple B n0->T)->T) with
  | O => fun ys ret => ret (start, tt)
  | S n' => fun ys ret => mapi_with'_cps 0%nat f start ys ret
  end ys.

  Lemma unfold_mapi_with'_cps {T A B n} i
        (f: nat->T->A->forall {R}, (T*B->R)->R) (start:T)
    : @mapi_with'_cps T A B n i f start
      = match n as n0 return (tuple' A n0 -> forall {R}, (T * tuple' B n0->R)->R) with
        | O => fun ys T ret => f i start ys ret
        | S n' => fun ys T ret =>
                    f i start (hd ys) (fun sb =>
                    mapi_with'_cps (S i) f (fst sb) (tl ys)
                        (fun r => ret (fst r, (snd r, snd sb))))
        end.
  Proof. destruct n; reflexivity. Qed.

  Lemma mapi_with'_cps_correct {S A B n} : forall i f start xs T ret,
  (forall i s a R (ret:_->R), f i s a R ret = ret (f i s a _ id)) ->
  @mapi_with'_cps S A B n i f start xs T ret = ret (mapi_with' i (fun i s a => f i s a _ id) start xs).
  Proof. induction n as [|n IHn]; intros i f start xs T ret H; simpl; rewrite H, ?IHn by assumption; reflexivity. Qed.
  Lemma mapi_with_cps_correct {S A B n} f start xs T ret
  (H:forall i s a R (ret:_->R), f i s a R ret = ret (f i s a _ id))
  : @mapi_with_cps S A B n f start xs T ret = ret (mapi_with (fun i s a => f i s a _ id) start xs).
  Proof. destruct n; simpl; rewrite ?mapi_with'_cps_correct by assumption; reflexivity. Qed.
  Hint Rewrite @mapi_with_cps_correct @mapi_with'_cps_correct
       using (intros; autorewrite with uncps; auto): uncps.

  Section internal_mapi_with_cps2.
    (* We define fixpoints with fewer parameters to the internal [fix] to allow unfolding to partially specialize them *)
    Context {R T A B : Type}
            (f: nat->T->A->(T*B->R)->R).

    Fixpoint mapi_with'_cps2_specialized {n} i
             (start:T)
      : Tuple.tuple' A n -> (T * tuple' B n -> R) -> R :=
      match n as n0 return (tuple' A n0 -> (T * tuple' B n0->R)->R) with
      | O => fun ys ret => f i start ys ret
      | S n' => fun ys ret =>
                  f i start (hd ys) (fun sb =>
                  mapi_with'_cps2_specialized (S i) (fst sb) (tl ys)
                      (fun r => ret (fst r, (snd r, snd sb))))
      end.
  End internal_mapi_with_cps2.

  Definition mapi_with'_cps2 {T A B n} i
          (f: nat->T->A->forall {R}, (T*B->R)->R) (start:T)
    : Tuple.tuple' A n -> forall {R}, (T * tuple' B n -> R) -> R
    := fun ts {R} => @mapi_with'_cps2_specialized R T A B (fun n t a => @f n t a R) n i start ts.

  Definition mapi_with_cps2 {S A B n}
          (f: nat->S->A->forall {T}, (S*B->T)->T) (start:S) (ys:tuple A n) {T}
    : (S * tuple B n->T)->T :=
  match n as n0 return (tuple A n0 -> (S * tuple B n0->T)->T) with
  | O => fun ys ret => ret (start, tt)
  | S n' => fun ys ret => mapi_with'_cps2 0%nat f start ys ret
  end ys.

  Lemma unfold_mapi_with'_cps2 {T A B n} i
        (f: nat->T->A->forall {R}, (T*B->R)->R) (start:T)
    : @mapi_with'_cps2 T A B n i f start
      = match n as n0 return (tuple' A n0 -> forall {R}, (T * tuple' B n0->R)->R) with
        | O => fun ys T ret => f i start ys ret
        | S n' => fun ys T ret =>
                    f i start (hd ys) (fun sb =>
                    mapi_with'_cps2 (S i) f (fst sb) (tl ys)
                        (fun r => ret (fst r, (snd r, snd sb))))
        end.
  Proof. destruct n; reflexivity. Qed.

  Lemma mapi_with'_cps2_correct {S A B n} : forall i f start xs T ret,
  (forall i s a R (ret:_->R), f i s a R ret = ret (f i s a _ id)) ->
  @mapi_with'_cps2 S A B n i f start xs T ret = ret (mapi_with' i (fun i s a => f i s a _ id) start xs).
  Proof. induction n as [|n IHn]; intros i f start xs T ret H; simpl; rewrite H, ?IHn by assumption; reflexivity. Qed.
  Lemma mapi_with_cps2_correct {S A B n} f start xs T ret
  (H:forall i s a R (ret:_->R), f i s a R ret = ret (f i s a _ id))
  : @mapi_with_cps2 S A B n f start xs T ret = ret (mapi_with (fun i s a => f i s a _ id) start xs).
  Proof. destruct n; simpl; rewrite ?mapi_with'_cps2_correct by assumption; reflexivity. Qed.
  Hint Rewrite @mapi_with_cps2_correct @mapi_with'_cps2_correct
       using (intros; autorewrite with uncps; auto): uncps.

  Fixpoint left_append_cps {A n} (x:A) (xs:tuple A n) {R} :
    (tuple A (S n) -> R) -> R :=
  match
    n as n0 return (tuple A n0 -> (tuple A (S n0) -> R) -> R)
  with
  | 0%nat => fun _ f => f x
  | S n' =>
      fun xs f =>
      left_append_cps x (tl xs) (fun r => f (append (hd xs) r))
  end xs.
  Lemma left_append_cps_correct A n x xs R f :
    @left_append_cps A n x xs R f = f (left_append x xs).
  Proof.
    induction n; [reflexivity|].
    simpl left_append. simpl left_append_cps.
    rewrite IHn. reflexivity.
  Qed.

  Definition tl_cps {A n} (xs : tuple A (S n)) {R} :
    (tuple A n -> R) -> R :=
  match
    n as n0 return (tuple A (S n0) -> (tuple A n0 -> R) -> R)
  with
  | 0%nat => fun _ f => f tt
  | S n' => fun xs f => f (fst xs)
  end xs.
  Lemma tl_cps_correct A n xs R f :
    @tl_cps A n xs R f = f (tl xs).
  Proof. destruct n; reflexivity. Qed.

  Definition hd_cps {A n} (xs : tuple A (S n)) {R} :
    (A -> R) -> R :=
  match
    n as n0 return (tuple A (S n0) -> (A -> R) -> R)
  with
  | 0%nat => fun x f => f x
  | S n' => fun xs f => f (snd xs)
  end xs.
  Lemma hd_cps_correct A n xs R f :
    @hd_cps A n xs R f = f (hd xs).
  Proof. destruct n; reflexivity. Qed.

  Fixpoint left_tl_cps {A n} (xs : tuple A (S n)) {R} :
    (tuple A n -> R) -> R :=
  match
    n as n0 return (tuple A (S n0) -> (tuple A n0 -> R) -> R)
  with
  | 0%nat => fun _ f => f tt
  | S n' =>
      fun xs f =>
        tl_cps xs (fun xtl => hd_cps xs (fun xhd =>
          left_tl_cps xtl (fun r => f (append xhd r))))
  end xs.
  Lemma left_tl_cps_correct A n xs R f :
    @left_tl_cps A n xs R f = f (left_tl xs).
  Proof.
    induction n; [reflexivity|].
    simpl left_tl. simpl left_tl_cps.
    rewrite IHn. reflexivity.
  Qed.

  Fixpoint left_hd_cps {A n} (xs : tuple A (S n)) {R} :
    (A -> R) -> R :=
  match
    n as n0 return (tuple A (S n0) -> (A -> R) -> R)
  with
  | 0%nat => fun x f => f x
  | S n' =>
      fun xs f => tl_cps xs (fun xtl => left_hd_cps xtl f)
  end xs.
  Lemma left_hd_cps_correct A n xs R f :
    @left_hd_cps A n xs R f = f (left_hd xs).
  Proof.
    induction n; [reflexivity|].
    simpl left_hd. simpl left_hd_cps.
    rewrite IHn. reflexivity.
  Qed.

  Lemma In_left_hd {A} n (p : tuple A (S n))
    : In (left_hd p) (to_list _ p).
  Proof.
    simpl in *.
    induction n as [|n IHn].
    { left; reflexivity. }
    { destruct p; simpl in *; right; auto. }
  Qed.

  Lemma In_to_list_left_tl {A} n (p : tuple A (S n)) x
    : In x (to_list n (left_tl p)) -> In x (to_list (S n) p).
  Proof.
    simpl in *.
    remember (to_list n (left_tl p)) as ls eqn:H.
    intro Hin; revert Hin H.
    revert n p.
    induction ls as [|l ls IHls], n.
    { simpl; intros ? []. }
    { simpl; intros ? []. }
    { simpl; congruence. }
    { simpl; intros [? p] [H0|H1] H; simpl in *;
        setoid_rewrite to_list_append in H;
        inversion H; clear H; subst; auto. }
  Qed.

  Lemma to_list_left_append {A} {n} (p:tuple A n) x
    : (to_list _ (left_append x p)) = to_list n p ++ x :: nil.
  Proof.
    destruct n as [|n]; simpl in *; [ reflexivity | ].
    induction n as [|n IHn]; simpl in *; [ reflexivity | ].
    destruct p; simpl in *; rewrite IHn; simpl; reflexivity.
  Qed.
End Tuple.
Hint Rewrite @Tuple.map_cps_correct @Tuple.left_append_cps_correct @Tuple.left_tl_cps_correct @Tuple.left_hd_cps_correct @Tuple.tl_cps_correct @Tuple.hd_cps_correct : uncps.
Hint Rewrite @Tuple.mapi_with_cps_correct @Tuple.mapi_with'_cps_correct @Tuple.mapi_with_cps2_correct @Tuple.mapi_with'_cps2_correct
     using (intros; autorewrite with uncps; auto): uncps.


Set Implicit Arguments.
Unset Strict Implicit.

Require Import List. Import ListNotations.
Require Import ZArith.

Require Import Integers.

Require Import lang hmac array.

Section higherlevel_hmac.
  Variables key msg: arr 16 bvec32.
  Variable hash1: arr 32 bvec32 -> arr 8 bvec32.
  Variable hash2: arr 24 bvec32 -> arr 8 bvec32.
  Definition opad_val: bvec32 := Int.repr 1549556828. (*0x5c5c5c5c*)
  Definition ipad_val: bvec32 := Int.repr 909522486. (*0x36363636*)
  Definition opad: arr 16 bvec32 := Vector.const opad_val 16.
  Definition ipad: arr 16 bvec32 := Vector.const ipad_val 16.
  Definition ikeypad: arr 16 bvec32 := arr_map2 Int.xor ipad key.
  Definition ikeypad_msg: arr 32 bvec32 := Vector.append ikeypad msg.
  Definition okeypad: arr 16 bvec32 := arr_map2 Int.xor opad key.
  Definition okeypad_hash: arr 24 bvec32 := Vector.append okeypad (hash1 ikeypad_msg).
  Definition out: arr 8 bvec32 := hash2 okeypad_hash.
End higherlevel_hmac.

Open Scope string_scope.

Section hmac_proof1.
  Variable st: state.
  Variables key msg: arr 16 bvec32.
  Definition key_id: id (TArr 16 TVec32) := "key".
  Definition msg_id: id (TArr 16 TVec32) := "msg".
  Variable st_key: st key_id = key.
  Variable st_msg: st msg_id = msg.
  Variable hash:
    forall (n:nat)
           (m: id (TArr n TVec32))
           (h: id (TArr 8 TVec32)), prog.
  (*HASH_ASSUMPTION 1: The hash function doesn't overwrite key_id or "okp"*)
  Variable hash_frame1: forall xin (xout:id (TArr 8 TVec32)) st t (y:id t),
    y=key_id \/ y="okp" ->
    prog_interp st (hash (n:=32) xin xout) (t:=t) y = st _ y.
  (*HASH_ASSUMPTION 1: The hash function produces equal outputs (xout) from initial
    states that agree on the input (xin).*)
  Variable hash_frame2:
    forall
      n (xin: id (TArr n TVec32)) (xout: id (TArr 8 TVec32))
      (st st':forall t, id t -> interp_ty t) (pf: st _ xin = st' _ xin),
    prog_interp st (hash (n:=n) xin xout) (t:=TArr 8 TVec32) xout =
    prog_interp st' (hash (n:=n) xin xout) (t:=TArr 8 TVec32) xout.

  Definition hash1 (m: arr 32 bvec32): arr 8 bvec32 :=
    prog_interp
      (upd ("fstin": id (TArr 32 TVec32)) m st)
      (@hash 32 "fstin" "fstot")
      ("fstot" : id (TArr 8 TVec32)).

 Definition hash2 (m: arr 24 bvec32): arr 8 bvec32 :=
    prog_interp
      (upd ("sndin": id (TArr 24 TVec32)) m st)
      (@hash 24 "sndin" "sndot")
      ("sndot" : id (TArr 8 TVec32)).

 Lemma filter_true T (l: list T) : filter (fun _ => true) l = l.
 Proof.
   induction l; auto.
   simpl. rewrite IHl; auto.
 Qed.

 Lemma Fin_list_lo_hi_0 n : Fin_list_lo_hi 0 n = enum_iN n.
 Proof.
   unfold Fin_list_lo_hi. unfold enum_iN. induction (enum_iN_rec n); auto.
   simpl. f_equal. rewrite filter_true; auto.
 Qed.

 Lemma vector_nth_lem' C (f:bvec32 -> bvec32 -> C) m (i:iN m) n v :
   Vector.nth (arr_map2 (N:=m) f (Vector.const (int32 n) m) v) i =
   f (int32 n) (Vector.nth v i).
 Proof.
   unfold arr_map2; erewrite Vector.nth_map2; eauto.
   rewrite VectorSpec.const_nth; auto.
 Qed.

 Lemma vector_nth_lem i n v :
   Vector.nth (arr_map2 (N:=16) Int.xor (Vector.const (int32 n) 16) v) i =
   Int.xor (Vector.nth v i) (int32 n).
 Proof.
   rewrite vector_nth_lem'.
   apply Int.xor_commut.
 Qed.

 Lemma ikp_ikeypad' (st':forall t:ty, id t -> interp_ty t) n
   (key_prop: st' (TArr 16 TVec32) key_id = key) :
   stmt_interp
     st'
     (itern_seq_list (hi:=16) (Fin_list_lo_hi 0 16)
                     (fun i : iN 16 =>
                        SUpdate (N:=16) "ikp" (Fin.of_nat_lt (hmac.h_core0_obligation_1 i))
                                (EBinop OXor (EDeref (N:=16) (t:=TVec32) i key_id)
                                        (EVal (int32 n)))))
   = upd (t:=TArr 16 TVec32) "ikp"
         (arr_map2 (N:=16) Int.xor (Vector.const (int32 n) 16) key) st'.
 Proof.
   unfold ikeypad, ipad.
   set (e key_id i n := (EBinop OXor (EDeref (N:=16) (t:=TVec32) i key_id) (EVal (int32 n)))).
   change (stmt_interp st'
    (itern_seq_list (hi:=16) (Fin_list_lo_hi 0 16)
       (fun i : iN 16 =>
          SUpdate (N:=16) "ikp" (Fin.of_nat_lt (hmac.h_core0_obligation_1 i))
                  (e key_id i n))) =
     upd (t:=TArr 16 TVec32) "ikp"
         (arr_map2 (N:=16) Int.xor (Vector.const (int32 n) 16) key) st').
   rewrite (@array_upd_lem_16 key (arr_map2 (N:=16) Int.xor (Vector.const (int32 n) 16) key)); auto.
   { intros st1 st2 H i n0.
     unfold e.
     simpl.
     specialize (H key_id).
     rewrite H; auto.
     inversion 1. }
   intros i; unfold e.
   assert (H: Vector.nth (arr_map2 (N:=16) Int.xor (Vector.const (int32 n) 16) key) i =
              Int.xor (Vector.nth key i) (int32 n)).
   { apply vector_nth_lem. }
   unfold interp_ty, bvec32 in H|-*; rewrite H.
   unfold exp_interp; fold exp_interp; simpl; rewrite key_prop; auto.
  Qed.

 Lemma ikp_ikeypad
    (st':forall t:ty, id t -> interp_ty t)
    (key_prop: st' (TArr 16 TVec32) key_id = key) :
   stmt_interp
     st'
     (itern_seq_list (hi:=16) (Fin_list_lo_hi 0 16)
                     (fun i : iN 16 =>
                        SUpdate (N:=16) "ikp" (Fin.of_nat_lt (hmac.h_core0_obligation_1 i))
                                (EBinop OXor (EDeref (N:=16) (t:=TVec32) i key_id)
                                        (EVal (int32 909522486)))))
   = upd (t:=TArr 16 TVec32) "ikp" (ikeypad key) st'.
  Proof. apply ikp_ikeypad'; auto. Qed.

  Lemma okp_okeypad' n
    (st':forall t:ty, id t -> interp_ty t)
    (key_prop: st' (TArr 16 TVec32) key_id = key) :
    stmt_interp
      st'
      (itern_seq_list
         (hi:=16) (Fin_list_lo_hi 0 16)
         (fun j : iN 16 =>
            SUpdate (N:=16) "okp" (Fin.of_nat_lt (hmac.h_core0_obligation_2 j))
                    (EBinop OXor (EDeref (N:=16) (t:=TVec32) j key_id) (EVal (int32 n)))))
    = upd (t:=TArr 16 TVec32) "okp"
          (arr_map2 (N:=16) Int.xor (Vector.const (Int.repr n) 16) key) st'.
  Proof.
   set (e key_id i n := (EBinop OXor (EDeref (N:=16) (t:=TVec32) i key_id) (EVal (int32 n)))).
   change (stmt_interp st'
    (itern_seq_list (hi:=16) (Fin_list_lo_hi 0 16)
       (fun i : iN 16 =>
          SUpdate (N:=16) "okp" (Fin.of_nat_lt (hmac.h_core0_obligation_1 i))
                  (e key_id i n))) =
     upd (t:=TArr 16 TVec32) "okp"
         (arr_map2 (N:=16) Int.xor (Vector.const (int32 n) 16) key) st').
   rewrite (@array_upd_lem_16 key (arr_map2 (N:=16) Int.xor (Vector.const (int32 n) 16) key)); auto.
   { intros st1 st2 H i n0.
     unfold e.
     simpl.
     specialize (H key_id).
     rewrite H; auto.
     inversion 1. }
   intros i; unfold e.
   assert (H: Vector.nth (arr_map2 (N:=16) Int.xor (Vector.const (int32 n) 16) key) i =
              Int.xor (Vector.nth key i) (int32 n)).
   { apply vector_nth_lem. }
   unfold interp_ty, bvec32 in H|-*; rewrite H.
   unfold exp_interp; fold exp_interp; simpl; rewrite key_prop; auto.
  Qed.

  Lemma okp_okeypad
    (st':forall t:ty, id t -> interp_ty t)
    (key_prop: st' (TArr 16 TVec32) key_id = key) :
    stmt_interp
      st'
      (itern_seq_list
         (hi:=16) (Fin_list_lo_hi 0 16)
         (fun j : iN 16 =>
            SUpdate (N:=16) "okp" (Fin.of_nat_lt (hmac.h_core0_obligation_2 j))
                    (EBinop OXor (EDeref (N:=16) (t:=TVec32) j key_id) (EVal (int32 1549556828)))))
    = upd ("okp": id (TArr 16 TVec32)) (okeypad key) st'.
  Proof. apply okp_okeypad'; auto. Qed.

  Lemma fstin_ikeypad_msg (st':forall t:ty, id t -> interp_ty t)
     (pf1: st' _ key_id = key)
     (pf2: st' (TArr 16 TVec32) "ikp" = ikeypad key)
     (pf3: st' (TArr 16 TVec32) msg_id = msg) :
    stmt_interp
      (stmt_interp
         st'
         (itern_seq_list
            (hi:=16) (Fin_list_lo_hi 0 16)
            (fun i : iN 16 =>
               SUpdate (N:=32) "fstin" (Fin.of_nat_lt (hmac.h_core0_obligation_3 i))
                       (EDeref (N:=16) (t:=TVec32) i "ikp"))))
      (itern_seq_list
         (hi:=32) (Fin_list_lo_hi 16 32)
         (fun j : iN 32 =>
            SUpdate (N:=32) "fstin" (Fin.of_nat_lt (hmac.h_core0_obligation_4 j))
                    (EDeref (N:=16) (t:=TVec32) (Fin.of_nat_lt (hmac.h_core0_obligation_5 j)) msg_id)))
    = upd ("fstin": id (TArr 32 TVec32)) (ikeypad_msg key msg) st'.
  Proof.
    rewrite (@array_copy_first_16 key key_id); auto.
    set (st'' := (upd (t:=TArr 32 TVec32) "fstin"
       (Vector.append (st' (TArr 16 TVec32) "ikp") (last_16 (st' (TArr 32 TVec32) "fstin"))) st')).
    rewrite (@array_copy_last_16 key key_id st'' msg_id "fstin"); auto.
    unfold st''.
    assert (H: (first_16
          (upd (t:=TArr 32 TVec32) "fstin"
             (Vector.append (st' (TArr 16 TVec32) "ikp") (last_16 (st' (TArr 32 TVec32) "fstin"))) st'
             (t0:=TArr 32 TVec32) "fstin")) = st' (TArr 16 TVec32) "ikp").
    { rewrite upd_get_same.
      rewrite first_16_append; auto. }
    rewrite H; unfold ikeypad_msg.
    assert (H2: (upd (t:=TArr 32 TVec32) "fstin"
     (Vector.append (st' (TArr 16 TVec32) "ikp") (last_16 (st' (TArr 32 TVec32) "fstin"))) st'
     (t0:=TArr 16 TVec32) msg_id) = msg).
    { rewrite upd_get_other; auto.
      unfold msg_id; inversion 1. }
    rewrite H2.
    rewrite pf2.
    rewrite upd_upd; auto.
  Qed.

  Lemma sndin_okeypad_hash :
    let st :=
        prog_interp
          (upd (t:=TArr 32 TVec32) "fstin" (ikeypad_msg key msg)
               (upd (t:=TArr 16 TVec32) "okp" (okeypad key)
                    (upd (t:=TArr 16 TVec32) "ikp" (ikeypad key) st))) (hash (n:=32) "fstin" "fstot")
    in
    stmt_interp
      (stmt_interp
         st
         (itern_seq_list
            (hi:=16) (Fin_list_lo_hi 0 16)
            (fun i : iN 16 =>
               SUpdate (N:=24) "sndin" (Fin.of_nat_lt (hmac.h_core0_obligation_6 i))
                       (EDeref (N:=16) (t:=TVec32) i "okp"))))
      (itern_seq_list
         (hi:=24) (Fin_list_lo_hi 16 24)
         (fun j : iN 24 =>
            SUpdate (N:=24) "sndin" (Fin.of_nat_lt (hmac.h_core0_obligation_7 j))
                    (EDeref (N:=8) (t:=TVec32) (Fin.of_nat_lt (hmac.h_core0_obligation_8 j)) "fstot")))
    = upd ("sndin": id (TArr 24 TVec32)) (okeypad_hash key msg hash1) st.
  Proof.
    intros st0.
    assert (H: st0 (TArr 16 TVec32) key_id = key).
    { unfold st0. rewrite hash_frame1; auto. }
    rewrite (@array_copy_first_16_24 key key_id st0 "okp" "sndin" H).
    unfold okeypad_hash.
    rewrite (@array_copy_last_8_24 key key_id); auto.
    rewrite upd_upd; auto.
    f_equal.
    f_equal.
    { rewrite upd_get_same.
      rewrite first_16_24_append.
      unfold st0; rewrite hash_frame1; [|right; auto].
      rewrite upd_get_other; [|inversion 1].
      rewrite upd_get_same; auto. }
    rewrite upd_get_other; [|inversion 1].
    unfold st0.
    unfold hash1.
    apply hash_frame2.
    do 2 rewrite upd_get_same; auto.
  Qed.

  Lemma hout_eq :
    stmt_interp
      (prog_interp
         (upd (t:=TArr 24 TVec32) "sndin" (okeypad_hash key msg hash1)
              (prog_interp
                 (upd (t:=TArr 32 TVec32) "fstin" (ikeypad_msg key msg)
                      (upd (t:=TArr 16 TVec32) "okp" (okeypad key)
                           (upd (t:=TArr 16 TVec32)
                                "ikp" (ikeypad key) st))) (hash (n:=32) "fstin" "fstot")))
         (hash (n:=24) "sndin" "sndot"))
      (itern_seq_list
         (hi:=8) (Fin_list_lo_hi 0 8)
         (fun i : iN 8 =>
            SUpdate (N:=8) "hout" (Fin.of_nat_lt (hmac.h_core0_obligation_9 i))
                    (EDeref (N:=8) (t:=TVec32) i "sndot"))) (t:=TArr 8 TVec32) "hout"
    = hash2 (okeypad_hash key msg hash1).
  Proof.
    rewrite array_copy_8.
    unfold hash2.
    unfold okeypad_hash.
    unfold hash1.
    generalize (hash (n:=32) "fstin" "fstot") as HASH1; intro.
    generalize (prog_interp (upd (t:=TArr 32 TVec32) "fstin" (ikeypad_msg key msg) st) HASH1
                            (t:=TArr 8 TVec32) "fstot") as HASH1_ST; intro.
    set (st' :=
    (upd (t:=TArr 24 TVec32) "sndin" (Vector.append (okeypad key) HASH1_ST)
       (prog_interp
          (upd (t:=TArr 32 TVec32) "fstin" (ikeypad_msg key msg)
             (upd (t:=TArr 16 TVec32) "okp" (okeypad key) (upd (t:=TArr 16 TVec32) "ikp" (ikeypad key) st)))
          (hash (n:=32) "fstin" "fstot")))).
    set (st'' := (upd (t:=TArr 24 TVec32) "sndin" (Vector.append (okeypad key) HASH1_ST) st)).
    assert (H: st' (TArr 24 TVec32) "sndin" = st'' _ "sndin").
    { unfold st', st''.
      do 2 rewrite upd_get_same; auto. }
    generalize (@hash_frame2 24 "sndin" "sndot" st' st'' H); auto.
  Qed.

  Lemma hmac_higherlevel_hmac:
    prog_interp st
      (h_core0' hash key_id msg_id "hout")
      ("hout" : id (TArr 8 TVec32)) =
    out key msg hash1 hash2.
  Proof.
    unfold h_core0'.
    unfold h_core0.
    unfold syntax.iter.
    unfold okeypad_hash.
    unfold ikeypad_msg.
    unfold okeypad.
    unfold ikeypad.
    rewrite fwd_adecl.
    rewrite fwd_adecl.
    rewrite fwd_adecl.
    rewrite fwd_adecl.
    rewrite fwd_adecl.
    rewrite fwd_adecl.
    rewrite fwd_adecl.
    rewrite fwd_pseq.
    rewrite fwd_pseq.
    rewrite fwd_pseq.
    rewrite fwd_pseq.
    do 4 rewrite fwd_pstmt.
    do 3 rewrite fwd_pseq.
    do 2 rewrite fwd_pstmt.
    do 2 rewrite fwd_pseq.
    rewrite fwd_pstmt.
    rewrite fwd_done.
    repeat unfold SIter.
    rewrite ikp_ikeypad; auto.
    rewrite okp_okeypad; auto.
    rewrite fstin_ikeypad_msg; auto.
    rewrite sndin_okeypad_hash; auto.
    apply hout_eq.
  Qed.
End hmac_proof1.


Require Import ssreflect ssrfun ssrbool.
(*Require Import Generic.lemmas Generic.wlog.
Require Import PG32.pg32_inductive PG32.pg32_spreads_packings.*)
Require Import List.
Require Import PG32.pg32_spreads_packings PG32.pg32_packings.

Lemma aux_S0 : statement_packings S0.
Proof.
  solve_goal1.
par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S0.
Lemma aux_S1 : statement_packings S1.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S1.
Lemma aux_S2 : statement_packings S2.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S2.
Lemma aux_S3 : statement_packings S3.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S3.
Lemma aux_S4 : statement_packings S4.
Proof.

solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S4.
Lemma aux_S5 : statement_packings S5.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S5.
Lemma aux_S6 : statement_packings S6.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S6.
Lemma aux_S7 : statement_packings S7.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S7.
Lemma aux_S8 : statement_packings S8.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S8.
Lemma aux_S9 : statement_packings S9.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S9.
Lemma aux_S10 : statement_packings S10.
Proof.
  solve_goal1.
  par: time (solve_goal2 s4 s5 s6 s7 Hs4 Hs5 Hs6 Hs7 le34 le45 le56 le67
                  Hd1 Hd2 Hd3 Hd4 Hd5 Hd6 Hd7 Hd8 Hd9 Hd10 Hd11 Hd12 Hd13 Hd14 Hd15 Hd16 Hd17 Hd18 Hd19 Hd20 Hd21).
Qed.
Check aux_S10.


(* Translation of model TSO *)
From Coq Require Import Relations String.
Require Import Cat.
Section Model.
Variable c : candidate.
Definition events := events c.
Instance SetLike_set_events : SetLike (set events) := SetLike_set events.
Instance SetLike_relation_events : SetLike (relation events) := SetLike_relation events.
Definition R := R c.
Definition W := W c.
Definition IW := IW c.
Definition FW := FW c.
Definition rf := rf c.
Definition po := po c.
Definition ext := ext c.
Definition loc := loc c.
Definition unknown_set := unknown_set c.
Definition M := union R W.
Definition classes_loc : set events -> set (set events) := fun S Si => forall x y, Si x -> Si y -> loc x y.
Definition MFENCE := unknown_set "MFENCE".
Definition partition := classes_loc.
Definition po_loc := intersection po loc.
Definition rfe := intersection rf ext.
Definition co0 := intersection loc (union (cartesian IW (diff W IW)) (cartesian (diff W FW) FW)).
Definition A := union ((*failed: try X with empty : (set _)*) empty : (set _)) ((*failed: try A with empty : (set _)*) empty : (set _)).
(* Definition of co_locs already included in the prelude *)
(* Definition of cross already included in the prelude *)
Definition generate_orders s pco := cross (co_locs pco (partition s)).
Definition generate_cos pco := generate_orders W pco.
Definition invrf_0 := rel_inv rf.
Definition cobase := co0.
Variable co : relation events.
Definition fr := diff (rel_seq invrf_0 co) id.
Definition test := acyclic (union po_loc (union rf (union fr co))).
Definition poWR := rel_seq (diagonal W) (rel_seq po (diagonal R)).
Definition i1 := rel_seq poWR (diagonal A).
Definition i2 := rel_seq (diagonal A) poWR.
Definition implied := union i1 i2.
Definition ppo := union (rel_seq (diagonal R) (rel_seq po (diagonal R))) (union (rel_seq (diagonal M) (rel_seq po (diagonal W))) (union (rel_seq (diagonal M) (rel_seq po (rel_seq (diagonal MFENCE) (rel_seq po (diagonal M))))) implied)).
Definition ghb := union ppo (union rfe (union fr co)).
Definition tso := acyclic ghb.
Definition witness_conditions := generate_cos cobase co.
Definition model_conditions := test /\ tso.
(* Informations on the translation from cat to coq:

The following set of variables is only used inside try/with's before
any definition:
  A, X
the corresponding try/with's failed. Use the option -defined
id1,id2,... to make the corresponding ones succeed instead.

The following set of variables is used but is neither defined in the
prelude nor provided by the candidate:
  MFENCE

The following renamings occurred:
  invrf -> invrf_0
 *)
End Model.

Hint Unfold SetLike_set_events SetLike_relation_events events R W IW FW rf po ext loc unknown_set M classes_loc MFENCE partition po_loc rfe co0 A generate_orders generate_cos invrf_0 cobase fr test poWR i1 i2 implied ppo ghb tso witness_conditions model_conditions : cat.

Definition valid (c : candidate) :=
  exists co : relation (events c),
    witness_conditions c co /\
    model_conditions c co.

(* End of translation of model TSO *)


From sflib Require Import sflib.
From Paco Require Import paco.

Require Import Coq.Classes.RelationClasses.
Require Import Program.

From Fairness Require Import Axioms.
From Fairness Require Export ITreeLib FairBeh FairSim NatStructsLarge.
From Fairness Require Import pind PCMLarge World WFLibLarge.
From Fairness Require Export Mod ModSimNoSync ModSimStutter.

Set Implicit Arguments.

Section GENORDER.
  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable _ident_src: ID.
  Let ident_src := @ident_src _ident_src.
  Variable _ident_tgt: ID.
  Let ident_tgt := @ident_tgt _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Let srcE := programE _ident_src state_src.
  Let tgtE := programE _ident_tgt state_tgt.

  Let shared := shared state_src state_tgt _ident_src _ident_tgt wf_src wf_tgt.
  Let shared_rel: Type := shared -> Prop.
  Variable I: shared -> URA.car -> Prop.

  Let A R0 R1 := (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type.
  Let wf_stt {R0 R1} := @ord_tree_WF (A R0 R1).

  Variant _geno
          (tid: thread_id) R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel)
          (geno: bool -> bool -> URA.car -> ((@wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel)
    :
    bool -> bool -> URA.car -> ((@wf_stt R_src R_tgt).(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel :=
  | geno_ret
      f_src f_tgt r_ctx o o0
      ths im_src im_tgt st_src st_tgt
      r_src r_tgt
      (LT: wf_stt.(lt) o0 o)
      (GENO: RR r_src r_tgt r_ctx (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, Ret r_src) (Ret r_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | geno_tauL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENO: geno true f_tgt r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, Tau itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_chooseL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X ktr_src itr_tgt
      (GENO: exists x, geno true f_tgt r_ctx (o, ktr_src x) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Choose X) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_rmwL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X rmw ktr_src itr_tgt
      (GENO: geno true f_tgt r_ctx (o, ktr_src (snd (rmw st_src) : X)) itr_tgt (ths, im_src, im_tgt, fst (rmw st_src), st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Rmw rmw) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_tidL
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
      (GENO: geno true f_tgt r_ctx (o, ktr_src tid) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (GetTid) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_UB
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      ktr_src itr_tgt
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Undefined) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_fairL
      f_src f_tgt r_ctx o
      ths im_src0 im_tgt st_src st_tgt
      f ktr_src itr_tgt
      (GENO: exists im_src1,
             (<<FAIR: fair_update im_src0 im_src1 (prism_fmap inrp f)>>) /\
               (<<GENO: geno true f_tgt r_ctx (o, ktr_src tt) itr_tgt (ths, im_src1, im_tgt, st_src, st_tgt)>>))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Fair f) >>= ktr_src) itr_tgt (ths, im_src0, im_tgt, st_src, st_tgt)

  | geno_tauR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENO: geno f_src true r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (Tau itr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_chooseR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X itr_src ktr_tgt
      (GENO: forall x, geno f_src true r_ctx (o, itr_src) (ktr_tgt x) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (trigger (Choose X) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_rmwR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      X rmw itr_src ktr_tgt
      (GENO: geno f_src true r_ctx (o, itr_src) (ktr_tgt (snd (rmw st_tgt) : X)) (ths, im_src, im_tgt, st_src, fst (rmw st_tgt)))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (trigger (Rmw rmw) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_tidR
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src ktr_tgt
      (GENO: geno f_src true r_ctx (o, itr_src) (ktr_tgt tid) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (trigger (GetTid) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)
  | geno_fairR
      f_src f_tgt r_ctx o
      ths im_src im_tgt0 st_src st_tgt
      f itr_src ktr_tgt
      (GENO: forall im_tgt1 (FAIR: fair_update im_tgt0 im_tgt1 (prism_fmap inrp f)),
          (<<GENO: geno f_src true r_ctx (o, itr_src) (ktr_tgt tt) (ths, im_src, im_tgt1, st_src, st_tgt)>>))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, itr_src) (trigger (Fair f) >>= ktr_tgt) (ths, im_src, im_tgt0, st_src, st_tgt)

  | geno_observe
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src ktr_tgt
      (GENO: forall ret,
             geno true true r_ctx (o, ktr_src ret) (ktr_tgt ret) (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Observe fn args) >>= ktr_src) (trigger (Observe fn args) >>= ktr_tgt) (ths, im_src, im_tgt, st_src, st_tgt)

  | geno_call
      f_src f_tgt r_ctx o
      ths im_src im_tgt st_src st_tgt
      fn args ktr_src itr_tgt
    :
    _geno tid RR geno f_src f_tgt r_ctx (o, trigger (Call fn args) >>= ktr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)

  | geno_yieldR
      f_src f_tgt r_ctx0 o0
      ths0 im_src0 im_tgt0 st_src0 st_tgt0
      r_own r_shared
      ktr_src ktr_tgt
      (INV: I (ths0, im_src0, im_tgt0, st_src0, st_tgt0) r_shared)
      (VALID: URA.wf (r_shared ⋅ r_own ⋅ r_ctx0))
      o1
      (STUTTER: wf_stt.(lt) o1 o0)
      (GENO: forall ths1 im_src1 im_tgt1 st_src1 st_tgt1 r_shared1 r_ctx1
               (INV: I (ths1, im_src1, im_tgt1, st_src1, st_tgt1) r_shared1)
               (VALID: URA.wf (r_shared1 ⋅ r_own ⋅ r_ctx1))
               im_tgt2
               (TGT: fair_update im_tgt1 im_tgt2 (prism_fmap inlp (tids_fmap tid ths1))),
          (<<GENO: geno f_src true r_ctx1 (o1, trigger (Yield) >>= ktr_src) (ktr_tgt tt) (ths1, im_src1, im_tgt2, st_src1, st_tgt1)>>))
    :
    _geno tid RR geno f_src f_tgt r_ctx0 (o0, trigger (Yield) >>= ktr_src) (trigger (Yield) >>= ktr_tgt) (ths0, im_src0, im_tgt0, st_src0, st_tgt0)

  | geno_yieldL
      f_src f_tgt r_ctx o0
      ths im_src0 im_tgt st_src st_tgt
      ktr_src itr_tgt
      (GENO: exists im_src1 o1,
          (<<FAIR: fair_update im_src0 im_src1 (prism_fmap inlp (tids_fmap tid ths))>>) /\
            (<<GENO: geno true f_tgt r_ctx (o1, ktr_src tt) itr_tgt (ths, im_src1, im_tgt, st_src, st_tgt)>>))
    :
    _geno tid RR geno f_src f_tgt r_ctx (o0, trigger (Yield) >>= ktr_src) itr_tgt (ths, im_src0, im_tgt, st_src, st_tgt)

  | geno_progress
      r_ctx o
      ths im_src im_tgt st_src st_tgt
      itr_src itr_tgt
      (GENO: ModSimNoSync.lsim I tid RR false false r_ctx itr_src itr_tgt (ths, im_src, im_tgt, st_src, st_tgt))
    :
    _geno tid RR geno true true r_ctx (o, itr_src) itr_tgt (ths, im_src, im_tgt, st_src, st_tgt)
  .

  Definition geno (tid: thread_id)
             R_src R_tgt (RR: R_src -> R_tgt -> URA.car -> shared_rel):
    bool -> bool -> URA.car -> (wf_stt.(T) * itree srcE R_src) -> itree tgtE R_tgt -> shared_rel :=
    pind6 (_geno tid RR) top6.

  Lemma geno_mon tid R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel): monotone6 (_geno tid RR).
  Proof.
    ii. inv IN; try (econs; eauto; fail).
    { des. econs; eauto. }
    { des. econs; eauto. }
    { econs; eauto. i. eapply LE. eapply GENO. eauto. }
    { econs; eauto. i. specialize (GENO _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto. }
    { des. econs; esplits; eauto. }
  Qed.

  Local Hint Constructors _geno: core.
  Local Hint Unfold geno: core.
  Local Hint Resolve geno_mon: paco.

  Lemma geno_ord_weak
        tid R0 R1 (LRR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt (shr: shared) o0 o1
        (LT: wf_stt.(lt) o0 o1)
        (GENO: geno tid LRR ps pt r_ctx (o0, src) tgt shr)
    :
    geno tid LRR ps pt r_ctx (o1, src) tgt shr.
  Proof.
    remember (o0, src) as osrc.
    move GENO before tid. revert_until GENO.
    pattern ps, pt, r_ctx, osrc, tgt, shr.
    revert ps pt r_ctx osrc tgt shr GENO. apply pind6_acc.
    intros rr DEC IH. clear DEC. intros ps pt r_ctx osrc tgt shr GENO.
    i; clarify.
    eapply pind6_unfold in GENO; eauto with paco.
    inv GENO.

    { eapply pind6_fold. eapply geno_ret; eauto. }
    { eapply pind6_fold. eapply geno_tauL; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_chooseL; eauto.
      des. destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }
    { eapply pind6_fold. eapply geno_rmwL; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_tidL; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_UB; eauto. }
    { eapply pind6_fold. eapply geno_fairL; eauto.
      des. destruct GENO as [GENO IND]. eapply IH in IND; eauto. esplits; eauto.
      split; ss; eauto.
    }

    { eapply pind6_fold. eapply geno_tauR; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_chooseR; eauto.
      i. specialize (GENO0 x).
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_rmwR; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_tidR; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_fairR; eauto.
      i. specialize (GENO0 _ FAIR).
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }
    { eapply pind6_fold. eapply geno_observe; eauto.
      i. specialize (GENO0 ret).
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }

    { eapply pind6_fold. eapply geno_call; eauto. }

    { eapply pind6_fold. eapply geno_yieldR; eauto.
      i. specialize (GENO0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des. esplits; eauto.
      destruct GENO0 as [GENO IND]. eapply IH in IND; eauto. split; ss.
    }

    { eapply pind6_fold. eapply geno_yieldL; eauto.
      des. esplits; eauto.
      eapply upind6_mon; eauto. ss.
    }

    { eapply pind6_fold. eapply geno_progress; eauto. }

  Qed.

  Lemma nosync_geno
        tid R0 R1 (RR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt shr
        (LSIM: ModSimNoSync.lsim I tid RR ps pt r_ctx src tgt shr)
    :
    exists o, geno tid RR ps pt r_ctx (o, src) tgt shr.
  Proof.
    punfold LSIM.
    pattern R0, R1, RR, ps, pt, r_ctx, src, tgt, shr.
    revert R0 R1 RR ps pt r_ctx src tgt shr LSIM. apply pind9_acc.
    intros rr DEC IH. clear DEC. intros R0 R1 RR ps pt r_ctx src tgt shr LSIM.
    eapply pind9_unfold in LSIM; eauto with paco.
    set (fzero:= fun _: (A R0 R1) => @ord_tree_base (A R0 R1)). set (one:= ord_tree_cons fzero).
    inv LSIM.

    { exists one. eapply pind6_fold. eapply geno_ret; eauto.
      instantiate (1:=fzero (ps, pt, r_ctx, Ret r_src, Ret r_tgt, (ths, im_src, im_tgt, st_src, st_tgt))); ss.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_tauL; eauto. split; ss.
    }
    { des. destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_chooseL; eauto. eexists. split; ss. eauto.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_rmwL; eauto. split; ss.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_tidL; auto. split; ss.
    }
    { exists one. eapply pind6_fold. eapply geno_UB; eauto. }
    { des. destruct LSIM as [LSIM IND]. eapply IH in IND. des.
      exists o. eapply pind6_fold. eapply geno_fairL; eauto. esplits; eauto. split; ss.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists o.
      eapply pind6_fold. eapply geno_tauR; eauto. ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des. exists o1.
      eapply pind6_fold. eapply geno_chooseR.
      i. specialize (LSIM0 x). destruct LSIM0 as [LSIM IND].
      specialize (JOIN (ps, true, r_ctx, src, (ktr_tgt x), (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN; auto. des. split; ss.
      eapply geno_ord_weak; eauto.
    }

    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists o.
      eapply pind6_fold. eapply geno_rmwR; eauto. ss.
    }
    { destruct LSIM0 as [LSIM IND]. eapply IH in IND. des. exists o.
      eapply pind6_fold. eapply geno_tidR; eauto. ss.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des. exists o1.
      eapply pind6_fold. eapply geno_fairR.
      i. specialize (LSIM0 _ FAIR). destruct LSIM0 as [LSIM IND].
      specialize (JOIN (ps, true, r_ctx, src, (ktr_tgt ()), (ths, im_src, im_tgt1, st_src, st_tgt))).
      destruct JOIN; auto. des. split; ss.
      eapply geno_ord_weak; eauto.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des. exists o1.
      eapply pind6_fold. eapply geno_observe.
      i. specialize (LSIM0 ret). destruct LSIM0 as [LSIM IND].
      specialize (JOIN (true, true, r_ctx, ktr_src ret, ktr_tgt ret, (ths, im_src, im_tgt, st_src, st_tgt))).
      destruct JOIN; auto. des. split; ss.
      eapply geno_ord_weak; eauto.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des.
      set (fo1:= fun _: A R0 R1 => o1). exists (ord_tree_cons fo1).
      eapply pind6_fold. eapply geno_call.
    }

    { hexploit ord_tree_join.
      { instantiate (2:=A R0 R1).
        instantiate (2:= fun '(ps, pt, rs, src, tgt, shr) => @rr R0 R1 RR ps pt rs src tgt shr).
        i. ss. des_ifs. eapply IH in SAT.
        instantiate (1:= fun '(ps, pt, rs, src, tgt, shr) o =>
                           geno tid RR ps pt rs (o, src) tgt shr).
        eauto.
      }
      intro JOIN. des.
      set (fo1:= fun _: A R0 R1 => o1). exists (ord_tree_cons fo1).
      eapply pind6_fold. eapply geno_yieldR.
      1,2: eauto.
      { instantiate (1:=fo1 (ps, pt, r_ctx, (x <- trigger Yield;; ktr_src x), (x <- trigger Yield;; ktr_tgt x), (ths0, im_src0, im_tgt0, st_src0, st_tgt0))). ss.
      }
      i. specialize (LSIM0 _ _ _ _ _ _ _ INV0 VALID0 _ TGT). destruct LSIM0 as [LSIM IND].
      specialize (JOIN (ps, true, r_ctx1, (x <- trigger Yield;; ktr_src x), ktr_tgt (), (ths1, im_src1, im_tgt2, st_src1, st_tgt1))).
      destruct JOIN; auto. des. subst fo1. ss. split; ss. eapply geno_ord_weak; eauto.
    }

    { des. destruct LSIM as [LSIM IND]. eapply IH in IND. des. exists o.
      eapply pind6_fold. eapply geno_yieldL; eauto. esplits; eauto.
      split; ss. eauto.
    }

    { exists one. eapply pind6_fold. eapply geno_progress. pclearbot. auto. }

  Qed.

End GENORDER.
#[export] Hint Constructors _geno: core.
#[export] Hint Unfold geno: core.
#[export] Hint Resolve geno_mon: paco.

Section PROOF.

  Context `{M: URA.t}.

  Variable state_src: Type.
  Variable state_tgt: Type.

  Variable _ident_src: ID.
  Let ident_src := @ident_src _ident_src.
  Variable _ident_tgt: ID.
  Let ident_tgt := @ident_tgt _ident_tgt.

  Variable wf_src: WF.
  Variable wf_tgt: WF.

  Let srcE := programE _ident_src state_src.
  Let tgtE := programE _ident_tgt state_tgt.

  Let shared :=
    (TIdSet.t *
       (@imap ident_src wf_src) *
       (@imap ident_tgt wf_tgt) *
       state_src *
       state_tgt)%type.

  Let shared_rel: Type := shared -> Prop.

  Variable I: shared -> URA.car -> Prop.

  Definition lift_wf (wf: WF): WF := sum_WF wf (option_WF wf).

  Definition mk_o (wf: WF) R (o: wf.(T)) (ps: bool) (itr_src: itree srcE R): (lift_wf wf).(T) :=
    if ps
    then match (observe itr_src) with
         | VisF (((|Yield)|)|)%sum _ => (inr (Some o))
         | _ => (inr None)
         end
    else match (observe itr_src) with
         | VisF (((|Yield)|)|)%sum _ => (inl o)
         | _ => (inr None)
         end.

  Let A R0 R1 := (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type.
  Let wf_ot R0 R1 := @ord_tree_WF (A R0 R1).
  Let wf_stt R0 R1 := lift_wf (@wf_ot R0 R1).

  Lemma nosync_implies_stutter
        tid
        R0 R1 (LRR: R0 -> R1 -> URA.car -> shared_rel)
        ps pt r_ctx src tgt
        (shr: shared)
        (LSIM: ModSimNoSync.lsim I tid LRR ps pt r_ctx src tgt shr)
    :
    exists (o: (@wf_stt R0 R1).(T)),
      ModSimStutter.lsim (wf_stt) I tid LRR ps pt r_ctx (o, src) tgt shr.
  Proof.
    eapply nosync_geno in LSIM. des.
    exists (mk_o (@wf_ot R0 R1) o ps src).
    ginit. eapply cpn6_wcompat. eapply lsim_mon.
    revert_until LRR. gcofix CIH; i.
    remember (o, src) as osrc.
    move LSIM before CIH. revert_until LSIM.
    pattern ps, pt, r_ctx, osrc, tgt, shr.
    revert ps pt r_ctx osrc tgt shr LSIM. apply pind6_acc.
    intros rr DEC IH. clear DEC. intros ps pt r_ctx osrc tgt shr LSIM.
    intros src o Eosrc. clarify.
    eapply pind6_unfold in LSIM; eauto with paco.
    inv LSIM.

    { guclo lsim_indC_spec. econs 1; eauto.
      instantiate (1:=(inl o1)). ss.
      unfold mk_o. des_ifs. all: econs 3.
    }

    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 2; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }
    { des. destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 3; eauto. exists x.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }
    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 4; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }
    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 5; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }
    { guclo lsim_indC_spec. econs 6; eauto. }
    { des. destruct GENO0 as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 7; eauto. esplits; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }

    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 8; eauto.
    }
    { guclo lsim_indC_spec. econs 9; eauto. i. specialize (GENO x).
      destruct GENO as [GENO IND]. eapply IH in IND; eauto.
    }
    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 10; eauto.
    }
    { destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 11; eauto.
    }
    { guclo lsim_indC_spec. econs 12; eauto. i. specialize (GENO _ FAIR).
      destruct GENO as [GENO IND]. eapply IH in IND; eauto.
    }

    { guclo lsim_indC_spec. econs 13; eauto. i. specialize (GENO ret).
      destruct GENO as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_ord_weakC_spec. econs; eauto.
      unfold mk_o. ss. des_ifs; try reflexivity.
      - right. ss. do 2 econs.
      - right. ss. do 2 econs.
    }

    { guclo lsim_indC_spec. econs 14. }

    { guclo lsim_indC_spec. econs 15; eauto.
      2:{ i. specialize (GENO _ _ _ _ _ _ _ INV0 VALID0 _ TGT). des.
          destruct GENO as [GENO IND]. eapply IH in IND; eauto.
          esplits.
          guclo lsim_resetC_spec. econs; eauto.
      }
      unfold mk_o; ss. rewrite !bind_trigger. ss.
      des_ifs.
      - do 2 econs. auto.
      - econs. auto.
    }

    { des. destruct GENO0 as [GENO IND]. eapply IH in IND; eauto.
      guclo lsim_indC_spec. econs 16; eauto.
    }

    { eapply nosync_geno in GENO. des.
      guclo lsim_ord_weakC_spec. econs.
      instantiate (1:=mk_o (@wf_ot R0 R1) o0 false src).
      gfinal. right. pfold. eapply pind6_fold. econs 17. right. eapply CIH. auto.
      ss. des_ifs; try reflexivity. right. ss. do 2 econs.
    }

  Qed.

End PROOF.

Section MODSIM.

  Lemma nosync_implies_stutter_mod
        md_src md_tgt
        (MDSIM: ModSimNoSync.ModSim.mod_sim md_src md_tgt)
    :
    ModSimStutter.ModSim.mod_sim md_src md_tgt.
  Proof.
    inv MDSIM.
    set (_ident_src := Mod.ident md_src). set (_ident_tgt := Mod.ident md_tgt).
    set (state_src := Mod.state md_src). set (state_tgt := Mod.state md_tgt).
    set (srcE := programE _ident_src state_src).
    set (tgtE := programE _ident_tgt state_tgt).
    set (ident_src := @ident_src _ident_src).
    set (ident_tgt := @ident_tgt _ident_tgt).
    set (shared := (TIdSet.t * (@imap ident_src wf_src) * (@imap ident_tgt wf_tgt) * state_src * state_tgt)%type).
    set (wf_stt:=fun R0 R1 => lift_wf (@ord_tree_WF (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type)).
    econs; eauto. instantiate (1:=wf_stt).
    i. specialize (init im_tgt). des. rename init0 into funs. exists I. esplits; eauto.
    i. specialize (funs fn args). des_ifs.
    unfold ModSimNoSync.local_sim in funs.
    ii. specialize (funs _ _ _ _ _ _ _ INV tid _ THS VALID _ UPD).
    des. esplits; eauto. instantiate (1:=inr None).
    i. specialize (funs1 _ _ _ _ _ _ _ INV1 VALID1 _ TGT).
    des. esplits; eauto. i. specialize (LSIM fs ft).
    eapply nosync_implies_stutter in LSIM. des.
    eapply stutter_ord_weak. 2: eapply LSIM.
    clear. destruct o.
    { right. econs. }
    destruct t.
    { right. do 2 econs. }
    { left. auto. }
  Qed.

End MODSIM.

Section USERSIM.

  Lemma nosync_implies_stutter_user
        md_src md_tgt p_src p_tgt
        (MDSIM: ModSimNoSync.UserSim.sim md_src md_tgt p_src p_tgt)
    :
    ModSimStutter.UserSim.sim md_src md_tgt p_src p_tgt.
  Proof.
    inv MDSIM.
    set (_ident_src := Mod.ident md_src). set (_ident_tgt := Mod.ident md_tgt).
    set (state_src := Mod.state md_src). set (state_tgt := Mod.state md_tgt).
    set (srcE := programE _ident_src state_src).
    set (tgtE := programE _ident_tgt state_tgt).
    set (ident_src := @ident_src _ident_src).
    set (ident_tgt := @ident_tgt _ident_tgt).
    set (shared := (TIdSet.t * (@imap ident_src wf_src) * (@imap ident_tgt wf_tgt) * state_src * state_tgt)%type).
    set (wf_stt:=fun R0 R1 => lift_wf (@ord_tree_WF (bool * bool * URA.car * (itree srcE R0) * (itree tgtE R1) * shared)%type)).
    econs; eauto. instantiate (1:=wf_stt).
    i. specialize (funs im_tgt). des. exists I. esplits; eauto.
    instantiate (1:=NatMap.map (fun _ => inr None) p_src).
    eapply nm_find_some_implies_forall4.
    { apply nm_forall2_wf_pair. eapply list_forall3_implies_forall2_2; eauto. clear. i. des. des_ifs. des; clarify. }
    { apply nm_forall2_wf_pair. eapply list_forall3_implies_forall2_3; eauto. clear. i. des. des_ifs. des; clarify. }
    { unfold nm_wf_pair. unfold key_set. rewrite nm_map_unit1_map_eq. ss. }
    i. eapply nm_forall3_implies_find_some in SIM; eauto.
    unfold ModSimNoSync.local_sim_init in SIM. unfold local_sim_init.
    i. specialize (SIM _ _ _ _ _ _ _ INV VALID _ FAIR). des. esplits; eauto.
    i. specialize (SIM0 fs ft). eapply nosync_implies_stutter in SIM0. des.
    rewrite NatMapP.F.map_o in FIND4. unfold option_map in FIND4. des_ifs.
    eapply stutter_ord_weak. 2: eapply SIM0.
    clear. destruct o.
    { right. econs. }
    destruct t.
    { right. do 2 econs. }
    { left. auto. }
  Qed.

End USERSIM.


Require Import List Map Envs AllInRel Exp AppExpFree.
Require Import IL Annotation AutoIndTac Liveness.Liveness LabelsDefined.
Require Import Infra.PartialOrder AnnotationLattice CSetPartialOrder.

Set Implicit Arguments.

(** * ReconstrLive *)

Fixpoint reconstr_live
         (Lv : list (set var))
         (ZL : list (params))
         (G : set var)
         (s : stmt)
         (rm : ann (set var))
         {struct s}
  : ann (set var)
  :=
    match s, rm with
    | stmtLet x e t, ann1 _ rm
      => let lv_t := reconstr_live Lv ZL (singleton x) t rm in
        ann1 ((getAnn lv_t) \ singleton x ∪ Exp.freeVars e ∪ G) lv_t

    | stmtReturn e, ann0 _
      => ann0 (Ops.freeVars e ∪ G)

    | stmtIf e t v, ann2 _ rm_t rm_v
      => let lv_t := reconstr_live Lv ZL ∅ t rm_t in
        let lv_v := reconstr_live Lv ZL ∅ v rm_v in
        ann2 (getAnn lv_t ∪ getAnn lv_v ∪ Ops.freeVars e ∪ G) lv_t lv_v

    | stmtApp f Y, ann0 _
      => let blv := nth (counted f) Lv ∅ in
        let Z   := nth (counted f) ZL nil in
        ann0 (list_union (Ops.freeVars ⊝ Y) ∪ blv \ of_list Z ∪ G)

    | stmtFun F t, annF _ rm_F rm_t
      => let rms := getAnn ⊝ rm_F in
        let lv_t := reconstr_live (rms ++ Lv) (fst ⊝ F ++ ZL) ∅ t rm_t in
        let lv_F := (fun ps rm_s =>
                      reconstr_live (rms ++ Lv)
                                    (fst ⊝ F ++ ZL)
                                    (of_list (fst ps))
                                    (snd ps)
                                    rm_s
                    ) ⊜ F rm_F in
        annF (getAnn lv_t ∪ G) lv_F lv_t

    | _,_ => ann0 G

    end.

Lemma reconstr_live_G_eq (G : ⦃var⦄) (Lv : list ⦃var⦄)
      (ZL : list params) (s : stmt) a
  : getAnn (reconstr_live Lv ZL G s a) [=] getAnn (reconstr_live Lv ZL ∅ s a) ∪ G .
Proof.
  general induction s;
    destruct a;
    try destruct a;
    simpl; eauto; cset_tac.
Qed.

Lemma reconstr_live_remove_G Lv ZL G s sl G'
  : getAnn (reconstr_live Lv ZL G s sl) \ G ⊆ getAnn (reconstr_live Lv ZL G' s sl) .
Proof.
  destruct s, sl, a; simpl; cset_tac.
Qed.

Lemma reconstr_live_G Lv ZL G s a
  : G ⊆ getAnn (reconstr_live Lv ZL G s a).
Proof.
  induction s,a; simpl; eauto with cset.
Qed.

Lemma reconstr_live_subset Lv Lv' ZL G s sl
  : Lv ⊑ Lv'
    -> reconstr_live Lv  ZL G s sl ⊑ reconstr_live Lv' ZL G s sl.
Proof.
  intros H.
  revert Lv Lv' H ZL G sl.
  sind s; intros; destruct s, sl; simpl; try econstructor; eauto;
    try eapply IH; eauto.
  - exploit (IH s); eauto.
    rewrite (ann_R_get H0); eauto.
  - exploit (IH s1); eauto.
    exploit (IH s2); eauto.
    rewrite (ann_R_get H0); eauto.
    rewrite (ann_R_get H1); eauto.
  - enough (nth (labN l) Lv ∅ ⊆ nth (labN l) Lv' ∅)
      as HH by (rewrite HH; clear; cset_tac).
    apply PIR2_length in H as Lv_len.
    decide (labN l < length Lv).
    + assert ({x : ⦃var⦄ & get Lv (labN l) x}) as [x get_x]
          by (apply get_in_range; eauto).
      rewrite Lv_len in l0.
      assert ({y : ⦃var⦄ & get Lv' (labN l) y}) as [y get_y]
          by (apply get_in_range; eauto).
      erewrite get_nth; eauto.
      erewrite get_nth; eauto.
      eapply get_PIR2; eauto.
    + apply not_le in n.
      rewrite nth_overflow; eauto with cset.
      omega.
  - eapply incl_union_lr; eauto.
    eapply ann_R_get.
    eapply (IH s); eauto.
  - eauto with len.
  - intros; inv_get; eauto with len.
    eapply IH; eauto.
Qed.

Lemma reconstr_live_equal Lv Lv' ZL G s sl
  : Lv ≣ Lv'
    -> reconstr_live Lv  ZL G s sl ≣ reconstr_live Lv' ZL G s sl.
Proof.
  intros H.
  revert Lv Lv' H ZL G sl.
  sind s; intros; destruct s, sl; simpl; try econstructor; eauto;
    try eapply IH; eauto.
  - exploit (IH s); eauto.
    rewrite (ann_R_get H0); eauto.
  - exploit (IH s1); eauto.
    exploit (IH s2); eauto.
    rewrite (ann_R_get H0); eauto.
    rewrite (ann_R_get H1); eauto.
  - enough (nth (labN l) Lv ∅ [=] nth (labN l) Lv' ∅)
      as HH by (rewrite HH; clear; cset_tac).
    apply PIR2_length in H as Lv_len.
    decide (labN l < length Lv).
    + assert ({x : ⦃var⦄ & get Lv (labN l) x}) as [x get_x]
          by (apply get_in_range; eauto).
      rewrite Lv_len in l0.
      assert ({y : ⦃var⦄ & get Lv' (labN l) y}) as [y get_y]
          by (apply get_in_range; eauto).
      erewrite get_nth; eauto.
      erewrite get_nth; eauto.
      eapply get_PIR2; eauto.
    + apply not_le in n.
      rewrite nth_overflow; eauto with cset;
        [ | omega].
      rewrite Lv_len in n.
      rewrite nth_overflow; eauto with cset.
      omega.
  - eapply eq_union_lr; eauto.
    eapply ann_R_get.
    eapply (IH s); eauto.
  - eauto with len.
  - intros; inv_get; eauto with len.
    eapply IH; eauto.
Qed.

Lemma reconstr_live_setTopAnn ZL Lv s alv G a
  : reconstr_live Lv ZL G s alv = reconstr_live Lv ZL G s (setTopAnn alv a).
Proof.
  destruct s, alv; simpl; eauto.
Qed.

Lemma reconstr_live_incl ZL Lv s alv G
  : live_sound Imperative ZL Lv s alv
    -> G ⊆ getAnn alv
    -> poLe (reconstr_live Lv ZL G s alv) alv.
Proof.
  intros LS.
  general induction LS; simpl in *.
  - eapply ann1_poLe; eauto with cset.
    + rewrite H2, IHLS; eauto 20 using Exp.freeVars_live with cset.
      rewrite Exp.freeVars_live; eauto.
      unfold poLe; simpl. cset_tac.
  - eapply ann2_poLe; eauto with cset.
    rewrite IHLS1, IHLS2; eauto 20 with cset.
    rewrite Ops.freeVars_live; eauto.
    unfold poLe; simpl. cset_tac.
  - eapply ann0_poLe; eauto with cset.
    erewrite !get_nth; eauto.
    unfold poLe; simpl.
    rewrite Ops.freeVars_live_list; eauto.
    cset_tac.
  - eapply ann0_poLe; eauto with cset.
    rewrite Ops.freeVars_live; eauto.
    unfold poLe; simpl. cset_tac.
  - eapply annF_poLe; eauto with cset.
    + rewrite IHLS; eauto with cset.
      unfold poLe; simpl. cset_tac.
    + eapply PIR2_get; eauto with len.
      intros; inv_get.
      rewrite H1; eauto.
      exploit H2; eauto.
Qed.

Lemma reconstr_live_sound ZL Lv s alv G
  : live_sound Imperative ZL Lv s alv
    -> G ⊆ getAnn alv
    -> live_sound Imperative ZL Lv s (reconstr_live Lv ZL G s alv).
Proof.
  intros LS.
  general induction LS; simpl in *.
  - econstructor; eauto with cset.
    + eapply live_exp_sound_incl.
      * eapply live_freeVars.
      * clear. cset_tac.
    + rewrite <- reconstr_live_G; eauto with cset.
  - econstructor; eauto with cset.
    + eapply live_op_sound_incl.
      * eapply Ops.live_freeVars.
      * clear. cset_tac.
  - econstructor; simpl; eauto.
    + erewrite !get_nth; eauto.
      clear. cset_tac.
    + intros.
      erewrite !get_nth; eauto.
      eapply live_op_sound_incl.
      * eapply Ops.live_freeVars.
      * do 2 eapply incl_union_left.
        eapply incl_list_union; eauto using map_get_1.
  - econstructor; eauto.
    + eapply live_op_sound_incl.
      * eapply Ops.live_freeVars.
      * clear. cset_tac.
  - econstructor; intros; inv_get; eauto with len.
    + eapply live_sound_monotone.
      * eapply IHLS; eauto with cset.
      * eapply PIR2_get; intros; eauto with len.
        eapply get_app_cases in H6 as [? |[? ?]]; inv_get.
        -- rewrite get_app_lt in H5; eauto with len.
           inv_get.
           rewrite reconstr_live_incl; eauto.
           exploit H2; eauto; dcr.
        -- rewrite get_app_ge in H5; len_simpl;
             rewrite H in *; inv_get; eauto.
    + eapply live_sound_monotone.
      * eapply H1; eauto with cset.
        exploit H2; eauto; dcr.
      * eapply PIR2_get; intros; eauto with len.
        eapply get_app_cases in H7 as [? |[? ?]]; inv_get.
        -- rewrite reconstr_live_incl; eauto.
           exploit H2; eauto; dcr.
        -- rewrite get_app_ge in H8; len_simpl;
             rewrite H in *; inv_get; eauto.
    + simpl.
      exploit H2; eauto; dcr.
      split; eauto.
      rewrite <- reconstr_live_G; eauto.
Qed.


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

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

Axiom map : forall (a:Type) {a_WT:WhyType a} (b:Type) {b_WT:WhyType b}, Type.
Parameter map_WhyType : forall (a:Type) {a_WT:WhyType a}
  (b:Type) {b_WT:WhyType b}, WhyType (map a b).
Existing Instance map_WhyType.

Parameter get: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b.

Parameter set: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  (map a b) -> a -> b -> (map a b).

Axiom Select_eq : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (m:(map a b)), forall (a1:a) (a2:a), forall (b1:b), (a1 = a2) ->
  ((get (set m a1 b1) a2) = b1).

Axiom Select_neq : forall {a:Type} {a_WT:WhyType a}
  {b:Type} {b_WT:WhyType b}, forall (m:(map a b)), forall (a1:a) (a2:a),
  forall (b1:b), (~ (a1 = a2)) -> ((get (set m a1 b1) a2) = (get m a2)).

Parameter const: forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  b -> (map a b).

Axiom Const : forall {a:Type} {a_WT:WhyType a} {b:Type} {b_WT:WhyType b},
  forall (b1:b) (a1:a), ((get (const b1:(map a b)) a1) = b1).

(* Why3 assumption *)
Definition grid := (map Z Z).

(* Why3 assumption *)
Definition valid_chunk (g:(map Z Z)) (i:Z) (start:(map Z Z)) (offsets:(map Z
  Z)): Prop := let s := (get start i) in forall (o1:Z) (o2:Z),
  (((0%Z <= o1)%Z /\ (o1 < 9%Z)%Z) /\ (((0%Z <= o2)%Z /\ (o2 < 9%Z)%Z) /\
  ~ (o1 = o2))) -> let i1 := (s + (get offsets o1))%Z in let i2 :=
  (s + (get offsets o2))%Z in ((((1%Z <= (get g i1))%Z /\ ((get g
  i1) <= 9%Z)%Z) /\ ((1%Z <= (get g i2))%Z /\ ((get g i2) <= 9%Z)%Z)) ->
  ~ ((get g i1) = (get g i2))).

(* Why3 assumption *)
Definition is_index (i:Z): Prop := (0%Z <= i)%Z /\ (i < 81%Z)%Z.

(* Why3 assumption *)
Definition valid (g:(map Z Z)): Prop := forall (i:Z), (is_index i) ->
  ((valid_chunk g i
  (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map
  Z Z)) 0%Z 0%Z) 1%Z 1%Z) 2%Z 2%Z) 3%Z 3%Z) 4%Z 4%Z) 5%Z 5%Z) 6%Z 6%Z) 7%Z
  7%Z) 8%Z 8%Z) 9%Z 0%Z) 10%Z 1%Z) 11%Z 2%Z) 12%Z 3%Z) 13%Z 4%Z) 14%Z 5%Z)
  15%Z 6%Z) 16%Z 7%Z) 17%Z 8%Z) 18%Z 0%Z) 19%Z 1%Z) 20%Z 2%Z) 21%Z 3%Z) 22%Z
  4%Z) 23%Z 5%Z) 24%Z 6%Z) 25%Z 7%Z) 26%Z 8%Z) 27%Z 0%Z) 28%Z 1%Z) 29%Z 2%Z)
  30%Z 3%Z) 31%Z 4%Z) 32%Z 5%Z) 33%Z 6%Z) 34%Z 7%Z) 35%Z 8%Z) 36%Z 0%Z) 37%Z
  1%Z) 38%Z 2%Z) 39%Z 3%Z) 40%Z 4%Z) 41%Z 5%Z) 42%Z 6%Z) 43%Z 7%Z) 44%Z 8%Z)
  45%Z 0%Z) 46%Z 1%Z) 47%Z 2%Z) 48%Z 3%Z) 49%Z 4%Z) 50%Z 5%Z) 51%Z 6%Z) 52%Z
  7%Z) 53%Z 8%Z) 54%Z 0%Z) 55%Z 1%Z) 56%Z 2%Z) 57%Z 3%Z) 58%Z 4%Z) 59%Z 5%Z)
  60%Z 6%Z) 61%Z 7%Z) 62%Z 8%Z) 63%Z 0%Z) 64%Z 1%Z) 65%Z 2%Z) 66%Z 3%Z) 67%Z
  4%Z) 68%Z 5%Z) 69%Z 6%Z) 70%Z 7%Z) 71%Z 8%Z) 72%Z 0%Z) 73%Z 1%Z) 74%Z 2%Z)
  75%Z 3%Z) 76%Z 4%Z) 77%Z 5%Z) 78%Z 6%Z) 79%Z 7%Z) 80%Z 8%Z)
  (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map Z Z)) 0%Z
  0%Z) 1%Z 9%Z) 2%Z 18%Z) 3%Z 27%Z) 4%Z 36%Z) 5%Z 45%Z) 6%Z 54%Z) 7%Z 63%Z)
  8%Z 72%Z)) /\ ((valid_chunk g i
  (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map
  Z Z)) 0%Z 0%Z) 1%Z 0%Z) 2%Z 0%Z) 3%Z 0%Z) 4%Z 0%Z) 5%Z 0%Z) 6%Z 0%Z) 7%Z
  0%Z) 8%Z 0%Z) 9%Z 9%Z) 10%Z 9%Z) 11%Z 9%Z) 12%Z 9%Z) 13%Z 9%Z) 14%Z 9%Z)
  15%Z 9%Z) 16%Z 9%Z) 17%Z 9%Z) 18%Z 18%Z) 19%Z 18%Z) 20%Z 18%Z) 21%Z 18%Z)
  22%Z 18%Z) 23%Z 18%Z) 24%Z 18%Z) 25%Z 18%Z) 26%Z 18%Z) 27%Z 27%Z) 28%Z
  27%Z) 29%Z 27%Z) 30%Z 27%Z) 31%Z 27%Z) 32%Z 27%Z) 33%Z 27%Z) 34%Z 27%Z)
  35%Z 27%Z) 36%Z 36%Z) 37%Z 36%Z) 38%Z 36%Z) 39%Z 36%Z) 40%Z 36%Z) 41%Z
  36%Z) 42%Z 36%Z) 43%Z 36%Z) 44%Z 36%Z) 45%Z 45%Z) 46%Z 45%Z) 47%Z 45%Z)
  48%Z 45%Z) 49%Z 45%Z) 50%Z 45%Z) 51%Z 45%Z) 52%Z 45%Z) 53%Z 45%Z) 54%Z
  54%Z) 55%Z 54%Z) 56%Z 54%Z) 57%Z 54%Z) 58%Z 54%Z) 59%Z 54%Z) 60%Z 54%Z)
  61%Z 54%Z) 62%Z 54%Z) 63%Z 63%Z) 64%Z 63%Z) 65%Z 63%Z) 66%Z 63%Z) 67%Z
  63%Z) 68%Z 63%Z) 69%Z 63%Z) 70%Z 63%Z) 71%Z 63%Z) 72%Z 72%Z) 73%Z 72%Z)
  74%Z 72%Z) 75%Z 72%Z) 76%Z 72%Z) 77%Z 72%Z) 78%Z 72%Z) 79%Z 72%Z) 80%Z
  72%Z) (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map Z
  Z)) 0%Z 0%Z) 1%Z 1%Z) 2%Z 2%Z) 3%Z 3%Z) 4%Z 4%Z) 5%Z 5%Z) 6%Z 6%Z) 7%Z 7%Z)
  8%Z 8%Z)) /\ (valid_chunk g i
  (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map
  Z Z)) 0%Z 0%Z) 1%Z 0%Z) 2%Z 0%Z) 3%Z 3%Z) 4%Z 3%Z) 5%Z 3%Z) 6%Z 6%Z) 7%Z
  6%Z) 8%Z 6%Z) 9%Z 0%Z) 10%Z 0%Z) 11%Z 0%Z) 12%Z 3%Z) 13%Z 3%Z) 14%Z 3%Z)
  15%Z 6%Z) 16%Z 6%Z) 17%Z 6%Z) 18%Z 0%Z) 19%Z 0%Z) 20%Z 0%Z) 21%Z 3%Z) 22%Z
  3%Z) 23%Z 3%Z) 24%Z 6%Z) 25%Z 6%Z) 26%Z 6%Z) 27%Z 27%Z) 28%Z 27%Z) 29%Z
  27%Z) 30%Z 30%Z) 31%Z 30%Z) 32%Z 30%Z) 33%Z 33%Z) 34%Z 33%Z) 35%Z 33%Z)
  36%Z 27%Z) 37%Z 27%Z) 38%Z 27%Z) 39%Z 30%Z) 40%Z 30%Z) 41%Z 30%Z) 42%Z
  33%Z) 43%Z 33%Z) 44%Z 33%Z) 45%Z 27%Z) 46%Z 27%Z) 47%Z 27%Z) 48%Z 30%Z)
  49%Z 30%Z) 50%Z 30%Z) 51%Z 33%Z) 52%Z 33%Z) 53%Z 33%Z) 54%Z 54%Z) 55%Z
  54%Z) 56%Z 54%Z) 57%Z 57%Z) 58%Z 57%Z) 59%Z 57%Z) 60%Z 60%Z) 61%Z 60%Z)
  62%Z 60%Z) 63%Z 54%Z) 64%Z 54%Z) 65%Z 54%Z) 66%Z 57%Z) 67%Z 57%Z) 68%Z
  57%Z) 69%Z 60%Z) 70%Z 60%Z) 71%Z 60%Z) 72%Z 54%Z) 73%Z 54%Z) 74%Z 54%Z)
  75%Z 57%Z) 76%Z 57%Z) 77%Z 57%Z) 78%Z 60%Z) 79%Z 60%Z) 80%Z 60%Z)
  (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map Z Z)) 0%Z
  0%Z) 1%Z 1%Z) 2%Z 2%Z) 3%Z 9%Z) 4%Z 10%Z) 5%Z 11%Z) 6%Z 18%Z) 7%Z 19%Z) 8%Z
  20%Z)))).

(* Why3 assumption *)
Definition full (g:(map Z Z)): Prop := forall (i:Z), (is_index i) ->
  ((1%Z <= (get g i))%Z /\ ((get g i) <= 9%Z)%Z).

(* Why3 assumption *)
Definition included (g1:(map Z Z)) (g2:(map Z Z)): Prop := forall (i:Z),
  ((is_index i) /\ ((1%Z <= (get g1 i))%Z /\ ((get g1 i) <= 9%Z)%Z)) ->
  ((get g2 i) = (get g1 i)).

(* Why3 assumption *)
Definition is_solution_for (sol:(map Z Z)) (data:(map Z Z)): Prop :=
  (included data sol) /\ ((full sol) /\ (valid sol)).

(* Why3 assumption *)
Inductive ref (a:Type) {a_WT:WhyType a} :=
  | mk_ref : a -> ref a.
Axiom ref_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (ref a).
Existing Instance ref_WhyType.
Implicit Arguments mk_ref [[a] [a_WT]].

(* Why3 assumption *)
Definition contents {a:Type} {a_WT:WhyType a} (v:(ref a)): a :=
  match v with
  | (mk_ref x) => x
  end.

(* Why3 assumption *)
Definition distinct_pair (g:(map Z Z)) (s:Z) (offsets:(map Z Z)) (o1:Z)
  (o2:Z): Prop := let i1 := (s + (get offsets o1))%Z in let i2 :=
  (s + (get offsets o2))%Z in ((~ (o1 = o2)) -> ((((1%Z <= (get g i1))%Z /\
  ((get g i1) <= 9%Z)%Z) /\ ((1%Z <= (get g i2))%Z /\ ((get g
  i2) <= 9%Z)%Z)) -> ~ ((get g i1) = (get g i2)))).

(* Why3 assumption *)
Definition distinct_pairs (g:(map Z Z)) (s:Z) (offsets:(map Z Z)) (o1:Z)
  (o2:Z): Prop := forall (a:Z) (b:Z), (((0%Z <= a)%Z /\ (a < o1)%Z) /\
  ((0%Z <= b)%Z /\ (b < o2)%Z)) -> (distinct_pair g s offsets a b).

Axiom distinct_pairs_to_valid_chunk : forall (g:(map Z Z)) (i:Z) (start:(map
  Z Z)) (offsets:(map Z Z)), (distinct_pairs g (get start i) offsets 9%Z
  9%Z) -> (valid_chunk g i start offsets).

(* Why3 assumption *)
Inductive array
  (a:Type) {a_WT:WhyType a} :=
  | mk_array : Z -> (map Z a) -> array a.
Axiom array_WhyType : forall (a:Type) {a_WT:WhyType a}, WhyType (array a).
Existing Instance array_WhyType.
Implicit Arguments mk_array [[a] [a_WT]].

(* Why3 assumption *)
Definition elts {a:Type} {a_WT:WhyType a} (v:(array a)): (map Z a) :=
  match v with
  | (mk_array x x1) => x1
  end.

(* Why3 assumption *)
Definition length {a:Type} {a_WT:WhyType a} (v:(array a)): Z :=
  match v with
  | (mk_array x x1) => x
  end.

(* Why3 assumption *)
Definition get1 {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z): a :=
  (get (elts a1) i).

(* Why3 assumption *)
Definition set1 {a:Type} {a_WT:WhyType a} (a1:(array a)) (i:Z) (v:a): (array
  a) := (mk_array (length a1) (set (elts a1) i v)).

(* Why3 assumption *)
Definition make {a:Type} {a_WT:WhyType a} (n:Z) (v:a): (array a) :=
  (mk_array n (const v:(map Z a))).

(* Why3 assumption *)
Definition is_grid (g:(map Z Z)): Prop := forall (k:Z), ((1%Z <= (get g
  k))%Z /\ ((get g k) <= 9%Z)%Z) \/ ((get g k) = (-1%Z)%Z).

(* Why3 assumption *)
Definition partial (g:(map Z Z)) (i:Z): Prop := (forall (k:Z),
  ((0%Z <= k)%Z /\ (k < i)%Z) -> ((1%Z <= (get g k))%Z /\ ((get g
  k) <= 9%Z)%Z)) /\ forall (k:Z), (is_index k) -> (((1%Z <= (get g k))%Z /\
  ((get g k) <= 9%Z)%Z) \/ ((get g k) = (-1%Z)%Z)).

Axiom partial_1 : forall (g:(map Z Z)) (i:Z), (i < 81%Z)%Z -> ((partial g
  i) -> ((~ ((get g i) = (-1%Z)%Z)) -> (partial g (i + 1%Z)%Z))).

(* Why3 goal *)
Theorem WP_parameter_valid_update : forall (g:(map Z Z)) (i:Z) (x:Z),
  (((is_grid g) /\ (valid g)) /\ ((1%Z <= x)%Z /\ (x <= 9%Z)%Z)) ->
  forall (j:Z), ((~ (i = j)) /\ (is_index j)) -> ((valid_chunk (set g i x) j
  (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map
  Z Z)) 0%Z 0%Z) 1%Z 1%Z) 2%Z 2%Z) 3%Z 3%Z) 4%Z 4%Z) 5%Z 5%Z) 6%Z 6%Z) 7%Z
  7%Z) 8%Z 8%Z) 9%Z 0%Z) 10%Z 1%Z) 11%Z 2%Z) 12%Z 3%Z) 13%Z 4%Z) 14%Z 5%Z)
  15%Z 6%Z) 16%Z 7%Z) 17%Z 8%Z) 18%Z 0%Z) 19%Z 1%Z) 20%Z 2%Z) 21%Z 3%Z) 22%Z
  4%Z) 23%Z 5%Z) 24%Z 6%Z) 25%Z 7%Z) 26%Z 8%Z) 27%Z 0%Z) 28%Z 1%Z) 29%Z 2%Z)
  30%Z 3%Z) 31%Z 4%Z) 32%Z 5%Z) 33%Z 6%Z) 34%Z 7%Z) 35%Z 8%Z) 36%Z 0%Z) 37%Z
  1%Z) 38%Z 2%Z) 39%Z 3%Z) 40%Z 4%Z) 41%Z 5%Z) 42%Z 6%Z) 43%Z 7%Z) 44%Z 8%Z)
  45%Z 0%Z) 46%Z 1%Z) 47%Z 2%Z) 48%Z 3%Z) 49%Z 4%Z) 50%Z 5%Z) 51%Z 6%Z) 52%Z
  7%Z) 53%Z 8%Z) 54%Z 0%Z) 55%Z 1%Z) 56%Z 2%Z) 57%Z 3%Z) 58%Z 4%Z) 59%Z 5%Z)
  60%Z 6%Z) 61%Z 7%Z) 62%Z 8%Z) 63%Z 0%Z) 64%Z 1%Z) 65%Z 2%Z) 66%Z 3%Z) 67%Z
  4%Z) 68%Z 5%Z) 69%Z 6%Z) 70%Z 7%Z) 71%Z 8%Z) 72%Z 0%Z) 73%Z 1%Z) 74%Z 2%Z)
  75%Z 3%Z) 76%Z 4%Z) 77%Z 5%Z) 78%Z 6%Z) 79%Z 7%Z) 80%Z 8%Z)
  (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map Z Z)) 0%Z
  0%Z) 1%Z 9%Z) 2%Z 18%Z) 3%Z 27%Z) 4%Z 36%Z) 5%Z 45%Z) 6%Z 54%Z) 7%Z 63%Z)
  8%Z 72%Z)) /\ ((valid_chunk (set g i x) j
  (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map
  Z Z)) 0%Z 0%Z) 1%Z 0%Z) 2%Z 0%Z) 3%Z 0%Z) 4%Z 0%Z) 5%Z 0%Z) 6%Z 0%Z) 7%Z
  0%Z) 8%Z 0%Z) 9%Z 9%Z) 10%Z 9%Z) 11%Z 9%Z) 12%Z 9%Z) 13%Z 9%Z) 14%Z 9%Z)
  15%Z 9%Z) 16%Z 9%Z) 17%Z 9%Z) 18%Z 18%Z) 19%Z 18%Z) 20%Z 18%Z) 21%Z 18%Z)
  22%Z 18%Z) 23%Z 18%Z) 24%Z 18%Z) 25%Z 18%Z) 26%Z 18%Z) 27%Z 27%Z) 28%Z
  27%Z) 29%Z 27%Z) 30%Z 27%Z) 31%Z 27%Z) 32%Z 27%Z) 33%Z 27%Z) 34%Z 27%Z)
  35%Z 27%Z) 36%Z 36%Z) 37%Z 36%Z) 38%Z 36%Z) 39%Z 36%Z) 40%Z 36%Z) 41%Z
  36%Z) 42%Z 36%Z) 43%Z 36%Z) 44%Z 36%Z) 45%Z 45%Z) 46%Z 45%Z) 47%Z 45%Z)
  48%Z 45%Z) 49%Z 45%Z) 50%Z 45%Z) 51%Z 45%Z) 52%Z 45%Z) 53%Z 45%Z) 54%Z
  54%Z) 55%Z 54%Z) 56%Z 54%Z) 57%Z 54%Z) 58%Z 54%Z) 59%Z 54%Z) 60%Z 54%Z)
  61%Z 54%Z) 62%Z 54%Z) 63%Z 63%Z) 64%Z 63%Z) 65%Z 63%Z) 66%Z 63%Z) 67%Z
  63%Z) 68%Z 63%Z) 69%Z 63%Z) 70%Z 63%Z) 71%Z 63%Z) 72%Z 72%Z) 73%Z 72%Z)
  74%Z 72%Z) 75%Z 72%Z) 76%Z 72%Z) 77%Z 72%Z) 78%Z 72%Z) 79%Z 72%Z) 80%Z
  72%Z) (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map Z
  Z)) 0%Z 0%Z) 1%Z 1%Z) 2%Z 2%Z) 3%Z 3%Z) 4%Z 4%Z) 5%Z 5%Z) 6%Z 6%Z) 7%Z 7%Z)
  8%Z 8%Z)) /\ (valid_chunk (set g i x) j
  (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map
  Z Z)) 0%Z 0%Z) 1%Z 0%Z) 2%Z 0%Z) 3%Z 3%Z) 4%Z 3%Z) 5%Z 3%Z) 6%Z 6%Z) 7%Z
  6%Z) 8%Z 6%Z) 9%Z 0%Z) 10%Z 0%Z) 11%Z 0%Z) 12%Z 3%Z) 13%Z 3%Z) 14%Z 3%Z)
  15%Z 6%Z) 16%Z 6%Z) 17%Z 6%Z) 18%Z 0%Z) 19%Z 0%Z) 20%Z 0%Z) 21%Z 3%Z) 22%Z
  3%Z) 23%Z 3%Z) 24%Z 6%Z) 25%Z 6%Z) 26%Z 6%Z) 27%Z 27%Z) 28%Z 27%Z) 29%Z
  27%Z) 30%Z 30%Z) 31%Z 30%Z) 32%Z 30%Z) 33%Z 33%Z) 34%Z 33%Z) 35%Z 33%Z)
  36%Z 27%Z) 37%Z 27%Z) 38%Z 27%Z) 39%Z 30%Z) 40%Z 30%Z) 41%Z 30%Z) 42%Z
  33%Z) 43%Z 33%Z) 44%Z 33%Z) 45%Z 27%Z) 46%Z 27%Z) 47%Z 27%Z) 48%Z 30%Z)
  49%Z 30%Z) 50%Z 30%Z) 51%Z 33%Z) 52%Z 33%Z) 53%Z 33%Z) 54%Z 54%Z) 55%Z
  54%Z) 56%Z 54%Z) 57%Z 57%Z) 58%Z 57%Z) 59%Z 57%Z) 60%Z 60%Z) 61%Z 60%Z)
  62%Z 60%Z) 63%Z 54%Z) 64%Z 54%Z) 65%Z 54%Z) 66%Z 57%Z) 67%Z 57%Z) 68%Z
  57%Z) 69%Z 60%Z) 70%Z 60%Z) 71%Z 60%Z) 72%Z 54%Z) 73%Z 54%Z) 74%Z 54%Z)
  75%Z 57%Z) 76%Z 57%Z) 77%Z 57%Z) 78%Z 60%Z) 79%Z 60%Z) 80%Z 60%Z)
  (set (set (set (set (set (set (set (set (set (const (-1%Z)%Z:(map Z Z)) 0%Z
  0%Z) 1%Z 1%Z) 2%Z 2%Z) 3%Z 9%Z) 4%Z 10%Z) 5%Z 11%Z) 6%Z 18%Z) 7%Z 19%Z) 8%Z
  20%Z)))).
intros g i x ((h1,h2),(h3,h4)) j (h5,h6).

Qed.