Require Import List String.
Import ListNotations.
#[ local ]
 Open Scope string.

From ASUB Require Import Language Graph AssocList Monad Utils ErrorM.
From ASUB Require NEList.
Import ErrorM.Notations ErrorM.

Module G := Digraph.

(** * Build a graph where the vertices are all the sorts from the spec and there
 ** * is an edge u->v iff v occurs directly in u (i.e. if there is some constructor
 ** * of u where v is an argument head. ) *)
Definition build_graph (spec: Spec) :=
  SFMap.fold (fun sort ctors g0 =>
                let args := flat_map getArgs ctors in
                fold_left (fun g1 arg => G.add_edge g1 sort arg)
                          args g0)
             spec G.empty.

Definition binder_analysis (spec: Spec) (occurs_in: G.vertex -> G.vertex -> bool) : ErrorM.t SSet.t :=
  SFMap.fold (fun sort ctors mbs0 =>
                let positions := flat_map con_positions ctors in
                fold_left (fun mbs1 '{| pos_binders := pos_binders; pos_head := pos_head |} =>
                             let binders := flat_map getBinders pos_binders in
                             fold_left (fun mbs2 bound_sort =>
                                          bs <- mbs2;;
                                          let vacuous := list_nonef (fun arg => occurs_in arg bound_sort) (getArgSorts pos_head) in
                                          if vacuous
                                          then error "vacuous!"
                                          else pure (SSet.add bs bound_sort))
                                       binders mbs1
                          )
                          positions mbs0)
             spec (ErrorM.pure SSet.empty).

(** * A sort needs renamings
 ** * either if it appears in a constructor in the same component
 ** * or if it occurs in a sort that needs renamings *)
Definition renaming_analysis (spec: Spec) (g_trans: G.t) (components: list (NEList.t tId)) : SSet.t :=
  let renamings := SSet.empty in
  (* add all sorts to the set that appear in their component *)
  let renamings := fold_left (fun ren0 (component: NEList.t tId) =>
                                let boundSorts := getBoundSorts spec component in
                                let has_bound := NEList.anyf (fun sort => list_mem sort boundSorts) component in
                                if has_bound
                                then SSet.union ren0 (SSet.fromList (NEList.to_list component))
                                else ren0)
                             components renamings in
  (* then go through all sorts and add those that occur in sorts already in the set *)
  let renamings := G.fold g_trans (fun sort adj ren0 =>
                                     if SSet.mem ren0 sort
                                     then SSet.union ren0 adj
                                     else ren0)
                          renamings in
  renamings.

(** * The substitution vector of a sort consist of the open sorts that occur in it. *)
Definition subordination (g: G.t) (canonical_order: list tId) (open_sorts: SSet.t) : tId -> list tId :=
  fun sort => filter (fun subst_sort =>
                     (SSet.mem open_sorts subst_sort
                      && G.mem_edge g sort subst_sort)%bool)
                  canonical_order.

(** Calculate the strongly connected components *)
(* TODO using a hack here to convert the non-empty list to a normal list temporarily
 * but it should be possible to implement the sorting if if I have a proof that the canonical_order list contains all sorts. (maybe even declare a finite string type indexed by this canonical_order) *)
(** We also filter out the non-definable sorts *)
Definition topological_sort g (open_sorts : SSet.t) (spec: Spec) (canonical_order: list tId) : list (NEList.t tId) :=
  list_filter_map (fun component =>
                     let componentL := NEList.to_list component in
                     let componentL := List.filter (fun sort =>
                                                      orb (SSet.mem open_sorts sort)
                                                          (match SFMap.find spec sort with
                                                           | None => false
                                                           | Some l => negb (list_empty l)
                                                           end)
                                                   ) componentL in
                     let componentOrdered := list_intersection canonical_order componentL in
                     NEList.from_list componentOrdered) (G.scc_list g).

