Load termination.

(* Main elements of the proof: we start with an autonomous operator f, a solution x of x = f(x),
    and a weak transition from g(x) (where g is a reduct of f), let's say g(x) =a=> y.
    Then we build a sequence of operators, and either it does not stop and we build
    a divergence, either it does and we can emulate this transition with a finite unfolding of f, i.e.
    g(f^n(x)) =a=> f'(x) ~~ y *)

(* This first section treats in the case of a visible weak transition: =a=>. If the construction stops
    in this section, then we built a transition g(f^n(x)) =a=> gn(x)  but we don't always have that gn(x) ~~ y;
    however gn(x) => yn ~~ y , and we treat this transition in the section seq_visible2 *)
Section seq_visible.
Variable T : LTS.
Variable O : Op T.
Variable f : T -> T.
Variable x : T.
(* f is the equation, x its solution *)
Hypothesis x_sol : f x ~~ x.
(* g is the context from which there is a transition; it needs to be a reduct of f *)
Variable g : T -> T.
Hypothesis redfg : comp_red O f g.
Variable y : T.
Variable a : label (l:=T).
(* This is the transition we consider and emulate *)
Hypothesis itr : wtrans (l a) (g x) y.
(* f and g are operators, f is guarded or autonomous *)
Hypothesis fop : op O f.
Hypothesis gop : op O g.
Hypothesis gf : guarded (op O) f.

Section step_visible1.
(* This is the predicate verified by any context/operator of the sequence that we built;
    if gn verifies seq_op, then we have g(f^n(x)) => gn(x) =a=> yn ~~ y *)
Definition seq_op (gn : T -> T) := (exists yn, yn ~~ y /\ wtrans (l a) (gn x) yn) /\ (exists n, wtaut O (comp g (unfolding f n)) gn) /\
op O gn /\ comp_red O f gn.

(* This is the predicate verified by gn when we stop: it means the visible transition is now an autonomous
    transition (g(f^n(x)) =a=> (gn(x)) *)
Definition seq_vis1 (gn : T -> T) := (exists yn, yn ~~ y /\ wttrans (gn x) yn) /\ (exists n, waut O (l a) (comp g (unfolding f n)) gn)
/\ op O gn /\ comp_red O f gn.

(* One step in the construction of the first sequence: we start from gn, we build gn+1 and show that either
    it verifies seq_op and we can continue, or it verifies seq_vis1 and we stop. *)
Variable gn : T -> T.
Hypothesis seqop : seq_op gn.

(* Some properties of gn *)
Lemma step_bsim : (comp gn f) x ~~ (gn x).
unfold comp.
apply (cong T O gn).
apply seqop.
apply x_sol.
Qed.

Lemma step_diag : exists yn', whtrans (l a) ((comp gn f) x) yn' /\ y ~~ yn'.
destruct seqop as [h so']; destruct h as [yn hn].
destruct (bsim_diag_weak T (gn x) (comp gn f x) yn (l a)) as [yn' h].
apply sym_bsim. apply step_bsim. simpl. apply hn.
exists yn'. split; [apply h|]. apply bsim_trans with yn.
apply sym_bsim. apply hn. apply h.
Qed.

Lemma gg : guarded (op O) (comp gn f).
apply (leftguard T O gn f).
apply seqop.
apply gf.
Qed.

(* Technical lemma to be able to use associativity of composition
    and commutation of composition of f and its unfoldings *)
Lemma ext_comp : forall n, ext_eq (comp g (comp f (unfolding f n))) (comp (comp g (unfolding f n)) f).
intros n. intros s.
assert (eeq : ext_eq ((comp f (unfolding f n))) (comp ((unfolding f n)) f)).
intros s'. simpl. rewrite (unfold_right T f n s'). trivial. specialize (eeq s).
unfold comp. unfold comp in eeq. rewrite eeq. reflexivity.
Qed.

(* We prove that gn+1 exists *)
Lemma proof_step_vis1 : (exists gn', seq_op gn' /\ aut O t (comp gn f) gn') \/ (exists gn', seq_vis1 gn'
/\ aut O (l a) (comp gn f) gn').
destruct step_diag as [yn' h]. destruct h as [tr eqn'].
simpl in tr. destruct tr as [z h]. destruct h as [wtr1 h]. destruct h as [z' h].
destruct h as [vtr wtr2]. remember (comp gn f x) as gnfx.
destruct (clos_refl_trans_one_or T (trans t) gnfx z wtr1) as [ | ex]; [subst|].
+ right. destruct gg as [d gd]; clear d. destruct (gd x z' (l a) vtr) as [gn' hn'].
  exists gn'. repeat (try split); try apply hn'.
  - exists yn'. split. apply sym_bsim. apply eqn'.
    destruct hn' as [opgn' h'']. destruct h'' as [s autr].
    subst. apply wtr2.
  - destruct seqop as [_ seqop']. destruct seqop' as [exn _]. destruct exn as [n hn].
    exists (S n). exists (comp gn f). exists gn'. repeat try split;
     [| apply (clos_comp T O); [apply seqop|apply fop] | apply hn' | apply hn'|apply rtf_refl].
    simpl. eapply wtaut_ext. apply ext_sym. apply ext_comp.
     ext. apply wtaut_comp. apply fop. apply hn. ext.
  - apply comp_red_right with gn (l a). destruct seqop as [_ hh]; destruct hh as [_ hh]; destruct hh as [_ cr]; exact cr.
    split; [|split; apply hn']. apply (clos_comp T O); [apply seqop|assumption].
  - apply (clos_comp T O); [apply seqop|assumption].
+ destruct ex as [zz h].
  left. destruct gg as [d gd]; clear d. subst.
  destruct h as [h wtr3].
  destruct (gd x zz t h) as [gn' h0]. exists gn'. repeat (try split); try apply h0.
  destruct h0 as [opgn' h0]; destruct h0 as [eqzz h0]. subst.
  - exists yn'. split; [apply sym_bsim; assumption|].
    exists z. split. assumption. exists z'. split; assumption.
  - destruct seqop as [_ seqop']. destruct seqop' as [exn _]. destruct exn as [n hn].
    exists (S n). simpl.  eapply wtaut_ext. apply ext_sym. apply ext_comp.
     ext. eapply rtf_trans. apply wtaut_comp. apply fop. apply hn.
    apply rtf_step. split; try split; [| |apply h0]. apply (clos_comp T O). apply seqop. apply fop.
    apply h0.
  - eapply comp_red_right with gn t. destruct seqop as [_ hh]; destruct hh as [_ hh]; destruct hh as [_ cr]; exact cr.
    split; [|split; apply h0]. apply (clos_comp T O); [apply seqop|assumption].
  - apply (clos_comp T O); [apply seqop|assumption].
Qed.

End step_visible1.

(* We use the proof for one step above to prove that we can stop. We start from g as g0, and then
    use either non divergence and excluded middle, or well-foundedness, to show that the construction stops *)
Section proof_vis1.

Lemma seqopg : seq_op g.
repeat try split.
+ exists y. split; [apply refl_bsim|apply itr].
+ exists 0. simpl. apply rtf_refl. ext.
+ apply gop.
+ apply redfg.
Qed.

Lemma divP_vis1 : forall gn, seq_op gn -> divP (T -> T) seq_op (rel_div T O f) (exists gn', seq_vis1 gn') gn.
cofix. intros gn seqop. destruct proof_step_vis1 with gn as [exn'|exn']; [apply seqop| |];
destruct exn' as [gn' hn'].
+ apply stepR' with gn'; [| apply divP_vis1| assumption]; apply hn'.
+ apply stopP. exists gn'. apply hn'. apply seqop.
Qed.

(* With excluded middle and non divergence *)
Section vis1_EM.
Hypothesis EM : forall A, A \/ ~A.

Lemma opdiv_div : ~ op_div O f -> forall gn, comp_red O f gn -> ~ comp_top_div O f gn.
intros div gn cr topdiv. apply div. apply red_div. exists gn; split; assumption.
Qed.

Lemma vis1_EM : ~ op_div O f -> exists gn, seq_vis1 gn.
intros ndiv.
destruct (notdiv_div_P T O f seq_op EM g (exists gn', seq_vis1 gn')) as [gn h]. apply divP_vis1. apply seqopg.
apply opdiv_div; assumption.
exists gn. apply h.
Qed.

End vis1_EM.
(* With well-foundedness of the reverse of the tau reduction relation over the reducts of f *)
Section vis1_Wf.
Hypothesis wf: well_founded (red_tau O f (comp_red O f)).

Lemma wf_seq_op : well_founded (red_tau O f seq_op).
eapply wf_wf; [assumption| | apply wf ]. intros. apply H.
Qed.

Lemma vis1_Wf: exists gn, seq_vis1 gn.
destruct (wf_P T O f seq_op g (exists gn', seq_vis1 gn') wf_seq_op) as [gn h]. apply divP_vis1. apply seqopg.
exists gn. apply h.
Qed.

End vis1_Wf.

End proof_vis1.

(* Same as step_visible, except the visible transition is already done by the gn's, and we want to complete it so that
    gn(x) ~~ y *)
Section step_visible2.
(* Verified by the gn's we build: we have g(f^n(x)) =a=> gn(x) => yn ~~ y *)
Definition seq_vis2 gn := (exists yn, yn ~~ y /\ wttrans (gn x) yn) /\ (exists n, waut O (l a) (comp g (unfolding f n)) gn) /\
op O gn /\ comp_red O f gn.

(* Verified by the gn when we stop: g(f^n(x)) =a=> gn(x) ~~ y *)
Definition seq_end gn := (comp gn f x ~~ y) /\ (exists n, waut O (l a) (comp g (unfolding f n)) gn) /\
op O gn /\ comp_red O f gn.

(* One step: we start from gn... Proof is almost the same as previously. *)
Variable gn : T -> T.
Hypothesis seqop : seq_vis2 gn.

Lemma step_bsim2 : (comp gn f) x ~~ (gn x).
unfold comp.
apply (cong T O gn).
apply seqop.
apply x_sol.
Qed.

Lemma step_diag2 : exists yn', wttrans ((comp gn f) x) yn' /\ y ~~ yn'.
destruct seqop as [h so']; destruct h as [yn hn].
destruct (bsim_diag_weak T (gn x) (comp gn f x) yn t) as [yn' h].
apply sym_bsim. apply step_bsim2. simpl. apply hn.
exists yn'. split; [apply h|]. apply bsim_trans with yn.
apply sym_bsim. apply hn. apply h.
Qed.

Lemma gg2 : guarded (op O) (comp gn f).
apply (leftguard T O gn f).
apply seqop.
apply gf.
Qed.

Lemma waut_cons_tau : forall f g h m, waut O m f g -> wtaut O g h -> waut O m f h.
intros i j k m wt tt. destruct wt as [i' wt]; destruct wt as [j' wt]; destruct wt as [tt' wt]; destruct wt as [tr tt''].
exists i'. exists j'. split; try assumption. split; try assumption. eapply rtf_trans; eassumption.
Qed.

Lemma proof_step_vis2 : (exists gn', seq_vis2 gn' /\ aut O t (comp gn f) gn') \/ (seq_end gn).
destruct step_diag2 as [yn' h]. destruct h as [tr eqn'].
simpl in tr. remember (comp gn f x) as gnfx.
destruct (clos_refl_trans_one_or T (trans t) gnfx yn' tr) as [ | ex]; [subst|].
+ right. repeat try split.
  - apply sym_bsim. apply eqn'.
  - destruct seqop as [_ seqop']. destruct seqop' as [exn _]. destruct exn as [n hn].
    exists n. simpl. apply hn.
  - apply seqop.
  - apply seqop.
+ destruct ex as [zz h].
  left. destruct gg2 as [d gd]; clear d. subst.
  destruct h as [h wtr3].
  destruct (gd x zz t h) as [gn' h0]. exists gn'. repeat (try split); try apply h0.
  destruct h0 as [opgn' h0]; destruct h0 as [eqzz h0]. subst.
  - exists yn'. split; [apply sym_bsim; assumption|]. apply wtr3.
  - destruct seqop as [_ seqop']. destruct seqop' as [exn _]. destruct exn as [n hn].
    exists (S n). simpl. eapply waut_ext. apply ext_sym. apply ext_comp.
     ext. apply waut_cons_tau with (comp gn f).
    apply waut_comp. apply fop. apply hn. apply rtf_step. split; [|split; apply h0].
    apply (clos_comp T O). apply seqop. apply fop.
  - eapply comp_red_right with gn t. destruct seqop as [_ hh]; destruct hh as [_ hh]; destruct hh as [_ cr]; exact cr.
    split; [|split; apply h0]. apply (clos_comp T O); [apply seqop|assumption].
  - apply (clos_comp T O); [apply seqop|assumption].
Qed.

End step_visible2.

(* We now end the proof (in the visible case), as previously, with either non divergence or well-foundedness*)
Section proof_vis2.

Lemma divP_vis2 : forall gn, seq_vis2 gn -> divP (T -> T) seq_vis2 (rel_div T O f) (exists gn', seq_end gn') gn.
cofix. intros gn seqop. destruct proof_step_vis2 with gn as [exn'|exn']; [apply seqop| |].
+ destruct exn' as [gn' hn']. apply stepR' with gn'; [| apply divP_vis2| assumption]; apply hn'.
+ apply stopP. exists gn. apply exn'. apply seqop.
Qed.

Section vis2_EM.
Hypothesis EM : forall A, A \/ ~A.

Lemma seqvis2 : ~ op_div O f -> exists g', seq_vis2 g'.
intros F. destruct (vis1_EM EM F) as [g' h].
destruct h as [exn h]. destruct h as [exnn h].
exists g'; repeat try split.
+ destruct exn as [yn h']. exists yn. apply h'.
+ destruct exnn as [n hn]. exists n. apply hn.
+ apply h.
+ apply h.
Qed.

Lemma vis_EM : ~ op_div O f -> exists gn, seq_end gn.
intros ndiv. destruct (seqvis2 ndiv) as [g' seqop'].
destruct (notdiv_div_P T O f seq_vis2 EM g' (exists gn, seq_end gn)) as [gn h]. apply divP_vis2. apply seqop'.
apply opdiv_div. apply ndiv. apply seqop'.
exists gn. apply h.
Qed.

End vis2_EM.

Section vis2_Wf.
Hypothesis wf: well_founded (red_tau O f (comp_red O f)).

Lemma wf_seq_vis2 : well_founded (red_tau O f seq_vis2).
eapply wf_wf; [assumption| | apply wf ]. intros. apply H.
Qed.

Lemma seqvis2_wf : exists g', seq_vis2 g'.
destruct (vis1_Wf wf) as [g' h].
destruct h as [exn h]. destruct h as [exnn h].
exists g'; repeat try split.
+ destruct exn as [yn h']. exists yn. apply h'.
+ destruct exnn as [n hn]. exists n. apply hn.
+ apply h.
+ apply h.
Qed.

Lemma vis_Wf: exists gn, seq_end gn.
destruct (seqvis2_wf) as [g' seqop].
destruct (wf_P T O f seq_vis2 g' (exists gn, seq_end gn) wf_seq_vis2) as [gn h]. apply divP_vis2. assumption.
exists gn. apply h.
Qed.

End vis2_Wf.

End proof_vis2.

End seq_visible.

(* Same as the two previous sections, but for a tau transition: we start from g(x) => y.
    Then there is only one sequence to build instead of two: we don't have to first produce a
    visible transition*)
Section seq_tau.
Variable T : LTS.
Variable O : Op T.
Variable f : T -> T.
Variable x : T.
Hypothesis x_sol : f x ~~ x.
Variable g : T -> T.
Hypothesis redfg : comp_red O f g.
Variable y : T.
Hypothesis itr : wttrans (g x) y.
Hypothesis fop : op O f.
Hypothesis gop : op O g.
Hypothesis gf : guarded (op O) f.

Definition seq_tau (gn : T -> T) := (exists yn, yn ~~ y /\ wttrans (gn x) yn) /\ (exists n, wtaut O (comp g (unfolding f n)) gn) /\
op O gn /\ comp_red O f gn.

Definition seq_end' gn := (comp gn f x ~~ y) /\ (exists n, wtaut O (comp g (unfolding f n)) gn) /\
op O gn /\ comp_red O f gn.

Section step_tau.
Variable gn : T -> T.
Hypothesis seqtau : seq_tau gn.

Lemma step_bsim_tau : (comp gn f) x ~~ (gn x).
unfold comp.
apply (cong T O gn).
apply seqtau.
apply x_sol.
Qed.

Lemma step_diagt : exists yn', wttrans ((comp gn f) x) yn' /\ y ~~ yn'.
destruct seqtau as [h so']; destruct h as [yn hn].
destruct (bsim_diag_weak T (gn x) (comp gn f x) yn t) as [yn' h].
apply sym_bsim.  apply step_bsim_tau. simpl. apply hn.
exists yn'. split; [apply h|]. apply bsim_trans with yn.
apply sym_bsim. apply hn. apply h.
Qed.

Lemma ggt : guarded (op O) (comp gn f).
apply (leftguard T O gn f).
apply seqtau.
apply gf.
Qed.

Lemma proof_step_tau : (exists gn', seq_tau gn' /\ aut O t (comp gn f) gn') \/ (seq_end' gn).
destruct step_diagt as [yn' h]. destruct h as [tr eqn'].
simpl in tr. remember (comp gn f x) as gnfx.
destruct (clos_refl_trans_one_or T (trans t) gnfx yn' tr) as [ | ex]; [subst|].
+ right. repeat try split.
  - apply sym_bsim. apply eqn'.
  - destruct seqtau as [_ seqtau']. destruct seqtau' as [exn _]. destruct exn as [n hn].
    exists n. simpl. apply hn.
  - apply seqtau.
  - apply seqtau.
+ destruct ex as [zz h].
  left. destruct ggt as [d gd]; clear d. subst.
  destruct h as [h wtr3].
  destruct (gd x zz t h) as [gn' h0]. exists gn'. repeat (try split); try apply h0.
  destruct h0 as [opgn' h0]; destruct h0 as [eqzz h0]. subst.
  - exists yn'. split; [apply sym_bsim; assumption|]. apply wtr3.
  - destruct seqtau as [_ seqop']. destruct seqop' as [exn _]. destruct exn as [n hn].
    exists (S n). simpl. eapply wtaut_ext. apply ext_sym. apply ext_comp.
     ext. eapply rtf_trans.
    apply wtaut_comp. apply fop. apply hn. apply rtf_step. split; [|split; apply h0].
    apply (clos_comp T O). apply seqtau. apply fop.
  - eapply comp_red_right with gn t. destruct seqtau as [_ hh]; destruct hh as [_ hh]; destruct hh as [_ cr]; exact cr.
    split; [|split; apply h0]. apply (clos_comp T O); [apply seqtau|assumption].
  - apply (clos_comp T O); [apply seqtau|assumption].
Qed.

End step_tau.

Lemma divP_tau : forall gn, seq_tau gn -> divP (T -> T) seq_tau (rel_div T O f) (exists gn', seq_end' gn') gn.
cofix. intros gn seqop. destruct proof_step_tau with gn as [exn'|exn']; [apply seqop| |].
+ destruct exn' as [gn' hn']. apply stepR' with gn'; [| apply divP_tau| assumption]; apply hn'.
+ apply stopP. exists gn. apply exn'. apply seqop.
Qed.

Lemma seqtaug : seq_tau g.
repeat try split.
+ exists y. split; [apply refl_bsim|apply itr].
+ exists 0. simpl. apply rtf_refl. ext.
+ apply gop.
+ apply redfg.
Qed.

Section tau_EM.
Hypothesis EM : forall A, A \/ ~A.

Lemma tau_EM : ~ op_div O f -> exists gn, seq_end' gn.
intros ndiv. destruct (seqtaug) as [g' seqop'].
destruct (notdiv_div_P T O f seq_tau EM g (exists gn, seq_end' gn)) as [gn h]. apply divP_tau. apply seqtaug.
apply opdiv_div. apply ndiv. apply seqop'.
exists gn. apply h.
Qed.

End tau_EM.

Section tau_Wf.
Hypothesis wf: well_founded (red_tau O f (comp_red O f)).

Lemma wf_tau : well_founded (red_tau O f seq_tau).
eapply wf_wf; [assumption| | apply wf ]. intros. apply H.
Qed.

Lemma tau_Wf: exists gn, seq_end' gn.
destruct (seqtaug) as [g' seqop'].
destruct (wf_P T O f seq_tau g (exists gn, seq_end' gn) wf_tau) as [gn h]. apply divP_tau. apply seqtaug.
exists gn. apply h.
Qed.

End tau_Wf.

End seq_tau.

(* We can now prove that if f is autonomous and non divergent (or that the tau reduction relation over
    the set of reducts of f is well-founded) then f protects its solutions. *)
Section aut_op_protects.
Variable T : LTS.
Variable O : Op T.
Variable f : T -> T.
Hypothesis fop : op O f.
Hypothesis gf : guarded (op O) f.

Section protects_EM.
Hypothesis EM : forall A, A \/ ~A.
Hypothesis ndiv : ~ op_div O f.

Lemma op_protects_EM : protects O f.
unfold protects. intros g x gop x_sol redfg m y itr.
induction m as [|a].
+ apply sym_bsim in x_sol.
  simpl in *. destruct (tau_EM T O f x x_sol g redfg y itr fop gop gf EM ndiv) as [gn hn].
  exists gn. destruct hn as [eqn hn]. destruct hn as [exn h]. destruct exn as [n hn].
  exists n. repeat try split; try apply h; try assumption.
  apply bsim_trans with (comp gn f x); [|apply eqn]. unfold comp; simpl. apply (cong T O ).
  apply h. apply sym_bsim. apply x_sol.
+ apply sym_bsim in x_sol.
  simpl in *. destruct (vis_EM T O f x x_sol g redfg y a itr fop gop gf EM ndiv) as [gn hn].
  exists gn. destruct hn as [eqn hn]. destruct hn as [exn h]. destruct exn as [n hn].
  exists n. repeat try split; try apply h; try assumption.
  apply bsim_trans with (comp gn f x); [|apply eqn]. unfold comp; simpl. apply (cong T O ).
  apply h. apply sym_bsim. apply x_sol.
Qed.

End protects_EM.

Section protects_Wf.
Hypothesis wf: well_founded (red_tau O f (comp_red O f)).

Lemma op_protects_wf : protects O f.
unfold protects. intros g x gop x_sol redfg m y itr.
induction m as [|a].
+ apply sym_bsim in x_sol.
  simpl in *. destruct (tau_Wf T O f x x_sol g redfg y itr fop gop gf wf) as [gn hn].
  exists gn. destruct hn as [eqn hn]. destruct hn as [exn h]. destruct exn as [n hn].
  exists n. repeat try split; try apply h; try assumption.
  apply bsim_trans with (comp gn f x); [|apply eqn]. unfold comp; simpl. apply (cong T O ).
  apply h. apply sym_bsim. apply x_sol.
+ apply sym_bsim in x_sol.
  simpl in *. destruct (vis_Wf T O f x x_sol g redfg y a itr fop gop gf wf) as [gn hn].
  exists gn. destruct hn as [eqn hn]. destruct hn as [exn h]. destruct exn as [n hn].
  exists n. repeat try split; try apply h; try assumption.
  apply bsim_trans with (comp gn f x); [|apply eqn]. unfold comp; simpl. apply (cong T O ).
  apply h. apply sym_bsim. apply x_sol.
Qed.

End protects_Wf.

End aut_op_protects.


Require Import VST.floyd.proofauto. (* Import the Verifiable C system *)
Require Import VST.progs.sumarray2. (* 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 sum_Z : list Z -> Z := fold_right Z.add 0.

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

(* Beginning of the API spec for the sumarray.c program *)
Definition sumarray_spec :=
 DECLARE _sumarray
  WITH a: val, sh : share, contents : list Z, size: Z
  PRE [ _a OF (tptr tuint), _n OF tint ]
          PROP  (readable_share sh; 0 <= size <= Int.max_signed)
          LOCAL (temp _a a; temp _n (Vint (Int.repr size)))
          SEP   (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a)
  POST [ tuint ]
        PROP () LOCAL(temp ret_temp  (Vint (Int.repr (sum_Z contents))))
           SEP (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a).

(* The precondition of "int main(void){}" always looks like this. *)
Definition main_spec :=
 DECLARE _main
  WITH u : unit
  PRE  [] main_pre prog nil u
  POST [ tint ]
     PROP()
     LOCAL (temp ret_temp (Vint (Int.repr (3+4))))
     SEP(TT).

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

(** Proof that f_sumarray, the body of the sumarray() function,
 ** satisfies sumarray_spec, in the global context (Vprog,Gprog).
 **)
Lemma body_sumarray: semax_body Vprog Gprog f_sumarray sumarray_spec.
Proof.
start_function.  (* Always do this at the beginning of a semax_body proof *)
(* The next two lines do forward symbolic execution through
   the first two executable statements of the function body *)
forward.  (* s = 0; *)
forward_for_simple_bound size
  (EX i: Z,
   PROP  ((*0 <= i <= size*))
   LOCAL (temp _a a;
          (*temp _i (Vint (Int.repr i)); *)
          temp _n (Vint (Int.repr size));
          temp _s (Vint (Int.repr (sum_Z (sublist 0 i contents)))))
   SEP   (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a)).

* (* Prove that current precondition implies loop invariant *)
entailer!.
* (* Prove postcondition of loop body implies loop invariant *)
(* "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; *)
 (* 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. *)
entailer!.
 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 *.
reflexivity.
Qed.

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

Lemma Forall_sublist: forall {A} (P: A->Prop) lo hi (al: list A),
  Forall P al -> Forall P (sublist lo hi al).
Proof.
intros.
apply Forall_forall. rewrite -> Forall_forall in H.
intros.
apply H; auto.
apply sublist_In in H0. auto.
Qed.

Lemma split_array:
 forall {cs: compspecs} mid n (sh: Share.t) (t: type)
                            v (v1' v2': list (reptype t)) v1 v2 p,
    Zlength v1' = mid ->
    Zlength v2' = n-mid ->
    JMeq v (v1'++v2') ->
    JMeq v1 v1' ->
    JMeq v2 v2' ->
    data_at sh (tarray t n) v p =
    data_at sh (tarray t mid) v1  p *
    data_at sh (tarray t (n-mid)) v2
            (field_address0 (tarray t n) [ArraySubsc mid] p).
Proof.
intros.
pose proof (Zlength_nonneg v1').
pose proof (Zlength_nonneg v2').
apply split2_data_at_Tarray with (v1'++v2'); auto.
omega.
autorewrite with sublist; auto.
autorewrite with sublist; auto.
autorewrite with sublist; auto.
Qed.

Lemma body_main:  semax_body Vprog Gprog f_main main_spec.
Proof.
name four _four.
start_function.
change [Int.repr 1; Int.repr 2; Int.repr 3; Int.repr 4] with (map Int.repr four_contents).
set (contents :=  map Vint (map Int.repr four_contents)).
assert (Zlength contents = 4) by (subst contents; reflexivity).
assert_PROP (field_compatible (tarray tuint 4) [] four) by entailer!.
assert (Forall (fun x : Z => Int.min_signed <= x <= Int.max_signed) four_contents)
  by (repeat constructor; computable).
 rewrite <- (sublist_same 0 4 contents), (sublist_split 0 2 4)
    by now autorewrite with sublist.
erewrite (split_array 2 4); try apply JMeq_refl; auto; try omega; try reflexivity.
forward_call (*  s = sumarray(four+2,2); *)
  (field_address0 (tarray tuint 4) [ArraySubsc 2] four, Ews,
    sublist 2 4 four_contents,2).
+
 clear - GV. unfold gvar_denote, eval_var in *.
  destruct (Map.get (ve_of rho) _four) as [[? ?]|?]; try contradiction.
  destruct (ge_of rho _four); try contradiction. apply I.
+
 entailer!.
 rewrite field_address0_offset. reflexivity.
 auto with field_compatible.
+
 split. auto. computable.
+
  gather_SEP 1 2.
  erewrite <- (split_array 2 4); try apply JMeq_refl; auto; try omega; try reflexivity.
  rewrite <- !sublist_map. fold contents. autorewrite with sublist.
  rewrite (sublist_same 0 4) by auto.
  forward. (* return *)
Qed.

Existing Instance NullExtension.Espec.

Lemma prog_correct:
  semax_prog prog Vprog Gprog.
Proof.
prove_semax_prog.
semax_func_cons body_sumarray.
semax_func_cons body_main.
Qed.

(**  Here begins an alternate proof of the "for" loop.
  Instead of using forward_for_simple_bound, we use the
  general-case loop tactic, forward_for.

To understand this verification, let's take the program,

  int sumarray(int a[], int n) {
     int i,s,x;
     s=0;
     for (i=0; i<n; i++) {
       x = a[i];
       s += x;
     }
     return s;
  }

and annotate with assertions:

  int sumarray(int a[], int n) {
     int i,s,x;
     s=0;
     for (i=0; i<n; i++) {
       assert (sumarray_Inv(i));
       x = a[i];
       s += x;
       assert (sumarray_PostBody(i));
     }
     return s;
  }

The assertions are defined in these definitions:
*)
Definition sumarray_Inv a sh contents size i :=
   PROP  (0 <= i <= size)
   LOCAL (temp _a a;
          temp _i (Vint (Int.repr i));
          temp _n (Vint (Int.repr size));
          temp _s (Vint (Int.repr (sum_Z (sublist 0 i contents)))))
   SEP   (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a).

Definition sumarray_PostBody a sh contents size i :=
   PROP  (0 <= i < size)
   LOCAL (temp _a a;
          temp _i (Vint (Int.repr i));
          temp _n (Vint (Int.repr size));
          temp _s (Vint (Int.repr (sum_Z (sublist 0 (i+1) contents)))))
   SEP   (data_at sh (tarray tuint size) (map Vint (map Int.repr contents)) a).

(* . . . and now you can see how these assertions are used
   in the proof, using the semax_loop rule. *)

Lemma body_sumarray_alt: semax_body Vprog Gprog f_sumarray sumarray_spec.
Proof.
start_function.  (* Always do this at the beginning of a semax_body proof *)
forward.  (* s = 0; *)
forward_for (sumarray_Inv a sh contents size)
   (sumarray_PostBody a sh contents size).
* (* initializer establishes precondition *)
forward. (* i=0; *)
unfold sumarray_Inv. Exists 0. entailer!.
* (* loop-test expression typechecks *)
entailer!.
* (* loop body preserves invariant *)
rename a0 into i.
assert_PROP (size=Zlength contents)
  by (entailer!; autorewrite with sublist; auto).
forward. (* x = a[i]; *)
forward. (* s += x; *)
unfold sumarray_PostBody. Exists i.
entailer!.
     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.
* (* loop increment *)
forward. (* i++; *)
rename a0 into i.
Exists (i+1). entailer!.
* (* after the loop *)
forward. (* return s; *)
autorewrite with sublist in *.
autorewrite with sublist.
entailer!.
Qed.


Section WeekDay.
  Inductive day : Type :=
    | monday
    | tuesday
    | wednesday
    | thursday
    | friday
    | saturday
    | sunday.
  Definition next_weekday (d:day) : day :=
    match d with
    | monday => tuesday
    | tuesday => wednesday
    | wednesday => thursday
    | thursday => friday
    | friday => saturday
    | saturday => sunday
    | sunday => monday
    end.

  Compute (next_weekday friday).
End WeekDay.


Require Import Coq.Arith.Compare_dec.

Require Import
        Essentials.Facts_Tactics
        Essentials.Notations
        Essentials.Types.

Require Import Metrics.Mappings Metrics.Cauchy Metrics.Mappings Metrics.Banach.
Require Import Metrics.Complete_UltraMetric.

Require Import
        Categories.Category.Main
        Categories.Functor.Main
        Categories.Ext_Cons.Prod_Cat.Prod_Cat
        Categories.Basic_Cons.Terminal
        Categories.Limits.Limit
        Categories.KanExt.Local
.
Require Import
        MCat.MCat
        MCat.IncreasingCauchyTower.IncreasingCauchyTower
        MCat.IncreasingCauchyTower.Cone_Limit_Related_CoCone
.

Require Import MCat.MCat MCat.Opposite MCat.Product MCat.MFunc.

Require Import
        MCat.FixedPoint.BiAlgebra
        MCat.FixedPoint.FixedPoint_Initial_BiAlg
        MCat.FixedPoint.Existence
.

Section FixedPoint_Unique.
  Context {L : MLattice}
          {M : MCat L}
          (F : LocallyContractive (MCat_Prod (MCat_Op M) M) M)
          (MTerm : Terminal M)
          (starting_point :
             (
               (terminal MTerm)
                 –≻
                 (F _o (terminal MTerm, terminal MTerm))%object
             )%morphism
          )
  .

  (** Local abreviations for more readability. *)
  Local Notation inhM := (inhM MTerm).
  Local Notation inhF := (inhF F MTerm starting_point).

  Context
    {A : inhM}
    (Ai : (inhF _o (A, A) ≃≃ A ::> inhM)%isomorphism)
    {B : inhM}
    (Bi : (inhF _o (B, B) ≃≃ B ::> inhM)%isomorphism)
  .

  (** Fixed points are unique. *)
  Theorem FixedPoint_Unique : (A ≃≃ B ::> inhM)%isomorphism.
  Proof.
    apply (@BiAlg_iso_obj_iso _ _ (Ai_BiAlg _ _ _ Ai) (Ai_BiAlg _ _ _ Bi)).
    apply (@CoIso ((BiAlg_Cat inhF)^op)%category).
    apply (@Terminal_iso
             _
             (FixedPoint_Initial_BiAlg _ _ _ Ai)
             (FixedPoint_Initial_BiAlg _ _ _ Bi)
          ).
  Defined.

  Context (limits_of_ICT : ∀ ICT : IncreasingCauchyTower M, Limit (ICT_Func ICT)).

  (** Abbreviation for more readability. *)
  Local Notation FixedPoint := (FixedPoint limits_of_ICT F MTerm starting_point).
  Local Notation FixedPoint_as_limit := (FixedPoint_as_limit limits_of_ICT F MTerm starting_point).

  Definition Inhabitant_of_Existing_FixedPoint :
    (MTerm –≻ FixedPoint)%morphism
    :=
      Trans
        (cone_edge
           (CCIW_CoCone
              _
              _
              (TRCC_CoCone
                 _
                 _
                 (@Cone_Limit_Related_CoCone
                    _
                    _
                    _
                    _
                    (@Limit_is_Limit _ _ _ FixedPoint_as_limit)
                 )
              )
           )
        )
        0
  .

  Definition Existing_FixedPoint_in_inhM : inhM :=
    existT _ FixedPoint Inhabitant_of_Existing_FixedPoint.

End FixedPoint_Unique.


Require Import Logic.GeneralLogic.Base.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.
Require Import Logic.HoareLogic.ImperativeLanguage.
Require Import Logic.HoareLogic.BigStepSemantics.
Require Import Logic.HoareLogic.TraceSemantics.
Require Import Logic.HoareLogic.HoareTriple_BigStepSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelSingleNotation.
Import KripkeModelNotation_Intuitionistic.

Definition guarded_triple_partial_valid
           {L: Language}
           {P: ProgrammingLanguage}
           {MD: Model}
           {J: Join model}
           {R: Relation model}
           {Res: Resource}
           {Ac: Action}
           {Acr: Action_resource Ac Res}
           {TS: TraceSemantics P (resources * model) Ac}
           {SM: Semantics L MD}
           (Inv: (resource * (model -> Prop)) -> Prop)
           (Pre: expr)
           (c: cmd)
           (Post: expr):
  Prop :=
  @triple_partial_valid L _ MD (ThreadLocal_BSS TS Inv) SM Pre c Post.


(* Adam Chlipalas heterogeneous list implementation (magic inside)
 * Useful for De Bruijn indices
 *)

Section hlist.
  Variable A : Type.
  Variable B : A -> Type.

  Inductive hlist : list A -> Type :=
  | HNil : hlist nil
  | HCons : forall (x : A) (ls : list A), B x -> hlist ls -> hlist (x :: ls).

  Variable elm : A.

  Inductive member : list A -> Type :=
  | HFirst : forall ls, member (elm :: ls)
  | HNext : forall x ls, member ls -> member (x :: ls).

  Fixpoint hget ls (mls : hlist ls) : member ls -> B elm :=
    match mls with
    | HNil
      => fun mem =>
           match mem in member ls'
                 return (match ls' with
                         | nil => B elm
                         | _ :: _ => unit
                         end) with
           | HFirst _ => tt
           | HNext _ _ _ => tt
           end
    | HCons _ _ x mls'
      => fun mem =>
           match mem in member ls'
                 return (match ls' with
                         | nil => Empty_set
                         | x' :: ls'' =>
                           B x' -> (member ls'' -> B elm)
                           -> B elm
                         end) with
           | HFirst _ => fun x _ => x
           | HNext _ _ mem' => fun _ get_mls' => get_mls' mem'
           end x (hget mls')
    end.

End hlist.

Arguments HNil [A B].
Arguments HCons [A B x ls].

Arguments HFirst [A elm ls].
Arguments HNext [A elm x ls].


Require Import Coq.Bool.Bool.

Require Import SpecCert.Equality.
Require Import SpecCert.Cache.Cache_def.
Require Import SpecCert.Address.
Require Import SpecCert.Utils.
Require Import SpecCert.Map.

Definition cache_hit
           {S     :Type}
           (cache :Cache S)
           (pa    :PhysicalAddress)
           :Prop :=
  eq pa (tag (find_in_map cache (phys_to_index pa))).

Definition cache_hit_dec
           {S     :Type}
           (cache :Cache S)
           (pa:PhysicalAddress)
           : { cache_hit cache pa } + { ~ cache_hit cache pa } :=
  eq_dec pa (tag (find_in_map cache (phys_to_index pa))).

Definition cache_location_is_dirty
           {S     :Type}
           (cache :Cache S)
           (pa    :PhysicalAddress) :=
  dirty (find_in_map cache (phys_to_index pa)) = true.

Definition cache_location_is_dirty_dec
           {S     :Type}
           (cache :Cache S)
           (pa    :PhysicalAddress)
  : { cache_location_is_dirty cache pa } + { ~ cache_location_is_dirty cache pa } :=
  bool_dec (dirty (find_in_map cache (phys_to_index pa))) true.

Definition cache_is_well_formed
           {S     :Type}
           (cache :Cache S) :=
  forall pa:PhysicalAddress,
    phys_to_index pa = phys_to_index (tag (find_in_map cache (phys_to_index pa))).


Require Import Coq.ZArith.ZArith.
Require Import riscv.Spec.Decode.
Require Import riscv.Utility.Encode.
Require Import riscv.Utility.Utility.
Require Import riscv.Utility.Tactics.
Require Import coqutil.Z.prove_Zeq_bitwise.
Require Import coqutil.Z.Lia.

Local Open Scope bool_scope.
Local Open Scope Z_scope.

Lemma encode_Fence_bitSlice_idemp: forall opcode funct3 z z0 z1 z2 z3,
    bitSlice (encode_Fence opcode z z0 funct3 z1 z2 z3) 0 32 =
              encode_Fence opcode z z0 funct3 z1 z2 z3.
Proof. intros. unfold encode_Fence. prove_Zeq_bitwise. Qed.

Lemma encode_Invalid_bitSlice_idemp: forall z,
     bitSlice (encode_Invalid z) 0 32 = encode_Invalid z.
Proof. intros. unfold encode_Invalid. prove_Zeq_bitwise. Qed.

Lemma encode_I_bitSlice_idemp: forall opcode r r0 funct3 z,
     bitSlice (encode_I opcode r r0 funct3 z) 0 32 = encode_I opcode r r0 funct3 z.
Proof. intros. unfold encode_I. prove_Zeq_bitwise. Qed.

Lemma encode_I_shift_57_bitSlice_idemp: forall opcode r r0 z funct3 funct7,
    bitSlice (encode_I_shift_57 opcode r r0 z funct3 funct7) 0 32 =
              encode_I_shift_57 opcode r r0 z funct3 funct7.
Proof. intros. unfold encode_I_shift_57. prove_Zeq_bitwise. Qed.

Lemma encode_I_shift_66_bitSlice_idemp: forall opcode r r0 z funct3 funct6,
    bitSlice (encode_I_shift_66 opcode r r0 z funct3 funct6) 0 32 =
              encode_I_shift_66 opcode r r0 z funct3 funct6.
Proof. intros. unfold encode_I_shift_66. prove_Zeq_bitwise. Qed.

Lemma encode_I_system_bitSlice_idemp: forall opcode r r0 funct3 z,
    bitSlice (encode_I_system opcode r r0 funct3 z) 0 32 =
              encode_I_system opcode r r0 funct3 z.
Proof. intros. unfold encode_I_system. prove_Zeq_bitwise. Qed.

Lemma encode_R_atomic_bitSlice_idemp: forall opcode r r0 r1 funct3 z funct5,
    bitSlice (encode_R_atomic opcode r r0 r1 funct3 z funct5) 0 32 =
              encode_R_atomic opcode r r0 r1 funct3 z funct5.
Proof. intros. unfold encode_R_atomic. prove_Zeq_bitwise. Qed.

Lemma encode_R_bitSlice_idemp: forall opcode z r r0 funct3 funct7,
    bitSlice (encode_R opcode z r r0 funct3 funct7) 0 32 =
              encode_R opcode z r r0 funct3 funct7.
Proof. intros. unfold encode_R. prove_Zeq_bitwise. Qed.

Lemma encode_SB_bitSlice_idemp: forall opcode r r0 funct3 z,
    bitSlice (encode_SB opcode r r0 funct3 z) 0 32 =
              encode_SB opcode r r0 funct3 z.
Proof. intros. unfold encode_SB. prove_Zeq_bitwise. Qed.

Lemma encode_S_bitSlice_idemp: forall opcode r r0 funct3 z,
    bitSlice (encode_S opcode r r0 funct3 z) 0 32 =
              encode_S opcode r r0 funct3 z.
Proof. intros. unfold encode_S. prove_Zeq_bitwise. Qed.

Lemma encode_UJ_bitSlice_idemp: forall opcode r z,
    bitSlice (encode_UJ opcode r z) 0 32 =
              encode_UJ opcode r z.
Proof. intros. unfold encode_UJ. prove_Zeq_bitwise. Qed.

Lemma encode_U_bitSlice_idemp: forall opcode r z,
    bitSlice (encode_U opcode r z) 0 32 =
              encode_U opcode r z.
Proof. intros. unfold encode_U. prove_Zeq_bitwise. Qed.

#[global] Hint Rewrite
  encode_Fence_bitSlice_idemp
  encode_Invalid_bitSlice_idemp
  encode_I_bitSlice_idemp
  encode_I_shift_57_bitSlice_idemp
  encode_I_shift_66_bitSlice_idemp
  encode_I_system_bitSlice_idemp
  encode_R_atomic_bitSlice_idemp
  encode_R_bitSlice_idemp
  encode_SB_bitSlice_idemp
  encode_S_bitSlice_idemp
  encode_UJ_bitSlice_idemp
  encode_U_bitSlice_idemp
: encode_bitSlice_idemp.

Lemma encode_bitSlice_idemp: forall (i: Instruction),
    bitSlice (encode i) 0 32 = encode i.
Proof.
  intros.
  unfold encode.
  repeat autounfold with mappers.
  destruct i as [i|i|i|i|i|i|i|i|i|i]; [destruct i..|];
    autorewrite with encode_bitSlice_idemp;
    reflexivity.
Qed.

Lemma encode_range: forall (i: Instruction),
    0 <= encode i < 2 ^ 32.
Proof.
  intros.
  rewrite <- encode_bitSlice_idemp.
  apply bitSlice_range.
  blia.
Qed.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__3__6b.
Require Export lemma__betweennotequal.
Require Export lemma__collinear4.
Require Export lemma__collinear5.
Require Export lemma__collinearbetween.
Require Export lemma__collinearorder.
Require Export lemma__extension.
Require Export lemma__inequalitysymmetric.
Require Export lemma__paralleldef2B.
Require Export lemma__parallelsymmetric.
Require Export lemma__planeseparation.
Require Export lemma__samesidesymmetric.
Require Export logic.
Definition lemma__diagonalsmeet : forall A B C D, (euclidean__defs.PG A B C D) -> (exists X, (euclidean__axioms.BetS A X C) /\ (euclidean__axioms.BetS B X D)).
Proof.
intro A.
intro B.
intro C.
intro D.
intro H.
assert (* Cut *) ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H0.
- assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H0 by exact H.
assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as __TmpHyp by exact H0.
destruct __TmpHyp as [H1 H2].
split.
-- exact H1.
-- exact H2.
- assert (* Cut *) (exists a b c d m, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B a) /\ ((euclidean__axioms.Col A B b) /\ ((euclidean__axioms.neq a b) /\ ((euclidean__axioms.Col C D c) /\ ((euclidean__axioms.Col C D d) /\ ((euclidean__axioms.neq c d) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS a m d) /\ (euclidean__axioms.BetS c m b))))))))))) as H1.
-- destruct H0 as [H1 H2].
exact H1.
-- destruct H1 as [a H2].
destruct H2 as [b H3].
destruct H3 as [c H4].
destruct H4 as [d H5].
destruct H5 as [m H6].
destruct H6 as [H7 H8].
destruct H8 as [H9 H10].
destruct H10 as [H11 H12].
destruct H12 as [H13 H14].
destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
destruct H24 as [H25 H26].
destruct H0 as [H27 H28].
assert (* Cut *) (euclidean__defs.Par C D A B) as H29.
--- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A B C D H27).
--- assert (* Cut *) (euclidean__defs.TP C D A B) as H30.
---- apply (@lemma__paralleldef2B.lemma__paralleldef2B C D A B H29).
---- assert (* Cut *) (euclidean__defs.OS A B C D) as H31.
----- destruct H30 as [H31 H32].
destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H36.
----- assert (* Cut *) (D = D) as H32.
------ apply (@logic.eq__refl Point D).
------ assert (* Cut *) (euclidean__axioms.Col D C D) as H33.
------- right.
left.
exact H32.
------- assert (* Cut *) (~(A = D)) as H34.
-------- intro H34.
assert (* Cut *) (euclidean__axioms.Col D C A) as H35.
--------- apply (@eq__ind__r euclidean__axioms.Point D (fun A0 => (euclidean__defs.PG A0 B C D) -> ((euclidean__defs.Par A0 B C D) -> ((euclidean__defs.Par A0 D B C) -> ((euclidean__axioms.neq A0 B) -> ((euclidean__axioms.Col A0 B a) -> ((euclidean__axioms.Col A0 B b) -> ((~(euclidean__defs.Meet A0 B C D)) -> ((euclidean__defs.Par C D A0 B) -> ((euclidean__defs.TP C D A0 B) -> ((euclidean__defs.OS A0 B C D) -> (euclidean__axioms.Col D C A0)))))))))))) with (x := A).
----------intro H35.
intro H36.
intro H37.
intro H38.
intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
exact H33.

---------- exact H34.
---------- exact H.
---------- exact H27.
---------- exact H28.
---------- exact H7.
---------- exact H11.
---------- exact H13.
---------- exact H23.
---------- exact H29.
---------- exact H30.
---------- exact H31.
--------- assert (* Cut *) (euclidean__axioms.Col C D A) as H36.
---------- assert (* Cut *) ((euclidean__axioms.Col C D A) /\ ((euclidean__axioms.Col C A D) /\ ((euclidean__axioms.Col A D C) /\ ((euclidean__axioms.Col D A C) /\ (euclidean__axioms.Col A C D))))) as H36.
----------- apply (@lemma__collinearorder.lemma__collinearorder D C A H35).
----------- destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
exact H37.
---------- assert (* Cut *) (A = A) as H37.
----------- apply (@eq__ind__r euclidean__axioms.Point D (fun A0 => (euclidean__defs.PG A0 B C D) -> ((euclidean__defs.Par A0 B C D) -> ((euclidean__defs.Par A0 D B C) -> ((euclidean__axioms.neq A0 B) -> ((euclidean__axioms.Col A0 B a) -> ((euclidean__axioms.Col A0 B b) -> ((~(euclidean__defs.Meet A0 B C D)) -> ((euclidean__defs.Par C D A0 B) -> ((euclidean__defs.TP C D A0 B) -> ((euclidean__defs.OS A0 B C D) -> ((euclidean__axioms.Col D C A0) -> ((euclidean__axioms.Col C D A0) -> (A0 = A0)))))))))))))) with (x := A).
------------intro H37.
intro H38.
intro H39.
intro H40.
intro H41.
intro H42.
intro H43.
intro H44.
intro H45.
intro H46.
intro H47.
intro H48.
exact H32.

------------ exact H34.
------------ exact H.
------------ exact H27.
------------ exact H28.
------------ exact H7.
------------ exact H11.
------------ exact H13.
------------ exact H23.
------------ exact H29.
------------ exact H30.
------------ exact H31.
------------ exact H35.
------------ exact H36.
----------- assert (* Cut *) (euclidean__axioms.Col A B A) as H38.
------------ right.
left.
exact H37.
------------ assert (* Cut *) (euclidean__defs.Meet A B C D) as H39.
------------- exists A.
split.
-------------- exact H7.
-------------- split.
--------------- exact H9.
--------------- split.
---------------- exact H38.
---------------- exact H36.
------------- apply (@H23 H39).
-------- assert (* Cut *) (exists E, (euclidean__axioms.BetS A D E) /\ (euclidean__axioms.Cong D E A D)) as H35.
--------- apply (@lemma__extension.lemma__extension A D A D H34 H34).
--------- destruct H35 as [E H36].
destruct H36 as [H37 H38].
assert (* Cut *) (~(euclidean__axioms.Col D C A)) as H39.
---------- intro H39.
assert (* Cut *) (A = A) as H40.
----------- apply (@logic.eq__refl Point A).
----------- assert (* Cut *) (euclidean__axioms.Col A B A) as H41.
------------ right.
left.
exact H40.
------------ assert (* Cut *) (euclidean__axioms.Col C D A) as H42.
------------- assert (* Cut *) ((euclidean__axioms.Col C D A) /\ ((euclidean__axioms.Col C A D) /\ ((euclidean__axioms.Col A D C) /\ ((euclidean__axioms.Col D A C) /\ (euclidean__axioms.Col A C D))))) as H42.
-------------- apply (@lemma__collinearorder.lemma__collinearorder D C A H39).
-------------- destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
exact H43.
------------- assert (* Cut *) (euclidean__defs.Meet A B C D) as H43.
-------------- exists A.
split.
--------------- exact H7.
--------------- split.
---------------- exact H9.
---------------- split.
----------------- exact H41.
----------------- exact H42.
-------------- assert (~(euclidean__defs.Meet A B C D)) as H44 by exact H23.
apply (@H23 H43).
---------- assert (* Cut *) (euclidean__axioms.TS A D C E) as H40.
----------- exists D.
split.
------------ exact H37.
------------ split.
------------- exact H33.
------------- apply (@euclidean__tactics.nCol__notCol D C A H39).
----------- assert (* Cut *) (euclidean__defs.OS B A D C) as H41.
------------ assert (* Cut *) ((euclidean__defs.OS B A C D) /\ ((euclidean__defs.OS A B D C) /\ (euclidean__defs.OS B A D C))) as H41.
------------- apply (@lemma__samesidesymmetric.lemma__samesidesymmetric C D A B H31).
------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
exact H45.
------------ assert (* Cut *) (euclidean__axioms.TS B D C E) as H42.
------------- apply (@lemma__planeseparation.lemma__planeseparation D C B A E H41 H40).
------------- assert (exists F, (euclidean__axioms.BetS B F E) /\ ((euclidean__axioms.Col D C F) /\ (euclidean__axioms.nCol D C B))) as H43 by exact H42.
destruct H43 as [F H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
assert (* Cut *) (euclidean__axioms.BetS E F B) as H49.
-------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B F E H45).
-------------- assert (* Cut *) (euclidean__axioms.BetS E D A) as H50.
--------------- apply (@euclidean__axioms.axiom__betweennesssymmetry A D E H37).
--------------- assert (* Cut *) (euclidean__axioms.Col E D A) as H51.
---------------- right.
right.
right.
right.
left.
exact H50.
---------------- assert (* Cut *) (euclidean__axioms.neq E D) as H52.
----------------- assert (* Cut *) ((euclidean__axioms.neq D A) /\ ((euclidean__axioms.neq E D) /\ (euclidean__axioms.neq E A))) as H52.
------------------ apply (@lemma__betweennotequal.lemma__betweennotequal E D A H50).
------------------ destruct H52 as [H53 H54].
destruct H54 as [H55 H56].
exact H55.
----------------- assert (* Cut *) (euclidean__axioms.neq E A) as H53.
------------------ assert (* Cut *) ((euclidean__axioms.neq D A) /\ ((euclidean__axioms.neq E D) /\ (euclidean__axioms.neq E A))) as H53.
------------------- apply (@lemma__betweennotequal.lemma__betweennotequal E D A H50).
------------------- destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
exact H57.
------------------ assert (* Cut *) (~(euclidean__defs.Meet A D B C)) as H54.
------------------- assert (exists U V u v X, (euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.Col C D U) /\ ((euclidean__axioms.Col C D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col A B u) /\ ((euclidean__axioms.Col A B v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet C D A B)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H54 by exact H29.
assert (exists U V u v X, (euclidean__axioms.neq C D) /\ ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.Col C D U) /\ ((euclidean__axioms.Col C D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col A B u) /\ ((euclidean__axioms.Col A B v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet C D A B)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp by exact H54.
destruct __TmpHyp as [x H55].
destruct H55 as [x0 H56].
destruct H56 as [x1 H57].
destruct H57 as [x2 H58].
destruct H58 as [x3 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
destruct H77 as [H78 H79].
assert (exists U V u v X, (euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.Col A D U) /\ ((euclidean__axioms.Col A D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B C u) /\ ((euclidean__axioms.Col B C v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A D B C)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H80 by exact H28.
assert (exists U V u v X, (euclidean__axioms.neq A D) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.Col A D U) /\ ((euclidean__axioms.Col A D V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col B C u) /\ ((euclidean__axioms.Col B C v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A D B C)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp0 by exact H80.
destruct __TmpHyp0 as [x4 H81].
destruct H81 as [x5 H82].
destruct H82 as [x6 H83].
destruct H83 as [x7 H84].
destruct H84 as [x8 H85].
destruct H85 as [H86 H87].
destruct H87 as [H88 H89].
destruct H89 as [H90 H91].
destruct H91 as [H92 H93].
destruct H93 as [H94 H95].
destruct H95 as [H96 H97].
destruct H97 as [H98 H99].
destruct H99 as [H100 H101].
destruct H101 as [H102 H103].
destruct H103 as [H104 H105].
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as H106 by exact H27.
assert (exists U V u v X, (euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq C D) /\ ((euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.neq U V) /\ ((euclidean__axioms.Col C D u) /\ ((euclidean__axioms.Col C D v) /\ ((euclidean__axioms.neq u v) /\ ((~(euclidean__defs.Meet A B C D)) /\ ((euclidean__axioms.BetS U X v) /\ (euclidean__axioms.BetS u X V))))))))))) as __TmpHyp1 by exact H106.
destruct __TmpHyp1 as [x9 H107].
destruct H107 as [x10 H108].
destruct H108 as [x11 H109].
destruct H109 as [x12 H110].
destruct H110 as [x13 H111].
destruct H111 as [H112 H113].
destruct H113 as [H114 H115].
destruct H115 as [H116 H117].
destruct H117 as [H118 H119].
destruct H119 as [H120 H121].
destruct H121 as [H122 H123].
destruct H123 as [H124 H125].
destruct H125 as [H126 H127].
destruct H127 as [H128 H129].
destruct H129 as [H130 H131].
exact H102.
------------------- assert (* Cut *) (~(B = C)) as H55.
-------------------- intro H55.
assert (* Cut *) (euclidean__axioms.Col D B C) as H56.
--------------------- right.
right.
left.
exact H55.
--------------------- assert (* Cut *) (euclidean__axioms.Col D C B) as H57.
---------------------- assert (* Cut *) ((euclidean__axioms.Col B D C) /\ ((euclidean__axioms.Col B C D) /\ ((euclidean__axioms.Col C D B) /\ ((euclidean__axioms.Col D C B) /\ (euclidean__axioms.Col C B D))))) as H57.
----------------------- apply (@lemma__collinearorder.lemma__collinearorder D B C H56).
----------------------- destruct H57 as [H58 H59].
destruct H59 as [H60 H61].
destruct H61 as [H62 H63].
destruct H63 as [H64 H65].
exact H64.
---------------------- apply (@H39).
-----------------------apply (@euclidean__tactics.not__nCol__Col D C A).
------------------------intro H58.
apply (@euclidean__tactics.Col__nCol__False D C B H48 H57).

-------------------- assert (* Cut *) (exists S, (euclidean__axioms.BetS B C S) /\ (euclidean__axioms.Cong C S B C)) as H56.
--------------------- apply (@lemma__extension.lemma__extension B C B C H55 H55).
--------------------- destruct H56 as [S H57].
destruct H57 as [H58 H59].
assert (* Cut *) (euclidean__axioms.BetS S C B) as H60.
---------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B C S H58).
---------------------- assert (* Cut *) (euclidean__axioms.Col S C B) as H61.
----------------------- right.
right.
right.
right.
left.
exact H60.
----------------------- assert (* Cut *) (euclidean__axioms.neq S B) as H62.
------------------------ assert (* Cut *) ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq S C) /\ (euclidean__axioms.neq S B))) as H62.
------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal S C B H60).
------------------------- destruct H62 as [H63 H64].
destruct H64 as [H65 H66].
exact H66.
------------------------ assert (* Cut *) (euclidean__axioms.neq C B) as H63.
------------------------- assert (* Cut *) ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq S C) /\ (euclidean__axioms.neq S B))) as H63.
-------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal S C B H60).
-------------------------- destruct H63 as [H64 H65].
destruct H65 as [H66 H67].
exact H64.
------------------------- assert (* Cut *) (~(euclidean__defs.Meet E A S B)) as H64.
-------------------------- intro H64.
assert (exists R, (euclidean__axioms.neq E A) /\ ((euclidean__axioms.neq S B) /\ ((euclidean__axioms.Col E A R) /\ (euclidean__axioms.Col S B R)))) as H65 by exact H64.
destruct H65 as [R H66].
destruct H66 as [H67 H68].
destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
assert (* Cut *) (euclidean__axioms.Col B C S) as H73.
--------------------------- right.
right.
right.
right.
left.
exact H58.
--------------------------- assert (* Cut *) (euclidean__axioms.Col S B C) as H74.
---------------------------- assert (* Cut *) ((euclidean__axioms.Col C B S) /\ ((euclidean__axioms.Col C S B) /\ ((euclidean__axioms.Col S B C) /\ ((euclidean__axioms.Col B S C) /\ (euclidean__axioms.Col S C B))))) as H74.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C S H73).
----------------------------- destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
exact H79.
---------------------------- assert (* Cut *) (euclidean__axioms.Col B C R) as H75.
----------------------------- assert (* Cut *) ((B = R) \/ (euclidean__axioms.neq B R)) as H75.
------------------------------ apply (@euclidean__tactics.eq__or__neq B R).
------------------------------ assert ((B = R) \/ (euclidean__axioms.neq B R)) as H76 by exact H75.
assert ((B = R) \/ (euclidean__axioms.neq B R)) as __TmpHyp by exact H76.
destruct __TmpHyp as [H77|H77].
------------------------------- assert (* Cut *) (euclidean__axioms.Col B C R) as H78.
-------------------------------- right.
left.
exact H77.
-------------------------------- exact H78.
------------------------------- assert (* Cut *) (euclidean__axioms.Col B R C) as H78.
-------------------------------- apply (@euclidean__tactics.not__nCol__Col B R C).
---------------------------------intro H78.
apply (@euclidean__tactics.Col__nCol__False B R C H78).
----------------------------------apply (@lemma__collinear4.lemma__collinear4 S B R C H72 H74 H69).

-------------------------------- assert (* Cut *) (euclidean__axioms.Col B C R) as H79.
--------------------------------- assert (* Cut *) ((euclidean__axioms.Col R B C) /\ ((euclidean__axioms.Col R C B) /\ ((euclidean__axioms.Col C B R) /\ ((euclidean__axioms.Col B C R) /\ (euclidean__axioms.Col C R B))))) as H79.
---------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B R C H78).
---------------------------------- destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
exact H86.
--------------------------------- exact H79.
----------------------------- assert (* Cut *) (euclidean__axioms.Col A D E) as H76.
------------------------------ right.
right.
right.
right.
left.
exact H37.
------------------------------ assert (* Cut *) (euclidean__axioms.Col E A D) as H77.
------------------------------- assert (* Cut *) ((euclidean__axioms.Col D A E) /\ ((euclidean__axioms.Col D E A) /\ ((euclidean__axioms.Col E A D) /\ ((euclidean__axioms.Col A E D) /\ (euclidean__axioms.Col E D A))))) as H77.
-------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A D E H76).
-------------------------------- destruct H77 as [H78 H79].
destruct H79 as [H80 H81].
destruct H81 as [H82 H83].
destruct H83 as [H84 H85].
exact H82.
------------------------------- assert (* Cut *) (euclidean__axioms.neq A D) as H78.
-------------------------------- assert (* Cut *) ((euclidean__axioms.neq C B) /\ ((euclidean__axioms.neq S C) /\ (euclidean__axioms.neq S B))) as H78.
--------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal S C B H60).
--------------------------------- destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
exact H34.
-------------------------------- assert (* Cut *) (euclidean__axioms.Col A D R) as H79.
--------------------------------- apply (@euclidean__tactics.not__nCol__Col A D R).
----------------------------------intro H79.
apply (@euclidean__tactics.Col__nCol__False A D R H79).
-----------------------------------apply (@lemma__collinear4.lemma__collinear4 E A D R H77 H71 H67).

--------------------------------- assert (* Cut *) (euclidean__defs.Meet A D B C) as H80.
---------------------------------- exists R.
split.
----------------------------------- exact H78.
----------------------------------- split.
------------------------------------ exact H55.
------------------------------------ split.
------------------------------------- exact H79.
------------------------------------- exact H75.
---------------------------------- apply (@H39).
-----------------------------------apply (@euclidean__tactics.not__nCol__Col D C A).
------------------------------------intro H81.
apply (@H54 H80).

-------------------------- assert (* Cut *) (euclidean__axioms.Col D F C) as H65.
--------------------------- assert (* Cut *) ((euclidean__axioms.Col C D F) /\ ((euclidean__axioms.Col C F D) /\ ((euclidean__axioms.Col F D C) /\ ((euclidean__axioms.Col D F C) /\ (euclidean__axioms.Col F C D))))) as H65.
---------------------------- apply (@lemma__collinearorder.lemma__collinearorder D C F H47).
---------------------------- destruct H65 as [H66 H67].
destruct H67 as [H68 H69].
destruct H69 as [H70 H71].
destruct H71 as [H72 H73].
exact H72.
--------------------------- assert (* Cut *) (euclidean__axioms.BetS D F C) as H66.
---------------------------- apply (@lemma__collinearbetween.lemma__collinearbetween E A S B D C F H51 H61 H53 H62 H52 H63 H64 H49 H47).
---------------------------- assert (* Cut *) (euclidean__axioms.BetS C F D) as H67.
----------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry D F C H66).
----------------------------- assert (* Cut *) (euclidean__axioms.neq A E) as H68.
------------------------------ assert (* Cut *) ((euclidean__axioms.neq D E) /\ ((euclidean__axioms.neq A D) /\ (euclidean__axioms.neq A E))) as H68.
------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A D E H37).
------------------------------- destruct H68 as [H69 H70].
destruct H70 as [H71 H72].
exact H72.
------------------------------ assert (euclidean__axioms.neq E A) as H69 by exact H53.
assert (* Cut *) (euclidean__axioms.neq B S) as H70.
------------------------------- assert (* Cut *) ((euclidean__axioms.neq C S) /\ ((euclidean__axioms.neq B C) /\ (euclidean__axioms.neq B S))) as H70.
-------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal B C S H58).
-------------------------------- destruct H70 as [H71 H72].
destruct H72 as [H73 H74].
exact H74.
------------------------------- assert (euclidean__axioms.neq S B) as H71 by exact H62.
assert (* Cut *) (~(euclidean__axioms.Col E A C)) as H72.
-------------------------------- intro H72.
assert (* Cut *) (euclidean__axioms.Col B C S) as H73.
--------------------------------- right.
right.
right.
right.
left.
exact H58.
--------------------------------- assert (* Cut *) (euclidean__axioms.Col S B C) as H74.
---------------------------------- assert (* Cut *) ((euclidean__axioms.Col C B S) /\ ((euclidean__axioms.Col C S B) /\ ((euclidean__axioms.Col S B C) /\ ((euclidean__axioms.Col B S C) /\ (euclidean__axioms.Col S C B))))) as H74.
----------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C S H73).
----------------------------------- destruct H74 as [H75 H76].
destruct H76 as [H77 H78].
destruct H78 as [H79 H80].
destruct H80 as [H81 H82].
exact H79.
---------------------------------- assert (* Cut *) (euclidean__defs.Meet E A S B) as H75.
----------------------------------- exists C.
split.
------------------------------------ exact H69.
------------------------------------ split.
------------------------------------- exact H71.
------------------------------------- split.
-------------------------------------- exact H72.
-------------------------------------- exact H74.
----------------------------------- apply (@H39).
------------------------------------apply (@euclidean__tactics.not__nCol__Col D C A).
-------------------------------------intro H76.
apply (@H64 H75).

-------------------------------- assert (* Cut *) (exists H73, (euclidean__axioms.BetS C H73 A) /\ (euclidean__axioms.BetS E F H73)) as H73.
--------------------------------- apply (@euclidean__axioms.postulate__Pasch__outer C E D F A H67 H50).
----------------------------------apply (@euclidean__tactics.nCol__notCol E A C H72).

--------------------------------- destruct H73 as [H74 H75].
destruct H75 as [H76 H77].
assert (* Cut *) (euclidean__axioms.Col E F H74) as H78.
---------------------------------- right.
right.
right.
right.
left.
exact H77.
---------------------------------- assert (* Cut *) (euclidean__axioms.Col E F B) as H79.
----------------------------------- right.
right.
right.
right.
left.
exact H49.
----------------------------------- assert (* Cut *) (euclidean__axioms.neq E F) as H80.
------------------------------------ assert (* Cut *) ((euclidean__axioms.neq F H74) /\ ((euclidean__axioms.neq E F) /\ (euclidean__axioms.neq E H74))) as H80.
------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal E F H74 H77).
------------------------------------- destruct H80 as [H81 H82].
destruct H82 as [H83 H84].
exact H83.
------------------------------------ assert (* Cut *) (euclidean__axioms.neq F E) as H81.
------------------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric E F H80).
------------------------------------- assert (* Cut *) (euclidean__axioms.Col F E H74) as H82.
-------------------------------------- assert (* Cut *) ((euclidean__axioms.Col F E H74) /\ ((euclidean__axioms.Col F H74 E) /\ ((euclidean__axioms.Col H74 E F) /\ ((euclidean__axioms.Col E H74 F) /\ (euclidean__axioms.Col H74 F E))))) as H82.
--------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder E F H74 H78).
--------------------------------------- destruct H82 as [H83 H84].
destruct H84 as [H85 H86].
destruct H86 as [H87 H88].
destruct H88 as [H89 H90].
exact H83.
-------------------------------------- assert (* Cut *) (euclidean__axioms.Col F E B) as H83.
--------------------------------------- assert (* Cut *) ((euclidean__axioms.Col F E B) /\ ((euclidean__axioms.Col F B E) /\ ((euclidean__axioms.Col B E F) /\ ((euclidean__axioms.Col E B F) /\ (euclidean__axioms.Col B F E))))) as H83.
---------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder E F B H79).
---------------------------------------- destruct H83 as [H84 H85].
destruct H85 as [H86 H87].
destruct H87 as [H88 H89].
destruct H89 as [H90 H91].
exact H84.
--------------------------------------- assert (* Cut *) (euclidean__axioms.Col E H74 B) as H84.
---------------------------------------- apply (@euclidean__tactics.not__nCol__Col E H74 B).
-----------------------------------------intro H84.
apply (@euclidean__tactics.Col__nCol__False E H74 B H84).
------------------------------------------apply (@lemma__collinear4.lemma__collinear4 F E H74 B H82 H83 H81).

---------------------------------------- assert (* Cut *) (euclidean__axioms.BetS A H74 C) as H85.
----------------------------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry C H74 A H76).
----------------------------------------- assert (* Cut *) (exists R, (euclidean__axioms.BetS A E R) /\ (euclidean__axioms.Cong E R A E)) as H86.
------------------------------------------ apply (@lemma__extension.lemma__extension A E A E H68 H68).
------------------------------------------ destruct H86 as [R H87].
destruct H87 as [H88 H89].
assert (* Cut *) (euclidean__axioms.Col A E R) as H90.
------------------------------------------- right.
right.
right.
right.
left.
exact H88.
------------------------------------------- assert (* Cut *) (euclidean__axioms.neq A E) as H91.
-------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq E R) /\ ((euclidean__axioms.neq A E) /\ (euclidean__axioms.neq A R))) as H91.
--------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A E R H88).
--------------------------------------------- destruct H91 as [H92 H93].
destruct H93 as [H94 H95].
exact H94.
-------------------------------------------- assert (* Cut *) (euclidean__axioms.neq A R) as H92.
--------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq E R) /\ ((euclidean__axioms.neq A E) /\ (euclidean__axioms.neq A R))) as H92.
---------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal A E R H88).
---------------------------------------------- destruct H92 as [H93 H94].
destruct H94 as [H95 H96].
exact H96.
--------------------------------------------- assert (euclidean__axioms.neq C B) as H93 by exact H63.
assert (* Cut *) (exists T, (euclidean__axioms.BetS C B T) /\ (euclidean__axioms.Cong B T C B)) as H94.
---------------------------------------------- apply (@lemma__extension.lemma__extension C B C B H93 H93).
---------------------------------------------- destruct H94 as [T H95].
destruct H95 as [H96 H97].
assert (* Cut *) (~(euclidean__defs.Meet A R T C)) as H98.
----------------------------------------------- intro H98.
assert (exists p, (euclidean__axioms.neq A R) /\ ((euclidean__axioms.neq T C) /\ ((euclidean__axioms.Col A R p) /\ (euclidean__axioms.Col T C p)))) as H99 by exact H98.
destruct H99 as [p H100].
destruct H100 as [H101 H102].
destruct H102 as [H103 H104].
destruct H104 as [H105 H106].
assert (euclidean__axioms.Col A E R) as H107 by exact H90.
assert (* Cut *) (euclidean__axioms.Col C B T) as H108.
------------------------------------------------ right.
right.
right.
right.
left.
exact H96.
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col A D E) as H109.
------------------------------------------------- right.
right.
right.
right.
left.
exact H37.
------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col R A p) as H110.
-------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col R A p) /\ ((euclidean__axioms.Col R p A) /\ ((euclidean__axioms.Col p A R) /\ ((euclidean__axioms.Col A p R) /\ (euclidean__axioms.Col p R A))))) as H110.
--------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A R p H105).
--------------------------------------------------- destruct H110 as [H111 H112].
destruct H112 as [H113 H114].
destruct H114 as [H115 H116].
destruct H116 as [H117 H118].
exact H111.
-------------------------------------------------- assert (* Cut *) (A = A) as H111.
--------------------------------------------------- apply (@logic.eq__refl Point A).
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A R A) as H112.
---------------------------------------------------- right.
left.
exact H111.
---------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col E A D) as H113.
----------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col D A E) /\ ((euclidean__axioms.Col D E A) /\ ((euclidean__axioms.Col E A D) /\ ((euclidean__axioms.Col A E D) /\ (euclidean__axioms.Col E D A))))) as H113.
------------------------------------------------------ apply (@lemma__collinearorder.lemma__collinearorder A D E H109).
------------------------------------------------------ destruct H113 as [H114 H115].
destruct H115 as [H116 H117].
destruct H117 as [H118 H119].
destruct H119 as [H120 H121].
exact H118.
----------------------------------------------------- assert (euclidean__axioms.Col A E R) as H114 by exact H107.
assert (* Cut *) (euclidean__axioms.Col E A R) as H115.
------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col E A R) /\ ((euclidean__axioms.Col E R A) /\ ((euclidean__axioms.Col R A E) /\ ((euclidean__axioms.Col A R E) /\ (euclidean__axioms.Col R E A))))) as H115.
------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A E R H114).
------------------------------------------------------- destruct H115 as [H116 H117].
destruct H117 as [H118 H119].
destruct H119 as [H120 H121].
destruct H121 as [H122 H123].
exact H116.
------------------------------------------------------ assert (* Cut *) (euclidean__axioms.neq A D) as H116.
------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq B T) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C T))) as H116.
-------------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C B T H96).
-------------------------------------------------------- destruct H116 as [H117 H118].
destruct H118 as [H119 H120].
exact H34.
------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A D R) as H117.
-------------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col A D R).
---------------------------------------------------------intro H117.
apply (@euclidean__tactics.Col__nCol__False A D R H117).
----------------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 E A D R H113 H115 H69).

