Require Import init.

Require Export nat_base.
Require Import nat_plus.
Require Import nat_mult.
Require Export nat_order.

Definition simple_finite U := ∃ n (f : U → nat_to_set_type n), Injective f.

Theorem simple_finite_trans : ∀ U V,
    simple_finite V → (∃ f : U → V, Injective f) → simple_finite U.
Proof.
    intros U V [n [g g_inj]] [f f_inj].
    exists n, (λ x, g (f x)).
    apply inj_comp; assumption.
Qed.

Theorem simple_finite_nat : ∀ n, simple_finite (set_type (initial_segment n)).
Proof.
    intros n.
    exists n.
    exists identity.
    apply identity_bijective.
Qed.

Theorem simple_finite_sum : ∀ U V,
    simple_finite U → simple_finite V → simple_finite (U + V).
Proof.
    intros U V [m [f f_inj]] [n [g g_inj]].
    exists (m + n).
    assert (∀ x, initial_segment (m + n) [f x|]) as f_in.
    {
        intros x.
        pose proof [|f x] as ltq.
        unfold initial_segment in *.
        apply (lt_le_trans ltq).
        apply nat_le_self_rplus.
    }
    assert (∀ x, initial_segment (m + n) (m + [g x|])) as g_in.
    {
        intros x.
        pose proof [|g x] as ltq.
        unfold initial_segment in *.
        apply lt_lplus.
        exact ltq.
    }
    exists (λ x, match x with
                 | inl a => [_|f_in a]
                 | inr b => [_|g_in b]
                 end).
    split.
    intros [a|a] [b|b] eq; setoid_rewrite set_type_eq2 in eq.
    -   rewrite set_type_eq in eq.
        apply inj in eq.
        subst b.
        reflexivity.
    -   pose proof [|f a] as ltq.
        unfold initial_segment in ltq.
        rewrite eq in ltq.
        apply (le_lt_trans (nat_le_self_rplus _ _)) in ltq.
        contradiction (irrefl _ ltq).
    -   pose proof [|f b] as ltq.
        unfold initial_segment in ltq.
        rewrite <- eq in ltq.
        apply (le_lt_trans (nat_le_self_rplus _ _)) in ltq.
        contradiction (irrefl _ ltq).
    -   apply plus_lcancel in eq.
        rewrite set_type_eq in eq.
        apply inj in eq.
        subst b.
        reflexivity.
Qed.

Theorem simple_finite_prod : ∀ U V,
    simple_finite U → simple_finite V → simple_finite (U * V).
Proof.
    intros U V [m [f f_inj]] [n [g g_inj]].
    exists (m * n).
    assert (∀ a b, initial_segment (m * n) (n * [f a|] + [g b|])) as fg_in.
    {
        intros a b.
        pose proof [|f a] as a_lt.
        pose proof [|g b] as b_lt.
        unfold initial_segment in *.
        rewrite <- nat_le_suc_lt in a_lt.
        apply (nat_le_lmult n) in a_lt.
        rewrite nat_mult_rsuc in a_lt.
        apply (lt_rplus (n * [f a|])) in b_lt.
        pose proof (lt_le_trans b_lt a_lt) as ltq.
        rewrite plus_comm in ltq.
        rewrite (mult_comm n m) in ltq.
        exact ltq.
    }
    exists (λ x, [_|fg_in (fst x) (snd x)]).
    split.
    intros [a1 a2] [b1 b2]; cbn.
    intros eq.
    setoid_rewrite set_type_eq2 in eq.
    pose proof [|g a2] as a2_lt.
    pose proof [|g b2] as b2_lt.
    unfold initial_segment in *.
    destruct (trichotomy [f a1|] [f b1|]) as [[ltq|eq2]|ltq].
    -   apply nat_lt_ex in ltq as [c c_eq].
        rewrite <- c_eq in eq.
        rewrite ldist in eq.
        rewrite <- plus_assoc in eq.
        apply plus_lcancel in eq.
        rewrite eq in a2_lt.
        apply (le_lt_trans (nat_le_self_rplus _ _)) in a2_lt.
        rewrite nat_mult_rsuc in a2_lt.
        apply (le_lt_trans (nat_le_self_rplus _ _)) in a2_lt.
        contradiction (irrefl _ a2_lt).
    -   rewrite set_type_eq in eq2.
        apply inj in eq2.
        subst b1.
        apply plus_lcancel in eq.
        rewrite set_type_eq in eq.
        apply inj in eq.
        subst b2.
        reflexivity.
    -   apply nat_lt_ex in ltq as [c c_eq].
        rewrite <- c_eq in eq.
        rewrite ldist in eq.
        rewrite <- plus_assoc in eq.
        apply plus_lcancel in eq.
        rewrite <- eq in b2_lt.
        apply (le_lt_trans (nat_le_self_rplus _ _)) in b2_lt.
        rewrite nat_mult_rsuc in b2_lt.
        apply (le_lt_trans (nat_le_self_rplus _ _)) in b2_lt.
        contradiction (irrefl _ b2_lt).
Qed.

Lemma simple_finite_in {U} : ∀ {n} {f : U → nat_to_set_type (nat_suc n)},
    ¬(∃ a, [f a|] = n) → ∀ x, initial_segment n [f x|].
Proof.
    intros n f a_nex x.
    split.
    -   rewrite <- nat_lt_suc_le.
        exact [|f x].
    -   intros eq.
        apply a_nex.
        exists x.
        exact eq.
Qed.

Theorem simple_finite_bij : ∀ U, simple_finite U →
    ∃ n (f : U → nat_to_set_type n), Bijective f.
Proof.
    intros U [n [f f_inj]].
    revert U f f_inj.
    nat_induction n; intros.
    {
        exists 0, f.
        split; [>exact f_inj|].
        split.
        intros n.
        contradiction (nat_lt_0_false n).
    }
    classic_case (∃ a, [f a|] = n) as [[a a_eq]|a_nex].
    -   pose (V := set_type (λ x, x ≠ a)).
        assert (∀ x : V, initial_segment n [f [x|]|]) as f_in.
        {
            intros x.
            split.
            -   rewrite <- nat_lt_suc_le.
                exact [|f [x|]].
            -   intros eq.
                destruct x as [x x_neq].
                cbn in eq.
                rewrite <- a_eq in eq.
                rewrite set_type_eq in eq.
                apply inj in eq.
                contradiction.
        }
        specialize (IHn _ (λ x, [_|f_in x])).
        prove_parts IHn.
        {
            split.
            intros x y.
            setoid_rewrite set_type_eq2.
            rewrite set_type_eq.
            intros eq.
            apply inj in eq.
            rewrite set_type_eq in eq.
            exact eq.
        }
        destruct IHn as [m [g g_bij]].
        exists (nat_suc m).
        assert (initial_segment (nat_suc m) m) as m_in by apply nat_lt_suc.
        assert (∀ x, initial_segment (nat_suc m) [g x|]) as g_in.
        {
            intros x.
            unfold initial_segment.
            apply (trans2 (nat_lt_suc m)).
            exact [|g x].
        }
        exists (λ x, IfH x = a
            then (λ _, [m|m_in])
            else (λ H, [_|g_in [_|H]])).
        split; split.
        +   intros x y.
            destruct (sem (x = a)) as [x_eq|x_neq];
            destruct (sem (y = a)) as [y_eq|y_neq].
            *   subst.
                reflexivity.
            *   intros eq.
                setoid_rewrite set_type_eq2 in eq.
                pose proof [|g [y|y_neq]] as ltq.
                unfold initial_segment in ltq.
                rewrite <- eq in ltq.
                contradiction (irrefl _ ltq).
            *   intros eq.
                setoid_rewrite set_type_eq2 in eq.
                pose proof [|g [x|x_neq]] as ltq.
                unfold initial_segment in ltq.
                rewrite eq in ltq.
                contradiction (irrefl _ ltq).
            *   intros eq.
                setoid_rewrite set_type_eq2 in eq.
                rewrite set_type_eq in eq.
                apply inj in eq.
                inversion eq.
                reflexivity.
        +   intros [y y_lt].
            unfold initial_segment in y_lt.
            pose proof y_lt as y_lt2.
            rewrite nat_lt_suc_le in y_lt2.
            classic_case (y = m) as [eq|neq].
            *   subst y.
                exists a.
                destruct (sem (a = a)); [>|contradiction].
                apply set_type_eq2.
                reflexivity.
            *   assert (initial_segment m y) as y_in by (split; assumption).
                pose proof (sur g [y|y_in]) as [[x x_neq] x_eq].
                exists x.
                destruct (sem (x = a)); [>contradiction|].
                setoid_rewrite set_type_eq2.
                apply set_type_eq in x_eq.
                cbn in x_eq.
                rewrite <- x_eq.
                apply set_type_eq.
                apply f_equal.
                apply set_type_eq.
                reflexivity.
    -   specialize (IHn U (λ a, [_|simple_finite_in a_nex a])).
        apply IHn.
        split.
        intros a b.
        setoid_rewrite set_type_eq2.
        rewrite set_type_eq.
        apply inj.
Qed.

Theorem nat_not_finite : ¬simple_finite nat.
Proof.
    intros [n [f f_inj]].
    revert f f_inj.
    nat_induction n; intros; [>contradiction (nat_lt_0_false (f 0))|].
    classic_case (∃ a, [f a|] = n) as [[a a_eq]|a_nex].
    -   pose (g x := If x < a then [f x|] else [f (nat_suc x)|]).
        assert (∀ x, initial_segment n (g x)) as g_in.
        {
            intros x.
            split.
            -   rewrite <- nat_lt_suc_le.
                unfold g.
                case_if.
                +   exact [|f x].
                +   exact [|f (nat_suc x)].
            -   intros contr.
                rewrite <- a_eq in contr.
                unfold g in contr.
                case_if [ltq|leq].
                +   rewrite set_type_eq in contr.
                    apply inj in contr.
                    subst.
                    contradiction (irrefl _ ltq).
                +   rewrite set_type_eq in contr.
                    apply inj in contr.
                    subst a.
                    exact (leq (nat_lt_suc x)).
        }
        apply (IHn (λ x, [_|g_in x])).
        split.
        intros x y eq.
        setoid_rewrite set_type_eq2 in eq.
        unfold g in eq.
        case_if [x_lt|x_le]; case_if [y_lt|y_le];
                rewrite set_type_eq in eq; apply inj in eq.
        +   exact eq.
        +   rewrite nlt_le in y_le.
            pose proof (lt_le_trans x_lt y_le) as ltq.
            rewrite eq in ltq.
            rewrite <- nle_lt in ltq.
            contradiction (ltq (nat_le_suc y)).
        +   rewrite nlt_le in x_le.
            pose proof (lt_le_trans y_lt x_le) as ltq.
            rewrite <- eq in ltq.
            rewrite <- nle_lt in ltq.
            contradiction (ltq (nat_le_suc x)).
        +   rewrite nat_suc_eq in eq.
            exact eq.
    -   apply (IHn (λ x, [_|simple_finite_in a_nex x])).
        split.
        intros a b eq.
        setoid_rewrite set_type_eq2 in eq.
        rewrite set_type_eq in eq.
        apply inj in eq.
        exact eq.
Qed.

Section MinMax.

Context {U : Type}.
Hypothesis U_fin : simple_finite U.

Section Min.

Context `{TotalOrder U}.

Theorem simple_finite_min : U → ∃ m : U, ∀ a, m ≤ a.
Proof.
    intros z.
    classic_contradiction contr.
    assert (∀ m : U, ∃ a, a < m) as lt_ex.
    {
        intros m.
        rewrite not_ex in contr.
        specialize (contr m).
        rewrite not_all in contr.
        destruct contr as [a ltq].
        rewrite nle_lt in ltq.
        exists a.
        exact ltq.
    }
    clear contr.
    pose (f := fix build (n : nat) :=
        match n with
        | nat_zero => z
        | nat_suc n' => ex_val (lt_ex (build n'))
        end).
    destruct U_fin as [n [g g_inj]].
    pose (h x := g (f x)).
    apply nat_not_finite.
    exists n, h.
    unfold h.
    apply inj_comp; [>|apply g_inj].
    split.
    assert (∀ n, f (nat_suc n) < f n) as lt.
    {
        intros m.
        unfold f at 1; fold f.
        rewrite_ex_val a a_lt.
        exact a_lt.
    }
    assert (∀ a b, a < b → f a ≠ f b) as wlog.
    {
        intros a b ltq eq.
        assert (f b < f a) as ltq'.
        {
            clear eq.
            apply nat_lt_ex in ltq as [c c_eq]; subst b.
            nat_induction c.
            -   rewrite plus_comm.
                apply lt.
            -   rewrite nat_plus_rsuc.
                apply (trans (lt _)).
                exact IHc.
        }
        rewrite eq in ltq'.
        contradiction (irrefl _ ltq').
    }
    intros a b eq.
    destruct (trichotomy a b) as [[ltq|eq']|ltq].
    -   apply wlog in ltq.
        contradiction.
    -   exact eq'.
    -   apply wlog in ltq.
        symmetry in eq.
        contradiction.
Qed.

End Min.

Context `{TotalOrder U}.

