Require Import Bool List Arith Nat.
Import ListNotations.
Require Import Mmx.ast_instructions Mmx.binary Mmx.association_list Mmx.encodeProof Mmx.decodeProof Mmx.encode.

(* Proof about encode_decode_flux *)

Lemma encode_decode_decoup_flux_decoup : forall (lb : list binary_instruction) (l : list instruction),
    encode_flux l = Some lb -> decode_flux_decoup lb = Some l.
Proof.
  induction lb.
  -intros.
   unfold encode_flux in H.
   assert (traverse (encode_flux_opt l) = Some [] -> l = []).
   {
     destruct l.
     -reflexivity.
     -simpl.
      destruct (encode i).
      +destruct (traverse (encode_flux_opt l)).
       discriminate.
       discriminate.
      +discriminate.
   }
   apply H0 in H.
   rewrite H.
   auto.
  -destruct l.
   +unfold encode_flux.
    simpl.
    discriminate.
   +intros.
    assert (keep : encode_flux (i :: l) = Some (a :: lb)) by auto.
    assert (encode_flux (i :: l) = Some (a :: lb) -> encode i = Some a).
    {
      unfold encode_flux.
      simpl.
      intros.
      destruct (encode i).
      assert (encode_flux (i :: l) = Some (a :: lb) -> encode_flux l = Some lb).
      {
        unfold encode_flux.
        simpl.
        intros.
        destruct (encode i).
        -destruct (traverse (encode_flux_opt l)).
         +inversion H1.
          reflexivity.
         +discriminate.
        -discriminate.
      }
      apply H1 in H.
      assert (traverse (encode_flux_opt l) = encode_flux l).
      {
        unfold encode_flux.
        reflexivity.
      }
      rewrite H2 in H0.
      rewrite H in H0.
      -inversion H0.
       reflexivity.
      -discriminate.
    }
    apply H0 in H.
    unfold decode_flux_decoup.
    simpl.
    apply encode_decode in H.
    rewrite H.
    fold decode_flux_decoup.
    assert (traverse (decode_flux_opt lb) = decode_flux_decoup lb).
    {
      unfold decode_flux_decoup.
      reflexivity.
    }
    rewrite H1.
    assert (decode_flux_decoup lb = Some l).
    {
      apply IHlb.
      assert (encode_flux (i :: l) = Some (a :: lb) -> encode_flux l = Some lb).
      {
        unfold encode_flux.
        simpl.
        intros.
        destruct (encode i).
        -destruct (traverse (encode_flux_opt l)).
         +inversion H2.
          reflexivity.
         +discriminate.
        -discriminate.
      }
      apply H2 in keep.
      auto.
    }
    rewrite H2.
    reflexivity.
Qed.

Lemma decode_decoup_encode_flux : forall (l : list instruction) (lb : list binary_instruction),
    decode_flux_decoup lb = Some l -> encode_flux l = Some lb.
Proof.
  induction l.
  -unfold decode_flux_decoup.
   unfold encode_flux.
   intros.
   assert (traverse (decode_flux_opt lb) = Some [] -> lb = []).
   {
     destruct lb.
     -reflexivity.
     -simpl.
      destruct (decode b).
      +destruct (traverse (decode_flux_opt lb)).
       discriminate.
       discriminate.
      +discriminate.
   }
   apply H0 in H.
   rewrite H.
   reflexivity.
  -intros.
   destruct lb.
   +unfold decode_flux_decoup in H.
    simpl in H.
    discriminate.
   +assert (keep : decode_flux_decoup (b :: lb) = Some (a :: l)) by auto.
    assert (keep2 : decode_flux_decoup (b :: lb) = Some (a :: l)) by auto.
    assert (decode_flux_decoup (b :: lb) = Some (a :: l) -> decode_flux_decoup lb = Some l).
    {
      unfold decode_flux_decoup.
      intros.
      simpl in H0.
      destruct (decode b).
      -destruct (traverse (decode_flux_opt lb)).
       +inversion H0.
        reflexivity.
       +discriminate.
      -discriminate.
    }
    apply H0 in H.
    unfold encode_flux.
    simpl.
    assert (decode_flux_decoup (b :: lb) = Some (a :: l) -> decode b = Some a).
    {
      intros.
      unfold decode_flux_decoup in H1.
      simpl in H1.
      destruct (decode b).
      -destruct (traverse (decode_flux_opt lb)).
       +inversion H1.
       reflexivity.
       +discriminate.
      -discriminate.
    }
    apply H1 in keep.
    Search decode.
    apply decode_encode in keep.
    {
      rewrite keep.
      assert (traverse (encode_flux_opt l) = encode_flux l).
      {
        unfold encode_flux.
        reflexivity.
      }
      rewrite H2.
      assert (encode_flux l = Some lb).
      {
        apply IHl.
        auto.
      }
      rewrite H3.
      reflexivity.
    }
    assert (decode_flux_decoup (b :: lb) = Some (a :: l) -> length b = 32).
    {
      unfold decode_flux_decoup.
      simpl.
      intros.
      Search decode.
      Check decode_size.
      apply decode_size in keep.
      auto.
    }
    apply H2 in keep2.
    auto.
Qed.

(* Some proofs about cut32 and concatlistes *)

(* good proofs *)
Lemma app_cut32 : forall (l1 l2 : list bool) (ll : list (list bool)), length l1 = 32 -> cut32 l2 = Some ll
                                                                      -> cut32 (l1 ++ l2) = Some (l1 :: ll).
Proof.
  intros.
  unfold cut32.
  assert (length (l1 ++ l2) mod 32 =? 0 = true).
  {
    rewrite app_length.
    rewrite H.
    Search ((_ + _) mod _).
    rewrite Nat.add_mod.
    -{
        Search (_ mod _ = 0).
        rewrite Nat.mod_same.
        -Search (0 + _).
         rewrite plus_O_n.
         unfold cut32 in H0.
         destruct (length l2 mod 32).
         +reflexivity.
         +discriminate.
        -auto.
     }
    -auto.
  }
  rewrite H1.
  assert(length (l1 ++ l2) / 32 = S (length l2 / 32)).
  {
    rewrite app_length.
    rewrite H.
    Check Nat.div_add_l.
    specialize (Nat.div_add_l 1 32 (length l2)).
    intros.
    Search (1 * _).
    rewrite Nat.mul_1_l in H2.
    apply H2.
    auto.
  }
  rewrite H2.
  unfold cut32_n.
  assert (firstn 32 (l1 ++ l2) = l1).
  {
    Search (_ = _ -> _ <= _).
    Search firstn.
    Check firstn_app_2.
    rewrite <- H.
    Search (_ + 0).
    specialize (plus_n_O (length l1)).
    intros.
    rewrite H3.
    Check firstn_app_2.
    specialize (firstn_app_2 0 l1 l2).
    intros.
    rewrite H4.
    simpl.
    Search (_ ++ []).
    apply app_nil_r.
  }
  rewrite H3.
  fold cut32_n.
  Search (_ :: _ = _ :: _).
  assert (forall (l1 l2: list (list bool)), l1 = l2 -> Some l1 = Some l2).
  {
    intros.
    rewrite H4.
    reflexivity.
  }
  apply H4.
  Check delete_concat.
  assert (forall (lb : list bool) (ll1 ll2 : list (list bool)), ll1 = ll2 -> lb :: ll1 = lb :: ll2).
  {
    intros.
    rewrite H5.
    reflexivity.
  }
  apply H5.
  unfold cut32 in H0.
  assert (length l2 mod 32 =? 0 = true).
  {
    destruct (length l2 mod 32).
    -reflexivity.
    -simpl in H0.
     discriminate.
  }
  rewrite H6 in H0.
  assert (skipn 32 (l1 ++ l2) = l2).
  {
    SearchAbout skipn.
    assert (firstn 32 (l1 ++ l2) ++ skipn 32 (l1 ++ l2) = (l1 ++ l2)).
    {
      apply firstn_skipn.
    }
    rewrite H3 in H7.
    Search (_ ++ _ = _ ++ _).
    apply app_inv_head in H7.
    auto.
  }
  rewrite H7.
  inversion H0.
  assert (forall (n : nat), n / 32 = fst (Nat.divmod n 31 0 31)).
  {
    destruct n.
    -reflexivity.
    -reflexivity.
  }
  rewrite H8.
  reflexivity.
Qed.

Lemma concat_listes_cut32 : forall (ll : list (list bool)) (l : list bool) ,
    concat_listes_32 ll = Some l -> cut32 l = Some ll.
Proof.
  assert (I : forall (ll : list (list bool)) (l : list bool), concat_listes_32 ll = Some l -> cut32 l = Some ll).
  {
    induction ll.
    -assert (I_1 : forall l : list bool, concat_listes_32 [] = Some l -> cut32 l = Some []).
     {
       intros.
       simpl in H.
       inversion H.
       reflexivity.
     }
     auto.
    -assert(forall l : list bool, concat_listes_32 (a :: ll) = Some l -> cut32 l = Some (a :: ll)).
     {
       intros.
       unfold concat_listes_32 in H.
       apply bind_rewrite in H.
       destruct H.
       destruct H.
       fold concat_listes_32 in H0.
       destruct (length a =? 32) eqn:H1.
       -{
           inversion H.
           specialize (IHll x).
           apply commut_equal in H0.
           apply IHll in H0.
           Check app_cut32.
           apply app_cut32.
           -apply beq_nat_true in H1.
            auto.
           -auto.
         }
       -discriminate.
     }
     auto.
  }
  auto.
Qed.

(* i made separatly the two case proof *)
Lemma cut32_concat_nil : forall (l : list bool),
    cut32 l = Some [] -> concat_listes_32 [] = Some l.