-------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A R D) as H118.
--------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col D A R) /\ ((euclidean__axioms.Col D R A) /\ ((euclidean__axioms.Col R A D) /\ ((euclidean__axioms.Col A R D) /\ (euclidean__axioms.Col R D A))))) as H118.
---------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A D R H117).
---------------------------------------------------------- destruct H118 as [H119 H120].
destruct H120 as [H121 H122].
destruct H122 as [H123 H124].
destruct H124 as [H125 H126].
exact H125.
--------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A D p) as H119.
---------------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col A D p).
-----------------------------------------------------------intro H119.
apply (@euclidean__tactics.Col__nCol__False A D p H119).
------------------------------------------------------------apply (@lemma__collinear5.lemma__collinear5 A R A D p H101 H112 H118 H105).

---------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B T C) as H120.
----------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col B C T) /\ ((euclidean__axioms.Col B T C) /\ ((euclidean__axioms.Col T C B) /\ ((euclidean__axioms.Col C T B) /\ (euclidean__axioms.Col T B C))))) as H120.
------------------------------------------------------------ apply (@lemma__collinearorder.lemma__collinearorder C B T H108).
------------------------------------------------------------ destruct H120 as [H121 H122].
destruct H122 as [H123 H124].
destruct H124 as [H125 H126].
destruct H126 as [H127 H128].
exact H123.
----------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col T C B) as H121.
------------------------------------------------------------ assert (* Cut *) ((euclidean__axioms.Col T B C) /\ ((euclidean__axioms.Col T C B) /\ ((euclidean__axioms.Col C B T) /\ ((euclidean__axioms.Col B C T) /\ (euclidean__axioms.Col C T B))))) as H121.
------------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B T C H120).
------------------------------------------------------------- destruct H121 as [H122 H123].
destruct H123 as [H124 H125].
destruct H125 as [H126 H127].
destruct H127 as [H128 H129].
exact H124.
------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.neq C T) as H122.
------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq B T) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C T))) as H122.
-------------------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal C B T H96).
-------------------------------------------------------------- destruct H122 as [H123 H124].
destruct H124 as [H125 H126].
exact H126.
------------------------------------------------------------- assert (euclidean__axioms.neq T C) as H123 by exact H103.
assert (* Cut *) (euclidean__axioms.Col C B p) as H124.
-------------------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col C B p).
---------------------------------------------------------------intro H124.
apply (@euclidean__tactics.Col__nCol__False C B p H124).
----------------------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 T C B p H121 H106 H123).