Theorem simple_finite_max : U → ∃ m : U, ∀ a, a ≤ m.
Proof.
    intros z.
    make_dual_op le.
    pose (UO' := {|le := dual_op le|}).
    pose proof (simple_finite_min (UO := UO') z) as [m m_least].
    exists m.
    apply m_least.
Qed.

End MinMax.


Require Export ProjectiveGeometry.Dev.projective_space_axioms.

(** MAJOR ISSUE : WORK ONLY WITH COQ8.4pl6 **)

(**  PG(3,2). **)

(** To show that our axiom system is consistent we build a finite model. **)

Section s_fanoSpaceModelPG32.

(** PG(3,2) the smallest projective space: http://demonstrations.wolfram.com/15PointProjectiveSpace/ **)
(** 15 points and 35 lines, 15 planes **)

(** We can not use directly the inductive type for a technical reason related to Coq's implementation. **)

(* 15 points *)
Inductive Point := A | B | C | D | E | F | G | H | I | J | K | L | M | N | O.

(* 35 lines *)
Inductive Line := ABC | ADE | AFG | AHI | AKJ | ALM | ANO |   (* 7 *)
                  BEG | BIK | BMO | BHJ | BNL | BDF |         (* 13 *)
                  CHK | CLO | CDG | CMN | CEF | CIJ |         (* 19 *)
                  DKO | DIM | DJN | DHL |                     (* 23 *)
                  EJO | EIL | EKN | EHM |                     (* 27 *)
                  FIO | FHN | FJL | FKM |                     (* 31 *)
                  GHO | GIN | GJM | GKL.                      (* 35 *)

Definition Incid_bool : Point -> Line -> bool := fun P l =>
 match P with
| A =>
    match l with
    | ABC | ADE | AFG | AHI | AKJ | ALM | ANO => true
    | _ => false
    end
| B =>
    match l with
    | ABC | BEG | BIK | BMO | BHJ | BNL | BDF => true
    | _ => false
    end
| C =>
    match l with
    | ABC | CHK | CLO | CDG | CMN | CEF | CIJ => true
    | _ => false
    end
| D =>
    match l with
    | ADE | BDF | CDG | DKO | DIM | DJN | DHL => true
    | _ => false
    end
| E =>
    match l with
    | ADE | BEG | CEF | EJO | EIL | EKN | EHM => true
    | _ => false
    end
| F =>
    match l with
    | AFG | BDF | CEF | FIO | FHN | FJL | FKM => true
    | _ => false
    end
| G =>
    match l with
    | AFG | BEG | CDG | GHO | GIN | GJM | GKL => true
    | _ => false
    end
| H =>
    match l with
    | AHI | BHJ | CHK | DHL | EHM | FHN | GHO => true
    | _ => false
    end
| I =>
    match l with
    | AHI | BIK | CIJ | DIM | EIL | FIO | GIN => true
    | _ => false
    end
| J =>
    match l with
    | AKJ | BHJ | CIJ | DJN | EJO | FJL | GJM => true
    | _ => false
    end
| K =>
    match l with
    | AKJ | BIK | CHK | DKO | EKN | FKM | GKL => true
    | _ => false
    end
| L =>
    match l with
    | ALM | BNL | CLO | DHL | EIL | FJL | GKL => true
    | _ => false
    end
| M =>
    match l with
    | ALM | BMO | CMN | DIM | EHM | FKM | GJM => true
    | _ => false
    end
| N =>
    match l with
    | ANO | BNL | CMN | DJN | EKN | FHN | GIN => true
    | _ => false
    end
| O =>
    match l with
    | ANO | BMO | CLO | DKO | EJO | FIO | GHO => true
    | _ => false
    end
 end.

Lemma sub_lemma : forall T:Type, forall t:T, forall P:Prop, t<>t->P.
Proof.
solve [intuition].
Qed.

Lemma sub_lemma2 : forall P:Type, false=true -> P.
Proof.
intros P H; inversion H.
Qed.

Ltac clean := match goal with
    | H : false = true |- ?G => exact (sub_lemma2 G H)
    | H: ?A <> ?A |- ?G => exact (sub_lemma _ A G H)
    end.

(** A tactic which chooses one element and tries to solve the goal *)
Ltac solve_ex L tac := solve [exists L;abstract (tac)].
Ltac tac1 := split; exact (@refl_equal bool true).

(** A tactic which tries all possible lines **)
Ltac solve_ex_l tac :=
  first [
      solve_ex ABC tac | solve_ex ADE tac | solve_ex AFG tac | solve_ex AHI tac | solve_ex AKJ tac | solve_ex ALM tac | solve_ex ANO tac
      | solve_ex BEG tac | solve_ex BIK tac| solve_ex BMO tac | solve_ex BHJ tac | solve_ex BNL tac | solve_ex BDF tac
      | solve_ex CHK tac | solve_ex CLO tac | solve_ex CDG tac | solve_ex CMN tac | solve_ex CEF tac | solve_ex CIJ tac
      | solve_ex DKO tac | solve_ex DIM tac | solve_ex DJN tac | solve_ex DHL tac
      | solve_ex EJO tac | solve_ex EIL tac | solve_ex EKN tac | solve_ex EHM tac
      | solve_ex FIO tac | solve_ex FHN tac | solve_ex FJL tac | solve_ex FKM tac
      | solve_ex GHO tac | solve_ex GIN tac | solve_ex GJM tac | solve_ex GKL tac
].

Definition dist_3 (S:Type) (A B C  : S) : Prop := A <> B /\ A <> C /\ B <> C.

Definition dist_4 (S:Type) (A B C D :S) : Prop :=
  A <> B /\ A <> C /\ A <> D /\ B <> C /\ B <> D /\ C <> D.

Definition Incid p l := Incid_bool p l= true.

Lemma incid_dec (P:Point) (l:Line): {Incid P l} + {~Incid P l}.
Proof.
  unfold Incid; destruct l; destruct P; simpl; solve [left;reflexivity | right; discriminate].
Qed.

(** A1 : existence and unicity of line generated from 2 points **)

Lemma a1_exists : forall A B : Point, {l : Line | Incid A l /\ Incid B l}.
Proof.
  intros P Q; unfold Incid; destruct P; destruct Q; simpl; solve_ex_l tac1.
Defined.

Lemma a1_unique:forall (A B :Point)(l1 l2:Line),
~A=B -> Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> l1=l2.
Proof.
  unfold Incid; intros X Y l1 l2 HXY H1 H2 H3 H4;
    destruct X;destruct Y; try clean;
      destruct l1; simpl in H1,H2; try clean; clear H1 H2;
        destruct l2; simpl in H3,H4; try clean; reflexivity.
Qed.

Lemma a2_unique : forall(l1 l2 :Line)(A B :Point),
  ~l1=l2 -> Incid A l1 -> Incid A l2 -> Incid B l1 -> Incid B l2 -> A=B.
Proof.
  unfold Incid; intros X Y l1 l2 HXY H1 H2 H3 H4;
    destruct X;destruct Y; try clean;
      destruct l1; simpl in H1,H2; try clean; clear H1 H2;
        destruct l2; simpl in H3,H4; try clean; reflexivity.
Qed.

Lemma uniqueness : forall (A B :Point)(l1 l2:Line),
  Incid A l1 -> Incid B l1  -> Incid A l2 -> Incid B l2 -> A = B \/ l1 = l2.
Proof.
  unfold Incid; intros P Q l1 l2 ha1 hb1 ha2 hb2;
    destruct P; destruct Q; try first [left; reflexivity | right; reflexivity];
      abstract (destruct l1;simpl in *;try clean; clear ha1 hb1; destruct l2; simpl in *; try clean; clear ha2 hb2;
        solve [left;reflexivity | right;reflexivity]).
Qed.

(** A3 : dimension-related axioms *)

  (** A3_1 *)

Ltac rsplit := apply conj; [apply conj ; [idtac | apply conj ] | apply conj ; [idtac | apply conj]].

Ltac many_ex_p := match goal with
    | |- {_:Point& _} => exists A; many_ex_p
    | |- {_:Point& _} => exists B; many_ex_p
    | |- {_:Point& _} => exists C; many_ex_p
    | |- {_:Point& _} => exists D; many_ex_p
    | |- {_:Point& _} => exists E; many_ex_p
    | |- {_:Point& _} => exists F; many_ex_p
    | |- {_:Point& _} => exists G; many_ex_p
    | |- {_:Point& _} => exists H; many_ex_p
    | |- {_:Point& _} => exists I; many_ex_p
    | |- {_:Point& _} => exists J; many_ex_p
    | |- {_:Point& _} => exists K; many_ex_p
    | |- {_:Point& _} => exists L; many_ex_p
    | |- {_:Point& _} => exists M; many_ex_p
    | |- {_:Point& _} => exists N; many_ex_p
    | |- {_:Point& _} => exists O; many_ex_p
    | |- {_:Point| _} => exists A; many_ex_p
    | |- {_:Point| _} => exists B; many_ex_p
    | |- {_:Point| _} => exists C; many_ex_p
    | |- {_:Point| _} => exists D; many_ex_p
    | |- {_:Point| _} => exists E; many_ex_p
    | |- {_:Point| _} => exists F; many_ex_p
    | |- {_:Point| _} => exists G; many_ex_p
    | |- {_:Point| _} => exists H; many_ex_p
    | |- {_:Point| _} => exists I; many_ex_p
    | |- {_:Point| _} => exists J; many_ex_p
    | |- {_:Point| _} => exists K; many_ex_p
    | |- {_:Point| _} => exists L; many_ex_p
    | |- {_:Point| _} => exists M; many_ex_p
    | |- {_:Point| _} => exists N; many_ex_p
    | |- {_:Point| _} => exists O; many_ex_p
    | _ => abstract (solve [unfold Incid, dist_3; simpl; rsplit; solve [discriminate | reflexivity]])
end.

Lemma a3_1 :
  forall l:Line,{A:Point &{B:Point &{ C:Point|
  dist_3 _ A B C/\Incid A l /\Incid B l /\ Incid C l}}}.
Proof.
  intros l; destruct l; many_ex_p.
Defined.

  (** A2_2 : there exists 2 lines which do not intersect *)

Ltac many_ex_l := match goal with
    | |- exists _:Line, _ => exists ABC; many_ex_l
    | |- exists _:Line, _ => exists ADE; many_ex_l
    | |- exists _:Line, _ => exists AFG; many_ex_l
    | |- exists _:Line, _ => exists AHI; many_ex_l
    | |- exists _:Line, _ => exists AKJ; many_ex_l
    | |- exists _:Line, _ => exists ALM; many_ex_l
    | |- exists _:Line, _ => exists ANO; many_ex_l

    | |- exists _:Line, _ => exists BEG; many_ex_l
    | |- exists _:Line, _ => exists BIK; many_ex_l
    | |- exists _:Line, _ => exists BMO; many_ex_l
    | |- exists _:Line, _ => exists BHJ; many_ex_l
    | |- exists _:Line, _ => exists BNL; many_ex_l
    | |- exists _:Line, _ => exists BDF; many_ex_l

    | |- exists _:Line, _ => exists CHK; many_ex_l
    | |- exists _:Line, _ => exists CLO; many_ex_l
    | |- exists _:Line, _ => exists CDG; many_ex_l
    | |- exists _:Line, _ => exists CMN; many_ex_l
    | |- exists _:Line, _ => exists CEF; many_ex_l
    | |- exists _:Line, _ => exists CIJ; many_ex_l

    | |- exists _:Line, _ => exists DKO; many_ex_l
    | |- exists _:Line, _ => exists DIM; many_ex_l
    | |- exists _:Line, _ => exists DJN; many_ex_l
    | |- exists _:Line, _ => exists DHL; many_ex_l

    | |- exists _:Line, _ => exists EJO; many_ex_l
    | |- exists _:Line, _ => exists EIL; many_ex_l
    | |- exists _:Line, _ => exists EKN; many_ex_l
    | |- exists _:Line, _ => exists EHM; many_ex_l

    | |- exists _:Line, _ => exists FIO; many_ex_l
    | |- exists _:Line, _ => exists FHN; many_ex_l
    | |- exists _:Line, _ => exists FJL; many_ex_l
    | |- exists _:Line, _ => exists FKM; many_ex_l

    | |- exists _:Line, _ => exists GHO; many_ex_l
    | |- exists _:Line, _ => exists GIN; many_ex_l
    | |- exists _:Line, _ => exists GJM; many_ex_l
    | |- exists _:Line, _ => exists GKL; many_ex_l

    | _ => solve [unfold Incid; let p:= fresh in intros p; destruct p; simpl; let h:=fresh in intro h; destruct h; discriminate]
end.

Lemma a3_2 (* dim >= 3 *) : exists l1:Line, exists l2:Line, forall p:Point, ~(Incid p l1/\Incid p l2).
Proof.
  many_ex_l. (* we could have chosen GKL and EHM for instance *)
Qed.

  (** A3_3 *)

Lemma pt_dec : forall T U:Point, {T=U}+{~T=U}.
Proof.
  intros T U; destruct T; destruct U; solve [left; reflexivity | right; discriminate].
Defined.

  (** points_from_l is actually a3_1 *)

Definition points_from_l (l:Line) := let t:= (a3_1 l) in (projT1 t, projT1 (projT2 t), proj1_sig (projT2 (projT2  t))).

Definition inter (l1 l2:Line) : option Point :=
  match (points_from_l l1) with (X,Y,Z) =>
    match (points_from_l l2) with (X',Y',Z') =>
                                  if (pt_dec X X')then Some (X) else
                                    if (pt_dec X Y') then Some (X) else
                                      if (pt_dec X Z') then Some (X) else
                                        if (pt_dec Y X') then Some (Y) else
                                          if (pt_dec Y Y') then Some (Y) else
                                            if (pt_dec Y Z') then (Some Y) else
                                              if (pt_dec Z X') then (Some Z) else
                                                if (pt_dec Z Y') then (Some Z) else
                                                  if (pt_dec Z Z') then (Some Z) else None end end.

Definition Intersect_In (l1 l2 :Line) (P:Point) := Incid P l1 /\ Incid P l2.

Ltac solve_l l l1 l2 l3 :=
  let sP1 := eval compute in (inter l l1) in
  let sP2 := eval compute in (inter l l2) in
  let sP3 := eval compute in (inter l l3) in
  match sP1 with
    | None => fail
    | Some ?P1 => match sP2 with
           | None => fail
           | Some ?P2 => match sP3 with
                  | None => fail
                  | Some ?P3 => solve [exists l; exists P1; exists P2; exists P3;
                                       unfold Intersect_In, Incid; split; [split ; reflexivity | split ; split; reflexivity]] end end end.

Ltac solve_ex_ll :=
  match goal with |- exists (l4 : Line) (J1 J2 J3 : Point),
      Intersect_In ?l1 l4 J1 /\
      Intersect_In ?l2 l4 J2 /\ Intersect_In ?l3 l4 J3 =>
                  first [
                      solve_l ABC l1 l2 l3| solve_l ADE l1 l2 l3 | solve_l AFG l1 l2 l3 | solve_l AHI l1 l2 l3
                      | solve_l AKJ l1 l2 l3 | solve_l ALM l1 l2 l3 | solve_l ANO l1 l2 l3
                      | solve_l BEG l1 l2 l3 | solve_l BIK l1 l2 l3 | solve_l BMO l1 l2 l3 | solve_l BHJ l1 l2 l3
                      | solve_l BNL l1 l2 l3 | solve_l BDF l1 l2 l3
                      | solve_l CHK l1 l2 l3 | solve_l CLO l1 l2 l3 | solve_l CDG l1 l2 l3 | solve_l CMN l1 l2 l3
                      | solve_l CEF l1 l2 l3 | solve_l CIJ l1 l2 l3
                      | solve_l DKO l1 l2 l3 | solve_l DIM l1 l2 l3 | solve_l DJN l1 l2 l3 | solve_l DHL l1 l2 l3
                      | solve_l EJO l1 l2 l3 | solve_l EIL l1 l2 l3 | solve_l EKN l1 l2 l3 | solve_l EHM l1 l2 l3
                      | solve_l FIO l1 l2 l3 | solve_l FHN l1 l2 l3 | solve_l FJL l1 l2 l3 | solve_l FKM l1 l2 l3
                      | solve_l GHO l1 l2 l3 | solve_l GIN l1 l2 l3 | solve_l GJM l1 l2 l3 | solve_l GKL l1 l2 l3
  ] end.

Lemma a3_3 : forall l1 l2 l3:Line,
  dist_3 Line l1 l2 l3 -> exists l4 :Line,  exists J1:Point, exists J2:Point, exists J3:Point,
  (Intersect_In l1 l4 J1) /\ (Intersect_In l2 l4 J2) /\ (Intersect_In l3 l4 J3).
Proof.
  unfold dist_3; intros l1 l2 l3 (hd1,(hd2,hd3)); destruct l1; destruct l2; try clean; clear hd1;
  abstract (destruct l3; try clean; clear hd2 hd3; solve_ex_ll).
Qed.

  (** A2 : Pasch's axiom *)

  (** l_from_points is actually a1_exists *)

Definition l_from_points (Z : Point * Point) := proj1_sig (a1_exists (fst Z) (snd Z)).

Definition proj t := match t with Some t' => t' | None => A end.

Ltac findp := match goal with
  |- exists J0 : Point,
  Incid_bool J0 ?m = true /\
  Incid_bool J0 ?p = true => exists (proj (inter m p));simpl; split; reflexivity end.

Lemma points_line : forall T Z, forall x,  Incid_bool T x = true -> Incid_bool Z x =true -> T<>Z -> x=(l_from_points(T,Z)).
Proof.
  intros T Z x HTx HZx HTZ;
  destruct T; destruct Z; try clean; destruct x; simpl in HTx,HZx;first [reflexivity | discriminate ].
Qed.

Ltac handle x :=
  match goal with Ht: Incid_bool ?T x = _, Hz:Incid_bool ?Z x =_ |- _ =>
  let HH:= fresh in (assert (HH:x= (l_from_points(T,Z))) by (apply (points_line T Z x Ht Hz); assumption)); simpl in HH; subst x end.

Lemma a2 : forall A B C D:Point, forall lAB lCD lAC lBD :Line,
	dist_4 _ A B C D ->
	Incid A lAB/\Incid B lAB ->
	Incid C lCD/\Incid D lCD ->
	Incid A lAC/\Incid C lAC ->
	Incid B lBD/\Incid D lBD ->
	(exists I:Point, (Incid I lAB /\ Incid I lCD)) -> exists J:Point, (Incid J lAC /\Incid J lBD).
Proof.
  unfold dist_4, Incid;
  intros P Q R S l1 l2 l3 l4 (hd1,(hd2,(hd3,(hd4,(hd5,hd6))))) (hp1,hq1) (hr2,hs2) (hp3,hr3) (hq4,hs4) Ht.
  destruct P; destruct Q; try clean;
          abstract (
              handle l1;
                abstract (
                    destruct R; try clean; handle l3;
                      abstract (
                          destruct S; try clean; handle l2; handle l4;
                            destruct Ht as [t (Ht1,Ht2)]; destruct t; simpl in Ht1, Ht2; try discriminate; clear Ht1 Ht2;findp))).
Qed.

End s_fanoSpaceModelPG32.


From HoTT Require Import HoTT.

Notation List := list.
Notation indList := @list_rect.

Definition recList (A X : Type) (x1 : X) (x2 : A -> X -> X) : List A -> X :=
  indList A (fun _ => X) x1 (fun a _ => x2 a).

Fixpoint length {A : Type} (l : List A) : nat :=
  match l with
  | nil       => 0
  | cons a l' => succ (length l')
  end.

Definition List' (A B : Type) : Type :=
  {l1 : List A & {l2 : List B & code_nat (length l1) (length l2)}}.

Definition nil' {A B : Type} : List' A B := (nil; nil; tt).
Definition cons' {A B : Type} : A * B -> List' A B -> List' A B :=
  fun '(a, b) '(l1; l2; c) => (cons a l1; cons b l2; c).

Definition indList' (A B : Type)
    (X : List' A B -> Type)
    (x1 : X nil')
    (x2 : forall (ab : A * B) (l' : List' A B), X l' -> X (cons' ab l'))
    : forall l' : List' A B, X l' :=
  sig_ind _ (
    fix f (l1 : List A) : forall l2c, X (l1; l2c) :=
      match l1 with
      | nil        => sig_ind _ (fun l2 =>
          match l2 return forall c, X (nil; l2; c) with
          | nil        => fun 'tt => x1
          | cons b l2' => fun c => Empty_rec c
          end)
      | cons a l1' => sig_ind _ (fun l2 =>
          match l2 return forall c, X (cons a l1'; l2; c) with
          | nil        => fun c => Empty_rec c
          | cons b l2' => fun c => x2 (a, b) (l1'; l2'; c) (f l1' (l2'; c))
          end)
      end
  ).

Definition recList' (A B X : Type) (x1 : X) (x2 : A * B -> X -> X)
    : List' A B -> X :=
  indList' A B (fun _ => X) x1 (fun ab _ => x2 ab).

Definition asList {A B : Type} : List' A B <~> List (A * B).
Proof.
  srapply equiv_adjointify.
  - exact (recList' A B (List (A * B)) nil (@cons _)).
  - exact (recList (A * B) (List' A B) nil' cons').
  - rapply (indList (A * B)).
    + reflexivity.
    + exact (fun ab _ w => ap (cons ab) w).
  - rapply (indList' A B).
    + reflexivity.
    + exact (fun ab _ w => ap (cons' ab) w).
Defined.

Definition zip {A B : Type}
    : Pullback (@length A) (@length B) <~> List (A * B) :=
  asList
  oE equiv_functor_sigma_id (fun l1 =>
     equiv_functor_sigma_id (fun l2 =>
     equiv_path_nat^-1)).

Notation unzip := zip^-1.

Open Scope list_scope.
Open Scope nat_scope.

Eval compute in
  zip (0 :: 2 :: 4 :: 8 :: nil; false :: true :: false :: true :: nil; idpath).

Eval compute in
  unzip ((0, true) :: (1, false) :: (2, true) :: (3, false) :: nil).


(*Introduction to propositional logic*)
From Coq Require Import List.
Import ListNotations.
Inductive tm : Set :=
| tTrue  : tm
| tFalse : tm
| tVar   : nat -> tm
(* | tNot   : tm -> tm *)
| tAnd   : tm -> tm -> tm
| tOr    : tm -> tm -> tm
| tImpl  : tm -> tm -> tm.
(*  *)

 Notation " ⊤ " := tTrue (at level 0).
 Notation " ⊥ " := tFalse (at level 0).

 (* Notation " ! A " := (tImpl A tFalse) (at level 75). *)
 Notation " ¬ A " := (tImpl A tFalse) (at level 75).

 Notation "A '&&&' B" := (tAnd A B) (at level 80, right associativity).
 Notation "A '|||' B" := (tOr A B) (at level 85, right associativity).
 Notation "A '-->' B" := (tImpl A B)  (at level 30, right associativity).

Definition context := (list tm)%type.

(*Semantics of tm*)
Definition assignment := list nat.
Fixpoint truthAssign (A: assignment) (t:tm) : Prop :=
    match t with
    | tTrue       => True
    | tFalse      => False
    | tVar n      => In n A
    | p_1 &&& p_2 => (truthAssign A p_1) /\ (truthAssign A p_2)
    | p_1 ||| p_2 => (truthAssign A p_1) \/ (truthAssign A p_2)
    | p_1 --> p_2 => (truthAssign A p_1) -> (truthAssign A p_2)
    end.

Lemma tm_eq_dec : forall x y:tm, {x=y}+{x<>y}.
Proof.
    induction x; destruct y; try (now right); try (now left).
    - destruct (Nat.eq_dec n n0) eqn:E; subst; auto. right. congruence.
    - destruct (IHx1 y1) eqn:E1.
        + destruct (IHx2 y2) eqn:E2; subst; auto.
          * right. congruence.
        + right. congruence.
    - destruct (IHx1 y1) eqn:E1.
        + destruct (IHx2 y2) eqn:E2; subst; auto.
            * right. congruence.
        + right. congruence.
    - destruct (IHx1 y1) eqn:E1.
        + destruct (IHx2 y2) eqn:E2; subst; auto.
            * right. congruence.
        + right. congruence.
Qed.


Module Type preorder.
Parameter (X : Set) (le : X -> X -> Prop).
Axiom (le_refl : forall x, le x x).
Axiom (le_trans : forall x y z, le x y -> le y z -> le x z).
Parameter (join : X -> X -> X).
Axiom (join_l : forall x' x y, le x' x -> le x' (join x y)).
Axiom (join_r : forall y' x y, le y' y -> le y' (join x y)).
Axiom (join_u : forall x y z, le x z -> le y z -> le (join x y) z).

Definition monotone (f : X -> X) :=
  forall x y, le x y -> le (f x) (f y).
Definition closure (f : X -> X) :=
  monotone f /\ (forall x, le x (f x)) /\ (forall x, le (f (f x)) (f x)).

Parameter (lfp : (X -> X) -> X).
Parameter (lfp_fixed : forall f (H : monotone f), f (lfp f) = lfp f).
Parameter (lfp_least : forall f (H : monotone f) x, le (f x) x -> le (lfp f) x).

End preorder.

Module closure_props (P : preorder).

Import P.

Create HintDb order_hints.
Local Hint Resolve le_refl le_trans join_l join_r join_u : order_hints.

Local Hint Extern 2 (le ?l (lfp ?f)) => (replace (le l (lfp f)) with (le l (f (lfp f)))
  by (apply f_equal; apply (lfp_fixed f); solve[auto])) : order_hints.

Local Hint Resolve lfp_least : order_hints.

Definition least_closure (f : X -> X) (x : X) : X :=
  lfp (fun Y => join (f Y) x).

Lemma closure_base : forall f, monotone f -> forall x, monotone (fun Y => join (f Y) x).
unfold monotone;intros. auto with order_hints.
Qed.

Require Import Setoid.

Lemma clomon : forall f, monotone f -> monotone (least_closure f).
intros. pose proof (closure_base _ H). unfold least_closure.
intro; auto with order_hints.
Qed.

Lemma closoure_closed : forall f, monotone f -> closure (least_closure f).
intros. pose proof (closure_base _ H). unfold least_closure.
split;[|split];
intro;auto with order_hints.
Qed.

Lemma closure_above : forall f, monotone f -> forall x, le (f x) (least_closure f x).
intros. pose proof (closure_base _ H). unfold least_closure.
auto 12 with order_hints.
Qed.

Lemma closure_least : forall f, monotone f -> forall c, closure c ->
      (forall x, le (f x) (c x)) -> (forall x, le (least_closure f x) (c x)).
intros. pose proof (closure_base _ H). unfold least_closure.
destruct H0 as (? & ? & ?).
eauto with order_hints.
Qed.

End closure_props.

Print closure_props.


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

From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

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

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

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

Fixpoint rev (rev_arg0 : lst) : lst
           := match rev_arg0 with
              | Nil => Nil
              | Cons x y => append (rev y) (Cons x Nil)
              end.

Fixpoint qreva (qreva_arg0 : lst) (qreva_arg1 : lst) : lst
           := match qreva_arg0, qreva_arg1 with
              | Nil, x => x
              | Cons z x, y => qreva x (Cons z y)
              end.
Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. rewrite 2 append_nil. reflexivity. }
   { simpl. rewrite append_nil.  reflexivity. }
   { simpl. rewrite 2 append_nil. reflexivity. }
Qed.

Theorem append_rev_cons:
   forall (l1 l2: lst) (x: natural),
   rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
   induction l1; induction l2; try (simpl; reflexivity).
   { intro.  simpl.  rewrite IHl1.  simpl. lfind.
Admitted.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
   induction l1.
   { induction l2.
   { simpl. rewrite append_rev_cons.
      rewrite <- 2 append_assoc.
      f_equal. }
   { simpl. rewrite append_nil. reflexivity. }
   }
   { intro. simpl. rewrite append_nil. reflexivity. }
Qed.

Theorem rev_involutive : forall (x : lst), eq (rev (rev x)) x.
Proof.
   induction x.
   { simpl. rewrite rev_append. simpl. f_equal.
   assumption. }
   { simpl. reflexivity. }
Qed.

Theorem qreva_append : forall (x y : lst), (qreva x y) = (append (rev x) y).
Proof.
   induction x; induction y; simpl; try reflexivity.
   { rewrite IHx.
   rewrite <- append_assoc.
   f_equal. }
   { rewrite IHx.
   rewrite append_nil.
   reflexivity. }
Qed.

Theorem rev_qreva_nil : forall (x : lst), eq (rev x) (qreva x Nil).
Proof.
   intros.
   rewrite qreva_append.
   rewrite append_nil.
   reflexivity.
Qed.

Theorem theorem0 : forall (x : lst), eq (rev (qreva x Nil)) x.
Proof.
   intro.
   rewrite <- rev_qreva_nil.
   apply rev_involutive.
Qed.


From Coq Require Import Lia.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq path eqtype order.
Import Order.TTheory.
Open Scope order_scope.

Lemma orlastelim : forall a b, [ || a, b | true] = true.
Proof. by case; case. Qed.

Lemma orsndelim : forall a b, [ || a, true | b] = true.
Proof. by case; case. Qed.

Hint Resolve orlastelim orsndelim : core.

Module BST.
Section BinSearchTree.
Notation ordType := (orderType tt).
Variable Elem : ordType.

Inductive Tree := E | T : Tree -> Elem -> Tree -> Tree.

Definition EmptyTree := E.

Implicit Type t : Tree.
Implicit Type x y : Elem.

(* equality *)
Fixpoint eqtree t1 t2 :=
match t1, t2 with
| E, E => true
| T l1 x1 r1, T l2 x2 r2 => [&& (x1 == x2), eqtree l1 l2 & eqtree r1 r2]
| _, _ => false
end.

Lemma eqtreeP : Equality.axiom eqtree.
Proof.
elim=> [|? IHl ?? IHr] /= [] *; try by constructor.
by apply: (iffP idP)=> [/and3P[/eqP-> /IHl-> /IHr->]|[/IHl-> /eqP-> /IHr->]].
Qed.
Canonical tree_eqMixin := EqMixin eqtreeP.
Canonical tree_eqType := Eval hnf in EqType Tree tree_eqMixin.

Lemma eqtreeE : eqtree = eq_op.
Proof. by []. Qed.

(* membership predicat *)
Fixpoint mem_tree t :=
  if t is T l x r then xpredU1 x (xpredU (mem_tree l) (mem_tree r)) else xpred0.

Definition tree_eqclass := Tree.
Identity Coercion tree_of_eqclass : tree_eqclass >-> Tree.
Coercion pred_of_tree (t : tree_eqclass) : {pred Elem} := mem_tree t.
Canonical tree_predType := PredType pred_of_tree.
(* The line below makes mem_seq a canonical instance of topred. *)
Canonical mem_seq_predType := PredType mem_tree.

Fixpoint LT x t : bool :=
  if t is T l y r then [&& LT x l, LT x r & (x < y)] else true.

Fixpoint GT x t : bool :=
  if t is T l y r then [&& GT x l, GT x r & (x > y)] else true.

Fixpoint BSTOrder t : bool :=
  if t is T l x r then [&& GT x l, LT x r, BSTOrder l & BSTOrder r] else true.

Lemma TOC l x r :
  BSTOrder (T l x r) ->
  [&& GT x l, LT x r, (BSTOrder l) & (BSTOrder r)].
Proof. by []. Qed.

Lemma LTC x l y r :
  LT x (T l y r) ->
  [&& LT x l, LT x r & (x < y)].
Proof. by []. Qed.

Lemma GTC x l y r :
  GT x (T l y r) ->
  [&& GT x l, GT x r & (x > y)].
Proof. by []. Qed.

Lemma LEG x x' t : (x' <= x) && LT x t -> LT x' t.
Proof.
elim: t=> //= l IHl y r IHr /and4P[x'x ?? /(le_lt_trans x'x)->].
by rewrite IHl ?IHr // x'x.
Qed.

Lemma GTL x x' t : (x' >= x) && GT x t -> GT x' t.
Proof.
elim: t=> //= l IHl y r IHr /and4P[xx' ?? /lt_le_trans->] //.
by rewrite IHl ?IHr // xx'.
Qed.

Lemma is_member x l y r : x \in T l y r = [|| x == y, x \in l | x \in r].
Proof. by []. Qed.

Lemma is_left l r x y (bst : BSTOrder (T l y r)) :
  x < y -> x \in T l y r = (x \in l).
Proof.
move=> xy. rewrite is_member. apply/or3P. move: bst=> /= /and4P[? L ??].
case: ifP=> ->; first by apply/or3P.
apply/or3P=> /=. rewrite negb_or. apply/andP; split; first by rewrite lt_eqF.
elim: (r) L=> //= l' IHl' x' r' IHr' /and3P[LTl' LTr' yx'].
by rewrite is_member !negb_or (lt_eqF (lt_trans xy yx')) ?IHl' ?IHr'.
Qed.

Lemma is_right l r x y (bst : BSTOrder (T l y r)) :
  x > y -> x \in T l y r = (x \in r).
Proof.
move=> yx. rewrite is_member. apply/or3P. move: bst=> /= /and4P[G ???].
case: ifP=> ->; first by apply/or3P.
apply/or3P. rewrite !negb_or /=. apply/and3P; split=> //; first by rewrite gt_eqF.
elim: (l) G=> //= l' IHl' x' r' IHr' /and3P[GTl' GTr' x'y].
by rewrite is_member !negb_or (gt_eqF (lt_trans x'y yx)) ?IHl' ?IHr'.
Qed.

(** member function with at most d + 1 comparisons where d is the depth of a tree*)
Fixpoint candidate x t (cand : option Elem) : bool :=
  if t is T l y r then
    if x < y then candidate x l cand
    else candidate x r (Some y)
  else if cand is Some c then x == c
       else false.

Definition member' x t : bool := candidate x t None.

Lemma nhd_member x y t :
  x != y -> candidate x t None = candidate x t (Some y).
Proof.
move=> neq_xy.
elim: t => /= [ | l IHl z r IHr]; first by rewrite (negbTE neq_xy).
case: ltgtP=> // xy; by apply: IHl.
Qed.

Lemma mem_in_hd x t (L : LT x t) :
  candidate x t (Some x).
Proof.
elim: t L=> /= [| ? IHl ??? /and3P[?? xx']]; first by rewrite /= eqxx.
by rewrite xx' IHl.
Qed.

Lemma memberE x t (bst : BSTOrder t) : x \in t = member' x t.
Proof.
rewrite/member'.
elim: t bst=> //= ? IHl ? ? IHr bst.
move: (TOC _ _ _ bst)=> /and4P[*]. case: ltgtP.
- move=> *. rewrite is_left //. by apply: IHl.
- move=> *. rewrite is_right // IHr //; apply: nhd_member=> //. by rewrite gt_eqF.
move=> ->; rewrite mem_in_hd // is_member eq_refl //.
Qed.

Fixpoint insert x t :=
  if t is T a y b then
    if x < y then T (insert x a) y b
    else if x > y then T a y (insert x b)
    else T a y b
  else T E x E.

Lemma member_LT x x' t (bst : BSTOrder t) : LT x t -> (x' \in t) -> x < x'.
Proof.
elim: t bst=> // ? IHl y ? IHr bst /and3P[?? xy] M. case: (ltgtP x' y);
move: (TOC _ _ _ bst)=> /and4P[????].
- by move=> x'y; rewrite is_left in M=> //; rewrite IHl.
- by move=> yx'; rewrite is_right in M=> //; rewrite IHr.
by move=> x'y; rewrite -x'y in xy.
Qed.

Lemma member_GT x x' t (bst : BSTOrder t) : GT x t -> (x' \in t) -> x > x'.
Proof.
elim: t bst=> //= ? IHl y ? IHr bst /and3P[?? yx] M. case: (ltgtP x' y);
move: (TOC _ _ _ bst)=> /and4P[????].
- by move=> x'y; rewrite is_left in M=> //; rewrite IHl.
- by move=> yx'; rewrite is_right in M; rewrite ?IHr.
by move=> x'y; rewrite -x'y in yx.
Qed.

Lemma insert_LT x x' t : LT x t -> (x < x') -> LT x (insert x' t).
Proof.
elim: t=> //= ? IHl y ? IHr /and3P[LTl LTr xy] xx'.
by case: (ltgtP x' y); move=> xy' /=; rewrite ?IHl ?IHr ?LTl ?LTr ?xy'.
Qed.

Lemma insert_GT x x' t : GT x t -> (x > x') -> GT x (insert x' t).
Proof.
elim: t=> //= ? IHl y ? IHr /and3P[GTl GTr yx] x'x.
by case: (ltgtP x' y); move=> xy' /=; rewrite ?IHl ?IHr ?GTl ?GTr ?xy'.
Qed.

Theorem BSTOrder_preserved x t (bst : BSTOrder t) : BSTOrder (insert x t).
Proof.
elim: t bst=> //= l IHl x' r IHr /and4P[]. by case: ltgtP; last (by move=><- /=->->->->);
move=> /= ? G L BSl BSr; rewrite (insert_GT, insert_LT) // (IHl, IHr) // (L, G) (BSr, BSl).
Qed.

Fixpoint makelist t :=
  if t is T l x r then
    makelist l ++ x :: makelist r
  else [::].

Fixpoint makelist_aux t (m : seq Elem) :=
  if t is T l x r then
    makelist_aux l (x :: makelist_aux r m)
  else m.

Definition makelist' t := makelist_aux t [::].

Lemma makelistE t : makelist t = makelist' t.
Proof.
have: (forall m, makelist_aux t m = makelist t ++ m).
- elim: t=> //= l IHl x r IHr m.
  by rewrite IHl // IHr // -catA.
move=> aux. rewrite/makelist'. by rewrite aux cats0.
Qed.

Lemma inlist t x :
  (x \in makelist t) = (x \in t).
Proof.
elim: t=> //= l IHl y r IHr.
by rewrite mem_cat in_cons is_member -IHl -IHr orbCA.
Qed.

Lemma bstlr l r x a b : BSTOrder (T l x r) -> a \in l -> b \in r -> a < b.
Proof.
move=> /= /and4P[GTl LTr BSl BSr] al br.
have: x < b.
- apply: member_LT; first by exact: BSr. exact: LTr. exact: br.
have: a < x.
- apply: member_GT; first by exact: BSl. exact: GTl. exact: al.
move=> /lt_trans; apply.
Qed.

Lemma mlistlr l r x a b :
  BSTOrder (T l x r) -> a \in makelist l -> b \in makelist r -> a < b.
Proof.
move=> BS. rewrite !inlist.
apply: bstlr. exact: BS.
Qed.

Lemma list_of_tree_sorted t (bst : BSTOrder t) :
  sorted <=%O (makelist t).
Proof.
elim: t bst=> //= l IHl x r IHr /and4P[GTl LTr BSl BSr].
move: (IHl BSl) (IHr BSr)=> Sl Sr.
have: sorted <=%O (x :: makelist r).
- rewrite /= path_sortedE; last by apply: le_trans. apply/andP. split; last by [].
  elim: (r) LTr=> //= l' IHl' y r' IHr' /and3P[LTl' LTr' xy].
  rewrite all_cat IHl' //= IHr' ?ltW //.
move=> /= Sxr.
case E: (makelist l)=> [// |y l']. move: (Sl).
rewrite E cat_cons /= cat_path=> -> /=.
have: (last y l') \in makelist l.
- rewrite E. apply: mem_last.
rewrite inlist=> lyl. apply/andP. split.
- apply: ltW. apply: member_GT. exact: BSl. exact: GTl. exact: lyl.
exact: Sxr.
Qed.

Lemma mem_hVtr x y t (bst : BSTOrder t) :
  x \in (insert y t) = (x == y) || (x \in t).
Proof.
elim: t bst=> [_ | l IHl x' r IHr bst].
- case: ltgtP=> neq //=; rewrite !is_member /=; first by rewrite lt_eqF.
  - by rewrite gt_eqF.
  by rewrite neq eq_refl.
case: ltgtP=> xy /=; case: ltgtP=> x'y; rewrite !is_member //=;
move: (TOC _ _ _ bst)=> /and4P[*];
by rewrite ?IHl ?IHr ?(lt_eqF xy) ?(gt_eqF xy) // xy ?x'y ?eq_refl.
Qed.

Lemma already_mem x t (bst : BSTOrder t) :
  x \in t -> insert x t = t.
Proof.
elim: t bst=> //= l IHl y r IHr /and4P[GTl LTr BSl BSr]. case: ltgtP=> xy //= xint;
rewrite (IHl BSl, IHr BSr) // -(is_left l r x y, is_right l r x y) //; by apply/and4P.
Qed.

Fixpoint insert_aux x t : option Tree :=
  if t is T l y r then
    if x < y then
      if insert_aux x l is Some l' then
        Some (T l' y r)
      else None
    else if x > y then
           if insert_aux x r is Some r' then
             Some (T l y r')
           else None
         else
           Some (T l y r)
  else
    Some (T E x E).

Definition insert' x t :=
  if insert_aux x t is Some t then t else E.

Lemma insertE x t : insert x t = insert' x t.
Proof.
have: Some (insert x t) = insert_aux x t.
- elim: t=> //= l IHl y r IHr. by case: ltgtP=> //; rewrite -(IHl, IHr).
rewrite/insert'. by move=> <-.
Qed.

Fixpoint omin t :=
  if t is T l y r then
    if l is T l' x r' then
      omin l
    else if l is T E x r' then Some x
    else Some y
  else None.

Arguments omin : simpl nomatch.

Lemma nonemptymin t : t != E -> exists x, omin t = Some x.
Proof.
elim: t=> //= l IHl x r IHr _.
case: l IHl=> //= [* | l' y r' IHl]; first by exists x. by apply: IHl.
Qed.

Lemma minint t x : omin t = Some x -> x \in t.
Proof.
elim: t=> //= l IHl y r IHr min. rewrite is_member.
case: (l) IHl min=> /= [_ [->]| ??? IHl ?]; first by rewrite eq_refl.
by rewrite IHl.
Qed.

Lemma ismin t y (bst : BSTOrder t) :
  omin t = Some y -> forall x, x \in t -> y <= x.
Proof.
elim: t bst=> //= l IHl x r IHr /and4P[GTl LTr BSl BSr] min x'.
rewrite is_member=> /or3P[/eqP -> | x'l | x'r]; case eq: (l) IHl BSl min=> IHl BSl /=.
- by move=> [->].
- move=> min. apply: ltW. apply: member_GT; first by exact: BSl. by rewrite -eq. exact: minint.
- move=> [<-]. apply: ltW. apply: member_LT; first by exact: BSl. by []. by rewrite eq in x'l.
- move=> min. by rewrite IHl // -eq.
- move=> [<-]. apply: ltW. apply: member_LT; first by exact: BSr. by []. by [].
move=> min. rewrite -eq in min. rewrite -eq in BSl. move: (minint l y min)=> yl.
apply: ltW. by rewrite (bstlr l r x y x') //= GTl LTr BSl BSr.
Qed.

Fixpoint deletemin t :=
  if t is T l y r then
    if l is T l' x r' then
      T (deletemin l) y r
    else r
  else E.

Arguments deletemin : simpl nomatch.

Lemma hNleft l r x (bst : BSTOrder (T l x r)) : x \notin l.
Proof.
elim: l bst=> //= l' IHl' y r' IHr' /and4P[/and3P[???] ? /and4P[*]].
by rewrite is_member !negb_or gt_eqF ?IHl' ?IHr' //; apply/and4P; split.
Qed.

Lemma hNright l r x (bst : BSTOrder (T l x r)) : x \notin r.
Proof.
elim: r bst=> // l' IHl' y r' IHr' /= /and4P[] ? /and3P[] ???? /and4P[*].
by rewrite is_member !negb_or lt_eqF ?IHl' ?IHr' //=; apply/and4P; split.
Qed.

Lemma nomin t y (bst : BSTOrder t) : omin t = Some y -> y \notin (deletemin t).
Proof.
elim: t bst=> //= l IHl x r IHr /and4P[GTl LTr BSl BSr] min.
case eq: (l) IHl BSl min=> [| l' x' r'] //.
- move=> _ _ /= [<-]. apply: hNright=> /=. apply/and4P.
  split; first by exact: GTl. by []. by rewrite eq. by [].
move=> IHl BSl min. rewrite is_member !negb_or.
have: y \in T l' x' r'.
- by rewrite minint.
move=> yl. apply/and3P. split.
- rewrite lt_eqF //. apply: member_GT. exact: BSl. by rewrite -eq. by [].
- by rewrite IHl.
apply: contra_eqN. move=> yr.
have: y != y.
- rewrite lt_eqF //. apply: bstlr=> /=. apply/and4P.
  split; first by exact: GTl. exact: LTr. by rewrite eq. by []. by rewrite eq. by [].
move=> yy. exact: yy. by [].
Qed.

Lemma stillinbst t x y (bst : BSTOrder t) :
  omin t = Some y -> x \in t -> x != y -> x \in (deletemin t).
Proof.
elim: t bst=> //= l IHl x' r IHr /and4P[GTl LTr BSl BSr min].
rewrite is_member=> /or3P[/eqP xx' | xl | xr] /eqP neq_xy;
case eq: l IHl GTl BSl min=> [| l' y' r'] //= IHl ??.
- move=> [x'y]. by move: x'y xx' neq_xy=>->->.
- move=> min. by rewrite is_member xx' eq_refl.
- move=> _. by move: eq xl=>->.
- move=> min. rewrite is_member IHl // -?eq //; by apply/eqP.
move=> min. by rewrite is_member xr.
Qed.

Lemma wasinbst t x : x \in (deletemin t) -> x \in t.
Proof.
elim: t=> // l IHl y r IHr xtt.
case: l IHl xtt=> /= [_ xr | l' x' r' IHl]; first by rewrite is_member xr.
rewrite is_member is_member=> /or3P[/eqP ->| xtl | ->] //; first by rewrite eq_refl.
by rewrite IHl.
Qed.

Lemma LTeq x t : LT x t <-> forall y, y \in t -> x < y.
Proof.
elim: t=> //= l IHl x' r IHr. split.
- move=> /and3P[LTl LTr xx'] y. rewrite is_member=> /or3P[/eqP -> // ||]; move: y; by rewrite -(IHl, IHr).
move=> H. apply/and3P.
by split; rewrite (IHl, IHr, H) ?is_member ?eq_refl // => y yt; rewrite H ?is_member ?yt.
Qed.

Lemma GTeq x t : GT x t <-> forall y, y \in t -> x > y.
Proof.
elim: t=> //= l IHl x' r IHr. split.
- move=> /and3P[GTl GTr x'x] y. rewrite is_member=> /or3P[/eqP -> // ||]; move: y; by rewrite -(IHl, IHr).
move=> H. apply/and3P.
by split; rewrite (IHl, IHr, H) ?is_member ?eq_refl // => y yt; rewrite H ? is_member ?yt.
Qed.

Lemma stillbst t (bst : BSTOrder t) : BSTOrder (deletemin t).
Proof.
elim: t bst=> //= l IHl x r IHr /and4P[GTl LTr BSl BSr].
case: (l) IHl BSl GTl=> //= l' y r' IHl BSl GTl. apply/and4P.
split; rewrite ?IHl ?GTeq //.
have: forall y', y' \in (T l' y r') -> y' < x.
- by rewrite -GTeq.
by move=> H y' y't; rewrite H // wasinbst.
Qed.

Fixpoint delete x t :=
  if t is T l y r then
    if x < y then
      T (delete x l) y r
    else if x > y then
      T l y (delete x r)
    else
      if omin r is Some z then
        T l z (deletemin r)
      else l
  else E.

Lemma LTnmem x t : LT x t -> x \notin t.
Proof.
elim: t=> //= l IHl y r IHr /and3P[LTl LTr xy].
by rewrite is_member !negb_or lt_eqF ?IHl ?IHr.
Qed.

Lemma GTnmem x t : GT x t -> x \notin t.
Proof.
elim: t=> //= l IHl y r IHr /and3P[GTl GTr yx].
by rewrite is_member !negb_or gt_eqF ?IHl ?IHr.
Qed.

Lemma deleted x t (bst : BSTOrder t) : x \notin (delete x t).
Proof.
elim tr: t bst=> [| l IHl y r IHr] //= /and4P[GTl LTr BSl BSr]. case: ltgtP=> xy;
rewrite ?is_member ?negb_or (IHl, IHr, xy) //=.
- rewrite lt_eqF //=.
  elim: (r) xy LTr=> //= l' IHl' x' r' IHr' xy /and3P[LTl' LTr' yx'].
  by rewrite is_member !negb_or (lt_eqF (lt_trans xy yx')) /= IHl' ?IHr'.
- rewrite gt_eqF //= andbT.
  elim: (l) xy GTl=> //= l' IHl' x' r' IHr' yx /and3P[GTl' GTe' x'y].
  by rewrite is_member !negb_or (gt_eqF (lt_trans x'y yx)) /= IHl' ?IHr'.
case eqr: (r)=> [| l' x' r'] //=; first by rewrite GTnmem.
have: exists m, omin (T l' x' r') = Some m.
- by apply: nonemptymin.
move=> [m min]. rewrite min -eqr is_member !negb_or.
have: m \in r. by rewrite minint // eqr.
move=> mr.
have: y < m. by move: LTeq LTr=> ->->.
 move=> ym. rewrite lt_eqF //=.
rewrite (hNleft l r) /=; last by apply/and4P; split.
rewrite (hNright l (deletemin r)) //= GTl BSl /= stillbst // andbT LTeq=> y' y't.
move: (LTeq y r) LTr=> ->-> //. by rewrite wasinbst.
Qed.

Lemma reminbst x t y (bst : BSTOrder t): x \in t -> x != y -> x \in (delete y t).
Proof.
elim: t bst=> //= l IHl x' r IHr /and4P[GTl LTr BSl BSr].
case: ltgtP=> x'y; rewrite !is_member.
- by move=> /or3P[->| xl neq_xy |-> neq_xy] //; rewrite IHl.
- by move=> /or3P[->|-> neq_xy| xr neq_xy] //; rewrite IHr.
case eqr: (r)=> [| l' y' r'] //=.
- by move=> /or3P[/eqP->||] //; rewrite x'y eq_refl.
have: exists m, omin (T l' y' r') = Some m.
- by apply: nonemptymin.
move=> [m min]. rewrite min=> /or3P[/eqP->| xl neq_xy | xt neq_xy].
- by rewrite x'y eq_refl.
- by rewrite is_member xl.
rewrite is_member. case: ltgtP=> xm; last by [].
- by rewrite -eqr (stillinbst r x m) // ?eqr // lt_eqF.
by rewrite -eqr (stillinbst r x m) // ?eqr // gt_eqF.
Qed.

Lemma delwasinsbt x y t (bst : BSTOrder t) : x \in (delete y t) -> x \in t.
Proof.
elim: t bst=> //= l IHl x' r IHr /and4P[GTl LTr BSl BSr].
case: ltgtP=> x'y; rewrite !is_member.
- by move=> /or3P[->| xdl |->] //; rewrite IHl.
- by move=> /or3P[->|->| xdr] //; rewrite IHr.
case eq: (r)=> /= [| l' y' r']; first by move=> ->.
have: exists m, omin r = Some m.
- by apply: nonemptymin; rewrite eq.
move=> [m min].
rewrite -eq min is_member=> /or3P[/eqP -> |->| xtr] //; first by rewrite [m \in r]minint.
by rewrite [x \in r]wasinbst.
Qed.

Lemma abs_min x y t (bst: BSTOrder t) : omin t = Some y -> x \in (deletemin t) -> y < x.
Proof.
elim: t bst=> //= l IHl x' r IHr /and4P[GTl LTr BSl BSr].
case eq: l IHl GTl BSl=> [| l' y' r'] IHl GTl BSl /=.
- move=> [<-] xr. by rewrite (member_LT x' x r).
move=> ?. rewrite is_member=> /or3P[/eqP ->| xtl | xr].
- by rewrite (member_GT x' y l) ?eq //; apply: minint.
- by rewrite IHl.
rewrite (bstlr l r x' y x) //= eq; first by apply/and4P; split.
by apply minint.
Qed.

Lemma delisbst x t (bst : BSTOrder t) : BSTOrder (delete x t).
Proof.
elim: t bst=> //= l IHl y r IHr /and4P[GTl LTr BSl BSr].
case: ltgtP=> xy /=.
- rewrite LTr BSr IHl //= andbT GTeq=> y' ydl.
  move: (GTeq y l) GTl=>->-> //. by rewrite (delwasinsbt y' x l).
- rewrite GTl BSl IHr //= andbT LTeq=> y' ydr.
  move: (LTeq y r) LTr=>->-> //. by rewrite (delwasinsbt y' x r).
case eq: (r)=> [| l' y' r'] //.
have: exists m, omin (T l' y' r') = Some m.
- by apply: nonemptymin.
move=> [m min]. rewrite min /= BSl stillbst //; last by rewrite -eq.
move=> /=. apply/and3P; split=> //.
- rewrite (GTL y m l) // GTl andbT.
  have: m \in r.
  - by apply: minint; rewrite eq.
  move=> mr. rewrite ltW //. move: (LTeq y r)=> [H1 H2]. by apply: H1.
rewrite LTeq=> z ytr. by rewrite (abs_min z m r) // eq.
Qed.

End BinSearchTree.
End BST.


From Coq Require Import List FinFun.
Import ListNotations.

From CasperCBC Require Import Preamble ListExtras.

(** * Finite function utility definitions and lemmas *)

Lemma map_option_listing
      {A B : Type} (f: A -> option B) (g: B -> A)
      (f_proj_inj: forall a b, f a = Some b -> a = g b)
      (f_surj: forall b, f (g b) = Some b)
      (A_listing: list A) (A_finite : Listing A_listing) : Listing (map_option f A_listing).
Proof.
  destruct A_finite as [Hnodup Hfull].
  split.
  - clear Hfull.
    induction A_listing as [|a l IHl].
    + constructor.
    + inversion_clear Hnodup as [|? ? H1 H2].
      specialize (IHl H2); clear H2.
      simpl.
      destruct (f a) eqn:Hfa;[|assumption].
      apply f_proj_inj in Hfa. subst a.
      constructor;[|assumption].
      contradict H1.
      apply in_map_option in H1.
      destruct H1 as [a [Ha Hfa]].
      apply f_proj_inj in Hfa.
      subst a.
      assumption.
  - intro b.
    specialize (Hfull (g b)).
    apply in_map_option.
    exists (g b).
    split;[assumption|].
    apply f_surj.
Qed.

Section sum_listing.
(** 'Listing' for the sum type implies 'Listing' for each projection *)

Context
  {Left Right : Type}
  {sum_listing : list (Left + Right)}
  .

Definition left_listing
  (sum_finite : Listing sum_listing)
  : list Left
  := list_sum_project_left sum_listing.

Definition right_listing
  (sum_finite : Listing sum_listing)
  : list Right
  := list_sum_project_right sum_listing.

Lemma left_finite
  (sum_finite : Listing sum_listing)
  : Listing (left_listing sum_finite).
Proof.
  revert sum_finite.
  apply map_option_listing with (g:=inl).
  destruct a;simpl;congruence.
  reflexivity.
Qed.

Lemma right_finite
  (sum_finite : Listing sum_listing)
  : Listing (right_listing sum_finite).
Proof.
  revert sum_finite.
  apply map_option_listing with (g:=inr).
  destruct a;simpl;congruence.
  reflexivity.
Qed.

End sum_listing.


Require Import HoTT.
Require Import structures.

Local Open Scope list_scope.
Notation "[]" := nil : list_scope.

Module ListHelpers.

Definition tl {A} (l:list A) :=
  match l with
    | nil => nil
    | a :: m => m
  end.

Fixpoint onth {A : Type} (l:list A) (n:nat) {struct n} : option A :=
  match n, l with
    | O, x :: _ => Some x
    | S n, _ :: l => onth l n
    | _, _ => None
  end.

Definition nil_cons {A} {x:A} {l:list A} : [] <> x :: l  :=
  fun eq =>
    @paths_rec _ [] (fun l => match l with [] => _ | _ => _ end) tt _ eq.

Lemma cons_inj {A} {x y : A} {l k} : x :: l = y :: k -> x = y /\ l = k.
Proof.
intro eq.
split.
- exact (ap (fun a => match a with [] => x | z :: _ => z end) eq).
- exact (ap (fun a => match a with [] => [] | _ :: z => z end) eq).
Defined.

End ListHelpers.
Import ListHelpers.

Module NEList.
Export Magma.

Inductive NEList (A : Type) : Type :=
  | single : A -> NEList A
  | cons : A -> NEList A -> NEList A
.
Arguments single {_} _.
Arguments cons {_} _ _.

Fixpoint Napp {A} (l l' : (NEList A)) : (NEList A) :=
  match l with
    | single i => cons i l'
    | cons i l => cons i (Napp l l')
    end.

Section VarSec.

Context {A} {G : Gop A}.

Definition someOp : Gop (option A) := fun a b => match a,b with
  | Some x, Some y => Some (gop x y)
  | _, _ => None
  end.

Fixpoint evalNE {B} (f : B -> option A) (l : (NEList B))
 : option A := match l with
    | cons i l => someOp (f i) (evalNE f l)
    | single i => f i
    end.

Global Instance someOp_assoc : forall {Hassoc : Associative G},
Associative someOp.
Proof.
red. destruct x,y,z;simpl;auto.
unfold gop;simpl. apply ap;apply Hassoc.
Defined.

Global Instance someOp_comm : forall {Hcomm : Commutative G},
Commutative someOp.
Proof.
red;destruct x,y;simpl;auto.
apply (ap (@Some _));apply Hcomm.
Defined.

Lemma evalNE_app : forall {Hassoc : Associative G},
  forall {B} (f : B -> option A) l l',
  evalNE f (Napp l l') = someOp (evalNE f l) (evalNE f l').
Proof.
induction l;intros;simpl in *.
reflexivity.
path_via (someOp (f a) (someOp (evalNE f l) (evalNE f l'))).
apply ap. apply IHl.
apply someOp_assoc.
Defined.

Lemma NEList_eq_dec : DecidablePaths A ->
 DecidablePaths (NEList A).
Proof.
red. intros Ha.
induction x;destruct y.
destruct (Ha a a0);[left|right].
apply ap;assumption.
exact (fun H => n (ap (fun s => match s with
  | single x => x | _ => a end) H)).
right;exact (fun H => transport (fun s => match s with
  | single _ => Unit | _ => Empty end) H tt).
right;exact (fun H => transport (fun s => match s with
  | single _ => Empty | _ => Unit end) H tt).
destruct (Ha a a0).
destruct (IHx y).
left;apply ap11;[apply ap|];assumption.
right;exact (fun H => n (ap (fun s => match s with
  | cons _ z => z | single _ => x end) H)).
right;exact (fun H => n (ap (fun s => match s with
  | cons z _ => z | _ => a end) H)).
Defined.

End VarSec.

Section Sort.

Context {A : Type}.
Variable order_dec : A -> A -> Bool.

Fixpoint sortInsert i l := match l with
  | single j => if order_dec i j
    then cons i (single j)
    else cons j (single i)
  | cons j l => if order_dec i j
    then cons i (cons j l)
    else cons j (sortInsert i l)
  end.

Fixpoint sort l := match l with
  | single i => single i
  | cons i l => sortInsert i (sort l)
  end.

Lemma sortInsert_correct : forall {B} {G:Gop B} {Hsg : IsSemigroup G},
forall (f : A -> option B) i l,
 evalNE f (sortInsert i l) = evalNE f (cons i l).
Proof.
simpl. induction l.
- simpl. destruct (order_dec i a);simpl;first [reflexivity | apply someOp_comm].
- simpl. destruct (order_dec i a);simpl.
  reflexivity.
  path_via (someOp (f a) (someOp (f i) (evalNE f l))).
  apply ap. assumption.
  path_via (someOp (someOp (f a) (f i)) (evalNE f l)).
  apply someOp_assoc.
  path_via (someOp (someOp (f i) (f a)) (evalNE f l)).
  apply ap10. apply ap. apply someOp_comm.
  apply inverse;apply someOp_assoc.
Defined.

Lemma sort_correct : forall {B} {G:Gop B} {Hsg : IsSemigroup G},
  forall (f : A -> option B) l, evalNE f (sort l) = evalNE f l.
Proof.
induction l;simpl.
- reflexivity.
- eapply concat.
  apply sortInsert_correct. simpl.
  apply ap. assumption.
Defined.

End Sort.

Arguments sort_correct {_} _ {_ _ _} _ _.

Definition nat_order_dec : nat -> nat -> Bool.
Proof.
intros n;induction n;intros m.
- (*0 < m *) destruct m;[exact false | exact true].
- (* S n < m *) destruct m.
  (* S n < 0 *) exact false.
  (* S n < S m *) exact (IHn m).
Defined.

Definition NEList_order_dec : forall {A} (order_dec : A -> A -> Bool),
forall l l' : NEList A, Bool.
Proof.
intros ? ? l;induction l as [x | x l];intro l';destruct l' as [y | y l'].
- (* [x] < [y] *) exact (order_dec x y).
- (* [x] < y::l', l' # [] *) exact (negb (order_dec y x)).
- (* x::l < [y], l # [] *) exact (negb (order_dec x y)).
- (* x::l < y::l', IHl is l < _ *) exact (orb (order_dec x y)
                             (andb (negb (order_dec y x)) (IHl l'))).
Defined.

Definition NEList_nat_order_dec := NEList_order_dec nat_order_dec.

End NEList.

Export NEList.

Module BinOpTree.
(*Import ListNotations.*)

Inductive T (A : Type) : Type :=
  | Op : T A -> T A -> T A
  | Val : A -> T A
.

Arguments Op {_} _ _.
Arguments Val {_} _.

Fixpoint evalTree {A} {G:Gop A} {B} (f : B -> option A) (t : T B) : option A :=
  match t with
    | Op t1 t2 => someOp (evalTree f t1) (evalTree f t2)
    | Val i => f i
    end.

Section Nota.

Fixpoint T2list {A} (t : T A) : (NEList A) :=
  match t with
    | Op t1 t2 => Napp (T2list t1) (T2list t2)
    | Val i => single i
    end.

Lemma T2list_correct : forall {A} {G : Gop A} {Hassoc : Associative G}
{B} (f : B -> option A) t, evalNE f (T2list t) = evalTree f t.
Proof.
induction t.
- simpl. path_via (someOp (evalNE f (T2list t1))
                  (evalNE f (T2list t2))).
  apply evalNE_app.
  apply ap11;[apply ap|];assumption.
- simpl. reflexivity.
Defined.

Section SortUse.

Context {A} {G : Gop A} {Hsg : IsSemigroup G}.
Context {B} {order_dec : B -> B -> Bool}.

Lemma sort_full : forall (f : B -> option A) t,
    evalNE f (sort order_dec (T2list t)) = evalTree f t.
Proof.
intros.
path_via (evalNE f (T2list t)).
apply sort_correct. assumption.
apply T2list_correct.
Defined.

Lemma sort_inj : forall (f : B -> option A) t1 t2,
 evalNE f (sort order_dec (T2list t1)) = evalNE f (sort order_dec (T2list t2)) ->
  evalTree f t1 = evalTree f t2.
Proof.
intros ? ? ? H. eapply concat;[symmetry;apply sort_full|].
eapply concat;[apply H|]. apply sort_full.
Defined.

End SortUse.

Section Prefix.

Context {A : Type}.

(* prefix stuff should be moved so that it may work for types not in magmas *)
Inductive prefix : relation (list A) :=
  | pref_nil : forall l, prefix nil l
  | pref_cons : forall l l', prefix l l' -> forall x, prefix (x::l) (x::l')
.

Instance prefix_refl : Reflexive prefix.
Proof.
red. intro l;induction l;constructor;auto.
Defined.

Lemma cons_pref : forall x l l', prefix (x::l) l' ->
(l' = x::(tl l') /\ prefix l (tl l')).
Proof.
assert (H : forall l l', prefix l l' -> forall x l1, l = x::l1 ->
l' = x::(tl l') /\ prefix l1 (tl l')).
intros ? ? H;induction H.
- intros ? ? H.
  destruct (nil_cons H).
- intros ? ? H0.
  apply cons_inj in H0.
  destruct H0 as [H0 H1]; destruct H0; destruct H1. simpl. split;auto.
- intros. apply H with (x::l);auto.
Defined.

Global Instance prefix_trans : Transitive prefix.
Proof.
red. intros l1 l2 l3 H H'.
revert H'. revert l3.
induction H.
- constructor.
- intros l3 H'. apply cons_pref in H'. destruct H' as [H0 H1].
  destruct l3;simpl in *. destruct (nil_cons H0).
  apply cons_inj in H0. destruct H0 as [H0 _]; destruct H0.
  constructor. auto.
Defined.

Lemma app_prefix : forall l l', prefix l (l++l').
Proof.
induction l;intros;constructor;auto.
Defined.

Lemma prefix_app : forall l l', prefix l l' -> exists l0, l' = l++l0.
Proof.
induction 1 as [| ? ? ? IH].
econstructor;reflexivity.
destruct IH as [? p]. econstructor. simpl; apply ap. apply p.
Defined.

Lemma prefix_nth : forall l l', prefix l l' ->
 forall i v, onth l i = Some v -> onth l' i = Some v.
Proof.
intros ? ? H;induction H.
- intros ? ? H;intros.
  destruct i;simpl in H;destruct (transport (fun s => match s with
    | None => Unit | _ => Empty end) H tt).
- intros ? ? H'. destruct i. apply H'.
  apply IHprefix. apply H'.
Defined.

Global Instance prefix_antisymm : Relation.Antisymmetric prefix.
Proof.
intros ? ? H;induction H;intros H'.
destruct l;auto.
apply cons_pref in H'. destruct H' as [H _].
destruct (nil_cons H).
apply cons_pref in H'. destruct H' as [_ H'].
simpl in *. apply ap. auto.
Defined.

End Prefix.

Arguments prefix_trans {_ _ _ _} _ _.

Section XFind.

Variable A : Type.

Definition invariant s r i (e : A) := onth r i = Some e /\ prefix s r.

(* Tagging for controlling the search of instances *)
Structure xtagged := XTag {xuntag :> A}.

Definition extend_tag := XTag.
Definition recurse_tag := extend_tag.
Canonical Structure found_tag x := recurse_tag x.

(* Main structure
   s : input sequence
   r : output sequence. If elem_of is in the sequence, then it's equal to s,
       otherwise it's equal to (elem_of :: s)
   i : output index of elem_of in r *)
Structure xfind (s r : list A) (i : nat) := XFind {
  elem_of :> xtagged;
  x_nth :> onth r i = @Some A elem_of;
  x_prefix :> prefix s r
}.

(*Implicit Arguments XFind [].*)

Canonical Structure found_struct x t :=
  XFind (x :: t) (x :: t) 0 (found_tag x) (idpath) (prefix_refl _).

Lemma recurse_pf {i : nat} (y : A) {s r : list A} (f : xfind s r i) :
        invariant (y :: s) (y :: r) (S i) f.
Proof. red.
simpl. split. apply f.
constructor. apply f.
Defined.

Canonical Structure recurse_struct i y t r (f : xfind t r i) :=
  XFind (y :: t) (y :: r) (S i) (recurse_tag f) f (pref_cons _ _ f _).

Canonical Structure extend_struct x :=
  XFind [] (x :: []) 0 (extend_tag x) idpath (pref_nil _).

End XFind.

Arguments elem_of {_ _ _ _} _.
Arguments xuntag {_} _.
Arguments xfind {_} _ _ _.

Section Ast.

Context {A : Type} {G : Gop A}.

Structure tagged := Tag { untag :> A }.

Definition ctx := list A.

Inductive valid : ctx -> T nat -> Type :=
  | valid_op : forall c t1, valid c t1 -> forall t2, valid c t2 ->
                valid c (Op t1 t2)
  | valid_val : forall c i v (Hv : onth c i = Some v),
                valid c (Val i).

Arguments valid_op {_ _} _ {_} _.
Arguments valid_val {_ _ _} _.

Lemma valid_prefix : forall c t, valid c t -> forall c', prefix c c' ->
  valid c' t.
Proof.
intros ? ? H;induction H;intros ? H'.
constructor;auto.
econstructor.
eapply prefix_nth. apply H'. apply Hv.
Defined.

Arguments valid_prefix {_ _} _ {_} _.

Lemma valid_prefix_eval : forall c t, valid c t ->
forall c', prefix c c' ->
 evalTree (onth c) t = evalTree (onth c') t.
Proof.
intros ? ? H;induction H;intros ? H';simpl in *.
apply ap11;[apply ap;apply IHvalid1|apply IHvalid2];auto.
path_via (Some v).
symmetry;eapply prefix_nth. apply H'. assumption.
Defined.

Lemma valid_ext : forall c t, valid c t ->
  sigT (fun v => evalTree (onth c) t = Some v).
Proof.
intros ? ? H;induction H.
destruct IHvalid1 as [v1 H1].
destruct IHvalid2 as [v2 H2].
exists (gop v1 v2). simpl.
path_via (someOp (Some v1) (Some v2)).
intros;apply ap11;[apply ap|];auto.
simpl. exists v;assumption.
Defined.

Arguments valid_ext {_ _} _.

Lemma ext_valid : forall c t v, evalTree (onth c) t = Some v -> valid c t.
Proof.
induction t;intros ? H.
simpl in H. destruct (evalTree (onth c) t1), (evalTree (onth c) t2);
 try solve [destruct
(transport (fun s => match s with | None => Unit | _ => Empty end) H tt)].
constructor;eauto.
eapply valid_val. apply H.
Defined.

Lemma prefix_eval : forall c c', prefix c c' -> forall t (v : A),
evalTree (onth c) t = Some v -> evalTree (onth c') t = Some v.
Proof.
intros. path_via (evalTree (onth c) t).
symmetry. apply valid_prefix_eval.
apply ext_valid with v. assumption.
assumption.
Defined.

Structure ast (c c' : ctx) (t : T nat) := Ast {
val :> tagged;
ast_prefix :> prefix c c';
ast_pr :> evalTree (onth c') t = @Some A val
}.

Arguments ast_prefix {_ _ _} _.
Arguments val {_ _ _} _.

Definition var_tag t := Tag t.
Canonical Structure op_tag t := var_tag t.

Lemma ast_pr_op : forall {i j k : ctx} {t1 t2 : T nat}
 (a1 : ast i j t1) (a2 : ast j k t2),
        evalTree (onth k) (Op t1 t2) = @Some A (op_tag (G a1 a2)).
Proof.
intros ? ? ? ? ? ? ?.
change (someOp (evalTree (onth k) t1) (evalTree (onth k) t2) =
   someOp (@Some A a1) (@Some A a2)).
apply ap11;[apply ap|].
eapply prefix_eval. apply a2. apply a1.
apply a2.
Defined.

Canonical Structure ast_op (i j k : ctx) (t1 t2 : T nat)
 (a1 : ast i j t1) (a2 : ast j k t2) :=
  Ast i k (Op t1 t2) (op_tag (G a1 a2)) (prefix_trans a1 a2)
   (ast_pr_op a1 a2).

Canonical Structure ast_var (i j : ctx) (n : nat) (f : xfind i j n) :=
  Ast i j (Val n) (var_tag (xuntag (elem_of f))) f f.

Lemma untag_injective : forall x y, untag x = untag y -> x=y.
Proof.
intros. destruct x,y.
apply ap;assumption.
Defined.

Context {Hsg : IsSemigroup G}.

Definition someRel {T T' : Type} (R : T -> T' -> Type)
 : option T -> option T' -> Type := fun x y => match x,y with
    | Some a, Some b => R a b
    | _, _ => Empty
    end.

Lemma some_injective : forall {T T' : Type} (R : T -> T' -> Type)
 x y, someRel R (Some x) (Some y) -> R x y.
Proof.
intros ? ? ? ? ? H.
apply H.
Defined.

Lemma ast_use : forall (R : relation A) {i j : ctx} {t1 t2 : T nat}
 (f1 : ast [] i t1) (f2 : ast i j t2),
  someRel R (evalNE (onth j) (sort nat_order_dec (T2list t1)))
            (evalNE (onth j) (sort nat_order_dec (T2list t2))) ->
  R (untag (val f1)) (untag (val f2)).
Proof.
intros ? ? ? ? ? ? ? H.
apply some_injective.
pattern (Some (untag (val f1)));eapply transport;[|eapply transport;[|apply H]];
(eapply concat;[apply sort_full|]);[eapply prefix_eval;[apply f2|apply f1]|apply f2].
Defined.

End Ast.

End Nota.

Ltac ssrapply l :=
first
[refine l
|refine (l _)
|refine (l _ _)
|refine (l _ _ _)
|refine (l _ _ _ _)
|refine (l _ _ _ _ _)
|refine (l _ _ _ _ _ _)
|refine (l _ _ _ _ _ _ _)
|refine (l _ _ _ _ _ _ _ _)
].

End BinOpTree.

Module Distributive.
Export BinOpTree.
Export Ring.

Inductive T2 : Type :=
  | Plus : T2 -> T2 -> T2
  | Mult : T2 -> T2 -> T2
  | Val2 : nat -> T2
.

Definition somePlus {A} {G : Symbols.Plus A} : Symbols.Plus (option A) := someOp.
Definition someMult {A} {G : Symbols.Mult A} : Symbols.Mult (option A) := someOp.

Fixpoint evalT2 {A} {G : Prering A} (f : _ -> option A) (t : T2) : option A :=
match t with
  | Plus x y => somePlus (evalT2 f x) (evalT2 f y)
  | Mult x y => someMult (evalT2 f x) (evalT2 f y)
  | Val2 i => f i
  end.

Notation Flat2 := (T (NEList nat)).

Notation FPlus := (@Op (NEList nat)).
Notation ValL  := (@Val (NEList nat)).

Definition evalFlat2 {A} {G : Prering A} (f : nat -> option A) (t : Flat2)
 : option A := @evalTree A (+) _
          (fun l => @evalNE _ (°) _ f l) t.

(* eval (distribute t1 t2) = (eval t1) * (eval t2) *)
Fixpoint distribute (t1 : Flat2) : Flat2 -> Flat2 := fix f (t2 : Flat2) :=
match t1, t2 with
  | Op x y, Op x' y' => FPlus (f x') (f y')
  | Op x y, Val l' => FPlus (distribute x (ValL l')) (distribute y (ValL l'))
  | Val l', Op x y => FPlus (f x) (f y)
  | Val l1, Val l2 => ValL (Napp l1 l2)
  end.

Fixpoint flatten (t : T2) : Flat2 := match t with
  | Plus x y => FPlus (flatten x) (flatten y)
  | Mult x y => distribute (flatten x) (flatten y)
  | Val2 i => ValL (single i)
  end.

Fixpoint Flat2_order_in (t : Flat2) : Flat2 := match t with
  | Op x y => Op (Flat2_order_in x) (Flat2_order_in y)
  | Val l => Val (sort nat_order_dec l)
  end.

Section Mag2.

Context {A} {G : Prering A}.
Context {Hadd : @IsSemigroup A (+)} {Hmult : @IsSemigroup A (°)}
 {Hdistrib : Distributes G}.

Lemma some_distrib_right : forall a b c : option A,
someMult (somePlus b c) a = somePlus (someMult b a) (someMult c a).
Proof.
destruct a,b,c;try reflexivity.
simpl. apply ap. apply Hdistrib.
Defined.

Lemma some_distrib_left :  forall a b c : option A,
someMult a (somePlus b c) = somePlus (someMult a b) (someMult a c).
Proof.
destruct a,b,c;try reflexivity.
simpl. apply ap. apply Hdistrib.
Defined.

Local Open Scope type_scope.

Lemma distribute_ok : forall (f : _ -> option A) t1 t2,
evalFlat2 f (distribute t1 t2) = someMult (evalFlat2 f t1) (evalFlat2 f t2).
Proof.
assert (Hleft : forall (f : _ -> option A) l x,
 evalFlat2 f (distribute x (ValL l)) =
someMult (evalFlat2 f x) (evalFlat2 f (ValL l))).
intros f l. simpl.
assert (X:(sigT (fun v => evalFlat2 f (ValL l) = Some v))
   + (evalFlat2 f (ValL l) = None)).
destruct (evalFlat2 f (ValL l));eauto.
destruct X as [[g Hl] | Hl];pattern (evalFlat2 f (ValL l));
apply (transport _ (inverse Hl)).
- induction x.
  simpl. path_via (someMult (somePlus (evalFlat2 f x1) (evalFlat2 f x2))
    (Some g)).
  destruct (evalFlat2 f x1);[destruct (evalFlat2 f x2)|].
  simpl. eapply concat.
  apply (@ap11 _ _ (somePlus (evalFlat2 f (distribute x1 (ValL l)))))
  ;[apply ap;apply IHx1|apply IHx2].
  simpl;apply ap;symmetry;apply Hdistrib.
  simpl. simpl in IHx2. path_via (somePlus (evalFlat2 f (distribute x1 (ValL l)))
    (evalFlat2 f (distribute x2 (ValL l)))).
  pattern (evalFlat2 f (distribute x2 (ValL l)));
  apply (transport _ (inverse IHx2)).
  destruct (evalFlat2 f (distribute x1 (ValL l)));reflexivity.
  simpl. simpl in IHx1. path_via (somePlus (evalFlat2 f (distribute x1 (ValL l)))
    (evalFlat2 f (distribute x2 (ValL l)))).
  pattern (evalFlat2 f (distribute x1 (ValL l)));
  apply (transport _ (inverse IHx1)). simpl. reflexivity.
  simpl. unfold someMult. eapply concat;[apply @evalNE_app|]. apply _.
  apply ap. apply Hl.

- induction x.
  simpl. path_via (somePlus (evalFlat2 f (distribute x1 (ValL l)))
    (evalFlat2 f (distribute x2 (ValL l)))).
  path_via (someMult (somePlus (evalFlat2 f x1) (evalFlat2 f x2)) None).
  destruct (evalFlat2 f x1), (evalFlat2 f x2);
  simpl in *; (path_via (@somePlus A _ None None);
  apply ap11;[apply ap|];assumption).
  simpl.
  eapply concat. apply (@evalNE_app A (°)). apply _.
  apply ap. assumption.

(* Hleft done *)
- intros l t1 t2;revert t1.
  induction t2;auto.
  induction t1.
  path_via (somePlus (evalFlat2 l (distribute (FPlus t1_1 t1_2) t2_1))
    (evalFlat2 l (distribute (FPlus t1_1 t1_2) t2_2))).
  pattern (evalFlat2 l (distribute (FPlus t1_1 t1_2) t2_2)).
  eapply transport. symmetry;apply IHt2_2.
  pattern (evalFlat2 l (distribute (FPlus t1_1 t1_2) t2_1)).
  eapply transport. symmetry;apply IHt2_1.
  path_via (somePlus (someMult (somePlus (evalFlat2 l t1_1) (evalFlat2 l t1_2))
     (evalFlat2 l t2_1))
  (someMult (somePlus (evalFlat2 l t1_1) (evalFlat2 l t1_2)) (evalFlat2 l t2_2))).
  path_via (someMult (somePlus (evalFlat2 l t1_1) (evalFlat2 l t1_2))
    (somePlus (evalFlat2 l t2_1) (evalFlat2 l t2_2))).
  repeat first [rewrite some_distrib_left | rewrite some_distrib_right].
  reflexivity.

  path_via (somePlus
    (someMult (evalFlat2 l (ValL a)) (evalFlat2 l t2_1))
    (someMult (evalFlat2 l (ValL a)) (evalFlat2 l t2_2))).
  path_via (somePlus (evalFlat2 l (distribute (ValL a) t2_1))
    (evalFlat2 l (distribute (ValL a) t2_2))).
  apply ap11;[apply ap|]; auto.
  symmetry. apply some_distrib_left.
Defined.

Lemma flatten_ok : forall (l : _ -> option A) t,
 evalFlat2 l (flatten t) = evalT2 l t.
Proof.
induction t.
simpl. path_via (somePlus (evalFlat2 l (flatten t1)) (evalFlat2 l (flatten t2))).
 apply ap11;[apply ap|];assumption.
simpl. eapply concat;[apply distribute_ok|].
apply ap11;[apply ap|];assumption.
reflexivity.
Defined.

Lemma order_in_ok : forall (f : _ -> option A) t,
 evalFlat2 f (Flat2_order_in t) = evalFlat2 f t.
Proof.
induction t.
path_via (somePlus (evalFlat2 f (Flat2_order_in t1))
 (evalFlat2 f (Flat2_order_in t2))).
path_via (somePlus (evalFlat2 f t1) (evalFlat2 f t2)).
apply ap11;[apply ap|];assumption.
unfold evalFlat2;simpl. apply (@sort_correct _ _ A (°)). exact _.
Defined.

End Mag2.

Section Ast2.

Context {A} {G : Prering A}.

(*note: cannot reuse BinOpTree.tagged because its canonical projections would override our new ones *)
Structure tagged := Tag { untag :> A }.

Lemma prefix_eval2 : forall c c', prefix c c' -> forall (t : T2) (v : A),
evalT2 (onth c) t = Some v -> evalT2 (onth c') t = Some v.
Proof.
induction t;intros.
- simpl in *.
  destruct (evalT2 (onth c) t1) as [v1 |];
  [destruct (evalT2 (onth c) t2) as [v2 |]|].
  eapply concat;[|apply X0]. apply ap11;[apply ap|];auto.
  simpl in X0. destruct (transport (fun s => match s with
    | None => Unit | _ => Empty end) X0 tt).
  simpl in X0. destruct (transport (fun s => match s with
    | None => Unit | _ => Empty end) X0 tt).
- simpl in *.
  destruct (evalT2 (onth c) t1) as [v1 |];
  [destruct (evalT2 (onth c) t2) as [v2 |]|].
  eapply concat;[|apply X0]. apply ap11;[apply ap|];auto.
  simpl in X0. destruct (transport (fun s => match s with
    | None => Unit | _ => Empty end) X0 tt).
  simpl in X0. destruct (transport (fun s => match s with
    | None => Unit | _ => Empty end) X0 tt).
- simpl in *. eapply prefix_nth;eauto.
Defined.

Structure ast2 (c c' : ctx) (t : T2) := Ast2 {
val2 :> tagged;
ast2_prefix :> prefix c c';
ast2_pr :> evalT2 (onth c') t = Some (untag val2)
}.

Arguments ast2_prefix {_ _ _} _.
Arguments val2 {_ _ _} _.

Definition var_tag (t:A) := Tag t.
Definition mult_tag (t:A) := var_tag t.
Canonical Structure plus_tag (t:A) := mult_tag t.

Lemma ast2_pr_plus : forall {i j k : ctx} {t1 t2 : T2}
 (a1 : ast2 i j t1) (a2 : ast2 j k t2),
        evalT2 (onth k) (Plus t1 t2)
        = Some (untag (plus_tag (untag a1 + untag a2))).
Proof.
intros ? ? ? ? ? ? ?.
change (somePlus (evalT2 (onth k) t1) (evalT2 (onth k) t2) =
   somePlus (Some (untag a1)) (Some (untag a2))).
apply ap11;[apply ap|].
apply prefix_eval2 with j. apply a2. apply a1.
apply a2.
Defined.

Canonical Structure ast2_plus (i j k : ctx) (t1 t2 : T2)
 (a1 : ast2 i j t1) (a2 : ast2 j k t2) :=
  Ast2 i k (Plus t1 t2) (plus_tag ((untag a1) + (untag a2)))
   (prefix_trans _ _ _ a1 a2) (ast2_pr_plus a1 a2).

Lemma ast2_pr_mult : forall {i j k : ctx} {t1 t2 : T2}
 (a1 : ast2 i j t1) (a2 : ast2 j k t2),
        evalT2 (onth k) (Mult t1 t2)
        = Some (untag (mult_tag ((untag a1) ° (untag a2)))).
Proof.
intros ? ? ? ? ? ? ?.
change (someMult (evalT2 (onth k) t1) (evalT2 (onth k) t2) =
   someMult (Some (untag a1)) (Some (untag a2))).
apply ap11;[apply ap|].
apply prefix_eval2 with j. apply a2. apply a1.
apply a2.
Defined.

Canonical Structure ast2_mult (i j k : ctx) (t1 t2 : T2)
 (a1 : ast2 i j t1) (a2 : ast2 j k t2) :=
  Ast2 i k (Mult t1 t2) (mult_tag ((untag a1) ° (untag a2)))
   (prefix_trans _ _ _ a1 a2) (ast2_pr_mult a1 a2).

Canonical Structure ast2_var (i j : ctx) (n : nat) (f : xfind _ i j n) :=
  Ast2 i j (Val2 n) (var_tag (xuntag _ (elem_of _ _ _ _ f))) f f.

Section Minimal.

Context {Hadd : @IsSemigroup A (+)} {Hmult : @IsSemigroup A (°)}
 {Hdistrib : Distributes G}.

Lemma ast2_use : forall R {i j : ctx} {t1 t2 : T2}
 (f1 : ast2 [] i t1) (f2 : ast2 i j t2),
  someRel R (evalFlat2 (onth j) (Flat2_order_in (flatten t1)))
            (evalFlat2 (onth j) (Flat2_order_in (flatten t2))) ->
  R (untag (val2 f1)) (untag (val2 f2)).
Proof.
intros ? ? ? ? ? ? ? H.
apply some_injective.
pattern (Some (untag (val2 f1)));eapply transport;[|eapply transport;[|apply H]];
(eapply concat;[ apply order_in_ok|
eapply concat;[ apply flatten_ok|]]).
eapply prefix_eval2. apply f2. apply f1.
apply f2.
Defined.

End Minimal.

Lemma ast2_semiring : forall {Hsemir : IsSemiring G},
forall R {i j : ctx} {t1 t2 : T2}
 (f1 : ast2 [] i t1) (f2 : ast2 i j t2),
  someRel R (evalFlat2 (onth j) (Flat2_order_in (flatten t1)))
            (evalFlat2 (onth j) (Flat2_order_in (flatten t2))) ->
  R (untag (val2 f1)) (untag (val2 f2)).
Proof.
intro.
apply @ast2_use;apply _.
Defined.

Definition full_simplify (t : T2) :=
  sort NEList_nat_order_dec (T2list (Flat2_order_in (flatten t))).

Lemma ast2_full_semiring : forall {Hsemir : IsSemiring G},
forall R {i j : ctx} {t1 t2 : T2}
 (f1 : ast2 [] i t1) (f2 : ast2 i j t2),
  someRel R (@evalNE A (+) _ (fun l => @evalNE A (°) _ (onth j) l)
               (full_simplify t1))
            (@evalNE A (+) _ (fun l => @evalNE A (°) _ (onth j) l)
               (full_simplify t2))
  -> R (untag (val2 f1)) (untag (val2 f2)).
Proof.
intros ? ? ? ? ? ? ? ? H.
apply (ast2_semiring R).
unfold evalFlat2.
eapply transport;[|pattern (@evalTree A (@plus A G) (NEList nat)
     (fun l : NEList nat => @evalNE A (@mult A G) nat (onth j) l)
     (Flat2_order_in (flatten t1))); eapply transport;[|apply H]];
(unfold full_simplify;
eapply concat;[ apply sort_correct; apply _|
apply T2list_correct]).
Defined.

End Ast2.

Lemma test2 : forall A (G : Prering A) {Hsemir : IsSemiring G},
forall a b c : A, a°(b+c) = a°c + a°b.
Proof.
intros.
refine (@ast2_full_semiring A _ Hsemir paths _ _ _ _ _ _ _).
reflexivity.
Fail idtac.
Abort.

End Distributive.