Proof.
  intros.
  assert (cut32 l = Some [] -> length l = 0).
  {
    destruct (length l) eqn:H1.
    -reflexivity.
    -intros.
     unfold cut32 in H0.
     destruct (length l mod 32 =? 0) eqn:H2.
     +destruct (length l / 32) eqn:H3.
      {
        Search (_ / _ = 0).
        specialize (Nat.div_small_iff (length l) 32).
        intros.
        assert (32 <> 0) by auto.
        apply H4 in H5.
        apply beq_nat_true in H2.
        apply H5 in H3.
        assert (forall (n' m': nat), n' = S m' -> n' < 32 -> n' mod 32 = n').
        {
          intros.
          apply Nat.mod_small.
          auto.
        }
        apply Nat.mod_small in H3.
        rewrite H3 in H2.
        rewrite H1 in H2.
        discriminate.
      }
      {
        unfold cut32_n in H0.
        fold cut32_n in H0.
        inversion H0.
      }
     +discriminate.
  }
  apply H0 in H.
  Search (length _ = 0).
  apply length_zero_iff_nil in H.
  rewrite H.
  reflexivity.
Qed.

Lemma cut32_length : forall (l l': list bool) (ll : list (list bool)),
    cut32 l = Some (l' :: ll) -> length l' = 32.
Proof.
  assert (div_S_n : forall (n m q : nat), n / m = S q -> m <= n).
  {
    intros.
    apply Nat.div_str_pos_iff.
    -destruct m.
     +discriminate.
     +auto.
    -rewrite H.
     apply Nat.lt_0_succ.
  }
  intros.
  unfold cut32 in H.
  destruct (length l mod 32 =? 0) eqn:H1.
  -destruct (length l / 32) eqn:H2.
   +simpl in H.
    discriminate.
   +unfold cut32_n in H.
    fold cut32_n in H.
    assert (32 <= length l) by (specialize (div_S_n (length l) 32 n);auto).
    assert (forall (l1 l2: list bool) (tl1 tl2 : list (list bool)), Some (l1 :: tl1) = Some (l2 :: tl2) -> l1 = l2).
    { intros. inversion H3. reflexivity. }
    apply H3 in H.
    rewrite <- H.
    Search firstn.
    apply firstn_length_le.
    auto.
  -discriminate.
Qed.

Lemma cut32_firstn : forall (l l': list bool) (ll : list (list bool)),
    cut32 l = Some (l' :: ll) -> firstn 32 l = l'.
Proof.
  intros.
  unfold cut32 in H.
  destruct (length l mod 32 =? 0) eqn:H0.
  -unfold cut32_n in H.
   destruct ((length l / 32)) eqn:H1.
   +discriminate.
   +fold cut32_n in H.
    inversion H.
    reflexivity.
  -discriminate.
Qed.

Lemma skipn_length : forall (l : list bool), 32 <= length l -> length (skipn 32 l) = length l - 32.
Proof.
  Search skipn.
  intros.
  specialize (firstn_skipn 32 l).
  intros.
  rewrite <- H0.
  rewrite app_length.
  Search firstn.
  rewrite firstn_length_le.
  -rewrite minus_plus.
   rewrite H0.
   reflexivity.
  -auto.
Qed.
Search (_ mod _ = 0).

(* Lemma mod_zero : forall (n m : nat), n mod m = 0 -> n = 0 \/ exists (a : nat),  a * n = m. *)
(* Proof. *)
(*   intros. *)
(*   Search (_ mod _ = 0). *)
(*   apply Nat.div_exact in H. *)
(*   -right. *)
(*    rewrite H. *)
(*    Search (_ * (_ / _)). *)
(*    admit. *)
(*   - *)

Lemma mod_sub : forall (n : nat), n mod 32 = 0 -> (n - 32) mod 32 = 0.
Proof.
  intros.
  specialize (Nat.mod_divides n 32).
  intros.
  assert (32 <> 0) by auto.
  apply H0 in H1.
  apply H1 in H.
  destruct H.
  rewrite H.
  Search (_ * _ - _).
  rewrite <- Nat.mul_pred_r.
  induction x.
  -reflexivity.
  -Search (Nat.pred (S _)).
   rewrite <- pred_Sn.
   Search (_ * _ mod _ = 0).
   Search (_ * _ = _ * _).
   rewrite Nat.mul_comm.
   apply Nat.mod_mul.
   auto.
Qed.

Lemma equal_succ_diff_0 : forall (n' m' : nat), n' = S m' -> 0 < n'.
Proof.
  intros.
  rewrite H.
  Search (0 < S _).
  apply Nat.lt_0_succ.
Qed.

Lemma div_sub : forall (n m k : nat), n <> 0 -> n / m = S k -> (n - m) / m = k.
Proof.
Admitted.

Lemma diff_zero : forall (n : nat), 32 <= n -> n <> 0.
Proof.
  destruct n.
  -Search (_ <= 0).
   intros.
   apply Nat.nle_succ_0 in H.
   inversion H.
  -auto.
Qed.

Lemma cut32_concat_listes : forall (ll : list (list bool)) (l : list bool),
    cut32 l = Some ll -> concat_listes_32 ll = Some l.
Proof.
  induction ll.
  -apply cut32_concat_nil.
  -intros.
   assert (cut32 (skipn 32 l) = Some ll).
   {
     unfold cut32 in H.
     destruct (length l mod 32 =? 0) eqn:H0.
     -destruct (length l / 32) eqn:H1.
      +simpl in H.
       discriminate.
      +unfold cut32_n in H.
       fold cut32_n in H.
       assert (forall (a b : list bool) (l1 l2 : list (list bool)), Some (a :: l1) = Some (b :: l2) -> Some l1 = Some l2).
       {
         intros.
         inversion H2.
         reflexivity.
       }
       apply H2 in H.
       assert (forall (ll1 ll2 : list (list bool)), Some ll1 = Some ll2 -> ll1 = ll2).
       {
         intros. inversion H3. reflexivity.
       }
       apply H3 in H.
       unfold cut32.
       assert (32 <= length l).
       {
         Search (_ / _).
         Check Nat.div_str_pos_iff.
         specialize (Nat.div_str_pos_iff (length l) 32).
         intros.
         assert (32 <> 0) by auto.
         apply H4 in H5.
         apply equal_succ_diff_0 in H1.
         apply H5 in H1.
         auto.
       }
       assert (length (skipn 32 l) mod 32 =? 0 = true).
       {
         assert (length (skipn 32 l) = length l - 32).
         {
           Check skipn_length.
           apply skipn_length.
           auto.
         }
         rewrite H5.
         auto.
         Check mod_sub.
         specialize (mod_sub (length l)).
         intros.
         apply beq_nat_true in H0.
         apply mod_sub in H0.
         rewrite H0.
         reflexivity.
       }
       rewrite H5.
       assert ((length (skipn 32 l) / 32) = n).
       {
         Check skipn_length.
         rewrite skipn_length.
         -apply div_sub in H1.
          auto.
          assert (length l <> 0).
          {
            apply diff_zero in H4.
            auto.
          }
          auto.
         -auto.
       }
       rewrite H6.
       rewrite H.
       reflexivity.
     -discriminate.
   }
   simpl.
   specialize (IHll (skipn 32 l)).
   rewrite IHll.
   +assert (length a =? 32 = true).
    {
      Check cut32_length.
      apply cut32_length in H.
      rewrite H.
      reflexivity.
    }
    rewrite H1.
    assert (l = firstn 32 l ++ skipn 32 l).
    {
      rewrite firstn_skipn.
      reflexivity.
    }
    assert (a = firstn 32 l).
    {
      apply cut32_firstn in H.
      apply commut_equal.
      auto.
    }
    rewrite H3.
    unfold bind.
    rewrite <- H2.
    reflexivity.
   +auto.
Qed.

(* Finals goal of this file, proofs about encode_flux_b and decode_flux_b *)

Lemma encode_decode_flux_decoup : forall (lb : list bool) (l : list instruction),
    encode_flux_b l = Some lb -> decode_flux lb = Some l.
Proof.
  intros.
  unfold encode_flux_b in H.
  destruct encode_flux eqn:H1.
  -Search (encode_flux).
   apply encode_decode_decoup_flux_decoup in H1.
   unfold decode_flux.
   Search concat_listes_32.
   apply concat_listes_cut32 in H.
   rewrite H.
   auto.
  -discriminate.
Qed.

Lemma decode_flux_decoup_encode : forall (lb : list bool) (l : list instruction),
    decode_flux lb = Some l -> encode_flux_b l = Some lb.
Proof.
  intros.
  unfold decode_flux in H.
  unfold encode_flux_b.
  destruct (cut32 lb) eqn:H1.
  -simpl in H. Search (decode_flux_decoup).
   apply decode_decoup_encode_flux in H.
   rewrite H.
   Search cut32.
   apply cut32_concat_listes in H1.
   rewrite H1.
   reflexivity.
  -simpl in H.
   discriminate.
Qed.


Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.ProofTheory.BasicSequentCalculus.
Require Import Logic.GeneralLogic.ShallowEmbedded.PredicateAsLang.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.ProofTheory.Minimum.
Require Import Logic.MinimumLogic.Semantics.Trivial.
Require Import Logic.MinimumLogic.Sound.Sound_Classical_Trivial.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.ProofTheory.Intuitionistic.
Require Import Logic.PropositionalLogic.ProofTheory.Classical.
Require Import Logic.PropositionalLogic.Semantics.Trivial.
Require Import Logic.PropositionalLogic.Sound.Sound_Classical_Trivial.

(* TODO: split part of this file into MinimumLogic folder. *)

Instance Pred_minL (A: Type): MinimumLanguage (Pred_L A) := Build_MinimumLanguage (Pred_L A) Semantics.impp.

Instance Pred_andpL (A: Type): AndLanguage (Pred_L A) := Build_AndLanguage (Pred_L A) Semantics.andp.

Instance Pred_orpL (A: Type): OrLanguage (Pred_L A) := Build_OrLanguage (Pred_L A) Semantics.orp.

Instance Pred_falsepL (A: Type): FalseLanguage (Pred_L A) := Build_FalseLanguage (Pred_L A) Semantics.falsep.

Instance Pred_tminSM (A: Type): TrivialMinimumSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  intros; apply Same_set_refl.
Qed.

Instance Pred_andpSM (A: Type): AndSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
Qed.

Instance Pred_orpSM (A: Type): OrSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
Qed.

Instance Pred_falsepSM (A: Type): FalseSemantics (Pred_L A) (Build_Model A) (Pred_SM A).
Proof.
  constructor.
  + apply Same_set_refl.
Qed.

Instance Pred_Gamma (A: Type): Provable (Pred_L A) :=
  Build_Provable (Pred_L A) (fun x: expr => forall a: A, x a).

Instance Pred_minAX (A: Type): MinimumAxiomatization (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x y ? ? m.
    pose proof @sound_modus_ponens (Pred_L A) _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) x y.
    exact (H1 m (H m) (H0 m)).
  + intros x y.
    exact (@sound_axiom1 (Pred_L A) _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) x y).
  + intros x y z.
    exact (@sound_axiom2 (Pred_L A) _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) x y z).
Qed.

Instance Pred_andpAX (A: Type): AndAxiomatization (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x y.
    exact (@sound_andp_intros (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_andpSM A) x y).
  + intros x y.
    exact (@sound_andp_elim1 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_andpSM A) x y).
  + intros x y.
    exact (@sound_andp_elim2 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_andpSM A) x y).
Qed.

Instance Pred_orpAX (A: Type): OrAxiomatization (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x y.
    exact (@sound_orp_intros1 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_orpSM A) x y).
  + intros x y.
    exact (@sound_orp_intros2 (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_orpSM A) x y).
  + intros x y z.
    exact (@sound_orp_elim (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_orpSM A) x y z).
Qed.

Instance Pred_falsepAX (A: Type): FalseAxiomatization (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  + intros x.
    exact (@sound_falsep_elim (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_falsepSM A) x).
Qed.
(*TODO: need to adjust(about classical)
Instance Pred_cpGamma (A: Type): ClassicalPropositionalLogic (Pred_L A) (Pred_Gamma A).
Proof.
  constructor.
  intros x.
  exact (@sound_excluded_middle (Pred_L A) _ _ (Build_Model A) (Pred_SM A) (Pred_tminSM A) (Pred_tpSM A) x).
Qed.
*)
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Semantics.SemanticEquiv.
Require Import Logic.PropositionalLogic.Semantics.Kripke.

Instance Pred_kiSM (A: Type): @KripkeIntuitionisticSemantics (Pred_L A) (Build_Model A) (unit_kMD _) tt eq (Pred_SM A) :=
  @eqR_KripkeIntuitionistic _ _ _.

Instance Pred_kminSM (A: Type): @KripkeMinimumSemantics (Pred_L A) (Pred_minL A) (Build_Model A) (unit_kMD _) tt eq (Pred_SM A) :=
  @Trivial2Kripke _ _ _ _ (Pred_tminSM A).

Instance Pred_kandpSM (A: Type): @KripkeAndSemantics (Pred_L A) (Pred_andpL A) (Build_Model A) (unit_kMD _) tt (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
Qed.

Instance Pred_korpSM (A: Type): @KripkeOrSemantics (Pred_L A) (Pred_orpL A) (Build_Model A) (unit_kMD _) tt (Pred_SM A).
Proof.
  constructor.
  + intros; apply Same_set_refl.
Qed.

Instance Pred_kfalsepSM (A: Type): @KripkeFalseSemantics (Pred_L A) (Pred_falsepL A) (Build_Model A) (unit_kMD _) tt (Pred_SM A).
Proof.
  constructor.
  + apply Same_set_refl.
Qed.


Require Import Coq.Relations.Relation_Operators.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OSAExamples.
Require Import Logic.SeparationLogic.Model.OSAGenerators.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.ProgramState.
Require Import Logic.HoareLogic.BigStepSemantics.

Local Open Scope kripke_model.
Import KripkeModelNotation_Intuitionistic.

Class Action: Type := {
  action: Type;
  trace := list action;
  traces := trace -> Prop
}.

Definition singleton_trace {Ac: Action} (a: action): trace := cons a nil.

Definition singleton_traces {Ac: Action} (tr: trace): traces := eq tr.

Definition trace_app {Ac: Action}: trace -> trace -> trace := @app _.

Inductive traces_app {Ac: Action}: traces -> traces -> traces :=
  traces_app_intro: forall tr1 tr2 (Tr1 Tr2: traces), Tr1 tr1 -> Tr2 tr2 -> traces_app Tr1 Tr2 (trace_app tr1 tr2).

Class Command2Traces (P: ProgrammingLanguage) (Ac: Action): Type := {
  cmd_denote: cmd -> traces
}.

Class ActionInterpret (state: Type) (Ac: Action): Type := {
  state_enable: action -> state -> MetaState state -> Prop (*;
  state_enable_pf: forall a s ms1 ms2, state_enable a s ms1 -> state_enable a s ms2 -> ms1 = ms2*)
}.

Class TraceSemantics (P: ProgrammingLanguage) (state: Type) (Ac: Action): Type := {
  c2t :> Command2Traces P Ac;
  ac_sem :> ActionInterpret state Ac
}.

Class Action_resource (Ac: Action) (Res: Resource) : Type := {
  Aacquire_res: resource -> action;
  Arelease_res: resource -> action;
}.

Class NormalAction_resource (Ac: Action) (Res: Resource) {Acr: Action_resource Ac Res}: Type := {
  Aacquire_res_inv: forall r1 r2, Aacquire_res r1 = Aacquire_res r2 -> r1 = r2;
  Arelease_res_inv: forall r1 r2, Arelease_res r1 = Arelease_res r2 -> r1 = r2;
  Aacquire_Arelease_res: forall r1 r2, Aacquire_res r1 <> Arelease_res r2;
}.

Definition is_resource_action {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} (r: resource) (a: action) := Aacquire_res r = a \/ Arelease_res r = a.

Definition is_resources_action {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} (a: action) := exists r, is_resource_action r a.

Ltac solve_resource_action :=
  repeat
  match goal with
  | H: Aacquire_res ?r1 = Aacquire_res ?r2 |- _ => apply Aacquire_res_inv in H; subst
  | H: Arelease_res ?r1 = Arelease_res ?r2 |- _ => apply Arelease_res_inv in H; subst
  | H: Aacquire_res ?r1 = Arelease_res ?r2 |- _ => exfalso; apply Aacquire_Arelease_res in H; apply H
  | H: Arelease_res ?r1 = Aacquire_res ?r2 |- _ => exfalso; symmetry in H; apply Aacquire_Arelease_res in H; apply H
  | H: ~ is_resource_action ?r (Aacquire_res ?r) |- _ => exfalso; apply H; left; auto
  | H: ~ is_resource_action ?r (Arelease_res ?r) |- _ => exfalso; apply H; right; auto
  | H: ~ is_resources_action (Aacquire_res ?r) |- _ => exfalso; apply H; exists r; left; auto
  | H: ~ is_resources_action (Arelease_res ?r) |- _ => exfalso; apply H; exists r; right; auto
  end;
  repeat
  let HH := fresh "H" in
  match goal with
  | H: ~ is_resource_action ?r1 (Aacquire_res ?r2) |- _ =>
         specialize (fun (HH: r2 = r1) => H (or_introl (f_equal Aacquire_res (eq_sym HH))))
  | H: ~ is_resource_action ?r1 (Arelease_res ?r2) |- _ =>
         specialize (fun (HH: r2 = r1) => H (or_intror (f_equal Arelease_res (eq_sym HH))))
  end.

Instance Res_Join (Res: Resource): Join resources := Pred_Join resource.

Instance Res_SA (Res: Resource): SeparationAlgebra resources := Pred_SA resource.

(* res_enable A1 A1' A2 := A1 ==> A1' while A2 is the environ *)
Inductive res_enable {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res}: action -> resources -> resources -> resources -> Prop :=
| res_enable_acq: forall r A1 A1' A2, join A1 (eq r) A1' -> ~ A2 r -> res_enable (Aacquire_res r) A1 A1' A2
| res_enable_rel: forall r A1 A1' A2, join A1' (eq r) A1 -> res_enable (Arelease_res r) A1 A1' A2
| res_enable_other: forall a A1 A2, ~ is_resources_action a -> res_enable a A1 A1 A2.

Lemma res_enable_acq_inv {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res}:
  forall r A1 A1' A2, res_enable (Aacquire_res r) A1 A1' A2 -> join A1 (eq r) A1' /\ ~ A2 r.
Proof.
  intros.
  inversion H; subst; solve_resource_action.
  auto.
Qed.

Lemma res_enable_rel_inv {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res}:
  forall r A1 A1' A2, res_enable (Arelease_res r) A1 A1' A2 -> join A1' (eq r) A1.
Proof.
  intros.
  inversion H; subst; solve_resource_action.
  auto.
Qed.

Lemma res_enable_not_res_inv {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} {nAcr: NormalAction_resource Ac Res}:
  forall a A1 A1' A2, ~ is_resources_action a -> res_enable a A1 A1' A2 -> A1 = A1'.
Proof.
  intros.
  inversion H0; subst; solve_resource_action.
  auto.
Qed.

Inductive start_by_Aacq {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res}: resource -> trace -> Prop :=
| start_by_Aacq_nil: forall r, start_by_Aacq r nil
| start_by_Aacq_acq: forall r tr, start_by_Arel r tr -> start_by_Aacq r (cons (Aacquire_res r) tr)
| start_by_Aacq_irr: forall r a tr, ~ is_resource_action r a -> start_by_Aacq r tr -> start_by_Aacq r (cons a tr)
with start_by_Arel {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res}: resource -> trace -> Prop :=
| start_by_Arel_rel: forall r tr, start_by_Aacq r tr -> start_by_Arel r (cons (Arelease_res r) tr)
| start_by_Arel_irr: forall r a tr, ~ is_resource_action r a -> start_by_Arel r tr -> start_by_Arel r (cons a tr).

Class Action_Parallel (Ac: Action): Type := {
  race: action;
  race_actions: action -> action -> Prop;
}.

Class NormalAction_Parallel_resource (Ac: Action) (Res: Resource) {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res}: Type := {
  res_actions_no_race: forall a1 a2, race_actions a1 a2 -> ~ is_resources_action a1 /\ ~ is_resources_action a2;
  race_not_resource: ~ is_resources_action race
}.

Inductive trace_interleave {Ac: Action} {Res: Resource} {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res}: resources -> resources -> trace -> trace -> trace -> Prop :=
| trace_interleave_nil_nil: forall (A1 A2: resources), trace_interleave A1 A2 nil nil nil
| trace_interleave_race: forall (A1 A2: resources) a1 tr1 a2 tr2, race_actions a1 a2 -> trace_interleave A1 A2 (cons a1 tr1) (cons a2 tr2) (cons race nil)
| trace_interleave_left: forall (A1 A1' A2: resources) a1 tr1 tr2 tr, res_enable a1 A1 A1' A2 -> trace_interleave A1' A2 tr1 tr2 tr -> trace_interleave A1 A2 (cons a1 tr1) tr2 (cons a1 tr)
| trace_interleave_right: forall (A1 A2 A2': resources) tr1 a2 tr2 tr, res_enable a2 A2 A2' A1 -> trace_interleave A1 A2' tr1 tr2 tr -> trace_interleave A1 A2 tr1 (cons a2 tr2) (cons a2 tr).

Inductive traces_interleave {Ac: Action} {Res: Resource} {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res}: traces -> traces -> traces :=
| traces_interleave_intro: forall (Tr1 Tr2: traces) tr1 tr2 tr, Tr1 tr1 -> Tr2 tr2 -> trace_interleave (fun _ => False) (fun _ => False) tr1 tr2 tr -> traces_interleave Tr1 Tr2 tr.

Class ActionInterpret_resource (state: Type) (Ac: Action) (Res: Resource) {Acr: Action_resource Ac Res} (ac_sem: ActionInterpret (resources * state) Ac): Type := {
  state_enable_Aacquire_res: forall r (A1 A2: resources) (s: state),
    join A1 (eq r) A2 -> state_enable (Aacquire_res r) (A1, s) (Terminating (A2, s));
  state_enable_Arelease_res: forall r (A1 A2: resources) (s: state),
    join A2 (eq r) A1 -> state_enable (Arelease_res r) (A1, s) (Terminating (A2, s));
  state_enable_non_resource_action1: forall a (A1 A2: resources) (s1 s2: state),
    ~ is_resources_action a -> state_enable a (A1, s1) (Terminating (A2, s2)) -> A1 = A2;
  state_enable_non_resource_action2: forall a (A A': resources) (s: state) (ms: MetaState state),
    ~ is_resources_action a -> state_enable a (A, s) (lift_function (pair A) ms) -> state_enable a (A', s) (lift_function (pair A') ms)
}.

Class ActionInterpret_Parallel_resource (state: Type) {J: Join state} (Ac: Action) {AcP: Action_Parallel Ac} (Res: Resource) {Acr: Action_resource Ac Res} (ac_sem: ActionInterpret (resources * state) Ac): Type := {
  state_enable_race: forall A s ms, state_enable race (A, s) ms <-> ms = Error; (* TODO: is this line necessary? *)
  state_enable_race_actions_spec: forall a1 a2 (A1 A2: resources) (s1 s2 s: state),
      race_actions a1 a2 -> ~ state_enable a1 (A1, s1) Error -> ~ state_enable a2 (A2, s2) Error -> join s1 s2 s -> False
  (* This formalization is critical. Even if there is no ms s.t. stable_enable a1 (s1, A1) ms, it still means (s1, A1) has a domain to perform a1. It's just the result does not match, i.e. the read action. *)
}.

Class Command2Traces_Sresource (P: ProgrammingLanguage) (Ac: Action) (Res: Resource) {Acr: Action_resource Ac Res} {CPR: ConcurrentProgrammingLanguage_Sresource P Res} (c2t: Command2Traces P Ac): Type := {
  Sresource_denote: forall r c, cmd_denote (Sresource r c) = traces_app (singleton_traces (singleton_trace (Aacquire_res r))) (traces_app (cmd_denote c) (singleton_traces (singleton_trace (Arelease_res r))))
}.

Class Command2Traces_Sparallel_resource (P: ProgrammingLanguage) (state: Type) (Ac: Action) (Res: Resource) {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res} {CPP: ConcurrentProgrammingLanguage_Sparallel P} (c2t: Command2Traces P Ac): Type := {
  Sparallel_denote: forall c1 c2, cmd_denote (Sparallel c1 c2) = traces_interleave (cmd_denote c1) (cmd_denote c2)
}.

Class StructuralResourceAccess (P: ProgrammingLanguage) (Ac: Action) (Res: Resource) {Acr: Action_resource Ac Res} (c2t: Command2Traces P Ac): Type := {
  resource_sequential: forall c r tr, cmd_denote c tr -> start_by_Aacq r tr
}.

Definition resource_no_occur {Ac: Action} {Res: Resource} {Acr: Action_resource Ac Res} (r: resource) (Tr: traces): Prop :=
  forall tr, Tr tr -> ~ List.In (Aacquire_res r) tr /\ ~ List.In (Arelease_res r) tr.

Class SAActionInterpret_resource (state: Type) (Ac: Action) (ac_sem: ActionInterpret state Ac) {J: Join state} (G: action -> Prop) : Prop := {
  frame_property: forall (a: action) (m1 f n1: state) (n2: MetaState state),
    G a ->
    join m1 f n1 ->
    state_enable a n1 n2 ->
    exists m2, lift_join m2 (Terminating f) n2 /\ state_enable a m1 m2
}.

Class KActionInterpret_resource (state: Type) (Ac: Action) (ac_sem: ActionInterpret state Ac) {state_R: Relation state}: Prop := {
  ordered_action_interpret: forall (a: action) (m1 n1: state) (n2: MetaState state),
    m1 <= n1 ->
    state_enable a n1 n2 ->
    exists m2, Partial.forward m2 n2 /\ state_enable a m1 m2
}.

Class KSAActionInterpret_resource (state: Type) (Ac: Action) (ac_sem: ActionInterpret state Ac) {J: Join state} {state_R: Relation state} (G: action -> Prop): Prop := {
  ordered_frame_property: forall (a: action) (m1 f n1' n1: state) (n2: MetaState state),
    G a ->
    join m1 f n1' ->
    n1' <= n1 ->
    state_enable a n1 n2  ->
    exists m2 n2', lift_join m2 (Terminating f) n2' /\ Partial.forward n2' n2 /\ state_enable a m1 m2
}.

Lemma ordered_and_frame_AIr {state: Type} {Ac: Action} {ac_sem: ActionInterpret state Ac} {J: Join state} {state_R: Relation state} (G: action -> Prop):
  SAActionInterpret_resource state Ac ac_sem G ->
  KActionInterpret_resource state Ac ac_sem ->
  KSAActionInterpret_resource state Ac ac_sem G.
Proof.
  intros.
  constructor.
  intros.
  pose proof ordered_action_interpret _ _ _ _ H3 H4 as [n2' [? ?]].
  pose proof frame_property _ _ _ _ _ H1 H2 H6 as [m2 [? ?]].
  exists m2, n2'; auto.
Qed.

Inductive trace_access {state: Type} {Ac: Action} {ac_sem: ActionInterpret state Ac}: trace -> state -> MetaState state -> Prop :=
| trace_access_nil: forall s, trace_access nil s (Terminating s)
| trace_access_NonTerminating: forall a tr s, state_enable a s NonTerminating -> trace_access (cons a tr) s NonTerminating
| trace_access_Error: forall a tr s, state_enable a s Error -> trace_access (cons a tr) s Error
| trace_access_Terminating: forall a tr s s' ms, state_enable a s (Terminating s') -> trace_access tr s' ms -> trace_access (cons a tr) s ms.

Inductive traces_access {state: Type} {Ac: Action} {ac_sem: ActionInterpret state Ac}: traces -> state -> MetaState state -> Prop :=
| traces_access_intro: forall tr (Tr: traces) s ms, Tr tr -> trace_access tr s ms -> traces_access Tr s ms.

(* TODO: maybe not necessary *)
Lemma trace_access_Terminating_inv {state: Type} {Ac: Action} {ac_sem: ActionInterpret state Ac}:
  forall P a tr s ms,
    trace_access (cons a tr) s ms ->
    (forall ms', state_enable a s ms' -> exists s', P s' /\ ms' = Terminating s') ->
    (exists s', P s' /\ trace_access tr s' ms).
Proof.
  intros.
  inversion H; subst.
  + apply H0 in H5.
    destruct H5 as [? [? ?]].
    inversion H2.
  + apply H0 in H5.
    destruct H5 as [? [? ?]].
    inversion H2.
  + apply H0 in H3.
    destruct H3 as [? [? ?]].
    inversion H2; subst.
    exists x; auto.
Qed.

Definition TS2BSS {P: ProgrammingLanguage} {state: Type} {Ac: Action} {Res: Resource} (TS: TraceSemantics P (resources * state) Ac): BigStepSemantics P state :=
  Build_BigStepSemantics _ _ (fun s c ms => traces_access (cmd_denote c) (fun _ => False, s) (lift_function (pair ( fun _ => False)) ms)).

Definition is_upper_bound {A: Type} {R: Relation A} (s: A -> Prop) (a: A): Prop :=
  forall a0, s a0 -> a0 <= a.

Definition greatest {A: Type} {R: Relation A} (s: A -> Prop) (a: A): Prop :=
  s a /\ is_upper_bound s a.

Inductive thread_local_state_enable {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} {ac_sem: ActionInterpret (resources * state) Ac} (Inv: resource * (state -> Prop) -> Prop) : action -> resources * state -> MetaState (resources * state) -> Prop :=
| thread_local_state_enable_acq: forall r A1 A2 I m f n,
    join A1 (eq r) A2 ->
    Inv (r, I) -> I f ->
    join m f n ->
    thread_local_state_enable Inv (Aacquire_res r) (A1, m) (Terminating (A2, n))
| thread_local_state_enable_rel_succ: forall r A1 A2 I m n,
    join A2 (eq r) A1 ->
    Inv (r, I) ->
    greatest (fun n => exists f, I f /\ join n f m) n ->
    thread_local_state_enable Inv (Arelease_res r) (A1, m) (Terminating (A2, n))
| thread_local_state_enable_rel_fail: forall r A1 A2 I m,
    join A2 (eq r) A1 ->
    Inv (r, I) ->
    (forall n, ~ exists f, I f /\ join n f m) ->
    thread_local_state_enable Inv (Arelease_res r) (A1, m) Error
| thread_local_state_enable_non_resource: forall a s s',
    ~ is_resources_action a ->
    state_enable a s s' ->
    thread_local_state_enable Inv a s s'.

Lemma thread_local_state_enable_non_resource_action {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} {ac_sem: ActionInterpret (resources * state) Ac}:
  forall Inv a s s',
    ~ is_resources_action a ->
    (state_enable a s s' <-> thread_local_state_enable Inv a s s').
Proof.
  intros.
  split; intros.
  + constructor; auto.
  + inversion H0; subst; solve_resource_action.
    auto.
Qed.

Definition ThreadLocal_ActionInterpret_resource {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} (ac_sem: ActionInterpret (resources * state) Ac) (Inv: resource * (state -> Prop) -> Prop): ActionInterpret (resources * state) Ac :=
  Build_ActionInterpret _ _ (thread_local_state_enable Inv).

Definition ThreadLocal_BSS {P: ProgrammingLanguage} {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {Acr: Action_resource Ac Res} (TS: TraceSemantics P (resources * state) Ac) (Inv: resource * (state -> Prop) -> Prop): BigStepSemantics P state :=
  TS2BSS (Build_TraceSemantics _ _ _ c2t (ThreadLocal_ActionInterpret_resource ac_sem Inv)).

Definition ThreadLocal_AIPr {state: Type} {Ac: Action} {Res: Resource} {J: Join state} {state_R: Relation state} {AcP: Action_Parallel Ac} {Acr: Action_resource Ac Res} {nAcPr: NormalAction_Parallel_resource Ac Res} {ac_sem: ActionInterpret (resources * state) Ac} {AIPr: ActionInterpret_Parallel_resource state Ac Res ac_sem}: forall (Inv: resource * (state -> Prop) -> Prop), ActionInterpret_Parallel_resource state Ac Res (ThreadLocal_ActionInterpret_resource ac_sem Inv).
  intros.
  constructor.
  + intros.
    simpl.
    rewrite <- (state_enable_race A s ms).
    rewrite (thread_local_state_enable_non_resource_action Inv) by (apply race_not_resource).
    tauto.
  + intros.
    simpl in H0, H1.
    destruct (res_actions_no_race _ _ H).
    rewrite <- (thread_local_state_enable_non_resource_action Inv) in H0, H1 by auto.
    revert H H0 H1 H2.
    apply state_enable_race_actions_spec.
Qed.


Require Import FP.Core.

Inductive v_step S A :=
  | v_Done : v_step S A
  | v_Yield : A -> S -> v_step S A.

Inductive v_stream A := v_Stream
  { v_streamS : Type
  ; v_streamSeed : v_streamS
  ; v_streamStep : v_step v_streamS A
  }.

Definition stream (A:qtype) := lib (v_stream (dom A)).


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Export Raxioms.
Require Export LegacyField.
Import LegacyRing_theory.

Section LegacyRfield.

Open Scope R_scope.

Lemma RLegacyTheory : Ring_Theory Rplus Rmult 1 0 Ropp (fun x y:R => false).
  split.
  exact Rplus_comm.
  symmetry  in |- *; apply Rplus_assoc.
  exact Rmult_comm.
  symmetry  in |- *; apply Rmult_assoc.
  intro; apply Rplus_0_l.
  intro; apply Rmult_1_l.
  exact Rplus_opp_r.
  intros.
  rewrite Rmult_comm.
  rewrite (Rmult_comm n p).
  rewrite (Rmult_comm m p).
  apply Rmult_plus_distr_l.
  intros; contradiction.
Defined.

End LegacyRfield.

Add Legacy Field
R Rplus Rmult 1%R 0%R Ropp (fun x y:R => false) Rinv RLegacyTheory Rinv_l
  with minus := Rminus div := Rdiv.


From iris.base_logic Require Export invariants.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang proofmode notation.
From iris.prelude Require Import options.

Definition nondet_bool : val :=
  λ: <>, let: "l" := ref #true in Fork ("l" <- #false);; !"l".

Section proof.
  Context `{!heapG Σ}.

  Lemma nondet_bool_spec : {{{ True }}} nondet_bool #() {{{ (b : bool), RET #b; True }}}.
  Proof.
    iIntros (Φ) "_ HΦ".
    wp_lam. wp_alloc l as "Hl". wp_let.
    pose proof (nroot .@ "rnd") as rndN.
    iMod (inv_alloc rndN _ (∃ (b : bool), l ↦ #b)%I with "[Hl]") as "#Hinv";
      first by eauto.
    wp_apply wp_fork.
    - iInv rndN as (?) "?". wp_store; eauto.
    - wp_seq. iInv rndN as (?) "?". wp_load.
      iSplitR "HΦ"; first by eauto.
      by iApply "HΦ".
  Qed.

End proof.


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 O E Eprime A B C Bprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ O Eprime Bprime /\ col_ O Eprime A)))))))))) -> col_ O E Eprime)).
Proof.
  time tac.
Qed.

End FOFProblem.


Set Implicit Arguments.
Unset Strict Implicit.

Require Export nnum_base.
Require Import aac.
Require Export quotient.

Module ZTemp.
Import nNum_ring.
Export Quotient.
Import Ordered_lci.
Export Pow.

Section NotaSec.

Definition zEquiv x y := (nPlus (P x) (Q y) = nPlus (P y) (Q x)).

Definition zNum := quotient zEquiv (product nNum nNum).

Notation "[ x ]" := (class_of zEquiv (product nNum nNum) x).

Definition z0 := [J n0 n0].

Definition z1 := [J n1 n0].

Lemma zEquiv_equiv : is_equivalence zEquiv (product nNum nNum).
Proof.
uhg;ee;uhg;ir.
product_nin H. ee. subst.
uhg. clpr. tv.
product_nin H;product_nin H0;ee;subst.
uh H1;uhg. clpri H1;clpr. au.
product_nin H;product_nin H0;product_nin H2;ee;subst.
uh H3;uh H1;uhg.
clpri H1;clpri H3. clpr.
apply nPlus_reg_l with x3;nSolveS.
rw nPlus_assoc. rw (nPlus_comm x3). rw H1.
wr nPlus_assoc. rw (nPlus_comm x1). rw nPlus_assoc.
rw H3. AAC_all.aac_solve_all (nPlus_assoc) (nPlus_comm).
Qed.

Lemma zNum_inc_rw : forall x, inc x zNum = (exists a, exists b, inc a nNum & inc b nNum & x = [J a b]).
Proof.
ir;ap iff_eq;ir.
apply Z_pr in H. nin H.
product_nin H. exists x0;exists x1;ee;au. ap uneq;am.
nin H;nin H;ee;subst.
ap class_in_quotient. ap class_of_class. ap product_pair_inc;am.
Qed.

Lemma zNum_inc : forall a, inc a nNum -> forall b, inc b nNum ->
inc [J a b] zNum.
Proof.
ir. rw zNum_inc_rw. exists a;exists b;ee;au.
Qed.

Lemma z0_inc : inc z0 zNum.
Proof.
ap zNum_inc;nSolveS.
Qed.

Lemma z1_inc : inc z1 zNum.
Proof.
ap zNum_inc;nSolveS.
Qed.

Definition zPlus := quotient_op zEquiv (product nNum nNum) zEquiv (product nNum nNum) (fun x y => J (nPlus (P x) (P y)) (nPlus (Q x) (Q y))).

Lemma zPlus_passes_p : forall x, inc x (product nNum nNum) -> forall y, inc y (product nNum nNum) ->
zPlus [x] [y] = [J (nPlus (P x) (P y)) (nPlus (Q x) (Q y))].
Proof.
uf zPlus.
ap quotient_op_passes.

ap zEquiv_equiv. ap zEquiv_equiv.
ir. product_nin H;product_nin H0.
ee;subst. clpr. ap product_pair_inc;nSolveS.
ir. product_nin H;product_nin H0;product_nin H2;product_nin H3.
ee;subst. clpr. uh H4;uh H1.
clpri H4;clpri H1.
uhg. clpr.
transitivity (nPlus (nPlus x0 x3) (nPlus x4 x7)).
AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
rw H1;rw H4. AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
Qed.

Lemma zPlus_passes : forall a, inc a nNum -> forall b, inc b nNum ->
forall a', inc a' nNum -> forall b', inc b' nNum ->
zPlus [J a b] [J a' b'] = [J (nPlus a a') (nPlus b b')].
Proof.
ir. rw zPlus_passes_p. clpr. tv.
apply product_pair_inc;am. apply product_pair_inc;am.
Qed.

Lemma zPlus_lci : is_lci zPlus zNum.
Proof.
uhg;ir. rwi zNum_inc_rw H;rwi zNum_inc_rw H0.
nin H;nin H;nin H0;nin H0;ee;subst.
rw zPlus_passes;au. ap zNum_inc;nSolveS.
Qed.

Lemma zPlus_comm : commutative zPlus zNum.
Proof.
uhg;ir. rwi zNum_inc_rw H;rwi zNum_inc_rw H0.
nin H;nin H;nin H0;nin H0;ee;subst.
rw zPlus_passes;au. rw zPlus_passes;au.
rw nPlus_comm. ap uneq. ap uneq. ap nPlus_comm.
Qed.

Lemma zPlus_assoc : associative zPlus zNum.
Proof.
uhg;ir. rwi zNum_inc_rw H;rwi zNum_inc_rw H0;rwi zNum_inc_rw H1.
nin H;nin H;nin H0;nin H0;nin H1;nin H1;ee;subst.
rw zPlus_passes;au. rw zPlus_passes;nSolveS.
rw zPlus_passes;nSolveS. rw zPlus_passes;nSolveS.
rw nPlus_assoc. rw nPlus_assoc. tv.
Qed.

Lemma z0_eq : forall a, inc a nNum -> [J a a] = z0.
Proof.
ir. ap related_classes_eq.
ap zEquiv_equiv.
ap product_pair_inc;au.
ap product_pair_inc;nSolveS.
uhg. clpr. ap nPlus_comm.
Qed.

Lemma zNum_eq : forall a, inc a nNum -> forall b, inc b nNum ->
forall c, inc c nNum -> forall d, inc d nNum ->
([J a b] = [J c d]) = (zEquiv (J a b) (J c d)).
Proof.
ir. ap iff_eq;ir.
eapply class_of_eq_related.
ap zEquiv_equiv. ap product_pair_inc;am.
ap product_pair_inc;am. am.
ap related_classes_eq. ap zEquiv_equiv.
apply product_pair_inc;am. apply product_pair_inc;am.
am.
Qed.

Lemma zPlus_z0_l : forall x, inc x zNum -> zPlus z0 x = x.
Proof.
ir. rwi zNum_inc_rw H. nin H;nin H;ee;subst.
uf z0. rw zPlus_passes;nSolveS.
rw nPlus_0_l. rw nPlus_0_l. tv. am. am.
Qed.

Lemma zPlus_z0_r : forall x, inc x zNum -> zPlus x z0 = x.
Proof.
ir. rw zPlus_comm. ap zPlus_z0_l. am.
am. ap z0_inc.
Qed.

Lemma zPlus_z0_neutre : is_neutre zPlus zNum z0.
Proof.
uhg;ee. ap z0_inc. ap zPlus_z0_r. ap zPlus_z0_l.
Qed.

Lemma zPlus_monoid : is_monoid zPlus zNum z0.
Proof.
uhg;ee.
ap zPlus_lci. ap zPlus_z0_neutre. ap zPlus_assoc.
Qed.

Lemma zPlus_inversible : forall x, inc x zNum -> inversible zPlus zNum z0 x.
Proof.
ir. rwi zNum_inc_rw H;nin H;nin H;ee;subst.
exists [J x1 x0]. uhg;ee.
ap zNum_inc;am. ap zNum_inc;am.
rw zPlus_passes;au. rw nPlus_comm.
ap z0_eq. nSolveS.
rw zPlus_passes;au. rw nPlus_comm.
ap z0_eq. nSolveS.
Qed.

Lemma zPlus_group : is_group zPlus zNum z0.
Proof.
uhg;ee;try ap zPlus_monoid.
ap zPlus_inversible.
Qed.

Definition zOpp := Lci.inverse_of zPlus zNum z0.

Lemma zOpp_inverse : forall x, inc x zNum -> Lci.are_inverse zPlus zNum z0 x (zOpp x).
Proof.
ir. ap group_inverse_of. ap zPlus_group. am.
Qed.

Lemma zOpp_inc : forall x, inc x zNum -> inc (zOpp x) zNum.
Proof.
ir;ap zOpp_inverse;am.
Qed.

Lemma zOpp_rw : forall a, inc a nNum -> forall b, inc b nNum ->
zOpp [J a b] = [J b a].
Proof.
ir. eapply Lci.inverse_unicity.
ap zPlus_monoid.
ap zOpp_inverse. ap zNum_inc;am.
uhg;ee;try (ap zNum_inc;am).
rw zPlus_passes;au. rw nPlus_comm.
ap z0_eq. nSolveS.
rw zPlus_passes;au. rw nPlus_comm.
ap z0_eq. nSolveS.
Qed.

Lemma zOpp_l : forall x, inc x zNum -> zPlus (zOpp x) x = z0.
Proof.
ir. ap zOpp_inverse. am.
Qed.

Lemma zOpp_r : forall x, inc x zNum -> zPlus x (zOpp x)  = z0.
Proof.
ir. ap zOpp_inverse. am.
Qed.

Lemma z0_z1_neq : z0<>z1.
Proof.
uhg;ir.
ufi z0 H;ufi z1 H.
apply class_of_eq_related in H.
uh H;clpri H.
rwi nPlus_0 H;nSolveS.
rwi nPlus_0 H;nSolveS.
eapply ordinal_inc_neq. ap ordinal_S. ap emptyset_ordinal.
Focus 2. ap H.
rw oS_inc;au.
ap zEquiv_equiv.
ap product_pair_inc;nSolveS. ap product_pair_inc;nSolveS.
Qed.

(*(a-b)*(c-d) = (ac+bd) - (b c + a d)*)
Definition zMult0 :=  (fun x y => let a := P x in let b := Q x in let c := P y in let d := Q y in
J (nPlus (nMult a c) (nMult b d)) (nPlus (nMult b c) (nMult a d))).

Definition zMult := quotient_op zEquiv (product nNum nNum)
zEquiv (product nNum nNum) zMult0.

Lemma zEquiv_zMult0_compat : Ordered_lci.is_compatible zEquiv zMult0 (product nNum nNum).
Proof.
ap Ordered_lci.invariant_transitive_compat.
ap zEquiv_equiv. uhg;ir.
product_nin H;product_nin H0;uf zMult0. subst;clpr.
ap product_pair_inc;nSolveS.

uhg. dj.
uhg;ir.
product_nin H;product_nin H0;product_nin H1. subst.
uh H2;clpri H2.
uhg;uf zMult0;clpr.
transitivity (nPlus (nPlus (nMult x2 x0) (nMult x5 x0)) (nPlus (nMult x3 x1) (nMult x4 x1))).
AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
wr nMult_distrib_r. rw H2. wr nMult_distrib_r.
rw nMult_distrib_r. rw (nPlus_comm x3). wr H2.
rw nMult_distrib_r.
AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
uh H. uhg.
assert (forall x y, zMult0 x y = zMult0 y x).
ir;uf zMult0. rw nMult_comm. rw (nMult_comm (Q x)).
ap uneq. rw nPlus_comm. rw nMult_comm. ap uneq.
ap nMult_comm.
ir. rw H0. rw (H0 x). ap H. am. am. am. am.
Qed.

Lemma zMult_passes_p : forall x, inc x (product nNum nNum) -> forall y, inc y (product nNum nNum) ->
zMult [x] [y] = [J (nPlus (nMult (P x) (P y)) (nMult (Q x) (Q y))) (nPlus (nMult (Q x) (P y)) (nMult (P x) (Q y)))].
Proof.
ir. uf zMult.
rw quotient_op_passes. tv.
ap zEquiv_equiv. ap zEquiv_equiv.
clear H;clear H0;clear x;clear y.
ir. uf zMult0.
product_nin H. product_nin H0. ee;subst.
clpr. ap product_pair_inc;nSolveS.

clear H;clear H0;clear x;clear y.

ir. ap zEquiv_zMult0_compat;am.
am. am.
Qed.

Lemma zMult_passes : forall a, inc a nNum -> forall b, inc b nNum ->
forall c, inc c nNum -> forall d, inc d nNum ->
zMult [J a b] [J c d] = [J (nPlus (nMult a c) (nMult b d)) (nPlus (nMult b c) (nMult a d))].
Proof.
ir. rw zMult_passes_p. clpr. tv.
ap product_pair_inc;am. ap product_pair_inc;am.
Qed.
(*beautiful*)

Lemma zMult_lci : is_lci zMult zNum.
Proof.
uhg;ir. rwi zNum_inc_rw H;rwi zNum_inc_rw H0.
nin H;nin H;nin H0;nin H0;ee;subst.
rw zMult_passes;au. ap zNum_inc;nSolveS.
Qed.

Lemma zMult_comm : commutative zMult zNum.
Proof.
uhg;ir. rwi zNum_inc_rw H;rwi zNum_inc_rw H0.
nin H;nin H;nin H0;nin H0;ee;subst.
rw zMult_passes;au. rw zMult_passes;au.
ap uneq. rw nMult_comm. rw (nMult_comm x1). ap uneq.
rw nPlus_comm. rw nMult_comm. ap uneq.
ap nMult_comm.
Qed.

Lemma zMult_assoc : associative zMult zNum.
Proof.
uhg;ir. rwi zNum_inc_rw H;rwi zNum_inc_rw H0;rwi zNum_inc_rw H1.
nin H;nin H;nin H0;nin H0; nin H1;nin H1;ee;subst.
rw zMult_passes;au. rw zMult_passes;nSolveS.
rw zMult_passes;au. rw zMult_passes;nSolveS.
ap uneq.
ap uneq2.
rw nMult_distrib_r. rw nMult_distrib_r.
rw nMult_distrib_l. rw nMult_distrib_l.
repeat wr nMult_assoc.
AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
rw nMult_distrib_r. rw nMult_distrib_r.
rw nMult_distrib_l. rw nMult_distrib_l.
repeat wr nMult_assoc.
AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
Qed.

Lemma zMult_0_l : forall x, inc x zNum -> zMult z0 x = z0.
Proof.
ir. rwi zNum_inc_rw H. nin H;nin H;ee;subst.
uf z0. rw zMult_passes;nSolveS.
rw nMult_0_l. rw nMult_0_l. rw nPlus_0;nSolveS.
Qed.

Lemma zMult_0_r : forall x, inc x zNum -> zMult x z0 = z0.
Proof.
ir. rw zMult_comm;au. ap zMult_0_l;au.
ap z0_inc.
Qed.

Lemma zMult_1_l : forall x, inc x zNum -> zMult z1 x = x.
Proof.
ir. uf z1;rwi zNum_inc_rw H;nin H;nin H;ee;subst.
rw zMult_passes;nSolveS.
rw nMult_1_l;nSolveS. rw nMult_0_l. rw nMult_0_l.
rw nMult_1_l;nSolveS. rw nPlus_0;nSolveS. rw nPlus_0_l;nSolveS.
Qed.

Lemma zMult_1_r : forall x, inc x zNum -> zMult x z1 = x.
Proof.
ir. rw zMult_comm;au. ap zMult_1_l;au.
ap z1_inc.
Qed.

Lemma zMult_1_neutre : is_neutre zMult zNum z1.
Proof.
uhg;ee. ap z1_inc. ap zMult_1_r. ap zMult_1_l.
Qed.

Lemma zMult_monoid : is_monoid zMult zNum z1.
Proof.
uhg;ee. ap zMult_lci. ap zMult_1_neutre.
ap zMult_assoc.
Qed.

Lemma zNum_pos_neg : forall x, inc x zNum =
((exists a, inc a nNum & x = [J a emptyset])\/(exists b, inc b nNum & x = [J emptyset b])).
Proof.
ir;ap iff_eq;ir.
rwi zNum_inc_rw H;nin H;nin H;ee;subst.
destruct nLeq_total with x0 x1;try am;rwi nLeq_rw H1;au;nin H1;ee;subst.
right. exists x;ee. am.
ap related_classes_eq. ap zEquiv_equiv.
ap product_pair_inc;nSolveS.
ap product_pair_inc;nSolveS.
uhg;clpr.
rw nPlus_0_l;nSolveS.
left. exists x;ee. am.
ap related_classes_eq. ap zEquiv_equiv.
ap product_pair_inc;nSolveS.
ap product_pair_inc;nSolveS.
uhg;clpr.
rw nPlus_0;nSolveS. ap nPlus_comm.
nin H;nin H;ee;subst;ap zNum_inc;nSolveS.
Qed.

Lemma z0_eq_pr : forall a, inc a nNum -> forall b, inc b nNum ->
[J a b] = z0 -> a=b.
Proof.
ir. apply class_of_eq_related in H1.
uh H1;clpri H1. rwi nPlus_0 H1;au. rw H1.
ap nPlus_0_l;au.
ap zEquiv_equiv.
ap product_pair_inc;am.
ap product_pair_inc;ap n0_inc.
Qed.

Lemma zMult_integral : is_integral zMult zNum z0.
Proof.
uhg;ir.
rwi zNum_pos_neg H;rwi zNum_pos_neg H0.
nin H;nin H0;nin H;nin H0;ee;subst;
rwi zMult_passes H1;nSolveS;repeat rwi nMult_0 H1;repeat rwi nMult_0_l H1.
rwi nPlus_0 H1;nSolveS. rwi nPlus_0 H1;nSolveS.
apply z0_eq_pr in H1;nSolveS.
apply nMult_integral_all in H1. nin H1;subst.
left. tv.
right. tv.
rwi nPlus_0 H1;nSolveS. rwi nPlus_0_l H1;nSolveS.
apply z0_eq_pr in H1;nSolveS. symmetry in H1.
apply nMult_integral_all in H1. nin H1;subst.
left. tv.
right. tv.
rwi nPlus_0 H1;nSolveS. rwi nPlus_0 H1;nSolveS.
apply z0_eq_pr in H1;nSolveS. symmetry in H1.
apply nMult_integral_all in H1. nin H1;subst.
left. tv.
right. tv.
rwi nPlus_0 H1;nSolveS. rwi nPlus_0_l H1;nSolveS.
apply z0_eq_pr in H1;nSolveS.
apply nMult_integral_all in H1. nin H1;subst.
left. tv.
right. tv.
Qed.

Lemma zPlus_regular : is_regular zPlus zNum.
Proof.
ap (group_is_regular zPlus_group).
Qed.

Lemma zPlus_reg_l : is_reg_l zPlus zNum.
Proof.
ap zPlus_regular.
Qed.

Lemma zPlus_reg_r : is_reg_r zPlus zNum.
Proof.
ap zPlus_regular.
Qed.

Lemma zMult_distrib_l : distrib_l zPlus zMult zNum.
Proof.
uhg. ir.
rwi zNum_inc_rw H;rwi zNum_inc_rw H0;rwi zNum_inc_rw H1.
nin H;nin H;nin H0;nin H0;nin H1;nin H1. ee;subst.
rw zPlus_passes;nSolveS. rw zMult_passes;nSolveS.
rw zMult_passes;nSolveS. rw zMult_passes;nSolveS.
rw zPlus_passes;nSolveS.
rw nMult_distrib_l. rw nMult_distrib_l.
rw nMult_distrib_l.  rw nMult_distrib_l.
ap uneq. ap uneq2;AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
Qed.

Lemma zMult_distrib_r : distrib_r zPlus zMult zNum.
Proof.
uhg;ir. rw zMult_comm.
rw zMult_distrib_l;try am.
ap uneq2;ap zMult_comm;am.
ap zPlus_lci;am.
am.
Qed.

Lemma zMult_distributes : distributes zPlus zMult zNum.
Proof.
uhg;ee. ap zMult_distrib_l. ap zMult_distrib_r.
Qed.

Lemma zNum_ring : is_ring zPlus zMult zNum z0 z1.
Proof.
uhg;ee. ap zPlus_group. ap zPlus_comm. ap zMult_monoid.
 ap zMult_distributes.
Qed.

Definition zMult_reg_l := integral_quasiregular_left zNum_ring zMult_integral.
Definition zMult_reg_r := integral_quasiregular_right zNum_ring zMult_integral.

(*(a-b) <= (c-d) iff a+d <= c+b*)
Inductive zLeq : E2P :=
  | zLeq_in : forall a, inc a nNum -> forall b, inc b nNum -> forall c, inc c nNum -> forall d, inc d nNum ->
nLeq (nPlus a d) (nPlus c b) -> zLeq [J a b] [J c d].

Lemma zLeq_rw : forall a, inc a nNum -> forall b, inc b nNum -> forall c, inc c nNum -> forall d, inc d nNum ->
zLeq [J a b] [J c d] = nLeq (nPlus a d) (nPlus c b).
Proof.
ir. ap iff_eq;ir.
inversion H3.
apply class_of_eq_related in H4;try ap zEquiv_equiv;try ap product_pair_inc;nSolveS.
apply class_of_eq_related in H5;try ap zEquiv_equiv;try ap product_pair_inc;nSolveS.
uh H4;uh H5;clpri H4;clpri H5.
rwi nLeq_rw H10;nSolveS.
nin H10;ee.
apply nLeq_nPlus_reg_l with (nPlus b0 c0);nSolveS.
replace (nPlus (nPlus b0 c0) (nPlus a d)) with (nPlus (nPlus a0 b) (nPlus c d0)).
Focus 2. rw H4. wr H5. AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
rwi nPlus_comm H11. rw H11.
rw nLeq_rw;nSolveS.
exists x;ee. am.
AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
constructor;am.
Qed.

Lemma zLeq_inc : forall x y, zLeq x y -> (inc x zNum & inc y zNum).
Proof.
ir. nin H. ee;ap zNum_inc;am.
Qed.

Lemma zLeq_refl : reflexiveT zLeq zNum.
Proof.
uhg;ir. rwi zNum_inc_rw H;nin H;nin H;ee;subst.
constructor;try am. ap sub_refl.
Qed.

Lemma zLeq_antisym : antisymmetricT zLeq zNum.
Proof.
uhg;ir. nin H1.
rwi zLeq_rw H2;nSolveS.
cp (extensionality H2 H6).
ap related_classes_eq. ap zEquiv_equiv.
ap product_pair_inc;am. ap product_pair_inc;am.
uhg. clpr. au.
Qed.

Lemma zLeq_zMult_preserves : Ordered_ring.order_preserves zLeq zMult zNum z0.
Proof.
uhg. ir.
rwi zNum_inc_rw H. rwi zNum_inc_rw H1.
nin H;nin H;nin H1;nin H1;ee;subst.
ufi z0 H2. ufi z0 H0.
rwi zLeq_rw H2;nSolveS. rwi zLeq_rw H0;nSolveS.
rwi nPlus_0 H2;nSolveS. rwi nPlus_0_l H2;nSolveS.
rwi nPlus_0 H0;nSolveS. rwi nPlus_0_l H0;nSolveS.
rw zMult_passes;nSolveS.
uf z0. constructor;nSolveS.
rw nPlus_0;nSolveS. rw nPlus_0_l;nSolveS.
rwi nLeq_rw H2;nSolveS.
rwi nLeq_rw H0;nSolveS.
nin H2;nin H0;ee;subst.
rw nMult_distrib_r. rw nMult_distrib_r.
rw nMult_distrib_l. rw nMult_distrib_l.
rw nLeq_rw;nSolveS.
exists (nMult x4 x). ee. nSolveS.
AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
Qed.

Lemma zPos_rw : forall x, zLeq z0 x = exists a, inc a nNum & x = [J a emptyset].
Proof.
ir. ap iff_eq;ir.
cp (zLeq_inc H). ee.
rwi zNum_inc_rw H1. nin H1;nin H1;ee;subst.
ufi z0 H. rwi zLeq_rw H;nSolveS.
rwi nPlus_0 H;nSolveS. rwi nPlus_0_l H;nSolveS.
rwi nLeq_rw H;nSolveS. nin H;ee;subst.
exists x;ee. am.
ap related_classes_eq;try ap product_pair_inc;nSolveS.
ap zEquiv_equiv. uhg;clpr.
rw nPlus_0;nSolveS. ap nPlus_comm.
nin H;ee;subst. uf z0. constructor;nSolveS.
rw nPlus_0;nSolveS.
Qed.

Lemma zLeq_total : is_total zLeq zNum.
Proof.
uhg;ir. rwi zNum_inc_rw H;rwi zNum_inc_rw H0.
nin H;nin H;nin H0;nin H0;ee;subst.
rw zLeq_rw;nSolveS. rw zLeq_rw;nSolveS.
ap nLeq_total;nSolveS.
Qed.

Lemma zNeg_rw : forall x, zLeq x z0 = exists b, inc b nNum & x = [J n0 b].
Proof.
ir. ap iff_eq;ir.
cp (zLeq_inc H). ee.
rwi zNum_inc_rw H0. nin H0;nin H0;ee;subst.
ufi z0 H. rwi zLeq_rw H;nSolveS.
rwi nPlus_0 H;nSolveS. rwi nPlus_0_l H;nSolveS.
rwi nLeq_rw H;nSolveS. nin H;ee;subst.
exists x;ee. am.
ap related_classes_eq;try ap product_pair_inc;nSolveS.
ap zEquiv_equiv. uhg;clpr.
rw nPlus_0_l;nSolveS.
nin H;ee;subst. uf z0. constructor;nSolveS.
rw nPlus_0;nSolveS.
Qed.

Lemma zLeq_ex_rw : forall x, inc x zNum -> forall y, inc y zNum ->
zLeq x y = exists z, inc z zNum & zLeq z0 z & y = zPlus x z.
Proof.
ir;ap iff_eq;ir.
nin H1.
rwi nLeq_rw H5;nSolveS. nin H5;ee.
exists [J x n0].
ee. ap zNum_inc;nSolveS.
uf z0. rw zLeq_rw;nSolveS.
rw nPlus_0;nSolveS.
rw zPlus_passes;nSolveS.
rw nPlus_0;nSolveS.
ap related_classes_eq;try ap product_pair_inc;nSolveS.
ap zEquiv_equiv.
uhg;clpr. rw H6.
AAC_all.aac_solve_all nPlus_assoc nPlus_comm.

nin H1;ee;subst.
rwi zNum_inc_rw H;nin H;nin H;ee;subst.
rwi zPos_rw H2. nin H2;ee;subst.
rw zPlus_passes;nSolveS. rw zLeq_rw;nSolveS.
rw nPlus_0;nSolveS. rw nLeq_rw;nSolveS.
 exists x;ee. am.
AAC_all.aac_solve_all nPlus_assoc nPlus_comm.
Qed.

Lemma zLeq_trans : transitiveT zLeq zNum.
Proof.
uhg;ir.
rwi zLeq_ex_rw H1;try am. rwi zLeq_ex_rw H3;try am.
rw zLeq_ex_rw;try am.
nin H1;nin H3;ee;subst.
exists (zPlus x0 x1).
ee. ap zPlus_lci;am.

rwi zPos_rw H6. rwi zPos_rw H4. nin H6;nin H4;ee;subst.
rw zPlus_passes;nSolveS. rw nPlus_0;nSolveS.
rw zPos_rw. exists (nPlus x2 x3);ee;nSolveS.
AAC_lci.aac_solve_lci zPlus zPlus_lci zPlus_assoc zPlus_comm;am.
Qed.

Lemma zLeq_order : is_order zLeq zNum.
Proof.
uhg;ee. ap zLeq_refl. ap zLeq_antisym. ap zLeq_trans.
Qed.

Lemma zLeq_etrans : forall x y, zLeq x y -> forall z, zLeq y z ->
zLeq x z.
Proof.
ir. cp (zLeq_inc H). cp (zLeq_inc H0). ee.
apply zLeq_trans with y;am.
Qed.

Lemma zLeq_total_order : is_total_order zLeq zNum.
Proof.
uhg;ee. ap zLeq_order. ap zLeq_total.
Qed.

Lemma zLeq_zPlus_compat : Ordered_lci.is_compatible zLeq zPlus zNum.
Proof.
ap Ordered_lci.invariant_compat. ap zLeq_order. ap zPlus_lci.
uhg. dj.
uhg;ir.
rwi zLeq_ex_rw H2;try am. nin H2;ee;subst.
rw zLeq_ex_rw;try am;try ap zPlus_lci;try am.
exists x0;ee. am. am.
AAC_lci.aac_solve_lci zPlus zPlus_lci zPlus_assoc zPlus_comm;am.
uhg;ir. rw zPlus_comm;try am. rw (zPlus_comm H0);try am.
ap H;am.
Qed.

Lemma zPlus_ordered : is_ordered_group zLeq zPlus zNum z0.
Proof.
uhg;ee. ap zLeq_order. ap zPlus_group. ap zLeq_zPlus_compat.
Qed.

Lemma zLeq_zPlus_reg : is_order_regular zLeq zPlus zNum.
Proof.
eapply ordered_group_order_regular. ap zPlus_ordered.
Qed.

Definition zLeq_zPlus_reg_l := and_P zLeq_zPlus_reg.
Definition zLeq_zPlus_reg_r := and_Q zLeq_zPlus_reg.

Lemma zOpp_zMult_l : forall a, inc a zNum -> forall b, inc b zNum ->
zOpp (zMult a b) = zMult (zOpp a) b.
Proof.
ir. uf zOpp.
eapply inverse_ml_insert_left. ap zNum_ring.
am. am.
Qed.

Lemma zOpp_zMult_r : forall a, inc a zNum -> forall b, inc b zNum ->
zOpp (zMult a b) = zMult a (zOpp b).
Proof.
ir. uf zOpp.
eapply inverse_ml_insert_right. ap zNum_ring.
am. am.
Qed.

Lemma zOpp_zPlus : forall a, inc a zNum -> forall b, inc b zNum ->
zOpp (zPlus a b) = zPlus (zOpp b) (zOpp a).
Proof.
ir. ap inverse_of_law. ap group_is_monoid;ap zPlus_group.
am. am. ap zPlus_group;am. ap zPlus_group;am.
Qed.

Lemma zOpp_zOpp : forall x, inc x zNum -> zOpp (zOpp x) = x.
Proof.
ir. symmetry. ap inverse_inverse. ap zPlus_group. am.
Qed.

Lemma zOpp_z0 : zOpp z0 = z0.
Proof.
uf z0. ap zOpp_rw;nSolveS.
Qed.

Lemma zMult_integral_neq : forall a, inc a zNum -> z0<>a -> forall b, inc b zNum ->
z0<>b -> z0<>(zMult a b).
Proof.
uhg;ir. symmetry in H3.
apply zMult_integral in H3;au. nin H3;au.
Qed.

Lemma zLeq_zMult_reg_l : forall a, inc a zNum -> z0<>a -> zLeq z0 a ->
forall x, inc x zNum -> forall y, inc y zNum -> zLeq (zMult a x) (zMult a y) ->
zLeq x y.
Proof.
ir.
rwi zNum_inc_rw H2. rwi zNum_inc_rw H3.
nin H2;nin H2;nin H3;nin H3;ee;subst.
rwi zPos_rw H1. nin H1;ee;subst.
rwi zMult_passes H4;nSolveS.
rwi zMult_passes H4;nSolveS.
rwi zLeq_rw H4;nSolveS.
rw zLeq_rw;nSolveS.
rwi nMult_0_l H4. rwi nMult_0_l H4.
rwi nMult_0_l H4. rwi nMult_0_l H4.
rwi nPlus_0_l H4;nSolveS.
rwi nPlus_0_l H4;nSolveS.
rwi nPlus_0 H4;nSolveS.
rwi nPlus_0 H4;nSolveS.
assert (x<>n0).
uhg;ir;subst;ap H0;tv.
wri nMult_distrib_l H4. wri nMult_distrib_l H4.
apply nLeq_nMult_reg_l in H4;nSolveS.
Qed.

Lemma zLeq_zMult_reg_r :  forall a, inc a zNum -> z0<>a -> zLeq z0 a ->
forall x, inc x zNum -> forall y, inc y zNum -> zLeq (zMult x a) (zMult y a) ->
zLeq x y.
Proof.
ir.
apply zLeq_zMult_reg_l with a;try am.
rw zMult_comm;try am. rw (zMult_comm H H3). am.
Qed.

Import Ordered_ring.

Lemma zNum_oring : is_ordered_ring zPlus zMult zLeq zNum z0 z1.
Proof.
uhg;ee. ap zNum_ring. ap zLeq_order. ap zLeq_zPlus_compat.
uf z0;uf z1. rw zLeq_rw;nSolveS.
rw nPlus_0;nSolveS.
ap zLeq_zMult_preserves.
Qed.

Lemma zLeq_zMult_l : forall a, inc a zNum -> zLeq z0 a -> forall b, inc b zNum -> forall c, inc c zNum ->
zLeq b c -> zLeq (zMult a b) (zMult a c).
Proof.
ap (oring_ml_lcompat zNum_oring).
Qed.

Lemma zLeq_zOpp : forall x, inc x zNum -> forall y, inc y zNum ->
zLeq x y = zLeq (zOpp y) (zOpp x).
Proof.
ir. rwi zNum_inc_rw H;rwi zNum_inc_rw H0.
nin H;nin H;nin H0;nin H0;ee;subst.
rw zLeq_rw;nSolveS.
rw zOpp_rw;try am. rw zOpp_rw;try am.
rw zLeq_rw;try am.
ap uneq2;ap nPlus_comm.
Qed.

Lemma zNum_pos_pow : forall a, inc a nNum -> [J a n0] = pow zPlus z0 z1 a.
Proof.
ap nNum_rect.
rw pow_0. tv.
ir.
rw pow_S. wr H0. uf z1. rw zPlus_passes;nSolveS.
rw nPlus_0_l;nSolveS.
ap uneq. ap uneq2;au.
rw nPlus_comm;nSolveS. uf n1. rw nPlus_S;nSolveS.
rw nPlus_0;nSolveS.
am.
Qed.

Lemma zNum_neg_pow : forall a, inc a nNum -> [J n0 a] = pow zPlus z0 (zOpp z1) a.
Proof.
ir. wr zOpp_rw;nSolveS. rw zNum_pos_pow;nSolveS.
ap pow_group_inverse. ap zPlus_group. ap z1_inc. am.
Qed.

Lemma zNum_nNum_pr : forall x, inc x zNum ->
(exists n, inc n nNum & x = pow zPlus z0 z1 n)\/(exists n, inc n nNum & x = pow zPlus z0 (zOpp z1) n).
Proof.
ir.
rwi zNum_pos_neg H.
nin H;nin H;ee;subst.
left. exists x0;ee. am. ap zNum_pos_pow. am.
right. exists x0;ee. am. ap zNum_neg_pow. am.
Qed.

Lemma zNum_pow_pos : forall n, inc n nNum -> zLeq z0 (pow zPlus z0 z1 n).
Proof.
ir. wr zNum_pos_pow. uf z0. constructor;nSolveS.
rw nPlus_0;nSolveS. am.
Qed.

Lemma zNum_pow_neg : forall n, inc n nNum -> zLeq (pow zPlus z0 (zOpp z1) n) z0.
Proof.
ir. wr zNum_neg_pow. uf z0. constructor;nSolveS.
rw nPlus_0;nSolveS. am.
Qed.

Lemma zNum_pow_pos_eq : forall n, inc n nNum -> forall m, inc m nNum ->
pow zPlus z0 z1 n = pow zPlus z0 z1 m -> n=m.
Proof.
ir. wri zNum_pos_pow H1;au.  wri zNum_pos_pow H1;au.
apply class_of_eq_related in H1. uh H1;clpri H1.
rwi nPlus_0 H1;nSolveS. rwi nPlus_0 H1;nSolveS.
ap zEquiv_equiv.
ap product_pair_inc;nSolveS.
ap product_pair_inc;nSolveS.
Qed.

Lemma zOpp_inj : Transformation.injects zNum zOpp.
Proof.
uhg;ir.
cp (uneq zOpp H1).
rwi zOpp_zOpp H2;au. rwi zOpp_zOpp H2;au.
Qed.

Lemma zNum_pow_neg_eq : forall n, inc n nNum -> forall m, inc m nNum ->
pow zPlus z0 (zOpp z1) n = pow zPlus z0 (zOpp z1) m -> n=m.
Proof.
ir.
ufi zOpp H1;wri pow_group_inverse H1.
ufi zOpp H1;wri pow_group_inverse H1.
fold zOpp in H1. apply zOpp_inj in H1.
ap zNum_pow_pos_eq. am. am. am.
ap pow_inc. ap zPlus_monoid;am. ap z1_inc. am.
ap pow_inc. ap zPlus_monoid;am. ap z1_inc. am.
ap zPlus_group.
ap z1_inc.
am. ap zPlus_group. ap z1_inc. am.
Qed.

Lemma zNum_pow_neg_pos : forall n, inc n nNum -> forall m, inc m nNum ->
pow zPlus z0 z1 n = pow zPlus z0 (zOpp z1) m -> (n=n0 & m=n0).
Proof.
ir.
cp (zNum_pow_pos H).
cp (zNum_pow_neg H0).
wri H1 H3.
assert (pow zPlus z0 z1 n = z0).
apply zLeq_antisym. ap pow_inc. ap zPlus_monoid. ap z1_inc. am.
ap z0_inc. am. am.
ee.
ap zNum_pow_pos_eq. am. ap n0_inc.
rw pow_0. am.
ap zNum_pow_neg_eq. am. ap n0_inc.
rw pow_0. wr H1.
 am.
Qed.

Lemma zLeq_z0_z1 : zLeq z0 z1.
Proof.
constructor;nSolveS.
repeat rw nPlus_0;nSolveS.
Qed.

End NotaSec.

Ltac zSolve := match goal with
  | |- inc (nPlus _ _) nNum => ap nPlus_lci;zSolve
  | |- inc (nMult _ _) nNum => ap nMult_lci;zSolve
  | |- inc (oS _) nNum => ap oS_nNum;zSolve
  | |- inc emptyset nNum => ap emptyset_N
  | |- inc n0 nNum => ap n0_inc
  | |- inc _ nNum => nSolveS
  | |- inc (zPlus _ _) zNum => ap zPlus_lci;zSolve
  | |- inc (zMult _ _) zNum => ap zMult_lci;zSolve
  | |- inc (zOpp _) zNum => ap zOpp_inc;zSolve
  | |- inc z0 zNum => ap z0_inc
  | |- inc z1 zNum => ap z1_inc
  | |- z0 <> z1 => ap z0_z1_neq
  | |- z1 <> z0 => uhg;intro zSolveH;ap z0_z1_neq;symmetry;am
  | |- zLeq z0 z1 => ap zLeq_z0_z1
  | |- zLeq ?z ?z => ap zLeq_refl;zSolve
  | |- inc (class_of (product nNum nNum) (zEquiv) (J ?a ?b)) zNum => ap zNum_inc;zSolve
  | |- inc _ zNum => try am
  | _ => tv
  end.

Section NotaSec2.

Notation "[ x ]" := (class_of zEquiv (product nNum nNum) x).

Definition zPos := Z zNum (zLeq z0).

Inductive in_zPos : E -> Prop :=
  | z0_in_zPos : in_zPos z0
  | S_in_zPos : forall z, in_zPos z -> in_zPos (zPlus z z1)
.

Lemma zPos_in_zPos : forall z, inc z zPos -> in_zPos z.
Proof.
assert (forall n, inc n nNum -> in_zPos [J n n0]).
ap nNum_rect.
constructor.
ir. set (z := [J n n0]) in *.
replace [J (oS n) n0] with (zPlus z z1).
constructor. am.
uf z. uf z1. rw zPlus_passes;nSolveS.
rw nPlus_0. uf n1;rw nPlus_S. rw nPlus_0.
tv. am. am. nSolveS. nSolveS.

ir. apply Z_all in H0. ee.
rwi zPos_rw H1. nin H1;ee;subst;au.
Qed.

Lemma in_zPos_zPos : forall z, in_zPos z -> inc z zPos.
Proof.
ir. nin H;ap Z_inc;zSolve.
apply Z_all in IHin_zPos. ee. am.
apply Z_all in IHin_zPos; ee.
apply zLeq_trans with (zPlus z0 z1);zSolve.
rw zPlus_z0_l;zSolve.
ap zLeq_zPlus_compat;zSolve.
Qed.

Lemma zNum_disj : forall z, inc z zNum -> (inc z zPos \/ inc (zOpp z) zPos).
Proof.
ir. nin (zLeq_total z0_inc H).
left. ap Z_inc;am.
right. ap Z_inc;zSolve.
wr zOpp_z0. wr zLeq_zOpp;zSolve.
Qed.

End NotaSec2.

End ZTemp.


(*For finite sets*)
Require Import MSets.MSetPositive.
Import PositiveSet. Module PSet:= PositiveSet. (*For positive-indexed sets*)
Require Import Coq.Classes.Morphisms.

Definition fresh_var (set_vars:PSet.t): positive:=
  match (max_elt set_vars) with
  | Some x => x~1
  | None => 1
  end.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj17synthconj3 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (plus lv0 lv1) lv2) (plus lv1 (plus lv0 lv2))).
Admitted.
QuickChick conj17synthconj3.


  Require Import LL.FOLL.Dyadic.Tactics.
Require Import LL.SL.FLL.InvPositivePhase.

Set Implicit Arguments.

Section Adequacy.
  Context `{OLS: OLSig}.

Section Soundness.

  Lemma comp n : forall B L X, seqN n B L X -> LL3S B ((Arrow2LL X)++L).
  Proof with subst;auto.
    induction n;intros...
  - inversion H;simpl...
    rewrite perm_takeit_8...
    LL3copy (atom A).
  - inversion H;simpl...
    + rewrite perm_takeit_8...
    + LL3copy (atom A).
    + rewrite H1. LL3tensor.
      apply IHn in H2...
      apply IHn in H3...
    + LL3plus1.
      apply IHn in H1...
    + LL3plus2.
      apply IHn in H1...
    + LL3bang.
      apply IHn in H1...
    + apply IHn in H2...
    + LL3bot.
      apply IHn in H1...
    + LL3par.
      apply IHn in H1...
    + LL3with.
      apply IHn in H1...
      apply IHn in H2...
    + LL3store.
      apply IHn in H1...
    + apply IHn in H2...
      simpl in H2.
      rewrite Permutation_middle...
    + apply IHn in H3...
      simpl in H3.
      rewrite <- H2...
    + apply IHn in H3...
      simpl in H3.
      LL3copy F.
    + apply IHn in H3...
      simpl in H3.
      LL3exist t.
    + LL3forall.
      apply H2 in H0.
      apply IHn in H0...
 Qed.

  (** Well formedness conditions for arrows. *)
  Definition isArrow (A:Arrow) : Prop :=
    match A with
    | UP l => isFormulaL l
    | DW F => isFormula F
    end.

Lemma compInv n : forall B L,
Forall isFormula L ->
          LL3N n B L -> seq B [] (UP L).
  Proof with sauto;solveLL;solveForall.
  induction n;intros...
  - inversion H0...
  - inversion H0...
    + apply IHn in H2.
      apply IHn in H3.
      do 2 rewrite <- (app_nil_r [F ** G]).
      rewrite app_assoc_reverse.
      apply InvTensor.
      eapply (EquivUpArrow2 _ H2)...
      eapply (EquivUpArrow2 _ H3)...
      admit.
      admit.
    + apply IHn in H2.
      do 2 rewrite <- (app_nil_r [F op G]).
      rewrite app_assoc_reverse.
      apply InvPlus.
      eapply (EquivUpArrow2 _ H2)...
      admit.
    + apply IHn in H2.
      do 2 rewrite <- (app_nil_r [F op G]).
      rewrite app_assoc_reverse.
      apply InvPlusComm.
      eapply (EquivUpArrow2 _ H2)...
      admit.
    + apply IHn in H2.
      LFocus.
      admit.
    + apply IHn in H3.
      eapply (EquivUpArrow2 _ H3)...
      admit.
    + apply IHn in H2...
    + apply IHn in H2...
      admit.
      admit.
    + apply IHn in H2...
      admit.
    + apply IHn in H3...
      admit.
    + apply IHn in H2...
    + apply IHn in H3...
      apply EquivUpArrow2 with (L':= L++[F]) in H3...
      apply AbsorptionClassic in H3...
      admit.
      admit.
    + apply IHn in H4...
      do 2 rewrite <- (app_nil_r [E{FX}]).
      rewrite app_assoc_reverse.
      apply @InvEx with (t:=t)...
      eapply (EquivUpArrow2 _ H4)...
      admit.
    + apply H3 in properX.
      apply IHn in properX...

      admit.
Qed.

Lemma asas M : forall L B N, Forall positiveFormula M ->
      |-f- B; M++N; UP L <-> |-f- B; N; UP (M++L).
Proof with subst;auto.
 split;intros.
 - revert dependent B.

   revert N L.
   revert dependent M.
   intro.
  induction M;intros...
inversion H...
 rewrite <- app_comm_cons.
 apply tri_store'.
  left;auto.
  eapply IHM...
  admit.
- revert dependent B.

   revert N L.
   revert dependent M.
   intro.
  induction M;intros...
 rewrite <- app_comm_cons in H0.
inversion H...
inversion H0;subst; try solve [ inversion H3 ]...
  eapply IHM in H8...
  admit.
Admitted.

Lemma asas' M : forall L B N,
      |-f- B; M++N; UP L <-> |-f- B; N; UP (M++L).
Proof with subst;auto.
 split;intros.
 - revert dependent B.

   revert N L.
   revert dependent M.
   intro.
  induction M;intros...
inversion H...
 rewrite <- app_comm_cons.
 apply tri_store'.
  left;auto.
  eapply IHM...
  admit.
- revert dependent B.

   revert N L.
   revert dependent M.
   intro.
  induction M;intros...
 rewrite <- app_comm_cons in H0.
inversion H...
inversion H0;subst; try solve [ inversion H3 ]...
  eapply IHM in H8...
  admit.
Admitted.

  Lemma compInv' : (forall n B M L, Forall positiveFormula M ->
          LL3N n B (M++L) -> seq B M (UP L)) <->

          (forall n B L, LL3N n B L -> seq B [] (UP L)).
  Proof with subst;auto.
  split;intros.
  - eapply H with (n:=n);auto.
  - destruct M.
    eapply H with (n:=n);auto.
    rewrite <- app_comm_cons in H1.
    apply H in H1.
    inversion H0...
    inversion H1;subst;try solve [inversion H4]...
    apply asas in H9...
    admit.
  Admitted.

Lemma compInvF : forall n B M L, Forall positiveFormula M ->
          LL3N n B (M++L) -> seq B M (UP L).
  Proof with subst;auto.
  apply compInv'.
  apply compInv.
Qed.


From isla Require Import opsem.

Definition a1822c : isla_trace :=
  Smt (DeclareConst 50%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R2" [] (RegVal_Base (Val_Symbolic 50%Z)) Mk_annot :t:
  Smt (DefineConst 56%Z (Manyop (Bvmanyarith Bvor) [Val (Val_Bits (BV 64%N 0x0%Z)) Mk_annot; Val (Val_Symbolic 50%Z) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "R0" [] (RegVal_Base (Val_Symbolic 56%Z)) Mk_annot :t:
  Smt (DeclareConst 57%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 57%Z)) Mk_annot :t:
  Smt (DefineConst 58%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 57%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 58%Z)) Mk_annot :t:
  tnil
.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

Require Export Bool.
Require Export LegacyRing_theory.
Require Export Quote.
Require Export Ring_normalize.
Require Export Ring_abstract.
Declare ML Module "legacy_ring_plugin".

(* As an example, we provide an instantation for bool. *)
(* Other instatiations are given in ArithRing and ZArithRing in the
   same directory *)

Definition BoolTheory :
  Ring_Theory xorb andb true false (fun b:bool => b) eqb.
split; simpl.
destruct n; destruct m; reflexivity.
destruct n; destruct m; destruct p; reflexivity.
destruct n; destruct m; reflexivity.
destruct n; destruct m; destruct p; reflexivity.
destruct n; reflexivity.
destruct n; reflexivity.
destruct n; reflexivity.
destruct n; destruct m; destruct p; reflexivity.
destruct x; destruct y; reflexivity || simpl; tauto.
Defined.

Add Legacy Ring bool xorb andb true false (fun b:bool => b) eqb BoolTheory
 [ true false ].


(**
    TODO
*)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import TypeTheory.Auxiliary.CategoryTheoryImports.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.
Require Import TypeTheory.CompCats.DiscreteComprehensionCat.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.

Local Definition D_ob {C : category} :=
  discrete_comprehension_cat_structure1_D_ob (C := C).

Local Definition F_ob {C : category} :=
  discrete_comprehension_cat_structure1_F_ob (C := C).

Local Definition D_lift_ob {C : category} :=
  discrete_comprehension_cat_structure1_D_lift_ob (C := C).

Local Definition D_ob_isaset {C : category} :=
  discrete_comprehension_cat_structure1_D_ob_isaset (C := C).

Local Definition D_id {C : category} :=
  discrete_comprehension_cat_structure1_D_id (C := C).

Local Definition D_comp {C : category} :=
  discrete_comprehension_cat_structure1_D_comp (C := C).

Local Definition D_mor_with_unique_lift {C : category} :=
  discrete_comprehension_cat_structure1_D_mor_with_unique_lift (C := C).

Local Definition D_mor {C : category}
      (DC : discrete_comprehension_cat_structure1 C)
  := pr1 (D_mor_with_unique_lift DC).

Local Definition D_lift_mor {C : category}
      (DC : discrete_comprehension_cat_structure1 C)
      {Γ Γ' : C}
      (f : C ⟦ Γ', Γ ⟧) (A : pr1 DC Γ)
  : D_mor DC Γ' Γ (D_lift_ob DC Γ Γ' f A) A f
  := pr1 (pr2 (pr2 (D_mor_with_unique_lift DC)) Γ Γ' f A).

Local Definition F_mor {C : category} :=
  discrete_comprehension_cat_structure1_F_mor (C := C).

Section DiscCompCat_mor.

  Context (C : category).

  Definition DiscCompCat_mor_data
             (X Y : discrete_comprehension_cat_structure1 C)
    : UU
    := ∑ (F_TY : ∏ {Γ : C}, D_ob X Γ → D_ob Y Γ),
       (* ϕ : *) ∏ (Γ : C) (A : D_ob X Γ),
            pr1 (F_ob X Γ A) --> pr1 (F_ob Y Γ (F_TY A)).

  Local Definition F_TY
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
    := pr1 mor.

  Local Definition ϕ
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
    := pr2 mor.

  Definition DiscCompCat_mor_axiom_F_TY
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
    : UU
    := ∏ (Γ Γ' : C) (f : C ⟦ Γ', Γ ⟧) (A : D_ob X Γ),
       F_TY mor _ (D_lift_ob X _ _ f A) = D_lift_ob Y _ _ f (F_TY mor _ A).

  Definition DiscCompCat_mor_axiom_ϕ_dpr
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
    : UU
    := ∏ (Γ : C) (A : D_ob X Γ),
       ϕ mor Γ A ;; pr2 (F_ob Y Γ (F_TY mor _ A)) = pr2 (F_ob X Γ A).

  Definition F_ob_compare
             {X : discrete_comprehension_cat_structure1 C}
             {Γ : C} {A A' : D_ob X Γ} (e : A = A')
    : z_iso (pr1 (F_ob X Γ A)) (pr1 (F_ob X Γ A')).
  Proof.
    apply idtoiso, maponpaths, maponpaths, e.
  Defined.

  Lemma F_ob_compare_id {X : discrete_comprehension_cat_structure1 C}
        {Γ : C} (A : D_ob X Γ)
    : F_ob_compare (idpath A) = identity_z_iso (pr1 (F_ob X Γ A)).
  Proof.
    apply idpath.
  Qed.

  Lemma F_ob_compare_id_general {X : discrete_comprehension_cat_structure1 C}
        {Γ : C} {A : D_ob X Γ}
        (e : A = A)
    : F_ob_compare e = identity_z_iso (pr1 (F_ob X Γ A)).
  Proof.
    apply @pathscomp0 with (F_ob_compare (idpath _)).
    apply maponpaths, D_ob_isaset.
    apply idpath.
  Qed.

  Lemma F_ob_compare_comp {X : discrete_comprehension_cat_structure1 C}
        {Γ : C} {A A' A'' : D_ob X Γ} (e : A = A') (e' : A' = A'')
    : pr1 (F_ob_compare (e @ e')) = F_ob_compare e ;; F_ob_compare e'.
  Proof.
    etrans. 2: { apply idtoiso_concat_pr. }
    unfold F_ob_compare. apply maponpaths, maponpaths.
    etrans. 2: apply maponpathscomp0.
    apply maponpaths.
    apply maponpathscomp0.
  Qed.

  Lemma F_ob_compare_comp_general {X : discrete_comprehension_cat_structure1 C}
        {Γ : C} {A A' A'' : D_ob X Γ}
        (e : A = A') (e' : A' = A'') (e'' : A = A'')
    : pr1 (F_ob_compare e'') = F_ob_compare e ;; F_ob_compare e'.
  Proof.
    refine (_ @ F_ob_compare_comp _ _).
    apply maponpaths, maponpaths, D_ob_isaset.
  Qed.

  Definition Δ
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
             (F_TY_ax : DiscCompCat_mor_axiom_F_TY mor)
    : ∏ (Γ Γ' : C) (f : C ⟦ Γ', Γ ⟧) (A : D_ob X Γ),
      C ⟦ pr1 (F_ob Y Γ' (F_TY mor Γ' (D_lift_ob X Γ Γ' f A))),
          pr1 (F_ob Y Γ' (D_lift_ob Y Γ Γ' f (F_TY mor Γ A))) ⟧.
  Proof.
    intros Γ A Γ' f.
    use F_ob_compare.
    apply F_TY_ax.
  Defined.

  Lemma Δ_ϕ
        {X Y : discrete_comprehension_cat_structure1 C}
        (G : DiscCompCat_mor_data X Y)
        {Γ : C} {A A' : D_ob X Γ}
        (e : A = A')
    : F_ob_compare e ;; ϕ G Γ A' = ϕ G Γ A ;; F_ob_compare (maponpaths (F_TY G _) e).
  Proof.
    destruct e; simpl. etrans. apply id_left. apply pathsinv0, id_right.
  Qed.

  Definition F_TY_on_morphisms
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
             (F_TY_ax : DiscCompCat_mor_axiom_F_TY mor)
             {Γ Γ' : C} {f : C ⟦ Γ, Γ' ⟧}
             {A : D_ob X Γ} {A' : D_ob X Γ'}
    : D_mor X Γ Γ' A A' f → D_mor Y Γ Γ' (F_TY mor _ A) (F_TY mor _ A') f.
  Proof.
    intros ff.
    apply (invweq (mor_with_unique_lift_mor_weq _ _ (D_ob_isaset Y) _)).
    etrans. apply pathsinv0, (F_TY_ax Γ' Γ f A').
    apply maponpaths.
    apply (mor_with_unique_lift_mor_weq _ _ (D_ob_isaset X) _ ff).
  Qed.

  Definition DiscCompCat_mor_axiom_ϕ_qq
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
             (F_TY_ax : DiscCompCat_mor_axiom_F_TY mor)
    : UU
    := ∏ (Γ Γ' : C) (f : C ⟦ Γ', Γ ⟧)
         (A : D_ob X Γ) (A' : D_ob X Γ') (ff : D_mor X _ _ A' A f),
       pr1 (F_mor X Γ' Γ A' A f ff) ;; ϕ mor Γ A =
       ϕ mor Γ' A' ;; pr1 (F_mor Y Γ' Γ (F_TY mor _ A') (F_TY mor _ A) f
                                 (F_TY_on_morphisms mor F_TY_ax ff)).

  Definition DiscCompCat_mor_axioms
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
    : UU
    := ∑ (F_TY_ax : DiscCompCat_mor_axiom_F_TY mor)
        (ϕ_dpr_ax : DiscCompCat_mor_axiom_ϕ_dpr mor),
      (* ϕ_qq_ax : *) DiscCompCat_mor_axiom_ϕ_qq mor F_TY_ax.

  Definition isaprop_DiscCompCat_mor_axiom_F_TY
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
    : isaprop (DiscCompCat_mor_axiom_F_TY mor).
  Proof.
    repeat (apply impred_isaprop; intros ?).
    apply D_ob_isaset.
  Qed.

  Definition isaprop_DiscCompCat_mor_axiom_ϕ_dpr
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
    : isaprop (DiscCompCat_mor_axiom_ϕ_dpr mor).
  Proof.
    repeat (apply impred_isaprop; intros ?).
    apply homset_property.
  Qed.

  Definition isaprop_DiscCompCat_mor_axiom_ϕ_qq
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
             (F_TY_ax : DiscCompCat_mor_axiom_F_TY mor)
    : isaprop (DiscCompCat_mor_axiom_ϕ_qq mor F_TY_ax).
  Proof.
    repeat (apply impred_isaprop; intros ?).
    apply homset_property.
  Qed.

  Definition isaprop_DiscCompCat_mor_axioms
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor_data X Y)
    : isaprop (DiscCompCat_mor_axioms mor).
  Proof.
    apply Propositions.isaproptotal2.
    - intros ?. apply isapropdirprod.
      + apply isaprop_DiscCompCat_mor_axiom_ϕ_dpr.
      + apply isaprop_DiscCompCat_mor_axiom_ϕ_qq.
    - intros. apply isaprop_DiscCompCat_mor_axiom_F_TY.
  Qed.

  Definition DiscCompCat_mor
             (X Y : discrete_comprehension_cat_structure1 C)
    : UU
    := ∑ (mor : DiscCompCat_mor_data X Y), DiscCompCat_mor_axioms mor.

  Definition DiscCompCat_mor_to_mor_data
             {X Y : discrete_comprehension_cat_structure1 C}
             (mor : DiscCompCat_mor X Y)
    : DiscCompCat_mor_data X Y
    := pr1 mor.

  Coercion DiscCompCat_mor_to_mor_data : DiscCompCat_mor >-> DiscCompCat_mor_data.

  Definition DiscCompCat_mor_eq
             {X Y : discrete_comprehension_cat_structure1 C}
             (F G : DiscCompCat_mor X Y)
             (F_TY_eq : ∏ Γ (A : D_ob X Γ), F_TY F _ A = F_TY G _ A)
             (ϕ_eq : ∏ Γ (A : D_ob X Γ),
                     ϕ F _ A ;; F_ob_compare (F_TY_eq Γ A) = ϕ G _ A)
    : F = G.
  Proof.
    use total2_paths_f. 2: apply isaprop_DiscCompCat_mor_axioms.
    use total2_paths_f.
    - repeat (apply funextsec; intros ?). apply F_TY_eq.
    - etrans. use transportf_forall.
      apply funextsec; intros Γ.
      etrans. use transportf_forall.
      apply funextsec; intros A.
      refine (_ @ ϕ_eq Γ A).
      etrans. apply (functtransportf
                       (λ x, x Γ A)
                       (λ y, C ⟦ pr1 (F_ob X Γ A), pr1 (F_ob Y Γ y) ⟧)).
      etrans. apply (functtransportf
                       (λ x, F_ob Y Γ x)
                       (λ y, C ⟦ pr1 (F_ob X Γ A), pr1 y ⟧)).
      etrans. apply (functtransportf
                       (λ x, pr1 x)
                       (λ y, C ⟦ pr1 (F_ob X Γ A), y ⟧)).
      etrans. apply pathsinv0, idtoiso_postcompose.
      apply maponpaths.
      unfold F_ob_compare.
      apply maponpaths.
      apply maponpaths.
      apply maponpaths.
      apply maponpaths.
      apply D_ob_isaset.
  Defined.

  Definition DiscCompCat_precat_ob_mor
    : precategory_ob_mor
    := (_ ,, DiscCompCat_mor).

  Definition DiscCompCat_mor_id_data
             (X : discrete_comprehension_cat_structure1 C)
    : DiscCompCat_mor_data X X.
  Proof.
    use tpair.
    + intros Γ. apply idfun.
    + intros Γ A. apply identity.
  Defined.

  Definition DiscCompCat_mor_id_axioms
             (X : discrete_comprehension_cat_structure1 C)
    : DiscCompCat_mor_axioms (DiscCompCat_mor_id_data X).
  Proof.
    use tpair. 2: use make_dirprod.
    + intros Γ Γ' f A. apply idpath.
    + intros Γ A. apply id_left.
    + intros Γ Γ' f A A' ff.
      etrans. apply id_right. cbn.
      apply pathsinv0.
      etrans. apply id_left.
      apply maponpaths.
      apply maponpaths.
      apply isaprop_mor_with_unique_lift_mor.
      apply D_ob_isaset.
  Qed.

  Definition DiscCompCat_mor_id
             (X : discrete_comprehension_cat_structure1 C)
    : DiscCompCat_mor X X
    := (_ ,, DiscCompCat_mor_id_axioms X).

  Definition DiscCompCat_mor_comp_data
             (X Y Z : discrete_comprehension_cat_structure1 C)
             (F : DiscCompCat_mor_data X Y)
             (G : DiscCompCat_mor_data Y Z)
    : DiscCompCat_mor_data X Z.
  Proof.
    use tpair.
    + intros Γ A. apply (F_TY G _ (F_TY F _ A)).
    + intros Γ A. apply (ϕ F _ _ ;; ϕ G _ _).
  Defined.

  Definition DiscCompCat_mor_comp_axioms
             (X Y Z : discrete_comprehension_cat_structure1 C)
             (F : DiscCompCat_mor X Y)
             (G : DiscCompCat_mor Y Z)
    : DiscCompCat_mor_axioms (DiscCompCat_mor_comp_data X Y Z F G).
  Proof.
    use tpair. 2: use make_dirprod.
    + intros Γ Γ' f A. cbn.
      etrans. apply maponpaths.
      apply (pr1 (pr2 F)).
      apply (pr1 (pr2 G)).
    + intros Γ A. cbn.
      etrans. apply assoc'.
      etrans. apply maponpaths.
      apply (pr1 (pr2 (pr2 G))).
      apply (pr1 (pr2 (pr2 F))).
    + intros Γ Γ' f A A' ff. cbn.
      etrans. apply assoc.
      etrans. apply maponpaths_2.
      apply (pr2 (pr2 (pr2 F))).
      etrans. apply assoc'.
      etrans. apply maponpaths.
      apply (pr2 (pr2 (pr2 G))).
      etrans. 2: apply assoc.
      apply maponpaths.
      apply maponpaths.
      apply maponpaths.
      apply maponpaths.
      apply isaprop_mor_with_unique_lift_mor.
      apply D_ob_isaset.
  Qed.

  Definition DiscCompCat_mor_comp
             (X Y Z : discrete_comprehension_cat_structure1 C)
             (F : DiscCompCat_mor X Y)
             (G : DiscCompCat_mor Y Z)
    : DiscCompCat_mor X Z
    := (_ ,, DiscCompCat_mor_comp_axioms X Y Z F G).

  Definition DiscCompCat_precat_id_comp
    : precategory_id_comp (DiscCompCat_precat_ob_mor)
    := (DiscCompCat_mor_id , DiscCompCat_mor_comp).

  Definition DiscCompCat_precat_data
    : precategory_data
    := (_ ,, DiscCompCat_precat_id_comp).

  Definition DiscCompCat_precat_id_left
             (X Y : DiscCompCat_precat_data)
             (F : DiscCompCat_precat_data ⟦ X, Y ⟧)
    : identity X ;; F = F.
  Proof.
    use DiscCompCat_mor_eq.
    - intros Γ A. apply idpath.
    - intros Γ A. etrans. apply id_right. apply id_left.
  Qed.

  Definition DiscCompCat_precat_id_right
             (X Y : DiscCompCat_precat_data)
             (F : DiscCompCat_precat_data ⟦ X, Y ⟧)
    : F ;; identity Y = F.
  Proof.
    use DiscCompCat_mor_eq.
    - intros Γ A. apply idpath.
    - intros Γ A. etrans. apply id_right. apply id_right.
  Qed.

  Definition DiscCompCat_precat_assoc
             (X Y Z W : DiscCompCat_precat_data)
             (F : DiscCompCat_precat_data ⟦ X, Y ⟧)
             (G : DiscCompCat_precat_data ⟦ Y, Z ⟧)
             (H : DiscCompCat_precat_data ⟦ Z, W ⟧)
    : F ;; (G ;; H) = (F ;; G) ;; H.
  Proof.
    use DiscCompCat_mor_eq.
    - intros Γ A. apply idpath.
    - intros Γ A. etrans. apply id_right. apply assoc.
  Qed.

  Definition DiscCompCat_precat_assoc'
             (X Y Z W : DiscCompCat_precat_data)
             (F : DiscCompCat_precat_data ⟦ X, Y ⟧)
             (G : DiscCompCat_precat_data ⟦ Y, Z ⟧)
             (H : DiscCompCat_precat_data ⟦ Z, W ⟧)
    : (F ;; G) ;; H = F ;; (G ;; H).
  Proof.
    use DiscCompCat_mor_eq.
    - intros Γ A. apply idpath.
    - intros Γ A. etrans. apply id_right. apply assoc'.
  Qed.

  Definition DiscCompCat_precat_axioms
    : is_precategory DiscCompCat_precat_data.
  Proof.
    use make_is_precategory.
    - apply DiscCompCat_precat_id_left.
    - apply DiscCompCat_precat_id_right.
    - apply DiscCompCat_precat_assoc.
    - apply DiscCompCat_precat_assoc'.
  Qed.

  Definition DiscCompCat_precat : precategory
    := (_ ,, DiscCompCat_precat_axioms).

  Definition DiscCompCat_precat_has_homsets
    : has_homsets DiscCompCat_precat.
  Proof.
    intros X Y.
    apply isaset_total2. 2: intros ?; apply isasetaprop, isaprop_DiscCompCat_mor_axioms.
    - apply isaset_total2.
      + repeat (apply impred_isaset; intros ?).
        apply D_ob_isaset.
      + intros ?.
        repeat (apply impred_isaset; intros ?).
        apply homset_property.
  Defined.

  Definition DiscCompCat_cat : category
    := (DiscCompCat_precat ,, DiscCompCat_precat_has_homsets).

End DiscCompCat_mor.


Require Export Fiat.Common.Coq__8_4__8_5__Compat.
Require Import
        Coq.ZArith.ZArith
        Fiat.Narcissus.Common.Notations
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.BaseFormats
        Fiat.Narcissus.Formats.Base.FixFormat.

Require Export
        Coq.Lists.List.

Notation "| ls |" := (Datatypes.length ls) : format_scope.

Section FixList.
  Context {A : Type}.
  Context {T : Type}.
  Context {cache : Cache}.
  Context {monoid : Monoid T}.

  Variable A_predicate : A -> Prop.
  Variable format_A : A -> CacheFormat -> Comp (T * CacheFormat).
  Variable A_decode : T -> CacheDecode -> option (A * T * CacheDecode).
  Variable A_cache_inv : CacheDecode -> Prop.
  Variable A_decode_pf : CorrectDecoder monoid A_predicate A_predicate
                                        eq format_A A_decode A_cache_inv
                                        format_A.

  Open Scope vector_scope.

  (* Could do this with a FixComp instead? *)
  Fixpoint format_list (xs : list A) (ce : CacheFormat)
    : Comp (T * CacheFormat) :=
    match xs with
    | nil => ret (mempty, ce)
    | x :: xs' => `(b1, env1) <- format_A x ce;
                  `(b2, env2) <- format_list xs' env1;
                  ret (mappend b1 b2, env2)
    end%comp.

  Fixpoint encode_list
           (encode_A : A -> CacheFormat -> T * CacheFormat)
           (xs : list A) (ce : CacheFormat)
    : T * CacheFormat :=
    match xs with
    | nil => (mempty, ce)
    | x :: xs' =>  let (b1, env1) := encode_A x ce in
                   let (b2, env2) := encode_list encode_A xs' env1 in
                   (mappend b1 b2, env2)
    end%comp.

  Fixpoint decode_list (s : nat) (b : T) (cd : CacheDecode) : option (list A * T * CacheDecode) :=
    match s with
    | O => Some (nil, b, cd)
    | S s' => `(x, b1, e1) <- A_decode b cd;
              `(xs, b2, e2) <- decode_list s' b1 e1;
              Some (x :: xs, b2, e2)
    end.

  Theorem FixList_decode_correct
    :
    forall sz ,
      CorrectDecoder
         monoid
         (fun ls => |ls| = sz /\ forall x, In x ls -> A_predicate x)
         (fun ls => |ls| = sz /\ forall x, In x ls -> A_predicate x)
         eq
         format_list (decode_list sz) A_cache_inv
         format_list.
  Proof.
    split.
    {
      intros env env' xenv l l' ext ? Eeq Ppred Penc.
      intuition; subst.
      revert H0.
      generalize dependent env. generalize dependent env'.
      generalize dependent xenv.
      generalize dependent l'. induction l.
      { intros.
        simpl in *; intuition; computes_to_inv;
          injections; simpl.
        rewrite mempty_left; eexists _, _; intuition eauto.
        simpl; computes_to_econstructor.
      }
      { intros; simpl in *.
        assert (A_predicate a) by eauto.
        unfold Bind2 in Penc; computes_to_inv; subst.
        destruct v; destruct v0; simpl in *.
        injections.
        destruct (proj1 A_decode_pf _ _ _ _ _ (mappend t0 ext) env_OK Eeq H Penc) as [ ? [? [? xenv_OK] ] ].
        intuition; destruct_ex.
        setoid_rewrite <- mappend_assoc; setoid_rewrite H1;
          simpl; subst.
        destruct (IHl t0 xenv _ H6 c) as [? [? ?] ];
          intuition eauto; subst.
        setoid_rewrite H5; simpl.
        eexists _, _; intuition.
        simpl; unfold Bind2; eauto.
      }
    }
    { induction sz; simpl; intros.
      - injections; simpl; repeat eexists; simpl; intuition eauto.
        symmetry; apply mempty_left.
      - destruct (A_decode t env') as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate.
        destruct (decode_list sz t0 c) as [ [ [? ?] ?] | ] eqn: ? ;
          simpl in *; try discriminate; injections.
        eapply (proj2 A_decode_pf) in Heqo; eauto;
          destruct Heqo; destruct_ex; intuition; subst;
            eapply IHsz in Heqo0; eauto; destruct Heqo0;
              destruct_ex; intuition; subst.
        simpl.
        eexists _, _; simpl; unfold id; intuition eauto.
        computes_to_econstructor; eauto.
        computes_to_econstructor; eauto.
        simpl. rewrite mappend_assoc; reflexivity.
        subst; eauto.
    }
  Qed.

  Definition format_list_body
               (A_format_Impl : A -> CacheFormat -> T * CacheFormat)
:= (fun (acc: T * CacheFormat) x =>
                                    let (bacc, env) := acc in
                                       let (b1, env1) := A_format_Impl x env in
                                       (mappend bacc b1, env1)).

  Import Fiat.Computation.FixComp.LeastFixedPointFun.

  Definition format_list' : FormatM (store := cache) (list A) T :=
    LeastFixedPoint
      (fDom := [list A; CacheFormat])
      (fun format_list' xs =>
         match xs with
         | nil => fun env => ret (mempty, env)
         | x :: xs' =>
           format_A x ThenC format_list' xs'
         end).

  Lemma format_list_body_characterization A_format_Impl :
    forall xs base env,
      fold_left (format_list_body A_format_Impl) xs (base, env) =
      (let (b2, env2) := fold_left (format_list_body A_format_Impl) xs (mempty, env) in
       (mappend base b2, env2)).
  Proof.
    induction xs; simpl.
    + intros; rewrite mempty_right; reflexivity.
    + intros; destruct (A_format_Impl _ _).
      rewrite IHxs, mempty_left, (IHxs t).
      destruct (fold_left _ _ _).
      rewrite mappend_assoc; reflexivity.
  Qed.

  Lemma format_list_as_foldl encode_A :
    forall xs env,
      encode_list encode_A xs env =
      fold_left (format_list_body encode_A) xs (mempty, env).
  Proof.
    induction xs; simpl.
    + reflexivity.
    + intros; destruct (encode_A _ _).
      rewrite IHxs, mempty_left, (format_list_body_characterization encode_A xs t c).
      destruct (fold_left _ _ _); reflexivity.
  Qed.

  Lemma measure_format_length_Spec n :
    (forall (a : A) b ctx ctx',
        computes_to (format_A a ctx) (b, ctx')
        -> bin_measure b = n)
    -> forall l b ctx ctx',
      computes_to (format_list l ctx) (b, ctx') ->
      bin_measure b = n * (length l).
  Proof.
    induction l; simpl; intros.
    - computes_to_inv; injections.
      pose proof (mappend_measure mempty mempty) as H';
        rewrite mempty_left in H'.
      simpl bin_measure in H'; simpl mempty in H'; omega.
    - unfold Bind2 in *; computes_to_inv; injections.
      destruct v; destruct v0; simpl in *.
      rewrite mappend_measure.
      apply H in H0; rewrite H0.
      apply IHl in H0'; rewrite H0'.
      rewrite Mult.mult_succ_r.
      auto with arith.
  Qed.

End FixList.