Require Import Semigroup.
Set Implicit Arguments.

Section Sample.
  Variable A : Type.
  Variable bot : A.
  Variable Aplus : A -> A -> A.
  Infix "+!" := Aplus (at level 50, left associativity).
  Variable Aplus_assoc : forall x y z : A, (x +! y) +! z = x +! (y +! z).
  Variable Aplus_comm : forall x y, x +! y = y +! x.

  Definition Acsg :=
    {| CSelem := bot;
       CSplus := Aplus;
       CSplus_assoc := Aplus_assoc;
       CSplus_comm := Aplus_comm; |}.

  Goal forall x y z, (x +! y) +! z = y +! (z +! x).
  Proof.
    intros.
    semigroup Acsg.
  Qed.

  Goal forall x y z w, (x +! y) +! (z +! w) = w +! (x +! z) +! y.
  Proof.
    intros.
    semigroup Acsg.
  Qed.

  Goal forall x y z, x +! y +! x +! z = x +! x +! y +! z.
  Proof.
    intros.
    semigroup Acsg.
  Qed.

  Goal forall x y z w,
    (x +! y) +! (x +! z +! (w +! y) +! w) = w +! w +! z +! y +! y+! x +! x.
  Proof.
    intros.
    semigroup Acsg.
  Qed.
End Sample.


From mathcomp
     Require Import ssreflect eqtype ssrnat ssrbool seq.

Require Import arith.
Require Import tactics.
Require Import lists.
Require Import sem.

Definition id := nat.

Inductive expr : Type :=
  NE of Z
| BE of bool
| AddE of expr & expr
| SubE of expr & expr
| MulE of expr & expr
| DivE of expr & expr
| EqE of expr & expr
| LtE of expr & expr
| LeE of expr & expr
| NegE of expr
| AndE of expr & expr
| IfE of expr & expr & expr
| NilE
| PPendE of expr & expr
| LCaseE of expr & expr & expr
| VarE of id
| AppE of expr & expr
| AbsE of id & expr
| LetRecE of id & expr & expr
.

Definition is_icfm (e: expr) :=
  match e with NE _ => true | _ => false end.

Definition is_bcfm (e: expr) :=
  match e with BE _ => true | _ => false end.

Definition is_fcfm (e: expr) :=
  match e with AbsE _ _ => true | _ => false end.

Fixpoint is_cfm (e: expr) :=
  match e with
    NE _ => true
  | BE _ => true
  | AbsE _ _ => true
  | NilE => true
  | PPendE e1 e2 => is_cfm e1 && is_cfm e2
  | _ => false
  end.

Definition is_lcfm (e: expr) :=
  match e with
    NilE => true
  | PPendE e1 e2 => is_cfm e1 && is_cfm e2
  | _ => false
  end.

Fixpoint is_zlcfm (e: expr) : bool :=
  match e with
    NilE => true
  | PPendE (NE z) e2 => is_zlcfm e2
  | _ => false
  end.

Definition fun_config := expr.
Definition fun_rconfig := expr.

