Require Import List.
Import ListNotations.

Require Import Relations.

Require Import Permutation.

Require Import StructTact.StructTactics.
Require Import Net.

Section dup_drop_reorder.
  Variable A : Type.
  Hypothesis A_eq_dec : forall x y : A, {x = y} + {x <> y}.

  Inductive dup_drop_step : list A -> list A -> Prop :=
  | DDS_dup : forall l p,
      In p l ->
      dup_drop_step l (p :: l)
  | DDS_drop : forall xs p ys,
      dup_drop_step (xs ++ p :: ys) (xs ++ ys).

  Definition dup_drop_step_star := clos_refl_trans_n1 _ dup_drop_step.

  Lemma dup_drop_step_star_trans :
    forall l l' l'',
      dup_drop_step_star l l' ->
      dup_drop_step_star l' l'' ->
      dup_drop_step_star l l''.
  Proof using.
    intros.
    apply clos_rt_rtn1_iff.
    eapply rt_trans; apply clos_rt_rtn1_iff; eauto.
  Qed.

  Lemma dup_drop_step_star_step_n1 :
    forall l l' l'',
      dup_drop_step_star l l' ->
      dup_drop_step l' l'' ->
      dup_drop_step_star l l''.
  Proof using.
    intros.
    econstructor; eauto.
  Qed.

  Lemma dup_drop_step_star_step_1n :
    forall l l' l'',
      dup_drop_step l l' ->
      dup_drop_step_star l' l'' ->
      dup_drop_step_star l l''.
  Proof using.
    intros.
    apply clos_rt_rtn1_iff.
    apply clos_rt_rt1n_iff.
    econstructor; [eauto|].
    apply clos_rt_rt1n_iff.
    apply clos_rt_rtn1_iff.
    auto.
  Qed.

  Lemma dup_drop_step_star_step_1 :
    forall l l',
      dup_drop_step l l' ->
      dup_drop_step_star l l'.
  Proof using.
    intros.
    eapply dup_drop_step_star_step_1n; eauto.
    constructor.
  Qed.

  Lemma dup_drop_swap :
    forall l x y,
      dup_drop_step_star (x :: y :: l) (y :: x :: l).
  Proof using.
    intros.
    eapply dup_drop_step_star_step_1n; [eapply DDS_dup with (p := y); simpl; auto|].
    eapply dup_drop_step_star_step_1n.
    eapply DDS_drop with (xs := [y; x]) (p := y) (ys := l).
    constructor.
  Qed.

  Lemma dup_drop_cons :
    forall l l' x,
      dup_drop_step_star l l' ->
      dup_drop_step_star (x :: l) (x :: l').
  Proof using.
    induction 1.
    - constructor.
    - invc H.
      + eapply dup_drop_step_star_trans; [eauto|].
        eapply dup_drop_step_star_step_1n; [eapply DDS_dup with (p := p); simpl; auto|].
        auto using dup_drop_swap.
      + eapply dup_drop_step_star_trans; [eauto|].
        eapply dup_drop_step_star_step_1n.
        eapply DDS_drop with (xs := x :: xs) (p := p) (ys := ys).
        constructor.
  Qed.

  Lemma dup_drop_Permutation :
    forall l l',
      Permutation l l' ->
      dup_drop_step_star l l'.
  Proof using.
    induction 1.
    - constructor.
    - auto using dup_drop_cons.
    - auto using dup_drop_swap.
    - eauto using dup_drop_step_star_trans.
  Qed.

  Lemma remove_not_in_nop :
    forall a l,
      ~ In a l ->
      remove A_eq_dec a l = l.
  Proof using.
    induction l; simpl; intuition.
    break_if; congruence.
  Qed.

  Lemma dup_drop_in :
    forall l l' a,
      dup_drop_step_star l l' ->
      In a l' ->
      In a l.
  Proof using.
    induction 1; intros.
    - auto.
    - invc H.
      + simpl in *. intuition.
        subst. auto.
      + apply IHclos_refl_trans_n1.
        find_apply_lem_hyp in_app_or.
        intuition.
  Qed.

  Lemma dup_drop_dup_early :
    forall l l' a,
      dup_drop_step_star l l' ->
      In a l ->
      dup_drop_step_star l (a :: l').
  Proof using.
    induction 1; intros.
    - apply dup_drop_step_star_step_1. constructor. auto.
    - concludes.
      eapply dup_drop_step_star_trans; eauto.
      apply dup_drop_cons.
      apply dup_drop_step_star_step_1.
      auto.
  Qed.

  Lemma dup_drop_step_star_remove_In :
    forall l' l a,
      In a l' ->
      dup_drop_step_star l (remove A_eq_dec a l') ->
      dup_drop_step_star (a :: l) l'.
  Proof using.
    induction l'; simpl; intuition.
    - subst. break_if; try congruence.
      destruct (in_dec A_eq_dec a0 l').
      + find_apply_hyp_hyp.
        eapply dup_drop_step_star_trans; eauto.
        eapply dup_drop_step_star_step_1.
        apply DDS_dup; auto.
      + rewrite remove_not_in_nop in * by auto.
        apply dup_drop_cons. auto.
    - break_if.
      + subst.
        find_apply_hyp_hyp.
        eapply dup_drop_step_star_trans; eauto.
        eapply dup_drop_step_star_step_1.
        apply DDS_dup; auto.
      + pose proof dup_drop_in l _ a ltac:(eauto).
        concludes.
        eapply dup_drop_step_star_step_n1 in H0; [| eapply DDS_drop with (xs := [])].
        simpl in *.
        apply IHl' in H0; auto.
        apply dup_drop_dup_early; auto.
        simpl. intuition.
  Qed.

  Lemma remove_In_elim :
    forall x a l,
      In x (remove A_eq_dec a l) ->
      x <> a /\ In x l.
  Proof using.
    induction l; simpl; intuition; break_if; subst; simpl in *; intuition.
  Qed.

  Lemma dup_drop_reorder :
    forall l l' : list A,
      (forall x, In x l' -> In x l) ->
      dup_drop_step_star l l'.
  Proof using A_eq_dec.
    induction l; intros.
    - destruct l'.
      + constructor.
      + simpl in *. exfalso. eauto.
    - destruct (in_dec A_eq_dec a l').
      + eapply dup_drop_step_star_remove_In. auto.
        apply IHl.
        intros.
        find_apply_lem_hyp remove_In_elim.
        intuition.
        find_apply_hyp_hyp.
        simpl in *. intuition.
        exfalso. eauto.
      + eapply dup_drop_step_star_step_1n.
        eapply DDS_drop with (xs := []).
        apply IHl.
        simpl in *. intros.
        find_copy_apply_hyp_hyp.
        intuition.
        subst. exfalso. eauto.
  Qed.
End dup_drop_reorder.

Section step_f_dup_drop_step.
  Context `{params : FailureParams}.

  Theorem step_f_dup_drop_step :
    forall ps ps' Sigma f,
      dup_drop_step_star _ ps ps' ->
      step_f_star (f, mkNetwork ps Sigma) (f, mkNetwork ps' Sigma) [].
  Proof using.
    induction 1.
    - constructor.
    - match goal with
      | [ H : dup_drop_step _ _ _ |- _ ] => invc H
      end.
      + find_apply_lem_hyp in_split. break_exists. break_and. subst.
        apply refl_trans_n1_1n_trace.
        eapply RTn1TStep with (cs := []).
        * apply refl_trans_1n_n1_trace.
          apply IHclos_refl_trans_n1.
        * eapply SF_dup; [simpl; eauto|]. auto.
      + apply refl_trans_n1_1n_trace.
        eapply RTn1TStep with (cs := []).
        * apply refl_trans_1n_n1_trace.
          apply IHclos_refl_trans_n1.
        * eapply SF_drop; [simpl; eauto|]. auto.
  Qed.
End step_f_dup_drop_step.


From mathcomp Require Import ssreflect ssrbool ssrfun.
From mathcomp Require Import eqtype seq order.
From ipcssr Require Import avlmap kripke_trees in_ngamma.

Section Disjunct.
Context {disp : unit} {A : orderType disp}.

Definition a_ai_disj (a : atoms A) (ai : atomic_imps A) : Prop :=
  forall i, lookup a i -> ~~ lookup ai i.

Definition a_goal_disj (a : atoms A) (goal : A) : Prop :=
  ~~ lookup a goal.

Lemma disjs_insert_ai i b a ai :
  invariant ai ->
  a_ai_disj a ai -> ~~ lookup a i ->
  a_ai_disj a (update_aimps b i ai).1.
Proof.
rewrite /a_ai_disj=>Ha Hd Hi j Hj.
rewrite lookup_upsert //=; case: eqP=>[E|_].
- by rewrite -E Hj in Hi.
by apply: Hd.
Qed.

Lemma disjs_delete_ai i a ai :
  invariant a -> invariant ai ->
  a_ai_disj a ai ->
  a_ai_disj (update_atoms i a).1 (delete i ai).1.
Proof.
rewrite /a_ai_disj =>Ha Hai Hd j.
rewrite lookup_upsert // lookup_delete //=; case: eqP=>//= _.
by apply: Hd.
Qed.

Lemma goal_disj_insert_a i goal a :
  invariant a ->
  a_goal_disj a goal -> goal != i ->
  a_goal_disj (update_atoms i a).1 goal.
Proof.
rewrite /a_goal_disj =>Ha Hd N.
by rewrite lookup_upsert //= (negbTE N).
Qed.

Lemma disjs_insert_a i a ai :
  invariant a ->
  a_ai_disj a ai -> ~~ lookup ai i -> (* could also be positive: lookup a i *)
  a_ai_disj (update_atoms i a).1 ai.
Proof.
rewrite /a_ai_disj =>Ha Hd N j.
rewrite lookup_upsert //=; case: eqP=>[{j}->|_ ] //.
by apply: Hd.
Qed.

End Disjunct.


Require Import GeoCoq.Axioms.continuity_axioms.
Require Import GeoCoq.Tarski_dev.Annexes.circles.

Section Dedekind_circle_circle.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** This proof is inspired by Franz Rothe's proof of Theorem 8.5 in Several topics from geometry *)

Lemma circle_circle_aux : (forall A B C D P Q,
  OnCircle P C D -> OnCircle Q C D -> InCircleS P A B -> OutCircleS Q A B ->
  OS A C P Q \/ (Col P A C /\ ~ Col Q A C) \/ (~ Col P A C /\ Col Q A C ) ->
  exists Z : Tpoint, OnCircle Z A B /\ OnCircle Z C D) ->
  circle_circle.
Proof.
  intro Haux.
  cut (forall A B C D P Q,
  OnCircle P C D -> OnCircle Q C D -> InCircleS P A B -> OutCircleS Q A B ->
  Coplanar A C P Q -> (~ Col P A C \/ ~ Col Q A C) ->
  exists Z : Tpoint, OnCircle Z A B /\ OnCircle Z C D).
  - intros Haux' A B C D P Q HPOn HQOn HPIn HQOut.
    assert (HQ' : exists Q', OnCircle Q' C D /\ OutCircle Q' A B /\ Col Q' A C).
    { destruct (segment_construction A C C D) as [Q' []].
      exists Q'.
      repeat split; Col.
      apply le_transitivity with A Q; trivial.
      apply triangle_inequality with C; trivial.
      apply cong_transitivity with C D; Cong.
    }
    clear dependent Q.
    destruct HQ' as [Q [HQOn [HQOut HCol]]].
    destruct (cong_dec A P A B).
      exists P; split; trivial.
    destruct (cong_dec A B A Q).
      exists Q; Circle.
    assert (HPInS : InCircleS P A B) by (split; trivial).
    assert (HQOutS : OutCircleS Q A B) by (split; trivial).
    assert (A <> C).
    { intro; subst C.
      apply (not_and_lt A B A P); split; trivial.
      apply (cong2_lt__lt A B A Q); Cong.
      apply cong_transitivity with A D; Cong.
    }
    assert (C <> D).
      intro; treat_equalities; apply (not_and_lt A C A B); split; trivial.
    destruct (col_dec P A C); [|apply Haux' with P Q; Cop].
    destruct (exists_cong_per A C C D) as [R [HR1 HR2]].
    assert_diffs.
    apply per_not_col in HR1; auto.
    destruct (circle_cases A B R) as [HOn|HNOn].
      exists R; split; trivial.
    destruct HNOn; [apply Haux' with R Q|apply Haux' with P R]; Col; Cop.

  - intros A B C D P Q HPOn HQOn HPIn HQOut HCop HDij.
    destruct (col_dec P A C) as [HCol|HNCol].
    { destruct HDij.
        contradiction.
      apply Haux with P Q; auto.
    }
    destruct (col_dec Q A C).
      apply Haux with P Q; auto.
    destruct (cop__one_or_two_sides A C P Q); trivial; [|apply Haux with P Q; auto].
    destruct (l10_2_existence A C P) as [P' HP'].
    assert_diffs.
    apply Haux with P' Q; trivial.
      apply cong_transitivity with C P; trivial.
      apply cong_commutativity, (is_image_col_cong A C); Col.
      apply cong2_lt__lt with A P A B; Cong.
      apply cong_symmetry, cong_commutativity, (is_image_col_cong A C); Col.
    left.
    exists P; split; Side.
    apply l10_14; auto.
    intro; subst; apply HNCol, l10_8, HP'.
Qed.

Lemma fod__circle_circle : first_order_dedekind -> circle_circle.
Proof.
  intro dedekind.
  apply circle_circle_aux.
  intros A B C D P Q HPOn HQOn HPIn HQOut HDij.
  assert (A <> C).
  { intro; subst C.
    apply (not_and_lt A B A P); split; trivial.
    apply (cong2_lt__lt A B A Q); Cong.
    apply cong_transitivity with A D; Cong.
  }
  assert (P <> Q) by (intro; apply (not_and_lt A P A B); subst; split; trivial).
  assert (C <> D) by (intro; treat_equalities; auto).
  assert (HOS : forall X Y, Bet P X Q -> Bet P Y Q -> X <> P -> X <> Q -> Y <> P -> Y <> Q -> OS A C X Y).
  { intros X Y; intros.
    destruct HDij as [HOS|[[HP HQ]|[HQ HP]]].
    - apply one_side_transitivity with P; [apply one_side_symmetry|]; apply l9_17 with Q; trivial.
    - apply one_side_transitivity with Q; [apply one_side_symmetry|];
      apply out_one_side_1 with P; Col; apply l6_6, bet_out; auto.
    - apply one_side_transitivity with P; [apply one_side_symmetry|];
      apply out_one_side_1 with Q; Col; apply l6_6, bet_out; Between.
  }
  assert (HNTS : forall X Y, Bet P Y Q -> Bet P X Y -> ~ TS A C X Y).
  { intros X Y HX HY HTS.
    absurd (TS A C P Q).
    - destruct HDij as [HOS'|[[HCol HNCol]|[HNCol HCol]]]; [apply l9_9_bis; trivial|intro..].
        apply (two_sides_not_col A C P Q); Col.
        apply (two_sides_not_col A C Q P); Col; Side.
    - apply bet_ts__ts with Y; trivial.
      apply l9_2, bet_ts__ts with X; Side; Between.
  }
  assert (HLta : LtA A C P A C Q).
  { apply t18_19; Cong.
      intro; treat_equalities; auto.
      apply cong_transitivity with C D; Cong.
      apply lt_comm, lt_transitivity with A B; trivial.
  }
  assert (HNCol1 : ~ Col P Q C).
  { intro.
    destruct HDij as [HOS'|[[HCol HNCol]|[HNCol HCol]]];
      [|apply HNCol; ColR..].
    destruct HLta as [_ HNCongA].
    apply HNCongA, out2__conga.
      apply out_trivial; auto.
    apply col_one_side_out with A; Col; Side.
  }

  assert (Haux : forall X Y X0 Y0, Bet P Y Q -> X <> Y ->
    OnCircle X0 C D -> Out C X X0 -> OnCircle Y0 C D -> Out C Y Y0 -> Bet P X Y -> Lt A X0 A Y0).
  { intros X Y X0 Y0; intros.
    apply t18_18 with C C; Cong.
      apply cong_transitivity with C D; Cong.
    apply lta_comm, (conga_preserves_lta A C X A C Y).
      apply out2__conga; [apply out_trivial|apply l6_6]; auto.
      apply out2__conga; [apply out_trivial|apply l6_6]; auto.
    split.
    { apply inangle__lea.
      assert_diffs.
      apply l11_24, in_angle_trans with P.
        repeat split; auto; exists X; split; Between; right; apply out_trivial; auto.
      apply in_angle_trans2 with Q.
        repeat split; auto.
        exists Y; split; Between.
        right; apply out_trivial; auto.
      destruct HDij as [HOS'|[[HCol HNCol]|[HNCol HCol]]].
      - apply l11_24, lea_in_angle; [Lea|Side].
      - apply out341__inangle; auto.
        apply not_bet_out; Col.
        intro; apply (lta__nlea A C P A C Q); Lea.
      - apply in_angle_line; auto.
        apply between_symmetry, not_out_bet; Col.
        intro; apply (lta__nlea A C P A C Q); trivial.
        apply l11_31_1; auto.
    }
    intro.
    destruct (conga_cop__or_out_ts A C X Y); trivial.
    - assert (Col P Q X) by ColR.
      apply coplanar_pseudo_trans with P Q C; [assumption| |Cop..].
      destruct HDij as [|[[]|[]]]; Cop.
    - absurd (X = Y); trivial; assert_diffs; apply (l6_21 P Q C X); ColR.
    - apply (HNTS X Y); trivial.
  }

  assert (HR : exists R, forall X Y,
    (Bet P X Q /\ (exists X0, OnCircle X0 C D /\ Out C X X0 /\ InCircle X0 A B)) ->
    (Bet P Y Q /\ (exists Y0, OnCircle Y0 C D /\ Out C Y Y0 /\ OutCircle Y0 A B)) ->
    Bet X R Y).
  { apply dedekind; [repeat constructor..|].
    exists P.
    intros X Y [HX [X0]] [HY [Y0]].
    destruct (l5_3 P X Y Q); trivial.
    destruct (eq_dec_points X Y).
      subst; Between.
    exfalso.
    spliter.
    apply (lt__nle A Y0 A X0).
      apply (Haux Y X); auto.
    apply le_transitivity with A B; trivial.
  }
  assert (HP : exists X0, OnCircle X0 C D /\ Out C P X0 /\ InCircle X0 A B).
    exists P; repeat (split; Circle); apply out_trivial; assert_diffs; auto.
  assert (HQ : exists Y0, OnCircle Y0 C D /\ Out C Q Y0 /\ OutCircle Y0 A B).
    exists Q; repeat (split; Circle); apply out_trivial; assert_diffs; auto.
  destruct HR as [R HR].
  assert (HBet : Bet P R Q) by (apply HR; split; Between).
  assert (R <> C) by (intro; subst; apply HNCol1; Col).
  destruct (onc_exists C D R) as [Z [HZ1 HZ2]]; auto.
  exists Z; split; trivial.
  assert (A <> B) by (apply (lt_diff A P), HPIn).
  destruct (circle_cases A B Z) as [|[Habs|Habs]]; trivial; exfalso.

  - assert (Q <> R).
    { intro; subst R.
      assert (Q = Z) by (apply (inc_onc2_out__eq C D C); Circle).
      subst.
      apply outcs__ninc in HQOut; Circle.
    }
    assert (HNCol2 : ~ Col C Q R) by (intro; apply HNCol1; ColR).
    assert (HT : exists T, OnCircle T A B /\ Bet A Z T).
    { destruct (eq_dec_points Z A).
        subst; exists B; split; Circle; Between.
      destruct (onc_exists A B Z) as [T [HT1 HT2]]; auto.
      exists T; split; trivial.
      apply l6_13_1; trivial.
      apply (l5_6 A Z A B); Cong; Le.
    }
    destruct HT as [T [HT1 HT2]].
    assert (T <> Z).
      intro; subst; apply incs__noutc in Habs; apply Habs; Circle.
    destruct (ex_per_cong C R Z Q T Z) as [I [HI1 [HI2 HI3]]]; Col.
    assert_diffs.
    assert (HNCol3 : ~ Col I Z C) by (apply per_not_col; auto).
    destruct (onc_exists C D I) as [X0 [HX0On HX0Out]]; auto.
    assert (HLt : Lt C X0 C I).
    { destruct (l11_46 I Z C) as [_ HLt]; auto.
        apply (cong2_lt__lt Z C I C); trivial.
          apply cong_transitivity with C D; Cong.
          Cong.
    }
    assert (X0 <> I) by (intro; apply (nlt C I); subst; assumption).
    assert (HNCol4 : ~ Col I X0 Z) by (intro; apply (one_side_not_col123 C R I Q); ColR).
    assert (HLt1 : Lt X0 Z I Z).
    { assert_diffs.
      destruct (l11_46 I X0 Z); auto.
      right.
      apply acute_bet__obtuse with C; auto.
        apply l6_13_1; [apply l6_6|]; Le.
      assert_diffs; apply cong__acute; auto.
      apply cong_transitivity with C D; Cong.
    }

    assert (HX0In : InCircleS X0 A B).
    { destruct (le_bet Z T Z X0) as [M [HM1 HM2]].
        apply (l5_6 X0 Z I Z); Cong; Le.
      assert (HMT : M <> T).
      { intro.
        apply (nlt Z M).
        apply (cong2_lt__lt X0 Z I Z); trivial; [|subst M; apply cong_transitivity with T Z]; Cong.
      }
      apply le1234_lt__lt with A M.
      - apply triangle_inequality with Z; Cong; eBetween.
      - apply (cong2_lt__lt A M A T); Cong.
        assert (Bet A M T) by eBetween.
        split; Le.
        intro.
        apply HMT, (between_cong A); assumption.
    }
    assert_diffs.
    assert (HX : InAngle X0 R C Q).
    { apply l11_25 with X0 Z Q; try (apply out_trivial); auto.
      apply lea_in_angle.
      - apply t18_19; auto.
          apply cong_transitivity with C D; Cong.
          Cong.
        apply le3456_lt__lt with I Z; trivial.
        apply (l5_6 T Z Q Z); Cong.
        assert (HLe : Le A T A Q) by (apply (l5_6 A B A Q); Cong; Le).
        destruct (eq_dec_points A Z).
          subst; Le.
        destruct (l5_5_1 A T A Q) as [M [HM1 HM2]]; trivial.
        assert (Bet A Z M) by eBetween.
        apply le_transitivity with M Z.
          apply bet__le2313; eBetween.
        apply le_comm, (triangle_reverse_inequality A); Cong.
        apply bet_out; auto.
      - apply invert_one_side, col_one_side with R; Col.
        apply one_side_transitivity with I; Side.
        apply out_one_side; trivial.
        left; apply one_side_not_col123 with Q; trivial.
    }
    destruct HX as [_ [_ [_ [X [HX1 [HX2|HX2]]]]]].
      subst; apply HNCol2; Col.
    assert (X = R).
      apply between_equality with Q; trivial.
      apply HR; split; [eBetween|..]; Between.
      exists X0; repeat (split; Circle).
    subst; apply HNCol4; ColR.

  - assert (P <> R).
    { intro; subst R.
      assert (P = Z) by (apply (inc_onc2_out__eq C D C); Circle).
      subst.
      apply incs__noutc in HPIn; Circle.
    }
    assert (HNCol2 : ~ Col C P R) by (intro; apply HNCol1; ColR).
    destruct (onc_exists A B Z) as [T [HT1 HT2]]; auto.
      apply (lt_diff A B), lt_right_comm, Habs.
    assert (HT3 : Bet A T Z).
    { apply l6_13_1.
        apply l6_6, HT2.
      apply (l5_6 A B A Z); Cong; Le.
    }
    assert (T <> Z).
      intro; subst; apply outcs__ninc in Habs; apply Habs; Circle.
    destruct (ex_per_cong C R Z P T Z) as [I [HI1 [HI2 HI3]]]; Col.
    assert_diffs.
    assert (HNCol3 : ~ Col I Z C) by (apply per_not_col; auto).

    destruct (onc_exists C D I) as [Y0 [HY0On HY0Out]]; auto.
    assert (HLt : Lt C Y0 C I).
    { destruct (l11_46 I Z C) as [_ HLt]; auto.
        apply (cong2_lt__lt Z C I C); trivial.
          apply cong_transitivity with C D; Cong.
          Cong.
    }
    assert (Y0 <> I) by (intro; apply (nlt C I); subst; assumption).
    assert (HNCol4 : ~ Col I Y0 Z) by (intro; apply (one_side_not_col123 C R I P); ColR).
    assert (HLt1 : Lt Y0 Z I Z).
    { assert_diffs.
      destruct (l11_46 I Y0 Z); auto.
      right.
      apply acute_bet__obtuse with C; auto.
        apply l6_13_1; [apply l6_6|]; Le.
      assert_diffs; apply cong__acute; auto.
      apply cong_transitivity with C D; Cong.
    }

    assert (HY0OutC : OutCircleS Y0 A B).
    { destruct (le_bet Z T Z Y0) as [M [HM1 HM2]].
        apply (l5_6 Y0 Z I Z); Cong; Le.
      assert (HTM : T <> M).
      { intro.
        apply (nlt Z M).
        apply (cong2_lt__lt Y0 Z I Z); trivial; [|subst M; apply cong_transitivity with T Z]; Cong.
      }
      apply le3456_lt__lt with A M.
      - apply (cong2_lt__lt A T A M); Cong.
        assert (Bet A T M) by eBetween.
        split; Le.
        intro.
        apply HTM, (between_cong A); assumption.
      - apply (triangle_reverse_inequality Z); Cong.
        assert_diffs; apply l6_6, bet_out; eBetween.
    }
    assert_diffs.
    assert (HY : InAngle Y0 P C R).
    { apply l11_25 with Y0 P Z; try (apply out_trivial); auto.
      apply l11_24, lea_in_angle.
      - apply t18_19; auto.
          apply cong_transitivity with C D; Cong.
          Cong.
        apply le3456_lt__lt with I Z; trivial.
        apply (l5_6 T Z P Z); Cong.
        destruct (le_bet A T A P) as [M [HM1 HM2]].
          apply (l5_6 A P A B); Cong; Le.
        assert (Bet A M Z) by eBetween.
        destruct (eq_dec_points M A).
          treat_equalities; Le.
        apply le_transitivity with M Z.
          apply bet__le2313; eBetween.
        apply le_comm, (triangle_reverse_inequality A); Cong.
        apply l6_6, bet_out; auto.
      - apply invert_one_side, col_one_side with R; Col.
        apply one_side_transitivity with I; Side.
        apply out_one_side; trivial.
        left; apply one_side_not_col123 with P; trivial.
    }
    destruct HY as [_ [_ [_ [Y [HY1 [HY2|HY2]]]]]].
      subst; apply HNCol2; Col.
    assert (Y = R).
      apply between_equality with P; apply between_symmetry; trivial.
      apply HR; split; [Between..| |]; [eBetween|].
      exists Y0; repeat (split; Circle).
    subst; apply HNCol4; ColR.
Qed.

End Dedekind_circle_circle.


Require Export euclidean__axioms.
Require Export euclidean__defs.
Require Export lemma__NCorder.
Require Export lemma__collinearorder.
Require Export logic.
Definition lemma__samesideflip : forall A B P Q, (euclidean__defs.OS P Q A B) -> (euclidean__defs.OS P Q B A).
Proof.
intro A.
intro B.
intro P.
intro Q.
intro H.
assert (* Cut *) (exists p q r, (euclidean__axioms.Col A B p) /\ ((euclidean__axioms.Col A B q) /\ ((euclidean__axioms.BetS P p r) /\ ((euclidean__axioms.BetS Q q r) /\ ((euclidean__axioms.nCol A B P) /\ (euclidean__axioms.nCol A B Q)))))) as H0.
- assert (exists X U V, (euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.BetS P U X) /\ ((euclidean__axioms.BetS Q V X) /\ ((euclidean__axioms.nCol A B P) /\ (euclidean__axioms.nCol A B Q)))))) as H0 by exact H.
assert (exists X U V, (euclidean__axioms.Col A B U) /\ ((euclidean__axioms.Col A B V) /\ ((euclidean__axioms.BetS P U X) /\ ((euclidean__axioms.BetS Q V X) /\ ((euclidean__axioms.nCol A B P) /\ (euclidean__axioms.nCol A B Q)))))) as __TmpHyp by exact H0.
destruct __TmpHyp as [x H1].
destruct H1 as [x0 H2].
destruct H2 as [x1 H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
exists x0.
exists x1.
exists x.
split.
-- exact H4.
-- split.
--- exact H6.
--- split.
---- exact H8.
---- split.
----- exact H10.
----- split.
------ exact H12.
------ exact H13.
- destruct H0 as [p H1].
destruct H1 as [q H2].
destruct H2 as [r H3].
destruct H3 as [H4 H5].
destruct H5 as [H6 H7].
destruct H7 as [H8 H9].
destruct H9 as [H10 H11].
destruct H11 as [H12 H13].
assert (* Cut *) (euclidean__axioms.Col B A p) as H14.
-- assert (* Cut *) ((euclidean__axioms.Col B A p) /\ ((euclidean__axioms.Col B p A) /\ ((euclidean__axioms.Col p A B) /\ ((euclidean__axioms.Col A p B) /\ (euclidean__axioms.Col p B A))))) as H14.
--- apply (@lemma__collinearorder.lemma__collinearorder A B p H4).
--- destruct H14 as [H15 H16].
destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
exact H15.
-- assert (* Cut *) (euclidean__axioms.Col B A q) as H15.
--- assert (* Cut *) ((euclidean__axioms.Col B A q) /\ ((euclidean__axioms.Col B q A) /\ ((euclidean__axioms.Col q A B) /\ ((euclidean__axioms.Col A q B) /\ (euclidean__axioms.Col q B A))))) as H15.
---- apply (@lemma__collinearorder.lemma__collinearorder A B q H6).
---- destruct H15 as [H16 H17].
destruct H17 as [H18 H19].
destruct H19 as [H20 H21].
destruct H21 as [H22 H23].
exact H16.
--- assert (* Cut *) (euclidean__axioms.nCol B A P) as H16.
---- assert (* Cut *) ((euclidean__axioms.nCol B A P) /\ ((euclidean__axioms.nCol B P A) /\ ((euclidean__axioms.nCol P A B) /\ ((euclidean__axioms.nCol A P B) /\ (euclidean__axioms.nCol P B A))))) as H16.
----- apply (@lemma__NCorder.lemma__NCorder A B P H12).
----- destruct H16 as [H17 H18].
destruct H18 as [H19 H20].
destruct H20 as [H21 H22].
destruct H22 as [H23 H24].
exact H17.
---- assert (* Cut *) (euclidean__axioms.nCol B A Q) as H17.
----- assert (* Cut *) ((euclidean__axioms.nCol B A Q) /\ ((euclidean__axioms.nCol B Q A) /\ ((euclidean__axioms.nCol Q A B) /\ ((euclidean__axioms.nCol A Q B) /\ (euclidean__axioms.nCol Q B A))))) as H17.
------ apply (@lemma__NCorder.lemma__NCorder A B Q H13).
------ 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__defs.OS P Q B A) as H18.
------ exists r.
exists p.
exists q.
split.
------- exact H14.
------- split.
-------- exact H15.
-------- split.
--------- exact H8.
--------- split.
---------- exact H10.
---------- split.
----------- exact H16.
----------- exact H17.
------ exact H18.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

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

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

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

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) : natural
           := match plus_arg0, plus_arg1 with
              | Zero, n => n
              | Succ n, m => Succ (plus n m)
              end.

Lemma lem: forall m n, Succ (plus m n) = plus m (Succ n).
Proof.
intros. simpl. induction m.
  - simpl. rewrite IHm. reflexivity.
  - reflexivity.
Qed.

Theorem theorem0 : forall (x : natural), eq (plus x (Succ x)) (Succ (plus x x)).
Proof.
induction x.
  - simpl. rewrite IHx. f_equal.
    lfind. Admitted.


Goal forall X Y : Prop, X -> Y -> X.

Proof.
  exact (fun X Y A B => A).
Qed.

Goal forall x y z : Prop, (x -> y) -> (y -> z) -> (x -> z).
Proof.
  intros x y z p q r.
  apply q.
  apply p.
  exact r.
  Show Proof.
Qed.

Goal forall x y z: Prop, (x -> y -> z) -> (x -> y) -> x -> z.
Proof.
  intros x y z a b c.
  apply a.
  Show Proof.
    - exact c.
  Show Proof.
    - apply b, c.
  Show Proof.
Qed.

Print Unnamed_thm1.


Require Import SepLogicTC.Heap.
Require Import SepLogicTC.Triples.

Require Import FunctionalExtensionality.
Require Import List.
Require Import PeanoNat.

Import ListNotations.

Open Scope heap_scope.
Open Scope hoare_scope.

(* We say that data of type 'T' is an object if it comes with methods
     - 'new' for creating an object of type 'T' on the heap and
     - 'del' for deleting an object of type 'T' at a given address
        on the heap.
   Furthermore, the specifications of 'new' and 'del' require another
   method 'isa' that asserts that a heaplet contains an object of type
   'T'. The specifications of 'new' and 'del' themselves are given as
   Hoare triples, the proofs of which are labelled 'ht_new' and 'ht_del'
   respectively:                                                         *)

Class MyObject (T : Set) :=
{
  isa : T -> nat -> hass ;
  new : T -> cmd nat ;
  del : T -> nat -> cmd unit ;

  ht_new : forall t, {{emp}} (new t) {{r, isa t r}} ;
  ht_del : forall t p, {{isa t p}} (del t p) {{r, <[r = tt]>}}
}.

(* Straightforward assertion that a heap represents a list 'ls' containing
   objects of type 'T' that satisfies the typeclass 'MyObject'. We adopt
   the convention that a null pointer represents the empty list:           *)

Fixpoint isList {T : Set} `{MyObject T} (ls : list T) (p : nat) : hass :=
  match ls with
    | []     => <[p = 0]>
    | t::ls' => <[p <> 0]> * (exist tp q, [[p |-> (tp,q)]]
                                          * isa t tp * isList ls' q)
  end.

(* Programs 'newList' and 'delList' for constructing lists on the heap: *)

Definition newList {T : Set} `{MyObject T} : list T -> cmd nat :=
  fix f ls :=
  match ls with
    | [] => Return 0
    | t::ls' => q <- f ls';
                tp <- new t;
                p <- Alloc (tp,q);
                Return p
  end.

Definition delList {T : Set} `{MyObject T} : list T -> nat -> cmd unit :=
  fix f ls q :=
  match ls with
    | []    => Return tt
    | t::ls' => if q =? 0 then Return tt
                          else p <- Read (nat*nat)%type q;
                               let (tp,p') := p in del t tp;;
                                                   Free (nat*nat)%type q;;
                                                   f ls' p'
  end.

(* Proofs of specification for 'newList' and 'delList' repectively: *)

Lemma ht_newList {T : Set} `{MyObject T} : forall (ls : list T),
  {{emp}} (newList ls) {{r, isList ls r}}.
Proof with auto.
  induction ls; simpl.
  + apply HtReturn.
  + repeat (eapply HtBind; intuition; auto).
    - apply IHls...
    - eapply hoare_cancel_empty_left_pre.
      * apply HtFrame. apply ht_new...
    - eapply hoare_cancel_empty_left_pre.
      * apply HtFrame. apply HtAlloc.
    - simpl. eapply HtConsequence.
      2: apply hass_imply_taut.
      * eapply hoare_cancel_empty_left_pre.
        apply hoare_return.
      * unfold imply. intuition.
        apply sep_pure_left.
        ** firstorder. subst...
        ** exists s0, s. firstorder.
           unfold emp in *; subst...
           repeat (rewrite union_empty_neutral_left in * ||
                   rewrite union_empty_neutral_right in *).
           apply sep_assoc.
           unfold sep...
           exists x8, (union x5 x6). firstorder.
Qed.

Lemma ht_delList {T : Set} `{MyObject T} : forall (ls : list T) (p : nat),
  {{isList ls p}} (delList ls p) {{r, <[r = tt]>}}.
Proof with auto.
  induction ls; intro p; simpl.
  + eapply HtConsequence with (P := emp).
    apply HtReturn.
    1,2: firstorder.
  + destruct (Nat.eqb_spec p 0).
    ++ eapply HtConsequence.
       apply HtReturn.
        1,2: firstorder.
    ++ repeat (eapply HtBind; intuition; auto).
       * apply hoare_frame_left.
         eapply HtConsequence with (P := exist v, [[p |-> v]]
                                                  * (isa a (fst v)
                                                     * isList ls (snd v))).
         ** apply HtRead.
         ** unfold ex, imply; intuition.
            destruct H0 as [x1 [x2 H0] ]. exists (x1,x2).
            apply sep_assoc...
         ** intro. apply hass_imply_taut.
       * intuition; simpl.
         apply hoare_frame_left. apply hoare_frame_left. apply HtFrame.
           apply ht_del.
       * intuition; simpl.
         apply hoare_frame_left. apply HtFrame. eapply HtConsequence.
         ** apply HtFree.
         ** firstorder.
         ** intro. simpl. apply hass_imply_taut.
       * intuition; simpl.
         eapply HtConsequence.
         ** apply IHls.
         ** unfold imply.
            firstorder.
            unfold emp in *. subst...
         ** firstorder.
Qed.

(* With the previous proofs, 'list T' satisfies the
   typeclass 'MyObject' whenever 'T' does so:       *)

Instance myListObject {T : Set} `{MyObject T} : MyObject (list T) :=
{
  isa := isList ;
  new := newList ;
  del := delList ;

  ht_new := ht_newList ;
  ht_del := ht_delList ;
}.

(* Lists of lists can now also be proven to satisfy
   the typeclass 'MyObject' in two equivalent ways: *)

Instance myListOfListsObject {T : Set} `{MyObject T}
  : MyObject (list (list T)) :=
{
  isa := isList ;
  new := newList ;
  del := delList ;

  ht_new := ht_newList ;
  ht_del := ht_delList ;
}.

Instance myListOfListsObject' {T : Set} `{MyObject T}
  : MyObject (list (list T)) :=
{
  isa := isa ;
  new := new ;
  del := del ;

  ht_new := ht_new ;
  ht_del := ht_del ;
}.

Close Scope hoare_scope.
Close Scope heap_scope.


(*******************************************************************)
(*  This is part of RelationAlgebra, it is distributed under the   *)
(*    terms of the GNU Lesser General Public License version 3     *)
(*              (see file LICENSE for more details)                *)
(*                                                                 *)
(*  Copyright 2012: Damien Pous. (CNRS, LIP - ENS Lyon, UMR 5668)  *)
(*******************************************************************)

(** * lsyntax: syntactic model for types structures (monoid operations) *)

Require Export positives comparisons.
Require Import Eqdep.
Require Import monoid.
Set Implicit Arguments.
Set Asymmetric Patterns.

(** * Free syntactic model *)

Section s.

Notation I := positive.
Variable A : Set.
(* [A=positive] for normalisation tactics
   [A=positive+lsyntax.expr (ord n)] for KAT proofs
   [A=positive+lsyntax.expr positive] for KAT computations (not yet) *)
Variables s t: A -> I.

(** residuated Kleene allegory expressions over a set [A] of
   variables, the variables being typed according to the functions [s]
   (source) and [t] (target).

   The indexing types ([I]) are fixed to be [positive] numbers:
   - this is convenient and efficient in practice, for reification
   - we need a decidable type to get the untyping theorems without axioms

   Note that we include constructors for flat operations
   (cup,cap,bot,top,neg): it is not convenient to reuse [lsyntax.expr]
   here since we would need to restrict the alphabet under those nodes to
   something like [A_(n,m) = { a: A / s a = n /\ t a = m }].
*)

(* TOTHINK: add a phantom/strong dependency on [l] on the expr type ? *)
Inductive expr: I -> I -> Type :=
| e_zer: forall n m, expr n m
| e_top: forall n m, expr n m
| e_one: forall n, expr n n
| e_pls: forall n m, expr n m -> expr n m -> expr n m
| e_cap: forall n m, expr n m -> expr n m -> expr n m
| e_neg: forall n m, expr n m -> expr n m
(* | e_not: forall n, expr n n -> expr n n *)
| e_dot: forall n m p, expr n m -> expr m p -> expr n p
| e_itr: forall n, expr n n -> expr n n
| e_str: forall n, expr n n -> expr n n
| e_cnv: forall n m, expr n m -> expr m n
| e_ldv: forall n m p, expr n m -> expr n p -> expr m p
| e_rdv: forall n m p, expr m n -> expr p n -> expr p m
| e_var: forall a, expr (s a) (t a).

(** level of an expression: the set of operations that appear in that expression *)
Fixpoint e_level n m (x: expr n m): level :=
  match x with
    | e_zer _ _ => BOT
    | e_top _ _ => TOP
    | e_one _ => MIN
    | e_pls _ _ x y => CUP + e_level x + e_level y
    | e_cap _ _ x y => CAP + e_level x + e_level y
    | e_neg _ _ x => BL + e_level x
      (* negation is ill-defined without the other Boolean operations,
         whence the [BL] rather than [NEG] *)
    | e_dot _ _ _ x y => e_level x + e_level y
    | e_itr _ x => STR + e_level x
    | e_str _ x => STR + e_level x
    | e_cnv _ _ x => CNV + e_level x
    | e_ldv _ _ _ x y
    | e_rdv _ _ _ x y => DIV + e_level x + e_level y
    | e_var a => MIN
  end%level.

Section e.
Context {X: ops} {f': I -> ob X}.
Variable f: forall a, X (f' (s a)) (f' (t a)).

(** interpretation of an expression into an arbitray structure, given
   an assignation [f] of the variables (and a interpretation function
   [f'] for the types) *)

Fixpoint eval n m (x: expr n m): X (f' n) (f' m) :=
  match x with
    | e_zer _ _ => 0
    | e_top _ _ => top
    | e_one _ => 1
    | e_pls _ _ x y => eval x + eval y
    | e_cap _ _ x y => eval x ^ eval y
    | e_neg _ _ x => ! eval x
    (* | e_not _ x => eval x ^~ *)
    | e_dot _ _ _ x y => eval x * eval y
    | e_itr _ x => eval x ^+
    | e_str _ x => eval x ^*
    | e_cnv _ _ x => eval x `
    | e_ldv _ _ _ x y => eval x -o eval y
    | e_rdv _ _ _ x y => eval y o- eval x
    | e_var a => f a
  end.
End e.

Section l.
Variable l: level.

(** * (In)equality of syntactic expressions.

   Like in [lsyntax], we use an impredicative encoding to define
   (in)equality in the free syntactic model, and we parametrise all
   definition with the level [l] at which we want to interpret the
   given expressions. *)

Definition e_leq n m (x y: expr n m) :=
  forall X (L:laws l X) f' (f: forall a, X (f' (s a)) (f' (t a))), eval f x <== eval f y.
Definition e_weq n m (x y: expr n m) :=
  forall X (L:laws l X) f' (f: forall a, X (f' (s a)) (f' (t a))), eval f x == eval f y.

(** by packing syntactic expressions and the above predicates into a
   canonical structure for flat operations, and another one for the
   other operations, we get all notations for free *)

Canonical Structure expr_lattice_ops n m := {|
  car := expr n m;
  leq := @e_leq n m;
  weq := @e_weq n m;
  cup := @e_pls n m;
  cap := @e_cap n m;
  neg := @e_neg n m;
  bot := @e_zer n m;
  top := @e_top n m
|}.

Canonical Structure expr_ops := {|
  ob  := I;
  mor := expr_lattice_ops;
  dot := e_dot;
  one := e_one;
  itr := e_itr;
  str := e_str;
  cnv := e_cnv;
  ldv := e_ldv;
  rdv := e_rdv
|}.

(** we easily show that we get a model so that we immediately benefit
   from all lemmas about the various structures *)

Global Instance expr_lattice_laws n m: lattice.laws l (expr_lattice_ops n m).
Proof.
  constructor; try right. constructor.
   intros x X L u f. reflexivity.
   intros x y z H H' X L u f. transitivity (eval f y); auto.
   intros x y. split.
    intro H. split; intros X L u f. now apply weq_leq, H. now apply weq_geq, H.
    intros [H H'] X L u f. apply antisym; auto.
   intros Hl x y z. split.
    intro H. split; intros X L u f; specialize (H X L u f); simpl in H; hlattice.
    intros [H H'] X L u f. simpl. apply cup_spec; auto.
   intros Hl x y z. split.
    intro H. split; intros X L u f; specialize (H X L u f); simpl in H; hlattice.
    intros [H H'] X L u f. simpl. apply cap_spec; auto.
   intros x X L u f. apply leq_bx.
   intros x X L u f. apply leq_xt.
   intros Hl x y z X L u f. apply cupcap_.
   intros Hl x X L u f. apply capneg.
   intros Hl x X L u f. apply cupneg.
Qed.

Global Instance expr_laws: laws l expr_ops.
Proof.
  constructor; repeat right; repeat intro; simpl.
   apply expr_lattice_laws.
   apply dotA.
   apply dot1x.
   apply dotx1.
   apply dot_leq; auto.
   now rewrite dotplsx.
   now rewrite dotxpls.
   now rewrite dot0x.
   now rewrite dotx0.
   apply cnvdot_.
   apply cnv_invol.
   apply cnv_leq. now refine (H0 _ _ _ _).
   apply cnv_ext.
   apply str_refl.
   apply str_cons.
   apply str_ind_l. now refine (H0 _ _ _ _).
   apply str_ind_r. now refine (H0 _ _ _ _).
   apply itr_str_l.
   apply capdotx.
   split; intros E X L f' f; intros; simpl; apply ldv_spec, (E X L f' f).
   split; intros E X L f' f; intros; simpl; apply rdv_spec, (E X L f' f).
Qed.

End l.

(** * Testing for particular constants *)

Definition is_zer n m (x: expr n m) :=
  match x with e_zer _ _ => true | _ => false end.

Definition is_top n m (x: expr n m) :=
  match x with e_top _ _ => true | _ => false end.

Inductive is_case n m (k x: expr n m): expr n m -> bool -> Prop :=
| is_case_true: x=k -> is_case k x k true
| is_case_false: x<>k -> is_case k x x false.

Lemma is_zer_spec n m (x: expr n m): is_case (e_zer n m) x x (is_zer x).
Proof. destruct x; constructor; discriminate || reflexivity. Qed.

Lemma is_top_spec n m (x: expr n m): is_case (e_top n m) x x (is_top x).
Proof. destruct x; constructor; discriminate || reflexivity. Qed.

(** casting the type of an expression *)
Definition cast n m n' m' (Hn: n=n') (Hm: m=m') (x: expr n m): expr n' m' :=
  eq_rect n (fun n => expr n m') (eq_rect m (expr n) x _ Hm) _ Hn.

End s.
Arguments e_var [A s t] a.
Arguments e_one [A s t] n.
Arguments e_zer [A s t] n m.
Arguments e_top [A s t] n m.

Bind Scope ast_scope with expr.
Delimit Scope ast_scope with ast.

(** additional notations, to specify explicitly at which level
   expressions are considered, or to work directly with the
   bare constructors (by opposition with the encapsulated ones,
   through monoid.ops) *)

Notation expr_ l s t n m := (expr_ops s t l n m).
Notation "x <==_[ l ] y" := (@leq (expr_ops _ _ l _ _) x y) (at level 79): ra_scope.
Notation "x ==_[ l ] y" := (@weq (expr_ops _ _ l _ _) x y) (at level 79): ra_scope.

Infix "+" := e_pls: ast_scope.
Infix "^" := e_cap: ast_scope.
Infix "*" := e_dot: ast_scope.
Notation "1" := (e_one _): ast_scope.
Notation "0" := (e_zer _ _): ast_scope.
Notation top := (e_top _ _).
Notation "x ^+" := (e_itr x): ast_scope.
Notation "x `"  := (e_cnv x): ast_scope.
Notation "x ^*" := (e_str x): ast_scope.
Notation "! x"  := (e_neg x): ast_scope.
Notation "x -o y" := (e_ldv x y) (right associativity, at level 60): ast_scope.
Notation "y o- x" := (e_rdv x y) (left associativity, at level 61): ast_scope.

(** * weakening (in)equations *)
(** any equation holding at some level holds at all higher levels  *)

Lemma e_leq_weaken {h k} {Hl: h<<k} A s t n m (x y: @expr A s t n m):
  x <==_[h] y -> x <==_[k] y.
Proof. intros H X L f' f. eapply @H, lower_laws. Qed.

Lemma e_weq_weaken {h k} {Hl: h<<k} A s t n m (x y: @expr A s t n m):
  x ==_[h] y -> x ==_[k] y.
Proof. intros H X L f' f. eapply @H, lower_laws. Qed.

(** * comparing expressions syntactically  *)
Section expr_cmp.

Notation I := positive.
Context {A : cmpType}.
Variables s t: A -> I.
Notation expr := (expr s t).

(** we need to generalise the comparison function to expressions of
   distinct types because of Coq's dependent types *)
Fixpoint expr_compare n m (x: expr n m) p q (y: expr p q) :=
  match x,y with
    | e_zer _ _, e_zer _ _
    | e_top _ _, e_top _ _
    | e_one _, e_one _ => Eq
    | e_var a, e_var b => cmp a b
    | e_pls _ _ x x', e_pls _ _ y y'
    | e_cap _ _ x x', e_cap _ _ y y' =>
         lex (expr_compare x y) (expr_compare x' y')
    | e_dot _ u _ x x', e_dot _ v _ y y'
    | e_ldv u _ _ x x', e_ldv v _ _ y y'
    | e_rdv u _ _ x x', e_rdv v _ _ y y' =>
         lex (cmp u v) (lex (expr_compare x y) (expr_compare x' y'))
    | e_neg _ _ x, e_neg _ _ y
    | e_itr _ x, e_itr _ y
    | e_str _ x, e_str _ y
    | e_cnv _ _ x, e_cnv _ _ y => expr_compare x y
    | e_zer _ _, _       => Lt
    | _, e_zer _ _       => Gt
    | e_one _, _         => Lt
    | _, e_one _         => Gt
    | e_top _ _, _       => Lt
    | _, e_top _ _       => Gt
    | e_var _, _         => Lt
    | _, e_var _         => Gt
    | e_itr _ _, _       => Lt
    | _, e_itr _ _       => Gt
    | e_str _ _, _       => Lt
    | _, e_str _ _       => Gt
    | e_cnv _ _ _, _     => Lt
    | _, e_cnv _ _ _     => Gt
    | e_ldv _ _ _ _ _, _ => Lt
    | _, e_ldv _ _ _ _ _ => Gt
    | e_rdv _ _ _ _ _, _ => Lt
    | _, e_rdv _ _ _ _ _ => Gt
    | e_pls _ _ _ _, _   => Lt
    | _, e_pls _ _ _ _   => Gt
    | e_cap _ _ _ _, _   => Lt
    | _, e_cap _ _ _ _   => Gt
    | e_neg _ _ _, _     => Lt
    | _, e_neg _ _ _     => Gt
  end.

(** since [A] is decidable, [cast] provably acts as an identity  *)
Lemma cast_eq n m (x: expr n m) (H: n=n) (H': m=m): cast H H' x = x.
Proof. unfold cast. now rewrite 2 cmp_eq_rect_eq. Qed.

(** auxiliary lemma for [expr_compare_spec] below, using dependent equality *)
Lemma expr_compare_eq_dep n m (x: expr n m): forall p q (y: expr p q),
  expr_compare x y = Eq -> n=p -> m=q ->
  eq_dep (I*I) (fun x => expr (fst x) (snd x)) (n,m) x (p,q) y.
Proof.
  induction x; intros ? ? z C; destruct z; try discriminate C;
    try (intros <- <- || intros <- _); try reflexivity;
     simpl expr_compare in C.

   apply compare_lex_eq in C as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply compare_lex_eq in C as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply IHx, cmp_eq_dep_eq in C; trivial. subst. reflexivity.

   apply compare_lex_eq in C as [C C']. apply cmp_eq in C. subst.
   apply compare_lex_eq in C' as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply IHx, cmp_eq_dep_eq in C; trivial. subst. reflexivity.

   apply IHx, cmp_eq_dep_eq in C; trivial. subst. reflexivity.

   apply IHx, cmp_eq_dep_eq in C; trivial. subst. reflexivity.

   apply compare_lex_eq in C as [C C']. apply cmp_eq in C. subst.
   apply compare_lex_eq in C' as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply compare_lex_eq in C as [C C']. apply cmp_eq in C. subst.
   apply compare_lex_eq in C' as [C1 C2].
   apply IHx1, cmp_eq_dep_eq in C1; trivial.
   apply IHx2, cmp_eq_dep_eq in C2; trivial.
   subst. reflexivity.

   apply cmp_eq in C. subst. reflexivity.
Qed.

Lemma expr_compare_eq n m (x y: expr n m): x=y -> expr_compare x y = Eq.
Proof.
  intros <-. induction x; simpl expr_compare; trivial;
  rewrite ?compare_lex_eq, ?cmp_refl; tauto.
Qed.

(** final specification of the comparison function *)
Lemma expr_compare_spec n m (x y: expr n m): compare_spec (x=y) (expr_compare x y).
Proof.
  generalize (fun H => expr_compare_eq_dep x y H eq_refl eq_refl) as H.
  generalize (@expr_compare_eq _ _ x y) as H'.
  case (expr_compare x y); intros H' H; constructor.
   now apply cmp_eq_dep_eq in H.
   intro E. now discriminate H'.
   intro E. now discriminate H'.
Qed.

(** packaging as a [cmpType]  *)
Definition expr_compare_ n m (x y: expr n m) := expr_compare x y.
Canonical Structure cmp_expr n m := mk_simple_cmp (@expr_compare_ n m) (@expr_compare_spec n m).

End expr_cmp.

(** * Packages for typed reification *)

(** according to the interpretation function [eval], (typed)
   reification has to provide a set [A] for indexing variables, and four maps:
   - [f': I -> ob X], to interpret types as written in the expressions ([I=positive])
   - [s] and [t]: A -> I, to specify the source and target types of each variable
   - [f: forall a: A, expr s t (s a) (t a)], to interpret each variable

   [A] is also fixed to be [positive], so that we can use simple and
   efficient positive maps, but the fact that [f] has a dependent type
   is not convenient.

   This is why we introduce the additionnal layer, to ease the
   definition of such maps: thanks to the definitions below, it
   suffices to provide the map [f'], and a map [f: A -> Pack X f']. *)

Record Pack (X: ops) (f': positive -> ob X) := pack {
  src: positive;
  tgt: positive;
  val: X (f' src) (f' tgt)
}.

Definition packed_eval (X: ops) (f': positive -> ob X) (f: positive -> Pack X f') :=
  eval (fun a => val (f a)) : forall n m, expr _ _ n m -> X (f' n) (f' m) .

(** these projections are used to build the reified expressions *)
Definition src_ (X: ops) (f': positive -> ob X) (f: positive -> Pack X f') a := src (f a).
Definition tgt_ (X: ops) (f': positive -> ob X) (f: positive -> Pack X f') a := tgt (f a).

(** loading ML reification module *)
Declare ML Module "ra_reification".