Require Export Reals.
Require Export projective_plane_axioms.
Require Export Bool.
Require Export field_variable_isolation_tactic.
Require Export Setoid.
Require Export Nsatz.

Open Scope R_scope.

Lemma R_eq_dec: forall r1 r2 : R, {r1 <> r2} + {r1 = r2}.
Proof.
intros.
elim (Req_EM_T r1 r2);intuition.
Qed.

Lemma zero_neq_minus_one : 0 <> -(1).
Proof.
auto with real.
Qed.

Hint Resolve zero_neq_minus_one : field_hints.

Lemma one_not_two : 1 <> 2.
Proof.
discrR.
Qed.

Hint Resolve one_not_two : field_hints.

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

Module HomogenousCoords : ProjectivePlane'.

Inductive IndPoint : Set :=
 | P2 : R -> R -> IndPoint (* (x1,x2,1) *)
 | P1 : R -> IndPoint (* (x1,1,0) *)
 | P0 : IndPoint. (* (1,0,0) *)

Inductive IndLine : Set :=
 | L2 : R -> R -> IndLine (* (x1,x2,1) *)
 | L1 : R -> IndLine (* (x1,1,0) *)
 | L0 : IndLine. (* (1,0,0) *)

Definition Point : Set := IndPoint.
Definition Line    : Set := IndLine.

Definition triple_of_point  P :=
 match P with
  P2 a b => (a,b,1)
| P1 a    => (a,1,0)
| P0       => (1,0,0)
end.

Definition triple_of_line  L :=
 match L with
  L2 a b => (a,b,1)
| L1 a    => (a,1,0)
| L0       => (1,0,0)
end.

Definition point_of_triple t :=
 match t with (a,b,c) =>
  if (R_eq_dec c 0) then P2 (a/c) (b/c) else
  (if (R_eq_dec b 0) then P1 (a/b) else
  P0)
end.

Definition line_of_triple t :=
 match t with (a,b,c) =>
  if (R_eq_dec c 0) then L2 (a/c) (b/c) else
  (if (R_eq_dec b 0) then L1 (a/b) else
  L0)
end.

Lemma triple_point : forall P : Point, point_of_triple (triple_of_point P) = P.
Proof.
intros.
unfold point_of_triple, triple_of_point.
assert (1<>0).
auto with real.
elim P;intros.
elim (R_eq_dec 1 0);intros.
replace (r/ 1) with r.
replace (r0/ 1) with r0.
auto.
field.
field.
intuition.
elim (R_eq_dec 0 0);intro;intuition.
elim (R_eq_dec 1 0);intro;intuition.
replace (r/ 1) with r.
auto.
field.
elim (R_eq_dec 0 0);intro;intuition.
Qed.

Lemma point_triple : forall a b c : R, (a,b,c) <> (0,0,0) ->
exists l, l <> 0 /\ triple_of_point (point_of_triple (a,b,c)) = (a*l,b*l,c*l).
Proof.
intros.
unfold point_of_triple, triple_of_point.
elim (R_eq_dec c 0);intro.
exists (1/c).
split.
unfold not;intro.
assert (1 / c * c = 0 * c).
rewrite H0.
ring.
replace (1 / c * c) with (1) in H1.
ring_simplify in H1.
intuition.
field;assumption.

replace (a * (1 / c)) with (a/c).
replace (b * (1 / c)) with (b/c).
replace ( c * (1 / c)) with 1.
auto.
field;assumption.
field;assumption.
field;assumption.
elim (R_eq_dec b 0);intro.
exists (1/b).
split.

unfold not;intro.
assert (1 / b * b = 0 * b).
rewrite H0.
ring.
replace (1 / b * b) with (1) in H1.
ring_simplify in H1.
intuition.
field;assumption.

rewrite b0.
replace (b * (1 / b)) with 1.
replace (0 * (1 / b)) with 0.
replace (a * (1 / b)) with (a/b).
auto.
field;assumption.
field;assumption.
field;assumption.
exists (1/a).
split.
subst.
assert (a<>0).
intro;subst;intuition.

unfold not;intro.
assert (1 / a * a = 0 * a).
rewrite H1.
ring.
replace (1 / a * a) with (1) in H2.
ring_simplify in H2.
intuition.
field;assumption.

rewrite b0.
rewrite b1.
replace (a * (1 / a)) with 1.
replace (0 * (1 / a)) with 0.
auto.
assert (a<>0).
unfold not;intro.
congruence.
field;assumption.
assert (a<>0).
unfold not;intro.
congruence.
field;assumption.
Qed.

Lemma point_of_triple_functionnal: forall a b c l : R, (a,b,c) <> (0,0,0) -> l <> 0 ->
point_of_triple(a,b,c) = point_of_triple(a*l,b*l,c*l).
Proof.
intros.
unfold point_of_triple.
repeat (elim R_eq_dec;intros).
replace (a * l / (c * l)) with (a /c).
replace (b*l / (c * l)) with (b/ c).
reflexivity.
field;split;assumption.
field;split;assumption.
generalize (Rmult_integral c l b0).
intuition.
generalize (Rmult_integral c l b0).
intuition.
subst.
replace (0*l) with 0 in a1 by ring.
intuition.
replace (a * l / (b * l)) with (a/b).
reflexivity.
field;split;assumption.
generalize (Rmult_integral b l b2).
intuition.
subst.
replace (0*l) with 0 in a0 by ring.
intuition.
subst.
replace (0*l) with 0 in a0 by ring.
intuition.
reflexivity.
Qed.

Definition inner_product_triple A B :=
match (A,B) with
  ((a,b,c),(d,e,f)) => a*d+b*e+c*f
end.

Definition Incid : Point -> Line -> Prop := fun P L =>
 inner_product_triple (triple_of_point P) (triple_of_line L) = 0.

Definition Incid_triple A B := inner_product_triple A B = 0.

Lemma incid_dec :  forall (A:Point)(l:Line), {Incid A l} + {~Incid A l}.
Proof.
intros.
unfold Incid.
generalize (R_eq_dec  (inner_product_triple (triple_of_point A) (triple_of_line l)) 0) .
intuition.
Qed.

Lemma eq_point_dec : forall A B : Point, {A=B} + {A<>B}.
Proof.
intros.
elim A;intros;elim B;intros; try (solve [(left; discriminate) || (right; discriminate)]).
elim (R_eq_dec r r1);intros.
right.
unfold not;intro.
inversion H.
intuition.
subst.
elim (R_eq_dec r0 r2);intros.
right.
unfold not;intro.
inversion H.
intuition.
subst.
left;auto.
elim (R_eq_dec r r0);intro.
right.
unfold not;intro.
inversion H.
intuition.
subst.
left.
intuition.
left.
trivial.
Qed.

Definition det2 a b c d := a * d - b * c.

Definition general_line_through P  Q :=
match triple_of_point P, triple_of_point Q with
 (y1,y2,y3),(z1,z2,z3) =>line_of_triple ((det2  y2 y3 z2 z3),(det2 y3 y1 z3 z1), (det2 y1 y2 z1 z2))
end.

(*
Definition line_through P Q := if (eq_point_dec P Q) then L0 else general_line_through P  Q.
*)

Definition general_point_through P Q :=
match triple_of_line P, triple_of_line Q with
 (y1,y2,y3),(z1,z2,z3) =>point_of_triple ((det2  y2 y3 z2 z3),(det2 y3 y1 z3 z1), (det2 y1 y2 z1 z2))
end.

Ltac unfold_all :=
(unfold general_point_through, general_line_through, Incid, inner_product_triple, det2,
triple_of_point, point_of_triple, triple_of_line, line_of_triple in *).

Lemma normalize_compat_incid : forall a b c l1 l2 l3, (a,b,c) <> (0,0,0) -> Incid_triple (a,b,c) (l1,l2,l3) ->
Incid_triple (triple_of_point (point_of_triple (a,b,c))) (l1,l2,l3).
Proof.
intros.
unfold Incid_triple, inner_product_triple in *.
unfold triple_of_point, point_of_triple.
elim ( R_eq_dec c 0).
intro.
field_simplify.
replace (a * l1 + c * l3 + b * l2) with (a * l1 + b * l2 + c * l3) by ring.
rewrite H0.
field.
assumption.
assumption.
intro.
subst.
elim ( R_eq_dec b 0).
intro.
ring_simplify in H0.
field_simplify.
rewrite H0.
field.
assumption.
assumption.
intro.
subst.
ring_simplify in H0.
ring_simplify.
assert (a<>0).
intro;subst;intuition.
generalize (Rmult_integral a l1 H0).
intuition.
Qed.

Ltac ring_simplify_neq := match goal with
H: ?X <> ?Y |- _ => (ring_simplify X Y in H)
end.

Lemma a1_exist : forall (A B : Point) ,{l:Line | Incid A l /\ Incid B l}.
Proof.
intros.
elim A.
(* Case A is P2 y1 y2 *)
intros y1 y2.
elim B.
intros z1 z2.
elim (R_eq_dec z2 y2); intro Hz2y2.

(* case z2<>y2*)
exists (general_line_through (P2 y1 y2) (P2 z1 z2)).
unfold_all.
elim (R_eq_dec (y1 * z2 - y2 * z1) 0);intros.

split.
field;assumption.
field;assumption.

elim (R_eq_dec (1 * z1 - y1 * 1) 0);intros.
split.
field_simplify.
replace (- y1 * z2 + y2 * z1) with (- (y1 * z2 - y2 * z1)) by ring.
rewrite b.

field.
replace (- y1 + z1) with (1 * z1 - y1 * 1) by ring.
intuition.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
field_simplify.
replace (z1 * y2 - z2 * y1) with (- (y1 * z2 - y2 * z1)) by ring.
rewrite b.
field.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
split.
ring_simplify.
ring_simplify in b.
ring_simplify in b0.
IsoleVar z1 b0.
rewrite b0 in *.
ring_simplify in b.
clear b0.

replace (y1 * z2 - y1 * y2) with (y1 *(z2-y2)) in b by ring.
elim (Rmult_integral y1 (z2 - y2) b);auto.
intro.
IsoleVar z2 H.
ring_simplify in H.
intuition.

ring_simplify.
ring_simplify in b0.
IsoleVar y1 b0.
subst.
ring_simplify in b.
replace (z1 * z2 - z1 * y2) with (z1 * (z2 - y2)) in b by ring.
elim (Rmult_integral z1 (z2 - y2) b);auto.
intro.
IsoleVar z2 H.
ring_simplify in H.
intuition.

(* Case z2 = y2 *)
subst.
unfold_all.

elim (R_eq_dec y2 0);intro Hy2.
exists (L2 0 (- (1)/y2)).
split.
field;assumption.
field;assumption.

exists (L1 0).
subst;split;ring.

intro z1.

exists (general_line_through (P2 y1 y2) (P1 z1)).
unfold_all.
elim (R_eq_dec);intro.
ring_simplify_neq.
split;field;auto.

elim (R_eq_dec  (1 * z1 - y1 * 0) 0);intros.
ring_simplify_neq.
split.
field_simplify.
replace (- y1 + y2 * z1) with (- (y1 * 1 - y2 * z1)) by ring.
rewrite b.
field;auto.
auto.
replace z1 with (1 * z1 - y1 * 0) by ring.
auto.
field_simplify.
field.
auto.
try auto. (* bizaarrre*)
split.
ring_simplify.
ring_simplify in b0.
subst.
ring_simplify in b.
auto.
ring_simplify in b0.
subst.
ring.

exists (general_line_through (P2 y1 y2) (P0)).
unfold_all.

elim (R_eq_dec (y1 * 0 - y2 * 1) 0);intro.
split.
field.
replace (y1 * 0 - y2 * 1) with (-y2) in a by ring.
auto with real.
field.
replace (y1 * 0 - y2 * 1) with (-y2) in a by ring.
auto with real.

elim (R_eq_dec  (1 * 1 - y1 * 0) 0);intro.
split.
field_simplify.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
field.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
field.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
ring_simplify in b0.
intuition.
cut False.
intuition.
intuition.
cut False.
intuition.
intuition.

(* Case A is P1 y1 *)
intro y1.

elim B.
intros z1 z2.

exists (general_line_through (P1 y1) (P2 z1 z2)).
unfold_all.

elim R_eq_dec;intro.
split.
field.
replace (y1 * z2 - z1) with (y1 * z2 - 1 * z1) by ring.
auto.
field.
replace (y1 * z2 - z1) with (y1 * z2 - 1 * z1) by ring.
auto.