Fixpoint e_subst (e: expr) (x: id) (e': expr) :=
  match e with
    NE z => NE z
  | BE b => BE b
  | AddE e1 e2 => AddE (e_subst e1 x e') (e_subst e2 x e')
  | SubE e1 e2 => SubE (e_subst e1 x e') (e_subst e2 x e')
  | MulE e1 e2 => MulE (e_subst e1 x e') (e_subst e2 x e')
  | DivE e1 e2 => DivE (e_subst e1 x e') (e_subst e2 x e')
  | EqE e1 e2 => EqE (e_subst e1 x e') (e_subst e2 x e')
  | LtE e1 e2 => LtE (e_subst e1 x e') (e_subst e2 x e')
  | LeE e1 e2 => LeE (e_subst e1 x e') (e_subst e2 x e')
  | NegE e1 => NegE (e_subst e1 x e')
  | AndE e1 e2 => AndE (e_subst e1 x e') (e_subst e2 x e')
  | IfE e1 e2 e3 =>
    IfE (e_subst e1 x e') (e_subst e2 x e') (e_subst e3 x e')
  | NilE => NilE
  | PPendE e1 e2 => PPendE (e_subst e1 x e') (e_subst e2 x e')
  | LCaseE e1 e2 e3 =>
    LCaseE (e_subst e1 x e') (e_subst e2 x e') (e_subst e3 x e')
  | VarE x' => if (x == x') then e' else (VarE x')
  | AppE e1 e2 => AppE (e_subst e1 x e') (e_subst e2 x e')
  | AbsE x' e1 => if (x == x') then (AbsE x' e1) else (AbsE x' (e_subst e1 x e'))
  (* letrec x1 = \lam x2.e2 in e1 *)
  | LetRecE x1 e2 e1 =>
    let: e1' := (if x == x1 then e1 else (e_subst e1 x e')) in
    LetRecE x1 (e_subst e2 x e') e1'
  end.

Inductive fun_rule :
  seq (prod fun_config fun_rconfig) -> (prod fun_config fun_rconfig) -> Prop :=

| FUNR_NUM z: fun_rule [:: ] (NE z, NE z)
| FUNR_BOOL b: fun_rule [:: ] (BE b, BE b)
| FUNR_ADD e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (AddE e1 e2, NE (z1+z2)%Z)
| FUNR_SUB e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (SubE e1 e2, NE (z1-z2)%Z)
| FUNR_MUL e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (MulE e1 e2, NE (z1*z2)%Z)
| FUNR_DIV e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (DivE e1 e2, NE (z1/z2)%Z)
| FUNR_EQ e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (EqE e1 e2, BE (Z.eqb z1 z2))
| FUNR_LT e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (LtE e1 e2, BE (Z.ltb z1 z2))
| FUNR_LE e1 e2 z1 z2:
    fun_rule [:: (e1, NE z1); (e2, NE z2) ] (LeE e1 e2, BE (Z.leb z1 z2))
| FUNR_NEQ e1 b1:
    fun_rule [:: (e1, BE b1) ] (NegE e1, BE (~~b1))
| FUNR_AND e1 e2 b1 b2:
    fun_rule [:: (e1, BE b1); (e2, BE b2) ] (EqE e1 e2, BE (b1 && b2))
| FUNR_IFTT e1 e2 e3 cf:
    fun_rule [:: (e1, BE true); (e2, cf) ] (IfE e1 e2 e3, cf)
| FUNR_IFFF e1 e2 e3 cf:
    fun_rule [:: (e1, BE false); (e3, cf) ] (IfE e1 e2 e3, cf)
| FUNR_NIL: fun_rule [:: ] (NilE, NilE)
| FUNR_PPEND e e' cf cf':
    is_cfm cf -> is_cfm cf' ->
    fun_rule [:: (e, cf); (e', cf') ] (PPendE e e', PPendE cf cf')
| FUNR_LCASE1 e e' e'' cf:
    is_cfm cf -> fun_rule [:: (e, NilE); (e', cf) ] (LCaseE e e' e'', cf)
| FUNR_LCASE2 e e' e'' cf cf' cf'':
    is_cfm cf -> is_cfm cf' -> is_cfm cf'' ->
    fun_rule [:: (e, PPendE cf cf'); ((AppE (AppE e'' cf) cf'), cf'') ]
             (LCaseE e e' e'', cf'')
| FUNR_APP e e' e'' x cf cf':
    is_cfm cf -> is_cfm cf' ->
    fun_rule [:: (e, AbsE x e''); (e', cf'); (e_subst e'' x cf', cf) ]
             (AppE e e', cf)
| FUNR_ABS x e: fun_rule [:: ] (AbsE x e, AbsE x e)
| FUNR_LETREC e e' e'' x x' cf:
    e'' = (AbsE x' e') ->
    x <> x' ->
    fun_rule [:: (AppE (AbsE x e) (AbsE x' (LetRecE x (AbsE x' e') e')), cf) ]
             (LetRecE x e'' e, cf)
.

Instance fun_Sem : Sem fun_config fun_rconfig :=
  {
  rule := fun_rule
  }.

(* the list-merging program *)

Definition merge_id: id := 0.

Definition x_id: id := 1.
Definition x'_id: id := 2.

Definition i_id: id := 3.
Definition i'_id: id := 4.

Definition r_id: id := 5.
Definition r'_id: id := 6.

Definition e_if :=
  IfE (LeE (VarE i_id) (VarE i'_id))
      (PPendE (VarE i_id) (AppE (AppE (VarE merge_id) (VarE r_id)) (VarE x'_id)))
      (PPendE (VarE i'_id) (AppE (AppE (VarE merge_id) (VarE x_id)) (VarE r'_id))).

Definition e_lcase :=
  LCaseE (VarE x_id)
         (VarE x'_id)
         (AbsE i_id (AbsE r_id
                          (LCaseE (VarE x'_id)
                                  (VarE x_id)
                                  (AbsE i'_id (AbsE r'_id e_if))))).

Definition e_mg (lcf1 lcf2: expr) :=
  LetRecE merge_id
          (AbsE x_id (AbsE x'_id e_lcase))
          (AppE (AppE (VarE merge_id) lcf1) lcf2).

(* the specification *)

(* aux. function computing the sequence (list) for a list canonical form *)
(* assuming lcf is a list canonical form *)
Fixpoint lcf_seq (lcf: expr) : seq Z :=
  match lcf with
    PPendE (NE z) lcf' => (z :: lcf_seq lcf')
  | _ => [:: ]
  end.

(* the actual specification *)
Inductive mg_spec (u:unit): Spec unit fun_config fun_rconfig u :=

  FUN_SP_e_mg (lcf1 lcf2: expr) (zs1 zs2: seq Z):
    is_zlcfm lcf1 ->
    is_zlcfm lcf2 ->
    zs1 = lcf_seq lcf1 ->
    zs2 = lcf_seq lcf2 ->
    sorted zs1 ->
    sorted zs2 ->
    mg_spec _
            (e_mg lcf1 lcf2)
            (fun r => (is_zlcfm r /\
                       (forall z, occ (lcf_seq r) z = occ zs1 z + occ zs2 z) /\
                       sorted (lcf_seq r)))

| FUN_SP_e_unfold (lcf1 lcf2: expr) (zs1 zs2: seq Z):
    is_zlcfm lcf1 ->
    is_zlcfm lcf2 ->
    zs1 = lcf_seq lcf1 ->
    zs2 = lcf_seq lcf2 ->
    sorted zs1 ->
    sorted zs2 ->
    mg_spec _
            (AppE
               (AppE
                  (AbsE x_id
                        (LetRecE merge_id
                                 (AbsE x_id (AbsE x'_id e_lcase))
                                 (AbsE x'_id e_lcase)))
                  lcf1)
               lcf2)
            (fun r => (is_zlcfm r /\
                       (forall z, occ (lcf_seq r) z = occ zs1 z + occ zs2 z) /\
                       sorted (lcf_seq r))).

Ltac inv_zlcfm :=
  match goal with [ H : context [is_zlcfm _] |- _ ] => inv H end.

Lemma zlcfm_subst:
  forall e x e', is_zlcfm e -> e_subst e x e' = e.
Proof.
  elim; try (move=> *; inv_zlcfm; fail).
  - move=>//.
  - move=> e IH1 e0 IH2 x e' H_zlcfm.
    move=>/=.
    move: IH1=> /(_ x e')=> IH1.
    move: IH2=> /(_ x e')=> IH2.
    inversion H_zlcfm; subst.
    case En: e; rewrite En in H0; inv H0.
    move=>/=.
    apply IH2 in H0. rewrite H0=>//.
Qed.

Lemma zlcfm_not_in_spec:
  forall lcf prm, is_zlcfm lcf -> ~(exists P, mg_spec prm lcf P).
Proof.
  move=> lcf prm H_zlcfm H_ex_P.
  inversion H_ex_P as [P H_spec_P]; clear H_ex_P.
  inv H_spec_P; subst;
  simpl in H_zlcfm; inv H_zlcfm.
Qed.

Lemma zlcfm_infer_preserve:
  forall lcf cf param,
    is_zlcfm lcf ->
    infer param (mg_spec param) (lcf, cf) ->
    cf = lcf.
Proof.
  elim; try (move=> *; inv_zlcfm; fail).
  -
    move=> cf prm H_zlcfm H_inf. inv H_inf.
    inv H1; subst. auto.
  -
    move=> e IH1 e0 IH2 cf prm H_zlcfm H_inf.
    inversion H_zlcfm; subst.
    case En: e; rewrite En in H0; simpl in H0; inv H0.
    inversion H_inf; subst.
    rename H3 into H_rule; inversion H_rule; subst.
    ith_prem_exe_0 H4 h' mg_spec. clear h.
    ith_prem_1 H4 H'.
    have: ~(exists P, mg_spec prm e0 P) by apply zlcfm_not_in_spec; auto.
    inversion H' as [H_ne | H_e]; clear H'.
    +
      move=> H_ne'. inv H_ne.
      move: IH2=>/(_ cf' prm H0)=>IH2. apply IH2 in H2. rewrite H2=>//.
    +
      move=> H_ne'. inv H_e. inv H.
      have H_ex: exists P, mg_spec prm e0 P.
      { exists x; auto. }
      apply H_ne' in H_ex. inv H_ex.
Qed.

Lemma zlcfm_infer_nil:
  forall lcf param,
    is_zlcfm lcf ->
    infer param (mg_spec param) (lcf, NilE) ->
    lcf = NilE.
Proof.
  elim; try (move=> *; inv_zlcfm; fail).
  - try done.
  - move=> e IH1 e0 IH2 prm H_zlcfm H_inf.
    inv H_inf; subst.
    inv H1; subst.
Qed.

Ltac get_branch hyp_or hyp_nex :=
        let h1 := fresh "h" in (
          let h2 := fresh "h" in (
            let h3 := fresh "h" in (
              let h4 := fresh "h" in (
                inversion hyp_or as [h1 | h2];
                [ inv h1; auto |
                  inversion h2 as [P h4]; inv h4;
                  exfalso; apply hyp_nex; exists P; auto ]
              )
            )
          )
        ).

Lemma zlcfm_infer_pend0:
  forall lcf param cf cf',
    is_zlcfm lcf ->
    infer param (mg_spec param) (lcf, PPendE cf cf') ->
    exists z lcf'',
      lcf = PPendE (NE z) lcf'' /\
      cf = (NE z) /\
      cf' = lcf'' /\
      is_zlcfm lcf''.
Proof.
  elim; try (move=> *; inv_zlcfm; fail).
  -
    move=> param cf cf' H_zlcfm H_inf.
    inv H_inf. inv H1.
  -
    move=> e IH1 e0 IH2 prm cf cf' H_zlcfm H_inf.
    inversion H_zlcfm; subst.
    case En: e; rewrite En in H0; simpl in H0; inv H0.
    inversion H_inf; subst.
    inversion H3; subst.
    eexists. exists e0.
    apply: conj. eauto. apply: conj.
    ith_prem_exe_0 H4 h' mg_spec; auto.
    ith_prem_1 H4 h'.
    have H_nex: ~(exists P, mg_spec prm e0 P)
      by apply zlcfm_not_in_spec; auto.
    have H_inf0: infer prm (mg_spec prm) (e0, cf')
      by get_branch h' H_nex.
    apply: conj.
    apply zlcfm_infer_preserve with (param:=prm); auto.
    auto.
Qed.

Lemma zlcfm_infer_pend:
  forall lcf param cf cf',
    is_zlcfm lcf ->
    infer param (mg_spec param) (lcf, PPendE cf cf') ->
    exists z,
      lcf = PPendE (NE z) cf' /\
      cf = (NE z) /\
      is_zlcfm cf'.
Proof.
  move=> lcf prm cf cf' H_zlcfm H_inf.
  have H_ex0:
    exists z lcf'',
      lcf = PPendE (NE z) lcf'' /\
      cf = (NE z) /\
      cf' = lcf'' /\
      is_zlcfm lcf'' by apply zlcfm_infer_pend0 with (param:=prm); auto.
  inv H_ex0. inv H. inv H0. inv H2. inv H4.
  exists x. apply: conj. congruence. apply: conj=>//. congruence.
Qed.

Lemma inf_le_comp:
  forall z1 z2 prm b,
    infer prm (mg_spec prm) (LeE (NE z1) (NE z2), BE b) ->
    (z1 <=? z2)%Z = b.
Proof.
  move=> z1 z2 prm b H_inf.
  inv H_inf; subst.
  inv H1; subst.
  ith_prem_0 H2 H2'.
  have H_inf1': infer prm (mg_spec prm) (NE z1, NE z0).
  {
    have H_nex: ~(exists P, mg_spec prm (NE z1) P).
    { move=> contra. inv contra. inv H; subst. }
    get_branch H2' H_nex.
  }
  have H_z1_eq_z0: z1 = z0.
  { inv H_inf1'; subst. inv H3; subst; auto. }
  rewrite <- H_z1_eq_z0 in *.
  clear H2'. clear H_inf1'.
  ith_prem_1 H2 H2'.
  have H_inf2': infer prm (mg_spec prm) (NE z2, NE z3).
  {
    have H_nex: ~(exists P, mg_spec prm (NE z2) P).
    { move=> contra. inv contra. inv H; subst. }
    get_branch H2' H_nex.
  }
  have H_z3_eq_z2: z2 = z3.
  { inv H_inf2'; subst. inv H3; subst; auto. }
  rewrite <- H_z3_eq_z2 in *.
  done.
Qed.

Lemma zlcfm_shape:
  forall cf,
    is_zlcfm cf ->
    (cf = NilE \/ exists z cf', cf = PPendE (NE z) cf').
Proof.
  move=> cf H_zlcfm;
  try destruct cf; inv H_zlcfm.
  - left=>//.
  - right.
    destruct cf1; inv H0.
    exists z. exists cf2. auto.
Qed.

(* the correctness proof *)

Theorem mg_spec_valid: forall param, valid _ (mg_spec param).
Proof.
  init_verif.
  inversion H0; subst.

  - (* proof for overall expression *)
    rename H1 into H_lcfm_lcf1. rename H2 into H_lcfm_lcf2.
    rename H5 into H_sorted_lcf1. rename H6 into H_sorted_lcf2.
    inversion H as [c r' crs H_rule H_all]; subst.
    inversion H_rule; subst. clear H_rule.
    rename H4 into H_abs_eq.
    inversion H_abs_eq; subst.
    clear H_abs_eq.

    ith_prem_exe_0 H_all H' mg_spec.
    ith_prem_exe_0 h h' mg_spec. clear h0.
    ith_prem_exe_1 h h' mg_spec. clear h0.

    simpl in h. repeat rewrite zlcfm_subst in h; auto.
    ith_prem_2 h h'.
    inversion h' as [H_nex_P | H_exP]; clear h'.
    +  (* refute that there is no info about the expr *)
      exfalso. apply H_nex_P.
      eexists.
      apply FUN_SP_e_unfold
        with (lcf1:=lcf1) (lcf2:=lcf2) (zs1:=lcf_seq lcf1) (zs2:=lcf_seq lcf2);
        auto.
    +  (* there is some info about the expr in the spec *)
      inversion H_exP as [P [H_spec_P H_P_r]]; clear H_exP.
      inv H_spec_P; subst.
      auto.

  - (* proof for the unfolded expression *)
    rename H1 into H_lcfm_lcf1. rename H2 into H_lcfm_lcf2.
    rename H5 into H_sorted_lcf1. rename H6 into H_sorted_lcf2.
    inversion H as [c r' crs H_rule H_all]; subst.
    inversion H_rule; subst. clear H_rule.

    ith_prem_exe_0 H_all H' mg_spec.
    ith_prem_exe_0 h h' mg_spec. clear h0.
    ith_prem_1 h h'.
    inversion h' as [H_nexP | H_exP]; clear h'.
    2: {
      have H_nex: ~(exists P, mg_spec param lcf1 P) by apply zlcfm_not_in_spec; auto.
      inv H_exP. inv H1. exfalso. apply H_nex. exists x0; auto.
    }
    inversion H_nexP as [H_nexP0  H_infer]; clear H_nexP.
    have H_cf'0_eq_lcf1: cf'0 = lcf1 by eapply zlcfm_infer_preserve; eauto.
    symmetry in H_cf'0_eq_lcf1. rewrite <- H_cf'0_eq_lcf1 in *.
    ith_prem_exe_2 h h' mg_spec.
    rename H7 into H_abs_eq. inv H_abs_eq; subst.
    ith_prem_exe_0 h0 h' mg_spec.
    ith_prem_exe_0 h1 h' mg_spec. clear h2.
    ith_prem_exe_1 h1 h' mg_spec. clear h2.
    ith_prem_exe_2 h1 h' mg_spec. clear h2.
    rename H7 into H_is_cfm_abs. clear H_is_cfm_abs.
    rename H10 into H_is_cfm_abs. clear H_is_cfm_abs.
    clear h1. clear h0.
    rename H5 into H_is_cfm_abs. clear H_is_cfm_abs.
    clear H_infer. clear H_nexP0. clear H_abs_eq.

    ith_prem_1 H_all H'.
    inversion H' as [H_nexP | H_exP]; clear H'.
    2: {
      have H_nex: ~(exists P, mg_spec param lcf2 P) by apply zlcfm_not_in_spec; auto.
      inv H_exP. inv H1. exfalso. apply H_nex. exists x; auto.
    }
    inversion H_nexP as [H_nex H_infer]; clear H_nexP.
    have H_cf'_eq_lcf2: cf' = lcf2 by eapply zlcfm_infer_preserve; eauto.
    symmetry in H_cf'_eq_lcf2. rewrite <- H_cf'_eq_lcf2 in *.
    ith_prem_2 H_all H'.
    inversion H' as [H_nexP | H_exP]; clear H'.
    2: { inv H_exP. inv H1. inv H2. }
    repeat rewrite zlcfm_subst in H_nexP; auto.
    2: { rewrite zlcfm_subst; auto. }
    clear H_nex. clear H_infer.
    inversion H_nexP as [H_nex H_infer]; clear H_nexP.
    rename cf'0 into lcf1.

    inversion H_infer as [c0 r0 crs0 H_rule_lcase H_all'].
    rename H1 into H_c0_eq_. clear c0 H_c0_eq_.
    rename H2 into H_r0_eq_. clear r0 H_r0_eq_.
    clear H_nex.
    inv H_rule_lcase; subst.

    +  (* first list is NilE *)
      ith_prem_0 H_all' h'.
      have H_nex: ~(exists P, mg_spec param lcf1 P) by eapply zlcfm_not_in_spec; eauto.
      have H_inf:  infer param (mg_spec param) (lcf1, NilE).
      { inv h'. inv H1; auto. inv H1. inv H2. exfalso. apply H_nex. exists x; auto. }
      clear h'. clear H_nex.
      have H_lcf1_nil: lcf1 = NilE by eapply zlcfm_infer_nil; eauto.
      ith_prem_1 H_all' h'.
      have H_nex: ~(exists P, mg_spec param cf' P) by eapply zlcfm_not_in_spec; eauto.
      have H_inf': infer param (mg_spec param) (cf', r) by get_branch h' H_nex.
      have H_r_eq_cf': r = cf'. eapply zlcfm_infer_preserve; eauto.
      symmetry in H_r_eq_cf'. rewrite <- H_r_eq_cf' in *.
      rewrite H_lcf1_nil. simpl.
      apply: conj=>//.

    + (* first list is not NilE *)
      ith_prem_0 H_all' h'.
      have H_nex: ~ (exists P, mg_spec param lcf1 P) by eapply zlcfm_not_in_spec; eauto.
      have H_inf: infer param (mg_spec param) (lcf1, PPendE cf cf'0)
        by get_branch h' H_nex.
      apply zlcfm_infer_pend in H_inf; auto.
      inversion H_inf as [z1 [H_lcf1_eq_pend [H_cf_ne H_zlcfm_cf'0]]]; clear H_inf.
      symmetry in H_lcf1_eq_pend. rewrite <- H_lcf1_eq_pend in *.
      symmetry in H_cf_ne. rewrite <- H_cf_ne in *.
      clear h'. clear H_nex.
      ith_prem_exe_1 H_all' h' mg_spec.
      ith_prem_exe_0 h0 h' mg_spec.
      ith_prem_exe_0 h1 h' mg_spec. clear h2.
      ith_prem_exe_1 h1 h' mg_spec.
      ith_prem_exe_2 h1 h' mg_spec. clear h3. clear h2. clear h1.
      rename H9 into H_is_cfm_abs. clear H_is_cfm_abs.
      (* clear H1. clear H2. *) clear H15.
      ith_prem_1 h0 h'.
      have H_nex: ~(exists P, mg_spec param cf'0 P)
        by apply zlcfm_not_in_spec; auto.
      have H_inf: infer param (mg_spec param) (cf'0, cf'1) by get_branch h' H_nex.
      have H_cf'0_eq_cf'1: cf'1 = cf'0
        by apply zlcfm_infer_preserve with (param:=param); auto.
      rewrite <- H_cf'0_eq_cf'1 in *.
      (* cf'1 is the tail of the first list *)
      rewrite zlcfm_subst in h0; auto.
      rewrite zlcfm_subst in h0; auto.
      rename cf' into lcf2.
      clear H_nex h'.
      ith_prem_exe_2 h0 h' mg_spec.

      * (* second list is NilE *)
        ith_prem_0 h1 h'.
        have H_nex: ~(exists P, mg_spec param lcf2 P)
          by apply zlcfm_not_in_spec; auto.
        clear H_inf.
        rewrite zlcfm_subst in h'; auto.
        have H_inf: infer param (mg_spec param) (lcf2, NilE)
          by get_branch h' H_nex.
        have H_lcf2_nil: lcf2 = NilE
          by apply zlcfm_infer_nil with (param:=param); auto.
        rewrite H_lcf2_nil.

        clear H_nex. ith_prem_exe_1 h1 h1' mg_spec.
        ith_prem_exe_0 h2 h2' mg_spec. clear h3.
        ith_prem_1 h2 h2'.
        clear H_inf.
        rewrite zlcfm_subst in h2'; auto.
        have H_nex: (~exists P, mg_spec param cf'0 P)
          by apply zlcfm_not_in_spec; auto.
        have H_inf: infer param (mg_spec param) (cf'0, cf')
          by get_branch h2' H_nex.
        have H_cf'_eq_cf'0: cf' = cf'0
          by apply zlcfm_infer_preserve with (param:=param); auto.
        rewrite H_cf'_eq_cf'0.
        apply: conj.
        (* is_zlcfm (PPendE (NE z1) cf'0) *)
        simpl; auto.
        (* goal with occ *)
        apply: conj. move=> z.
        have: occ (lcf_seq NilE) z = 0 by simpl; auto.
        move->. rewrite add_zero. auto.
        (* sorted ... *)
        assumption.

      * (* second list is not NilE *)
        ith_prem_0 h1 h1'.
        rewrite zlcfm_subst in h1'; auto.
        have H_nex: ~(exists P, mg_spec param lcf2 P)
          by apply zlcfm_not_in_spec; auto.
        clear H_inf.
        have H_inf: infer param (mg_spec param) (lcf2, PPendE cf cf').
        get_branch h1' H_nex.
        apply zlcfm_infer_pend in H_inf; auto.
        inversion H_inf as [z2 [H_lcf2_eq_ [H_cf_eq_ H_zlcfm_cf']]];
          clear H_inf.
        subst. clear H_nex.
        ith_prem_exe_2 h0 h0' mg_spec.
        ith_prem_0 h2 h2'.
        inv h2'. inv H1. inv H9. inv H19.
        inv H1. inv H2. inv H9.
        rewrite zlcfm_subst in h2; auto.
        ith_prem_exe_0 h2 h2' mg_spec.
        ith_prem_0 h3 h3'.
        have H_nex: ~(exists P, mg_spec param (NE z2) P)
          by intro contra; inv contra; inv H1.
        have H_inf: infer param (mg_spec param) (NE z2, cf)
          by get_branch h3' H_nex.
        have H_ne_z2_eq_cf: NE z2 = cf.
        { inversion H_inf; subst. inv H3; subst; auto. }
        rewrite <- H_ne_z2_eq_cf in *.
        clear h3'. clear H_nex. clear H_inf.
        ith_prem_1 h3 h3'.
        have H_nex: ~(exists P, mg_spec param cf' P)
          by apply zlcfm_not_in_spec; auto.
        have H_inf: infer param (mg_spec param) (cf', cf'1)
          by get_branch h3' H_nex.
        have H_cf'_1_eq_cf': cf'1 = cf'.
        apply zlcfm_infer_preserve with (param:=param); auto.
        symmetry in H_cf'_1_eq_cf'. rewrite <- H_cf'_1_eq_cf' in *.
        clear H_nex H_inf.
        clear H_ne_z2_eq_cf H_cf'_1_eq_cf'. clear h3'.
        rename H9 into H_is_cfm_ne_z2. clear H_is_cfm_ne_z2.
        clear h3.
        ith_prem_exe_1 h2 h2' mg_spec.
        ith_prem_exe_0 h3 h3' mg_spec.
        ith_prem_exe_0 h4 h4' mg_spec. clear h5.
        ith_prem_1 h4 h4'.
        have H_nex: ~(exists P, mg_spec param (NE z2) P).
        { intro contra. inv contra. inv H1. }
        have H_inf: infer param (mg_spec param) (NE z2, cf'3)
          by get_branch h4' H_nex.
        have H_cf'3_eq_ne_z2: NE z2 = cf'3.
        { inv H_inf; subst. inv H3; subst; auto. }
        rewrite <- H_cf'3_eq_ne_z2 in *. clear H_cf'3_eq_ne_z2.
        clear h4' H_inf H_nex.
        ith_prem_exe_2 h4 h4' mg_spec. clear h5.
        rename H18 into H_is_cfm_abs. clear H_is_cfm_abs.
        clear h4.
        ith_prem_2 h3 h3'.
        inversion h3' as [H_nexP | H_exP].
        2: { inv H_exP. inv H1. inv H2. }
        inversion H_nexP as [H_nex H_inf]. clear H_nex.
        repeat (rewrite zlcfm_subst in H_inf; auto;
                [ | try (rewrite zlcfm_subst; auto)]).
        (* H_inf is about the inf result of the if expression *)
        inversion H_inf; subst.
        rename H3 into H_rule_if.
        inversion H_rule_if; subst.

        (* the true branch for the if expression *)
        rename H18 into H_forall_true.
        ith_prem_0 H_forall_true h'.
        have H_inf_tt: infer param (mg_spec param) (LeE (NE z1) (NE z2), BE true).
        {
          have H_nex: ~(exists P, mg_spec param (LeE (NE z1) (NE z2)) P).
          { intro contra. inv contra. inv H1. }
          get_branch h' H_nex.
        }
        apply inf_le_comp in H_inf_tt.
        clear h'.
        ith_prem_exe_1 H_forall_true h' mg_spec.
        ith_prem_exe_0 h4 h4' mg_spec.
        ith_prem_1 h4 h4'.
        fold e_lcase in h4'.
        rewrite zlcfm_subst in h4'; auto.
        rewrite zlcfm_subst in h4'; auto; [ | try (rewrite zlcfm_subst; auto)].
        rewrite zlcfm_subst in h4'; auto.
        clear H_nexP.
        inversion h4' as [H_nexP | H_exP]; clear h4'.
        (* refute that there is no info in the spec *)
        inv H_nexP.
        exfalso. apply H1.
        eexists.
        apply FUN_SP_e_unfold
          with (lcf1:=cf'0) (lcf2:=PPendE (NE z2) cf')
               (zs1:=lcf_seq cf'0) (zs2:=lcf_seq (PPendE (NE z2) cf'));
          eauto.
        (* goal on the sortedness of tail of first list *)
        simpl in H_sorted_lcf1.
        apply sorted_tail in H_sorted_lcf1; auto.

        (* there is some info in the spec *)
        inversion H_exP as [P H_mg_spec]; clear H_exP.
        inversion H_mg_spec as [H_spec_P H_P_cf'4]; clear H_mg_spec.
        inv H_spec_P; subst. clear H_spec_P.
        inversion H_P_cf'4 as [H_zlcfm_cf'4 [H_occ H_sorted]]; clear H_P_cf'4.
        apply: conj. simpl; auto. (* goal with is_zlcfm *)
        apply: conj.
        (* goal with occ *)
        move=> z. specialize (H_occ z).
        simpl in H_occ. simpl. rewrite H_occ.
        case En: (z1 =? z)%Z; case En': (z2 =? z)%Z;
          auto with zarith.
        (* goal on sortedness *)
        simpl.
        have H_cf'4_cases: cf'4 = NilE \/ exists z cf', cf'4 = PPendE (NE z) cf'
              by apply zlcfm_shape; auto.
        inversion H_cf'4_cases as [H_nil | H_n_nil]; clear H_cf'4_cases.
        rewrite H_nil. simpl. apply singleton_sorted.
        inversion H_n_nil as [z0 [cf'' H_cf'4_eq]]; clear H_n_nil.
        have H_corr:
          size (lcf_seq cf'0) > 0 /\ nth 0%Z (lcf_seq cf'4) 0 = nth 0%Z (lcf_seq cf'0) 0 \/
          size (lcf_seq (PPendE (NE z2) cf')) > 0 /\
          nth 0%Z (lcf_seq cf'4) 0 = nth 0%Z (lcf_seq (PPendE (NE z2) cf')) 0.
        {
          apply occ_sorted_hd_corr; auto with zarith.
          rewrite H_cf'4_eq. simpl. auto.
        }
        have H_simp: nth 0%Z (lcf_seq cf'4) 0 = z0 by rewrite H_cf'4_eq=>//=.
        rewrite H_simp in H_corr.
        inversion H_corr as [H_l_first | H_r_first]; clear H_corr.
        (* head ele of new list is head ele of first list *)
        inversion H_l_first as [H_sz_cf'0 H_z0_eq_]; clear H_l_first.
        have H_z1_le_: (z1 <= nth 0%Z (lcf_seq cf'0) 0)%Z.
        { apply sorted_hd_nxt; auto with zarith. }
        rewrite <- H_z0_eq_ in H_z1_le_. rewrite <- H_simp in H_z1_le_.
        have: z1 :: lcf_seq cf'4 = [:: z1] ++ lcf_seq cf'4 by auto.
        move->.
        apply sorted_concat; auto with zarith. apply singleton_sorted.
        have: size [:: z1] - 1 = 0 by auto with arith. move->.
        have: nth 0%Z [:: z1] 0 = z1 by auto. move->.
        auto with zarith.
        (* head ele of new list if head ele of second list *)
        inversion H_r_first as [H_sz_ H_z0_eq_]; clear H_r_first.
        have H_z1_le_: (z1 <= z2)%Z by apply Zle_bool_imp_le; auto.
        simpl in H_z0_eq_. rewrite <- H_z0_eq_ in *.
        have: z1 :: lcf_seq cf'4 = [:: z1] ++ lcf_seq cf'4 by auto.
        move->.
        apply sorted_concat; auto with zarith. apply singleton_sorted.
        have: size [:: z1] - 1 = 0 by auto with arith. move->.
        have: nth 0%Z [:: z1] 0 = z1 by auto. move->.
        auto with zarith.

        (* the false branch for the if expression *)
        have H_cf'2_eq_cf': cf'2 = cf'.
        {
          ith_prem_1 h3 h3''.
          have H_nex: ~(exists P, mg_spec param cf' P)
            by apply zlcfm_not_in_spec; auto.
          have H_inf': infer param (mg_spec param) (cf', cf'2)
            by get_branch h3'' H_nex.
          apply zlcfm_infer_preserve with (param:=param); auto.
        }
        symmetry in H_cf'2_eq_cf'. rewrite <- H_cf'2_eq_cf' in *.
        move: H_cf'2_eq_cf'.
        rename H18 into H_forall_false.
        ith_prem_0 H_forall_false h'.
        have H_inf_ff: infer param (mg_spec param) (LeE (NE z1) (NE z2), BE false).
        {
          have H_nex: ~(exists P, mg_spec param (LeE (NE z1) (NE z2)) P).
          { intro contra. inv contra. inv H1. }
          get_branch h' H_nex.
        }
        apply inf_le_comp in H_inf_ff.
        clear h'.
        ith_prem_exe_1 H_forall_false h' mg_spec.
        ith_prem_exe_0 h4 h4' mg_spec.
        ith_prem_1 h4 h4'.
        fold e_lcase in h4'.
        rewrite zlcfm_subst in h4'; auto. 2: { repeat rewrite zlcfm_subst; auto. }
        rewrite zlcfm_subst in h4'; auto. 2: { rewrite zlcfm_subst; auto. }
        rewrite zlcfm_subst in h4'; auto.
        clear H_nexP.
        inversion h4' as [H_nexP | H_exP]; clear h4'.
        (* refute that there is no info in the spec *)
        inv H_nexP.
        exfalso. apply H1.
        eexists.
        apply FUN_SP_e_unfold
          with (lcf1:=(PPendE (NE z1) cf'0)) (lcf2:=cf')
               (zs1:=lcf_seq (PPendE (NE z1) cf'0)) (zs2:=lcf_seq cf');
          eauto.
        (* goal on the sortedness of tail of first list *)
        simpl in H_sorted_lcf2.
        apply sorted_tail in H_sorted_lcf2; auto.

        (* there is some info in the spec *)
        move=> H'. move=> {H'}.
        inversion H_exP as [P H_mg_spec]; clear H_exP.
        inversion H_mg_spec as [H_spec_P H_P_cf'4]; clear H_mg_spec.
        inv H_spec_P; subst. clear H_spec_P.
        inversion H_P_cf'4 as [H_zlcfm_cf'4 [H_occ H_sorted]]; clear H_P_cf'4.
        apply: conj. simpl; auto. (* goal with is_zlcfm *)
        apply: conj.
        (* goal on occ *)
        move=> z. specialize (H_occ z).
        simpl in H_occ. simpl. rewrite H_occ.
        rewrite [(z2 =? z)%Z + ((z1 =? z)%Z + _ + _)]Nat.add_assoc.
        rewrite [((z2 =? z)%Z + ((z1 =? z)%Z + _))%coq_nat]Nat.add_assoc.
        rewrite [((z2 =? z)%Z + (z1 =? z)%Z)%coq_nat]Nat.add_comm.
        rewrite -[(((z1 =? z)%Z + (z2 =? z)%Z)%coq_nat + _)%coq_nat]Nat.add_assoc.
        rewrite [((z2 =? z)%Z + occ (lcf_seq cf'0) z)%coq_nat]Nat.add_comm.
        rewrite [((z1 =? z)%Z + (_ + (z2 =? z)%Z)%coq_nat)%coq_nat]Nat.add_assoc.
        auto with arith.
        (* goal on sortedness *)
        simpl.
        have H_cf'4_cases: cf'4 = NilE \/ exists z cf', cf'4 = PPendE (NE z) cf'
              by apply zlcfm_shape; auto.
        inversion H_cf'4_cases as [H_nil | H_n_nil]; clear H_cf'4_cases.
        rewrite H_nil. simpl. apply singleton_sorted.
        inversion H_n_nil as [z0 [cf'' H_cf'4_eq]]; clear H_n_nil.
        have H_corr:
          size (lcf_seq (PPendE (NE z1) cf'0)) > 0 /\
          nth 0%Z (lcf_seq cf'4) 0 = nth 0%Z (lcf_seq (PPendE (NE z1) cf'0)) 0 \/
          size (lcf_seq cf') > 0 /\
          nth 0%Z (lcf_seq cf'4) 0 = nth 0%Z (lcf_seq cf') 0.
        {
          apply occ_sorted_hd_corr; auto with zarith.
          rewrite H_cf'4_eq. simpl. auto.
        }
        have H_simp: nth 0%Z (lcf_seq cf'4) 0 = z0 by rewrite H_cf'4_eq=>//=.
        rewrite H_simp in H_corr.
        inversion H_corr as [H_l_first | H_r_first]; clear H_corr.
        (* head ele of new list is head ele of first list *)
        inversion H_l_first as [H_sz_ H_z0_eq_]; clear H_l_first.
        have H_z2_lt_: (z2 < z1)%Z by apply Z.leb_gt; auto.
        have H_z2_le_: (z2 <= z1)%Z by auto with zarith.
        simpl in H_z0_eq_. symmetry in H_z0_eq_. rewrite <- H_z0_eq_ in *.
        have: z2 :: lcf_seq cf'4 = [:: z2] ++ lcf_seq cf'4 by auto.
        move->.
        apply sorted_concat; auto with zarith. apply singleton_sorted.
        have: size [:: z2] - 1 = 0 by auto with arith. move->.
        have: nth 0%Z [:: z2] 0 = z2 by auto. move->.
        auto with zarith.
        (* head ele of new list is head ele of second list *)
        inversion H_r_first as [H_sz_cf'0 H_z0_eq_]; clear H_r_first.
        have H_z2_le_: (z2 <= nth 0%Z (lcf_seq cf') 0)%Z.
        { apply sorted_hd_nxt; auto with zarith. }
        rewrite <- H_z0_eq_ in H_z2_le_. rewrite <- H_simp in H_z2_le_.
        have: z2 :: lcf_seq cf'4 = [:: z2] ++ lcf_seq cf'4 by auto.
        move->.
        apply sorted_concat; auto with zarith. apply singleton_sorted.
        have: size [:: z2] - 1 = 0 by auto with arith. move->.
        have: nth 0%Z [:: z2] 0 = z2 by auto. move->.
        auto with zarith.

Qed.


Require Export XR_Rminus.
Require Export XR_IZR.
Require Export XR_Int_part.

Local Open Scope R_scope.

Definition frac_part r : R := r - IZR (Int_part r).


Require Import HoTT minus1Trunc.
Require Export basics nat_struct.
Require Import syntax.
Import Distributive.

(** This file: various results which apply to Q, for use in constructing R **)
(** Later, should split in order to require weaker hypotheses when possible **)

Module FullDecField.
Export Field_pr OrderedMagma_pr OrderedRing.

Section VarSec.

Context {T : Type}.
Variable L : PreringFull T.
Context {Hset : IsHSet T} {Hpr1 : RelationProp (#)}
{Hpr2 : RelationProp (<=)} {Hpr3 : RelationProp (<)}.
Context {Hl : IsFullDecField L}.
Context {Hdec : @Decidable T paths}.

Global Instance fullpseudo : FullPseudoOrder L.
Proof.
split;apply Hl.
Defined.

Global Instance fullposet : FullPoset L.
Proof.
apply fullpseudo_is_fullposet;apply _.
Defined.

Global Instance plus_lt_invariant : IsInvariant (+ <).
Proof.
apply linvariant_invariant. apply _.
red. apply _.
Defined.

Global Instance lt_trans : Transitive (<).
Proof.
apply fullposet.
Defined.

Global Instance plus_lt_compat : IsCompat (+ <).
Proof.
apply invariant_compat;apply _.
Defined.

Global Instance plus_lt_regular : forall z, IsRegular (+ <) z.
Proof.
intros. apply inverse_regular with (roppV z).
unfold gop;apply _. apply _. apply roppP.
Defined.

Global Instance strict_srorder : IsStrictSemiringOrder L.
Proof.
split;try apply Hl.
apply (@pseudo_is_strict T L _). apply _.
intros. apply Hl.
red. apply Hl. assumption.
Defined.

Global Instance plus_apart_invariant : IsInvariant (+ #).
Proof.
apply linvariant_invariant. apply _.
intros z x y. unfold rrel,gop. simpl. intros.
apply (@apart_iff_total_lt T L _).
apply (@apart_iff_total_lt T L _) in X. destruct X;[left|right];
apply plus_lt_invariant;assumption.
Defined.

Global Instance plus_leq_invariant : IsInvariant (+ <=).
Proof.
apply linvariant_invariant. apply _.
hnf. intros z x y.
unfold rrel,gop. simpl.
intros. apply (@le_iff_not_lt_flip T L _). intro H.
apply (@le_iff_not_lt_flip T L _) in X. apply X.
apply plus_lt_regular with z. assumption.
Defined.

Global Instance plus_leq_compat : IsCompat (+ <=).
Proof.
apply invariant_compat.
apply fullposet.
apply _.
Defined.

Lemma plus_lt_leq_lt : forall a b, a < b -> forall c d, c <= d ->
a + c < b+d.
Proof.
intros.
apply (@lt_le_trans T L _) with (b+c).
apply _.
apply plus_lt_invariant. assumption.
apply plus_leq_invariant. assumption.
Defined.

Lemma plus_leq_lt_lt : forall a b, a <= b -> forall c d, c < d ->
a+c < b+d.
Proof.
intros.
apply (@le_lt_trans T L _) with (b+c).
apply _.
(*NB:this simpl makes it go faster*)
simpl;apply plus_leq_invariant. assumption.
apply plus_lt_invariant. assumption.
Defined.

Lemma ropp_lt_flip : forall a b, a < b -> roppV b < roppV a.
Proof.
pose (H := @gopp_rrel_flip T (+ <) _).
simpl in H. unfold rrel in H.
change goppV with roppV in H. apply H. apply plus_lt_invariant.
Defined.

Lemma ropp_apart_flip : forall a b, a # b -> roppV b # roppV a.
Proof.
intros. apply (@apart_iff_total_lt T L _).
apply (@apart_iff_total_lt T L _) in X.
destruct X;[left|right];apply ropp_lt_flip;assumption.
Defined.

Lemma ropp_lt_flip_back : forall a b, roppV b < roppV a -> a < b.
Proof.
intros. pattern a;apply transport with (roppV (roppV a));[|
apply transport with (roppV (roppV b));[|apply ropp_lt_flip;assumption]];
apply gopp_gopp.
Defined.

Lemma ropp_leq_flip : forall a b, a <= b -> roppV b <= roppV a.
Proof.
intros. simpl;apply Hl.
intro H;simpl in X;apply Hl in X. apply X.
apply ropp_lt_flip_back;assumption.
Defined.

Lemma ropp_leq_flip_back : forall a b, roppV b <= roppV a -> a <= b.
Proof.
intros. simpl;apply Hl.
intro H;simpl in X;apply Hl in X. apply X.
apply ropp_lt_flip;assumption.
Defined.

Global Instance plus_leq_regular : forall z, IsRegular (+ <=) z.
Proof.
intros;apply inverse_regular with (roppV z).
unfold gop;apply _.
apply _.
apply roppP.
Defined.

Lemma lt_flip : forall {x y : T}, x < y -> y < x -> Empty.
Proof.
apply Hl.
Defined.

Lemma not_lt_apart_lt_flip : forall {x y : T}, ~ x < y -> x # y -> y < x.
Proof.
intros. apply (@apart_iff_total_lt T L _) in X0.
destruct X0;auto. destruct X;auto.
Defined.

Global Instance pospreserving : IsPosPreserving (+ ° <):= _.

Lemma mult_apart_embed : forall z, ZeroV # z ->
IsEmbedding (#) (#) (mult z).
Proof.
intros z Hz;split.
- hnf;unfold rrel. intros.
  assert (Hb : IsBinRegular (° #)). apply _.
  hnf in Hb. unfold rrel,gop in Hb. simpl in Hb.
  assert (dec_inv z ° (z°x) # dec_inv z ° (z°y)).
  pattern (dec_inv z ° (z°x)). apply transport with x.
  path_via ((dec_inv z ° z) ° x). apply inverse. apply dec_inv_ok.
  intros H;destruct H;apply (@irrefl T (#)) in Hz. assumption.
  apply Hl.
  apply inverse. apply associative. apply Hl.
  apply transport with y.
  path_via ((dec_inv z ° z) ° y). apply inverse. apply dec_inv_ok.
  intros H;destruct H;apply (@irrefl T (#)) in Hz. assumption.
  apply Hl.
  apply inverse. apply associative. apply Hl.
  assumption.
  apply Hb in X0. clear Hb. revert X0.
  apply minus1Trunc_rect_nondep;[|apply Hpr1].
  intros. destruct X0 as [H|H].
  apply (@irrefl T (#) Hl) in H. destruct H.
  assumption.
- hnf. unfold rrel.
  intros.
  assert (Hb : IsBinRegular (° #)). apply _.
  apply Hb in X.
  clear Hb;revert X.
  apply minus1Trunc_rect_nondep;[|apply Hpr1].
  unfold rrel. simpl. intros [H|H].
  apply (@irrefl T (#) Hl) in H. destruct H.
  assumption.
Defined.

Lemma mult_lt_embed_pos : forall z, ZeroV < z ->
IsEmbedding (<) (<) (mult z).
Proof.
assert (forall z : T, ZeroV < z -> IsMorphism lt lt (mult z)).
- intros z Hz;red;unfold gop,rrel;simpl;intros ? ? H.
  apply plus_lt_regular with (roppV (z ° x)).
  unfold gop,rrel. simpl.
  set (X := roppV (z°x) + z°x). pattern X;apply transport with ZeroV;
  unfold X;clear X.
  apply inverse.
  apply (@ropp_l T L _).
  set (X := roppV (z ° x) + z ° y). apply transport with (z ° ((roppV x) + y));
  unfold X;clear X.
  eapply concat. apply ldistributes. apply _.
  apply (@ap T T (fun k:T => k + _)).
  apply inverse. apply (@ropp_rmult_right T L _).
  apply pospreserving. assumption.
  apply plus_lt_regular with x.
  apply transport with y. unfold gop;simpl.
  path_via ((x+roppV x)+y).
  apply inverse. apply roppP.
  apply inverse;apply associative. apply Hl.
  unfold gop,rrel; simpl.
  set (X := x+ZeroV);pattern X;apply transport with x;unfold X;clear X.
  apply inverse;apply (@ZeroP T L _).
  assumption.

- intros z Hz;split. apply X;assumption.
  hnf;unfold rrel.
  intros ? ? H. apply not_lt_apart_lt_flip.
  intros H'. apply (lt_flip H).
  apply X. assumption.
  assumption.
  apply mult_apart_embed with z.
  apply (@apart_iff_total_lt T L _). left;assumption.
  unfold rrel. apply (@apart_iff_total_lt T L _). right;assumption.
Defined.

Lemma ropp_inv : forall x, roppV (dec_inv x) = dec_inv (roppV x).
Proof.
intros. destruct (Hdec ZeroV x) as [H|H];unfold rrel in H.
- destruct H.
  path_via ZeroV.
  eapply concat. apply ap. apply dec_inv0.
  apply ropp_zero.
  apply inverse. eapply concat. apply ap.
  apply ropp_zero. apply dec_inv0.
- apply (@inverse_unicity T (°) _ (roppV x)).
  apply linverse_inverse. red.
  unfold gop. apply transport with OneV.
  eapply concat;[|apply ropp_rmult_right].
  eapply concat;[|apply ap;apply ropp_rmult_left].
  apply inverse. eapply concat. apply gopp_gopp.
  apply (id_unique (°)).
  apply dec_inv_ok. assumption.
  apply One. apply One.

  apply dec_inv_ok. intro H'.
  pose (H0 := ap roppV H'). clearbody H0.
  apply H. eapply concat;[|eapply concat;[apply H0|]].
  symmetry. apply ropp_zero.
  apply gopp_gopp.
Defined.

Lemma mult_lt_embed_neg : forall z, z < ZeroV ->
IsEmbedding (<) (fun x y => y < x) (mult z).
Proof.
split;red; unfold rrel.
- intros.
  apply plus_lt_regular with (roppV (z ° y)).
  unfold gop,rrel;simpl.
  set (Y := roppV (z°y) + z°y). pattern Y;apply transport with ZeroV;unfold Y;
  clear Y.
  apply (id_unique (+)). apply Zero. apply inverse_right. exact (roppP (z°y)).
  apply transport with (roppV z ° (y + roppV x)).
  eapply concat. apply ldistributes. apply _.
  apply ap11;[apply ap|].
  apply inverse;exact (ropp_rmult_left z y).
  eapply concat;[symmetry;apply ropp_rmult_right|].
  eapply concat;[symmetry;apply ap;apply ropp_rmult_left|].
  apply gopp_gopp.

  apply pospreserving;change rrel with lt.
  pattern ZeroV. apply transport with (roppV ZeroV).
  apply ropp_zero.
  apply ropp_lt_flip. assumption.
  apply plus_lt_regular with x.
  unfold gop,rrel. simpl.
  set (Y := x+ZeroV). pattern Y;apply transport with x;unfold Y.
  apply inverse. apply (@Zero T L _).
  apply transport with y.
  path_via ((x + roppV x) + y).
  apply inverse. apply roppP.
  eapply concat. symmetry;apply associative. apply Hl.
  unfold gop;simpl.
  apply ap. apply commutative. apply Hl.
  assumption.

- intros.
  apply ropp_lt_flip in X0.
  rewrite ropp_rmult_left in X0. (* !! rewrite *)
  rewrite ropp_rmult_left in X0.
  apply mult_lt_embed_pos with (roppV z).
  apply ropp_lt_flip_back.
  rewrite ropp_zero;change roppV with goppV. rewrite gopp_gopp.
  assumption.
  assumption.
Qed.

Lemma mult_lt_pos_inverse_pos : forall x, ZeroV < x -> ZeroV < dec_inv x.
Proof.
intros.
apply mult_lt_embed_pos with (x°x).
apply pospreserving;assumption.
unfold rrel.
apply transport with x.
path_via (x °  (x ° dec_inv x)).
apply inverse. apply dec_inv_ok.
intros H;destruct H;apply Hl in X;assumption.
apply associative. apply Hl.
pattern (x ° x ° ZeroV). apply transport with ZeroV.
apply inverse. apply rmult_0_r.
assumption.
Defined.

Lemma mult_lt_neg_inverse_neg : forall x, x < ZeroV -> dec_inv x < ZeroV.
Proof.
intros. apply ropp_lt_flip_back.
pattern (roppV ZeroV). apply transport with ZeroV.
apply inverse. apply ropp_zero.
eapply transport.
symmetry;apply ropp_inv.
apply mult_lt_pos_inverse_pos.
apply ropp_lt_flip_back.
pattern (roppV (roppV x)). apply transport with x.
apply inverse. apply gopp_gopp.
eapply transport. symmetry. apply ropp_zero.
assumption.
Defined.

Lemma dec_inv_neq : forall x, ZeroV != x -> ZeroV != dec_inv x.
Proof.
intros x Hx H'.
generalize (ap (mult (x°x)) H').
intro Hx'.
apply Hx. eapply concat;[|eapply concat;[apply Hx'|]].
apply inverse. apply rmult_0_r.
path_via (x ° (x ° dec_inv x)).
apply inverse. apply associative;apply Hl.
apply dec_inv_ok. assumption.
Defined.

Lemma inv_inv : forall x, dec_inv (dec_inv x) = x.
Proof.
intros.
destruct (Hdec ZeroV x) as [Hx|Hx].
destruct Hx.
eapply concat;[apply ap|];apply dec_inv0.
unfold rrel in Hx.
apply (@inverse_unicity T (°) _ (dec_inv x)).
apply dec_inv_ok. apply dec_inv_neq. assumption.
apply inverse_symm. apply dec_inv_ok. assumption.
Defined.

Global Instance nat_embed_lt : IsEmbedding (<) (<) (nat_embed L).
Proof.
assert (IsMorphism (<) (<) (nat_embed L)).
red. unfold rrel.
assert (forall n, nat_embed L n < nat_embed L (S n)).
intros. pattern (nat_embed L n). apply transport with (ZeroV + nat_embed L n).
apply Zero.
simpl. apply plus_lt_leq_lt. apply fulldecfield_zero_lt_one.
apply fullposet.
intros n m H.
induction H. auto.

apply transitivity with (nat_embed L m).
assumption. apply X.

split;try assumption. red. unfold rrel.
intros. destruct (nat_trichotomic x y) as [?|H]. assumption.
destruct H as [H|H].
destruct H. apply (@irrefl T (<) _) in X0. destruct X0.
apply X in H. unfold rrel in H.
destruct (@pseudoorder_antisym T L _ _ _ X0 H).
Defined.

Global Instance nat_embed_inj : IsReflecting (paths) (paths) (nat_embed L).
Proof.
red;unfold rrel. intros.
destruct (nat_trichotomic x y) as [H|[H|H]];auto;
apply nat_embed_lt in H;unfold rrel in H;destruct X;
apply (@irrefl T (<) _) in H;destruct H.
Defined.

Global Instance nat_embed_apart : IsEmbedding (#) (#) (nat_embed L).
Proof.
split;red;unfold rrel.
intros. apply (@apart_iff_total_lt T L _).
destruct (nat_trichotomic x y) as [H|[H|H]];[left|destruct X;assumption|right];
apply nat_embed_lt;assumption.

intros. intro H. destruct H. apply (@irrefl T (#) Hl) in X. assumption.
Defined.

Global Instance nat_embed_leq : IsEmbedding (<=) (<=) (nat_embed L).
Proof.
split;red;unfold rrel.
intros. induction H.
apply fullposet.
simpl. eapply fullposet. apply IHnle.
change ((fun k => k <= OneV + nat_embed L m) (nat_embed L m)).
apply transport with (ZeroV + nat_embed L m).
apply Zero.
apply plus_leq_compat. apply (@lt_le T L _). apply fulldecfield_zero_lt_one.
apply fullposet.

intros. destruct x. apply nle_0.
change (x < y). apply nat_embed_lt.
unfold rrel.
eapply (@lt_le_trans T L _ _).
apply nat_embed_lt. apply nle_n.
assumption.
Defined.

Global Instance nat_embed_plus : Magma.IsMorphism (+) (+) (nat_embed L).
Proof.
apply _.
Defined.

Global Instance nat_embed_mult : Magma.IsMorphism (°) (°) (nat_embed L).
Proof.
apply _.
Defined.

Lemma mult_cancel : forall x : T, ZeroV != x -> Cancel (°) x.
Proof.
apply @intdom_partial_cancels.
red. intros.
apply min1. destruct (Hdec ZeroV a). left;assumption.
right.
apply (ap (fun k => dec_inv a ° k)) in X.
path_via (dec_inv a ° ZeroV).
apply inverse;apply rmult_0_r.
path_via (dec_inv a ° (a°b)).
path_via ((dec_inv a ° a) ° b).
apply associative. change (Associative (°)). apply _.
apply dec_inv_ok. assumption.
assumption.
Defined.

Section Average.

Definition avg_at (a b : T) (n m : nat) := a +
 nat_embed L m ° ((b + roppV a) ° (dec_inv (nat_embed L n))).

(*
avg_at a b n m := a + m (b-a) / n = (m b + (n-m) a) / n
 = b + ((n-m)a - (n-m)b)/n
 = avg_at b a n (n-m)
NB: only when n-m >= 0: n = m+k
*)

Lemma avg_comm : forall a b : T,
forall m k, 0 != k+m -> avg_at a b (k+m) m = avg_at b a (k+m) k.
Proof.
intros;unfold avg_at.
apply (@right_cancel T (°) (nat_embed L (k+m))).
apply mult_cancel.
apply nat_embed_apart in X. unfold rrel in X.
intro H;destruct H. apply @irrefl in X. assumption. apply fullposet.

unfold gop.
set (K := nat_embed L (k+m)).
path_via (a ° K + nat_embed L m ° (b + roppV a) ° (dec_inv K ° K)).
ssrapply (@ast2_full_semiring T L _); reflexivity.
path_via (a° K + nat_embed L m ° (b + roppV a)).
apply ap. apply dec_inv_ok.
change ZeroV with (nat_embed L 0);unfold K;clear K;intro H.
apply nat_embed_inj in H. auto.
path_via (b ° K + nat_embed L k ° (a + roppV b)).
pattern K. apply transport with (nat_embed L k + nat_embed L m).
unfold K. apply inverse. apply nat_embed_plus.
ssrapply (@ast2_full_semiring T L _). simpl. unfold gop.
apply ap.
path_via (ZeroV + nat_embed L m ° b).
path_via ((a + roppV a) ° nat_embed L m + nat_embed L m ° b).
ssrapply (@ast2_full_semiring T L _);reflexivity.
apply (@ap _ _ (fun k => k + _)).
path_via (ZeroV ° nat_embed L m).
apply (@ap _ _ (fun k : T => k ° _)).
apply ropp_r.
apply rmult_0_l.

apply inverse. path_via ((b + roppV b) ° nat_embed L k + nat_embed L m ° b).
ssrapply (@ast2_full_semiring T L _);reflexivity.
apply (@ap _ _ (fun k => k + _)).
path_via (ZeroV ° nat_embed L k).
apply (@ap _ _ (fun k => k ° _)). apply ropp_r.
apply rmult_0_l.

path_via (b ° K + (nat_embed L k ° (a + roppV b)) ° (dec_inv K ° K)).
apply inverse. apply ap. apply dec_inv_ok.
unfold K;change ZeroV with (nat_embed L 0);intro H.
apply nat_embed_inj in H. auto.
ssrapply (@ast2_full_semiring T L _);reflexivity.
Qed.

Lemma avg_gt : forall a b : T, a < b ->
forall n m, 0 < n -> 0 < m -> a < avg_at a b n m.
Proof.
unfold avg_at.
intros.
Defined.

End Average.

End VarSec.

End FullDecField.


Require Import Automatik.lib.operators.

(** * Operations over sets *)

Section Pset.

Variable A : Type.

Definition pset := (A -> Prop).

Definition inter (P Q : pset) : pset :=
  fun x => P x /\ Q x.

Definition union (P Q : pset) : pset :=
  fun x => P x \/ Q x.

Definition diff (P Q : pset) : pset :=
  fun x => P x /\ ~Q x.

Definition comp (P : pset) : pset :=
  fun x => ~P x.

Definition subseteq (P Q : pset) :=
  forall x, P x -> Q x.

Definition subset (P Q : pset) :=
  subseteq P Q /\ exists x, Q x /\ ~Q x.

End Pset.

Instance inter_cap (A : Type) : CapOp (pset A) := inter A.
Instance union_cup (A : Type) : CupOp (pset A) := union A.
Instance subseteq_subseteq (A : Type) : SubseteqOp (pset A) := subseteq A.
Instance subset_subset (A : Type) : SubsetOp (pset A) := subset A.


Require Import CT.Category.
Require Import CT.Functor.
Require Import CT.NaturalTransformation.
Require Export CT.Instance.NaturalTransformation.HCNaturalTransformation.
Require Export CT.Instance.NaturalTransformation.VCNaturalTransformation.
Require Import FunctionalExtensionality.

(** * Interchange of horizontal/vertical composition

Given functors \(F\), \(G\), \(H\) : \(C \to D\) and \(F'\), \(G'\), \(H'\) :
\(D \to E\), and natural transformations \(\alpha : F \Rightarrow G\),
\(\beta : G \Rightarrow H\), \(\alpha' : F' \Rightarrow G'\), and
\(\beta' : G' \Rightarrow H'\), then the following holds:

$$$$
(\beta' \circ \alpha') * (\beta \circ \alpha) = (\beta' * \beta) \circ (\alpha' * \alpha) : F' \circ F \to H' \circ H
$$$$
*)
Section NaturalTransformationInterchange.
  Context {A A' A'' : Category}.
  Context {F G H : Functor A A'}.
  Context {F' G' H' : Functor A' A''}.
  Context {alpha : NaturalTransformation F G}.
  Context {beta : NaturalTransformation G H}.
  Context {alpha' : NaturalTransformation F' G'}.
  Context {beta' : NaturalTransformation G' H'}.

  Let l := HCNaturalTransformation (VCNaturalTransformation alpha beta) (VCNaturalTransformation alpha' beta').
  Let r := VCNaturalTransformation (HCNaturalTransformation alpha alpha') (HCNaturalTransformation beta beta').

  Theorem NaturalTransformationInterchange : l = r.
  Proof.
    apply nt_eq.
    simpl.
    extensionality X.
    rewrite F_comp_law.
    repeat rewrite assoc.
    match goal with
      [|- (comp ?B ?A = comp ?C ?A)] =>
      let H := fresh in
      cut (B = C); [intro H; rewrite H; trivial|]
    end.
    repeat rewrite assoc_sym.
    match goal with
      [|- (comp ?B ?A = comp ?B ?C)] =>
      let H := fresh in
      cut (A = C); [intro H; rewrite H; trivial|]
    end.
    rewrite <- nt_commutes.
    reflexivity.
  Qed.
End NaturalTransformationInterchange.


(**************************************************************************)
(*  This is part of IMP-STATES-EXCEPTIONS, it is distributed under the    *)
(*       terms  of the GNU Lesser General Public License version 3        *)
(*              (see file LICENSE for more details)                       *)
(*                                                                        *)
(*       Copyright 2015: Jean-Guillaume Dumas, Dominique Duval            *)
(*			 Burak Ekici, Damien Pous.                        *)
(**************************************************************************)

Require Import Relations Morphisms.
Require Import Program.
Require Memory Terms Decorations Axioms Derived_co_Pairs Derived_co_Products.
Set Implicit Arguments.
Require Import ZArith.
Open Scope Z_scope.

Module Make(Import M: Memory.T).
  Module Export ProofsExp := Derived_co_Products.Make(M).

Goal forall A B C D (f: term B A) (g: term C B) (h: term D C),
  PURE epure f -> PURE epure g -> PURE epure h -> h o (g o f) === (h o g) o f.
Proof. intros. now rewrite assoc. Qed.

(**STATES**)

 (** annihilation lookup-update *)
 Theorem ALU: forall i: Loc,
         update i o lookup i === id.
         (* Prop: 2.1: All Cases *)
 Proof.
     intro i. apply local_global. intro k.
     destruct (Loc_dec i k) as [e|n]. rewrite <- e.
     (*Case k = i*)
     rewrite assoc.
     rewrite ax1, ids, idt. reflexivity.
     (*Case k <> i*)
     rewrite assoc. rewrite ax2; [| exact n].
       rewrite <- assoc. rewrite ss_unit; [| edecorate].
       cut (forget === id). intro H1. rewrite H1.
       reflexivity.
       (* forget == id *)
         symmetry. apply ss_unit. decorate.
 Qed.

 (** interaction lookup-lookup *)
 Theorem ILL: forall i,
         lookup i o forget o lookup i === lookup i.
         (* Prop: 2.2: All Cases: Simplified Version *)
 Proof.
     intro i. rewrite <- assoc.
       rewrite ss_unit; [| edecorate].
         cut (forget === id).
         intro H0. rewrite H0, ids. reflexivity.
           symmetry. apply ss_unit; decorate.
 Qed.

 (** interaction update-update *)
 Theorem IUU: forall (x: Loc) (p q: Z),
         (update x o constant q) o (update x o constant p) === update x o constant q.
         (* Prop: 2.3: IMP+Exc adapted version *)
 Proof. intros x p q. apply local_global.
          intro i. destruct(Loc_dec i x). rewrite e.
            (* i = x *)
            repeat rewrite assoc. rewrite ax1. setoid_rewrite idt.
            setoid_rewrite <- ids at 6. rewrite <- assoc. apply (@pwsrepl _ _ _ epure); [decorate |].
            apply ws_unit.
            (* i<>x *)
            repeat rewrite assoc. rewrite ax2; [| auto].
            setoid_rewrite <- assoc at 4.
            setoid_rewrite <- assoc at 3.
            cut(forget o constant q === (@id unit)).
              intro H. rewrite H. setoid_rewrite ids at 1.
              rewrite ax2; auto. repeat rewrite <- assoc. apply sstows.
              apply replsubs; [reflexivity |].
              setoid_rewrite ss_unit; [reflexivity| decorate| decorate].
            (*1st cut*)
             setoid_rewrite ss_unit; [reflexivity| decorate| decorate].
 Qed.

 (** interaction update-lookup *)
 Theorem IUL: forall i: Loc,
         lookup i o update i ~== id. (* Prop: 2.4: All Cases *)
 Proof. intro i. apply ax1. Qed.

 (** commutation update-update *)
 Lemma CUU: forall {x y: Loc}, forall (n m: Z), x<>y ->
	(update y o constant m) o (update x o constant n) ===
        (update x o constant n) o (update y o constant m).
         (*Prop 2.6: IMP+Exc adapted version.*)
 Proof.
    intros x y n m H0. apply local_global.
      intro i. destruct (Loc_dec i y). rewrite e.
        (* i = y *)
        repeat rewrite assoc. rewrite ax1.
        apply wssym. rewrite  ax2; [| decorate].
        setoid_rewrite <- assoc at 3.
        cut(forget o constant n === (@id unit)).
          intro H1. rewrite H1.
          setoid_rewrite ids. rewrite ax1.
          setoid_rewrite idt. rewrite <- assoc. setoid_rewrite <- ids at 1.
          apply (@pwsrepl _ _ _ epure); [decorate |].
          apply ws_unit; reflexivity.
        (*1st cut*)
        setoid_rewrite ss_unit; [reflexivity| decorate| decorate ].
        destruct (Loc_dec i x). rewrite e.
        (* i = x and i <> y*)
        repeat rewrite assoc. rewrite ax1.
        rewrite  ax2; [| auto].
        setoid_rewrite <- assoc at 3.
        cut(forget o constant m === (@id unit)).
          intro H1. rewrite H1.
          setoid_rewrite ids. rewrite ax1.
          setoid_rewrite idt. rewrite <- assoc. setoid_rewrite <- ids at 1.
          apply (@pwsrepl _ _ _ epure); [decorate |].
          apply ws_unit; reflexivity.
        (*2nd cut*)
        setoid_rewrite ss_unit; [reflexivity| decorate| decorate ].
        (* i <> x and i <> y *)
        repeat rewrite assoc. setoid_rewrite ax2; [| auto| auto].
        setoid_rewrite <- assoc at 3. setoid_rewrite <- assoc at 5.
        cut(forget o constant m === (@id unit)).
          intro H1. rewrite H1.
          setoid_rewrite ids. rewrite ax2; [| auto]. rewrite <- assoc.
          cut(forget o constant n === (@id unit)).
            intro H2. rewrite H2.
            setoid_rewrite ids. rewrite ax2; [| auto]. rewrite <- assoc. rewrite H1.
            rewrite ids. reflexivity.
          (*3rd cut*)
          setoid_rewrite ss_unit; [reflexivity| decorate| decorate ].
        (*4th cut*)
        setoid_rewrite ss_unit; [reflexivity| edecorate| decorate ].
 Qed.

 (** commutation lookup-constant *)
 Theorem CLC: forall (i: Loc) (c: Z),
         (lookup i o (update i o (constant c)))
         ===
         (constant c) o update i o (constant c).
         (*Prop 2.8: All Cases*)
 Proof.
     intros i c. apply effect.
     (* Case 1: <> o f == <> o g *)
     rewrite assoc.
     cut (forget o lookup i === (@id unit)).
       intro H. rewrite H, idt.
       do 2 rewrite assoc.
       cut (forget o constant c === (@id unit)).
         intro H1; rewrite H1, idt.
         reflexivity.
       (*1st cut*)
       setoid_rewrite ss_unit; [reflexivity| decorate| decorate].
     (*2nd cut*)
     setoid_rewrite ss_unit; [reflexivity| edecorate| decorate].
     (* Case 2: f ~ g *)
     rewrite assoc, ax1, idt. setoid_rewrite <- ids at 1. rewrite <- assoc.
     apply (@pwsrepl _ _ _ epure); [decorate |].
     apply ws_unit.
 Qed.

 (** interactcommutation lookup-update-update *)
 Lemma CLUC: forall (m: Loc) (p q: Z),
      (pair (lookup m) (constant q)) o (update m o constant p)
      ===
      (pair (constant p) (constant q)) o (update m o constant p).
 Proof.
      intros m p q.
        apply ss_lpair_u.
          (*pi1 o f === pi1 o g*)
          setoid_rewrite assoc. setoid_rewrite fst_lpair_eq; [| decorate| decorate| decorate| decorate].
          rewrite CLC, assoc. reflexivity.
          (*pi2 o f === pi2 o g*)
          setoid_rewrite assoc. setoid_rewrite snd_lpair_eq; [reflexivity| decorate| decorate| decorate| decorate].
 Qed.

 (** annihilation tag-untag *)
 Lemma ATU: forall e: EName, (tag e) o (untag e) === (@id Empty_set).
 Proof.
    intro e.
    apply elocal_global.
    intro r. destruct(Exc_dec r e) as [Ha|Hb]. rewrite Ha.
    (* case e = r *) (* (1) *)
    rewrite idt. setoid_rewrite <- ids at 6. rewrite <- assoc. (* (1.1) *)
    apply swrepl; [reflexivity| apply eax1]. (* (1.2) *)
    (* case e <> r *) (* (2) *)
    cut(tag e o (@empty unit) === (@id (Empty_set)));
      [ intro H0| setoid_rewrite ss_empty; [reflexivity| decorate| edecorate]].
    rewrite <- H0. setoid_rewrite <- assoc. (* (2.1) *)
    apply swrepl; [reflexivity| apply eax2; exact Hb]. (* (2.2) *)
Qed.

 (** commutation untag-untag *)
 Lemma CUUe: forall (t s: EName) , s <> t ->
    (rcoprod (untag t) id) o in2 o (untag s) === (lcoprod id (untag s)) o in1 o (untag t).
 Proof.
    intros. apply elocal_global. intro r.
    (* r = t /\ r <> s *)
    destruct(Exc_dec r s). rewrite e. setoid_rewrite <- assoc at 4. rewrite (@eax2 s t); [| exact H].
      setoid_rewrite <- assoc at 4. setoid_rewrite assoc at 2.
      cut (in1 o (@empty unit) === in2).
        intro H1. rewrite H1.
        rewrite assoc, (@ss_lcoprod_eq _ _ _ _ pure); [| edecorate| edecorate].
        setoid_rewrite <- assoc. rewrite eax1.
        setoid_rewrite ids. rewrite (@sw_rcoprod_eq _ _ _ _ pure); [| edecorate| edecorate].
        rewrite ids. reflexivity.
      (*1st cut*)
      setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].

     destruct(Exc_dec r t). rewrite e. setoid_rewrite <- assoc. rewrite (@eax2 t s); [| auto].
       setoid_rewrite <- assoc. setoid_rewrite assoc at 2.
        cut (in2 o (@empty unit) === in1).
          intro H1. rewrite H1.
          rewrite assoc, ss_rcoprod_eq; [| edecorate| edecorate].
          setoid_rewrite <- assoc. rewrite eax1.
          setoid_rewrite ids. rewrite sw_lcoprod_eq; [| edecorate| edecorate].
          rewrite ids. reflexivity.
      (*2nd cut*)
      setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].

     setoid_rewrite <- assoc. rewrite (@eax2 r s); [| auto].
       setoid_rewrite <- assoc. setoid_rewrite assoc at 2.
        cut (in2 o (@empty unit) === in1).
          intro H1. rewrite H1.
          rewrite assoc, ss_rcoprod_eq; [| edecorate| edecorate].
          setoid_rewrite <- assoc.
          rewrite (@eax2 r t); [| auto].
          setoid_rewrite assoc at 3.
          cut (in1 o (@empty unit) === in2).
            intro H2. rewrite H2.
            setoid_rewrite assoc at 2. rewrite ss_lcoprod_eq; [| edecorate| edecorate].
            setoid_rewrite <- assoc. rewrite eax2; [| auto].
            apply sstosw. setoid_rewrite assoc. apply replsubs; [| reflexivity].
            setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].
          (*4th cut*)
          setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].
        (*3rd cut*)
        setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].
Qed.

 (** annihilation catch-raise *)
 Lemma ACR: forall (l: EName), forall (X Y: Type) (f: term Y X), PPG rw f ->
 downcast ((copair id ((empty Y o tag l) o untag l) o in1) o f) === f.
 Proof.
    intros. apply (@swtoss _ _ rw); [decorate | edecorate |].
    rewrite <- sw_downcast.
    apply sstosw. setoid_rewrite <- assoc.
    transitivity(copair id ((@empty Y) o id) o in1 o f).
      rewrite assoc. apply replsubs; [| reflexivity]. apply replsubs; [| reflexivity].
        apply ss_lcopair_u.
          setoid_rewrite sw_lcopair_eq; [reflexivity| edecorate| edecorate].
          setoid_rewrite (@ss_lcopair_eq _ _ _ pure); [| edecorate| edecorate].
          rewrite <- assoc. rewrite ATU. reflexivity.
        setoid_rewrite <- idt at 10. apply replsubs; [| reflexivity].
        apply (@swtoss _ _ rw); [edecorate| edecorate |].
        apply (@sw_lcopair_eq _ _ _ pure); edecorate.
 Qed.

 Axiom mono: forall {X Y: Type} (f g: term Empty_set Y), PPG rw f /\ PPG rw g -> ((@empty X) o f === (@empty X) o g)-> f === g.

(*propagate*)
 Lemma PPT: forall X Y (e: EName) (a: term Y X), PPG rw a -> a o ((@empty X) o tag e) === (@empty Y) o tag e.
 Proof.
    intros X Y e a H.
    rewrite assoc. apply replsubs; [| reflexivity]. apply ss_empty; edecorate.
 Qed.

(*recover*)
 Lemma RCV: forall X Y (e: EName) (u1 u2: term unit Y), EPURE rw u1 -> EPURE rw u2 ->
            ((@empty X) o tag e) o u1 === ((@empty X) o tag e) o u2 -> u1 ===  u2.
 Proof.
    intros X Y e u1 u2 H0 H1 H2. setoid_rewrite <- assoc in H2.
      apply mono in H2; [| split; apply is_comp; [decorate| edecorate | decorate | edecorate ]].
      apply (@swtoss _ _ rw); [edecorate| edecorate| ].
        transitivity ((untag e o tag e) o u1). setoid_rewrite <- idt at 1.
          apply (@pswsubs _ _ _ rw). apply swsym, eax1. unfold pure_id.
            split; [exact H0| reflexivity].
        apply swsym.
        transitivity ((untag e o tag e) o u2). setoid_rewrite <- idt at 1.
      apply (@pswsubs _ _ _ rw). apply swsym, eax1. unfold pure_id.
            split; [exact H1| reflexivity].
        apply swsym. apply sstosw. setoid_rewrite <- assoc.
        apply replsubs; [reflexivity| exact H2].
 Qed.

(*try0*)
 Lemma TRY0: forall X Y (e: EName) (u: term Y X) (b: term Y unit), EPURE rw u -> PPG rw b ->
         downcast ((copair id (b o untag e) o in1) o u) === u.
 Proof.
    intros X Y e u b H0 H1.
      apply (@swtoss _ _ rw); [decorate |edecorate| ].
      rewrite <- sw_downcast.
        transitivity(id o u). apply (@pswsubs _ _ _ rw); [| split; [exact H0| reflexivity]].
        apply (@sw_lcopair_eq _ _ _ rw); edecorate.
      rewrite idt. reflexivity.
 Qed.

(*try1*)
 Lemma TRY1: forall X Y (e: EName) (u: term unit X) (b: term Y unit), EPURE rw u -> PPG rw b ->
            downcast ((copair id (b o untag e) o in1) o ((empty Y o tag e) o u)) === b o u.
 Proof.
    intros X Y e u b H0 H1.
      apply (@swtoss _ _ rw); [decorate |edecorate| ].
      rewrite <- sw_downcast.
      do 2 setoid_rewrite assoc. setoid_rewrite <- assoc at 3.
      cut (in2 === in1 o (@empty Y)).
        intro H2. rewrite <- H2.
        rewrite ss_lcopair_eq; [| edecorate].
        apply (@pswsubs _ _ _ rw); [| split; [exact H0| reflexivity]].
        rewrite <- assoc. rewrite eax1, ids. reflexivity.
      setoid_rewrite ss_empty; [reflexivity| edecorate| edecorate].
 Qed.

(* -------------------- End of Main Proofs -------------------- *)

End Make.


(* Chap 12.1 The Type Hierarchy *)

Require Import Cpdt.CpdtTactics Cpdt.MoreSpecif.
Require Import Classical_Prop.
Require Import ProofIrrelevance.
Require Import Eqdep.
Require Eqdep_dec.
Require RelationalChoice.

Check 0.
Check nat.
Check Set.
Check Type.

Set Printing Universes.

Check nat.
Check Type.
Check forall T:Type, T.

Set Implicit Arguments.
Set Asymmetric Patterns.

Definition id (T:Set) (x:T) :T := x.

Check id 0.
Reset id.

Definition id (T:Type) (x:T) :T := x.
Check id Set.
Check id Type.
(* Check id id. *)

(* Chap 12.1.1 *)

Inductive exp : Type -> Type :=
| Const : forall T : Type, T -> exp T
| Pair : forall T1 T2, exp T1 -> exp T2 -> exp (T1*T2)
| Eq : forall T, exp T -> exp T -> exp bool.

Check Const 0.
Check Pair (Const 0) (Const tt).
Check Eq (Const Set) (Const Type).

Print exp.
Print Universes.
Print prod.

Check (nat, (Type, Set)).
Inductive prod': Type->Type->Type:=
| pair' : forall A B:Type, A->B->prod' A B.

(* Check (pair' nat (pair' Type Set)). *)

Inductive foo (A:Type) : Type:=
| Foo : A-> foo A.

Check foo nat.
Check foo Set.
Check foo (foo Set).

Inductive bar   : Type := Bar: bar.
Check bar.

Theorem symmetry : forall A B:Type, A=B -> B=A.
  intros; rewrite H; reflexivity. Qed.

Theorem illustrative_but_silly_detour : unit=unit.
  Set Printing All.
Abort.

Theorem illustrative_but_silly_detour':(unit:Type)=unit.
  apply symmetry; reflexivity. Qed.

Unset Printing All.

Theorem ex_symmetry : (exists x, x=0)->(exists x, 0=x).
  eexists. destruct H. Restart.
  destruct 1 as [x].
  eapply ex_intro. symmetry. eassumption. Qed.

(* 12.2 *)
Print sig.
Print ex.
Print exist.

Definition projS A (P:A->Prop) (x : sig P):A :=
match x with
| exist v _ => v
end.

(*
Definition projE A (P:A->Prop) (x:ex P) : A :=
  match x with
    | ex_intro v _ => v
  end.
 *)

Definition sym_sig (x:sig (fun n=>n =0)) : sig (fun n => 0=n) :=
  match x with
  | exist n pf => exist _ n (sym_eq pf)
  end.
Extraction sym_sig.

Definition sym_ex (x: ex (fun n=> n=0)) : ex (fun n=> 0 =n) :=
  match x with
  | ex_intro n pf => ex_intro _ n (sym_eq pf)
  end.

Extraction sym_ex.

Check forall P Q:Prop, P \/ Q -> Q \/ P.
Inductive expP:Type->Prop :=
| ConstP : forall T, T->expP T
| PairP: forall T1 T2, expP T1-> expP T2->expP (T1*T2)
| EqP : forall T, expP T->expP T ->expP bool.

Check ConstP 0.
Check (PairP (ConstP 0) (ConstP tt)).
Check (EqP (ConstP Set) (ConstP Type)).

Inductive eqPlus: forall T, T->T->Prop:=
| Base : forall T (x:T), eqPlus x x
| Func : forall dom ran (f1 f2:dom->ran),
    (forall x:dom, eqPlus (f1 x) (f2 x)) -> eqPlus f1 f2.

Check (Base 0).
Check (Func (fun n => n) (fun n=> 0+n) (fun n=> Base n)).
Check (Base (Base 1)).

(* 12.3 *)

Require Import Classical_Prop.
Print classic.

Parameter num : nat.
Axiom positive : num>0.
Reset num.

Axiom not_classic : ~ forall P:Prop, P \/ ~P.
Theorem uhoh : False.
  generalize classic not_classic; tauto. Qed.

Theorem uhoh_again : 1+1=3.
  destruct uhoh. Qed.

Reset not_classic.

Theorem t1 : forall P:Prop, P -> ~ ~ P.
  tauto. Qed.

Print Assumptions t1.
Theorem t2 : forall P:Prop, ~ ~ P ->P.
  tauto. Qed.

Print Assumptions t2.

Theorem nat_eq_dec : forall n m:nat, n=m \/ n<>m.
  induction n. destruct m. intuition.
  - right. unfold not; intros. inversion H.
  - destruct m.
    + right; unfold not; intros; inversion H.
    + destruct (IHn m).
      * rewrite H. left; reflexivity.
      * right; unfold not in *; intros; apply H.
        inversion H0. reflexivity. Qed.

Require Import ProofIrrelevance.

Print proof_irrelevance.
Require Import ZArith.

(*
Definition pred_strong1 (n:nat) : n>0 -> nat:=
  match n with
  | O=> fun pf: 0 > 0 => match Z.zgtz pf with end
  | S n' => fun _ => n'
  end.
 *)

Require Import Eqdep.
Import Eq_rect_eq.
Print Eq_rect_eq.

Corollary UIP_refl : forall A (x:A) (pf: x=x), pf=eq_refl x.
  intros; replace pf with (eq_rect x (eq x) (eq_refl x) x pf);
    [symmetry; apply eq_rect_eq
    | exact (match pf as pf' return match pf' in _ = y return x=y with
                                    | eq_refl => eq_refl x
                                    end = pf' with
             | eq_refl => eq_refl _
             end)]. Qed.

Corollary UIP : forall A (x y:A) (pf1 pf2:x=y), pf1=pf2.
  intros; generalize pf1 pf2;subst;intros;
    match goal with
    | [ |- ?pf1 = ?pf2] => rewrite (UIP_refl pf1); rewrite (UIP_refl pf2); reflexivity
    end. Qed.

Require Import FunctionalExtensionality.
Print functional_extensionality_dep.
Corollary predicate_extensionality : forall (A:Type) (B:A->Prop) (f g:forall x:A, B x),
    (forall x:A, f x=g x) -> f=g.
  intros. apply functional_extensionality_dep; assumption. Qed.

(* 12.3.2 Axiom of Choice *)
Reset Printing.

Require Import ConstructiveEpsilon.
Check constructive_definite_description.
Print Assumptions constructive_definite_description.

(* 唯一 *)
Require Import ClassicalUniqueChoice.
Check dependent_unique_choice.

(* 选择公理 *)
Require Import ClassicalChoice.
Check choice.

Definition choice_Set (A B:Type) (R:A->B->Prop) (H: forall x:A, {y:B|R x y}):{f:A->B| forall x:A, R x (f x)}:=
  exist (fun f => forall x:A, R x (f x)) (fun x=> proj1_sig (H x)) (fun x=> proj2_sig (H x)).

Check exist.
Check proj1_sig.
Check proj2_sig.

Check forall (A:Type) (P:A->Prop) (x:A), {x:A|P x}.

(* 12.3.3 Axioms and Computation *)
Definition cast (x y:Set) (pf: x=y) (v:x):y :=
  match pf with
  | eq_refl => v
  end.

Eval compute in (cast (eq_refl( nat->nat)) (fun n => S n)) 12.
Eval compute in (fun n => S n) 12.

(*
Theorem t3 :(forall n:nat, fin (S n))=(forall n:nat, fin (n+1)).
  change ((forall n:nat, (fun n=> fin (S n)) n)=(forall n:nat, (fun n=>fin (n+1)) n));
    erewrite (functional_extensionality (fun n=> fin (n+1))); crush. Qed.

Eval compute in (cast t3 (fun _ => First)) 12.
 *)

(* 12.3.4 *)


Require Import RelationClasses.

Definition option_map2 (A B:Type) (f2: A -> A -> B) (f1: A -> B) (f0:B) o1 o2 :=
match o1 with
  | None =>
    match o2 with
      | None => f0
      | Some a2 => (f1 a2)
    end
  | Some a1 =>
    match o2 with
      | None => (f1 a1)
      | Some a2 => (f2 a1 a2)
    end
end.

Implicit Arguments option_map2 [A B].

Definition option_map_eq (A:Type) (eq: A -> A -> Prop) o1 o2 :=
  option_map2 eq (fun _ => False) True o1 o2.

Implicit Arguments option_map_eq [A].

Theorem option_map_eq_refl : forall A Aeq (EQUIV: Equivalence Aeq) (o: option A),
  option_map_eq Aeq o o.
  Proof.
    intros.
    unfold option_map_eq in *; unfold option_map2 in *.
    destruct o; auto.
    apply reflexivity; auto.
  Qed.

Theorem option_map_eq_symmetric: forall A Aeq (EQUIV: Equivalence Aeq) (o1 o2: option A),
  option_map_eq Aeq o1 o2 ->   option_map_eq Aeq o2 o1.
  Proof.
    intros.
    unfold option_map_eq in *; unfold option_map2 in *.
    destruct o1; destruct o2; auto.
    apply symmetry; auto.
  Qed.

Theorem option_map_eq_transitive:  forall A Aeq (EQUIV: Equivalence Aeq) (o1 o2 o3: option A),
  option_map_eq Aeq o1 o2 -> option_map_eq Aeq o2 o3 -> option_map_eq Aeq o1 o3.
  Proof.
    intros.
    unfold option_map_eq in *; unfold option_map2 in *.
    destruct o1; destruct o2; destruct o3; auto.
    apply transitivity with a0; auto.
    contradiction.
  Qed.

Theorem option_map_eq_Equiv: forall A (eqA:A->A->Prop) (EqA: Equivalence eqA),
  Equivalence (option_map_eq eqA).
Proof.
  intros.
  eapply Build_Equivalence.
  unfold Reflexive; apply option_map_eq_refl; auto.
  unfold Symmetric; apply option_map_eq_symmetric; auto.
  unfold Transitive; apply option_map_eq_transitive; auto.
Qed.

Implicit Arguments option_map_eq_Equiv [A].

Theorem option_map_eq_dec: forall A (eqA: A->A->Prop)
  (Hdec: forall a1 a2, {eqA a1 a2} + {~ eqA a1 a2}),
  forall o1 o2, {option_map_eq eqA o1 o2} + {~ option_map_eq eqA o1 o2}.
Proof.
  intros.
  destruct o1 as [a1|]; destruct o2 as [a2|]; simpl; intuition.
Qed.

Implicit Arguments option_map_eq_dec [A eqA].

Definition option_map1 (A B:Type) (f1:A -> B) (f0:B) o :=
  match o with
    | None => f0
    | Some a => f1 a
  end.

Implicit Arguments option_map1 [A B].

Theorem option_map_is_option_map1 :
  forall (A B:Type) (a:option A) (f:A->B),
    option_map f a = option_map1 (fun a => Some (f a)) None a.
Proof.
  auto.
Qed.

(* we need a version of this that has op and op' *)

(* Definition option_map1_compat_op A B eqA eqB  *)
(*   (EqA: Equivalence eqA) (EqB:Equivalence eqB) (op: A -> B) : Prop :=  *)
(*   forall a a', eqA a a' -> eqB (op a) (op a'). *)

(* Implicit Arguments option_map1_compat_op [A B]. *)

(* Theorem option_map1_Equiv A B eqA eqB EqA EqB op  *)
(*   (compat_op: @option_map1_compat_op A B eqA eqB EqA EqB op): *)
(*   forall base, @option_map1_compat_op (option A) B (option_map_eq eqA) eqB  *)
(*     (option_map_eq_Equiv eqA EqA) EqB (option_map1 op base). *)
(* Proof. *)
(*   intros. *)
(*   unfold option_map1_compat_op in *. *)
(*   intros. *)
(*   unfold option_map1. *)
(*   destruct EqB. *)
(*   destruct a; destruct a'; auto; contradiction. *)
(* Qed.   *)

Definition option_map1_compat_op A B eqA eqB
  (EqA: Equivalence eqA) (EqB:Equivalence eqB) (op op': A -> B) : Prop :=
  forall a a', eqA a a' -> eqB (op a) (op' a').

Implicit Arguments option_map1_compat_op [A B].

Theorem option_map1_Equiv A B eqA eqB EqA EqB op op'
  (compat_op: @option_map1_compat_op A B eqA eqB EqA EqB op op'):
  forall base base', eqB base base' ->
    @option_map1_compat_op (option A) B (option_map_eq eqA) eqB
    (option_map_eq_Equiv eqA EqA) EqB (option_map1 op base) (option_map1 op' base').
Proof.
  intros.
  unfold option_map1_compat_op in *.
  intros.
  unfold option_map1.
  destruct EqB.
  destruct a; destruct a'; auto; contradiction.
Qed.

Implicit Arguments option_map1_Equiv [A B].


Require Export ProjectiveGeometry.Dev.general_tactics.

(*****************************************************************************)
(** Fano plane **)

Module Type fano_plane.

Parameter Point:Set.
Parameter A B C D E F G : Point.

Parameter Line: Set.
Parameter ABF BCD CAE ADG  BEG  CFG  DEF : Line.

Parameter Incid : Point -> Line -> Prop.

Axiom is_only_7_pts : forall P:Point, {P=A}+{P=B}+{P=C}+{P=D}+{P=E}+{P=F}+{P=G}.

Axiom is_only_7_lines : forall P:Line, {P=ABF}+{P=BCD}+{P=CAE}+{P=ADG}+{P=BEG}+{P=CFG}+{P=DEF}.

Definition is_fano_plane A B C D E F G ABF BCD CAE ADG BEG CFG DEF :=
(~A=B /\ ~A=C /\ ~A=D /\ ~A=E /\ ~A=F /\ ~A=G /\
~B=C /\ ~B=D /\ ~B=E /\ ~B=F /\ ~B=G /\
~C=D /\ ~C=E /\ ~C=F /\ ~C=G /\
~D=E /\ ~D=F /\ ~D=G /\
~E=F /\ ~E=G /\
~F=G) /\
(ABF<>BCD /\ ABF <>CAE /\ ABF <>ADG /\ ABF<>BEG /\ ABF<>CFG /\ ABF<>DEF /\
BCD<>CAE /\ BCD<>ADG /\ BCD<>BEG /\ BCD<>CFG /\ BCD<>DEF /\
CAE<>ADG /\ CAE<>BEG /\ CAE<>CFG /\ CAE<>DEF /\
ADG<>BEG /\ ADG<>CFG /\ADG<>DEF /\
BEG<>CFG /\ BEG<>DEF /\
CFG<>DEF )/\

( Incid A ABF /\ Incid B ABF /\ ~ Incid C ABF /\ ~ Incid D ABF /\ ~ Incid E ABF /\ Incid F ABF /\ ~ Incid G  ABF /\
 ~ Incid A BCD /\ Incid B BCD /\ Incid C BCD /\ Incid D BCD /\ ~ Incid E BCD /\ ~ Incid F BCD /\ ~ Incid G  BCD /\
 Incid A CAE /\ ~ Incid B CAE /\ Incid C CAE /\ ~ Incid D CAE /\ Incid E CAE /\ ~ Incid F CAE /\ ~ Incid G  CAE /\
 Incid A ADG /\ ~ Incid B ADG /\ ~ Incid C ADG /\ Incid D ADG /\ ~ Incid E ADG /\ ~ Incid F ADG /\ Incid G  ADG /\
 ~ Incid A BEG /\ Incid B BEG /\ ~ Incid C BEG /\ ~ Incid D BEG /\  Incid E BEG /\ ~ Incid F BEG /\ Incid G  BEG /\
 ~ Incid A CFG /\ ~ Incid B CFG /\ Incid C CFG /\ ~ Incid D CFG /\ ~ Incid E CFG /\ Incid F CFG /\ Incid G  CFG /\
 ~ Incid A DEF /\ ~ Incid B DEF /\ ~ Incid C DEF /\ Incid D DEF /\ Incid E DEF /\ Incid F DEF /\ ~ Incid G  DEF).

Axiom is_fano_plane_inst :  is_fano_plane A B C D E F G ABF BCD CAE ADG BEG CFG DEF.

End fano_plane.

(*****************************************************************************)
(** Fano plane swap **)

Module swapf3 (M:fano_plane) : fano_plane
with Definition Point:=M.Point

with Definition A:= M.B
with Definition B:=M.E
with Definition C:=M.D
with Definition D:=M.F
with Definition E:=M.C
with Definition F:=M.G
with Definition G:=M.A

with Definition Line:=M.Line

with Definition ABF:=M.BEG
with Definition BCD:=M.DEF
with Definition CAE:=M.BCD
with Definition ADG:=M.ABF
with Definition BEG:=M.CAE
with Definition CFG:=M.ADG
with Definition DEF:=M.CFG

with Definition Incid :=M.Incid

with Definition is_fano_plane := M.is_fano_plane.

Definition Point:=M.Point.

Definition A:=M.B.
Definition B:=M.E.
Definition C:=M.D.
Definition D:=M.F.
Definition E:=M.C.
Definition F:=M.G.
Definition G:=M.A.

Definition Line:=M.Line.

Definition ABF:=M.BEG.
Definition BCD:=M.DEF.
Definition CAE:=M.BCD.
Definition ADG:=M.ABF.
Definition BEG:=M.CAE.
Definition CFG:=M.ADG.
Definition DEF:=M.CFG.

Definition Incid :=M.Incid.

Definition is_fano_plane := M.is_fano_plane.

Lemma is_only_7_pts : forall P:Point, {P=A}+{P=B}+{P=C}+{P=D}+{P=E}+{P=F}+{P=G}.
Proof.
generalize (M.is_only_7_pts).
unfold A, B,C, D, E, F, G.
intros H P; elim (H P).
intuition.
intuition.
Qed.

Lemma is_only_7_lines : forall P:Line, {P=ABF}+{P=BCD}+{P=CAE}+{P=ADG}+{P=BEG}+{P=CFG}+{P=DEF}.
Proof.
generalize (M.is_only_7_lines).
unfold ABF, BCD, CAE, ADG, BEG, CFG, DEF .
intros H P;
generalize (H P); intuition.
Qed.

Lemma is_fano_plane_inst : is_fano_plane A B C D E F G ABF BCD CAE ADG BEG CFG DEF.
Proof.
generalize (M.is_fano_plane_inst).
unfold is_fano_plane, M.is_fano_plane.
intros H; decompose [and] H; clear H.
unfold A, B, C, D, E, F, G, ABF, BCD, CAE, ADG, BEG, CFG, DEF .
repeat split;try  assumption;try auto.
Qed.

End swapf3.

Module Desargues_from_A (M:fano_plane).

Import M.

Definition on_line := fun A B C l => M.Incid A l /\ Incid B l /\ Incid C l.
Definition collinear A B C :=  exists l, Incid A l /\ Incid B l /\ Incid C l.

Ltac use H := decompose [and ex] H; clear H.

Ltac solve_ex L := solve [exists L;auto].

(** A tactic which tries all possible lines **)

Ltac solve_ex_l := first [solve_ex ABF
     |  solve_ex BCD
     |  solve_ex CAE
     |  solve_ex ADG
     |  solve_ex BEG
     |  solve_ex CFG
     |  solve_ex DEF
 ].

Ltac solve_ex_p := first [
        solve_ex A
     |  solve_ex B
     |  solve_ex C
     |  solve_ex D
     |  solve_ex E
     |  solve_ex F
     |  solve_ex G
 ].

Ltac new_case P :=
match (type of P) with
| Point => generalize (is_only_7_pts P) ; let Q := fresh in (intros Q; decompose [sumor sumbool] Q; clear Q; subst)
| Line => generalize (is_only_7_lines P) ; let Q := fresh in (intros Q; decompose [sumor sumbool] Q; clear Q; subst)
end.

Lemma col_degen_1 : forall P R, ~ collinear P P R -> False.
Proof.
intros.
apply H.
unfold collinear in *.
generalize (is_fano_plane_inst); unfold is_fano_plane in *;
intro Hw ;use Hw;new_case P; new_case R;solve_ex_l.
Qed.

Lemma col_degen_2 : forall P R,
~ collinear P R P -> False.
Proof.
intros.
apply H.
unfold collinear.
generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw;
new_case P;new_case R;solve_ex_l.
Qed.

Lemma col_degen_3 : forall P R,
~ collinear R P P -> False.
Proof.
intros.
apply H.
unfold collinear.
generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw;
new_case P;new_case R;solve_ex_l.
Qed.

Lemma not_all_equal : forall P Q R : Point, ~(~P=P \/ ~Q=Q \/ ~R=R).
Proof.
intros P Q R H; intuition.
Qed.

Ltac degens :=
match goal with
| H: ~?A=?A \/ ~?B=?B \/ ~?C=?C |- _ => elim (not_all_equal A B C H)
| H:~collinear ?P ?P ?R |- _ => elim (col_degen_1 P R H)
| H:~collinear ?P ?R ?P |- _ => elim (col_degen_2 P R H)
| H:~collinear ?R ?P ?P |- _ => elim (col_degen_3 P R H)
| H:Incid ?P ?l, H2: ~ Incid ?P ?l |- _ => cut False; [let hf := fresh in (intro hf;elim hf)| apply (H2 H)]
end.

Ltac case_eq_s  O := new_case O.

Ltac case_clear P := case_eq_s P; try solve [degens].

Ltac fano_ctx := generalize (is_fano_plane_inst); unfold is_fano_plane in *; let Hw := fresh in (intro Hw ;use Hw).

Lemma collinearPPQ : forall P Q: Point, collinear P P Q.
Proof.
intros P; generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw; new_case P; intros Q; new_case Q; unfold collinear in *;
solve_ex_l.
Qed.

Lemma collinearPQQ : forall P Q: Point, collinear P Q Q.
Proof.
intros P; generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw; new_case P; intros Q; new_case Q; unfold collinear in *;
solve_ex_l.
Qed.

Lemma collinearPQP : forall P Q: Point, collinear P Q P.
Proof.
intros P; generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw;new_case P; intros Q; new_case Q; unfold collinear in *;
solve_ex_l.
Qed.

Ltac cols :=  apply collinearPPQ ||
                    apply  collinearPQQ ||
                    apply collinearPQP ||
                    (unfold collinear;solve_ex_l).

Ltac collinear_line :=
match goal with
H : ~collinear ?P ?Q ?R |- _ =>
  solve[assert (collinear P Q R) by (solve_ex_l);
cut False; [intros Hf; elim Hf | auto]]
end.

Ltac collinear_line_gen ABF BCD CAE ADG  BEG CFG DEF :=
match goal with
H : ~collinear ?P ?Q ?R |- _ =>
  solve [assert (collinear P Q R) by (solve_ex_l);
cut False; [intros Hf; elim Hf | auto]]
end.

Lemma Desargues_from_A_spec :  forall P Q R P' Q' R' alpha beta gamma lPQ lPR lQR lP'Q' lP'R' lQ'R',
((on_line P Q gamma lPQ) /\ (on_line P' Q' gamma lP'Q')) /\
((on_line P R beta lPR) /\ (on_line P' R' beta lP'R')) /\
((on_line Q R alpha lQR) /\ (on_line Q' R' alpha lQ'R')) /\
((on_line A P P' ADG) /\ (on_line A Q Q' CAE) /\(on_line A R R' ABF)) /\
~collinear A P Q /\  ~collinear A P R /\ ~collinear A Q R /\
~collinear P Q R /\ ~collinear P' Q' R' /\ ((~P=P')\/(~Q=Q')\/(~R=R')) ->
collinear alpha beta gamma.
Proof.

intros P Q R P' Q' R' alpha beta gamma lPQ lPR lQR lP'Q' lP'R' lQ'R'.
intros.
unfold on_line in  *;use H.
generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw.

case_clear P;
case_clear Q;
case_clear R;

try collinear_line;
case_clear P';
case_clear Q';
case_clear R';
try collinear_line;
case_clear lPQ;
case_clear lP'Q';
case_clear lPR;
case_clear lP'R';
case_clear lQR;
case_clear lQ'R';
case_clear alpha;
case_clear beta;
try cols;
case_clear gamma;
try cols.
Qed.

Lemma col_1 : forall A B C,
 collinear A B C -> collinear B A C.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Lemma col_2 : forall A B C,
 collinear A B C -> collinear A C B.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Lemma col_3 : forall A B C,
 collinear A B C -> collinear B C A.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Lemma col_4 : forall A B C,
 collinear A B C -> collinear C A B.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Lemma col_5 : forall A B C,
 collinear A B C -> collinear C B A.
Proof.
intros.
unfold collinear in *.
decompose [ex and] H; clear H.
exists x.
intuition.
Qed.

Hint Resolve col_1 col_2 col_3 col_4 col_5 : Geom.

Lemma Desargues_from_A :  forall P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R',
((on_line P Q gamma lPQ) /\ (on_line P' Q' gamma lP'Q')) /\
((on_line P R beta lPR) /\ (on_line P' R' beta lP'R')) /\
((on_line Q R alpha lQR) /\ (on_line Q' R' alpha lQ'R')) /\
((on_line A P P' lP) /\ (on_line A Q Q' lQ) /\(on_line A R R' lR)) /\
~collinear A P Q /\  ~collinear A P R /\ ~collinear A Q R /\
~collinear P Q R /\ ~collinear P' Q' R' /\ ((~P=P')\/(~Q=Q')\/(~R=R')) ->
collinear alpha beta gamma.
Proof.
intros P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R'.
intros.
unfold on_line in  *;use H.
generalize (is_fano_plane_inst); unfold is_fano_plane in *; intro Hw ;use Hw.
case_clear lP;
case_clear lQ;
case_clear lR;
try collinear_line.

cut (collinear gamma beta alpha).
auto with Geom.
apply (Desargues_from_A_spec R Q P R' Q' P' gamma beta alpha
  lQR lPR lPQ lQ'R' lP'R' lP'Q').
repeat split; auto with Geom;
decompose [or] H33;auto.

cut (collinear beta gamma alpha).
auto with Geom.
eapply (Desargues_from_A_spec Q R P Q' R' P' beta gamma alpha
lQR lPQ lPR lQ'R' lP'Q' lP'R').
repeat split; auto with Geom;
decompose [or] H33;auto.

cut (collinear gamma alpha beta).
auto with Geom.
eapply (Desargues_from_A_spec R P Q R' P' Q' gamma alpha beta
 lPR lQR lPQ lP'R' lQ'R' lP'Q');
repeat split; auto with Geom;
decompose [or] H33;auto.

cut (collinear beta alpha gamma).
auto with Geom.
eapply (Desargues_from_A_spec Q P R Q' P' R' beta alpha gamma
 lPQ lQR lPR lP'Q' lQ'R' lP'R');
repeat split; auto with Geom;
decompose [or] H33;auto.

cut (collinear alpha gamma beta).
auto with Geom.
eapply (Desargues_from_A_spec P R Q P' R' Q' alpha gamma beta
lPR lPQ lQR lP'R' lP'Q' lQ'R');
repeat split; auto with Geom;
decompose [or] H33;auto.

apply (Desargues_from_A_spec P Q R P' Q' R' alpha beta gamma lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split; auto with Geom.
Qed.

End Desargues_from_A.

Module Desargues (M:fano_plane).

Import M.

Module Import M2:= Desargues_from_A M.

Module swaped_B := swapf3 M.
Module swaped_B' := Desargues_from_A swaped_B.
Module swaped_E := swapf3 swaped_B.
Module swaped_E' := Desargues_from_A swaped_E.
Module swaped_C := swapf3 swaped_E.
Module swaped_C' := Desargues_from_A swaped_C.
Module swaped_D := swapf3 swaped_C.
Module swaped_D' := Desargues_from_A swaped_D.
Module swaped_F := swapf3 swaped_D.
Module swaped_F' := Desargues_from_A swaped_F.
Module swaped_G := swapf3 swaped_F.
Module swaped_G' := Desargues_from_A swaped_G.

Theorem Desargues :
 forall O P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R',
((on_line P Q gamma lPQ) /\ (on_line P' Q' gamma lP'Q')) /\
((on_line P R beta lPR) /\ (on_line P' R' beta lP'R')) /\
((on_line Q R alpha lQR) /\ (on_line Q' R' alpha lQ'R')) /\
((on_line O P P' lP) /\ (on_line O Q Q' lQ) /\(on_line O R R' lR)) /\
~collinear O P Q /\  ~collinear O P R /\ ~collinear O Q R /\
~collinear P Q R /\ ~collinear P' Q' R' /\ ((~P=P')\/(~Q=Q')\/(~R=R')) ->
collinear alpha beta gamma.
Proof.
intros.
unfold on_line in *.
use H.
new_case O.

apply (Desargues_from_A  P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R');repeat split;eauto.

assert (T:=swaped_B'.Desargues_from_A).
unfold swaped_B'.on_line, swaped_B'.collinear,  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_C'.Desargues_from_A).
unfold swaped_C'.on_line, swaped_C'.collinear,  swaped_C.A, swaped_C.Incid, swaped_C.Line, swaped_C.Point in *.
unfold swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_D'.Desargues_from_A).
unfold swaped_D'.on_line, swaped_D'.collinear,  swaped_D.A, swaped_D.Incid, swaped_D.Line, swaped_D.Point in *.
unfold swaped_C.A, swaped_C.Incid, swaped_C.Line, swaped_C.Point in *.
unfold swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_E'.Desargues_from_A).
unfold swaped_E'.on_line, swaped_E'.collinear,  swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold   swaped_B.B, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_F'.Desargues_from_A).
unfold swaped_F'.on_line, swaped_F'.collinear,  swaped_F.A, swaped_F.Incid, swaped_F.Line, swaped_F.Point in *.
unfold swaped_D.A, swaped_D.Incid, swaped_D.Line, swaped_D.Point in *.
unfold swaped_C.A, swaped_C.Incid, swaped_C.Line, swaped_C.Point in *.
unfold swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.

assert (T:=swaped_G'.Desargues_from_A).
unfold swaped_G'.on_line, swaped_G'.collinear in *.
unfold  swaped_G.A, swaped_G.Incid, swaped_G.Line, swaped_G.Point in *.
unfold swaped_F'.on_line, swaped_F'.collinear,  swaped_F.A, swaped_F.Incid, swaped_F.Line, swaped_F.Point in *.
unfold swaped_D.A, swaped_D.Incid, swaped_D.Line, swaped_D.Point in *.
unfold swaped_C.A, swaped_C.Incid, swaped_C.Line, swaped_C.Point in *.
unfold swaped_E.A, swaped_E.Incid, swaped_E.Line, swaped_E.Point in *.
unfold  swaped_B.A, swaped_B.Incid, swaped_B.Line, swaped_B.Point in *.
eapply (T P Q R P' Q' R' alpha beta gamma lP lQ lR lPQ lPR lQR lP'Q' lP'R' lQ'R').
repeat split;auto.
Qed.

End Desargues.


Require Import Setoid.
Require Import Coq.Lists.List.
Require Import Bool.
Require Import Coq.Program.Equality.
Import ListNotations.
Import PeanoNat.Nat.

Require Import Lib.Deduplicated.
Require Import Lib.Sorted.
Require Import Lib.EqDec.
Require Import Lib.LinearOrder.

Inductive BTree (A: Type) : Type :=
| leaf : BTree A
| node : A -> BTree A -> BTree A -> BTree A.

Arguments leaf {A}.
Arguments node {A} _ _ _.

Definition treeComp {A: Type} `{LinearOrder A} (x: A) (t: BTree A) : option comparison :=
match t with
| leaf => None
| node y _ _ =>  Some (comp x y)
end.

Fixpoint add_tree {A: Type} `{LinearOrder A} (x: A) (t : BTree A) : BTree A :=
match t with
| leaf => node x leaf leaf
| node v l r => match comp x v with
                | Lt => node v (add_tree x l) r
                | Eq => node v l r
                | Gt => node v l (add_tree x r)
                end
end.

Fixpoint to_tree {A: Type} `{LinearOrder A} (l : list A) : BTree A :=
  match l with
  | []      => leaf
  | (x::l') => add_tree x (to_tree l')
  end.

Fixpoint to_list {A: Type} (l : BTree A) : list A :=
  match l with
  | leaf       => []
  | node x l r => to_list l ++ [x] ++ to_list r
  end.

Fixpoint TCount {A: Type}(p: A -> bool)(t: BTree A) : nat :=
  match t with
  | leaf => 0
  | node x l r => if (p x) then S (TCount p l + TCount p r) else TCount p l + TCount p r
  end.

Fixpoint TAny {A: Type}(p: A -> bool)(t: BTree A) : bool :=
  match t with
  | leaf => false
  | node x l r => p x || TAny p l || TAny p r
  end.

Definition BTreeListPermutation {A: Type} (t: BTree A) (l: list A) : Prop :=
  forall p: A->bool, TCount p t = count p l.

Definition BTreePermutation {A: Type} (t1 t2: BTree A) : Prop :=
  forall p: A->bool, TCount p t1 = TCount p t2.

Definition BTreeElem_eq (A: Type) (l l' : BTree A) : Prop :=
  forall p : A -> bool, TAny p l = TAny p l'.

Definition BTreeListElem_eq {A: Type} (t: BTree A) (l: list A) : Prop :=
  forall p : A -> bool, TAny p t = any p l.

Definition dedupSort {A: Type} `{LinearOrder A} (l : list A) : list A :=
  to_list (to_tree l).

Lemma to_list_perm {A: Type} (t: BTree A) : BTreeListPermutation t (to_list t).
Proof.
  intros p. induction t; [auto|].
  cbn. rewrite count_list_concat. cbn. destruct (p a).
  - rewrite plus_n_Sm, IHt1, IHt2. reflexivity.
  - rewrite IHt1, IHt2. reflexivity.
Qed.

Lemma same_count_TCount {A: Type} (t: BTree A) : forall p: A-> bool,
  TCount p t = count p (to_list t).
Proof.
  apply to_list_perm.
Qed.

Fixpoint TIn {A: Type} (x: A) (t: BTree A) : Prop :=
match t with
| leaf => False
| node v l r => v = x \/ TIn x l \/ TIn x r
end.

Inductive NormalTree {A: Type} `{LinearOrder A} : BTree A -> Prop :=
| NormLeaf : NormalTree leaf
| NormNode : forall (x: A) (l r: BTree A), NormalTree l -> NormalTree r ->
  (forall y: A, TIn y l -> comp y x = Lt) -> (forall y: A, TIn y r -> comp y x = Gt) ->
  NormalTree (node x l r).

Definition TDeduplicated {A: Type} `{EqDec A} (t: BTree A) : Prop :=
  forall x : A, TIn x t -> TCount (eqf x) t = 1.

Lemma in_to_list {A: Type} (x: A) (t: BTree A) :
  In x (to_list t) <-> TIn x t.
Proof.
  split.
  - induction t; [auto | cbn].
    intro H. rewrite in_app_iff in H. cbn in *. destruct H as [H | [H | H]].
    + right. left. apply IHt1. assumption.
    + left. assumption.
    + right. right. apply IHt2. assumption.
  - induction t; [auto | cbn].
    intro H. rewrite in_app_iff. cbn. destruct H as [H | [H | H]].
    + right. left. assumption.
    + left. apply IHt1. assumption.
    + right. right. apply IHt2. assumption.
Qed.

Lemma add_dont_remove {A: Type} `{LinearOrder A} (t : BTree A) (v: A):
  TIn v t -> forall n: A, TIn v (add_tree n t).
Proof.
  intros I n. induction t; cbn in *; [destruct I|].
  destruct (comp n a) eqn:c.
  - apply I.
  - cbn. destruct I as [e|[l | r]]; subst; auto.
  - cbn. destruct I as [e|[l | r]]; subst; auto.
Qed.

Lemma TIn_add {A: Type} `{LinearOrder A} (n: A) (t : BTree A) (v: A) :
  TIn v (add_tree n t) <-> n = v \/ TIn v t.
Proof.
  split.
  - intros I. induction t.
    + left. cbn in *. destruct I as [I | [I | I]]; [auto | destruct I | destruct I].
    + cbn in *. destruct (comp n a) eqn:c.
      * rewrite comp_eq in c; subst. cbn in *. destruct I as [e|[l|r]]; subst; auto.
      * cbn in *. destruct I as [e|[l|r]]; subst; auto. destruct (IHt1 l); auto.
      * cbn in *. destruct I as [e|[l|r]]; subst; auto. destruct  (IHt2 r); auto.
  - intros [e | I].
    + subst. induction t; cbn; [auto |].
      destruct (comp v a) eqn:c; cbn; [| auto | auto]. left. symmetry.
      now apply comp_eq.
    + apply add_dont_remove. assumption.
Qed.

Theorem add_preserves_normal {A: Type} `{LinearOrder A} (n: A) (t : BTree A) :
  NormalTree t -> NormalTree (add_tree n t).
Proof.
  intro N. induction N.
  - cbn. constructor; [constructor| constructor| |]; intros y I; cbn in *; try inversion I.
  - cbn in *. destruct (comp n x) eqn:c.
    + constructor; assumption.
    + constructor; auto. intros y I. rewrite TIn_add in I. destruct I; subst; auto.
    + constructor; auto. intros y I. rewrite TIn_add in I. destruct I; subst; auto.
Qed.

Lemma TCount_for_not_satisfied_pred {A: Type} (t : BTree A) (p: A -> bool):
  (forall x:A, TIn x t -> p x = false) -> TCount p t = 0.
Proof.
  intros N. induction t; [auto|].
  cbn in *. rewrite (N a); auto. rewrite IHt1, IHt2; auto.
Qed.

(* Deduplicated *)
Theorem normal_is_deduplicated {A: Type} `{LinearOrder A} (t: BTree A) :
  NormalTree t -> TDeduplicated t.
Proof.
  intro N. induction N; intros y I; cbn in I; [destruct I|].
  destruct I as [e|[I|I]].
  - subst. cbn [TCount]. rewrite eqf_refl, TCount_for_not_satisfied_pred, TCount_for_not_satisfied_pred; auto.
    + intros x I. specialize (H1 x I). rewrite <-eqf_comp_not_eq, comp_inv_iff. cbn. rewrite H1. intros [=].
    + intros x I. specialize (H0 x I). rewrite <-eqf_comp_not_eq, comp_inv_iff. cbn. rewrite H0. intros [=].
  - destruct (comp y x) eqn:c.
    + specialize (H0 y I). rewrite H0 in c. inversion c.
    + cbn [TCount]. rewrite eqf_lt, IHN1, TCount_for_not_satisfied_pred; auto.
      intros z I'. rewrite <-eqf_comp_not_eq, comp_eq. specialize (H1 z I'). intros c'.
      subst. rewrite c in H1. discriminate.
    + cbn [TCount]. rewrite eqf_lt, IHN1, TCount_for_not_satisfied_pred; auto.
      intros z I'. rewrite <-eqf_comp_not_eq, comp_eq. specialize (H1 z I'). specialize (H0 y I).
      intros e. subst. rewrite H1 in H0. discriminate.
  - destruct (comp y x) eqn:c.
    + specialize (H1 y I). rewrite H1 in c. inversion c.
    + cbn [TCount]. rewrite eqf_lt, IHN2, TCount_for_not_satisfied_pred; auto.
      intros z I'. rewrite <-eqf_comp_not_eq, comp_eq. intro e; subst. specialize (H0 z I').
      specialize (H1 z I). rewrite H0 in H1. discriminate.
    + cbn [TCount]. rewrite eqf_gt, IHN2, TCount_for_not_satisfied_pred; auto.
      intros z I'. rewrite <-eqf_comp_not_eq, comp_eq. intro e; subst. specialize (H0 z I').
      rewrite c in H0. discriminate.
Qed.

Theorem to_tree_normal {A: Type} `{LinearOrder A} (l: list A) : NormalTree (to_tree l).
Proof.
  induction l; [constructor|]. cbn. apply add_preserves_normal. assumption.
Qed.

Theorem to_tree_dedup {A: Type} `{LinearOrder A} (l: list A) : TDeduplicated (to_tree l).
Proof.
  apply normal_is_deduplicated. apply to_tree_normal.
Qed.

Theorem dedup_dedupSort {A: Type} `{LinearOrder A} (l : list A) : Deduplicated (dedupSort l).
Proof.
  rewrite dup_def_eq. unfold dedupSort, CountDeduplicated. intros x I. rewrite <- same_count_TCount.
  rewrite in_to_list in I. apply to_tree_dedup. assumption.
Qed.

(* Sorted *)
Theorem normal_to_list_sorted {A: Type} `{LinearOrder A} (t: BTree A) : NormalTree t -> Sorted (to_list t).
Proof.
  intros N. induction N; cbn; [constructor|].
  apply concat_sorted; auto.
    + apply head_in_sorted; [auto|]. intros z I. apply comp_gt. apply H1. apply in_to_list. auto.
    + intros z I. apply comp_lt. apply H0. apply in_to_list. auto.
Qed.

Theorem sorted_dedupSort {A: Type} `{LinearOrder A} (l : list A) : Sorted (dedupSort l).
Proof.
  apply normal_to_list_sorted. apply to_tree_normal.
Qed.

(* Preserves elems *)
Lemma to_list_any {A: Type} (t: BTree A) : BTreeListElem_eq t (to_list t).
Proof.
  intros p. induction t; [auto|].
  cbn. rewrite any_concat. cbn. destruct (p a); cbn; auto.
  - rewrite orb_comm. auto.
  - rewrite IHt1, IHt2. reflexivity.
Qed.

Lemma add_tree_any {A: Type} `{LinearOrder A} (x: A) (t: BTree A) (p: A -> bool):
  TAny p (add_tree x t) = (if p x then true else TAny p t).
Proof.
  induction t; cbn; [destruct (p x); auto|].
  destruct (comp x a) eqn:e; cbn.
  - rewrite comp_eq in e. subst. destruct (p a) eqn:p_a; auto.
  - rewrite IHt1. destruct (p a); destruct (p x); auto.
  - rewrite IHt2. destruct (p a); destruct (p x); auto. rewrite orb_false_l, orb_comm. auto.
Qed.

Lemma to_tree_any {A: Type} `{LinearOrder A} (l: list A) : BTreeListElem_eq (to_tree l) l.
Proof.
  intros p. induction l; cbn; [auto|].
  rewrite add_tree_any, IHl. auto.
Qed.

Theorem same_elements_dedupSort {A: Type} `{LinearOrder A} (l : list A) :
  Elem_eq l (dedupSort l).
Proof.
  unfold dedupSort. intros p. rewrite <-to_list_any. symmetry. apply to_tree_any.
Qed.