Require Import Coq.Logic.FunctionalExtensionality.
From mathcomp Require Import ssreflect ssrfun eqtype choice fintype seq bigop.

Set Warnings "-parsing". (* Some weird bug in ssrbool throws out parsing warnings*)
  From mathcomp Require Import ssrbool.
Set Warnings "parsing".
Set Warnings "-ambiguous-paths". (* Some weird bug in ssralg throws out coercion warnings*)
    From mathcomp Require Import ssralg.
Set Warnings "ambiguous-paths".

Require Import Algebras QuiverRep PathAlgebra Submodule Morphism ntPath Path.
Require Import PathAlgebraBasis Basis FreeModules DirectSum Dimension Matrices.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope ring_scope.
Module QuivRepFunc.

  Section Def.
    Variable R : comRingType.
    Variable Q : finQuiverType.

    Section RepToMod.
      Variable V : fdQuiverRepType R Q.

      Definition VIndex := fun i => \Vec^fd_(V)(i).
      Definition AIndex (f : \A_Q -> \V_Q) := fun a => \Vec^fd_(V)(f(a)).

      Definition dsum_vertices :=   \fbigoplus_(i : \V_Q)VIndex i.

      (* We want to define a path-algebra action on
      the R-module dsum_vertices, turning it into a
      (path-algebra)-module
      *)
      Definition path_action_Lin (p : pathAlgBasis R Q) : {linear dsum_vertices -> dsum_vertices}
      :=  linConcat.map
            (fdFreeLmodProj VIndex (Path.tail p))
            (linConcat.map
              (QuivRep.Path V p)
              (fdFreeLmodInj VIndex (Path.head p))
            ).

      Definition ntpath_action_mul_Lin (p q : NTPath.type Q) :
       {linear dsum_vertices -> dsum_vertices}
        := match \head_p--Q-->\tail_q
        as J' return _ = J' -> _
      with  true =>
            fun J' => path_action_Lin (inr (NTPath.cat J'))
         | false =>
            fun _ => linZero.map _ _ end
      (erefl (\head_p--Q-->\tail_q)).

      Definition path_action_mul_Lin (p q : pathAlgBasis R Q) : {linear dsum_vertices -> dsum_vertices}
       := match p : pathType Q with
       |\e_i => if (Path.tail q) == i
          then path_action_Lin q
          else linZero.map _ _
       |inr p' => match q : pathType Q with
          |\e_i => if (Path.head p' == i)
                  then path_action_Lin p
                  else linZero.map _ _
          |inr q'   => ntpath_action_mul_Lin p' q'
        end
      end.

      Lemma path_action_mul (p q : pathAlgBasis R Q)
       : (path_action_Lin q) \o (path_action_Lin p) = path_action_mul_Lin p q.
      Proof.
        case p=>[pi|pp].
        {
          case q=>[qi|qq].
          {
            rewrite /path_action_mul_Lin/comp/path_action_Lin.
            apply functional_extensionality=>v/=.
            case (qi == pi) as []eqn:E.
              by apply (rwP eqP) in E;
                rewrite E fdFreeLmodFin.proj_injK.
              by rewrite fdFreeLmodFin.proj_inj0;
                [rewrite GRing.linear0| rewrite E].
          } {
            rewrite /path_action_mul_Lin/comp/path_action_Lin.
            apply functional_extensionality=>v/=.
            case (\t_Q(\tail_qq) == pi) as []eqn:E=>/=.
              by apply (rwP eqP) in E;
                rewrite -E fdFreeLmodFin.proj_injK.
              by rewrite fdFreeLmodFin.proj_inj0;
                [rewrite !GRing.linear0| rewrite E].
          }
        } {
          case q=>[qi|qq].
          {
            rewrite /path_action_mul_Lin/comp/path_action_Lin.
            apply functional_extensionality=>v/=.
            case (\h_Q(\head_pp) == qi) as []eqn:E=>/=.
              by apply (rwP eqP) in E;
            rewrite -E fdFreeLmodFin.proj_injK.
              by rewrite fdFreeLmodFin.proj_inj0;
                [rewrite !GRing.linear0 | rewrite eq_sym E].
          } {
            rewrite /path_action_mul_Lin/comp/path_action_Lin.
            apply functional_extensionality=>v/=.
            destruct pp as [[pa pp] pH], qq as [[qa qq] qH].
            induction pp.
            rewrite/NTPath.type2path/NTPath.type2head/NTPath.type2deTail/NTPath.type2tail=>/=.
            case (\h_Q(pa) == \t_Q(qa)) as []eqn:E. {
              apply (rwP eqP) in E=>/=.
              rewrite E.
          }

              case(pi == \h_Q( \head_ (qq))) as []eqn:E2.
                apply (rwP eqP) in E2.
                rewrite E2.
                rewrite fdFreeLmodFin.proj_injK.
              rewrite fdFreeLmodFin.proj_inj0.
              by rewrite GRing.linear0.
              case(pi == \h_Q( \head_ (qq))) as []eqn:E2.
                apply (rwP eqP) in E2.
                rewrite E2 in E.
                by [].
            }

        rewrite eq_refl=>/=.
        rewrite /fdFreeLmodProj=>/=.
        rewrite /fdFreeLmodFin.inj=>/=.
        rewrite /fdFreeLmodFin.proj=>/=.
        rewrite /fdFreeLmodFin.from_direct_sum.

      Definition action (v1 : dsum_vertices) : lmodMatrixType (freePathAlgType R Q) (fdFreeLmod.to_arb dsum_vertices)
       := fun b_pv => let (b_p,b_v2) := b_pv in
       lmodBasisProj (basis (fdFreeLmod.to_arb dsum_vertices)) b_v2 (path_action_Lin b_p v1).

      Definition scale (r : pathAlgType R Q) (v : dsum_vertices)
      := extendLinearlyRisky (action v) r.
       (*Takes each basis element of v in V_tp
        to the corresponding sum of basis elements in V_hp and scales by r(p) *)

      Lemma scale_comp (a b : pathAlgType R Q) (v : dsum_vertices) : scale a (scale b v) = scale (a * b) v.
      Proof.
        rewrite /scale=>/=.
        rewrite {1}/action=>/=.

        fun b_pv : PAlgBasis.pathAlgBasisSet R Q * basis dsum_vertices =>
        let (b_p, b_v2) := b_pv in
        lmodBasisProj (basis dsum_vertices) b_v2
          (fdFreeLmodFin.inj (f:= Path.head b_p)
            (\PathMap_(V)(b_p)
              (fdFreeLmodFin.proj (f:= Path.tail b_p)
                (extendLinearlyRisky (action v) b)))))

        rewrite (linExtend.extendLinearlyREq)=>p/=.
        rewrite (extendLinearlyRisky1K).
        rewrite (@extendLinearlyRiskyK R (pathAlgType R Q) (dsum_vertices)
          (pathAlgBasis R Q) (basis dsum_vertices) (path_action_fn)).
        rewrite {1 2}/path_action=>/=.
        destruct(typeIsInfSpanning (PAlgBasis.basis R Q) a) as [La Ha]eqn:A.
        destruct(typeIsInfSpanning (PAlgBasis.basis R Q) b) as [Lb Hb]eqn:B.
        destruct(typeIsInfSpanning (PAlgBasis.basis R Q) ((a : pathAlgType R Q) * b)) as [Lab Hab]eqn:AB.
        rewrite A B AB=>/=. clear A B AB.
        rewrite /PAlgBasis.pathApply.
      Admitted.

      Lemma newScale_left_id : left_id 1 newScale.
      Proof.      rewrite /newScale=>v/=.
        rewrite /infBasis.MakeExtension.
        destruct(typeIsInfSpanning (PAlgBasis.basis R Q) 1) as [L H]eqn:One.
        rewrite One.
        rewrite /path_action.
        rewrite /PAlgBasis.pathApply=>/=.
        rewrite PAlgBasis.OneIsFiniteSum.

      (* GRing.raddf_sum *)
      Admitted.

      Program Definition repToMod_lmodMixin
        := LmodMixin newScale_comp newScale_left_id _ _.
      Next Obligation.
      move=>r x y.
      rewrite /newScale.
      Admitted.
      Next Obligation.
      by move=>x y; rewrite -GRing.raddfD.
      Qed.

      (*refine (eq_bigr _
      (infGenSet.RiskyLinear_basis (PAlgBasis.basis R Q) (path_action V v))).
      rewrite /(GRing.one _)=>/=.
      rewrite /PAMul.One.
      Check (@LmodBasis.coefProj_endo_eq R (pathAlgType R Q) (PAlgBasis.basis R Q) ((path_action_func V)^~(newScale b v))).
      rewrite -GRing.scalerA.
      rewrite (LmodBasis.coefProj_eq (PAlgBasis.basis R Q)).
      rewrite (LmodBasis.basisMap_to_lmodMap_unfold
      (PAlgBasis.basis R Q)
      ((path_action_func V)^~v)
      ).
      destruct(scale_sig V v) as [g G]=>/=.
      destruct(scale_sig V v) as [g2 G2]=>/=.
      rewrite /scale_sig.
      apply eq_bigr=>i _.
      apply lmod_CountSums.sum_eq.
      apply functional_extensionality=>p.
      rewrite -lmod_CountSums.sum_bigop.
      Admitted.*)

      Definition repToMod : lmodType (PathAlg.lalg R Q)
      := LmodType (PathAlg.lalg R Q) dsum_vertices repToMod_lmodMixin.
    End RepToMod.

    Section ModToRep.
      Variable (M : lmodType (pathAlgType R Q)).

      Definition vPred (i : \V_Q) : pred M := fun m => m == \B[R](\e_i)*:m.

      Lemma vPred_subModule (i : \V_Q)
        : @submod_closed R (lmods.AtoRmod M) (subLmod.qualSubElem (vPred i)).
      Proof.
        split=>[|a x y]; rewrite qualifE unfold_in.
        by rewrite GRing.scaler0.
        rewrite !unfold_in -!(rwP eqP)=>Hx Hy.
        rewrite Hx Hy !GRing.scalerDr !GRing.scalerA PAlgBasis.idem.
      Admitted.

      Definition VSpace (i : \V_Q) := subLmodPack (vPred_subModule i).
  (*
      Program Definition VSpace_zmod_mixin (i : \V_Q)
        := (@ZmodMixin {m : M | m == \B[R](\e_i)*:m } _ _ _ _ _ _ _).
      Next Obligation.
      refine(exist _ 0%R _).
      by rewrite GRing.scaler0 eq_refl.
      Qed. Next Obligation.
      refine(exist _ (-X) _).
      apply(rwP eqP) in H.
      rewrite GRing.scalerN.
      by rewrite {1}H.
      Qed. Next Obligation.
      refine(exist _ (X + X0) _).
      apply(rwP eqP) in H.
      apply(rwP eqP) in H0.
      by rewrite {1}H {1}H0 GRing.scalerDr.
      Qed. Next Obligation.
      move=>x y z.
      Admitted. Next Obligation.
      Admitted. Next Obligation.
      Admitted. Next Obligation.
      Admitted.

      Definition VSpace_zmod (i : \V_Q)
      := ZmodType _ (VSpace_zmod_mixin i).

      Program Definition VSpace_lmod_mixin (i : \V_Q)
        := (@LmodMixin R (VSpace_zmod i) _ _ _ _ _).
      Next Obligation.
      Admitted. Next Obligation.
      Admitted. Next Obligation.
      Admitted. Next Obligation.
      Admitted. Next Obligation.
      Admitted.

      Definition VSpace_lmod (i : \V_Q)
      := LmodType R (VSpace_zmod i) (VSpace_lmod_mixin i).
  *)
      Program Definition modToRep : quiverRepType R Q
        := QuivRep.Pack R Q
          (fun i => (VSpace i : lmodType R))
          (fun a => _).
      Next Obligation.
      Admitted.
    End ModToRep.
  End Def.

End QuivRepFunc.
Close Scope ring_scope.


Require Import Coq.Lists.List.
Require Export ParDB.Spec.
Require Export ParDB.Lemmas.
Require Export ParDB.Inst.

Require Export SpecSyntax.
Require Export SpecTyping.
Require Export SpecEvaluation.
Require Export LemmasTyping.
Require Export Agreement.
Require Export Consistency.

Local Ltac crush :=
  intros;
  repeat
    (cbn in *;
     repeat crushIH;
     repeat crushSyntaxMatch;
     repeat crushDbSyntaxMatchH;
     repeat crushDbLemmasRewriteH;
     repeat crushSyntaxRefold;
     repeat crushTypingMatchH;
     subst*;
     try discriminate;
     eauto with ws;
     destruct_conjs;
     idtac
    ).

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma preservation {Γ t τ} (wΓ: WfEnv Γ) (clΓ: CoVarClosed Γ)
  (wt: ⟨ Γ ⊢ t : τ ⟩) :
  ∀ {t'}, t --> t' → ⟨ Γ ⊢ t' : τ ⟩.
Proof.
  induction wt; intros t' r; repeat crushIH; inversion r; crush;
  try
    match goal with
      | H: UValue ?t |- _ => destruct t; crush
    end;
  try (consistency; crush; fail);
  try (repeat (econstructor; crush); fail).
  - replace τ2 with τ2[wkm Exp][beta1 s2] by crush.
    eapply tm_sub; crush.
    constructor; crush.
  - assert (k0 = k) by consistency; subst k0.
    repeat (econstructor; crush).
  - replace τ3 with τ3[wkm Exp][beta1 γ] by crush.
    eapply tm_sub; crush.
    constructor; crush.
  - assert (k0 = k) by consistency; subst k0.
    repeat (econstructor; crush).
Qed.


(** * Equivalence

    等価性に関する定理や定義。 *)

Require Import Basis .
Require Import Path .
Require Import Pwpath .
Require Import Homotopy.

(** 戦術を使う。 *)
Declare ML Module "ltac_plugin".
Set Default Proof Mode "Classic".

(** 記法を使う。 *)
Import Basis.Notation .
Import Basis.Notation.Path .
Import Path.Notation .
Import Pwpath.Notation .
Import Pwpath.Notation.Chain .

(** Note: このモジュールでは式が複雑なため [ _ @[ _ ] _ ] という記法を
    使っている。理解するために絵算を書いてみることを勧める。その際に使う
    見方は以下のとおりである。

    * [A : Type] - 圏
    * [x = y : Type] - [x] から [y] への射
    * [f : A -> B] - [A] から [B] への関手
    * [f == g] - [f] から [g] への自然変換
    * [f @> η] - "Fη" 、左から関手を付ける
    * [ε <@ f] - "εF" 、右から関手を付ける

    *)

(** ** Equivalence'

    Equivalence を使いやすい形で再定義する。
    これらは [change] で元の定義と互いに移り合う。 *)

(** [s] は [r] の断面 (section) である。

    * [s] は [r] の右逆射である。
    * [r] は [s] の引き込み (retraction) である。
    * [r] は [s] の左逆射である。 *)
Definition section
  {A B : Type}
  (s : A -> B) (r : B -> A)
  : Type
  := r o s == idmap .

(** [r] は [s] の引き込み (retraction) である。

    * [r] は [s] の左逆射である。
    * [s] は [r] の断面 (section) である。
    * [s] は [r] の右逆射である。 *)
Definition retraction
  {A B : Type}
  (r : B -> A) (s : A -> B)
  : Type
  := r o s == idmap .

(** [f] と [g] は [retr] と [sect] を通じて随伴的である。 *)
Definition is_adjoint
  {A B : Type}
  {f : A -> B} {g : B -> A}
  (retr : retraction f g) (sect : section f g)
  : Type
  := retr <@ f == f @> sect .

(** [A] と [B] は [f] と [g] を通じて等価 (equivalence) である。 *)
Definition is_equiv_rel
  {A B : Type}
  (f : A -> B) (g : B -> A)
  : Type
  := sigma retr sect, is_adjoint (f := f) (g := g) retr sect .

(** [f] は等価射 (equivalence) である。 *)
Definition is_equiv
  {A B : Type} (f : A -> B)
  : Type
  := sigma equiv_inv, is_equiv_rel f equiv_inv .

(** [A] と [B] は等価 (equivalence) である。 *)
Definition equiv
  (A B : Type) : Type
  := sigma f, is_equiv (A := A) (B := B) f .

(** それぞれ [Homotopy] の同名定義と互換である (convertible) 。 *)
Check idpath : @is_adjoint = @Homotopy.is_adjoint .
Check idpath : @is_equiv_rel = @Homotopy.is_equiv_rel .
Check idpath : @is_equiv = @Homotopy.is_equiv .
Check idpath : @equiv = @Homotopy.equiv .

(** ** Reflexivity

    [equiv] は反射的である。 *)

Lemma retr_idmap
  {A : Type}
  : @retraction A A idmap idmap .
Proof.
 exact 1 .
Defined.

Lemma sect_idmap
  {A : Type}
  : @section A A idmap idmap .
Proof.
 exact 1 .
Defined.

Lemma is_adj_idmap
  {A : Type}
  : @is_adjoint A A idmap idmap retr_idmap sect_idmap .
Proof.
 exact 1 .
Defined.

(** [idmap] は [is_equiv] である。 *)
Definition is_equiv_idmap {A : Type} : is_equiv (@idmap A) .
Proof.
 refine (dpair idmap _) .
 refine (dpair retr_idmap _) .
 refine (dpair sect_idmap _) .
 exact is_adj_idmap .
Defined.

(** 全ての [A : Type] に対して [equiv A A] である。 *)
Definition equiv_idmap {A : Type} : equiv A A .
Proof.
 refine (dpair idmap _) .
 exact is_equiv_idmap .
Defined.

(** ** Transitivity

    [equiv] は推移的である。 *)

Lemma retr_compose
  {A B C : Type} {f : A -> B} {g : B -> A} {h : B -> C} {i : C -> B}
  (r_fg : retraction f g) (r_hi : retraction h i)
  : retraction (h o f) (g o i) .
Proof.
 unfold retraction ; unfold retraction in r_fg, r_hi .
 change (h o (f o g) o i == idmap) .
  refine (
      (* h o (f o g) o i *)
    _
      @[ h o i ]
    _
      (* idmap *)
    ) .
 -
  change (h o (f o g) o i == h o idmap o i) .
  refine (h @> _ <@ i) .
  exact r_fg .
 -
  exact r_hi .
Defined.

Lemma sect_compose
  {A B C : Type} {f : A -> B} {g : B -> A} {h : B -> C} {i : C -> B}
  (s_fg : section f g) (s_hi : section h i)
  : section (h o f) (g o i) .
Proof.
 unfold section ; unfold section in s_fg, s_hi .
 change (g o (i o h) o f == idmap) .
  refine (
      (* g o (i o h) o f *)
    _
      @[ g o f ]
    _
      (* idmap *)
    ) .
 -
  change (g o (i o h) o f == g o idmap o f) .
  refine (g @> _ <@ f) .
  exact s_hi .
 -
  exact s_fg .
Defined.

Lemma is_adj_compose
  {A B C : Type} {f : A -> B} {g : B -> A} {h : B -> C} {i : C -> B}
  (r_fg : retraction f g) (s_fg : section f g)
  (r_hi : retraction h i) (s_hi : section h i)
  (fg : is_adjoint r_fg s_fg) (hi : is_adjoint r_hi s_hi)
  : is_adjoint (retr_compose r_fg r_hi) (sect_compose s_fg s_hi) .
Proof.
 unfold is_adjoint ; unfold is_adjoint in fg, hi .
 unfold retraction in r_fg, r_hi .
 unfold section in s_fg, s_hi .
 unfold retr_compose, sect_compose .
 refine (
     (* (h @> r_fg <@ i) @ r_hi <@ h o f *)
   _
     @[ (h @> r_fg <@ i <@ h o f) @ (r_hi <@ h o f) ]
   _
     @[ ((h @> r_fg <@ i o h) <@ f) @ ((h @> s_hi) <@ f) ]
   _
     @[ (h @> ((r_fg <@ i o h) @ s_hi)) <@ f ]
   _
     @[ h @> ((f o g @> s_hi) @ r_fg) <@ f ]
   _
     @[ (h @> (f o g @> s_hi) <@ f) @ (h @> r_fg <@ f) ]
   _
     @[ (h o f @> (g @> s_hi <@ f)) @ (h o f @> s_fg) ]
   _
     (* h o f @> (g @> s_hi <@ f) @ s_fg *)
   ) .
 -
  exact (wiskerR_pw_fn_pp (h @> r_fg <@ i) r_hi (h o f)) .
 -
  refine (concat_pw_pw _ _) .
  +
   refine ( _ @[ h @> r_fg <@ i <@ h <@ f ] _ ) .
   *
    exact (wiskerR_pw_fn_ff (h @> r_fg <@ i) h f) .
   *
    refine (wiskerR_pw_fn_p _ f) .
    exact (wiskerR_pw_fn_ff (h @> r_fg) i h)^ .
  +
   refine ( _ @[ r_hi <@ h <@ f ] _ ) .
   *
    exact (wiskerR_pw_fn_ff r_hi h f) .
   *
    refine (wiskerR_pw_fn_p _ f) .
    exact hi .
 -
  refine ( _ @[ (h @> r_fg <@ i o h) @ (h @> s_hi) <@ f ] _ ) .
  +
   exact (wiskerR_pw_fn_pp (h @> r_fg <@ i o h) (h @> s_hi) f)^ .
  +
   refine (wiskerR_pw_fn_p _ f) .
   refine ( _ @[ (h @> (r_fg <@ i o h)) @ (h @> s_hi) ] _ ).
   *
    refine (wiskerR_pw_pw _ (h @> s_hi)) .
    exact (wiskerLR_pw_fn_comm h r_fg (i o h)) .
   *
    exact (wiskerL_pw_fn_pp h (r_fg <@ i o h) s_hi)^ .
 -
  refine (wiskerR_pw_fn_p _ f) .
  refine (wiskerL_pw_fn_p h _) .
  exact (concat_pw_wLpp r_fg s_hi)^ .
 -
  refine ( _ @[ (h @> f o g @> s_hi) @ (h @> r_fg) <@ f ] _ ) .
  +
   refine (wiskerR_pw_fn_p _ f) .
   exact (wiskerL_pw_fn_pp h (f o g @> s_hi) r_fg) .
  +
   exact (wiskerR_pw_fn_pp (h @> f o g @> s_hi) (h @> r_fg) f) .
 -
  refine (concat_pw_pw _ _) .
  +
   refine ( _ @[ h @> f @> g @> s_hi <@ f ] _ ).
   *
    refine (wiskerR_pw_fn_p _ f) .
    refine (wiskerL_pw_fn_p h _) .
    exact (wiskerL_pw_fn_ff f g s_hi) .
   *
    refine ( _ @[ h o f @> g @> s_hi <@ f ] _ ) .
    --
     refine (wiskerR_pw_fn_p _ f) .
     exact (wiskerL_pw_fn_ff h f (g @> s_hi))^ .
    --
     exact (wiskerLR_pw_fn_comm (h o f) (g @> s_hi) f) .
  +
   refine ( _ @[ h @> (r_fg <@ f) ] _ ) .
   *
    exact (wiskerLR_pw_fn_comm h r_fg f) .
   *
    refine ( _ @[ h @> f @> s_fg ] _ ) .
    --
     refine (wiskerL_pw_fn_p h _) .
     exact fg .
    --
     exact (wiskerL_pw_fn_ff h f s_fg)^ .
 -
  exact (wiskerL_pw_fn_pp (h o f) (g @> s_hi <@ f) s_fg)^ .
Defined.

Lemma is_equiv_rel_compose
  {A B C : Type} {f : A -> B} {g : B -> A} {h : B -> C} {i : C -> B}
  (fg : is_equiv_rel f g) (hi : is_equiv_rel h i)
  : is_equiv_rel (h o f) (g o i) .
Proof.
 revert fg hi .
 refine (dsum_elim_nodep _) .
 refine (fun r_fg => _) .
 refine (dsum_elim_nodep _) .
 refine (fun s_fg fg => _) .
 refine (dsum_elim_nodep _) .
 refine (fun r_hi => _) .
 refine (dsum_elim_nodep _) .
 refine (fun s_hi hi => _) .
 refine (dpair (retr_compose r_fg r_hi) _) .
 refine (dpair (sect_compose s_fg s_hi) _) .
 exact (is_adj_compose r_fg s_fg r_hi s_hi fg hi) .
Defined.

(** [f] と [h] が等価射であるならば、それを合成した [h o f] も等価射である。 *)
Definition is_equiv_compose
  {A B C : Type} {f : A -> B} {h : B -> C}
  (f_iv : is_equiv f) (h_iv : is_equiv h)
  : is_equiv (h o f) .
Proof.
 revert f_iv h_iv .
 refine (dsum_elim_nodep _) .
 refine (fun g fg => _) .
 refine (dsum_elim_nodep _) .
 refine (fun i hi => _) .
 refine (dpair (g o i) _) .
 exact (is_equiv_rel_compose fg hi) .
Defined.

(** [equiv] の合成。 *)
Definition equiv_compose
  {A B C : Type}
  (AB : equiv A B) (BC : equiv B C)
  : equiv A C .
Proof.
 revert AB BC .
 refine (dsum_elim_nodep _) .
 refine (fun f f_iv => _) .
 refine (dsum_elim_nodep _) .
 refine (fun h h_iv => _) .
 refine (dpair (h o f) _) .
 exact (is_equiv_compose f_iv h_iv) .
Defined.

(** ** Homotopic

    [h : f == g] を通して [is_equiv f] から [is_equiv g] を得る。 *)

Lemma retr_homotopic
  {A B : Type} {f : A -> B} {g : A -> B} {h : B -> A}
  (r : retraction f h) (homo : f == g)
  : retraction g h .
Proof.
 unfold retraction; unfold retraction in r .
 refine ( _ @[ f o h ] _ ) .
 -
  exact (wiskerR_pw_fn homo^ h) .
 -
  exact r .
Defined.

Lemma sect_homotopic
  {A B : Type} {f : A -> B} {g : A -> B} {h : B -> A}
  (s : section f h) (homo : f == g)
  : section g h .
Proof.
 unfold section; unfold section in s .
 refine ( _ @[ h o f ] _ ) .
 -
  exact (wiskerL_pw_fn h homo^) .
 -
  exact s .
Defined.

Definition idpath_pw' := @idpath_pw .

Arguments idpath_pw' [_ _] _ .

Lemma is_adj_homotopic
  {A B : Type} {f : A -> B} {g : A -> B} {h : B -> A}
  (r : retraction f h) (s : section f h)
  (a : is_adjoint r s) (homo : f == g)
  : is_adjoint (retr_homotopic r homo) (sect_homotopic s homo) .
Proof.
 unfold is_adjoint ; unfold is_adjoint in a .
 unfold retraction in r .
 unfold section in s .
 unfold retr_homotopic, sect_homotopic .
 refine (
     (* (homo^ <@ h) @ r <@ g *)
   _
     @[ (homo^ @@ (1 : h == h)) @ (r @@ (1 : g == g)) ]
   _
     @[ (homo^ @@ (1 : h == h) @ r) @@ (homo^ @ (1 : f == f) @ homo) ]
   _
     @[ ((homo^ @@ (1 : h == h)) @@ homo^) @ ((1 : f == f) @@ r) @ homo ]
   _
     @[ ((homo^ @@ (1 : h == h)) @@ homo^) @ (f @> r) @ homo ]
   _
     @[ (homo^ @@ ((1 : h == h) @@ homo^)) @ (s <@ f) @ homo ]
   _
     @[ (homo^ @@ ((1 : h == h) @@ homo^)) @ (s @@ (1 : f == f)) @ homo ]
   _
     @[ (homo^ @ (1 : f == f) @ homo) @@ (((1 : h == h) @@ homo^) @ s) ]
   _
     @[ idpath_pw' (idpath_pw' g) @@ ((idpath_pw' homo^) @@ (idpath_pw' (idpath_pw' h)) @ s) ]
   _
     (* g @> (h @> homo^) @ s *)
   ) .
Admitted.

(** 参考文献:

    * https://github.com/HoTT/HoTT/blob/1940297dd121d54d033274d84c5d023fdc56bfb4/theories/Basics/Equivalences.v

    *)


(* Definition of Machines (Processes), and their evaluation.  *)
Require Import Merges.Tactics.
Require Import Merges.Map.

Require Import Coq.Lists.List.
Import ListNotations.
Set Implicit Arguments.
Require Import Coq.Logic.FunctionalExtensionality.

Module Base.
Section Machine.
  Variable Label : Set.

  Definition Value := nat.

  Variable ChanV : Set.
  Variable ChanVEqDec : EqDec ChanV.

  Variable ScalarV : Set.
  Variable ScalarVEqDec : EqDec ScalarV.

  Definition StreamHeap := Map ChanV (list Value).
  Definition ScalarHeap := Map ScalarV Value.
  Definition Pred := StreamHeap -> ScalarHeap -> Prop.

  Let streamUpdate := Map.update ChanV (list Value) ChanVEqDec.
  Let scalarUpdate := Map.update ScalarV Value ScalarVEqDec.

  Inductive StreamTypeT :=
   | Input | Output | Ignore.
  Variable StreamType : ChanV -> StreamTypeT.

  Inductive Block : Type :=
   (* Blocking pull, wait forever until we get something *)
   | BlockPull : ScalarV -> ChanV -> Label -> Block
   (* Release the thing we just pulled.
      When two machines are pulling from same thing, this
      signals to other machine that it can now pull if it wants *)
   | BlockRelease : ChanV -> Label -> Block

   (* Push a value *)
   | BlockPush : ChanV -> (ScalarHeap -> Value) -> Label -> Block

   (* Update a variable *)
   | BlockUpdate : ScalarV -> (ScalarHeap -> Value) -> Label -> Block

   (* If non-zero *)
   | BlockIf : (ScalarHeap -> Value) -> Label -> Label -> Block

   (* Jump to another label without doing anything *)
   | BlockJump   : Label -> Block
   .

  Variable Blocks : Label -> Block.
  Variable LabelPre  : Label -> Pred.

  Inductive EvalB : StreamHeap -> ScalarHeap -> Label
                 -> StreamHeap -> ScalarHeap -> Label -> Prop :=
   | EvalBPullOk l v c lok i h sh
      : Blocks l = BlockPull v c lok
     -> StreamType c = Input
     -> EvalB h sh l
              (streamUpdate c (i :: h c) h) (scalarUpdate v i sh) lok

   (* Release does nothing *)
   | EvalBRelease l v l' h sh
      : Blocks l = BlockRelease v l'
     -> StreamType v = Input
     -> EvalB h sh l
              h sh l'

   | EvalBPush l v push l' h sh
      : Blocks l = BlockPush v push l'
     -> StreamType v = Output
     -> EvalB h sh l
              (streamUpdate v (push sh :: h v) h) sh l'

   | EvalBUpdate l v f l' h sh
      : Blocks l = BlockUpdate v f l'
     -> EvalB h sh l
              h (scalarUpdate v (f sh) sh) l'

   | EvalBIfZ l f lz lnz h sh
      : Blocks l = BlockIf f lz lnz
     -> f sh = 0
     -> EvalB h sh l
              h sh lz

   | EvalBIfS l f lz lnz h sh n
      : Blocks l = BlockIf f lz lnz
     -> f sh = S n
     -> EvalB h sh l
              h sh lnz

   | EvalBJump l l' h sh
      : Blocks l = BlockJump l'
     -> EvalB h sh l
              h sh l'

   | EvalBIgnore l v i h sh
      : StreamType v = Ignore
     -> EvalB h sh l
              (streamUpdate v (i :: h v) h) sh l
   .
  Hint Constructors EvalB.

  Variable Init : Label.
  Variable InitPre : LabelPre Init (fun _ => []) (fun _ => 0).

  Inductive EvalBs : StreamHeap -> ScalarHeap -> Label -> Prop :=
   | EvalBs0
      : EvalBs (fun _ => []) (fun _ => 0) Init
   | EvalBs1 l l' h h' sh sh'
      : EvalBs h sh l
     -> EvalB  h sh l h' sh' l'
     -> EvalBs h' sh' l'
   .
  Hint Constructors EvalBs.

  Definition BlocksPreT :=
    forall h h' sh sh' l l',
    LabelPre l h sh ->
    EvalB  h sh l h' sh' l' ->
    LabelPre l' h' sh'.

  Hypothesis BlocksPre: BlocksPreT.

  Theorem EvalBs_Hoare l h sh
   (hEvB : EvalBs h sh l)
         : LabelPre l h sh.
  Proof.
   !induction hEvB.
  Qed.
End Machine.

End Base.

Module Program.
 Module B := Base.

 Record Program (Label : Set) (ChanVar : Set) (ScalarVar : Set) : Type
  := mkProgram
   { Init     : Label
   ; Blocks   : Label -> B.Block Label ChanVar ScalarVar

   ; ChanVarEqDec : EqDec ChanVar
   ; ScalarVarEqDec : EqDec ScalarVar
   ; StreamType : ChanVar -> B.StreamTypeT

   ; LabelPre : Label -> B.Pred ChanVar ScalarVar
   ; BlocksPre: B.BlocksPreT ChanVarEqDec ScalarVarEqDec StreamType Blocks LabelPre
   ; InitPre  : LabelPre Init (fun _ => []) (fun _ => 0)
   }.

  Definition EvalBs (Label : Set) (ChanVar : Set) (ScalarVar : Set) (P : Program Label ChanVar ScalarVar)
   := B.EvalBs (ChanVarEqDec P) (ScalarVarEqDec P) (StreamType P) (Blocks P) (Init P).
End Program.


Require Import eqtype seq path ssrfun.
Require Import Commons Tree OtDef ListTools Comp SortedTree.
Import Bool.

Section FilesystemOT.

Parameter T : eqType.
Parameter R : rel T.
Parameter Rord : order R.

Inductive raw_fs_cmd :=
 | RawEdit   of T & T
 | RawCreate of tree T
 | RawRemove of tree T
 | RawOpen   of T & raw_fs_cmd.

Fixpoint raw_fs_inv (cmd : raw_fs_cmd) :=
  match cmd with
  | RawOpen l c => RawOpen l (raw_fs_inv c)
  | RawEdit l k => RawEdit k l
  | RawCreate t => RawRemove t
  | RawRemove t => RawCreate t
  end.

Fixpoint eq_cmd (t1 t2 : raw_fs_cmd) : bool :=
match t1, t2 with
  | RawOpen l c, RawOpen l2 c2 => (l == l2) && (eq_cmd c c2)
  | RawEdit l k, RawEdit l2 k2 => (l == l2) && (k == k2)
  | RawCreate t, RawCreate t2 => (t == t2)
  | RawRemove t, RawRemove t2 => (t == t2)
  | _, _ => false end.

Lemma eq_cmdK: @Equality.axiom raw_fs_cmd eq_cmd.
elim => [l k | t | t | l c IH] [l2 k2| t2| t2| l2 c2] /=;
(try by constructor); repeat (case A0: (eq_op _ _) => /=; move: A0 => /eqP);
try constructor; subst => // A; try by case: A.
 + subst. case A0: (eq_cmd); move: A0 => /IH;
   constructor; subst => // A. by case: A. Qed.

Canonical cmd_eqMixin := EqMixin eq_cmdK.
Canonical cmd_eqType := Eval hnf in EqType raw_fs_cmd cmd_eqMixin.

Ltac correct_label A := let H := fresh "H" in
  move: (find_pred A) => H; rewrite /by_value /= in H; move: H => /eqP H; subst.
Ltac correct_interp_label A := let A' := fresh A in
 (assert (A':=A); move: A' => /interp_label_indep /= A'; move: A; rewrite ?A' => [] [] A; subst).

Section FsCmd.

Inductive fs_cmd :=
 | Edit   of T & T
 | Create (c : sorted_tree R)
 | Remove (c : sorted_tree R)
 | Open   of T & fs_cmd.

Fixpoint fs_to_raw_fs (c : fs_cmd) : raw_fs_cmd :=
 match c with
 | Edit l k => RawEdit l k
 | Create c => RawCreate (treeOf c)
 | Remove t => RawRemove (treeOf t)
 | Open l c => RawOpen l (fs_to_raw_fs c)
 end.

Fixpoint fs_inv (cmd : fs_cmd) :=
 match cmd with
 | Open l c => Open l (fs_inv c)
 | Edit l k => Edit k l
 | Create t => Remove t
 | Remove t => Create t
 end.

End FsCmd.

Section Interpretation.

Fixpoint raw_fs_interp (c : raw_fs_cmd) (t : tree T) : option (tree T) :=
 let (v, cs) := t in let without v := filter (negb \o @by_value T v) in
 match c with
 | RawCreate  tc  => [! negb (has (by_value (value tc)) cs) !] Node v (insert R tc cs)
 | RawRemove  tr  => find (by_value (value tr)) cs >>= fun tr' => [! tr == tr' !] Node v (without' (value tr) cs)
 | RawOpen vo co  => open R (fun t => raw_fs_interp co t) vo t
 | RawEdit ve ve' => find (by_value ve) cs >>= fun te  =>
                     let cs' := without' ve cs in
                     match te with | Node _ cste =>
                       [! negb (has (by_value ve') cs') !]
                       Node v (insert R (Node ve' cste) cs') end end.

Lemma interp_label_preserving c: label_preserving (raw_fs_interp c).
move: c => [s s0|t |t |s r] [vt ts] /=.
 + by case find => [[]|] //=; case: has.
 + by case has.
 + by case find => [?|] //=; case eq_op.
 + by case find => [?|] //=; case raw_fs_interp. Qed.

Lemma interp_label_indep v cs v' (op : raw_fs_cmd) t :
raw_fs_interp op (Node v cs) = Some t ->
raw_fs_interp op (Node v' cs) = Some (Node v' (children t)).
by case: op v v' cs t => [l l'|c |c |l op] v v' cs [vt cst] /=;
 [case: find => [[??]|] //=; case: has | case has |
  case find => [?|] //=; case eq_op | case: bind => a]; move => //= [] [] ? ->. Qed.

Corollary interp_some c t t': raw_fs_interp c t = Some t' -> value t = value t'.
move: (interp_label_preserving c t); rewrite /label_preserving.
by case: (raw_fs_interp _ _) => [a <- [] <-|]. Qed.

Lemma raw_fs_interp_sorted c (t t' : tree T): is_tree_sorted R t ->
      raw_fs_interp (fs_to_raw_fs c) t = Some t' -> is_tree_sorted R t'.
Ltac tc1 X := by (move: X => /= /andP []; try by rewrite -?sorted_compatibility).
elim: c t t' => [l k|t1 |t1 |l c IH] [v cs] [v' cs'] A0 /=; try rewrite /without' -lock.
 + case A1: find => [[v'' cs'']| //] /=; case A2: has => [] //= [] A3 <-.
   rewrite insert_all sorted_compatibility insert_sorted /=.
  * move: A1 => /(find_sorted R v) A1. assert (A0' := A0).
    move: A0 => /A1 /= /andP [] -> ->. rewrite ?andb_true_r.
    apply all_filter. tc1 A0'. apply Rord.
  * apply sorted_filter. by expand_order (treeR_order _ Rord). tc1 A0.
 + move: t1 => [t1 H0]. case A1: has => //= [] [] ? <-.
   rewrite insert_all H0 sorted_compatibility insert_sorted.
   by move: A0 => /= /andP [] ? ->. apply Rord. tc1 A0.
 + case A1: find => [] //=; case A2: eq_op => [] //= [] ? <-.
   apply /andP. split.
   + rewrite sorted_compatibility. apply sorted_filter. by expand_order (treeR_order _ Rord). tc1 A0.
   + apply all_filter. tc1 A0.
 + case A1: find => [a|] //=. case A2: raw_fs_interp => [a'|] //= [] ? <-. assert (A0' := A0).
   move: A1 => /find_sorted A1. move: A0 => /(A1 R v) A0. move: A2 => /(IH _ _ A0) A2.
   rewrite sorted_compatibility insert_sorted /= ?insert_all ?A2 ?andb_true_r.
  * apply all_without. tc1 A0'. apply Rord.
  * apply without_sorted. apply Rord. tc1 A0'. Qed.

Corollary raw_fs_interp_sorted_all c t t':
 is_tree_sorted R t -> exec_all (raw_fs_interp \o fs_to_raw_fs) (Some t) c = Some t' -> is_tree_sorted R t'.
elim: c t => [|a c IH] t //=.
 + by move => A0 [] <-.
 + move => A0. rewrite /bind /flip. case A1: (raw_fs_interp (fs_to_raw_fs a) t) => [b|].
  + apply (IH b (raw_fs_interp_sorted _ _ _ A0 A1)).
  + by rewrite exec_all_none. Qed.

(* Inversion property IP1 *)
Theorem ip1 c x y: is_tree_sorted R x -> raw_fs_interp c x = Some y -> raw_fs_interp (raw_fs_inv c) y = Some x.
 elim: c x y=> [ s c | t | t | s c IH] [l0 cs0] [l cs] S; assert (S' := S); move: S' => /= /andP [] S0 S1; rewrite sorted_compatibility in S0.
 + case A0: find => [[v1 cs1]|] /=; case A1: has => [] //= [] <- <- {l} /=.
   rewrite /without' -lock in A1. sop_simpl => /=. correct_label A0. rewrite insert_same //. apply Rord.
 + case A0: has => [] //= [] <- <- {l} /=. by sop_simpl.
 + case A0: find => [[v1 cs1]|] //=. case A1: eq_op => //= [] [] <- <- {l}. move: A1 => /eqP A1; subst.
   sop_simpl => /=. rewrite insert_same //. apply Rord.
 + rewrite /bind /=. case A0: find => [[v1 cs1]|] //=. correct_label A0.
   case A1: raw_fs_interp => [[v2 cs2]|] // [] <- <- {l}. move: (IH _ _ (find_sorted R _ _ _ _ S A0) A1) => A1'.
   correct_interp_label A1'. sop_simpl. rewrite A1'0. rewrite insert_same //. apply Rord. Qed.

Lemma ip1_e v v' t mv mcs: sorted (treeR R) mcs ->
find (by_value v) mcs = Some t -> has (by_value v') (without v mcs) = false ->
(exec_all raw_fs_interp) (Some ((Node mv mcs))) ([:: RawEdit v v'; RawEdit v' v]) = Some (Node mv mcs).
move: t => [v1 cs1] S A0 A1 /=; rewrite /bind /flip /= A0 /without' -lock A1 /=. correct_label A0. sop_simpl.
rewrite /= insert_same //. apply Rord. Qed.

End Interpretation.

Section InsFs.

Inductive ins_cmd :=
 | Ins of T
 | IOpen of T & ins_cmd.

Fixpoint ins_fs (cmd : ins_cmd) :=
 match cmd with
  | Ins t => RawCreate (Node t [::])
  | IOpen t c => RawOpen t (ins_fs c)
 end.

Fixpoint ins_fs' (cmd : ins_cmd) :=
 match cmd with
  | Ins t => Create (SNode R t)
  | IOpen t c => Open t (ins_fs' c)
 end.

Lemma ins_fs_inj: injective ins_fs.
by elim => [t1|t1 c1 IH] [t2|t2 c2] //= [] -> // /IH ->. Qed.

Fixpoint eq_ins (t1 t2 : ins_cmd) : bool :=
match t1, t2 with
  | IOpen l c, IOpen l2 c2 => (l == l2) && (eq_ins c c2)
  | Ins t1, Ins t2 => t1 == t2
  | _, _ => false
end.

Lemma eq_insK: @Equality.axiom ins_cmd eq_ins.
elim => [t | l c IH] [t2| l2 c2] /=;
(try by constructor); repeat (case A0: (eq_op _ _) => /=; move: A0 => /eqP);
try constructor; subst => // A; try by case: A.
 + subst. case A0: (eq_ins); move: A0 => /IH;
   constructor; subst => // A. by case: A. Qed.

Canonical ins_eqMixin := EqMixin eq_insK.
Canonical ins_cmd_eqType := Eval hnf in EqType ins_cmd ins_eqMixin.

Fixpoint subdiv (t : tree T) : seq (raw_fs_cmd) :=
match t with Node v cs => RawCreate (Node v [::]) :: (map (fun y => RawOpen v y) (flatten (map subdiv cs))) end.

Fixpoint subdiv' (t : tree T) : seq (ins_cmd) :=
match t with Node v cs => Ins v :: (map (fun y => IOpen v y) (flatten (map subdiv' cs))) end.

Lemma sd_step1 t v1 v2:
 exec_all raw_fs_interp t [:: RawCreate v1; RawCreate v2] =
 exec_all raw_fs_interp t [:: RawCreate v2; RawCreate v1].
 rewrite /= /flip /=. case: t => [[t ts]|] //=.
 case A0: (has (by_value (value v1)) ts); case A1: (has (by_value (value v2)) ts) => //=;
 rewrite ?has_insert ?A0 ?A1 //= /by_value /= eq_sym insert_insert //. apply Rord. Qed.

Corollary sd_commutes t v vs:
  exec_all raw_fs_interp t (map (fun t => RawCreate t) (v :: vs)) =
  exec_all raw_fs_interp t (map (fun t => RawCreate t) (rcons vs v)).

 elim: vs v t => [|v0 vs IH] v t //. rewrite 2!map_cons 2!exec_all_ind.
 move: (sd_step1 t v0 v) => A1; rewrite /= /flip in A1.
 rewrite -A1. remember (bind (raw_fs_interp (RawCreate v0)) t) as l1.
 move: (IH v l1) => A2; rewrite /= /flip in A2. by rewrite A2 Heql1 rcons_cons. Qed.

Local Notation insert_sorted := (insert_sorted R Rord).
Local Notation without_sorted := (without_sorted R Rord).

Lemma sd_open (cmds : seq raw_fs_cmd) vs cs v: sorted (treeR R) cs -> has (by_value v) cs ->
  exec_all raw_fs_interp (Some (Node vs cs)) ((map (fun c => RawOpen v c) cmds)) =
  open R ((flip (exec_all raw_fs_interp) cmds) \o (fun t => Some t)) v (Node vs cs).
elim: cmds vs cs => [|c cmds IH] /= vs cs A0.
 + move => /has_find [a A1]; rewrite A1 /= insert_same //. apply Rord.
 + move => A1. assert (A1':=A1). move: A1' => /has_find [[vx xs]] A2.
   rewrite /flip /= A2 /flip /bind /=.
   case A3: (raw_fs_interp c _) => [[av acs]|] /=; [| by rewrite ?exec_all_none].
   rewrite IH //; try (by apply insert_sorted, without_sorted);
   (move: A2 A3 => /find_pred; rewrite /by_value /= => /eqP -> /=);
   [|by move => /interp_some /= ->; rewrite has_insert /= eq_refl orb_true_r].
   rewrite /flip /bind => /interp_some /= ->. sop_simpl.
   case A2: (exec_all _ _) => [a|] //. Qed.

Lemma open_create v:
  (fun t => RawOpen v (RawCreate t)) =1 (fun c => RawOpen v c) \o (fun t => RawCreate t).
 by rewrite /eqfun /=. Qed.

Lemma create_many v xs: sorted (treeR R) xs ->
  exec_all raw_fs_interp (Some (Node v [::])) [seq RawCreate t | t <- xs] = Some (Node v xs).
elim: xs => [|x xs IH] // A0. rewrite /flip sd_commutes map_rcons exec_all_rcons_ind IH /=; try by move: A0 => /path_sorted.
assert (A0' := A0). move: A0' => /= /path_has -> /=. rewrite /insert g_insert_path //. apply treeR_order, Rord. apply Rord. Qed.

Lemma subdivision_step: forall t v xs, is_tree_sorted R (Node v xs) -> is_tree_sorted R t ->
  exec_all raw_fs_interp (Some t) ((RawCreate (Node v [::])) :: (map (fun t => RawOpen v (RawCreate t)) xs)) =
  raw_fs_interp (RawCreate (Node v xs)) t.
move => [vt tcs]; intros. rewrite (@eq_map _ _ _ _ (open_create v)) exec_all_ind map_comp.
move A0: (bind (raw_fs_interp (RawCreate (Node v [::]))) (Some (Node vt tcs))) => [[va csa]|] //=;
move: A0 => /=; case A0: (has _ _) => //=; [move => [] [] -> <-| by rewrite exec_all_none].
 + rewrite sd_open. rewrite /flip /= without_insert_i //. sop_simpl. rewrite /= create_many ?has_without //.
 + use_sortedness H.
 + use_sortedness H0. apply Rord.
 + by rewrite has_insert /by_value /= eq_refl orb_true_r. Qed.

Lemma insert_subdivision: forall c t, is_tree_sorted R t -> is_tree_sorted R c ->
  exec_all raw_fs_interp (Some t) (subdiv c) = raw_fs_interp (RawCreate c) t.
elim => [v|v cs IH] [vt ts] A0 A1.
 + by rewrite /= /flip /bind /=.
 + rewrite -subdivision_step //. simpl subdiv. rewrite ?exec_all_cons.
   move A2: (raw_fs_interp _ _) => [[a1 as1]|]; rewrite ?exec_all_none //.
   move: A2 => /=. case A2: has => [] //= [] ? <-.
   rewrite (@eq_map _ _ _ _ (open_create v)) map_comp ?sd_open;
    try (by rewrite insert_has_t // ?/by_value /= eq_refl);
    try (by rewrite insert_sorted //; move: A0 => /= /andP []; rewrite sorted_compatibility).

   rewrite /flip /= /bind /=. case A3: (find (by_value v) _) => [a|] //.
   assert (A3': is_tree_sorted R a).
   +  move: A3 => /=. by sop_simpl => [] [] <-.
   clear A3. elim: cs IH A0 A1 a A3' => [|c cs IHcs] IH A0 A1 a A3' //.
   rewrite ?map_cons /= /flip /bind.
   move: IH => [] A4 A5. rewrite exec_all_cat A4.
   move A6: (raw_fs_interp _ a) => [a'|].
   move: A5 => /IHcs A5. apply (A5 A0).

 * by move: A1 => /= /andP [] /path_sorted -> /andP [] ? ->.
 * move: A1 => /= /andP [] ? /andP [] A1 ?. case: a A6 A3' => [va csa] /=.
   case: (has _ _ ) => [] //=; try by rewrite exec_all_none. case => <-.
  * move => /andP [] A6 A7 /=. by rewrite sorted_compatibility insert_sorted ?andb_true_l ?insert_all ?A7 // -sorted_compatibility.
 * by rewrite ?exec_all_none.
 * done.
 * by move: A1 => /= /andP [] ? /andP []. Qed.

Fixpoint ins_it (x y : ins_cmd) (f : bool) : seq ins_cmd :=
 match x, y with
  | Ins t1, Ins t2 => if (t1 == t2) then [::] else [::Ins t1]
  | IOpen t1 c1, IOpen t2 c2 => if t1 == t2 then map (IOpen t1) (ins_it c1 c2 f) else [:: x]
  | _, _ => [::x]
 end.

Lemma ins_it1 i1 i2 f: ins_it i1 i2 f = if (i1 == i2) then [:: ] else [:: i1].
elim: i1 i2 => [t1|t1 c1 IH] [t2|t2 c2] //=. case A0: eq_op.
 + move: A0 (IH c2) => /eqP -> ->. rewrite /eq_op /= eq_refl. by case eq_ins.
 + by rewrite /eq_op /= A0. Qed.

Lemma subdiv_l1 l1 x2: uniq l1 ->
exists n, transform ins_it l1 [:: x2] n = Some ([:: x2] \ l1, l1 \ [:: x2]).

elim: l1 => [|x1 l1 IH] U. rewrite ?seqminus_nil seqminus_nil'. by exists 1.
move: U => /= /andP [] B0 B1.
move: (IH B1) => [] n A0. exists (n.+2). remember (n.+1) as n1. simpl. rewrite ?ins_it1 eq_sym.
move: B0. case A1: eq_op. move: A1 => /eqP -> /=.
rewrite Heqn1 2!TransformApp.tr_through_nil /= /in_mem /= eq_refl /= => B0. by rewrite seqminus_singleton.
rewrite Heqn1 => B0. apply tstab with (k:=1) in A0.
move: A0. rewrite addn1 => ->. by rewrite TransformApp.tr_through_nil /= /in_mem /= eq_sym A1 /= cats0. Qed.

Lemma subdiv_it l1 l2: uniq l1 -> uniq l2 ->
exists n, @transform ins_cmd ins_it l1 l2 n = Some (l2 \ l1, l1 \ l2).
elim: l2 l1 => [|x2 l2 IH] [|x1 l1] //=; rewrite ?seqminus_nil; try by exists 1.

move => B1 /andP [] B2 B2'.
move: B1 => /andP [] B1 B1'.
move: (IH (l1) B1' B2') => [n' A0'].
move: (subdiv_l1 l1 x2 B1') => [n01 A01].

assert (U: uniq (x1 :: l1 \ [:: x2])). rewrite /=. apply /andP. split.
 + by rewrite /seqminus mem_filter (negbTE B1) andb_false_r.
 + by apply uniq_setminus.
move: (IH (x1 :: l1 \ [:: x2]) U B2') => [n02 A02].
remember (n01 + n02) as n.

exists ((n'+n).+2). remember ((n'+n).+1) as n1. simpl. rewrite ?ins_it1 eq_sym.
case A1: eq_op => /=.
 + move: A1 B2 => /eqP <- B2. rewrite Heqn1 TransformApp.tr_through_nil -Heqn1 /=.
   apply tstab with (k:=n+1) in A0'. move: A0'. rewrite addnA addn1 Heqn1 => ->.
   by rewrite /in_mem /= eq_refl /= ?seqminus_cons.
 +  apply tstab with (k:=n02 + n' +1) in A01. move: A01.
    rewrite 2!addnA -Heqn addn1 addnC -Heqn1 => ->.
    apply tstab with (k:=n01 + n' +1) in A02. move: A02.
    rewrite ?addnA (addnC n02) -Heqn addn1 addnC -Heqn1 => ->.
    rewrite /in_mem /= eq_sym A1 /= /in_mem /=.
    case C0: (@pred_of_eq_seq ins_cmd_eqType l1 x2);
    case C1: (@pred_of_eq_seq ins_cmd_eqType l2 x1) => /=; rewrite ?seqminus_cat /=;
    (rewrite -(seqminus_cons' l1 [::x2] x1); [by rewrite seqminus_p1| by rewrite /in_mem /= A1]). Qed.

Lemma subdiv_prime x: subdiv x = map ins_fs (subdiv' x).
elim: x => [x|x xs IH] //=.
elim: xs IH => [|x' xs IH'] IH //=. rewrite ?map_cat /=.
move: IH => /= [] IH0 IH1. apply IH' in IH1. clear IH'.
move: IH1 IH0 => [] <- ->. rewrite -?map_comp.
assert (A0: [eta RawOpen x] \o ins_fs =1 ins_fs \o [eta IOpen x]).
 by move => ? /=. by rewrite (@eq_map _ _ _ _ A0). Qed.

End InsFs.

 Definition merge_trees (x y : tree T) : seq raw_fs_cmd := (subdiv x) \ (subdiv y).

  Fixpoint raw_fs_it (x y : raw_fs_cmd) (f : bool) : seq raw_fs_cmd :=
    let instead a b := [:: raw_fs_inv a; b] in
    match x, y with
    | RawEdit xl xk, RawEdit yl yk =>
        match xl == yl, xk == yk with
          | false, false => [:: x]
          | true, true => [::]
          | true, false => (if f then [::] else [:: RawEdit yk xk])
          | false, true => [:: RawEdit yk yl]
        end
    | RawEdit xl xk, RawCreate  yt => if xk == value yt then instead y x else [:: x]
    | RawCreate  xt, RawEdit yl yk => if value xt == yk then [::] else [:: x]
    | RawOpen xl xc, RawOpen yl yc => if xl == yl then map (RawOpen xl) (raw_fs_it xc yc f) else [:: x]
    | RawRemove xt, RawRemove yt =>   if value xt == value yt then [::] else [:: x]
    | RawRemove xt, RawOpen yl yc =>
       if value xt == yl
       then if raw_fs_interp yc xt is Some t then [:: RawRemove t] else [::]
       else [:: x]
    | RawOpen xl xc, RawRemove yt =>  if value yt == xl then [::] else [:: x]
    | RawOpen xl xc, RawEdit yl yk => if xl == yl then [:: RawOpen yk xc ] else [:: x]
    | RawEdit xl xk, RawRemove yt =>  if xl == value yt then [::] else [:: x]
    | RawRemove xt, RawEdit yl yk =>  if yl == value xt
                                      then [:: RawRemove (Node yk (children xt)) ] else [:: x]
    | RawCreate xt, RawCreate yt =>   if value xt == value yt then merge_trees xt yt else [:: x]
    | _, _ => [:: x]
    end.

Lemma ins_fs_comp i1 i2 f: raw_fs_it (ins_fs i1) (ins_fs i2) f = map ins_fs (ins_it i1 i2 f).
 elim: i1 i2 => [t1|t1 c1 IH] [t2|t2 c2] //=; case A0: eq_op => //=.
 + move: A0 => /eqP ->. by rewrite /merge_trees /= /in_mem /= eq_refl.
 + rewrite IH -?map_comp. apply eq_map. by rewrite /eqfun. Qed.

Section PropertyC1.

Definition C1' (op1 op2 : raw_fs_cmd) := forall (f : bool) m (m1 m2 : tree T), is_tree_sorted R m ->
  raw_fs_interp op1 m = Some m1 -> raw_fs_interp op2 m = Some m2 ->
  let m21 := (exec_all raw_fs_interp) (Some m2) (raw_fs_it op1 op2 f) in
   let m12 := (exec_all raw_fs_interp) (Some m1) (raw_fs_it op2 op1 (~~f)) in
    m21 = m12 /\ exists node, m21 = Some node.

Lemma c1_r_r t s: C1' (RawRemove t) (RawRemove s).
move => f [v cs] [v' cs'] [v'' cs''] ?.
case A0: (eq_op (value s) (value t)); move: A0; [move => /eqP| move => A0].
 + simpl => ->. rewrite eq_refl. case A1: find => [a| //] /=.
   repeat (case: eq_op => //=). move => <- <-. by split; eauto.
 + simpl raw_fs_it. rewrite eq_sym A0 /= /flip /bind /=.
   case A1: find => [tr'|]; case A2: find => [tr''|] //=;
   case A3: eq_op; case A4: eq_op => //=. SearchAbout filter find.
   repeat (case => -> <-). rewrite /without' -lock ?find_filter ?A1 ?A2 /= ?A3 ?A4 /=;
     [|apply by_diff_values; rewrite eq_sym| apply by_diff_values] => //.
   rewrite without_without. eauto. Qed.

Lemma c1_c_r tc tr: C1' (RawCreate tc) (RawRemove tr).
move => f [v cs] [v' cs'] [v'' cs''] S /=.
case A0: has => //= [] [] <- <-. case A1: find => [a|] //=. case A2: eq_op => //=.
move: A2 => /eqP -> [] <- <-. rewrite /flip /bind /=.
move: (find_pred A1); rewrite {1}/by_value /= => /eqP <-.
case A2: (eq_op (value tc) (value tr)).
 + move: A2 A0 => /eqP ->. move /find_absent. by rewrite A1.
 + rewrite /without' -lock has_filter ?A0 /=; [|by (apply by_diff_values; rewrite eq_sym)].
   sop_simpl. rewrite A1 /= eq_refl /= -without_insert; [ eauto | by apply Rord | by use_sortedness S | by rewrite A2]. Qed.

Lemma c1_c_e tc ve ve': C1' (RawCreate tc) (RawEdit ve ve').
move => f [v cs] [v' cs'] [v'' cs''] S /=. rewrite /without' -lock.
case A0: has => //= [] [] <- <-. case A1: find => [[av acs]|] //=. case A2: has => [] //= [] <- <-.
rewrite eq_sym. case A3: (ve' == value tc) => /=; rewrite /flip /bind /=.
 + move: A3 A2 => /eqP -> A2. sop_simpl. rewrite A1 /= A2 /=. eauto.
 +  assert (H0: (value tc) == ve = false).
      by (case H1: eq_op => //; move: H1 A1 A0 => /eqP <- /find_has ->).
    rewrite has_insert {2}/by_value /= eq_sym A3 orb_false_r; sop_simpl.
    rewrite A0 /= A1 /= -without_insert; try by apply Rord.
    + rewrite has_insert /by_value /= A3 orb_false_r A2 /= insert_insert.
     + rewrite eq_sym A3 /=. eauto.
     + apply Rord.
    + use_sortedness S.
    + by rewrite H0. Qed.

Lemma c1_r_e tr ve ve': C1' (RawRemove tr) (RawEdit ve ve').
move => f [v cs] [v' cs'] [v'' cs''] /= S. rewrite /without' -lock.
case A0: find => //= [a]. case A1: eq_op => //=. move: A1 A0 => /eqP <- A0 {a} [] <- <-.
case A1: find => //= [[va csa]]. case A2: has => //= [] [] <- <-. assert (A1':=A1).
move: A1' A1 => /find_by_value <- A1. case A3: eq_op => //=; rewrite /flip /bind /=.
 + sop_simpl. move: A3 A1 A2 => /eqP -> /=. rewrite A0 => [] [] -> /= A2. sop_simpl. eauto.
 + assert (H0: (value tr == ve') = false).
    (case H1: eq_op => //; move: H1 A0 A2 => /eqP <- /find_has; sop_simpl => -> //).
   sop_simpl. rewrite A0 /= eq_refl /=.
   rewrite A1 /= without_without. sop_simpl.
   rewrite A2 /= -without_insert /=; [ eauto | | use_sortedness S | rewrite eq_sym H0 //]; apply Rord. Qed.

Lemma c1_e_e ve ve' vf vf': C1' (RawEdit vf vf') (RawEdit ve ve').
move => f [v cs] [v' cs'] [v'' cs''] /= S. rewrite /without' -lock.
assert (H: sorted (T:=tree_eqType T) (treeR R) cs) by use_sortedness S.
case A0: find => //= [[fa fcs]]. case A1: has => //= [] [] <- <-.
case A0': find => //= [[ea ecs]]. case A1': has => //= [] [] <- <-.
rewrite eq_sym. case A2: eq_op => /=; rewrite eq_sym; case A2': eq_op => /=.
 + move: A2 A2' => /eqP A2 /eqP A2'; subst. by move: A0 A0' => -> [] ? <-; eauto.
 + move: A2 => /eqP A2; subst; case f; rewrite /= /bind /flip /=; sop_simpl;
   rewrite ?A1' ?A1 /=; by move: A0 A0' => -> [] ? ->; eauto.
 + move: (ip1_e vf vf' _ v _ H A0 A1). move: (ip1_e ve ve' _ v _ H A0' A1').
   by rewrite /= {2 4}/flip {2 4}/bind /= A0 A0' /= /without' -lock A1 A1' /= => -> ->; eauto.
 + rewrite /= /bind /flip /= /without' -lock .
   case A3: (vf == ve').
   * move: A3 => /eqP A3. by assert False; by move: A0 A1' => /find_has; sop_simpl => ->.
   * case A4: (ve == vf').
    * move: A4 => /eqP A4. subst. rewrite without_has' // in A1. apply find_has in A0'. by rewrite A0' in A1. by rewrite eq_sym A2.
    * sop_simpl; rewrite A0 A0' /=. rewrite -?without_insert /=;
        try (by rewrite eq_sym ?A3 ?A4); try apply without_sorted => //; try by apply Rord.
      rewrite ?insert_has_f /=; try rewrite /by_value //= eq_sym //.
      rewrite (without_without vf); sop_simpl; rewrite A1.
      rewrite (without_without ve); sop_simpl; rewrite A1' /=.
      rewrite insert_insert; eauto. apply Rord. Qed.

Lemma c1_o_e vc vc' vo op1: C1' (RawOpen vo op1) (RawEdit vc vc').
move => f [v cs] [v' cs'] [v'' cs''] /= S. rewrite /without' -lock.
case A0: bind => [a|] // [] <- <-. case A1: find => [[bv bcs]|] //=.
move: (find_pred A1); rewrite {1}/by_value /= => /eqP H0; subst.
case A2: has => //= [] [] <- <-. case A3: eq_op => /=.
 + move: A3 => /eqP A3. subst. rewrite /flip /bind /=. sop_simpl;
   destruct a as [va csa]. rewrite A1 /= in A0. correct_interp_label A0.
   sop_simpl; rewrite A2 /=. eauto.
 + rewrite /flip /bind /=. case A4: (vc' == vo).
  * move: A4 => /eqP A4. subst. move: A2 A0.
    rewrite eq_sym in A3. by rewrite without_has' // => /find_absent ->.
  * rewrite find_insert_f //; [|by rewrite /by_value /= eq_sym A4].
    sop_simpl; rewrite A0.
    case: a A0 => [va csa]. case A5: find => [[vc ccs]|] //=.
    correct_label A5 => A0. assert (A0' := A0).
    move: A0' => /interp_label_indep /= A0'. move: A0. rewrite ?A0' => [] [] A0.
    sop_simpl; rewrite A1.
    rewrite -(without_insert Rord _ bv) /=; [| by use_sortedness S; apply Rord| by rewrite A3].
    rewrite without_without. rewrite insert_has_f; [|by rewrite /by_value /= A4]. sop_simpl.
    rewrite A2 /=. rewrite -without_insert /=; [| |use_sortedness S | by rewrite A4]; try by apply Rord.
    rewrite insert_insert. eauto. apply Rord. Qed.

Lemma c1_o_r s vo op1: C1' (RawOpen vo op1) (RawRemove s).
move => f [v cs] [v' cs'] [v'' cs''] /= S. rewrite /without' -lock /=.
case A0: find => [[ev ecs]|] //=. correct_label A0.
case A1: raw_fs_interp => [[av acs]|] //= [] <- <-. correct_interp_label A1.
case A1: find => [[bv bcs]|] //=.
case A3: eq_op => [] //=; move: A3 A1 => /eqP -> /= A1 {s} [] <- <-.
 case A4: eq_op => [] /=.
 + move: A4 => /eqP A4; subst.
   move: A0. rewrite A1 => [] [] A3; subst.
   rewrite A2 /= /bind /flip /=. sop_simpl; eauto.
 + rewrite /flip /=. sop_simpl; rewrite A0 /= A2 A1 /= eq_refl -without_insert;
    [ rewrite without_without; eauto | | use_sortedness S | rewrite eq_sym A4 //]; apply Rord. Qed.

Lemma c1_o_c s vo op1: C1' (RawOpen vo op1) (RawCreate s).
move => f [v cs] [v' cs'] [v'' cs''] /= S.
case A0: find => [[av acs]|] //=. correct_label A0.
case A1: raw_fs_interp => [[bv bcs]|] //=. correct_interp_label A1 => [] [] <- <-.
case A1: has => [] //= [] <- <-. rewrite /flip /= /bind /=.
case A3: ((value s) == bv).
 + by move: A3 A0 A1=> /eqP <- /find_has ->.
 + rewrite find_insert_f; [| by rewrite /by_value /= eq_sym].
   rewrite A0 A2 insert_has_f;[| by rewrite /by_value /=]. sop_simpl;
   by rewrite /= A1 /= -without_insert;
    [ rewrite insert_insert; eauto | | use_sortedness S | rewrite /= A3 //]; apply Rord. Qed.

Lemma C1'_C c1 c2: C1' c1 c2 -> C1' c2 c1.
rewrite /C1'; intros. move: (H (~~f) m m2 m1 H0 H2 H1) => [] => ->.
rewrite negb_involutive; eauto. Qed.

Lemma c1_o_o op1 op2: C1' op1 op2 ->
  (forall l1 l2, C1' (RawOpen l1 op1) (RawOpen l2 op2)).

   move => IH; intros.
   rewrite /C1' => f [v cs] [v' cs'] [v'' cs''] S /=.
   rewrite eq_sym. case A3: eq_op.
  * move: A3 => /eqP A3; subst.
    move A0: (find (by_value l1) cs) => [[vf csf]|] //=.
    case A1: raw_fs_interp => [[va csa]|] //= [] [] <- <-.
    case A2: raw_fs_interp => [[vb csb]|] //= [] [] <- <-.
    move: (find_sorted R v _ _ _ S A0) => SF.
    move: (IH f (Node vf csf) _ _ SF A1 A2) => /= IH0.
    move: (find_pred A0) => H. rewrite /by_value /= in H. move: H A0 => /eqP -> A0.
    move: (interp_some _ _ _ A1) (interp_some _ _ _ A2) => /= H1 H2; subst; subst.
    rewrite ?sd_open; try (by rewrite insert_has_t // /by_value /= eq_refl);
                      try (by use_sortedness S; apply Rord).
    rewrite /flip /= /bind /=. sop_simpl;
    move: IH0 => [] -> [] x ->. eauto.

  * rewrite /bind /=.
    case A1: find => [[va csa]|] //=.
    case A2: find => [[vb csb]|] //=.
    case A4: raw_fs_interp => [[ve cse]|] //= [] [] <- <-.
    case A5: raw_fs_interp => [[vf csf]|] //= [] [] <- <-.
    move: (interp_some _ _ _ A4) (interp_some _ _ _ A5) => /= H1 H2; subst; subst.
    correct_label A1. correct_label A2.
    rewrite /= /flip /= /bind /=. sop_simpl; rewrite A1 A2 A4 A5.
    rewrite -(without_insert Rord _ ve) /=; [| by use_sortedness S; apply Rord |by rewrite A3].
    rewrite -(without_insert Rord _ vf) /=; [| by use_sortedness S; apply Rord |by rewrite eq_sym A3].
    rewrite insert_insert. rewrite without_without. eauto. apply Rord. Qed.

Ltac elem_case := first [apply c1_e_e | apply c1_c_e | apply c1_r_e | apply c1_o_e |
                         apply c1_o_r | apply c1_r_e | apply c1_r_r | apply c1_c_r |
                         apply c1_o_c | apply c1_o_o].
Ltac elem_or_sym := (try by elem_case); (try by apply C1'_C; elem_case).

Ltac ii := let A0 := fresh "A0" in let A1 := fresh "A1" in let A2 := fresh "A2" in
move => f [v cs] [v' cs'] [v'' cs''] S; simpl raw_fs_it; rewrite eq_sym; case A0: eq_op;
[rewrite -?insert_subdivision /merge_trees // => A1 A2; rewrite -A1 -A2 |
 simpl; case A1: has => //= [] [] <- <-; case A2: has => //= [] [] <- <-;
  rewrite /flip /=; rewrite ?insert_has_f /=; (try by rewrite /by_value /= ?A0 // eq_sym ?A0);
  rewrite A1 A2 /= insert_insert; eauto].

Lemma c1_ins op1 op2: C1' (ins_fs op1) (ins_fs op2).
elim: op1 op2 => [t1|t1 c1 IH] [t2|t2 c2] /=; elem_or_sym.
 + ii. rewrite -?exec_all_cat. move: A0 A1 => /eqP ->; rewrite /= /in_mem /= eq_refl /= => /= ->. eauto. apply Rord. Qed.

Definition ins_interp (c : ins_cmd) (t : sorted_tree R) : option (tree T) := raw_fs_interp (fs_to_raw_fs (ins_fs' c)) (treeOf t).

Definition sorted_option (x : option (tree T)) := match x with None => true | Some t => is_tree_sorted R t end.

Lemma so_from_sorted (c : fs_cmd) t: is_tree_sorted R t -> sorted_option (raw_fs_interp (fs_to_raw_fs c) t).
case A0: (raw_fs_interp (fs_to_raw_fs c) t) => [t'|] A1 //=. exact (raw_fs_interp_sorted _ _ _ A1 A0). Qed.

Definition so_st (t : option (tree T)): sorted_option t -> option (sorted_tree R).
case: t => [t|] /= A0. exact (Some (STree R t A0)). exact None. Defined.

Lemma fmap_so_st t S: (fmap treeOf) (so_st t S) = t.
 rewrite /so_st. by dependent destruction t. Qed.

Definition ins_sorted (c : ins_cmd) (t : sorted_tree R) : option (sorted_tree R).
move: t => [t S]. apply (so_st (raw_fs_interp (fs_to_raw_fs (ins_fs' c)) t)), so_from_sorted, S. Defined.

Lemma ins_sorted_treeOf c (s : sorted_tree R):
 (fmap treeOf) (ins_sorted c s) = ins_interp c s.
rewrite /ins_sorted. case: s => [t S] /=. by rewrite fmap_so_st /ins_interp. Qed.

Lemma ins_compat x: fs_to_raw_fs (ins_fs' x) = ins_fs x.
elim: x => [t|t c IH] //=. by rewrite IH. Qed.

Corollary ins_compat': fs_to_raw_fs \o ins_fs' =1 ins_fs. apply /ins_compat. Qed.

Lemma exec_ins_compat: forall c s, (fmap treeOf) (exec_all ins_sorted (Some s) c) =
  exec_all (raw_fs_interp \o ins_fs) (Some (treeOf s)) c.
apply (@last_ind ins_cmd (fun c =>
 forall s, fmap treeOf (exec_all ins_sorted (Some s) c) = exec_all (raw_fs_interp \o ins_fs) (Some (treeOf s)) c)).
 + done.
 + intros s x IH s'. rewrite 2!exec_all_rcons_ind /= /bind /flip -IH.
   case A0: exec_all => [b|] //=. by rewrite ins_sorted_treeOf /ins_interp ins_compat. Qed.

Lemma ins_fs_fs'_compat m c:
exec_all (raw_fs_interp \o fs_to_raw_fs) m (map ins_fs' c) = exec_all (raw_fs_interp \o ins_fs) m c.
case: m => [m|].
 + by rewrite (exec_all_compat _ ins_fs') (exec_all_eqfun (compA _ _ _)) (exec_all_eqfun (eq_comp (frefl _) ins_compat')).
 + by rewrite ?exec_all_none. Qed.

Instance insOT': (OTBase (sorted_tree R) ins_cmd) := {interp := ins_sorted; it := ins_it}.
intros. rewrite /m21 /m12 => {m12} {m21}.
case: m m1 m2 H H0 => [m S] [m1 S1] [m2 S2].

 move /opt_eq => H. rewrite ins_sorted_treeOf /= in H.
 move /opt_eq => H0. rewrite ins_sorted_treeOf /= in H0.

move: H H0. rewrite ?ins_sorted_treeOf /= /ins_interp /=? ins_compat => /= H H0.
move: (c1_ins op1 op2 f m m1 m2 S H H0) => [] A0 A1. split.
 + apply opt_eq. by rewrite ?exec_ins_compat /= -?(exec_all_compat raw_fs_interp ins_fs) -?ins_fs_comp A0.
 + move: A1 => [t]. rewrite ins_fs_comp exec_all_compat -ins_fs_fs'_compat => A1. assert (A1' := A1).
   move: A1 => /raw_fs_interp_sorted_all A1. exists (STree R t (A1 S2)) => /=. apply opt_eq.
   by rewrite /= -A1' exec_ins_compat ins_fs_fs'_compat /=. Defined.

Definition firstP (x : ins_cmd) := match x with | Ins t => t | IOpen t c => t end.

Lemma firstP_subdiv' c xs: c \in flatten [seq subdiv' i | i <- xs] -> firstP c \in map value xs.
elim: xs => [|x xs IH] //=. rewrite mem_cat. case A0: in_mem => /=.
 + move => ?. destruct x. move: A0 => /=. move: (flatten _) => f.
   destruct c => /=; rewrite /in_mem /=.
  + case A0: eq_op.
   + move: A0 => /eqP [] ->. by rewrite eq_refl.
   + by elim: f.
  + elim: f => //= f fs IHf. case A0: eq_op.
   + move: A0 => /eqP [] ->. by rewrite eq_refl.
   + by rewrite orb_false_l.
 + move => /IH. rewrite /in_mem /= => ->. by rewrite orb_true_r. Qed.

Lemma uniq_subdiv' {s}: is_tree_sorted R s -> uniq (subdiv' s).
expand_order Rord.
elim: s => [x|x xs IH] //= /andP [] /(sorted_uniq H2 H0) A0 A1.
apply /andP. split.
 + by elim: flatten.
 + assert (injective [eta IOpen x]). by move => ?? [].
   rewrite (map_inj_uniq H3).
   elim: xs A1 A0 IH => [|x' xs IH] //= /andP [] A0 A1 /andP [] A2 A3 [] A4 A5.
   move: (IH A1 A3 A5) => A6 {IH}. rewrite cat_uniq A6 andb_true_r (A4 A0) /=.
   apply /negP => /hasP /= [c A7 A8]. apply firstP_subdiv' in A7.
   move: (firstP_subdiv' c [::x']) => /=. rewrite cats0 => A9. apply A9 in A8. clear A9.
   by case: c A8 A7 => [v|v c] /=; rewrite {1}/in_mem /= orb_false_r => /eqP ->;
     rewrite (negbTE A2). Qed.

Lemma c1_c_c t s : is_tree_sorted R s -> is_tree_sorted R t -> C1' (RawCreate t) (RawCreate s).
move => S1 S2. ii. move: (subdiv_it _ _ (uniq_subdiv' S1) (uniq_subdiv' S2)) => [n B0].
move: A1 A2. rewrite ?subdiv_prime ?(exec_all_compat raw_fs_interp ins_fs) -?map_seq_minus; try by apply ins_fs_inj.
move => A1 A2. assert (B1 := A1). assert (B2 := A2).
rewrite -ins_fs_fs'_compat in A1. rewrite -ins_fs_fs'_compat in A2.
move: (raw_fs_interp_sorted_all _ _ _ S A1) => SA1.
move: (raw_fs_interp_sorted_all _ _ _ S A2) => SA2.

Ltac tc2 := apply opt_eq; rewrite /= exec_ins_compat /=; by rewrite -ins_fs_fs'_compat.

assert (H: exec_all ins_sorted (Some {| treeOf := Node v cs; stp := S |}) (subdiv' s) =
        Some {| treeOf := Node v'' cs''; stp := SA2 |}). by tc2.
assert (H2: exec_all ins_sorted (Some {| treeOf := Node v cs; stp := S |}) (subdiv' t) =
        Some {| treeOf := Node v' cs'; stp := SA1 |}). by tc2.

move: (ot_execution insOT' n (subdiv' s) (subdiv' t)
 (subdiv' s \ subdiv' t) (subdiv' t \ subdiv' s)
 (Some (STree R _ S)) (STree R _ SA2) (STree R _ SA1) (conj H H2) B0) => [] C1 C2.

by split; [move: C1 | move: C2 => [[m3t S3]] /= C2; exists m3t; move: C2]; move => /opt_eq /=;
rewrite ?exec_ins_compat /= -?A1 -?A2 ?ins_fs_fs'_compat ?(exec_all_compat _ ins_fs). apply Rord. Qed.

Theorem c1 (op1 op2 : fs_cmd): C1' (fs_to_raw_fs op1) (fs_to_raw_fs op2).

elim: op1 op2 => [l1 l1'|c1|c1|l1 op1 IH] [l2 l2'|c2|c2|l2 op2];
 (try by elem_case); (try by apply C1'_C; elem_case).

 + apply c1_c_c. destruct c2. apply stp. destruct c1. apply stp. Qed.

End PropertyC1.

Section Computability.

Fixpoint raw_fs_sz0 (x : raw_fs_cmd) :=
 match x with
 | RawOpen l c => raw_fs_sz0 c
 | RawEdit l c => 1
 | RawCreate t => weight t
 | RawRemove t => 1
 end.

Fixpoint raw_fs_si0 (x : raw_fs_cmd) :=
 match x with
 | RawOpen l c => raw_fs_si0 c
 | RawEdit l c => 0
 | RawCreate t => weight t
 | RawRemove t => 0
 end.

Lemma sz0_open y: raw_fs_sz0 =1 raw_fs_sz0 \o (RawOpen y). by rewrite /eqfun => [] []. Qed.
Lemma si0_open y: raw_fs_si0 =1 raw_fs_si0 \o (RawOpen y). by rewrite /eqfun; case. Qed.

Definition raw_fs_sz (x : seq raw_fs_cmd) := foldl addn 0 (map raw_fs_sz0 x).
Definition raw_fs_si (x : seq raw_fs_cmd) := foldl addn 0 (map raw_fs_si0 x).

Lemma fs_sz_cons x xs: raw_fs_sz (x :: xs) = raw_fs_sz0 x + raw_fs_sz xs.
by rewrite /raw_fs_sz /= add0n (fadd (raw_fs_sz0 x)). Qed.

Lemma fs_si_cons x xs: raw_fs_si (x :: xs) = raw_fs_si0 x + raw_fs_si xs.
by rewrite /raw_fs_si /= add0n (fadd (raw_fs_si0 x)). Qed.

Lemma fs_sz_cat xs1 xs2: raw_fs_sz (xs1 ++ xs2) = raw_fs_sz xs1 + raw_fs_sz xs2.
elim: xs1 xs2 => [|x xs1 IH] xs2 //=. by rewrite ?fs_sz_cons IH addnA. Qed.

Lemma fs_si_cat xs1 xs2: raw_fs_si (xs1 ++ xs2) = raw_fs_si xs1 + raw_fs_si xs2.
elim: xs1 xs2 => [|x xs1 IH] xs2 //=. by rewrite ?fs_si_cons IH addnA. Qed.

Corollary sz_open s l: raw_fs_sz [seq RawOpen s i | i <- l] = raw_fs_sz l.
case: l => [|l ls] //=. move Heqf: (RawOpen s) => f.
by rewrite  /raw_fs_sz /= -map_comp -Heqf (eq_map (sz0_open s)). Qed.

Corollary si_open s l: raw_fs_si [seq RawOpen s i | i <- l] = raw_fs_si l.
case: l => [|l ls] //=. move Heqf: (RawOpen s) => f.
by rewrite /raw_fs_si /= -map_comp -Heqf (eq_map (si0_open s)). Qed.

Lemma weight_subdiv t1: weight t1 = raw_fs_sz (subdiv t1).
elim: t1 => [] //= v cs. elim: cs => [|c cs IH2] [] // A0 A1. apply IH2 in A1.
 move: A1. rewrite map_cons /= map_cat ?fs_sz_cons fs_sz_cat ?sz_open -A0.
 rewrite (addnA _ (weight c)) (addnC _ (weight c)) -addnA => <-. by rewrite ?weight_Node ?weights_cons addnA. Qed.

Lemma weight_subdiv_si t1: weight t1 = raw_fs_si (subdiv t1).
elim: t1 => [] //= v cs. elim: cs => [|c cs IH2] [] // A0 A1. apply IH2 in A1.
 move: A1. rewrite map_cons /= map_cat ?fs_si_cons fs_si_cat ?si_open -A0.
 rewrite (addnA _ (weight c)) (addnC _ (weight c)) -addnA => <-. by rewrite ?weight_Node ?weights_cons addnA. Qed.

Lemma sz_weight t1 t2: raw_fs_sz (merge_trees t1 t2) <= weight t1.
 rewrite /merge_trees /raw_fs_sz. move: (sum_setminus raw_fs_sz0 (subdiv t1) (subdiv t2)).
 by rewrite weight_subdiv /raw_fs_sz. Qed.

Lemma si_weight t1 t2: raw_fs_si (merge_trees t1 t2) <= weight t1.
 rewrite /merge_trees /raw_fs_si. move: (sum_setminus raw_fs_si0 (subdiv t1) (subdiv t2)).
 by rewrite weight_subdiv_si /raw_fs_si. Qed.

Lemma weight_nonzero (t : tree T): weight t > 0. by case: t => t l; rewrite /weight /encode. Qed.

Theorem OT_C op1 op2: computability raw_fs_it raw_fs_sz raw_fs_si op1 op2.
  rewrite /computability.
  elim: op1 op2 => [s1 c1|t1|t1|s1 r1 IH] [s2 c2|t2|t2|s2 r2] f;
  try (case: f => [] /=; rewrite (eq_sym (value t2)); case (_ == _);
  move A0: (raw_fs_sz [::_]) => f0; move A1: (raw_fs_sz [::_]) => f1;
  move A2: (raw_fs_si [::_]) => f2; move A3: (raw_fs_si [::_]) => f3;
  rewrite /raw_fs_sz /raw_fs_si /= ?add0n in A0, A1, A2, A3; subst; eauto;
  move: (sz_weight t1 t2) (sz_weight t2 t1) (si_weight t1 t2) (si_weight t2 t1) => H0 H1 H2 H3; intuition;
  try (by apply (leq_add H0 H1)); by apply (leq_add H2 H3));
  try (rewrite /= ?(eq_sym s2); case: (s1 == s2); rewrite ?sz_open ?si_open;
   move: (IH r2 f) => /=; rewrite /raw_fs_sz /raw_fs_si; intuition);
  rewrite /raw_fs_sz /raw_fs_si /= ?(eq_sym s2) ?(eq_sym c2) ?(eq_sym (value t2));
  try by intuition.
  + by case: (s1 == s2); case: (c1 == c2); case: f => /=; eauto.
  + by case: (c1 == value t2) => [] /=; move: (weight_nonzero t2); intuition.
  + by case: (s1 == value t2); intuition.
  + by case: (s1 == s2); intuition.
  + by case: (value t1 == c2); nat_norm; move: (weight_nonzero t1); intuition.
  + by case: (value t1 == s2) => /=; nat_norm; intuition.
  + by case: (value t1 == s2) => /=; nat_norm; case: (raw_fs_interp r2 t1) => [a|] /=; intuition.
  + by case: (s1 == s2); intuition.
  + case: (s1 == value t2) => /=; nat_norm; [|intuition].
   move: (raw_fs_interp _ _) => [t|] /=; intuition. Qed.

End Computability.
End FilesystemOT.


Require Import SystemF.
Require Import List.
Require Import Eval.

Section Cyclic.

  Variable Delta : nat -> Term.
  Variable Xi : nat -> Ty.
  Variable Prog : forall n l m, Derivation Xi [n ; l |= F m @ Xi m] -> Derivation Xi [n ; l |= Delta m @ Xi m].
  Variable ProgTy : forall m, valid (Xi m) 0.

(*
  Inductive Ev_delta : Term -> Term -> Set :=
  | ev_f : forall n, Ev (F n) (Delta n)
  | ev_app : forall t t' s, Ev t t' -> Ev (App t s) (App t' s)
  | ev_tapp : forall t t' ty, Ev t t' -> Ev (TApp t ty) (TApp t' ty).

  Notation "t ~>d t'" := (Ev Delta t t') (at level 60).
*)

  CoInductive PreProof : Holds -> Set :=
  | DeltaStep' : forall n l t t' ty,
    PreProof [n ; l |= t' @ ty] ->
    t ~> t' ->
    PreProof [n ; l |= t @ ty]
  | ImpIntro' : forall n l t ty xty,
    valid xty n ->
    PreProof [n ; xty::l |= t @ ty] ->
    PreProof [n ; l |= (Abs xty t) @ (Imp xty ty)]
  | ImpElim' : forall n l t f ty xty,
    PreProof [n ; l |= t @ xty] ->
    PreProof [n ; l |= f @ (Imp xty ty)] ->
    PreProof [n ; l |= (App f t) @ ty]
  | AllIntro' : forall n l t ty,
    PreProof [S n ; map tyshift l |= t @ ty] ->
    PreProof [n ; l |= (Lam t) @ All ty]
  | AllElim' : forall n l t ty xty,
    valid xty n ->
    PreProof [n ; l |= t @ All ty] ->
    PreProof [n ; l |= TApp t xty @ (tysub ty 0 xty)]
  | VarIntro' : forall n l ty i,
    valid ty n -> i < length l -> nth i l Zero = ty ->
    PreProof [n ; l |= V i @ ty].

(* Parameter ProgCyc : forall n l m, PreProof [n ; l |= F m @ Xi m] -> PreProof [n ; l |= Delta m @ Xi m]. *)

Theorem derivation_imp_preproof : forall n l t ty, Derivation Xi [ n ; l |= t @ ty ] -> PreProof [n ; l |= t @ ty].
Proof.
  refine (cofix derivation_imp_preproof n l t ty (HD : Derivation Xi [ n ; l |= t @ ty ]) : PreProof [n ; l |= t @ ty] := _).
  inversion HD ; subst.
  (* F *)
  apply DeltaStep' with (t':= Delta m).
  apply derivation_imp_preproof.
  apply Prog in HD. auto.
  apply Evplus_base. apply ev_f.
  (* Abs *)
  apply ImpIntro' ; auto.
  (* App *)
  apply ImpElim' with (xty:=xty) ; auto.
  (* Lam *)
  apply AllIntro'.
  apply derivation_imp_preproof ; auto.
  (* TApp *)
  apply AllElim' ; auto.
  (* V *)
  apply VarIntro' ; auto.
Defined.

(*
Lemma ev_lemma : forall a b c, (a ~> b) -> (App a c ~> App b c) -> (App a c ~>+ d) -> (App b c ~>+ d).

H2 : t0 ~> t'0
  EvH : App t0 t1 ~> App t'0 t1
  t' : Term
  H1 : PreProof [n; l |=t' @ ty]
  H5 : App t0 t1 ~>+ t'
  ============================
   App t'0 t1 ~>+ t'
*)

Theorem ev_preservation_cyc : forall t t' n l ty,  PreProof [n ; l |= t @ ty] ->  t ~> t' -> PreProof [n ; l |= t' @ ty].
Proof.
  refine (cofix ev_preservation_cyc t t' n l ty (D : PreProof [n ; l |= t @ ty]) (EvH : t ~> t') : PreProof [n ; l |= t' @ ty] := _)
    ; case_eq t ; intros; subst.
  (* F *)
  inversion D; subst.
  apply ev_inter_evplus with (c:= t'0) in EvH.
  inversion EvH ; subst.
    (* = *)
    auto.
    (* ~>+ *)
    apply DeltaStep' with (t':=t'0). auto. auto. auto.
  (* V *)
  inversion EvH.
  (* App *)
  inversion D ; subst.
    (* Delta *)
    apply ev_inter_evplus with (b:= t') in H4.
    inversion H4 ; subst.
      (* = *)
      subst. exact H1.
      (* ~> *)
      apply DeltaStep' with (t':=t'0); auto. auto.
    (* App Rule *)
    inversion EvH ; subst.
    apply ImpElim' with (xty:=xty). auto.
    apply ev_preservation_cyc with (ty:=Imp xty ty) (n:=n) (l:=l)  in H3 ; auto.
    (* Subst Rule *)
    apply sub_preservation.
  (* TApp *)
  inversion EvH ; subst.
  inversion D ; subst.
  apply AllElim ; auto.
  apply ev_preservation with (t:=t0) ; auto.
  inversion D ; subst.
  inversion H6 ; subst.
  apply tysub_derivation_simple. auto. auto.
  (* Abs *)
  inversion EvH.
  (* Lam *)
  inversion EvH.
Defined.


(* This module defines containers. *)

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Basics.

Set Implicit Arguments.

Record Cont : Type := cont {shapes: Type; pos: shapes -> Type}.

Record Ext (C:Cont )(X:Type):Type := ext {shape: shapes C; elems : pos C shape -> X }.

Definition cforall {X} (P : X -> Prop) {C} (E : Ext C X) : Prop :=
  forall (p : pos C (shape E)), P (elems E p).

Definition cmap {C} {X Y} (f : X -> Y) (E : Ext C X) : Ext C Y :=
  {| shape := shape E; elems := (fun p => f (elems E p)) |}.

Lemma cmap_cmap  {X Y Z} (f : X -> Y) (g : Y -> Z) {C} (E : Ext C X) :
  cmap g (cmap f E) = cmap (compose g f) E.
Proof. auto. Qed.

Lemma cmap_id {X} {C} (E : Ext C X) :
  cmap (fun x => x) E = E.
Proof. destruct E. reflexivity. Qed.

Ltac cmap_eq := intros; unfold cmap; f_equal; simpl; apply functional_extensionality; intros;
  unfold cforall in *; auto.

Lemma cforall_rewrite {X Y} (f g : X -> Y) {C} (E : Ext C X):
  cforall (fun x => f x = g x) E -> cmap f E = cmap g E.
Proof.
  cmap_eq.
Qed.


Set Implicit Arguments.

Require Import Bedrock.StringSet.
Import StringSet.
Require Import Platform.Cito.StringSetFacts.

Section TopSection.

  Require Import Platform.Cito.GetLocalVars.
  Require Import Platform.Cito.FreeVars.

  Lemma get_local_vars_cardinal : forall s1 s2 argvars retvar, Subset (free_vars s1) (free_vars s2) -> length (get_local_vars s1 argvars retvar) <= length (get_local_vars s2 argvars retvar).
    intros.
    unfold get_local_vars.
    repeat rewrite <- StringSet.cardinal_1.
    eapply subset_cardinal.
    eapply diff_s_m.
    eapply add_s_m; eauto.
    unfold Basics.flip.
    eapply subset_refl.
  Qed.

  Require Import Coq.Strings.String.
  Require Import Coq.Lists.List.
  Require Import Platform.Cito.GeneralTactics2.
  Require Import Platform.Cito.SetoidListFacts.

  Lemma get_local_vars_subset : forall stmt argvars retvar, Subset (free_vars stmt) (of_list (argvars ++ get_local_vars stmt argvars retvar)).
    unfold get_local_vars.
    unfold Subset; intros.
    eapply of_list_spec.
    destruct (List.In_dec string_dec a argvars).
    eapply in_or_app; eauto.
    eapply in_or_app; right.
    eapply InA_eq_In_iff.
    eapply elements_iff.
    eapply diff_iff.
    split.
    eapply add_iff; eauto.
    not_not.
    eapply of_list_spec; eauto.
  Qed.

End TopSection.


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

(*i $Id: Euclid.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Require Import Mult.
Require Import Compare_dec.
Require Import Wf_nat.

Open Local Scope nat_scope.

Implicit Types a b n q r : nat.

Inductive diveucl a b : Set :=
  divex : forall q r, b > r -> a = q * b + r -> diveucl a b.

Lemma eucl_dev : forall n, n > 0 -> forall m:nat, diveucl m n.
Proof.
  intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
  elim (le_gt_dec b n).
  intro lebn.
  elim (H0 (n - b)); auto with arith.
  intros q r g e.
  apply divex with (S q) r; simpl in |- *; auto with arith.
  elim plus_assoc.
  elim e; auto with arith.
  intros gtbn.
  apply divex with 0 n; simpl in |- *; auto with arith.
Qed.

Lemma quotient :
  forall n,
    n > 0 ->
    forall m:nat, {q : nat |  exists r : nat, m = q * n + r /\ n > r}.
Proof.
  intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
  elim (le_gt_dec b n).
  intro lebn.
  elim (H0 (n - b)); auto with arith.
  intros q Hq; exists (S q).
  elim Hq; intros r Hr.
  exists r; simpl in |- *; elim Hr; intros.
  elim plus_assoc.
  elim H1; auto with arith.
  intros gtbn.
  exists 0; exists n; simpl in |- *; auto with arith.
Qed.

Lemma modulo :
  forall n,
    n > 0 ->
    forall m:nat, {r : nat |  exists q : nat, m = q * n + r /\ n > r}.
Proof.
  intros b H a; pattern a in |- *; apply gt_wf_rec; intros n H0.
  elim (le_gt_dec b n).
  intro lebn.
  elim (H0 (n - b)); auto with arith.
  intros r Hr; exists r.
  elim Hr; intros q Hq.
  elim Hq; intros; exists (S q); simpl in |- *.
  elim plus_assoc.
  elim H1; auto with arith.
  intros gtbn.
  exists n; exists 0; simpl in |- *; auto with arith.
Qed.


Require Export GeoCoq.Elements.OriginalProofs.lemma_collinear4.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_collinearbetween :
   forall A B C D E F H,
   Col A E B -> Col C F D -> neq A B -> neq C D -> neq A E -> neq F D -> ~ Meet A B C D -> BetS A H D -> Col E F H ->
   BetS E H F.
Proof.
intros.
assert (~ eq H E).
 {
 intro.
 assert (Col A H B) by (conclude cn_equalitysub).
 assert (Col H A B) by (forward_using lemma_collinearorder).
 assert (Col A H D) by (conclude_def Col ).
 assert (Col H A D) by (forward_using lemma_collinearorder).
 assert (neq A H) by (forward_using lemma_betweennotequal).
 assert (neq H A) by (conclude lemma_inequalitysymmetric).
 assert (Col A B D) by (conclude lemma_collinear4).
 assert (eq D D) by (conclude cn_equalityreflexive).
 assert (Col C D D) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ eq H F).
 {
 intro.
 assert (Col A H D) by (conclude_def Col ).
 assert (Col A F D) by (conclude cn_equalitysub).
 assert (Col F D A) by (forward_using lemma_collinearorder).
 assert (Col F D C) by (forward_using lemma_collinearorder).
 assert (Col D A C) by (conclude lemma_collinear4).
 assert (Col C D A) by (forward_using lemma_collinearorder).
 assert (eq A A) by (conclude cn_equalityreflexive).
 assert (Col A B A) by (conclude_def Col ).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ BetS E F H).
 {
 intro.
 assert (BetS D H A) by (conclude axiom_betweennesssymmetry).
 assert (~ Col D A E).
  {
  intro.
  assert (Col E A B) by (forward_using lemma_collinearorder).
  assert (Col E A D) by (forward_using lemma_collinearorder).
  assert (neq E A) by (conclude lemma_inequalitysymmetric).
  assert (Col A B D) by (conclude lemma_collinear4).
  assert (eq D D) by (conclude cn_equalityreflexive).
  assert (Col C D D) by (conclude_def Col ).
  assert (Meet A B C D) by (conclude_def Meet ).
  contradict.
  }
 let Tf:=fresh in
 assert (Tf:exists Q, (BetS E Q A /\ BetS D F Q)) by (conclude postulate_Pasch_outer);destruct Tf as [Q];spliter.
 assert (Col E Q A) by (conclude_def Col ).
 assert (Col D F Q) by (conclude_def Col ).
 assert (Col E A Q) by (forward_using lemma_collinearorder).
 assert (Col E A B) by (forward_using lemma_collinearorder).
 assert (neq E A) by (conclude lemma_inequalitysymmetric).
 assert (Col A Q B) by (conclude lemma_collinear4).
 assert (Col A B Q) by (forward_using lemma_collinearorder).
 assert (Col F D Q) by (forward_using lemma_collinearorder).
 assert (Col F D C) by (forward_using lemma_collinearorder).
 assert (Col D Q C) by (conclude lemma_collinear4).
 assert (Col C D Q) by (forward_using lemma_collinearorder).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ BetS F E H).
 {
 intro.
 assert (~ Col A D F).
  {
  intro.
  assert (Col F D C) by (forward_using lemma_collinearorder).
  assert (Col F D A) by (forward_using lemma_collinearorder).
  assert (Col D C A) by (conclude lemma_collinear4).
  assert (Col C D A) by (forward_using lemma_collinearorder).
  assert (eq A A) by (conclude cn_equalityreflexive).
  assert (Col A B A) by (conclude_def Col ).
  assert (Meet A B C D) by (conclude_def Meet ).
  contradict.
  }
 let Tf:=fresh in
 assert (Tf:exists R, (BetS F R D /\ BetS A E R)) by (conclude postulate_Pasch_outer);destruct Tf as [R];spliter.
 assert (Col F R D) by (conclude_def Col ).
 assert (Col A E R) by (conclude_def Col ).
 assert (Col F D R) by (forward_using lemma_collinearorder).
 assert (Col F D C) by (forward_using lemma_collinearorder).
 assert (Col D R C) by (conclude lemma_collinear4).
 assert (Col C D R) by (forward_using lemma_collinearorder).
 assert (Col E A R) by (forward_using lemma_collinearorder).
 assert (Col E A B) by (forward_using lemma_collinearorder).
 assert (neq A E) by (forward_using lemma_betweennotequal).
 assert (neq E A) by (conclude lemma_inequalitysymmetric).
 assert (Col A R B) by (conclude lemma_collinear4).
 assert (Col A B R) by (forward_using lemma_collinearorder).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert (~ eq E F).
 {
 intro.
 assert (Col C D F) by (forward_using lemma_collinearorder).
 assert (Col A B E) by (forward_using lemma_collinearorder).
 assert (Col A B F) by (conclude cn_equalitysub).
 assert (Meet A B C D) by (conclude_def Meet ).
 contradict.
 }
assert ((eq E F \/ eq E H \/ eq F H \/ BetS F E H \/ BetS E F H \/ BetS E H F)) by (conclude_def Col ).
assert (BetS E H F).
by cases on (eq E F \/ eq E H \/ eq F H \/ BetS F E H \/ BetS E F H \/ BetS E H F).
{
 assert (~ ~ BetS E H F).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS E H F).
  {
  intro.
  assert (neq E H) by (conclude lemma_inequalitysymmetric).
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS E H F).
  {
  intro.
  assert (neq F H) by (conclude lemma_inequalitysymmetric).
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS E H F).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS E H F).
  {
  intro.
  contradict.
  }
 close.
 }
{
 close.
 }
(** cases *)
close.
Qed.

End Euclid.


Require Import floyd.proofauto. (* Import the Verifiable C system *)
Require Import examples.sum_cl_array. (* Import the AST of this C program *)
(* The next line is "boilerplate", always required after importing an AST. *)
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs.  mk_varspecs prog. Defined.

(* Some definitions relating to the functional spec of this particular program. *)

Definition get_public(p: Z * bool): Z :=
  let (x, isPublic) := p in if isPublic then x else 0.

Definition sum_cl : list (Z * bool) -> Z :=
  fold_right (fun (p: Z * bool) (sum: Z) => get_public p + sum) 0.

Lemma sum_cl_app:
  forall a b, sum_cl (a++b) =  sum_cl a + sum_cl b.
Proof.
  intros. induction a; simpl; omega.
Qed.

Definition sum_cl_array_spec :=
 DECLARE _sum_cl_array
  WITH a: val, isPublic: val, a_sh : share, isPublic_sh: share,
       contents: list (Z * bool), n: Z
  PRE [ _a OF (tptr tint), _isPublic OF (tptr tbool), _n OF tint ]
          PROP  (readable_share a_sh; readable_share isPublic_sh;
                 0 <= n <= Int.max_signed;
                 Forall (fun p => Int.min_signed <= (fst p) <= Int.max_signed) contents)
          LOCAL (temp _a a; temp _isPublic isPublic; temp _n (Vint (Int.repr n)))
          SEP   (data_at a_sh (tarray tint n) (map Vint (map Int.repr (map fst contents))) a;
                 data_at isPublic_sh (tarray tbool n) (map Val.of_bool (map snd contents)) isPublic)
  POST [ tint ]
        PROP () LOCAL(temp ret_temp  (Vint (Int.repr (sum_cl contents))))
          SEP   (data_at a_sh (tarray tint n) (map Vint (map Int.repr (map fst contents))) a;
                 data_at isPublic_sh (tarray tbool n) (map Val.of_bool (map snd contents)) isPublic).

(* The spec of "int main(void){}" always looks like this. *)
Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ] main_post prog nil u.

(* Packaging the API spec all together. *)
Definition Gprog : funspecs :=
        ltac:(with_library prog [sum_cl_array_spec; main_spec]).

(* Loop invariant, for use in body_sumarray.  *)
Definition sumarray_Inv a isPublic a_sh isPublic_sh contents n :=
 EX i: Z,
   PROP  (0 <= i <= n)
   LOCAL (temp _a a;
          temp _i (Vint (Int.repr i));
          temp _n (Vint (Int.repr n));
          temp _sum (Vint (Int.repr (sum_cl (sublist 0 i contents)))))
   SEP   (data_at a_sh (tarray tint n) (map Vint (map Int.repr (map fst contents))) a;
          data_at isPublic_sh (tarray tbool n) (map Val.of_bool (map snd contents)) isPublic).

(** Proof that f_sum_cl_array, the body of the sum_cl_array() function,
 ** satisfies sum_cl_array_spec, in the global context (Vprog,Gprog).
 **)
Lemma body_sum_cl_array: semax_body Vprog Gprog f_sum_cl_array sum_cl_array_spec.
Proof.
  start_function. Admitted. (*
(* The next two lines do forward symbolic execution through
   the first two executable statements of the function body *)
forward.  (* i = 0; *)
forward.  (* s = 0; *)
(* To do symbolic execution through a [while] loop, we must
 * provide a loop invariant, so we use [forward_while] with
 * the invariant as an argument .*)
forward_while (sumarray_Inv a sh contents size).
(* forward_while leaves four subgoals; here we label them
   with the * bullet. *)
* (* Prove that current precondition implies loop invariant *)
Exists 0.   (* Instantiate the existential on the right-side of |--   *)
entailer!.  (* Simplify this entailment as much as possible; in this
      case, it solves entirely; in other cases, entailer! leaves subgoals *)
* (* Prove that loop invariant implies typechecking condition *)
entailer!.  (* Typechecking conditions usually solve quite easily *)
* (* Prove postcondition of loop body implies loop invariant *)
(* In order to get to the postcondition of the loop body, of course,
   we must forward-symbolic-execute through the loop body;
   so we start that here. *)
(* "forward" fails and tells us to first make (0 <= i < Zlength contents)
   provable by auto, so we assert the following: *)
assert_PROP (Zlength contents = size). {
  entailer!. do 2 rewrite Zlength_map. reflexivity.
}

forward. (* x = a[i] *)
forward. (* s += x; *)
forward. (* i++; *)
 (* Now we have reached the end of the loop body, and it's
   time to prove that the _current precondition_  (which is the
   postcondition of the loop body) entails the loop invariant. *)
 Exists (i+1).
 entailer!.
 clear - H HRE H1.
 f_equal. f_equal.
 rewrite (sublist_split 0 i (i+1)) by omega.
 rewrite sum_Z_app. rewrite (sublist_one i) with (d:=0) by omega.
 simpl. rewrite Z.add_0_r. reflexivity.
* (* After the loop *)
forward.  (* return s; *)
 (* Here we prove that the postcondition of the function body
    entails the postcondition demanded by the function specification. *)
entailer!.
autorewrite with sublist in *.
autorewrite with sublist.
reflexivity.
Qed.
*)

(* Contents of the extern global initialized array "_four" *)
Definition four_contents := [1; 2; 3; 4].

(*
Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
name four _four.
start_function.
forward_call (*  s = sumarray(four,4); *)
  (four,Ews,four_contents,4).
 split3; auto. computable.
 repeat constructor; computable.
forward. (* return s; *)
Qed.

Existing Instance NullExtension.Espec.

Lemma all_funcs_correct:
  semax_func Vprog Gprog (prog_funct prog) Gprog.
Proof.
unfold Gprog, prog, prog_funct; simpl.
semax_func_cons body_sumarray.
semax_func_cons body_main.
Qed.
*)