elim R_eq_dec;intro.
split.
field.
replace (0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
field_simplify.
replace (z1 - z2 * y1) with (- (y1 * z2 - 1 * z1)) by ring.
rewrite b.
field.
replace (0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
replace (0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
split.
ring_simplify in b0.
ring_simplify in b.
ring_simplify.
IsoleVar y1 b0.
rewrite b0.
ring.
ring_simplify.
ring_simplify in b0.
IsoleVar y1 b0.
rewrite b0 in *.
ring_simplify in b.
IsoleVar z1 b.
rewrite b.
ring.

(* Case B = P1 z1 *)

intro z1.
unfold_all.

exists (L2 0 0).
split;ring.

(* Case B = P0 *)
unfold_all.

exists (L2 0 0).
split;ring.

(* Case A is P0 *)

elim B.

(* Case B is P2 z1 z2 *)
intros z1 z2.

exists (general_line_through (P0) (P2 z1 z2)).
unfold_all.

elim (R_eq_dec);intro.
split.
field.
replace (z2) with (1 * z2 - 0 * z1) by ring.
auto.
field.
replace (z2) with (1 * z2 - 0 * z1) by ring.
auto.

elim (R_eq_dec);intro.
split.
field.
intuition.
ring_simplify in b.
subst.
field.

split;
ring_simplify in b0;
cut False;intuition.

(* Case B is P2 z1 z2 *)
intros z1.
unfold_all.

exists (L2 0 0).
split;ring.

unfold_all.
exists (L2 0 0).
split;ring.
Qed.

(*
Extraction a1_exist.
*)
(*
let a1_exist a b =
  match a with
    | P2 (x, x0) ->
        (match b with
           | P2 (x1, x2) ->
               (match Top.coq_F_eq_dec x2 x0 with
                  | Left -> general_line_through (P2 (x, x0)) (P2 (x1, x2))
                  | Right ->
                      (match Top.coq_F_eq_dec x0 f0 with
                         | Left -> L2 (f0, (fdiv (fopp f1) x0))
                         | Right -> L1 f0))
           | P1 x1 -> general_line_through (P2 (x, x0)) (P1 x1)
           | P0 -> general_line_through (P2 (x, x0)) P0)
    | P1 x ->
        (match b with
           | P2 (x0, x1) -> general_line_through (P1 x) (P2 (x0, x1))
           | _ -> L2 (f0, f0))
    | P0 ->
        (match b with
           | P2 (x, x0) -> general_line_through P0 (P2 (x, x0))
           | _ -> L2 (f0, f0))
*)

Lemma a2_exist : forall (l1 l2:Line), {A:Point | Incid A l1 /\ Incid A l2}.
Proof.
intros A B.
elim A.
(* Case A is P2 y1 y2 *)
intros y1 y2.
elim B.
intros z1 z2.
elim (R_eq_dec z2 y2); intro Hz2y2.

(* case z2<>y2*)
exists (general_point_through (L2 y1 y2) (L2 z1 z2)).
unfold_all.

elim (R_eq_dec (y1 * z2 - y2 * z1) 0);intros.

split.
field;assumption.
field;assumption.

elim (R_eq_dec (1 * z1 - y1 * 1) 0);intros.
split.
field_simplify.
replace (y2 * z1 - z2 * y1) with (- (y1 * z2 - y2 * z1)) by ring.
rewrite b.
field.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
field_simplify.
replace (y2 * z1 - z2 * y1) with (- (y1 * z2 - y2 * z1)) by ring.
rewrite b.
field.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
replace (z1 - y1) with (1 * z1 - y1 * 1) by ring.
intuition.
split.
ring_simplify.
ring_simplify in b.
ring_simplify in b0.
IsoleVar z1 b0.
rewrite b0 in *.
ring_simplify in b.
clear b0.

replace (y1 * z2 - y1 * y2) with (y1 *(z2-y2)) in b by ring.
elim (Rmult_integral y1 (z2 - y2) b);auto.
intro.
IsoleVar z2 H.
ring_simplify in H.
intuition.

ring_simplify.
ring_simplify in b0.
IsoleVar y1 b0.
subst.
ring_simplify in b.
replace (z1 * z2 - z1 * y2) with (z1 * (z2 - y2)) in b by ring.
elim (Rmult_integral z1 (z2 - y2) b);auto.
intro.
IsoleVar z2 H.
ring_simplify in H.
intuition.

(* Case z2 = y2 *)
subst.
unfold_all.

elim (R_eq_dec y2 0);intro Hy2.
exists (P2 0 (- (1)/y2)).
split.
field;assumption.
field;assumption.

exists (P1 0).
subst;split;ring.

intro z1.

exists (general_point_through (L2 y1 y2) (L1 z1)).
unfold_all.
elim (R_eq_dec);intro.
split.
field.
replace (y1 - y2 * z1) with (y1 * 1 - y2 * z1) by ring.
auto.
field.
replace (y1 - y2 * z1) with (y1 * 1 - y2 * z1) by ring.
auto.

elim (R_eq_dec  (1 * z1 - y1 * 0) 0);intros.
split.
field_simplify.
replace (y2 * z1 - y1) with (- (y1 * 1 - y2 * z1)) by ring.
rewrite b.
field.
replace z1 with (1 * z1 - y1 * 0) by ring.
auto.
replace z1 with (1 * z1 - y1 * 0) by ring.
auto.
field_simplify.
field.
replace z1 with (1 * z1 - y1 * 0) by ring.
auto.
try (ring_simplify (1 *z1 - y1*0) in a; auto).
split.
ring_simplify.
ring_simplify in b0.
subst.
ring_simplify in b.
auto.
ring_simplify in b0.
subst.
ring.

exists (general_point_through (L2 y1 y2) (L0)).
unfold_all.

elim (R_eq_dec (y1 * 0 - y2 * 1) 0);intro.
split.
field.

replace (y1 * 0 - y2 * 1) with (- y2) in a by ring.
auto with real.

field.
replace (y1 * 0 - y2 * 1) with (- y2) in a by ring.
auto with real.

elim (R_eq_dec  (1 * 1 - y1 * 0) 0);intro.
split.
field_simplify.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
field.
intuition.
intuition.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
field.
ring_simplify in b.
IsoleVar y2 b.
rewrite b.
ring_simplify in b0.
intuition.
cut False.
intuition.
intuition.
cut False.
intuition.
intuition.

(* Case A is P1 y1 *)
intro y1.

elim B.
intros z1 z2.

exists (general_point_through (L1 y1) (L2 z1 z2)).
unfold_all.

elim R_eq_dec;intro.
split.
field.
replace (y1 * z2 - z1) with (y1 * z2 - 1 * z1) by ring.
auto.
field.
replace (y1 * z2 - z1) with (y1 * z2 - 1 * z1) by ring.
auto.

elim R_eq_dec;intro.
split.
field.
replace ( 0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
field_simplify.
replace (- z2 * y1 + z1) with (- (y1 * z2 - 1 * z1)) by ring.
rewrite b.
field.
replace ( 0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
replace ( 0 * z1 - y1 * 1) with (- y1) in a by ring.
auto with real.
split.

ring_simplify in b0.
ring_simplify in b.
ring_simplify.
IsoleVar y1 b0.
rewrite b0.
ring.
ring_simplify.
ring_simplify in b0.
IsoleVar y1 b0.
rewrite b0 in *.
ring_simplify in b.
IsoleVar z1 b.
rewrite b.
ring.

(* Case B = P1 z1 *)

intro z1.
unfold_all.

exists (P2 0 0).
split;ring.

(* Case B = P0 *)
unfold_all.

exists (P2 0 0).
split;ring.

(* Case A is P0 *)

elim B.

(* Case B is P2 z1 z2 *)
intros z1 z2.

exists (general_point_through (L0) (L2 z1 z2)).

unfold_all.

elim (R_eq_dec);intro.
split.
field.
replace (z2) with (1 * z2 - 0 * z1) by ring.
auto.
field.
replace (z2) with (1 * z2 - 0 * z1) by ring.
auto.

elim (R_eq_dec);intro.
split.
field.
intuition.
ring_simplify in b.
subst.
field.

split;
ring_simplify in b0;
cut False;intuition.

(* Case B is P2 z1 z2 *)
intros z1.
unfold_all.

exists (P2 0 0).
split;ring.

unfold_all.
exists (P2 0 0).
split;ring.
Qed.

Lemma a3_1 :
  (forall l:Line,{A:Point & {B:Point & {C:Point | (dist3 A B C/\Incid A l /\Incid B l /\ Incid C l)}}}).
Proof.
intro.
case l.
intros x1 x2.
elim (R_eq_dec x1 0);intro.
elim (R_eq_dec x2 0);intro.

exists (P2 ((0- 1) / x1) 0).
exists (P2 0 ((0- 1) / x2)).
exists (P1 (- x2 / x1)).
unfold dist3.
repeat split.
intro H; inversion H.

assert ((0 - 1) / x1 * x1 = 0-1).
field;auto.
rewrite H1 in H0.
ring_simplify in H0.
auto with field_hints.

intro H;inversion H.
intro H;inversion H.

unfold_all;field;assumption.
unfold_all;field;assumption.
unfold_all;field;assumption.

exists (P2 (- (1) / x1) (1)).
exists (P2 (- (1) / x1) (0)).
exists (P2 (- (1) / x1) (2)).

unfold dist3;repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0 <> 2);auto with real.

elim (R_eq_dec x2 0);intro.

exists (P2  1 (- (1) / x2)).
exists (P2  0 (- (1) / x2)).
exists (P2  2 (- (1) / x2)).
unfold dist3;repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0 <> 2);auto with real.

exists (P1  2 ).
exists (P1  0 ).
exists (P1  1 ).

unfold dist3;repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0 <> 2);auto with real.

intro x1.

exists (P2 0 0).
elim (R_eq_dec x1 0);intro.

exists (P1 (- (1) / x1)).
exists (P2 (- (1) / x1) 1).

unfold dist3;repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

exists (P2 1 0).
exists (P2 2 0).

unfold dist3;repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0 <> 2);auto with real.

exists (P2 0 1).
exists (P2 0 0).
exists (P2 0 2).

unfold dist3;repeat split;(intro H; inversion H;auto with real field_hints) || (subst;unfold_all;field;assumption).

assert (0<>2);auto with real.

Qed.

Lemma a3_2 : {l1:Line & {l2:Line | l1 <> l2}}.
Proof.
exists L0.
exists (L1 0).
intro H;inversion H.
Qed.

Lemma equiv_eq: forall a b, a = b <-> a - b = 0.
Proof.
split.
intros.
rewrite H.
ring.
intro.
assert (a-b + b = 0 + b).
rewrite H.
ring.
ring_simplify in H0.
assumption.
Qed.

Lemma equiv_or: forall a b, a = 0 \/ b = 0 <-> a*b = 0.
Proof.
intros.
split.
intro.
case H;intros.
rewrite H0.
ring.
rewrite H0.
ring.
intro.
apply Rmult_integral.
assumption.
Qed.

Lemma equiv_and : forall a b, a = 0 /\ b = 0 <-> a*a + b*b = 0.
Proof.
intros.
intuition.
subst.
ring.
generalize (Rplus_sqr_eq_0 a b).
intuition.
generalize (Rplus_sqr_eq_0 a b).
intuition.
Qed.

Ltac replace_cons X Y := progress (
   match Y  with
| 0 => idtac
| _ => setoid_replace (X=Y) with (X-Y=0) by (apply equiv_eq)
end).

Ltac injection_equiv := let H := fresh in
(split;
intro H;[injection H;auto | decompose [and] H;subst;auto]).

Lemma eq_2 : forall X1 X2 Y1 Y2,
P2 X1 X2 = P2 Y1 Y2 <-> (X1 = Y1 /\ X2 = Y2).
Proof.
intros X1 X2 Y1 Y2.
injection_equiv.
Qed.

Lemma eq_1 : forall X Y,
P1 X = P1 Y <-> X = Y.
intros.
injection_equiv.
Qed.

Ltac reduce_prop :=
match goal with
| H: _ |- context [?X = ?Y] => replace_cons X Y
| H: _ |- context [?X = 0 /\ ?Y=0] => setoid_replace (X = 0 /\ Y=0) with (X*X + Y*Y = 0) by apply equiv_and
| H: _ |- context [?X = 0 \/ ?Y=0] => setoid_replace (X = 0 \/ Y=0) with (X*Y = 0) by apply equiv_or
| H: _ |- context [(P1 ?X1 = P1 ?Y1)] => setoid_replace (P1 X1 = P1 Y1) with (X1 = Y1) by try injection_equiv
| H: _ |- context [(L1 ?X1 = L1 ?Y1)] => setoid_replace (L1 X1 = L1 Y1) with (X1 = Y1) by try injection_equiv

| H: _ |- context [(?P ?X1 ?X2 = ?P ?Y1 ?Y2)] =>
   setoid_replace (P X1 X2 = P Y1 Y2) with (X1 = Y1 /\ X2 = Y2)
  by let H := fresh in (split;intro H;[inversion H;auto | decompose [and] H;subst;auto])
| H: _  |- context [P2 ?X ?Y = P1 ?Z] => setoid_replace (P2 X Y = P1 Z) with False by try (intuition;discriminate)
| H: _  |- context [P2 ?X ?Y = P0] => setoid_replace (P2 X Y = P0) with False by try (intuition;discriminate)
| H: _  |- context [P1 ?X = P0] => setoid_replace (P1 X = P0) with False by try (intuition;discriminate)
| H: _  |- context [L2 ?X ?Y = L1 ?Z] => setoid_replace (L2 X Y = L1 Z) with False by try (intuition;discriminate)
| H: _  |- context [L2 ?X ?Y = L0] => setoid_replace (L2 X Y = L0) with False by try (intuition;discriminate)
| H: _  |- context [L1 ?X = L0] => setoid_replace (L1 X = L0) with False by try (intuition;discriminate)

| H: _  |- context [P1 ?Z = P2 ?X ?Y] => setoid_replace (P1 Z = P2 X Y) with False by try (intuition;discriminate)
| H: _  |- context [P0 = P2 ?X ?Y] => setoid_replace (P0 = P2 X Y) with False by try (intuition;discriminate)
| H: _  |- context [P0 = P1 ?X] => setoid_replace (P0 = P1 X) with False by try (intuition;discriminate)
| H: _  |- context [L1 ?Z = L2 ?X ?Y] => setoid_replace (L1 Z = L2 X Y) with False by try (intuition;discriminate)
| H: _  |- context [L0 = L2 ?X ?Y] => setoid_replace (L0 = L2 X Y) with False by try (intuition;discriminate)
| H: _  |- context [L0 = L1 ?X] => setoid_replace (L0 = L1 X) with False by try (intuition;discriminate)

| H: _  |- context [L0 = L0] => setoid_replace (L0 = L0) with True by try (split;auto)
| H: _  |- context [P0 = P0] => setoid_replace (P0 = P0) with True by try (split;auto)

| H: _  |- context [?P \/ False] => setoid_replace (P \/ False) with (P) by try intuition
| H: _  |- context [False \/ ?P] => setoid_replace (False \/ P) with (P) by try intuition

| H: _  |- context [?P \/ True] => setoid_replace (P \/ True) with (True) by try intuition
| H: _  |- context [True \/ ?P] => setoid_replace (True \/ P) with (True) by try intuition
end.

Ltac normalize_prop := repeat reduce_prop.

Ltac simplify_eqs eq1 eq2 eq3 eq4 :=
  ring_simplify in eq1;try subst;
  ring_simplify in eq2;try subst;
  ring_simplify in eq3;try subst;
  ring_simplify in eq4;try subst.

(** NB : The following proof takes ages with the new proof engine.
  Probably something to see with the high number of goals, evars(?)
  and/or setoid_replace(?). While I investigate the matter, let's
  temporary try to speed-up the coq bench by commenting the original
  proof and replacing it by a faster one.

  Nota: some other files are currently slower than earlier, but
  not by a 10x factor, I'll inspect them later.

  Pierre Letouzey, 10/12/2010
*)

(* ORIGINAL PROOF:

Lemma uniqueness : forall A B :Point, forall l m : Line,
 Incid A l -> Incid B l  -> Incid A m -> Incid B m -> A=B\/l=m.
Proof.
intros A B l m.
case_eq A;intros;
case_eq B;intros;
case_eq l;intros;
case_eq m;intros;
unfold_all;subst;normalize_prop; trivial;
 try (solve [nsatz]);assert (1=0) by nsatz;intuition.
Qed.

*)

Lemma triple_of_point_carac : forall A,
 let '(a,b,c) := triple_of_point A in
 (c=1 \/ c=0) /\
 (c=1 \/ b=1 \/ b=0) /\
 (c=1 \/ b=1 \/ a=1).
Proof.
 destruct A; simpl; intuition.
Qed.

Lemma triple_of_point_carac' : forall A,
 let '(a,b,c) := triple_of_point A in
 (c-1)*c=0 /\
 (c-1)*(b-1)*b=0 /\
 (c-1)*(b-1)*(a-1)=0.
Proof.
 intros A.
 generalize (triple_of_point_carac A).
 destruct triple_of_point as ((a,b),c).
 rewrite <- !equiv_or, <- !equiv_eq. intuition.
Qed.

Lemma triple_of_line_carac : forall l,
 let '(a,b,c) := triple_of_line l in
 (c=1 \/ c=0) /\
 (c=1 \/ b=1 \/ b=0) /\
 (c=1 \/ b=1 \/ a=1).
Proof.
 destruct l; simpl; intuition.
Qed.

Lemma triple_of_line_carac' : forall l,
 let '(a,b,c) := triple_of_line l in
 (c-1)*c=0 /\
 (c-1)*(b-1)*b=0 /\
 (c-1)*(b-1)*(a-1)=0.
Proof.
 intros l.
 generalize (triple_of_line_carac l).
 destruct triple_of_line as ((a,b),c).
 rewrite <- !equiv_or, <- !equiv_eq. intuition.
Qed.

Lemma pair_eq : forall A B (a a':A)(b b':B),
 (a,b) = (a',b') <-> a=a' /\ b=b'.
Proof.
 intros.
 split. injection 1; split; trivial.
 destruct 1; subst; trivial.
Qed.

Lemma triple_of_point_inj : forall A B,
 triple_of_point A = triple_of_point B <-> A = B.
Proof.
 intros. split; intros.
 rewrite <- (triple_point A), <- (triple_point B). now f_equal.
 now subst.
Qed.

Lemma triple_of_line_inj : forall l m,
 triple_of_line l = triple_of_line m <-> l = m.
Proof.
 destruct l, m; unfold_all; simpl; rewrite !pair_eq;
  intuition; subst; try congruence; exfalso; auto with real.
Qed.

Lemma uniqueness : forall A B :Point, forall l m : Line,
 Incid A l -> Incid B l  -> Incid A m -> Incid B m -> A=B\/l=m.
Proof.
intros A B l m. intros.
unfold Incid in *.
rewrite <- triple_of_point_inj, <- triple_of_line_inj.
generalize (triple_of_point_carac' A)(triple_of_point_carac' B)
 (triple_of_line_carac' l)(triple_of_line_carac' m).
destruct (triple_of_point A) as ((a1,a2),a3).
destruct (triple_of_point B) as ((b1,b2),b3).
destruct (triple_of_line l) as ((l1,l2),l3).
destruct (triple_of_line m) as ((m1,m2),m3).
intros (EQa3 & EQa2 & EQa1).
intros (EQb3 & EQb2 & EQb1).
intros (EQl3 & EQl2 & EQl1).
intros (EQm3 & EQm2 & EQm1).
unfold_all.
rewrite !pair_eq.
normalize_prop.
nsatz.
Qed.

End HomogenousCoords.


Require Export GeoCoq.Elements.OriginalProofs.proposition_44.
Require Export GeoCoq.Elements.OriginalProofs.lemma_RTcongruence.
Require Export GeoCoq.Elements.OriginalProofs.lemma_RTsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.proposition_14.

Section Euclid.

Context `{Ax:area}.

Lemma proposition_45 :
   forall A B C D E J K N O R S,
   nCol J E N -> nCol A B D -> nCol C B D -> BetS A O C -> BetS B O D -> neq R K -> nCol K R S ->
   exists X Z U, PG X K Z U /\ CongA X K Z J E N /\ EF X K Z U A B C D /\ Out K R Z /\ OS X S K Z.
Proof.
intros.
assert (neq B D) by (forward_using lemma_NCdistinct).
let Tf:=fresh in
assert (Tf:exists m, (BetS B m D /\ Cong m B m D)) by (conclude proposition_10);destruct Tf as [m];spliter.
assert (Cong B m m D) by (forward_using lemma_congruenceflip).
assert (Midpoint B m D) by (conclude_def Midpoint ).
assert (neq B m) by (forward_using lemma_betweennotequal).
let Tf:=fresh in
assert (Tf:exists P, (BetS R K P /\ Cong K P B m)) by (conclude lemma_extension);destruct Tf as [P];spliter.
assert (Triangle A B D) by (conclude_def Triangle ).
assert (neq K P) by (forward_using lemma_betweennotequal).
assert (neq P K) by (conclude lemma_inequalitysymmetric).
rename_H H;let Tf:=fresh in
assert (Tf:exists H, (BetS P K H /\ Cong K H P K)) by (conclude lemma_extension);destruct Tf as [H];spliter.
assert (Cong P K K H) by (conclude lemma_congruencesymmetric).
assert (Midpoint P K H) by (conclude_def Midpoint ).
assert (Cong P K B m) by (forward_using lemma_congruenceflip).
assert (Cong K H B m) by (conclude lemma_congruencetransitive).
assert (Cong B m m D) by (forward_using lemma_congruenceflip).
assert (Cong K H m D) by (conclude lemma_congruencetransitive).
assert (BetS P K R) by (conclude axiom_betweennesssymmetry).
assert (Col P K H) by (conclude_def Col ).
assert (Col P K R) by (conclude_def Col ).
assert (neq P K) by (forward_using lemma_betweennotequal).
assert (Col K H R) by (conclude lemma_collinear4).
assert (Col R K H) by (forward_using lemma_collinearorder).
assert (nCol R K S) by (forward_using lemma_NCorder).
assert (eq K K) by (conclude cn_equalityreflexive).
assert (Col R K K) by (conclude_def Col ).
assert (neq K H) by (forward_using lemma_betweennotequal).
assert (neq H K) by (conclude lemma_inequalitysymmetric).
assert (nCol H K S) by (conclude lemma_NChelper).
assert (nCol S K H) by (forward_using lemma_NCorder).
let Tf:=fresh in
assert (Tf:exists F G, (PG F K H G /\ EF A B m D F K H G /\ CongA H K F J E N /\ OS S F K H)) by (conclude proposition_42B);destruct Tf as [F[G]];spliter.
assert (nCol D B C) by (forward_using lemma_NCorder).
assert (Triangle D B C) by (conclude_def Triangle ).
assert (Par F K H G) by (conclude_def PG ).
assert (nCol K H G) by (forward_using lemma_parallelNC).
assert (nCol H G K) by (forward_using lemma_NCorder).
assert (nCol G H K) by (forward_using lemma_NCorder).
let Tf:=fresh in
assert (Tf:exists M L e, (PG G H M L /\ CongA G H M J E N /\ EF D B e C G H M L /\ Midpoint B e C /\ TS M G H K)) by (conclude proposition_44);destruct Tf as [M[L[e]]];spliter.
assert (BetS B e C) by (conclude_def Midpoint ).
assert (CongA J E N G H M) by (conclude lemma_equalanglessymmetric).
assert (CongA H K F G H M) by (conclude lemma_equalanglestransitive).
assert (Par F K H G) by (conclude_def PG ).
assert (Par K F H G) by (forward_using lemma_parallelflip).
assert (neq H K) by (forward_using lemma_NCdistinct).
let Tf:=fresh in
assert (Tf:exists s, (BetS H K s /\ Cong K s H K)) by (conclude lemma_extension);destruct Tf as [s];spliter.
assert (Par F G K H) by (conclude_def PG ).
assert (Par K H F G) by (conclude lemma_parallelsymmetric).
assert (TP K H F G) by (conclude lemma_paralleldef2B).
assert (OS F G K H) by (conclude_def TP ).
assert (RT F K H K H G) by (conclude proposition_29C).
assert (CongA G H M H K F) by (conclude lemma_equalanglessymmetric).
assert (nCol H K F) by (conclude lemma_equalanglesNC).
assert (nCol F K H) by (forward_using lemma_NCorder).
assert (CongA F K H H K F) by (conclude lemma_ABCequalsCBA).
assert (CongA F K H G H M) by (conclude lemma_equalanglestransitive).
assert (RT G H M K H G) by (conclude lemma_RTcongruence).
assert (RT K H G G H M) by (conclude lemma_RTsymmetric).
assert (eq G G) by (conclude cn_equalityreflexive).
assert (neq H G) by (forward_using lemma_NCdistinct).
assert (Out H G G) by (conclude lemma_ray4).
assert (BetS K H M) by (conclude proposition_14).
assert (neq F K) by (forward_using lemma_NCdistinct).
assert (nCol G H M) by (conclude lemma_equalanglesNC).
assert (neq G H) by (forward_using lemma_NCdistinct).
assert (Par G H M L) by (conclude_def PG ).
assert (nCol H M L) by (forward_using lemma_parallelNC).
assert (neq L M) by (forward_using lemma_NCdistinct).
assert (eq K K) by (conclude cn_equalityreflexive).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (eq M M) by (conclude cn_equalityreflexive).
assert (Col F K K) by (conclude_def Col ).
assert (Col G H H) by (conclude_def Col ).
assert (Col L M M) by (conclude_def Col ).
assert (Par F K G H) by (forward_using lemma_parallelflip).
assert (Par M L G H) by (conclude lemma_parallelsymmetric).
assert (Par L M G H) by (forward_using lemma_parallelflip).
assert (Par F K L M) by (conclude proposition_30).
assert (Par F K M L) by (forward_using lemma_parallelflip).
assert (Par F G K H) by (conclude_def PG ).
assert (Par G L H M) by (conclude_def PG ).
assert (Par F G H K) by (forward_using lemma_parallelflip).
assert (Col K H M) by (conclude_def Col ).
assert (Col H K M) by (forward_using lemma_collinearorder).
assert (neq K M) by (forward_using lemma_betweennotequal).
assert (neq M K) by (conclude lemma_inequalitysymmetric).
assert (Par F G M K) by (conclude lemma_collinearparallel).
assert (Col H M K) by (forward_using lemma_collinearorder).
assert (Par G L K M) by (conclude lemma_collinearparallel).
assert (Par G L M K) by (forward_using lemma_parallelflip).
assert (Par M K G L) by (conclude lemma_parallelsymmetric).
assert (Par M K F G) by (conclude lemma_parallelsymmetric).
assert (Par M K G F) by (forward_using lemma_parallelflip).
assert (Col G L F) by (conclude lemma_Playfair).
assert (Col G F L) by (forward_using lemma_collinearorder).
assert (nCol F L M) by (forward_using lemma_parallelNC).
assert (neq L F) by (forward_using lemma_NCdistinct).
assert (Par M K L F) by (conclude lemma_collinearparallel).
assert (Par L F M K) by (conclude lemma_parallelsymmetric).
assert (Par F L K M) by (forward_using lemma_parallelflip).
assert (PG F K M L) by (conclude_def PG ).
assert (nCol F K H) by (forward_using lemma_parallelNC).
assert (CongA F K H H K F) by (conclude lemma_ABCequalsCBA).
assert (CongA F K H J E N) by (conclude lemma_equalanglestransitive).
assert (neq K H) by (forward_using lemma_betweennotequal).
assert (Out K H M) by (conclude lemma_ray4).
assert (Out K M H) by (conclude lemma_ray5).
assert (eq F F) by (conclude cn_equalityreflexive).
assert (neq K F) by (forward_using lemma_NCdistinct).
assert (Out K F F) by (conclude lemma_ray4).
assert (nCol F K M) by (forward_using lemma_parallelNC).
assert (CongA F K M F K M) by (conclude lemma_equalanglesreflexive).
assert (CongA F K M F K H) by (conclude lemma_equalangleshelper).
assert (CongA F K M J E N) by (conclude lemma_equalanglestransitive).
assert (Col B O D) by (conclude_def Col ).
assert (Col B D O) by (forward_using lemma_collinearorder).
assert (nCol B D A) by (forward_using lemma_NCorder).
assert (TS A B D C) by (conclude_def TS ).
assert (Par G H L M) by (forward_using lemma_parallelflip).
assert (TP G H L M) by (conclude lemma_paralleldef2B).
assert (OS L M G H) by (conclude_def TP ).
assert (Par F K G H) by (forward_using lemma_parallelflip).
assert (Par G H F K) by (conclude lemma_parallelsymmetric).
assert (TP G H F K) by (conclude lemma_paralleldef2B).
assert (OS F K G H) by (conclude_def TP ).
assert (eq H H) by (conclude cn_equalityreflexive).
assert (Col G H H) by (conclude_def Col ).
assert (TS K G H M) by (conclude_def TS ).
assert (TS F G H M) by (conclude lemma_planeseparation).
assert (TS M G H F) by (conclude lemma_oppositesidesymmetric).
assert (TS L G H F) by (conclude lemma_planeseparation).
let Tf:=fresh in
assert (Tf:exists t, (BetS L t F /\ Col G H t /\ nCol G H L)) by (conclude_def TS );destruct Tf as [t];spliter.
assert (Col F L G) by (forward_using lemma_collinearorder).
assert (Col L t F) by (conclude_def Col ).
assert (Col F L t) by (forward_using lemma_collinearorder).
assert (neq F L) by (forward_using lemma_NCdistinct).
assert (Col L G t) by (conclude lemma_collinear4).
assert (Col t G L) by (forward_using lemma_collinearorder).
assert (Col t G H) by (forward_using lemma_collinearorder).
assert (~ neq t G).
 {
 intro.
 assert (Col G L H) by (conclude lemma_collinear4).
 assert (Col G H L) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (BetS L G F) by (conclude cn_equalitysub).
assert (BetS F G L) by (conclude axiom_betweennesssymmetry).
let Tf:=fresh in
assert (Tf:exists j, (BetS F j M /\ BetS K j L)) by (conclude lemma_diagonalsmeet);destruct Tf as [j];spliter.
assert (EF A B C D F K M L) by (conclude axiom_paste4).
assert (EF F K M L A B C D) by (conclude axiom_EFsymmetric).
assert (BetS P K M) by (conclude lemma_3_7b).
assert (Out K R M) by (conclude_def Out ).
assert (OS F S K H) by (forward_using lemma_samesidesymmetric).
assert (Col K H M) by (conclude_def Col ).
assert (OS F S K M) by (conclude lemma_samesidecollinear).
close.
Qed.

End Euclid.


Require Import Reals.
Require Import Flocq.Core.Core.
Require Import Gappa_tactic.
Open Scope R_scope.

Definition floor := rounding_fixed rndDN 0.

Goal forall x y,
  floor x = floor y ->
  2 <= sqrt (4 + Rsqr (x - y)) <= 9/4.
Proof.
unfold floor, Rsqr.
gappa.
Qed.


(** This page contains the documentation for the Coq proofs written to verify our implementations of the <<lookup>> and <<insertion>> operations on AVL Trees. To view the code corresponding to the implementation, see #the github page #. To get a sense of how the proofs proceed, it is recommended that the libraries in the project be viewed in the following order: *)

(** * # paraphernalia # *)

(** This library contains general lemmas used across the project. The notion of an ordering comparison function is defined in this library. *)

(** * # hbt # *)

(** This library contains the Gallina implementation of the insertion and lookup functions, and the predicates for soundness, balancedness, and orderedness.It also contains unfold lemmas for the functions, which are key to algebraically reasoning about our programs. **)

(** * # theorems # *)

(** This library contains the specifications for the insertion and lookup functions, the statement of theorems claiming that the implementations meet these specifications, and the proofs for these theorems. The proof for <<lookup>> is trivial, while fairly complex for <<insertion>>. The latter proof is constructed with the help of 3 key lemmas which are discussed in the next section *)

(** * Lemmas *)

(** The 3 key lemmas used to show the correctness of the insertion implementation were:

- Insertion preserves the soundness invariant
- Insertion preserves the balancedness invariant
- Insertion preserves the orderedness invariant *)

(** ** # sound  # *)

(** This library contains lemmas concerning the soundness property. *)

(** ** # balanced # *)

(** This library contains lemmas concerning the balancedness property. *)

(** ** # ordered_main # *)

(** This library contains the most importatnt lemmas for the orderedness property, including:
- The lemma to relate the inserted element to a payload in terms of an ordering
- The lemmas to show that rotations preserve order
- The lemma to show that insertion preserves orderedness *)

(** The library builds on helper lemmas defined in # ordered_helper # *)


(** Construction of KY trees for probabilistic choice with proof of
correctness wrt a simple inference function. *)

(** Given a rational number p ∈ [0, 1], construct a boolean tree t
such that infer(t) = p (the probability of sampling true from t is
equal to p). *)

(*To install ITree, do: *)
(*     opam install coq-itree *)
From ITree Require Import
     ITree ITreeFacts.
Import ITreeNotations.

Require Import Coq.Program.Basics.
Require Import List.
Require Import Coq.Init.Nat.
Require Import PeanoNat.
Require Import Coq.QArith.QArith_base.
Require Import Coq.QArith.Qfield.
Require Import Coq.micromega.Lqa.
Require Import Omega.
Local Open Scope program_scope.
Import ListNotations.

(** KY trees *)
Inductive tree A : Type :=
| Leaf : A -> tree A
| Fail : tree A
| Split : tree A -> tree A -> tree A.

Fixpoint tree_fmap {A B : Type} (f : A -> B) (t : tree A) : tree B :=
  match t with
  | Leaf _ x => Leaf _ (f x)
  | Split _ t1 t2 => Split _ (tree_fmap f t1) (tree_fmap f t2)
  | Fail _ => Fail _
  end.

Fixpoint tree_join {A : Type} (t : tree (tree A)) : tree A :=
  match t with
  | Leaf _ t' => t'
  | Split _ t1 t2 => Split _ (tree_join t1) (tree_join t2)
  | Fail _ => Fail _
  end.

Definition tree_bind {A B : Type} (t : tree A) (k : A -> tree B) : tree B :=
  tree_join (tree_fmap k t).

Instance Monad_tree : Monad tree := { ret := Leaf; bind := @tree_bind }.

Definition tree_kcomp {A B C : Type} (f : A -> tree B) (g : B -> tree C) : A -> tree C :=
  fun x => bind (f x) g.

(** Bernoulli KY tree construction (for implementing probabilistic choice) *)
Definition unit_bool_eqb (x y : unit + bool) : bool :=
  match (x, y) with
  | (inl _, inl _) => true
  | (inr b1, inr b2) => Bool.eqb b1 b2 (* XNOR *)
  | _ => false
  end.

Lemma unit_bool_eqb_spec (x y : unit + bool)
  : Bool.reflect (x = y) (unit_bool_eqb x y).
Proof.
  destruct x, y.
  - destruct u, u0; left; reflexivity.
  - right; congruence.
  - right; congruence.
  - destruct b, b0; constructor; auto; congruence.
Qed.

Lemma unit_bool_eqb_refl (x : unit + bool) :
  unit_bool_eqb x x.
Proof. destruct x; auto; apply eqb_reflx. Qed.

Fixpoint unit_bool_tree_eqb (t1 : tree (unit + bool)) (t2 : tree (unit + bool)) : bool :=
  match (t1, t2) with
  | (Leaf _ b1, Leaf _ b2) => unit_bool_eqb b1 b2
  | ((Split _ t1 t2), (Split _ t1' t2')) =>
    andb (unit_bool_tree_eqb t1 t1') (unit_bool_tree_eqb t2 t2')
  | (Fail _, Fail _) => true
  | _ => false
  end.

Lemma unit_bool_tree_eqb_refl (t : tree (unit + bool)) :
  unit_bool_tree_eqb t t = true.
Proof.
  induction t; auto.
  - apply unit_bool_eqb_refl.
  - simpl; intuition.
Qed.

(** Using equality testing to check for success (SPECIALIZED TO BOOL) *)
Fixpoint add_to_tree (b : bool) (t : tree (unit + bool)) : tree (unit + bool) :=
  match t with
  | Leaf _ (inl _) => Leaf _ (inr b)
  | Leaf _ (inr _) => t
  | Split _ t1 t2 =>
    let t1' := add_to_tree b t1 in
    if unit_bool_tree_eqb t1 t1'
    then Split _ t1 (add_to_tree b t2)
    else Split _ t1' t2
  | Fail _ => Fail _
  end.

Fixpoint heightb {A : Type} (t : tree A) : nat :=
  match t with
  | Split _ t1 t2 => 1 + max (heightb t1) (heightb t2)
  | _ => 0
  end.

Inductive height {A : Type} : tree A -> nat -> Prop :=
| height_leaf : forall x, height (Leaf _ x) 0
| height_fail : height (Fail _ ) 0
| height_split : forall t1 t2 n m,
    height t1 n ->
    height t2 m ->
    height (Split _ t1 t2) (1 + max n m).

Lemma heightb_spec {A : Type} (t : tree A) :
  height t (heightb t).
Proof.
  induction t; simpl; constructor; auto.
Qed.

Fixpoint new_bool_tree (n : nat) : tree (unit + bool) :=
  match n with
  | O => Leaf _ (inl tt)
  | S n' => Split _ (new_bool_tree n') (new_bool_tree n')
  end.

Fixpoint list_tree_aux (l : list bool) (t : tree (unit + bool))
  : tree (unit + bool) :=
  match l with
  | [] => t
  | b :: bs =>
    let t' := add_to_tree b t in
    let t'' := if unit_bool_tree_eqb t t'
               then Split _ t (add_to_tree b (new_bool_tree (heightb t)))
               else t' in
    list_tree_aux bs t''
  end.

Fixpoint tie_tree (t : tree (unit + bool)) : tree bool :=
  match t with
  | Leaf _ (inl _) => Fail _
  | Leaf _ (inr b) => Leaf _ b
  | Split _ t1 t2 => Split _ (tie_tree t1) (tie_tree t2)
  | Fail _ => Fail _
  end.

Definition list_tree (l : list bool) : tree bool :=
  tie_tree (list_tree_aux l (Leaf _ (inl tt))).

Definition bernoulli_tree (n d : nat) : tree bool :=
  list_tree (repeat true n ++ repeat false (d-n)).

(** Inference on KY trees *)
Fixpoint mass {A : Type} (f : A -> Q) (t : tree A) : Q :=
  match t with
  | Leaf _ x => f x
  | Split _ t1 t2 => (1#2) * mass f t1 + (1#2) * mass f t2
  | Fail _ => 0
  end.

(** Liberal mass *)
Fixpoint lmass {A : Type} (f : A -> Q) (t : tree A) : Q :=
  match t with
  | Leaf _ x => f x
  | Split _ t1 t2 => (1#2) * mass f t1 + (1#2) * mass f t2
  | Fail _ => 1
  end.

Definition infer_ {A : Type} (f g : A -> Q) (t : tree A) : Q * Q :=
  (mass f t, mass g t).

Definition infer {A : Type} (f : A -> bool) (t : tree A) : Q :=
  let (n, d) := infer_ (fun x => if f x then 1 else 0) (fun _ => 1) t in
  n / d.

Inductive congruent {A B : Type} : tree A -> tree B -> Prop :=
| congruent_leaf_leaf : forall x y, congruent (Leaf _ x) (Leaf _ y)
| congruent_leaf_fail : forall x, congruent (Leaf _ x) (Fail _)
| congruent_fail_leaf : forall y, congruent (Fail _) (Leaf _ y)
| congruent_fail_fail : congruent (Fail _) (Fail _)
| congruent_split : forall t1 t1' t2 t2',
    congruent t1 t1' -> congruent t2 t2' ->
    congruent (Split _ t1 t2) (Split _ t1' t2').

Lemma congruent_refl {A : Type} (t : tree A) :
  congruent t t.
Proof. induction t; constructor; auto. Qed.

Lemma congruent_symm {A B : Type} (t1 : tree A) (t2 : tree B) :
  congruent t1 t2 -> congruent t2 t1.
Proof. intro H; induction H; constructor; auto. Qed.

Lemma congruent_trans {A B C : Type}
      (t1 : tree A) (t2 : tree B) (t3 : tree C) :
  congruent t1 t2 -> congruent t2 t3 -> congruent t1 t3.
Proof.
  revert t3 t1; induction t2; intros t1 t3 H0 H1;
    inversion H0; inversion H1; subst; constructor.
  - eapply IHt2_1 in H4; eauto.
  - eapply IHt2_2 in H5; eauto.
Qed.

Inductive perfect {A : Type} : tree A -> Prop :=
| perfect_leaf : forall x, perfect (Leaf _ x)
| perfect_fail : perfect (Fail _)
| perfect_split : forall t1 t2,
    congruent t1 t2 ->
    perfect t1 -> perfect t2 ->
    perfect (Split _ t1 t2).

Lemma congruent_perfect {A B : Type} (t1 : tree A) (t2 : tree B) :
  congruent t1 t2 -> perfect t1 -> perfect t2.
Proof.
  intro H. induction H; intros; try solve [constructor].
  inversion H1; subst. constructor; auto.
  apply congruent_symm in H.
  eapply congruent_trans; eauto.
  eapply congruent_trans; eauto.
Qed.

Fixpoint countb {A : Type} (f : A -> bool) (t : tree A) : nat :=
  match t with
  | Leaf _ x => if f x then 1 else 0
  | Fail _ => 0
  | Split _ t1 t2 => countb f t1 + countb f t2
  end.

Inductive count {A : Type} (f : A -> bool) : tree A -> nat -> Prop :=
| count_leaf0 : forall x, ~ f x -> count f (Leaf _ x) 0
| count_leaf1 : forall x, f x -> count f (Leaf _ x) 1
| count_fail : count f (Fail _) 0
| count_split : forall t1 t2 n m,
    count f t1 n -> count f t2 m ->
    count f (Split _ t1 t2) (n + m).

Lemma countb_spec {A : Type} (f : A -> bool) (t : tree A) :
  count f t (countb f t).
Proof.
  induction t; simpl; try solve [constructor; auto].
  destruct (f a) eqn:H; constructor; congruence.
Qed.

Fixpoint countb_list {A : Type} (f : A -> bool) (l : list A) : nat :=
  match l with
  | [] => 0
  | x :: xs => (if f x then 1 else 0) + countb_list f xs
  end.

Fixpoint terminals {A : Type} (t : tree A) : nat :=
  match t with
  | Leaf _ _ => 1
  | Fail _ => 1
  | Split _ t1 t2 => terminals t1 + terminals t2
  end.

Lemma terminals_nonzero {A : Type} (t : tree A) :
  (0 < terminals t)%nat.
Proof. induction t; simpl; omega. Qed.

Lemma perfect_congruent_terminals {A B : Type} (t1 : tree A) (t2 : tree B) :
  perfect t1 -> perfect t2 ->
  congruent t1 t2 ->
  terminals t1 = terminals t2.
Proof.
  revert t2.
  induction t1; intros t2 H0 H1 H2; inversion H2; subst; auto.
  - inversion H0; subst; inversion H1; subst; simpl; auto.
Qed.

Lemma Q_lem1 a b c d :
  (a#c) * (b#d) = (a*b#c*d).
Proof. reflexivity. Qed.

Lemma Q_lem2 a b c :
  (a#c) + (b#c) == (a+b#c).
Proof.
  rewrite 3!Qmake_Qdiv.
  rewrite inject_Z_plus. field.
  admit.
Admitted.

Lemma Q_lem3 (a b c : nat) :
  (c <> 0)%nat ->
  (1 # 2) * (Z.of_nat a # Pos.of_nat c) +
  (1 # 2) * (Z.of_nat b # Pos.of_nat c) ==
  Z.of_nat (a + b) # Pos.of_nat (c + c).
Proof.
  intro H0.
  rewrite 2!Q_lem1.
  rewrite 2!Z.mul_1_l.
  rewrite Nat2Z.inj_add.
  assert (H1: (c + c = 2 * c)%nat). omega.
  rewrite H1. clear H1.
  rewrite Nat2Pos.inj_mul; auto.
  apply Q_lem2.
Qed.

Lemma count_mass {A : Type} (t : tree A) (f : A -> bool) (n : nat) :
  perfect t ->
  countb f t = n ->
  mass (fun x => if f x then 1 else 0) t == (Z.of_nat n # Pos.of_nat (terminals t)).
Proof.
  revert n.
  induction t; intros n Hp Hc.
  - simpl in *; destruct (f a); subst; field.
  - simpl in *; subst; field.
  - simpl in *.
    inversion Hp; subst.
    specialize (IHt1 (countb f t1) H2 eq_refl).
    specialize (IHt2 (countb f t2) H3 eq_refl).
    rewrite IHt1, IHt2. clear IHt1 IHt2.
    apply (@perfect_congruent_terminals _ _ t1 t2) in H2; auto.
    rewrite H2.
    clear Hp H1 H2 H3.
    apply Q_lem3.
    generalize (terminals_nonzero t2); omega.
Qed.

Lemma new_bool_tree_height (n : nat) :
  heightb (new_bool_tree n) = n.
Proof.
  induction n; simpl; auto.
  - rewrite IHn, Nat.max_id; reflexivity.
Qed.

Lemma new_bool_tree_perfect (n : nat) :
  perfect (new_bool_tree n).
Proof. induction n; simpl; constructor; auto; apply congruent_refl. Qed.

Lemma congruent_heightb {A B : Type} (t1 : tree A) (t2 : tree B) :
  congruent t1 t2 ->
  heightb t1 = heightb t2.
Proof.
  intro H; induction H; auto; simpl;
    rewrite IHcongruent1, IHcongruent2; reflexivity.
Qed.

Lemma perfect_height_congruent {A B : Type} (t1 : tree A) (t2 : tree B) :
  perfect t1 -> perfect t2 ->
  heightb t1 = heightb t2 ->
  congruent t1 t2.
Proof.
  revert t2. induction t1; intros t2 Hp1 Hp2 Hh.
  - destruct t2; try constructor; inversion Hh.
  - destruct t2; try constructor; inversion Hh.
  - destruct t2.
    + inversion Hh.
    + inversion Hh.
    + simpl in *.
      inversion Hp1. inversion Hp2. subst.
      apply congruent_heightb in H1.
      apply congruent_heightb in H6.
      rewrite H1, H6 in *.
      rewrite 2!Nat.max_id in *.
      inversion Hh.
      constructor.
      * apply IHt1_1; firstorder.
      * apply IHt1_2; firstorder.
Qed.

Lemma perfect_new_tree_congruent {A : Type} (t : tree A) :
  perfect t ->
  congruent t (new_bool_tree (heightb t)).
Proof.
  intro Hp.
  apply perfect_height_congruent; auto.
  apply new_bool_tree_perfect.
  rewrite new_bool_tree_height; reflexivity.
Qed.

Lemma add_to_tree_congruent (b : bool) (t : tree (unit + bool)) :
  congruent t (add_to_tree b t).
Proof.
  induction t; simpl; try destruct a; try constructor.
  destruct (unit_bool_tree_eqb t1 (add_to_tree b t1));
    constructor; auto; apply congruent_refl.
Qed.

Lemma list_tree_aux_perfect (l : list bool) (t : tree (unit + bool)) :
  perfect t ->
  perfect (list_tree_aux l t).
Proof.
  revert t. induction l; auto.
  - intros t Hp. simpl.
    apply IHl.
    destruct (unit_bool_tree_eqb t (add_to_tree a t)).
    + assert (H0: congruent t (add_to_tree a (new_bool_tree (heightb t)))).
      { apply congruent_trans with (t2:=new_bool_tree (heightb t)).
        apply perfect_new_tree_congruent; auto.
        apply add_to_tree_congruent. }
      constructor; auto.
      * eapply congruent_perfect; eauto.
    + eapply congruent_perfect; eauto.
      apply add_to_tree_congruent.
Qed.

Lemma tie_tree_shape (t : tree (unit + bool)) :
  congruent t (tie_tree t).
Proof. induction t; try destruct a; constructor; auto. Qed.

Lemma bernoulli_perfect (n d : nat) :
  perfect (bernoulli_tree n d).
Proof.
  unfold bernoulli_tree.
  unfold list_tree.
  eapply congruent_perfect.
  apply tie_tree_shape.
  apply list_tree_aux_perfect.
  constructor.
Qed.

Lemma countb_tie_tree (f : bool -> bool) (t : tree (unit + bool)) :
  countb f (tie_tree t) = countb (fun x => match x with
                                        | inl _ => false
                                        | inr x' => f x'
                                        end) t.
Proof. induction t; simpl; auto; destruct a; auto. Qed.

Lemma add_to_tree_new_tree a n :
  unit_bool_tree_eqb (new_bool_tree n) (add_to_tree a (new_bool_tree n)) = false.
Proof.
  induction n; auto.
  simpl; rewrite 2!IHn; auto.
Qed.

Lemma countb_add_to_new_tree (f : bool -> bool) a n :
  countb (fun x : unit + bool => match x with
                           | inl _ => false
                           | inr x' => f x'
                           end) (add_to_tree a (new_bool_tree n)) =
  ((if f a then 1 else 0) +
   countb (fun x : unit + bool => match x with
                            | inl _ => false
                            | inr x' => f x'
                            end) (new_bool_tree n))%nat.
Proof.
  induction n; auto.
  simpl; rewrite add_to_tree_new_tree; simpl; rewrite IHn; omega.
Qed.

Lemma countb_new_tree (f : bool -> bool) n :
  countb (fun x : unit + bool => match x with
                           | inl _ => false
                           | inr x' => f x'
                           end) (new_bool_tree n) = O.
Proof. induction n; auto; simpl; rewrite IHn; auto. Qed.

Lemma countb_list_tree_aux f l t :
  countb (fun x => match x with
                | inl _ => false
                | inr x' => f x'
                end) (list_tree_aux l t) =
  (countb_list f l + countb (fun x => match x with
                                   | inl _ => false
                                   | inr x' => f x'
                                   end) t)%nat.
Proof.
  revert f t. induction l; intros f t; auto.
  simpl. destruct (unit_bool_tree_eqb t (add_to_tree a t)) eqn:H0.
  - rewrite IHl. simpl. clear IHl.
    rewrite countb_add_to_new_tree.
    rewrite countb_new_tree.
    omega.
  - rewrite IHl. clear IHl.
    cut ((countb (fun x : unit + bool => match x with
                                   | inl _ => false
                                   | inr x' => f x'
                                   end) (add_to_tree a t))%nat =
         ((if f a then 1 else 0) +
          countb (fun x : unit + bool => match x with
                                   | inl _ => false
                                   | inr x' => f x'
                                   end) t)%nat); try omega.
    (* NOTE: countb, add_to_tree *)
    induction t; simpl in *; try congruence.
    + destruct a0; simpl; try omega.
      unfold unit_bool_eqb in H0. rewrite eqb_reflx in H0. congruence.
    + destruct (unit_bool_tree_eqb t1 (add_to_tree a t1)) eqn:H1.
      * rewrite unit_bool_tree_eqb_refl in H0.
        simpl in H0.
        apply IHt2 in H0. clear IHt1 IHt2.
        simpl; omega.
      * specialize (IHt1 eq_refl). simpl; omega.
Qed.

Lemma list_tree_count (l : list bool) (f : bool -> bool) :
  countb f (list_tree l) = countb_list f l.
Proof.
  unfold list_tree. simpl.

  revert f. induction l; intro f; auto.
  simpl. rewrite <- IHl.
  rewrite 2!countb_tie_tree.
  rewrite 2!countb_list_tree_aux. simpl.
  destruct (f a); auto.
Qed.

Lemma countb_list_app {A : Type} (f : A -> bool) (l1 l2 : list A) :
  countb_list f (l1 ++ l2) = (countb_list f l1 + countb_list f l2)%nat.
Proof. induction l1; auto; simpl; rewrite IHl1; omega. Qed.

Lemma count_true_n (n : nat) :
  countb_list id (repeat true n) = n.
Proof. induction n; simpl; auto. Qed.

Lemma count_false_0 (n : nat) :
  countb_list id (repeat false n) = O.
Proof. induction n; simpl; auto. Qed.

Lemma bernoulli_count_n (n d : nat) :
  countb id (bernoulli_tree n d) = n.
Proof.
  unfold bernoulli_tree.
  rewrite list_tree_count.
  rewrite countb_list_app.
  rewrite count_true_n.
  rewrite count_false_0.
  apply Nat.add_0_r.
Qed.

Lemma list_tree_count_mass (l : list bool) :
  countb (fun _ => true) (list_tree l) = length l.
Proof.
  unfold list_tree. rewrite countb_tie_tree.
  rewrite countb_list_tree_aux. simpl. rewrite Nat.add_0_r.
  induction l; auto; simpl; rewrite IHl; auto.
Qed.

Lemma bernoulli_count_d (n d : nat) :
  (n <= d)%nat ->
  countb (fun _ => true) (bernoulli_tree n d) = d.
Proof.
  intros ?; unfold bernoulli_tree.
  rewrite list_tree_count_mass, app_length, 2!repeat_length; omega.
Qed.

Lemma bernoulli_tree_indicator_mass (n d : nat) :
  mass (fun b => if b:bool then 1 else 0) (bernoulli_tree n d) ==
  (Z.of_nat n # Pos.of_nat (terminals (bernoulli_tree n d))).
Proof.
  apply count_mass. apply bernoulli_perfect. apply bernoulli_count_n.
Qed.

Lemma bernoulli_tree_const_mass (n d : nat) :
  (n <= d)%nat ->
  mass (fun _ => 1) (bernoulli_tree n d) ==
  (Z.of_nat d # Pos.of_nat (terminals (bernoulli_tree n d))).
Proof.
  intro H.
  exact (@count_mass bool (bernoulli_tree n d) (fun _ => true) d
                     (bernoulli_perfect n d) (bernoulli_count_d n d H)).
Qed.

Lemma Q_lem4 (a b c : Q) :
  0 < b -> 0 < c ->
  (a / c) / (b / c) == a / b.
Proof. intros H0 H1; field; split; nra. Qed.

(* Maybe useful for below *)
(* Require Import Coq.PArith.BinPos. *)

Lemma Q_lem5 (a : Z) (b : nat) (c : positive) :
  (0 < b)%nat ->
  (a # c) / (Z.of_nat b # c) == a # Pos.of_nat b.
Proof.
  intro H0.
  rewrite 3!Qmake_Qdiv.
  rewrite Q_lem4.
  - cut (inject_Z (Z.of_nat b) == inject_Z (Z.pos (Pos.of_nat b))).
    { intro H1. rewrite H1. reflexivity. }
    cut (Z.pos (Pos.of_nat b) = Z.of_nat b).
    { intro H. rewrite H. reflexivity. }
    clear c. clear a.

    Eval compute in (Z.pos (Pos.of_nat 2)).
    Eval compute in (Z.of_nat 2).

    (* ugh *)
    admit.
Admitted.

Lemma bernoulli_tree_spec (n d : nat) :
  (0 < d)%nat -> (n <= d)%nat ->
  infer id (bernoulli_tree n d) == Z.of_nat n # Pos.of_nat d.
Proof.
  intros H0 H1. unfold infer.
  simpl. unfold id.
  rewrite bernoulli_tree_indicator_mass.
  rewrite bernoulli_tree_const_mass; auto.
  apply Q_lem5; auto.
Qed.


(*
Z_3 háromelemű (véges) típus, Z_3={0, 1, 2} ill. {n, a, b}
*)

Inductive Z_3 : Set :=
  | n : Z_3
  | a : Z_3
  | b : Z_3.

(*
Legyen belőle csoport, ami egy olyan algebrai struktúra, ahol van
op: G->G->G művelet,
ahol op asszociatív,
van z neutrális elem: op z x = x = op x z
van inv: inverz : op x (inv) x = z = op (inv x) x
Z_3-ban ez az összeadás:
*)

Definition ope (x:Z_3) (y:Z_3) :=
  match x , y with
  | n , y => y
  | x , n => x
  | a , b => n
  | b , a => n
  | a , a => b
  | b , b => a
  end.

Definition inve (x:Z_3) :=
  match x with
  | n => n
  | a => b
  | b => a
  end.

(*Absztrakt csoport definíciója Structure vagy Record környezettel: *)

Structure Group : Type := const_kozos
{
  A :> Set;

  op : A -> A -> A ;
  inv : A -> A ;
  z : A ;

  op_assoc : forall a b c, op a (op b c) = op (op a b) c;
  op_z : forall a, op a z = a /\ op z a = a ;
  op_inverse : forall a, op a (inv a) = z /\ op (inv a) a = z
}.

(*Z_3 a műveletekkel valóban csoport, amit
 a Group típus Z_3_group jelölésű eleme mutat, aminek a definíciója: *)

Theorem Z_3_group : Group.
Proof.
  apply (const_kozos Z_3 ope inve n).
  induction a0, b0, c; compute; auto.
  induction a0; auto.
  induction a0; auto.
Defined.

(*Minden véges típus algoritmikusan eldönthető, így Z_3 is: *)

Theorem Z_3_eq_dec : forall (x y: Z_3), x = y \/ x <> y.
Proof.
  induction x, y; auto; right; discriminate.
  Show Proof.
Defined.

(*A morfizmusok őshonos állatfajok a típuselméletben,
így a csoportok közötti G->H művelettartó leképezések is *)

Definition GroupMorphism (G:Group) (H:Group) (f:G->H) : Prop :=
    f(z G)=z H /\
    forall a:G, f(inv G a)=inv H (f(a)) /\
    forall a b : G, f(op G a b) = op H (f(a)) (f(b)).

(*Pl. a Z_1->Z_3, e|--->n leképezés is egy csoportmorfizmus *)

Inductive Z_1 : Set :=
  | e : Z_1.

Definition ope_1 (x:Z_1) (y:Z_1) :=
  match x , y with
  | e , e => e
  end.

Definition inve_1 x:Z_1 :=
  match x with
  | e => e
  end.

Theorem Z_1_group : Group.
Proof.
  apply (const_kozos Z_1 ope_1 inve_1 e).
  induction a0, b0, c; compute; auto.
  induction a0; auto.
  induction a0; auto.
Defined.

Definition f_Z_1_Z_3 : Z_1->Z_3 := fun (x:Z_1) => match x with e => n end.

Theorem f_Z_1_Z_3_csoportmorfizmus : GroupMorphism (Z_1_group) (Z_3_group) f_Z_1_Z_3.
Proof.
  unfold GroupMorphism.
  split.
  compute; auto.
  split.
  induction a0.
  compute; auto.
  induction a0, b0.
  induction a0.
  compute; auto.
Qed.

Inductive Z_6 : Set :=
  |z0 : Z_6
  |z1 : Z_6
  |z2 : Z_6
  |z3 : Z_6
  |z4 : Z_6
  |z5 : Z_6.

Definition inve6 (x:Z_6) :=
  match x with
  | z0 => z0
  | z1 => z5
  | z2 => z4
  | z3 => z3
  | z4 => z2
  | z5 => z1
  end.

(*Ezt Marits Marcitól csentem el, hogy teljes legyen a file.*)
Definition Z6_succ (x:Z_6) : Z_6 :=
match x with
  | z0 => z1
  | z1 => z2
  | z2 => z3
  | z3 => z4
  | z4 => z5
  | z5 => z0
  end.

Definition Z6_add (x : Z_6) (y : Z_6) : Z_6 :=
match x with
  |z0 => y
  |z1 => Z6_succ y
  |z2 => Z6_succ (Z6_succ y)
  |z3 => Z6_succ (Z6_succ (Z6_succ y))
  |z4 => Z6_succ (Z6_succ (Z6_succ (Z6_succ y)))
  |z5 => Z6_succ (Z6_succ (Z6_succ (Z6_succ (Z6_succ y))))
  end.

Theorem Z_3_eq_dec_mod : forall (x y: Z_3), x = y \/ x <> y.
Proof.
  induction x, y; auto; right; discriminate.
Defined.

Inductive szavak : Set :=
   | Hello : szavak -> szavak
   | world : szavak.

Definition mondat_1 : szavak.
  constructor 1.
  constructor 2.
  Show Proof.
Defined.

Definition mondat_2 : szavak.
  apply Hello.
  apply world.
Defined.

Theorem szavak_dec_1 : forall (x : szavak), x = world \/ x<>world.
  intros.
  induction x.
  right.
  discriminate.
  left.
  reflexivity.
  Show Proof.
Qed.


From stdpp Require Import prelude.
From Coq Require Import Streams Sorted.
From VLSM.Lib Require Import Preamble StreamExtras SortedLists ListExtras StdppExtras NeList.

(**
  Given a predicate <<P>> and a stream <<s>>, a stream of naturals <<ns>>
  determines a [filtering_subsequence] for <<P>> on <<s>> if it corresponds to
  the list of positions in <<ss>> where <<P>> holds, increasingly ordered.
*)
Definition filtering_subsequence
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ns : Stream nat)
  : Prop
  := (forall i, i < hd ns -> ~ P (Str_nth i s)) /\
     ForAll2 (fun m n => P (Str_nth m s) /\ m < n /\ forall i, m < i < n -> ~ P (Str_nth i s)) ns.

(**
  A more intuitive statement of the [filtering_subsequence] property.
  See [FilteringSubsequence_iff] for the equivalence result.
*)
Record FilteringSubsequence
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ns : Stream nat)
  : Prop :=
{
  fs_monotone : monotone_nat_stream_prop ns;
  fs_is_filter : forall n, P (Str_nth n s) <-> exists k, n = Str_nth k ns;
}.

Lemma filtering_subsequence_sorted
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ns : Stream nat)
  (Hfs : filtering_subsequence P s ns)
  : ForAll2 lt ns.
Proof.
  destruct Hfs as [_ Hfs].
  revert Hfs; apply ForAll2_subsumption.
  by intros a b H; apply H.
Qed.

Lemma filtering_subsequence_prefix_sorted
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ns : Stream nat)
  (Hfs : filtering_subsequence P s ns)
  : forall n, LocallySorted lt (stream_prefix ns n).
Proof.
  intro n. apply LocallySorted_ForAll2.
  apply stream_prefix_ForAll2.
  by apply filtering_subsequence_sorted in Hfs.
Qed.

Lemma filtering_subsequence_iff
  {A : Type}
  (P Q : A -> Prop)
  (HPQ : forall a, P a <-> Q a)
  (s : Stream A)
  (ss : Stream nat)
  : filtering_subsequence P s ss <-> filtering_subsequence Q s ss.
Proof.
  unfold filtering_subsequence.
  rewrite !ForAll2_forall.
  by setoid_rewrite <- HPQ.
Qed.

(**
  Each element in a [filtering_subsequence] is a position in the base
  stream for which the predicate holds.
*)
Lemma filtering_subsequence_witness
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ss : Stream nat)
  (Hfs : filtering_subsequence P s ss)
  (k : nat)
  : P (Str_nth (Str_nth k ss) s).
Proof.
  destruct Hfs as [_ Hfs].
  by rewrite ForAll2_forall in Hfs; apply Hfs.
Qed.

(**
  For each position in the base stream for which the predicate holds is
  present in the [filtering_subsequence].
*)
Lemma filtering_subsequence_witness_rev
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ss : Stream nat)
  (Hfs : filtering_subsequence P s ss)
  (n : nat)
  (Hn : P (Str_nth n s))
  : exists k, n = Str_nth k ss.
Proof.
  apply filtering_subsequence_sorted in Hfs as Hss_sorted.
  apply monotone_nat_stream_prop_from_successor in Hss_sorted.
  apply monotone_nat_stream_find with (n := n) in Hss_sorted.
  destruct Hss_sorted  as [Hlt | [k Hk]].
  - by destruct Hfs as [Hfs _]; elim (Hfs n).
  - destruct Hk as [Heq | Hk]; subst; [by exists k |].
    exfalso. apply proj2 in Hfs.
    rewrite ForAll2_forall in Hfs.
    specialize (Hfs k) as [_ [_ Hfs]].
    by elim (Hfs n).
Qed.

Lemma FilteringSubsequence_iff
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ss : Stream nat)
  : FilteringSubsequence P s ss <-> filtering_subsequence P s ss.
Proof.
  split.
  - intros []; split.
    + setoid_rewrite fs_is_filter0.
      intros i Hi [? ->].
      apply (fs_monotone0 x 0) in Hi.
      by lia.
    + apply ForAll2_forall; intros n; split_and!.
      * by apply fs_is_filter0; eexists.
      * by apply (fs_monotone0 n (S n)); lia.
      * setoid_rewrite fs_is_filter0.
        intros i [Hni Hni'] [? ->].
        by apply fs_monotone0 in Hni, Hni'; lia.
  - constructor.
    + by eapply monotone_nat_stream_prop_from_successor, filtering_subsequence_sorted.
    + split; [by apply filtering_subsequence_witness_rev |].
      by intros [? ->]; apply filtering_subsequence_witness.
Qed.

(** Prefixes of the filtering subsequence expressed as filters. *)
Lemma filtering_subsequence_prefix_is_filter
  {A : Type}
  (P : A -> Prop)
  {Pdec : forall a, Decision (P a)}
  (s : Stream A)
  (ss : Stream nat)
  (Hfs : filtering_subsequence P s ss)
  : forall (k : nat),
    stream_prefix ss (S k) =
    filter (fun i => P (Str_nth i s)) (stream_prefix nat_sequence (S (Str_nth k ss))).
Proof.
  intro k.
  apply (@set_equality_predicate _ lt _).
  - by apply filtering_subsequence_prefix_sorted with P s.
  - apply LocallySorted_filter.
    + by typeclasses eauto.
    + by apply nat_sequence_prefix_sorted.
  - unfold ListSetExtras.set_eq, subseteq, list_subseteq.
    setoid_rewrite elem_of_list_filter.
    setoid_rewrite elem_of_stream_prefix.
    setoid_rewrite nat_sequence_nth.
    split; intros.
    + destruct H as [i [Hi Ha]].
      subst.
      split; [by apply filtering_subsequence_witness |].
      eexists; split; [| done].
      destruct (decide (i = k)); [subst; lia |].
      cut (Str_nth i ss < Str_nth k ss); [lia |].
      apply ForAll2_transitive_lookup; [by typeclasses eauto | | lia].
      by apply filtering_subsequence_sorted in Hfs.
    + destruct H as [Hpa [_a [Hlt H_a]]].
      subst _a.
      destruct (filtering_subsequence_witness_rev _ _ _ Hfs _ Hpa) as [k' ->].
      exists k'.
      split; [| done].
      apply filtering_subsequence_sorted in Hfs.
      apply monotone_nat_stream_prop_from_successor in Hfs.
      specialize (monotone_nat_stream_rev _ Hfs k' k) as Hle.
      by feed specialize Hle; lia.
Qed.

Lemma filtering_subsequence_prefix_length
  {A : Type}
  (P : A -> Prop)
  {Pdec : forall a, Decision (P a)}
  (s : Stream A)
  (ss : Stream nat)
  (Hfs : filtering_subsequence P s ss)
  (m : nat)
  : length (filter P (stream_prefix s (S (Str_nth m ss)))) = S m.
Proof.
  specialize (filtering_subsequence_prefix_is_filter _ _ _ Hfs m) as Hfilter.
  apply f_equal with (f := length) in Hfilter.
  rewrite stream_prefix_length in Hfilter.
  rewrite! stream_prefix_S, filter_app in Hfilter.
  unfold filter at 2 in Hfilter. simpl in Hfilter.
  rewrite nat_sequence_nth in Hfilter.
  rewrite stream_prefix_S, filter_app.
  unfold filter at 2. simpl.
  specialize (filtering_subsequence_witness _ _ _ Hfs m) as Hm.
  rewrite decide_True in Hfilter by done.
  rewrite decide_True by done.
  rewrite app_length, Nat.add_comm in Hfilter. simpl in Hfilter.
  rewrite app_length, Nat.add_comm. simpl.
  rewrite Hfilter.
  f_equal.
  clear -Hfs.
  generalize (Str_nth m ss).
  induction n; [done |].
  rewrite !stream_prefix_S, !filter_app, !app_length, IHn.
  f_equal. rewrite nat_sequence_nth.
  by cbn; case_decide.
Qed.

Lemma filtering_subsequence_prefix_is_filter_last
  {A : Type}
  (P : A -> Prop)
  {Pdec : forall a, Decision (P a)}
  (s : Stream A)
  (ss : Stream nat)
  (Hfs : filtering_subsequence P s ss)
  (n : nat)
  (Hn : P (Str_nth n s))
  : Str_nth (length (filter P (stream_prefix s n))) ss = n.
Proof.
  specialize (filtering_subsequence_witness_rev _ _ _ Hfs _ Hn) as [k Heqn].
  replace (length _) with k; [by subst |].
  specialize (filtering_subsequence_prefix_length _ _ _ Hfs k) as Hlength.
  rewrite! stream_prefix_S, filter_app in Hlength.
  unfold filter at 2 in Hlength. simpl in Hlength.
  rewrite decide_True in Hlength by (subst; done).
  rewrite app_length, Nat.add_comm in Hlength. simpl in Hlength.
  by inversion Hlength; subst.
Qed.

(**
  Given a [filtering_subsequence] for property <<P>> over a stream <<s>> and
  a function <<f>> transforming elements with property <<P>>, we can define the
  filtering of <<s>> by <<P>> mapped through the function <<f>>.
*)
Definition filtering_subsequence_stream_filter_map
  {A B : Type}
  (P : A -> Prop)
  {Pdec : forall a, Decision (P a)}
  (f : dsig P -> B)
  (s : Stream A)
  (ss : Stream nat)
  (Hfs : filtering_subsequence P s ss)
  : Stream B
  := map (fun k => f (dexist _ (filtering_subsequence_witness P s ss Hfs k))) nat_sequence.

(**
  Connecting prefixes of [filtering_subsequence_stream_filter_map] with
  [list_filter_map]s on prefixes.
*)
Lemma fitering_subsequence_stream_filter_map_prefix
  {A B : Type}
  (P : A -> Prop)
  {Pdec : forall a, Decision (P a)}
  (f : dsig P -> B)
  (s : Stream A)
  (ss : Stream nat)
  (Hfs : filtering_subsequence P s ss)
  (n : nat)
  (pre_filter_map := list_filter_map P f (stream_prefix s n))
  (m := length pre_filter_map)
  : stream_prefix (filtering_subsequence_stream_filter_map P f s ss Hfs) m = pre_filter_map.
Proof.
  subst m pre_filter_map.
  induction n; [done |].
  rewrite stream_prefix_S, list_filter_map_app, app_length.
  remember (list_filter_map P f [Str_nth n s]) as lst.
  unfold list_filter_map in Heqlst.
  rewrite filter_annotate_unroll in Heqlst. simpl in Heqlst.
  case_decide; subst lst; simpl; [| by rewrite Nat.add_comm, app_nil_r].
  replace (length (list_filter_map P f (stream_prefix s n)) + 1)
    with (S (length (list_filter_map P f (stream_prefix s n))))
    by lia.
  rewrite stream_prefix_S.
  rewrite IHn.
  f_equal. f_equal.
  unfold filtering_subsequence_stream_filter_map.
  rewrite Str_nth_map.
  f_equal. apply dsig_eq.
  simpl. rewrite nat_sequence_nth.
  f_equal.
  unfold list_filter_map.
  rewrite map_length. rewrite filter_annotate_length.
  by apply filtering_subsequence_prefix_is_filter_last.
Qed.

Program Definition fitering_subsequence_stream_filter_map_prefix_ex
  {A B : Type}
  (P : A -> Prop)
  {Pdec : forall a, Decision (P a)}
  (f : dsig P -> B)
  (s : Stream A)
  (ss : Stream nat)
  (Hfs : filtering_subsequence P s ss)
  (m : nat)
  : {n : nat |
      stream_prefix (filtering_subsequence_stream_filter_map P f s ss Hfs) m =
      list_filter_map P f (stream_prefix s n)}
  :=
  match m with
  | 0 => exist _ 0 _
  | S m => exist _ (S (Str_nth m ss)) _
  end.
Next Obligation.
Proof. done. Qed.
Next Obligation.
Proof.
  intros. subst.
  specialize (fitering_subsequence_stream_filter_map_prefix P f _ _ Hfs (S (Str_nth m ss))) as Heq.
  remember (S m) as Sm.
  simpl in *.
  rewrite <- Heq.
  f_equal.
  unfold list_filter_map.
  rewrite map_length. rewrite filter_annotate_length.
  symmetry. subst.
  by apply filtering_subsequence_prefix_length.
Qed.

Lemma stream_filter_Forall
  {A : Type}
  (P : A -> Prop)
  (s : Stream A)
  (ss : Stream nat)
  (s' := stream_subsequence s ss)
  (Hfs : filtering_subsequence P s ss)
  : ForAll1 P s'.
Proof.
  apply ForAll1_forall.
  intro n.
  unfold s'.
  unfold stream_subsequence.
  rewrite Str_nth_map.
  by apply filtering_subsequence_witness.
Qed.

(** ** Obtaining [filtering_sequences] for streams

  Given a stream, a decidable predicate on its elements, and a guarantee that the
  predicates holds [InfinitelyOften] on the elements of the stream, we can
  (coinductively) obtain a [filtering_sequence].

  The approach below follows closely the one proposed by the following paper,
  except that instead of obtaining the filtered sequence itself we obtain the
  stream of all positions corresponding to the filtered sequence.

  Yves Bertot. Filters on Co-Inductive streams: an application to Eratosthenes’ sieve.
  RR-5343, INRIA. 2004, pp.21. ffinria-00070658 https://hal.inria.fr/inria-00070658/document
*)

Section sec_stream_filter_positions.

Context
  [A : Type]
  (P : A -> Prop)
  {Pdec : forall a, Decision (P a)}
  .

(**
  Given a stream <<s>> and a proof that there exists an element of <<s>> for
  which <<P>> holds, computes the first position of <<s>> in which <<P>> holds
  (shifted by the given argument <<n>>) and the remainder of <<s>> after that
  position.

  The definition iterates looking for the first position in which <<P>> holds,
  termination being ensured by the fact that [Exists1] is inductive.
*)
Fixpoint stream_filter_fst_pos
  (s : Stream A)
  (Hev : Exists1 P s)
  (n : nat)
  {struct Hev}
  : nat * Stream A.
Proof.
  refine
    (match decide (P (hd s)) with
      | left p => (n, tl s)
      | right _ =>
        stream_filter_fst_pos (tl s) _ (S n)
     end).
  by destruct Hev.
Defined.

Lemma stream_filter_fst_pos_characterization
  (s : Stream A)
  (Hev : Exists1 P s)
  (n : nat)
  : exists k,
    stream_filter_fst_pos s Hev n = (n + k, Str_nth_tl (S k) s) /\
    P (Str_nth k s) /\ (forall i, i < k -> ~ P (Str_nth i s)).
Proof.
  revert s Hev n.
  fix H 2.
  intros.
  destruct Hev; simpl.
  - destruct (decide _); [| done].
    by exists 0; split_and!; f_equal; [lia | | lia].
  - destruct (decide _); simpl.
    + by exists 0; split_and!; f_equal; [lia | | lia].
    + specialize (H (tl s) Hev (S n)) as (k & Heq & Hp & Hnp).
      exists (S k). rewrite Heq.
      split; [f_equal; lia |].
      split; [done |].
      intros. destruct i; [done |].
      by apply Hnp; lia.
Qed.

Lemma stream_filter_fst_pos_infinitely_often
  (s : Stream A)
  (Hev : Exists1 P s)
  (n : nat)
  : InfinitelyOften P s -> InfinitelyOften P (stream_filter_fst_pos s Hev n).2.
Proof.
  destruct (stream_filter_fst_pos_characterization s Hev n) as (k & -> & _).
  by apply InfinitelyOften_nth_tl.
Qed.

Lemma stream_filter_fst_pos_le
  (s : Stream A)
  (Hev : Exists1 P s)
  (n : nat)
  : n <= (stream_filter_fst_pos s Hev n).1.
Proof.
  destruct (stream_filter_fst_pos_characterization s Hev n) as (k & -> & _).
  by cbn; lia.
Qed.

Lemma stream_filter_fst_pos_nth_tl_has_property
  (s : Stream A)
  (n : nat)
  (sn := Str_nth_tl n s)
  (Hev : Exists1 P sn)
  (fpair := stream_filter_fst_pos (Str_nth_tl n s) Hev n)
  : P (Str_nth fpair.1 s) /\
    forall i, n <= i < fpair.1 -> ~ P (Str_nth i s).
Proof.
  specialize (stream_filter_fst_pos_characterization sn Hev n)
    as [k [Heq [Hp Hnp]]].
  subst sn fpair.
  rewrite Heq.
  clear -Hp Hnp. rewrite Str_nth_plus, Nat.add_comm in Hp.
  split; [done |].
  intros i [Hlt_i Hilt].
  apply stdpp_nat_le_sum in Hlt_i as [i' ->].
  rewrite Nat.add_comm, <- Str_nth_plus.
  by apply Hnp; cbn in *; lia.
Qed.

(**
  Given as stream <<s>> for which predicate <<P>> holds [InfinitelyOften]
  produces the streams of all its position at which <<P>> holds in a strictly
  increasing order (shifted by the given argument <<n>>).
*)
CoFixpoint stream_filter_positions
  (s : Stream A) (Hinf : InfinitelyOften P s) (n : nat) : Stream nat :=
  let fpair := stream_filter_fst_pos _ (fHere _ _ Hinf) n in
  Cons fpair.1 (stream_filter_positions fpair.2
    (stream_filter_fst_pos_infinitely_often _ (fHere _ _ Hinf) n Hinf)  (S fpair.1)).

Lemma stream_filter_positions_unroll (s : Stream A) (Hinf : InfinitelyOften P s) (n : nat)
  (fpair := stream_filter_fst_pos _ (fHere _ _ Hinf) n)
  : stream_filter_positions s Hinf n =
    Cons fpair.1 (stream_filter_positions fpair.2
      (stream_filter_fst_pos_infinitely_often _ (fHere _ _ Hinf) n Hinf)  (S fpair.1)).
Proof.
  by rewrite <- recons at 1.
Qed.

Lemma stream_filter_positions_Str_nth_tl
  (s : Stream A) (Hinf : InfinitelyOften P s) (n0 : nat) (n : nat)
  : exists kn (Hinf' : InfinitelyOften P (Str_nth_tl (S kn) s)),
    Str_nth_tl n (stream_filter_positions s Hinf n0) =
    Cons (n0 + kn) (stream_filter_positions (Str_nth_tl (S kn) s) Hinf' (S (n0 + kn))) /\
    P (Str_nth kn s).
Proof.
  induction n.
  - simpl. rewrite (stream_filter_positions_unroll s Hinf n0).
    specialize
      (stream_filter_fst_pos_characterization s (fHere _ s Hinf) n0)
        as [k [Heq [Hp _]]].
    assert (Hk : (stream_filter_fst_pos s (fHere (Exists1 P) s Hinf) n0).1 = n0 + k).
    { by rewrite Heq. }
    assert (Htl : (stream_filter_fst_pos s (fHere (Exists1 P) s Hinf) n0).2 = Str_nth_tl (S k) s).
    { by rewrite Heq. }
    exists k.
    by rewrite Hk; cbn in *; rewrite <- Htl; eauto.
  - replace
      (Str_nth_tl (S n) (stream_filter_positions s Hinf n0))
      with (tl (Str_nth_tl n (stream_filter_positions s Hinf n0)))
      by apply tl_nth_tl.
    destruct IHn as [kn [Hinfn [Hsn Hpn]]].
    rewrite Hsn.
    simpl. rewrite (stream_filter_positions_unroll (Str_nth_tl kn (tl s)) Hinfn (S (n0 + kn))).
    specialize
      (stream_filter_fst_pos_characterization (Str_nth_tl kn (tl s)) (fHere _ _ Hinfn) (S (n0 + kn)))
        as [k [Heq [Hp _]]].
    match type of Heq with
    | ?pair = (?f, ?s) =>
      assert (Hk : pair.1 = f) by (rewrite Heq; done);
      assert (Htl : pair.2 = s) by (rewrite Heq; done)
    end.
    simpl in Hk.  rewrite Hk.
    simpl in Htl.
    exists (S (k + kn)).
    simpl.
    rewrite tl_nth_tl, Str_nth_tl_plus in Htl.
    rewrite Str_nth_plus in Hp.
    rewrite <- Htl.
    by replace (n0 + S (k + kn)) with (S (n0 + kn + k)) by lia; eauto.
Qed.

Lemma stream_filter_positions_monotone
  (s : Stream A) (Hinf : InfinitelyOften P s) (n : nat)
  : monotone_nat_stream_prop (stream_filter_positions s Hinf n).
Proof.
  apply monotone_nat_stream_prop_from_successor.
  revert s Hinf n.
  cofix H.
  intros.
  constructor; simpl; [| by apply H].
  by apply stream_filter_fst_pos_le.
Qed.

(** [stream_filter_positions] produces a [filtering_sequence]. *)
Lemma stream_filter_positions_filtering_subsequence
  (s : Stream A) (Hinf : InfinitelyOften P s)
  : filtering_subsequence P s (stream_filter_positions s Hinf 0).
Proof.
  split.
  - specialize (stream_filter_fst_pos_characterization s (fHere (Exists1 P) s Hinf) 0)
      as [k [Heq [Hpk Hnp]]].
    simpl in Heq.
    by rewrite stream_filter_positions_unroll; cbn; rewrite Heq.
  - apply ForAll2_forall.
    intro n.
    specialize (stream_filter_positions_Str_nth_tl s Hinf 0 n) as Hnth_tl.
    simpl in Hnth_tl.
    remember (stream_filter_positions s Hinf 0).
    destruct Hnth_tl as [kn [Hnth_inf [Hnth Hnth_p]]].
    unfold Str_nth. simpl. rewrite <- tl_nth_tl.
    rewrite stream_filter_positions_unroll in Hnth.
    specialize (stream_filter_fst_pos_characterization
      (Str_nth_tl kn (tl s)) (fHere _ _ Hnth_inf) (S kn))
      as [k [Heq [Hpk Hnp]]].
    rewrite Hnth; simpl.
    split; [done |].
    rewrite Heq. simpl.
    split; [lia |].
    intros i [Hle Hlt].
    apply stdpp_nat_le_sum in Hle as [k' ->].
    rewrite Nat.add_comm, <- Str_nth_tl_plus. simpl.
    by apply Hnp; lia.
Qed.

(**
  A restatement of [filtering_subsequence_stream_filter_map] based on the
  [InfinitelyOften] predicate, using the [stream_filter_positions_filtering_subsequence].
*)
Definition stream_filter_map
  [B : Type]
  (f : dsig P -> B)
  (s : Stream A)
  (Hinf : InfinitelyOften P s)
  : Stream B :=
  filtering_subsequence_stream_filter_map P f _ _
    (stream_filter_positions_filtering_subsequence s Hinf).

(** Stream filtering is obtained as a specialization of [stream_filter_map]. *)
Definition stream_filter
  (s : Stream A)
  (Hinf : InfinitelyOften P s)
  : Stream A :=
  stream_filter_map proj1_sig s Hinf.

End sec_stream_filter_positions.

Section sec_stream_map_option.

(** ** Mapping a partial function on a stream

  Given a partial function <<f>> which is [InfinitelyOften] defined on the
  elements of a stream <<s>>, we can define the stream of the defined mapped
  values of <<s>> through <<f>> as a particular [stream_filter_map].
*)

Context
  [A B : Type]
  (f : A -> option B)
  (P : A -> Prop := is_Some ∘ f)
  (s : Stream A)
  .

Definition stream_map_option
  (Hinf : InfinitelyOften P s)
  : Stream B :=
  stream_filter_map P (fun k : dsig P => is_Some_proj (proj2_dsig k)) s Hinf.

Lemma stream_map_option_prefix
  (Hinf : InfinitelyOften P s)
  (n : nat)
  (map_opt_pre := map_option f (stream_prefix s n))
  (m := length map_opt_pre)
  : stream_prefix (stream_map_option Hinf) m = map_opt_pre.
Proof.
  subst map_opt_pre m.
  rewrite !(map_option_as_filter f (stream_prefix s n)).
  by apply fitering_subsequence_stream_filter_map_prefix.
Qed.

Program Definition stream_map_option_prefix_ex
  (Hinf : InfinitelyOften P s)
  (Hfs := stream_filter_positions_filtering_subsequence _ _ Hinf)
  (k : nat)
  : { n | stream_prefix (stream_map_option Hinf) k = map_option f (stream_prefix s n)} :=
  let (n, Heq) := (fitering_subsequence_stream_filter_map_prefix_ex P
                    (fun k => is_Some_proj (proj2_dsig k)) _ _ Hfs k)
  in exist _ n _.
Next Obligation.
Proof.
  by intros; cbn; rewrite !map_option_as_filter.
Qed.

Definition bounded_stream_map_option
  (Hfin : FinitelyManyBound P s)
  : list B :=
  map_option f (stream_prefix s (` Hfin)).