-------------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col B C p) as H125.
--------------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col B C p) /\ ((euclidean__axioms.Col B p C) /\ ((euclidean__axioms.Col p C B) /\ ((euclidean__axioms.Col C p B) /\ (euclidean__axioms.Col p B C))))) as H125.
---------------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder C B p H124).
---------------------------------------------------------------- destruct H125 as [H126 H127].
destruct H127 as [H128 H129].
destruct H129 as [H130 H131].
destruct H131 as [H132 H133].
exact H126.
--------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Meet A D B C) as H126.
---------------------------------------------------------------- exists p.
split.
----------------------------------------------------------------- exact H116.
----------------------------------------------------------------- split.
------------------------------------------------------------------ exact H55.
------------------------------------------------------------------ split.
------------------------------------------------------------------- exact H119.
------------------------------------------------------------------- exact H125.
---------------------------------------------------------------- apply (@H39).
-----------------------------------------------------------------apply (@euclidean__tactics.not__nCol__Col D C A).
------------------------------------------------------------------intro H127.
apply (@H54 H126).

----------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS T B C) as H99.
------------------------------------------------ apply (@euclidean__axioms.axiom__betweennesssymmetry C B T H96).
------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col T B C) as H100.
------------------------------------------------- right.
right.
right.
right.
left.
exact H99.
------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq T C) as H101.
-------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq T B) /\ (euclidean__axioms.neq T C))) as H101.
--------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal T B C H99).
--------------------------------------------------- destruct H101 as [H102 H103].
destruct H103 as [H104 H105].
exact H105.
-------------------------------------------------- assert (* Cut *) (euclidean__axioms.neq B C) as H102.
--------------------------------------------------- assert (* Cut *) ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq T B) /\ (euclidean__axioms.neq T C))) as H102.
---------------------------------------------------- apply (@lemma__betweennotequal.lemma__betweennotequal T B C H99).
---------------------------------------------------- destruct H102 as [H103 H104].
destruct H104 as [H105 H106].
exact H103.
--------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col E B H74) as H103.
---------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col H74 E B) /\ ((euclidean__axioms.Col H74 B E) /\ ((euclidean__axioms.Col B E H74) /\ ((euclidean__axioms.Col E B H74) /\ (euclidean__axioms.Col B H74 E))))) as H103.
----------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder E H74 B H84).
----------------------------------------------------- destruct H103 as [H104 H105].
destruct H105 as [H106 H107].
destruct H107 as [H108 H109].
destruct H109 as [H110 H111].
exact H110.
---------------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS E H74 B) as H104.
----------------------------------------------------- apply (@lemma__collinearbetween.lemma__collinearbetween A R T C E B H74 H90 H100 H92 H101 H91 H102 H98 H85 H103).
----------------------------------------------------- assert (* Cut *) (euclidean__axioms.BetS B H74 E) as H105.
------------------------------------------------------ apply (@euclidean__axioms.axiom__betweennesssymmetry E H74 B H104).
------------------------------------------------------ assert (* Cut *) (~(euclidean__axioms.Col B E A)) as H106.
------------------------------------------------------- intro H106.
assert (* Cut *) (euclidean__axioms.Col A D E) as H107.
-------------------------------------------------------- right.
right.
right.
right.
left.
exact H37.
-------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col E A D) as H108.
--------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col D A E) /\ ((euclidean__axioms.Col D E A) /\ ((euclidean__axioms.Col E A D) /\ ((euclidean__axioms.Col A E D) /\ (euclidean__axioms.Col E D A))))) as H108.
---------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder A D E H107).
---------------------------------------------------------- destruct H108 as [H109 H110].
destruct H110 as [H111 H112].
destruct H112 as [H113 H114].
destruct H114 as [H115 H116].
exact H113.
--------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col E A B) as H109.
---------------------------------------------------------- assert (* Cut *) ((euclidean__axioms.Col E B A) /\ ((euclidean__axioms.Col E A B) /\ ((euclidean__axioms.Col A B E) /\ ((euclidean__axioms.Col B A E) /\ (euclidean__axioms.Col A E B))))) as H109.
----------------------------------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B E A H106).
----------------------------------------------------------- destruct H109 as [H110 H111].
destruct H111 as [H112 H113].
destruct H113 as [H114 H115].
destruct H115 as [H116 H117].
exact H112.
---------------------------------------------------------- assert (* Cut *) (euclidean__axioms.Col A D B) as H110.
----------------------------------------------------------- apply (@euclidean__tactics.not__nCol__Col A D B).
------------------------------------------------------------intro H110.
apply (@euclidean__tactics.Col__nCol__False A D B H110).
-------------------------------------------------------------apply (@lemma__collinear4.lemma__collinear4 E A D B H108 H109 H69).

