From Coq Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import ssrnat eqtype seq path fintype tuple finfun finset.
From pcm Require Import options axioms prelude pred.
From pcm Require Import pcm unionmap heap.
From htt Require Import options model heapauto.

Definition indx {I : finType} (x : I) := index x (enum I).

Prenex Implicits indx.

(***********************************)
(* Arrays indexed by a finite type *)
(***********************************)

(* an array is a pointer to a contiguous memory region holding its values *)

Record array (I : finType) (T : Type) : Type := Array {orig :> ptr}.
Arguments Array [I T].

Definition array_for (I : finType) (T : Type) of phant (I -> T) := array I T.
Identity Coercion array_for_array : array_for >-> array.
Notation "{ 'array' aT }" := (array_for (Phant aT))
  (at level 0, format "{ 'array'  '[hv' aT ']' }") : type_scope.

Module Array.
Section Array.
Variable (I : finType) (T : Type).
Notation array := {array I -> T}.

(* an array is specified by a finite function *)

Definition shape (a : array) (f : {ffun I -> T}) :=
  [Pred h | h = updi a (fgraph f) /\ valid h].

(*
(* helper lemmas *)

Lemma enum_split k :
        enum I = take (indx k) (enum I) ++ k :: drop (indx k).+1 (enum I).
Proof.
case: path.splitP; first by rewrite mem_enum.
by move=>p1 p2; rewrite -cats1 -catA.
Qed.

Lemma updi_split (a : array) k (f : {ffun I -> T}) :
        updi a (fgraph f) = updi a (take (indx k) (fgraph f)) \+
                            a.+(indx k) :-> f k \+
                            updi (a.+(indx k).+1) (drop (indx k).+1 (fgraph f)).
Proof.
rewrite fgraph_codom /= codomE {1}(enum_split k) map_cat updi_cat /=.
rewrite map_take map_drop size_takel ?joinA ?ptrA ?addn1 //.
by rewrite size_map index_size.
Qed.

Lemma takeord k x (f : {ffun I -> T}) :
        take (indx k) (fgraph [ffun y => [eta f with k |-> x] y]) =
        take (indx k) (fgraph f).
Proof.
set f' := (finfun _).
suff E: {in take (indx k) (enum I), f =1 f'}.
- by rewrite !fgraph_codom /= !codomE -2!map_take; move/eq_in_map: E.
move: (enum_uniq I); rewrite {1}(enum_split k) cat_uniq /= =>H4.
move=>y H5; rewrite /f' /= !ffunE /=; case: eqP H5 H4=>// -> ->.
by rewrite andbF.
Qed.

Lemma dropord k x (f : {ffun I -> T}) :
        drop (indx k).+1 (fgraph [ffun y => [eta f with k |->x] y]) =
        drop (indx k).+1 (fgraph f).
Proof.
set f' := (finfun _).
suff E: {in drop (indx k).+1 (enum I), f =1 f'}.
- by rewrite !fgraph_codom /= !codomE -2!map_drop; move/eq_in_map: E.
move: (enum_uniq I); rewrite {1}(enum_split k) cat_uniq /= => H4.
move=>y H5; rewrite /f' /= !ffunE /=; case: eqP H5 H4=>// -> ->.
by rewrite !andbF.
Qed.
*)
(* main methods *)

(* a new empty array preallocates all cells for all possible index values *)
(* initializing all of them to `x` *)

Program Definition new (x : T) :
  STsep (emp, [vfun a => shape a [ffun => x]]) :=
  Do (x <-- allocb x #|I|;
      ret (Array x)).
Next Obligation.
(* pull out ghost vars, run the program *)
move=>x [] _ /= ->; step=>y; step.
(* simplify *)
rewrite unitR=>H; split=>//; congr updi; rewrite codomE cardE.
by elim: (enum I)=>[|t ts] //= ->; rewrite (ffunE _ _).
Qed.

Opaque new.

(* a new array corresponding to a domain of a finite function f *)

(* the loop invariant: *)
(* a partially filled array corresponds to some finite function g acting as a prefix of f *)
Definition fill_loop a (f : {ffun I -> T}) : Type :=
  forall s : seq I, STsep (fun i => exists g s',
                                      [/\ i \In shape a g,
                                          s' ++ s = enum I &
                                          forall x, x \in s' -> g x = f x],
                           [vfun a => shape a f]).

Program Definition newf (f : {ffun I -> T}) :
  STsep (emp, [vfun a => shape a f]) :=
  (* `return` helps to avoid extra obligations *)
  (* test I for emptiness *)
  Do (if [pick x in I] is Some v return _ then
        (* preallocate a new array *)
        x <-- new (f v);
        (* fill it with values of f on I *)
        let fill := Fix (fun (loop : fill_loop x f) s =>
                      Do (if s is k::t return _ then
                             x .+ (indx k) ::= f k;;
                             loop t
                          else ret (Array x)))
        in fill (enum I)
      else ret (Array null)).
(* first the loop *)
Next Obligation.
(* pull out preconditions (note that there are no ghost vars), split *)
move=>f v x loop s [] /= _ [g][s'][[-> _]]; case: s=>[|k t] /= H1 H2.
- (* we've reached the end, return the array *)
  rewrite cats0 in H1; step=>H; split=>//.
  (* g spans the whole f *)
  by rewrite (_ : g = f) // -ffunP=>y; apply: H2; rewrite H1 mem_enum.
(* run the loop iteration, split the heap and save its validity *)
rewrite (updi_split x k); step; apply: vrfV=>V; apply: [gE]=>//=.
(* add the new index+value to g *)
exists (finfun [eta g with k |-> f k]), (s' ++ [:: k]).
(* massage the heap, simplify *)
rewrite /shape (updi_split x k) takeord dropord (ffunE _ _) /= eq_refl -catA.
split=>// y; rewrite ffunE /= mem_cat inE /=.
(* the new g is still a prefix of f *)
by case: eqP=>[->|_] //; rewrite orbF; apply: H2.
Qed.
(* now the outer program *)
Next Obligation.
(* pull out params, check if I is empty *)
move=>f [] _ ->; case: fintype.pickP=>[v|] H /=.
- (* run the `new` subroutine, simplify *)
  apply: [stepE]=>//= a _ [-> V].
  (* invoke the loop, construct g from the first value of f *)
  by apply: [gE]=>//=; exists [ffun => f v], nil.
(* I is empty, so should be the resulting heap *)
step=>_; split=>//; rewrite codom_ffun.
suff L: #|I| = 0 by case: (fgraph f)=>/=; rewrite L; case.
by rewrite cardE; case: (enum I)=>[|x s] //; move: (H x).
Qed.

(* freeing an array by deallocating all of its cells *)

(* the loop invariant: *)
(* a partially freed array still contains valid #|I| - k cells *)
(* corresponding to some suffix xs of the original array's spec *)
Definition free_loop (a : array) : Type :=
  forall k, STsep (fun i => exists xs: seq T,
                            [/\ i = updi (a .+ k) xs,
                                valid i &
                                size xs + k = #|I|],
                   [vfun _ : unit => emp]).

Program Definition free (a : array) :
  STsep (fun i => exists f, i \In shape a f,
         [vfun _ : unit => emp]) :=
  Do (let go := Fix (fun (loop : free_loop a) k =>
                     Do (if k == #|I| then ret tt
                         else dealloc a.+k;;
                              loop k.+1))
      in go 0).
(* first the loop *)
Next Obligation.
(* pull out params, if the remaining suffix xs is empty, we're done *)
move=>a loop k [] i /= [[|v xs]][->] /= _; first by rewrite add0n=>/eqP ->; step.
(* the suffix is non-empty so k < #|I| *)
case: eqP=>[->|_ H]; first by move/eqP; rewrite -{2}(add0n #|I|) eqn_add2r.
(* run the program, simplify *)
step; apply: vrfV=>V; apply: [gE]=>//=.
by exists xs; rewrite V ptrA addn1 -addSnnS unitL.
Qed.
(* now the outer program *)
Next Obligation.
(* pull out params, invoke the loop *)
move=>a [] /= _ [f][-> V]; apply: [gE]=>//=.
(* the suffix xs is the whole codomain of f *)
exists (tval (fgraph f))=>/=.
by rewrite ptr0 V {3}codomE size_map -cardE addn0.
Qed.

(* reading from an array, doesn't modify the heap *)

Program Definition read (a : array) (k : I) :
   {f h}, STsep (fun i => i = h /\ i \In shape a f,
                 [vfun (y : T) m => m = h /\ y = f k]) :=
  Do (!a .+ (indx k)).
Next Obligation.
(* pull out ghost vars *)
move=>a k [f][_][] _ [->][/= -> _].
(* split the heap and run the program *)
by rewrite (updi_split a k); step.
Qed.

(* writing to an array, updates the spec function with a new value *)

Program Definition write (a : array) (k : I) (x : T) :
  {f}, STsep (shape a f,
              [vfun _ : unit => shape a (finfun [eta f with k |-> x])]) :=
  Do (a .+ (indx k) ::= x).
Next Obligation.
(* pull out ghost vars, split the heap *)
move=>a k x [f][] _ [-> _] /=; rewrite /shape !(updi_split a k).
(* run the program, simplify *)
by step; rewrite takeord dropord ffunE /= eq_refl.
Qed.

End Array.
End Array.

(* Tabulating a finite function over another one *)
(* Useful in building linked data structures that are pointed to by *)
(* array elements, such as hashtables *)

Section Table.

Variables (I : finType) (T S : Type) (x : {array I -> T})
          (Ps : T -> S -> Pred heap).

Definition table (t : I -> T) (b : I -> S) (i : I) : Pred heap :=
  Ps (t i) (b i).

Lemma tableP (s : {set I}) t1 t2 b1 b2 h :
        (forall x, x \in s -> t1 x = t2 x) ->
        (forall x, x \in s -> b1 x = b2 x) ->
        h \In sepit s (table t1 b1) -> h \In sepit s (table t2 b2).
Proof.
move=>H1 H2 H.
apply/(sepitF (f1 := table t1 b1))=>//.
by move=>y R; rewrite /table (H1 _ R) (H2 _ R).
Qed.

Lemma tableP2 (s1 s2 : {set I}) t1 t2 b1 b2 h :
        s1 =i s2 ->
        (forall x, s1 =i s2 -> x \in s1 -> t1 x = t2 x) ->
        (forall x, s1 =i s2 -> x \in s1 -> b1 x = b2 x) ->
        h \In sepit s1 (table t1 b1) -> h \In sepit s2 (table t2 b2).
Proof.
move=>H1 H2 H3; rewrite (eq_sepit _ H1).
by apply: tableP=>y; rewrite -H1=>R; [apply: H2 | apply: H3].
Qed.

End Table.

Prenex Implicits table.


Require Import Coq.Arith.Compare_dec.

Require Import
        Essentials.Facts_Tactics
        Essentials.Notations
        Essentials.Types
        Essentials.Omega.
Require Import Metrics.Mappings Metrics.Cauchy.
Require Import Metrics.Complete_UltraMetric.
Require Import
        Categories.Category.Main
        Categories.Functor.Main
        Categories.Archetypal.Discr.Discr
        Categories.Archetypal.PreOrder_Cat.OmegaCat
        Categories.KanExt.Local
        Categories.KanExt.LocalFacts.Uniqueness
        Categories.Limits.Limit
        Categories.Basic_Cons.Terminal
.
Require Import MCat.MCat.

Require Import MCat.MCat MCat.Opposite MCat.Product MCat.MFunc
        MCat.IncreasingCauchyTower.IncreasingCauchyTower
        MCat.IncreasingCauchyTower.Related_CoCone_Cone_Limit
        MCat.IncreasingCauchyTower.Cone_Limit_Related_CoCone
        MCat.IncreasingCauchyTower.Ops_and_Props.

Local Open Scope order_scope.
Local Open Scope metric_scope.
Local Open Scope lattice_scope.

(** We show that any locally-contractive functor F : Mᵒᵖ × M –≻ M where
M is an M-category has a fixed point (an object A such that F(A, A) ≃ A).
*)
Section Existence.
  Context {L : MLattice}
          {M : MCat L}
          (limits_of_ICT : ∀ ICT : IncreasingCauchyTower M, Limit (ICT_Func ICT))
          (F : LocallyContractive (MCat_Prod (MCat_Op M) M) M)
          (MTerm : Terminal M)
          (starting_point :
             (
               (terminal MTerm)
                 –≻
                 (F _o (terminal MTerm, terminal MTerm))%object
             )%morphism
          )
  .

  Fixpoint ICT_of_Locally_Contractive_Func_obj (n : nat) : M :=
    match n with
      | O => terminal MTerm
      | S n' =>
        (F _o
          (
            ICT_of_Locally_Contractive_Func_obj n',
            ICT_of_Locally_Contractive_Func_obj n'
          ))%object
    end.

  Fixpoint ICT_of_Locally_Contractive_Func_gs (n : nat) :
    ((ICT_of_Locally_Contractive_Func_obj (S n))
      –≻
      (ICT_of_Locally_Contractive_Func_obj n))%morphism
    :=
    match n with
      | O => t_morph MTerm _
      | S n' =>
        F @_a
          (_, _)
          (_, _)
          (
            ICT_of_Locally_Contractive_Func_fs n',
            ICT_of_Locally_Contractive_Func_gs n'
          )
    end
  with
  ICT_of_Locally_Contractive_Func_fs (n : nat) :
    ((ICT_of_Locally_Contractive_Func_obj n)
      –≻
      (ICT_of_Locally_Contractive_Func_obj (S n)))%morphism
    :=
    match n with
      | O => starting_point
      | S n' =>
        F @_a
          (_, _)
          (_, _)
          (
            ICT_of_Locally_Contractive_Func_gs n',
            ICT_of_Locally_Contractive_Func_fs n'
          )
    end
  .

  (** We show that given a locally contractive functor F : Mᵒᵖ × M –≻ M, we can build an
increasing cauchy tower:
#
<pre>

     f₀                 F(g₀, f₀)
   <————               ———–——————>                    <.......
A₀       A₁ = F(A₀,A₀)              A₂ = F(A₁,A₁)     .......
   ————>               —————————–>                    .......>
    g₀                  F(f₀, g₀)
</pre>
#
where f₀ = 1 is the terminal object of M and g₀ is the starting point
(a morphims from 1 to F (1,1) ).
*)
  Program Definition ICT_of_Locally_Contractive_Func :
    IncreasingCauchyTower M :=
    {|
      ICT_Objs := ICT_of_Locally_Contractive_Func_obj;
      ICT_fs := ICT_of_Locally_Contractive_Func_fs;
      ICT_gs := ICT_of_Locally_Contractive_Func_gs
    |}.

  Next Obligation.
  Proof.
    induction n; cbn.
    apply (t_morph_unique MTerm).
    cbn_rewrite <- (@F_compose _ _ F); cbn.
    rewrite IHn.
    apply (@F_id _ _ F).
  Qed.

  Next Obligation.
  Proof.
    destruct (CR_rate_indicator (LCN_ContrRate _ _ F) ε (existT _ _ (ML_appr_top L))) as [N H2].
    exists N.
    intros n H3.
    cbn in *.
    eapply LE_LT_Trans; [|apply H2].
    clear H2.
    induction H3.
    {
      induction N.
      + cbn; trivial.
      + cbn.
        cbn_rewrite <- (@F_compose _ _ F); cbn.
        cbn_rewrite <- (@F_id _ _ F); cbn.
        eapply PO_Trans; [eapply (CCN_contractive (@LCN_FA _ _ _ F _ _))|]; cbn.
        apply (CR_monotone (LCN_ContrRate _ _ F)).
        apply lub_lst; intros []; trivial.
    }
    {
      cbn.
      cbn_rewrite <- (@F_compose _ _ F); cbn.
      cbn_rewrite <- (@F_id _ _ F); cbn.
      eapply PO_Trans; [eapply (CCN_contractive (@LCN_FA _ _ _ F _ _))|]; cbn.
      eapply PO_Trans; [|apply (CR_non_expansive (LCN_ContrRate _ _ F))].
      apply (CR_monotone (LCN_ContrRate _ _ F)).
      apply lub_lst; intros []; trivial.
    }
  Qed.

  (** The limit of the cauchy tower of a contractive functor is its fixed point. *)
  Definition FixedPoint_as_limit := limits_of_ICT ICT_of_Locally_Contractive_Func.

  (** The limit of the cauchy tower of a contractive functor is its fixed point. *)
  Definition FixedPoint : M := limits_of_ICT ICT_of_Locally_Contractive_Func.

  (** We show that the limit of the cauchy tower of a contractive functor is indeed
the fixed point of F. *)
  Definition FixedPoint_is_fixed_point :
    (F _o (FixedPoint, FixedPoint) ≃ FixedPoint)%isomorphism
  .
  Proof.
    match goal with
      [|- (?A ≃ _)%isomorphism ] =>
      change A with
      (
        (is_Limit_Limit
           _
           (is_Limit_Cone_To_Locally_Contractive_Func_ICT_is_Limit
              _
              F
              _
              (Cone_Limit_Related_CoCone
                 _
                 _
                 (limits_of_ICT ICT_of_Locally_Contractive_Func)
                 (@Limit_is_Limit
                    _
                    _
                    _
                    (limits_of_ICT ICT_of_Locally_Contractive_Func)
                 )
              )
           )
        ) : M
      )
    end.
    match goal with
      [|- (_ ≃ ?A)%isomorphism ] =>
      change A with
      (
        (is_Limit_Limit
           _
           (is_Limit_Cone_To_ICT_Shift_One_is_Limit
              _
              (limits_of_ICT ICT_of_Locally_Contractive_Func)
              (Cone_Limit_Related_CoCone
                 _
                 _
                 (limits_of_ICT ICT_of_Locally_Contractive_Func)
                 (@Limit_is_Limit
                    _
                    _
                    _
                    (limits_of_ICT ICT_of_Locally_Contractive_Func)
                 )
              )
           )
          ) : M
      )
    end.
    apply LoKan_Cone_Iso_object_Iso.
    apply Local_Right_KanExt_unique.
  Defined.

End Existence.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q A B C Aprime Cprime : Universe, ((wd_ P Q /\ (wd_ P Aprime /\ (wd_ P Cprime /\ (wd_ A Aprime /\ (wd_ B Cprime /\ (wd_ C Cprime /\ (wd_ A B /\ (wd_ C B /\ (wd_ A C /\ (wd_ Aprime Cprime /\ (wd_ C P /\ (wd_ B P /\ (wd_ A P /\ (col_ P Q Aprime /\ (col_ P Q Cprime /\ (col_ A B C /\ (col_ B C Cprime /\ col_ A C Cprime))))))))))))))))) -> col_ P Aprime Cprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C X1 X2 X3 D E F : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A E /\ (wd_ A F /\ (wd_ B D /\ (wd_ B F /\ (wd_ C D /\ (wd_ C E /\ (wd_ A X3 /\ (wd_ B X2 /\ (wd_ C X1 /\ (col_ D B X2 /\ (col_ D C X1 /\ (col_ E A X3 /\ (col_ E C X1 /\ (col_ F A X3 /\ col_ F B X2))))))))))))))))) -> col_ B D F)).
Proof.
  time tac.
Qed.

End FOFProblem.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C D E F P Q DD FF X CC : Universe, ((wd_ A B /\ (wd_ D E /\ (wd_ E F /\ (wd_ B Q /\ (wd_ E P /\ (wd_ B C /\ (wd_ A C /\ (wd_ D F /\ (wd_ E FF /\ (wd_ E DD /\ (wd_ CC B /\ (wd_ E X /\ (col_ DD E FF /\ (col_ DD X FF /\ (col_ B C CC /\ (col_ E X P /\ (col_ E F FF /\ col_ E D DD))))))))))))))))) -> col_ D E F)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Base.
Require Import Monad.
Import Monad.Instances.
Require Import FlowEquivalence.
Import FE_Tactics.

Require Import List.
Import ListNotations.
Open Scope list_scope.

Set Implicit Arguments.

Section Flops.

  (* Trying to avoid master/slave terminology *)
  Inductive master_latch (flop : Set) : Set :=
  | Master : flop -> master_latch flop.
  Inductive clone_latch (flop : Set) : Set :=
  | Clone : flop -> clone_latch flop.
  Definition from_master {flop} (f : master_latch flop) : flop :=
    match f with
    | Master f' => f'
    end.
  Definition from_clone {flop} (f : clone_latch flop) : flop :=
    match f with
    | Clone f' => f'
    end.

  Record FF_circuit (flop : Set) :=
    { ff_neighbors : list (flop * flop)
    ; ff_next_state : forall (f : flop),
      state {fpred : flop & In (fpred,f) ff_neighbors} -> value
    }.
  Definition restrict_state {flop : Set} {P : flop -> Prop}
                       (s : state flop) : state {f : flop & P f} :=
    fun f => s (projT1 f).

  Section FF_to_latch.

    Variable flop : Set.
    Variable c : FF_circuit flop.
    Variable flop_bank : list flop.

    Hypothesis all_flop_bank : forall f, In f flop_bank.

    Let master_clone_neighbor (f : flop) := (Master f,Clone f).
    Let clone_master_neighbor (fs : flop * flop) := (Clone (fst fs), Master (snd fs)).

    Let master_clone_neighbors := fmap master_clone_neighbor flop_bank.
    Let clone_master_neighbors := fmap clone_master_neighbor (ff_neighbors c).

    Program Let convert_state f :
        state {fpred : clone_latch flop & In (fpred,f) clone_master_neighbors } ->
        state {fpred : flop & In (fpred, from_master f) (ff_neighbors c)} :=
      fun st fpred' => st (existT _ (Clone (projT1 fpred')) _).
    Next Obligation.
      simpl.
      unfold clone_master_neighbors.
      destruct f as [f].
      replace (Clone fpred', Master f) with (clone_master_neighbor (fpred',f)).
      2:{ unfold clone_master_neighbor. simpl. reflexivity. }
      apply in_map.
      auto.
    Defined.

    Let next_state_master (f : master_latch flop)
             (st : state { f0 : clone_latch flop & In (f0,f) clone_master_neighbors })
            : value :=
      ff_next_state c (from_master f) (convert_state f st).

    Program Let next_state_clone (f : clone_latch flop)
            (st : state {f0 : master_latch flop & In (f0,f) master_clone_neighbors })
            : value :=
      st (existT _ (Master (from_clone f)) _).
    Next Obligation.
      unfold master_clone_neighbors.
      destruct f.
      simpl.
      replace (Master f,Clone f) with (master_clone_neighbor f)
        by reflexivity.
      apply in_map.
      auto.
    Defined.

    Definition FF_to_latch_circuit : circuit (master_latch flop) (clone_latch flop) :=
      {| even_odd_neighbors := master_clone_neighbors
      ;  odd_even_neighbors := clone_master_neighbors
      ;  next_state_e := next_state_master
      ;  next_state_o := next_state_clone
      |}.
  End FF_to_latch.

End Flops.


Require Import core_config.
Require Import env_desc.
Require Import Omega.

(*
Here's an example of a core configuration given with
explicit proof terms (all [I]: the properties are just True).
*)

(*
(* Here are examples of accessing field names and values *)
Compute io_file_buffer_size.name. (* module name dot property name *)
Compute io_file_buffer_size.value a_core_config.(io_file_buffer_size).
(* module dot property to get value function, applied to structure dot field name *)
(* A little confusing: io_file_buffer_size is both module and field name *)
Compute io_compression_codecs.value a_core_config.(io_compression_codecs).
*)

(*
It's also possible to use interactive proof mode
to construct the proofs interactively. The idea is to
"refine" a configuration with "holes" where the proofs
belong, then to use additional tactics to provide the
required proofs. Here all three proofs are just "I" (the
trivial proof of True), and so its easy to provide them
all at once using Coq's [;] tactical.
*)
Definition a_core_config: CoreConfig. (* page size env parameter *)
Proof.
 refine (
    mk_core_config
    (io_file_buffer_size.mk            false 65536%positive _)
    (io_map_index_interval.mk     false 128%positive _)
    (io_map_index_skip.mk         false 0%N _)
    (io_seqfile_compress_blocksize.mk  false 1000000%positive _)
    (io_seqfile_sorter_recordlimit.mk  false 1000000%positive _)
    (ipc_maximum_data_length.mk        false 67108864%positive _)
); try (exact I); try compute; auto.
Qed.


(**
This file is part of the Flocq formalization of floating-point
arithmetic in Coq: http://flocq.gforge.inria.fr/

Copyright (C) 2009-2018 Sylvie Boldo
#<br />#
Copyright (C) 2009-2018 Guillaume Melquiond

This library 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 3 of the License, or (at your option) any later version.

This library 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
COPYING file for more details.
*)

(** * Floating-point format without underflow *)
Require Import Raux Defs Round_pred Generic_fmt Float_prop.
Require Import FIX Ulp Round_NE.
Require Import Psatz.

Section RND_FLX.

Variable beta : radix.

Notation bpow e := (bpow beta e).

Variable prec : Z.

Class Prec_gt_0 :=
  prec_gt_0 : (0 < prec)%Z.

Context { prec_gt_0_ : Prec_gt_0 }.

Inductive FLX_format (x : R) : Prop :=
  FLX_spec (f : float beta) :
    x = F2R f -> (Z.abs (Fnum f) < Zpower beta prec)%Z -> FLX_format x.

Definition FLX_exp (e : Z) := (e - prec)%Z.

(** Properties of the FLX format *)

Global Instance FLX_exp_valid : Valid_exp FLX_exp.
Proof.
intros k.
unfold FLX_exp.
generalize prec_gt_0.
repeat split ; intros ; lia.
Qed.

Theorem FIX_format_FLX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FLX_format x ->
  FIX_format beta (e - prec) x.
Proof.
clear prec_gt_0_.
intros x e Hx [[xm xe] H1 H2].
rewrite H1, (F2R_prec_normalize beta xm xe e prec).
now eexists.
exact H2.
now rewrite <- H1.
Qed.

Theorem FLX_format_generic :
  forall x, generic_format beta FLX_exp x -> FLX_format x.
Proof.
intros x H.
rewrite H.
eexists ; repeat split.
simpl.
apply lt_IZR.
rewrite abs_IZR.
rewrite <- scaled_mantissa_generic with (1 := H).
rewrite <- scaled_mantissa_abs.
apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp (Rabs x))).
apply bpow_gt_0.
rewrite scaled_mantissa_mult_bpow.
rewrite IZR_Zpower, <- bpow_plus.
2: now apply Zlt_le_weak.
unfold cexp, FLX_exp.
ring_simplify (prec + (mag beta (Rabs x) - prec))%Z.
rewrite mag_abs.
destruct (Req_dec x 0) as [Hx|Hx].
rewrite Hx, Rabs_R0.
apply bpow_gt_0.
destruct (mag beta x) as (ex, Ex).
now apply Ex.
Qed.

Theorem generic_format_FLX :
  forall x, FLX_format x -> generic_format beta FLX_exp x.
Proof.
clear prec_gt_0_.
intros x [[mx ex] H1 H2].
simpl in H2.
rewrite H1.
apply generic_format_F2R.
intros Zmx.
unfold cexp, FLX_exp.
rewrite mag_F2R with (1 := Zmx).
apply Zplus_le_reg_r with (prec - ex)%Z.
ring_simplify.
now apply mag_le_Zpower.
Qed.

Theorem FLX_format_satisfies_any :
  satisfies_any FLX_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
intros x.
split.
apply FLX_format_generic.
apply generic_format_FLX.
Qed.

Theorem FLX_format_FIX :
  forall x e,
  (bpow (e - 1) <= Rabs x <= bpow e)%R ->
  FIX_format beta (e - prec) x ->
  FLX_format x.
Proof with auto with typeclass_instances.
intros x e Hx Fx.
apply FLX_format_generic.
apply generic_format_FIX in Fx.
revert Fx.
apply generic_inclusion with (e := e)...
apply Z.le_refl.
Qed.

(** unbounded floating-point format with normal mantissas *)
Inductive FLXN_format (x : R) : Prop :=
  FLXN_spec (f : float beta) :
    x = F2R f ->
    (x <> 0%R -> Zpower beta (prec - 1) <= Z.abs (Fnum f) < Zpower beta prec)%Z ->
    FLXN_format x.

Theorem generic_format_FLXN :
  forall x, FLXN_format x -> generic_format beta FLX_exp x.
Proof.
intros x [[xm ex] H1 H2].
destruct (Req_dec x 0) as [Zx|Zx].
rewrite Zx.
apply generic_format_0.
specialize (H2 Zx).
apply generic_format_FLX.
rewrite H1.
eexists ; repeat split.
apply H2.
Qed.

Theorem FLXN_format_generic :
  forall x, generic_format beta FLX_exp x -> FLXN_format x.
Proof.
intros x Hx.
rewrite Hx.
simpl.
eexists. easy.
rewrite <- Hx.
intros Zx.
simpl.
split.
(* *)
apply le_IZR.
rewrite IZR_Zpower.
2: now apply Zlt_0_le_0_pred.
rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_le_reg_r with (bpow (cexp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- cexp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold cexp, FLX_exp.
rewrite mag_abs.
ring_simplify (prec - 1 + (mag beta x - prec))%Z.
destruct (mag beta x) as (ex,Ex).
now apply Ex.
(* *)
apply lt_IZR.
rewrite IZR_Zpower.
2: now apply Zlt_le_weak.
rewrite abs_IZR, <- scaled_mantissa_generic with (1 := Hx).
apply Rmult_lt_reg_r with (bpow (cexp beta FLX_exp x)).
apply bpow_gt_0.
rewrite <- bpow_plus.
rewrite <- scaled_mantissa_abs.
rewrite <- cexp_abs.
rewrite scaled_mantissa_mult_bpow.
unfold cexp, FLX_exp.
rewrite mag_abs.
ring_simplify (prec + (mag beta x - prec))%Z.
destruct (mag beta x) as (ex,Ex).
now apply Ex.
Qed.

Theorem FLXN_format_satisfies_any :
  satisfies_any FLXN_format.
Proof.
refine (satisfies_any_eq _ _ _ (generic_format_satisfies_any beta FLX_exp)).
split ; intros H.
now apply FLXN_format_generic.
now apply generic_format_FLXN.
Qed.

Lemma negligible_exp_FLX :
   negligible_exp FLX_exp = None.
Proof.
case (negligible_exp_spec FLX_exp).
intros _; reflexivity.
intros n H2; contradict H2.
unfold FLX_exp; unfold Prec_gt_0 in prec_gt_0_; lia.
Qed.

Theorem generic_format_FLX_1 :
  generic_format beta FLX_exp 1.
Proof.
unfold generic_format, scaled_mantissa, cexp, F2R; simpl.
rewrite Rmult_1_l, (mag_unique beta 1 1).
{ unfold FLX_exp.
  rewrite <- IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; lia].
  rewrite Ztrunc_IZR, IZR_Zpower; [|unfold Prec_gt_0 in prec_gt_0_; lia].
  rewrite <- bpow_plus.
  now replace (_ + _)%Z with Z0 by ring. }
rewrite Rabs_R1; simpl; split; [now right|].
unfold Z.pow_pos; simpl; rewrite Zmult_1_r; apply IZR_lt.
assert (H := Zle_bool_imp_le _ _ (radix_prop beta)); lia.
Qed.

Theorem ulp_FLX_0: (ulp beta FLX_exp 0 = 0)%R.
Proof.
unfold ulp; rewrite Req_bool_true; trivial.
rewrite negligible_exp_FLX; easy.
Qed.

Lemma ulp_FLX_1 : ulp beta FLX_exp 1 = bpow (-prec + 1).
Proof.
unfold ulp, FLX_exp, cexp; rewrite Req_bool_false; [|apply R1_neq_R0].
rewrite mag_1; f_equal; ring.
Qed.

Lemma succ_FLX_1 : (succ beta FLX_exp 1 = 1 + bpow (-prec + 1))%R.
Proof.
now unfold succ; rewrite Rle_bool_true; [|apply Rle_0_1]; rewrite ulp_FLX_1.
Qed.

Theorem eq_0_round_0_FLX :
   forall rnd {Vr: Valid_rnd rnd} x,
     round beta FLX_exp rnd x = 0%R -> x = 0%R.
Proof.
intros rnd Hr x.
apply eq_0_round_0_negligible_exp; try assumption.
apply FLX_exp_valid.
apply negligible_exp_FLX.
Qed.

Theorem gt_0_round_gt_0_FLX :
   forall rnd {Vr: Valid_rnd rnd} x,
     (0 < x)%R -> (0 < round beta FLX_exp rnd x)%R.
Proof with auto with typeclass_instances.
intros rnd Hr x Hx.
assert (K: (0 <= round beta FLX_exp rnd x)%R).
rewrite <- (round_0 beta FLX_exp rnd).
apply round_le... now apply Rlt_le.
destruct K; try easy.
absurd (x = 0)%R.
now apply Rgt_not_eq.
apply eq_0_round_0_FLX with rnd...
Qed.

Theorem ulp_FLX_le :
  forall x, (ulp beta FLX_exp x <= Rabs x * bpow (1-prec))%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLX_0, Rabs_R0.
right; ring.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLX_exp.
replace (mag beta x - prec)%Z with ((mag beta x - 1) + (1-prec))%Z by ring.
rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
now apply bpow_mag_le.
Qed.

Theorem ulp_FLX_ge :
  forall x, (Rabs x * bpow (-prec) <= ulp beta FLX_exp x)%R.
Proof.
intros x; case (Req_dec x 0); intros Hx.
rewrite Hx, ulp_FLX_0, Rabs_R0.
right; ring.
rewrite ulp_neq_0; try exact Hx.
unfold cexp, FLX_exp.
unfold Zminus; rewrite bpow_plus.
apply Rmult_le_compat_r.
apply bpow_ge_0.
left; now apply bpow_mag_gt.
Qed.

Lemma ulp_FLX_exact_shift :
  forall x e,
  (ulp beta FLX_exp (x * bpow e) = ulp beta FLX_exp x * bpow e)%R.
Proof.
intros x e.
destruct (Req_dec x 0) as [Hx|Hx].
{ unfold ulp.
  now rewrite !Req_bool_true, negligible_exp_FLX; rewrite ?Hx, ?Rmult_0_l. }
unfold ulp; rewrite Req_bool_false;
  [|now intro H; apply Hx, (Rmult_eq_reg_r (bpow e));
    [rewrite Rmult_0_l|apply Rgt_not_eq, Rlt_gt, bpow_gt_0]].
rewrite (Req_bool_false _ _ Hx), <- bpow_plus; f_equal; unfold cexp, FLX_exp.
now rewrite mag_mult_bpow; [ring|].
Qed.

Lemma succ_FLX_exact_shift :
  forall x e,
  (succ beta FLX_exp (x * bpow e) = succ beta FLX_exp x * bpow e)%R.
Proof.
intros x e.
destruct (Rle_or_lt 0 x) as [Px|Nx].
{ rewrite succ_eq_pos; [|now apply Rmult_le_pos, bpow_ge_0].
  rewrite (succ_eq_pos _ _ _ Px).
  now rewrite Rmult_plus_distr_r; f_equal; apply ulp_FLX_exact_shift. }
unfold succ.
rewrite Rle_bool_false; [|assert (H := bpow_gt_0 beta e); nra].
rewrite Rle_bool_false; [|now simpl].
rewrite Ropp_mult_distr_l_reverse, <-Ropp_mult_distr_l_reverse; f_equal.
unfold pred_pos.
rewrite mag_mult_bpow; [|lra].
replace (_ - 1)%Z with (mag beta (- x) - 1 + e)%Z; [|ring]; rewrite bpow_plus.
unfold Req_bool; rewrite Rcompare_mult_r; [|now apply bpow_gt_0].
fold (Req_bool (-x) (bpow (mag beta (-x) - 1))); case Req_bool.
{ unfold FLX_exp.
  replace (_ - _)%Z with (mag beta (- x) - 1 - prec + e)%Z; [|ring].
  rewrite bpow_plus; ring. }
rewrite ulp_FLX_exact_shift; ring.
Qed.

(** FLX is a nice format: it has a monotone exponent... *)
Global Instance FLX_exp_monotone : Monotone_exp FLX_exp.
Proof.
intros ex ey Hxy.
now apply Zplus_le_compat_r.
Qed.

(** and it allows a rounding to nearest, ties to even. *)
Hypothesis NE_prop : Z.even beta = false \/ (1 < prec)%Z.

Global Instance exists_NE_FLX : Exists_NE beta FLX_exp.
Proof.
destruct NE_prop as [H|H].
now left.
right.
unfold FLX_exp.
split ; lia.
Qed.

End RND_FLX.


(*
 * Copyright © 2013 http://io7m.com
 *
 * Permission to use, copy, modify, and/or distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)
(** A file size in bytes. *)
Definition t := nat.


Require Import Equivalence EquivDec.
Require Import Coqlib.

(* To avoid useless definitions of inductors in extracted code. *)
Local Unset Elimination Schemes.
Local Unset Case Analysis Schemes.

Set Implicit Arguments.

(** * The abstract signatures of trees *)

Module Type TREE.
  Parameter elt: Type.
  Parameter elt_eq: forall (a b: elt), {a = b} + {a <> b}.
  Parameter t: Type -> Type.
  Parameter empty: forall (A: Type), t A.
  Parameter get: forall (A: Type), elt -> t A -> option A.
  Parameter set: forall (A: Type), elt -> A -> t A -> t A.
  Parameter remove: forall (A: Type), elt -> t A -> t A.

  (** The ``good variables'' properties for trees, expressing
    commutations between [get], [set] and [remove]. *)
  Axiom gempty:
    forall (A: Type) (i: elt), get i (empty A) = None.
  Axiom gss:
    forall (A: Type) (i: elt) (x: A) (m: t A), get i (set i x m) = Some x.
  Axiom gso:
    forall (A: Type) (i j: elt) (x: A) (m: t A),
    i <> j -> get i (set j x m) = get i m.
  Axiom gsspec:
    forall (A: Type) (i j: elt) (x: A) (m: t A),
    get i (set j x m) = if elt_eq i j then Some x else get i m.
  (* We could implement the following, but it's not needed for the moment.
  Hypothesis gsident:
    forall (A: Type) (i: elt) (m: t A) (v: A),
    get i m = Some v -> set i v m = m.
  Hypothesis grident:
    forall (A: Type) (i: elt) (m: t A) (v: A),
    get i m = None -> remove i m = m.
  *)
  Axiom grs:
    forall (A: Type) (i: elt) (m: t A), get i (remove i m) = None.
  Axiom gro:
    forall (A: Type) (i j: elt) (m: t A),
    i <> j -> get i (remove j m) = get i m.
  Axiom grspec:
    forall (A: Type) (i j: elt) (m: t A),
    get i (remove j m) = if elt_eq i j then None else get i m.

  (** Extensional equality between trees. *)
  Parameter beq: forall (A: Type), (A -> A -> bool) -> t A -> t A -> bool.
  Axiom beq_correct:
    forall (A: Type) (eqA: A -> A -> bool) (t1 t2: t A),
    beq eqA t1 t2 = true <->
    (forall (x: elt),
     match get x t1, get x t2 with
     | None, None => True
     | Some y1, Some y2 => eqA y1 y2 = true
     | _, _ => False
    end).

  (** Applying a function to all data of a tree. *)
  Parameter map:
    forall (A B: Type), (elt -> A -> B) -> t A -> t B.
  Axiom gmap:
    forall (A B: Type) (f: elt -> A -> B) (i: elt) (m: t A),
    get i (map f m) = option_map (f i) (get i m).

  (** Same as [map], but the function does not receive the [elt] argument. *)
  Parameter map1:
    forall (A B: Type), (A -> B) -> t A -> t B.
  Axiom gmap1:
    forall (A B: Type) (f: A -> B) (i: elt) (m: t A),
    get i (map1 f m) = option_map f (get i m).

  (** Applying a function pairwise to all data of two trees. *)
  Parameter combine:
    forall (A B C: Type), (option A -> option B -> option C) -> t A -> t B -> t C.
  Axiom gcombine:
    forall (A B C: Type) (f: option A -> option B -> option C),
    f None None = None ->
    forall (m1: t A) (m2: t B) (i: elt),
    get i (combine f m1 m2) = f (get i m1) (get i m2).

  (** Enumerating the bindings of a tree. *)
  Parameter elements:
    forall (A: Type), t A -> list (elt * A).
  Axiom elements_correct:
    forall (A: Type) (m: t A) (i: elt) (v: A),
    get i m = Some v -> In (i, v) (elements m).
  Axiom elements_complete:
    forall (A: Type) (m: t A) (i: elt) (v: A),
    In (i, v) (elements m) -> get i m = Some v.
  Axiom elements_keys_norepet:
    forall (A: Type) (m: t A),
    list_norepet (List.map (@fst elt A) (elements m)).
  Axiom elements_extensional:
    forall (A: Type) (m n: t A),
    (forall i, get i m = get i n) ->
    elements m = elements n.
  Axiom elements_remove:
    forall (A: Type) i v (m: t A),
    get i m = Some v ->
    exists l1 l2, elements m = l1 ++ (i,v) :: l2 /\ elements (remove i m) = l1 ++ l2.

  (** Folding a function over all bindings of a tree. *)
  Parameter fold:
    forall (A B: Type), (B -> elt -> A -> B) -> t A -> B -> B.
  Axiom fold_spec:
    forall (A B: Type) (f: B -> elt -> A -> B) (v: B) (m: t A),
    fold f m v =
    List.fold_left (fun a p => f a (fst p) (snd p)) (elements m) v.
  (** Same as [fold], but the function does not receive the [elt] argument. *)
  Parameter fold1:
    forall (A B: Type), (B -> A -> B) -> t A -> B -> B.
  Axiom fold1_spec:
    forall (A B: Type) (f: B -> A -> B) (v: B) (m: t A),
    fold1 f m v =
    List.fold_left (fun a p => f a (snd p)) (elements m) v.
End TREE.

(** * The abstract signatures of maps *)

Module Type MAP.
  Parameter elt: Type.
  Parameter elt_eq: forall (a b: elt), {a = b} + {a <> b}.
  Parameter t: Type -> Type.
  Parameter init: forall (A: Type), A -> t A.
  Parameter get: forall (A: Type), elt -> t A -> A.
  Parameter set: forall (A: Type), elt -> A -> t A -> t A.
  Axiom gi:
    forall (A: Type) (i: elt) (x: A), get i (init x) = x.
  Axiom gss:
    forall (A: Type) (i: elt) (x: A) (m: t A), get i (set i x m) = x.
  Axiom gso:
    forall (A: Type) (i j: elt) (x: A) (m: t A),
    i <> j -> get i (set j x m) = get i m.
  Axiom gsspec:
    forall (A: Type) (i j: elt) (x: A) (m: t A),
    get i (set j x m) = if elt_eq i j then x else get i m.
  Axiom gsident:
    forall (A: Type) (i j: elt) (m: t A), get j (set i (get i m) m) = get j m.
  Parameter map: forall (A B: Type), (A -> B) -> t A -> t B.
  Axiom gmap:
    forall (A B: Type) (f: A -> B) (i: elt) (m: t A),
    get i (map f m) = f(get i m).
End MAP.

(** * An implementation of maps over any type with decidable equality *)

Module Type EQUALITY_TYPE.
  Parameter t: Type.
  Parameter eq: forall (x y: t), {x = y} + {x <> y}.
End EQUALITY_TYPE.

Module EMap(X: EQUALITY_TYPE) <: MAP.

  Definition elt := X.t.
  Definition elt_eq := X.eq.
  Definition t (A: Type) := X.t -> A.
  Definition init (A: Type) (v: A) := fun (_: X.t) => v.
  Definition get (A: Type) (x: X.t) (m: t A) := m x.
  Definition set (A: Type) (x: X.t) (v: A) (m: t A) :=
    fun (y: X.t) => if X.eq y x then v else m y.
  Lemma gi:
    forall (A: Type) (i: elt) (x: A), init x i = x.
  Proof.
    intros. reflexivity.
  Qed.
  Lemma gss:
    forall (A: Type) (i: elt) (x: A) (m: t A), (set i x m) i = x.
  Proof.
    intros. unfold set. case (X.eq i i); intro.
    reflexivity. tauto.
  Qed.
  Lemma gso:
    forall (A: Type) (i j: elt) (x: A) (m: t A),
    i <> j -> (set j x m) i = m i.
  Proof.
    intros. unfold set. case (X.eq i j); intro.
    congruence. reflexivity.
  Qed.
  Lemma gsspec:
    forall (A: Type) (i j: elt) (x: A) (m: t A),
    get i (set j x m) = if elt_eq i j then x else get i m.
  Proof.
    intros. unfold get, set, elt_eq. reflexivity.
  Qed.
  Lemma gsident:
    forall (A: Type) (i j: elt) (m: t A), get j (set i (get i m) m) = get j m.
  Proof.
    intros. unfold get, set. case (X.eq j i); intro.
    congruence. reflexivity.
  Qed.
  Definition map (A B: Type) (f: A -> B) (m: t A) :=
    fun (x: X.t) => f(m x).
  Lemma gmap:
    forall (A B: Type) (f: A -> B) (i: elt) (m: t A),
    get i (map f m) = f(get i m).
  Proof.
    intros. unfold get, map. reflexivity.
  Qed.
End EMap.


From fae_gtlc_mu.cast_calculus Require Export typing contexts.
From fae_gtlc_mu.stlc_mu Require Export typing contexts.
From fae_gtlc_mu.cast_calculus Require Import lang consistency consistency_lemmas.
From fae_gtlc_mu.backtranslation Require Import types expressions cast_help.general_def cast_help.general_def_lemmas contexts.

(* Well-typedness for expressions *)
Lemma well_typedness_expr Γ e τ : (Γ ⊢ₜ e : τ) →
    map backtranslate_type Γ ⊢ₛ backtranslate_expr e : backtranslate_type τ.
Proof.
  induction 1; simpl; try by econstructor.
  - constructor. by apply back_closed. by rewrite list_lookup_fmap H.
  - apply InjL_typed. by apply back_closed. auto.
  - apply InjR_typed. by apply back_closed. auto.
  - eapply Lam_typed. by apply back_closed. apply IHtyped.
  - apply Fold_typed.
    by rewrite back_unfold_comm in IHtyped.
  - rewrite back_unfold_comm.
    by apply Unfold_typed.
  - assert (pτi : Closed τi). apply (cast_calculus.typing.typed_closed H).
    destruct (consistency_open_dec τi τf);
      destruct (decide (Closed τi));
      destruct (decide (Closed τf)); try by contradiction.
    eapply App_typed with (τ1 := <<τi>>).
    apply EClosed_typed; auto. apply 𝓕c_closed; auto.
    rewrite /𝓕c /env_subst. asimpl.
    apply 𝓕_typed with (A := []); auto. apply IHtyped.
  - apply Ω_typed. by apply back_closed.
Qed.

(* Well-typedness for contexts of depth 1 *)
Lemma well_typedness_ctx_item Γ (τ : cast_calculus.types.type) (pτ : Closed τ) Γ' τ' C :
  cast_calculus.contexts.typed_ctx_item C Γ τ Γ' τ' →
  typed_ctx_item (backtranslate_ctx_item C) (map backtranslate_type Γ) (backtranslate_type τ) (map backtranslate_type Γ') (backtranslate_type τ').
Proof.
  induction 1; try (by constructor).
  - apply TP_CTX_Lam. by apply back_closed.
  - apply TP_CTX_AppL. apply well_typedness_expr; done.
  - apply TP_CTX_AppR.
    cut (map backtranslate_type Γ ⊢ₛ backtranslate_expr e1 : <<(cast_calculus.types.TArrow τ τ')>>). by simpl.
    by apply well_typedness_expr.
  - constructor. by apply well_typedness_expr.
  - constructor. by apply well_typedness_expr.
  - constructor. by apply back_closed.
  - constructor. by apply back_closed.
  - constructor; rewrite -map_cons; by apply well_typedness_expr.
  - eapply TP_CTX_CaseM with (τ2 := <<τ2>>); auto.
    cut (map backtranslate_type Γ ⊢ₛ backtranslate_expr e0 : <<(cast_calculus.types.TSum τ1 τ2)>>). by simpl.
    by apply well_typedness_expr. rewrite -map_cons. by apply well_typedness_expr.
  - eapply TP_CTX_CaseR with (τ1 := <<τ1>>); auto.
    cut (map backtranslate_type Γ ⊢ₛ backtranslate_expr e0 : <<(cast_calculus.types.TSum τ1 τ2)>>). by simpl.
    by apply well_typedness_expr. rewrite -map_cons. by apply well_typedness_expr.
  - rewrite back_unfold_comm. apply TP_CTX_Fold.
  - rewrite back_unfold_comm. apply TP_CTX_Unfold.
  - simpl. destruct (consistency_open_dec τi τf); destruct (decide (Closed τi)); destruct (decide (Closed τf)); try by contradiction.
    apply TP_CTX_AppR. apply EClosed_typed. apply 𝓕c_closed; auto.
    rewrite /𝓕c /=. asimpl. apply 𝓕_typed with (A := []); auto.
Qed.

(* Well-typedness for contexts *)
Lemma well_typedness_ctx Γ (τ : cast_calculus.types.type) (pτ : Closed τ) Γ' τ' C :
  cast_calculus.contexts.typed_ctx C Γ τ Γ' τ' →
  typed_ctx (backtranslate_ctx C) (map backtranslate_type Γ) (backtranslate_type τ) (map backtranslate_type Γ') (backtranslate_type τ').
Proof.
  induction 1.
  - constructor.
  - econstructor; simpl. apply well_typedness_ctx_item with (τ := τ2).
    eapply cast_calculus.contexts.typed_ctx_closedness. apply pτ. apply H0. apply H. apply IHtyped_ctx. auto.
Qed.


(** Formal Reasoning About Programs <http://adam.chlipala.net/frap/>
  * An entailment procedure for separation logic's assertion language
  * Author: Adam Chlipala
  * License: https://creativecommons.org/licenses/by-nc-nd/4.0/ *)

Require Import Frap Setoid Classes.Morphisms.

Set Implicit Arguments.

Module Type SEP.
  Parameter hprop : Type.
  Parameter lift : Prop -> hprop.
  Parameter star : hprop -> hprop -> hprop.
  Parameter exis : forall A, (A -> hprop) -> hprop.

  Notation "[| P |]" := (lift P).
  Infix "*" := star.
  Notation "'exists' x .. y , p" := (exis (fun x => .. (exis (fun y => p)) ..)).

  Parameters himp heq : hprop -> hprop -> Prop.

  Infix "===" := heq (no associativity, at level 70).
  Infix "===>" := himp (no associativity, at level 70).

  Axiom himp_heq : forall p q, p === q
                               <-> (p ===> q /\ q ===> p).
  Axiom himp_refl : forall p, p ===> p.
  Axiom himp_trans : forall p q r, p ===> q -> q ===> r -> p ===> r.

  Axiom lift_left : forall p (Q : Prop) r,
    (Q -> p ===> r)
    -> p * [| Q |] ===> r.
  Axiom lift_right : forall p q (R : Prop),
    p ===> q
    -> R
    -> p ===> q * [| R |].
  Axiom extra_lift : forall (P : Prop) p,
    P
    -> p === [| P |] * p.

  Axiom star_comm : forall p q, p * q === q * p.
  Axiom star_assoc : forall p q r, p * (q * r) === (p * q) * r.
  Axiom star_cancel : forall p1 p2 q1 q2, p1 ===> p2
    -> q1 ===> q2
    -> p1 * q1 ===> p2 * q2.

  Axiom exis_gulp : forall A p (q : A -> _),
    p * exis q === exis (fun x => p * q x).
  Axiom exis_left : forall A (p : A -> _) q,
    (forall x, p x ===> q)
    -> exis p ===> q.
  Axiom exis_right : forall A p (q : A -> _) x,
    p ===> q x
    -> p ===> exis q.
End SEP.

Module Make(Import S : SEP).
  Add Parametric Relation : hprop himp
    reflexivity proved by himp_refl
    transitivity proved by himp_trans
    as himp_rel.

  Lemma heq_refl : forall p, p === p.
  Proof.
    intros; apply himp_heq; intuition (apply himp_refl).
  Qed.

  Lemma heq_sym : forall p q, p === q -> q === p.
  Proof.
    intros; apply himp_heq; apply himp_heq in H; intuition.
  Qed.

  Lemma heq_trans : forall p q r, p === q -> q === r -> p === r.
  Proof.
    intros; apply himp_heq; apply himp_heq in H; apply himp_heq in H0;
    intuition (eauto using himp_trans).
  Qed.

  Add Parametric Relation : hprop heq
    reflexivity proved by heq_refl
    symmetry proved by heq_sym
    transitivity proved by heq_trans
    as heq_rel.

  Global Instance himp_heq_mor : Proper (heq ==> heq ==> iff) himp.
  Proof.
    hnf; intros; hnf; intros.
    apply himp_heq in H; apply himp_heq in H0.
    intuition eauto using himp_trans.
  Qed.

  Add Parametric Morphism : star
  with signature heq ==> heq ==> heq
  as star_mor.
  Proof.
    intros; apply himp_heq; apply himp_heq in H; apply himp_heq in H0;
    intuition (auto using star_cancel).
  Qed.

  Add Parametric Morphism : star
  with signature himp ==> himp ==> himp
  as star_mor'.
  Proof.
    auto using star_cancel.
  Qed.

  Global Instance exis_iff_morphism (A : Type) :
    Proper (pointwise_relation A heq ==> heq) (@exis A).
  Proof.
    hnf; intros; apply himp_heq; intuition.
    hnf in H.
    apply exis_left; intro.
    eapply exis_right.
    assert (x x0 === y x0) by eauto.
    apply himp_heq in H0; intuition eauto.
    hnf in H.
    apply exis_left; intro.
    eapply exis_right.
    assert (x x0 === y x0) by eauto.
    apply himp_heq in H0; intuition eauto.
  Qed.

  Global Instance exis_imp_morphism (A : Type) :
    Proper (pointwise_relation A himp ==> himp) (@exis A).
  Proof.
    hnf; intros.
    apply exis_left; intro.
    eapply exis_right.
    unfold pointwise_relation in H.
    eauto.
  Qed.

  Lemma star_combine_lift1 : forall P Q, [| P |] * [| Q |] ===> [| P /\ Q |].
  Proof.
    intros.
    apply lift_left; intro.
    rewrite extra_lift with (P := True); auto.
    apply lift_left; intro.
    rewrite extra_lift with (P := True) (p := [| P /\ Q |]); auto.
    apply lift_right.
    reflexivity.
    tauto.
  Qed.

  Lemma star_combine_lift2 : forall P Q, [| P /\ Q |] ===> [| P |] * [| Q |].
  Proof.
    intros.
    rewrite extra_lift with (P := True); auto.
    apply lift_left; intro.
    apply lift_right; try tauto.
    rewrite extra_lift with (P := True) (p := [| P |]); auto.
    apply lift_right; try tauto.
    reflexivity.
  Qed.

  Lemma star_combine_lift : forall P Q, [| P |] * [| Q |] === [| P /\ Q |].
  Proof.
    intros.
    apply himp_heq; auto using star_combine_lift1, star_combine_lift2.
  Qed.

  Lemma star_comm_lift : forall P q, [| P |] * q === q * [| P |].
  Proof.
    intros; apply star_comm.
  Qed.

  Lemma star_assoc_lift : forall p Q r,
    (p * [| Q |]) * r === p * r * [| Q |].
  Proof.
    intros.
    rewrite <- star_assoc.
    rewrite (star_comm [| Q |]).
    apply star_assoc.
  Qed.

  Lemma star_comm_exis : forall A (p : A -> _) q, exis p * q === q * exis p.
  Proof.
    intros; apply star_comm.
  Qed.

  Ltac lift :=
    intros; apply himp_heq; split;
    repeat (apply lift_left; intro);
    repeat (apply lift_right; intuition).

  Lemma lift_combine : forall p Q R,
    p * [| Q |] * [| R |] === p * [| Q /\ R |].
  Proof.
    intros; apply himp_heq; split;
    repeat (apply lift_left; intro);
    repeat (apply lift_right; intuition).
  Qed.

  Lemma lift1_left : forall (P : Prop) q,
    (P -> [| True |] ===> q)
    -> [| P |] ===> q.
  Proof.
    intros.
    rewrite (@extra_lift True [| P |]); auto.
    apply lift_left; auto.
  Qed.

  Lemma lift1_right : forall p (Q : Prop),
    Q
    -> p ===> [| True |]
    -> p ===> [| Q |].
  Proof.
    intros.
    rewrite (@extra_lift True [| Q |]); auto.
    apply lift_right; auto.
  Qed.

  Ltac normalize0 :=
    match goal with
    | [ |- context[star ?p (exis ?q)] ] => rewrite (exis_gulp p q)
    | [ |- context[star (star ?p (lift ?q)) (lift ?r)] ] => rewrite (lift_combine p q r)
    | [ |- context[star ?p (star ?q ?r)] ] => rewrite (star_assoc p q r)
    | [ |- context[star (lift ?p) (lift ?q)] ] => rewrite (star_combine_lift p q)
    | [ |- context[star (lift ?p) ?q ] ] => rewrite (star_comm_lift p q)
    | [ |- context[star (star ?p (lift ?q)) ?r] ] => rewrite (star_assoc_lift p q r)
    | [ |- context[star (exis ?p) ?q] ] => rewrite (star_comm_exis p q)
    end.

  Ltac normalizeL :=
    (apply exis_left || apply lift_left; intro; try congruence)
    || match goal with
         | [ |- lift ?P ===> _ ] =>
           match P with
             | True => fail 1
             | _ => apply lift1_left; intro; try congruence
           end
       end.

  Ltac normalizeR :=
    match goal with
    | [ |- _ ===> exis _ ] => eapply exis_right
    | [ |- _ ===> _ * lift _ ] => apply lift_right
    | [ |- _ ===> lift ?Q ] =>
      match Q with
      | True => fail 1
      | _ => apply lift1_right
      end
    end.

  Ltac normalize1 := normalize0 || normalizeL || normalizeR.

  Lemma lift_uncombine : forall p P Q,
    p * [| P /\ Q |] === p * [| P |] * [| Q |].
  Proof.
    lift.
  Qed.

  Ltac normalize2 :=
    match goal with
    | [ |- context[star ?p (lift (?P /\ ?Q))] ] => rewrite (lift_uncombine p P Q)
    | [ |- context[star ?p (star ?q ?r)] ] => rewrite (star_assoc p q r)
    end.

  Ltac normalizeLeft :=
    let s := fresh "s" in intro s;
    let rhs := fresh "rhs" in
    match goal with
      | [ |- _ ===> ?Q ] => set (rhs := Q)
    end;
    simpl; intros; repeat (normalize0 || normalizeL);
    repeat match goal with
             | [ H : ex _ |- _ ===> _ ] => destruct H
             | [ H : _ /\ _ |- _ ] => destruct H
             | [ H : _ = _ |- _ ] => rewrite H
           end; subst rhs.

  Ltac normalize :=
    simpl; intros; repeat normalize1; repeat normalize2;
    repeat (match goal with
              | [ H : ex _ |- _ ===> _ ] => destruct H
            end; intuition idtac).

  Ltac forAllAtoms p k :=
    match p with
      | ?q * ?r => forAllAtoms q k || forAllAtoms r k
      | _ => k p
    end.

  Lemma stb1 : forall p q r,
    (q * p) * r === q * r * p.
  Proof.
    intros; rewrite <- star_assoc; rewrite (star_comm p r); apply star_assoc.
  Qed.

  Ltac sendToBack part := repeat (rewrite (stb1 part) || rewrite (star_comm part)).

  Theorem star_cancel' : forall p1 p2 q, p1 ===> p2
    -> p1 * q ===> p2 * q.
  Proof.
    intros; apply star_cancel; auto using himp_refl.
  Qed.

  Theorem star_cancel'' : forall p q, lift True ===> q
    -> p ===> p * q.
  Proof.
    intros.
    eapply himp_trans.
    rewrite extra_lift with (P := True); auto.
    instantiate (1 := p * q).
    rewrite star_comm.
    apply star_cancel; auto.
    reflexivity.
    reflexivity.
  Qed.

  Module Type TRY_ME_FIRST.
    Parameter try_me_first : hprop -> Prop.

    Axiom try_me_first_easy : forall p, try_me_first p.
  End TRY_ME_FIRST.

  Module TMF : TRY_ME_FIRST.
    Definition try_me_first (_ : hprop) := True.

    Theorem try_me_first_easy : forall p, try_me_first p.
    Proof.
      constructor.
    Qed.
  End TMF.

  Import TMF.
  Export TMF.

  Ltac cancel1 :=
    match goal with
      | [ |- ?p ===> ?q ] =>
        (is_var q; fail 2)
        || forAllAtoms p ltac:(fun p0 =>
          (let H := fresh in assert (H : try_me_first p0) by eauto; clear H);
                                 sendToBack p0;
          forAllAtoms q ltac:(fun q0 =>
            (let H := fresh in assert (H : try_me_first q0) by eauto; clear H);
            sendToBack q0;
            apply star_cancel'))
    end ||
    match goal with
      | [ |- _ ===> ?Q ] =>
        match Q with
        | _ => is_evar Q; fail 1
        | ?Q _ => is_evar Q; fail 1
        | _ => apply himp_refl
        end
      | [ |- ?p ===> ?q ] =>
        (is_var q; fail 2)
        || forAllAtoms p ltac:(fun p0 =>
          sendToBack p0;
          forAllAtoms q ltac:(fun q0 =>
            sendToBack q0;
            apply star_cancel'))
      | _ => progress autorewrite with core
    end.

  Ltac hide_evars :=
    repeat match goal with
           | [ |- ?P ===> _ ] => is_evar P; set P
           | [ |- _ ===> ?Q ] => is_evar Q; set Q
           | [ |- context[star ?P _] ] => is_evar P; set P
           | [ |- context[star _ ?Q] ] => is_evar Q; set Q
           | [ |- _ ===> exists v, _ * ?R v ] => is_evar R; set R
           end.

  Ltac restore_evars :=
    repeat match goal with
           | [ x := _ |- _ ] => subst x
           end.

  Fixpoint flattenAnds (Ps : list Prop) : Prop :=
    match Ps with
    | nil => True
    | [P] => P
    | P :: Ps => P /\ flattenAnds Ps
    end.

  Ltac allPuresFrom k :=
    match goal with
    | [ H : ?P |- _ ] =>
      match type of P with
      | Prop => generalize dependent H; allPuresFrom ltac:(fun Ps => k (P :: Ps))
      end
    | _ => intros; k (@nil Prop)
    end.

  Ltac whichToQuantify skip foundAlready k :=
    match goal with
    | [ x : ?T |- _ ] =>
      match type of T with
      | Prop => fail 1
      | _ =>
        match skip with
        | context[x] => fail 1
        | _ =>
          match foundAlready with
          | context[x] => fail 1
          | _ => (instantiate (1 := lift (x = x)); fail 2)
                 || (instantiate (1 := fun _ => lift (x = x)); fail 2)
                 || (whichToQuantify skip (x, foundAlready) k)
          end
        end
      end
    | _ => k foundAlready
    end.

  Ltac quantifyOverThem vars e k :=
    match vars with
    | tt => k e
    | (?x, ?vars') =>
      match e with
      | context[x] =>
        match eval pattern x in e with
        | ?f _ => quantifyOverThem vars' (exis f) k
        end
      | _ => quantifyOverThem vars' e k
      end
    end.

  Ltac addQuantifiers P k :=
    whichToQuantify tt tt ltac:(fun vars =>
        quantifyOverThem vars P k).

  Ltac addQuantifiersSkipping x P k :=
    whichToQuantify x tt ltac:(fun vars =>
        quantifyOverThem vars P k).

  Ltac basic_cancel :=
    normalize; repeat cancel1; repeat match goal with
                                      | [ H : _ /\ _ |- _ ] => destruct H
                                      | [ |- _ /\ _ ] => split
                                      end; eassumption || apply I.

  Ltac beautify := repeat match goal with
                          | [ H : True |- _ ] => clear H
                          | [ H : ?P, H' : ?P |- _ ] =>
                            match type of P with
                            | Prop => clear H'
                            end
                          | [ H : _ /\ _ |- _ ] => destruct H
                          end.

  Ltac cancel := hide_evars; normalize; repeat cancel1; restore_evars; beautify;
                 try match goal with
                     | [ |- _ ===> ?p * ?q ] =>
                       ((is_evar p; fail 1) || apply star_cancel'')
                       || ((is_evar q; fail 1) || (rewrite (star_comm p q); apply star_cancel''))
                     end;
                 try match goal with
                     | [ |- ?P ===> _ ] => sendToBack P;
                       match goal with
                       | [ |- ?P ===> ?Q * ?P ] => is_evar Q;
                         rewrite (star_comm Q P);
                         allPuresFrom ltac:(fun Ps =>
                                              match Ps with
                                              | nil => instantiate (1 := lift True)
                                              | _ =>
                                                let Ps' := eval simpl in (flattenAnds Ps) in
                                                addQuantifiers (lift Ps') ltac:(fun e => instantiate (1 := e))
                                              end;
                                              basic_cancel)
                       end
                     | [ |- ?P ===> ?Q ] => is_evar Q;
                       allPuresFrom ltac:(fun Ps =>
                                            match Ps with
                                            | nil => reflexivity
                                            | _ =>
                                              let Ps' := eval simpl in (flattenAnds Ps) in
                                              addQuantifiers (star P (lift Ps')) ltac:(fun e => instantiate (1 := e));
                                              basic_cancel
                                            end)
                     | [ |- ?P ===> ?Q ?x ] => is_evar Q;
                        allPuresFrom ltac:(fun Ps =>
                                             match Ps with
                                             | nil => reflexivity
                                             | _ =>
                                               let Ps' := eval simpl in (flattenAnds Ps) in
                                               addQuantifiersSkipping x (star P (lift Ps'))
                                                 ltac:(fun e => match eval pattern x in e with
                                                                | ?f _ => instantiate (1 := f)
                                                                end);
                                               basic_cancel
                                             end)
                     | [ |- _ ===> _ ] => intuition (try congruence)
                     end; intuition idtac; beautify.
End Make.


Require Import Coq.Lists.List Coq.Setoids.Setoid Coq.Classes.RelationClasses Coq.Classes.Morphisms.
Require Export Fiat.Common.Coq__8_4__8_5__Compat.

Set Implicit Arguments.

Local Coercion is_true : bool >-> Sortclass.

#[global]
Instance proper_if {A B R}
         {test : bool} {then_case else_case}
         `{Proper (A -> B) R then_case, Proper (A -> B) R else_case}
: Proper R (fun x => if test then then_case x else else_case x).
Proof.
  destruct test; trivial.
Qed.
#[global]
Instance proper_idmap {A R}
: Proper (R ==> R) (fun x : A => x).
Proof. repeat intro; assumption. Qed.
#[global]
Instance proper_const {A B} {R1 : relation A} {R2}
         `{Reflexive B R2} v
: Proper (R1 ==> R2) (fun _ => v).
Proof.
  repeat intro; reflexivity.
Qed.

Lemma pointwise_Proper {A B} R (f : A -> B) `{forall x, Proper R (f x)}
: Proper (pointwise_relation A R) f.
Proof.
  unfold Proper in *.
  repeat intro; trivial.
Qed.

#[global]
Hint Extern 10 (Proper (pointwise_relation _ _) _) => class_apply @pointwise_Proper : typeclass_instances.

Global Instance sumbool_rect_Proper {L R : Prop} {P} {R1}
: Proper (pointwise_relation L R1 ==> pointwise_relation R R1 ==> @forall_relation _ (fun _ : {L} + {R} => P) (fun _ => R1))
         (@sumbool_rect L R (fun _ => P)).
Proof.
  intros ?????? [a|a]; simpl in *; eauto.
Qed.

Global Hint Extern 0 (Proper _ (@sumbool_rect ?L ?R (fun _ => ?P))) => refine (@sumbool_rect_Proper L R P _) : typeclass_instances.

Global Instance andb_Proper
: Proper (eq ==> eq ==> eq) andb.
Proof.
  repeat ((intro; progress subst) || intros []); try reflexivity.
Qed.
Global Instance orb_Proper
: Proper (eq ==> eq ==> eq) orb.
Proof.
  repeat ((intro; progress subst) || intros []); try reflexivity.
Qed.

Global Instance map_Proper_eq {A B}
: Proper (pointwise_relation _ eq ==> eq ==> eq) (@map A B).
Proof.
  intros ?? H ? ls ?; subst.
  induction ls; trivial; simpl.
  hnf in H; rewrite H, IHls; reflexivity.
Qed.

Global Instance bool_rect_Proper {P} {R1}
: Proper (R1 ==> R1 ==> @forall_relation _ (fun _ : bool => P) (fun _ => R1))
         (@bool_rect (fun _ => P)).
Proof.
  intros ?????? [|]; simpl in *; eauto.
Qed.

Global Instance fst_eq_Proper {A B} : Proper (eq ==> eq) (@fst A B).
Proof.
  repeat intro; subst; reflexivity.
Qed.
Global Instance snd_eq_Proper {A B} : Proper (eq ==> eq) (@snd A B).
Proof.
  repeat intro; subst; reflexivity.
Qed.

Global Instance: Proper (eq ==> Basics.flip Basics.impl) is_true | 10 := _.
Global Instance: Proper (eq ==> Basics.impl) is_true | 10 := _.
Global Instance: Proper (eq ==> iff) is_true | 5 := _.
Global Instance: Proper (eq ==> eq) is_true | 0 := _.

Global Instance istrue_impl_Proper
: Proper (implb ==> Basics.impl) is_true.
Proof.
  intros [] []; compute; trivial.
Qed.

Global Instance istrue_flip_impl_Proper
: Proper (Basics.flip implb ==> Basics.flip Basics.impl) is_true.
Proof.
  intros [] []; compute; trivial.
Qed.

Global Instance implb_Reflexive : Reflexive implb | 1.
Proof. intros []; reflexivity. Qed.
Global Instance implb_Transitive : Transitive implb | 1.
Proof. intros [] [] []; simpl; trivial. Qed.
Global Instance implb_Antisymmetric : @Antisymmetric _ eq _ implb | 1.
Proof. intros [] [] []; simpl; trivial. Qed.

Global Instance flip_implb_Reflexive : Reflexive (Basics.flip implb) | 1.
Proof. intros []; reflexivity. Qed.
Global Instance flip_implb_Transitive : Transitive (Basics.flip implb) | 1.
Proof. intros [] [] []; simpl; trivial. Qed.
Global Instance flip_implb_Antisymmetric : @Antisymmetric _ eq _ (Basics.flip implb) | 1.
Proof. intros [] []; compute; intros [] []; trivial. Qed.

Global Instance implb_implb_Proper0
: Proper (implb ==> Basics.flip implb ==> Basics.flip implb) implb.
Proof. intros [] [] ? [] []; compute; trivial. Qed.

Global Instance implb_implb_Proper1
: Proper (Basics.flip implb ==> implb ==> implb) implb.
Proof. intros [] [] ? [] []; compute; trivial. Qed.

Global Instance implb_flip_implb_Proper0
: Proper (Basics.flip implb ==> implb ==> Basics.flip implb) (Basics.flip implb).
Proof. intros [] [] ? [] []; compute; trivial. Qed.

Global Instance implb_flip_implb_Proper1
: Proper (implb ==> Basics.flip implb ==> implb) (Basics.flip implb).
Proof. intros [] [] ? [] []; compute; trivial. Qed.

Global Instance subrelation_eq_pointwise {A B} : subrelation (@eq (A -> B)) (pointwise_relation A eq).
Proof.
  compute; intros; subst; reflexivity.
Qed.

Global Instance and_flip_impl_Proper
  : Proper (Basics.flip Basics.impl ==> Basics.flip Basics.impl ==> Basics.flip Basics.impl) and | 10.
Proof. lazy; tauto. Qed.

#[global]
Hint Extern 0 (Proper (_ ==> Basics.impl --> _) and) => apply and_flip_impl_Proper : typeclass_instances.
#[global]
Hint Extern 0 (Proper (Basics.impl --> _ ==> _) and) => apply and_flip_impl_Proper : typeclass_instances.

Global Instance eq_eq_impl_impl_Proper
  : Proper (eq ==> eq ==> Basics.impl) Basics.impl | 1
  := _.

Global Instance map_Proper_eq_In {A B ls}
  : Proper (forall_relation (fun a x y => List.In a ls -> x = y) ==> eq) (fun f => @List.map A B f ls).
Proof.
  induction ls as [|l ls IHls];
    unfold forall_relation.
  { repeat intro; reflexivity. }
  { intros ?? H.
    simpl; rewrite H by (left; reflexivity).
    f_equal.
    rewrite IHls; [ reflexivity | ].
    intros ??; apply H; right; assumption. }
Qed.

(** If we don't know the relation, default to assuming that it's equality, if the type is not a function *)
#[global]
Hint Extern 0 (@Reflexive ?T ?e)
 => is_evar e;
      lazymatch T with
      | forall x : _, _ => fail
      | _ => refine eq_Reflexive
      end : typeclass_instances.

Lemma pointwise_Reflexive {A B R} {_ : @Reflexive B R}
  : Reflexive (pointwise_relation A R).
Proof.
  repeat intro; reflexivity.
Qed.
#[global]
Hint Extern 1 (Reflexive (pointwise_relation _ _)) => apply @pointwise_Reflexive : typeclass_instances.

Ltac solve_Proper_eqs :=
  idtac;
  lazymatch goal with
  | [ |- Proper _ _ ] => apply @reflexive_proper; solve_Proper_eqs
  | [ |- Reflexive (_ ==> _)%signature ]
    => apply @reflexive_eq_dom_reflexive; solve_Proper_eqs
  | [ |- Reflexive _ ] => try apply eq_Reflexive
  end.
Ltac is_evar_or_eq e :=
  first [ is_evar e
        | match e with
          | eq => idtac
          end ].
Ltac is_evar_or_eq_or_evar_free e :=
  first [ is_evar_or_eq e
        | try (has_evar e; fail 1) ].
#[global]
Hint Extern 1 (Proper ?e _) =>
is_evar_or_eq e; solve_Proper_eqs : typeclass_instances.
#[global]
Hint Extern 1 (Proper (?e1 ==> ?e2) _) =>
is_evar_or_eq e1; is_evar_or_eq_or_evar_free e2; solve_Proper_eqs : typeclass_instances.
#[global]
Hint Extern 1 (Proper (?e1 ==> ?e2 ==> ?e3) _) =>
is_evar_or_eq e1; is_evar_or_eq e2; is_evar_or_eq_or_evar_free e3; solve_Proper_eqs : typeclass_instances.
#[global]
Hint Extern 1 (Proper (?e1 ==> ?e2 ==> ?e3 ==> ?e4) _) =>
is_evar_or_eq e1; is_evar_or_eq e2; is_evar_or_eq e3; is_evar_or_eq_or_evar_free e4; solve_Proper_eqs : typeclass_instances.


(** This module proves the fundamental property of the logical
relation defined in the [LogicalRelation] module. *)

From SimplyRatt Require Import Tactics.

From SimplyRatt Require Export LogicalRelationAux.

From Coq Require Import Program.Equality Arith.Wf_nat Omega.

Lemma vrel_box_cases A Hs Hs' s v h h' :
  vrel (Box A) Hs s v -> suffix Hs' Hs -> closed_heapseq Hs' ->
  closed_store (store_lock h h') ->
  (exists t v' s' , v = box t /\   {t,store_lock h h' } ⇓ {v',s'} /\ vrel A Hs' s' v')
  \/ (exists t v' s',
         v = fixp t /\
         {sub_term t (ref (alloc_fresh h')) ,store_lock h (heap_cons h' (alloc_fresh h') (unbox (fixp t))) } ⇓ {v',s'} /\
         vrel A Hs' s' v').
Proof.
  intros V Su Cl CS. rewrite vrel_box in V. unfold trel in V.
  destruct V as [Va T].

  pose (T _ Su _ _ (heapseq_le_refl _) (tick_le_empty h h') Cl CS) as T'.
  destruct T' as (w & s'& R & V').
  inversion R.
  + inversion H.
  + inversion H0; subst;try solve[inversion Va]. left.
    do 3 eexists. repeat split; eauto.
  + subst. inversion H2; subst;try solve[inversion Va]. right.
    do 5 eexists. repeat split;eauto using heap_fresh_alloc. auto.
Qed.

(** Fundamental property (cf. Theorem 6.3 in the paper). *)

Theorem fund_prop ty (G : ctx ty) t A Hs s g :
  hastype G t A -> crel G Hs s g -> closed_sub g ->
  closed_heapseq Hs -> closed_store s ->
  trel A Hs s (sub_app g t).
Proof.
  intros T. generalize dependent g. generalize dependent Hs.
  generalize dependent s.
  induction T;  intros s Hs g C CS CH Cs.
  - (* unit *)
    apply vrel_trel. simpl. autorewrite with vrel. auto.
  - (* natlit *)
    apply vrel_trel. simpl. autorewrite with vrel. eauto.
  - (* var *)
    eapply ctx_lookup_vrel in H; try eassumption. autodest.
    apply vrel_trel. simpl. rewrite H. assumption.
  - (* abs *)
    apply vrel_trel. simpl. autorewrite with vrel.
    exists (sub_app (None :: g) t). split. reflexivity.
    intros. rewrite sub_term_merge.
    apply IHT. constructor. assumption.
    apply crel_gc in C. eauto using crel_mono. assumption.
    auto. auto. auto. auto.
  - (* app *)
    unfold trel in *. intros Hs' s' HS TL HCH HCs.
    pose (IHT1 _ _ _ C CS CH Cs _ _ HS TL HCH HCs) as IH1.
    destruct IH1 as (v & s''& [IH1s IH1v]).
    rewrite vrel_arrow in IH1v.
    destruct IH1v as (u & [V IH1]). subst.
    assert (tick_le s s'') as TL' by eauto using tick_le_trans, red_extensive.
    assert (closed_term (abs u) /\ closed_store s'') as HCC
        by (apply red_closed with (t := sub_app g t1) (s := s');eauto using crel_sub_closed).
    destruct HCC as [HC'' HCs'].
    pose (IHT2 _ _ _ C CS CH Cs _ _ HS TL' HCH HCs') as IH2.
    destruct IH2 as (v' & s'''& [IH2s IH2v]).
    apply vrel_gc in IH2v.
    assert (store_le (gc s'') (gc s''')) as SL by
          eauto using tick_le_gc,red_extensive.
    assert (closed_term v' /\ closed_store s''') as CT by
          (apply red_closed with (t := sub_app g t2) (s := s'');eauto using crel_sub_closed).
    destruct CT as [CT CTS].
    assert (closed_store (gc s''')) as CGS by (eauto using closed_store_gc).
    pose (IH1 _ (gc s''') (heapseq_le_refl _) SL HCH CGS v' IH2v CT _ _ (heapseq_le_refl _)
              (tick_le_gc' s''') HCH CTS) as IH1v.
    destruct IH1v as (w & s1 & [R V]).
    exists w, s1. simpl. eauto.
  - (* pair *)
    unfold trel in *. intros Hs' s' HS TL HCH HCs.

    assert (exists (v : term) (s'' : store),
               {sub_app g t1, s'}⇓ {v, s''} /\ vrel T1 Hs' s'' v) as IH1 by
          (eapply IHT1; eauto).
    destruct IH1 as (v & s'' & R1 & V1).
    assert (closed_term (sub_app g t1)) as CT by eauto using crel_sub_closed.
    pose (red_closed _ _ _ _ CT HCs R1) as MC.
    destruct MC as [CV Cs'].
    pose (red_extensive _ _ _ _ R1) as Ex1.
    apply tick_le_store in Ex1.
    assert (exists (v' : term) (s''' : store),
               {sub_app g t2, s''}⇓ {v', s'''} /\ vrel T2 Hs' s''' v') as IH2 by
          (eapply IHT2; eauto using tick_le_trans).
    destruct IH2 as (v' & s''' & R2 & V2).

    pose (red_extensive _ _ _ _ R2) as Ex2.
    apply tick_le_store in Ex2.
    eexists. eexists. simpl. split. eapply red_pair;eauto.
    rewrite vrel_times. eexists. eexists.
    split. reflexivity.  eauto using vrel_mono.
  - (* pr1 *)
    unfold trel in *. intros Hs' s' HS TL HCH HCs.
    assert (exists (v : term) (s'' : store),
               {sub_app g t, s'}⇓ {v, s''} /\ vrel (Times T1 T2) Hs' s'' v) as IH by
          (eapply IHT; eauto).
    destruct IH as (v & s'' & R & V).
    rewrite vrel_times in V. autodest.
    eexists. eexists. split. simpl. eapply red_pr1. eassumption. assumption.

  - (* pr2 *)
    unfold trel in *. intros Hs' s' HS TL HCH HCs.
    assert (exists (v : term) (s'' : store),
               {sub_app g t, s'}⇓ {v, s''} /\ vrel (Times T1 T2) Hs' s'' v) as IH by
          (eapply IHT; eauto).
    destruct IH as (v & s'' & R & V).
    rewrite vrel_times in V. autodest.
    eexists. eexists. split. simpl. eapply red_pr2. eassumption. assumption.
  - (* in1 *)
    unfold trel in *. intros Hs' s' HS TL HCH HCs.
    assert (exists (v : term) (s'' : store),
               {sub_app g t, s'}⇓ {v, s''} /\ vrel T1 Hs' s'' v) as IH by
          (eapply IHT; eauto).
    destruct IH as (v & s'' & R & V).

    eexists. eexists. split. simpl. eapply red_in1. eassumption.
    rewrite vrel_plus. eauto.

  - (* in2 *)
    unfold trel in *. intros Hs' s' HS TL HCH HCs.
    assert (exists (v : term) (s'' : store),
               {sub_app g t, s'}⇓ {v, s''} /\ vrel T2 Hs' s'' v) as IH by
          (eapply IHT; eauto).
    destruct IH as (v & s'' & R & V).

    eexists. eexists. split. simpl. eapply red_in2. eassumption.
    rewrite vrel_plus. eauto.
  - (* case *)
    simpl. unfold trel in *. intros Hs' s' HS TL HCH HCs.

    assert (exists (v : term) (s'' : store),
         {sub_app g t, s'}⇓ {v, s''} /\ vrel (Plus T2 T3) Hs' s'' v) as IH1 by
          (eapply IHT1; eauto).
    destruct IH1 as (v & s'' & R1 & V1). clear IHT1.
    assert (closed_term (sub_app g t)) as CT by eauto using crel_sub_closed.
    pose (red_closed _ _ _ _ CT HCs R1) as MC.
    destruct MC as [CV Cs'].
    pose (red_extensive _ _ _ _ R1) as Ex1.
    apply tick_le_store in Ex1.
    rewrite vrel_plus in V1.
    destruct V1 as [V1|V1]; destruct V1 as (v0 & Subst & V1);subst.
    + inversion CV. subst.
      assert (exists (v' : term) (s''' : store),
                 {sub_app (Some v0 :: g) t1, s''}⇓ {v', s'''} /\ vrel T1 Hs' s''' v') as IH2 by
            (eapply IHT2; eauto using tick_le_trans, crel_var,crel_mono).

      destruct IH2 as (v' & s''' & R2 & V2).

      pose (red_extensive _ _ _ _ R2) as Ex2.
      apply tick_le_store in Ex2.

      eexists. eexists. split. simpl.
      eapply red_case1; try eassumption. rewrite sub_term_merge. eassumption. assumption.
      assumption.
    + inversion CV. subst.
      assert (exists (v' : term) (s''' : store),
                 {sub_app (Some v0 :: g) t2, s''}⇓ {v', s'''} /\ vrel T1 Hs' s''' v') as IH2 by
            (eapply IHT3; eauto using tick_le_trans, crel_var,crel_mono).

      destruct IH2 as (v' & s''' & R2 & V2).

      pose (red_extensive _ _ _ _ R2) as Ex2.
      apply tick_le_store in Ex2.

      eexists. eexists. split. simpl.
      eapply red_case2; try eassumption. rewrite sub_term_merge. eassumption. assumption.
      assumption.

  - (* delay *)
    unfold trel. intros Hs' s' HsL TL CHs' Cs'.
    apply crel_mono with (Hs':=Hs') (s':=s') in C;auto.
    assert (exists h h', s' = store_lock h h') as S' by eauto using crel_now'.
    destruct S' as (h&h'&S'). rewrite S' in *.
    eexists. eexists. simpl. split.
    apply red_delay; eauto.
    destruct Hs'.
    + rewrite vrel_delay_nil. eauto.
    + rewrite vrel_delay. eexists. eexists. split. reflexivity.
      split. apply store_mapsto_cons.
      dependent destruction CHs'.
      intros.

      apply crel_gc in C;try solve[intro CO;inversion CO].

      assert (crel (ctx_tick G) (Hs') (store_lock (Some h') h1) g).
      constructor. eapply crel_mono;try eapply C;eauto.
      constructor; eauto.
      intros h2 HS. inversion HS;subst. exists h1. split;eauto.
      constructor;auto. dependent destruction Cs';eauto.
      assert (closed_term (sub_app g t)).
      eapply crel_sub_closed;eauto.

      apply IHT;eauto. constructor. simpl in C.
      eapply crel_mono;try eapply C.
      * constructor;eauto.
        intros h2 HS. inversion HS;subst. exists h1. split;eauto.
      * constructor;auto.
      * eauto using heap_fresh_alloc,heap_cons_mono.
      * dependent destruction Cs';eauto using closed_heap_alloc.
      * simpl. dependent destruction Cs';eauto using closed_heap_alloc.
   - (* adv *)
    unfold trel in *. intros Hs' s' HsL TL CHs' Cs'.
    assert (exists hn hl : heap, s = store_lock (Some hn) hl) as ST by
          eauto using crel_later.
    destruct ST as (hn & hl & ST). subst.
    pose (tick_le_tick' _ _ _ TL) as ST.
    destruct ST as (hn' & hl' & [ST [HLn HLl]]). subst.
    dependent destruction Cs.
    dependent destruction Cs'.
    assert (exists (v : term) (s'' : store),
       {sub_app (sub_skip (skip_later_count G) g) t, store_lock None hn'}⇓ {v, s''} /\
       vrel (Delay T) (heaps_single hl :: Hs') s'' v) as IH by
          (eapply IHT;eauto using crel_skip_later, sub_skip_closed,heaps_single_closed).
    destruct IH as (v & s''& R & V).
    assert (store_le (store_lock None hn') (s'')) as SL
        by eauto using red_extensive.
    inversion SL. subst.
    rewrite vrel_delay in V.
    destruct V as (l & u & [RL [M TT]]). subst.
    assert (closed_term (ref l) /\ closed_store (store_lock None h')) as CL by
          (eapply red_closed; try eassumption;
           eauto using crel_sub_closed, sub_skip_closed, crel_skip_later).
    destruct CL as [CL1 CL2].
    dependent destruction CL2.
    unfold trel in TT.
    assert (exists (v : term) (s'' : store),
               {u, store_lock (Some h') hl'}⇓ {v, s''} /\
               vrel T Hs' s'' v) as TT' by
          (eapply TT ; simpl;eauto using crel_skip_later, sub_skip_closed,heaps_single_closed).
    destruct TT' as (v & s'' & R2 & V2).
    erewrite sub_skip_later_app in R by eauto.

    simpl. exists v, s''. split. eapply red_adv. eapply R.
    inversion M;subst. eassumption. eassumption. auto.

  - (* progress *)
    unfold trel in *. intros Hs' s' HsL TL CHs' Cs'.
    assert (exists hn hl : heap, s = store_lock (Some hn) hl) as ST by
          eauto using crel_later.
    destruct ST as (hn & hl & ST). subst.
    pose (tick_le_tick' _ _ _ TL) as ST.
    destruct ST as (hn' & hl' & [ST [HLn HLl]]). subst.
    dependent destruction Cs.
    dependent destruction Cs'.
    assert (exists (v : term) (s'' : store),
       {sub_app (sub_skip (skip_later_count G) g) t, store_lock None hn'}⇓ {v, s''} /\
       vrel T (heaps_single hl :: Hs') s'' v) as IH by
    (eapply IHT;
      eauto using crel_skip_later, sub_skip_closed,heaps_single_closed).
    destruct IH as (v & s''& R & V).
    assert (store_le (store_lock None hn') (s'')) as SL
        by eauto using red_extensive.
    inversion SL. subst.
    erewrite sub_skip_later_app in R by eauto.
    eexists. eexists.
    split. simpl.  apply red_progr.
    eapply R. eapply vrel_stable in V. apply V. auto. auto.
  - (* box *)
    apply vrel_trel. simpl. autorewrite with vrel.
    split. auto. intros Hs0 Su.
    unfold trel in *. intros Hs' s' HsL TL CHs' Cs'.
    assert (exists (v : term) (s'' : store), {sub_app g t, s'}⇓ {v, s''} /\ vrel T Hs' s'' v) as IH.
    eapply IHT; try eassumption;eauto.
    pose (heapseq_le_suffix'' _ _ _ HsL Su CH CHs') as HSS.
    destruct HSS as (Hs'' & HsL' & Su' & CH').
    apply crel_mono with (Hs':=Hs'') (s':=s) in C;eauto.
    eapply crel_lock;try eassumption;eauto.
    rewrite <- tick_le_bot' by apply TL. intros CO;inversion CO.
    assert (s = store_bot) by eauto using crel_init. subst.
    assumption.
    destruct IH as (v & s''& R & V).
    eexists. eexists. split. eapply red_unbox_box;try eassumption;eauto.
    rewrite <- tick_le_bot'; try eassumption. eauto. assumption.
  - (* unbox *)
    unfold trel in *. intros Hs' s' HsL TL CHs' Cs'.
    apply crel_mono with (Hs':=Hs') (s':=s') in C;auto.
    pose C as C'. apply crel_skip_now in C'.
    destruct C' as (Hs'' & Su & CHS & C').
    assert (exists (v : term) (s'' : store),
               {sub_app (sub_skip (skip_now_count G) g) t, store_bot}⇓ {v, s''} /\
               vrel (Box T) Hs'' s'' v) as IH by
        (eapply IHT; eauto using crel_skip_now, sub_skip_closed,heaps_single_closed).

    destruct IH as (v & s''& R & V).
    assert (store_le store_bot (s'')) as SL
        by eauto using red_extensive.
    inversion SL. subst.
    erewrite sub_skip_now_app in R by eauto.
    assert (exists h h', s' = store_lock h h') as S' by eauto using crel_now'.
    destruct S' as (h&h'&S'). rewrite S' in *.
    apply vrel_box_cases with (Hs' := Hs') (h := h) (h':=h') in V;eauto.

    destruct V.
    + autodest. eexists; eexists; split.
      simpl. eapply red_unbox_box;eauto. eauto.
    + autodest. eexists; eexists; split.
      simpl. eapply red_unbox_fix;eauto using heap_fresh_alloc. eauto.
  - (* promote (now context) *)
    unfold trel in *. intros Hs' s' HsL TL CHs' Cs'.
    apply crel_mono with (Hs':=Hs') (s':=s') in C;auto.
    pose C as C'. apply crel_skip_now in C'.
    destruct C' as (Hs'' & Su & CHS & C').
    assert (exists (v : term) (s'' : store),
               {sub_app (sub_skip (skip_now_count G) g) t, store_bot}⇓ {v, s''} /\
               vrel T Hs'' s'' v) as IH by
        (eapply IHT; eauto using crel_skip_now, sub_skip_closed,heaps_single_closed).

    destruct IH as (v & s''& R & V).
    assert (store_le store_bot (s'')) as SL
        by eauto using red_extensive.
    inversion SL. subst. erewrite sub_skip_now_app in R by eauto.
    eexists. eexists. split. simpl.  apply red_promote.
    eapply R. eauto using crel_now. eapply vrel_stable in V. apply V. auto. auto.
  - (* promote (later context) *)
    unfold trel in *. intros Hs' s' HsL TL CHs' Cs'.
    assert (exists hn hl : heap, s = store_lock (Some hn) hl) as ST by
          eauto using crel_later.
    destruct ST as (hn & hl & ST). subst.
    pose (tick_le_tick' _ _ _ TL) as ST.
    destruct ST as (hn' & hl' & [ST [HLn HLl]]). subst.
    dependent destruction Cs.
    dependent destruction Cs'.
    apply crel_mono with (Hs':=Hs') (s':=store_lock (Some hn) hl) in C;auto.
    pose C as C'. apply crel_skip_later in C'.
    apply crel_skip_now in C'.
    destruct C' as (Hs'' & Su & CHS & C').
    assert (exists (v : term) (s'' : store),
               {sub_app (sub_skip (skip_now_count (skip_later G))
                                  (sub_skip (skip_later_count G) g)) t, store_bot}⇓ {v, s''} /\
               vrel T Hs'' s'' v) as IH by
        (eapply IHT; eauto using crel_skip_now, sub_skip_closed,heaps_single_closed).

    destruct IH as (v & s''& R & V).
    assert (store_le store_bot (s'')) as SL
        by eauto using red_extensive.
    inversion SL. subst. simpl. erewrite sub_skip_both_app in R;eauto.
    eexists. eexists. split. simpl.  apply red_promote.
    eapply R. eauto using crel_later. eapply vrel_stable in V. apply V. auto.
    eauto using suffix_cons.
  - (* fixp *)
    assert (closed_term (sub_app g (fixp t))).
    eapply crel_sub_closed;eauto.

    apply vrel_trel. simpl. autorewrite with vrel.
    split. auto. intros Hs0 Su.
    apply suffix_wsuffix in Su.
    remember (length Hs0).
    generalize dependent Hs0.
    induction (lt_wf n) as [n _ IHn];intros Hs0 Su N;subst.

    unfold trel. intros Hs' s' HsL TL CHs' Cs'.
    assert (exists hn hl, s' = store_lock hn hl) as SS by
          eauto using tick_le_lock.
    destruct SS as (hn & hl & SS). subst.
    assert (s = store_bot) by eauto using crel_init. subst.
    pose (alloc_fresh hl) as l.

    pose (heapseq_le_suffix_trans _ _ _ Su HsL) as Su'.

    assert (vrel (Delay T) Hs'
               (store_lock hn (heap_cons hl l (unbox (fixp (sub_app (None :: g) t))))) (ref l)) as D.
    destruct Hs'.
    + rewrite vrel_delay_nil. eauto.
    + rewrite vrel_delay.

      eexists. eexists. split. reflexivity. split. apply store_mapsto_cons.
      intros. apply trel_mono with (Hs:= Hs') (s:=store_lock None heap_empty);auto.
      eauto using tick_le_none, heap_le_empty.
      eapply IHn with (y := length Hs').
      assert (length Hs0 = length (h :: Hs')) by eauto using heapseq_le_length.
      simpl in *. omega. eauto using wsuffix_trans, heapseq_le_cons_wsuffix.
      reflexivity.

    + assert (exists (v : term) (s'' : store),
                 {sub_app (Some (ref l) :: g) t,
                  store_lock hn (heap_cons hl l (unbox (fixp (sub_app (None :: g) t))))}⇓ {v, s''} /\
                 vrel T Hs' s'' v) as IH.
      eapply IHT ; try first [eapply crel_var; first[eapply D|eauto]|eassumption].
      inversion Su'. subst. eapply crel_mono with (Hs:=Hs2);try eassumption;eauto.
      dependent destruction Cs';eauto using closed_heap_alloc.
      eauto. dependent destruction Cs';eauto using closed_heap_alloc. auto.
      simpl. auto.
      dependent destruction Cs';eauto using closed_heap_alloc.
      autodest.
      eexists. eexists. split. eapply red_unbox_fix; try eassumption. eauto.
      eauto using heap_fresh_alloc.  rewrite sub_term_merge. eauto. eauto. eauto.
  - (* into *)
    unfold trel in *. intros Hs' s' HsL TL CHs' Cs'.
    apply crel_mono with (Hs':=Hs') (s':=s') in C;auto.
    assert (exists (v : term) (s'' : store),
               {sub_app g t, s'}⇓ {v, s''} /\ vrel (tsubst 0 T (Delay (Mu T))) Hs' s'' v) as IH
        by (eapply IHT;try eassumption;eauto).
    destruct IH as (v & s''& R & V).
    eexists. eexists. split. simpl. apply red_into. apply R.
    rewrite vrel_mu. eauto.
  - (* out *)
    unfold trel in *. intros Hs' s' HsL TL CHs' Cs'.
    apply crel_mono with (Hs':=Hs') (s':=s') in C;auto.
    assert (exists (v : term) (s'' : store), {sub_app g t, s'}⇓ {v, s''}
                                             /\ vrel (Mu A) Hs' s'' v) as IH
        by (eapply IHT;try eassumption;eauto).
    destruct IH as (v & s''& R & V).
    rewrite vrel_mu in V.
    destruct V as (v' & E & V). subst.
    eexists. eexists. split. simpl. apply red_out. apply R. apply V.
Qed.


From Hammer Require Import Hammer.

Import EqNotations.

Section Dependent_Equality.

Variable U : Type.
Variable P : U -> Type.

Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop :=
eq_dep_intro : eq_dep p x p x.
Hint Constructors eq_dep: core.

Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_refl".  exact (eq_dep_intro). Qed.

Lemma eq_dep_sym :
forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep q y p x.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_sym".
destruct 1; auto.
Qed.
Hint Immediate eq_dep_sym: core.

Lemma eq_dep_trans :
forall (p q r:U) (x:P p) (y:P q) (z:P r),
eq_dep p x q y -> eq_dep q y r z -> eq_dep p x r z.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_trans".
destruct 1; auto.
Qed.

Scheme eq_indd := Induction for eq Sort Prop.

Inductive eq_dep1 (p:U) (x:P p) (q:U) (y:P q) : Prop :=
eq_dep1_intro : forall h:q = p, x = rew h in y -> eq_dep1 p x q y.

Lemma eq_dep1_dep :
forall (p:U) (x:P p) (q:U) (y:P q), eq_dep1 p x q y -> eq_dep p x q y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep1_dep".
destruct 1 as (eq_qp, H).
destruct eq_qp using eq_indd.
rewrite H.
apply eq_dep_intro.
Qed.

Lemma eq_dep_dep1 :
forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_dep1".
destruct 1.
apply eq_dep1_intro with (eq_refl p).
simpl; trivial.
Qed.

End Dependent_Equality.

Arguments eq_dep  [U P] p x q _.
Arguments eq_dep1 [U P] p x q y.

Lemma eq_sigT_eq_dep :
forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
existT P p x = existT P q y -> eq_dep p x q y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_sigT_eq_dep".
intros.
dependent rewrite H.
apply eq_dep_intro.
Qed.

Notation eq_sigS_eq_dep := eq_sigT_eq_dep (compat "8.2").

Lemma eq_dep_eq_sigT :
forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
eq_dep p x q y -> existT P p x = existT P q y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_eq_sigT".
destruct 1; reflexivity.
Qed.

Lemma eq_sigT_iff_eq_dep :
forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q),
existT P p x = existT P q y <-> eq_dep p x q y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_sigT_iff_eq_dep".
split; auto using eq_sigT_eq_dep, eq_dep_eq_sigT.
Qed.

Notation equiv_eqex_eqdep := eq_sigT_iff_eq_dep (only parsing).

Lemma eq_sig_eq_dep :
forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
exist P p x = exist P q y -> eq_dep p x q y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_sig_eq_dep".
intros.
dependent rewrite H.
apply eq_dep_intro.
Qed.

Lemma eq_dep_eq_sig :
forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
eq_dep p x q y -> exist P p x = exist P q y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_eq_sig".
destruct 1; reflexivity.
Qed.

Lemma eq_sig_iff_eq_dep :
forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q),
exist P p x = exist P q y <-> eq_dep p x q y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_sig_iff_eq_dep".
split; auto using eq_sig_eq_dep, eq_dep_eq_sig.
Qed.

Set Implicit Arguments.

Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <->
{H:x1=x2 | rew H in H1 = H2}.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_sigT_sig_eq".
intros; split; intro H.
- change x2 with (projT1 (existT P x2 H2)).
change H2 with (projT2 (existT P x2 H2)) at 5.
destruct H. simpl.
exists eq_refl.
reflexivity.
- destruct H as (->,<-).
reflexivity.
Defined.

Lemma eq_sigT_fst :
forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), x1 = x2.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_sigT_fst".
intros.
change x2 with (projT1 (existT P x2 H2)).
destruct H.
reflexivity.
Defined.

Lemma eq_sigT_snd :
forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_sigT_snd".
intros.
unfold eq_sigT_fst.
change x2 with (projT1 (existT P x2 H2)).
change H2 with (projT2 (existT P x2 H2)) at 3.
destruct H.
reflexivity.
Defined.

Lemma eq_sig_fst :
forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), x1 = x2.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_sig_fst".
intros.
change x2 with (proj1_sig (exist P x2 H2)).
destruct H.
reflexivity.
Defined.

Lemma eq_sig_snd :
forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), rew (eq_sig_fst H) in H1 = H2.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_sig_snd".
intros.
unfold eq_sig_fst, eq_ind.
change x2 with (proj1_sig (exist P x2 H2)).
change H2 with (proj2_sig (exist P x2 H2)) at 3.
destruct H.
reflexivity.
Defined.

Unset Implicit Arguments.

Hint Resolve eq_dep_intro: core.
Hint Immediate eq_dep_sym: core.

Section Equivalences.

Variable U:Type.

Definition Eq_rect_eq_on (p : U) (Q : U -> Type) (x : Q p) :=
forall (h : p = p), x = eq_rect p Q x p h.
Definition Eq_rect_eq := forall p Q x, Eq_rect_eq_on p Q x.

Definition Eq_dep_eq_on (P : U -> Type) (p : U) (x : P p) :=
forall (y : P p), eq_dep p x p y -> x = y.
Definition Eq_dep_eq := forall P p x, Eq_dep_eq_on P p x.

Definition UIP_on_ (x y : U) (p1 : x = y) :=
forall (p2 : x = y), p1 = p2.
Definition UIP_ := forall x y p1, UIP_on_ x y p1.

Definition UIP_refl_on_ (x : U) :=
forall (p : x = x), p = eq_refl x.
Definition UIP_refl_ := forall x, UIP_refl_on_ x.

Definition Streicher_K_on_ (x : U) (P : x = x -> Prop) :=
P (eq_refl x) -> forall p : x = x, P p.
Definition Streicher_K_ := forall x P, Streicher_K_on_ x P.

Lemma eq_rect_eq_on__eq_dep1_eq_on (p : U) (P : U -> Type) (y : P p) :
Eq_rect_eq_on p P y -> forall (x : P p), eq_dep1 p x p y -> x = y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_rect_eq_on__eq_dep1_eq_on".
intro eq_rect_eq.
simple destruct 1; intro.
rewrite <- eq_rect_eq; auto.
Qed.
Lemma eq_rect_eq__eq_dep1_eq :
Eq_rect_eq -> forall (P:U->Type) (p:U) (x y:P p), eq_dep1 p x p y -> x = y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_rect_eq__eq_dep1_eq".
       exact ((fun eq_rect_eq P p y x => @eq_rect_eq_on__eq_dep1_eq_on p P x (eq_rect_eq p P x) y)).
Qed.

Lemma eq_rect_eq_on__eq_dep_eq_on (p : U) (P : U -> Type) (x : P p) :
Eq_rect_eq_on p P x -> Eq_dep_eq_on P p x.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_rect_eq_on__eq_dep_eq_on".
intros eq_rect_eq; red; intros.
symmetry; apply (eq_rect_eq_on__eq_dep1_eq_on _ _ _ eq_rect_eq).
apply eq_dep_sym in H; apply eq_dep_dep1; trivial.
Qed.
Lemma eq_rect_eq__eq_dep_eq : Eq_rect_eq -> Eq_dep_eq.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_rect_eq__eq_dep_eq".
       exact ((fun eq_rect_eq P p x y => @eq_rect_eq_on__eq_dep_eq_on p P x (eq_rect_eq p P x) y)).
Qed.

Lemma eq_dep_eq_on__UIP_on (x y : U) (p1 : x = y) :
Eq_dep_eq_on (fun y => x = y) x eq_refl -> UIP_on_ x y p1.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_eq_on__UIP_on".
intro eq_dep_eq; red.
elim p1 using eq_indd.
intros; apply eq_dep_eq.
elim p2 using eq_indd.
apply eq_dep_intro.
Qed.
Lemma eq_dep_eq__UIP : Eq_dep_eq -> UIP_.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_eq__UIP".
       exact ((fun eq_dep_eq x y p1 => @eq_dep_eq_on__UIP_on x y p1 (eq_dep_eq _ _ _))).
Qed.

Lemma UIP_on__UIP_refl_on (x : U) :
UIP_on_ x x eq_refl -> UIP_refl_on_ x.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.UIP_on__UIP_refl_on".
intro UIP; red; intros; symmetry; apply UIP.
Qed.
Lemma UIP__UIP_refl : UIP_ -> UIP_refl_.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.UIP__UIP_refl".
       exact ((fun UIP x p => @UIP_on__UIP_refl_on x (UIP x x eq_refl) p)).
Qed.

Lemma UIP_refl_on__Streicher_K_on (x : U) (P : x = x -> Prop) :
UIP_refl_on_ x -> Streicher_K_on_ x P.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.UIP_refl_on__Streicher_K_on".
intro UIP_refl; red; intros; rewrite UIP_refl; assumption.
Qed.
Lemma UIP_refl__Streicher_K : UIP_refl_ -> Streicher_K_.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.UIP_refl__Streicher_K".
       exact ((fun UIP_refl x P => @UIP_refl_on__Streicher_K_on x P (UIP_refl x))).
Qed.

Lemma Streicher_K_on__eq_rect_eq_on (p : U) (P : U -> Type) (x : P p) :
Streicher_K_on_ p (fun h => x = rew -> [P] h in x)
-> Eq_rect_eq_on p P x.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.Streicher_K_on__eq_rect_eq_on".
intro Streicher_K; red; intros.
apply Streicher_K.
reflexivity.
Qed.
Lemma Streicher_K__eq_rect_eq : Streicher_K_ -> Eq_rect_eq.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.Streicher_K__eq_rect_eq".
       exact ((fun Streicher_K p P x => @Streicher_K_on__eq_rect_eq_on p P x (Streicher_K p _))).
Qed.

End Equivalences.

Theorem UIP_shift_on (X : Type) (x : X) :
UIP_refl_on_ X x -> forall y : x = x, UIP_refl_on_ (x = x) y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.UIP_shift_on".
intros UIP_refl y.
rewrite (UIP_refl y).
intros z.
assert (UIP:forall y' y'' : x = x, y' = y'').
{ intros. apply eq_trans with (eq_refl x). apply UIP_refl.
symmetry. apply UIP_refl. }
transitivity (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
(eq_sym (UIP (eq_refl x) (eq_refl x)))).
- destruct z. destruct (UIP _ _). reflexivity.
- change
(match eq_refl x as y' in _ = x' return y' = y' -> Prop with
| eq_refl => fun z => z = (eq_refl (eq_refl x))
end (eq_trans (eq_trans (UIP (eq_refl x) (eq_refl x)) z)
(eq_sym (UIP (eq_refl x) (eq_refl x))))).
destruct z. destruct (UIP _ _). reflexivity.
Qed.
Theorem UIP_shift : forall U, UIP_refl_ U -> forall x:U, UIP_refl_ (x = x).
Proof. hammer_hook "EqdepFacts" "EqdepFacts.UIP_shift".  exact ((fun U UIP_refl x => @UIP_shift_on U x (UIP_refl x))). Qed.

Section Corollaries.

Variable U:Type.

Definition Inj_dep_pair_on (P : U -> Type) (p : U) (x : P p) :=
forall (y : P p), existT P p x = existT P p y -> x = y.
Definition Inj_dep_pair := forall P p x, Inj_dep_pair_on P p x.

Lemma eq_dep_eq_on__inj_pair2_on (P : U -> Type) (p : U) (x : P p) :
Eq_dep_eq_on U P p x -> Inj_dep_pair_on P p x.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_eq_on__inj_pair2_on".
intro eq_dep_eq; red; intros.
apply eq_dep_eq.
apply eq_sigT_eq_dep.
assumption.
Qed.
Lemma eq_dep_eq__inj_pair2 : Eq_dep_eq U -> Inj_dep_pair.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_eq__inj_pair2".  exact ((fun eq_dep_eq P p x => @eq_dep_eq_on__inj_pair2_on P p x (eq_dep_eq P p x))). Qed.

End Corollaries.

Notation Inj_dep_pairS := Inj_dep_pair.
Notation Inj_dep_pairT := Inj_dep_pair.
Notation eq_dep_eq__inj_pairT2 := eq_dep_eq__inj_pair2.

Module Type EqdepElimination.

Axiom eq_rect_eq :
forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p),
x = eq_rect p Q x p h.

End EqdepElimination.

Module EqdepTheory (M:EqdepElimination).

Section Axioms.

Variable U:Type.

Lemma eq_rect_eq :
forall (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.EqdepElimination.eq_rect_eq".  exact (M.eq_rect_eq U). Qed.

Lemma eq_rec_eq :
forall (p:U) (Q:U -> Set) (x:Q p) (h:p = p), x = eq_rec p Q x p h.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.EqdepTheory.eq_rec_eq".  exact ((fun p Q => M.eq_rect_eq U p Q)). Qed.

Lemma eq_dep_eq : forall (P:U->Type) (p:U) (x y:P p), eq_dep p x p y -> x = y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.EqdepTheory.eq_dep_eq".  exact ((eq_rect_eq__eq_dep_eq U eq_rect_eq)). Qed.

Lemma UIP : forall (x y:U) (p1 p2:x = y), p1 = p2.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.EqdepTheory.UIP".  exact ((eq_dep_eq__UIP U eq_dep_eq)). Qed.

Lemma UIP_refl : forall (x:U) (p:x = x), p = eq_refl x.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.EqdepTheory.UIP_refl".  exact ((UIP__UIP_refl U UIP)). Qed.

Lemma Streicher_K :
forall (x:U) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.EqdepTheory.Streicher_K".  exact ((UIP_refl__Streicher_K U UIP_refl)). Qed.

End Axioms.

Lemma inj_pair2 :
forall (U:Type) (P:U -> Type) (p:U) (x y:P p),
existT P p x = existT P p y -> x = y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.EqdepTheory.inj_pair2".  exact ((fun U => eq_dep_eq__inj_pair2 U (eq_dep_eq U))). Qed.

Notation inj_pairT2 := inj_pair2.

End EqdepTheory.

Lemma f_eq_dep :
forall U (P:U->Type) R p q x y (f:forall p, P p -> R p),
eq_dep p x q y -> eq_dep p (f p x) q (f q y).
Proof. hammer_hook "EqdepFacts" "EqdepFacts.f_eq_dep".
intros * []. reflexivity.
Qed.

Lemma eq_dep_non_dep :
forall U P p q x y, @eq_dep U (fun _ => P) p x q y -> x = y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.eq_dep_non_dep".
intros * []. reflexivity.
Qed.

Lemma f_eq_dep_non_dep :
forall U (P:U->Type) R p q x y (f:forall p, P p -> R),
eq_dep p x q y -> f p x = f q y.
Proof. hammer_hook "EqdepFacts" "EqdepFacts.f_eq_dep_non_dep".
intros * []. reflexivity.
Qed.

Arguments eq_dep  U P p x q _ : clear implicits.
Arguments eq_dep1 U P p x q y : clear implicits.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Y P Z Q Qprime Cprime X U V : Universe, ((wd_ A Y /\ (wd_ P Y /\ (wd_ Q Y /\ (wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ P Q /\ (wd_ A Z /\ (wd_ B Y /\ (wd_ Y Qprime /\ (wd_ Qprime Cprime /\ (wd_ Y Z /\ (wd_ Z X /\ (wd_ C Y /\ (wd_ P C /\ (wd_ Y Cprime /\ (wd_ Q C /\ (wd_ Q Qprime /\ (wd_ C Cprime /\ (wd_ C X /\ (wd_ X Y /\ (wd_ X Cprime /\ (wd_ Z Q /\ (wd_ Z Qprime /\ (wd_ P A /\ (col_ P Y Q /\ (col_ P Y C /\ (col_ P Q C /\ (col_ Y Q C /\ (col_ A Y B /\ (col_ A Y Z /\ (col_ A B Z /\ (col_ Y B Z /\ (col_ Y Qprime Cprime /\ (col_ Z Y X /\ (col_ A B X /\ (col_ U A B /\ (col_ V C X /\ (col_ Q Z Qprime /\ col_ X C Cprime))))))))))))))))))))))))))))))))))))))) -> col_ U Y Z)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Init.Prelude.
Require Import Coq.Setoids.Setoid.

Axiom incr_Some : option nat -> option nat.
Axiom eqn : forall n, incr_Some (Some n) = Some (S n).

Fixpoint pln (n : nat) : option nat :=
  match n with
  | O => Some O
  | S n => incr_Some (pln n)
  end.

Goal pln 1000 = Some 1000.
  Time cbv [pln]. Fail Timeout 60 (rewrite_strat (bottomup (eqn))). Abort.