Require Import Arith.

Require Import matchingl.
Require Import matchinglreduction.
Require Import matchinglproofsystem.

Module MatchLPartialCorrectness(Base : ObjectLanguage).

Module MatchLProofSystemBase := MatchLProofSystem Base.
Export MatchLProofSystemBase.

Require Import Arith.

Proposition forall_in : forall T P l (e : T),
  List.In e l ->
  List.Forall P l ->
  P e.
Proof.
  induction 2; firstorder congruence.
Qed.

Hint Rewrite <- SatAnd : SatRewrite.
Hint Rewrite <- SatEquals : SatRewrite.
Hint Rewrite <- SatExists : SatRewrite.
Hint Rewrite <- SatImplies : SatRewrite.
Hint Rewrite <- SatOr : SatRewrite.

Ltac keep_first_conjunct H :=
  match type of H with
    ?P /\ ?Q => let name := fresh in assert (name: P) by (apply H); clear H; rename name into H
  end.

Definition gamma_entails parent strict s r :=
  forall gamma : M,
    clos s false parent gamma ->
    forall rho : Valuation,
      Satisfies gamma rho (fst r) ->
      exists gamma' : M, clos s strict gamma gamma' /\ Satisfies gamma' rho (snd r).

Lemma gamma_entails_fwd gamma gamma' strict s r :
  clos s false gamma gamma' ->
  gamma_entails gamma strict s r ->
  gamma_entails gamma' strict s r.
Proof.
  intros. intro gamma0;intros.
  destruct H0 with gamma0 rho.
  eauto using clos_trans.
  assumption.
  exists x. firstorder.
Qed.