----------------------------------------------------------- assert (* Cut *) (B = B) as H111.
------------------------------------------------------------ apply (@logic.eq__refl Point B).
------------------------------------------------------------ assert (* Cut *) (euclidean__axioms.Col B C B) as H112.
------------------------------------------------------------- right.
left.
exact H111.
------------------------------------------------------------- assert (* Cut *) (euclidean__defs.Meet A D B C) as H113.
-------------------------------------------------------------- exists B.
split.
--------------------------------------------------------------- exact H34.
--------------------------------------------------------------- split.
---------------------------------------------------------------- exact H102.
---------------------------------------------------------------- split.
----------------------------------------------------------------- exact H110.
----------------------------------------------------------------- exact H112.
-------------------------------------------------------------- apply (@H39).
---------------------------------------------------------------apply (@euclidean__tactics.not__nCol__Col D C A).
----------------------------------------------------------------intro H114.
apply (@H54 H113).

------------------------------------------------------- assert (* Cut *) (exists M, (euclidean__axioms.BetS B M D) /\ (euclidean__axioms.BetS A M H74)) as H107.
-------------------------------------------------------- apply (@euclidean__axioms.postulate__Pasch__inner B A E H74 D H105 H37).
---------------------------------------------------------apply (@euclidean__tactics.nCol__notCol B E A H106).