Definition build_signature (componentsO: option (list (NEList.t tId))) (canonical_order: list tId) (spec: Spec) : ErrorM.t Signature :=
  let g := build_graph spec in
  open_sorts <- binder_analysis spec (G.mem_edge (G.transitive_closure g false));;
  let substs := subordination (G.transitive_closure g true) canonical_order open_sorts in
  let subst_of := SFMap.mapi (fun sort _ => substs sort) spec in
  let components := match componentsO with None => topological_sort g open_sorts spec canonical_order | Some c => c end in
  let arguments := SFMap.mapi (fun sort _ => match G.succ g sort with None => [] | Some x => x end) spec in
  (* let arguments := SFMap.fromList (map (fun '(sort, _) => (sort, match G.succ g sort with None => [] | Some x => x end)) (SFMap.elements spec)) in *)
  let renamings := renaming_analysis spec (G.transitive_closure g false) components in
  pure {| sigSpec := spec;
          sigSubstOf := subst_of;
          sigComponents := components;
          sigIsOpen := open_sorts;
          sigArguments := arguments;
          sigRenamings := renamings
       |}.

Module Ex.
  Definition spec := Hsig_example.mySigSpec.
  Definition g := build_graph spec.
  Open Scope string.

  Compute g.
  Compute (G.invert g).

  (* test occurs_in relation *)
  Compute bool_beq (G.mem_edge g "ty" "ty") true.
  Compute bool_beq (G.mem_edge g "ty" "tm") false.
  Compute bool_beq (G.mem_edge g "ty" "vl") false.
  Compute bool_beq (G.mem_edge g "tm" "ty") true.
  Compute bool_beq (G.mem_edge g "tm" "tm") true.
  Compute bool_beq (G.mem_edge g "tm" "vl") true.
  Compute bool_beq (G.mem_edge g "vl" "ty") true.
  Compute bool_beq (G.mem_edge g "vl" "tm") true.
  Compute bool_beq (G.mem_edge g "vl" "vl") false.

  (* test open sorts *)
  Definition open_sorts := (match run (binder_analysis spec (G.mem_edge (G.transitive_closure g false))) tt tt with
                            | inl _ => SSet.empty
                            | inr (_, _, x) => x
                            end).
  Compute open_sorts.

  Definition substs := subordination (G.transitive_closure g true) ["ty"; "tm"; "vl"] open_sorts.
  (* While it does not diverge it takes a very long time to compute. This and the trouble with the actually diverging function call above indicates that I should write my own finmaps *)
  Compute (SFMap.mapi (fun sort _ => substs sort) spec).
  (* Compute (SFMap.fromList (map (fun '(sort, _) => (sort, substs sort)) (SFMap.elements spec))). *)

  Compute (run (build_signature (Some [("ty", []); ("tm", ["vl"])]) ["ty"; "tm"; "vl"] spec) tt tt).
  Compute (run (build_signature None ["ty"; "tm"; "vl"] spec) tt tt).
  Compute (G.succ g "ty").
  Compute (G.succ g "tm").
  Compute (G.succ g "vl").

  Definition components := [("tm", ["vl"]); ("ty", [])].
  Compute (renaming_analysis spec (G.transitive_closure (G.invert g) false) components).

End Ex.

Module Ex2.
  Definition spec := Hsig_fol.mySigSpec.
  Definition g := build_graph spec.
  Open Scope string.

  Compute g.

  Definition open_sorts := (match run (binder_analysis spec (G.mem_edge (G.transitive_closure g false))) tt tt with
                            | inl _ => SSet.empty
                            | inr (_, _, x) => x
                            end).
  Compute open_sorts.
  Definition components : list (NEList.t tId) := [("form", []); ("term", [])].
  (* as expected this is the empty list *)
  Compute (renaming_analysis spec (G.transitive_closure (G.invert g) false) components).

  Compute (run (build_signature None ["term"; "form"] spec) tt tt).
End Ex2.


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

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

Require Import Cop. (*for sem_cast*)
Require Import Ctypes. (*for access_mode*)
Require Import Clight.
Require Import Clight_coop.

Definition assign_loc_Effect (ty:type) (b: block) (ofs: int) v : (block -> Z -> bool)  :=
  match access_mode ty with
     By_value chunk => fun b' z' => eq_block b b'
              && zle (Int.unsigned ofs) z'
              && zlt z' ((Int.unsigned ofs) + Z.of_nat (length (encode_val chunk v)))
   | By_copy => fun b' z' => eq_block b' b
              && zle (Int.unsigned ofs) z'
              && zlt z' ((Int.unsigned ofs) + (sizeof ty))
   | _ => fun b' z' => false
  end.

Lemma assign_loc_Effect_Sound: forall a m loc ofs v m'
      (AL: assign_loc (typeof a) m loc ofs v m'),
     Mem.unchanged_on (fun b z => assign_loc_Effect (typeof a)
                            loc ofs v b z = false) m m'.
Proof. intros. inv AL.
inv H0.
(*access_mode (typeof a) = By_value chunk*)
  split; intros.
  (*perm*)
    split; intros.
    eapply Mem.perm_store_1; eassumption.
    eapply Mem.perm_store_2; eassumption.
  (*memcontents*)
    rewrite (Mem.store_mem_contents _ _ _ _ _ _ H2).
    unfold assign_loc_Effect in H0; rewrite H in H0.
    destruct (eq_block loc b); subst; simpl in H0.
      rewrite PMap.gss. rewrite andb_false_iff in H0.
      apply Mem.setN_other. intros; intros N. subst.
      destruct H3.
      destruct (zle (Int.unsigned ofs) ofs0); simpl in *.
        destruct H0; try discriminate.
        destruct (zlt ofs0 (Int.unsigned ofs + Z.of_nat (length (encode_val chunk v)))); simpl in *. discriminate.
        omega.
      omega.
    rewrite PMap.gso; trivial. intros N; subst; apply n; trivial.
(*access_mode (typeof a) = By_copy*)
  split; intros.
  (*perm*)
    split; intros.
    eapply Mem.perm_storebytes_1; eassumption.
    eapply Mem.perm_storebytes_2; eassumption.
  (*memcontents*)
    rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H4).
    unfold assign_loc_Effect in H5; rewrite H in H5.
    destruct (eq_block b loc); subst; simpl in H5.
      rewrite PMap.gss. rewrite andb_false_iff in H5.
      apply Mem.setN_other. intros; intros N. subst.
      destruct H7.
      destruct (zle (Int.unsigned ofs) ofs0); simpl in *.
        destruct H5; try discriminate.
        destruct (zlt ofs0 (Int.unsigned ofs + sizeof (typeof a))); simpl in *. discriminate.
        apply Mem.loadbytes_length in H3. rewrite H3 in H8.
          rewrite nat_of_Z_eq in H8. omega.
          assert (ZZZ:= sizeof_pos (typeof a)). omega.
      omega.
    rewrite PMap.gso; trivial.
Qed.

Lemma alloc_variables_unchanged_on:
      forall P args env m e m' (H:alloc_variables env m args e m'),
      Mem.unchanged_on P m m'.
Proof. intros P args.
  induction args; simpl; intros; inv H.
    apply Mem.unchanged_on_refl.
  apply IHargs  in H7.
  specialize (alloc_forward _ _ _ _ _ H4). intros.
  eapply unchanged_on_trans;  try eassumption.
  eapply Mem.alloc_unchanged_on. eassumption.
Qed.

Lemma alloc_variables_freshblocks: forall vars E m e m1
      (AL: alloc_variables E m vars e m1)
      id b t (Hid: e!id = Some (b,t)),
      E!id = Some (b,t) \/ ~Mem.valid_block m b.
Proof. intros vars.
  induction vars; simpl; intros; inv AL; simpl in *.
    left; trivial.
  destruct (IHvars _ _ _ _ H6 _ _ _ Hid); clear IHvars.
    rewrite PTree.gsspec in H.
    destruct (peq id id0); subst.
      inv H. right. eapply Mem.fresh_block_alloc; eassumption.
      left; trivial.
    right. intros N; elim H; clear H.
      eapply Mem.valid_block_alloc; eassumption.
Qed.

Lemma assign_loc_forward: forall ty m b ofs v m1
      (A: assign_loc ty m b ofs v m1),
      mem_forward m m1.
Proof. intros.
  inv A.
   inv H0. eapply (store_forward _ _ _ _ _ _ H2).
   eapply (storebytes_forward _ _ _ _ _ H4).
Qed.

Section EFFSEM.
Variable FE:function -> list val -> mem -> env -> temp_env -> mem -> Prop.

Inductive clight_effstep (ge:genv): (block -> Z -> bool) ->
            CL_core -> mem -> CL_core -> mem -> Prop :=
  | clight_effstep_assign:   forall f a1 a2 k e le m loc ofs v2 v m',
      eval_lvalue ge e le m a1 loc ofs ->
      eval_expr ge e le m a2 v2 ->
      sem_cast v2 (typeof a2) (typeof a1) = Some v ->
      assign_loc (typeof a1) m loc ofs v m' ->
      clight_effstep ge (assign_loc_Effect (typeof a1) loc ofs v)
        (CL_State f (Sassign a1 a2) k e le) m
        (CL_State f Sskip k e le) m'

  | clight_effstep_set:   forall f id a k e le m v,
      eval_expr ge e le m a v ->
      clight_effstep ge EmptyEffect (CL_State f (Sset id a) k e le) m
        (CL_State f Sskip k e (PTree.set id v le)) m

  | clight_effstep_call:   forall f optid a al k e le m tyargs tyres vf vargs fd,
      classify_fun (typeof a) = fun_case_f tyargs tyres ->
      eval_expr ge e le m a vf ->
      eval_exprlist ge e le m al tyargs vargs ->
      Genv.find_funct ge vf = Some fd ->
      type_of_fundef fd = Tfunction tyargs tyres ->
      clight_effstep ge EmptyEffect (CL_State f (Scall optid a al) k e le) m
        (CL_Callstate fd vargs (Kcall optid f e le k)) m

(* WE DO NOT TREAT BUILTINS
  | clight_effstep_builtin:   forall f optid ef tyargs al k e le m vargs t vres m',
      eval_exprlist ge e le m al tyargs vargs ->
      external_call ef ge vargs m t vres m' ->
      clight_effstep ge (BuiltinEffect ge (ef_sig ef) vargs m)
         (CL_State f (Sbuiltin optid ef tyargs al) k e le) m
         (CL_State f Sskip k e (set_opttemp optid vres le)) m'
*)
  | clight_effstep_seq:  forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect (CL_State f (Ssequence s1 s2) k e le) m
        (CL_State f s1 (Kseq s2 k) e le) m

  | clight_effstep_skip_seq: forall f s k e le m,
      clight_effstep ge EmptyEffect (CL_State f Sskip (Kseq s k) e le) m
        (CL_State f s k e le) m
  | clight_effstep_continue_seq: forall f s k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Scontinue (Kseq s k) e le) m
        (CL_State f Scontinue k e le) m

  | clight_effstep_break_seq: forall f s k e le m,
      clight_effstep ge EmptyEffect (CL_State f Sbreak (Kseq s k) e le) m
        (CL_State f Sbreak k e le) m

  | clight_effstep_ifthenelse:  forall f a s1 s2 k e le m v1 b,
      eval_expr ge e le m a v1 ->
      bool_val v1 (typeof a) = Some b ->
      clight_effstep ge EmptyEffect
        (CL_State f (Sifthenelse a s1 s2) k e le) m
        (CL_State f (if b then s1 else s2) k e le) m

  | clight_effstep_loop: forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f (Sloop s1 s2) k e le) m
        (CL_State f s1 (Kloop1 s1 s2 k) e le) m
  | clight_effstep_skip_or_continue_loop1:  forall f s1 s2 k e le m x,
      x = Sskip \/ x = Scontinue ->
      clight_effstep ge EmptyEffect
        (CL_State f x (Kloop1 s1 s2 k) e le) m
        (CL_State f s2 (Kloop2 s1 s2 k) e le) m
  | clight_effstep_break_loop1:  forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Sbreak (Kloop1 s1 s2 k) e le) m
        (CL_State f Sskip k e le) m
  | clight_effstep_skip_loop2: forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Sskip (Kloop2 s1 s2 k) e le) m
        (CL_State f (Sloop s1 s2) k e le) m
  | clight_effstep_break_loop2: forall f s1 s2 k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Sbreak (Kloop2 s1 s2 k) e le) m
        (CL_State f Sskip k e le) m

  | clight_effstep_return_0: forall f k e le m m',
      Mem.free_list m (blocks_of_env e) = Some m' ->
      clight_effstep ge (FreelistEffect m (blocks_of_env e))
        (CL_State f (Sreturn None) k e le) m
        (CL_Returnstate Vundef (call_cont k)) m'
  | clight_effstep_return_1: forall f a k e le m v v' m',
      eval_expr ge e le m a v ->
      sem_cast v (typeof a) f.(fn_return) = Some v' ->
      Mem.free_list m (blocks_of_env e) = Some m' ->
      clight_effstep ge (FreelistEffect m (blocks_of_env e))
        (CL_State f (Sreturn (Some a)) k e le) m
        (CL_Returnstate v' (call_cont k)) m'
  | clight_effstep_skip_call: forall f k e le m m',
      is_call_cont k ->
      Mem.free_list m (blocks_of_env e) = Some m' ->
      clight_effstep ge (FreelistEffect m (blocks_of_env e))
        (CL_State f Sskip k e le) m
        (CL_Returnstate Vundef k) m'

  | clight_effstep_switch: forall f a sl k e le m n,
      eval_expr ge e le m a (Vint n) ->
      clight_effstep ge EmptyEffect
       (CL_State f (Sswitch a sl) k e le) m
        (CL_State f (seq_of_labeled_statement (select_switch n sl)) (Kswitch k) e le) m
  | clight_effstep_skip_break_switch: forall f x k e le m,
      x = Sskip \/ x = Sbreak ->
      clight_effstep ge EmptyEffect
        (CL_State f x (Kswitch k) e le) m
        (CL_State f Sskip k e le) m
  | clight_effstep_continue_switch: forall f k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f Scontinue (Kswitch k) e le) m
        (CL_State f Scontinue k e le) m

  | clight_effstep_label: forall f lbl s k e le m,
      clight_effstep ge EmptyEffect
        (CL_State f (Slabel lbl s) k e le) m
        (CL_State f s k e le) m

  | clight_effstep_goto: forall f lbl k e le m s' k',
      find_label lbl f.(fn_body) (call_cont k) = Some (s', k') ->
      clight_effstep ge EmptyEffect
        (CL_State f (Sgoto lbl) k e le) m
        (CL_State f s' k' e le) m

  | clight_effstep_internal_function: forall f vargs k m e le m',
      FE f vargs m e le m' ->
      clight_effstep ge EmptyEffect
        (CL_Callstate (Internal f) vargs k) m
        (CL_State f f.(fn_body) k e le) m'
(*no external step
  | step_external_function: forall ef targs tres vargs k m vres t m',
      external_call ef ge vargs m t vres m' ->
      clight_effstep (CL_Callstate (External ef targs tres) vargs k) m
         (CL_Returnstate vres k) m'
*)

  | clight_effstep_returnstate: forall v optid f e le k m,
      clight_effstep ge EmptyEffect
        (CL_Returnstate v (Kcall optid f e le k)) m
        (CL_State f Sskip k e (set_opttemp optid v le)) m

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

Variable FE_FWD: forall f vargs m e le m', FE f vargs m e le m' -> mem_forward m m'.
Variable FE_UNCH: forall f vargs m e le m', FE f vargs m e le m'->
         Mem.unchanged_on (fun b z => EmptyEffect b z = false) m m'.

Lemma clightstep_effax1: forall (M : block -> Z -> bool) ge c m c' m'
      (H: clight_effstep ge M c m c' m'),
       corestep (CL_coop_sem FE FE_FWD) ge c m c' m' /\
       Mem.unchanged_on (fun (b : block) (ofs : Z) => M b ofs = false) m m'.
Proof.
intros.
  induction H.
  split. econstructor; try eassumption.
         eapply assign_loc_Effect_Sound; eassumption.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
(*  split. econstructor; try eassumption.
         eapply ec_builtinEffectPolymorphic; eassumption.*)
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         eapply FreelistEffect_freelist; eassumption.
  split. econstructor; try eassumption.
         eapply FreelistEffect_freelist; eassumption.
  split. econstructor; try eassumption.
         eapply FreelistEffect_freelist; eassumption.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  split. econstructor; try eassumption.
         eapply FE_UNCH; eassumption.
  split. econstructor; try eassumption.
         apply Mem.unchanged_on_refl.
  (*effstep_sub_val*)
    destruct IHclight_effstep.
    split; trivial.
    eapply unchanged_on_validblock; try eassumption.
    intros; simpl. remember (E b ofs) as d.
    destruct d; trivial. apply eq_sym in Heqd.
    rewrite (H _ _ H3 Heqd) in H4. discriminate.
Qed.

Lemma clightstep_effax2: forall ge c m c' m',
      corestep (CL_coop_sem FE FE_FWD) ge c m c' m' ->
      exists M, clight_effstep ge M c m c' m'.
Proof.
intros. inv H.
  eexists. eapply clight_effstep_assign; eassumption.
  eexists. eapply clight_effstep_set; eassumption.
  eexists. eapply clight_effstep_call; eassumption.
(*  eexists. eapply clight_effstep_builtin; eassumption.*)
  eexists. eapply clight_effstep_seq; eassumption.
  eexists. eapply clight_effstep_skip_seq; eassumption.
  eexists. eapply clight_effstep_continue_seq; eassumption.
  eexists. eapply clight_effstep_break_seq; eassumption.
  eexists. eapply clight_effstep_ifthenelse; eassumption.
  eexists. eapply clight_effstep_loop; eassumption.
  eexists. eapply clight_effstep_skip_or_continue_loop1; eassumption.
  eexists. eapply clight_effstep_break_loop1; eassumption.
  eexists. eapply clight_effstep_skip_loop2; eassumption.
  eexists. eapply clight_effstep_break_loop2; eassumption.
  eexists. eapply clight_effstep_return_0; eassumption.
  eexists. eapply clight_effstep_return_1; eassumption.
  eexists. eapply clight_effstep_skip_call; eassumption.
  eexists. eapply clight_effstep_switch; eassumption.
  eexists. eapply clight_effstep_skip_break_switch; eassumption.
  eexists. eapply clight_effstep_continue_switch; eassumption.
  eexists. eapply clight_effstep_label; eassumption.
  eexists. eapply clight_effstep_goto; eassumption.
  eexists. eapply clight_effstep_internal_function; eassumption.
  eexists. eapply clight_effstep_returnstate; eassumption.
Qed.

Definition clight_eff_sem
  :  @EffectSem Clight.genv CL_core.
eapply Build_EffectSem with (sem := CL_coop_sem _ FE_FWD)
         (effstep:=clight_effstep).
eapply clightstep_effax1.
apply clightstep_effax2.
apply clight_effstep_sub_val.
Defined.
End EFFSEM.

Lemma function_entry1_UNCH: forall f vargs m e le m',
      function_entry1 f vargs m e le m'->
      Mem.unchanged_on (fun b z => EmptyEffect b z = false) m m'.
Proof. intros. inv H.
  assert (FRESH: forall id b ty,
           e ! id = Some (b, ty) -> ~ Mem.valid_block m b).
    intros.
    destruct (alloc_variables_freshblocks _ _ _ _ _ H1 _ _ _ H); trivial.
      rewrite PTree.gempty in H3. discriminate.
  clear H0.
  apply unchanged_on_validblock with (V:= fun b z => Mem.valid_block m b /\ EmptyEffect b z = false).
    simpl; intros. split; trivial.
  specialize (alloc_variables_forward _ _ _ _ _ H1).
  eapply unchanged_on_trans; try eassumption.
    eapply alloc_variables_unchanged_on; eassumption.
  clear H1. remember (fn_params f) as pars. clear Heqpars.
  generalize dependent m1. generalize dependent vargs.
  induction pars; simpl; intros.
    inv H2. apply Mem.unchanged_on_refl.
    inv H2. specialize (IHpars _ _ H7).
    apply FRESH in H1.
    eapply unchanged_on_trans; try eassumption;
      try (eapply assign_loc_forward; eassumption).
    clear H7 IHpars FRESH.
    inv H4.
      inv H0.
      split; intros.
        split; intros.
          eapply Mem.perm_store_1; eassumption.
          eapply Mem.perm_store_2; eassumption.
      rewrite (Mem.store_mem_contents _ _ _ _ _ _ H3).
        rewrite PMap.gso. trivial.
        destruct H0. intros N; subst. contradiction.
    split; intros.
      split; intros.
        eapply Mem.perm_storebytes_1; eassumption.
        eapply Mem.perm_storebytes_2; eassumption.
      rewrite (Mem.storebytes_mem_contents _ _ _ _ _ H6).
        rewrite PMap.gso. trivial.
        destruct H4. intros N; subst. contradiction.
Qed.

Lemma function_entry2_UNCH: forall f vargs m e le m',
      function_entry2 f vargs m e le m'->
      Mem.unchanged_on (fun b z => EmptyEffect b z = false) m m'.
Proof. intros. inv H.
    eapply alloc_variables_unchanged_on; eassumption.
Qed.

Definition CL_eff_sem1: @EffectSem Clight.genv CL_core.
  eapply (clight_eff_sem function_entry1).
  apply function_entry1_forward.
  apply function_entry1_UNCH.
Defined.

Definition CL_eff_sem2: @EffectSem Clight.genv CL_core.
  eapply (clight_eff_sem function_entry2).
  apply function_entry2_forward.
  apply function_entry2_UNCH.
Defined.


(**

This file describes the array tiling transformation.

Author: Ramon Fernandez I Mir and Arthur Charguéraud.

License: MIT.

*)

Set Implicit Arguments.
Require Export Semantics LibSet LibMap LibList TLCbuffer Typing.

Implicit Types i j k I J K : int.

Open Scope Z_scope.

(* ---------------------------------------------------------------------- *)
(** Definition of the transformation *)

(** Tiling transformation. Specified by:
    - The typvar of the array to be tiled.
    - The new typvar of the tiles.
    - The size of the tiles. *)

Record tiling_tr := make_tiling_tr {
  tiling_tr_array_name : typvar;
  tiling_tr_tile_name : typvar;
  tiling_tr_tile_size : size
}.

Notation make_tiling_tr' := make_tiling_tr.

(** Checking if the transformation is acceptable. *)

Inductive tiling_tr_ok : tiling_tr -> typdefctx -> Prop :=
  | tiling_tr_ok_intros : forall Ta Tt K T os tt C,
      tt = make_tiling_tr Ta Tt K ->
      Ta \indom C ->
      C[Ta] = typ_array T os ->
      Tt \notindom C ->
      K > 0%Z ->
      (forall Tv,
        Tv \indom C ->
        Tv <> Ta ->
        ~ free_typvar C Ta C[Tv]) ->
      tiling_tr_ok tt C.

(* ---------------------------------------------------------------------- *)
(** Representation of indices. *)

Definition nb_tiles (K I J:int) : Prop :=
  J = I / K + If (I mod K = 0) then 0 else 1.

Definition tiled_indices (I J K i j k:int) : Prop :=
      i = j * K + k
  /\  index I i
  /\  index J j
  /\  index K k.

(* ---------------------------------------------------------------------- *)
(** The transformation applied to the different constructs. *)

(** Transformation of typdefctxs: C ~ |C| *)

Inductive tr_typdefctx (tt:tiling_tr) : typdefctx -> typdefctx -> Prop :=
  | tr_typdefctx_intro : forall T Tt Ta K os os' C C',
      tt = make_tiling_tr Ta Tt K ->
      dom C' = dom C \u \{Tt} ->
      C[Ta] = typ_array T os ->
      C'[Ta] = typ_array (typ_var Tt) os' ->
      C'[Tt] = typ_array T (Some K) ->
      (forall Tv,
        Tv \indom C ->
        Tv <> Ta ->
        C'[Tv] = C[Tv]) ->
      (match os, os' with
      | Some Ii, Some Jj => nb_tiles K Ii Jj
      | None, None => True
      | _,_ => False
      end) ->
      tr_typdefctx tt C C'.

(** Transformation of paths: π ~ |π| *)

Inductive tr_accesses (tt:tiling_tr) : accesses -> accesses -> Prop :=
  | tr_accesses_nil :
      tr_accesses tt nil nil
  | tr_accesses_array_tiling : forall π π' Ta Tt i n a0 a1 a2,
      tr_accesses tt π π' ->
      tt = make_tiling_tr Ta Tt n ->
      a0 = access_array (typ_var Ta) i ->
      a1 = access_array (typ_var Ta) (i/n) ->
      a2 = access_array (typ_var Tt) (i mod n) ->
      tr_accesses tt (a0::π) (a1::a2::π')
  | tr_accesses_array_other : forall π π' T i,
      T <> typ_var (tiling_tr_array_name tt) ->
      tr_accesses tt π π' ->
      tr_accesses tt ((access_array T i)::π) ((access_array T i)::π')
  | tr_accesses_field : forall T π π' f,
      tr_accesses tt π π' ->
      tr_accesses tt ((access_field T f)::π) ((access_field T f)::π').

(** Transformation of values: v ~ |v| *)

Inductive tr_val (tt:tiling_tr) : val -> val -> Prop :=
  | tr_val_uninitialized :
      tr_val tt val_uninitialized val_uninitialized
  | tr_val_unit :
      tr_val tt val_unit val_unit
  | tr_val_bool : forall b,
      tr_val tt (val_bool b) (val_bool b)
  | tr_val_int : forall i,
      tr_val tt (val_int i) (val_int i)
  | tr_val_double : forall d,
      tr_val tt (val_double d) (val_double d)
  | tr_val_abstract_ptr : forall l π π',
      tr_accesses tt π π' ->
      tr_val tt (val_abstract_ptr l π) (val_abstract_ptr l π')
  | tr_val_array_tiling : forall K I J Tt Ta aI aJ,
      tt = make_tiling_tr Ta Tt K ->
      nb_tiles K I J ->
      length aI = I ->
      length aJ = J ->
      (forall j,
        index aJ j ->
        exists aK,
            aJ[j] = (val_array (typ_var Tt) aK)
        /\  length aK = K) ->
      (forall i j k aK,
        tiled_indices I J K i j k ->
        aJ[j] = (val_array (typ_var Tt) aK) ->
        tr_val tt aI[i] aK[k]) ->
      tr_val tt (val_array (typ_var Ta) aI) (val_array (typ_var Ta) aJ)
  | tr_val_array_other : forall T a a',
      T <> typ_var (tiling_tr_array_name tt) ->
      length a = length a' ->
      (forall i,
        index a i ->
        tr_val tt a[i] a'[i]) ->
      tr_val tt (val_array T a) (val_array T a')
  | tr_val_struct_other : forall T s s',
      dom s = dom s' ->
      (forall f,
        f \indom s ->
        tr_val tt s[f] s'[f]) ->
      tr_val tt (val_struct T s) (val_struct T s').

(** Transformation used in the struct cases to avoid repetition. *)

Inductive tr_prim (tt:tiling_tr) (pr:typ->prim) : trm -> trm -> trm -> Prop :=
  | tr_prim_intro : forall op1 Ta op2 Tt ta1 ta2 K tlk tlj v1 v2,
      tt = make_tiling_tr Ta Tt K ->
      op1 = pr (typ_var Ta) ->
      op2 = pr (typ_var Tt) ->
      tlk = trm_app binop_mod ((trm_val v2)::(trm_val (val_int K))::nil) ->
      tlj = trm_app binop_div ((trm_val v2)::(trm_val (val_int K))::nil) ->
      ta1 = trm_app op1 ((trm_val v1)::tlj::nil) ->
      ta2 = trm_app op2 (ta1::tlk::nil) ->
      tr_prim tt pr (trm_val v1) (trm_val v2) ta2.

(** v1[v2 / K][v2 % K] *)

Inductive tr_array_op (tt:tiling_tr) : trm -> trm -> Prop :=
  | tr_array_op_tiling_access : forall op t1 t2 tlt,
      op = prim_array_access (typ_var (tiling_tr_array_name tt)) ->
      tr_prim tt prim_array_access t1 t2 tlt ->
      tr_array_op tt (trm_app op (t1::t2::nil)) tlt
  | tr_array_op_tiling_get : forall op t1 t2 tlt,
      op = prim_array_get (typ_var (tiling_tr_array_name tt)) ->
      tr_prim tt prim_array_get t1 t2 tlt ->
      tr_array_op tt (trm_app op (t1::t2::nil)) tlt
  | tr_array_op_other_access : forall Ta op T ts,
      Ta = tiling_tr_array_name tt ->
      T <> (typ_var Ta) ->
      op = prim_array_access T ->
      tr_array_op tt (trm_app op ts) (trm_app op ts)
  | tr_array_op_other_get : forall Ta op T ts,
      Ta = tiling_tr_array_name tt ->
      T <> (typ_var Ta) ->
      op = prim_array_get T ->
      tr_array_op tt (trm_app op ts) (trm_app op ts).

(** Transformation of terms: t ~ |t| *)

Inductive tr_trm (tt:tiling_tr) : trm -> trm -> Prop :=
  | tr_trm_val : forall v v',
      tr_val tt v v' ->
      tr_trm tt (trm_val v) (trm_val v')
  | tr_trm_var : forall x,
      tr_trm tt (trm_var x) (trm_var x)
  | tr_trm_if : forall t1 t2 t3 t1' t2' t3',
      tr_trm tt t1 t1' ->
      tr_trm tt t2 t2' ->
      tr_trm tt t3 t3' ->
      tr_trm tt (trm_if t1 t2 t3) (trm_if t1' t2' t3')
  | tr_trm_let : forall x t1 t2 t1' t2',
      tr_trm tt t1 t1' ->
      tr_trm tt t2 t2' ->
      tr_trm tt (trm_let x t1 t2) (trm_let x t1' t2')
  (* new *)
  | tr_trm_new : forall T,
      tr_trm tt (trm_app (prim_new T) nil) (trm_app (prim_new T) nil)
  (* Special case: array access *)
  | tr_trm_array : forall t1' t2' op t1 t2 tr,
      is_array_op op ->
      tr_trm tt t1 t1' ->
      tr_trm tt t2 t2' ->
      tr_array_op tt (trm_app op (t1'::t2'::nil)) tr ->
      tr_trm tt (trm_app op (t1::t2::nil)) tr
  (* Args *)
  | tr_trm_args1 : forall op t1 t1',
      tr_trm tt t1 t1' ->
      tr_trm tt (trm_app op (t1::nil)) (trm_app op (t1'::nil))
  | tr_trm_args2 : forall op t1 t1' t2 t2',
      ~ is_array_op op ->
      tr_trm tt t1 t1' ->
      tr_trm tt t2 t2' ->
      tr_trm tt (trm_app op (t1::t2::nil)) (trm_app op (t1'::t2'::nil)).

(** Transformation of stacks: S ~ |S| *)

Inductive tr_stack_item (tt:tiling_tr) : (var * val) -> (var * val) -> Prop :=
  | tr_stack_item_intro : forall x v v',
      tr_val tt v v' ->
      tr_stack_item tt (x, v) (x, v').

Inductive tr_stack (tt:tiling_tr) : stack -> stack -> Prop :=
  | tr_stack_intro : forall S S',
      LibList.Forall2 (tr_stack_item tt) S S' ->
      tr_stack tt S S'.

(** Transformation of states: m ~ |m| *)

Inductive tr_state (tt:tiling_tr) : state -> state -> Prop :=
  | tr_state_intro : forall m m',
      dom m = dom m' ->
      (forall l,
        l \indom m ->
        tr_val tt m[l] m'[l]) ->
      tr_state tt m m'.

(* ---------------------------------------------------------------------- *)
(** Results about division and modulo operation. *)

Section DivModResults.

(** Axioms. *)

Axiom div_mod_eq : forall i j k:Z,
  k > 0%Z ->
  (i / k)%Z = (j / k)%Z ->
  (i mod k)%Z = (j mod k)%Z ->
  i = j.

Axiom div_plus_mod_eq : forall i K,
  K > 0%Z ->
  i = (i/K)*K + (i mod K).

Axiom residual_div : forall (x i:int) (K:size),
  K > 0%Z ->
  index K i ->
  ((x * K + i) / K)%Z = x.

Axiom index_div : forall I K i:Z,
  K > 0%Z ->
  index I i ->
  index ((I/K + If (I mod K = 0) then 0 else 1)%Z) ((i/K)%Z).

Axiom index_mod : forall K i:Z,
  K > 0%Z ->
  index K ((i mod K)%Z).

Axiom index_mul_plus : forall I K i k:Z,
  K > 0%Z ->
  index ((I/K + If (I mod K = 0) then 0 else 1)%Z) i ->
  index K k ->
  index I (i * K + k)%Z.

(** Numerical results. *)

Lemma div_mod_enforce_mod : forall i k j:Z,
  k > 0%Z ->
  i = i / k * k + j ->
  j = (i mod k)%Z.
Proof using.
  introv Hnz Heq. forwards~ H: div_plus_mod_eq i k.
  remember (i/k * k) as n. rewrite H in Heq.
  forwards*: Z.add_reg_l Heq.
Qed.

Lemma div_mod_enforce_mod_inv : forall i k j:Z,
  k > 0%Z ->
  j = (i mod k)%Z ->
  i = i / k * k + j.
Proof using.
  introv Hnz Heq. rewrite Heq. apply~ div_plus_mod_eq.
Qed.

Lemma div_mod_enforce_div : forall i k j:Z,
  k > 0%Z ->
  i = j * k + (i mod k)%Z ->
  j = (i / k)%Z.
Proof using.
  introv Hnz Heq. forwards~ H: div_plus_mod_eq i k.
  remember ((i mod k)%Z) as n. rewrite H in Heq.
  rewrite Z.add_comm in Heq.
  rewrite Z.add_comm with (n:=j*k) (m:=n) in Heq.
  forwards H0: Z.add_reg_l Heq.
  forwards*: Z.mul_reg_r H0.
  math.
Qed.

Lemma div_mod_enforce_div_inv : forall i (k:size) j,
  k > 0%Z ->
  j = (i / k)%Z ->
  i = j * k + (i mod k)%Z.
Proof using.
  introv Hnz Heq. rewrite Heq. apply~ div_plus_mod_eq.
Qed.

Lemma div_quotient_neq : forall i K j r,
  K > 0%Z ->
  (r / K)%Z <> i ->
  index K j ->
  (i * K + j)%Z <> r.
Proof using.
  introv Hnz Hneq Hineq. introv HN.
  rewrite <- HN in Hneq.
  forwards* Heq: residual_div Hnz Hineq.
Qed.

Lemma div_both_sides : forall a b c,
  a = b ->
  (a/c)%Z = (b/c)%Z.
Proof using.
  introv Heq. rewrite~ Heq.
Qed.

Lemma j_value : forall i j k K,
  K > 0%Z ->
  i = (j * K + k)%Z ->
  index K k ->
  j = (i/K)%Z.
Proof using.
  introv HK Heq Hi.
  forwards* Heq': div_both_sides i (j * K + k)%Z K.
  rewrite~ residual_div in Heq'.
Qed.

(** Higher-level results. *)

Lemma tiled_indices_i : forall I J K i,
  K > 0%Z ->
  nb_tiles K I J ->
  index I i ->
  tiled_indices I J K i (i / K) (i mod K).
Proof using.
  introv Hgtz Hnb HI.
  unfolds nb_tiles. unfolds tiled_indices.
  splits~.
  { applys~ div_plus_mod_eq. }
  { subst. applys~ index_div. }
  { applys~ index_mod. }
Qed.

Lemma tiled_indices_jk : forall I J K j k,
  K > 0%Z ->
  nb_tiles K I J ->
  index J j ->
  index K k ->
  tiled_indices I J K (j * K + k) j k.
Proof using.
  introv Hgtz Hnb HJ HK.
  unfolds nb_tiles. unfolds tiled_indices.
  splits~. subst. applys~ index_mul_plus.
Qed.

Lemma tiled_index_range_i : forall J I j K k,
  K > 0%Z ->
  nb_tiles K I J ->
  index J j ->
  index K k ->
  index I (j * K + k).
Proof using.
  introv Hgtz Hnb HJ HK. unfolds nb_tiles.
  subst. applys~ index_mul_plus.
Qed.

Lemma tiled_index_range_k : forall k K i I j J,
  K > 0%Z ->
  nb_tiles K I J ->
  tiled_indices I J K i j k ->
  index K k.
Proof using.
  introv Hgtz Hnb Hti. unfolds tiled_indices.
  destructs~ Hti.
Qed.

End DivModResults.

(* ---------------------------------------------------------------------- *)
(** Hints and tactics *)

Hint Constructors red redbinop.
Hint Constructors read_accesses write_accesses.
Hint Constructors tr_trm tr_val tr_accesses tr_state tr_stack.
Hint Constructors wf_trm wf_prim wf_val.

Hint Resolve wf_red.

(** Rewrite lengths. *)

Ltac rew_index_length_val_goal :=
  repeat match goal with
    Hl: length ?a = ?n
    |- index (length ?a) ?i =>
      rewrite Hl; clear Hl end.

Ltac rew_index_length_val_hyp :=
  repeat match goal with
    Hl: length ?a = ?n,
    Hi: index (length ?a) ?i
    |- ?G =>
      rewrite Hl in Hi end.

Ltac rew_index_length_val :=
  rew_index_length_val_goal;
  rew_index_length_val_hyp.

(** Rewrite and solve indeces. *)

Hint Rewrite length_update index_eq_index_length : rew_int.

Ltac solve_index :=
  unfolds nb_tiles;
  rew_index_length_val;
  rew_int in *;
  try solve [ congruence ];
  first [ applys index_div | applys index_mod ].

Hint Extern 1 (index ?a (?i mod ?k)%Z) =>
  rew_index_length_val;
  solve_index.

Hint Extern 1 (index ?a (?i/?k)%Z) =>
  rew_index_length_val;
  solve_index.

Hint Extern 1 (index ?a ?i) =>
  rew_index_length_val;
  solve_index.

Hint Extern 1 (index ?I (?j * ?K + ?k)) =>
  apply tiled_index_range_i; auto.

Hint Extern 1 (length ?a[?i:=?v] = ?l) =>
  rewrite length_update.

Hint Extern 1 (tiled_indices ?I ?J ?K ?i (?i / ?K) (?i mod ?K)) =>
  apply tiled_indices_i; auto.

Hint Extern 1 (tiled_indices ?I ?J ?K (?j * ?K + ?k) ?j ?k) =>
  apply tiled_indices_jk; auto.

(** Quick way of proving K > 0 in many cases. *)

Ltac inverts_Hok :=
  match goal with
    Hok: tiling_tr_ok ?C ?tt
    |- ?G =>
      inverts Hok end.

Hint Extern 1 (?K > 0%Z) =>
  inverts_Hok; simpls*.

(* ---------------------------------------------------------------------- *)
(** Regularity of the transformation with respect to values *)

(** Basic values stay basic after the transformation. *)

Lemma is_basic_tr : forall tt v1 v2,
  tr_val tt v1 v2 ->
  is_basic v1 ->
  is_basic v2.
Proof using.
  introv Htr Hv1. induction Htr;
  try solve [ inverts Hv1 ];
  constructors~.
Qed.

(** The transformation doesn't transform errors. *)

Lemma not_tr_val_error : forall tt v1 v2,
  tr_val tt v1 v2 ->
  ~ is_error v2.
Proof using.
  introv Hv He. unfolds is_error.
  destruct* v2. inverts Hv.
Qed.

(** The core primitive transformation returns a term. *)

Lemma not_is_val_tr_access : forall tt pr t1 t2 tlt,
  tr_prim tt pr t1 t2 tlt ->
  ~ is_val tlt.
Proof using.
  introv Htra HN. inverts Htra. inverts HN.
Qed.

(** Terms stay terms after the transformation. *)

Lemma not_is_val_tr : forall tt t1 t2,
  tr_trm tt t1 t2 ->
  ~ is_val t1 ->
  ~ is_val t2.
Proof using.
  introv Htr Hv. induction Htr; introv HN;
  try solve [ subst ; inverts HN ].
  forwards*: Hv. inverts H0 as.
  { introv Htr. applys* not_is_val_tr_access. }
  { introv Htr. applys* not_is_val_tr_access. }
  { introv Hneq. inverts HN. }
  { introv Hneq. inverts HN. }
Qed.

(** Initialized values are transformed to initialized values. *)

Lemma not_is_uninitialized_tr : forall tt v v',
  tiling_tr_tile_size tt > 0%Z ->
  tr_val tt v v' ->
  ~ is_uninitialized v ->
  ~ is_uninitialized v'.
Proof using.
  introv Hgtz Htr Hu HN. induction Htr; subst; inverts HN as.
  { applys* Hu. constructors. }
  { introv (j&Hj&HuaJj).
    forwards* (aK&HaJj&HlaK): H3 j.
    rewrite HaJj in HuaJj.
    inverts HuaJj as (k&Hk&HuaKk).
    forwards*: H5 (j * K + k) j k.
    introv HuaI. applys~ Hu.
    constructors. exists (j * K + k). splits~.
    applys* tiled_index_range_i. }
  { introv (i&Hi&Hua'i). asserts Hi': (index a i).
    { rewrite index_eq_index_length in *. rewrite~ H0. }
    applys* H2. introv Huai. applys~ Hu. constructors.
    exists* i. }
  { introv (f&Hfin&Hus'f). asserts Hfin': (f \indom s).
    { rewrite~ H. }
    applys* H1. introv Husf. applys~ Hu. constructors.
    exists* f. }
Qed.

(** The relation [nb_tiles] is a (partial) function. *)

Lemma functional_nb_tiles : forall n k m1 m2,
  nb_tiles n k m1 ->
  nb_tiles n k m2 ->
  m1 = m2.
Proof using.
  introv Hm1 Hm2. unfolds nb_tiles. subst*.
Qed.

(** The relation [tr_accesses] is a (partial) function. *)

Theorem functional_tr_accesses : forall tt π π1 π2,
  tr_accesses tt π π1 ->
  tr_accesses tt π π2 ->
    π1 = π2.
Proof using.
  introv H1 H2. gen π2. induction H1; intros;
  inverts_head tr_accesses; repeat fequals*;
  inverts_head access_array; subst; simpls; tryfalse.
Qed.

(** Path surgery *)

Lemma tr_accesses_app : forall tt π1 π2 π1' π2',
  tr_accesses tt π1 π1' ->
  tr_accesses tt π2 π2' ->
  tr_accesses tt (π1 ++ π2) (π1' ++ π2').
Proof using.
  introv Ha1 Ha2. gen π2 π2'. induction Ha1; intros;
  rew_list in *; eauto.
Qed.

(** The relation [tr_val] is a (partial) function. *)

Theorem functional_tr_val : forall tt v v1 v2,
  tiling_tr_tile_size tt > 0%Z ->
  tr_val tt v v1 ->
  tr_val tt v v2 ->
  v1 = v2.
Proof using.
  introv Hnz H1 H2. gen v2. induction H1; intros;
  try solve [ inverts_head tr_val; fequals*; subst; simpls; tryfalse ].
  { inverts H2 as Hπ. forwards*: functional_tr_accesses H Hπ.
    subst. fequals. }
  { (* Tiled array *)
    inverts H6 as; inverts_head make_tiling_tr'.
    { introv Hnb HE Ha''.
      asserts Hl: (length aJ = length aJ0).
      { subst. forwards*: functional_nb_tiles H0 Hnb. }
      fequals*. applys* eq_of_extens. introv Hi.
      asserts Hi': (index aJ0 i).
      { rewrite index_eq_index_length in *. rewrite~ <- Hl. }
      forwards* (aK1&HaJ0i&HlaK1): HE i.
      forwards* (aK2&HaJi&HlaK2): H3 i.
      rewrite HaJ0i. rewrite HaJi. fequals.
      asserts HlK: (length aK1 = length aK2).
      { congruence. }
      applys~ eq_of_extens. introv Hi0.
      asserts Hik: (index K0 i0).
      { rewrite index_eq_index_length in Hi0. rewrite~ HlaK2 in Hi0. }
      asserts Hij: (index J i).
      { rewrite index_eq_index_length in Hi. rewrite~ H2 in Hi. }
      applys* H5 (i * K0 + i0). eauto.
      applys~ Ha'' i. }
    { simpls. introv HN. false. } }
  { (* Another array *)
    inverts H3 as; simpls; tryfalse.
    introv Hneq Hl Htr. fequals. applys eq_of_extens.
    { congruence. }
    { introv Hi. asserts: (index a i).
      { rewrite index_eq_index_length in *. rewrite~ H0. }
      applys* H2. } }
  { (* Structs *)
    inverts H2 as HD Htr. fequals. applys read_extens.
    { congruence. }
    { introv Hin. asserts_rewrite* (dom s' = dom s) in *. } }
Qed.

(** The function [tr_accesses] is injective. *)

Lemma tr_accesses_inj : forall C tt π π1 π2,
  tiling_tr_ok tt C ->
  wf_accesses C π1 ->
  wf_accesses C π2 ->
  tr_accesses tt π1 π ->
  tr_accesses tt π2 π ->
    π1 = π2.
Proof using.
  introv Hok Hva1 Hva2 Hπ1 Hπ2. gen C π2. induction Hπ1; intros.
  { inverts Hπ2. auto. }
  { subst. inverts Hπ2; inverts Hva1; inverts Hva2.
    { inverts_head make_tiling_tr'. repeat inverts_head access_array.
      repeat fequals*. applys* div_mod_eq. inverts Hok.
      inverts_head make_tiling_tr'. auto. }
    { simpls. false. } }
  { inverts Hπ2; inverts Hva1; inverts Hva2.
    { inverts_head access_array. fequals*. }
    { fequals*. } }
  { inverts Hπ2; inverts Hva1; inverts Hva2.
    { inverts_head access_array. }
    { fequals*. } }
Qed.

(** The function [tr_val] is injective. *)

Lemma tr_val_inj : forall C tt v v1 v2,
  tiling_tr_ok tt C ->
  is_basic v1 ->
  is_basic v2 ->
  wf_val C v1 ->
  wf_val C v2 ->
  tr_val tt v1 v ->
  tr_val tt v2 v ->
  v1 = v2.
Proof using.
  introv Hok HBv1 HBv2 Hwfv1 Hwfv2 Hv1 Hv2. gen C v2. induction Hv1; intros;
  try solve [ inverts Hv2; repeat fequals*; subst; simpls; tryfalse* ].
  { inverts Hv2 as Hπ. repeat fequals*.
    inverts Hwfv1 as HRφ1. inverts Hwfv2 as HRφ2.
    applys* tr_accesses_inj. }
Qed.

(** Contrapositive of the previous statement. *)

Lemma tr_val_inj_cp : forall C tt v1 v2 v1' v2',
  tiling_tr_ok tt C ->
  is_basic v1 ->
  is_basic v2 ->
  wf_val C v1 ->
  wf_val C v2 ->
  tr_val tt v1 v1' ->
  tr_val tt v2 v2' ->
  v1 <> v2 ->
  v1' <> v2'.
Proof using.
  introv Hok HBv1 HBv2 HTv1 HTv2 Hv1 Hv2 Hneq HN. subst.
  forwards*: tr_val_inj Hok HTv1 HTv2 Hv1.
Qed.

(* ---------------------------------------------------------------------- *)
(** Specific results about the transformation and typing. *)

(** The transformation preserves well-formed types. *)

Lemma tr_typdefctx_wf_typ : forall tt C C' T,
  tr_typdefctx tt C C' ->
  wf_typ C T ->
  wf_typ C' T.
Proof using.
  introv HC HT. induction HT; try solve [ constructors* ].
  inverts HC as HDC' HCTa HC'Ta HC'Tt HC'Tv Hos.
  constructors.
  { rewrite HDC'. rew_set~. }
  { tests: (Tv=Ta).
    { rewrite HC'Ta. repeat constructors~.
      { rewrite HDC'. rew_set~. }
      { rewrite HC'Tt. constructors~.
        rewrite HCTa in IHHT.
        inverts~ IHHT. } }
    { rewrite~ HC'Tv. } }
Qed.

(** All structs have the same type in C and C'. *)

Lemma tr_typing_struct : forall tt C C' Ts Tfs,
  tr_typdefctx tt C C' ->
  typing_struct C Ts Tfs ->
  typing_struct C' Ts Tfs.
Proof using.
  introv HC HTs. induction HTs; intros.
  { constructors~. }
  { inverts HC as HD HCTa HC'Ta HC'Tt HC'Tv _.
    constructors~.
    { rewrite HD. rew_set~. }
    { tests: (Tv=Ta).
      { rewrite HCTa in HTs. inverts HTs. }
      { rewrite~ HC'Tv. } } }
Qed.

(** Arrays where Tat does not appear free have the same type. *)

Lemma tr_typing_array : forall Tat Tt k C C' Ta T os,
  tr_typdefctx (make_tiling_tr Tat Tt k) C C' ->
  wf_typdefctx C ->
  ~ free_typvar C Tat Ta ->
  typing_array C Ta T os ->
  typing_array C' Ta T os.
Proof using.
  introv HC Hwf Hfv HTa. gen Tt Tat k C'. induction HTa; intros.
  { constructors~. applys* tr_typdefctx_wf_typ. }
  { inverts HC as Htt HD HCTa HC'Ta HC'Tt HC'Tv Hos.
    inverts Htt. constructors.
    { rewrite HD. rew_set~. }
    { tests: (Tv=Ta).
      { false. applys~ Hfv. constructors~. }
      { rewrite~ HC'Tv. applys* IHHTa Tt0 Ta K.
        { introv HN. applys~ Hfv. constructors~. }
        { constructors*. } } } }
Qed.

(* ---------------------------------------------------------------------- *)
(** Correctness proofs *)

Section TransformationProofs.

(** Lookup into the translated stack. *)

Lemma stack_lookup_tr : forall tt S S' x v,
  tr_stack tt S S' ->
  Ctx.lookup x S = Some v ->
    exists v',
       Ctx.lookup x S' = Some v'
    /\ tr_val tt v v'.
Proof using.
  introv HS Hx. inverts HS as HS. induction HS.
  { inverts Hx. }
  { inverts H as Hv. inverts Hx as Hx. case_if in Hx.
    { inverts Hx. exists v'. splits*. unfolds. case_if*. }
    { forwards (v''&Hx'&Hv''): IHHS Hx. exists v''.
      splits*. unfolds. case_if. fold Ctx.lookup. auto. } }
Qed.

(** Used in the [let] case. *)

Lemma tr_stack_add : forall tt z v S v' S',
  tr_stack tt S S' ->
  tr_val tt v v' ->
  tr_stack tt (Ctx.add z v S) (Ctx.add z v' S').
Proof using.
  introv HS Hv. constructors~. inverts HS.
  unfolds Ctx.add. destruct* z.
  applys~ Forall2_cons. constructors~.
Qed.

(** Used in the [get] case. *)

Lemma tr_read_accesses : forall tt v π v' π' w,
  tiling_tr_tile_size tt > 0%Z ->
  tr_val tt v v' ->
  tr_accesses tt π π' ->
  read_accesses v π w ->
  (exists w',
      tr_val tt w w'
  /\  read_accesses v' π' w').
Proof using.
  introv Hgt Hv Ha HR. gen tt v' π'. induction HR; intros.
  { (* nil *)
    inverts Ha. exists~ v'. }
  { (* array_access *)
    inverts Ha as.
    { (* tiling array *)
      introv Hπ Heq. inverts Heq.
      inverts Hv as.
      2:{ introv HN. simpls. false. }
      introv Heq Hnb Ha'' Htrv. inverts Heq.
      unfolds nb_tiles.
      forwards* (a''&Ha'i&Hla''): Ha'' ((i0/K)%Z).
      { rewrite index_eq_index_length in *. rewrite* Hnb. }
      forwards* Hai0: Htrv i0 (i0/K)%Z (i0 mod K)%Z a''.
      forwards* (w'&Hvw'&HR'): IHHR.
      simpls~.
      exists w'. splits~.
      constructors~.
      { rewrite index_eq_index_length in *. rewrite* Hnb. }
      rewrite Ha'i. constructors~.
      { rewrite index_eq_index_length in *. rewrite* Hla''. } }
    { (* absurd case *)
      introv Hneq Hπ. inverts Hv as.
      { intros. simpls. false. }
      { introv _ Hla Htrv.
        forwards Htrv': Htrv H.
        forwards* (w'&Hvw'&HR'): IHHR. } } }
  { (* struct_access *)
    inverts Ha as.
    { introv _ HN. inverts HN. }
    introv Hπ. inverts Hv as HD Hsf.
    forwards~ Htr: Hsf f.
    forwards* (w'&Htrv2w'&HR'): IHHR.
    exists w'. splits~.
    constructors~. rewrite~ <- HD. }
Qed.

(** Used in the [set] case. *)

Lemma tr_write_accesses : forall tt Ta Tt K v1 w π v1' π' w' v2,
  tt = make_tiling_tr' Ta Tt K ->
  K > 0%Z ->
  tr_val tt v1 v1' ->
  tr_val tt w w' ->
  tr_accesses tt π π' ->
  write_accesses v1 π w v2 ->
  (exists v2',
        tr_val tt v2 v2'
    /\  write_accesses v1' π' w' v2').
Proof using.
  introv Htt HK Hv1 Hw Hπ HW. gen v1' w' π'. induction HW; intros.
  { (* nil *)
    inverts Hπ. exists~ w'. }
  { (* array_access *)
    inverts Hπ as; inverts Hv1 as; inverts_head make_tiling_tr'.
    { (* tiling *)
      introv Htt Hnb Ha'i1 Htra1 Hπ Heq.
      inverts Htt. inverts Heq. subst.
      forwards* (aK&HaJiK&HlK): Ha'i1 ((i0/K0)%Z).
      { rewrite index_eq_index_length in *. rewrite* Hnb. }
      forwards* HtraK: Htra1 i0 (i0/K0)%Z (i0 mod K0)%Z aK.
      forwards* (v2'&Hv2'&HW'): IHHW.
      remember (val_array (typ_var Tt1) aK[((i0 mod K0)%Z):=v2']) as aK'.
      exists (val_array (typ_var Ta1) aJ[((i0/K0)%Z):=aK']).
      subst_hyp HeqaK'. splits.
      { remember aK[(i0 mod K0)%Z:=v2'] as aK'.
        remember aJ[(i0/K0)%Z:=val_array (typ_var Tt1) aK'] as aJ'.
        asserts Hex:
          (forall j : int,
            index aJ' j ->
            exists aK,
                  aJ'[j] = val_array (typ_var Tt1) aK
               /\ length aK = K0).
        { subst. introv Hi. rew_reads*. }
        subst_hyp HeqaK'. subst_hyp HeqaJ'.
        applys* tr_val_array_tiling.
        introv Hi' Hup.
        unfolds tiled_indices. destruct Hi' as (Hieq&Hi&Hk&Hj).
        forwards* (aK1&Heq&HlaK1): Hex j.
        inverts Heq.
        asserts Hi''': (index a1 (j * K0 + k)%Z).
        { rewrite index_eq_index_length in *.
          unfolds nb_tiles. rewrite Hnb in *. eauto. }
        rew_reads~ in Hup.
        { introv Heq. subst. inverts Hup. rew_reads*.
          { introv Hneq Heq.
            forwards*: div_mod_enforce_mod Heq. false. }
          { introv Heq Hneq. symmetry in Heq.
            forwards*: div_mod_enforce_mod_inv Heq. } }
        { introv Hneq.
          forwards* Htra1': Htra1.
          asserts Hneq': (j*K0+k <> i0).
          { applys~ div_quotient_neq. }
          rew_reads~. } }
        { constructors~.
          { rewrite index_eq_index_length in *. eauto. }
          rewrite HaJiK. constructors*.
          { rewrite index_eq_index_length in *. eauto. } } }
      { (* absurd case *)
        introv Hneq Hla1 Htra1i1 Hπ Heq. inverts Heq. simpls. false. }
      { (* absurd case *)
        intros. simpls. false. }
      { (* other array *)
        introv _ Hla1 Htra1i0 Hneq Hπ. subst.
        forwards* (v2'&Hv2'&HW'): IHHW.
        exists (val_array T a'[i:=v2']). splits.
        { constructors~.
          { repeat rewrite~ length_update. }
          { introv Hi0. rewrite index_update_eq in Hi0. rew_reads*. } }
        { constructors~. auto. } } }
  { (* struct *)
    inverts Hπ as; inverts Hv1 as.
    { (* absurd case *)
      introv _ _ _ HN. inverts HN. }
    { (* any struct *)
      introv HDs1 Hs1f0 Hπ. subst.
      forwards* (v2'&Hv2'&HW'): IHHW.
      exists (val_struct T s'[f:=v2']). splits.
      { constructors~.
        { repeat rewrite dom_update. congruence. }
        { introv Hf0. rewrite* dom_update_at_indom in Hf0.
          rew_reads*. } }
      { constructors~. rewrite~ <- HDs1. auto. } } }
Qed.

(** Lemma for the [new] case. *)

Lemma tr_uninitialized_val_aux : forall tt v v' T C C',
  tr_typdefctx tt C C' ->
  tiling_tr_ok tt C ->
  wf_typdefctx C ->
  tr_val tt v v' ->
  uninitialized C T v ->
  uninitialized C' T v'.
Proof using.
  introv HC Hok Hwf Hv Hu. gen tt C' v'. induction Hu; intros;
  try solve [ inverts Hv ; constructors~ ].
  { (* array *)
    inverts HC as HD HCTa HC'Ta HC'Tt HC'Tv Hos.
    inverts Hv as.
    { (* tiling array *)
      introv Htt Hnb Ha'i Htra. inverts Htt.
      inverts Hok as Htt HTain HCTa' HTt0nin Hnz Hfv.
      inverts Htt. unfolds wf_typdefctx.
      rewrite HCTa in HCTa'. inverts HCTa'.
      inverts H as _ HTCTa.
      rewrite HCTa in HTCTa. inverts HTCTa.
      destruct* os; destruct* os'.
      { (* Fixed-size array. *)
        applys uninitialized_array (Some (length aJ)).
        3:{ introv Hi. forwards* (a''&Ha'i'&Hla''): Ha'i.
            rewrite Ha'i'. applys uninitialized_array (Some K).
            { constructors.
              { rewrite HD. rew_set~. }
              { rewrite HC'Tt. constructors~.
                applys* tr_typdefctx_wf_typ. constructors*. } }
            { introv Heq. inverts~ Heq. }
            { introv Hi0. forwards* Htra'': Htra (i*K + i0)%Z i i0 a''.
              applys* H2.
              { applys* tiled_index_range_i. }
              { constructors*. }
              { constructors*. } } }
        { constructors.
          { rewrite HD. rew_set~. }
          { rewrite HC'Ta. unfolds nb_tiles.
            rewrite Hos. rewrite Hnb.
            forwards* Heq: H0 s. rewrite Heq.
            constructors. constructors.
            { rewrite HD. rew_set~. }
            { rewrite HC'Tt. constructors.
              applys* tr_typdefctx_wf_typ. constructors*. } } }
        { introv Heq. inverts~ Heq. } }
      { (* Variable length array. *)
        applys uninitialized_array.
        { constructors.
          { rewrite HD. rew_set~. }
          { rewrite HC'Ta. repeat constructors~.
            { rewrite HD. rew_set~. }
            { rewrite HC'Tt. constructors~.
              applys* tr_typdefctx_wf_typ. constructors*. } } }
        { introv HN. inverts HN. }
        { introv Hi. forwards* (a''&Ha'i'&Hla''): Ha'i.
          rewrite Ha'i'. constructors.
          { constructors.
            { rewrite HD. rew_set~. }
            { rewrite HC'Tt. constructors~.
              applys* tr_typdefctx_wf_typ. constructors*. } }
          { introv Hn. inverts~ Hn. }
          { introv Hi0. forwards* Htra': Htra (i*K + i0)%Z i i0 a''.
            applys* H2.
            { applys* tiled_index_range_i. }
            { constructors*. }
            { constructors*. } } } } }
    { (* other array *)
      introv Hneq Hla Htra. simpls. constructors.
      2:{ rewrite <- Hla. eapply H0. }
      { inverts H as.
        { introv HwfT. constructors*.
          applys* tr_typdefctx_wf_typ. constructors*. }
        { introv HTvin HTCTv.
          inverts Hok as Htt HTain HCTa' HTt0nin Hnz Hfv.
          inverts Htt. unfolds wf_typdefctx. constructors*.
          { rewrite HD. rew_set~. }
          { rewrite~ HC'Tv. applys~ tr_typing_array Ta Tt0 K0 C.
            { rewrite HCTa in HCTa'. inverts HCTa'. constructors*. }
            { applys~ Hfv. introv HN. subst. applys~ Hneq. }
            { introv HN. subst. applys~ Hneq. } } } }
      { introv Hi.
        asserts: (index a i).
        { rewrite index_eq_index_length in *. rewrite~ Hla. }
        forwards* Htra': Htra i.
        applys* H2. constructors*. } } }
  { (* struct *)
    inverts Hv as HD Hvfsf. constructors.
    2:{ rewrite~ H0. }
    { applys* tr_typing_struct. }
    { introv Hfin. applys* H2. applys Hvfsf.
      rewrite~ <- H0. } }
Qed.

(** This will be proved when the relation is translated to a function.
    See TrTilingFun.v. *)

Lemma total_tr_val_aux : forall gt v,
  exists v', tr_val gt v v'.
Proof using.
Admitted.

(** Usable lemma for the [new] case. *)

Lemma tr_uninitialized_val : forall tt v T C C',
  tr_typdefctx tt C C' ->
  tiling_tr_ok tt C ->
  wf_typdefctx C ->
  uninitialized C T v ->
  exists v',
        tr_val tt v v'
    /\  uninitialized C' T v'.
Proof using.
  introv HC Hok Hwf Hu. forwards* (v'&Hv'): total_tr_val_aux tt v.
  exists v'. splits~. applys* tr_uninitialized_val_aux.
Qed.

(* ---------------------------------------------------------------------- *)
(** Main lemma *)

Theorem red_tr_ind: forall tt C LLC C' t t' v S S' m1 m1' m2,
  red C LLC S m1 t m2 v ->
  tiling_tr_ok tt C ->
  tr_typdefctx tt C C' ->
  tr_trm tt t t' ->
  tr_stack tt S S' ->
  tr_state tt m1 m1' ->
  wf_typdefctx C ->
  wf_trm C t ->
  wf_stack C S ->
  wf_state C m1 ->
  ~ is_error v ->
  exists v' m2',
      tr_val tt v v'
  /\  tr_state tt m2 m2'
  /\  red C' LLC S' m1' t' m2' v'.
Proof using.
  introv HR Hok HC Ht HS Hm1 HwfC Hwft HwfS Hwfm1.
  introv He. gen tt C' t' S' m1'.
  induction HR; intros; try solve [ forwards*: He; unfolds* ].
  { (* val *)
    inverts Ht as Hv. exists* v' m1'. }
  { (* var *)
    inverts Ht. forwards* (v'&H'&Hv'): stack_lookup_tr HS H. exists* v' m1'. }
  { (* if *)
    inverts Ht as Hb HTrue HFalse.
    inverts Hwft as Hwft0 Hwft1 Hwft2.
    forwards* (v'&m2'&Hv'&Hm2'&HR3): IHHR1 Hb HS Hm1.
    inverts* Hv'. destruct b;
    forwards* (vr'&m3'&Hvr'&Hm3'&HR4): IHHR2 HS Hm2';
    forwards*: wf_red HR1; exists* vr' m3'. }
  { (* let *)
    inverts Ht as Ht1 Ht2.
    inverts Hwft as Hwft0 Hwft1.
    forwards* (v'&m2'&Hv'&Hm2'&HR3): IHHR1 Ht1 HS Hm1.
    forwards HS': tr_stack_add z HS Hv'.
    forwards: not_tr_val_error Hv'.
    forwards* (vr'&m3'&Hvr'&Hm3'&HR4): IHHR2 Ht2 HS' Hm2'.
    { applys~ wf_stack_add. applys* wf_red HR1. }
    { applys* wf_red HR1. }
    exists* vr' m3'. }
  { (* binop *)
    inverts Ht as.
    { introv Hop. inverts Hop. }
    { introv Hop Ht1 Ht2. inverts Ht1 as Ht1. inverts Ht2 as Ht2.
      inverts H3;
      try solve [ exists __ m1' ; splits~ ; inverts Ht1 ;
      inverts Ht2 ; repeat constructors~ ].
      { exists __ m1'. splits~.
        forwards~: functional_tr_val Ht1 Ht2. subst.
        constructors;
        repeat applys* is_basic_tr;
        repeat applys* not_tr_val_error.
        constructors~. }
      { exists __ m1'. splits~. constructors;
        repeat applys* is_basic_tr;
        repeat applys* not_tr_val_error.
        inverts Hwft as Hwfp Hwft1 Hwft2.
        inverts Hwft1 as Hwft1. inverts Hwft2 as Hwft2.
        forwards*: tr_val_inj_cp H H0. } } }
  { (* get *)
    inverts Ht as Ht1'. subst.
    inverts Ht1' as Ht1'. inverts Ht1' as Hπ.
    inverts Hm1 as HD Htrm.
    inverts H0 as Hi Ha.
    forwards Htrml: Htrm Hi.
    forwards~ (w'&Hw'&Ha'): tr_read_accesses Htrml Hπ Ha.
    exists w' m1'. splits*.
    repeat constructors~. rewrite~ <- HD.
    applys* not_is_uninitialized_tr. inverts~ Hok. }
  { (* set *)
    inverts Ht as.
    { introv HN. inverts HN. }
    introv Hneq Htrt1' Htrt2'. subst.
    inverts Hm1 as HD Htrm.
    inverts H2 as Hin HW.
    forwards Htrml: Htrm Hin.
    inverts Htrt1' as Hp.
    inverts Hp as Hπ.
    inverts Htrt2' as Hv.
    inverts Hok as HTain HCTa HTtnin Hnz Hfv.
    forwards* (w'&Hw'&HW'): tr_write_accesses Htrml Hv Hπ HW.
    exists val_unit m1'[l:=w']. splits~.
    { constructors.
      { unfold state. repeat rewrite~ dom_update.
        fold state. rewrite~ HD. }
      { introv Hi'. rew_reads~. intros. applys Htrm.
        applys~ indom_update_inv_neq Hi'. } }
    { constructors~. applys* not_tr_val_error.
      constructors*. rewrite~ <- HD. } }
  { (* new *)
    inverts Ht. subst.
    inverts Hm1 as HD Htrm.
    forwards* (v'&Hv'&Hu): tr_uninitialized_val.
    exists (val_abstract_ptr l nil) m1'[l:=v']. splits~.
    { constructors.
      { unfold state. repeat rewrite~ dom_update.
        fold state. rewrite~ HD. }
      { introv Hin. unfolds state. rew_reads; intros; eauto. } }
    { constructors*. rewrite~ <- HD. applys* tr_typdefctx_wf_typ. } }
  { (* new_array *)
    inverts Ht as.
    introv Ht.
    inverts Ht as Hv.
    inverts Hm1 as HD Htrm. subst.
    forwards* (v''&Hv''&Hu): tr_uninitialized_val.
    inverts Hv''.
    exists (val_abstract_ptr l nil) m1'[l:=(val_array (typ_array T None) a')].
    splits~.
    { constructors.
      { unfold state. repeat rewrite~ dom_update.
        fold state. rewrite~ HD. }
      { introv Hin. unfolds state. rew_reads; intros; eauto.
        constructors*. introv HN. inverts HN. } }
    { inverts Hv. applys~ red_new_array. rewrite~ <- HD.
      applys* tr_typdefctx_wf_typ. auto. } }
  { (* struct access *)
    inverts Ht as Ht. subst.
    inverts Ht as Ht.
    inverts Ht as Hπ.
    exists (val_abstract_ptr l (π' & access_field T f)) m1'.
    splits~.
    { constructors. applys~ tr_accesses_app. }
    { constructors~. } }
  { (* array access *)
    inverts Hok as HTain HCTa HTtnin Hnz Hfv.
    subst. inverts Ht as.
    { introv Hop Ht1' Ht2' Haop.
      inverts Haop as; try solve [ intros; simpls; false* ].
      { (* tiling array *)
        introv Hpr Htrp. inverts Hpr.
        inverts Ht1' as Htp.
        inverts Ht2' as Htv.
        inverts Htp as Hπ.
        inverts Htv.
        inverts Htrp.
        inverts_head make_tiling_tr'. simpls.
        remember (access_array (typ_var Ta0) ((i/K0)%Z)) as a1.
        remember (access_array (typ_var Tt0) ((i mod K0)%Z)) as a2.
        exists (val_abstract_ptr l (π'++(a1::a2::nil))) m1'.
        subst. splits~.
        { constructors~. applys~ tr_accesses_app. constructors~. }
        { constructors*.
          { applys red_args_2.
            { introv HN. inverts HN. }
            { applys~ red_binop. constructors~. math. }
            applys~ red_array_access. }
          { applys red_args_2.
            { introv HN. inverts HN. }
            { applys~ red_binop. constructors~. math. }
            applys~ red_array_access. fequals. rew_list~. } } }
      { (* other array *)
        introv Hneq Hpr.
        inverts Hpr. simpls.
        inverts Ht1' as Htp.
        inverts Ht2' as Htv.
        inverts Htp as Hπ.
        inverts Htv.
        exists (val_abstract_ptr l (π'++(access_array T1 i::nil))) m1'.
        splits~.
        { constructors~. applys~ tr_accesses_app. }
        { constructors~. } } }
    { (* absurd case *)
      introv HN. false. applys HN. unfolds~. } }
  { (* struct get *)
    inverts Ht as Ht. subst.
    inverts Ht as Hv.
    inverts Hv as HD Hsf.
    exists s'[f] m1'. splits~.
    constructors~. rewrite~ <- HD. }
  { (* array get *)
    inverts Hok as HTain HCTa HTtnin Hnz Hfv.
    subst. inverts Ht as.
    { (* array get *)
      introv Hop Ht1' Ht2' Haop.
      inverts Haop as; try solve [ intros; tryfalse* ].
      { (* tiling array *)
        introv Hpr Htrp.
        inverts Hpr. simpls.
        inverts Ht1' as Hva.
        inverts Ht2' as Hvi.
        inverts Hva as; try solve [ intros ; false* ].
        introv Htt Hnb Ha' Ha''.
        inverts Hvi. inverts Htt.
        forwards* (a''&Ha'i&Hla''): Ha' ((i/K0)%Z).
        { rewrite index_eq_index_length in *. eauto. }
        forwards* Htra: Ha'' i ((i/K0)%Z) ((i mod K0)%Z) a''.
        exists a''[(i mod K0)%Z] m1'. splits~.
        inverts Htrp as Htt. rewrite <- Hla'' in *.
        inverts Htt. constructors*.
        { applys red_args_2.
          { introv HN. inverts HN. }
          { applys~ red_binop. constructors~. math. }
          applys~ red_array_get.
          { rewrite index_eq_index_length. eauto. } }
        { applys red_args_2.
          { introv HN. inverts HN. }
          { applys~ red_binop. constructors~. math. }
          applys* red_array_get. } }
      { (* another array *)
        introv Hneq Hpr.
        inverts Hpr. simpls.
        inverts Ht1' as Hva.
        inverts Ht2' as Hvi.
        inverts Hvi.
        inverts Hva as.
        { introv Htt. inverts Htt. simpls. false~. }
        { introv _ Hla Htrai.
          exists a'[i] m1'. splits~.
          constructors~. } } }
    { (* absurd case *)
      introv HN. false. applys HN. unfolds~. } }
  { (* ll_get *)
    admit. }
  { (* ll_set *)
    admit. }
  { (* ll_new *)
    admit. }
  { (* ll_access *)
    admit. }
  { (* args 1 *)
    inverts Ht; inverts Hwft;
    forwards* (v'&m2'&Hv'&Hm2'&HR'): IHHR1;
    forwards*: not_is_error_args_1 HR2 He.
    { (* array op *)
      inverts_head tr_array_op;
      forwards* (v''&m3'&Hv''&Hm3'&HR''): IHHR2;
      try solve [ repeat constructors~; applys* wf_red HR1 ].
      { applys* tr_trm_array.
        applys* tr_array_op_tiling_access.
        asserts Htv: (t1' = trm_val v').
        { inverts_head tr_prim. inverts~ HR'. }
        subst_hyp Htv. eauto. }
      { exists v'' m3'; splits*.
        asserts Htv: (t1' = trm_val v').
        { inverts_head tr_prim. inverts~ HR'. }
        subst_hyp Htv. inverts~ HR'. }
      { applys* tr_trm_array.
        applys* tr_array_op_tiling_get.
        asserts Htv: (t1' = trm_val v').
        { inverts_head tr_prim. inverts~ HR'. }
        subst_hyp Htv. eauto. }
      { exists v'' m3'; splits*.
        asserts Htv: (t1' = trm_val v').
        { inverts_head tr_prim. inverts~ HR'. }
        subst_hyp Htv. inverts~ HR'. }
      { applys* tr_trm_array. applys*
        tr_array_op_other_access. }
      { exists v'' m3'; splits*. applys* red_args_1.
        applys* not_is_val_tr. }
      { applys* tr_trm_array.
        applys* tr_array_op_other_get. }
      { exists v'' m3'; splits*. applys* red_args_1.
        applys* not_is_val_tr. } }
    { (* ops with just one argument *)
      forwards* (v''&m3'&Hv''&Hm3'&HR''): IHHR2;
      try solve [ repeat constructors~; applys* wf_red HR1 ].
      exists v'' m3'; splits*. applys* red_args_1.
      applys* not_is_val_tr. }
    { (* ops with two arguments that are not array ops *)
      forwards* (v''&m3'&Hv''&Hm3'&HR''): IHHR2;
      try solve [ repeat constructors~; applys* wf_red HR1 ].
      exists v'' m3'; splits*. applys* red_args_1.
      applys* not_is_val_tr. } }
  { (* args 2 *)
    inverts Ht; inverts Hwft;
    forwards* (v'&m2'&Hv'&Hm2'&HR'): IHHR1;
    forwards*: not_is_error_args_2 HR2 He.
    { (* array op *)
      inverts_head tr_array_op;
      forwards* (v''&m3'&Hv''&Hm3'&HR''): IHHR2;
      try solve [ repeat constructors~; applys* wf_red HR1 ].
      { applys* tr_trm_array.
        applys* tr_array_op_tiling_access.
        asserts Htv: (t2' = trm_val v').
        { inverts_head tr_prim. inverts~ HR'. }
        subst_hyp Htv. eauto. }
      { exists v'' m3'; splits*.
        asserts Htv: (t2' = trm_val v').
        { inverts_head tr_prim. inverts~ HR'. }
        subst_hyp Htv. inverts~ HR'. }
      { applys* tr_trm_array.
        applys* tr_array_op_tiling_get.
        asserts Htv: (t2' = trm_val v').
        { inverts_head tr_prim. inverts~ HR'. }
        subst_hyp Htv. eauto. }
      { exists v'' m3'; splits*.
        asserts Htv: (t2' = trm_val v').
        { inverts_head tr_prim. inverts~ HR'. }
        subst_hyp Htv. inverts~ HR'. }
      { applys* tr_trm_array. applys*
        tr_array_op_other_access. }
      { exists v'' m3'; splits*. inverts H6. applys* red_args_2.
        applys* not_is_val_tr. }
      { applys* tr_trm_array.
        applys* tr_array_op_other_get. }
      { exists v'' m3'; splits*. inverts H6. applys* red_args_2.
        applys* not_is_val_tr. } }
    { (* not array op *)
      forwards* (v''&m3'&Hv''&Hm3'&HR''): IHHR2;
      try solve [ repeat constructors~; applys* wf_red HR1 ].
      exists v'' m3'; splits*. inverts H6. applys* red_args_2.
      applys* not_is_val_tr. } }
Qed.

(** From full execution. *)

Theorem red_tr: forall tt LLC C C' t t' v m2,
  red C LLC empty_stack empty_state t m2 v ->
  tiling_tr_ok tt C ->
  tr_typdefctx tt C C' ->
  tr_trm tt t t' ->
  wf_typdefctx C ->
  wf_trm C t ->
  ~ is_error v ->
  exists v' m2',
      tr_val tt v v'
  /\  tr_state tt m2 m2'
  /\  red C' LLC empty_stack empty_state t' m2' v'.
Proof using.
  introv HR Hok HC Ht HwfC Hwft Hne.
  asserts HS: (tr_stack tt empty_stack empty_stack).
  { constructors. applys~ Forall2_nil. }
  asserts Hm1: (tr_state tt empty_state empty_state).
  { constructors~. introv Hl. false. applys* indom_empty_inv. }
  asserts HwfS: (wf_stack C empty_stack).
  { unfolds~. introv HN. false. }
  asserts Hwfm1: (wf_state C empty_state).
  { unfolds~. introv HN. false. applys* indom_empty_inv. }
  forwards*: red_tr_ind HR Hok HC Ht HS.
Qed.

End TransformationProofs.


(* HoTT stuff required for categories *)
(* Borrowed from the other files over HoTT *)

Set Universe Polymorphism.
Set Nested Proofs Allowed.

Require Import Utf8.

Arguments id {_}.

Notation "'Σ' ( x : A ) , B" :=
  ({ x : A & B }) (at level 0, x at level 0, B at level 100, only parsing).
Notation "'Π' ( x : A ) , B" :=
  (∀ x : A, B) (at level 0, x at level 0, B at level 100, only parsing).

Definition homotopy {A B} (f g : A → B) := Π (x : A), (f x = g x).
Notation "f '∼' g" := (homotopy f g) (at level 70).

Definition composite {A B C} (f : A → B) (g : B → C) x := g (f x).
Notation "g '◦◦' f" := (composite f g) (at level 40, left associativity).

Definition isequiv {A B : Type} f :=
  ((Σ (g : B → A), (f ◦◦ g ∼ id)) * (Σ (h : B → A), (h ◦◦ f ∼ id)))%type.

Definition equivalence (A B : Type) := Σ (f : A → B), isequiv f.
Notation "A ≃ B" := (equivalence A B) (at level 70).

Definition ap {A B x y} (f : A → B) (p : x = y) : f x = f y :=
  match p with
  | eq_refl _ => eq_refl (f x)
  end.

Definition invert {A} {x y : A} (p : x = y) : y = x :=
  match p with
  | eq_refl _ => eq_refl x
  end.
Notation "p '⁻¹'" := (invert p)
  (at level 8, left associativity, format "'[v' p ']' ⁻¹").

Definition compose {A} {x y z : A} : x = y → y = z → x = z :=
  λ p,
  match p with
  | eq_refl _ => id
  end.
Notation "p • q" := (compose p q) (at level 40, left associativity).

Definition qinv {A B} (f : A → B) :=
  Σ (g : B → A), ((f ◦◦ g ∼ id) * (g ◦◦ f ∼ id))%type.

Definition isequiv_qinv {A B} (f : A → B) : isequiv f → qinv f :=
  λ p,
  match p with
  | (existT _ g Hg, existT _ h Hh) =>
      existT _ g (Hg, λ x, ((ap h (Hg (f x)))⁻¹ • Hh (g (f x)))⁻¹ • Hh x)
  end.

Theorem qinv_isequiv {A B} (f : A → B) : qinv f → isequiv f.
Proof.
intros p.
destruct p as (g, (α, β)).
split; exists g; assumption.
Defined.

Definition hott_2_1_4_i_1 {A} {x y : A} : ∀ (p : x = y),
    p = p • eq_refl y
 := (λ (p : x = y),
     match p return (p = p • eq_refl _) with
     | eq_refl _ => eq_refl (eq_refl x • eq_refl x)
     end).

Definition hott_2_1_4_i_2 {A} {x y : A} : ∀ (p : x = y),
    p = eq_refl x • p
 := (λ (p : x = y),
   match p return (p = eq_refl _ • p) with
   | eq_refl _ => eq_refl (eq_refl x • eq_refl x)
   end).

Definition ru {A} {a b : A} (p : a = b) : p = p • eq_refl b :=
  hott_2_1_4_i_1 p.

Definition dotl {A} {a b c : A} {r s : b = c}
  (q : a = b) (β : r = s) : (q • r = q • s).
Proof.
destruct q.
pose proof (@hott_2_1_4_i_2 A a c r) as H2.
apply invert in H2.
eapply compose; [ apply H2 | idtac ].
pose proof (@hott_2_1_4_i_2 A a c s) as H4.
eapply compose; [ apply β | apply H4 ].
Defined.

Definition dotr {A} {a b c : A} {p q : a = b}
  (r : b = c) (α : p = q) : (p • r = q • r).
Proof.
destruct r.
pose proof (@hott_2_1_4_i_1 A a b p) as H1.
apply invert in H1.
eapply compose; [ apply H1 | idtac ].
pose proof (@hott_2_1_4_i_1 A a b q) as H3.
eapply compose; [ apply α | apply H3 ].
Defined.

Lemma compose_invert_l {A} {x y : A} : ∀ (p : x = y), p⁻¹ • p = eq_refl y.
Proof.
intros p; destruct p; reflexivity.
Qed.

Definition compose_invert_r {A} {x y : A} : ∀ (p : x = y), p • p⁻¹ = eq_refl x
  := λ p, match p with eq_refl _ => eq_refl (eq_refl x) end.

Lemma compose_assoc {A} {x y z w : A} :
  ∀ (p : x = y) (q : y = z) (r : z = w),
  p • (q • r) = (p • q) • r.
Proof.
intros p q r; destruct p; reflexivity.
Qed.

Definition hott_2_4_3 {A B x y} (f g : A → B) (H : f ∼ g) (p : x = y)
  : H x • ap g p = ap f p • H y
  := match p with
     | eq_refl _ =>
         match
           match H x as q return (q = q • eq_refl _) with
           | eq_refl _ => eq_refl (eq_refl (f x) • eq_refl (f x))
           end
         with
         | eq_refl _ => eq_refl (id (H x))
         end
     end.

Definition ap_composite {A B C x y}
  : ∀ (f : A → B) (g : B → C) (p : x = y),
    ap g (ap f p) = ap (g ◦◦ f) p
  := λ f g p,
     match p with eq_refl _ => eq_refl (ap g (ap f (eq_refl x))) end.

Definition hott_2_2_2_iv A (x y : A) : ∀ (p : x = y), ap id p = p
  := λ p, match p with eq_refl _ => eq_refl (eq_refl x) end.

Definition isContr A := {a : A & ∀ x : A, a = x }.

Definition transport {A} P {x y : A} (p : x = y) : P x → P y :=
  match p with
  | eq_refl _ => λ x, x
  end.

Definition happly {A B} (f g : Π (x : A), B x)
  : f = g → Π (x : A), f x = g x
  := λ p,
     match p with
     | eq_refl _ => λ y, eq_refl (f y)
     end.

Definition Σ_pr₁ {A B} (x : { y : A & B y }) : A :=
  match x with existT _ a _ => a end.
Definition Σ_pr₂ {A B} (x : { y : A & B y }) : B (Σ_pr₁ x) :=
  match x with existT _ _ b => b end.

Definition pr₁ {A B} := @Σ_pr₁ A B.
Definition pr₂ {A B} := @Σ_pr₂ A B.

Definition isequiv_transport {A B} : ∀ (p : A = B),
  isequiv (transport id p).
Proof.
intros p; destruct p; simpl.
split; exists id; intros x; apply eq_refl.
Defined.

Definition idtoeqv {A B : Type} : A = B → A ≃ B :=
  λ p,
  existT isequiv (transport id p) (isequiv_transport p).

Axiom univ : ∀ A B : Type, isequiv (@idtoeqv A B).

Definition ua {A B} : A ≃ B → A = B :=
  match isequiv_qinv idtoeqv (univ A B) with
  | existT _ f _ => f
  end.

Theorem idtoeqv_ua {A B} : ∀ (f : A ≃ B), idtoeqv (ua f) = f.
Proof.
intros.
unfold ua; simpl.
set (q := isequiv_qinv idtoeqv (univ A B)).
destruct q as (g, (α, β)).
apply α.
Defined.

Tactic Notation "transparent" "assert" "(" ident(H) ":" lconstr(type) ")" :=
  unshelve (refine (let H := (_ : type) in _)).

Definition fib {A B} (f : A → B) (y : B) := Σ (x : A), (f x = y).

Theorem equiv_compose {A B C} :
  ∀ (f : equivalence A B) (g : equivalence B C), equivalence A C.
Proof.
intros eqf eqg.
destruct eqf as (f, ((f₁, eqf₁), (f₂, eqf₂))).
destruct eqg as (g, ((g₁, eqg₁), (g₂, eqg₂))).
unfold equivalence.
exists (composite f g).
split.
 exists (composite g₁ f₁).
 intros c; unfold composite; simpl.
 transitivity (g (g₁ c)); [ apply ap, eqf₁ | apply eqg₁ ].

 exists (composite g₂ f₂).
 intros a; unfold composite; simpl.
 transitivity (f₂ (f a)); [ apply ap, eqg₂ | apply eqf₂ ].
Defined.

Theorem hott_4_8_1 A (B : A → Type) (a : A) :
  fib (Σ_pr₁ (B := B)) a ≃ B a.
Proof.
transparent assert (f : fib (Σ_pr₁ (B := B)) a → B a).
 intros p; unfold fib in p.
 destruct p as ((x, p), q), q; apply p.

 exists f; unfold f; clear f; simpl.
 apply qinv_isequiv.
 transparent assert (f : B a → fib (Σ_pr₁ (B := B)) a).
  intros p; unfold fib.
  exists (existT _ a p); apply eq_refl.

  exists f; unfold f; clear f; simpl.
  unfold "∼", id.
  split; [ easy | ].
  intros ((x, p), q); simpl in q.
  destruct q; apply eq_refl.
Defined.

Theorem hott_4_9_2 A B X (e : A ≃ B) : (X → A) ≃ (X → B).
Proof.
unfold "≃".
exists (λ h x, projT1 e (h x)).
apply qinv_isequiv.
exists (λ h x, projT1 (isequiv_qinv _ (projT2 e)) (h x)).
unfold "◦◦", "∼", id; cbn.
split.
-intros f.
 rewrite <- (idtoeqv_ua e).
 destruct (ua e); cbn.
 now unfold id.
-intros f.
 rewrite <- (idtoeqv_ua e).
 now destruct (ua e); cbn.
Defined.

Notation "p '⁎'" := (transport _ p)
  (at level 8, left associativity, only parsing).
(*
Notation "p '⁎'" := (transport _ p)
  (at level 8, left associativity, format "'[v' p ']' ⁎", only parsing).
*)

Definition Σ_type_pair_eq {A} {P : A → Type} {x y : A} {u : P x} {v : P y} :
  Π (p : x = y), p⁎ u = v → existT _ x u = existT _ y v
:=
  λ p q,
  match p with
  | eq_refl _ =>
      λ (w : P x) (r : transport P (eq_refl x) u = w),
      match r in (_ = t) return (existT P x u = existT P x t) with
      | eq_refl _ => eq_refl (existT P x (transport P (eq_refl x) u))
      end
  end v q.

Theorem pre_hott_4_9_3 A (P : A → Type) (p : Π (x : A), isContr (P x)) :
  (Σ (x : A), P x) ≃ A.
Proof.
exists (λ x, projT1 x).
apply qinv_isequiv; unfold qinv.
exists (λ x, existT _ x (projT1 (p x))).
unfold "◦◦", "∼", id; cbn.
split; [ easy | ].
intros (x, Hx); cbn.
apply eq_existT_uncurried.
exists eq_refl; cbn.
destruct (p x) as (Hx', H); apply H.
Defined.

Theorem hott_4_9_3 A (P : A → Type) (p : Π (x : A), isContr (P x)) :
  (A → Σ (x : A), P x) ≃ (A → A).
Proof.
apply hott_4_9_2.
now apply pre_hott_4_9_3.
Defined.

Definition ishae {A B} f :=
  Σ (g : B → A), Σ (η : g ◦◦ f ∼ id), Σ (ε : f ◦◦ g ∼ id),
    Π (x : A), ap f (η x) = ε (f x).

Definition fib_intro {A B} {f : A → B} {y} x (p : f x = y) :=
  (existT (λ z, f z = y) x p : fib f y).

Lemma hott_2_7_2_f {A} : ∀ P (w w' : Σ (x : A), P x),
  w = w' → Σ (p : pr₁ w = pr₁ w'), p⁎ (pr₂ w) = pr₂ w'.
Proof.
intros P w w' p.
destruct p; simpl.
exists (eq_refl _); apply eq_refl.
Defined.

Lemma hott_2_7_2_g {A} : ∀ P (w w' : Σ (x : A), P x),
  (Σ (p : pr₁ w = pr₁ w'), p⁎ (pr₂ w) = pr₂ w') → w = w'.
Proof.
intros P w w' p.
destruct w as (w₁, w₂).
destruct w' as (w'₁, w'₂); simpl.
simpl in p.
destruct p as (p, q).
destruct p, q; apply eq_refl.
Defined.

Theorem hott_2_7_2 {A} : ∀ (P : A → Type) (w w' : Σ (x : A), P x),
  (w = w') ≃ Σ (p : pr₁ w = pr₁ w'), p⁎ (pr₂ w) = pr₂ w'.
Proof.
intros.
exists (hott_2_7_2_f P w w').
apply qinv_isequiv.
exists (hott_2_7_2_g P w w'); split.
 intros r; unfold id; simpl.
 destruct r as (p, q).
 destruct w as (a, b).
 destruct w' as (a', b').
 simpl in p, q; simpl.
 destruct p, q; simpl.
 unfold hott_2_7_2_f; simpl.
 unfold hott_2_7_2_g; simpl.
 unfold "◦◦"; simpl.
 apply eq_refl.

 intros r; unfold id; simpl.
 destruct r.
 destruct w as (a, b); simpl.
 unfold hott_2_7_2_f; simpl.
 unfold hott_2_7_2_g; simpl.
 unfold "◦◦"; simpl.
 apply eq_refl.
Defined.

Lemma hott_2_1_4_iii A (x y : A) : ∀ (p : x = y), (p⁻¹)⁻¹ = p.
Proof.
intros p; destruct p; reflexivity.
Qed.

Definition Σ_equiv {A} {P Q : A → Type} :
  P ∼ Q → {x : A & P x} ≃ {x : A & Q x}.
Proof.
intros p.
exists
  (λ (q : Σ (x : A), P x),
   existT Q (Σ_pr₁ q)
     match p (Σ_pr₁ q) in (_ = y) return y with
     | eq_refl _ => Σ_pr₂ q
     end).
apply qinv_isequiv.
exists
  (λ (q : Σ (x : A), Q x),
   existT P (Σ_pr₁ q)
     (match p (Σ_pr₁ q) in (_ = y) return y → P (Σ_pr₁ q) with
      | eq_refl _ => id
      end (Σ_pr₂ q))).
unfold "◦◦", "∼", id; simpl.
split; intros (x, q); simpl.
 apply (Σ_type_pair_eq (eq_refl _)).
 simpl; unfold id.
 destruct (p x); apply eq_refl.

 apply (Σ_type_pair_eq (eq_refl _)).
 simpl; unfold id.
 destruct (p x); apply eq_refl.
Defined.

Theorem hott_4_2_5 A B (f : A → B) y x x' (p p' : f _ = y) :
  (fib_intro x p = fib_intro x' p')
  ≃ (Σ (γ : x = x'), ap f γ • p' = p).
Proof.
eapply equiv_compose; [ apply hott_2_7_2 | simpl ].
apply Σ_equiv; intros q.
unfold transport.
destruct q; simpl; unfold id.
apply ua.
exists invert.
apply qinv_isequiv.
exists invert.
unfold "◦◦", "∼", id.
split; intros z; apply hott_2_1_4_iii.
Defined.

Theorem ap_compose {A B} : ∀ (f : A → B) x y z (p : x = y) (q : y = z),
  ap f (p • q) = ap f p • ap f q.
Proof. destruct p, q; constructor. Qed.

Definition hott_4_2_6 A B (f : A → B) : ishae f → ∀ y, isContr (fib f y).
Proof.
intros p y.
destruct p as (g, (η, (ε, q))).
exists (fib_intro (g y) (ε y)).
intros (x, p).
apply (Σ_pr₁ (fst (Σ_pr₂ (hott_4_2_5 A B f y (g y) x (ε y) p)))).
exists (ap g p⁻¹ • η x).
rewrite ap_compose.
destruct p; simpl; unfold id.
eapply compose; [ eapply invert, ru | apply q ].
Defined.

Definition hott_2_4_4 {A x} (f : A → A) (H : f ∼ id) : H (f x) = ap f (H x).
Proof.
intros.
assert (ap f (H x) • H x = H (f x) • H x) as p.
 eapply invert, compose; [ idtac | apply hott_2_4_3 ].
 apply dotl, invert, hott_2_2_2_iv.

 apply dotr with (r := (H x) ⁻¹) in p.
 eapply compose in p; [ idtac | apply compose_assoc ].
 eapply compose in p.
  unfold id in p; simpl in p.
  eapply compose in p; [ idtac | apply hott_2_1_4_i_1 ].
  eapply invert, compose in p; [ idtac | apply compose_assoc ].
  eapply compose in p.
   eapply compose in p; [ eassumption | apply hott_2_1_4_i_1 ].

   eapply dotl, invert.
   eapply compose_invert_r; reflexivity.

  eapply dotl, invert.
  eapply compose_invert_r; reflexivity.
Qed.

Definition alt_τ A B (f : A → B) (g : B → A)
    (ε : f ◦◦ g ∼ id) (η : g ◦◦ f ∼ id)
    (ε' := ((λ b, (ε (f (g b)))⁻¹ • ap f (η (g b)) • ε b) : f ◦◦ g ∼ id)) :
  ∀ a, ap f (η a) = ε' (f a).
Proof.
intros a; simpl in ε'.
assert (p' : η (g (f a)) = ap g (ap f (η a))).
 rewrite (ap_composite f g (η a)).
 apply (hott_2_4_4 (g ◦◦ f) η).

 apply (ap (ap f)) in p'.
 apply (dotr (ε (f a))) in p'.
 pose proof (hott_2_4_3 (f ◦◦ g ◦◦ f) f (λ x, ε (f x)) (η a)) as q.
 unfold id in q; simpl in q; apply invert in q.
 eapply compose in q; [  | eapply compose; [ eapply p' |  ] ].
  unfold ε'.
  rewrite <- compose_assoc.
  unfold id, composite in q; simpl.
  unfold id, composite; simpl.
  rewrite q, compose_assoc, compose_invert_l.
  apply invert, hott_2_1_4_i_2.

  apply dotr.
  eapply compose; [ apply (ap_composite g f (ap f (η a))) |  ].
  apply (ap_composite f (f ◦◦ g) (η a)).
Defined.

Definition hott_4_2_3 A B (f : A → B) : qinv f → ishae f.
Proof.
intros (g, (ε, η)).
unfold ishae.
exists g, η.
pose proof alt_τ A B f g ε η as τ.
set (ε' := (λ b, (ε (f (g b)))⁻¹ • ap f (η (g b)) • ε b) : f ◦◦ g ∼ id) in τ.
simpl in τ.
exists ε'; intros x; apply τ.
Defined.

Definition retraction A B :=
  Σ (r : A → B), Σ (s : B → A), Π (y : B), (r (s y) = y).

Definition hott_3_11_7 A B (r : retraction A B) : isContr A → isContr B.
Proof.
intros p.
destruct r as (r, (s, q)).
destruct p as (a₀, p).
exists (r a₀); intros b₀.
eapply compose; [ | apply (q b₀) ].
apply ap, p.
Defined.

Theorem weak_funext : ∀ {A} (P : A → Type),
  (Π (x : A), isContr (P x)) → isContr (Π (x : A), P x).
Proof.
intros * Hf.
set (H1 := hott_4_8_1 A P).
transparent assert (f : (A → {x : A & P x}) → (A → A)). {
  intros f x.
  apply (projT1 (f x)).
}
clear f.
set (α := hott_4_9_3 A P Hf).
transparent assert (φ : (Π (x : A), P x) → fib (projT1 α) id). {
  intros h.
  exists (λ x, existT _ x (h x)).
  unfold α.
  unfold hott_4_9_3.
  now unfold hott_4_9_2; cbn.
}
transparent assert (ψ : fib (projT1 α) id → (Π (x : A), P x)). {
  intros (g', p) x.
  apply ((happly _ _ p x) ⁎ (pr₂ (g' x))).
}
assert (Hsr : ψ ◦◦ φ = id) by easy.
assert (H : retraction (fib (projT1 α) id) (Π (x : A), P x)). {
  unfold retraction.
  exists ψ, φ.
  intros z.
  replace z with (id z) by easy.
  now rewrite <- Hsr.
}
eapply hott_3_11_7; [ apply H | ].
apply hott_4_2_6.
apply hott_4_2_3.
apply (isequiv_qinv _ (projT2 α)).
Qed.

(* to be completed
Check @weak_funext.
Print Assumptions weak_funext.

Theorem funext {A B} :∀ f g : ∀ (x : A), B x,
  (∀ x : A, f x = g x) → f = g.
Proof.
intros  * Hfg.
Check @weak_funext.
apply weak_funext.
intros h.
unfold isContr.
...
*)


Require Import Coq.Lists.List.
Require Import ExtLib.Data.HList.
Require Import ExtLib.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Set Strict Implicit.

Section hlist_build_option.
  Context {T : Type} (F : T -> Type).
  Context {U : Type}.
  Variable (f : forall x : T, U -> option (F x)).

  Fixpoint hlist_build_option (ls : list T) (ls' : list U)
  : option (hlist F ls) :=
    match ls as ls , ls' return option (hlist F ls) with
    | nil , nil => Some Hnil
    | l :: ls , l' :: ls' =>
      match hlist_build_option ls ls' with
      | None => None
      | Some res =>
        match f l l' with
        | None => None
        | Some x =>
          Some (Hcons x res)
        end
      end
    | _ , _ => None
    end.

  Lemma hlist_build_option_app_if
    : forall a b c d e f,
      length a = length c ->
      hlist_build_option (a ++ b) (c ++ d) = Some (hlist_app e f) ->
      hlist_build_option a c = Some e /\
      hlist_build_option b d = Some f.
  Proof.
    clear.
    induction a; simpl; intros.
    { intuition; destruct c; simpl in *; try congruence.
      rewrite (hlist_eta e). reflexivity.
      rewrite (hlist_eta e) in H0. simpl in H0. assumption. }
    { destruct c; simpl in *; try congruence.
      inversion H; clear H; subst.
      forward. inv_all.
      rewrite (hlist_eta e) in *.
      simpl in *.
      inv_all. subst.
      eapply IHa in H; auto.
      destruct H. rewrite H. eauto. }
  Qed.

  Lemma hlist_build_option_app_only_if
  : forall a b c d e f,
      hlist_build_option a c = Some e ->
      hlist_build_option b d = Some f ->
      hlist_build_option (a ++ b) (c ++ d) = Some (hlist_app e f).
  Proof.
    induction a; simpl; intros; forward.
    { rewrite (hlist_eta e). simpl. auto. }
    { inv_all; subst.
      simpl. eapply IHa in H0; eauto. rewrite H0. rewrite H2. reflexivity. }
  Qed.
End hlist_build_option.


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

(* A set with elements in U, is defined by its belonging relation,      *)
(* the equality is defined by the extensionality axiom.                 *)

(* The following notions are defined :                                  *)
(*      - U_set :  set with elements in U,                              *)
(*      - U_set_eq : 2 sets with same elements are equals,              *)
(*      - Empty :  set with no elements,                                *)
(*              no constructors                                         *)
(*      - Full :  set with all the elements,                            *)
(*              constructor : In_full                                   *)
(*      - Single : set with a unique element {x},                       *)
(*              constructor : In_single                                 *)
(*      - Included : like imply,                                        *)
(*      - Union : binary operation like or,                             *)
(*              constructors : In_left, In_right.                       *)
(*      - Inter : binary operation like and,                            *)
(*              constructors : In_inter.                                *)

Require Export Omega.
Require Export Peano_dec.

Section U_SETS.

Variable U : Set.

Definition U_set := U -> Prop.

Axiom U_set_eq : forall E F : U_set, (forall x : U, E x <-> F x) -> E = F.

Lemma U_eq_set : forall E F : U_set, E = F -> forall x : U, E x -> F x.
Proof.
        intros; rewrite <- H; trivial.
Qed.

Lemma U_set_eq_commut : forall E F : U_set, E = F -> F = E.
Proof.
        auto.
Qed.

Lemma U_set_diff_commut : forall E F : U_set, E <> F -> F <> E.
Proof.
        intros; red in |- *; intros.
        elim H; apply U_set_eq_commut; trivial.
Qed.

Inductive Empty : U_set :=.

Inductive Full : U_set :=
    In_full : forall x : U, Full x.

Inductive Single (x : U) : U_set :=
    In_single : Single x x.

Lemma Single_equal : forall x y : U, Single x y -> x = y.
Proof.
        intros; inversion H; trivial.
Qed.

Lemma Single_equal_single : forall x y : U, Single x = Single y -> x = y.
Proof.
        intros; generalize (U_eq_set _ _ H x).
        intros; elim H0.
        trivial.

        apply In_single.
Qed.

Lemma Empty_nothing : forall x : U, ~ Empty x.
Proof.
        tauto.
Qed.

Lemma U_set_diff : forall E F : U_set, (exists x : U, E x /\ ~ F x) -> E <> F.
Proof.
        intros; red in |- *; intros.
        elim H; intros.
        elim H1; intros.
        elim H3; rewrite <- H0; auto.
Qed.

        Section INCLUSION.

Definition Included (E F : U_set) : Prop := forall x : U, E x -> F x.

Lemma Included_single :
 forall (E : U_set) (x : U), E x -> Included (Single x) E.
Proof.
        unfold Included in |- *; intros.
        inversion H0; rewrite <- H1; trivial.
Qed.

        End INCLUSION.

        Section UNION.

Inductive Union (E F : U_set) : U_set :=
  | In_left : forall x : U, E x -> Union E F x
  | In_right : forall x : U, F x -> Union E F x.

Lemma Union_eq :
 forall E F E' F' : U_set, E = E' -> F = F' -> Union E F = Union E' F'.
Proof.
        intros; elim H.
        elim H0; trivial.
Qed.

Lemma Union_neutral : forall e : U_set, Union Empty e = e.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H.
        inversion H0.

        trivial.

        apply In_right; trivial.
Qed.

Lemma Union_commut : forall e1 e2 : U_set, Union e1 e2 = Union e2 e1.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H; [ apply In_right | apply In_left ]; trivial.

        inversion H; [ apply In_right | apply In_left ]; trivial.
Qed.

Lemma Union_assoc :
 forall e1 e2 e3 : U_set, Union (Union e1 e2) e3 = Union e1 (Union e2 e3).
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H.
        inversion H0.
        apply In_left; trivial.

        apply In_right; apply In_left; trivial.

        apply In_right; apply In_right; trivial.

        inversion H.
        apply In_left; apply In_left; trivial.

        inversion H0.
        apply In_left; apply In_right; trivial.

        apply In_right; trivial.
Qed.

Lemma Not_union :
 forall (E1 E2 : U_set) (x : U), ~ E1 x -> ~ E2 x -> ~ Union E1 E2 x.
Proof.
        intros; red in |- *; intros.
        inversion H1.
        elim H; trivial.

        elim H0; trivial.
Qed.

Lemma Union_dec :
 forall (e1 e2 : U_set) (x : U),
 {e1 x} + {~ e1 x} -> {e2 x} + {~ e2 x} -> Union e1 e2 x -> {e1 x} + {e2 x}.
Proof.
        intros; case H.
        left; trivial.

        intros; case H0; intros.
        right; trivial.

        absurd (Union e1 e2 x).
        apply Not_union; trivial.

        trivial.
Qed.

Lemma Included_union : forall E F : U_set, Included E (Union E F).
Proof.
        unfold Included in |- *; intros.
        apply In_left; trivial.
Qed.

Lemma Union_absorb : forall E F : U_set, Included E F -> Union E F = F.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H0; auto.

        apply In_right; trivial.
Qed.

        End UNION.

        Section INTERSECTION.

Inductive Inter (E F : U_set) : U_set :=
    In_inter : forall x : U, E x -> F x -> Inter E F x.

Lemma Inter_eq :
 forall E F E' F' : U_set, E = E' -> F = F' -> Inter E F = Inter E' F'.
Proof.
        intros; elim H.
        elim H0; trivial.
Qed.

Lemma Inter_neutral : forall e : U_set, Inter Full e = e.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H; trivial.

        apply In_inter.
        apply In_full; trivial.

        trivial.
Qed.

Lemma Inter_empty : forall e : U_set, Inter e Empty = Empty.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H; trivial.

        inversion H.
Qed.

Lemma Inter_commut : forall e1 e2 : U_set, Inter e1 e2 = Inter e2 e1.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H; apply In_inter; trivial.

        inversion H; apply In_inter; trivial.
Qed.

Lemma Inter_assoc :
 forall e1 e2 e3 : U_set, Inter (Inter e1 e2) e3 = Inter e1 (Inter e2 e3).
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H; inversion H0.
        apply In_inter; trivial.
        apply In_inter; trivial.

        inversion H; inversion H1.
        apply In_inter; trivial.
        apply In_inter; trivial.
Qed.

Lemma Not_inter : forall (E1 E2 : U_set) (x : U), ~ E1 x -> ~ Inter E1 E2 x.
Proof.
        intros; red in |- *; intros.
        inversion H0.
        elim H; trivial.
Qed.

Lemma Included_inter : forall E F : U_set, Included (Inter E F) E.
Proof.
        unfold Included in |- *; intros.
        inversion H; trivial.
Qed.

Lemma Inter_absorb : forall E F : U_set, Included E F -> Inter E F = E.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H0; auto.

        apply In_inter; auto.
Qed.

        End INTERSECTION.

        Section DIFFERENCE.

Inductive Differ (E F : U_set) : U_set :=
    In_differ : forall x : U, E x -> ~ F x -> Differ E F x.

Lemma Differ_E_E : forall E : U_set, Differ E E = Empty.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H.
        absurd (E x); trivial.

        inversion H.
Qed.

Lemma Differ_empty : forall E : U_set, Differ E Empty = E.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H; trivial.

        apply In_differ.
        trivial.

        tauto.
Qed.

Lemma Union_differ_inter :
 forall E F : U_set,
 (forall x : U, {F x} + {~ F x}) -> Union (Differ E F) (Inter E F) = E.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H0.
        inversion H1; trivial.

        inversion H1; trivial.

        case (H x); intros.
        apply In_right; apply In_inter; trivial.

        apply In_left; apply In_differ; trivial.
Qed.

        End DIFFERENCE.

        Section MIXED_PROPERTIES.

Lemma Distributivity_inter_union :
 forall E F G : U_set, Inter E (Union F G) = Union (Inter E F) (Inter E G).
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H; inversion H1.
        apply In_left; apply In_inter; auto.

        apply In_right; apply In_inter; auto.

        inversion H; inversion H0.
        apply In_inter.
        trivial.

        apply In_left; trivial.

        apply In_inter.
        trivial.

        apply In_right; trivial.
Qed.

Lemma Distributivity_union_inter :
 forall E F G : U_set, Union E (Inter F G) = Inter (Union E F) (Union E G).
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H.
        apply In_inter; apply In_left; trivial.

        inversion H0; apply In_inter; apply In_right; trivial.

        inversion H.
        inversion H0.
        apply In_left; trivial.

        inversion H1.
        apply In_left; trivial.

        apply In_right; apply In_inter; trivial.
Qed.

Lemma Union_inversion :
 forall E F G : U_set,
 Inter E F = Empty -> Inter E G = Empty -> Union E F = Union E G -> F = G.
Proof.
        intros; apply U_set_eq; split; intros.
        generalize (In_right E F x H2).
        rewrite H1; intros.
        inversion H3.
        absurd (Inter E F x).
        rewrite H; tauto.

        apply In_inter; auto.

        trivial.

        generalize (In_right E G x H2).
        rewrite <- H1; intros.
        inversion H3.
        absurd (Inter E G x).
        rewrite H0; tauto.

        apply In_inter; auto.

        trivial.
Qed.

Lemma Union_inversion2 :
 forall E F G H : U_set,
 Inter E F = Empty ->
 Inter E G = Empty ->
 Inter G H = Empty -> Union E F = Union G H -> F = Union G (Inter F H).
Proof.
        intros; apply U_set_eq; split; intros.
        generalize (In_right E F x H4).
        rewrite H3; intros.
        inversion H5.
        apply In_left; trivial.

        apply In_right; apply In_inter; trivial.

        inversion H4.
        generalize (In_left G H x H5).
        rewrite <- H3; intros.
        inversion H7.
        absurd (Inter E G x).
        rewrite H1; tauto.

        apply In_inter; trivial.

        trivial.

        inversion H5; trivial.
Qed.

Lemma Single_disjoint :
 forall (x : U) (E : U_set), ~ E x -> Inter (Single x) E = Empty.
Proof.
        intros; apply U_set_eq; split; intros.
        inversion H0.
        inversion H1; absurd (E x).
        trivial.

        rewrite H4; trivial.

        inversion H0.
Qed.

Lemma Single_single_disjoint :
 forall x y : U, x <> y -> Inter (Single x) (Single y) = Empty.
Proof.
        intros; apply Single_disjoint.
        red in |- *; intros H0; elim H; inversion H0; trivial.
Qed.

Lemma Union_single_single :
 forall (e : U_set) (x y : U),
 x <> y ->
 ~ e y -> Union (Single x) (Single y) = Union (Single y) e -> e = Single x.
Proof.
        intros; symmetry  in |- *; apply (Union_inversion (Single y)).
        apply Single_single_disjoint; auto.

        apply Single_disjoint; trivial.

        rewrite Union_commut; trivial.
Qed.

        End MIXED_PROPERTIES.

End U_SETS.