End sec_stream_map_option.

Section sec_stream_concat_map.

(** ** Mapping a function expanding elements to lists of elements on a stream

  Given a function <<f>> which [InfinitelyOften] produces non-empty lists from
  the elements of a stream <<s>>, we can define the stream obtained by
  concatenating the values of <<s>> through <<f>>.
*)

Context
  [A B : Type]
  (f : A -> list B)
  (FNonEmpty : A -> Prop := fun a => f a <> [])
  (s : Stream A)
  .

Definition stream_concat_map
  (Hinf : InfinitelyOften FNonEmpty s)
  : Stream B :=
  stream_concat (stream_filter_map FNonEmpty (list_function_restriction f) s Hinf).

Lemma stream_concat_map_prefix
  (Hinf : InfinitelyOften FNonEmpty s)
  (n : nat)
  (mbind_prefix := mbind f (stream_prefix s n))
  (m := length mbind_prefix)
  : stream_prefix (stream_concat_map Hinf) m = mbind_prefix.
Proof.
  subst mbind_prefix m; unfold stream_concat_map.
  cut (mjoin
    (List.map ne_list_to_list
      (list_filter_map (fun a : A => f a <> []) (list_function_restriction f)
          (stream_prefix s n))) = mbind f (stream_prefix s n)).
  {
    intros <-.
    by erewrite stream_concat_prefix;
      unfold stream_filter_map;
      rewrite fitering_subsequence_stream_filter_map_prefix.
  }
  by apply list_filter_map_mbind.