-------------------------------------------------------- destruct H107 as [M H108].
destruct H108 as [H109 H110].
assert (euclidean__axioms.BetS A H74 C) as H111 by exact H85.
assert (* Cut *) (euclidean__axioms.BetS A M C) as H112.
--------------------------------------------------------- apply (@lemma__3__6b.lemma__3__6b A M H74 C H110 H111).
--------------------------------------------------------- exists M.
split.
---------------------------------------------------------- exact H112.
---------------------------------------------------------- exact H109.
Qed.


Require Import Coq.Lists.List.
Import List.ListNotations.

Require Import Leapfrog.P4automaton.
Require Import Leapfrog.FinType.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.Relations.
Require Leapfrog.Bisimulations.Leaps.
Require Import Leapfrog.Bisimulations.AlgorithmicLeaps.

Section AlgorithmicLeaps.
  Variable (a: p4automaton).
  Notation conf := (configuration a).
  Variable (top: rel conf).
  Variable (top_closed: forall x y b, top x y -> top (step x b) (step y b)).

  Notation "⟦ x ⟧" := (interp_rels top x).
  Notation "R ⊨ S" := (forall q1 q2,
                          ⟦R⟧ q1 q2 ->
                          S q1 q2)
                        (at level 40).

  Definition bisimulation_with_leaps (R: rel conf) :=
    forall q1 q2 : configuration a,
      R q1 q2 ->
      (accepting q1 <-> accepting q2) /\
      (forall buf : list bool,
          length buf = Leaps.leap_size _ q1 q2 ->
          R (follow q1 buf) (follow q2 buf)).

  Lemma bisimilar_is_bisimulation:
    forall R q1 q2,
      bisimulation_with_leaps R ->
      R q1 q2 ->
      Leaps.bisimilar_with_leaps a q1 q2.
  Proof.
    cofix C.
    intros.
    constructor.
    - specialize (H q1 q2 H0).
      tauto.
    - intros.
      eapply C with (R:=R); auto.
      apply H; eauto.
  Qed.

  Definition follow_closed (R T: rel conf) : Prop :=
    forall q1 q2 bs,
        length bs = Leaps.leap_size _ q1 q2 ->
        R q1 q2 /\ T q1 q2 ->
        R (follow q1 bs) (follow q2 bs).

  Definition coaccepting (R: rel conf) : Prop :=
    forall q1 q2,
      R q1 q2 ->
      (accepting q1 <-> accepting q2).

  Lemma pre_bisimulation_is_bisimulation:
    forall R T,
      coaccepting (⟦R⟧ ⊓ ⟦T⟧) ->
      follow_closed ⟦R⟧ ⟦T⟧ ->
      bisimulation_with_leaps (pre_bisimulation a top R T).
  Proof.
    unfold bisimulation_with_leaps.
    intros.
    induction H1.
    - split.
      + apply H; split; auto.
        simpl.
        eapply interp_rels_bound; eauto.
      + intros.
        constructor 1.
        eapply H0; eauto.
        split; simpl; eauto.
        eapply interp_rels_bound; eauto.
    - assert (coaccepting (⟦ R ⟧ ⊓ ⟦ T ⟧)).
      {
        unfold coaccepting; intros.
        apply H.
        destruct H3.
        repeat split; auto.
      }
      assert (follow_closed ⟦ R ⟧ ⟦ T ⟧).
      {
        unfold follow_closed; intros.
        destruct H5.
        apply H0; auto.
        repeat split; eauto.
      }
      split.
      + apply IHpre_bisimulation; auto.
      + intros.
        constructor 2; auto.
        apply IHpre_bisimulation; eauto.
    - assert (coaccepting (⟦C :: R⟧ ⊓ ⟦W ++ T⟧)).
      {
        unfold coaccepting; intros.
        apply H.
        destruct H4.
        apply app_interp_rels in H5; destruct H5.
        simpl in H4; destruct H4.
        repeat split; auto.
      }
      assert (follow_closed ⟦C::R⟧ ⟦W++T⟧).
      {
        unfold follow_closed.
        unfold follow_closed in H0.
        intros.
        destruct H6.
        apply app_interp_rels in H7.
        destruct H6, H7.
        repeat split.
        - eapply H3; eauto.
        - apply H0; eauto.
          repeat split; eauto.
      }
      split.
      + apply IHpre_bisimulation; eauto.
      + intros.
        econstructor 3; eauto.
        eapply IHpre_bisimulation; eauto.
  Qed.

  Lemma algorithmic_leaps_implies_bisimilar_leaps:
    forall R T q1 q2,
      coaccepting (⟦R⟧ ⊓ ⟦T⟧) ->
      follow_closed ⟦R⟧ ⟦T⟧ ->
      pre_bisimulation a top R T q1 q2 ->
      Leaps.bisimilar_with_leaps a q1 q2.
  Proof.
    intros.
    eauto using bisimilar_is_bisimulation,
                pre_bisimulation_is_bisimulation.
  Qed.