Lemma entails_forall_gamma_entails : forall A strict phi phi',
  (forall gamma, terminates gamma A ->
    gamma_entails gamma strict A (phi,phi')) <->
  entails strict A (phi,phi').
Proof.
  split.
  firstorder using clos.
  intros; intro gamma0; intros.
  eauto using terminates_fwd.
Qed.

Lemma gamma_entails_unstrict : forall gamma A strict r,
  gamma_entails gamma true A r ->
  gamma_entails gamma strict A r.
Proof.
  unfold gamma_entails.
  firstorder.
  destruct (H gamma0 H0 rho H1).
  exists x.
  intuition.
  destruct strict; auto using clos_unstrict.
Qed.

Definition gamma_entails_system parent strict s (R : System) :=
  forall r, R r -> gamma_entails parent strict s r.

Lemma entails_system_forall_gamma_entails_system :
  forall A strict A',
  (forall gamma, terminates gamma A ->
    gamma_entails_system gamma strict A A') ->
  entails_system strict A A'.
Proof.
  unfold gamma_entails_system, entails_system.
  intros.
  destruct r.
  apply entails_forall_gamma_entails.
  auto.
Qed.

Lemma gamma_entails_system_fwd gamma gamma' strict s R :
  clos s false gamma gamma' ->
  gamma_entails_system gamma strict s R ->
  gamma_entails_system gamma' strict s R.
Proof.
  intro. unfold gamma_entails_system. intro.
  eauto using gamma_entails_fwd.
Qed.

Section FixSystem.

(* A is the new system, for some strange reason *)
Hypothesis SF : (M -> M -> Prop).

Definition gamma_rule (gamma : M) strict (phi phi' : Formula) :=
  gamma_entails gamma strict SF (phi,phi').

Definition gamma_system (gamma : M) strict (A' : System) : Prop :=
  gamma_entails_system gamma strict SF A'.

Theorem lemma1 : forall strict A phi phi',
  forall (proof : PS strict A phi phi'),
    forall gamma,
      terminates gamma SF ->
      gamma_system gamma true A ->
      gamma_rule gamma strict phi phi'.
  intros strict A phi phi' proof.
  induction proof; intros gamma Hterm Hproper.

  (* ps_refl *)
  subst strict. intro;intros.
  exists gamma0. solve[firstorder using clos_refl].

  (* ps_axiom *)
  apply gamma_entails_unstrict; solve [auto].

  (* ps_subst *)
  specialize (IHproof gamma Hterm Hproper).
  clear -IHproof.
  unfold gamma_rule, gamma_entails.
  simpl; setoid_rewrite SatApply.
  solve[firstorder].

  (* ps_trans *)
  specialize (IHproof1 gamma Hterm Hproper).
  specialize (IHproof2 gamma Hterm Hproper).
  clear -IHproof1 IHproof2.
  unfold gamma_rule, gamma_entails.
  intros.
  destruct (IHproof1 gamma0 H rho H0) as [x [xtranz xsat]].
  assert (clos SF false gamma x) by
    (clear -H xtranz; destruct strict;
      eauto using clos,clos_unstrict).
  destruct (IHproof2 x H1 rho xsat) as [gamma'' [Htranz Hsat'']].
  exists gamma''.
  split;[apply clos_trans_lt with x|];assumption.

  (* ps_case *)
  intros n Himpl.
  specialize (IHproof1 gamma Hterm Hproper).
  specialize (IHproof2 gamma Hterm Hproper).
  intro rho.
  simpl. rewrite <- SatOr.
  solve[firstorder].

  (* ps_lf *)
  specialize (IHproof gamma Hterm Hproper).
  unfold gamma_rule, gamma_entails.
  simpl.
  setoid_rewrite <- SatAnd.
  intros. destruct H1.
  destruct (IHproof gamma0 H0 rho H1) as [gamma'' [Htranz Hsat]].
  exists gamma''.
  firstorder.
  eapply patternless_sat; eassumption.

  (* ps_conseq *)
  unfold Valid in H, H0.
  setoid_rewrite <- SatImplies in H.
  setoid_rewrite <- SatImplies in H0.
  intro; intros.
  specialize (IHproof gamma Hterm Hproper gamma0).
  apply H in H2.
  solve[firstorder].

  (* ps_abstr *)
  intro; intros.
  simpl in H1.
  rewrite <- SatExists in H1.
  destruct H1.
  destruct (IHproof gamma Hterm Hproper gamma0 H0 _ H1).
  exists x0.
  rewrite <- notFree_sat in H2; assumption.

  (* ps_circ *)
  specialize (IHproof1 gamma Hterm Hproper).

  assert (forall gamma' : M, clos SF false gamma gamma' ->
    gamma_rule gamma' true phi phi' ->
    gamma_rule gamma' false phi'' phi') as IH2.
  intros; apply IHproof2; unfold gamma_system.
    eauto using terminates_fwd.
    intros r Hr.
    destruct Hr.
    subst r;assumption.

    eapply gamma_entails_system_fwd;eassumption.

  clear -IHproof1 IH2 Hterm.

  cut (gamma_rule gamma true phi phi').

  apply gamma_entails_unstrict.

  apply terminates_trans in Hterm.
  revert Hterm.
  remember (SF) as s.
  induction 1.
  clear H.
  subst s.

  assert (forall y : M,
    clos SF true x y ->
    gamma_rule y true phi phi').
  intros.
  specialize (H0 y H).
  apply H0.
  revert IHproof1; apply gamma_entails_fwd.
  apply clos_unstrict; assumption.
  intros.
  apply IH2.
  clear -H H1. apply clos_unstrict. exact (clos_cat H H1).
  assumption.

  assert (forall y : M,
    clos SF true x y ->
    gamma_rule y false phi'' phi').
  intros.
  apply IH2. apply clos_unstrict. assumption.
  apply H. assumption.

  clear -IHproof1 H1.
  intro gamma_phi; intros.
  specialize (IHproof1 gamma_phi H rho H0).
  destruct IHproof1 as [gamma_phi' [Hstep Hsat]].

  assert (clos SF true x gamma_phi').
    clear -Hstep H. exact (clos_cat H Hstep).
  destruct (H1 gamma_phi' H2) with gamma_phi' rho.
  apply clos_refl.
  assumption.

  exists x0.
  intuition.
  clear -Hstep H4. exact (clos_cat Hstep H4).
Qed.
End FixSystem.

Theorem partial_correctness : forall S A strict phi phi',
  entails_system true S A ->
  PS strict A phi phi' ->
  entails strict S (phi,phi').
Proof.
intros.
apply entails_forall_gamma_entails.
intros.
assert (gamma_system S gamma true A).
revert H; unfold entails_system, gamma_system, gamma_entails_system.
intros. specialize (H r H2).
unfold gamma_entails; intros.
apply H.
eauto using terminates_fwd.
assumption.

eapply lemma1;eassumption.
Qed.

Theorem system_correctness : forall S strict phi phi',
  wd_system S ->
  PS strict S phi phi' ->
  entails strict (ts S) (phi,phi').
Proof.
Abort.

End MatchLPartialCorrectness.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export euclidean__tactics.
Require Export lemma__NCdistinct.
Require Export lemma__collinear4.
Require Export lemma__collinearorder.
Require Export lemma__collinearparallel2.
Require Export lemma__congruenceflip.
Require Export lemma__congruencesymmetric.
Require Export lemma__congruencetransitive.
Require Export lemma__crisscross.
Require Export lemma__inequalitysymmetric.
Require Export lemma__parallelNC.
Require Export lemma__parallelflip.
Require Export lemma__parallelsymmetric.
Require Export logic.
Require Export proposition__33.
Require Export proposition__34.
Require Export proposition__35.
Definition proposition__36 : forall A B C D E F G H, (euclidean__defs.PG A B C D) -> ((euclidean__defs.PG E F G H) -> ((euclidean__axioms.Col A D E) -> ((euclidean__axioms.Col A D H) -> ((euclidean__axioms.Col B C F) -> ((euclidean__axioms.Col B C G) -> ((euclidean__axioms.Cong B C F G) -> (euclidean__axioms.EF A B C D E F G H))))))).
Proof.
intro A.
intro B.
intro C.
intro D.
intro E.
intro F.
intro G.
intro H.
intro H0.
intro H1.
intro H2.
intro H3.
intro H4.
intro H5.
intro H6.
assert (* Cut *) ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H7.
- assert ((euclidean__defs.Par E F G H) /\ (euclidean__defs.Par E H F G)) as H7 by exact H1.
assert ((euclidean__defs.Par E F G H) /\ (euclidean__defs.Par E H F G)) as __TmpHyp by exact H7.
destruct __TmpHyp as [H8 H9].
assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H10 by exact H0.
assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as __TmpHyp0 by exact H10.
destruct __TmpHyp0 as [H11 H12].
split.
-- exact H11.
-- exact H12.
- assert (* Cut *) ((euclidean__defs.Par E F G H) /\ (euclidean__defs.Par E H F G)) as H8.
-- assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H8 by exact H7.
assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as __TmpHyp by exact H8.
destruct __TmpHyp as [H9 H10].
assert ((euclidean__defs.Par E F G H) /\ (euclidean__defs.Par E H F G)) as H11 by exact H1.
assert ((euclidean__defs.Par E F G H) /\ (euclidean__defs.Par E H F G)) as __TmpHyp0 by exact H11.
destruct __TmpHyp0 as [H12 H13].
assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as H14 by exact H0.
assert ((euclidean__defs.Par A B C D) /\ (euclidean__defs.Par A D B C)) as __TmpHyp1 by exact H14.
destruct __TmpHyp1 as [H15 H16].
split.
--- exact H12.
--- exact H13.
-- assert (* Cut *) (euclidean__axioms.nCol E H G) as H9.
--- destruct H8 as [H9 H10].
destruct H7 as [H11 H12].
assert (* Cut *) ((euclidean__axioms.nCol E H F) /\ ((euclidean__axioms.nCol E F G) /\ ((euclidean__axioms.nCol H F G) /\ (euclidean__axioms.nCol E H G)))) as H13.
---- apply (@lemma__parallelNC.lemma__parallelNC E H F G H10).
---- destruct H13 as [H14 H15].
destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
exact H19.
--- assert (* Cut *) (euclidean__axioms.neq E H) as H10.
---- destruct H8 as [H10 H11].
destruct H7 as [H12 H13].
assert (* Cut *) ((euclidean__axioms.neq E H) /\ ((euclidean__axioms.neq H G) /\ ((euclidean__axioms.neq E G) /\ ((euclidean__axioms.neq H E) /\ ((euclidean__axioms.neq G H) /\ (euclidean__axioms.neq G E)))))) as H14.
----- apply (@lemma__NCdistinct.lemma__NCdistinct E H G H9).
----- 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].
exact H15.
---- assert (* Cut *) (euclidean__axioms.nCol A B C) as H11.
----- destruct H8 as [H11 H12].
destruct H7 as [H13 H14].
assert (* Cut *) ((euclidean__axioms.nCol A D B) /\ ((euclidean__axioms.nCol A B C) /\ ((euclidean__axioms.nCol D B C) /\ (euclidean__axioms.nCol A D C)))) as H15.
------ apply (@lemma__parallelNC.lemma__parallelNC A D B C H14).
------ destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
exact H18.
----- assert (* Cut *) (euclidean__axioms.neq B C) as H12.
------ destruct H8 as [H12 H13].
destruct H7 as [H14 H15].
assert (* Cut *) ((euclidean__axioms.neq A B) /\ ((euclidean__axioms.neq B C) /\ ((euclidean__axioms.neq A C) /\ ((euclidean__axioms.neq B A) /\ ((euclidean__axioms.neq C B) /\ (euclidean__axioms.neq C A)))))) as H16.
------- apply (@lemma__NCdistinct.lemma__NCdistinct A B C H11).
------- 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].
exact H19.
------ assert (* Cut *) (euclidean__axioms.Cong E H F G) as H13.
------- destruct H8 as [H13 H14].
destruct H7 as [H15 H16].
assert (* Cut *) ((euclidean__axioms.Cong E H F G) /\ ((euclidean__axioms.Cong E F H G) /\ ((euclidean__defs.CongA F E H H G F) /\ ((euclidean__defs.CongA E H G G F E) /\ (euclidean__axioms.Cong__3 F E H H G F))))) as H17.
-------- apply (@proposition__34.proposition__34 E H F G H1).
-------- destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
destruct H23 as [H24 H25].
exact H18.
------- assert (* Cut *) (euclidean__axioms.Cong F G E H) as H14.
-------- destruct H8 as [H14 H15].
destruct H7 as [H16 H17].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric F E H G H13).
-------- assert (* Cut *) (euclidean__axioms.Cong B C E H) as H15.
--------- destruct H8 as [H15 H16].
destruct H7 as [H17 H18].
apply (@lemma__congruencetransitive.lemma__congruencetransitive B C F G E H H6 H14).
--------- assert (* Cut *) (euclidean__defs.Par B C A D) as H16.
---------- destruct H8 as [H16 H17].
destruct H7 as [H18 H19].
apply (@lemma__parallelsymmetric.lemma__parallelsymmetric A D B C H19).
---------- assert (* Cut *) (euclidean__defs.Par B C E H) as H17.
----------- destruct H8 as [H17 H18].
destruct H7 as [H19 H20].
apply (@lemma__collinearparallel2.lemma__collinearparallel2 B C A D E H H16 H2 H3 H10).
----------- assert (* Cut *) (euclidean__defs.Par E H B C) as H18.
------------ destruct H8 as [H18 H19].
destruct H7 as [H20 H21].
apply (@lemma__parallelsymmetric.lemma__parallelsymmetric B C E H H17).
------------ assert (* Cut *) (euclidean__axioms.Cong E H B C) as H19.
------------- destruct H8 as [H19 H20].
destruct H7 as [H21 H22].
apply (@lemma__congruencesymmetric.lemma__congruencesymmetric E B C H H15).
------------- assert (* Cut *) (~(~((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)))) as H20.
-------------- intro H20.
assert (* Cut *) (euclidean__defs.CR E C B H) as H21.
--------------- destruct H8 as [H21 H22].
destruct H7 as [H23 H24].
apply (@lemma__crisscross.lemma__crisscross E B H C H18).
----------------intro H25.
apply (@H20).
-----------------right.
exact H25.

--------------- apply (@H20).
----------------left.
exact H21.

-------------- assert (* Cut *) (euclidean__axioms.EF A B C D E F G H) as H21.
--------------- assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H21.
---------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C))).
-----------------intro H21.
destruct H7 as [H22 H23].
destruct H8 as [H24 H25].
assert (* Cut *) (False) as H26.
------------------ apply (@H20 H21).
------------------ assert (* Cut *) ((euclidean__defs.CR E C B H) -> False) as H27.
------------------- intro H27.
apply (@H21).
--------------------left.
exact H27.

------------------- assert (* Cut *) ((euclidean__defs.CR E B H C) -> False) as H28.
-------------------- intro H28.
apply (@H21).
---------------------right.
exact H28.

-------------------- contradiction H26.

---------------- assert ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H22 by exact H21.
assert ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as __TmpHyp by exact H22.
destruct __TmpHyp as [H23|H23].
----------------- assert (* Cut *) (exists M, (euclidean__axioms.BetS E M C) /\ (euclidean__axioms.BetS B M H)) as H24.
------------------ destruct H8 as [H24 H25].
destruct H7 as [H26 H27].
exact H23.
------------------ destruct H24 as [M H25].
destruct H25 as [H26 H27].
destruct H8 as [H28 H29].
destruct H7 as [H30 H31].
assert (* Cut *) (euclidean__axioms.BetS H M B) as H32.
------------------- assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H32.
-------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
-------------------- apply (@euclidean__axioms.axiom__betweennesssymmetry B M H H27).
------------------- assert (* Cut *) ((euclidean__defs.Par E B H C) /\ (euclidean__axioms.Cong E B H C)) as H33.
-------------------- assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H33.
--------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
--------------------- apply (@proposition__33.proposition__33 E H B C M H18 H19 H26 H32).
-------------------- assert (* Cut *) (euclidean__defs.Par E B C H) as H34.
--------------------- destruct H33 as [H34 H35].
assert (* Cut *) ((euclidean__defs.Par B E H C) /\ ((euclidean__defs.Par E B C H) /\ (euclidean__defs.Par B E C H))) as H36.
---------------------- apply (@lemma__parallelflip.lemma__parallelflip E B H C H34).
---------------------- destruct H36 as [H37 H38].
destruct H38 as [H39 H40].
exact H39.
--------------------- assert (* Cut *) (euclidean__defs.PG E B C H) as H35.
---------------------- assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H35.
----------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
----------------------- split.
------------------------ exact H34.
------------------------ exact H18.
---------------------- assert (* Cut *) (euclidean__axioms.EF A B C D E B C H) as H36.
----------------------- destruct H33 as [H36 H37].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H38.
------------------------ apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------ apply (@proposition__35.proposition__35 A B C D E H H0 H35 H2 H3).
----------------------- assert (* Cut *) (euclidean__axioms.Col C F G) as H37.
------------------------ destruct H33 as [H37 H38].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H39.
------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------- apply (@euclidean__tactics.not__nCol__Col C F G).
--------------------------intro H40.
apply (@euclidean__tactics.Col__nCol__False C F G H40).
---------------------------apply (@lemma__collinear4.lemma__collinear4 B C F G H4 H5 H12).

------------------------ assert (* Cut *) (euclidean__axioms.Col G F C) as H38.
------------------------- destruct H33 as [H38 H39].
assert (* Cut *) ((euclidean__axioms.Col F C G) /\ ((euclidean__axioms.Col F G C) /\ ((euclidean__axioms.Col G C F) /\ ((euclidean__axioms.Col C G F) /\ (euclidean__axioms.Col G F C))))) as H40.
-------------------------- apply (@lemma__collinearorder.lemma__collinearorder C F G H37).
-------------------------- destruct H40 as [H41 H42].
destruct H42 as [H43 H44].
destruct H44 as [H45 H46].
destruct H46 as [H47 H48].
exact H48.
------------------------- assert (* Cut *) (euclidean__axioms.Col C B F) as H39.
-------------------------- destruct H33 as [H39 H40].
assert (* Cut *) ((euclidean__axioms.Col C B F) /\ ((euclidean__axioms.Col C F B) /\ ((euclidean__axioms.Col F B C) /\ ((euclidean__axioms.Col B F C) /\ (euclidean__axioms.Col F C B))))) as H41.
--------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C F H4).
--------------------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H42.
-------------------------- assert (* Cut *) (euclidean__axioms.Col C B G) as H40.
--------------------------- destruct H33 as [H40 H41].
assert (* Cut *) ((euclidean__axioms.Col C B G) /\ ((euclidean__axioms.Col C G B) /\ ((euclidean__axioms.Col G B C) /\ ((euclidean__axioms.Col B G C) /\ (euclidean__axioms.Col G C B))))) as H42.
---------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C G H5).
---------------------------- 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__axioms.neq C B) as H41.
---------------------------- destruct H33 as [H41 H42].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H43.
----------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
----------------------------- apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B C H12).
---------------------------- assert (* Cut *) (euclidean__axioms.Col B F G) as H42.
----------------------------- destruct H33 as [H42 H43].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H44.
------------------------------ apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------------ apply (@euclidean__tactics.not__nCol__Col B F G).
-------------------------------intro H45.
apply (@euclidean__tactics.Col__nCol__False B F G H45).
--------------------------------apply (@lemma__collinear4.lemma__collinear4 C B F G H39 H40 H41).

----------------------------- assert (* Cut *) (euclidean__axioms.Col G F B) as H43.
------------------------------ destruct H33 as [H43 H44].
assert (* Cut *) ((euclidean__axioms.Col F B G) /\ ((euclidean__axioms.Col F G B) /\ ((euclidean__axioms.Col G B F) /\ ((euclidean__axioms.Col B G F) /\ (euclidean__axioms.Col G F B))))) as H45.
------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B F G H42).
------------------------------- destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H53.
------------------------------ assert (* Cut *) (euclidean__defs.Par F G E H) as H44.
------------------------------- destruct H33 as [H44 H45].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H46.
-------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
-------------------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric E H F G H29).
------------------------------- assert (* Cut *) (euclidean__defs.Par G F H E) as H45.
-------------------------------- destruct H33 as [H45 H46].
assert (* Cut *) ((euclidean__defs.Par G F E H) /\ ((euclidean__defs.Par F G H E) /\ (euclidean__defs.Par G F H E))) as H47.
--------------------------------- apply (@lemma__parallelflip.lemma__parallelflip F G E H H44).
--------------------------------- destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
exact H51.
-------------------------------- assert (* Cut *) (euclidean__defs.Par E F G H) as H46.
--------------------------------- destruct H35 as [H46 H47].
destruct H33 as [H48 H49].
destruct H1 as [H50 H51].
destruct H0 as [H52 H53].
exact H28.
--------------------------------- assert (* Cut *) (euclidean__defs.Par G H E F) as H47.
---------------------------------- destruct H33 as [H47 H48].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H49.
----------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
----------------------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric E F G H H46).
---------------------------------- assert (* Cut *) (euclidean__defs.PG G H E F) as H48.
----------------------------------- assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H48.
------------------------------------ apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------------------ split.
------------------------------------- exact H47.
------------------------------------- exact H45.
----------------------------------- assert (* Cut *) (euclidean__defs.Par C H E B) as H49.
------------------------------------ destruct H33 as [H49 H50].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H51.
------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric E B C H H34).
------------------------------------ assert (* Cut *) (euclidean__defs.Par B C E H) as H50.
------------------------------------- destruct H33 as [H50 H51].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H52.
-------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
-------------------------------------- exact H17.
------------------------------------- assert (* Cut *) (euclidean__defs.Par C B H E) as H51.
-------------------------------------- destruct H33 as [H51 H52].
assert (* Cut *) ((euclidean__defs.Par C B E H) /\ ((euclidean__defs.Par B C H E) /\ (euclidean__defs.Par C B H E))) as H53.
--------------------------------------- apply (@lemma__parallelflip.lemma__parallelflip B C E H H50).
--------------------------------------- destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
exact H57.
-------------------------------------- assert (* Cut *) (euclidean__defs.PG C H E B) as H52.
--------------------------------------- assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H52.
---------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
---------------------------------------- split.
----------------------------------------- exact H49.
----------------------------------------- exact H51.
--------------------------------------- assert (* Cut *) (euclidean__axioms.EF G H E F C H E B) as H53.
---------------------------------------- destruct H33 as [H53 H54].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H55.
----------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
----------------------------------------- apply (@proposition__35.proposition__35 G H E F C B H48 H52 H38 H43).
---------------------------------------- assert (* Cut *) (euclidean__axioms.EF G H E F E B C H) as H54.
----------------------------------------- destruct H33 as [H54 H55].
assert (* Cut *) ((euclidean__axioms.EF G H E F H E B C) /\ ((euclidean__axioms.EF G H E F B E H C) /\ ((euclidean__axioms.EF G H E F E B C H) /\ ((euclidean__axioms.EF G H E F H C B E) /\ ((euclidean__axioms.EF G H E F B C H E) /\ ((euclidean__axioms.EF G H E F E H C B) /\ (euclidean__axioms.EF G H E F C B E H))))))) as H56.
------------------------------------------ apply (@euclidean__axioms.axiom__EFpermutation G H E F C H E B H53).
------------------------------------------ destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
exact H61.
----------------------------------------- assert (* Cut *) (euclidean__axioms.EF E B C H G H E F) as H55.
------------------------------------------ destruct H33 as [H55 H56].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H57.
------------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------------------------- apply (@euclidean__axioms.axiom__EFsymmetric G H E F E B C H H54).
------------------------------------------ assert (* Cut *) (euclidean__axioms.EF A B C D G H E F) as H56.
------------------------------------------- destruct H33 as [H56 H57].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H58.
-------------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
-------------------------------------------- apply (@euclidean__axioms.axiom__EFtransitive A B C D G H E F E B C H H36 H55).
------------------------------------------- assert (* Cut *) (euclidean__axioms.EF A B C D E F G H) as H57.
-------------------------------------------- destruct H33 as [H57 H58].
assert (* Cut *) ((euclidean__axioms.EF A B C D H E F G) /\ ((euclidean__axioms.EF A B C D F E H G) /\ ((euclidean__axioms.EF A B C D E F G H) /\ ((euclidean__axioms.EF A B C D H G F E) /\ ((euclidean__axioms.EF A B C D F G H E) /\ ((euclidean__axioms.EF A B C D E H G F) /\ (euclidean__axioms.EF A B C D G F E H))))))) as H59.
--------------------------------------------- apply (@euclidean__axioms.axiom__EFpermutation A B C D G H E F H56).
--------------------------------------------- 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].
exact H64.
-------------------------------------------- exact H57.
----------------- assert (* Cut *) (exists M, (euclidean__axioms.BetS E M B) /\ (euclidean__axioms.BetS H M C)) as H24.
------------------ destruct H8 as [H24 H25].
destruct H7 as [H26 H27].
exact H23.
------------------ destruct H24 as [M H25].
destruct H25 as [H26 H27].
destruct H8 as [H28 H29].
destruct H7 as [H30 H31].
assert (* Cut *) (euclidean__defs.Par H E B C) as H32.
------------------- assert (* Cut *) ((euclidean__defs.Par H E B C) /\ ((euclidean__defs.Par E H C B) /\ (euclidean__defs.Par H E C B))) as H32.
-------------------- apply (@lemma__parallelflip.lemma__parallelflip E H B C H18).
-------------------- destruct H32 as [H33 H34].
destruct H34 as [H35 H36].
exact H33.
------------------- assert (* Cut *) (euclidean__axioms.Cong H E B C) as H33.
-------------------- assert (* Cut *) ((euclidean__axioms.Cong H E C B) /\ ((euclidean__axioms.Cong H E B C) /\ (euclidean__axioms.Cong E H C B))) as H33.
--------------------- apply (@lemma__congruenceflip.lemma__congruenceflip E H B C H19).
--------------------- destruct H33 as [H34 H35].
destruct H35 as [H36 H37].
exact H36.
-------------------- assert (* Cut *) ((euclidean__defs.Par H B E C) /\ (euclidean__axioms.Cong H B E C)) as H34.
--------------------- assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H34.
---------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
---------------------- apply (@proposition__33.proposition__33 H E B C M H32 H33 H27 H26).
--------------------- assert (* Cut *) (euclidean__defs.Par H B C E) as H35.
---------------------- destruct H34 as [H35 H36].
assert (* Cut *) ((euclidean__defs.Par B H E C) /\ ((euclidean__defs.Par H B C E) /\ (euclidean__defs.Par B H C E))) as H37.
----------------------- apply (@lemma__parallelflip.lemma__parallelflip H B E C H35).
----------------------- destruct H37 as [H38 H39].
destruct H39 as [H40 H41].
exact H40.
---------------------- assert (* Cut *) (euclidean__defs.PG H B C E) as H36.
----------------------- assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H36.
------------------------ apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------ split.
------------------------- exact H35.
------------------------- exact H32.
----------------------- assert (* Cut *) (euclidean__axioms.EF A B C D H B C E) as H37.
------------------------ destruct H34 as [H37 H38].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H39.
------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------- apply (@proposition__35.proposition__35 A B C D H E H0 H36 H3 H2).
------------------------ assert (* Cut *) (euclidean__axioms.Col C G F) as H38.
------------------------- destruct H34 as [H38 H39].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H40.
-------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
-------------------------- apply (@euclidean__tactics.not__nCol__Col C G F).
---------------------------intro H41.
apply (@euclidean__tactics.Col__nCol__False C G F H41).
----------------------------apply (@lemma__collinear4.lemma__collinear4 B C G F H5 H4 H12).

------------------------- assert (* Cut *) (euclidean__axioms.Col F G C) as H39.
-------------------------- destruct H34 as [H39 H40].
assert (* Cut *) ((euclidean__axioms.Col G C F) /\ ((euclidean__axioms.Col G F C) /\ ((euclidean__axioms.Col F C G) /\ ((euclidean__axioms.Col C F G) /\ (euclidean__axioms.Col F G C))))) as H41.
--------------------------- apply (@lemma__collinearorder.lemma__collinearorder C G F H38).
--------------------------- destruct H41 as [H42 H43].
destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
exact H49.
-------------------------- assert (* Cut *) (euclidean__axioms.Col C B G) as H40.
--------------------------- destruct H34 as [H40 H41].
assert (* Cut *) ((euclidean__axioms.Col C B G) /\ ((euclidean__axioms.Col C G B) /\ ((euclidean__axioms.Col G B C) /\ ((euclidean__axioms.Col B G C) /\ (euclidean__axioms.Col G C B))))) as H42.
---------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C G H5).
---------------------------- 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__axioms.Col C B F) as H41.
---------------------------- destruct H34 as [H41 H42].
assert (* Cut *) ((euclidean__axioms.Col C B F) /\ ((euclidean__axioms.Col C F B) /\ ((euclidean__axioms.Col F B C) /\ ((euclidean__axioms.Col B F C) /\ (euclidean__axioms.Col F C B))))) as H43.
----------------------------- apply (@lemma__collinearorder.lemma__collinearorder B C F H4).
----------------------------- destruct H43 as [H44 H45].
destruct H45 as [H46 H47].
destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
exact H44.
---------------------------- assert (* Cut *) (euclidean__axioms.neq C B) as H42.
----------------------------- destruct H34 as [H42 H43].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H44.
------------------------------ apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------------ apply (@lemma__inequalitysymmetric.lemma__inequalitysymmetric B C H12).
----------------------------- assert (* Cut *) (euclidean__axioms.Col B G F) as H43.
------------------------------ destruct H34 as [H43 H44].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H45.
------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------------- apply (@euclidean__tactics.not__nCol__Col B G F).
--------------------------------intro H46.
apply (@euclidean__tactics.Col__nCol__False B G F H46).
---------------------------------apply (@lemma__collinear4.lemma__collinear4 C B G F H40 H41 H42).