Qed.

Program Definition stream_concat_map_ex_prefix
  (Hinf : InfinitelyOften FNonEmpty s)
  (Hfs := stream_filter_positions_filtering_subsequence _ _ Hinf)
  (k : nat)
  : {n : nat |
      stream_prefix (stream_concat_map Hinf) k
        `prefix_of`
      mbind f (stream_prefix s n)}
  :=
  let (n, Heq) :=
    (fitering_subsequence_stream_filter_map_prefix_ex
      FNonEmpty (list_function_restriction f) _ _ Hfs k)
  in exist _ n _.
Next Obligation.
Proof.
  cbn; intros Hinf k n Heq.
  rewrite <- (stream_concat_map_prefix Hinf).
  apply stream_prefix_of.
  rewrite <- list_filter_map_mbind.
  replace k
    with (length (list_filter_map FNonEmpty (list_function_restriction f) (stream_prefix s n)))
    by (rewrite <- Heq; apply stream_prefix_length).
  by apply ne_list_concat_min_length.
Qed.

Program Definition stream_concat_map_ex_min_prefix
  `{EqDecision B}
  (Hinf : InfinitelyOften FNonEmpty s)
  (k : nat)
  (Ppre := fun m =>
    stream_prefix (stream_concat_map Hinf) k
      `prefix_of`
    mbind f (stream_prefix s m))
  : {n : nat | minimal_among le Ppre n}
  :=
  let (n, Hpre) :=  stream_concat_map_ex_prefix Hinf k in
  exist _ (find_least_among Ppre n) _.
Next Obligation.
Proof.
  by intros; apply find_least_among_is_minimal.
Qed.

Definition bounded_stream_concat_map
  (Hfin : FinitelyManyBound FNonEmpty s)
  : list B :=
  mbind f (stream_prefix s (` Hfin)).