End AlgorithmicLeaps.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                                  Lci.v                                   *)
(****************************************************************************)

(* Proprie'te's des lois de composition interne *)

(*****************************************************************************)
Section Internal.

Variable S : Set.
Variable G : S -> Prop.
Variable Add : S -> S -> S.
Variable O I : S.
Variable Opp Inv : S -> S.
(*****************************************************************************)

(***************)
Definition intern := forall x y : S, G x -> G y -> G (Add x y).

(**********************)
Definition commutativity := forall x y : S, Add x y = Add y x.

(**********************)
Definition associativity :=
  forall x y z : S, Add x (Add y z) = Add (Add x y) z :>S.

(****************)
Definition neutral (S : Set) (G : S -> Prop) (Add : S -> S -> S)
  (O : S) := G O /\ (forall x : S, G x -> Add x O = x /\ Add O x = x).

(****************)
Lemma neutral_add : neutral S G Add O -> O = Add O O.

Proof.
intros; symmetry  in |- *.
elim H; intros; elim (H1 O H0); trivial.
Qed.

(********************)
Definition is_opposite (x y : S) := G x /\ G y /\ Add x y = O /\ Add y x = O.

(************)
Lemma opp_com :
 commutativity ->
 forall x y : S, G x -> G y -> Add x y = O -> is_opposite x y.