------------------------------ assert (* Cut *) (euclidean__axioms.Col F G B) as H44.
------------------------------- destruct H34 as [H44 H45].
assert (* Cut *) ((euclidean__axioms.Col G B F) /\ ((euclidean__axioms.Col G F B) /\ ((euclidean__axioms.Col F B G) /\ ((euclidean__axioms.Col B F G) /\ (euclidean__axioms.Col F G B))))) as H46.
-------------------------------- apply (@lemma__collinearorder.lemma__collinearorder B G F H43).
-------------------------------- destruct H46 as [H47 H48].
destruct H48 as [H49 H50].
destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
exact H54.
------------------------------- assert (* Cut *) (euclidean__defs.Par H E F G) as H45.
-------------------------------- destruct H34 as [H45 H46].
assert (* Cut *) ((euclidean__defs.Par H E F G) /\ ((euclidean__defs.Par E H G F) /\ (euclidean__defs.Par H E G F))) as H47.
--------------------------------- apply (@lemma__parallelflip.lemma__parallelflip E H F G H29).
--------------------------------- destruct H47 as [H48 H49].
destruct H49 as [H50 H51].
exact H48.
-------------------------------- assert (* Cut *) (euclidean__defs.Par F G H E) as H46.
--------------------------------- destruct H34 as [H46 H47].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H48.
---------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
---------------------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric H E F G H45).
--------------------------------- assert (* Cut *) (euclidean__defs.Par F G E H) as H47.
---------------------------------- destruct H34 as [H47 H48].
assert (* Cut *) ((euclidean__defs.Par G F H E) /\ ((euclidean__defs.Par F G E H) /\ (euclidean__defs.Par G F E H))) as H49.
----------------------------------- apply (@lemma__parallelflip.lemma__parallelflip F G H E H46).
----------------------------------- destruct H49 as [H50 H51].
destruct H51 as [H52 H53].
exact H52.
---------------------------------- assert (* Cut *) (euclidean__defs.Par F E H G) as H48.
----------------------------------- destruct H34 as [H48 H49].
assert (* Cut *) ((euclidean__defs.Par F E G H) /\ ((euclidean__defs.Par E F H G) /\ (euclidean__defs.Par F E H G))) as H50.
------------------------------------ apply (@lemma__parallelflip.lemma__parallelflip E F G H H28).
------------------------------------ destruct H50 as [H51 H52].
destruct H52 as [H53 H54].
exact H54.
----------------------------------- assert (* Cut *) (euclidean__defs.PG F E H G) as H49.
------------------------------------ assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H49.
------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------------------- split.
-------------------------------------- exact H48.
-------------------------------------- exact H47.
------------------------------------ assert (* Cut *) (euclidean__defs.Par C E H B) as H50.
------------------------------------- destruct H34 as [H50 H51].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H52.
-------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
-------------------------------------- apply (@lemma__parallelsymmetric.lemma__parallelsymmetric H B C E H35).
------------------------------------- assert (* Cut *) (euclidean__defs.Par C B E H) as H51.
-------------------------------------- destruct H34 as [H51 H52].
assert (* Cut *) ((euclidean__defs.Par C B E H) /\ ((euclidean__defs.Par B C H E) /\ (euclidean__defs.Par C B H E))) as H53.
--------------------------------------- apply (@lemma__parallelflip.lemma__parallelflip B C E H H17).
--------------------------------------- destruct H53 as [H54 H55].
destruct H55 as [H56 H57].
exact H54.
-------------------------------------- assert (* Cut *) (euclidean__defs.PG C E H B) as H52.
--------------------------------------- assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H52.
---------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
---------------------------------------- split.
----------------------------------------- exact H50.
----------------------------------------- exact H51.
--------------------------------------- assert (* Cut *) (euclidean__axioms.EF F E H G C E H B) as H53.
---------------------------------------- destruct H34 as [H53 H54].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H55.
----------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
----------------------------------------- apply (@proposition__35.proposition__35 F E H G C B H49 H52 H39 H44).
---------------------------------------- assert (* Cut *) (euclidean__axioms.EF F E H G H B C E) as H54.
----------------------------------------- destruct H34 as [H54 H55].
assert (* Cut *) ((euclidean__axioms.EF F E H G E H B C) /\ ((euclidean__axioms.EF F E H G B H E C) /\ ((euclidean__axioms.EF F E H G H B C E) /\ ((euclidean__axioms.EF F E H G E C B H) /\ ((euclidean__axioms.EF F E H G B C E H) /\ ((euclidean__axioms.EF F E H G H E C B) /\ (euclidean__axioms.EF F E H G C B H E))))))) as H56.
------------------------------------------ apply (@euclidean__axioms.axiom__EFpermutation F E H G C E H B H53).
------------------------------------------ destruct H56 as [H57 H58].
destruct H58 as [H59 H60].
destruct H60 as [H61 H62].
destruct H62 as [H63 H64].
destruct H64 as [H65 H66].
destruct H66 as [H67 H68].
exact H61.
----------------------------------------- assert (* Cut *) (euclidean__axioms.EF H B C E F E H G) as H55.
------------------------------------------ destruct H34 as [H55 H56].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H57.
------------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
------------------------------------------- apply (@euclidean__axioms.axiom__EFsymmetric F E H G H B C E H54).
------------------------------------------ assert (* Cut *) (euclidean__axioms.EF A B C D F E H G) as H56.
------------------------------------------- destruct H34 as [H56 H57].
assert (* Cut *) ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) as H58.
-------------------------------------------- apply (@euclidean__tactics.NNPP ((euclidean__defs.CR E C B H) \/ (euclidean__defs.CR E B H C)) H20).
-------------------------------------------- apply (@euclidean__axioms.axiom__EFtransitive A B C D F E H G H B C E H37 H55).
------------------------------------------- assert (* Cut *) (euclidean__axioms.EF A B C D E F G H) as H57.
-------------------------------------------- destruct H34 as [H57 H58].
assert (* Cut *) ((euclidean__axioms.EF A B C D E H G F) /\ ((euclidean__axioms.EF A B C D G H E F) /\ ((euclidean__axioms.EF A B C D H G F E) /\ ((euclidean__axioms.EF A B C D E F G H) /\ ((euclidean__axioms.EF A B C D G F E H) /\ ((euclidean__axioms.EF A B C D H E F G) /\ (euclidean__axioms.EF A B C D F G H E))))))) as H59.
--------------------------------------------- apply (@euclidean__axioms.axiom__EFpermutation A B C D F E H G H56).
--------------------------------------------- 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].
exact H66.
-------------------------------------------- exact H57.
--------------- exact H21.
Qed.