End sec_stream_concat_map.

(**
  For a totally defined function, [stream_map_option] corresponds to the
  regular [map] on streams.
*)
Lemma stream_map_option_EqSt [A B : Type] (f : A -> B)
  : forall s (Hinf : InfinitelyOften (is_Some ∘ (Some ∘ f)) s),
  EqSt (map f s) (stream_map_option (Some ∘ f) s Hinf).
Proof.
  intros. apply EqSt_stream_prefix. intro n.
  destruct n; [done |].
  rewrite <- stream_prefix_map.

  pose (stream_map_option_prefix_ex (Some ∘ f) s Hinf (S n)) as Hrew.
  rewrite (proj2_sig Hrew).
  replace (` Hrew) with (S n); [done |].
  simpl. f_equal. clear.
  cut
    (forall k, Streams.Str_nth n
      (stream_filter_positions (is_Some ∘ (Some ∘ f)) s Hinf k) = k + n).
  { intros Hk. specialize (Hk 0). simpl in Hk. congruence.  }
  revert s Hinf.
  assert (Hfirst : forall s Hinf k,
    (stream_filter_fst_pos (is_Some ∘ (Some ∘ f)) s (fHere _ _ Hinf) k).1 = k).
  { intros.
    match goal with
    |- fst (stream_filter_fst_pos ?P s ?Hex k) = k =>
      specialize (stream_filter_fst_pos_characterization P s Hex k)
        as [_k [Heq1 [_ H_k]]]
    end.
    rewrite Heq1.
    simpl.
    destruct _k; [lia |].
    by exfalso; apply (H_k 0); [lia | eexists].
  }
  induction n; intros; rewrite stream_filter_positions_unroll; unfold Streams.Str_nth; simpl.
  - by rewrite Hfirst; lia.
  - unfold Streams.Str_nth in IHn.
    by rewrite IHn, Hfirst; lia.
Qed.


Require Import ProofWeb.

Parameter A B C : Prop.

Hypothesis P1: (A -> B).
Hypothesis P2: (B -> C).

Theorem c0n002 : (A -> C).
Proof.
imp_i h1.
imp_e B.
exact P2.
imp_e A.
exact P1.
exact h1.

Qed.


(** * Auto: More Automation *)

(** Before we start on the next major topic, let's spend a
    little time learning to use some of Coq's more powerful automation
    features... *)

Require Export Smallstep.

(* ###################################################################### *)
(** * The [auto] and [eauto] Tactics *)

(** The [auto] tactic solves goals that are solvable by any combination of
     - [intros],
     - [apply] (with a local hypothesis, by default), and
     - [reflexivity].

    The [eauto] tactic works just like [auto], except that it uses
    [eapply] instead of [apply]. *)

(** Using [auto] is always "safe" in the sense that it will never fail
    and will never change the proof state: either it completely solves
    the current goal, or it does nothing.

    Here is a contrived example: *)

Lemma auto_example_1 : forall P Q R S T U : Prop,
  (P -> Q) ->
  (P -> R) ->
  (T -> R) ->
  (S -> T -> U) ->
  ((P->Q) -> (P->S)) ->
  T ->
  P ->
  U.
Proof. auto. Qed.

(** When searching for potential proofs of the current goal, [auto]
    and [eauto] consider the hypotheses in the current context
    together with a _hint database_ of other lemmas and constructors.
    Some of the lemmas and constructors we've already seen -- e.g.,
    [conj], [or_introl], and [or_intror] -- are installed in this hint
    database by default. *)

Lemma auto_example_2 : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof.
  auto. Qed.

(** We can extend the hint database just for the purposes of one
    application of [auto] or [eauto] by writing [auto using ...].
    E.g., if [conj], [or_introl], and [or_intror] had _not_ already
    been in the hint database, we could have done this instead: *)

Lemma auto_example_2a : forall P Q R : Prop,
  Q ->
  (Q -> R) ->
  P \/ (Q /\ R).
Proof.
  auto using conj, or_introl, or_intror.  Qed.

(** Of course, in any given development there will also be some of our
    own specific constructors and lemmas that are used very often in
    proofs.  We can add these to the global hint database by writing
      Hint Resolve T.
    at the top level, where [T] is a top-level theorem or a
    constructor of an inductively defined proposition (i.e., anything
    whose type is an implication).  As a shorthand, we can write
      Hint Constructors c.
    to tell Coq to do a [Hint Resolve] for _all_ of the constructors
    from the inductive definition of [c].

    It is also sometimes necessary to add
      Hint Unfold d.
    where [d] is a defined symbol, so that [auto] knows to expand
    uses of [d] and enable further possibilities for applying
    lemmas that it knows about. *)

(** Here are some [Hint]s we will find useful. *)

Hint Constructors multi.
Hint Resolve beq_id_eq beq_id_false_not_eq.

(** Warning: Just as with Coq's other automation facilities, it
    is easy to overuse [auto] and [eauto] and wind up with proofs that
    are impossible to understand later!  Also, overuse of [eauto] can
    make proof scripts very slow.  Get in the habit of using [auto]
    most of the time and [eauto] only when necessary.

    For much more detailed information about using [auto] and [eauto],
    see the chapter [UseAuto]. *)

(* ###################################################################### *)
(** * The [Proof with] Tactic *)

(** If you start a proof by saying [Proof with (tactic)] instead of
    just [Proof], then writing [...] instead of [.] after a tactic in
    the body of the proof will try to solve all generated subgoals
    with [tactic] (and fail if this doesn't work).

    One common use of this facility is "[Proof with auto]" (or
    [eauto]).  We'll see many examples of this later in the file. *)

(* ###################################################################### *)
(** * The [solve by inversion] Tactic *)

(** Here's another nice automation feature: it often arises that the
    context contains a contradictory assumption and we want to use
    [inversion] on it to solve the goal.  We'd like to be able to say
    to Coq, "find a contradictory assumption and invert it" without
    giving its name explicitly.

    Doing [solve by inversion] will find a hypothesis that can be
    inverted to solve the goal, if there is one.  The tactics [solve
    by inversion 2] and [solve by inversion 3] are slightly fancier
    versions which will perform two or three inversions in a row, if
    necessary, to solve the goal.

    (These tactics are not actually built into Coq -- their
    definitions are in [Sflib].)

    Caution: Overuse of [solve by inversion] can lead to slow proof
    scripts. *)

(* ###################################################################### *)
(** * The [try solve] Tactic *)

(** If [t] is a tactic, then [try solve [t]] is a tactic that
      - if [t] solves the goal, behaves just like [t], or
      - if [t] cannot completely solve the goal, does
        nothing.

    More generally, [try solve [t1 | t2 | ...]] will try to solve the
    goal by using [t1], [t2], etc.  If none of them succeeds in
    completely solving the goal, then [try solve [t1 | t2 | ...]] does
    nothing. *)

(* ###################################################################### *)
(** * The [f_equal] Tactic *)

(** [f_equal] replaces a goal of the form [f x1 x2 ... xn = f y1 y2
    ... yn], where [f] is some function, with the subgoals [x1 = y1],
    [x2 = y2],...,[xn = yn].  It is useful for avoiding explicit
    rewriting steps, and often the generated subgoals can be quickly
    cleared by [auto].  This tactic is not fundamental, in the sense
    that it can always be replaced by a sequence of [assert]s.
    However in some cases it can be very handy. *)

(* ###################################################################### *)
(** * The [normalize] Tactic *)

(** When experimenting with definitions of programming languages in
    Coq, we often want to see what a particular concrete term steps
    to -- i.e., we want to find proofs for goals of the form [t ==>*
    t'], where [t] is a completely concrete term and [t'] is unknown.
    These proofs are simple but repetitive to do by hand. Consider for
    example reducing an arithmetic expression using the small-step
    relation [astep] defined in the previous chapter: *)

Definition amultistep st := multi (astep st).
Notation " t '/' st '==>a*' t' " := (amultistep st t t')
  (at level 40, st at level 39).

Example astep_example1 :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  apply multi_step with (APlus (ANum 3) (ANum 12)).
    apply AS_Plus2.
      apply av_num.
      apply AS_Mult.
  apply multi_step with (ANum 15).
    apply AS_Plus.
  apply multi_refl.
Qed.

(** We repeatedly apply [multi_step] until we get to a normal
    form. The proofs that the intermediate steps are possible are
    simple enough that [auto], with appropriate hints, can solve
    them. *)

Hint Constructors astep aval.
Example astep_example1' :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  eapply multi_step. auto. simpl.
  eapply multi_step. auto. simpl.
  apply multi_refl.
Qed.

(** The following custom [Tactic Notation] definition captures this
    pattern.  In addition, before each [multi_step] we print out the
    current goal, so that the user can follow how the term is being
    evaluated. *)

Tactic Notation "print_goal" := match goal with |- ?x => idtac x end.
Tactic Notation "normalize" :=
   repeat (print_goal; eapply multi_step ;
             [ (eauto 10; fail) | (instantiate; simpl)]);
   apply multi_refl.

Example astep_example1'' :
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* (ANum 15).
Proof.
  normalize.
  (* At this point in the proof script, the Coq response shows
     a trace of how the expression evaluated.

   (APlus (ANum 3) (AMult (ANum 3) (ANum 4)) / empty_state ==>a* ANum 15)
   (multi (astep empty_state) (APlus (ANum 3) (ANum 12)) (ANum 15))
   (multi (astep empty_state) (ANum 15) (ANum 15))
*)
Qed.

(** The [normalize] tactic also provides a simple way to calculate
    what the normal form of a term is, by proving a goal with an
    existential variable in it. *)

Example astep_example1''' : exists e',
  (APlus (ANum 3) (AMult (ANum 3) (ANum 4))) / empty_state
  ==>a* e'.
Proof.
  eapply ex_intro. normalize.

(* This time, the trace will be:

    (APlus (ANum 3) (AMult (ANum 3) (ANum 4)) / empty_state ==>a* ??)
    (multi (astep empty_state) (APlus (ANum 3) (ANum 12)) ??)
    (multi (astep empty_state) (ANum 15) ??)

   where ?? is the variable ``guessed'' by eapply.
*)
Qed.

(** **** Exercise: 1 star (normalize_ex) *)
Theorem normalize_ex : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(** **** Exercise: 1 star, optional (normalize_ex') *)
(** For comparison, prove it using [apply] instead of [eapply]. *)

Theorem normalize_ex' : exists e',
  (AMult (ANum 3) (AMult (ANum 2) (ANum 1))) / empty_state
  ==>a* e'.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* $Date: 2013-04-10 10:12:40 -0400 (Wed, 10 Apr 2013) $ *)


(** Interpretation of a hypersequent as a term in NNF *)
Require Import Rpos.
Require Import RL.hmr.term.
Require Import RL.hmr.hseq.
Require Import RL.hmr.semantic.

Require Import List.
Require Import Lra.

Require Import RL.OLlibs.Permutation_Type_more.

Local Open Scope R_scope.

(** ** Interpretation of a sequent *)
Fixpoint sem_seq (T1 : sequent) :=
  match T1 with
  | nil => HMR_zero
  | ((r , A) :: T1) => (r *S A) +S (sem_seq T1)
  end.

(** *** Properties of this interpretation *)
Lemma sem_seq_plus : forall T1 T2, sem_seq (T1 ++ T2) === sem_seq T1 +S sem_seq T2.
Proof.
  induction T1; intros T2.
  - rewrite commu_plus; now rewrite neutral_plus.
  - specialize (IHT1 T2).
    destruct a as (r , A).
    simpl; rewrite IHT1.
    now auto with MGA_solver.
Qed.

Lemma sem_seq_mul : forall T r, sem_seq (seq_mul r T) === r *S sem_seq T.
Proof.
  induction T; intros r.
  - now rewrite mul_0.
  - destruct a as [a Ha]; simpl.
    rewrite IHT.
    rewrite <-mul_assoc.
    auto with MGA_solver.
Qed.

Lemma sem_seq_vec : forall r A (Hnnil : r <> nil), sem_seq (vec r A) === (existT _ (sum_vec r) (sum_vec_non_nil _ Hnnil)) *S A.
Proof.
  induction r; intros A Hnnil.
  { exfalso; auto. }
  destruct r as [ | b r].
  - simpl in *.
    replace (existT (fun r : R => (0 <? r) = true) (projT1 a + 0) (sum_vec_non_nil _ Hnnil)) with a by (apply Rpos_eq; simpl; nra).
    auto.
  - assert (b :: r <> nil) as H by now auto.
    specialize (IHr A H).
    change (sem_seq (vec (a :: b :: r) A)) with (a *S A +S (sem_seq (vec (b :: r) A))).
    replace (existT (fun r0 : R => (0 <? r0) = true) (sum_vec (a :: b :: r)) (sum_vec_non_nil _ Hnnil)) with (plus_pos a (existT _ (sum_vec (b :: r)) (sum_vec_non_nil _ H))) by (destruct a; destruct  b; apply Rpos_eq; simpl; nra).
    rewrite IHr.
    auto with MGA_solver.
Qed.

Lemma sem_seq_permutation : forall T1 T2, Permutation_Type T1 T2 -> sem_seq T1 === sem_seq T2.
Proof.
  intros T1 T2 Hperm; induction Hperm; try destruct x; try destruct y; simpl; try auto with MGA_solver.
  - rewrite 2? asso_plus.
    rewrite (commu_plus (r0 *S t0)); reflexivity.
  - transitivity (sem_seq l'); assumption.
Qed.

Lemma sem_seq_diamond : forall T, sem_seq (seq_diamond T) === <S> (sem_seq T).
Proof.
  induction T; try (symmetry; apply diamond_zero).
  destruct a as [r A].
  simpl.
  rewrite diamond_linear.
  rewrite diamond_mul.
  rewrite IHT; reflexivity.
Qed.

Lemma mul_vec_eq : forall A l r, sem_seq (vec (mul_vec r l) A) === r *S sem_seq (vec l A).
Proof.
  intros A.
  induction l; intros r.
  - simpl; rewrite mul_0; auto.
  - simpl.
    rewrite IHl.
    rewrite <-mul_assoc.
    rewrite mul_distri_term.
    reflexivity.
Qed.

(** ** Interpretation of a hypersequent *)
Fixpoint sem_hseq G :=
  match G with
  | nil => HMR_zero (* should not happen *)
  | T1 :: nil => sem_seq T1
  | T1 :: G => (sem_seq T1) \/S (sem_hseq G)
  end.

(** *** Properties of this interpretation *)
Lemma sem_hseq_permutation : forall G1 G2, Permutation_Type G1 G2 -> sem_hseq G1 === sem_hseq G2.
Proof.
  intros G1 G2 Hperm; induction Hperm.
  - reflexivity.
  - destruct l; destruct l'.
    + reflexivity.
    + exfalso; apply (Permutation_Type_nil_cons Hperm).
    + apply Permutation_Type_sym in Hperm.
      exfalso; apply (Permutation_Type_nil_cons Hperm).
    + unfold sem_hseq; fold (sem_hseq (s :: l)); fold (sem_hseq (s0 :: l')).
      rewrite IHHperm; reflexivity.
  - destruct l.
    + simpl; apply commu_max.
    + unfold sem_hseq; fold (sem_hseq (s :: l)); rewrite ?asso_max; rewrite (commu_max (sem_seq y)); reflexivity.
  - transitivity (sem_hseq l'); assumption.
Qed.


Require Import type.

Lemma sum_eq_dec L R
  (L_eq_dec : forall l1 l2 : L, {l1=l2}+{l1<>l2})
  (R_eq_dec : forall r1 r2 : R, {r1=r2}+{r1<>r2}) :
  forall x1 x2 : sum L R, {x1 = x2} + {x1 <> x2}.
Proof. decide equality. Defined.