Proof.
intros. unfold is_opposite in |- *.
split. exact H0. split. exact H1. split. exact H2. elim (H x y). exact H2.
Qed.

(*****************)
Definition opposite := forall x : S, G x -> is_opposite x (Opp x).

(***********************)
Definition distributivity (S : Set) (Add Mult : S -> S -> S) :=
  forall x y z : S,
  Mult (Add x y) z = Add (Mult x z) (Mult y z) /\
  Mult x (Add y z) = Add (Mult x y) (Mult x z).

End Internal.
(*****************************************************************************)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e369m25_15limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e401m31_17limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas64_2e255m19_5limbs_donna.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.solinas32_2e379m19_16limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition sub :
  { sub : feBW_tight -> feBW_tight -> feBW_loose
  | forall a b, phiBW_loose (sub a b) = F.sub (phiBW_tight a) (phiBW_tight b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_sub ().
  Show Ltac Profile.
Time Defined.

Print Assumptions sub.


Set Implicit Arguments.

Open Scope type_scope.

Inductive One : Set := inOne: One.

Definition maybe: forall A B:Set,(A -> B) -> One + A -> One + B.
Proof.
  intros A B f c.
  case c.
  left; assumption.
  right; apply f; assumption.
Defined.

Definition id (A:Set)(a:A):=a.

Definition LamF (X: Set -> Set)(A:Set) :Set :=
  A + (X A)*(X A) + X(One + A).

Definition LamF' (X: Set -> Set)(A:Set) :Set :=
  LamF X A.

Require Import List.
Require Import Bool.

Definition index := list bool.

Inductive L (A:Set) : index -> Set :=
  initL: A -> L A nil
  | pluslL: forall l:index, One -> L A (false::l)
  | plusrL: forall l:index, L A l -> L A (false::l)
  | varL: forall l:index, L A l -> L A (true::l)
  | appL: forall l:index, L A (true::l) -> L A (true::l) -> L A (true::l)
  | absL: forall l:index, L A (true::false::l) -> L A (true::l).

Scheme L_rec_simp := Minimality for L Sort Set.

Definition Lam' (A:Set) := L A (true::nil).

Definition aczelapp: forall (l1 l2: index)(A:Set), L (L A l2) l1 -> L A
  (l1++l2).
Proof.
  intros l1 l2 A.
  generalize l1.
  clear l1.
  (* Check (fun i:index => L A (i++l2)). *)
  apply (L_rec_simp (A:=L A l2) (fun i:index => L A (i++l2))).
  trivial.
  intros l o.
  simpl app.
  apply pluslL; assumption.
  intros l _ t.
  simpl app.
  apply plusrL; assumption.
  intros l _ t.
  simpl app.
  apply varL; assumption.
  intros l _ t1 _ t2.
  simpl app in *|-*.
  Check 0.
  apply appL; [exact t1| exact t2].
  intros l _ t.
  simpl app in *|-*.
  Check 0.
  apply absL; assumption.
Defined.

Definition monL: forall (l:index)(A:Set)(B:Set), (A->B) -> L A l -> L B l.
Proof.
  intros l A B f.
  intro t.
  elim t.
  intro a.
  exact (initL (f a)).
  intros i u.
  exact (pluslL _ _ u).
  intros i _ r.
  exact (plusrL r).
  intros i _ r.
  exact (varL r).
  intros i _ r1 _ r2.
  exact (appL r1 r2).
  intros i _ r.
  exact (absL r).
Defined.

Definition lam': forall (A B:Set), (A -> B) -> Lam' A -> Lam' B.
Proof.
  intros A B f t.
  unfold Lam' in *|-*.
  Check 0.
  exact (monL f t).
Defined.

Definition inLam': forall A:Set, LamF' Lam' A -> Lam' A.
Proof.
  intros A [[a|[t1 t2]]|r].
  unfold Lam'.
  exact (varL (initL a)).
  exact (appL t1 t2).
  unfold Lam' in * |- *.
  Check 0.
  apply absL.
  change (L A ((true::nil) ++ (false::nil))).
  apply aczelapp.
  (* Check (fun x:One + A =>  (match (maybe (fun a:A => initL a) x) with
    | inl u => pluslL _ _ u
    | inr t' => plusrL t' end)). *)
  exact (monL (fun x:One + A =>
    (match (maybe (fun a:A => initL a) x) with
       | inl u => pluslL _ _ u
       | inr t' => plusrL t' end)) r).
Defined.

Section minimal.

Definition sub1 (F G: Set -> Set):= forall A:Set, F A->G A.
Hypothesis G: Set -> Set.
Hypothesis step: sub1 (LamF' G) G.

Fixpoint L'(A:Set)(i:index){struct i} : Set :=
  match i with
    nil => A
    | false::l => One + L' A l
    | true::l => G (L' A l)
  end.

Definition LinL': forall (A:Set)(i:index), L A i -> L' A i.
Proof.
  intros A i t.
  elim t.
  intro a.
  unfold L'.
  assumption.
  intros l u.
  left; assumption.
  intros l _ r.
  right; assumption.
  intros l _ r.
  apply (step (A:=L' A l)).
  exact (inl _ (inl _ r)).
  intros l _ r1 _ r2.
  apply (step (A:=L' A l)).
  (* unfold L' in * |- *.
  Check 0. *)
  exact (inl _ (inr _ (pair r1 r2))).
  intros l _ r.
  apply  (step (A:=L' A l)).
  exact (inr _ r).
Defined.

Definition L'inG: forall A: Set, L' A (true::nil) -> G A.
Proof.
  intros A t.
  unfold L' in t.
  assumption.
Defined.

Definition Itbasic: sub1 Lam' G.
Proof.
  intros A t.
  apply L'inG.
  unfold Lam' in t.
  exact (LinL' t).
Defined.

End minimal.

Definition recid := Itbasic inLam'.

Definition L'Lam'inL: forall (i:index)(A:Set), L' Lam' A i -> L A i.
Proof.
  intros i A t.
  induction i.
  unfold L' in t.
  apply initL.
  assumption.
  induction a.
  simpl L' in t.
  apply (aczelapp (l1:=true::nil) (l2:=i)).
  exact (lam' IHi t).
  simpl L' in t.
  induction t.
  exact (pluslL _ _ a).
  exact (plusrL (IHi b)).
Defined.

Lemma recidgen: forall(A:Set)(i:index)(t:L A i), L'Lam'inL i A (LinL' inLam' t)
  = t.
Proof.
  intros A i t.
  induction t.
  trivial.
  trivial.
  simpl.
  rewrite IHt.
  trivial.
  simpl L'Lam'inL.
  rewrite IHt.
  trivial.
  simpl L'Lam'inL.
  simpl L'Lam'inL in IHt1.
  unfold lam' in IHt1.
  simpl L'Lam'inL in IHt2.
  unfold lam' in IHt2.

  (* going on. This fails for the original solution. *)
  rewrite IHt1.
  rewrite IHt2.
  trivial.
Abort. (* one goal still left *)


From ZornsLemma Require Export ImageImplicit.
From ZornsLemma Require Import EnsemblesImplicit.
From ZornsLemma Require Import FunctionProperties.

Lemma option_Full_set_Im (X : Type) :
  Full_set = Add (Im Full_set (@Some X)) None.
Proof.
apply Extensionality_Ensembles; split; red; intros.
2: { constructor. }
destruct x.
- left. exists x; constructor.
- right. constructor.
Qed.

Lemma Im_Full_set_surj {X Y : Type} (f : X -> Y) :
  surjective f ->
  Full_set = Im Full_set f.
Proof.
intros. apply Extensionality_Ensembles; split; red; intros.
2: { constructor. }
destruct (H x) as [y].
subst. apply Im_def.
constructor.
Qed.

Lemma Im_monotonous {X Y : Type} (f : X -> Y) (U V : Ensemble X) :
  Included U V ->
  Included (Im U f) (Im V f).
Proof.
  intros.
  red. intros.
  inversion H0; subst; clear H0.
  apply H in H1.
  exists x0; auto.
Qed.

Lemma Im_Included_injective {X Y : Type} (f : X -> Y) :
  injective f <->
  forall U V : Ensemble X,
    Included U V <->
    Included (Im U f) (Im V f).
Proof.
  split.
  - intros. split.
    { apply Im_monotonous. }
    intros.
    red; intros.
    specialize (H0 (f x)).
    unshelve epose proof (H0 _); [|clear H0].
    { exists x; auto. }
    inversion H2; subst; clear H2.
    apply H in H3.
    subst. assumption.
  - intros.
    red; intros.
    specialize (H (Singleton x) (Singleton y)) as [_].
    unshelve epose proof (H _); [|clear H].
    { red; intros.
      inversion H1; subst; clear H1.
      inversion H2; subst; clear H2.
      exists y; auto with sets.
    }
    unshelve epose proof (H1 x _); [|clear H1].
    { constructor. }
    inversion H; subst; clear H.
    reflexivity.
Qed.

Lemma Union_Im {X Y : Type} (f : X -> Y) (U V : Ensemble X) :
  Union (Im U f) (Im V f) = Im (Union U V) f.
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - destruct H.
    all: inversion H; subst; clear H.
    all: apply Im_def.
    1: left.
    2: right.
    all: assumption.
  - inversion H; subst; clear H.
    destruct H0; [left|right].
    all: apply Im_def.
    all: assumption.
Qed.

Lemma Im_id {X : Type} (U : Ensemble X) :
  Im U id = U.
Proof.
  apply Extensionality_Ensembles; split; red; intros.
  - inversion H; subst; clear H. assumption.
  - exists x; auto.
Qed.

Lemma Im_compose_inj_surj {X Y Z : Type} (f : X -> Y) (g : Y -> Z) :
  injective g -> Im Full_set (compose g f) = Im Full_set g ->
  surjective f.
Proof.
  intros ? ? ?.
  assert (In (Im Full_set g) (g y)).
  { apply Im_def. constructor. }
  rewrite <- H0 in H1.
  inversion H1; subst; clear H1.
  unfold compose in H3.
  exists x. apply H in H3.
  congruence.
Qed.