(* PREAMBLE *)

From compcert.cfrontend           Require Csem.
From compcert.common              Require Values.
From compcert.lib                 Require Coqlib.

From trancert.lib                 Require All.
From trancert.properties.memory   Require Permissions.
From trancert.simulations.memory.bijection
                                  Require Def ToInjection.

Import lib.All
       bijection.Def bijection.AST
       Coqlib bijection.ToInjection
       common.Values
       Values.Val
       memory.Permissions
       Memory Mem.

Section Store.

  Theorem store_mapped_biject:
    forall M (chunk : AST.memory_chunk) (m1 : mem)
      (b1 : block) (ofs : Z) (v1 : val)
      (n1 m2 : mem) (b2 : block) (v2 : val),
      biject M m1 m2 ->

      store chunk m1 b1 ofs v1 = Some n1 ->
      m_fwd M b1 = Some b2 ->
      biject_value (m_fwd M) v1 v2 ->

      exists n2 : mem,
        store chunk m2 b2 ofs v2 = Some n2 /\
        biject M n1 n2.
  Proof.
    intros M chunk m1 b1 ofs v1 n1 m2 b2 v2 Hbiject Hstore Hf Hmap.

    assert (Hinj: Val.inject (m_fwd M) v1 v2) by exact (biject_value_inject (m_fwd M) v1 v2 Hmap).

    destruct Hbiject.
    exploit store_mapped_inject; try eapply mb_inj__fwd; eauto.
    eapply embedding_meminj_some. eassumption.
    rewrite Z.add_0_r.
    intros (n2 & Hstore' & Hinject').

    exploit store_mapped_inject; try eapply mb_inj__bwd; eauto.
    {
      apply M in Hf.
      eapply embedding_meminj_some. eassumption.
    }
    {
      eapply biject_value_symm in Hmap; eauto; last by apply M.
      by eapply biject_value_inject; eassumption.
    }

    rewrite Z.add_0_r.
    intros (n3 & Hstore'' & Hinject'').
    rewrite Hstore in Hstore''. inv Hstore''.

    exists n2.
    split; auto.
    econstructor; eauto.
    erewrite nextblock_store; eauto.
    erewrite nextblock_store; eauto.
  Qed.

  (** Modifying a block which is not mapped by bijection. *)
  Theorem store_unmapped_biject:
    forall M (chunk : AST.memory_chunk) (m1 : mem)
           (b1 : Values.block) (ofs : Z) (v1 : Values.val)
           (n1 m2 : mem),
      biject M m1 m2 ->
      store chunk m1 b1 ofs v1 = Some n1 ->
      m_fwd M b1 = None ->
      biject M n1 m2.
  Proof.
    intros until m2.
    intros [] Hstore Hf.
    constructor; auto.
    - by erewrite nextblock_store; eauto.
    - exploit store_unmapped_inject; [eapply mb_inj__fwd| | | ]; eauto.
      by eapply embedding_meminj_none.
    - exploit store_outside_inject; [eapply mb_inj__bwd | | | ]; eauto.
      intros b' delta ofs' H H0 H1.
      apply embedding_meminj_none in Hf.
      unfold to_meminj, option_map in *.
      repeat option_cases.
      inv H.
      apply M in Heq.
      congruence.
  Qed.

  (** Modifying a block which is not mapped by bijection. *)
  Theorem store_outside_biject:
    forall M (m1 m2 : mem) (chunk : AST.memory_chunk)
      (b : Values.block) (ofs : Z) (v : Values.val) (m2' : mem),
      biject M m1 m2 ->
      (forall (b' : Values.block) (ofs' : Z),
          m_fwd M b' = Some b ->
          perm m1 b' ofs' Cur Readable ->
          ~ ofs <= ofs' < ofs + Memdata.size_chunk chunk)%Z ->
      store chunk m2 b ofs v = Some m2' ->
      biject M m1 m2'.
  Proof.
    intros M m1 m2 chunk b ofs v m2' [] Hcond Hstore.
    constructor; auto.
    - erewrite nextblock_store; eauto.
    - eapply store_outside_inject ; eauto.
      intros b' delta ofs' H H0 H1.
      edestruct to_meminj_delta; eauto.
      subst delta.
      rewrite Z.add_0_r in H1.
      eapply Hcond; eauto.
    - eapply store_unmapped_inject; eauto.
      destruct (to_meminj (m_bwd M) b) eqn: Hg; auto.
      destruct p.
      edestruct to_meminj_delta; eauto. subst z.
      exfalso.
      eapply M in H.
      eapply Hcond with (ofs' := ofs) in H.
      eapply H; destruct chunk; simpl; omega.
      replace (ofs) with (ofs + 0)%Z; last by rewrite Z.add_0_r.
      eapply perm_inject; eauto.
      eapply store_valid_access_3 in Hstore; eauto.
      unfold valid_access in *.
      decomp.
      eapply perm_read_from_writable; eauto.
      destruct chunk; simpl; omega.
  Qed.

End Store.

(** ** [storebytes] commutation *)

Section Storebytes.

  (** Parallel [storebytes] in bijected memories. *)
  Theorem storebytes_mapped_biject:
    forall M (m1 : mem) (b1 : Values.block)
           (ofs : Z) (bytes1 : list Memdata.memval) (n1 m2 : mem)
           (b2 : Values.block) (bytes2 : list Memdata.memval),
      biject M m1 m2 ->
      storebytes m1 b1 ofs bytes1 = Some n1 ->
      m_fwd M b1 = Some b2 ->
      list_forall2 (biject_memval (m_fwd M)) bytes1 bytes2 ->
      exists n2 : mem, storebytes m2 b2 ofs bytes2 = Some n2 /\ biject M n1 n2.
  Proof.
    intros until bytes2.
    intros [] Hstore Hf Hlist.
    edestruct storebytes_mapped_inject as (n2 & Hstore2 & Hinject); try eapply mb_inj__fwd; eauto.
    { eapply embedding_meminj_some. eassumption. }
    { eapply list_forall2_imply; eauto 2. intros. by apply biject_memval_inject. }
    rewrite Z.add_0_r in Hstore2.
    exists n2.
    split; auto.
    constructor; auto.
    - by erewrite nextblock_storebytes; eauto 2.
    - erewrite nextblock_storebytes; eauto 2.
    - edestruct storebytes_mapped_inject as (n3 &Hstore' & Hinject'); try eapply mb_inj__bwd; eauto.
      + by apply M in Hf; apply embedding_meminj_some; eauto.
      + eapply list_forall2_inv in Hlist; eauto.
        intros a1 a2 H.
        apply biject_memval_inject.
        eapply biject_memval_symm; eauto.
        by apply M.
      + rewrite -> Z.add_0_r in *.
        rewrite Hstore' in Hstore. by autoinj.
  Qed.

  (** [storebytes] in a discarded block. *)
  Theorem storebytes_unmapped_biject:
    forall M (m1 : mem) (b1 : Values.block)
      (ofs : Z) (bytes1 : list Memdata.memval) (n1 m2 : mem),
      biject M m1 m2 ->
      storebytes m1 b1 ofs bytes1 = Some n1 ->
      m_fwd M b1 = None ->
      biject M n1 m2.
  Proof.
    intros M m1 b1 ofs bytes1 n1 m2 [] Hstore Hf.
    constructor; auto.
    - erewrite nextblock_storebytes; eauto.
    - eapply storebytes_unmapped_inject in Hstore; eauto.
      by eapply embedding_meminj_none.
    - exploit storebytes_outside_inject; eauto.
      intros b' ofs' _ H _ _.
      apply meminj_embedding_some in H.
      apply M in H.
      congruence.
  Qed.

  (** Auxiliary lemma: [storebytes] when a list of values to store is empty *)
  Lemma storebytes_outside_biject_nil:
    forall M (m1 m2 : mem) (b : Values.block)
           (ofs : Z) (m2' : mem),
      biject M m1 m2 ->
      storebytes m2 b ofs nil = Some m2' ->
      biject M m1 m2'.
  Proof.
    intros M m1 m2 b ofs m2' [] H0.
    constructor; auto.
    - erewrite nextblock_storebytes; eauto.
    - eapply storebytes_outside_inject; eauto.
      intros b' delta ofs' H H1 H2.
      exploit to_meminj_delta; eauto.
      intros. decomp. subst. simpl in *.
      rewrite Z.add_0_r in H5 H2.
      omega.
    - simpl in *.
      constructor.
      destruct mb_inj__bwd.
      + constructor.
        * apply storebytes_access in H0.
          eauto.
          destruct mi_inj0.
          intros. unfold perm in *.
          by rewrite H0 in H1; eauto.
        * intros.
          apply to_meminj_delta in H.
          decomp. subst.
          apply Z.divide_0_r.
        * intros.
          pose proof H0 as Hperm.
          apply storebytes_access in Hperm.
          apply storebytes_mem_contents in H0.
          apply to_meminj_delta in H; decomp; subst.
          rewrite H0.
          simpl.
          rewrite Maps.PMap.gsident.
          destruct mi_inj0.
          eapply mi_memval0; eauto.
          ** by eapply embedding_meminj_some.
          ** unfold perm in *.
             by rewrite -Hperm.
    + unfold valid_block in *.
      erewrite nextblock_storebytes; eauto.
      intros b0 H.
      destruct mb_inj__bwd.
        by eapply mi_freeblocks0.
    + intros b0 b' delta H.
      destruct mb_inj__bwd.
      by eapply mi_mappedblocks0; eauto.
    + destruct mb_inj__bwd.
      unfold meminj_no_overlap.
      intros b1 b1' delta1 b2 b2' delta2 ofs1 ofs2 H H1 H2 H3 H4.
      apply storebytes_access in H0.
      unfold perm in *.
      rewrite H0 in H3 H4.
      eapply mi_no_overlap0; eauto.
    + intros b0 b' delta ofs0 H H1.
      destruct mb_inj__bwd. unfold perm in *.
      apply storebytes_access in H0.
        by rewrite H0 in H1; eauto.
    + intros b1 ofs0 b2 delta k p H H1.
      destruct mb_inj__bwd. unfold perm in *.
      apply storebytes_access in H0.
        by rewrite H0; eauto.
  Qed.

  (** [storebytes] into a block without preimage. *)
  Theorem storebytes_outside_biject:
    forall M (m1 m2 : mem) (b : Values.block)
           (ofs : Z) (bytes2 : list Memdata.memval) (m2' : mem),
      biject M m1 m2 ->

      (forall (b' : Values.block) (ofs' : Z),
          m_fwd M b' = Some b ->
          perm m1 b' ofs' Cur Readable ->
          ~ ofs <= ofs'< ofs + Z.of_nat (length bytes2) )%Z ->

      storebytes m2 b ofs bytes2 = Some m2' ->
      biject M m1 m2'.
  Proof.
    intros M m1 m2 b ofs bytes2 m2' H Hcond Hstore.
    destruct bytes2; [ eapply storebytes_outside_biject_nil; eauto|].

    destruct H.

    constructor; auto.
    - erewrite nextblock_storebytes; eauto.
    - eapply storebytes_outside_inject in Hstore; eauto.
      intros b' delta ofs' H H0 H1.
      eapply Hcond; simpl; eauto 2.
      + by eapply meminj_embedding_some; eauto.
      + edestruct to_meminj_delta; eauto. subst.
        rewrite Z.add_0_r in H1.
        simpl in *.
        omega.
    - exploit storebytes_unmapped_inject; eauto.
      destruct (m_bwd M b) eqn: Hg; auto; last by eapply embedding_meminj_none.
      exfalso.
      pose proof Hg as Hf.
      apply M in Hf.
      eapply (Hcond p ofs); eauto.
      + apply storebytes_range_perm in Hstore.
        eapply range_perm_inj with (delta:=0%Z) in Hstore; try by (eapply embedding_meminj_some; eapply Hg).
        * repeat rewrite Z.add_0_r in Hstore.
          eapply perm_read_from_writable in Hstore; eauto.
          simpl. rewrite Zpos_P_of_succ_nat . omega.
        * eapply mb_inj__bwd.
      + simpl.
        rewrite Zpos_P_of_succ_nat .
        omega.
  Qed.

End Storebytes.


(* We show that the bin product of a presentable  signature with the tautological  signature
is presentable (actually it is also true of any bin products of presentable  arities)

- if a category is distributive, then the functor category  also, the
Left module category also and the ()-signature category as well.
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
(* Require Import UniMath.SubstitutionSystems.FromBindingSigsToMonads_Summary. *)
Require Import UniMath.SubstitutionSystems.BindingSigToMonad.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SignatureCategory.
Require Import UniMath.SubstitutionSystems.BinProductOfSignatures.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.HSET.All.

Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.EpiFacts.
Require Import UniMath.Combinatorics.Lists.
Require Import UniMath.CategoryTheory.whiskering.
Require Import Modules.Prelims.lib.

Require Import Modules.Prelims.CoproductsComplements.
Require Import Modules.Signatures.Signature.
Require Import Modules.Signatures.SigWithStrengthToSignature.
Require Import Modules.Signatures.BindingSig.
Require Import Modules.Signatures.PresentableSignature.
Require Import Modules.Signatures.SignatureBinproducts.
Require Import Modules.Signatures.SignatureCoproduct.
Require Import Modules.Signatures.SignaturesColims.
Require Import Modules.Signatures.PresentableSignatureCoproducts.
Require Import Modules.Signatures.HssSignatureCommutation.

Require Import Modules.Prelims.LModulesBinProducts.
Require Import Modules.Prelims.LModulesCoproducts.
Require Import Modules.Prelims.BinProductComplements.

Require Import UniMath.CategoryTheory.Monads.Monads.
Require Import UniMath.CategoryTheory.Monads.LModules.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
(* Require Import Modules.Signatures.FullArToRaw. *)
Open Scope cat.

(* inspiré de PresentableSignatureCoproducts pour les coproduits *)
(* TODO faire une section à part *)

Section CoprodAr.
  Context {C : category} (bp : BinProducts C) (bcp : BinCoproducts C)
          (T : Terminal C) (cp : ∏ (I:hSet), Coproducts I C).

  Local Notation PO := (BinProductObject _). Local Notation CPO := (CoproductObject _ _).
  Let MOD R  := category_LModule (B:= C) R C.
  Let Sig_bp := signature_BinProducts  bp.
  Let Sig_cp I := signature_Coproducts  (cp I).

  Let bpFunct :=
    (BinProducts_functor_precat C C bp).
  Let cpFunct (Z : hSet) :=
    (Coproducts_functor_precat Z C C (cp Z)).

  Let bpMOD (R : Monad C) :=
    (LModule_BinProducts R bp).

  Let cpMOD (R : Monad C) (Z : hSet) :=
    (LModule_Coproducts C R (cp Z) ).

  Let toSig sig :=
    (BindingSigToSignature bp
                           bcp T sig
                           (cp ((BindingSigIndexhSet sig)) )).

  (** * distributivity lifts to functor categories, left modules categories, signature category

TODO move these lemmas in a different file
   *)
Hypothesis (isDistC : ∏ (I : hSet) , bp_coprod_isDistributive bp
                                         (cp I)).
(* TODO déplacer ces lemms qq part *)
Lemma functor_cat_isDistributive (Z : hSet) (R : Monad C) :
  bp_coprod_isDistributive
    (C :=  [C,C])
    (bpFunct)
    (cpFunct Z)  .
Proof.
  intros B X.
  apply functor_iso_if_pointwise_iso.
  intro c.
  apply isDistC.
Defined.

Lemma LMod_isDistributive_inv_laws (Z :hSet) (R : Monad C) B (X : LModule _ _) :
  LModule_Mor_laws R (T := PO (bpMOD R (CPO (cpMOD R Z B)) X) : LModule _ _)
                   (T' := CPO (cpMOD R Z (fun o => PO (bpMOD R _ _) )):LModule _ _)
                   (inv_from_iso
                           (iso_from_isDistributive _ _
                                                    (functor_cat_isDistributive Z R )
                                                    (fun z => (B z : LModule _ _) : functor _ _)
                                                    (X : functor _ _))).
Proof.
  intro c.
  cbn.
  repeat rewrite id_right.
  unfold LModule_coproduct_mult_data; cbn.
  apply iso_inv_on_right.
  rewrite assoc.
  apply iso_inv_on_left.
  set (i :=   bp_coprod_mor (cpMOD R _ B)
                            (fun o => bpMOD R _ _) (bpMOD R _ X) (cpMOD R _ _)).
  apply  ( LModule_Mor_σ R i).
Qed.

Definition LMod_isDistributive_inv (Z :hSet) (R : Monad C) B (X : LModule _ _) :
  LModule_Mor R
              (PO (bpMOD R (CPO (cpMOD R Z B)) X) : LModule _ _)
              (CPO (cpMOD R Z (fun o => PO (bpMOD R _ _) )):LModule _ _) :=
  _ ,, LMod_isDistributive_inv_laws Z R B X.

Lemma LMod_isDistributive_is_inverse (Z : hSet) R B X :
  is_inverse_in_precat
    (bp_coprod_mor (LModule_Coproducts C R (cp Z) B)
       (λ o : Z, LModule_BinProducts R bp (B o) X)
       (LModule_BinProducts R bp (CPO (LModule_Coproducts C R (cp Z) B)) X)
       (LModule_Coproducts C R (cp Z)
          (λ o : Z, PO (LModule_BinProducts R bp (B o) X))))
    (LMod_isDistributive_inv Z R B X).
Proof.
    set (h := (iso_from_isDistributive _ _
                                          (functor_cat_isDistributive Z R)
                                          ((B : Z -> LModule _ _) : Z -> functor _ _)
                                          ((X : LModule _ _) : functor _ _)
                 )).
    split; apply LModule_Mor_equiv; try apply homset_property.
    + cbn; apply (iso_inv_after_iso h).
    + cbn; apply (iso_after_iso_inv h).
Qed.

Lemma LMod_isDistributive (Z : hSet) (R : Monad C) :
  bp_coprod_isDistributive
    (C :=  MOD R)
    (LModule_BinProducts R bp)
    (LModule_Coproducts C R (cp Z) )  .
Proof.
  intros B X.
  eapply is_iso_qinv.
  apply LMod_isDistributive_is_inverse.
Defined.

(* TODO : déplacer ce lemme qq part *)
Lemma Sig_isDistributive_inv_law (Z :hSet) (X : signature C) (B : Z -> signature C) :
  is_signature_Mor  (PO (Sig_bp  (CPO (Sig_cp  Z B)) X) : signature _ )
                   ( CPO (Sig_cp  Z (fun o => PO (Sig_bp  _ _) )):signature _)
                   (fun R => LMod_isDistributive_inv Z R (fun z => B z R) (X R)).
Proof.
  intros R S f.
    set (h := fun R => (iso_from_isDistributive _ _
                                          (functor_cat_isDistributive Z R)
                                          (fun z => B z R : functor _ _)
                                          ((X R : LModule _ _) : functor _ _)
                 )).
    apply pathsinv0.
  apply (iso_inv_on_right _ _ _ (h R)).
  rewrite assoc.
  apply (iso_inv_on_left _ _ _ _ (h S)).
  set  (i :=   bp_coprod_mor (Sig_cp _ B)
                            (fun o => Sig_bp _ _) (Sig_bp _ X) (Sig_cp  _ _)).
  apply pathsinv0.
  apply (signature_Mor_ax i f) .
Qed.

Definition Sig_isDistributive_inv (Z :hSet) (X : signature C) (B : Z -> signature C) :
  signature_Mor  (PO (Sig_bp  (CPO (Sig_cp  Z B)) X) : signature _ )
             ( CPO (Sig_cp  Z (fun o => PO (Sig_bp  _ _) )):signature _) :=
  _ ,, Sig_isDistributive_inv_law Z X B.

Lemma Sig_isDistributive_is_inverse (Z : hSet) (B : Z -> signature C) (X :signature C) :
  is_inverse_in_precat
    (bp_coprod_mor (Sig_cp Z B)
       (λ o : Z, Sig_bp (B o) X)
       (Sig_bp (CPO (Sig_cp ( Z) B)) X)
       (Sig_cp Z (λ o : Z, PO (Sig_bp  (B o) X))))
    (Sig_isDistributive_inv Z X B).
Proof.
    set (h := fun R => (iso_from_isDistributive _ _
                                          (LMod_isDistributive Z R)
                                          (fun z => B z R  )
                                          ((X R : LModule _ _) )
                 )).
    set (h' := fun R => (iso_from_isDistributive _ _
                                          (functor_cat_isDistributive Z R)
                                          (fun z => B z R : functor _ _)
                                          ((X R : LModule _ _) : functor _ _)
                 )).
    split; apply signature_Mor_eq;   intro R; apply LModule_Mor_equiv;
    try apply homset_property.
    + cbn; apply (iso_inv_after_iso (h' R)).
    + cbn; apply (iso_after_iso_inv (h' R)).
Qed.

Lemma Sig_isDistributive (Z : hSet)  :
  bp_coprod_isDistributive
    (C :=  signature_category )
    Sig_bp
    (Sig_cp  Z).
Proof.
  intros B X.
  eapply is_iso_qinv.
  apply Sig_isDistributive_is_inverse.
Defined.
  (** * The product of a presentable signature with the tautological signature is presentable

It requires that the base category is distributive and that bin products
of epimorphisms are epimorphisms in the functor category.

*)
Definition isEpiBinProd :=
   ∏ (X X' Y Y' : functor C C) (f : nat_trans X X') (g : nat_trans Y Y')
                        (epif : isEpi (C :=  [C,C]) f)(epig : isEpi (C :=  [C,C]) g),
                      isEpi (C:=[C,C]) (BinProductOfArrows _ (bpFunct _ _)
                                                           (bpFunct _ _) f g).

Hypothesis
  (epiBinProd : isEpiBinProd).

  Context {a : signature C} .
  Context (pres_a : isPresentable bp bcp T cp a).
  Let Ba : BindingSig := p_sig pres_a.
  Let I : hSet := BindingSigIndexhSet Ba.
  Let Sa' : I -> list nat := BindingSigMap Ba.

  Let Fa :  signature_Mor (sigWithStrength_to_sig (C:= C) (toSig Ba)) a := p_mor pres_a.
  Let epiFa : ∏ (R : Monad C), (isEpi (C := [_, _]) (pr1 (Fa R))) :=
    epi_p_mor pres_a.

  Local Notation SIG := (Signature_category C C C).

  (**
[[ a_1, a_2,.. ] , [b_1, b_2, ...], ..]
becomes
[[0 , a_1, a_2,.. ] , [0 , b_1, b_2, ...], ..]
*)
  Let b : signature _ := PO (Sig_bp a tautological_signature).
  Definition har_binprodR_p_sig : BindingSig :=
    make_BindingSig (BindingSigIsaset (p_sig pres_a))
                 (λ i : BindingSigIndex (p_sig pres_a), cons 0 (BindingSigMap (p_sig pres_a) i)).

  Let p_alg_ar' := sigWithStrength_to_sig (C:=C) (toSig har_binprodR_p_sig).

  Let FuncCP :=
    Coproducts_functor_precat  (BindingSigIndex (p_sig pres_a))
                               C C (cp (BindingSigIndexhSet (p_sig pres_a))) .

  Let FuncBP :=
    BinProducts_functor_precat C C bp .

  Let cpSig  : Coproducts I SIG
    := Coproducts_Signature_category _ C _ _ (cp I).
  Let bpSig  : BinProducts  SIG
    := BinProducts_Signature_category _ C  bp _.

  (* TODO : move this somewhere else *)
  Lemma Const1Sig_isTerminal : isTerminal SIG (SignatureExamples.ConstConstSignature C C _ T).
  Proof.
    intro S.
    use make_iscontr.
    - use tpair.
      {
      use make_nat_trans.
      + intro x.
        use make_nat_trans.
        * intro c.
          apply TerminalArrow.
        * intros z z' f.
          etrans;[apply TerminalArrowUnique|]; apply pathsinv0; apply TerminalArrowUnique.
      + intros c c' f.
        apply nat_trans_eq; [  apply homset_property|].
        intro z.
          etrans;[apply TerminalArrowUnique|]; apply pathsinv0; apply TerminalArrowUnique.
      }
      cbn.
      intros X Y .
      apply nat_trans_eq; [  apply homset_property|].
      intro z.
      etrans;[apply TerminalArrowUnique|]; apply pathsinv0; apply TerminalArrowUnique.
    - intros f.
      apply SignatureMor_eq.
      apply nat_trans_eq; [  apply (homset_property [C,C])|].
      intro z.
      apply nat_trans_eq; [  apply homset_property|].
      intro z'.
      apply TerminalArrowUnique.
  Defined.

  Definition TerminalSignature : Terminal SIG := make_Terminal _ Const1Sig_isTerminal.

  Lemma Signature_to_signature_cons_iso n ar :
    iso (C := SIG) ( (Arity_to_Signature bp bcp T (cons n ar)))
        (BinProductObject _ (bpSig
                               (precomp_option_iter_Signature bcp T n)
                               (Arity_to_Signature bp bcp T ar)
        )).
  Proof.
    apply iso_inv_from_iso.
    revert  n.
    pattern ar.
    apply list_ind; clear ar.
    - intro n.
      cbn -[bpSig].
      apply (BinProductWith1_iso  (TerminalSignature) (bpSig _ _)).
    - intros n ar .
      (* revert n. *)
      intros HI n2.
      apply identity_iso.
  Defined.

Definition har_binprodR_commute_mor_mod
  :  iso (C := signature_category)  (p_alg_ar' )
                ((PO (Sig_bp (sigWithStrength_to_sig (C := C) (toSig Ba)) tautological_signature) : signature C)
                ) .
Proof.
  unfold p_alg_ar'.
  eapply iso_comp.
  {
    (* apply morphism_from_iso. *)
    eapply iso_comp;[ apply coprod_sigs_har_iso|].
    eapply iso_comp.
    {
      eapply (coprod_pw_iso (C:=signature_category) _ (Sig_cp  I _)).
      intro o.
      eapply iso_comp.
      {
        eapply (functor_on_iso (sigWithStrength_to_sig_functor)).
        apply Signature_to_signature_cons_iso.
      }
      eapply (iso_comp (C := signature_category)).
      - apply binprod_sigs_har_iso.
      - apply BinProduct_commutative_iso.
      (* - apply binprod_sigs_har_iso. *)
      (* - apply binprod_sigs_har_iso. *)
      (* (* eapply iso_comp. *) *)
      (* - apply binprod_sigs_har_iso. *)
      (* - apply BinProduct_commutative_iso. *)
    }

    apply (iso_from_isDistributive (C:=signature_category)).
    apply Sig_isDistributive.
  }
  apply BinProduct_pw_iso.
  - apply iso_inv_from_iso.
    (* eapply iso_comp. *)
    (* + eapply (functor_on_iso sigWithStrength_to_sig_functor). *)
    (*   apply Signature_to_signature_fold_iso. *)
    apply coprod_sigs_har_iso.
  - apply tauto_sigs_har_iso.
Defined.

  Definition har_binprodR_p_mor  : signature_Mor p_alg_ar' b.
    eapply (compose (C := signature_category)).
    - apply har_binprodR_commute_mor_mod.
    - apply BinProductOfArrows.
      + apply Fa.
      + apply identity.
  Defined.

  Lemma har_binprodR_epi_p_mor
        (R : Monad C) : isEpi (C := [_,_])
                                                     (har_binprodR_p_mor R : nat_trans _ _).
  Proof.
    apply (isEpi_comp ([C,C]) ((morphism_from_iso har_binprodR_commute_mor_mod
                        : signature_Mor _ _) R : nat_trans _ _)).
    - apply is_iso_isEpi.
      apply is_z_iso_from_is_iso.
      set (i := functor_on_iso (forget_Sig R) har_binprodR_commute_mor_mod).
       apply ( (functor_on_iso_is_iso _ _ (LModule_forget_functor R C)) _ _ i).
    - apply epiBinProd.
      + apply epiFa.
      + apply identity_isEpi.
  Qed.

  Definition har_binprodR_isPresentable : isPresentable bp bcp T cp b :=
    _ ,, _ ,, har_binprodR_epi_p_mor.

End CoprodAr.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(* ************************************************************************** *)

(*

ChangeLog:

  1. we only have PMTs for log blocks. While in the previous version, every
     block has a PMT (20140523)
  2. alloc_block routine doesn't update BIT, because it doesn't know the new allocated
     block is a data block or a log block  (20140523)
*)

(* ************* ************************************* *****)
(* ftl interface *)

Require Import ListEx.
Require Import Monad.
Require Import Data.

Require Import Params.
Require Import Nand.

(*

       BFTL Flash Translation Layer (Version 0.1)

  BFTL is a simplified verion of BAST[1], which is an FTL algorithm
proposed by Jesung Kim et.al. The classic algorithm uses a mapping
table at the block level, while using log blocks . BAST uses simple
techniques to assure the consistency of FTL meta-data under unexpected
power-loss.

  We build a simplified version of BAST, called BFTL, in Coq, in order
to verify the core algorithm of the FTL. The BFTL is runnable in Coq
and we can test the algorithm by the command 'Eval'. But we haven't
started to work on the feature of power-loss recovery yet. The
interface of BFTL consists of only three operations, ftl_init(),
ftl_read() and ftl_write().

[1] A space-efficient flash translation layer for compact flash systems.

 *)

Definition bvalid_logical_block_no (lbn: block_no) := blt_nat lbn MAX_LOGICAL_BLOCKS.

(* ************* ************************************* *****)
(*

* FTL Data Structures

** Block mapping table

  FTL translates a logical address (lbn, page offset) to a phyiscal page number
via a mapping table. BFTL adopts a block-level mapping table and transfer
a logical block number into two phyiscal block numbers. One of those is a phyiscal
block for data, the other is for logging. Each entry in the table is a pair of
physical block numbers. The block mapping table is defined as a list of entries.

  Two operations are provided for the block mapping table, bmt_get and bmt_update.
Both of them return either a value or none.

*)

Definition bmt_record := prod (option block_no) (option block_no).

Definition block_mapping_table := list bmt_record.

Definition bmt_get (bmt: block_mapping_table) (lbn: block_no) : option bmt_record :=
  list_get bmt lbn.

Definition bmt_update (bmt: block_mapping_table) (lbn: block_no) (record : bmt_record)
     : option block_mapping_table :=
  match record with
    | (d, l) =>
      (list_set bmt lbn (d, l))
  end.

Definition bmt_len (bmt: block_mapping_table) : nat :=
  length bmt.

(*

** block info table

  Different from the original BAST, BFTL uses a separate table to store the block
information, including block state, erase counter, page mapping table in each block,
and the programmable page.

  In BFTL, a block is invalid if all pages in the block are invalid, and it could
be erased when needed. A block is erased if it isn't programmed after erased. A
block is in the state of "used" if it is used as a data block or a log block. The
used state is bound with a block number that reversely links to the logical block
number in the block mapping table. It is assured that any used block presents in
the block mapping table.

  There is one page mapping table for each block in the block info table. Each
entry of the table is the logical page offset of the logical address. For instance,
in a log block (b0), the page mapping table is like

   [..., 1,0,1,2,2,3,1],

and the pages in the block are:

   [..., d0,d1,d2,d3,d4,d5,d6],

the logical address, (lbn, 2), will be translated to a physical (b0, _).

*)

Inductive pmt_entry : Set :=
  | pmte_empty
  | pmte_log (off: page_off).

Definition page_mapping_table := list pmt_entry.

Inductive ftl_block_state : Set :=
  | bs_invalid
  | bs_erased
  | bs_data (lbn: block_no)
  | bs_log (lbn: block_no) (pmt: page_mapping_table).

Definition pmt_len (pmt: page_mapping_table) : nat :=
  length pmt.

Definition pmt_get (pmt: page_mapping_table) (loc: page_off) : option pmt_entry :=
  list_get pmt loc.

Definition beq_pmt_entry (pe1 pe2: pmt_entry) : bool :=
  match pe1, pe2 with
    | pmte_empty, pmte_empty => true
    | pmte_log off1, pmte_log off2 => beq_nat off1 off2
    | _, _ => false
  end.

Definition pmt_find (pmt: page_mapping_table) (pe: pmt_entry) : option page_off :=
  list_find beq_pmt_entry pmt pe.

Definition pmt_find_rev (pmt: page_mapping_table) (pe: pmt_entry) : option page_off :=
  list_find_rev beq_pmt_entry pmt pe.

Definition pmt_update (pmt: page_mapping_table) (loc: page_off) (off: page_off)
   : option page_mapping_table :=
  list_set pmt loc (pmte_log off).

Definition blank_pmt : page_mapping_table := list_repeat_list PAGES_PER_BLOCK pmte_empty.

Record block_info : Set :=
  mk_bi {
      bi_state: ftl_block_state;
      bi_used_pages: nat;
      bi_erase_count: nat
    }.

Definition bi_set_state (bi : block_info) (bi_state : ftl_block_state) : block_info :=
  mk_bi bi_state (bi_used_pages bi) (bi_erase_count bi).

Definition block_info_table :=  list block_info.

Definition bit_get (bit: block_info_table) (b: block_no)
     : option block_info :=
  list_get bit b.

Definition bit_update (bit: block_info_table) (b: block_no) (bi: block_info)
      : option block_info_table :=
  list_set bit b bi.

(* In FTL, a block is initialized to be 'bs_invalid' *)
Definition blank_bi : block_info :=
  mk_bi bs_erased 0 0.

(*

** Free block queue

Free blocks are those not used, and each of them can be invalid or
erased (filled with \og{0xFF}). All the free blocks are put into a
queue, where a new allocated block is get from the head.

The number of free block queue is important. If it is below a certain
number, mBFTL will invoke GC process to free more blocks into the
queue.  Since new blocks are needed in the GC process, mBFTL is
required to keep the number of free blocks above a threshold.
Otherwise, the GC process will go stuck and mBFTL will run out of
blocks.

*)

Definition block_queue := list block_no.

Definition fbq_enq (fbq : block_queue) (b : block_no) : option (block_queue) :=
  Some (list_append fbq b).

Definition fbq_deq (fbq : block_queue) : option (prod block_no (block_queue)) :=
  match fbq with
    | nil => None
    | cons b fbq' => Some (b, fbq')
  end.

Definition fbq_in (fbq: list block_no) (pbn: block_no) : bool := list_inb beq_nat fbq pbn.

Definition fbq_get (fbq: list block_no) (i: nat) : option block_no := list_get fbq i.

Definition check_block_is_full (bi: block_info) : bool :=
  match blt_nat (bi_used_pages bi) PAGES_PER_BLOCK with
    | true => false
    | false => true
  end.

Record FTL : Set :=
  mk_FTL {
      ftl_bi_table: block_info_table;
      ftl_bm_table: block_mapping_table;
      ftl_free_blocks: block_queue
    }.

Definition ftl_update_bit (f: FTL) (bit: block_info_table) : option FTL :=
  ret mk_FTL bit (ftl_bm_table f) (ftl_free_blocks f).

Definition ftl_update_fbq (f: FTL) (fbq: block_queue) : option FTL :=
  ret mk_FTL (ftl_bi_table f) (ftl_bm_table f) fbq.

Inductive freebq_state : Set :=
  | fbqs_abundant
  (* | fbqs_needgc *)
  | fbqs_scarce.

(* IMPORTANT !!! *)
Definition check_freebq_count (freebq: block_queue): freebq_state :=
  match (ble_nat MIN_FREE_BLOCKS (length freebq)) with
    | false => fbqs_scarce
    | true => fbqs_abundant
  end.

Definition bit_init : block_info_table :=
  list_repeat_list BLOCKS blank_bi.

Definition bmt_init : block_mapping_table :=
  list_repeat_list MAX_LOGICAL_BLOCKS (None, None).

 (* check_good_blocks (i : nat) : block_queue := *)
 (*  match i with *)
 (*    | 0 => nil *)
 (*    | S i' => cons i' (check_good_blocks i') (* we assume all blocks are flawless *) *)
 (*  end. *)

Definition fbq_init : block_queue :=
  list_make_nat_list BLOCKS.

Definition ftl_init : FTL :=
  mk_FTL bit_init bmt_init fbq_init.

(*
errcode 2 : FTL inconsistent
*)
(*

  global invariants:

  pre-condition: (1) 0 <= lbn < MAX_LOGICAL_BLOCKS
                 (2) 0 <= poff < LOGICAL_PAGES_PER_BLOCK

*)

(*
  bk: the log block
  poff: the logical page address that we are looking for
  pgn: the next free page in the block

  @return: the physical offset of the page we are looking for

*)

Definition find_page_in_log_block (bi: block_info) (off: page_off) : option page_off :=
  match (bi_state bi) with
    | bs_log lbn pmt => (pmt_find_rev pmt (pmte_log off))
    | _ => None
  end.

Definition find_empty_page_in_block (bi: block_info): option page_off :=
  match blt_nat (bi_used_pages bi) PAGES_PER_BLOCK with
    | true => Some (bi_used_pages bi)
    | false => None
  end.

(* ****************************************************

   * ReadBlock/WriteBlock Operations
*)

Definition read_log_block (c: chip) (bi: block_info) (pbn_log: block_no) (off: page_off) : option data :=
  (* find the lastest log page for "poff" in 'bk' , return the log-location *)
  do loc <-- (find_page_in_log_block bi off);

  (* read the page from "loc" in pbn_log *)
  do [d, o] <-- (nand_read_page c pbn_log loc);

  (* return the data in the page *)
  ret d.

Definition read_data_block (c: chip) (pbn_data: block_no) (off: page_off) : option data :=
  (* read the page from "off" in pbn_data *)
  do [d, o] <-- (nand_read_page c pbn_data off);

  (* return the data in the page *)
  ret d.

Definition write_data_block (c: chip) (pbn_bi: block_info) (pbn: block_no)
           (loc: page_off) (d: data): option (prod chip block_info) :=
  (* write the data to "pbn#loc", return c' *)
  do c' <-- (nand_write_page c pbn loc d init_page_oob);

  (* return bi := <bi_state, used+1, ec> *)
  let bi' := mk_bi (bi_state pbn_bi) ((bi_used_pages pbn_bi)+1) (bi_erase_count pbn_bi)  in

  ret  (c', bi').

(* *)

Definition bi_lbn (bi: block_info) : option block_no :=
  match (bi_state bi) with
    | bs_log lbn pmt => Some lbn
    | bs_data lbn => Some lbn
    | _ => None
  end.

Definition bi_pm_table (bi: block_info) : option page_mapping_table :=
  match (bi_state bi) with
    | bs_log lbn pmt => Some pmt
    | _ => None
  end.

Definition write_log_block (c: chip) (pbn_bi: block_info) (pbn: block_no)
           (off: page_off) (d: data) : option (prod chip block_info) :=
  do loc <-- (find_empty_page_in_block pbn_bi);

  do c' <-- (nand_write_page c pbn loc d init_page_oob);

  do pmt <-- bi_pm_table pbn_bi;

  (* update pm_table: {loc --> off } *)
  do pmt' <-- pmt_update pmt loc off;

  do lbn <-- bi_lbn pbn_bi;

  let bi' := mk_bi (bs_log lbn pmt') ((bi_used_pages pbn_bi)+1)  (bi_erase_count pbn_bi) in
  ret (c', bi').

(* ****************************************************

* Alloc_Block

Allocation block routine, no GC yet. But I believe that it will be
not difficult to add a simple GC.

*)

Definition alloc_block (c: chip) (f: FTL) : option (prod block_no (prod chip FTL)) :=
  let bmt := ftl_bm_table f in
  let bit := ftl_bi_table f in
  let fbq := ftl_free_blocks f in
  match (check_freebq_count fbq) with
    | fbqs_abundant =>
        do [b, fbq'] <-- fbq_deq fbq;
        do bi_free <-- bit_get bit b;
        match bi_state bi_free with
          | bs_erased =>
              (* TODO:  we don't need to update bit. *)
              do bit' <-- bit_update bit b (mk_bi bs_erased 0 (bi_erase_count bi_free));
              ret (b, (c, (mk_FTL bit' bmt fbq')))
          | bs_invalid =>
              do c' <-- nand_erase_block c b;
              do bit' <-- bit_update bit b (mk_bi bs_erased 0 (1 + bi_erase_count bi_free));
              ret (b, (c', (mk_FTL bit' bmt fbq')))

          | bs_data _ => None

          | bs_log _ _ => None
        end

    | _ => None
  end.

(* ****************************************************

* Auxiliary Routines for update Meta-Data

*)

(*  The function (bit_set_state bit pbn st) :
      bit{pbn->bi},  bi' = bi{bs_state:=st},  bit'{pbn->bi'}
*)

Definition bit_set_state (bit: block_info_table) (pbn: block_no) (st: ftl_block_state)
  : option block_info_table :=
  do bi <-- bit_get bit pbn;
  do bi' <-- Some (mk_bi st (bi_used_pages bi) (bi_erase_count bi));
  do bit' <-- bit_update bit pbn bi';
  ret bit'.

Definition bit_get_bstate (f: FTL) (pbn: block_no) : option ftl_block_state :=
  do bi <-- bit_get (ftl_bi_table f) pbn;
  ret (bi_state bi).

(* ****************************************************

* Free_Block

Free a unused block back to the free block queue. It doesn't erase the data until FTL
tries to write new data into it.

*)

Definition free_block (bit: block_info_table) (fbq: block_queue) (pbn: block_no)
  : option (prod block_info_table (block_queue)) :=
  do bi <-- bit_get bit pbn;
  do bi' <-- Some (mk_bi bs_invalid (bi_used_pages bi) (bi_erase_count bi));
  do bit' <-- bit_update bit pbn bi';
  do fbq' <-- fbq_enq fbq pbn;
  ret (bit', fbq').

Definition zero_page := (zero_data PAGE_DATA_SIZE).

Fixpoint merge_block_fix (c: chip) (pl_bi: block_info) (pf_bi: block_info)
         (pd: option block_no) (pl: block_no) (pf: block_no) (* (D, L, F) *)
         (poi: nat) (* offset *) {struct poi} : option (prod chip block_info) :=
  match poi with
    | O => ret (c, pf_bi)

    | S poi' =>
           let off := poi' in
           (* firstly, write the pages with lower no *)
           do [c', pf_bi'] <-- (merge_block_fix c pl_bi pf_bi pd pl pf poi');
           match (read_log_block c' pl_bi pl off) with
             | Some d =>
                 write_data_block c' pf_bi' pf off d
             | None =>
               (
                 match pd with
                   | None =>
                       do [c'', pf_bi''] <-- write_data_block c' pf_bi' pf off zero_page;
                       ret (c'', pf_bi'')
                   | Some pbn_data =>
                     do d <-- (read_data_block c' pbn_data off); (* by Inv ##11 *)
                     do [c'', pf_bi''] <-- write_data_block c' pf_bi' pf off d;
                     ret (c'', pf_bi'')
                 end
               )
           end
  end.

Definition merge_block (c: chip) (f: FTL) (lbn : block_no) : option (chip * FTL) % type :=
  do bit <-- Some (ftl_bi_table f);
  do bmt <-- Some (ftl_bm_table f);
  do fbq <-- Some (ftl_free_blocks f);
  do entry_to_merge <-- bmt_get bmt lbn;
  match entry_to_merge with
    | (opt_bd, Some bl) =>
      do [bf, cfx] <-- alloc_block c f;
      do [c', f'] <-- Some cfx;
      do bit' <-- Some (ftl_bi_table f') ;
      do bmt' <-- Some (ftl_bm_table f');
      do fbq' <-- Some (ftl_free_blocks f');

      (* merge_block_fix *)
      do bi_log <-- bit_get bit' bl;
      do bi_free <-- bit_get bit' bf;
      do [c_m, bi_new_data] <-- merge_block_fix c' bi_log bi_free opt_bd bl bf PAGES_PER_BLOCK;
      do bmt_m <-- bmt_update bmt' lbn (Some bf, None);
      do bit_m <-- bit_update bit' bf
                              (bi_set_state bi_new_data (bs_data lbn));

      (* free_block bl *)
      do [bit_f, fbq_f] <-- free_block bit_m fbq' bl;

      match opt_bd with
        | None => ret (c_m, (mk_FTL bit_f bmt_m fbq_f))
        | Some bd =>
          (* free_block bd *)
          do [bit_f2, fbq_f2] <-- free_block bit_f fbq_f bd;
          ret (c_m, (mk_FTL bit_f2 bmt_m fbq_f2))
      end

    | (_, _) => None

  end.

(* ****************************************************

* FTL read rouine

*)

Definition FTL_read (c: chip) (f: FTL) (lbn : block_no) (off: page_off) : option data :=
  let bit := ftl_bi_table f in
  let bmt := ftl_bm_table f in
  test bvalid_page_off off;
  do bmt_entry <-- bmt_get bmt lbn;
  match bmt_entry with
    | (Some pbn_data, Some pbn_log) =>
      do pbn_log_bi <-- (bit_get bit pbn_log);
      match (read_log_block (c: chip) pbn_log_bi (pbn_log: block_no) (off: page_off)) with
       | Some d => ret d
       | None =>
        (
           do d <-- (read_data_block (c: chip) (pbn_data: block_no) off);
           ret d
        )
      end

    | (None, Some pbn_log) =>
      do pbn_log_bi <-- (bit_get bit pbn_log);
      match (read_log_block (c: chip) pbn_log_bi (pbn_log: block_no) (off: page_off)) with
       | Some d => ret d
       | None => ret zero_page
      end

    | (Some pbn_data, None) =>
       do d <-- (read_data_block (c: chip) (pbn_data: block_no) off);
       ret d
    | (None, None) => ret zero_page
  end.

Definition bmt_update_log (bmt: block_mapping_table) (lbn: block_no) (pbn: block_no)
  : option block_mapping_table :=
  do bme <-- bmt_get bmt lbn;
  do [data, log] <-- Some bme;
  do bme' <-- Some (data, Some pbn);
  do bmt' <-- bmt_update bmt lbn bme';
  ret bmt'.

Definition bmt_update_data (bmt: block_mapping_table) (lbn: block_no) (pbn: block_no)
  : option block_mapping_table :=
  do bme <-- bmt_get bmt lbn;
  do [data, log] <-- Some bme;
  do bme' <-- Some (Some pbn, log);
  do bmt' <-- bmt_update bmt lbn bme';
  ret bmt'.

(* ****************************************************

* FTL write rouine

*)

Definition FTL_write (c: chip) (f: FTL) (lbn : block_no) (poff: page_off) (d: data)
             : option (prod chip FTL) :=
  (* aux def *)
  test bvalid_page_off poff;
  let bit := ftl_bi_table f in
  let bmt := ftl_bm_table f in
  let fbq := ftl_free_blocks f in
  do bmt_entry <-- bmt_get bmt lbn;  (* by Inv #10. *)
  match bmt_entry with
    (* 1st case: {lbn -> _ ,  pbn_log}*)
    | (opt_pbn_data, Some pbn_log) =>
      do bi_log <-- bit_get bit pbn_log; (* by Inv #1 *)
      match (check_block_is_full bi_log) with

        | true =>
          (* the log block is full, so we have to merge data & log *)
          do [c', ftl'] <-- merge_block c f lbn;  (* merge preserves $1 $2 *)

          (* allocate another new block for the new log block *)
          do [pbn_log_new, pack'] <-- alloc_block c' ftl';  (* by Inv #9 *)
          let (c_a, f_a) := (pack' : prod chip FTL) in
          do bi_log_new <-- bit_get (ftl_bi_table f_a) pbn_log_new; (* by Inv #9 *)
          do bi_log_new' <-- Some (bi_set_state bi_log_new (bs_log lbn blank_pmt)); (* trivial *)
          do [c_w, bi_log_new''] <-- write_log_block c_a bi_log_new' pbn_log_new poff d; (* *)
          do bmt_w <-- bmt_update_log (ftl_bm_table f_a) lbn pbn_log_new;
          do bit_w <-- bit_update (ftl_bi_table f_a) pbn_log_new bi_log_new'';
          ret (c_w, (mk_FTL bit_w bmt_w (ftl_free_blocks f_a)))

        (* the log block is not full, then we write the log block directly *)
        | false =>
          do [c', bi_log'] <-- write_log_block c bi_log pbn_log poff d;
          do bit' <-- bit_update bit pbn_log bi_log';
          ret (c', (mk_FTL bit' bmt fbq))
      end

    (* 2nd case: {lbn -> _, X} *)
    | (_, None) =>
        do [pbn_log, pack] <-- alloc_block c f;
        let (c_a, f_a) := (pack : prod chip FTL) in
        let bmt_a := ftl_bm_table f_a in
        let bit_a := ftl_bi_table f_a in
        let fbq_a := ftl_free_blocks f_a in
        do bi_log <-- bit_get bit_a pbn_log;
        do bi_log' <-- Some (bi_set_state bi_log (bs_log lbn blank_pmt));
        do [c_w, bi_log''] <-- write_log_block c_a bi_log' pbn_log poff d;
        do bmt_w <-- bmt_update_log bmt lbn pbn_log;
        do bit_w <-- bit_update bit_a pbn_log bi_log'';
        ret (c_w, (mk_FTL bit_w bmt_w fbq_a))
  end.

(*  -------------------------------------------------------------

  Definitions

*)

Definition check_data_block (bi: block_info) : bool :=
  match bi_state bi with
    | bs_data _ => true
    | _ => false
  end.

Definition check_log_block (bi: block_info) : bool :=
  match bi_state bi with
    | bs_log _ _ => true
    | _ => false
  end.

Definition check_used_block (bi: block_info) : bool :=
  match bi_state bi with
    | bs_data _ => true
    | bs_log _ _ => true
    | _ => false
  end.

(*  -------------------------------------------------------------

  Lemmas

*)

Fact PBN_is_greater_than_2_LBN :
    BLOCKS >= MIN_FREE_BLOCKS + 2 * MAX_LOGICAL_BLOCKS.
Proof.
  simpl.
  unfold BLOCKS.
  omega.
Qed.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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 2.1 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 GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Export Reals.
Require Export MyReals.
Require Export Rsequence_def Rsequence_facts Rsequence_sums_facts.
Require Export Rseries_def.
Require Import Rpser_def Rpser_sums Rpser_sums_facts Rpser_derivative.
Require Import Rpser_radius_facts Rpser_taylor.
Require Import Lra.
Require Import Rintegral.
Require Import Rseries_facts.
Require Import Rseries_RiemannInt.
Require Import Rsequence_subsequence.
Require Import Rtactic.

(* begin hide *)
Lemma continuity_pt_eq_compat :
  forall f g x, (exists alp, alp > 0 /\ forall y, R_dist x y < alp -> f y = g y) ->
  continuity_pt f x -> continuity_pt g x.
Proof.
intros f g x [alp1 [Halp1 H1]] H.
intros eps Heps.
destruct (H eps Heps) as [alp2 [Halp2 H2]].
exists (Rmin alp1 alp2); split.
apply Rmin_pos_lt; assumption.
intros u Hu.
repeat rewrite <- H1.
apply H2.
split; intuition.
unfold Rmin in * |- ; destruct Rle_dec; lra.
rewrite R_dist_eq; assumption.
apply Rlt_le_trans with (Rmin alp1 alp2).
  destruct Hu as [_ Hu].
  rewrite R_dist_sym; apply Hu.
  apply Rmin_l.
Qed.
(* end hide *)

(** ** Taylor series of ln *)

(** * Taylor series of ln (1 - x) *)

Section ln_minus.

Let Un n :=
match n with
| 0 => 0
| _ => - / (INR n)
end.

Lemma ln_minus_cv_radius : Cv_radius_weak Un 1.
Proof.
exists 1; intros m [n Hn]; subst m.
unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult.
rewrite pow1; rewrite Rmult_1_r.
unfold Un; destruct n.
  rewrite Rabs_R0; apply Rle_0_1.
  assert (Hle : 1 <= INR (S n)).
    rewrite S_INR.
    pattern 1 at 1; rewrite <- Rplus_0_l.
    apply Rplus_le_compat_r.
    apply pos_INR.
  rewrite Rabs_Ropp.
  rewrite Rabs_Rinv; [|intros Hc; lra].
  rewrite Rabs_right; [|lra].
  apply (Rmult_le_reg_l (INR (S n))); [lra|].
  rewrite Rinv_r; [lra|intros Hc; lra].
Qed.
(* begin hide *)

Lemma sum_f_R0_Ropp_compat : forall An n, - sum_f_R0 An n = sum_f_R0 (-An)%Rseq n.
Proof.
intros An n ; induction n.
 reflexivity.
 simpl ; rewrite Ropp_plus_distr ; rewrite IHn ; reflexivity.
Qed.
(* end hide *)

Lemma ln_minus_finite_cv_radius : finite_cv_radius Un 1.
Proof.
 assert (Un_decr : Un_decreasing (- (fun n => Un (S n)))%Rseq).
  assert (Hrew : forall n, Un (S n) = -/ INR (S n)).
   intro ; reflexivity.
   intro n ; unfold Rseq_opp ; repeat rewrite Hrew, Ropp_involutive.
   apply Rle_Rinv ; intuition.
  assert (Un_cv_0 : Un_cv (fun n : nat => - Un (S n)) 0).
  replace (fun n : nat => Un (S n)) with (fun n => - / INR (S n)).
  rewrite <- Ropp_involutive ;  do 2 apply Rseq_cv_opp_compat.
  apply Rseq_cv_pos_infty_inv_compat.
  intro M.
  assert (lt_0_1 : (0 < 1)%nat) by auto ;
  destruct (Rseq_poly_cv 1 lt_0_1 M) as [N HN] ;
  exists N ; intros n n_gt_N ; apply Rlt_trans with (INR n).
  rewrite <- pow_1 ; apply HN ; assumption.
  intuition.
  reflexivity.
 destruct (alternated_series (fun n => - Un (S n)) Un_decr Un_cv_0) as [l Hl].

 rewrite <- Rabs_R1.
 rewrite <- Rabs_Ropp.
 apply Rpser_finite_cv_radius_caracterization with l.
 unfold Pser, infinite_sum.
 intros eps eps_pos ; destruct (Hl eps eps_pos) as [N HN] ; exists (S N) ;
 intros n n_lb ; unfold R_dist.
 rewrite <- Rabs_Ropp.
 rewrite Ropp_minus_distr.
 assert (Hrew := (Rseq_pps_opp_compat Un (-1) n)) ; unfold Rseq_opp in Hrew ;
 unfold Rminus . change (-(1)) with (-1). rewrite <- Hrew.
 apply Rle_lt_trans with (R_dist (sum_f_R0 (tg_alt (fun n0 : nat => - Un (S n0))) (pred n)) l).
 right ; rewrite <- Rabs_Ropp ; unfold R_dist ; apply Rabs_eq_compat.
 clear - n_lb; induction n ; unfold tg_alt.
 inversion n_lb.
 simpl pred.
 clear ; induction n.
  compute ; field.
  unfold Rseq_pps, Rseq_sum in *.
  rewrite tech5.
  repeat rewrite Ropp_plus_distr in *.
  rewrite <- Rplus_assoc.
  rewrite IHn.
  unfold Rminus ; rewrite tech5.
  repeat rewrite Rplus_assoc ; apply Rplus_eq_compat_l.
  rewrite Rplus_comm ; apply Rplus_eq_compat_r.
  unfold gt_pser. unfold Rseq_mult. simpl pow. ring.
  apply HN ; intuition.

 intros M Hconv.
 unfold Rpser_abs in *.
(*
 rewrite Rabs_Ropp; rewrite Rabs_R1.
 intros M Hconv.
*) pose (fun n => match n with O => 0 | S _ => / INR n end) as An.
 apply Rseq_cv_not_infty with (sum_f_R0 An); split.
  exists M.
  refine (proj1 (Rser_cv_ext _ An M _) Hconv).
  intros [|n].
   simpl. unfold gt_abs_pser. unfold Rseq_abs. unfold gt_pser.
   unfold Rseq_mult. simpl. rewrite Rmult_0_l. rewrite Rabs_R0. reflexivity.

   unfold Un, An.
   unfold gt_abs_pser. unfold Rseq_abs. unfold gt_pser.
   unfold Rseq_mult. rewrite Rabs_mult.
   rewrite pow_1_abs.
   rewrite Rabs_Ropp.
   rewrite Rabs_pos_eq; [ | apply Rlt_le; apply Rinv_0_lt_compat; INR_solve].
   ring.

 apply Rseq_cv_pos_infty_shift_compat.
 eapply Rseq_cv_pos_infty_eq_compat.
  2:eapply Rseq_equiv_cv_pos_infty_compat.
   2:apply Rseq_equiv_sym.
   2:apply harmonic_series_equiv.

  intro n; unfold Rseq_shift.
   induction n.
    simpl; ring.

    rewrite tech5.
    rewrite IHn.
    reflexivity.

   apply Rseq_subseq_cv_pos_infty_compat with (fun n => ln (INR n)).
    exists (exist _ _ (extractor_Rseq_iter_S 2)).
    unfold extracted, is_extractor.
    reflexivity.

    apply Rseq_ln_cv.
Qed.

Let sum x := weaksum_r Un 1 ln_minus_cv_radius x.

Lemma ln_minus_taylor_sum :
  forall x, Rabs x < 1 -> sum x = (ln (1 - x)).
Proof.
intros x Hx.
pose (f := comp ln (fct_cte 1 - id)).
pose (df := fun u => / (1 - u) * (0 - 1)).
assert (Hb : forall u, Rmin 0 x <= u <= Rmax 0 x -> -1 < u < 1).
  destruct (Rabs_def2 x 1 Hx) as [Hmax Hmin].
  intros u [Hul Hur].
    unfold Rmin, Rmax in Hul, Hur.
    destruct Rle_dec; split; lra.
pose (Hcv := ln_minus_cv_radius).
pose (g := weaksum_r Un 1 Hcv).
pose (dg := weaksum_r_derive Un 1 Hcv).
destruct Rint_derive2
  with (f := f) (a := 0) (b := x) (d := df) as [pr HI].
  intros u Hu.
  apply derivable_pt_lim_comp.
  apply derivable_pt_lim_minus.
  apply derivable_pt_lim_const.
  apply derivable_pt_lim_id.
  apply derivable_pt_lim_ln.
  apply Rgt_minus; apply (Hb u Hu).
  intros u Hu.
  apply continuity_pt_mult.
  apply continuity_pt_inv.
  apply continuity_pt_minus.
  apply continuity_pt_const; unfold constant; auto.
  apply derivable_continuous_pt; apply derivable_pt_id.
  apply Rgt_not_eq; apply Rgt_minus; apply (Hb u Hu).
  apply continuity_pt_minus.
  apply continuity_pt_const; unfold constant; auto.
  apply continuity_pt_const; unfold constant; auto.
assert (Heq : forall u, -1 < u < 1 -> dg u = df u).
  intros u [Hul Hur]; unfold df, dg.
  replace (/ (1 - u) * (0 - 1))
    with (- / (1 - u)) by (field; intros Hc; lra).
  assert (Habs : Rabs u < 1).
    unfold Rabs; destruct Rcase_abs; lra.
  assert (Hser1 := weaksum_r_derive_sums Un 1 Hcv u Habs).
  assert (Hser2 := GP_infinite u Habs).
  eapply Rseq_cv_unique.
    apply Hser1.
    assert (Hrw : - sum_f_R0 (fun n => 1 * u ^ n) ==
      sum_f_R0 (fun n => An_deriv Un n * u ^ n)).
      unfold An_deriv.
      unfold Rseq_opp; intros n; induction n.
        simpl; unfold Rseq_shift, Rseq_mult; simpl; field.
        simpl sum_f_R0 at 1; rewrite Ropp_plus_distr.
        rewrite IHn.
        simpl; apply Rplus_eq_compat_l; destruct n.
          simpl. unfold Rseq_shift, Rseq_mult; simpl; field.
          unfold Rseq_shift. unfold Rseq_mult. unfold Un.
          field; assert (H := pos_INR (S n)); intros Hc. do 2 rewrite S_INR in Hc.
          lra.
    eapply Rseq_cv_eq_compat; unfold Rseq_pps, Rseq_sum, gt_pser.
    erewrite <- Hrw. reflexivity. apply Rseq_cv_opp_compat; apply Hser2.
edestruct Rint_eq_compat
  with (f := df) (g := dg) (a := 0) (b := x) as [pr2 HI2].
  intros u Hu.
  apply Heq; apply Hb; assumption.
  exists pr; apply HI.
destruct Rint_derive2
  with (f := g) (a := 0) (b := x) (d := dg) as [pr3 HI3].
  intros u Hu.
  apply derivable_pt_lim_weaksum_r.
  apply Hb in Hu.
  destruct Hu as [Hul Hur].
  unfold Rabs; destruct Rcase_abs; lra.
  intros u Hu.
  assert (Hu2 := Hb u Hu).
  destruct Hu2 as [Hul Hur].
  assert (Hct : continuity_pt df u).
    unfold df.
    apply continuity_pt_mult.
    apply continuity_pt_inv; [|intros Hc; lra].
    apply continuity_pt_minus.
    apply continuity_pt_const; unfold constant; auto.
    apply derivable_continuous_pt; apply derivable_pt_id.
    apply continuity_pt_const; unfold constant; auto.
  eapply continuity_pt_eq_compat; [|apply Hct].
    pose (alp1 := u / 2 + / 2).
    pose (alp2 := /2 - u / 2).
    exists (Rmin alp1 alp2); split.
    apply Rmin_pos_lt.
      unfold alp1; lra.
      unfold alp2; lra.
    intros y Hy; symmetry.
    apply Heq.
    unfold alp1, alp2, R_dist, Rabs, Rmin in *.
    destruct Rcase_abs as [Hc|Hc] in Hy;
    destruct Rle_dec as [Hl|Hl] in Hy;
    split; try lra;
      try apply Rnot_le_lt in Hl; lra.
assert (Hint : Rint dg 0 x (f x - f 0)).
  apply Rint_eq_compat with (f := df).
  intros u Hu.
  apply Heq; apply Hb; assumption.
  exists pr; assumption.
assert (Heq_fun : g x - g 0 = f x - f 0).
  eapply Rint_uniqueness.
    exists pr3; assumption.
    assumption.
replace (ln (1 - x)) with (weaksum_r Un 1 Hcv x).
  unfold sum, Hcv; reflexivity.
unfold f, g, comp, fct_cte, id, minus_fct in Heq_fun; hnf in Heq_fun.
replace (1 - 0) with 1 in Heq_fun by ring; rewrite ln_1 in Heq_fun.
rewrite Rminus_0_r in Heq_fun.
replace (weaksum_r Un 1 Hcv 0) with 0 in Heq_fun.
rewrite Rminus_0_r in Heq_fun; assumption.
symmetry.
eapply Rseq_cv_unique.
apply weaksum_r_sums; rewrite Rabs_R0; lra.
intros eps Heps; exists 0%nat; intros n _.
unfold Rseq_pps, gt_pser.
rewrite sum_eq_R0.
rewrite R_dist_eq; assumption.
intros m _; unfold Un; destruct m.
  unfold Rseq_mult.
  field.
  unfold Rseq_mult.
  rewrite pow_ne_zero; [field|].
    apply not_0_INR; auto.
    auto.
Qed.

Lemma ln_minus_taylor :
  forall x, Rabs x < 1 -> Pser Un x (ln (1 - x)).
Proof.
intros x Hx.
rewrite <- ln_minus_taylor_sum; [|assumption].
apply weaksum_r_sums; assumption.
Qed.

End ln_minus.

(** * Taylor series of ln (1 + x) *)

Section ln_plus.

Let Un n :=
match n with
| 0 => 0
| _ => (- 1) ^ (S n) / (INR n)
end.

Lemma ln_plus_cv_radius : Cv_radius_weak Un 1.
Proof.
exists 1; intros m [n Hn]; subst m.
unfold gt_abs_pser, gt_pser, Rseq_abs, Rseq_mult.
rewrite pow1; rewrite Rmult_1_r.
unfold Un; destruct n.
  rewrite Rabs_R0; apply Rle_0_1.
  assert (Hle : 1 <= INR (S n)).
    rewrite S_INR.
    pattern 1 at 1; rewrite <- Rplus_0_l.
    apply Rplus_le_compat_r.
    apply pos_INR.
  unfold Rdiv; rewrite Rabs_mult.
  rewrite pow_1_abs; rewrite Rmult_1_l.
  rewrite Rabs_Rinv; [|intros Hc; lra].
  rewrite Rabs_right; [|lra].
  apply (Rmult_le_reg_l (INR (S n))); [lra|].
  rewrite Rinv_r; [lra|intros Hc; lra].
Qed.

Let sum x := weaksum_r Un 1 ln_plus_cv_radius x.

Lemma ln_plus_taylor_sum :
  forall x, Rabs x < 1 -> sum x = (ln (1 + x)).
Proof.
intros x Hx.
assert (Hmx : Rabs (- x) < 1).
  rewrite Rabs_Ropp; assumption.
replace (1 + x) with (1 - (- x)) by ring.
eapply trans_eq; [|apply ln_minus_taylor_sum; assumption].
eapply Rseq_cv_unique.
  apply weaksum_r_sums; assumption.
eapply Rseq_cv_eq_compat; [|apply weaksum_r_sums; assumption].
intros n; apply sum_eq; intros i Hi; unfold Un.
unfold gt_pser. unfold Rseq_mult.
destruct i; [field|].
replace (- x) with (- 1 * x) by ring.
rewrite Rpow_mult_distr.
repeat rewrite <- tech_pow_Rmult; field.
auto with real.
Qed.

Lemma ln_plus_taylor :
  forall x, Rabs x < 1 -> Pser Un x (ln (1 + x)).
Proof.
intros x Hx.
rewrite <- ln_plus_taylor_sum; [|assumption].
apply weaksum_r_sums; assumption.
Qed.

End ln_plus.


(*
  This is a dummy file for interactively observing how
  the step_solver tactics work on a concrete program.
  (especially that it's not getting stuck in the semantics,
   and that the example configuration is well-formed).
 *)

Require Import himp_steps.
Require Import himp_syntax_sugar.
Require Import himp_tactics.

Require Import ZArith.

Ltac step_solver :=
  econstructor (solve[simpl;eauto;equate_maps;eauto]).

(*
Ltac step_solver := econstructor (solve[simpl;try reflexivity;eauto with step_hints]);idtac.
*)

Goal
 reaches kstep
      (KCfg (kra (SWhile (BLt (EVar "x") (ECon 13))
                         (Seq (SAssign "cur" EAlloc)
                         (Seq (HAssign (EVar "cur")
                                       (EBuild
                                          ("val" s|-> KId "x"
                                          :* "next" s|-> KId "prev")))
                         (Seq (SAssign "prev" (EVar "cur"))
                              (SAssign "x" (EPlus (EVar "x") (ECon 1)))))))
                 kdot)
       ("x" s|-> KInt 10 :* "cur" s|-> (KUndef undef) :* "prev" s|-> KInt 0 :* mapEmpty)
       nil
       mapEmpty
       mapEmpty
       1)
      (fun c => kcell c = kdot).

Set Printing Coercions.

do 40 (eapply rstep;[step_solver|]).
do 40 (eapply rstep;[step_solver|]).
do 40 (eapply rstep;[step_solver|]).
do 9 (eapply rstep;[step_solver|]).
apply rdone. reflexivity.
Qed.


From mathcomp Require Import ssreflect ssrfun.

Require Import lib.utils.

(* Monadic function composition *)
Definition opt_compose {A B C}
                       (f : B -> option C)
                       (g : A -> option B)
                       : A -> option C :=
  obind f \o g.
Infix "<=<" := opt_compose (at level 30).
Arguments opt_compose {A B C} f g / x.

Infix "$"   := (fun f x => f x) (at level 150, left associativity).
Infix "<$>" := option_map       (at level 130, left associativity).
Infix "=<<" := obind            (at level 130, left associativity).


Require Import Arith.Compare_dec.
Require Import List.
Require Import Map.
Require Import Monad.

Set Implicit Arguments.

Module List.
  Import Monad.

  (** List map with index *)
  Definition mapi (A B: Type) (f: A -> nat -> B) (l: list A): list B :=
    let fix aux (l: list A) (i: nat): list B :=
      match l with
      | nil => nil
      | x :: l' => (f x i) :: (aux l' (S i))
      end
    in
      aux l 0.

  (** Evaluate each action in the list from left to right
      and collect the results. *)
  Definition do (sig: Sig.t) (T: Type) (l: list (M sig T))
    : M sig (list T) :=
    fold_right (fun x l' =>
      let! x := x in
      let! l' := l' in
      ret (x :: l'))
      (ret nil) l.

  (** Apply an effectful function to each element of a list. *)
  Definition iter (sig: Sig.t) (T: Type)
    (f: T -> M sig unit) (l: list T): M sig unit :=
    do! do (map f l) in
    ret tt.
End List.

(** A data structure for arrays implemented in the monad. *)
(* FIXME: Implement it using a more efficient data structure. *)
Module Array.
  Import Monad.

  Definition internal_t (T: Type): Type :=
    list T.

  Definition t (sig: Sig.t) (T: Type): Type :=
    Ref.t sig (internal_t T).

  (** Read a value. *)
  Definition read (sig: Sig.t) (T: Type) (array: t sig T) (index: nat)
    : M sig T :=
    let! l := !array in
    match nth_error l index with
    | Some v => ret v
    | None => error "Invalid array read"
    end.

  (** Write a value. *)
  Definition write (sig: Sig.t) (T: Type) (array: t sig T) (index: nat) (v: T)
    : M sig unit :=
    let! l := !array in
    match lt_dec index (length l) with
    | left _ => array :=! (firstn index l ++ (v :: nil) ++ skipn (S index) l)
    | right _ => error "Invalid array write"
    end.

  (** Modify an array applying a function to each element. *)
  Definition map (sig: Sig.t) (T: Type) (array: t sig T)
    (f: T -> nat -> M sig T): M sig unit :=
    let! l := !array in
    let! l := List.do (List.mapi f l) in
    array :=! l.

  (** Convert to a persistent list. *)
  Definition to_list (sig: Sig.t) (T: Type) (array: t sig T)
    : M sig (list T) :=
    !array.
End Array.

(** An mutable associative data structure. *)
Module Hash (Map: IMap).
  Import Monad.

  Definition internal_t (T: Type): Type := Map.t T.

  Definition t (sig: Sig.t) (T: Type) := Ref.t sig (internal_t T).

  (** Evaluate each action in the hash table. *)
  Definition do (sig: Sig.t) (T: Type) (map: internal_t (M sig T))
    : M sig (internal_t T) :=
    Map.fold (fun k x map' =>
      let! x := x in
      let! map' := map' in
      ret (Map.add k x map'))
      map (ret (Map.empty _)).

  (** Read a value. *)
  Definition read (sig: Sig.t) (T: Type) (hash: t sig T)
    (key: Map.key): M sig T :=
    let! map := !hash in
    match Map.find key map with
    | None => error "Hash read: not found"
    | Some v => ret v
    end.

  (** Write a value. *)
  Definition write (sig: Sig.t) (T: Type) (hash: t sig T)
    (key: Map.key) (value: T): M sig unit :=
    let! map := !hash in
    match Map.find key map with
    | None => error "Hash write: not found"
    | Some _ => hash :=! Map.add key value map
    end.

  (** Iterate a function over each element. *)
  Definition iter (sig: Sig.t) (T: Type) (hash: t sig T)
    (f: Map.key -> T -> M sig unit): M sig unit :=
    let! map := !hash in
    do! do (Map.mapi f map) in
    ret tt.

  (** Convert to a persistent map. *)
  Definition to_map (sig: Sig.t) (T: Type) (hash: t sig T)
    : M sig (Map.t T) :=
    !hash.
End Hash.


(** * A variant of the [Comp] monad laws using [apply] *)
Require Import Coq.Strings.String Coq.Sets.Ensembles.
Require Import Fiat.Common.
Require Import Fiat.Computation.Core Fiat.Computation.Monad Fiat.Computation.SetoidMorphisms.

(** ** Helper monad laws, on the left side of a [refine] *)

Section monad.
  Local Ltac t := intro H; autorewrite with refine_monad; exact H.

  Lemma refine_bind_bind_helper X Y Z (f : X -> Comp Y) (g : Y -> Comp Z) x y
  : refine (Bind x (fun u => Bind (f u) g)) y
    -> refine (Bind (Bind x f) g) y.
  Proof. t. Qed.

  Lemma refine_bind_unit_helper X Y (f : X -> Comp Y) x y
  : refine (f x) y
    -> refine (Bind (Return x) f) y.
  Proof. t. Qed.

  Lemma refine_unit_bind_helper X (x : Comp X) y
  : refine x y
    -> refine (Bind x (@Return X)) y.
  Proof. t. Qed.

  (** XXX This is a terribly ugly tactic that should be improved *)
  Local Ltac t2 :=
    unfold refine; intros;
    specialize_all_ways;
    computes_to_inv; eauto;
    computes_to_econstructor; eauto.

  Lemma refine_under_bind_helper X Y (f f' : X -> Comp Y) x x' y
  : (forall y, refine x y -> refine x' y)
    -> (forall x0 y, refine (f x0) y -> refine (f' x0) y)
    -> refine (Bind x f) y
    -> refine (Bind x' f') y.
  Proof. t2. Qed.

  Lemma refine_under_bind_helper_1 X Y (f : X -> Comp Y) x x' y
  : (forall y, refine x y -> refine x' y)
    -> refine (Bind x f) y
    -> refine (Bind x' f) y.
  Proof. t2. Qed.

  Lemma refine_under_bind_helper_2 X Y (f f' : X -> Comp Y) x y
  : (forall x0 y, refine (f x0) y -> refine (f' x0) y)
    -> refine (Bind x f) y
    -> refine (Bind x f') y.
  Proof. t2. Qed.
End monad.

Ltac simplify_with_applied_monad_laws :=
  progress repeat first [ apply refine_bind_unit_helper
                        | apply refine_unit_bind_helper
                        | apply refine_bind_bind_helper
                        | eapply refine_under_bind_helper; [ let H := fresh in
                                                             intros ? H;
                                                               simplify_with_applied_monad_laws;
                                                               exact H
                                                           | let H := fresh in
                                                             intros ? ? H;
                                                               simplify_with_applied_monad_laws;
                                                               exact H
                                                           | ]
                        | eapply refine_under_bind_helper_1; [ let H := fresh in
                                                               intros ? H;
                                                                 simplify_with_applied_monad_laws;
                                                                 exact H
                                                             | ]
                        | eapply refine_under_bind_helper_2; [ let H := fresh in
                                                               intros ? ? H;
                                                                 simplify_with_applied_monad_laws;
                                                                 exact H
                                                             | ] ].

Tactic Notation "simplify" "with" "monad" "laws" :=
  simplify_with_applied_monad_laws.

(* Ideally we would throw refineEquiv_under_bind in here as well, but it gets stuck *)

Tactic Notation "autorewrite" "with" "monad" "laws" :=
  repeat first [ setoid_rewrite refineEquiv_bind_bind
               | setoid_rewrite refineEquiv_bind_unit
               | setoid_rewrite refineEquiv_unit_bind].

Ltac interleave_autorewrite_refine_monad_with tac :=
  repeat first [ reflexivity
               | progress tac
               | progress autorewrite with refine_monad
               (*| rewrite refine_bind_bind'; progress tac
               | rewrite refine_bind_unit'; progress tac
               | rewrite refine_unit_bind'; progress tac
               | rewrite <- refine_bind_bind; progress tac
               | rewrite <- refine_bind_unit; progress tac
               | rewrite <- refine_unit_bind; progress tac ]*)
               | rewrite <- !refineEquiv_bind_bind; progress tac
               | rewrite <- !refineEquiv_bind_unit; progress tac
               | rewrite <- !refineEquiv_unit_bind; progress tac
               (*| rewrite <- !refineEquiv_under_bind; progress tac *)].


Require Import ReflParam.common.
Require Import ReflParam.templateCoqMisc.
Require Import String.
Require Import List.
Require Import Template.Ast.
Require Import SquiggleEq.terms.
Require Import ReflParam.paramDirect ReflParam.indType.
Require Import SquiggleEq.substitution.
Require Import ReflParam.PiTypeR.
Import ListNotations.
Open Scope string_scope.

Require Import ReflParam.Trecord.
Require Import squiggle2.

Section iff.

   Lemma xx (Tm Tm₂ : Set) (Tm_R : BestRel Tm Tm₂) : False.
    set (f:= Top_squiggle2_evaln_pmtcty_RR _ _ Tm_R).
    simpl in f.
    destruct Tm_R as [Tm_R Rtot Rone].
    simpl in f.
    unfold  Top_squiggle2_evaln_pmtcty_RR in f.
    simpl BestR in f.
    simpl in Rtot.
  Abort.

   Variables
      (Tm Tm₂ : Set)

      (Tm_R : Tm -> Tm₂ -> Prop)

      (Rtot : TotalHeteroRel Tm_R)

      (elimTerm : Tm -> tmExt Tm) (elimTerm₂ : Tm₂ -> tmExt Tm₂)

      (elimTerm_R : forall (a1 : Tm) (a2 : Tm₂),
                       Tm_R a1 a2 ->
                       Top_squiggle2_tmExt_pmtcty_RR0 Tm Tm₂ Tm_R (elimTerm a1) (elimTerm₂ a2))

      (applyBtm : Tm -> Tm -> Tm) (applyBtm₂ : Tm₂ -> Tm₂ -> Tm₂)

      (applyBtm_R : forall (a1 : Tm) (a2 : Tm₂),
                       Tm_R a1 a2 ->
                       forall (a3 : Tm) (a4 : Tm₂),
                         Tm_R a3 a4 -> Tm_R (applyBtm a1 a3) (applyBtm₂ a2 a4)).

   Section eval.
   Variables
      (n n₂ : nat) (n_R : Coq_Init_Datatypes_nat_pmtcty_RR0 n n₂)
      (t : Tm) (t₂ : Tm₂) (t_R : Tm_R t t₂).

   Lemma evalnUni:

     Top_squiggle2_option_pmtcty_RR0 Tm Tm₂ Tm_R
                                     (evaln _ elimTerm applyBtm n t)
                                     (evaln _ elimTerm₂ applyBtm₂ n₂ t₂).

     set (ff := proj1_sig (projT2 (dependsOnlyOnRelEvaln _ _ Tm_R))
                          _ _ elimTerm_R _ _ applyBtm_R
                          _ _ n_R _ _ t_R).
  exact ff.
   Qed.
   End eval.
   Variables
      (n n₂ : nat) (n_R : Coq_Init_Datatypes_nat_pmtcty_RR0 n n₂)
      (tl : Tm) (tl₂ : Tm₂) (tl_R : Tm_R tl tl₂)
      (tr : Tm) (tr₂ : Tm₂) (tr_R : Tm_R tr tr₂).

   Require Import squiggle3.
   Lemma obsEqUni:
     (obsEq _ elimTerm applyBtm (evaln _ elimTerm applyBtm) n tl tr)
       <->
     (obsEq _ elimTerm₂ applyBtm₂ (evaln _ elimTerm₂ applyBtm₂) n₂ tl₂ tr₂).
   Proof.
     set (ff := proj1_sig (projT2 (obsEqExistsAOneFreeImpl _ _ Tm_R Rtot))
                          _ _ elimTerm_R _ _ applyBtm_R
                          _ _ evalnUni
                          _ _ n_R _ _ tl_R _ _ tr_R).
  pose proof (Trecord.Rtot ff) as Ht.
  simpl in Ht.
  apply Prop_RSpec in Ht.
  apply fst in Ht.
  unfold IffRel in Ht.
  apply tiffIff in Ht.
  apply Ht.

  Qed.

End iff.

Check obsEqUni.
Print Assumptions obsEqUni.


Require Import Software.Language.DynamicBinding.
Require Import Software.Language.State.
Require Import Software.Language.ExecutionProp.
Require Import Software.Language.Syntax.
Import ObjectOrientedNotations.

Open Scope oo_scope.

Definition wf_ex (x : term) (st : state) : Prop :=
  exists var ref at_start count first,
      x = tvar var
  /\  read_sk_hd var st = tref ref
  /\  read_sr ref st = tcl "NatRangeIterator" <(tbool at_start, tnat count, tnat first)>.

Definition wf x var ref st at_start count first : Prop :=
      x = tvar var
  /\  read_sk_hd var st = tref ref
  /\  read_sr ref st = tcl "NatRangeIterator" <(tbool at_start, tnat count, tnat first)>.

Lemma wf_implies_wf_ex:
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  wf_ex x st.
Proof.
  Abort.

Section Specs.

Variable exec_step : exec_step_relation.

Notation "t1 '/' st1 '==>' t2 '/' st2" := (exec_step (Cexec_state t1 st1) (Cexec_state t2 st2))
  (at level 40, st1 at level 39, t2 at level 39, format "'[' t1 / st1 '==>' t2 / st2 ']'").

Notation "t1 '/' st1 '==>*' t2 '/' st2" := (multi exec_step (Cexec_state t1 st1) (Cexec_state t2 st2))
  (at level 40, st1 at level 39, t2 at level 39, format "'[' t1 / st1 '==>*' t2 / st2 ']'").

Definition get_at_start : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  (x # "get_at_start"|()|) / st ==>* (tbool at_start) / st.

Definition get_count : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  (x # "get_count"|()|) / st ==>* (tnat count) / st.

Definition get_first : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  (x # "get_first"|()|) / st ==>* (tnat first) / st.

Definition set_at_start : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  forall val,
  (x # "set_at_start"|(val)|) / st ==>* tvoid / write_sr ref (tcl "NatRangeIterator" <(val, tnat count, tnat first)>) st.

Definition set_count : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  forall val,
  (x # "set_count"|(val)|) / st ==>* tvoid / write_sr ref (tcl "NatRangeIterator" <(tbool at_start, val, tnat first)>) st.

Definition set_first : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  forall val,
  (x # "set_first"|(val)|) / st ==>* tvoid / write_sr ref (tcl "NatRangeIterator" <(tbool at_start, tnat count, val)>) st.

Definition off_true : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  count = 0 \/ at_start = true ->
  (x # "off"|()|) / st ==>* (tbool true) / st.

Definition off_false : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  lt 0 count /\ at_start = false ->
  (x # "off"|()|) / st ==>* (tbool false) / st.

Definition after_true : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  count = 0 /\ at_start = false ->
  (x # "after"|()|) / st ==>* (tbool true) / st.

Definition after_false : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  lt 0 count \/ at_start = true ->
  (x # "after"|()|) / st ==>* (tbool true) / st.

Definition forth_at_start : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  at_start = true ->
  (x # "forth"|()|) / st ==>* tvoid / write_sr ref (tcl "NatRangeIterator" <(tbool false, tnat count, tnat first)>) st.

Definition forth : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  at_start = false ->
  (x # "forth"|()|) / st ==>* tvoid / write_sr ref (tcl "NatRangeIterator" <(tbool at_start, tnat (count - 1), tnat (first + 1))>) st.

Definition item : Prop :=
  forall x var ref st at_start count first,
  wf x var ref st at_start count first ->
  (x # "item"|()|) / st ==>* (tnat first) / st.

End Specs.

Close Scope oo_scope.


From Coq Require Export ZArith NArith List String Ascii.
From stdpp Require Import gmap.
Import ListNotations.

Set Implicit Arguments.

(* dirty preprocessing will insert an empty string *)
Notation "'input' tbl _r0 r1 .. rn" := (tbl%string, cons r1%string .. (cons rn%string nil) ..)
  (at level 200, tbl at level 0, _r0 at level 0, r1 at level 0, rn at level 0, only parsing).

Definition example := input
"..#.#..#####.#.#.#.###.##.....###.##.#..###.####..#####..#....#..#..##..##
#..######.###...####..#..#####..##..#.#####...##.#.#..#.##..#.#......#.###
.######.###.####...#.##.##..#..#..#####.....#.#....###..#.##......#.....#.
.#..#..##..#...##.######.####.####.#.#...#.......#..#.#.#...####.##.#.....
.#..#...##.#.##..#...##.#.##..###.#......#.#.......#.#.#.####.###.##...#..
...####.#..#..#.##.#....##..#.####....##...##..#...#......#.#.......#.....
..##..####..#...#.#.#...##..#.#..###..#####........#..####......#..#"
""
"#..#."
"#...."
"##..#"
"..#.."
"..###"
.

Inductive cellstate := On | Off.

Definition foldli {A B} (f : N -> A -> B -> B) (b : B) (xs : list A) : B :=
  fold_right (fun x go i b => go (N.succ i) (f i x b)) (fun _ b => b) xs 0%N b.

Definition _mk_table (s : string) : gmap N unit :=
  foldli (fun i c => if (c =? "#")%char then insert i tt else fun m => m) empty
    (filter (fun c => (c =? "#") || (c =? "."))%bool%char (list_ascii_of_string s)).

Definition mk_table (s : string) : N -> cellstate :=
  let t := _mk_table s in
  fun i => match lookup i t with
    | None => Off
    | Some _ => On
    end.

Definition point : Type := Z * Z.

Definition mk_grid : list string -> list (list cellstate) :=
  map (fun row => map (fun c => if (c =? "#")%char then On else Off) (list_ascii_of_string row)).

Definition shifts0 {A} (x0 : A) : list (list A -> list A) :=
  [fun x => x; fun x => x0 :: x; fun x => x0 :: x0 :: x].

Definition shifts {A} (x0 : A) : list (list (list A) -> list (list A)) := Eval cbn in
  List.rev' (map (fun '(f, g) x => f (g x))
    (list_prod
      (shifts0 [])
      ((fun x => x) :: List.tl (map (@map _ _) (shifts0 x0))))).

Definition snocbit (i : N) (b : cellstate) :=
  match b with
  | On => N.succ_double i
  | Off => N.double i
  end.

Fixpoint zip_with_extend {A B C} (f : A -> B -> C) (x0 : A) (y0 : B)
    (xs : list A) (ys : list B) : list C :=
  match xs, ys with
  | x :: xs, y :: ys => f x y :: zip_with_extend f x0 y0 xs ys
  | [], _ => map (f x0) ys
  | _, [] => map (fun x => f x y0) xs
  end.

Definition nine (def : cellstate) (g : list (list cellstate)) : list (list N) :=
  let zz def' := zip_with_extend (zip_with_extend snocbit def' def) [] [] in
  snd (fold_left (fun '(def', g') z => (snocbit def' def, zz def' g' (z g))) (shifts def) (0%N, [])).

Definition step (f : N -> cellstate) '((def, g) : cellstate * list (list cellstate))
  : cellstate * list (list cellstate) :=
  let newdef :=
    match def with
    | Off => f 0%N
    | On => f 511%N
    end in
  (newdef, map (map f) (nine def g)).

Definition sum_with {A} (f : A -> N) (xs : list A) : N :=
  fold_left (fun i x => i + f x)%N xs 0%N.

Definition count '((def, g) : cellstate * list (list cellstate)) : N :=
  match def with
  | On => 9999999999%N (* Boo *)
  | Off => sum_with (sum_with (fun c => match c with On => 1 | Off => 0 end)%N) g
  end.

Definition enhance (n : N) (f : N -> cellstate)
  : cellstate * list (list cellstate) -> cellstate * list (list cellstate) :=
  N.iter n (step f).

Definition solve '(t, g) :=
  let t := mk_table t in
  let g := (Off, mk_grid g) in
  count (enhance 2 t g).

(* Compute solve example. *)
(*
Compute
  let '(t, g) := example in
  let t := mk_table t in
  let g := (Off, mk_grid g) in
  step t (step t g).
*)

Definition solve2 '(t, g) :=
  let t := mk_table t in
  let g := (Off, mk_grid g) in
  count (enhance 50 t g).

(* Compute solve2 example. *)

Definition solve12 '(t, g) :=
  let t := mk_table t in
  let g := (Off, mk_grid g) in
  (count (enhance 2 t g), count (enhance 50 t g)).