Require Import HoTT.
Require Import pointed_lemmas.

Section Smash.
  (* Define smash product *)
  Private Inductive smash (A B : pType) : Type :=
    |pair_smash (a : A) (b : B) : (smash A B)
    |hub_l : smash A B
    |hub_r : smash A B.

  Arguments pair_smash {A} {B} a b.
  Arguments hub_l {A} {B}.
  Arguments hub_r {A} {B}.

  Axiom ispointed_pairs_l : forall (A B : pType) (b : B), pair_smash (point A) b = hub_l.
  Axiom ispointed_pairs_r : forall (A B : pType) (a : A), pair_smash a (point B) = hub_r.

  Definition smash_ind (A B : pType)
             (P : smash A B -> Type)
             (pair_smash' : forall (a : A) (b : B), P (pair_smash a b))
             (hub_l' : P (hub_l))
             (hub_r' : P (hub_r))
             (ispointed_pairs_l' : forall (b : B), transport P (ispointed_pairs_l A B b) (pair_smash' (point A) b) = hub_l')
             (ispointed_pairs_r' : forall (a : A), transport P (ispointed_pairs_r A B a) (pair_smash' a (point B)) = hub_r')
                                                   :forall x : smash A B, P x.
  Proof.
    intro x. destruct x.
    - exact (pair_smash' a b).
    - exact hub_l'.
    - exact hub_r'.
  Defined.

  Axiom smash_ind_beta_ispointed_pairs_l :
    forall (A B : pType)
           (P : smash A B -> Type)
           (pair_smash' : forall (a : A) (b : B), P (pair_smash a b))
           (hub_l' : P (hub_l))
           (hub_r' : P (hub_r))
           (ispointed_pairs_l' : forall (b : B), transport P (ispointed_pairs_l A B b) (pair_smash' (point A) b) = hub_l')
           (ispointed_pairs_r' : forall (a : A), transport P (ispointed_pairs_r A B a) (pair_smash' a (point B)) = hub_r')
           (b : B),
      apD (smash_ind A B P pair_smash' hub_l' hub_r' ispointed_pairs_l' ispointed_pairs_r') (ispointed_pairs_l A B b) = ispointed_pairs_l' b.

  Axiom smash_ind_beta_ispointed_pairs_r :
    forall (A B : pType)
           (P : smash A B -> Type)
           (pair_smash' : forall (a : A) (b : B), P (pair_smash a b))
           (hub_l' : P (hub_l))
           (hub_r' : P (hub_r))
           (ispointed_pairs_l' : forall (b : B), transport P (ispointed_pairs_l A B b) (pair_smash' (point A) b) = hub_l')
           (ispointed_pairs_r' : forall (a : A), transport P (ispointed_pairs_r A B a) (pair_smash' a (point B)) = hub_r')
           (a : A),
      apD (smash_ind A B P pair_smash' hub_l' hub_r' ispointed_pairs_l' ispointed_pairs_r') (ispointed_pairs_r A B a) = ispointed_pairs_r' a.
End Smash.

Definition smash_rec (A B : pType)
           (P : Type)
           (pair_smash' : A  -> B -> P)
           (hub_l' : P)
           (hub_r' : P)
           (ispointed_pairs_l' : forall (b : B), pair_smash' (point A) b = hub_l')
           (ispointed_pairs_r' : forall (a : A), pair_smash' a (point B) = hub_r')
  : smash A B -> P.
Proof.
  apply (smash_ind A B (fun _ => P) pair_smash' hub_l' hub_r'); intros;
    refine (transport_const _ _ @ _).
  - exact (ispointed_pairs_l' b).
  - exact (ispointed_pairs_r' a).
Defined.

Definition smash_rec_beta_ispointed_pairs_l (A B : pType)
           (P : Type)
           (pair_smash' : A  -> B -> P)
           (hub_l' : P)
           (hub_r' : P)
           (ispointed_pairs_l' : forall (b : B), pair_smash' (point A) b = hub_l')
           (ispointed_pairs_r' : forall (a : A), pair_smash' a (point B) = hub_r')
           (b : B) :
  ap (smash_rec A B P pair_smash' hub_l' hub_r' ispointed_pairs_l' ispointed_pairs_r')
     (ispointed_pairs_l A B b)
  = ispointed_pairs_l' b.
Proof.
  apply (cancelL (transport_const (ispointed_pairs_l A B b) (pair_smash' (point A) b))).
  transitivity (apD (smash_rec A B P pair_smash' hub_l' hub_r' ispointed_pairs_l' ispointed_pairs_r')
               (ispointed_pairs_l A B b)).
  - symmetry;
      refine
        (apD_const
           (smash_rec A B P pair_smash' hub_l' hub_r' ispointed_pairs_l' ispointed_pairs_r') _).
  - refine (smash_ind_beta_ispointed_pairs_l A B _ _ _ _ _ _ b).
Defined.

Global Instance ispointed_smash {A B : pType} : IsPointed (smash A B) := (hub_l A B).

Definition functor_smash {A B A' B' : pType} (f : A ->* A') (g : B ->* B')
           : smash A B ->* smash A' B'.
Proof.
  srapply @Build_pMap.
  - cbn.
    srapply @smash_rec.
    + intros a b.
      apply pair_smash.
      * exact (f a).
      * exact (g b).
    + apply hub_l.
    + apply hub_r.
    + intros. cbn.
      transitivity (pair_smash A' B' (point A') (g b)).
      { apply (ap (fun a' => pair_smash A' B' a' (g b))). exact (point_eq f). }
      { apply (ispointed_pairs_l A' B'). }
    + intros. cbn.
      transitivity (pair_smash A' B' (f a) (point B')).
      { apply (ap (pair_smash A' B' (f a))). exact (point_eq g). }
      { apply (ispointed_pairs_r A' B'). }
  - cbn. reflexivity.
Defined.


Require Import Metalib.Metatheory.
Require Import Metalib.LibTactics.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Import Strings.String.
Require Import Lia.

Require Import Language.
Require Import Tactical.
Require Import Subtyping.Subtyping.
Require Import Subtyping.Splitable.
Require Import Appsub.

Require Import Value.
Require Import PrincipalTyping.
Require Import Typing.
Require Import Casting.
Require Import LocallyNameless.
Require Import Application.

(** * Definition *)

Inductive step : term -> term -> Prop :=
| St_Lit : forall n,
    step (Lit n) (Ann (Lit n) Int)
| St_Lam : forall e A B,
    step (Lam A e B) (Ann (Lam A e B) (Arr A B))
| St_Spl : forall p A A1 A2,
    pvalue p ->
    splitable A A1 A2 ->
    step (Ann p A) (Mrg (Ann p A1) (Ann p A2))
| St_App : forall v vl e,
    value v -> value vl ->
    papp v vl e ->
    step (App v vl) e
| St_Val : forall v v' A,
    value v ->
    casting v A v' ->
    step (Ann v A) v'
| St_Ann : forall e e' A,
    not (pvalue e) ->
    step e e' ->
    step (Ann e A) (Ann e' A)
| St_App_L : forall e1 e1' e2,
    lc e2 ->
    step e1 e1' ->
    step (App e1 e2) (App e1' e2)
| St_App_R : forall v e2 e2',
    value v ->
    step e2 e2' ->
    step (App v e2) (App v e2')
| St_Mrg_L : forall e1 e1' e2,
    step e1 e1' ->
    step (Mrg e1 e2) (Mrg e1' e2)
| St_Mrg_R : forall v e2 e2',
    value v ->
    step e2 e2' ->
    step (Mrg v e2) (Mrg v e2').

Hint Constructors step : core.

Notation "e ⟾ e'" := (step e e') (at level 68).

(** * Value *)

Lemma value_no_step :
  forall v,
    value v -> forall e, ~ step v e.
Proof.
  introv Val.
  induction v; intros; eauto.
  - intros St.
    dependent destruction Val. dependent destruction St; eauto.
    + eapply IHv1; eauto.
    + eapply IHv2; eauto.
  - dependent destruction Val.
    destruct H.
    + intros St. dependent destruction St; eauto.
    + intros St. dependent destruction St; eauto.
Qed.

Lemma step_lc :
  forall e e',
    lc e -> step e e' -> lc e'.
Proof.
  introv Lc St. gen e'.
  induction Lc; intros;
    try solve [dependent destruction St; eauto 3].
  - dependent destruction St. eapply Lc_Ann. eapply Lc_Lam; eauto.
  - dependent destruction St; try solve [econstructor; eauto].
    pose proof (papp_lc e1 e2 e). eauto 3.
  - dependent destruction St; econstructor; eauto.
  - dependent destruction St.
    + econstructor; eapply Lc_Ann; eapply lc_pvalue; eauto.
    + eapply casting_lc; eauto.
    + econstructor. eauto.
Qed.

Lemma step_value :
  forall v v',
    value v -> step v v' -> value v'.
Proof.
  introv Val St. gen v'.
  induction Val; intros.
  - dependent destruction St; eauto.
  - dependent destruction St; eauto.
Qed.

Hint Resolve step_value : core.

(** * Preservation *)

Ltac ind_term_size s :=
  assert (SizeInd: exists i, s < i) by eauto;
  destruct SizeInd as [i SizeInd];
  repeat match goal with | [ h : term |- _ ] => (gen h) end;
  induction i as [|i IH]; [
      intros; match goal with | [ H : _ < 0 |- _ ] => (dependent destruction H) end
    | intros ].

Theorem preservation :
  forall e e' A,
    typing nil e Inf A ->
    step e e' ->
    (exists B, typing nil e' Inf B /\ isosub B A).
Proof.
  introv Typ St. gen e' A.
  ind_term_size (size_term e).
  dependent destruction Typ; simpl in SizeInd.
  - Case "Lit".
    dependent destruction St; eauto.
    exists Int; eauto.
  - Case "Var".
    dependent destruction St.
  - Case "Lam".
    dependent destruction St; eauto.
    exists (Arr A B). split; eauto.
  - Case "Ann".
    dependent destruction St.
    + SCase "Split".
      dependent destruction Typ.
      exists (And A1 A2). split; eauto.
      pose proof (sub_inv_splitable_r A B A1 A2) as Sub. destruct Sub; eauto.
      eapply Ty_Mrg; eauto.
    + SCase "Value".
      dependent destruction Typ.
      eapply casting_preservation; eauto.
    + SCase "Ann".
      dependent destruction Typ.
      eapply IH in St; eauto; try lia.
      destruct St as [C Typ']. destruct Typ' as [Typ'1 Typ'2].
      pose proof (isosub_to_sub1 _ _ Typ'2).
      exists B. split; eauto. eapply Ty_Ann; eauto; try solve [eapply sub_transitivity; eauto].
      eapply Ty_Sub; eauto. eapply sub_transitivity; eauto.
  - Case "App".
    dependent destruction St.
    + pose proof (papp_preservation e1 e2 e) as P.
      eapply uunisub_sound_appsub in H2.
      eapply P; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply uunisub_sound_appsub in H0.
      eapply appsub_iso in H0; eauto. destruct_conjs.
      eexists; split; eauto. eapply Ty_App; eauto.
      eapply uunisub_complete_appsub; eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs.
      eapply uunisub_sound_appsub in H0.
      eapply appsub_iso in H0; eauto. destruct_conjs.
      eexists; split; eauto. eapply Ty_App; eauto.
      eapply uunisub_complete_appsub; eauto.
  - Case "Merge".
    dependent destruction St.
    + eapply IH in St; eauto; try lia. destruct_conjs. eauto.
    + eapply IH in St; eauto; try lia. destruct_conjs. eauto.
Qed.

Theorem preservation_chk :
  forall e e' A,
    typing nil e Chk A ->
    step e e' ->
    typing nil e' Chk A.
Proof.
  introv Typ St.
  dependent destruction Typ.
  pose proof (preservation _ _ _ Typ St). destruct_conjs.
  eapply Ty_Sub; eauto. eapply isosub_to_sub1 in H2. eapply sub_transitivity; eauto.
Qed.

Theorem preservation_gen :
  forall e e' A dir,
    typing nil e dir A ->
    step e e' ->
    typing nil e' Chk A.
Proof.
  introv Typ St.
  destruct dir.
  - pose proof (preservation _ _ _ Typ St). destruct_conjs.
    eapply Ty_Sub; eauto. eapply isosub_to_sub1 in H1. auto.
  - eapply preservation_chk; eauto.
Qed.

(** * Progress *)

Theorem progress :
  forall e A dir,
    typing nil e dir A ->
    value e \/ exists e', step e e'.
Proof.
  introv Typ.
  dependent induction Typ; eauto 3.
  - Case "Anno".
    destruct IHTyp as [Val | St] ; eauto.
    + right. eapply casting_progress in Typ; eauto. destruct Typ.
      exists x. eapply St_Val; eauto.
    + destruct (pvalue_decidable e) as [Pv | nPv];
        destruct (splitable_or_ordinary A) as [Spl | Ord]; eauto.
      * destruct Pv; right; destruct_conjs; eexists; eauto.
      * destruct St. right. eexists; eauto.
      * destruct St. right. eexists; eauto.
  - Case "App".
    right. destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
    pose proof (papp_progress e1 e2 A B C) as P. destruct P; eauto.
    eapply uunisub_sound_appsub; eauto.
  - Case "Merge".
    destruct IHTyp1; destruct IHTyp2; eauto 3; try solve [destruct_conjs; eauto].
Qed.

(** * Soundness *)

Definition relation (X : Type) := X -> X -> Prop.

Inductive multi {X : Type} (R : relation X) : relation X :=
| multi_refl : forall (x : X), multi R x x
| multi_step : forall (x y z : X), R x y -> multi R y z -> multi R x z.

Notation multistep := (multi step).

Definition normal_form {X : Type} (R : relation X) (e : X) : Prop :=
  not (exists e', R e e').

Definition stuck (e : term) : Prop :=
  (normal_form step) e /\ ~ value e.

Corollary soundness :
  forall e e' A dir,
    typing nil e dir A ->
    multistep e e' ->
    ~ (stuck e').
Proof.
  introv Typ Mult. unfold stuck.
  intros [Nf Nval]. unfold normal_form in Nf. gen A dir.
  dependent induction Mult; intros.
  - pose proof (progress _ _ _ Typ). destruct H; eauto.
  - destruct dir.
    + pose proof (preservation _ _ _ Typ H) as Prv.
      destruct Prv. destruct H0.
      eapply IHMult; eauto.
    + pose proof (preservation_chk _ _ _ Typ H) as Prv.
      dependent destruction Prv.
      eapply IHMult; eauto.
Qed.

Print Assumptions soundness.


From QuickChick Require Import QuickChick Tactics Instances Classes DependentClasses.
Require Import String. Open Scope string.
Require Import List.

From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.

Import GenLow GenHigh .

Import ListNotations.
Import QcDefaultNotation. Open Scope qc_scope.

Set Bullet Behavior "Strict Subproofs".

Typeclasses eauto := debug.

Require Import DependentTest.

(* XXX these instances should be present *)
Existing Instance GenSizedFoo.
Existing Instance ShrinkFoo.
Derive Sized for Foo.
Derive SizeMonotonic for Foo using GenSizedFoo.
Derive SizedMonotonic for Foo using GenSizedFoo.
Derive CanonicalSized for Foo.
Derive SizedCorrect for Foo using GenSizedFoo and SizeMonotonicFoo.

Inductive tree : Type :=
| Leaf : tree
| Node : nat -> tree -> tree -> tree.

(* Example with two IH *)
Inductive goodTree : nat -> tree -> Prop :=
| GL : goodTree 0 Leaf
| GN : forall k t1 t2 n m, goodTree n t1 ->
                      goodTree m t2 ->
                      goodTree m t1 ->
                      goodTree (S n) (Node k t1 t2).

(* Derive DecOpt for (goodTree n t). *)
Instance DecgoodTree (n : nat) (t : tree) : Dec (goodTree n t).
Admitted.

Instance DecTreeEq (t1 t2 : tree) : Dec (t1 = t2).
dec_eq. Defined.

Existing Instance GenOfGenSized.
Existing Instance genNatSized.

Derive ArbitrarySizedSuchThat for (fun foo => goodTree n foo).

QuickChickDebug Debug On.

Derive SizedProofEqs for (fun foo => goodTree n foo).

Derive SizeMonotonicSuchThatOpt for (fun foo => goodTree n foo).

Derive GenSizedSuchThatCorrect for (fun foo => goodTree n foo).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodTree n foo).

Definition genSTgooTree (n : nat) := @arbitraryST _ (fun foo => goodTree n foo) _.

(* Definition genSTgooTreeSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => goodTree n foo) _) _. *)

Existing Instance GenSizedSuchThatgoodFooUnif. (* ???? *)

Derive SizeMonotonicSuchThatOpt for (fun (x : Foo) => goodFooUnif input x).

Derive SizedProofEqs for (fun foo => goodFooUnif n foo).

Derive GenSizedSuchThatCorrect for (fun foo => goodFooUnif n foo).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooUnif n foo).

Definition genSTgoodFooUnif (n : nat) := @arbitraryST _  (fun foo => goodFooUnif n foo) _.

Definition genSTgoodFooUnifSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => goodFooUnif n foo) _) _.

(* Interesting. Do we need  Global instance?? *)
Existing Instance GenSizedSuchThatgoodFooNarrow.  (* Why???? *)

Derive SizeMonotonicSuchThatOpt for (fun foo => goodFooNarrow n foo).

Derive SizedProofEqs for (fun foo => goodFooNarrow n foo).

Derive GenSizedSuchThatCorrect for (fun foo => goodFooNarrow n foo).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooNarrow n foo).

Definition genSTgoodFooNarrow (n : nat) := @arbitraryST _  (fun foo => goodFooNarrow n foo) _.

Definition genSTgoodFooNarrowSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => goodFooNarrow n foo) _) _.

Existing Instance GenSizedSuchThatgoodFooCombo.

Derive SizeMonotonicSuchThatOpt for (fun foo => goodFooCombo n foo).

Derive SizedProofEqs for (fun foo => goodFooCombo n foo).

Derive GenSizedSuchThatCorrect for (fun foo => goodFooCombo n foo).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooCombo n foo).

Definition genSTgoodFooCombo (n : nat) := @arbitraryST _  (fun foo => goodFooCombo n foo) _.

Definition genSTgoodFooComboSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => goodFooCombo n foo) _) _.

Existing Instance GenSizedSuchThatgoodFoo.

Derive SizeMonotonicSuchThatOpt for (fun (x : Foo) => goodFoo input x).

Derive SizedProofEqs for (fun (x : Foo) => goodFoo input x).

Derive GenSizedSuchThatCorrect for (fun foo => goodFoo n foo).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFoo n foo).

Definition genSTgoodFoo (n : nat) := @arbitraryST _  (fun foo => goodFoo n foo) _.

Definition genSTgoodFooSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => goodFoo n foo) _) _.

Existing Instance GenSizedSuchThatgoodFooPrec.  (* ???? *)

Derive SizeMonotonicSuchThatOpt for (fun (x : Foo) => goodFooPrec input x).

Derive SizedProofEqs for (fun (x : Foo) => goodFooPrec input x).

Derive GenSizedSuchThatCorrect for (fun foo => goodFooPrec n foo).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooPrec n foo).

Definition genSTgoodFooPrec (n : nat) := @arbitraryST _  (fun foo => goodFooPrec n foo) _.

Definition genSTgoodFooPrecSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => goodFooPrec n foo) _) _.

Existing Instance GenSizedSuchThatgoodFooMatch.  (* ???? *)

Derive SizeMonotonicSuchThatOpt for (fun foo => goodFooMatch n foo).

Derive SizedProofEqs for (fun foo => goodFooMatch n foo).

Derive GenSizedSuchThatCorrect for (fun foo => goodFooMatch n foo).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooMatch n foo).

Definition genSTgoodFooMatch (n : nat) := @arbitraryST _  (fun foo => goodFooMatch n foo) _.

Definition genSTgoodFooMatchSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => goodFooMatch n foo) _) _.

Existing Instance GenSizedSuchThatgoodFooRec.  (* ???? *)

Derive SizeMonotonicSuchThatOpt for (fun (x : Foo) => goodFooRec input x).

Derive SizedProofEqs for (fun (x : Foo) => goodFooRec input x).

Derive GenSizedSuchThatCorrect for (fun foo => goodFooRec n foo).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => goodFooRec n foo).

Definition genSTgoodFooRec (n : nat) := @arbitraryST _  (fun foo => goodFooRec n foo) _.

Definition genSTgoodFooRecSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => goodFooRec n foo) _) _.

Inductive goodFooB : nat -> Foo -> Prop :=
| GF1 : goodFooB 2 (Foo2 Foo1)
| GF2 : goodFooB 3 (Foo2 (Foo2 Foo1)).

Derive ArbitrarySizedSuchThat for (fun (x : Foo) => goodFooB input x).

Derive SizedProofEqs for (fun (x : Foo) => goodFooB input x).

Derive SizeMonotonicSuchThatOpt for (fun foo => goodFooB n foo).

Derive GenSizedSuchThatCorrect for (fun foo => goodFooB n foo).

Derive GenSizedSuchThatSizeMonotonicOpt for  (fun foo => goodFooB n foo).

Definition genSTgoodFooB (n : nat) := @arbitraryST _  (fun foo => goodFooB n foo) _.

Definition genSTgoodFooBSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => goodFooB n foo) _) _.

(* Derive SizeMonotonicSuchThat for (fun foo => goodTree n foo). *)
(* XXX
   bug for
| GL : goodTree 0 Leaf
| GN : forall k t1 t2 n, goodTree n t1 ->
                      ~ t1 =  t2 ->υ
                      (* goodTree m t1 -> *)
                      goodTree (S n) (Node k t1 t2).
 *)

Inductive LRTree : tree -> Prop :=
| PLeaf : LRTree Leaf
| PNode :
    forall m t1 t2,
      ~ t1 = Node 2 Leaf Leaf ->
      ~ Node 4 Leaf Leaf = t1 ->
      LRTree t1 ->
      LRTree t2 ->
      LRTree (Node m t1 t2).

Derive ArbitrarySizedSuchThat for (fun (x : tree) => LRTree x).

(* XXX sucThatMaybe case *)

Instance DecidableLRTree t : Dec (LRTree t).
Proof.
Admitted.

Derive SizedProofEqs for (fun (x : tree) => LRTree x).

Derive SizeMonotonicSuchThatOpt for (fun foo => LRTree foo).

Derive GenSizedSuchThatCorrect for (fun foo => LRTree foo).

Derive GenSizedSuchThatSizeMonotonicOpt for (fun foo => LRTree foo).

Definition genSTLRTree (n : nat) := @arbitraryST _  (fun foo => LRTree foo) _.

Definition genSTLRTreeSound (n : nat) := @STCorrect _ _ (@arbitraryST _  (fun foo => LRTree foo) _) _.

Inductive HeightTree : nat -> tree -> Prop :=
| HLeaf : forall n, HeightTree n Leaf
| HNode :
    forall t1 t2 n m,
      HeightTree n t1 ->
      HeightTree n t2 ->
      HeightTree (S n) (Node m t1 t2).

Instance ArbitrarySuchThatEql {A} (x : A) : GenSuchThat A (fun y => eq x y) :=
  {| arbitraryST := returnGen (Some x) |}.

(* XXX breaks gen *)

(* Inductive ex_test : tree -> Prop := *)
(* | B : ex_test Leaf  *)
(* | Ind : *)
(*     forall (list  y12  : nat) t, *)
(*       list = y12 -> *)
(*       ex_test (Node 4 t t). *)

(* Derive ArbitrarySizedSuchThat for (fun (x : tree) => ex_test x). *)

(* Set Printing All.  *)

(* Inductive LRTree : tree -> Prop := *)
(* | PLeaf : LRTree Leaf *)
(* | PNode : *)
(*     forall m t1 t2, *)
(*       Node 2 Leaf Leaf = t1 -> *)
(*       t1 = Node 2 Leaf Leaf -> *)
(*       LRTree t1 -> *)
(*       LRTree t2 -> *)
(*       LRTree (Node m t1 t2). *)

(* Inductive test : nat -> Foo -> Prop := *)
(* | T : forall (x : False), test 1 Foo1. *)

(* Derive ArbitrarySizedSuchThat for (fun foo => test n foo). *)

(* Inductive test1 : bool -> Foo -> Prop := *)
(* | T1 : forall (x1 x2 x3 : bool), x1 = x3 -> test1 x2 Foo1. *)

(* Derive ArbitrarySizedSuchThat for (fun foo => test1 n foo). *)

(* Inductive test2 : nat -> Foo -> Prop := *)
(* | T2 : forall (x1 x2 : bool), x1 = x2 ->  test2 1 Foo1. *)

(* Derive ArbitrarySizedSuchThat for (fun foo => test2 n foo). *)

(* XXX weird bug when naming binders with name of already existing ids,
   e.g. nat, list*)

(* Inductive HeightTree : nat -> tree -> Prop := *)
(* | HLeaf : forall n, HeightTree n Leaf *)
(* | HNode : *)
(*     forall t1 t2 n k m, *)
(*       k = 3 -> *)
(*       HeightTree k t2 -> *)
(*       HeightTree k t1 -> *)
(*       HeightTree n (Node m t1 t2). *)

(* Inductive goodTree : nat -> tree -> Prop := *)
(* | GL : goodTree 0 Leaf *)
(* | GN : forall k t1 t2 n m, goodTree n t1 -> *)
(*                       goodTree m t2 -> *)
(*                       goodTree (n + m + 1) (Node k t1 t2). *)

(* Lemma test2 {A} (gs1 gs2 : nat -> list (nat * G (option A))) s s1 s2 :  *)
(*       \bigcup_(g in gs1 s1) (semGenSize (snd g) s) \subset  \bigcup_(g in gs2 s2) (semGenSize (snd g) s) -> *)
(*       semGenSize (backtrack (gs1 s1)) s \subset semGenSize (backtrack (gs2 s2)) s. *)
(* Admitted. *)

(* Goal (forall inp : nat, SizedMonotonic (@arbitrarySizeST Foo (fun (x : Foo) => goodFooRec inp x) _)). *)
(* Proof. *)
(*   intros inp. *)
(*   constructor. *)
(*   intros s s1 s2. *)
(*   revert inp. *)
(*   induction s1; induction s2; intros. *)
(*   - simpl. eapply subset_refl. *)
(*   - simpl. *)
(*     refine (test *)
(*               (fun s => [(1, returnGen (Some Foo1))]) *)
(*               (fun s => [(1, returnGen (Some Foo1)); *)
(*                        (1, *)
(*                         doM! foo <- *)
(*                            (fix aux_arb (size0 input0_ : nat) {struct size0} :  *)
(*                               G (option Foo) := *)
(*                               match size0 with *)
(*                                 | 0 => backtrack [(1, returnGen (Some Foo1))] *)
(*                                 | size'.+1 => *)
(*                                   backtrack *)
(*                                     [(1, returnGen (Some Foo1)); *)
(*                                       (1, doM! foo <- aux_arb size' 0; returnGen (Some (Foo2 foo)))] *)
(*                               end) s 0; returnGen (Some (Foo2 foo)))]) *)
(*               s 0 s2 _). *)
(*     admit. *)
(*   - ssromega. *)
(*   - simpl. *)
(*     refine (test *)
(*               (fun s => [(1, returnGen (Some Foo1)); *)
(*                        (1, *)
(*                         doM! foo <- *)
(*                            (fix aux_arb (size0 input0_ : nat) {struct size0} :  *)
(*                               G (option Foo) := *)
(*                               match size0 with *)
(*                                 | 0 => backtrack [(1, returnGen (Some Foo1))] *)
(*                                 | size'.+1 => *)
(*                                   backtrack *)
(*                                     [(1, returnGen (Some Foo1)); *)
(*                                       (1, doM! foo <- aux_arb size' 0; returnGen (Some (Foo2 foo)))] *)
(*                               end) s 0; returnGen (Some (Foo2 foo)))]) *)
(*               (fun s => [(1, returnGen (Some Foo1)); *)
(*                        (1, *)
(*                         doM! foo <- *)
(*                            (fix aux_arb (size0 input0_ : nat) {struct size0} :  *)
(*                               G (option Foo) := *)
(*                               match size0 with *)
(*                                 | 0 => backtrack [(1, returnGen (Some Foo1))] *)
(*                                 | size'.+1 => *)
(*                                   backtrack *)
(*                                     [(1, returnGen (Some Foo1)); *)
(*                                       (1, doM! foo <- aux_arb size' 0; returnGen (Some (Foo2 foo)))] *)
(*                               end) s 0; returnGen (Some (Foo2 foo)))]) *)
(*               s s1 s2 _). *)
(*     admit. *)

Definition success := "Proofs work!".
Print success.


Require  Coq.Program.Program.

Require Import CoRN.reals.fast.CRln.

Require Export hybrid.examples.room_heating.params.
Require Import hybrid.tactics.
Require Import hybrid.util.
Require Import hybrid.c_util.
Require Import hybrid.nat_util.
Require Import hybrid.list_util.
Require Import hybrid.hs_solver.
Require Import hybrid.monotonic_flow.
Require Import hybrid.vector_setoid.
Require Import hybrid.square_abstraction.
Require Import hybrid.decreasing_exponential_flow.
Require Import stability.

Set Implicit Arguments.

Local Open Scope CR_scope.
Local Open Scope vec_scope.

(** * Instantiation of room heating to a given
      specification *)
Module RoomHeatingConcrete (Import RHS : RoomHeatingSpec).

   (** A state of the room. *)
  Inductive RoomState :=
  | NoHeater   (**r no heater in the room *)
  | HeaterOn   (**r there is heater and it's on *)
  | HeaterOff  (**r there is heater and it's off *)
  .

  Definition hasHeater rs :=
    match rs with
    | HeaterOn | HeaterOff => true
    | NoHeater => false
    end.

   (** The discreet state of the system consists of
       states of all the rooms. *)
  Definition DS := vector RoomState n.

  Instance DS_eq_dec: EquivDec.EqDec DS eq.
  Proof.
    unfold EquivDec.EqDec. apply eq_vec_dec.
    decide equality.
  Defined.

  Fixpoint exhaustiveRS (n : nat) : list (vector RoomState n) :=
    match n with
    | 0%nat => [ Vnil ]
    | S p =>
        let all rs := List.map (fun vs => Vcons rs vs) (exhaustiveRS p) in
          all NoHeater ++ all HeaterOn ++ all HeaterOff
    end.

  Ltac in_or_app_proof :=
    solve
    [ apply in_map; auto
    | apply in_or_app; left; in_or_app_proof
    | apply in_or_app; right; in_or_app_proof
    ].

  Lemma exhaustiveRS_correct x : In x (exhaustiveRS n).
  Proof with auto.
    induction x.
    crunch.
    simpl. destruct a; in_or_app_proof.
  Qed.

  Instance locations : ExhaustiveList DS :=
    { exhaustive_list := exhaustiveRS n }.
  Proof.
    apply exhaustiveRS_correct.
  Defined.

  Lemma exhaustiveRS_NoDup n : NoDup (exhaustiveRS n).
  Proof with auto.
    induction n0; simpl.
    constructor...
    repeat apply NoDup_app; intros;
      try solve
      [ apply NoDup_map; auto; intros;
        match goal with
        | H: Vcons ?a ?x = Vcons ?b ?y |- _ =>
            set (w := Vcons_eq a b x y); intuition
        end
      | intro;
        match goal with
        | H: In _ (_ ++ _) |- _ =>
            destruct (in_app_or H); clear H
        | _ => idtac
        end;
        match goal with
        | H: In ?x _, H': In ?x _ |- _ =>
          let l := fresh "l" in set (l := ListUtil.in_map_elim H);
          let r := fresh "r" in set (r := ListUtil.in_map_elim H')
        end;
        decomp; subst; discriminate
      ].
  Qed.

  Lemma NoDup_locations : NoDup locations.
  Proof.
    apply exhaustiveRS_NoDup.
  Qed.

   (** The continuous state of the system consists of
       temperatures of all the rooms. *)
  Definition CS := vecCSetoid CRasCSetoid n.

  Definition State := (DS * CS)%type.
  Definition ds : State -> DS := fst.
  Definition cs : State -> CS := snd.

   (** initial state predicate *)
  Definition initial (s : State) : Prop :=
    let init_room i ip :=
      match initHeaters [@ip] with
      | false => NoHeater
      | true =>
          let temp := initTemp [@ip] in
          let threshold := on [@ip] in
            match Qlt_le_dec temp threshold with
            | left _ => HeaterOn
            | right _ => HeaterOff
            end
      end
    in
    let check_temp actual prescribed := actual = 'prescribed in
      ds s = Vbuild init_room /\
      Vforall2n check_temp (cs s) initTemp.

   (** invariant *)
  Definition invariant (s : State) : Prop :=
    let check_room i ip :=
      let temp := (cs s) [@ip] in
      let roomState := (ds s) [@ip] in
        match roomState with
          (* no heater, no invariant *)
        | NoHeater => True
          (* heater on, temperature below [off] threshold *)
        | HeaterOn => temp <= '(off [@ip])
          (* heater off, temperature above [on] threshold *)
        | HeaterOff => '(on [@ip]) <= temp
        end
    in
      check_n check_room.

  Lemma initial_invariant s : initial s -> invariant s.
  Proof with auto.
    intros [dS cS] [init_dS init_cS].
    simpl in *. subst.
    apply check_n_holds. intros. simpl in *.
    unfold roomState. rewrite Vbuild_nth.
    destruct (initHeaters [@ip])...
    unfold temp.
    destruct (Qlt_le_dec (initTemp [@ip]) (on [@ip]));
      rewrite (Vforall2n_nth _ _ _ ip init_cS);
      eapply (proj2 (CRle_Qle _ _))...
    apply Qlt_le_weak. apply Qlt_trans with (on [@ip])...
    apply (Vforall2n_nth _ _ _ ip on_lt_off).
  Qed.

  Lemma invariant_wd: forall l l', l = l' ->
    forall (p p': CS), p [=] p' -> (invariant (l, p) <-> invariant (l', p')).
  Proof.
    unfold invariant. intros. subst.
    apply check_n_equiv. intros. simpl.
    destruct (l')[@ip].
    tauto.
     (* FIXME: This should be handled by simple rewrite with setoid! *)
    rewrite (Vnth_Cmorph ip _ _ H0). tauto.
    rewrite (Vnth_Cmorph ip _ _ H0). tauto.
  Qed.

  Definition temp_reset (l1 l2 : DS) : square_abstraction.Reset :=
    square_abstraction.Reset_id.

  Definition reset (l1 l2 : DS) (cs : CS) : CS :=
    Vmap (square_abstraction.apply_Reset (temp_reset l1 l2)) cs.

  Definition guard (s : State) (l2 : DS) : Prop :=
    let (l1, cs) := s in
      (* a heater is moved from room [j] to room [i] *)
      exists i, exists ip : (i < n)%nat,
      exists j, exists jp : (j < n)%nat,
         (* rooms other than [i] and [j] remain unchanged *)
        (forall k (kp : (k < n)%nat),
          k <> i -> k <> j -> l1 [@kp] = l2 [@kp]) /\
         (* room [i] had no heater and now gets one *)
        hasHeater (l1 [@ip]) = false /\ hasHeater (l2 [@ip]) = true /\
         (* room [j] had a heater and now it's removed *)
        hasHeater (l1 [@jp]) = true  /\ hasHeater (l2 [@jp]) = false /\
         (* temperature in room [i] is <= [get_i] *)
        cs [@ip] <= '(get [@ip]) /\
         (* the difference of temperatures in rooms [j] and [i] is at
            least [diff_i] *)
        '(diff [@ip]) <= (cs [@jp]) - (cs [@ip]).

  Definition room_flow (rs : RoomState) : Flow CRasCSetoid :=
    match rs with
    | HeaterOn => flow.scale.flow ('2) flow.positive_linear.f
    | HeaterOff | NoHeater => decreasing_exponential_flow.f
    end.

  Definition flow (l : DS) := vector_flow (Vmap room_flow l).

  Lemma invariant_stable s: Stable (invariant s).
  Proof.
    intros. apply check_n_Stable.
    intros. destruct (ds s) [@ip]; crunch.
  Qed.

  Definition concrete_system: concrete.System :=
    concrete.Build_System _ _ NoDup_locations
    initial_invariant invariant_wd invariant_stable flow guard reset.

End RoomHeatingConcrete.