Require Import nd models.
Require Import List.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Program.Equality.
Require Import Coq.Logic.Classical.

(** * Classical Strong Completeness *)

Definition LEM := forall p, p \/ ~p.
Definition DN  := forall p, ~~ p -> p.
(** We can derive double-negation elimination from LEM *)
Lemma LEM2DN: LEM -> DN.
Proof.
  intros LEM p H.
  destruct (LEM p); firstorder.
Qed.

Section Models.
  Context {d : DerivationType}.

  Definition evalK' {M: KripkeModel} (Γ: theory) :=
    fun w => forall s, (Γ s) -> @evalK M s w.

  (**
    Being an IEL or IEL^- model is a property of a given model.
   **)
  Definition isIEL (M: KripkeModel) := forall w, exists w', verif w w'.

  Definition model_constraint (d : DerivationType) m :=
      if d then True else isIEL m.

  Definition entails {d: DerivationType} (Γ: theory) (φ: form) :=
    forall (M : KripkeModel), model_constraint d M ->
      ((forall w,evalK' Γ w -> @evalK M φ w)).

  Notation "Γ ⊨ φ" := (entails Γ φ) (at level 30).

  (** Evaluation is monotone, that is if φ is true at world w
      and we can reach world v from w, φ true at v.  *)
  Variable M : KripkeModel.

  Lemma monotone_ctx (A:theory)  :
    forall w w', cogn w w' -> evalK' A w -> evalK' A w'.
  Proof.
    intros. intros t H1.
    apply eval_monotone with (w0 := w); auto.
  Qed.
End Models.
(** ** Canonical models *)
Section Canonical.
  (**
We define the *canonical models*, whose worlds are the maximally consistent theories.
We first define the relations.
   **)
  Context {d : DerivationType}.

  Record mcTheory := mkmcTheory {
                         T: theory;
                         Ttheory: forall φ, (@ndT d T φ) -> T φ;
                         consistentT:  ~(T ⊥);
                         prime: is_prime T;
                       }.

  Definition lindenBaumTheory (DN: DN) (Γ: theory) (φ: form) (H: ~(ndT Γ φ)) :mcTheory.
    destruct (Lindenbaum H).  destruct H1. destruct H2.

    apply mkmcTheory with (T := (max Γ φ)).
    + tauto.
    + intro. apply H1. apply ndtE. apply ndtA. assumption.
    +  intros a b Ha.
       unfold is_primeDN in H2. specialize (H2 a b).
       apply DN in H2.  eauto.
  Defined.

  Lemma lindenBaumTheorySubset (DN: DN) Γ (φ: form) (H: ~(ndT Γ φ)) : exists Δ: mcTheory ,Γ ⊆ (T Δ).
  Proof.
    exists (lindenBaumTheory DN H).
    simpl T. assert ( (T (lindenBaumTheory DN H)) = (max Γ φ)). cbv. firstorder.  unfold lindenBaumTheory. apply max_subset.
  Qed.

  Definition subsetMKT (A B: mcTheory) := subset (T A) (T B).
  Definition valuationMKT (A: mcTheory) (a: nat) := (T A) (Var a).

  Definition subsetVerif (A B:mcTheory) :=
    forall a, ((T A) (K a)) -> (T B) a.
  Instance canonical: (KripkeModel).
  Proof.
    apply mkKripkeModel with (world := mcTheory) (cogn := subsetMKT) (val := valuationMKT) (verif := subsetVerif).
    all: try firstorder.
    intros A B c d' E. apply Ttheory with (φ := d'). destruct B. simpl. apply ndtA. apply c. apply ndtA in E. apply ndtKpos in E.
      apply Ttheory in E. exact E.
  Defined.

  Lemma deductionGamma (Gamma: mcTheory) (phi: form):  ndT (T Gamma) phi <-> (T Gamma) phi.
  Proof.
    split.
    - intro. apply Ttheory in H. exact H.
    - apply ndtA.
  Qed.
  Hint Resolve deductionGamma : core.

  Lemma world_canonical_disjunction (t: mcTheory) ψ φ :
    ((T t) (φ ∨ ψ)) <-> (ndT (T t) φ) \/ ndT (T t) ψ.
  Proof.
    intros. split.
    - intro.
      apply prime.
      apply deductionGamma.
      exact H.
    - intro. destruct H; eauto.
      + apply deductionGamma. apply ndtDIL. eauto.
      + apply deductionGamma. apply ndtDIR. eauto.
  Qed.

End Canonical.

Lemma canonicalIEL (DN: DN): isIEL (@canonical normal).
Proof.
  intros w.
  assert (~(@ndT normal (unbox (T w)) ⊥)).
  {
    intros H % modalShiftingLemma.
    destruct w. apply consistentT0.
    apply @Ttheory0.
    apply @ndtIE with (s := (K ⊥)).
    - apply @ndtW with (T := empty).
      + apply IELKBot.
      + firstorder.
    - simpl T in H.  exact H.
  }
  exists (lindenBaumTheory DN  H).
  intros x H1. simpl lindenBaumTheory.
  simpl T.
  apply max_subset.
  apply unbox_rewrite.
  exact H1.
Qed.

(** ** Strong Completeness *)
Section Completeness.

  (** *** Truth-Lemma *)
  Lemma truth_lemma {d: DerivationType} (DN: DN): forall  (X: form) (t: (@world  canonical)),
    (evalK X t) <-> ((T t) X).
  Proof.
    intro x.
    induction x.
    - split.
      + intro H0. apply DN. intro H'.
        assert (H: ~ unbox (T t) ⊢T x).
        * intros H. now apply H', deductionGamma, modalShiftingLemma.
        * assert (exists Δ: mcTheory , (unbox (T t)) ⊆ (T Δ)
                                  /\ ~((T Δ) x)).
          {
            exists (lindenBaumTheory DN H).
            split.
            - apply max_subset.
            - intro. apply ndtA in H1.
              apply does_not_derive in H1; auto.
          }
          destruct H1. destruct H1.  apply H2.  apply IHx. auto.

      + intros A. simpl evalK. intros r V. apply IHx. auto.
    - split.
      +
        intro.
        apply deductionGamma. apply DN.  rewrite deductionGamma.
        intro.
        enough (exists Δ: mcTheory, (T t) ⊆ (T Δ) /\ ((T Δ) x1) /\ ~((T Δ) x2)). destruct H1 as [Δ H2].
        specialize (H Δ). destruct H2. destruct H2. apply H3. apply IHx2. (*apply H0.*) firstorder eauto.
        (*    apply IHx1. exact H2.  *)
        rewrite<- deductionGamma in H0. rewrite ImpAgree in H0.
        destruct (Lindenbaum H0).
        exists (lindenBaumTheory DN H0).
        split. intros x H3. firstorder eauto.

        split.
        * apply deductionGamma. apply ndtW with  (x1#(T t)). apply ndtA. left. reflexivity. unfold lindenBaumTheory. cbn. apply max_subset.
        * rewrite<- deductionGamma. destruct H2. auto.
      + intros. intros w H1 H2. apply IHx2. apply deductionGamma. apply ndtIE with (s := x1). apply deductionGamma. apply H1. exact H. apply deductionGamma. apply IHx1. exact H2.
    - split.
      + intro H.
        destruct H.
        apply deductionGamma.
        apply ndtCI; apply ndtA.
        * apply IHx1. exact H.
        *  apply IHx2. exact H0.
      + intros H1.  split.
        * apply deductionGamma in H1.  apply ndtCEL in H1. apply IHx1.
          apply deductionGamma.  auto.
        * apply deductionGamma in H1.  apply ndtCER in H1. apply IHx2.
          apply deductionGamma.  auto.
    - intro.  simpl evalK. rewrite world_canonical_disjunction. rewrite IHx1. rewrite IHx2.
      repeat rewrite deductionGamma. tauto.

    - split.
      +
        intro. exfalso. apply H.
      + intro.  exfalso. apply (consistentT H).
    - split; firstorder.
  Qed.

  Lemma StrongCompleteness {d: DerivationType} (Γ: theory) (φ: form):
   LEM ->  (entails Γ φ) -> Γ ⊢T φ.
  Proof.

    intros DN % LEM2DN  H0.
    apply DN.
    intro H.
    unfold entails in H0.
    specialize (H0 canonical).
    enough (exists Δ: mcTheory, ~((T Δ) ⊢T φ) /\ (Γ ⊆ (T Δ))).
    destruct H1 as [Δ H2].
    assert (model_constraint d canonical).  {
      destruct d eqn:deq.
      - simpl. auto.
      - apply canonicalIEL.   auto.
    }
    specialize (H0 H1 Δ).
    apply H2.
    apply deductionGamma.
    apply truth_lemma. auto.
    apply H0. intros ψ P. apply truth_lemma. auto.  apply deductionGamma. destruct H2. apply ndtA.
    apply H3. exact P.
    (* Show that such a theory exists *)
    exists (lindenBaumTheory DN H).
    split.
    apply does_not_derive. exact H.
    apply max_subset.
  Qed.

  Lemma evalKimp {M: KripkeModel} s t w: evalK s w -> evalK (Imp s t) w -> evalK t w.
  Proof.
    intros H0 H1.
    apply H1. apply preorderCogn. auto.
  Qed.

  Lemma evalKdistr {M: KripkeModel} s w w': evalK (K s) w -> verif w w' -> evalK s w'.
  Proof.
    intros.
    apply H.
    exact H0.
  Qed.

  Definition ctx2thy (Γ: context) := fun x => In x Γ.

  Lemma ndSoundIELCtx (A: context) (s: form) {p: DerivationType}  (D:@nd p A s):entails  (ctx2thy A) s.
  Proof.
    intros M Mc. induction D.
    + eauto.
    + intros.   exfalso. apply (IHD) with w; auto.
    + intros w1 c1 H2 c2 H3. apply IHD; auto.  intro s'. intro H4. destruct H4. subst s'.   assumption.  apply eval_monotone with (w := w1); auto.
    + intros w H. apply evalKimp with (s0 := s). apply IHD2; auto. apply IHD1; auto.
    + intros w H w' c H1 w'' v. specialize IHD with w. apply evalKimp with (s0 := s). apply H1. exact v.
      apply evalKdistr with (w0 := w); auto. apply transvalid with (y := w'); auto.
    + intros w H w' v. apply IHD; auto.  apply monotone_ctx with (w := w); try tauto; auto. apply  vericont; auto.
    + intros w H1. apply IHD in H1; auto. destruct H1. auto.
    + intros w H1. apply IHD in H1; auto. destruct H1. auto.
    + intros w H1. split; auto.
    + intros w H1. left. auto.
    + intros w H1. right. auto.
    + intros w H1. destruct (IHD1 Mc w H1).
    - apply (IHD2 Mc w); auto. apply preorderCogn.
    - apply (IHD3 Mc w); auto. apply preorderCogn.
      + intros w H1 u c.
        apply monotone_ctx with (w' := u)  in H1. 2: auto.
        unfold isIEL in Mc. destruct (Mc u).
        specialize (IHD Mc u).
        assert (evalK s x).
        {
          apply IHD; auto.
        }
        intro.
        apply (H2 x). apply vericont. auto.
        apply H0.
  Qed.

  Lemma ndSoundIEL  (A: theory) (s: form) {p: DerivationType}  (D:@ndT p A s):entails A s.
  Proof.
    intros. destruct D. intros M c w H1. destruct H.
    specialize (ndSoundIELCtx H0) . intro H2.   apply H2. auto. intros a Ha.
    apply H1. apply H. apply Ha.
  Qed.

  Lemma ndSound (Γ: theory) A {p: DerivationType}: Γ ⊢T A -> entails Γ A.
  Proof.
    intros. apply ndSoundIEL. auto.
  Qed.

  Inductive uno := Uno.
  Definition cogUno := fun (x: uno) (y: uno) => True.
  Definition unoModel: KripkeModel.
    apply mkKripkeModel with (world := uno) (cogn := cogUno) (verif := cogUno) (val := fun x y => True).
    firstorder eauto.
    firstorder eauto.
    firstorder eauto.
    firstorder eauto.
  Defined.

  Lemma hasConstraint (D: DerivationType): model_constraint D unoModel.
  Proof.
    destruct D; firstorder eauto.
  Qed.

  Lemma ndConsistent (D: DerivationType): ~(nil ⊢ ⊥).
  Proof.
    intro.
    specialize (ndSoundIELCtx H).  intro.

    enough (exists M, (exists w, ~(@evalK M ⊥ w) /\ model_constraint D M)).
    destruct H1 as (M & w & (H1 & H2)).  specialize (H0 M H2 w).
    apply H1. apply H0. intros a Ha. destruct Ha.

    exists unoModel. exists Uno.  split; try apply hasConstraint.
    intro. simpl evalK in H1. auto.
  Qed.
End Completeness.

(** Equivalence between completeness and LEM **)
Notation "Γ ⊨ A" := (entails Γ A) (at level 100).
Section CompletenessLEM.
  Variable (D: DerivationType).
  Definition strongCompleteness := forall Γ φ, (entails Γ φ) -> Γ ⊢T φ.

  Definition falsityStable := forall Γ, ~~(ndT Γ ⊥) -> (ndT Γ ⊥).

  Lemma entailmentBotDN Γ: ~~(entails Γ ⊥) -> entails Γ ⊥.
  Proof.
    intro.
    intros M mc w H1. simpl evalK.
     apply wm with (Γ ⊨ ⊥). intro. destruct H0; try tauto.
    specialize (H0 M mc w  H1).  apply H0.
  Qed.

  Lemma st2fs: strongCompleteness -> falsityStable.
  Proof.
    intros H T H1.
    assert (~~(entails T ⊥)).  {
     firstorder eauto using ndSoundIEL.
    }
    firstorder eauto using entailmentBotDN.
  Qed.

  Lemma fstab2LEM: falsityStable -> LEM.
  Proof.
    intros fstab P.
    pose (T := fun (x: form) => P \/ ~P).
    enough (T ⊢T ⊥).
    destruct H as (Γ & Hgam1 & Hgam2).
    destruct Γ.
    - exfalso.  apply (@ndConsistent D). apply Hgam2.
    - unfold T in Hgam1. apply Hgam1 with f. eauto.
    - apply fstab.  intro. apply wm with P. intro.
      apply H. apply ndtA. unfold T. apply H0.
  Qed.

  Theorem st2lem: strongCompleteness -> LEM.
  Proof.
     intros H % st2fs. apply fstab2LEM; auto.
  Qed.
End  CompletenessLEM.

(** Completeness for enumerable theories and MP *)
Section CompletenessEnumerableMP.
  Definition MP := forall (f: nat -> bool), ~~(exists n, f n = true) -> exists n, f n = true.
  Context {d: DerivationType}.

  Definition enumerable (T: theory) := exists (f: nat -> option form), forall x, T x -> exists n, f n = (Some x).
  Definition falsityEnumStable := forall Γ, enumerable Γ ->  ~~(ndT Γ ⊥) -> (ndT Γ ⊥).

  Definition strongEnumerableCompleteness :=
    forall Γ φ, enumerable Γ -> (entails Γ φ) -> Γ ⊢T φ.

  Lemma ste2fs: strongEnumerableCompleteness -> falsityEnumStable.
  Proof.
    intros H T H0 H1.
    assert (~~(entails T ⊥)).  {
      intro.  apply H1. intro.  apply ndSoundIEL in H3. congruence.
    }
    apply H. auto. apply entailmentBotDN. auto.
  Qed.

  Definition ftheroy (f: nat -> bool) : nat -> option form.
    intro x.
    destruct (f x) eqn:fx.
    + apply (Some (decode x)).
    + apply None.
  Defined.
  Definition ftheroy' (f: nat -> bool) : nat -> option form :=
    fun n =>
         Some ((decode (n)) ∧ (¬ (decode (n)))).

  Lemma fenum2MP: strongEnumerableCompleteness -> MP.
  Proof.
    intros H1 f H2.
    pose (T := fun (x: form) => exists n, f n = true /\ (exists m, x = (m ∧ ¬ m) /\ (decode n = m)   )).
    enough (T ⊢T ⊥).
    destruct H as (Γ & Hgam1 & Hgam2).
    destruct Γ.
    - exfalso.  apply (@ndConsistent d). apply Hgam2.
    - unfold T in Hgam1. specialize (Hgam1 f0). destruct Hgam1.  eauto.  exists x. tauto.
    - apply ste2fs. auto.
      + exists (ftheroy' f).
        intros x1 Hx1.  unfold T in Hx1. destruct Hx1 as (nHx1 & Thx1).
        destruct Thx1. destruct (decode_surj x1).  destruct H0 as (m1 & Hm1 & Hm2).
        exists (nHx1).  unfold  ftheroy'.    rewrite Hm2, Hm1.  reflexivity.
      + intro. apply wm with (exists n, f n = true). intro. destruct H0; try tauto. clear H2.
        apply H. destruct H0 as (n1 & Hn1).  apply ndtIE with ((decode n1)).
        apply  ndtCER with (decode n1).  apply ndtA. exists n1. split; eauto.
         apply  ndtCEL with (¬(decode n1)). apply ndtA. exists n1. split; eauto.
  Qed.
End CompletenessEnumerableMP.


(*===========================================================================
  Properties of bit vectors
  ===========================================================================*)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.ssrnat Ssreflect.seq Ssreflect.tuple Ssreflect.fintype Ssreflect.div Ssreflect.zmodp Ssreflect.ssralg.
Require Import Coq.ZArith.ZArith.
Require Import x86proved.tuplehelp x86proved.bitsrep x86proved.nathelp.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Lemma trivialBits (p q: BITS 0) : p = q.
Proof. by rewrite (tuple0 p) (tuple0 q). Qed.

(*---------------------------------------------------------------------------
    Properties of conversion to and from natural numbers.
  ---------------------------------------------------------------------------*)
Lemma toNatCons n b (p:BITS n) : toNat (consB b p) = b + (toNat p).*2.
Proof. done. Qed.

Lemma toNatNil (p:BITS 0) : toNat p = 0.
Proof. by rewrite (tuple0 p). Qed.

(* toNat is left-inverse to fromNat *)
Lemma toNatK n : cancel (@toNat n) (@fromNat n).
Proof. induction n; first (move => p; apply trivialBits).
+ case/tupleP => b x. rewrite toNatCons/fromNat-/fromNat /= half_bit_double.
rewrite IHn odd_add odd_double. by case b.
Qed.

(* Hence toNat is injective *)
Definition toNat_inj n := can_inj (@toNatK n).

(* toNat result is bounded *)
Lemma toNatBounded n : forall (p: BITS n), toNat p < 2^n.
Proof. induction n. move => p. by rewrite toNatNil.
case/tupleP => [b p].
rewrite expnS mul2n toNatCons.
case b.
+ rewrite ltn_Sdouble. apply IHn.
+ rewrite ltn_double. apply IHn.
Qed.

Lemma toNat_fromNatBounded n : forall m, m < 2^n -> toNat (fromNat (n:=n) m) = m.
Proof. induction n.
+ rewrite expn0. by case.
+ rewrite expnS. move => m.  specialize (IHn m./2).
  move => LT.
  assert (m./2 < 2^n).
  rewrite -ltn_double. rewrite -(odd_double_half m) mul2n in LT.
  rewrite -(ltn_add2l (odd m)).
  by apply ltn_addl.
  specialize (IHn H).
  rewrite /toNat-/toNat/=.
  rewrite /toNat/= in IHn. rewrite IHn.
  by rewrite odd_double_half.
Qed.

Lemma fromNatBounded_eq m1 m2 n : m1 < 2^n -> m2 < 2^n ->
  (m1==m2) = (fromNat (n:=n) m1 == fromNat m2).
Proof. move => B1 B2.
case E: (m1 == m2);
case E': (#m1 == #m2) => //. by rewrite (eqP E) eq_refl in E'.
rewrite -(toNat_fromNatBounded B1) -(toNat_fromNatBounded B2) in E.
by rewrite (eqP E') eq_refl in E.
Qed.

Lemma fromNatHalf n m : cons_tuple (odd m) (fromNat (n:=n) m./2) = fromNat m.
Proof. done. Qed.

Lemma fromNat_wrap n : forall m, fromNat (n:=n) m = fromNat (n:=n) (m + 2^n).
Proof. induction n => //.
rewrite expnS.
move => m.
case ODD: (odd m); rewrite /fromNat-/fromNat /=ODD odd_add odd_mul/=ODD/= halfD ODD/=.
specialize (IHn m./2). by rewrite odd_mul/= add0n mul2n doubleK IHn.
specialize (IHn m./2). by rewrite add0n mul2n doubleK IHn.
Qed.

Lemma fromNat_wrapMany n c : forall m, fromNat (n:=n) m = fromNat (n:=n) (m + c * 2^n).
Proof. induction c => m. by rewrite mul0n addn0.
rewrite mulSn (addnC (2^n)) addnA fromNat_wrap. rewrite IHc.
by rewrite -addnA (addnC (2^n)) addnA.
Qed.

Lemma toNat_mod n (p:BITS n): toNat p = toNat p %% 2^n.
Proof. rewrite modn_small => //. apply toNatBounded. Qed.

Lemma toNat_fromNat n m : @toNat n (fromNat m) = m %% 2^n.
Proof. have H:= divn_eq m (2^n). rewrite {1}H.
have HH:= @fromNat_wrapMany n (m %/ 2^n) (m %% 2^n). rewrite addnC in HH. rewrite -HH.
rewrite toNat_fromNatBounded. done. apply ltn_pmod. apply expn_gt0. Qed.

Lemma fromNat_succn n : forall b c, @fromNat n b = fromNat c -> @fromNat n (b.+1) = fromNat(c.+1).
Proof. induction n => //.
move => b c EQ. rewrite /fromNat-/fromNat. rewrite /fromNat-/fromNat in EQ.
elim: (splitTuple EQ) => [EQ1 EQ2]. simpl in EQ1. simpl in EQ2.
specialize (IHn _ _ EQ2). rewrite/= !uphalf_half /=EQ1.
case ODD: (odd c). + by rewrite !add1n IHn. + by rewrite !add0n EQ2.
Qed.

Lemma fromNat_addn n : forall a b c, @fromNat n b = fromNat c -> @fromNat n (a+b) = fromNat(a+c).
Proof. induction a => //.
move => b c EQ. rewrite -addn1 -!addnA !add1n. apply IHa. by apply fromNat_succn.
Qed.

Lemma toZp_fromNat n m : toZp (fromNat (n:=n.+1) m) = (m%:R)%R.
Proof. apply val_inj.
rewrite /toZp toNat_fromNat Zp_nat.
rewrite /=Zp_cast; last apply pow2_gt1.
by rewrite modn_mod.
Qed.

Lemma toZpAux_fromNat n c : toZpAux (m:=n.+1) (fromNat (n:=n.+1) c) = (c%:R)%R.
Proof. apply val_inj.
rewrite /toZpAux toNat_fromNat Zp_nat.
rewrite /=Zp_cast; last apply pow2_gt1.
by rewrite modn_mod.
Qed.

Hint Rewrite toZp_fromNat toZpAux_fromNat : ZpHom.

Lemma toNat_droplsb n (p: BITS n.+1) : toNat (droplsb p) = (toNat p)./2.
Proof. case/tupleP: p => [b p]. rewrite /droplsb/splitlsb beheadCons theadCons.
by rewrite toNatCons/= half_bit_double.
Qed.

Lemma toNatCat m n (p : BITS m) (q: BITS n) : toNat (p ## q) = toNat p * 2^n + toNat q.
Proof. induction n. rewrite (tuple0 q). by rewrite expn0 muln1.
case/tupleP: q => [b q].
unfold "##".  rewrite catCons. rewrite !toNatCons. unfold "##" in IHn.
rewrite IHn. rewrite expnS. rewrite -!muln2. ring.
Qed.

(*---------------------------------------------------------------------------
    Properties of conversion to and from 'Z_(2^n)
  ---------------------------------------------------------------------------*)

(* This only holds for n.+1 because 'Z_1 actually has two elements - it's
   definitionally the same as 'Z_2 in order to force a ring structure. See zmodp
   for more details *)
Lemma fromZpK n : cancel (@fromZp n.+1) (@toZp n.+1).
Proof.
  move => x. rewrite /toZp/fromZp. rewrite  toNat_fromNat modn_small. apply valZpK.
  destruct x. simpl. rewrite Zp_cast in i => //.
  apply pow2_gt1.
Qed.

Lemma toZpK n : cancel (@toZp n) (@fromZp n).
Proof. case E: (n == 0).
+ rewrite /cancel. rewrite (eqP E). move => x. apply trivialBits.
+ move => x. rewrite /fromZp/toZp/=.
  rewrite Zp_cast. by rewrite (modn_small (toNatBounded _)) toNatK.
  apply negbT in E. destruct n => //. apply pow2_gt1.
Qed.

Lemma toZp_inj n : injective (@toZp n).
Proof. apply (can_inj (@toZpK _)). Qed.

Lemma fromZp_inj n : injective (@fromZp n.+1).
Proof. apply (can_inj (@fromZpK _)). Qed.

Lemma toZp_eq n (x y: BITS n) : (x == y) = (toZp x == toZp y).
Proof. destruct n. by rewrite (tuple0 x) (tuple0 y).
case E: (toZp x == toZp y).
rewrite (toZp_inj (eqP E)). by rewrite eq_refl.
apply (contraFF (b:=false)) => // => H.
rewrite (eqP H) (eq_refl) in E. done.
Qed.

Corollary toZp_neq n (x y: BITS n) : (x != y) = (toZp x != toZp y).
Proof. by rewrite toZp_eq. Qed.

(*---------------------------------------------------------------------------
    Properties of bit get and set
  ---------------------------------------------------------------------------*)

Lemma setBitThenGetSame n : forall (p: BITS n) i b, i<n -> getBit (setBit p i b) i = b.
Proof.
induction n => //.
case/tupleP => [b' p]. move => i b LT.
destruct i => //.
simpl. rewrite theadCons beheadCons. assert (LT' : i < n) by done.
rewrite /getBit/=. apply IHn; done.
Qed.

Lemma setBitThenGetDistinct n :
  forall (p: BITS n) i i' b, i<n -> i'<n -> i<>i' -> getBit (setBit p i b) i' = getBit p i'.
Proof.
induction n => //.
case/tupleP => [b' p]. move => i i' b LT LT' NEQ.
destruct i.
(* i = 0 *) simpl. rewrite beheadCons. destruct i' => //.
(* i <> 0 *)
destruct i' => //.
rewrite /= theadCons beheadCons /getBit/=.
assert (lt : i < n) by done.
assert (lt' : i' < n) by done.
assert (neq' : i <> i') by  intuition.
specialize (IHn p _ _ b lt lt' neq'). apply IHn.
Qed.

(*---------------------------------------------------------------------------
    Properties of all zeroes and all ones
  ---------------------------------------------------------------------------*)
Lemma fromNat0 n : #0 = zero n.
Proof. induction n; first apply trivialBits.
+ rewrite /zero /copy. rewrite /zero /copy in IHn. by rewrite /fromNat-/fromNat IHn nseqCons.
Qed.

Lemma toNat_zero n : toNat (zero n) = 0.
Proof. induction n => //. rewrite /toNat/=. rewrite /toNat in IHn. by rewrite IHn. Qed.

Corollary toNat_fromNat0 n : @toNat n #0 = 0.
Proof. by rewrite fromNat0 toNat_zero. Qed.

Lemma msb_zero n : msb (zero n) = false.
Proof. by induction n. Qed.

Lemma toNat_ones_succ n : (toNat (ones n)).+1 = 2^n.
Proof. induction n => //.
rewrite /toNat/=. rewrite /toNat/= in IHn.
by rewrite expnS mul2n addnC addn1 -doubleS IHn.
Qed.

Corollary toNat_ones n : toNat (ones n) = (2^n).-1.
Proof. by rewrite -toNat_ones_succ succnK. Qed.

Lemma msb_ones n : msb (ones n.+1) = true.
Proof. by induction n. Qed.

Lemma toZp_zero n : toZp (zero n) = 0%R.
Proof. rewrite /toZp toNat_zero. by apply val_inj. Qed.

Lemma toZpAux_zero m n : toZpAux (m:=m) (zero n) = 0%R.
Proof. rewrite /toZpAux toNat_zero. by apply val_inj. Qed.

Lemma toZp_ones n : toZp (ones n.+1) = (-1)%R.
Proof. rewrite /toZp toNat_ones. apply val_inj.
rewrite /= Zp_cast; last apply pow2_gt1.
rewrite -subn1. replace (1 %% 2^n.+1) with 1 => //.
by rewrite modn_small; last apply pow2_gt1.
Qed.

Hint Rewrite toZpK fromZpK toZp_zero toZpAux_zero toZp_ones : ZpHom.

(*---------------------------------------------------------------------------
    Properties of joinmsb and splitmsb
  ---------------------------------------------------------------------------*)

Lemma toNat_joinmsb n : forall c (p: BITS n), toNat (joinmsb (c, p)) = c * 2^n + toNat p.
Proof. induction n.
+ move => c p. by rewrite /joinmsb (tuple0 p) expn0 muln1.
+ move => c. case/tupleP => [b p].
  rewrite /joinmsb-/joinmsb /splitlsb theadCons beheadCons !toNatCons expnS IHn.
  by rewrite doubleD addnCA -mul2n mulnCA.
Qed.

Lemma toNat_joinmsb0 n (p: BITS n) : toNat (joinmsb0 p) = toNat p.
Proof. by rewrite toNat_joinmsb. Qed.

Lemma splitmsb_fromNat n :
  forall m, splitmsb (n:=n) (fromNat m) = (odd (m %/ 2^n), fromNat m).
Proof. induction n => m.
+ by rewrite /dropmsb/=beheadCons!theadCons expn0 divn1.
+ rewrite expnS. rewrite /fromNat-/fromNat/=.
  rewrite /joinlsb !beheadCons!theadCons fromNatHalf. specialize (IHn m./2). rewrite IHn.
  by rewrite -divn2 -divnMA.
Qed.

Corollary dropmsb_fromNat n m : dropmsb (n:=n) (fromNat m) = (fromNat m).
Proof. by rewrite /dropmsb splitmsb_fromNat. Qed.

Corollary toNat_dropmsb n (p: BITS n.+1) : toNat (dropmsb p) = toNat p %% 2^n.
Proof. rewrite -{1}(toNatK p). rewrite dropmsb_fromNat. by rewrite toNat_fromNat. Qed.

Lemma toZp_joinmsb0 n (p: BITS n) : toZp (joinmsb0 p) = toZpAux p.
Proof. apply val_inj.
rewrite /toZp/toZpAux/= Zp_cast; last apply pow2_gt1.
by rewrite toNat_joinmsb0.
Qed.

Lemma toZp_dropmsb n (p: BITS n.+2) : toZp (n:=n.+1) (dropmsb p) = toZpAux (m:=n.+1) p.
Proof.
apply val_inj.
rewrite /toZp/toZpAux/= Zp_cast; last apply pow2_gt1.
rewrite toNat_dropmsb.
by rewrite modn_mod.
Qed.

Hint Rewrite toZp_joinmsb0 toZp_dropmsb : ZpHom.

Lemma splitmsbK n : cancel (@splitmsb n) (@joinmsb n).
Proof. induction n.
+ case/tupleP => [b p]. by rewrite (tuple0 p).
+ case/tupleP => [b p]. rewrite /= beheadCons theadCons. specialize (IHn p).
case E: (splitmsb p) => [b' p'].
rewrite beheadCons theadCons.
rewrite E in IHn. by rewrite IHn.
Qed.

Lemma joinmsbK n : cancel (@joinmsb n) (@splitmsb n).
Proof. induction n.
+ move => [b p]. by rewrite !(tuple0 p) /= theadCons beheadCons.
+ move => [c p]. case/tupleP: p => [b p].
  by rewrite /= !theadCons !beheadCons IHn.
Qed.

Corollary dropmsb_joinmsb n b (p:BITS n) : dropmsb (joinmsb (b, p)) = p.
Proof. by rewrite /dropmsb joinmsbK. Qed.

Lemma splitlsbK n : cancel (@splitlsb n) (@joinlsb n).
Proof. case/tupleP => [b p]. by rewrite /splitlsb beheadCons theadCons. Qed.

Lemma joinlsbK n : cancel (@joinlsb n) (@splitlsb n).
Proof. move => [p b]. by rewrite /joinlsb /splitlsb beheadCons theadCons. Qed.

Lemma toNat_joinlsb n (p:BITS n) b : toNat (joinlsb (p, b)) = b + (toNat p).*2.
Proof. done. Qed.

(* Totally ridiculous proof *)
Lemma splitmsb_rev n : forall (b: BITS n.+1) hi (lo:BITS n),
   splitmsb b = (hi,lo) -> rev b = hi::rev lo.
Proof. induction n => b hi lo/=.
+ move => [<- <-] {lo}/=. case/tupleP:b => [b u]//=. by rewrite tuple0/=.
+ move => H.
specialize (IHn (behead_tuple b) hi).
destruct (splitmsb (behead_tuple b)).
injection H => [H1 H2] {H}. rewrite H2 {H2} in IHn.
specialize (IHn b1 refl_equal). rewrite -H1/=.
case/tupleP E: b => [b' u]/=. rewrite E/= in IHn.
by rewrite 2!rev_cons IHn rcons_cons.
Qed.

(*---------------------------------------------------------------------------
    Properties of concatenation and splitting of bit strings
  ---------------------------------------------------------------------------*)
Lemma high_catB n2 n1 (p:BITS n1) (q:BITS n2) : high n1 (p ## q) = p.
Proof. induction n2.
- rewrite /high (tuple0 q). by apply catNil.
- case/tupleP: q => x q. rewrite /catB catCons /= beheadCons. apply IHn2.
Qed.

Lemma low_catB n2 n1 (p:BITS n1) (q:BITS n2) : low n2 (p ## q) = q.
Proof. induction n2; first apply trivialBits.
case/tupleP: q => x q. rewrite /catB catCons /= beheadCons. by rewrite IHn2.
Qed.

Lemma low_fromNat n2 n1: forall m, low n2 (fromNat (n:=n2+n1) m) = fromNat (n:=n2) m.
Proof. induction n2 => m //. by rewrite /= /joinlsb !beheadCons !theadCons/= IHn2. Qed.

Lemma split2eta : forall n2 n1 p, let (p1,p2) := split2 n1 n2 p in p = p1 ## p2.
Proof. unfold split2. induction n2.
- move =>n1 p. by rewrite /catB catNil.
- move => n1. case/tupleP => x p. rewrite /= (IHn2 n1 p).
rewrite beheadCons theadCons high_catB low_catB. by rewrite /catB catCons. Qed.

Lemma split2app n2 n1 p1 p2 : split2 n1 n2 (p1 ## p2) = (p1,p2).
Proof. by rewrite /split2 high_catB low_catB. Qed.

Lemma split3app n3 n2 n1 p1 p2 p3 : split3 n1 n2 n3 (p1 ## p2 ## p3) = (p1,p2,p3).
Proof. by rewrite /split3 !split2app. Qed.

Lemma split4app n4 n3 n2 n1 p1 p2 p3 p4 :
  split4 n1 n2 n3 n4 (p1 ## p2 ## p3 ## p4) = (p1,p2,p3,p4).
Proof. by rewrite /split4 !split2app. Qed.

Lemma split3eta n3 n2 n1 p: match split3 n1 n2 n3 p with (p1,p2,p3) => p1 ## p2 ## p3 end = p. Proof. rewrite /split3 /=. by rewrite -!split2eta. Qed.

Lemma split4eta n4 n3 n2 n1 p:
  match split4 n1 n2 n3 n4 p with (p1,p2,p3,p4) => p1 ## p2 ## p3 ## p4 end = p.
Proof. rewrite /split4 /=. by rewrite -!split2eta. Qed.

Lemma split4eta' n4 n3 n2 n1 p:
  let: (p1,p2,p3,p4) := split4 n1 n2 n3 n4 p in p1 ## p2 ## p3 ## p4 = p.
Proof. rewrite /split4 /=. by rewrite -!split2eta. Qed.

Lemma catB_inj n1 n2 (p1 q1: BITS n1) (p2 q2: BITS n2) :
  p1 ## p2 = q1 ## q2 -> p1 = q1 /\ p2 = q2.
Proof.
move => EQ.
have H1 := high_catB p1 p2.
have H2 := high_catB q1 q2.
have L1 := low_catB p1 p2.
have L2 := low_catB q1 q2.
split. by rewrite -H1 -H2 EQ.
by rewrite -L1 -L2 EQ.
Qed.

Lemma toNat_low n1 n2 (p: BITS (n1+n2)) : toNat (low n1 p) = toNat p %% 2^n1.
Proof. by rewrite -{1}(toNatK p) low_fromNat toNat_fromNat. Qed.

Lemma allBitsEq n (p q: BITS n) : (forall i, i < n -> getBit p i = getBit q i) -> p = q.
Proof. induction n. by rewrite (tuple0 p) (tuple0 q).
case/tupleP: p => [b p].
case/tupleP: q => [c q].
move => H. have H0:= H 0. rewrite /getBit/= in H0. rewrite H0 => //.
rewrite (IHn p q). done.
move => i LT. apply (H i.+1 LT).
Qed.

Require Import tuplehelp.
Lemma lowBitsEq n1 n2 (p q: BITS (n1+n2)) :
  (forall i, i < n1 -> getBit p i = getBit q i) <-> low n1 p = low n1 q.
Proof. induction n1 => //=.
case/tupleP: p => [b p]. fold plus in p.
case/tupleP: q => [c q]. fold plus in q.
rewrite 2!beheadCons 2!theadCons /getBit/=. split => H.
+ have H0:= H 0. rewrite /= in H0. rewrite H0 => //.
  rewrite (proj1 (IHn1 p q)). done. move => i LT. apply (H i.+1 LT).
+ move => i LT. destruct i. by injection H.
  injection H => H1 H2. subst. apply (IHn1 p q). apply val_inj. apply H1. apply LT.
Qed.

Lemma highBitsEq n1 n2 (p q: BITS (n1+n2)) :
  (forall i, n1 <= i -> getBit p i = getBit q i) <-> high n2 p = high n2 q.
Proof. induction n1 => /=.
split.
have ABE := @allBitsEq _ p q. move => H. apply: ABE. move => i H'. rewrite H => //.
by move => ->.
case/tupleP: p => [b p]. fold plus in p.
case/tupleP: q => [c q]. fold plus in q.
rewrite 2!beheadCons /getBit/=. split => H.
+ apply IHn1. move => i LE. apply (H i.+1 LE).
+ have IH' := (proj2 (IHn1 p q)). case => // i. by apply IH'.
Qed.

Lemma getBit_low n1: forall n2 (p: BITS (n1+n2)) i,
  getBit (low n1 p) i = if i < n1 then getBit p i else false.
Proof. induction n1 => // n2 p i. destruct i => //. case/tupleP: p => [b p].
rewrite /getBit/joinlsb/= beheadCons theadCons. destruct i => //. apply IHn1.
Qed.

Lemma getBit_high n1: forall n2 (p: BITS (n1+n2)) i,
  getBit (high n2 p) i = getBit p (i+n1).
Proof. induction n1 => // n2 p i. by rewrite addn0.
rewrite addnS. case/tupleP: p => [b p]. apply IHn1. Qed.

Lemma getBit_catB n1 n2 (p:BITS n1) (q:BITS n2) :
  forall i, getBit (p ## q) i = if i < n2 then getBit q i else getBit p (i-n2).
Proof. induction n2 => // i.
rewrite (tuple0 q). destruct i => //.
case/tupleP: q => [b q] //. destruct i => //. apply IHn2.
Qed.

Lemma sliceEq n1 n2 n3 (p q: BITS (n1+n2+n3)) :
  (forall i, n1 <= i < n1+n2 -> getBit p i = getBit q i) <->
  slice n1 n2 n3 p = slice n1 n2 n3 q.
Proof. rewrite /slice/split3/split2.
rewrite <-highBitsEq. split.
move => H1 i LE. rewrite 2!getBit_low.
case LT: (i < (n1+n2)) => //.
- apply H1. by rewrite LE LT.
move => H i. move/andP => [LE LT].
specialize (H i LE). by rewrite 2!getBit_low LT in H.
Qed.

(*---------------------------------------------------------------------------
    Zero and sign extension
  ---------------------------------------------------------------------------*)

Lemma signExtendK extra n : pcancel (@signExtend extra n) (signTruncate extra).
Proof. move => p. rewrite /signExtend /signTruncate split2app.
case: (msb p).
+ by rewrite /ones eq_refl.
+ by rewrite /zero eq_refl.
Qed.

Lemma signTruncateK extra n p q :
  signTruncate extra (n:=n) p = Some q ->
  signExtend extra (n:=n) q = p.
Proof. rewrite /signTruncate/signExtend.
rewrite (split2eta p) split2app.
case P: (_ || _) => // H.
have EQ: low n.+1 p = q by congruence. subst.
case M: (msb _).
+ rewrite M andTb andFb orbF in P. by rewrite (eqP P).
+ rewrite M andTb andFb orFb in P. by rewrite (eqP P).
Qed.

Lemma zeroExtendK extra n : pcancel (@zeroExtend extra n) (zeroTruncate extra).
Proof. move => p. by rewrite /zeroExtend/zeroTruncate split2app eq_refl. Qed.

Lemma zeroTruncateK extra n p q :
  zeroTruncate extra (n:=n) p = Some q ->
  zeroExtend extra (n:=n) q = p.
Proof. rewrite /zeroTruncate/zeroExtend.
rewrite (split2eta p) split2app.
case P: (high extra p == zero extra) => // H.
have EQ: low n p = q by congruence. subst.
by rewrite (eqP P).
Qed.

Lemma toNat_zeroExtend extra n (p: BITS n) : toNat (zeroExtend extra p) = toNat p.
Proof. rewrite /zeroExtend. rewrite toNatCat. by rewrite toNat_zero. Qed.

Lemma toNat_zeroExtendAux extra n (p: BITS n) : toNat (zeroExtendAux extra p) = toNat p.
Proof. induction extra => //. by rewrite /= toNat_joinmsb0 IHextra. Qed.

(*---------------------------------------------------------------------------
    Properties of equality
  ---------------------------------------------------------------------------*)

Lemma iffBool (b1 b2:bool) : (b1 <-> b2) -> b1==b2.
Proof. destruct b1; destruct b2; intuition. Qed.

Lemma bitsEq_nat n {b1 b2: BITS n} :  (b1 == b2) = (toNat b1 == toNat b2).
Proof. suff: b1 == b2 <-> (toNat b1 == toNat b2).

move => H. assert (H' := iffBool H). apply (eqP H').
split. move => H. rewrite (eqP H). done.
move => H. assert (EQ:toNat b1 = toNat b2) by apply (eqP H). by rewrite (toNat_inj EQ).
Qed.


Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Import notations decidable_prop list_dec.
Require Export syntax_obs equiv_obs.

Section s.
  Context {G : Graph} {decG : DecidableGraph G}.
  (** * Semantics of observation terms *)

  (** The semantics is given by a satisfaction relation, specifying which cliques belong to the language of a term. *)
  Global Instance satObs : Satisfaction clique observation :=
    fix satObs (x : clique) (o : observation) :=
      match o with
      | ⊤o  => True
      | ⊥o => False
      | ⦑u⦒ => u ⊨ x
      | o1 ⟇ o2 => satObs x o1 \/ satObs x o2
      | o1 ⟑ o2 => satObs x o1 /\ satObs x o2
      | o1 → o2 =>
          forall y, satObs y o1 -> y ⊃ x -> satObs y o2
      end.

  Remark sat_top x : x ⊨ ⊤o <-> True.
  Proof. reflexivity. Qed.
  Remark sat_bot x : x ⊨ ⊥o <-> False.
  Proof. reflexivity. Qed.
  Remark sat_at x u : x ⊨ ⦑u⦒ <-> u ⊨ x.
  Proof. reflexivity. Qed.
  Remark sat_disj x o1 o2 : x ⊨ (o1 ⟇ o2) <-> x ⊨ o1 \/ x ⊨ o2.
  Proof. reflexivity. Qed.
  Remark sat_conj x o1 o2 : x ⊨ (o1 ⟑ o2) <-> x ⊨ o1 /\ x ⊨ o2.
  Proof. reflexivity. Qed.
  Remark sat_impl x o1 o2 :
    x ⊨ (o1 → o2) <-> forall y, y ⊨ o1 -> y ⊃ x -> y ⊨ o2.
  Proof. reflexivity. Qed.

  Hint Rewrite sat_top sat_bot sat_at sat_disj sat_conj sat_impl
    : simpl_typeclasses.

  Global Instance satObs_proper :
    Proper (sequiv ==> sequiv ==> iff) satisfies.
  Proof.
    intros α β e s t E;rewrite <- E;clear t E;revert α β e.
    (* induction s;intros;repeat sat_simpl; try reflexivity. *)
    induction s;intros;rsimpl in *; try reflexivity.
    - simpl;rewrite (e v);reflexivity.
    - rewrite IHs1,IHs2;reflexivity||assumption.
    - rewrite IHs1,IHs2;reflexivity||assumption.
    - setoid_rewrite e;reflexivity.
  Qed.

  Global Instance satisfies_inf :
    Proper (ssmaller ==> ssmaller ==> Basics.impl) satisfies.
  Proof.
    unfold Basics.impl.
    intros α β e s t E;rewrite <- E;clear t E;revert α β e.
    induction s;intros α β e;rsimpl;try tauto.
    - apply e.
    - intros [h|h].
      + left;apply (IHs1 _ _ e h).
      + right;apply (IHs2 _ _ e h).
    - intros (h1&h2);split.
      + apply (IHs1 _ _ e h1).
      + apply (IHs2 _ _ e h2).
    - intros h y h1 h2.
      apply h.
      + assumption.
      + transitivity β;assumption.
  Qed.

  (** [n]-ary meets and joins. *)
  Lemma satisfies_Join x A : x ⊨ (⋁ A) <-> exists a, a ∈ A /\ x ⊨ a.
  Proof.
    induction A;rsimpl.
    - split;[|intros (_&F&_)];tauto.
    - rewrite IHA.
      split.
      + intros [h|(b&hb&h)].
        * exists a;tauto.
        * exists b;tauto.
      + intros (b&[->|hb]&h);[|right;exists b];auto.
  Qed.

  Lemma satisfies_Meet x A : x ⊨ (⋀ A) <-> forall a, a ∈ A -> x ⊨ a.
  Proof.
    induction A;rsimpl.
    - split;tauto.
    - rewrite IHA.
      split.
      + intros (h1&h2) b [<-|hb];auto.
      + intros h;split;[|intros b hb];apply h;auto.
  Qed.

  (** Finite cliques *)
  Remark π_spec x y : x ⊨ (π y) <-> x ⊃ ! y.
  Proof.
    unfold π;rewrite satisfies_Meet.
    setoid_rewrite in_map_iff.
    split.
    - intros h u hu.
      cut (x ⊨ ⦑u⦒);[simpl;tauto|].
      revert hu;simpl_fc;intro hu.
      apply h;exists u;split;[reflexivity|assumption].
    - intros h a (u&<-&hu).
      apply h;simpl_fc;assumption.
  Qed.

  (** The problems of 1) satifiability for finite cliques 2) semantic containment of a pair of terms 3) semantic equivalence of a pair of terms are all equi-decidable. *)
  Remark dec_fsat_impl_dec_ssmaller :
    (forall α s, DecidableProp (!α ⊨ s)) -> forall s t, DecidableProp ( s ≲ t ).
  Proof.
    intros hdec s t.
    assert (ic : test (is_coherent []) = true)
      by (now apply test_spec;intro;simpl).
    case_prop (! (exist _ [] ic) ⊨ (s→t));[left|right].
    - intros α hα.
      rsimpl in *.
      apply hyp;[assumption|].
      intro a;rewrite fc_to_clique_spec;simpl;tauto.
    - intros h;apply hyp;clear hyp.
      rsimpl;intros α hα _;apply h,hα.
  Qed.
  Remark dec_ssmaller_impl_dec_fsat :
    (forall s t, DecidableProp ( s ≲ t )) -> (forall α s, DecidableProp (!α ⊨ s)).
  Proof.
    intros hdec α s.
    case_prop (π α ≲ s);[left|right].
    - apply hyp,π_spec;reflexivity.
    - intros h;apply hyp;clear hyp.
      intros β hβ.
      apply π_spec in hβ as <-.
      assumption.
  Qed.
  Remark dec_sequiv_impl_dec_ssmaller :
    (forall s t, DecidableProp (s ≃ t)) -> forall s t, DecidableProp ( s ≲ t ).
  Proof.
    intros hdec s t ;case_prop (s ⟇ t ≃ t);[left|right].
    - rewrite <- hyp;intro α;rsimpl;tauto.
    - intros h;apply hyp;clear hyp.
      intros α;rsimpl;split;[intros [];[apply h|]|];tauto.
  Qed.
  Remark dec_ssmaller_impl_dec_sequiv :
    (forall s t, DecidableProp (s ≲ t)) -> forall s t, DecidableProp ( s ≃ t ).
  Proof.
    intros hdec s t ;case_prop (s ≲ t /\ t ≲ s);[left|right].
    - intro α;split;apply hyp.
    - intros h;apply hyp;clear hyp.
      rewrite h;split;reflexivity.
  Qed.

  (** The following property will be useful to combine observation algebras. *)
  Definition choose_clique :=
    forall (α : clique) (s t : observation),
      {forall β, β ⊃ α -> β ⊨ s -> β ⊨ t} + {exists β, β ⊃ α /\ β ⊨ s /\ ~ β ⊨ t}.

  (** It implies the decidability of satisfiability. *)
  Lemma choose_clique_sat_dec :
    choose_clique -> forall α s, DecidableProp (α ⊨ s).
  Proof.
    intros hyp α s.
    destruct (hyp α ⊤o s) as [h|h].
    - left;apply h;[reflexivity|exact I].
    - right;intro f.
      destruct h as (β&h1&_&h2).
      rewrite h1 in f;tauto.
  Qed.

End s.

Infix " ⊨ " := satisfies (at level 10).
Arguments choose_clique : clear implicits.
Global Hint Rewrite @sat_top @sat_bot @sat_at @sat_disj @sat_conj
       @sat_impl
    : simpl_typeclasses.

Proposition eo_sound `{Graph} 𝖠 :
  (subrelation 𝖠 sequiv) -> forall a b, 𝖠 ⊢ a ≡ b -> a ≃ b.
Proof.
  unfold sequiv;intros h a b E;induction E;intro x;simpl;rsimpl;try tauto.
  - rewrite (IHE);reflexivity.
  - rewrite (IHE1),(IHE2);reflexivity.
  - rewrite (IHE1),(IHE2);reflexivity.
  - rewrite (IHE1),(IHE2);reflexivity.
  - setoid_rewrite <- (IHE1).
    setoid_rewrite <- (IHE2).
    reflexivity.
  - apply h;assumption.
Qed.

Proposition ha_sound `{Graph} : subrelation ha_ax sequiv.
Proof.
  unfold sequiv;intros a b E;destruct E;intro x;rsimpl;try tauto.
  - split;intros (h1&h2);split;auto.
    + apply h2;[assumption|reflexivity].
    + intros y h3 <-;assumption.
  - split;[tauto|intro h;split;[assumption|]].
    intros y h1 <-;assumption.
  - split;[intros h;split|intros (h1&h2)];intros y hya hyx.
    + apply h;assumption.
    + apply h;assumption.
    + split;[apply h1|apply h2];assumption.
Qed.

Proposition Obs_sound `{DecidableGraph} :
  subrelation Obs sequiv.
Proof.
  intros _ _ [s t E|s t [a b h]].
  - apply ha_sound,E.
  - intros x; split;simpl;rsimpl;[|tauto].
    intros (h1&h2);apply h,(members_are_coh x a b);assumption.
Qed.

Proposition Obs'_sound {G : Graph} {decG : DecidableGraph G} :
  subrelation Obs' sequiv.
Proof.
  intros _ _ [s t E| _ _ [s t E|_ _ [α s t|α a haα]]].
  - apply ha_sound,E.
  - apply Obs_sound,jright,E.
  - intros x;simpl;split.
    + intros h1.
      destruct (decidable_incompatible_with_fcliques x α)
        as [(a&b&ha&hb&hab)|i].
      * left;intros y h2 h3.
        exfalso;apply hab.
        apply (members_are_coh y).
        -- apply h3,ha.
        -- apply π_spec in h2.
           apply h2,hb.
      * apply not_incompatible_is_joins in i as (z&hz).
        cut (z ⊨ (s ⟇ t)).
           ++ intros [h|h];[left|right];intros y hyα hyx;
                eapply (@satisfies_inf _ z);
                try apply h;try apply reflexivity;
                  intro a;simpl;rewrite (hz a);
                    intros [I|I];auto.
              ** apply π_spec in hyα.
                 apply hyα,I.
              ** apply π_spec in hyα.
                 apply hyα,I.
           ++ simpl;apply h1;[apply π_spec|];
                intro a;simpl;rewrite (hz a);tauto.
    + intros [h|h] y h1 h2;[left|right];apply h;auto.
  - intros x;simpl.
    destruct (decidable_incompatible_with_fcliques x α)
        as [(b&c&hb&hc&hbc)|i].
    + split;[intro h;left|intros _];intros y h1 h2;apply π_spec in h1;
        [|exfalso];
        (apply hbc,(members_are_coh y);[apply h2|apply h1]);auto.
    + split.
      * rsimpl;setoid_rewrite π_spec.
        intro h;right.
        apply not_incompatible_is_joins in i as (z&hz).
        assert (!α ≲ z /\ x ≲ z) as (h1&h2).
        ++ split;intro b;rewrite (hz b);simpl;auto.
        ++ pose proof (h z h1 h2) as hz'.
           apply hz in hz' as [hz'|hz'];auto.
           exfalso;apply haα,inb_spec,Is_true_iff_eq_true,hz'.
      * intros [h|h] y h1 h2.
        -- exfalso;apply (h y h1 h2).
        -- apply h2,h.
Qed.


(* ************************************************************************** *)
(*                                                                            *)
(* Verified Flash Translation Layer                                           *)
(*                                                                            *)
(*                                                                            *)
(*   Author: Yu Guo <aciclo@gmail.com>                                        *)
(*                                        Computer Science Department, USTC   *)
(*                                                                            *)
(*                                                                            *)
(*                                                                            *)
(*                                                                            *)
(* ************************************************************************** *)

Require Import List.
Require Import ListEx.
Require Import Data.

Require Import Params.
Require Import Nand.
Require Import Bast0.
Require Import FTLProp.

Section INV.

  Variable bit : block_info_table.
  Variable bmt : block_mapping_table.
  Variable fbq : list block_no.

(* ## I1: every valid pbn has an item in the BIT table, and vice versa.  *)
Definition I_pbn_bit_valid := forall (pbn : block_no),
                   valid_block_no pbn
                   <-> exists bi, bit_get bit pbn = Some bi.

(* ## I2: every pbn in BMT is valid
 *)
Definition I_pbn_bmt_valid := forall (lbn : block_no),
                   forall (pbn: block_no),
                     pbn_in_bmt_lbn bmt lbn pbn
                     -> valid_block_no pbn.

(* ## I3: every pbn in freebq is valid.
 *)

Definition I_pbn_fbq_valid := forall (pbn: block_no),
                    fbq_in fbq pbn = true
                    -> valid_block_no pbn.

(* ## I4: every pbn in freebq is of "INVALID" or "ERASED" state.
*)

Definition I_pbn_fbq_state := forall (pbn: block_no) bi,
                                fbq_in fbq pbn = true
                                -> bit_get bit pbn = Some bi
                                -> bi_state bi = bs_invalid \/ bi_state bi = bs_erased.

(* ## I5: every pbn in the block_mapping_table is of "bs_log" state or "bs_data".
 *)

(*TODO: The following definition is easier to understand

Definition I_pbn_bmt_used :=
  forall (pbn : block_no) bi,
    bit_get bit pbn = Some bi
    -> (forall lbn, pbn_in_bmt_data bmt lbn pbn -> bi_state bi = bs_data lbn)
       /\ (forall lbn, pbn_in_bmt_log bmt lbn pbn -> exists pmt, bi_state bi = bs_log lbn pmt).
*)
Definition I_pbn_bmt_used :=
  forall lbn (pbn : block_no) bi,
    bit_get bit pbn = Some bi
    -> (pbn_in_bmt_data bmt lbn pbn -> bi_state bi = bs_data lbn)
       /\ (pbn_in_bmt_log bmt lbn pbn -> exists pmt, bi_state bi = bs_log lbn pmt).

(* ## I6: for every valid pbn, it is either in freebq, or in BMT *)

Definition I_pbn_habitation := (* pbn_bmt_freebq_dec *)
  forall pbn,
    valid_block_no pbn
    -> ((exists lbn, pbn_in_bmt_lbn bmt lbn pbn) /\ fbq_in fbq pbn = false )
       \/ ((forall lbn, ~ pbn_in_bmt_lbn bmt lbn pbn) /\ fbq_in fbq pbn = true).

(* ## I7: every two pbns in BMT are different *)

Definition I_pbn_bmt_distinguishable :=
  forall lbn lbn' pbn pbn',
    lbn <> lbn'
    -> pbn_in_bmt_lbn bmt lbn pbn
    -> pbn_in_bmt_lbn bmt lbn' pbn'
    -> pbn <> pbn'.

Definition I_pbn_bmt_distinguishable_2 := forall lbn pbn pbn',
                   bmt_get bmt lbn = Some (Some pbn, Some pbn')
                   -> pbn <> pbn'.

(* ## I8: every two pbns in FREEBQ are different *)

Definition I_pbn_fbq_distinguishable:= forall i i' pbn pbn',
                     i <> i'
                     -> fbq_get fbq i = Some pbn
                     -> fbq_get fbq i' = Some pbn'
                     -> pbn <> pbn'.

(* Derivable !!! *)
(* ## I9: the number of blocks in freebq should be greater than GC_THRESHOLD, so as to
          ensure the process of GC could be done.
 *)

(* Definition I_blocks_abundant := *)
(*   blt_nat MIN_FREE_BLOCKS (length fbq) = true. *)

(* Definition I_blocks_minimum := *)
(*     length fbq > GC_THRESHOLD. *)

(* Definition I_blocks_minimum_after_allocation := *)
(*     length fbq >= GC_THRESHOLD. *)

(* ## I10: every valid lbn is in the domain of BMT *)

Definition I_valid_lbn_has_entry_in_bmt : Prop :=
  forall lbn,
    valid_logical_block_no lbn
    <-> exists bme, bmt_get bmt lbn = Some bme.

(* TODO: I11 is admissible. It is removed *)
(* ## I11: the total number of blocks is a constant. *)
(*       This invariant doesn't have to hold, unless we prove block-leak-free. *)

(* TODO: If we add GC, this invariant should be removed. *)

(* Definition I_used_blocks_less_than_2_max_lbn : Prop := *)
(*   count_used_blocks bit <= 2 * MAX_LOGICAL_BLOCKS. *)

Variable c: chip.

(* $1: if a block is "INVALID" or "ERASED" in BIT, its hardware
       part is in the state of "FREE".
 *)

Definition chip_bi_coherent (c: chip) (pbn: block_no) (bi: block_info) : Prop :=
  exists b, chip_get_block c pbn = Some b
            /\ match (bi_state bi) with
                 | bs_erased => block_coherent_erased bi b
                 | bs_invalid => block_state b = bs_programmed
                 | bs_data _ => block_coherent_data bi b
                 | bs_log _ _ => block_coherent_log bi b
               end.

Definition J_bi_block_coherent (c: chip) (bit: block_info_table) :=
  forall pbn bi,
    bit_get bit pbn = Some bi
    -> chip_bi_coherent c pbn bi.

(*
  Admissible invariant
 *)

Definition I_pbn_data_in_bmt :=
  forall pbn bi lbn,
    bit_get bit pbn = Some bi
    -> bi_state bi = bs_data lbn
    -> pbn_in_bmt_data bmt lbn pbn.

Definition I_pbn_log_in_bmt :=
  forall pbn bi lbn pmt,
    bit_get bit pbn = Some bi
    -> bi_state bi = bs_log lbn pmt
    -> pbn_in_bmt_log bmt lbn pbn.

(* ## IA1: the total number of blocks is a constant. *)
(*       This invariant doesn't have to hold, unless we prove block-leak-free. *)

Definition I_bmt_fbq_distinguiable :=
  forall pbn pbn' lbn,
    valid_block_no pbn
    -> valid_block_no pbn'
    -> pbn_in_bmt_data bmt lbn pbn \/ pbn_in_bmt_log bmt lbn pbn
    -> fbq_in fbq pbn' = true
    -> pbn <> pbn'.

End INV.

(*

Lemma $1:
   invariant is satisfied
   -> merge_block _____ = res_okay _.

 *)

Definition F_Inv (f: FTL) : Prop :=
  let bit := ftl_bi_table f in
  let bmt := ftl_bm_table f in
  let fbq := ftl_free_blocks f in
    I_pbn_bit_valid bit         (* I1 *)
    /\ I_pbn_bmt_valid bmt      (* I2 *)
    /\ I_pbn_fbq_valid fbq   (* I3 *)
    /\ I_pbn_fbq_state bit fbq   (* I4 *)
    /\ I_pbn_bmt_used bit bmt       (* I5 *)
    /\ I_pbn_habitation bmt fbq     (* I6 *)
    /\ I_pbn_bmt_distinguishable bmt   (* I7_1 *)
    /\ I_pbn_bmt_distinguishable_2 bmt (* I7_2 *)
    /\ I_pbn_fbq_distinguishable fbq   (* I8 *)
    (* /\ I_blocks_abundant fbq            (* I9 *) *)
    /\ I_valid_lbn_has_entry_in_bmt bmt  (* I10 *).
    (* /\ I_used_blocks_less_than_2_max_lbn bit  (* I11 *). *)

Definition R_Inv (c: chip) (f: FTL) : Prop :=
  let bit := ftl_bi_table f in
  let bmt := ftl_bm_table f in
  let fbq := ftl_free_blocks f in
  J_bi_block_coherent c bit.

Definition Inv (c: chip) (f: FTL) :=
  F_Inv f /\ R_Inv c f.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops
        Functor.Representable.Hom_Func_Prop.
Require Import Functor.Functor_Extender.
Require Import Ext_Cons.Prod_Cat.Prod_Cat.
Require Import NatTrans.NatTrans NatTrans.Operations NatTrans.Func_Cat.
Require Import Adjunction.Adjunction Adjunction.Duality Adjunction.Adj_Facts.
Require Import KanExt.Global KanExt.Local KanExt.LocalFacts.Uniqueness
        KanExt.GlobalDuality.

Local Open Scope functor_scope.

(** This module contains conversion from local to global kan extensions.
That is, we show that if we have all local kan extensions, we also have
the global kan extension.
 *)

(** To do this, we need to build a functor from (Func_Cat C D) to
(Func_Cat C' D). That means we have to provide a natural transformation
(a cone morph) from the local kan extension of one functor to the local
kan extension of another functor. Of course, this is easy as each local
right kan extension is the terminal object of the category of cones there
always is a cone morph to it. The only practical difficulty is converting
the local kan extension of a functor (which is a cone for that functor) to
the cone of another functor – and provide necessary tools for conversion.
This is waht we do below.
*)
Section Local_to_Global_Right.
  Context {C C' : Category}
          (p : C –≻ C')
          (D : Category)
          (rke : ∀ F : C –≻ D,  Local_Right_KanExt p F)
  .

  (** Conversion from a cone of a functor to the cone of another functor.
The appex remains the same (the objects in D are not changed) but the
cone_edge does – see below. *)
  Section Cone_conv.
    Context {F G : C –≻ D} (N : (F –≻ G)%nattrans) (Cn : LoKan_Cone p F).

    Definition Cone_conv : LoKan_Cone p G :=
      {|
        cone_apex := Cn;
        cone_edge := NatTrans_compose Cn N
      |}.

  End Cone_conv.

  Section Cone_conv_Morph_for_compose.
    Context {F G H : C –≻ D}
            (N : (F –≻ G)%nattrans)
            (N' : (G –≻ H)%nattrans)
            (Cn : LoKan_Cone p F)
    .

    (** If we convert using the composition of two natural transformations it is
        the same as converting twice. We show this by building a cone morph from
        the former to the latter which is simply an identity natural
        transformation. In cases such as this, proving equality requires
        destruction of equality proofs in terms whereas composing with the
        identity natural transformation gives a composition with identity
        morphism at the level of the terms produced. *)
    Program Definition Cone_conv_Morph_for_compose :
      LoKan_Cone_Morph (Cone_conv (N' ∘ N) Cn) (Cone_conv N' (Cone_conv N Cn))
      :=
      {|
        cone_morph := NatTrans_id Cn
      |}.

    Next Obligation.
    Proof.
      rewrite NatTrans_hor_comp_ids.
      rewrite NatTrans_id_unit_right.
      rewrite NatTrans_compose_assoc; trivial.
    Qed.

  End Cone_conv_Morph_for_compose.

  Section Cone_Morph_conv.
    Context {F G : C –≻ D}
            (N : (F –≻ G)%nattrans)
            {Cn Cn' : LoKan_Cone p F}
            (h : LoKan_Cone_Morph Cn Cn')
    .

    (** Conversion of cone morphs. *)
    Program Definition Cone_Morph_conv :
      LoKan_Cone_Morph (Cone_conv N Cn) (Cone_conv N Cn') :=
      {|
        cone_morph := h
      |}.

    Next Obligation.
    Proof.
      unfold Cone_conv; cbn.
      rewrite NatTrans_compose_assoc.
      rewrite (cone_morph_com h).
      trivial.
    Qed.

  End Cone_Morph_conv.

  (** For any functor (that can be the functor of a cone), there is a functor
for which it is cone trivially. *)
  Section Trivial_Cone.
    Context (F : C' –≻ D).

    Definition Trivial_Cone : LoKan_Cone p (Functor_compose p F) :=
      {|
        cone_apex := F;
        cone_edge := ((NatTrans_id F) ∘_h (NatTrans_id p))%nattrans
      |}.

  End Trivial_Cone.

  Section Trivial_Cone_Morph.
    Context {F G : C' –≻ D} (N : (F –≻ G)%nattrans).

    (** If N : F -> G is a natural transformation, then there is a trivial cone
        morphism from trivial cone of F to trivial cone of G – after
        conversion. *)
    Program Definition Trivial_Cone_Morph :
      LoKan_Cone_Morph
        (Cone_conv (N ∘_h (NatTrans_id p)) (Trivial_Cone F))
        (Trivial_Cone G) :=
      {|
        cone_morph := N
      |}.

    Next Obligation.
    Proof.
      repeat rewrite NatTrans_hor_comp_ids.
      rewrite NatTrans_id_unit_left.
      rewrite NatTrans_id_unit_right.
      trivial.
    Qed.

  End Trivial_Cone_Morph.

  Section Cone_Morph_to_other_Cone.
    Context {L : C' –≻ D}
            {F : C –≻ D}
            (Cn : LoKan_Cone p F)
            (N : (L –≻ Cn)%nattrans)
    .

    (** Given a natural transformation from some functor L : C' -> D to a cone
        (the underlying functor) we construct a cone morphism from trivial cone
        of L (after conversion) to the given cone. *)
    Program Definition Cone_Morph_to_other_Cone :
      LoKan_Cone_Morph
        (Cone_conv (Cn ∘ (N ∘_h (NatTrans_id p))) (Trivial_Cone L))
        Cn :=
      {|
        cone_morph := N
      |}.

    Next Obligation.
      rewrite NatTrans_hor_comp_ids.
      rewrite NatTrans_id_unit_right.
      trivial.
    Qed.

  End Cone_Morph_to_other_Cone.

  Local Obligation Tactic := idtac.

  (** The functor (mapping functors to their kan extensions) for global
      kan extension. *)
  Program Definition Local_to_Global_Right_Functor :
    (Func_Cat C D) –≻ (Func_Cat C' D) :=
    {|
      FO := fun F => LRKE (rke F);
      FA := fun F G N => LRKE_morph_ex (rke G) (Cone_conv N (LRKE (rke F)))
    |}.

  Next Obligation.
  Proof.
    intros F; cbn.
    unfold Cone_conv.
    rewrite NatTrans_id_unit_left.
    change (NatTrans_id (LRKE (rke F)))
    with (cone_morph (LoKan_id_Cone_Morph _ _ (LRKE (rke F)))).
    apply LRKE_morph_unique.
  Qed.

  Next Obligation.
  Proof.
    intros F G H N N'; cbn.
    match goal with
      [|- _ = ?A] =>
      match A with
      | ((cone_morph ?Y) ∘ (cone_morph ?X))%nattrans =>
        replace A with (A ∘(NatTrans_id _))%nattrans;
          [|apply NatTrans_id_unit_right];
        set (V := (LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv N' X) Y));
        set (Z := Cone_conv_Morph_for_compose N N' (LRKE (rke F)));
        set (U := cone_morph (LoKan_Cone_Morph_compose _ _ Z V));
        unfold V, Z in U; clear V Z
      end
    end.
    match goal with
      [|- _ = ?A] =>
      change A with U
    end.
    apply (LRKE_morph_unique (rke H) (Cone_conv (N' ∘ N) (LRKE (rke F)))).
  Qed.

  (** The unit of adjunction for global kan extension. *)
  Program Definition Local_to_Global_Right_adj_unit :
      ((Functor_id (Func_Cat C' D))
         –≻ (Functor_compose
               (Left_Functor_Extender p D)
               Local_to_Global_Right_Functor))%nattrans
    :=
    {|
      Trans := fun F => LRKE_morph_ex (rke (F ∘ p)) (Trivial_Cone F)
    |}.

  Next Obligation.
  Proof.
    intros F G N.
    cbn.
    change N with (cone_morph (Trivial_Cone_Morph N)).
    match goal with
      [|- ?X = ?Y] =>
      match X with
        ((cone_morph ?B) ∘ (cone_morph ?A))%nattrans =>
        change X with (cone_morph (LoKan_Cone_Morph_compose _ _ A B))
      end;
        match Y with
          ((cone_morph ?B) ∘ (cone_morph ?A))%nattrans =>
          change Y
          with (cone_morph
                  (LoKan_Cone_Morph_compose
                     _ _ (Cone_Morph_conv (N ∘_h (NatTrans_id p)) A) B
                  )
               )
        end
    end.
    apply (LRKE_morph_unique
             (rke (Functor_compose p G))
             (Cone_conv (N ∘_h (NatTrans_id p)) (Trivial_Cone F))
          ).
  Qed.

  Next Obligation.
  Proof.
    symmetry.
    apply Local_to_Global_Right_adj_unit_obligation_1.
  Qed.

  (** Existence of conversion for adjunction – see definition of Adjunct. *)
  Definition Local_to_Global_Right_adj_morph_ex
             (L : C' –≻ D)
             (F : C –≻ D)
             (N : (L –≻ (LRKE (rke F)))%nattrans)
    : ((L ∘ p) –≻ F)%nattrans :=
    ((cone_edge (LRKE (rke F))) ∘ (N ∘_h (NatTrans_id p)))%nattrans.

  (** Conversion from local kan extensions (if we have all of them) to the
      global kan extension. *)
  Program Definition Local_to_Global_Right : Right_KanExt p D :=
    {|
      right_kan_ext := Local_to_Global_Right_Functor;
      right_kan_ext_adj := {|
                            adj_unit := Local_to_Global_Right_adj_unit;
                            adj_morph_ex := Local_to_Global_Right_adj_morph_ex|}
    |}.

  Next Obligation.
  Proof.
    intros L F h.
    unfold Local_to_Global_Right_adj_morph_ex.
    cbn in *.
    match goal with
      [|- ?X = ?Y] =>
        match Y with
          ((cone_morph ?B) ∘ (cone_morph ?A))%nattrans =>
          change Y
          with (cone_morph
                  (LoKan_Cone_Morph_compose
                     _ _
                     (Cone_Morph_conv
                        ((LRKE (rke F) ∘ (h ∘_h (NatTrans_id p)))) A) B
                  )
               )
        end
    end.
    change h with (cone_morph (Cone_Morph_to_other_Cone (LRKE (rke F)) h)).
    apply (LRKE_morph_unique
             (rke F)
             (Cone_conv ((LRKE (rke F))
                           ∘ (h ∘_h (NatTrans_id p))) (Trivial_Cone L))
          ).
  Qed.

  Next Obligation.
  Proof.
    intros L F h g g' H1 H2.
    cbn in *.
    match type of H1 with
      _ = ?X =>
      match X with
          NatTrans_compose (cone_morph ?A) (cone_morph ?B) =>
          change X with
          (cone_morph(LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv g A) B))
            in H1
      end
    end.
    match type of H2 with
      _ = ?X =>
      match X with
          NatTrans_compose (cone_morph ?A) (cone_morph ?B) =>
          change X with
          (cone_morph (LoKan_Cone_Morph_compose _ _ (Cone_Morph_conv g' A) B))
            in H2
      end
    end.
    match type of H1 with
      _ = cone_morph ?X =>
      set (H4 := cone_morph_com X); rewrite <- H1 in H4; cbn in H4;
      match type of H2 with
        _ = cone_morph ?Y =>
        set (H3 := cone_morph_com Y); rewrite <- H2 in H3; cbn in H3
      end;
      rewrite <- H4 in H3; clear H4
    end.
    rewrite NatTrans_hor_comp_ids in H3.
    repeat rewrite NatTrans_id_unit_right in H3.
    symmetry; trivial.
  Qed.

End Local_to_Global_Right.

(** The conversion from local left kan extensions to global left kan extensions
    is just the daul of that for right. *)
Section Local_to_Global_Left.
  Context {C C' : Category} (p : C –≻ C') (D : Category).

  Context (lke : ∀ F : C –≻ D,  Local_Left_KanExt p F).

  Definition Local_to_Global_Left : Left_KanExt p D :=
    KanExt_Right_to_Left
      _ _ (Local_to_Global_Right _ _ (fun (F : C^op –≻ D^op) => (lke (F^op)))).

End Local_to_Global_Left.


From mathcomp.ssreflect Require Import all_ssreflect seq.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Fixpoint Forall A (P : A -> Prop) (l : seq A) :=
  match l with
  | [::] => True
  | h :: t => P h /\ Forall P t
  end.

Fixpoint Forall2 A (P : A -> A -> Prop) (l1 l2 : seq A) :=
  match l1, l2 with
  | [::], [::] => True
  | h1 :: t1, h2 :: t2 => P h1 h2 /\ Forall2 P t1 t2
  | _, _ => False
  end.

Lemma Fa_cat A (P : A -> Prop) (l1 l2 : seq A) :
  Forall P (l1 ++ l2) <-> Forall P l1 /\ Forall P l2.
Proof.
  elim: l1=>/=; first (by split=>[H|[_ H]];[split|]).
  by move=> a l1 Ih; rewrite Ih and_assoc.
Qed.

Lemma Fa_rev A (P : A -> Prop) (l : seq A) : Forall P l <-> Forall P (rev l).
Proof.
  elim: l=>//a l Ih/=.
  rewrite -[a::l]/([::a] ++ l) rev_cat Fa_cat/= -and_assoc.
  have H Q : Q <-> Q /\ True by split=>//[[]].
  by rewrite -H Ih and_comm.
Qed.

Lemma Fa_map A B (P : A -> Prop) (f : B -> A) (l : seq B) :
  Forall P [seq f x | x <- l] <-> Forall (fun x => P (f x)) l.
Proof. by elim l=>//a {l}l Ih/=; rewrite Ih. Qed.

Lemma Fa_rw A (P : A -> Prop) (Q : A -> Prop) (l : seq A) :
  (forall X, P X -> Q X) ->
  Forall (fun X => P X) l ->
  Forall (fun X => Q X) l.
Proof. by move=> PQ;elim l=>///=h t Ih [/PQ-Qh /Ih-Qt]; split. Qed.

Lemma Fa_conj A (P1 P2 : A -> Prop) l :
  Forall P1 l -> Forall P2 l -> Forall (fun x => P1 x /\ P2 x) l.
Proof.
  by elim l=>///= h t=> Ih [Ph1 Pt1] [Ph2 Pt2]; do ! (split=>//); apply: Ih.
Qed.

Lemma Fa_lift A B (P : A -> B -> Prop) l :
  Forall (fun X => forall y, P X y) l -> forall y, Forall (P^~y) l.
Proof. by move=> F y; move: F; apply: Fa_rw => X PX. Qed.

Lemma Fa_app A (P : A -> Prop) (Q : A -> Prop) (l : seq A) :
  Forall (fun X => (P X -> Q X) /\ P X) l ->
  Forall (fun X => Q X) l.
Proof. by elim l=>///=h t Ih [[PQh /PQh-Qh] /Ih-PQt]; split. Qed.

Lemma Fa_map_eq A B (f g : A -> B) l :
  Forall (fun a => f a = g a) l -> [seq f a | a <- l] = [seq g a | a <- l].
Proof. by elim l=>// h t/= Ih [-> /Ih->]. Qed.

Lemma forallP T P (f : T -> bool) (l : seq T) :
  (forall x, reflect (P x) (f x)) -> reflect (Forall P l) (all f l).
Proof.
  move=> PP; elim: l=>/=.
  + by apply: ReflectT.
  + move=> h t Ih; case: PP.
    - case: Ih => Pt Ph.
      * by apply: ReflectT; split.
      * by apply: ReflectF =>[[_]].
    - by move=> Fh{Ih}; apply: ReflectF=>[[Ph _]].
Qed.

Lemma forallbP T (f : T -> bool) l :
  reflect (Forall f l) (all f l).
Proof. by apply: forallP=>x; apply: idP. Qed.


(**
プログラミング Coq 証明駆動開発入門(1)
http://www.iij-ii.co.jp/lab/techdoc/coqt/coqt8.html

をSSReflectに書き直した。
その上で、「Program Fixpoint」を使って定義をした。
*)

From mathcomp Require Import all_ssreflect.
Require Import Program.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Set Print All.

Lemma le_false_lt n n' : (n <= n') = false -> n' < n.
Proof.
  move=> H.
  apply/ltP.
  apply PeanoNat.Nat.nle_gt.
  apply/leP.
  by apply negbT.
Qed.

(* Hint Resolve not_le__lt b_false__not_b : myleq. *)
Hint Resolve le_false_lt : myleq.

(* **** *)
(* 証明 *)
(* **** *)
Inductive Permutation (T : eqType) : seq T -> seq T -> Prop :=
| perm_nil : Permutation nil nil
| perm_skip : forall (x : T) (l l' : seq T),
    Permutation l l' -> Permutation (x :: l) (x :: l')
| perm_swap : forall (x y : T) (l : seq T), Permutation [:: y, x & l] [:: x, y & l]
| perm_trans : forall l l' l'' : seq T,
    Permutation l l' -> Permutation l' l'' -> Permutation l l''.

Hint Resolve perm_nil perm_skip perm_swap perm_trans : perm.

Lemma perm_refl : forall (T : eqType) (l : seq T), Permutation l l.
Proof.
  move=> T l.
  elim: l; by auto with perm.
Qed.

Lemma perm_cons : forall (T : eqType) (n : T) (l l' : seq T),
    Permutation l l' -> Permutation (n :: l) (n :: l').
Proof.
  move=> T n l l' H.
  now inversion H; auto with perm.
Qed.

Hint Resolve perm_refl perm_cons : perm.

Lemma perm_iff : forall (T : eqType) (m n : seq T),
    (forall l, Permutation m l = Permutation n l) <-> Permutation m n.
Proof.
  move=> T m n.
  split=> H.
  - rewrite H; by auto with perm.
  - inversion H; subst.
    + by auto with perm.
    +
admit.
Admitted.
(* Permutation をつかって rewrite したい。 *)

Lemma perm_cat_swap : forall (T : eqType) (s1 s2 s3 : seq T),
    Permutation (s1 ++ s2 ++ s3) (s2 ++ s1 ++ s3).
Proof.
Admitted.

Lemma perm_cons_swap : forall (T : eqType) (l l' : seq T) (x a : T),
      Permutation [:: x, a & l] l' = Permutation [:: a, x & l] l'.
Proof.
  move=> T l l' x a.
  apply perm_iff.
  rewrite -[[:: x, a & l]]cat1s.
  rewrite -[[:: a & l]]cat1s.
  rewrite -[[:: a, x & l]]cat1s.
  rewrite -[[:: x & l]]cat1s.
  by apply perm_cat_swap.
Qed.

(* **** *)
(* 証明 *)
(* **** *)
Inductive LocallySorted (T : eqType) (R : rel T) : seq T -> Prop :=
| LSorted_nil : LocallySorted R nil
| LSorted_cons1 : forall a : T, LocallySorted R (a :: nil)
| LSorted_consn : forall (a b : T) (l : seq T),
                    LocallySorted R (b :: l) ->
                    R a b -> LocallySorted R (a :: b :: l).

Hint Resolve LSorted_nil LSorted_cons1 LSorted_consn : sort.

(* ソート処理の定義 *)

Program Fixpoint insert n l {struct l} :
  {l' : seq nat | Permutation (n :: l) l' /\
                  (LocallySorted leq l -> LocallySorted leq l') /\
                  (head n l' = n \/ head n l' = head n l)} :=
  match l with
  | [::] => n :: nil
  | n' :: l' =>
    if n <= n' then
      [:: n, n' &  l']
    else
      n' :: insert n l'
  end.
Obligations.
Next Obligation.
    by auto with perm sort.
Defined.
Next Obligation.
  case Hnn' : (n <= n').
  - split; by auto with perm sort.
  - split.
    + rewrite perm_cons_swap.
      by auto with perm.
    + split.
      * move=> H0.
        have H1 : LocallySorted leq l' by inversion H0; auto with sort.
        have H2 : LocallySorted leq x by auto.
        elim: x p l0 o H2.
        ** by auto with sort.
        ** inversion H0; subst.
           *** move=> a l' _ _ _ Ho H2; rewrite /= in Ho.
               case: Ho => Ho; subst;
                             by auto with sort myleq.
           *** move=> a l' _ _ _ Ho H2; rewrite /= in Ho.
               case: Ho => Ho; subst;
                             by auto with sort myleq.
      * by auto.
Defined.

Program Fixpoint isort l {struct l} :
  {l' : seq nat | Permutation l l' /\ LocallySorted leq l'} :=
  match l with
  | nil => nil
  | a::l' => insert a (isort l')
  end.
Next Obligation.
  by auto with sort perm.
Defined.
Next Obligation.
  remember (insert a x).
  case H : s => /= {Heqs}; subst.
    by intuition; eauto with perm.
Defined.

Eval compute in proj1_sig (insert 1 nil).                (* [:: 1] *)
Eval compute in proj1_sig (insert 5 [:: 1; 4; 2; 9; 3]). (* [:: 1; 4; 2; 5; 9; 3] *)
Eval compute in proj1_sig (isort [:: 2; 4; 1; 5; 3]).    (* [:: 1; 2; 3; 4; 5] *)

Extraction insert.
Extraction isort.

(* END *)


Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Require Import Bedrock.Decidables.

Set Implicit Arguments.
Set Strict Implicit.

(* Some tactics for automation of later proofs *)
Ltac caseDestruct t := destruct t; try solve [ simpl in *; discriminate ].

Ltac dointuition := repeat (intuition;
  match goal with
    | [ H : exists _, _ |- _ ] => destruct H
  end).

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

Ltac hypRewriter := repeat match goal with
                              | [ H : ?x = _ |- context [ ?x ] ] => rewrite H
                              | [ H1 : ?x = _, H2 : context [ ?x ] |- _ ] => rewrite H1 in H2
                            end.

Ltac loop := repeat (repeat (hypRewriter; autorewrite with provers in *); simpl in *; subst; dointuition).

Ltac provers := intuition; loop; unlet; loop; try congruence; firstorder.

(* null hint to initialize db *)
Hint Rewrite app_nil_l : provers.

Section UpdateAt.
  Variable A : Type.

  Variable new default : A.

  Fixpoint updateAt (ls : list A) (n : nat) : list A :=
    match n with
      | 0 => new :: tail ls
      | S n => match head ls with
                 | None => default
                 | Some v => v
               end :: updateAt (tail ls) n
    end.

  Definition defaulted (ls : list A) (n : nat) (n' : nat) : option A :=
    match Compare_dec.lt_eq_lt_dec n n' with
      | inleft (left _) => nth_error ls n'
      | inleft (right _) => Some new
      | inright _ => match nth_error ls n' with
                       | None => Some default
                       | Some v => Some v
                     end
    end.

  Require Import Coq.omega.Omega.
  Lemma nth_error_updateAt : forall n l,
    nth_error (updateAt l n) n = value new.
    induction n; destruct l; simpl; (reflexivity || apply IHn).
  Defined.

  Lemma nth_error_updateAt_not : forall old n' ls n,
    n <> n' ->
    nth_error ls n = Some old ->
    nth_error (updateAt ls n') n = Some old.
  Proof.
    induction n'; destruct ls; destruct n; simpl; intros; try solve [ discriminate | exfalso; auto | auto ].
  Qed.

  Lemma nth_error_updateAt_gt : forall n n' ls,
    n < n' ->
    nth_error (updateAt ls n) n' = nth_error ls n'.
  Proof.
    induction n; simpl; intros.
      destruct n'; destruct ls; simpl; intros; try solve [ auto | exfalso; omega | destruct n'; reflexivity ].

      destruct n'. exfalso; omega.
        destruct ls; simpl. rewrite IHn. destruct n'; auto. omega.
        apply IHn. omega.
  Defined.

  Lemma nth_error_updateAt_lt : forall n' n ls,
    n' < n ->
    nth_error (updateAt ls n) n' =
      match nth_error ls n' with
        | None => Some default
        | Some v => Some v
      end.
  Proof.
    induction n'; simpl; intros.
      destruct n; [ exfalso; omega | ]. destruct ls; auto.
      destruct n; [ exfalso; omega | ]. destruct ls; simpl; rewrite IHn' by omega. destruct n'; auto.
      auto.
  Defined.

  Theorem nth_error_updateAt_eq : forall n ls n',
    nth_error (updateAt ls n) n' = defaulted ls n n'.
  Proof.
    unfold defaulted; intros.
      destruct (lt_eq_lt_dec n n'). destruct s.
      eapply nth_error_updateAt_gt; auto.
      subst; eapply nth_error_updateAt; auto.
      eapply nth_error_updateAt_lt; auto.
  Defined.

  (** **)
  Fixpoint cast (P : option A -> Type) ls idx
    : P (nth_error (updateAt ls idx) idx) -> P (Some new) :=
    match idx with
      | O => match ls
             return P (nth_error (updateAt ls O) O) -> _ with
               | nil => fun x => x
               | _ => fun x => x
             end
      | S idx =>
        match ls return P (nth_error (updateAt ls (S idx)) (S idx)) -> _ with
          | nil => cast P nil idx
          | _ => cast P _ idx
        end
    end.

  Theorem cast_inj : forall P idx ls x y, cast P ls idx x = cast P ls idx y -> x = y.
  Proof.
    induction idx; destruct ls; simpl; intros; auto.
  Qed.

End UpdateAt.

Section UpdatePosition2.
  Variable A : Type.

  Hint Rewrite nth_error_updateAt : provers.
  Lemma nth_error_updateAt_2 : forall A (ls : list A) d d' a b m n,
    m <> n ->
    nth_error (updateAt a d (updateAt b d' ls n) m) n = value b.
    induction ls; induction m; induction n; provers.
  Qed.
End UpdatePosition2.

(*
Section MapRepr.
  Variable T : Type.
  Record Repr : Type :=
  { footprint : list (nat * T)
  ; default : T
  }.

  Definition nil_Repr (d : T) : Repr :=
  {| footprint := nil
   ; default := d
   |}.

  Definition listToRepr (ls : list T) (d : T) : Repr :=
    {| footprint :=
      ((fix listToRepr ls cur : list (nat * T) :=
        match ls with
          | nil => nil
          | l :: ls => (cur, l) :: listToRepr ls (S cur)
        end) ls 0)
     ; default := d
     |}.

  Definition listOptToRepr (ls : list (option T)) (d : T) : Repr :=
    {| footprint :=
      ((fix listToRepr ls cur : list (nat * T) :=
        match ls with
          | nil => nil
          | Some l :: ls => (cur, l) :: listToRepr ls (S cur)
          | None :: ls => listToRepr ls (S cur)
        end) ls 0)
     ; default := d
     |}.

  Fixpoint repr' (d : T) (ls : list (nat * T)) : list T -> list T :=
    match ls with
      | nil => fun x => x
      | (n, v) :: ls =>
        fun x => updateAt v d (repr' d ls x) n
    end.

  Section get.
    Variable n : nat.

    Fixpoint get (ls : list (nat * T)) : option T :=
      match ls with
        | nil => None
        | (n',v) :: ls =>
          if Peano_dec.eq_nat_dec n n' then Some v else get ls
      end.
  End get.

  Definition repr (l : Repr) : list T -> list T :=
    match l with
      | {| footprint := f ; default := d |} =>
        repr' d f
    end.

  Fixpoint nat_eq_bool (a b : nat) : bool :=
    match a , b with
      | 0 , 0 => true
      | S a , S b => nat_eq_bool a b
      | _ , _ => false
    end.

  Fixpoint nat_in (l : list nat) (n : nat) : bool :=
    match l with
      | nil => false
      | a :: b => if nat_eq_bool a n then true else nat_in b n
    end.

  Fixpoint repr_optimize (l : list (nat * T)) (ignore : list nat) : list (nat * T) :=
    match l with
      | nil => nil
      | (n,t) :: b =>
        if nat_in ignore n then
          repr_optimize b ignore
        else
          (n,t) :: repr_optimize b (n :: ignore)
    end.

  Definition repr_combine (l r : Repr) : Repr :=
    match l , r with
      | {| footprint := lf ; default := ld |} ,
        {| footprint := rf ; default := rd |} =>
        {| footprint := repr_optimize (lf ++ rf) nil ; default := ld |}
    end.
  (** NOTE: that we don't have any lemmas for combination because we are
   ** relying on Ltac's dynamic types to do combinations
   **)

  Definition repr_get (l : Repr) (n : nat) : option T :=
    get n (footprint l).

End MapRepr.
*)

(** This is an alternative representation
 ** 1) it avoids nats (including comparison)
 ** 2) it is canonical
 ** 3) it optimizes the common case of prefixes
 **)
Section Repr2.
  Section parametric.
    Variable T : Type.
    Record Repr : Type :=
    { footprint : list (option T)
    ; default : T
    }.

    Definition nil_Repr (d : T) : Repr :=
      {| footprint := nil
       ; default := d
      |}.

    Definition listToRepr (ls : list T) (d : T) : Repr :=
      {| footprint := map (@Some _) ls
       ; default := d
      |}.

    Definition listOptToRepr (ls : list (option T)) (d : T) : Repr :=
      {| footprint := ls
       ; default := d
      |}.

    Fixpoint repr' (d : T) (ls : list (option T)) : list T -> list T :=
      match ls with
        | nil => fun x => x
        | None :: ls => fun x =>
          match x with
            | nil => d
            | a :: _ => a
          end :: repr' d ls (tl x)
        | Some v :: ls => fun x =>
          v :: repr' d ls (tl x)
      end.

    Definition repr (l : Repr) : list T -> list T :=
      Eval cbv delta [ repr' ] in
        match l with
          | {| footprint := f ; default := d |} =>
            repr' d f
        end.

    Fixpoint join (ls rs : list (option T)) : list (option T) :=
      match ls , rs with
        | nil , rs => rs
        | ls , nil => ls
        | l :: ls , r :: rs =>
          match l with
            | Some _ => l
            | None => r
          end :: join ls rs
      end.

    Definition repr_combine (l r : Repr) : Repr :=
      Eval cbv delta [ join ] in
        match l , r with
          | {| footprint := lf ; default := ld |} ,
            {| footprint := rf ; default := rd |} =>
            {| footprint := join lf rf ; default := ld |}
        end.

    Lemma repr_idempotent : forall a b,
      repr a (repr a b) = repr a b.
    Proof.
      clear. destruct a.
      simpl. induction footprint0; simpl; intros; auto.
      destruct a; simpl; auto. f_equal. rewrite IHfootprint0. auto.
      destruct b; auto. rewrite IHfootprint0; auto. simpl.
      rewrite IHfootprint0. auto.
    Qed.

  End parametric.
End Repr2.

Ltac reduce_repr_list ls :=
  eval cbv beta zeta delta [
    repr_combine repr listOptToRepr listToRepr nil_Repr
    map
  ] in ls.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf2 : lst) : natural := len (append (append Nil Nil) lf2).


Require Export XR_Rlt_0_1.
Require Export XR_Rlt_le_trans.
Require Export XR_Rinv_lt_contravar.

Local Open Scope R_scope.

Lemma Rinv_1_lt_contravar : forall r1 r2,
  R1 <= r1 ->
  r1 < r2 ->
  / r2 < / r1.
Proof.
  intros x y hx hxy.
  apply Rinv_lt_contravar.
  {
    apply Rmult_lt_0_compat.
    {
      apply Rlt_le_trans with R1.
      { exact Rlt_0_1. }
      { exact hx. }
    }
    {
      apply Rlt_trans with x.
      {
        apply Rlt_le_trans with R1.
        { exact Rlt_0_1. }
        { exact hx. }
      }
      { exact hxy. }
    }
  }
  { exact hxy. }
Qed.


Require Import Basics.
Require Import Paths.
Require Import HIT.

Set Primitive Projections.

Record Aug (F : Type) (n : nat) :=
              mkAug {
                  E : Type;
                  d : E × Sphere n -> F
                }.

Arguments mkAug {_ _} _ _.
Arguments E {_ _} _.
Arguments d {_ _} _.

Definition FreeA {F : Type} {n : nat} (aug : Aug F n) : Type :=
  Pushout (d aug) (fun x  => (x.1 , Faces n x.2) : (E aug) × Ball n).

Notation "[ aug ]*" := (FreeA aug).

Inductive Pol : nat -> Type :=
|Disc : Type -> Pol 0
|Ext {n : nat} (P : Pol n) (aug : Aug (Free P) (S n)) : Pol (S n)
fix Free {n : nat} (P : Pol n) : Type :=
       match P with
       | Disc A => A
       | Ext _ _ aug => [ aug ]*
       end.

Opaque Free.
Arguments Free {_} _.

Definition tr {n : nat} (P : Pol n) : Pol (pred n) :=
  match P with
  | Disc E => Disc False
  | Ext P' aug =>  P'
  end.

Definition PAug {n : nat} (P : Pol n) : Aug (Free (tr P)) n :=
  match P with
  | Disc E => mkAug False (fun x => x.1)
  | Ext P aug => aug
  end.

Coercion PAug : Pol >-> Aug.

Definition case0 (P : Pol 0 -> Type) (H : forall (T : Type), P (Disc T))  (p : Pol 0) : P p :=
  match p with
  |Disc T => H T
  |_ => tt
  end.

Definition caseS' {n : nat} (p : Pol (S n)) :
  forall (P : Pol (S n) -> Type) (H : forall (p : Pol n) (aug : Aug (Free p) (S n)), P (Ext p aug)), P p :=
  match p with
  |Ext p' aug => fun P H => H p' aug
  |_ => tt
  end.

(** Definition of the Morphisms of polygraphs **)

Record MAug {F F' : Type} {n :nat} (f : F -> F') (aug : Aug F n) (aug' : Aug F' n) :=
  mkMAug {
      ME: E aug -> E aug';
      Md : forall e x, d aug' (ME e, x) = f (d aug (e, x))
    }.

Arguments ME {_ _ _ _ _ aug'} _ _.
Arguments Md {_ _ _ _ _ aug'} _ _ _.
Arguments mkMAug {_ _ _ _ _ aug' } _ _.

Notation "aug1 - f -- aug2" := (MAug f aug1 aug2) (at level 10).

Definition FreeMA {F F' : Type} {n : nat} {aug : Aug F n} {aug' : Aug F' n}  {f : F -> F'} : aug - f -- aug' -> (FreeA aug -> FreeA aug').
Proof.
  intros Phi.
  simple refine (Pushout_rect _ _ _).
  - intro xf. exact (inl (f xf)).
  - intros. simple refine (inr _).
    exact (ME Phi X.1, X.2).
  - intro x. simpl.
    simple refine ((f_equal inl (Md Phi x.1 x.2))^ @ _).
    exact (incoh (ME Phi x.1, x.2)).
Defined.

Definition ComposeMA {F F' F'' : Type} {n : nat} {f : F -> F'} {f' : F' -> F''} {aug : Aug F n} {aug' aug''} (G : MAug f aug aug') (G' : MAug f' aug' aug'') : MAug (compose f' f) aug aug''.
Proof.
  simple refine (mkMAug _ _).
  - exact (compose (ME G') (ME G)).
  - intros. unfold compose. exact ((Md G' (ME G e) x) @ (f_equal (fun W => f' W)  (Md G e x))).
Defined.

Definition FreeComposeMA {F F' F'' : Type} {n : nat} {f : F -> F'} {f' : F' -> F''} {aug : Aug F n} {aug' aug''} (G : MAug f aug aug') (G' : MAug f' aug' aug'') : FreeMA (ComposeMA G G') = compose (FreeMA G') (FreeMA G).
Proof.
  apply funext.
  simple refine (Pushout_rect_dep _ _ _ _).
  - reflexivity.
  - reflexivity.
  - intro x. apply transport_lemma. simpl.
    rewrite concat_1p. unfold compose.
    rewrite ap_compose. unfold FreeMA. unfold compose.
    match goal with
    | |- _ = f_equal (Pushout_rect ?g1 ?g2 ?H) (incoh x) => refine (_ @ (Pushout_rect_compute_coh (f1 := d aug) (f2 := fun x => (x.1, (Faces n x.2))) (g1:= g1) (g2 := g2) (a := x))^)
    end.
    simpl. rewrite ap_concat.
    match goal with
    | |- f_equal ?F (f_equal (Pushout_rect ?g1 ?g2 ?H) (incoh x)) = _ => pose proof (Pushout_rect_compute_coh (f1 := d aug) (f2 := fun x => (x.1, (Faces n x.2))) (g1 := g1) (g2 := g2) (H := H) (a := x))
    end.
    match goal with
    | |- f_equal ?F ?u = ?v => refine (apap F H @ _); clear H
    end.
    rewrite ap_concat.
    rewrite concat_ap_V.
    match goal with
    | |- (f_equal ?a1 (f_equal inl ?a2))^ @ _ = _ => rewrite <- ap_compose
    end.
    unfold compose. simpl.
    match goal with
    | |- ?a1 @ f_equal (Pushout_rect ?g1 ?g2 ?H) (incoh ?y) = _ =>
      refine (f_equal (fun T => a1 @ T) (Pushout_rect_compute_coh (f1 := d aug') (f2 := fun x => (x.1, Faces n x.2)) (g1 := g1) (g2 := g2) (H := H)) @ _)
    end.
    simpl. rewrite concat_V.
    pose proof @ap_compose.
    unfold compose in H. rewrite <- H.
    now rewrite assoc.
Defined.

Inductive MPol : forall n : nat, (Pol n) -> (Pol n) -> Type :=
| DiscM (T T' : Type) : (T -> T') -> MPol 0 (Disc T) (Disc T')
| ExtM (n : nat) (P P' : Pol n) (aug : Aug (Free P) (S n)) (aug' : Aug (Free P') (S n))
       (f : MPol n P P') (Mf : MAug (FreeM P P' f) aug aug') : MPol (S n) (Ext P aug) (Ext P' aug')
 fix FreeM {n : nat} (P P' : Pol n) (X : MPol n P P') : (Free P) -> (Free P') :=
  match X with
  |DiscM _ _ f => f
  |ExtM _ _ _ _ _ _ Mf => FreeMA Mf
  end.

Notation "P ~> Q" := (MPol _ P Q) (at level 10).

Arguments MPol {_} _ _.
Arguments DiscM {_ _} _.
Arguments ExtM {_ _ _ _ _} _ _.
Arguments FreeM {_ _ _} _.

(** As often with dependent types, destructors are not precis enough, so we define our own: one version for n=0, the other when n = S n' **)

Definition case2 (n : nat) (p0 p1 : Pol n)
           (P : forall n : nat, Pol n -> Pol n -> Type)
           (H0 : forall T0 T1, P 0 (Disc T0) (Disc T1))
           (HS : forall n p0 aug0 p1 aug1, P (S n) (Ext p0 aug0) (Ext p1 aug1)) :
  P n p0 p1 :=
  match p0 with
  |Disc T0 => (fun p1 => case0 _ (H0 T0) p1)
  |Ext p'0 aug'0 => (fun p1 => caseS' p1 _ (HS _ p'0 aug'0))
  end p1.

Definition caseM0 (T T' : Type)  (m : (Disc T) ~> (Disc T')):
  forall (P : MPol (Disc T) (Disc T') -> Type)
    (H : forall (f : T -> T'), P (DiscM f)),
    P m :=
  match m in @MPol n p p' return
        (case2 n p p'
               (fun _ p0 p0' => MPol p0 p0'-> Type)
               (fun t t'  => fun (f : MPol (Disc t) (Disc t'))
                          => forall (P : MPol (Disc t) (Disc t') -> Type) (H : forall f, P (DiscM f)), P f)
               (fun _ _ _ _ _ => (fun _ => unit))
               m)
  with
  | DiscM f => fun P H => H f
  | _ => tt
  end.

Definition caseMS' (n : nat) (p p' : Pol n) (aug : Aug (Free p) (S n)) (aug' : Aug (Free p') (S n))
           (m : (Ext p aug) ~> (Ext p' aug')) :
  forall (P : (Ext p aug) ~> (Ext p' aug') -> Type)
    (HS : forall  (f : p ~> p') (Mf : MAug (FreeM f) aug aug'), P (ExtM f Mf)),
    P m :=
  match m in @MPol n p p' return
        (case2 n p p'
               (fun _ p0 p0' => MPol p0 p0'-> Type)
               (fun _ _ => (fun _ => unit))
               (fun n0 p0 aug0 p'0 aug'0 => fun (m : MPol (Ext p0 aug0) (Ext p'0 aug'0))
                                         => forall P H, P m)
               m)
  with
  | ExtM f Mf => (fun P H => H f Mf)
  | _ => tt
  end.

(** This defines the composition of morphisms of polygraphs **)

Fixpoint PolyComposeAndFree {n : nat} (p q r : Pol n) (G : p ~> q) (H : q ~> r) {struct n}:
  {Comp : p ~> r |
    FreeM Comp = compose (FreeM H) (FreeM G)}.
Proof.
  destruct n.
  - simple refine (mkDPair _ _); destruct p using case0; destruct q using case0; destruct r using case0;
      destruct H as [h] using (caseM0 _ _); destruct G as [g] using (caseM0 _ _).
    + econstructor. exact (compose h g).
    + exact 1.
  - simple refine (mkDPair _ _);
      destruct p as [p' Ep] using caseS';
      destruct q as [q' Eq] using caseS'; destruct r as [r' Er] using caseS';
      destruct G as [G' GAug] using (caseMS' _ _ _ _ _); destruct  H as [H' HAug] using (caseMS' _ _ _ _ _).
    + unshelve econstructor.
      * exact (fstd (PolyComposeAndFree _ _ _ _ G' H')).
      * refine (eq_rect (fun W => MAug W Ep Er) _ ((sndd (PolyComposeAndFree n p' q' r' G' H'))^)).
        exact (ComposeMA GAug HAug).
    + simpl.
      simple refine (_ @ (FreeComposeMA _ _)).
      match goal with
      | |- ?f (eq_rect ?P ?p ?u) = _ => exact (image_transport P u p _)
      end.
Defined.

Notation ComposeM G H := (fstd (PolyComposeAndFree _ _ _ G H)).
Notation FreeComposeM G H := (sndd (PolyComposeAndFree _ _ _ G H)).

Definition IdMA {n : nat} {T : Type} (aug : Aug T n)  : MAug (fun x => x) aug aug := mkMAug (fun x => x) (fun  _ _ => 1).

Definition FreeIdMA {n : nat} {T : Type} (aug : Aug T n) : FreeMA (IdMA aug) = (fun x => x).
Proof.
  apply funext.
  simple refine (eqMorphPushout _ _ _ ).
  - intro b1. simpl. reflexivity.
  - intro b2. simpl. destruct b2.  reflexivity.
  - simpl. intros [a a'].
    simple refine ( concat_1p _ @ _).
    simple refine (ap_along_id _ @ _).
    refine (_ @  Pushout_rect_compute_coh ^).
    exact ((concat_1p _)^).
Defined.

Fixpoint IdAndFreeM {n : nat} : {f : forall p : Pol n, MPol p p | forall p : Pol n, FreeM (f p) = (fun x => x)}.
Proof.
  destruct n.
  - simple refine (mkDPair _ _); intro p;  destruct p using case0.
    + econstructor.  exact (fun x => x).
    + exact 1.
  -  simple refine (mkDPair _ _ ); intro p; destruct p using caseS'.
    + unshelve econstructor.
      * exact (fstd (IdAndFreeM n) p).
      * match goal with
        | |- MAug _ aug aug => simple refine (eq_rect (fun W => MAug W aug aug)  _ _)
        end.
        -- exact (fun x => x).
        -- simpl. exact (IdMA aug).
        -- exact ((sndd (IdAndFreeM n) p)^).
    + simpl.
      simple refine ((image_transport _ _ _ _) @ (FreeIdMA _) ).
Defined.


Require Import Burrow.trees.
From stdpp Require Import gmap.

Require Import cpdt.CpdtTactics.
Require Import coq_tricks.Deex.

Inductive AuthFrag (M: Type) :=
  | AF : option (option M) -> M -> AuthFrag M
.
Global Arguments AF {_}%type_scope _ _.

Definition af_valid {M} `{!EqDecision M} `{!TPCM M} a :=
  match a with
  | AF None frag => m_valid frag
  | AF (Some (Some auth)) frag => m_valid auth /\ ∃ c , dot frag c = auth
  | AF (Some None) _ => False
  end.

Definition auth_dot {M} (a b : option (option M)) : option (option M) :=
  match a, b with
  | None, None => None
  | Some x, None => Some x
  | None, Some y => Some y
  | Some x, Some y => Some None
  end.

Definition af_dot {M} `{!EqDecision M} `{!TPCM M} (a b : AuthFrag M) :=
  match a, b with
  | AF auth_a frag_a, AF auth_b frag_b => AF (auth_dot auth_a auth_b) (dot frag_a frag_b)
  end.

Definition af_mov {M} `{!EqDecision M} `{!TPCM M} (a b : AuthFrag M) :=
  ∀ z , af_valid (af_dot a z) -> af_valid (af_dot b z).

Lemma af_dot_comm {M} `{!EqDecision M} `{!TPCM M} (x y : AuthFrag M)
  : (af_dot x y) = (af_dot y x).
Proof. unfold af_dot. destruct x, y.
    rewrite tpcm_comm. f_equal.
    unfold auth_dot. destruct o, o0; trivial.
Qed.

Lemma af_dot_assoc {M} `{!EqDecision M} `{!TPCM M} (x y z : AuthFrag M)
  : af_dot x (af_dot y z) = af_dot (af_dot x y) z.
Proof. unfold af_dot. destruct x, y, z.
    rewrite tpcm_assoc. f_equal.
    unfold auth_dot. destruct o, o0, o1; trivial.
Qed.

Global Instance af_eqdec M `{!EqDecision M} : EqDecision (AuthFrag M).
Proof. solve_decision. Qed.

#[refine]
Global Instance af_tpcm M `{!EqDecision M} `{!TPCM M} : TPCM (AuthFrag M) := {
  m_valid p := af_valid p ;
  dot a b := af_dot a b ;
  mov a b := af_mov a b ;
  unit := AF None unit ;
}.
 - intros. unfold af_valid, af_dot in *. destruct x, y. unfold auth_dot in *.
    destruct o, o0; intuition.
    + destruct o; intuition. deex. exists (dot m0 c). rewrite tpcm_assoc. trivial.
    + destruct o; intuition. deex. subst m1. rewrite <- tpcm_assoc in H0.
        apply valid_monotonic with (y := dot m0 c). trivial.
    + apply valid_monotonic with (y := m0). trivial.
 - unfold af_valid. apply unit_valid.
 - intros. unfold af_dot. destruct x. rewrite unit_dot.
    unfold auth_dot. destruct o; trivial.
 - apply af_dot_comm.
 - apply af_dot_assoc.
 - intros. unfold af_mov. intro. trivial.
 - intros. unfold af_mov in *. intros. apply H0. apply H. trivial.
 - intros. split.
  * unfold af_mov in H. apply H. apply H0.
  * unfold af_mov in H. unfold af_mov. intro.
      rewrite <- af_dot_assoc.
      rewrite <- af_dot_assoc.
      apply H.
Defined.

Definition auth {M} `{!EqDecision M} `{!TPCM M} (m: M) :=
    AF (Some (Some m)) unit.

Definition frag {M} `{!EqDecision M} `{!TPCM M} (m: M) :=
    AF None m.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Succ : natural -> natural
| Zero : natural.

Inductive lst : Set :=
| Cons : natural -> lst -> lst
| Nil : lst.

Fixpoint double (n : natural) {struct n} : natural :=
  match n with
  | Succ n => Succ (Succ (double n))
  | Zero => Zero
  end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) {struct append_arg0}
  : lst :=
  match append_arg0 with
  | Cons x y => Cons x (append y append_arg1)
  | Nil => append_arg1
  end.

Fixpoint len (n : lst) {struct n} : natural :=
  match n with
  | Cons _ y => Succ (len y)
  | Nil => Zero
  end.

Definition synth (lf1 : lst) : natural := len (append (append Nil Nil) lf1).


Require Export B6_Cercle_Def.

Section EQUILATERAL_TRIANGLE.

Definition Equilateral (A B C : Point) :=
	Distance A B = Distance A C /\
	Distance A B = Distance B C.

Lemma DegeneratedEquilateral : forall A : Point,
	Equilateral A A A.
Proof.
	intro; split; auto.
Qed.

Lemma Exists2AB : forall A B : Point,
	A <> B ->
	{C : Point |
		Between A B C /\
		Distance B C = Distance A B}.
Proof.
	intros A B Hab.
	setLine A B Hab ipattern:(L) ipattern:(AB).
	setCircle B A B Hab ipattern:(G) ipattern:(BAB).
	setLinterposC L G AB BAB ipattern:(C) ipattern:(H1) ipattern:(H2) ipattern:(H3) ipattern:(H4).
	 apply CollinearABB.
	 exists C; canonize.
Qed.

Lemma EquilateralLSlt : forall A B : Point,
	A<>B -> LSlt (Distance A B) (LSplus (Distance A B) (Distance A B)).
Proof.
	intros A B H; destruct (Exists2AB A B H) as (C, (H0, H1)).
	pattern (Distance A B) at -3 in |- *; rewrite <- H1.
	rewrite (DistSym A B); rewrite (DistSym B C).
	rewrite Chasles.
	 apply OrderLSlt.
	  auto.
	  generalizeChangeSide.
	 apply (BetweenSymHalfLine _ _ _ H0).
	 apply (BetweenHalfLine _ _ _ H0).
Qed.

Lemma EquilateralSpec : forall A B : Point,
	A<>B -> TriangleSpec (Distance A B) (Distance A B) (Distance A B).
Proof.
	unfold TriangleSpec in |- *; intuition; apply EquilateralLSlt; auto.
Qed.

Lemma EquilateralClockwise : forall A B : Point,
	A <> B ->
	{C : Point | Equilateral A B C /\ Clockwise A B C}.
Proof.
	intros.
	setCircle A A B H ipattern:(C1) ipattern:(H1).
	setCircle B A B H ipattern:(C2) ipattern:(H2).
	setCinterclockC C1 C2 H1 H2 ipattern:(C) ipattern:(H3) ipattern:(H4) ipattern:(H5)
	 ipattern:(H6); unfold C1, C2, H1, H2 in *; simpl in *.
	 apply EquilateralSpec; auto.
	 exists C; unfold Equilateral in |- *; intuition.
Defined.

Lemma ClockwiseExists : forall A B : Point,
	A <> B ->
	{C : Point | Clockwise A B C}.
Proof.
	intros A B H; destruct (EquilateralClockwise A B H) as (C, (H1, H2)).
	exists C; trivial.
Qed.

Lemma ThirdPoint : {Vv : Point | Clockwise Oo Uu Vv}.
Proof.
	exact (ClockwiseExists Oo Uu DistinctOoUu).
Qed.

Lemma  Apart : forall A B C : Point,
	A <> B -> A <> C \/ B <> C.
Proof.
	intros A B C H; decompose [or] (FourCases A B C).
	 right; exact (ClockwiseDistinctBC A B C H0).
	 left; exact (ClockwiseDistinctBC B A C H1).
	 canonize.
	   destruct (ClockwiseExists A B H) as (E, H1).
	   left; exact (ClockwiseDistinctAB A C E (H0 E H1)).
	 canonize.
	   destruct (ClockwiseExists B A (sym_not_eq H)) as (E, H1).
	   right; exact (ClockwiseDistinctAB B C E (H0 E H1)).
Qed.

End EQUILATERAL_TRIANGLE.


(** * Muskens' Higher Order Modal Logic *)

Parameters S  I  P_S : Set.

Parameter Elem : S -> P_S -> Prop.

Definition Cont (s : P_S) ( t: P_S) := forall (x: S),   Elem x s -> Elem x t.

Definition Char ( s: P_S ) :=  fun ( x : S) =>  Elem x s.

Parameter CSet : (S -> Prop) -> P_S.

Definition Ex_eq (s : P_S) (t : P_S) := forall (x : S), Elem x s <-> Elem x t.

Axiom char_equiv : forall (s : P_S),    Ex_eq (CSet (Char s)) s.

Axiom cset_equiv : forall (c : S -> Prop), forall (x :S),  c x <->   Char (CSet c) x.

Definition Cl (s : P_S) :=   CSet (fun (x : S) => not ((Char s) x ) ).

Definition Lim (I : Set) (D: I -> P_S) :=  CSet ( fun (x :S) => forall ( i : I),  Elem x (D i) ).

Definition MType (T : Type) := T -> P_S.

Definition Inv_r ( r : S -> P_S) := fun (x :S) =>  CSet ( fun (z :S) =>  Elem x (r z)).

Definition O := CSet (fun (x :S) => False).

Definition S_S := CSet (fun (x :S) => True).

Definition Top := fun (x :S) => S_S.

Definition Bot := fun (x :S) => O.

Definition mod (r : S -> P_S) ( p : P_S ) :=  CSet ( fun (x: S) => exists ( y :S),  and (Elem y (r x)) ((Char p) y)
).

Definition dot (a : S) := Lim (S -> P_S) ( fun (r : S -> P_S) =>  mod r (   (Inv_r r) a )     ).

Definition Imp (a : P_S) (b : P_S) :=   CSet ( fun (x : S) =>  not (and (Elem x a) (not (Elem x b) )    )).

Definition MEq (T : Set) ( x : T)( y :T) := Lim ( T -> P_S) ( fun (z : T -> P_S) =>  Imp ( z x) ( z y)   ).

Definition sq (r : S -> P_S) ( p : P_S ) := Cl (mod r (Cl p) ).

Definition Loz ( p : P_S ) :=  mod Top p.

Definition Sq  ( p : P_S ) := sq Top p.